(** Polymorphic versions of exponentiation functions *)

Require Import Arith ZArith.
Require Import String.

(**
  Polymorphic exponentiation functions
 *)

(* begin snippet Defs *)
Section Definitions.

 Variables (A : Type)
           (mult : A -> A -> A)
           (one : A).

#[local] Infix "*" := mult.
#[local] Notation "1" := one.

(**  Naive (linear) implementation *)

Fixpoint power (x:A)(n:nat) : A :=
  match n with
    | 0%nat => 1
    | S p =>   x * x ^ p
  end
where "x ^ n" := (power x n).
(* end snippet Defs *)

(** Logarithmic implementation (with exponents in [N])  *)

(* begin snippet bpowDef *)

Fixpoint binary_power_mult (x a:A)(p:positive) : A
  :=
  match p with
    | xH =>  a * x
    | xO q => binary_power_mult  (x * x) a q
    | xI q =>  binary_power_mult  (x * x) (a * x) q
  end.

Fixpoint Pos_bpow   (x:A)(p:positive) :=
 match p with
  | xH => x
  | xO q => Pos_bpow  (x * x) q
  | xI q => binary_power_mult   (x * x) x q
end.

Definition N_bpow  x (n:N) :=
  match n with
  | 0%N => 1
  | Npos p => Pos_bpow x p
  end.

(* end snippet bpowDef *)

(* begin snippet EndDefs *)
End Definitions.

Arguments N_bpow  {A}.
Arguments power  {A}.
(* end snippet EndDefs *)

(** **  Examples *)

(* begin snippet PowerCompute *)
Compute power Z.mul 1%Z 2%Z 10.

Compute N_bpow Z.mul 1%Z 2%Z 10.

Open Scope string_scope.

Compute power append  "" "ab"  12.

Compute N_bpow append  "" "ab"  12.
(* end snippet PowerCompute *)

(** Exponentiation on 2x2 matrices *)

(* begin snippet M2a *)

Module M2.
Section M2_Definitions.

  Variables (A: Type)
           (zero one : A)
           (plus mult  : A -> A -> A).

  Variable rt : semi_ring_theory  zero one plus mult   (@eq A).
  Add Ring Aring : rt.

  Notation "0" := zero.
  Notation "1" := one.
  Notation "x + y" := (plus x y).
  Notation "x * y " := (mult x y).

  Structure t : Type := mat{c00 : A;  c01 : A;
                            c10 : A;  c11 : A}.

  Definition Id2 : t := mat 1 0 0 1.

(* end snippet M2a *)

