Require Import CaMain.
Require Import ReoCA.
Require Import Coq.micromega.Lia.
Import ListNotations.

Obligation Tactic := program_simpl; congruence.

(* An unary FIFO as a simple example *)
Inductive automatonStates := q0.
Inductive automatonPorts := A | B.

Program Instance automatonStatesEq : EqDec automatonStates eq :=
	{equiv_dec x y :=
		match x, y with
		| q0,q0 => in_left
		end
	}.

Program Instance automatonPortsEq : EqDec automatonPorts eq :=
	{equiv_dec x y :=
		match x, y with
		| A,A => in_left
		| B,B => in_left
		| A,B => in_right
		| B,A => in_right
		end
	}.

  Definition dataAssignmentA n :=
    match n with
    | 0 =>  1
    | 1 =>  (1)
    | 2 =>  0
    | S n =>  0
    end.

  Definition dataAssignmentB n :=
    match n with
    | 0 =>  1
    | 1 =>  (1)
    | 2 =>  0
    | S n =>  0
    end.

   Definition timeStampAutomatonA(n:nat) : QArith_base.Q :=
    match n with
    | 0 => 1#1
    | 1 => 5#1
    | 2 => 8#1
    | 3 => 11#1
    | 4 => 14#1
    | 5 => 17#1
    | S n =>  Z.of_nat (S n) + 19#1
    end.

  Definition timeStampAutomatonB (n:nat) : QArith_base.Q :=
    match n with
    | 0 => 1#1
    | 1 => 5#1
    | 2 => 8#1
    | 3 => 11#1
    | 4 => 14#1
    | 5 => 17#1
    | S n =>  Z.of_nat (S n) + 19#1
    end.