(* begin snippet M2Mult *)
  Definition M2_mult (M M':t) : t :=
    mat (c00 M * c00 M' + c01 M * c10 M')
        (c00 M * c01 M' + c01 M * c11 M')
        (c10 M * c00 M' + c11 M * c10 M')
        (c10 M * c01 M' + c11 M * c11 M').

End M2_Definitions.
End M2.

Import M2.

Arguments M2_mult {A} plus mult  _  _.
Arguments mat {A} _ _ _ _.
Arguments Id2 {A}  _ _.
(* end snippet M2Mult *)

Definition fibonacci (n:N) :=
 c00 N  (N_bpow  (M2_mult Nplus Nmult) (Id2  0%N 1%N)(mat  1 1 1 0)%N n).

 Compute fibonacci 20.

(* begin snippet powerTDef *)
Definition power_t := forall (A:Type)
                             (mult : A -> A -> A)
                             (one:A)
                             (x:A)
                             (n:N), A.
(* end snippet powerTDef *)

(** * A wrong definition of correctness *)

(* begin snippet Bada *)
Module Bad.

  Definition correct_expt_function (f : power_t) : Prop :=
    forall A (mult : A -> A -> A) (one:A)
           (x:A) (n:N), power mult one x (N.to_nat n) =
                        f A mult one x n.
  (* end snippet Bada *)

(* begin snippet Badb:: no-out *)
  Section CounterExample.
    Let mul (n p : nat) := n + 2 * p.
    Let one := 0.

    (** With our fake definition, [N_bpow] is not correct! *)

    Remark mul_not_associative :
      exists  n p q,  mul n (mul p q) <> mul (mul n p) q.
    Proof.
      exists 1, 1, 1; discriminate.
    Qed.

    Remark one_not_neutral  :
      exists n : nat, mul one n <> n.
    Proof.
      exists 1; discriminate.
    Qed.

    Lemma correct_exp_too_strong : ~ correct_expt_function (@N_bpow).
    Proof.
      intro H; specialize (H _ mul one 1  7%N).
      discriminate H.
    Qed.

  End CounterExample.

End Bad.
(* end snippet Badb *)

(** Fibonacci matrices *)
(*

Open Scope Z_scope.
Definition encode (p: Z*Z) := let (a,b) := p in  mat (a+b)%Z a a b.

Definition id2 := (0,1).
Definition matfib2 := (1, 0).
Definition mul2 (m m' : Z*Z) := let (a,b) := m in
                        let (c,d) := m' in
                        ((a+b)*c + a*d, a*c + b*c).

Compute mul2 id2 matfib2.
Compute mul2 matfib2 id2.

Lemma mul2_assoc (m m' m'': Z*Z):
      mul2 (mul2 m m') m'' = mul2 m (mul2 m' m'').
destruct m,m',m''.
  unfold mul2.
 f_equal. ring_simplify.
Abort.

Definition yves_fib (n:nat) := let p := power mul2 id2 matfib2 n in
                               fst p + snd p.

Compute yves_fib 10.
Compute yves_fib 0.
Compute yves_fib 20.

Compute power mul2 id2 matfib2 4%nat.

*)


Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Proof.
 intros n m o. intros H. intros I. rewrite H. rewrite I. reflexivity. Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) : natural := plus Zero (Succ lf2).


Require Import Rsequence_def Rsequence_sums_facts Rsequence_rewrite_facts.
Require Import MyNat.
Require Import Rfunction_def.

Local Open Scope R_scope.

Definition D (f : R -> R) : R -> R := fun x => f (x + 1) - f x.
Definition Int (a b: nat) (f : R -> R) : R :=
  Rseq_sum (Rseq_shifts (fun n => f (INR n)) a) (b - a).

Lemma D_opp_compat : forall f, D (- f)%F == (- D f)%F.
Proof.
intros f x ; unfold D, opp_fct ; ring.
Qed.

Lemma D_plus_compat : forall f g, D (f + g)%F == (D f + D g)%F.
Proof.
intros f g x ; unfold D, plus_fct ; ring.
Qed.

Lemma D_minus_compat : forall f g, D (f - g)%F == (D f - D g)%F.
Proof.
intros f g x ; unfold D, minus_fct, Rminus ; ring.
Qed.

Lemma Int_D: forall a b f, (a <= b)%nat -> Int a b (D f) = f (INR b + 1) - f (INR a).
Proof.
intros a b ; revert a ; induction b ; intros a f altb.
 inversion altb ; reflexivity.
 unfold Int in * ; destruct a ; simpl minus.
  rewrite Rseq_sum_simpl ; rewrite (minus_n_O b), IHb ; [| apply le_0_n].
  unfold Rseq_shifts, D ; rewrite <- minus_n_O ; simpl plus ;
  rewrite S_INR ; ring.
  erewrite Rseq_sum_ext ; [| apply Rseq_shift_shifts] ;
  rewrite Rseq_sum_shift_compat.
  unfold Rseq_shift ; rewrite Rseq_sum_simpl, IHb ; unfold Rseq_shifts, D.
  rewrite minus_Sn_m, le_plus_minus_r, plus_0_r, S_INR, S_INR.
   ring.
   transitivity (S a) ; [apply le_n_Sn | assumption].
   apply le_S_n ; assumption.
   apply le_S_n ; assumption.
Qed.

Fixpoint Fp (n : nat) : R -> R := fun x =>
match n with
  | O   => 1
  | S m => (x - INR m) * Fp m x
end.

Lemma D_Fp_S_simpl : forall x n, D (Fp (S n)) x = INR (S n) * Fp n x.
Proof.
intros x n ; induction n.
 unfold D, Fp ; simpl ; ring.

 replace (INR(S(S n))) with (1+ INR(S n)) by (simpl; auto with *).
 rewrite Rmult_plus_distr_r; simpl Fp at 3.
 rewrite Rmult_comm with  (x - INR n) (Fp n x).
 rewrite <- Rmult_assoc.
 rewrite <- IHn.
 unfold D, Fp.
 replace (INR (S n)) with (1 + INR n) by (simpl; case n; auto with *).
 ring.
Qed.


Require Import UnivalentParametricity.theories.Basics UnivalentParametricity.theories.StdLib.Basics.
Require Import NatBinDefs.

Require Import BinNat.

Set Universe Polymorphism.

Definition nat := Datatypes.nat.
Definition S := Datatypes.S.

Record Monoid A :=
  Build_Monoid {
      mon_e : A;
      mon_m : A -> A -> A;
      mon_unitL : forall x, mon_m x mon_e = x;
      mon_unitR : forall x, mon_m mon_e x = x;
      mon_assoc : forall x y z, mon_m x (mon_m y z) = mon_m (mon_m x y) z
    }.

(* The fact that it is univalent can be almost automatically inferred
   using its equivalent presentation with dependent sums *)

Instance issig_monoid {A : Type} :
  { e:A & {m:A -> A -> A & {uL : forall x, m x e = x & { uR : forall x, m e x = x &
                                            forall x y z, m x (m y z) = m (m x y) z}}}}
  ≃ Monoid A.
Proof.
  issig (Build_Monoid A) (@mon_e A) (@mon_m A) (@mon_unitL A) (@mon_unitR A) (@mon_assoc A).
Defined.

Instance issig_monoid_inv {A : Type} :
  Monoid A ≃
         { e:A & {m:A -> A -> A & {uL : forall x, m x e = x & { uR : forall x, m e x = x &
                                                                               forall x y z, m x (m y z) = m (m x y) z}}}}
         := Equiv_inverse _.

Definition FP_Monoid : Monoid ≈ Monoid.
Proof.
  univ_param_record.
Defined.

#[export] Hint Extern 0 (Monoid ≈ Monoid) => exact (ur_type FP_Monoid) : typeclass_instances.

#[export] Hint Extern 0 (Monoid _ ≃ Monoid _) => unshelve refine (equiv (ur_type FP_Monoid _ _ _)) : typeclass_instances.

(* we define the monoid structure on N *)

Definition N_mon : Monoid N.
Proof.
  unshelve refine (Build_Monoid _ _ _ _ _ _).
  - exact N0.
  - exact N.add.
  - intro x. destruct x; reflexivity.
  - intro x. destruct x; reflexivity.
  - intros. cbn. apply logic_eq_is_eq. exact (N.add_assoc x y z).
Defined.

(* Then we can deduce automatically a monoid structure on nat *)

Definition n_mon : Monoid nat := ↑ N_mon.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.

(** The solution set condition. In Freyd's adjoint functor theorem
it is assumed that (Comma (Func_From_SingletonCat x) G) satisfies
solution set condition.

A category C satisfies solution set condition if there is a type A,
a function f : A → C such that for any object (c : C) there exists
a (t : A) such that there is a morphism h : (f t) –≻ c. In short,
f is jointly weakly initial.
*)
Record Solution_Set_Cond (C : Category) :=
  {
    SSC_Type : Type;
    SSC_Objs : SSC_Type → C;
    SSC_jointly_weakly_initial :>
      ∀ (c : C), {t : SSC_Type & ((SSC_Objs t) –≻ c)%morphism}
  }
.

Arguments SSC_Type {_} _.
Arguments SSC_Objs {_} _ _.
Arguments SSC_jointly_weakly_initial {_} _ _.

From Categories Require Import Limits.Limit Limits.GenProd_GenSum.
From Categories Require Import Functor.Functor.
From Categories Require Import NatTrans.NatTrans.
From Categories Require Import
        Basic_Cons.Terminal
        Basic_Cons.Equalizer
        Basic_Cons.Limits
        Basic_Cons.Facts.Equalizer_Monic
.
From Categories Require Import Archetypal.Discr.Discr.

(** We show that a category that is complete and satisfies solution
    set condition has an initial object. This initial object is the
    equalizer of all endo-morphisms d : W –≻ W,
    where W is the generalized product of the function (SSC_Objs) of
    the solution set condition. *)
Section Complete_SSC_Initial.
  Context
    {C : Category}
    (CC : Complete C)
    (SSC : Solution_Set_Cond C)
  .

  (** The product of objects producing SSC. *)
  Definition SSC_Prod : (Π (SSC_Objs SSC))%object
    :=
      (LimitOf (Discr_Func (SSC_Objs SSC))).

  (** SSC_Prod is weakly initial. I.e., it has an arrow (not necessarily unique)
to any other object. *)
  Definition SSC_Prod_WI (c : C) :
    (SSC_Prod –≻ c)%morphism
    :=
      (
        (projT2 (SSC_jointly_weakly_initial SSC c))
          ∘
          (
            Trans
              (cone_edge SSC_Prod)
              (projT1 (SSC_jointly_weakly_initial SSC c))
          )
      )%morphism
  .

  (** The constant function from endomorphisms of SSC_Prod that
returns SSC_Prod.  *)
  Definition endomorph_const (h : (SSC_Prod –≻ SSC_Prod)%morphism) : C
    :=
      SSC_Prod
  .

  (** The product of SSC_Prod with endomorphisms as index. *)
  Definition Endo_Prod : (Π endomorph_const)%object
    :=
      (LimitOf (Discr_Func endomorph_const)).

  (** Cone to (Discr_Func endomorph_const) that maps to ids. *)
  Program Definition Cone_Endo_Prod_ids : Cone (Discr_Func endomorph_const)
    :=
      {|
        cone_apex :=
          {|
            FO := fun _ => SSC_Prod;
            FA := fun _ _ _ => id
          |};
        cone_edge :=
          {|
            Trans := fun _ => id
          |}
      |}
  .

  (** Morphism that projects to ids. *)
  Definition morph_to_Endo_Prod_ids : (SSC_Prod –≻ Endo_Prod)%morphism
    :=
      Trans (LRKE_morph_ex Endo_Prod Cone_Endo_Prod_ids) tt.

  (** Cone to (Discr_Func endomorph_const) that maps to ids. *)
  Program Definition Cone_Endo_Prod_endomorphs :
    Cone (Discr_Func endomorph_const)
    :=
      {|
        cone_apex :=
          {|
            FO := fun _ => SSC_Prod;
            FA := fun _ _ _ => id
          |};
        cone_edge :=
          {|
            Trans := fun h => h
          |}
      |}
  .

  (** Morphism that projects to endomorphisms. *)
  Definition morph_to_Endo_Prod_endomorphs : (SSC_Prod –≻ Endo_Prod)%morphism
    :=
      Trans (LRKE_morph_ex Endo_Prod Cone_Endo_Prod_endomorphs) tt.

  Definition ids_endomorphs_equalizer :
    Equalizer
      morph_to_Endo_Prod_endomorphs
      morph_to_Endo_Prod_ids
    :=
      Equalizer_as_Limit
        morph_to_Endo_Prod_endomorphs
        morph_to_Endo_Prod_ids
        (LimitOf
           (Equalizer_Producing_Func
              morph_to_Endo_Prod_endomorphs
              morph_to_Endo_Prod_ids)
        )
  .

  (** ids_endomorphs_equalizer is weakly initial. I.e., it has an arrow
(not necessarily unique) to any other object. *)
  Definition ids_endomorphs_equalizer_WI (c : C) :
    (ids_endomorphs_equalizer –≻ c)%morphism
    :=
      (SSC_Prod_WI c ∘ equalizer_morph ids_endomorphs_equalizer)%morphism
  .

  (** composing any endomorphism after equalizer morphism of
      ids_endomorphs_equalizer is the same as the equalizer
      morphism of ids_endomorphs_equalizer.
*)
  Theorem ids_endomorphs_equalizer_morph_neutralizes_endomorphs
          (d : (SSC_Prod –≻ SSC_Prod)%morphism)
    :
      (d ∘ equalizer_morph ids_endomorphs_equalizer)%morphism
      = equalizer_morph ids_endomorphs_equalizer
  .
  Proof.
    assert (H :=
              f_equal
                (fun w => ((Trans Endo_Prod d) ∘ w)%morphism)
                (equalizer_morph_com ids_endomorphs_equalizer)
           ).
    cbn -[equalizer_morph ids_endomorphs_equalizer Endo_Prod] in H.
    unfold morph_to_Endo_Prod_endomorphs, morph_to_Endo_Prod_ids in H.
    repeat rewrite assoc_sym in H.
    assert (V :=
           f_equal
             (fun w :
                    ((Functor_Ops.Functor_compose
                        (Functor_To_1_Cat
                           (Discr_Cat (SSC_Prod –≻ SSC_Prod)%morphism))
                        Cone_Endo_Prod_endomorphs)
                       –≻ Discr_Func endomorph_const)%nattrans
              => Trans w d)
             (cone_morph_com
                (LRKE_morph_ex Endo_Prod Cone_Endo_Prod_endomorphs))
        ).
    cbn -[LRKE_morph_ex Endo_Prod] in V.
    rewrite From_Term_Cat in V.
    simpl_ids in V.
    rewrite <- V in H.
    clear V.
    assert (V :=
           f_equal
             (fun w :
                    ((Functor_Ops.Functor_compose
                       (Functor_To_1_Cat
                          (Discr_Cat (SSC_Prod –≻ SSC_Prod)%morphism))
                       Cone_Endo_Prod_ids)
                       –≻ Discr_Func endomorph_const)%nattrans
              => Trans w d)
             (cone_morph_com (LRKE_morph_ex Endo_Prod Cone_Endo_Prod_ids))
        ).
    cbn -[LRKE_morph_ex Endo_Prod] in V.
    rewrite From_Term_Cat in V.
    simpl_ids in V.
    rewrite <- V in H.
    clear V.
    auto.
  Qed.

  Section equalizer_of_morphs_from_ids_endomorphs_equalizer_iso.
    Context
      {d : C}
      (f g : (ids_endomorphs_equalizer –≻ d)%morphism)
    .

    (** Let's show ids_endomorphs_equalizer with V, we construct for any pair of
         morphisms f, g : V –≻ d, their equalizer (U, e : U –≻ V).
     *)
    Definition equalizer_of_morphs_from_ids_endomorphs_equalizer
      :
        Equalizer f g
      :=
        Equalizer_as_Limit
          f
          g
          (LimitOf (Equalizer_Producing_Func f g))
    .

    Theorem equalizer_of_morphs_from_ids_endomorphs_equalizer_iso_RI :
      ((equalizer_morph (equalizer_of_morphs_from_ids_endomorphs_equalizer))
         ∘
         ((SSC_Prod_WI _)
            ∘ (equalizer_morph ids_endomorphs_equalizer)))%morphism
      =
      id.
    Proof.
      apply (
          mono_morphism_monomorphic
            (@Equalizer_Monic _ _ _ _ _ ids_endomorphs_equalizer)
        ).
      rewrite id_unit_right.
      repeat rewrite assoc_sym.
      apply ids_endomorphs_equalizer_morph_neutralizes_endomorphs.
    Qed.

    Theorem equalizer_of_morphs_from_ids_endomorphs_equalizer_iso_LI :
      (((SSC_Prod_WI _) ∘ (equalizer_morph ids_endomorphs_equalizer))
         ∘
         (equalizer_morph (equalizer_of_morphs_from_ids_endomorphs_equalizer))
      )%morphism
      =
      id.
    Proof.
      apply (
          mono_morphism_monomorphic
            (@Equalizer_Monic _ _ _ _ _
                              equalizer_of_morphs_from_ids_endomorphs_equalizer)
        ).
      unfold Equalizer_Monic.
      cbn [mono_morphism].
      rewrite assoc_sym.
      simpl_ids.
      trivial.
      apply equalizer_of_morphs_from_ids_endomorphs_equalizer_iso_RI.
    Qed.

    (** Let's show ids_endomorphs_equalizer with V, then, for any pair of
        morphisms f, g : V –≻ d, we have their equalizer (U, e : U –≻ V)
        forms an isomorphism (U ≃ V).
     *)
    Program Definition equalizer_of_morphs_from_ids_endomorphs_equalizer_iso
      :
        ((equalizer_of_morphs_from_ids_endomorphs_equalizer)
           ≃ ids_endomorphs_equalizer)%isomorphism
      :=
        {|
          iso_morphism := equalizer_morph
                            (equalizer_of_morphs_from_ids_endomorphs_equalizer);
          inverse_morphism :=
            ((SSC_Prod_WI _)
               ∘ (equalizer_morph ids_endomorphs_equalizer))%morphism;
          left_inverse :=
            equalizer_of_morphs_from_ids_endomorphs_equalizer_iso_LI;
          right_inverse :=
            equalizer_of_morphs_from_ids_endomorphs_equalizer_iso_RI
        |}
    .

  End equalizer_of_morphs_from_ids_endomorphs_equalizer_iso.

  Local Obligation Tactic := idtac.

  Program Definition Complete_SSC_Initial : (𝟘_ C)%object
    :=
      {|
        terminal := ids_endomorphs_equalizer;
        t_morph := ids_endomorphs_equalizer_WI
      |}
  .

  Next Obligation.
  Proof.
    intros d f g.
    cbn -[ids_endomorphs_equalizer] in *.
    assert (H :=
              f_equal
                (fun w => (f ∘ w)%morphism)
                (equalizer_of_morphs_from_ids_endomorphs_equalizer_iso_RI f g)).
    cbn -[ids_endomorphs_equalizer
            equalizer_of_morphs_from_ids_endomorphs_equalizer] in H.
    simpl_ids in H.
    rewrite <- H.
    clear H.
    assert (H :=
              f_equal
                (fun w => (g ∘ w)%morphism)
                (equalizer_of_morphs_from_ids_endomorphs_equalizer_iso_RI f g)).
    cbn -[ids_endomorphs_equalizer
            equalizer_of_morphs_from_ids_endomorphs_equalizer] in H.
    simpl_ids in H.
    etransitivity; [|apply H].
    clear H.
    repeat rewrite assoc_sym.
    match goal with
      [|- (((f ∘ ?A) ∘ ?B) ∘ ?C = _)%morphism] =>
      apply (f_equal (fun w => ((w ∘ B) ∘ C)%morphism))
    end.
    apply (equalizer_morph_com
             (equalizer_of_morphs_from_ids_endomorphs_equalizer f g)).
  Qed.

End Complete_SSC_Initial.


(* Exercise 104 *)

Require Import BenB.

Variables A B C D : Prop.

(* de Morgan's conjunction law inverse variant *)

Theorem exercise_104 : (A \/ B) -> ~(~A /\ ~B).
Proof.
imp_i a1.
neg_i (1=1) a2.
dis_e (A \/ B) a3 a3.
hyp a1.
neg_e (A).
con_e1 (~B).
hyp a2.
hyp a3.
neg_e (B).
con_e2 (~A).
hyp a2.
hyp a3.
lin_solve.
Qed.


Require Import Arith.
Require Import List.

Fixpoint rcons {X : Type} (s : list X) (x : X) :=
  match s with
  | nil => x :: nil
  | y :: ys => y :: (rcons ys x)
  end.

Fixpoint timechart_elem {A : Type} (x0 : nat*A) (s : list (nat*A)) (t : nat) :=
  match s with
  | nil =>
    let (t', a) := x0 in (t, a)
  | x :: xs =>
    let (t', a) := x in
    if t <? t' then let (t0, a0) := x0 in (t,a0) else timechart_elem x xs t
  end.

Fixpoint timechart {A : Type} (x0 : nat*A) (s : list (nat*A)) (t : nat) :=
  match t with
  | S t' => rcons (timechart x0 s t') (timechart_elem x0 s t)
  | O => timechart_elem x0 s O :: nil
  end.


Require Import
  ssreflect ssrfun ssrbool eqtype ssrnat seq path choice fintype fingraph finfun
  bigop finset.

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

Section regular.

Variable (Sigma : finType).

Record DFA := {
  DFA_states    : finType ;
  DFA_start     : DFA_states ;
  DFA_accept    : {set DFA_states} ;
  DFA_delta     : {ffun DFA_states -> {ffun Sigma -> DFA_states}} }.

Record NFA := {
  NFA_states    : finType ;
  NFA_start     : NFA_states ;
  NFA_accept    : {set NFA_states} ;
  NFA_delta     : {ffun NFA_states -> {ffun Sigma -> {set NFA_states}}} }.

Record eNFA := {
  eNFA_states   : finType ;
  eNFA_start    : eNFA_states ;
  eNFA_accept   : {set eNFA_states} ;
  eNFA_epsilon  : {ffun eNFA_states -> {set eNFA_states}} ;
  eNFA_delta    : {ffun eNFA_states -> {ffun Sigma -> {set eNFA_states}}} }.

Inductive RE : Type :=
  | re_emptyset
  | re_singleton of Sigma
  | re_concat of RE & RE
  | re_union of RE & RE
  | re_star of RE.

Section DFA.

Variable (dfa dfa' : DFA).

Definition DFA_delta' (xs : seq Sigma) (q : DFA_states dfa) : DFA_states dfa :=
  foldl (fun_of_fin (DFA_delta dfa)) q xs.

Definition DFA_match (xs : seq Sigma) : bool :=
  DFA_delta' xs (DFA_start dfa) \in DFA_accept dfa.

Definition NFA_of_DFA : NFA :=
  Build_NFA
    (DFA_start dfa)
    (DFA_accept dfa)
    [ffun q => [ffun x => [set DFA_delta dfa q x]]].

Definition DFA_reverse : eNFA :=
  @Build_eNFA
    (option_finType (DFA_states dfa))
    None
    [set Some (DFA_start dfa)]
    [ffun q => if q is None then (@Some _) @: DFA_accept dfa else set0]
    [ffun q => [ffun x =>
      [set Some q' | q' in [pred q' | Some (DFA_delta dfa q' x) == q]]]].

Definition DFA_complement : DFA :=
  Build_DFA (DFA_start dfa) (~: DFA_accept dfa) (DFA_delta dfa).

Definition DFA_intersection : DFA :=
  @Build_DFA
    (prod_finType (DFA_states dfa) (DFA_states dfa'))
    (DFA_start dfa, DFA_start dfa')
    [set (q, q') | q in DFA_accept dfa, q' in DFA_accept dfa']
    [ffun q => [ffun x => (DFA_delta dfa q.1 x, DFA_delta dfa' q.2 x)]].

End DFA.

Section NFA.

Variable (nfa : NFA).

Definition NFA_delta'
  (xs : seq Sigma) (qs : {set NFA_states nfa}) : {set NFA_states nfa} :=
  @foldl _ {set NFA_states nfa}
    (fun qs' x => cover [set NFA_delta nfa q x | q in qs'])
    qs xs.

Definition NFA_match (xs : seq Sigma) : bool :=
  NFA_accept nfa :&: NFA_delta' xs [set NFA_start nfa] != set0.

Definition eNFA_of_NFA : eNFA :=
  Build_eNFA (NFA_start nfa) (NFA_accept nfa) [ffun q => set0] (NFA_delta nfa).

Definition subset_construction_next qs x :=
  cover [set NFA_delta nfa q x | q in pred_of_set qs].

Definition subset_construction_filter : pred {set NFA_states nfa} :=
  connect
    (fun q1 q2 => q2 \in [set subset_construction_next q1 x | x in Sigma])
    [set NFA_start nfa].

Lemma subset_construction_next_proof (qs : {set NFA_states nfa}) x :
  subset_construction_filter qs ->
  subset_construction_filter (subset_construction_next qs x).
Proof.
  case/connectP => path1 H H0; apply/connectP.
  exists (path1 ++ [:: subset_construction_next qs x]).
  - by rewrite cat_path H /= andbT -H0; apply/imsetP; exists x.
  - by rewrite last_cat.
Qed.

Definition DFA_of_NFA : DFA :=
  @Build_DFA
    [finType of {qs : {set NFA_states nfa} | subset_construction_filter qs}]
    (exist subset_construction_filter [set NFA_start nfa] (connect0 _ _))
    [set st | sval st :&: NFA_accept nfa != set0]
    [ffun qs => [ffun x => exist subset_construction_filter
     (subset_construction_next (sval qs) x)
     (subset_construction_next_proof _ (proj2_sig qs))]].

End NFA.

Section eNFA.

Variable (enfa : eNFA).

Definition eclose (q : eNFA_states enfa) : {set eNFA_states enfa} :=
  [set q' | connect (fun x y => y \in eNFA_epsilon enfa x) q q'].

Definition eNFA_delta'
  (xs : seq Sigma) (qs : {set eNFA_states enfa}) : {set eNFA_states enfa} :=
  @foldl _ {set eNFA_states enfa}
    (fun qs' x => cover (eclose @: cover [set eNFA_delta enfa q x | q in qs']))
    qs xs.

Definition eNFA_match (xs : seq Sigma) : bool :=
  eNFA_accept enfa :&: eNFA_delta' xs (eclose (eNFA_start enfa)) != set0.

Definition subset_construction_next' qs x :=
  cover (eclose @: cover [set eNFA_delta enfa q x | q in pred_of_set qs]).

Definition subset_construction_filter' : pred {set eNFA_states enfa} :=
  connect
    (fun q1 q2 : {set eNFA_states enfa} =>
      q2 \in (subset_construction_next' q1 @: setT))
    (cover (eclose @: [set eNFA_start enfa])).

Lemma subset_construction_next_proof' (qs : {set eNFA_states enfa}) x :
  subset_construction_filter' qs ->
  subset_construction_filter' (subset_construction_next' qs x).
Proof.
  case/connectP => path1 H H0; apply/connectP.
  exists (path1 ++ [:: subset_construction_next' qs x]).
  - by rewrite cat_path H /= andbT -H0; apply/imsetP; exists x.
  - by rewrite last_cat.
Qed.

Definition DFA_of_eNFA :=
  @Build_DFA
    [finType of {qs : {set eNFA_states enfa} | subset_construction_filter' qs}]
    (exist subset_construction_filter'
     (cover (eclose @: [set eNFA_start enfa])) (connect0 _ _))
    [set st | sval st :&: eNFA_accept enfa != set0]
    [ffun qs => [ffun x => exist subset_construction_filter'
     (subset_construction_next' (sval qs) x)
     (subset_construction_next_proof' _ (proj2_sig qs))]].

End eNFA.

Definition regular_language (P : seq Sigma -> Prop) : Prop :=
  exists dfa, forall xs, DFA_match dfa xs <-> P xs.

Lemma NFA_of_DFA_eq dfa xs q :
  [set @DFA_delta' dfa xs q] = @NFA_delta' (NFA_of_DFA dfa) xs [set q].
Proof.
  rewrite /NFA_of_DFA /NFA_delta' /DFA_delta' /=.
  elim: xs q => //= x xs IH q.
  rewrite IH; f_equal.
  apply setP => q'; rewrite inE cover_imset; apply/esym/bigcupP; case: ifP.
  - by move/eqP => -> {q'}; exists q; rewrite ?ffunE inE.
  - by move/eqP => H H0; apply: H; case: H0 => q''; rewrite inE;
      move/eqP => H; subst q''; rewrite !ffunE inE; move/eqP.
Qed.

Lemma DFA_reverse_correct dfa xs (qs : {set DFA_states dfa}) :
  @eNFA_delta' (DFA_reverse dfa) (rev xs) [set Some q | q in qs] =
  [set Some q | q in predT & @DFA_delta' dfa xs q \in qs].
Proof.
  rewrite /DFA_reverse /eNFA_delta' /DFA_delta' /=.
  elim: xs qs => /= [| x xs IH] qs.
  - apply setP => q; apply/imsetP; case: ifP.
    + by case/imsetP => q'; rewrite inE => H H0; subst q; exists q'.
    + by move/negP => H H0; apply: H; case: H0 => q' H H0; subst q;
        apply/imsetP; exists q' => //; rewrite inE.
  - rewrite rev_cons -cats1 foldl_cat /= {}IH cover_imset.
    apply setP => q; apply/bigcupP; case: ifP.
    + case/imsetP => q'; rewrite inE => H H0; subst q; exists (Some q').
      * rewrite cover_imset; apply/bigcupP; exists (Some (DFA_delta dfa q' x)).
        - by apply/imsetP; exists (DFA_delta dfa q' x) => //; rewrite inE.
        - by rewrite !ffunE; apply/imsetP; exists q' => //; rewrite inE.
      * by rewrite /eclose /= inE connect0.
    + move/negP => H H0; apply: H; case: H0 => q'; rewrite cover_imset;
        case/bigcupP => q''; rewrite !ffunE; case/imsetP => q''';
        rewrite inE => H H0; subst q''; case/imsetP => q''; rewrite inE;
        case/eqP => H0 H1; subst q''' q'; rewrite /eclose /= inE;
        case/connectP; case; last by move => ? ? /=; rewrite ffunE inE.
      by move => /= _ H0; subst q; apply/imsetP; exists q'' => //; rewrite inE.
Qed.

Lemma DFA_complement_correct dfa xs :
  DFA_match dfa xs != DFA_match (DFA_complement dfa) xs.
Proof. by rewrite /DFA_match /DFA_complement negb_eqb inE addbN addbb. Qed.

Lemma DFA_intersection_correct dfa dfa' xs :
  DFA_match dfa xs && DFA_match dfa' xs =
  DFA_match (DFA_intersection dfa dfa') xs.
Proof.
  rewrite /DFA_intersection /DFA_match /DFA_delta' /=.
  elim: xs (DFA_start dfa) (DFA_start dfa') => /=.
  - move => q q'; apply/esym/imset2P; case: ifP.
    + by case/andP => H H0; apply: (Imset2spec H H0 erefl).
    + by move/negP => H H0; apply: H;
        case: H0 => q'' q''' H H0 [H1 H2]; subst; rewrite H H0.
  - by move => x xs IH qs qs'; rewrite !ffunE /= -IH.
Qed.

Lemma eNFA_of_NFA_eq nfa xs qs :
  @NFA_delta' nfa xs qs = @eNFA_delta' (eNFA_of_NFA nfa) xs qs.
Proof.
  elim: xs qs => //= x xs IH qs; rewrite {}IH; f_equal.
  apply/esym/setP; rewrite cover_imset => q; apply/bigcupP; case: ifP.
  - by move => H; exists q => //; rewrite /eclose /= inE connect0.
  - move/negP => H H0; apply: H; case: H0 => q' H; rewrite /eclose /= inE;
      case/connectP; case; last by move => ? ? /=; rewrite ffunE inE.
    by move => /= _ H0; subst q'.
Qed.

Lemma DFA_of_NFA_eq nfa xs (qs : {qs | subset_construction_filter qs}) :
  @NFA_delta' nfa xs (sval qs) = sval (@DFA_delta' (DFA_of_NFA nfa) xs qs).
Proof. by elim: xs qs => //= x xs IH [qs H] /=; rewrite !ffunE /= -IH. Qed.

Lemma DFA_of_eNFA_eq enfa xs (qs : {qs | subset_construction_filter' qs}) :
  @eNFA_delta' enfa xs (sval qs) = sval (@DFA_delta' (DFA_of_eNFA enfa) xs qs).
Proof. by elim: xs qs => //= x xs IH [qs H] /=; rewrite !ffunE /= -IH /=. Qed.

Definition DFA_minimization dfa : DFA :=
  DFA_of_eNFA (DFA_reverse (DFA_of_eNFA (DFA_reverse dfa))).

End regular.


(*******************************************************************)
(*  This is part of RelationAlgebra, it is distributed under the   *)
(*    terms of the GNU Lesser General Public License version 3     *)
(*              (see file LICENSE for more details)                *)
(*                                                                 *)
(*  Copyright 2012: Damien Pous. (CNRS, LIP - ENS Lyon, UMR 5668)  *)
(*******************************************************************)

(** * ugregex_dec: simple decision procedure for untyped generalised regular expressions *)

(** We implement a rather basic algorithm consisting in trying to
   build a bisimulation on-the-fly, using partial derivatives.

   We prove the correctness of this algorithm, but not completeness
   ("it merely let you sleep better" according to Krauss and Nipkow).

   This very simple algorithm seems to be sufficient for reasonable
   expressions; we plan to improve it to be able to handle larger
   ones. *)

Require Import lset kat positives sums glang boolean comparisons powerfix.
Require Export ugregex.
Set Implicit Arguments.

Section l.
Variable Pred: nat.
Notation Sigma := positive.
Notation Atom := (ord (pow2 Pred)).
Notation tt := ugregex_tt.
Notation ugregex := (ugregex_monoid_ops Pred tt tt).
Notation uglang := (glang_kat_ops Pred Sigma traces_tt traces_tt).
Notation lang := (@lang Pred).

Ltac fold_ugregex_type := change (@ugregex.ugregex Pred) with (@car ugregex) in *.
Ltac fold_ugregex := ra_fold ugregex_monoid_ops tt; fold_ugregex_type.

(** * Partial derivatives *)

(** reversed product *)
Notation tod e := (fun f => u_dot f e) (only parsing).

(** [pderiv a i e] returns the set of partial derivatives of [e] along
   transition [(a,i)] (since we work with KAT regular expressions,
   labels are composed of an atom together with a letter) *)
Fixpoint pderiv a i (e: ugregex): list ugregex :=
  match e with
    | u_prd _ => []
    | u_var _ j => if eqb_pos i j then [u_one _] else []
    | u_pls e f => union (pderiv a i e) (pderiv a i f)
    | u_dot e f =>
        if epsilon a e then union (map (tod f) (pderiv a i e)) (pderiv a i f)
        else map (tod f) (pderiv a i e)
    | u_itr e => map (tod (u_str e)) (pderiv a i e)
  end.

(** [epsilon] was defined in [ugregex],
   we now to extend both notions to sets of expressions, homomorphically: *)

Definition epsilon' a (l: list ugregex): bool :=
  fold_right (fun e b => b ||| epsilon a e) false l.

Definition pderiv' a i (l: list ugregex): list ugregex :=
  fold_right (fun e => union (pderiv a i e)) [] l.

(** specification of [epsilon'] *)
Lemma epsilon'_eq a l: epsilon a (sup id l) == epsilon' a l.
Proof.
  induction l. reflexivity. simpl.
  rewrite <- IHl. unfold id.
  rewrite <-2Bool.orb_lazy_alt. apply Bool.orb_comm.
Qed.

(** correctness of partial derivatives *)
Lemma deriv_eq a i e: deriv a i e == sup id (pderiv (set.mem a) i e).
Proof.
  induction e; simpl; fold_ugregex.
   case eqb_pos. 2: reflexivity. now rewrite sup_singleton.
   reflexivity.
   rewrite union_app, sup_app. now apply cup_weq.
   assert (H: deriv a i e1 * e2 == sup id (map (tod e2) (pderiv (set.mem a) i e1))).
    rewrite sup_map. setoid_rewrite <-(dotsumx (X:=ugregex_monoid_ops _)).
    now apply dot_weq.
   case epsilon.
    rewrite union_app, sup_app.
    setoid_rewrite dot1x. now apply cup_weq.
    setoid_rewrite dot0x. now rewrite cupxb.
   rewrite sup_map. setoid_rewrite <-(dotsumx (X:=ugregex_monoid_ops _)).
    now apply dot_weq.
Qed.

Lemma deriv'_eq a i l: deriv a i (sup id l) == sup id (pderiv' (set.mem a) i l).
Proof.
  induction l. reflexivity. simpl (sup _ _).
  rewrite union_app, sup_app.
  apply cup_weq. apply deriv_eq. assumption.
Qed.

(** Kleene variables of an expression *)
Fixpoint vars (e: ugregex) : list _ :=
  match e with
    | u_prd _ => []
    | u_var _ i => [i]
    | u_pls e f | u_dot e f => union (vars e) (vars f)
    | u_itr e => vars e
  end.

(** partial derivatives do not increase the set of Kleene variables *)
Lemma deriv_vars a i (e: ugregex): \sup_(x\in pderiv a i e) vars x <== vars e.
Proof.
  induction e; simpl pderiv; simpl vars.
   case eqb_pos; apply leq_bx.
   apply leq_bx.
   rewrite 2union_app, sup_app. now apply cup_leq.
   setoid_rewrite union_app at 2.
   assert (H: \sup_(x\in map (tod e2) (pderiv a i e1)) vars x <== vars e1 ++ vars e2).
    rewrite sup_map. simpl vars. setoid_rewrite union_app. rewrite supcup.
    apply cup_leq. assumption. now apply leq_supx.
   case epsilon. rewrite union_app, sup_app, H. hlattice. assumption.
   rewrite sup_map. simpl vars. setoid_rewrite union_app. rewrite supcup.
    apply leq_cupx. assumption. now apply leq_supx.
Qed.

Lemma deriv'_vars a i l: \sup_(x\in pderiv' a i l) vars x <== sup vars l.
Proof.
  induction l. reflexivity. setoid_rewrite union_app. rewrite sup_app.
  apply cup_leq. apply deriv_vars. assumption.
Qed.

(** deriving an expression w.r.t. a letter it does not contain necessarily gives [0] *)
Lemma deriv_out a i e I: vars e <== I -> ~In i I -> deriv a i e == 0.
Proof.
  intros He Hi. induction e; simpl deriv; simpl vars in He; fold_ugregex.
   case eqb_spec. 2: reflexivity. intros <-. apply Hi in He as []. now left.
   reflexivity.
   rewrite union_app in He.
    rewrite IHe1, IHe2 by (rewrite <-He; lattice). apply cupI.
   rewrite union_app in He.
    rewrite IHe1, IHe2 by (rewrite <-He; lattice). rewrite dot0x, dotx0. apply cupI.
   rewrite IHe by assumption. apply dot0x.
Qed.

(** we need binary relations on sets of expressions, we represent them
   as lists of pairs (this could easily be optimised) *)
Definition rel_mem (p: list ugregex * list ugregex) := existsb (eqb p).
Notation rel_insert p rel := (p::rel).
Notation rel_empty := [].
(* OPT *)
(* Definition rel_mem := trees.mem (pair_compare (list_compare compare)).  *)
(* Definition rel_insert := trees.insert (pair_compare (list_compare compare)).  *)
(* Notation rel_empty := (@trees.L _) *)

Lemma rel_mem_spec p rel: reflect (In p rel) (rel_mem p rel).
Proof.
  induction rel. constructor. tauto.
  simpl rel_mem. case eqb_spec.
  intros <-. constructor. now left.
  case IHrel; constructor. now right. intros [?|?]; congruence.
Qed.

(** * Main loop for the on-the-fly bisimulation algorithm *)

(** [epsilon'] and [deriv'] provide us with a (generalised) DFA whose
   states are sets of generalised expressions ([list ugregex]). We
   simply try compute bisimulations in this DFA. *)

Section a.

(** we assume a set of Kleene variable, and a set of atoms; the
   following algorithm tries to compute bisimulations w.r.t. those
   sets. *)
Variable I: list positive.
Variable A: list (ord Pred -> bool).

Definition obind X Y (f: X -> option Y) (x: option X): option Y :=
  match x with Some x => f x | _ => None end.

Fixpoint ofold X Y (f: X -> Y -> option Y) (l: list X) (y: Y): option Y :=
  match l with
    | [] => Some y
    | x::q => obind (f x) (ofold f q y)
  end.

(** [loop_aux e f a todo] checks the accepting status of [e] and [f] along [a],
   - if a mismatch is found, we can stop (a counter example has bee found)
   - otherwise, it inserts all derivatives of the pair [(e,f)] along [{a}*I] into [todo] *)
Definition loop_aux e f :=
  fun a todo =>
    if eqb_bool (epsilon' a e) (epsilon' a f)
    then Some (fold_right (fun i => cons (pderiv' a i e, pderiv' a i f)) todo I)
    else None.

(** [ofold (loop_aux e f) A todo] does the same, for all [a\in A] *)

(** [loop n rel todo] is the main loop of the algorithm:
   it tries to prove that all pairs in [todo] are bisimilar, assuming
   that those in [rel] are bisimilar.
   - if a pair of [todo] was already in [rel], it can be skipped;
   - otherwise, its accepting status is checked, all derivatives are
     inserted in [todo], and the pair is added to [rel]
   The number of iterations is bounded by [2^n], using the [powerfix] operator. *)
Definition loop n := powerfix n (fun loop rel todo =>
  match todo with
    | [] => Some true
    | (e,f)::todo =>
      if rel_mem (e,f) rel then loop rel todo else
        match ofold (loop_aux e f) A todo with
          | Some todo => loop (rel_insert (e,f) rel) todo
          | None => Some false
        end
    end
) (fun _ _ => None).

(** * Correctness of the main loop *)

(** [prog] is a predicate on binary relations:

   [prog rel (rel++todo)] is the invariant of the main loop *)

Definition prog R S :=
  forall e f, In (e,f) R -> sup vars (e++f) <== I /\
    forall a, In a A -> epsilon' a e = epsilon' a f /\
      forall i, In i I -> In (pderiv' a i e, pderiv' a i f) S.

Lemma prog_cup_x R R' S: prog R S -> prog R' S -> prog (R++R') S.
Proof. intros H H' e f Hef. apply in_app_iff in Hef as [?|?]. now apply H. now apply H'. Qed.

Lemma prog_x_leq R S S': prog R S -> S <== S' -> prog R S'.
Proof.
  intros H H' e f Hef. apply H in Hef as [? Hef].
  split. assumption. split. now apply Hef. intros. now apply H', Hef.
Qed.

Definition below_I todo := forall e f, In (e,f) todo -> sup vars (e++f) <== I.

(** specification of the inner loop *)

Lemma loop_aux_spec e f a todo todo':
  below_I ((e,f)::todo) ->
  loop_aux e f a todo = Some todo' ->
  epsilon' a e = epsilon' a f /\
  todo <== todo' /\
  below_I todo' /\
  forall i, In i I -> In (pderiv' a i e, pderiv' a i f) todo'.
Proof.
  unfold loop_aux. case eqb_bool_spec. 2: discriminate. intros Heps Hvars E.
  split. assumption. injection E. clear E Heps. revert todo'.
  induction I as [|i J IH]; simpl fold_right; intro todo'.
   intros <-. split. reflexivity. split. intros ? ? ?. apply Hvars; now right. intros _ [].
   intro E. destruct todo' as [|p todo']. discriminate.
   injection E. intros H <-. clear E. apply IH in H as [H1 [H2 H3]]. clear IH.
   split. fold_cons. rewrite <- H1. lattice.
   split. intros ? ? [E|H].
    injection E; intros <- <-. rewrite sup_app, 2deriv'_vars, <-sup_app. apply Hvars. now left.
    now apply H2.
   intros b [<-|Hb]. now left. right. now apply H3.
Qed.

Lemma fold_loop_aux_spec e f todo: forall todo',
  below_I ((e,f)::todo) ->
  ofold (loop_aux e f) A todo = Some todo' ->
  todo <== todo' /\
  below_I todo' /\
  forall a, In a A -> epsilon' a e = epsilon' a f /\
  forall i, In i I -> In (pderiv' a i e, pderiv' a i f) todo'.
Proof.
  induction A as [|b B IH]; simpl ofold; intros todo'.
   intros Hvars H. injection H. intros <-. split. reflexivity.
   split. intros ? ? ?. apply Hvars. now right. intros _ [].
  unfold obind. fold_ugregex_type. case_eq (ofold (X:=ord Pred -> bool) (loop_aux e f) B todo).
   2: discriminate.
  intros todo'' Htodo'' Hvars Htodo'.
  apply IH in Htodo'' as [Htodo''_leq [Hvars' Htodo'']]. 2: assumption. clear IH.
  apply loop_aux_spec in Htodo' as (Heps&Htodo'_leq&Hvars''&Htodo').
  split. etransitivity; eassumption.
  split. assumption.
  intros a [<-|Ha]. now split.
  apply Htodo'' in Ha as [Haeps Ha]. split. assumption.
  intros. now apply Htodo'_leq, Ha.
  intros ? ? [E|?]. injection E; intros <- <-. apply Hvars; now left. now apply Hvars'.
Qed.

Lemma In_cons X (a: X) l: In a l -> [a]++l <== l.
Proof. now intros ? ? [<-|?]. Qed.

(** specification of the outer loop *)

Lemma prog_loop n: forall rel todo,
  loop n rel todo = Some true ->
  prog rel (rel++todo) ->
  below_I todo ->
  exists rel', rel++todo <== rel' /\ prog rel' rel'.
Proof.
  (* TODO: use powerfix_invariant *)
  unfold loop. rewrite powerfix_linearfix. generalize (pow2 n). clear n. intro n.
  induction n; intros rel todo Hloop Hrel Hvars. discriminate.
  simpl in Hloop. destruct todo as [|[e f] todo].
   exists rel. split. now rewrite <- app_nil_end. now rewrite <-app_nil_end in Hrel.
   revert Hloop. case rel_mem_spec.
   intros Hef Hloop. apply IHn in Hloop as (rel'&H1&H2).
    eexists. split. 2: eassumption.
     rewrite <- H1. rewrite <-(In_cons Hef) at 2. fold_cons. lattice.
    eapply prog_x_leq. apply Hrel.
     rewrite <-(In_cons Hef) at 2. fold_cons. lattice.
    intros ? ? ?. apply Hvars. now right.
   intros _. fold_ugregex_type. case_eq (ofold (X:=ord Pred -> bool) (loop_aux e f) A todo).
    2: discriminate.
   intros todo' Htodo' Hloop.
   apply fold_loop_aux_spec in Htodo' as [Htodo' [Hvars' Hef]]. 2: assumption.
   destruct (IHn _ _ Hloop) as (rel'&Hrel'&Hrel''). 2: assumption.
   clear - Hef Hvars Hvars' Hrel Htodo'.
   apply (@prog_cup_x [_]). eapply prog_x_leq.
    intros ? ? [E|[]]. injection E; intros <- <-; clear E.
    split. apply Hvars. now left. apply Hef. lattice.
   eapply prog_x_leq. apply Hrel. rewrite <- Htodo'. fold_cons. lattice.
   eexists. split. 2: eassumption. rewrite <-Hrel', <-Htodo'. fold_cons. lattice.
Qed.

End a.

Existing Instance lang'_weq.

(** correctness of the bisimulation proof method, at the abstract level *)

Lemma prog_correct I l rel:
  (forall a, In (set.mem a) l) ->
  prog I l rel rel -> below_I I rel ->
  forall e f, In (e,f) rel -> sup lang e == sup lang f.
Proof.
  intros Hl Hrel Hvars e f Hef.
  rewrite <-2lang_sup, 2lang_lang'.
  intro w. revert e f Hef. induction w; simpl lang'; intros e f Hef.
  - apply Hrel in Hef as [_ Hef].
    rewrite 2epsilon'_eq. destruct (Hef _ (Hl a)) as [-> _]. reflexivity.
  - destruct (fun H => In_dec H i I) as [Hi|Hi]. decide equality.
    etransitivity. apply lang'_weq. apply deriv'_eq.
    etransitivity. 2: apply lang'_weq; symmetry; apply deriv'_eq.
    apply IHw. apply Hrel. assumption. apply Hl. assumption.
    clear IHw. revert w. apply lang'_weq. rewrite 2deriv_sup.
    rewrite 2sup_b. reflexivity.
     intros f' Hf. eapply deriv_out. 2: eassumption.
      etransitivity. 2: apply Hvars. 2: apply Hef. apply leq_xsup. apply in_app_iff. now right.
     intros e' He. eapply deriv_out. 2: eassumption.
      etransitivity. 2: apply Hvars. 2: apply Hef. apply leq_xsup. apply in_app_iff. now left.
Qed.

(** * Final algorithm, correctness *)

(** the final algorithm is obtained by callign the main loop with
   appropriate arguments *)

Definition eqb_kat (e f: ugregex) :=
  let atoms := map (@set.mem _) (seq _) in
  let vars := vars (e+f) in
    loop vars atoms 1000 rel_empty [([e],[f])]%list.
(* stated as this, the algorithm is not complete: we would need to
   replace 1000 with the size of [e+f]... bzzz *)

(** correctness of the algorithm *)

Theorem eqb_kat_correct e f: eqb_kat e f = Some true -> e == f.
Proof.
  unfold eqb_kat. intro H. apply prog_loop in H as [rel [Hef Hrel]].
  2: intros _ _ [].
  2: simpl vars; intros ? ? [E|[]]; injection E; intros <- <-;
      rewrite union_app, sup_app, 2sup_singleton; reflexivity.
  eapply prog_correct in Hrel.
   2: intro; apply in_map, in_seq.
   3: apply Hef; now left.
  rewrite 2sup_singleton in Hrel. assumption.
  intros ? ? ?. now apply Hrel.
Qed.

End l.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool eqtype ssrfun ssrnat.
Require Import Reals Fourier.
Require Import Reals_ext Ranalysis_ext Rssr.

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

Local Open Scope R_scope.

Lemma ln_2_pos : 0 < ln 2.
Proof. rewrite -ln_1; apply ln_increasing; fourier. Qed.

Lemma ln_2_neq0 : ln 2 <> 0.
Proof. by apply nesym, Rlt_not_eq, ln_2_pos. Qed.

Lemma ln_increasing_le a b : 0 < a -> a <= b -> ln a <= ln b.
Proof.
move=> Ha.
case/Rle_lt_or_eq_dec; last by move=> ->; apply Rle_refl.
move/(ln_increasing _ _ Ha)/Rlt_le => a_b //.
Qed.

Lemma exp_le_inv x y : exp x <= exp y -> x <= y.
Proof.
case/Rle_lt_or_eq_dec; [move/exp_lt_inv => ?; by apply Rlt_le |
  move/exp_inv => ->; by apply Rle_refl].
Qed.

Lemma exp_pow n : forall k, exp (INR k * n) = (exp n) ^ k.
Proof.
elim => [|k IH].
by rewrite Rmult_0_l exp_0.
by rewrite S_INR mulRDl mul1R exp_plus IH mulRC.
Qed.

(** * Log base 2 *)

(* NB: log is 0 for input < 0 *)
Definition log x := ln x / ln 2.

Lemma log_1 : log 1 = 0.
Proof. by rewrite /log ln_1 /Rdiv Rmult_0_l. Qed.

Lemma log_2 : log 2 = 1.
Proof. rewrite /log /Rdiv -Rinv_r_sym //; by apply ln_2_neq0. Qed.

Lemma log_exp1_Rle_0 : 0 <= log (exp 1).
Proof. rewrite /log ln_exp /Rdiv ; apply Rle_mult_inv_pos ; [fourier | apply ln_2_pos]. Qed.

Lemma log_mult x y : 0 < x -> 0 < y -> log (x * y) = log x + log y.
Proof. move=> *; rewrite /log ln_mult //; field; by apply ln_2_neq0. Qed.

Lemma log_Rinv x : 0 < x -> log (/ x) = - log x.
Proof. move=> ?; rewrite /log ln_Rinv //; field; by apply ln_2_neq0. Qed.

Lemma log_increasing_le a b : 0 < a -> a <= b -> log a <= log b.
Proof.
move=> Ha.
case/Rle_lt_or_eq_dec; last by move=> ->; apply Rle_refl.
move/(ln_increasing _ _ Ha)/Rlt_le => a_b.
apply Rmult_le_compat_r => //; by apply Rlt_le, Rinv_0_lt_compat, ln_2_pos.
Qed.

Lemma log_increasing a b : 0 < a -> a < b -> log a < log b.
Proof.
move=> Ha a_b.
rewrite /log.
apply Rmult_lt_compat_r; last by apply ln_increasing.
by apply Rinv_0_lt_compat, ln_2_pos.
Qed.

Lemma log_inv x y : 0 < x -> 0 < y -> log x = log y -> x = y.
Proof.
move=> Hx Hy.
rewrite /log /Rdiv => H.
apply Rmult_eq_reg_r in H.
by apply ln_inv in H.
by apply Rinv_neq_0_compat, ln_2_neq0.
Qed.

Lemma log_lt_inv x y : 0 < x -> 0 < y -> log x < log y -> x < y.
Proof.
move=> Hx Hy.
rewrite /log /Rdiv.
have H : 0 < / ln 2 by apply Rinv_0_lt_compat, ln_2_pos.
move/(Rmult_lt_reg_r _ _ _ H) => {H}?.
by apply ln_lt_inv.
Qed.

Lemma log_le_inv x y : 0 < x -> 0 < y -> log x <= log y -> x <= y.
Proof.
move=> Hx Hy.
case/Rle_lt_or_eq_dec; first by by move/(log_lt_inv Hx Hy)/Rlt_le.
move/(log_inv Hx Hy) => ->; by apply Rle_refl.
Qed.

Lemma derivable_pt_log : forall x : R, 0 < x -> derivable_pt log x.
move=> x Hx.
rewrite /log.
rewrite /Rdiv.
apply derivable_pt_mult.
by apply derivable_pt_ln.
apply derivable_pt_const.
Defined.

Lemma derive_pt_log
     : forall (a : R) (Ha : 0 < a), derive_pt log a (derivable_pt_log Ha) = / a * / ln 2.
move=> a Ha.
rewrite /log.
rewrite /Rdiv.
rewrite derive_pt_mult.
rewrite derive_pt_const.
rewrite derive_pt_ln.
rewrite Rmult_0_r Rplus_0_r.
reflexivity.
Defined.

(** * 2 ^ x *)

Definition exp2 (x : R) := exp (x * ln 2).

Lemma exp2_pos x : 0 < exp2 x.
Proof. rewrite /exp2; by apply exp_pos. Qed.

Lemma exp2_not_0 l : exp2 l <> 0.
Proof. apply not_eq_sym, Rlt_not_eq ; exact (exp2_pos l). Qed.

Lemma exp2_0 : exp2 0 = 1.
Proof. by rewrite /exp2 Rmult_0_l exp_0. Qed.

Lemma exp2_plus x y : exp2 (x + y) = exp2 x * exp2 y.
Proof. by rewrite /exp2 mulRDl exp_plus. Qed.

Lemma exp2_pow2 : forall m, exp2 (INR m) = INR (expn 2 m).
Proof.
elim => [|m IH]; first by rewrite /exp2 Rmult_0_l exp_0.
rewrite S_INR exp2_plus expnS mult_INR IH /exp2 Rmult_1_l exp_ln; [by rewrite mulRC | fourier].
Qed.

Lemma exp2_pow n k : exp2 (INR k * n) = (exp2 n) ^ k.
Proof. by rewrite /exp2 -mulRA exp_pow. Qed.

Lemma exp2_Ropp x : exp2 (- x) = / exp2 x.
Proof. by rewrite /exp2 Ropp_mult_distr_l_reverse exp_Ropp. Qed.

Lemma exp2_le_inv x y : exp2 x <= exp2 y -> x <= y.
Proof.
rewrite /exp2 => HH.
apply Rmult_le_reg_l with (ln 2).
by apply ln_2_pos.
apply exp_le_inv in HH.
by rewrite mulRC -(mulRC y).
Qed.

Lemma exp2_increasing x y : x < y -> exp2 x < exp2 y.
Proof.
move=> x_y.
rewrite /exp2.
apply exp_increasing, Rmult_lt_compat_r => //.
by apply ln_2_pos.
Qed.

Lemma exp2_le_increasing x y : x <= y -> exp2 x <= exp2 y.
Proof.
case/Rle_lt_or_eq_dec.
move/exp2_increasing => x_y; by apply Rlt_le.
move=> ->; by apply Rle_refl.
Qed.

Lemma exp2_log x : 0 < x -> exp2 (log x) = x.
Proof.
move=> Hx.
rewrite /exp2 /log /Rdiv mulRC mulRA Rinv_r_simpl_m.
by rewrite exp_ln.
by apply ln_2_neq0.
Qed.

Lemma log_exp2 x : log (exp2 x) = x.
Proof.
rewrite /log /exp2 ln_exp /Rdiv -mulRA mulRC Rinv_r_simpl_r //.
by apply ln_2_neq0.
Qed.

Local Open Scope Rb_scope.

Lemma Rle_exp2_log1_L a b : 0 < b -> exp2 a <b= b = (a <b= log b).
Proof.
move=> Hb; move H1 : (_ <b= _ ) => [|] /=.
- move/RleP in H1.
  have {H1}H1 : a <= log b.
    rewrite (_ : a = log (exp2 a)); last by rewrite log_exp2.
    apply log_increasing_le => //; by apply exp2_pos.
  move/RleP in H1; by rewrite H1.
- move H2 : (_ <b= _ ) => [|] //=.
  move/RleP in H2.
  rewrite -(log_exp2 a) in H2.
  apply log_le_inv in H2 => //; last by apply exp2_pos.
  move/RleP in H2.
  by rewrite H2 in H1.
Qed.

Lemma Rle_exp2_log2_R b c : 0 < b -> b <b= exp2 c = (log b <b= c).
Proof.
move=> Hb; move H1 : (_ <b= _ ) => [|] /=.
- move/RleP in H1.
  have {H1}H1 : log b <= c.
    rewrite (_ : c = log (exp2 c)); last by rewrite log_exp2.
    apply log_increasing_le => //; by apply exp2_pos.
  by move/RleP in H1.
- move H2 : (_ <b= _ ) => [|] //=.
  move/RleP in H2.
  rewrite -(log_exp2 c) in H2.
  apply log_le_inv in H2 => //; last by apply exp2_pos.
  move/RleP in H2.
  by rewrite H2 in H1.
Qed.

Lemma Rle2_exp2_log a b c : 0 < b ->
  exp2 a <b= b <b= exp2 c = (a <b= log b <b= c).
Proof.
move=> Hb; move H1 : (_ <b= _ ) => [|] /=.
- rewrite Rle_exp2_log1_L // in H1.
  by rewrite H1 /= Rle_exp2_log2_R.
- move H2 : (_ <b= _ ) => [|] //=.
  rewrite -Rle_exp2_log1_L // in H2.
  by rewrite H2 in H1.
Qed.

Lemma exists_frac_part (P : nat -> Prop) : (exists n, P n) ->
  forall num den, (0 < num)%nat -> (0 < den)%nat ->
  (forall n m, (n <= m)%nat -> P n -> P m) ->
  exists n, P n /\
    frac_part (exp2 (INR n * (log (INR num) / INR den))) = 0.
Proof.
case=> n Pn num den Hden HP.
exists (n * den)%nat.
split.
  apply H with n => //.
  by rewrite -{1}(muln1 n) leq_mul2l HP orbC.
rewrite mult_INR -mulRA (mulRA (INR den)) Rinv_r_simpl_m; last first.
  apply not_0_INR.
  move=> ?; by subst den.
rewrite exp2_pow exp2_log; last first.
  apply lt_0_INR.
  by apply/ltP.
by apply frac_part_pow, frac_part_INR.
Qed.