(*   Lemma aux'' : forall n: nat,
                forall q : QArith_base.Q, Z.of_nat (S n) + (q) = Z.of_nat (S n) + (q).
  Proof. *)

  Lemma timeStampAutomatonAHolds : forall n,
    Qlt (timeStampAutomatonA n) (timeStampAutomatonA (S n)).
  Proof.
  intros. destruct n. unfold timeStampAutomatonA. reflexivity.
  unfold timeStampAutomatonA. case (n). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. unfold Qlt. apply orderZofNat.  Defined.

  Lemma timeStampAutomatonBHolds : forall n,
    Qlt (timeStampAutomatonB n) (timeStampAutomatonB (S n)).
  Proof.
  intros. destruct n. unfold timeStampAutomatonB. reflexivity.
  unfold timeStampAutomatonB. case (n). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. apply orderZofNat. Defined.

  Definition portA := {|
        ConstraintAutomata.id := A;
        ConstraintAutomata.dataAssignment := dataAssignmentA;
        ConstraintAutomata.timeStamp := timeStampAutomatonA;
        ConstraintAutomata.tdsCond := timeStampAutomatonAHolds;
        ConstraintAutomata.index := 0 |}.

  Definition portB := {|
        ConstraintAutomata.id := B;
        ConstraintAutomata.dataAssignment := dataAssignmentB;
        ConstraintAutomata.timeStamp := timeStampAutomatonB;
        ConstraintAutomata.tdsCond := timeStampAutomatonBHolds;
        ConstraintAutomata.index := 0 |}.

  Definition automatonTransition (s:automatonStates):=
    match s with
    | q0 => [([A;B], (ConstraintAutomata.eqDc nat A B), q0)]
    end.

  Definition theta := [portA;portB].

  Definition reoSync := ReoCa.ReoCABinaryChannel A B [q0] [q0] automatonTransition.

  Lemma aux': forall k, ConstraintAutomata.thetaN
       [ConstraintAutomata.calcIndex (k) portA;
       ConstraintAutomata.calcIndex (k) portB] = [A;B].
  Proof.
  induction k.
  - auto.
  - unfold ConstraintAutomata.thetaN. simpl.
    unfold ConstraintAutomata.timeStampEqThetaTime.
    unfold ConstraintAutomata.nextTime. simpl.
    case k. auto.
    intros. case n. auto.
    intros. case n0. auto.
    intros. case n1. auto.
    intros. case n2. auto.
    intros. case n3. auto.
    intros.
    unfold ConstraintAutomata.minimum.
    simpl.
    case_eq (Qle_bool (Z.pos
               (Pos.succ
                  (Pos.succ
                     (Pos.succ (Pos.succ (Pos.succ (Pos.succ (Pos.of_succ_nat n4)))))) +
                19) # 1) (Z.pos
               (Pos.succ
                  (Pos.succ
                     (Pos.succ (Pos.succ (Pos.succ (Pos.succ (Pos.of_succ_nat n4)))))) +
                19) # 1)).
    case_eq ( Qeq_bool
    (Z.pos
       (Pos.succ
          (Pos.succ (Pos.succ (Pos.succ (Pos.succ (Pos.succ (Pos.of_succ_nat n4)))))) +
        19) # 1)
        (Z.pos
         (Pos.succ
            (Pos.succ (Pos.succ (Pos.succ (Pos.succ (Pos.succ (Pos.of_succ_nat n4)))))) +
          19) # 1)).
    intros. simpl. rewrite H. reflexivity.
    intros. rewrite Qeq_eq_bool in H. inversion H.
    congruence.
    intros. unfold Qle_bool in H. simpl in H. unfold Qeq_bool. unfold negb.
    unfold Zeq_bool. simpl.
    Search Q. Search "_ <=? _".
    Admitted.

  Theorem acceptingRun : ConstraintAutomata.accepting' reoSync theta.
  Proof.
  unfold ConstraintAutomata.accepting'.
  intros. destruct q. induction k.
  - unfold ConstraintAutomata.stepAux. simpl. congruence.
  - unfold ConstraintAutomata.stepAux. simpl. rewrite aux'.
    simpl. unfold ConstraintAutomata.eqDataPorts.
    unfold ConstraintAutomata.retrievePortFromInput. simpl.
    destruct k. auto. destruct k. auto. simpl. discriminate.
  Defined.

  Eval compute in ConstraintAutomata.run reoSync [portA;portB] 11.


Require Import Ctl.BinaryRelations.
Require Import Ctl.Paths.
Require Import Ctl.Definition.
Open Scope tprop_scope.

Section Basic.

Variable state : Type.
Variable R: relation state.
Context {T: transition R}.
Variable s: state.

Theorem tentails_ttop :
  R @s ⊨ ⊤.
Proof using. intros; exact I. Qed.

Theorem ntentails_tbot :
  R @s ⊭ ⊥.
Proof using. auto. Qed.

Theorem tentails_tconj : forall P Q,
  R @s ⊨ P ->
  R @s ⊨ Q ->
  R @s ⊨ P ∧ Q.
Proof using.
  intros.
  split; assumption.
Qed.

Theorem rew_tconj : forall P Q,
  R @s ⊨ P ∧ Q =
  (R @s ⊨ P /\ R @s ⊨ Q).
Proof using. reflexivity. Qed.

Theorem tentails_tdisj_l : forall P Q,
  R @s ⊨ P ->
  R @s ⊨ P ∨ Q.
Proof using.
  intros.
  left.
  assumption.
Qed.

Theorem tentails_tdisj_r : forall P Q,
  R @s ⊨ Q ->
  R @s ⊨ P ∨ Q.
Proof using.
  intros.
  right.
  assumption.
Qed.

Theorem rew_tdisj : forall P Q,
  R @s ⊨ P ∨ Q =
  (R @s ⊨ P \/ R @s ⊨ Q).
Proof using. reflexivity. Qed.

Theorem rew_timpl : forall P Q,
  R @s ⊨ P ⟶ Q =
  (R @s ⊨ P -> R @s ⊨ Q).
Proof using. reflexivity. Qed.

Theorem rew_tbiimpl : forall P Q,
  R @s ⊨ P ⟷ Q =
  (R @s ⊨ P <-> R @s ⊨ Q).
Proof using. reflexivity. Qed.

Theorem rew_tnot : forall P,
  R @s ⊨ ¬ P =
  (R @s ⊭ P).
Proof using. reflexivity. Qed.

Theorem rew_tlift : forall P,
  R @s ⊨ ⟨P⟩ =
  P s.
Proof using. reflexivity. Qed.

Theorem rew_AX : forall P,
  R @s ⊨ AX P =
  forall s', R s s' -> R @s' ⊨ P.
Proof using. reflexivity. Qed.

Theorem rew_EX : forall P,
  R @s ⊨ EX P =
  exists s', R s s' /\ R @s' ⊨ P.
Proof using. reflexivity. Qed.

Theorem rew_AG : forall P,
  R @s ⊨ AG P =
  forall (p: path R s) s', in_path s' p -> R @s' ⊨ P.
Proof using. reflexivity. Qed.

Theorem rew_EG : forall P,
  R @s ⊨ EG P =
  exists p: path R s, forall s', in_path s' p -> R @s' ⊨ P.
Proof using. reflexivity. Qed.

Theorem rew_AF : forall P,
  R @s ⊨ AF P =
  forall p: path R s, exists s', in_path s' p /\ R @s' ⊨ P.
Proof using. reflexivity. Qed.

Theorem rew_EF : forall P,
  R @s ⊨ EF P =
  exists (p: path R s) s', in_path s' p /\ R @s' ⊨ P.
Proof using. reflexivity. Qed.

Theorem rew_AU : forall P Q,
  R @s ⊨ A[P U Q] =
  forall p: path R s, exists sQ i,
    in_path_at sQ i p /\
    (forall sP, in_path_before sP i p -> R @sP ⊨ P) /\
    R @sQ ⊨ Q.
Proof using. reflexivity. Qed.

Theorem rew_EU : forall P Q,
  R @s ⊨ E[P U Q] =
  exists (p: path R s) sQ i,
    in_path_at sQ i p /\
    (forall sP, in_path_before sP i p -> R @sP ⊨ P) /\
    R @sQ ⊨ Q.
Proof using. reflexivity. Qed.

Theorem rew_AW : forall P Q,
  R @s ⊨ A[P W Q] =
  forall p: path R s,
    (forall s', in_path s' p -> R @s' ⊨ P ∧ ¬Q) \/
    (exists sQ i,
      in_path_at sQ i p /\
      (forall sP, in_path_before sP i p -> R @sP ⊨ P) /\
      R @sQ ⊨ Q).
Proof using. reflexivity. Qed.

End Basic.
Close Scope tprop_scope.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq ssralg.
From mathcomp Require Import path choice fintype tuple finset bigop poly polydiv.

From CoqEAL Require Import hrel param refinements poly_op.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic.
Import Refinements.Op Poly.Op.

Local Open Scope ring_scope.

Section seqpoly_op.

Local Open Scope computable_scope.

Variable A N : Type.

Definition seqpoly := seq A.

Context `{zero_of A, one_of A}.
Context `{add_of A, opp_of A, mul_of A, eq_of A}.
Context `{zero_of N, one_of N, add_of N, eq_of N}.
Context `{spec_of N nat}.

#[export] Instance cast_seqpoly : cast_of A seqpoly := fun x => [:: x].

#[export] Instance seqpoly0 : zero_of seqpoly := [::].
#[export] Instance seqpoly1 : one_of seqpoly := [:: 1].
#[export] Instance opp_seqpoly : opp_of seqpoly := List.map -%C.

Fixpoint add_seqpoly_fun (p q : seqpoly) : seqpoly := match p,q with
  | [::], q => q
  | p, [::] => p
  | a :: p', b :: q' => a + b :: add_seqpoly_fun p' q'
  end.

#[export] Instance add_seqpoly : add_of seqpoly := add_seqpoly_fun.
#[export] Instance sub_seqpoly : sub_of seqpoly := fun x y => (x + - y)%C.

Lemma sub_seqpoly_0 (s : seqpoly) : s - 0 = s.
Proof. by elim: s. Qed.

#[export] Instance scale_seqpoly : scale_of A seqpoly := fun a => map ( *%C a).

(* 0%C :: aux p = shift 1 (aux p) *)
#[export] Instance mul_seqpoly : mul_of seqpoly := fun p q =>
  let fix aux p :=
      if p is a :: p then (a *: q + (0%C :: aux p))%C else 0
  in aux p.

#[export] Instance exp_seqpoly : exp_of seqpoly N :=
  fun p n => iter (spec n) (mul_seqpoly p) 1.

#[export] Instance size_seqpoly : size_of seqpoly N :=
  let fix aux p :=
      if p is a :: p then
        let sp := aux p in
        if (sp == 0)%C then if (a == 0)%C then 0%C else 1%C
        else (sp + 1)%C
      else 0%C
  in aux.

#[export] Instance eq_seqpoly : eq_of seqpoly :=
  fun p q => all (fun x => x == 0)%C (p - q)%C.

#[export] Instance shift_seqpoly : shift_of seqpoly N :=
  fun n => ncons (spec n) 0%C.

#[export] Instance split_seqpoly : split_of seqpoly N :=
  fun n p => (drop (spec n) p,take (spec n) p).

#[export] Instance lead_coef_seqpoly : lead_coef_of A seqpoly :=
  fun p => nth 0 p (spec (size_seqpoly p)).-1.

End seqpoly_op.

Parametricity cast_seqpoly.
Parametricity seqpoly0.
Parametricity seqpoly1.
Parametricity opp_seqpoly.
Parametricity add_seqpoly.
Parametricity sub_seqpoly.
Parametricity scale_seqpoly.
Parametricity mul_seqpoly.
Definition exp_seqpoly' := Eval compute in exp_seqpoly.
Parametricity exp_seqpoly'.
Realizer exp_seqpoly as exp_seqpoly_R := exp_seqpoly'_R.
Parametricity size_seqpoly.
Parametricity eq_seqpoly.
Parametricity shift_seqpoly.
Parametricity split_seqpoly.
Parametricity lead_coef_seqpoly.

Section seqpoly_more_op.

Variable R : ringType.

Context (C : Type).
Context `{zero_of C, one_of C, add_of C, opp_of C, eq_of C}.
Context `{spec_of C R}.

Fixpoint spec_seqpoly_aux n (s : seqpoly C) : {poly R} :=
  match s with
      | [::] => 0
      | (hd :: tl) =>
        if (hd == 0)%C then spec_seqpoly_aux n.+1 tl
        else
          let c := if (n == 0%N) then if (hd == 1)%C then 1 else (spec hd)%:P
                   else let mon := if (n == 1%N) then 'X else 'X^n in
                        if (hd == 1)%C then mon else (spec hd) *: mon
          in
          if (tl == 0)%C then c
          else (spec_seqpoly_aux n.+1 tl) + c
  end.

#[export] Instance spec_seqpoly : spec_of (seqpoly C) {poly R}:=
  spec_seqpoly_aux 0%N.

Lemma spec_aux_shift n s :
  spec_seqpoly_aux n s = spec_seqpoly_aux 0 s * 'X^n.
Proof.
  elim: s n=> [n|a s ih n] /=; first by rewrite mul0r.
  simpC; case: ifP=> _.
    by rewrite ih [in RHS]ih exprS expr1 mulrA.
  have h : (if n == 0%N then if (a ==1)%C then 1 else (spec a)%:P else
            if (a == 1)%C then if n == 1%N then 'X : {poly R} else 'X^n else
              spec a *: (if n == 1%N then 'X else 'X^n)) =
         (if (a == 1)%C then 1 else (spec a)%:P) * 'X^n.
    case: n=> [|n] /=; simpC.
    rewrite expr0 mulr1.
    by case: ifP=> [/eqP a1|_].
    case: ifP=> [/eqP a1|_].
      rewrite mul1r.
      by case: ifP; move/eqP=> // ->; rewrite expr1.
    rewrite mul_polyC.
    by case: ifP; move/eqP=> // ->; rewrite expr1.
  case: ifP=> _; first by rewrite h.
  rewrite ih [in RHS]ih mulrDl exprS expr1 mulrA.
  exact: congr2.
Qed.

(* Cyril: fix this *)
Lemma spec_aux_eq0 s :
  (s == 0)%C -> spec_seqpoly_aux 0 s = 0.
Proof.
elim: s=> [_|a s ih aseq0] //=.
have heq0 : (a == 0)%C /\ (s == 0)%C.
  move: aseq0; rewrite /(_ == _)%C /eq_seqpoly /= => /andP [a0 s0].
  split => //; rewrite /eq_op /eq_seqpoly sub_seqpoly_0.
  by rewrite s0.
by rewrite (proj1 heq0) spec_aux_shift ih ?(proj2 heq0) // mul0r.
Qed.

End seqpoly_more_op.

Arguments spec_seqpoly / _ _ _ _ _ _ _ _ _ : assert.

(* (* translations for ringType *) *)
(* Parametricity Logic.False. *)
(* Parametricity reflect. *)
(* Parametricity Equality.mixin_of as equality_mixin_of_R. *)
(* Parametricity Logic.ex. *)
(* Parametricity Choice.mixin_of as choice_mixin_of_R. *)
(* Parametricity Choice.class_of as choice_class_of_R. *)
(* Parametricity GRing.Zmodule.mixin_of as gRing_Zmodule_mixin_of_R. *)
(* Parametricity GRing.Zmodule.class_of as gRing_Zmodule_class_of_R. *)
(* Parametricity GRing.Zmodule.type as gRing_Zmodule_type_R. *)
(* Parametricity Equality.type as equality_type_R. *)
(* Parametricity GRing.Ring.mixin_of as gRing_Ring_mixin_of_R. *)
(* Parametricity GRing.Ring.class_of as gRing_Ring_class_of_R. *)
(* Parametricity GRing.Ring.type as gRing_Ring_type_R. *)

(* (* translations for poly *) *)
(* Parametricity phant. *)
(* Parametricity polynomial. *)

Section seqpoly_theory.

Variable R : ringType.

Local Instance zeroR : zero_of R := 0%R.
Local Instance oneR  : one_of R  := 1%R.
Local Instance addR  : add_of R  := +%R.
Local Instance mulR  : mul_of R  := *%R.
Local Instance oppR  : opp_of R  := -%R.
Local Instance eqR   : eq_of R   := eqtype.eq_op.
Local Instance specR : spec_of R R := spec_id.

Local Instance zero_nat : zero_of nat := 0%N.
Local Instance one_nat  : one_of nat  := 1%N.
Local Instance add_nat  : add_of nat  := addn.
Local Instance eq_nat   : eq_of nat   := eqtype.eq_op.
Local Instance spec_nat : spec_of nat nat := spec_id.

Definition seqpoly_of_poly (p : {poly R}) : seqpoly R :=
  polyseq p.

Definition poly_of_seqpoly (sp : seqpoly R) : {poly R} :=
  \poly_(i < size sp) nth 0 sp i.

Definition Rseqpoly : {poly R} -> seqpoly R -> Type := fun_hrel poly_of_seqpoly.

Local Open Scope rel_scope.

(* zero and one *)
Local Instance Rseqpoly_0 : refines Rseqpoly 0%R 0%C.
Proof.
  by rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly poly_def big_ord0.
Qed.

Local Instance Rseqpoly_1 : refines Rseqpoly 1%R 1%C.
Proof.
  rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly poly_def /=.
  by rewrite zmodp.big_ord1 expr0 alg_polyC [(1%:P)]/(1%C) polyC1.
Qed.

Local Instance Rseqpoly_cons :
  refines (eq ==> Rseqpoly ==> Rseqpoly) (@cons_poly R) cons.
Proof.
  rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ x -> _ sp <-.
  rewrite cons_poly_def poly_def big_ord_recl /= expr0 alg_polyC addrC.
  rewrite /bump poly_def big_distrl /=.
  apply: congr2=> //.
  apply: eq_bigr=> i _.
  by rewrite -[in RHS]mul_polyC -mulrA -exprSr mul_polyC.
Qed.

Local Instance Rseqpoly_cast : refines (eq ==> Rseqpoly) polyC cast_op.
Proof.
  rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ x ->.
  rewrite /cast /cast_seqpoly /= poly_def zmodp.big_ord1 /=.
  by rewrite expr0 alg_polyC.
Qed.

Local Instance Rseqpoly_opp : refines (Rseqpoly ==> Rseqpoly) -%R -%C.
Proof.
  rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ sp <-.
  rewrite !poly_def -GRing.sumrN size_map.
  apply: eq_bigr=> i _.
  rewrite -[in RHS]mul_polyC -mulNr -polyCN mul_polyC.
  by rewrite (nth_map 0%C).
Qed.

Lemma coef_poly_of_seqpoly (sp : seqpoly R) (i : nat) :
  (\poly_(j < size sp) sp`_j)`_i = sp`_i.
Proof.
  rewrite coef_poly.
  have [iltp|pleqi] := ltnP i (size sp)=> //.
  by rewrite nth_default.
Qed.

Lemma coef_add_seqpoly (sp sq : seqpoly R) (i : nat) :
  (sp + sq)%C`_i = sp`_i + sq`_i.
Proof.
  elim: sp sq i=> [sq i|a p ihp [|b q] [|i]] //=.
        by rewrite [(_ + _)%C]/add_seqpoly /add_seqpoly_fun nth_nil add0r.
      by rewrite addr0.
    by rewrite addr0.
  by rewrite ihp.
Qed.

Local Instance Rseqpoly_add :
  refines (Rseqpoly ==> Rseqpoly ==> Rseqpoly) +%R +%C.
Proof.
  rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ sp <- _ sq <-.
  apply/polyP=> i.
  by rewrite coef_add_poly !coef_poly_of_seqpoly coef_add_seqpoly.
Qed.

Lemma coef_opp_seqpoly (sp : seqpoly R) (i : nat) : (- sp)%C`_i = - sp`_i.
Proof.
  have [iltp|pleqi] := ltnP i (size sp).
    by rewrite (nth_map 0%C).
  by rewrite !nth_default ?oppr0 ?size_map.
Qed.

Local Instance Rseqpoly_sub :
  refines (Rseqpoly ==> Rseqpoly ==> Rseqpoly) (fun x y => x - y) sub_op.
Proof.
  rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ sp <- _ sq <-.
  apply/polyP=> i.
  rewrite coef_add_poly coef_opp_poly !coef_poly_of_seqpoly coef_add_seqpoly.
  by rewrite coef_opp_seqpoly.
Qed.

(* scaling *)

Lemma coef_scale_seqpoly (sp : seqpoly R) (a : R) (i : nat) :
  (a *: sp)%C`_i = a * sp`_i.
Proof.
  have [iltp|pleqi] := ltnP i (size sp).
    by rewrite (nth_map 0%C).
  by rewrite !nth_default ?mulr0 ?size_map.
Qed.

Local Instance Rseqpoly_scale :
  refines (eq ==> Rseqpoly ==> Rseqpoly) *:%R *:%C.
Proof.
  rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ x -> _ sp <-.
  apply/polyP=> i.
  by rewrite coefZ !coef_poly_of_seqpoly coef_scale_seqpoly.
Qed.

(* multiplication *)
Local Instance Rseqpoly_mul :
  refines (Rseqpoly ==> Rseqpoly ==> Rseqpoly) *%R *%C.
Proof.
  rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ sp <- _ sq <-.
  apply/polyP=> i.
  rewrite coef_poly_of_seqpoly.
  elim: sp i=> [i|a p ihp i].
    by rewrite [(_ * _)%C]/mul_seqpoly poly_def big_ord0 mul0r coef0 nth_nil.
  rewrite [(_ * _)%C]/mul_seqpoly coef_add_seqpoly coefM big_ord_recl.
  rewrite !coef_poly_of_seqpoly subn0.
  apply: congr2; first by rewrite coef_scale_seqpoly.
  move: ihp; case: i=> [_|i ihp]; first by rewrite big_ord0.
  rewrite [(_ :: _)`_ _]/= ihp coefM=> {ihp}.
  apply: eq_bigr=> j _.
  by rewrite !coef_poly_of_seqpoly.
Qed.

Local Instance Rseqpoly_exp :
  refines (Rseqpoly ==> Logic.eq ==> Rseqpoly) (@GRing.exp _) exp_op.
Proof.
  apply refines_abstr2=> p sp hp m n; rewrite refinesE=> -> {m}.
  rewrite /exp_op /exp_seqpoly.
  elim: n=> [|n ihn] /=;
    by rewrite ?(expr0, exprS); tc.
Qed.

Lemma poly_cons (p : seqpoly R) (a : R) :
  \poly_(i < size (a :: p)) (a :: p)`_i = a%:P + (\poly_(i < size p) p`_i) * 'X.
Proof.
  rewrite !poly_def big_ord_recl big_distrl /= expr0 alg_polyC /bump /=.
  apply: congr2=> //; apply: eq_bigr=> i _.
  by rewrite add1n exprSr scalerAl.
Qed.

Local Instance Rseqpoly_size :
  refines (Rseqpoly ==> eq) (sizep (R:=R)) (size_op (N:=nat)).
Proof.
  rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ sp <-.
  rewrite sizepE /size_op.
  elim: sp=> [|a p ihp].
    by rewrite poly_def big_ord0 size_poly0.
  rewrite poly_cons /= -ihp.
  case sp: (size (\poly_(i < size p) p`_i))=> [|n] /=; simpC.
    move /eqP: sp; rewrite size_poly_eq0; move/eqP=> ->.
    by rewrite mul0r addr0 size_polyC; case: (a == 0).
  rewrite addrC size_addl size_mulX ?sp ?size_polyC ?addn1; case: (a != 0)=> //;
  by apply/negP; rewrite -size_poly_eq0 sp.
Qed.

Local Instance Rseqpoly_eq :
  refines (Rseqpoly ==> Rseqpoly ==> bool_R) eqtype.eq_op eq_op.
Proof.
  rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ sp <- _ sq <-.
  have -> : (\poly_(i < size sp) sp`_i == \poly_(i < size sq) sq`_i)
            = (sp == sq)%C.
    apply/eqP/allP=> [/polyP heq|heq].
      move=> x /(nthP 0%C) [i] hi <-.
      rewrite coef_add_seqpoly coef_opp_seqpoly; simpC.
      by have := (heq i); rewrite !coef_poly_of_seqpoly subr_eq0=> ->.
    apply/polyP=> i; rewrite !coef_poly_of_seqpoly; apply/eqP.
    have [hlt|] := ltnP i (size (sp - sq)%C).
      rewrite -subr_eq0 -coef_opp_seqpoly -coef_add_seqpoly [_ == _]heq //.
      by rewrite mem_nth.
    have -> : size (sp - sq)%C = maxn (size sp) (size sq)=> [{heq}|hleq].
      elim: sp sq=> [sq|a p ihp [|b q]] /=.
          by rewrite max0n [(_ - _)%C]/add_seqpoly /add_seqpoly_fun size_map.
        by rewrite maxn0.
      by rewrite ihp maxnSS.
    by rewrite !nth_default // (leq_trans _ hleq) // leq_max leqnn ?orbT.
  exact: bool_Rxx.
Qed.

(* These can be done with eq instead of nat_R *)
Local Instance Rseqpoly_shift :
  refines (eq ==> Rseqpoly ==> Rseqpoly) (shiftp (R:=R)) (shift_op (N:=nat)).
Proof.
  rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ n -> _ sp <-.
  apply/polyP=> i.
  rewrite /shiftp coefMXn !coef_poly_of_seqpoly /shift_op /shift_seqpoly.
  by rewrite nth_ncons.
Qed.

Local Instance Rseqpoly_split :
  refines (eq ==> Rseqpoly ==> prod_R Rseqpoly Rseqpoly)
          (splitp (R:=R)) (split_op (N:=nat)).
Proof.
  rewrite refinesE /Rseqpoly /fun_hrel /poly_of_seqpoly=> _ n -> _ sp <-.
  rewrite /split_op /split_seqpoly /splitp /=.
  apply: prod_RI; rewrite /prod_hrel /=.
  elim: sp n=> [n|a p ihp [|n]].
      by rewrite poly_def big_ord0 rdiv0p rmod0p.
    by rewrite expr0 rdivp1 rmodp1 [\poly_(_ < 0) _]poly_def big_ord0.
  rewrite !poly_cons [\poly_(i < size p) p`_i](@rdivp_eq _ 'X^n) ?monicXn //.
  have [/= -> ->] := ihp n.
  rewrite mulrDl -mulrA -exprSr addrC -addrA.
  suff htnp :
    size (rmodp (\poly_(i < size p) p`_i) 'X^n * 'X + a%:P) <
    size ('X^n.+1 : {poly R}).
    by rewrite rdivp_addl_mul_small ?rmodp_addl_mul_small ?monicXn // addrC.
  rewrite size_polyXn size_MXaddC ltnS; case: ifP=> // _.
  by rewrite (leq_trans (ltn_rmodpN0 _ _)) ?monic_neq0 ?monicXn ?size_polyXn.
Qed.

Local Instance Rseqpoly_lead_coef :
  refines (Rseqpoly ==> eq) lead_coef (lead_coef_seqpoly (N:=nat)).
Proof.
  rewrite refinesE /lead_coef_seqpoly /lead_coef=> p sp hp.
  rewrite -sizepE [sizep _]refines_eq /size_op -hp /poly_of_seqpoly.
  by rewrite coef_poly_of_seqpoly.
Qed.

Local Instance Rseqpoly_head :
  refines (Rseqpoly ==> Logic.eq) (fun p => p`_0) (fun sp => nth 0%C sp 0).
Proof.
  rewrite refinesE=> _ sp <-.
  rewrite /poly_of_seqpoly coef_poly_of_seqpoly.
  by case: sp.
Qed.

Local Instance Rseqpoly_spec_l : refines (Rseqpoly ==> Logic.eq) spec_id spec.
Proof.
  rewrite refinesE=> _ sp <-.
  rewrite /spec_id /spec /spec_seqpoly /poly_of_seqpoly.
  elim: sp=> [|a p ih] /=.
    by rewrite poly_def big_ord0.
  rewrite spec_aux_shift expr1 poly_cons ih.
  simpC.
  case: ifP=> [/eqP a0|_]; first by rewrite a0 polyC0 add0r.
  rewrite /spec /specR /spec_id addrC.
  by case: ifP=> p0;
    case: ifP=> [/eqP a1|_];
    rewrite ?a1 ?polyC1 // spec_aux_eq0 // ?mul0r ?add0r.
Qed.

Section seqpoly_param.

Context (C : Type) (rAC : R -> C -> Type).
Context (N : Type) (rN : nat -> N -> Type).
Context `{zero_of C, one_of C}.
Context `{opp_of C, add_of C, mul_of C, eq_of C}.
Context `{implem_of R C, spec_of C R}.
Context `{zero_of N, one_of N, add_of N, eq_of N}.
Context `{spec_of N nat}.
Context `{!refines rAC 0%R 0%C, !refines rAC 1%R 1%C}.
Context `{!refines (rAC ==> rAC) -%R -%C}.
Context `{!refines (rAC ==> rAC ==> rAC) +%R +%C}.
Context `{!refines (rAC ==> rAC ==> rAC) *%R *%C}.
Context `{!refines (rAC ==> rAC ==> bool_R) eqtype.eq_op eq_op}.
Context `{!refines (rAC ==> Logic.eq) spec_id spec}.
Context `{!refines rN 0%N 0%C, !refines rN 1%N 1%C}.
Context `{!refines (rN ==> rN ==> rN) addn +%C}.
Context `{!refines (rN ==> rN ==> bool_R) eqtype.eq_op eq_op}.
Context `{!refines (rN ==> nat_R) spec_id spec}.

Definition RseqpolyC : {poly R} -> seq C -> Type :=
  (Rseqpoly \o (list_R rAC)).

#[export] Instance RseqpolyC_cons :
  refines (rAC ==> RseqpolyC ==> RseqpolyC) (@cons_poly R) cons.
Proof. param_comp list_R_cons_R. Qed.

#[export] Instance RseqpolyC_cast :
  refines (rAC ==> RseqpolyC) polyC cast_op.
Proof. param_comp cast_seqpoly_R. Qed.

#[export] Instance RseqpolyC_0 : refines RseqpolyC 0%R 0%C.
Proof. param_comp seqpoly0_R. Qed.

#[export] Instance RseqpolyC_1 : refines RseqpolyC 1%R 1%C.
Proof. param_comp seqpoly1_R. Qed.

#[export] Instance RseqpolyCN : refines (RseqpolyC ==> RseqpolyC) -%R -%C.
Proof. param_comp opp_seqpoly_R. Qed.

#[export] Instance RseqpolyCD :
  refines (RseqpolyC ==> RseqpolyC ==> RseqpolyC) +%R +%C.
Proof. param_comp add_seqpoly_R. Qed.

#[export] Instance RseqpolyC_sub :
  refines (RseqpolyC ==> RseqpolyC ==> RseqpolyC) (fun x y => x - y) sub_op.
Proof. param_comp sub_seqpoly_R. Qed.

#[export] Instance RseqpolyC_scale :
  refines (rAC ==> RseqpolyC ==> RseqpolyC) *:%R *:%C.
Proof. param_comp scale_seqpoly_R. Qed.

#[export] Instance RseqpolyCM :
  refines (RseqpolyC ==> RseqpolyC ==> RseqpolyC) *%R *%C.
Proof. param_comp mul_seqpoly_R. Qed.

#[export] Instance RseqpolyC_exp :
  refines (RseqpolyC ==> rN ==> RseqpolyC) (@GRing.exp _) exp_op.
Proof.
  eapply refines_trans; tc.
  rewrite refinesE; do ?move=> ?*.
  eapply (exp_seqpoly_R (N_R:=rN))=> // *;
    exact: refinesP.
Qed.

#[export] Instance RseqpolyC_size :
  refines (RseqpolyC ==> rN) (sizep (R:=R)) size_op.
Proof. rewrite /size_op; param_comp size_seqpoly_R. Qed.

#[export] Instance RseqpolyC_eq :
  refines (RseqpolyC ==> RseqpolyC ==> bool_R) eqtype.eq_op eq_op.
Proof. param_comp eq_seqpoly_R. Qed.

#[export] Instance RseqpolyC_shift :
  refines (rN ==> RseqpolyC ==> RseqpolyC) (shiftp (R:=R)) shift_op.
Proof.
  (* param_comp shift_seqpoly_R does a mistake on the instantiation of a
  relation, why? *)
  eapply refines_trans; tc.
  rewrite refinesE; do ?move=> ?*.
  eapply (shift_seqpoly_R (N_R:=rN))=> // *;
    exact: refinesP.
Qed.

#[export] Instance RseqpolyCMXn p sp n rn :
  refines rN n rn -> refines RseqpolyC p sp ->
  refines RseqpolyC (p * 'X^n) (shift_op rn sp).
Proof.
  move=> hn hp; rewrite -[_ * 'X^_]/(shiftp _ _).
  apply: refines_apply.
Qed.

Lemma mulXnC (p : {poly R}) n : p * 'X^n = 'X^n * p.
Proof.
  apply/polyP=> i.
  by rewrite coefMXn coefXnM.
Qed.

#[export] Instance RseqpolyC_Xnmul p sp n rn :
  refines rN n rn -> refines RseqpolyC p sp ->
  refines RseqpolyC ('X^n * p) (shift_op rn sp).
Proof. rewrite -mulXnC; exact: RseqpolyCMXn. Qed.

#[export] Instance RseqpolyC_scaleXn c rc n rn :
  refines rN n rn -> refines rAC c rc ->
  refines RseqpolyC (c *: 'X^n) (shift_op rn (cast rc)).
Proof.
  move=> hn hc; rewrite -mul_polyC -[_ * 'X^_]/(shiftp _ _).
  apply: refines_apply.
Qed.

#[export] Instance RseqpolyCMX p sp :
  refines RseqpolyC p sp -> refines RseqpolyC (p * 'X) (shift_op (1%C : N) sp).
Proof. rewrite -['X]expr1; exact: RseqpolyCMXn. Qed.

#[export] Instance RseqpolyC_Xmul p sp :
  refines RseqpolyC p sp -> refines RseqpolyC ('X * p) (shift_op (1%C : N) sp).
Proof. rewrite -['X]expr1 -mulXnC; exact: RseqpolyCMX. Qed.

#[export] Instance RseqpolyC_scaleX c rc :
  refines rAC c rc ->
  refines RseqpolyC (c *: 'X) (shift_op (1%C : N) (cast rc)).
Proof. rewrite -['X]expr1; exact: RseqpolyC_scaleXn. Qed.

(* Uses composable_prod *)
#[export] Instance RseqpolyC_split :
  refines (rN ==> RseqpolyC ==> prod_R RseqpolyC RseqpolyC)
    (splitp (R:=R)) split_op.
Proof.
  eapply refines_trans; tc.
  rewrite refinesE; do ?move=> ?*.
  eapply (split_seqpoly_R (N_R:=rN))=> // *.
  exact: refinesP.
Qed.

#[export] Instance RseqpolyC_splitn n rn p sp :
  refines rN n rn -> refines RseqpolyC p sp ->
  refines (prod_R RseqpolyC RseqpolyC) (splitp n p) (split_op rn sp).
Proof. by move=> hn hp; apply: refines_apply. Qed.

Definition eq_prod_seqpoly (x y : (seqpoly C * seqpoly C)) :=
  (eq_op x.1 y.1) && (eq_op x.2 y.2).

#[export] Instance refines_prod_RseqpolyC_eq :
  refines (prod_R RseqpolyC RseqpolyC ==> prod_R RseqpolyC RseqpolyC ==> bool_R)
          eqtype.eq_op eq_prod_seqpoly.
Proof.
  rewrite refinesE=> x x' hx y y' hy.
  rewrite /eqtype.eq_op /eq_prod_seqpoly /=.
  have -> : (x.1 == y.1) = (x'.1 == y'.1)%C.
    apply: refines_eq.
  have -> : (x.2 == y.2) = (x'.2 == y'.2)%C.
    apply: refines_eq.
  exact: bool_Rxx.
Qed.

#[export] Instance RseqpolyC_lead_coef :
  refines (RseqpolyC ==> rAC) lead_coef (lead_coef_seqpoly (N:=N)).
Proof.
param_comp lead_coef_seqpoly_R.
Qed.

Local Instance refines_refl_nat : forall m, refines nat_R m m | 999.
Proof. by rewrite refinesE; apply: nat_Rxx. Qed.

#[export] Instance RseqpolyC_head :
  refines (RseqpolyC ==> rAC) (fun p => p`_0) (fun sp => nth 0%C sp 0).
Proof.
  eapply refines_trans; tc.
  rewrite refinesE=> l l' rl.
  apply nth_R; exact: refinesP.
Qed.

#[export] Instance RseqpolyC_X : refines RseqpolyC 'X (shift_op (1%C : N) 1)%C.
Proof. rewrite -['X]mul1r; exact: RseqpolyCMX. Qed.

#[export] Instance RseqpolyC_Xn n rn :
  refines rN n rn -> refines RseqpolyC 'X^n (shift_op rn 1)%C.
Proof. move=> hn; rewrite -['X^_]mul1r; exact: RseqpolyCMXn. Qed.

(* Lemma gRing_Ring_type_Rxx r : gRing_Ring_type_R r r. *)
(* Proof. *)
(* Admitted. *)

(* #[export] Instance RseqpolyC_spec_l : *)
(*   refines (RseqpolyC ==> (@polynomial_R _ _ (gRing_Ring_type_Rxx R))) *)
(*           spec_id spec. *)
(* Proof. *)
(* Admitted. *)

#[export] Instance RseqpolyC_spec : refines (RseqpolyC ==> eq) spec_id spec.
Proof.
  eapply refines_trans; tc.
  rewrite refinesE=> l l' rl.
  elim: rl=> [|x y rx p q rp] {l l'};
    rewrite /spec /spec_seqpoly //=.
  rewrite ![spec_seqpoly_aux 1 _]spec_aux_shift=> ->.
  have -> : (p == 0)%C = (q == 0)%C.
    elim: rp=> [|a b ra l l' rl] {p q} //=.
    rewrite /eq_op /eq_seqpoly /=.
    by simpC; rewrite [(_ == _)]refines_eq !sub_seqpoly_0=> ->.
  rewrite /spec /specR [spec_id _]refines_eq /spec [(_ == _)%C]refines_eq.
  by rewrite [(_ == 1)%C]refines_eq.
Qed.

End seqpoly_param.

End seqpoly_theory.

(* Always simpl Poly. Maybe have refinement instance instead? Is this *)
(* more efficient? *)
#[export] Hint Extern 0 (refines _ (Poly _) _) => simpl : typeclass_instances.
#[export] Hint Extern 0 (refines _ _ (Poly _)) => simpl : typeclass_instances.

From mathcomp Require Import ssrint.
From CoqEAL Require Import binnat binint.

Section testpoly.

Goal (0 == 0 :> {poly int}).
by coqeal.
Abort.

Goal (0 == (0 : {poly {poly {poly int}}})).
by coqeal.
Abort.

Goal (1 == 1 :> {poly int}).
by coqeal.
Abort.

Goal (1 == (1 : {poly {poly {poly int}}})).
by coqeal.
Abort.

Goal ((1 + 2%:Z *: 'X + 3%:Z *: 'X^2) + (1 + 2%:Z%:P * 'X + 3%:Z%:P * 'X^2)
      == (1 + 1 + (2%:Z + 2%:Z) *: 'X + (3%:Z + 3%:Z)%:P * 'X^2)).
rewrite -[X in (X == _)]/(spec_id _) [spec_id _]refines_eq /=.
(* by coqeal. *)
Abort.

Goal (Poly [:: 1; 2%:Z; 3%:Z] + Poly [:: 1; 2%:Z; 3%:Z]) ==
      Poly [:: 1 + 1; 2%:Z + 2%:Z; 2%:Z + 4%:Z].
by coqeal.
Abort.

Goal (- 1 == - (1: {poly {poly int}})).
by coqeal.
Abort.

Goal (- (1 + 2%:Z *: 'X + 3%:Z%:P * 'X^2) == -1 - 2%:Z%:P * 'X - 3%:Z *: 'X^2).
by coqeal.
Abort.

Goal (- Poly [:: 1; 2%:Z; 3%:Z]) == Poly [:: - 1; - 2%:Z; - 3%:Z].
by coqeal.
Abort.

Goal (1 + 2%:Z *: 'X + 3%:Z *: 'X^2 - (1 + 2%:Z *: 'X + 3%:Z *: 'X^2) == 0).
by coqeal.
Abort.

Goal (Poly [:: 1; 2%:Z; 3%:Z] - Poly [:: 1; 2%:Z; 3%:Z]) == 0.
by coqeal.
Abort.

Goal ((1 + 2%:Z *: 'X) * (1 + 2%:Z%:P * 'X) == 1 + 4%:Z *: 'X + 4%:Z *: 'X^2).
by coqeal.
Abort.

Goal (Poly [:: 1; 2%:Z] * Poly [:: 1; 2%:Z]) == Poly [:: 1; 4%:Z; 4%:Z].
by coqeal.
Abort.

(* (1 + xy) * x = x + x^2y *)
Goal ((1 + 'X * 'X%:P) * 'X == 'X + 'X^2 * 'X%:P :> {poly {poly int}}).
rewrite -[X in (X == _)]/(spec_id _) [spec_id _]refines_eq /=.
(* by coqeal. *)
Abort.

Goal (Poly [:: Poly [:: 1; 0]; 1] * Poly [:: 1; 0]) ==
      Poly [:: Poly [:: 1; 0]; 1 ; 0] :> {poly {poly int}}.
rewrite -[X in (X == _)]/(spec_id _) [spec_id _]refines_eq /=.
by coqeal.
Abort.

Goal (sizep ('X^2 : {poly int}) ==
      sizep (- 3%:Z *: 'X^(sizep ('X : {poly int})))).
by coqeal.
Abort.

Goal (sizep (1 + 2%:Z *: 'X + 3%:Z *: 'X^2) == 3%N).
by coqeal.
Abort.

Goal (sizep (Poly [:: 1; 2%:Z; 3%:Z]) == 3%nat).
by coqeal.
Abort.

Goal ((1 + 2%:Z *: 'X) * (1 + 2%:Z%:P * 'X^(sizep (1 : {poly int}))) ==
      1 + 4%:Z *: 'X + 4%:Z *: 'X^(sizep (10%:Z *: 'X))).
by coqeal.
Abort.

Goal (splitp 2 (1 + 2%:Z *: 'X + 3%:Z%:P * 'X^2 + 4%:Z *: 'X^3) ==
      (3%:Z%:P + 4%:Z *: 'X, 1 + 2%:Z%:P * 'X)).
by coqeal.
Abort.

Goal (splitp (sizep ('X : {poly int}))
             (1 + 2%:Z *: 'X + 3%:Z%:P * 'X^2 + 4%:Z *: 'X^3) ==
      (3%:Z%:P + 4%:Z *: 'X, 1 + 2%:Z%:P * 'X)).
by coqeal.
Abort.

Goal (splitp 2%nat (Poly [:: 1; 2%:Z; 3%:Z; 4%:Z]) ==
     (Poly [:: 3%:Z; 4%:Z], Poly [:: 1; 2%:Z])).
rewrite /= [_ == _]refines_eq.
by compute.
Abort.

(* Test shiftp *)
Goal (2%:Z *: shiftp 2%nat 1 == Poly [:: 0; 0; 2%:Z]).
by coqeal.
Abort.

End testpoly.


(**
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 Fcore_Zaux.
Require Import ZArith.Zquot.

(** Computes the 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.
replace (digits2_Pnat n~1) with (S (digits2_Pnat n)); try reflexivity.

rewrite Zpos_xI, 2!Hp.
omega.
replace (digits2_Pnat n~0) with (S (digits2_Pnat n)); try reflexivity.
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_eq 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_eq.
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.

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.

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.
Hypothesis Hp : (0 <= 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_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.
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.

End Fcore_digits.


From iris.program_logic Require Export weakestpre total_weakestpre.
From iris.heap_lang Require Export lang.
From iris.proofmode Require Export tactics.
From iris.heap_lang Require Import proofmode notation.
Set Default Proof Using "Type".

Section Concrete.
  Context `{heapG Σ}.

  Definition incrementer (l : expr) : expr := l <- !l + #1.

  Lemma simple_assign l (n : Z):
    [[{ l ↦ #n }]]
      incrementer #l
      [[{ RET #(); l ↦ #(n + 1) }]].
  Proof.
    iIntros (Φ) "Hloc HΦ".
    rewrite /incrementer.
    wp_load.
    wp_store.
    by iApply "HΦ".
  Qed.

  Check simple_assign.

  (* Questions/remarks: *)

  (* The Σ here in the type of simple_assign is determined by Coq, presumably by looking for a type that matches the typeclass constraint heapG? *)

  (* Compared to the lecture notes, there seems to be no need to invoke a "wp_bind" rule for getting to the right part of an evaluation context. We can just use wp_load and wp_store right away. *)

  (* Unset Printing Notations. *)

  Lemma simple_assign2 l (n : Z):
    [[{ l ↦ #n }]]
      (incrementer #l);; (incrementer #l)
      [[{ RET #(); l ↦ #(n + 2) }]].
  Proof.
    iIntros (Φ) "Hloc HΦ".
    (* wp_seq. *)
    wp_apply (simple_assign with "Hloc").
    iIntros "Hloc".
    wp_seq.
    wp_apply (simple_assign with "Hloc").
    iIntros "Hloc".
    iApply "HΦ".
    replace (n + 1 + 1) with (n + 2).
    - done.
    - omega.
  Qed.

  (* loop n = if n = 0 then 0 else loop (n - 1) + 1

  This is simply the identity function for non-negative integers,
  implemented in a roundabout fashion. *)
  Definition simple_loop : val :=
    rec: "loop" "n" :=
      if: "n" = #0
      then #0
      else "loop" ("n" - #1%nat) + #1.

  (* The error message you get when you forget the heapG Σ is somewhat
  cryptic. I just put it in the Context now so I cannot forget
  anymore. *)

  (* If I make simple_loop an expr then wp_rec (understandably) fails
  to work with a cryptic error message. Presumably I have to "reduce"
  the left-hand side of the application to a value first. *)

  Lemma spec_simple_loop (n : nat):
    WP simple_loop #n {{ v, ⌜v = #n⌝}}%I.
  Proof.
    iInduction n as [|n'] "IH"; rewrite /simple_loop; wp_rec.
    - wp_op. wp_if_true. done.
    - wp_op. wp_if_false. wp_op.
  Admitted.

End Concrete.


From Hammer Require Import Hammer.

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

Lemma Rlt_R0_R2 : 0 < 2.
Proof. hammer_hook "DiscrR" "DiscrR.Rlt_R0_R2".
change 2 with (INR 2); apply lt_INR_0; apply lt_O_Sn.
Qed.

Notation Rplus_lt_pos := Rplus_lt_0_compat (only parsing).

Lemma IZR_eq : forall z1 z2:Z, z1 = z2 -> IZR z1 = IZR z2.
Proof. hammer_hook "DiscrR" "DiscrR.IZR_eq".
intros; rewrite H; reflexivity.
Qed.

Ltac discrR :=
try
match goal with
|  |- (?X1 <> ?X2) =>
repeat
rewrite <- plus_IZR ||
rewrite <- mult_IZR ||
rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus;
apply IZR_neq; try discriminate
end.

Ltac prove_sup0 :=
match goal with
|  |- (0 < 1) => apply Rlt_0_1
|  |- (0 < ?X1) =>
repeat
(apply Rmult_lt_0_compat || apply Rplus_lt_pos;
try apply Rlt_0_1 || apply Rlt_R0_R2)
|  |- (?X1 > 0) => change (0 < X1); prove_sup0
end.

Ltac omega_sup :=
repeat
rewrite <- plus_IZR ||
rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus;
apply IZR_lt; omega.

Ltac prove_sup :=
match goal with
|  |- (?X1 > ?X2) => change (X2 < X1); prove_sup
|  |- (0 < ?X1) => prove_sup0
|  |- (- ?X1 < 0) => rewrite <- Ropp_0; prove_sup
|  |- (- ?X1 < - ?X2) => apply Ropp_lt_gt_contravar; prove_sup
|  |- (- ?X1 < ?X2) => apply Rlt_trans with 0; prove_sup
|  |- (?X1 < ?X2) => omega_sup
| _ => idtac
end.

Ltac Rcompute :=
repeat
rewrite <- plus_IZR ||
rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus;
apply IZR_eq; try reflexivity.


(************************************************************************)
(* Copyright 2006 Milad Niqui                                           *)
(* This file is distributed under the terms of the                      *)
(* GNU Lesser General Public License Version 2.1                        *)
(* A copy of the license can be found at                                *)
(*                  <http://www.gnu.org/licenses>                       *)
(************************************************************************)

Require Export QArith_Stern_Brocot.   (* Rational Numbers of QArithSternBrocot package *)
Require Export Streams.   (* Streams from the standard library *)
Require Import Streams_addenda.
Require Import Raxioms.

(** The definition of the digits and the basic operations on matrices
and tensors. *)

Unset Printing Notations.

Open Scope type_scope.

Definition Vector := Q*Q.

Definition Matrix := Vector*Vector.

Definition Tensor := Matrix*Matrix.

Set Printing Notations.

Definition EStream:Set := (Stream Matrix).

Inductive Digit : Set := LL : Digit | RR: Digit | MM: Digit.

(* Bisimulation equality is defined in the stanadard library
Coq.Lists.Streams.EqSt. We need that equlaity to prove the cofixed
point equations later on. *)

Definition bisim := @EqSt Digit.

Open Scope Z_scope.
Open Scope Q_scope.

(** ##Digits## as Moebius maps *)
Definition map_digits (d: Digit) : Matrix :=
  match d with
  | LL =>  (1/2, (-1)/2, (1/2,3/2))
  | RR =>  (1/2, 1/2, ((-1)/2,3/2))
  | MM =>  (1/1, 0/1, (0/1, 3/1))
  end.

Coercion map_digits : Digit >-> Matrix.

(** Inverses of the digits *)
Definition inv_LL := ((3/2,1/2),((-1)/2,1/2)).
Definition inv_RR := ((3/2,(-1)/2),(1/2,1/2)).
Definition inv_MM := ((1/1,0/1),(0/1,1/3)).

Definition inv_digit (D : Digit) : Matrix :=
  match D with
  | LL => inv_LL
  | RR => inv_RR
  | MM => inv_MM
  end.

(** ##Product## of two matrices *)

Definition product (M N:Matrix):Matrix :=
  let (a1,b1) := (fst (fst M), snd (fst M)) in
    let (c1,d1) := (fst (snd M), snd (snd M)) in
      let (a2,b2) := (fst (fst N), snd (fst N)) in
	let (c2,d2) := (fst (snd N), snd (snd N)) in
	  ((a1 * a2 + b1 * c2, a1 * b2 + b1 * d2),
            (c1 * a2 + d1 * c2, c1 * b2 + d1 * d2)).

(** ##Product## of a matrix and a tensor *)

Definition m_product (M:Matrix) (T:Tensor) : Tensor :=
  let (A,B) := (fst (fst M), snd (fst M)) in
   let (C,D) := (fst (snd M), snd (snd M)) in
    let (a,b) := (fst (fst (fst T)), snd (fst (fst T))) in
     let (c,d) := (fst (snd (fst T)), snd (snd (fst T))) in
      let (e,f) := (fst (fst (snd T)), snd (fst (snd T))) in
       let (g,h) := (fst (snd (snd T)), snd (snd (snd T))) in
          (((A*a + B*e),(A*b + B*f), ((A*c + B*g), (A*d + B*h))),
           ((C*a + D*e),(C*b + D*f), ((C*c + D*g), (C*d + D*h)))).

(** ##Left product## of a tensor and a matrix *)

Definition left_product (T:Tensor) (M:Matrix) : Tensor :=
  let (a,b) := (fst (fst (fst T)), snd (fst (fst T))) in
   let (c,d) := (fst (snd (fst T)), snd (snd (fst T))) in
    let (e,f) := (fst (fst (snd T)), snd (fst (snd T))) in
     let (g,h) := (fst (snd (snd T)), snd (snd (snd T))) in
      let (A,B) := (fst (fst M), snd (fst M)) in
	let (C,D) := (fst (snd M), snd (snd M)) in
          (((a*A + c*C),(b*A + d*C), ((a*B + c*D), (b*B + d*D))),
           ((e*A + g*C),(f*A + h*C), ((e*B + g*D), (f*B + h*D)))).

(** ##Right product## of a tensor and a matrix *)

Definition right_product (T:Tensor) (M:Matrix) : Tensor :=
  let (a,b) := (fst (fst (fst T)), snd (fst (fst T))) in
   let (c,d) := (fst (snd (fst T)), snd (snd (fst T))) in
    let (e,f) := (fst (fst (snd T)), snd (fst (snd T))) in
     let (g,h) := (fst (snd (snd T)), snd (snd (snd T))) in
      let (A,B) := (fst (fst M), snd (fst M)) in
	let (C,D) := (fst (snd M), snd (snd M)) in
          (((a*A + b*C),(a*B + b*D), ((c*A + d*C), (c*B + d*D))),
           ((e*A + f*C),(e*B + f*D), ((g*A + h*C), (g*B + h*D)))).

(** This is the set
#Digit∞#$\texttt{Digit}^\infty$ (streams
of the elements of Digits). *)

Definition Reals := (Stream Digit).

Definition map_reals  : Reals ->  EStream  := Streams.map map_digits.

Coercion map_reals :Reals >-> EStream.

(** ##Bounded## Moebius map on #[#-1,+1#]#. *)

Definition Bounded_M (M:Matrix):=
  let (a,b) := (fst (fst M), snd (fst M)) in
    let (c,d) := (fst (snd M), snd (snd M)) in
      (Qlt Zero (d+c) /\ Qlt Zero (d-c)) \/  (* 0<cx+d *)
      (Qlt (d+c) Zero /\ Qlt (d-c) Zero).   (* cx+d<0 *)

Lemma Bounded_M_dec: forall (M:Matrix), {Bounded_M M} + {~(Bounded_M M)}.
Proof.
 intros ((a,b),(c,d));
 unfold Bounded_M, fst, snd;
 case (Qlt_dec Zero (d+c)); intros;
  case (Qlt_dec Zero (d-c)); intros;
   case (Qlt_dec (d+c) Zero); intros;
    case (Qlt_dec (d-c) Zero); intros; tauto.
Qed.

(** ##Emission condition## for the matrices:

    Our base interval is #I0#=#[#-1,+1#]# (due to the choice of the
    digits set), and hence the following definition means

  M(#I0#) #⊆#$\subseteq$  D(#I0#).

  Note also that 0< dig4-dig3, dig4+dig3. *)

Definition Incl_M (M:Matrix) (D:Digit) :=
  let (a,b) := (fst (fst M), snd (fst M)) in
    let (c,d) := (fst (snd M), snd (snd M)) in
      let (dig1,dig2) := (fst (fst (map_digits D)), snd (fst (map_digits D))) in
	let (dig3,dig4) := (fst (snd (map_digits D)), snd (snd (map_digits D))) in
	  Bounded_M M /\
              (d-c)*((d-c)*(dig2-dig1))<= (d-c)*((b-a)*(dig4-dig3)) /\           (* D(-1)<=M(-1) *)
              (d-c)*((b-a)*(dig3+dig4))<= (d-c)*((d-c)*(dig1+dig2)) /\           (* M(-1)<=D(+1) *)
              (d+c)*((c+d)*(dig2-dig1))<= (d+c)*((a+b)*(dig4-dig3)) /\           (* D(-1)<=M(+1) *)
              (d+c)*((a+b)*(dig3+dig4))<= (d+c)*((c+d)*(dig1+dig2)).             (* M(+1)<=D(+1) *)

Lemma Incl_M_dec_D: forall (M : Matrix) (D:Digit), {Incl_M M D} + {~(Incl_M M D)}.
Proof.
 intros ((a,b),(c,d)) D;
 unfold Incl_M;
 destruct (map_digits D) as ((dig1,dig2),(dig3,dig4)); simpl;
 case (Bounded_M_dec (a,b,(c,d))); intros ; [| tauto];
    case (Qle_dec ((d-c)*((d-c)*(dig2-dig1))) ((d-c)*((b-a)*(dig4-dig3)))); intros; [|tauto];
     case (Qle_dec ((d-c)*((b-a)*(dig3+dig4))) ((d-c)*((d-c)*(dig1+dig2)))); intros; [|tauto];
      case (Qle_dec ((d+c)*((c+d)*(dig2-dig1))) ((d+c)*((a+b)*(dig4-dig3)))); intros; [|tauto];
        case (Qle_dec ((d+c)*((a+b)*(dig3+dig4))) ((d+c)*((c+d)*(dig1+dig2)))); intros; tauto.
Qed.

(** ##Bounded## tensor on #[#-1,+1#]# #×# #[#-1,+1#]#. *)

Definition Bounded_T (T:Tensor):=
  let (a,b) := (fst (fst (fst T)), snd (fst (fst T))) in
   let (c,d) := (fst (snd (fst T)), snd (snd (fst T))) in
    let (e,f) := (fst (fst (snd T)), snd (fst (snd T))) in
     let (g,h) := (fst (snd (snd T)), snd (snd (snd T))) in
      (Qlt Zero (e+f+g+h) /\ Qlt Zero (e-f-g+h) /\ Qlt Zero (-e-f+g+h) /\ Qlt Zero (-e+f-g+h)) \/  (* 0<exy+fx+gy+h *)
      (Qlt (e+f+g+h) Zero /\ Qlt (e-f-g+h) Zero /\ Qlt (-e-f+g+h) Zero /\ Qlt (-e+f-g+h) Zero).    (* exy+fx+gy+h<0 *)

Lemma Bounded_T_dec: forall (T:Tensor), {Bounded_T T} + {~(Bounded_T T)}.
Proof.
 intros (((a,b),(c,d)),((e,f),(g,h)));
 unfold Bounded_T, fst, snd.
 case (Qlt_dec Zero (e+f+g+h)); case (Qlt_dec (e+f+g+h) Zero); intros; [ | | |tauto];
  case (Qlt_dec Zero (e-f-g+h)); case (Qlt_dec (e-f-g+h) Zero); intros; [ | | |tauto| | | |tauto| | | |tauto];
   case (Qlt_dec Zero (-e-f+g+h)); intros;
    case (Qlt_dec Zero (-e+f-g+h)); intros;
	  case (Qlt_dec (-e-f+g+h) Zero); intros;
	    case (Qlt_dec (-e+f-g+h) Zero); intros; tauto.
Qed.

(** ##Emission condition## for the tensors *)

Definition Incl_T (T:Tensor) (D:Digit) :=
  let (a,b) := (fst (fst (fst T)), snd (fst (fst T))) in
   let (c,d) := (fst (snd (fst T)), snd (snd (fst T))) in
    let (e,f) := (fst (fst (snd T)), snd (fst (snd T))) in
     let (g,h) := (fst (snd (snd T)), snd (snd (snd T))) in
      let (dig1,dig2) := (fst (fst (map_digits D)), snd (fst (map_digits D))) in
	let (dig3,dig4) := (fst (snd (map_digits D)), snd (snd (map_digits D))) in
	  Bounded_T T /\
	   ((e-f-g+h)*((e-f-g+h)*(dig2-dig1)))   <= ((e-f-g+h)*((a-b-c+d)*(dig4-dig3)))   /\   (* D(-1)<=T(-1,-1) *)
	   ((e-f-g+h)*((a-b-c+d)*(dig3+dig4)))   <= ((e-f-g+h)*((e-f-g+h)*(dig1+dig2)))   /\   (* T(-1,-1)<=D(+1) *)
	   ((-e-f+g+h)*((-e-f+g+h)*(dig2-dig1))) <= ((-e-f+g+h)*((-a-b+c+d)*(dig4-dig3))) /\   (* D(-1)<=T(-1,+1) *)
	   ((-e-f+g+h)*((-a-b+c+d)*(dig3+dig4))) <= ((-e-f+g+h)*((-e-f+g+h)*(dig1+dig2))) /\   (* T(-1,+1)<=D(+1) *)
	   ((-e+f-g+h)*((-e+f-g+h)*(dig2-dig1))) <= ((-e+f-g+h)*((-a+b-c+d)*(dig4-dig3))) /\   (* D(-1)<=T(+1,-1) *)
	   ((-e+f-g+h)*((-a+b-c+d)*(dig3+dig4))) <= ((-e+f-g+h)*((-e+f-g+h)*(dig1+dig2))) /\   (* T(+1,-1)<=D(+1) *)
	   ((e+f+g+h)*((e+f+g+h)*(dig2-dig1)))   <= ((e+f+g+h)*((a+b+c+d)*(dig4-dig3)))   /\   (* D(-1)<=T(+1,+1) *)
	   ((e+f+g+h)*((a+b+c+d)*(dig3+dig4)))   <= ((e+f+g+h)*((e+f+g+h)*(dig1+dig2))).        (* T(+1,+1)<=D(+1) *)

Lemma Incl_T_dec_D: forall (T : Tensor) (D:Digit), {Incl_T T D} + {~(Incl_T T D)}.
Proof.
 intros (((a,b),(c,d)),((e,f),(g,h))) D.
 unfold Incl_T.
 destruct (map_digits D) as ((dig1,dig2),(dig3,dig4)); unfold fst, snd.
 case (Bounded_T_dec (a, b, (c, d), (e, f, (g, h)))); intros; [|tauto];
 case (Qle_dec ((e-f-g+h)*((e-f-g+h)*(dig2-dig1))) ((e-f-g+h)*((a-b-c+d)*(dig4-dig3)))); intros; [|tauto];
    case (Qle_dec ((e-f-g+h)*((a-b-c+d)*(dig3+dig4))) ((e-f-g+h)*((e-f-g+h)*(dig1+dig2)))); intros; [|tauto];
      case (Qle_dec ((-e-f+g+h)*((-e-f+g+h)*(dig2-dig1))) ((-e-f+g+h)*((-a-b+c+d)*(dig4-dig3)))); intros; [|tauto];
	case (Qle_dec ((-e-f+g+h)*((-a-b+c+d)*(dig3+dig4))) ((-e-f+g+h)*((-e-f+g+h)*(dig1+dig2)))); intros; [|tauto];
          case (Qle_dec ((-e+f-g+h)*((-e+f-g+h)*(dig2-dig1))) ((-e+f-g+h)*((-a+b-c+d)*(dig4-dig3)))); intros; [|tauto];
	    case (Qle_dec ((-e+f-g+h)*((-a+b-c+d)*(dig3+dig4))) ((-e+f-g+h)*((-e+f-g+h)*(dig1+dig2)))); intros; [|tauto];
              case (Qle_dec ((e+f+g+h)*((e+f+g+h)*(dig2-dig1))) ((e+f+g+h)*((a+b+c+d)*(dig4-dig3)))); intros; [|tauto];
		case (Qle_dec ((e+f+g+h)*((a+b+c+d)*(dig3+dig4))) ((e+f+g+h)*((e+f+g+h)*(dig1+dig2)))); intros;  [|tauto];
                  left; split; trivial; repeat split; assumption.
Qed.

(** ##Refining## Moebius map on #[#-1,+1#]#. *)

Definition Is_refining_M M:=
  let (a,b) := (fst (fst M), snd (fst M)) in
    let (c,d) := (fst (snd M), snd (snd M)) in
      Bounded_M M /\
      ((Qle Zero (a+b+c+d) /\ Qle Zero (a-b-c+d) /\ Qle Zero (-a-b+c+d) /\ Qle Zero (-a+b-c+d)) \/  (* 0<axy+bx+cy+d *)
       (Qle (a+b+c+d) Zero /\ Qle (a-b-c+d) Zero /\ Qle (-a-b+c+d) Zero /\ Qle (-a+b-c+d) Zero)).    (* axy+bx+cy+d<0 *)

(** ##Refining## tensor on #[#-1,+1#]# #×# #[#-1,+1#]#. *)

Definition Is_refining_T T:=
  let (a,b) := (fst (fst (fst T)), snd (fst (fst T))) in
   let (c,d) := (fst (snd (fst T)), snd (snd (fst T))) in
    let (e,f) := (fst (fst (snd T)), snd (fst (snd T))) in
     let (g,h) := (fst (snd (snd T)), snd (snd (snd T))) in
      Bounded_T T /\
      ((Qle Zero (a+b+c+d+e+f+g+h) /\ Qle Zero (-a-b-c-d+e+f+g+h) /\
        Qle Zero (a-b-c+d+e-f-g+h) /\ Qle Zero (-a+b+c-d+e-f-g+h) /\
        Qle Zero (-a-b+c+d-e-f+g+h) /\ Qle Zero (a+b-c-d-e-f+g+h) /\
        Qle Zero (-a+b-c+d-e+f-g+h) /\ Qle Zero (a-b+c-d-e+f-g+h)) \/
       (Qle (a+b+c+d+e+f+g+h) Zero /\ Qle (-a-b-c-d+e+f+g+h) Zero /\
        Qle (a-b-c+d+e-f-g+h) Zero /\ Qle (-a+b+c-d+e-f-g+h) Zero /\
        Qle (-a-b+c+d-e-f+g+h) Zero /\ Qle (a+b-c-d-e-f+g+h) Zero /\
        Qle (-a+b-c+d-e+f-g+h) Zero /\ Qle (a-b+c-d-e+f-g+h) Zero)).

(** The ##iedntity## mobius map *)
Definition idM :=  (1 / 1, 0 / 1, (0 / 1, 1 / 1)).

Lemma Is_refining_M_idM:Is_refining_M idM.
Proof.
 red; unfold idM, Bounded_M, fst, snd; qZ_numerals; split; left; repeat split; auto.
Qed.

(** This calculates the product of the inverses of the first [n]
elements of [alpha] in the ##reverse order##, eg

 a#0#:a#1#:a#2#:a#3#:...  |-------> a#3# #-1# o a#2# #-1# o a#1# #-1# o a#0# #-1#: ...    for n=4

*)
Definition product_init_rev alpha n: Matrix := List.fold_right product idM (List.rev (Streams_addenda.take n (Streams.map inv_digit alpha))).

(** Calculating the product of the first [n] elements of [alpha]. *)
Definition product_init_pure (alpha:Reals) n := List.fold_right product idM (Streams_addenda.take n (map_reals alpha)).

Lemma product_associative:forall M N P, product M (product N P) = product (product M N) P.
Proof.
 intros ((a0,b0),(c0,d0)) ((a1,b1),(c1,d1)) ((a2,b2),(c2,d2));
 unfold product, fst, snd;
 apply (f_equal2 (@pair Vector Vector));
 apply (f_equal2 (@pair Q Q)); ring; auto.
Qed.

Lemma product_digit_inv_digit_identity_right:forall (d:Digit), product d (inv_digit d) = idM.
Proof.
 intros [ | | ]; unfold map_digits, inv_digit, inv_LL, inv_RR, inv_MM, idM, product, fst, snd;
 apply (f_equal2 (@pair Vector Vector));
 apply (f_equal2 (@pair Q Q)); qZ_numerals.
Qed.

Lemma product_idM_identity_right:forall M, product M idM = M.
Proof.
  intros ((a,b),(c,d));
  unfold idM, product, fst, snd, Qdiv at 2 3 6 7; rewrite Qmult_zero; repeat rewrite Qmult_zero_right;
  repeat rewrite Qplus_zero_right; repeat rewrite Qplus_zero_left; qZ_numerals; rewrite Qdiv_Qone_Qone;
  repeat rewrite Qmult_one_right; trivial.
Qed.

Lemma product_idM_identity_left:forall M, product idM M = M.
Proof.
  intros ((a,b),(c,d));
  unfold idM, product, fst, snd, Qdiv at 2 4 5 7; rewrite Qmult_zero; repeat rewrite Qmult_zero_right;
  repeat rewrite Qplus_zero_right; repeat rewrite Qplus_zero_left; qZ_numerals; rewrite Qdiv_Qone_Qone;
  repeat rewrite Qmult_one_left; trivial.
Qed.

Lemma product_inv_L:forall mu, mu = (product (map_digits LL) (product inv_LL mu)).
Proof.
 intro mu; rewrite product_associative;
 replace inv_LL with (inv_digit LL); trivial;
 rewrite product_digit_inv_digit_identity_right;
 rewrite product_idM_identity_left; reflexivity.
Qed.

Lemma product_inv_R:forall mu, mu = (product (map_digits RR) (product inv_RR mu)).
Proof.
 intro mu; rewrite product_associative;
 replace inv_RR with (inv_digit RR); trivial;
 rewrite product_digit_inv_digit_identity_right;
 rewrite product_idM_identity_left; reflexivity.
Qed.

Lemma product_inv_M:forall mu, mu = (product MM (product inv_MM mu)).
Proof.
 intro mu; rewrite product_associative;
 replace inv_MM with (inv_digit MM); trivial;
 rewrite product_digit_inv_digit_identity_right;
 rewrite product_idM_identity_left; reflexivity.
Qed.

Lemma right_left_product_idM_identity_right:forall T, right_product (left_product T idM) idM = T.
Proof.
  intros (((a,b),(c,d)),((e,f),(g,h)));
  unfold idM, left_product, right_product, fst, snd, Qdiv at 2 3 6 7; rewrite Qmult_zero; repeat rewrite Qmult_zero_right;
  repeat rewrite Qplus_zero_right; repeat rewrite Qplus_zero_left; qZ_numerals; rewrite Qdiv_Qone_Qone;
  repeat rewrite Qmult_one_right; trivial.
Qed.

Lemma m_product_left_right_product_associative: forall M T N P,
        m_product M (right_product (left_product T N) P)=right_product (left_product (m_product M T) N) P.
Proof.
  intros ((A,B),(C,D)) (((a,b),(c,d)),((e,f),(g,h)))  ((E,F),(G,H)) ((I,J),(K,L)).
  unfold m_product, left_product, right_product, fst, snd.
  apply (f_equal2 (@pair Matrix Matrix));
  apply (f_equal2 (@pair Vector Vector));
  apply (f_equal2 (@pair Q Q)); ring.
Qed.

Lemma product_left_right_product_associative: forall T M1 M2 N1 N2,
     right_product (left_product (right_product (left_product T M1) N1) M2) N2=
     right_product (left_product T (product M1 M2)) (product N1 N2).
Proof.
  intros (((a,b),(c,d)),((e,f),(g,h)))  ((A1,B1),(C1,D1)) ((A2,B2),(C2,D2)) ((E1,F1),(G1,H1)) ((E2,F2),(G2,H2));
  unfold product, left_product, right_product, fst, snd.
  apply (f_equal2 (@pair Matrix Matrix));
  apply (f_equal2 (@pair Vector Vector));
  apply (f_equal2 (@pair Q Q)); ring.
Qed.

Lemma m_product_inv_L: forall xi, xi = m_product LL (m_product inv_LL xi).
Proof.
 intros (((a,b),(c,d)),((e,f),(g,h))); unfold map_digits, inv_digit, inv_LL, m_product, fst, snd;
 apply (f_equal2 (@pair Matrix Matrix));
 apply (f_equal2 (@pair Vector Vector));
 apply (f_equal2 (@pair Q Q)); qZ_numerals; field; auto.
Qed.

Lemma m_product_inv_R: forall xi, xi = m_product RR (m_product inv_RR xi).
Proof.
 intros (((a,b),(c,d)),((e,f),(g,h))); unfold map_digits, inv_digit, inv_RR, m_product, fst, snd;
 apply (f_equal2 (@pair Matrix Matrix));
 apply (f_equal2 (@pair Vector Vector));
 apply (f_equal2 (@pair Q Q));
 qZ_numerals; field ;auto.
Qed.

Lemma m_product_inv_M: forall xi, xi = m_product MM (m_product inv_MM xi).
Proof.
 intros (((a,b),(c,d)),((e,f),(g,h))); unfold map_digits, inv_digit, inv_MM, m_product, fst, snd;
 apply (f_equal2 (@pair Matrix Matrix));
 apply (f_equal2 (@pair Vector Vector));
 apply (f_equal2 (@pair Q Q));
 qZ_numerals; field ;auto.
Qed.

(** Moebius map applied to a rational number. *)

Definition as_Moebius_Q (M:Matrix) :=
  let (a,b) := (fst (fst M), snd (fst M)) in
    let (c,d) := (fst (snd M), snd (snd M)) in
      fun (x:Q) => ((a*x+b)/(c*x+d)).

(** Tensor applied to two rational numbers. *)

Definition as_Tensor_Q (T:Tensor) :=
  let (a,b) := (fst (fst (fst T)), snd (fst (fst T))) in
   let (c,d) := (fst (snd (fst T)), snd (snd (fst T))) in
    let (e,f) := (fst (fst (snd T)), snd (fst (snd T))) in
     let (g,h) := (fst (snd (snd T)), snd (snd (snd T))) in
      fun (x y:Q)=> (a*x*y+b*x+c*y+d)/(e*x*y+f*x+g*y+h).

Lemma as_Moebius_Q_L: forall x, Zero<x+3->as_Moebius_Q LL x= (x-1)/(x+3).
Proof.
 intros x H_x;
 (* TP:  x * 2 + 3 * 2 <> Zero *)
 assert (H_x':x * 2 + 3 * 2 <> Zero); [stepl (2*(x+3)); auto; ring|];
 unfold as_Moebius_Q, map_digits, fst, snd, Qdiv at 2 4;
 rewrite <- Qmult_assoc; rewrite Qmult_one_left; rewrite Qmult_sym;
 fold (Qdiv x 2); rewrite Qplus_Qdiv; auto; rewrite Qplus_Qdiv; auto;
 rewrite Qdiv_Qdiv_simplify; auto; qZ_numerals; field; auto.
Qed.

Lemma as_Moebius_Q_R: forall x, Zero<(-x)+3->as_Moebius_Q RR x= (x+1)/((-x)+3).
Proof.
 intros x H_x;
 (* TP:  (-x) * 2 + 3 * 2 <> Zero *)
 assert (H_x':(-x) * 2 + 3 * 2 <> Zero); [stepl (2*((-x)+3)); auto; ring|];
 unfold as_Moebius_Q, map_digits, fst, snd, Qdiv at 2;
 replace ((-1)%Z/2*x) with (-x/2); [|rewrite Z_to_Q_min_one; field; auto];
 rewrite <- Qmult_assoc; rewrite Qmult_one_left; rewrite Qmult_sym;
 fold (Qdiv x 2); rewrite Qplus_Qdiv; auto; rewrite Qplus_Qdiv; auto;
 rewrite Qdiv_Qdiv_simplify; auto; field; auto.
Qed.

Lemma as_Moebius_Q_M: forall x, as_Moebius_Q MM x= (x/3).
Proof.
 intros x; unfold as_Moebius_Q, map_digits, fst, snd; qZ_numerals; field; auto.
Qed.

Lemma as_Moebius_Q_L_nondecreasing:forall x y, (Qopp Qone) <= x -> y<= Qone -> x<=y ->
                                                as_Moebius_Q LL x <= as_Moebius_Q LL y.
Proof.
 intros x y Hx Hy Hxy.
 unfold as_Moebius_Q, map_digits, fst, snd.
 (* TP: Zero <= x+ 1 *)
 assert (H_x_one_nonneg: Zero <= x+1).
 stepr (x-(Qopp 1)); try ring; apply Qle_Qminus_Zero; auto.
 (* TP: Zero < x+3 *)
 assert (H_x_three_pos: Zero < x+3).
 apply Qle_lt_trans with (x+1); auto;
 apply Qlt_Zero_Qminus; stepr 2; auto; qZ_numerals; ring.
 (* TP: Zero < 1 * x * 2 + 3 * 2 *)
 assert (H:Zero < 1 * x * 2 + 3 * 2).
  stepr (2*(x+3)); [|qZ_numerals; ring].
  apply Qlt_mult_pos_pos; auto.
 (* TP: Zero <= y+ 1 *)
 assert (H_y_one_nonneg: Zero <= y+1).
 stepr (y-(Qopp 1)); try ring; apply Qle_Qminus_Zero; auto; apply Qle_trans with x; auto.
 (* TP: Zero < y+3 *)
 assert (H_y_three_pos: Zero < y+3).
 apply Qle_lt_trans with (y+1); auto;
 apply Qlt_Zero_Qminus; stepr 2; auto; qZ_numerals; ring.
 (* TP: Zero < 1 * y * 2 + 3 * 2 *)
 assert (H':Zero < 1 * y * 2 + 3 * 2).
  stepr (2*(y+3)); [|qZ_numerals; ring].
  apply Qlt_mult_pos_pos; auto.

 repeat rewrite Qdiv_Qmult_numerator_r; auto.
 repeat rewrite Qplus_Qdiv; auto.
 repeat rewrite Qdiv_Qdiv_simplify; auto.
 apply Qmult_Qdiv_pos_Qle; auto.
 apply Qle_Zero_Qminus.
 stepr (16*(y-x)); qZ_numerals; [|qZ_numerals; ring].
 apply Qle_mult_nonneg_nonneg; auto.
 apply Qle_Qminus_Zero; auto.
Qed.

Lemma as_Moebius_Q_R_nondecreasing:forall x y, (Qopp Qone) <= x -> y<= Qone -> x<=y ->
                                                as_Moebius_Q RR x <= as_Moebius_Q RR y.
Proof.
 intros x y Hx Hy Hxy.
 unfold as_Moebius_Q, map_digits, fst, snd.
 (* TP: Zero <= -y+ 1 *)
 assert (H_min_y_one_nonneg: Zero <= -y+1).
 stepr (1-y); try ring; apply Qle_Qminus_Zero; auto.
 (* TP: Zero < -y+3 *)
 assert (H_min_y_three_pos: Zero < -y+3).
 apply Qle_lt_trans with ((-y)+1); auto.
 apply Qlt_Zero_Qminus; stepr 2; auto; qZ_numerals; ring.
 (* TP: Zero < (-1) * y * 2 + 3 * 2 *)
 assert (H':Zero < (-1)%Z * y * 2 + 3 * 2).
  rewrite Z_to_Q_min_one;
  stepr (2*(-y+3)); [|ring].
  apply Qlt_mult_pos_pos; auto.
 (* TP: Zero <= -x+ 1 *)
 assert (H_min_x_one_nonneg: Zero <= -x+1).
 stepr (1-x); try ring; apply Qle_Qminus_Zero; auto; apply Qle_trans with y; auto.
 (* TP: Zero < -x+3 *)
 assert (H_min_x_three_pos: Zero < -x+3).
 apply Qle_lt_trans with ((-x)+1); auto.
 apply Qlt_Zero_Qminus; stepr 2; auto; qZ_numerals; ring.
 (* TP: Zero < (-1) * x * 2 + 3 * 2 *)
 assert (H:Zero < (-1)%Z * x * 2 + 3 * 2).
  rewrite Z_to_Q_min_one;
  stepr (2*(-x+3)); [|ring].
  apply Qlt_mult_pos_pos; auto.

 repeat rewrite Qdiv_Qmult_numerator_r; auto.
 repeat rewrite Qplus_Qdiv; auto.
 repeat rewrite Qdiv_Qdiv_simplify; auto.
 apply Qmult_Qdiv_pos_Qle; auto.
 apply Qle_Zero_Qminus;
 stepr (16*(y-x));
 qZ_numerals; [|ring].
 apply Qle_mult_nonneg_nonneg; auto.
 apply Qle_Qminus_Zero; auto.
Qed.

Lemma as_Moebius_Q_M_nondecreasing:forall x y, (Qopp Qone) <= x -> y<= Qone -> x<=y ->
                                                as_Moebius_Q MM x <= as_Moebius_Q MM y.
Proof.
 intros x y Hx Hy Hxy.
 unfold as_Moebius_Q, map_digits, fst, snd.

 repeat rewrite Qdiv_Qmult_numerator_r; auto.
 repeat rewrite Qplus_Qdiv; auto.
 repeat rewrite Qdiv_Qdiv_simplify; auto.
 apply Qmult_Qdiv_pos_Qle; auto.
 apply Qle_Zero_Qminus.
 stepr (3*(y-x)); [|qZ_numerals; ring].
 apply Qle_mult_nonneg_nonneg; auto; apply Qle_Qminus_Zero; auto.
Qed.

(** ##Determinant## of a matrix *)

Definition Determinant M :=
  let (a,b) := (fst (fst M), snd (fst M)) in
    let (c,d) := (fst (snd M), snd (snd M)) in
	  (a * d - b * c).

(** ##Diameter## of a application of a Moebius map on #[#-1,+1#]#. *)

Definition diameter mu (H_refining:Is_refining_M mu) : Q := Qabs (as_Moebius_Q mu Qone - as_Moebius_Q mu (-Qone)).

Lemma diameter_PI:forall mu H1 H2, diameter mu H1 = diameter mu H2.
Proof.
 intros mu H1 H2; unfold diameter; reflexivity.
Qed.

Definition min_one_is_in_base_interval_Q := conj (Qle_reflexive (-Qone)) (Qlt_le_weak (-Qone) Qone Qopp_Qone_Qlt_Qone).
Definition one_is_in_base_interval_Q :=conj (Qlt_le_weak (- Qone) Qone Qopp_Qone_Qlt_Qone) (Qle_reflexive Qone).

(** ##Redundancy## of the digit set. *)
Definition redundancy := 1/3.

Lemma redundancy_pos:Zero < redundancy.
Proof.
 auto.
Qed.

(** ##Diameter## of a tensor on #[#-1,+1#]# #×# #[#-1,+1#]#. *)
(* I_1=[x_1,x_2], I_2=[y_1,y_2] *)
Definition diameter2 xi (H_xi: Is_refining_T xi) x1 y1 x2 y2 (Hx1:-Qone<=x1/\x1<=Qone) (Hy1:-Qone<=y1/\y1<=Qone)
   (Hx2:-Qone<=x2/\x2<=Qone) (Hy2:-Qone<=y2/\y2<=Qone) :=
 let xi_ll:= as_Tensor_Q xi x1 y1 in
  let xi_lr:= as_Tensor_Q xi x1 y2 in
   let xi_rl:= as_Tensor_Q xi x2 y1 in
    let xi_rr:= as_Tensor_Q xi x2 y2 in
     (Qmax4 xi_ll xi_lr xi_rl xi_rr) - (Qmin4 xi_ll xi_lr xi_rl xi_rr).

(** The following map can be used in estimating the maximum of the
diameter. *)
Definition eta_discriminant (M:Matrix) :=
  let (c,d) := (fst (snd M), snd (snd M)) in
	  ((0/1,1/1),(c,d)).

(** This predicate states that the denominator of a Moebius map does
not vanish in #[#-1,+1#]#. *)
Definition denom_nonvanishing_M (mu:Matrix) r:=
  let (a,b) := (fst (fst mu), snd (fst mu)) in
    let (c,d) := (fst (snd mu), snd (snd mu)) in
      (c*r+d<>0)%R.

(** The denominator of a tensor does not vanish in #[#-1,+1#]#
#×# #[#-1,+1#]#. *)
Definition denom_nonvanishing_T (xi:Tensor) r1 r2:=
  let (a,b) := (fst (fst (fst xi)), snd (fst (fst xi))) in
   let (c,d) := (fst (snd (fst xi)), snd (snd (fst xi))) in
    let (e,f) := (fst (fst (snd xi)), snd (fst (snd xi))) in
     let (g,h) := (fst (snd (snd xi)), snd (snd (snd xi))) in
      (e*r1*r2+f*r1+g*r2+h<>0)%R.

(** Moebius map applied to a real number.*)
Definition as_Moebius (M:Matrix) :=
  let (a,b) := (fst (fst M), snd (fst M)) in
    let (c,d) := (fst (snd M), snd (snd M)) in
      fun (x:R) => ((a*x+b)/(c*x+d))%R.

(** Tensor applied to two real number.*)
Definition as_Tensor (T:Tensor) :=
  let (a,b) := (fst (fst (fst T)), snd (fst (fst T))) in
   let (c,d) := (fst (snd (fst T)), snd (snd (fst T))) in
    let (e,f) := (fst (fst (snd T)), snd (fst (snd T))) in
     let (g,h) := (fst (snd (snd T)), snd (snd (snd T))) in
      fun x y=> ((a*x*y+b*x+c*y+d)/(e*x*y+f*x+g*y+h))%R.

(** Tensor ##partially## applied to a rational number.*)
Definition Tensor_Moebius_Q_l (xi:Tensor) x :=
  let (a,b) := (fst (fst (fst xi)), snd (fst (fst xi))) in
   let (c,d) := (fst (snd (fst xi)), snd (snd (fst xi))) in
    let (e,f) := (fst (fst (snd xi)), snd (fst (snd xi))) in
     let (g,h) := (fst (snd (snd xi)), snd (snd (snd xi))) in
        ((a*x+c,b*x+d),(e*x+g,f*x+h)).

Definition Tensor_Moebius_Q_r (xi:Tensor) y :=
  let (a,b) := (fst (fst (fst xi)), snd (fst (fst xi))) in
   let (c,d) := (fst (snd (fst xi)), snd (snd (fst xi))) in
    let (e,f) := (fst (fst (snd xi)), snd (fst (snd xi))) in
     let (g,h) := (fst (snd (snd xi)), snd (snd (snd xi))) in
        ((a*y+b,c*y+d),(e*y+f,g*y+h)).

(** Tensor ##partially## applied to a rational number resulting a Moebius map.*)
Definition as_Tensor_Moebius_Q_l xi x:= as_Moebius_Q (Tensor_Moebius_Q_l xi x).

Definition as_Tensor_Moebius_Q_r xi x:= as_Moebius_Q (Tensor_Moebius_Q_r xi x).

Lemma Q_to_R_as_Moebius:forall mu q, denom_nonvanishing_M mu (Q_to_R.Q_to_R q)->
  Q_to_R.Q_to_R (as_Moebius_Q mu q) = as_Moebius mu (Q_to_R.Q_to_R q).
Proof.
 intros ((a,b),(c,d)) q;
 unfold denom_nonvanishing_M, as_Moebius_Q, as_Moebius, fst, snd;
 intro Hcd; Q_to_R.realify_Q; trivial;
 apply Q_to_R.Q_to_R_Qneq; Q_to_R.realify_Q; trivial.
Qed.

Close Scope Z_scope.


Definition negb (b:bool) : bool :=
  match b with
  | true ⇒ false
  | false ⇒ true
  end.
Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true ⇒ b2
  | false ⇒ false
  end.
Definition orb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true ⇒ true
  | false ⇒ b2
  end.

  Example test_orb1: (orb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb2: (orb false false) = false.
Proof. simpl. reflexivity. Qed.
Example test_orb3: (orb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb4: (orb true true) = true.
Proof. simpl. reflexivity. Qed.


(*This file considers Baire space nat -> nat as example for
a space that can be thought about continuity on. *)
From Coq.micromega Require Import Psatz.
From mathcomp Require Import all_ssreflect.
Require Import all_core.
Require Import Classical.

Open Scope coq_nat_scope.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section BAIRE_SPACE.
Context (Q A Q' A': Type).
Inductive one := star.
Notation B := (nat -> nat).
Notation N := (one -> nat).
Notation "'init_seg' phi" := (in_seg id phi) (at level 2).

Lemma min_sec: @is_min_sec nat id id.
Proof. split => // s m ineq; apply /leP; lia. Qed.

Lemma melt_init_seg:
	forall n, max_elt id (init_seg n) = n.
Proof.
elim => //= n ->; rewrite /maxn; case: ifP => // ineq.
by exfalso; apply /PeanoNat.Nat.nlt_succ_diag_l/leP /ineq.
Qed.

(* This is the more conventional continuity using intial segments.
It is equivalent to the corresponding multifunction being continuous
in the sense of "continuity.v" *)
Definition is_cont1 (G: (nat -> nat) -> nat -> nat) :=
  forall phi n, exists m, forall psi,
    phi \and psi \coincide_on (init_seg m) -> (G phi) \and (G psi) \coincide_on (init_seg n).

Lemma continuity1 (F: B -> B):
	is_cont1 F <-> is_cont (F2MF F).
Proof.
split => [ cont phi fd s' | cont phi].
	have [m cont']:= (cont phi (S s')).
	exists (init_seg m); split => // Fphi /= iv psi coin Fpsi iv'.
	move: cont' (cont' psi coin) => _ coinv; rewrite iv iv' in coinv.
	by apply /((inseg_coin _ _ _ _).2 coinv)/ltnSn.
elim; first by exists 0 => psi coin; apply: (inseg_coin id (F phi) (F psi) 0).1.
move => n [m] ih.
have [L [/=phifd cond]]:= (cont phi (F2MF_tot F phi) n).
exists (max_elt id (app (init_seg m) L)) => psi coin.
move: ((inseg_coin id phi psi (max_elt id (init_seg m ++ L))).2 coin) => coin'.
apply: (inseg_coin id (F phi) (F psi) (S n)).1=> n0 ineq.
case: (Compare_dec.le_lt_eq_dec n0 n _) => [ | neq | eq]; first by move/leP: ineq; lia.
	move: ineq neq => _; move: n0.
	move => n0 /leP ineq; move: n0 ineq.
	apply/inseg_coin; apply ih; apply/inseg_coin => n1 n1ls.
	by apply coin'; rewrite melt_app melt_init_seg; apply/leq_trans; last exact: leq_maxl.
have coin'': phi \and psi \coincide_on (init_seg (max_elt id L)).
	apply: (inseg_coin id phi psi (max_elt id L)).1 => n1 n1ls.
	by apply coin'; rewrite (melt_app); apply/leq_trans;last exact: leq_maxr.
rewrite eq; apply/ (cond (F phi)) => //=.
by apply/ list_melt; first apply min_sec.
Qed.

(* The following uses lists for regular functions and is easier to prove equal to the
continuity from "continuity.v" *)
Definition is_cont2 (G: (Q-> A) -> Q' -> A') :=
  forall phi (q': Q'), exists (L : list Q), forall psi,
    phi \and psi \coincide_on L -> G phi q' = G psi q'.

Lemma continuity2 (F: (Q-> A) -> Q' -> A'):
	is_cont2 F <-> is_cont (F2MF F).
Proof.
split => [cont psi fd s' | cont psi s'].
	have [L cond]:= (cont psi s').
	by exists L; split =>// Fpsi /= <- phi coin Fphi <-; apply (cond phi).
have [L [/=_ cond]] := (cont psi (F2MF_tot F psi) s').
by exists L => phi coin; apply/ (cond (F psi) _) => //=.
Qed.

(*To have function from baire space to natural numbers, we identify nat with one -> nat.*)
Definition F phi n := phi (n star) = 0 /\ forall m, phi m = 0 -> n star <= m.
(* F is a partial function: if phi is never zero, the right hand side is always false and
phi is not assinged any value. On the other hand the function is single valued, as only
the smalles number where phi is zero allowed as return value. More generally, the function
is continuous:*)

Lemma F_is_continuous: F \is_continuous.
Proof.
set L := in_seg (fun n:nat => n) => phi phifd str.
case: (classic (exists m, phi m = 0)) => [[m me0]| neq0]; last first.
	by exists nil; split =>// fp1 /= v1; exfalso; apply neq0; exists (fp1 star); apply v1.
exists (L m.+1); split =>// Fphi /= [v1 c1] psi pep Fpsi [v2 c2].
have cond:= ((inseg_coin (fun n:nat => n) phi psi m.+1).2 pep).
have le1: Fphi star <= m by apply (c1 m); lia.
have leq2: Fpsi star <= m	by apply: (c2 m); replace (psi m) with (phi m) by by apply (cond m).
have /leP l2: Fpsi star < m.+1 by lia.
rewrite -((cond (Fpsi star) l2)) in v2.
have/leP l1: Fphi star < m.+1 by lia.
rewrite (cond (Fphi star) l1) in v1.
move: (c1 (Fpsi star) v2) (c2 (Fphi star) v1) => ieq1 ieq2.
replace str with star by by elim str.
by lia.
Qed.

Lemma F_is_single_valued: F \is_single_valued.
Proof.
exact: cont_sing F_is_continuous.
Qed.

Lemma no_extension :
	~ exists G, (F2MF G) \extends F /\ (F2MF G) \is_continuous.
Proof.
move => [] G [] ext cont.
set psi := fun n:nat => 1.
have [L [/=_ Lprop]]:= (cont psi (F2MF_tot G psi) star).
set sL := max_elt id L.
set m := (max ((G psi) star).+1 sL).
set psi' := fun n => if (leq m n) then 0 else 1.
have coin: psi \and psi' \coincide_on init_seg sL.
	apply/inseg_coin => n nls; rewrite /psi /psi'.
	case E: (leq m n); last by trivial.
	suffices ineq: (m <= n)%N.
		rewrite /m in ineq.
		by move/leP: nls; move/leP: ineq; lia.
	by rewrite E.
have coin': psi \and psi' \coincide_on L by apply/list_melt; last by apply/ coin.
have neq: (G psi') = fun star => m.
	apply: (ext psi' (fun star => m)); rewrite /F /psi'.
	split => [ | m0]; last by case E: (leq m m0) => // _; apply /leP; rewrite E.
	replace (leq m m) with true => //.
	by have: (leq m m) by apply /leP; lia.
suffices: G psi star = G psi' star.
	by rewrite neq /m; lia.
by apply/ Lprop => //.
Qed.

(* Since classically, any multi function can be extended to a total multi function and
we get the following:
Lemma no_extension':
	~ exists G, G extends F /\ G is_continuous /\ G is_total.
But I don't feel like proving that now. *)
End BAIRE_SPACE.


Require Import Unicode.Utf8.
Require Import Decidable.
Require expr.
Require Import List Datatypes util.
Require Import FunctionalExtensionality CpdtTactics.
Require Import Arith.Peano_dec.
Require Import Program.Basics.
Set Implicit Arguments.

Inductive tm : Type :=
  | var : nat -> tm
  | lam : tm -> tm
  | app : tm -> tm -> tm.

Inductive value : tm → Type :=
  | isval : ∀ b, value (lam b).

Fixpoint fvs (e:tm) : list nat := match e with
  | var v =>  v::nil
  | lam b =>  map pred (remove 0 (fvs b))
  | app m n => fvs m ++ fvs n
  end.

Definition closed (e:tm) := fvs e = nil.

Notation " :λ N " := (lam N) (at level 20).
Notation " M @ N " := (app M N) (at level 60).
Coercion var : nat >-> tm.

Example term_1 : tm := lam (var 0).
Example term_2 : tm := app term_1 term_1.

(* TODO
Lemma dbClosedUnder (tm : expr.tm) (env : Map nat nat) :
  subset (expr.fvs tm) (domain env) → exists e, db tm env = Some e.
intros. induction tm. apply subset_domain_map with (l:=(expr.fvs (expr.var n)))
(eq0:=eq_nat_dec) in H. simpl in H. simpl. destruct H. destruct H. rewrite H.
apply ex_intro with (var x). reflexivity. simpl in H. rewrite
app_subset_and in H. destruct H. apply IHtm1 in H. apply IHtm2 in H0. simpl.
destruct H, H0. rewrite H. rewrite H0. apply ex_intro with (app x
x0). reflexivity. simpl in H. simpl. rewrite <- subset_remove_cons in H.
rewrite <- domain_fmap with (C:=nat) (f:=S) in H.
induction (expr.fvs tm).
assert (subset nil (domain env)). apply subset_nil. apply IHtm in H0. destruct
H0. apply ex_intro with (lam x).
*)

(*
Theorem closed_db_under : forall f t, subset (expr.fvs t) (domain f) -> exists
e, db t f e.
intros. induction t. destruct H. apply in_split in H. crush. clear H0.
apply ex_intro with (var n).
induction f. crush. induction t. inversion H. inversion H0. unfold expr.fvs
in H. apply app_subset_and in H. destruct H. crush. apply ex_intro with
(app x0 x). apply dbApp; assumption. apply ex_intro with
lam
induction e. crush. apply in_split in H0. destruct H0. destruct H.
induction H. crush. unfold domain. rewrite map_app. rewrite in_app_iff.
right. crush. crush. rewrite <- subset_remove_cons. rewrite domain_fmap in IHdb.
assumption. simpl. apply app_subset_and. crush. Qed.
*)