Require Import Containers.MapInterface.
Require Import Containers.OrderedTypeEx Min.

Module RawBag.
  Section WithMap.
    Context `{A_OT: OrderedType A}.
    Context `{A_Map: @FMap A A_OT}.
    Open Scope map_scope.

    SubClass bag := Map[A, nat].
    Definition Mult (x : A) (b : bag) :=
      match b[x] with
        | None => O
        | Some n => n
      end.

    Definition empty : bag := [].
    Definition is_empty (b : bag) := MapInterface.is_empty b.
    Definition mem (x : A) (b : bag) :=
      match b[x] with
        | Some (S _) => true
        | _ => false
      end.

    Definition add (x : A) (b : bag) :=
      insert x 1 S b.
    Definition singleton (x : A) : bag :=
      [][x <- 1].
    Definition remove (x : A) (b : bag) :=
      match b[x] with
        | None => b
        | Some n =>
          match n with
            | 0 | 1 => MapInterface.remove x b
            | S p => b[x <- p]
          end
      end.
    Definition union (b b' : bag) : bag :=
      map2 (fun xo yo =>
        match xo, yo with
          | None, None => None
          | Some p, Some q => Some (p + q)
          | Some p, None => Some p
          | None, Some q => Some q
        end) b b'.
    Definition inter (b b' : bag) : bag :=
      map2 (fun xo yo =>
        match xo, yo with
          | Some p, Some q => Some (min p q)
          | _, _ => None
        end) b b'.
    Definition diff (b b' : bag) : bag :=
      map2 (fun xo yo =>
        match xo, yo with
          | Some p, Some q =>
            match p - q with
              | O => None
              | k => Some k
            end
          | Some p, None => Some p
          | None, _ => None
        end) b b'.

    Definition equal (b b' : bag) :=
      MapInterface.equal (fun n n' => n == n') b b'.
    Definition subbag (b b' : bag) :=
      MapInterface.fold (fun x n (r : bool) =>
        if r then Mult x b' << n else false) b true.

    Definition fold {B : Type} (f : A -> nat -> B -> B) (b : bag) (i : B) :=
      MapInterface.fold f b i.
    Definition for_all (f : A -> bool) (b : bag) :=
      MapInterface.fold (fun x _ (r : bool) =>
        if r then f x else false) b true.
    Definition exists_ (f : A -> bool) (b : bag) :=
      MapInterface.fold (fun x _ (r : bool) =>
        if r then true else f x) b false.
    Definition filter (f : A -> bool) (b : bag) :=
      MapInterface.fold (fun x n b =>
        if f x then b else MapInterface.remove x b) b b.
    Definition partition (f : A -> bool) (b : bag) :=
      MapInterface.fold (fun x n (acc : bag * bag) =>
        let (bin,bout) := acc in
          if f x then (bin[x <- n], bout) else (bin, bout[x <- n])
      ) b ([],[]).

    Definition cardinal (b : bag) :=
      MapInterface.fold (fun _ n c => n + c) b O.
    Definition elements (b : bag) :=
      elements b.
    Definition choose (b : bag) :=
      MapInterface.fold (fun x _ acc =>
        match acc with Some _ => acc | None => Some x end) b None.
    Definition min_elt (b : bag) :=
      MapInterface.fold (fun x _ acc =>
        match acc with Some _ => acc | None => Some x end) b None.
    Definition max_elt (b : bag) :=
      MapInterface.fold (fun x _ acc => Some x) b None.

  End WithMap.
End RawBag.
Export RawBag.

(* (* FBag_OrderedType :> *) *)
(* (* SpecificOrderedType _ (MEqual_pw bag A Mult) (MEqual_pw_Equivalence _ _ _) *) *)

(* Set Implicit Arguments. *)
(* Unset Strict Implicit. *)

(* (** * [FBagSpecs] : finite bags' specification *)

(*    We provide the specifications of bag operations in a separate class *)
(*    [FBagSpecs] parameterized by an [FBag] instance.  *)
(*    *) *)
(* Class FBagSpecs_Mult `(FBag A) := { *)
(*   Mult_1 : forall s (x y : A), x === y -> Mult x s = Mult y s *)
(* (*   In_1 : forall s (x y : A), x === y -> In x s -> In y s *) *)
(* }. *)
(* Class FBagSpecs_mem `(FBag A) := { *)
(*   mem_1 : forall s x, In x s -> mem x s = true; *)
(*   mem_2 : forall s x, mem x s = true -> In x s *)
(* }. *)
(* Class FBagSpecs_equal `(FBag A) := { *)
(*   equal_1 : forall s s', Equal s s' -> equal s s' = true; *)
(*   equal_2 : forall s s',  equal s s' = true -> Equal s s' *)
(* }. *)
(* Class FBagSpecs_subbag `(FBag A) := { *)
(*   subbag_1 : forall s s', Subbag s s' -> subbag s s' = true; *)
(*   subbag_2 : forall s s', subbag s s' = true -> Subbag s s' *)
(* }. *)
(* Class FBagSpecs_empty `(FBag A) := { *)
(*   empty_1 : MEmpty empty *)
(* }. *)
(* Class FBagSpecs_is_empty `(FBag A) := { *)
(*   is_empty_1 : forall s, MEmpty s -> is_empty s = true; *)
(*   is_empty_2 : forall s, is_empty s = true -> MEmpty s *)
(* }. *)
(* Class FBagSpecs_add `(FBag A) := { *)
(*   add_mult : forall s (x y : A), Mult x (add y s) =  *)
(*     if x == y then S (Mult x s) else Mult x s *)
(* (*   add_1 : forall s (x y : A), x === y -> In y (add x s); *) *)
(* (*   add_2 : forall s x y, In y s -> In y (add x s); *) *)
(* (*   add_3 : forall s (x y : A), x =/= y -> In y (add x s) -> In y s *) *)
(* }. *)
(* Class FBagSpecs_remove `(FBag A) := { *)
(*   remove_mult : forall s (x y : A), Mult x (remove y s) = *)
(*     if x == y then pred (Mult x s) else Mult x s *)
(* (*   remove_1 : forall s (x y : A), x === y -> ~ In y (remove x s); *) *)
(* (*   remove_2 : forall s (x y : A), *) *)
(* (*     x =/= y -> In y s -> In y (remove x s); *) *)
(* (*   remove_3 : forall s x y, In y (remove x s) -> In y s *) *)
(* }. *)
(* Class FBagSpecs_singleton `(FBag A) := { *)
(*   singleton_mult : forall s (x y : A), Mult x s = *)
(*     if x == y then 1 else 0 *)
(* (*   singleton_1 : forall (x y : A), In y (singleton x) -> x === y; *) *)
(* (*   singleton_2 : forall (x y : A), x === y -> In y (singleton x) *) *)
(* }. *)
(* Class FBagSpecs_union `(FBag A) := { *)
(*   union_mult : forall s s' x, Mult x (union s s') = Mult x s + Mult x s' *)
(* (*   union_1 : forall s s' x, *) *)
(* (*     In x (union s s') -> In x s \/ In x s'; *) *)
(* (*   union_2 : forall s s' x, In x s -> In x (union s s'); *) *)
(* (*   union_3 : forall s s' x, In x s' -> In x (union s s') *) *)
(* }. *)
(* Require Import Min. *)
(* Class FBagSpecs_inter `(FBag A) := { *)
(*   inter_mult : forall s s' x, Mult x (inter s s') = min (Mult x s) (Mult x s') *)
(* (*   inter_1 : forall s s' x, In x (inter s s') -> In x s; *) *)
(* (*   inter_2 : forall s s' x, In x (inter s s') -> In x s'; *) *)
(* (*   inter_3 : forall s s' x, *) *)
(* (*     In x s -> In x s' -> In x (inter s s') *) *)
(* }. *)
(* Class FBagSpecs_diff `(FBag A) := { *)
(*   diff_mult : forall s s' x, Mult x (diff s s') = Mult x s - Mult x s' *)
(* (*   diff_1 : forall s s' x, In x (diff s s') -> In x s; *) *)
(* (*   diff_2 : forall s s' x, In x (diff s s') -> ~ In x s'; *) *)
(* (*   diff_3 : forall s s' x, *) *)
(* (*     In x s -> ~ In x s' -> In x (diff s s') *) *)
(* }. *)
(* Class FBagSpecs_fold `(FBag A) := { *)
(*   fold_1 : forall s (B : Type) (i : B) (f : A -> nat -> B -> B), *)
(*       fold f s i = fold_left (fun a en => f (fst en) (snd en) a) (elements s) i *)
(* }. *)
(* Class FBagSpecs_cardinal `(FBag A) := { *)
(*   cardinal_1 : forall s, cardinal s = length (elements s) *)
(* }. *)
(* Class FBagSpecs_filter `(FBag A) := { *)
(*   filter_mult_1 : forall s x f `{Morphism _ (_eq ==> @eq bool) f}, *)
(*     In x (filter f s) -> Mult x (filter f s) = Mult x s; *)
(*   filter_mult_2 : forall s x f `{Morphism _ (_eq ==> @eq bool) f}, *)
(*     In x (filter f s) -> f x = true; *)
(*   filter_mult_3 : forall s x f `{Morphism _ (_eq ==> @eq bool) f}, *)
(*     f x = true -> Mult x s = Mult x (filter f s) *)
(* (*   filter_1 : forall s x f `{Morphism _ (_eq ==> @eq bool) f}, *) *)
(* (*     In x (filter f s) -> In x s; *) *)
(* (*   filter_2 : forall s x f `{Morphism _ (_eq ==> @eq bool) f}, *) *)
(* (*     In x (filter f s) -> f x = true; *) *)
(* (*   filter_3 : forall s x f `{Morphism _ (_eq ==> @eq bool) f}, *) *)
(* (*     In x s -> f x = true -> In x (filter f s) *) *)
(* }. *)
(* Class FBagSpecs_for_all `(FBag A) := { *)
(*   for_all_1 : forall s f `{Morphism _ (_eq ==> @eq bool) f}, *)
(*     For_all (fun x => f x = true) s -> for_all f s = true; *)
(*   for_all_2 : forall s f `{Morphism _ (_eq ==> @eq bool) f}, *)
(*     for_all f s = true -> For_all (fun x => f x = true) s *)
(* }. *)
(* Class FBagSpecs_exists `(FBag A) := { *)
(*   exists_1 : forall s f `{Morphism _ (_eq ==> @eq bool) f}, *)
(*     Exists (fun x => f x = true) s -> exists_ f s = true; *)
(*   exists_2 : forall s f `{Morphism _ (_eq ==> @eq bool) f}, *)
(*     exists_ f s = true -> Exists (fun x => f x = true) s *)
(* }. *)
(* Class FBagSpecs_partition `(FBag A) := { *)
(*   partition_1 : forall s f `{Morphism _ (_eq ==> @eq bool) f}, *)
(*     Equal (fst (partition f s)) (filter f s); *)
(*   partition_2 : forall s f `{Morphism _ (_eq ==> @eq bool) f}, *)
(*     Equal (snd (partition f s)) (filter (fun x => negb (f x)) s) *)
(* }. *)
(* Class FBagSpecs_elements `(FBag A) := { *)
(*   elements_1 : forall s x, In x s -> InA _eq (x, Mult x s) (elements s); *)
(*   elements_2 : forall s x n, InA _eq (x, n) (elements s) -> Mult x s =  n; *)
(*   elements_3 : forall s, sort _lt (elements s); *)
(*   elements_3w : forall s, NoDupA _eq (elements s) *)
(* }. *)
(* Class FBagSpecs_choose `(FBag A) := { *)
(*   choose_1 : forall s x, choose s = Some x -> In x s; *)
(*   choose_2 : forall s, choose s = None -> Empty s; *)
(*   choose_3 : forall s s' x y, *)
(*     choose s = Some x -> choose s' = Some y -> Equal s s' -> x === y *)
(* }. *)
(* Class FBagSpecs_min_elt `(FBag A) := { *)
(*   min_elt_1 : forall s x, min_elt s = Some x -> In x s; *)
(*   min_elt_2 : forall s x y, *)
(*     min_elt s = Some x -> In y s -> ~ y <<< x; *)
(*   min_elt_3 : forall s, min_elt s = None -> Empty s *)
(* }. *)
(* Class FBagSpecs_max_elt `(FBag A) := { *)
(*   max_elt_1 : forall s x, max_elt s = Some x -> In x s; *)
(*   max_elt_2 : forall s x y, *)
(*     max_elt s = Some x -> In y s -> ~ x <<< y; *)
(*   max_elt_3 : forall s, max_elt s = None -> Empty s *)
(* }. *)

(* Class FBagSpecs `(F : FBag A) := { *)
(*   FFBagSpecs_Mult :> FBagSpecs_Mult F; *)
(*   FFBagSpecs_mem :> FBagSpecs_mem F; *)
(*   FFBagSpecs_equal :> FBagSpecs_equal F; *)
(*   FFBagSpecs_subbag :> FBagSpecs_subbag F; *)
(*   FFBagSpecs_empty :> FBagSpecs_empty F; *)
(*   FFBagSpecs_is_empty :> FBagSpecs_is_empty F; *)
(*   FFBagSpecs_add :> FBagSpecs_add F; *)
(*   FFBagSpecs_remove :> FBagSpecs_remove F; *)
(*   FFBagSpecs_singleton :> FBagSpecs_singleton F; *)
(*   FFBagSpecs_union :> FBagSpecs_union F; *)
(*   FFBagSpecs_inter :> FBagSpecs_inter F; *)
(*   FFBagSpecs_diff :> FBagSpecs_diff F; *)
(*   FFBagSpecs_fold :> FBagSpecs_fold F; *)
(*   FFBagSpecs_cardinal :> FBagSpecs_cardinal F; *)
(*   FFBagSpecs_filter :> FBagSpecs_filter F; *)
(*   FFBagSpecs_for_all :> FBagSpecs_for_all F; *)
(*   FFBagSpecs_exists :> FBagSpecs_exists F; *)
(*   FFBagSpecs_partition :> FBagSpecs_partition F; *)
(*   FFBagSpecs_elements :> FBagSpecs_elements F; *)
(*   FFBagSpecs_choose :> FBagSpecs_choose F; *)
(*   FFBagSpecs_min_elt :> FBagSpecs_min_elt F; *)
(*   FFBagSpecs_max_elt :> FBagSpecs_max_elt F *)
(* }. *)


Require Import HoTT.
From GR.basics Require Import
     general.
From GR Require Export
     groupoid.grpd_bicategory.grpd_bicategory
     groupoid.grpd_bicategory.sum_grpd
     groupoid.grpd_bicategory.prod_grpd
     groupoid.grpd_bicategory.grpd_laws
     groupoid.groupoid_quotient.gquot_principles
     basics.polynomial.

(** * Groupoid quotient commmutes with polynomials *)

(** ** The groupoid quotient commutes with sums.
    We use recursion to define the maps and `gquot_ind_set` to prove they are inverses.
 *)
Section gquot_sum.
  Variable (G₁ G₂ : groupoid).

  Definition gquot_sum_in
             (z : gquot G₁ + gquot G₂)
    : gquot (sum_groupoid G₁ G₂).
  Proof.
    destruct z as [x | y].
    - exact (gquot_rec
               _
               (fun a => gcl (sum_groupoid G₁ G₂) (inl a))
               (fun a₁ a₂ g => @gcleq (sum_groupoid G₁ G₂) (inl a₁) (inl a₂) g)
               (fun a => ge (sum_groupoid G₁ G₂) (inl a))
               (fun a₁ a₂ a₃ g₁ g₂ =>
                  @gconcat (sum_groupoid G₁ G₂)
                           (inl a₁)
                           (inl a₂)
                           (inl a₃)
                           g₁
                           g₂)
               x).
    - exact (gquot_rec
               _
               (fun b => gcl (sum_groupoid G₁ G₂) (inr b))
               (fun b₁ b₂ g => @gcleq (sum_groupoid G₁ G₂) (inr b₁) (inr b₂) g)
               (fun b => ge (sum_groupoid G₁ G₂) (inr b))
               (fun b₁ b₂ b₃ g₁ g₂ =>
                  @gconcat (sum_groupoid G₁ G₂)
                           (inr b₁)
                           (inr b₂)
                           (inr b₃)
                           g₁
                           g₂)
               y).
  Defined.

  Definition gquot_sum_out : gquot (sum_groupoid G₁ G₂) -> gquot G₁ + gquot G₂.
  Proof.
    simple refine (gquot_rec _ _ _ _ _) ; cbn.
    - intros [a | b].
      + exact (inl (gcl _ a)).
      + exact (inr (gcl _ b)).
    - intros [a₁ | b₁] [a₂ | b₂] g ; try refine (Empty_rec g).
      + exact (ap inl (gcleq _ g)).
      + exact (ap inr (gcleq _ g)).
    - intros [a | b].
      + exact (ap _ (ge _ a)).
      + exact (ap _ (ge _ b)).
    - intros [a₁ | b₁] [a₂ | b₂] [a₃ | b₃] g₁ g₂;
        try (exact (Empty_rec g₁) || exact (Empty_rec g₂)).
      + exact (ap (ap inl) (gconcat G₁ g₁ g₂) @ ap_pp _ _ _).
      + exact (ap (ap inr) (gconcat G₂ g₁ g₂) @ ap_pp _ _ _).
  Defined.

  Lemma gquot_sum_out_in_sect : Sect gquot_sum_out gquot_sum_in.
  Proof.
    intros x.
    simple refine (gquot_ind_set (fun x => gquot_sum_in (gquot_sum_out x) = x) _ _ _ x).
    - intros [ | ] ; reflexivity.
    - intros [a1 | b1] [a2 | b2] g ; try refine (Empty_rec g) ; simpl in g.
      (**
       <<
                     1
       [inl(a₂)] —————————→ [inl(a₂)]
          |                     |
          |                     |
 ap       |                     |
  (gquot_sum_in o               | ap 1 [g]
    gquot_sum_out) [g]          |
          |                     |
          |                     |
          |                     |
       [inl(a₁)] —————————→ [inl(a₁)]
                     1
       >>
       *)
      + apply map_path_over.
        refine (whisker_square idpath _ (ap_idmap _)^ idpath (vrefl _)).
        refine (_ @ (ap_compose _ _ _)^).
        refine ((ap _ _ @ _)^).
        ** apply gquot_rec_beta_gcleq.
        ** refine ((ap_compose inl gquot_sum_in _)^ @ _).
           apply gquot_rec_beta_gcleq.
      + apply map_path_over.
        refine (whisker_square idpath _ (ap_idmap _)^ idpath (vrefl _)).
        refine (_ @ (ap_compose _ _ _)^).
        refine ((ap _ _ @ _ )^).
        ** apply gquot_rec_beta_gcleq.
        ** refine ((ap_compose inr gquot_sum_in _)^ @ _).
           apply gquot_rec_beta_gcleq.
  Qed.

  Lemma gquot_sum_in_out_sect : Sect gquot_sum_in gquot_sum_out.
  Proof.
    intros [x | y].
    - simple refine (gquot_ind_set
                       (fun z => gquot_sum_out (gquot_sum_in (inl z)) = inl z) _ _ _ x).
      + exact (fun _ => idpath).
      + intros a₁ a₂ g.
        apply map_path_over.
        refine (whisker_square idpath _ idpath idpath (vrefl _)).
        * refine (_ @ (ap_compose (gquot_sum_in o inl) gquot_sum_out _)^).
          refine (ap _ _ @ _)^.
          ** apply gquot_rec_beta_gcleq.
          ** apply gquot_rec_beta_gcleq.
    - simple refine (gquot_ind_set
                       (fun z => gquot_sum_out (gquot_sum_in (inr z)) = inr z) _ _ _ y).
      + exact (fun _ => idpath).
      + intros a₁ a₂ g.
        apply map_path_over.
        refine (whisker_square idpath _ idpath idpath (vrefl _)).
        refine (_ @ (ap_compose (gquot_sum_in o inr) gquot_sum_out _)^).
        refine (ap _ _ @ _)^.
        ** apply gquot_rec_beta_gcleq.
        ** apply gquot_rec_beta_gcleq.
  Qed.

  Global Instance gquot_sum_in_isequiv : IsEquiv gquot_sum_in
    := isequiv_adjointify _ gquot_sum_out gquot_sum_out_in_sect gquot_sum_in_out_sect.

  Definition gquot_sum : (gquot G₁ + gquot G₂) <~> gquot (sum_groupoid G₁ G₂) :=
    BuildEquiv _ _ gquot_sum_in _.
End gquot_sum.

(** ** The groupoid quotient commutes with products.
    We use recursion and double recursion to define the maps.
    We use `gquot_ind_set` to show they are inverses.
 *)
Section gquot_prod.
  Variable (G₁ G₂ : groupoid).

  Context `{Funext}.

  Definition gquot_prod_in
    : gquot G₁ * gquot G₂ -> gquot (prod_groupoid G₁ G₂).
  Proof.
    simple refine (gquot_double_rec _ _ _ _ _ _ _ _ _).
    - exact (fun a b => gcl (prod_groupoid G₁ G₂) (a, b)).
    - intros a b₁ b₂ g ; simpl.
      apply gcleq.
      exact (e a, g).
    - intros a b ; simpl.
      apply ge.
    - intros a b₁ b₂ b₃ g₁ g₂ ; simpl.
      rewrite <- gconcat ; cbn.
      rewrite grpd_right_identity.
      reflexivity.
    - intros a₁ a₂ b g ; simpl.
      apply gcleq.
      exact (g, e b).
    - intros a b ; simpl.
      apply ge.
    - intros a₁ a₂ a₃ b g₁ g₂ ; simpl.
      rewrite <- gconcat ; cbn.
      rewrite grpd_right_identity.
      reflexivity.
    - intros a₁ a₂ b₁ b₂ g₁ g₂ ; simpl.
      apply path_to_square.
      rewrite <- !gconcat.
      apply ap ; cbn.
      rewrite !grpd_right_identity, !grpd_left_identity.
      reflexivity.
  Defined.

  Definition gquot_prod_out : gquot (prod_groupoid G₁ G₂) -> gquot G₁ * gquot G₂.
  Proof.
    simple refine (gquot_rec _ _ _ _ _) ; cbn.
    - exact (fun x => (gcl _ (fst x), gcl _ (snd x))).
    - intros a₁ a₂ g ; simpl.
      exact (path_prod' (gcleq _ (fst g)) (gcleq _ (snd g))).
    - intros ; simpl.
      refine (ap (fun p => path_prod' p _) (ge _ _) @ _).
      exact (ap (fun p => path_prod' _ p) (ge _ _)).
    - intros ; simpl.
      refine (ap (fun p => path_prod' p _) (gconcat _ _ _) @ _).
      refine (ap (fun p => path_prod' _ p) (gconcat _ _ _) @ _).
      apply path_prod_pp.
  Defined.

  Lemma gquot_prod_out_in_sect : Sect gquot_prod_out gquot_prod_in.
  Proof.
    simple refine (gquot_ind_set (fun x => gquot_prod_in (gquot_prod_out x) = x) _ _ _).
    - reflexivity.
    - intros x₁ x₂ g.
      apply map_path_over.
      refine (whisker_square idpath _ (ap_idmap _)^ idpath (vrefl _)).
      refine ((ap_compose _ _ _ @ ap (ap gquot_prod_in) _ @ _ @ _)^).
      * apply gquot_rec_beta_gcleq.
      * apply gquot_double_rec_beta_gcleq.
      * simpl.
        refine ((@gconcat (prod_groupoid G₁ G₂)
                          _
                          (fst x₂, snd x₁)
                          _
                          (fst g, e (snd x₁))
                          (e (fst x₂), snd g))^
                @ _).
        apply ap.
        exact (path_prod' (grpd_right_identity _) (grpd_left_identity _)).
  Qed.

  Lemma gquot_prod_in_out_sect : Sect gquot_prod_in gquot_prod_out.
  Proof.
    intros [x₁ x₂].
    revert x₁ x₂.
    simple refine (gquot_double_ind_set _ _ _).
    - reflexivity.
    - intros a b₁ b₂ g.
      apply map_path_over.
      refine (whisker_square idpath _ (ap_pair_r _ _)^ idpath (vrefl _)).
      refine (_ @ _ @ _ @ _)^.
      * exact (ap_compose (fun z => gquot_prod_in (gcl G₁ a,z)) gquot_prod_out (gcleq G₂ g)).
      * apply ap.
        refine (ap_compose _ _ _ @ _).
        apply gquot_double_rec_beta_r_gcleq.
      * exact (gquot_rec_beta_gcleq (prod_groupoid G₁ G₂)
                                    _ _ _ _ _ _
                                    (a, b₁) (a, b₂) (e a, g)).
      * exact (ap (fun z => path_prod' z (gcleq G₂ g)) (ge G₁ a)).
    - intros a₁ a₂ b g.
      apply map_path_over.
      refine (whisker_square idpath _ (ap_pair_l _ _)^ idpath (vrefl _)).
      refine (_ @ _ @ _ @ _)^.
      * exact (ap_compose (fun z => gquot_prod_in (z,gcl G₂ b)) gquot_prod_out (gcleq G₁ g)).
      * apply ap.
        refine (ap_compose _ _ _ @ _).
        apply gquot_double_rec_beta_l_gcleq.
      * exact (gquot_rec_beta_gcleq (prod_groupoid G₁ G₂)
                                    _ _ _ _ _ _
                                    (a₁, b) (a₂, b) (g, e b)).
      * exact (ap (path_prod' (gcleq G₁ g)) (ge G₂ b)).
  Qed.

  Global Instance gquot_prod_in_isequiv : IsEquiv gquot_prod_in
    := isequiv_adjointify _ gquot_prod_out gquot_prod_out_in_sect gquot_prod_in_out_sect.

  Definition gquot_prod : (gquot G₁ * gquot G₂) <~> gquot (prod_groupoid G₁ G₂) :=
    BuildEquiv _ _ gquot_prod_in _.
End gquot_prod.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e235m15_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e191m19_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e152m17_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e212m29_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


(** * Kripke-Models *)
Require Import nd forms.
Require Import Coq.Classes.CRelationClasses.
Require Import PslBase.Base.
Require Import PslBase.Lists.BaseLists.

Section Models.
  Context {d : DerivationType}.
  (** ** Kripke Models *)

  Class KripkeModel  := mkKripkeModel {
                            world : Type;
                            valuation := nat -> Prop;
                            cogn  : world -> world -> Prop;
                            verif : world -> world -> Prop;
                            val   : world -> valuation;
                            preorderCogn: PreOrder cogn;
                            monotone: forall s x y, cogn x y -> val x s -> val y s;
                            vericont: subrelation verif cogn;
                            transvalid: forall x y z, cogn x y -> verif y z -> verif x z;
                          }.
  Context {M: (@KripkeModel)}.

  Instance kripke_verif_trans_equiv_Equiv {M': KripkeModel}  : Transitive (verif).
  Proof.
    intros u v w H H2. apply vericont in H. apply transvalid with (y := v); auto.
  Qed.

  Instance cogn_trans {M': KripkeModel}  : Transitive (cogn).
  Proof.
    apply preorderCogn.
  Qed.

  Fixpoint evalK {M: KripkeModel} (s: form) : (world) -> Prop :=
    match s with
    | (K x)  => (fun y => forall r, ((verif y r) -> evalK x r))
    | Bot    => (fun x => False)
    | Var y  => (fun x => val  x y)
    | x ⊃ y  => (fun z => forall r', cogn z r' -> (evalK x r') -> (evalK y r'))
    | s ∨ t  => (fun y => evalK s y \/ evalK t y)
    | s ∧ t  => (fun y => evalK s y /\  evalK t y)
    end.

  Definition evalK' {M: KripkeModel} (Γ: context) :=
    fun w => forall s, (s el Γ) -> @evalK M s w.

    Definition isIEL (M: KripkeModel) := forall w, exists w', verif w w'.

  Definition model_constraint  m :=
    if d then True else isIEL m.

  Definition entails Γ φ :=
    forall (M : KripkeModel), model_constraint M ->
      ((forall w,evalK' Γ w -> @evalK M φ w)).

  Notation "Γ ⊨ φ" := (entails Γ φ) (at level 30).

  (** Evaluation is monotone, that is if φ is true at world w
      and we can reach world v from w, φ true at v.  *)
  Lemma eval_monotone  (s: form)  w v:
    cogn w v -> evalK s w -> evalK s v.

  Proof.
    intros C H. induction s.
    + intros z H1. apply H. apply transvalid with (y := v); auto.
    + intros z H1 H2. apply H. apply transitivity with v; auto. exact H2.
    + destruct H. split.
      ++ apply IHs1. auto.
      ++ apply IHs2. auto.
    + destruct H.
      ++ left. auto.
      ++ right. auto.
    + exfalso. apply H.
    + apply monotone with (x := w); auto.
  Qed.

  Lemma monotone_ctx (A:context)  :
    forall w w', cogn w w' -> evalK' A w -> evalK' A w'.
  Proof.
    intros. intros t H1.
    apply eval_monotone with (w := w); auto.
  Qed.

End Models.
  Lemma soundness (Γ: context) (A: form) {D: DerivationType}:
    nd Γ A -> entails Γ A.
  Proof.
    intro. induction H; try firstorder eauto.
    - unfold entails. intros M' c w H0. unfold evalK.  intros r' H1 H2.  apply IHnd. auto. intros a Ha. destruct Ha; eauto.
      + subst s. apply H2.
      + apply eval_monotone with w; eauto.
    - unfold entails in IHnd1.  intros M c w H1. eapply IHnd1; auto. apply H1.  apply preorderCogn. apply IHnd2.  auto. auto.
    -
      intros M Mc w H1.
      intros w' cw Hs. specialize (IHnd M Mc w').   simpl evalK in IHnd.
      intros w'' wc. apply IHnd with w''; auto.  apply monotone_ctx with w; auto.
      apply preorderCogn.
    - intros M c w H0. intros r H1.  apply eval_monotone with w.  apply vericont.  auto.  apply IHnd.  auto. auto.
    - intros M c w H2.   specialize (IHnd1 M c w H2).   destruct IHnd1.
      + eapply IHnd2; auto.  apply H2.  apply preorderCogn.
      + eapply IHnd3; eauto. apply preorderCogn.
    - intros M Mc w H1 u c.
      apply monotone_ctx with (w' := u)  in H1. 2: auto.
      unfold isIEL in Mc. destruct (Mc u).
      assert (evalK s x).
      {
        eapply IHnd; auto.
        apply H1. auto.
      }
      intro.
      apply (H3 x).
      + apply vericont. auto.
      + apply H2.
  Qed.


(* -*- mode: coq; mode: visual-line -*-  *)

Require Import HoTT.Basics HoTT.Types.
Require Import Extensions.
Require Import Modality Accessible Nullification Lex.

Local Open Scope path_scope.

(** * Open modalities *)

(** ** Definition *)

Definition Op `{Funext} (U : HProp) : Modality.
Proof.
  snrapply easy_modality.
  - intros X; exact (U -> X).
  - intros T x; cbn.
    exact (fun _ => x).
  - cbn; intros A B f z u.
    refine (transport B _ (f (z u) u)).
    apply path_arrow; intros u'.
    apply ap; apply path_ishprop.
  - cbn; intros A B f a.
    apply path_arrow; intros u.
    transitivity (transport B 1 (f a u));
      auto with path_hints.
    apply (ap (fun p => transport B p (f a u))).
    transitivity (path_arrow (fun _ => a) (fun _ => a) (@ap10 U _ _ _ 1));
      auto with path_hints.
    * apply ap.
      apply path_forall; intros u'.
      apply ap_const.
    * apply eta_path_arrow.
  - intros A z z'.
    srefine (isequiv_adjointify _ _ _ _).
    * intros f; apply path_arrow; intros u.
      exact (ap10 (f u) u).
    * intros f; apply path_arrow; intros u.
      transitivity (path_arrow z z' (ap10 (f u))).
      + unfold to; apply ap.
        apply path_forall; intros u'.
        apply (ap (fun u0 => ap10 (f u0) u')).
        apply path_ishprop.
      + apply eta_path_arrow.
    * intros p.
      refine (eta_path_arrow _ _ _).
Defined.

(** ** The open modality is lex *)

(** Note that unlike most other cases, we can prove this without univalence (though we do of course need funext). *)
Global Instance lex_open `{Funext} (U : HProp)
  : Lex (Op U).
Proof.
  apply lex_from_isconnected_paths.
  intros A ? x y.
  assert (uc : U -> Contr A).
  { intros u.
    pose (contr_inhabited_hprop U u).
    refine (contr_equiv (U -> A) (equiv_contr_forall _)).
    apply Ac. }
  simple refine (Build_Contr _ _ _).
  - intros u; pose (uc u); exact (center (x=y)).
  - intros f; apply path_arrow; intros u.
    pose proof (uc u); apply path_contr.
Defined.

(** ** The open modality is accessible. *)

Global Instance acc_open `{Funext} (U : HProp)
  : IsAccModality (Op U).
Proof.
  unshelve econstructor.
  - econstructor.
    exact (unit_name U).
  - intros X; split.
    + intros X_inO u.
      apply (equiv_inverse (equiv_ooextendable_isequiv _ _)).
      refine (cancelR_isequiv (fun x (u:Unit) => x)).
      apply X_inO.
    + intros ext; specialize (ext tt).
      refine (isequiv_compose (f := (fun x => unit_name x))
                              (g := (fun h => h o const_tt U))).
      refine (isequiv_ooextendable (fun _ => X) (const_tt U) ext).
Defined.

(** Thus, arguably a better definition of [Op] would be as a nullification modality, as it would not require [Funext] and would have a judgmental computation rule.  However, the above definition is also nice to know, as it doesn't use HITs.  We name the other version [Op']. *)
Definition Op' (U : HProp) : Modality
  := Nul (Build_NullGenerators Unit (fun _ => U)).


Set Implicit Arguments.
Require Import Morphisms Setoid std.
Require Export prelim.
Require Import semantics.

(** * Confluence *)
Section Confluence.

  Context {X: Const}.

  Reserved Notation "s ≫ t" (at level 60).

  Inductive par : exp X -> exp X -> Prop :=
  | parVar x: var x ≫ var x
  | parConst c: const c ≫ const c
  | parLam s s': s ≫ s' -> (lambda s) ≫ lambda s'
  | parBeta s s' t t' u: s ≫ s' -> t ≫ t' -> u = beta s' t' -> (lambda s) t ≫ u
  | parApp s s' t t': s ≫ s' -> t ≫ t' -> s t ≫ s' t'
  where "s ≫ t" := (par s t).

  Hint Constructors par.

  Lemma refl_par: forall s, s ≫ s.
  Proof. induction s; eauto. Qed.

  Hint Immediate refl_par.

  Global Instance refl_par_inst: Reflexive par.
  Proof.
    intros ?; eapply refl_par.
  Qed.

  Lemma ren_compatible_par s s' delta:
    s ≫ s' -> ren delta s ≫ ren delta s'.
  Proof.
    induction 1 in delta |-*; cbn; eauto; subst.
    econstructor; eauto. now asimpl.
  Qed.

  Lemma subst_compatible_par s s' sigma sigma':
    s ≫ s' -> (forall x, sigma x ≫ sigma' x) -> (sigma • s) ≫ (sigma'• s').
  Proof.
    induction 1 in sigma, sigma' |-*; cbn; eauto.
    - intros; econstructor; eapply IHpar.
      intros []; cbn; eauto using ren_compatible_par.
    - intros; econstructor.
      eapply IHpar1 with (sigma' := up sigma'); eauto.
      intros []; cbn; eauto using ren_compatible_par.
      eapply IHpar2; eauto.
      subst; now asimpl.
  Qed.

  Global Instance par_lam_proper: Proper (star par ++> star par) lam.
  Proof.
    intros s s' H; induction H; eauto.
  Qed.

  Global Instance par_app_proper: Proper (star par ++> star par ++> star par) app.
  Proof.
    intros s s' H; induction H; intros t t' H'; induction H'; eauto.
  Qed.

  Global Instance sandwich_step: subrelation step par.
  Proof.
    intros ??; induction 1; eauto.
  Qed.

  Global Instance sandwich_steps: subrelation par (star step).
  Proof.
    intros ??; induction 1; eauto.
    - rewrite IHpar; eauto.
    - rewrite IHpar1, IHpar2, stepBeta; eauto.
    - rewrite IHpar1, IHpar2; eauto.
  Qed.

  Fixpoint rho (e: exp X) :=
    match e with
    | var x => var x
    | const c => const c
    | lambda s => lambda (rho s)
    | app (lambda s) t => beta (rho s) (rho t)
    | app s t => (rho s) (rho t)
    end.

  Lemma tak_fun_rho: tak_fun par rho.
  Proof.
    intros s t H; induction H; cbn; eauto.
    - subst u; eapply subst_compatible_par; eauto.
      intros []; cbn; eauto.
    - destruct s; eauto.
      inv H; inv IHpar1.
      econstructor; eauto.
  Qed.

  Lemma confluence_step: confluent (@step X).
    eapply TMT.
    eapply sandwich_step. eapply sandwich_steps.
    typeclasses eauto.
    eapply tak_fun_rho.
  Qed.

End Confluence.

Notation "s ≫ t" := (par s t) (at level 60).
Hint Resolve confluence_step tak_fun_rho.


Require Import refine.
Require Import parser.

Require Export Vehicle.
Require Export Station.

(** The CyCab example *)

(** The security of the composition of Vehicle and Station.
    This case shows the composition of Vehicle and Station is secure *)

Eval compute in IAutomaton.b_compatible Vehicle Station.

Definition Vehicle_Station: IA :=
 IAutomaton.composition Vehicle Station.
Eval compute in :> Vehicle_Station.

(* SIR-GNNI at m: true *)
Definition Vehicle_Station_hid_m: IA :=
 IAutomaton.hiding Vehicle_Station (ASet.GenActs [&"emrg",&"reset"]).

Definition Vehicle_Station_res_m: IA :=
 IAutomaton.hiding
 ( IAutomaton.restriction Vehicle_Station (ASet.GenActs [&"emrg"]) )
 (ASet.GenActs [&"reset"]).

Eval compute in :> Vehicle_Station_hid_m.
Eval compute in :> Vehicle_Station_res_m.
Eval compute in SIRGNNI_refinement Vehicle_Station_res_m Vehicle_Station_hid_m.

(* SME-NI at m: true *)
Definition Vehicle_Station_rep_m: IA :=
 IAutomaton.hiding
 ( IAutomaton.replacement Vehicle_Station (&"tau") (ASet.GenActs [&"emrg"]) )
 (ASet.GenActs [&"reset"]).

Eval compute in :> Vehicle_Station_rep_m.
Eval compute in SMENI_refinement Vehicle_Station_rep_m Vehicle_Station_hid_m.

(* SIR-GNNI at l: true *)
Definition Vehicle_Station_hid_l: IA :=
 IAutomaton.hiding Vehicle_Station (ASet.GenActs [&"emrg",&"reset",&"start"]).

Definition Vehicle_Station_res_l: IA :=
 IAutomaton.hiding
 ( IAutomaton.restriction Vehicle_Station (ASet.GenActs [&"emrg",&"start"]) )
 (ASet.GenActs [&"reset"]).

Eval compute in :> Vehicle_Station_hid_l.
Eval compute in :> Vehicle_Station_res_l.
Eval compute in SIRGNNI_refinement Vehicle_Station_res_l Vehicle_Station_hid_l.

(* SME-NI at l: true *)

Definition Vehicle_Station_rep_l: IA :=
 IAutomaton.hiding
 ( IAutomaton.replacement Vehicle_Station (&"tau") (ASet.GenActs [&"emrg",&"start"]) )
 (ASet.GenActs [&"reset"]).

Eval compute in :> Vehicle_Station_rep_l.
Eval compute in SMENI_refinement Vehicle_Station_rep_l Vehicle_Station_hid_l.

(* The security of vehicle*station*starter *)
Definition Starter: IA := parse
 "IA [s0,s1] (s0) [] [start] [] [s0->(start)s1]".

Eval compute in IAutomaton.b_compatible Vehicle_Station Starter.

Definition Vehicle_Station_Starter: IA := IAutomaton.composition Vehicle_Station Starter.
Eval compute in :> Vehicle_Station_Starter.

(* SIR-GNNI and SME-NI at m/l: *)
Definition Vehicle_Station_Starter_hid: IA :=
 IAutomaton.hiding Vehicle_Station_Starter (ASet.GenActs [&"emrg",&"reset"]).

Definition Vehicle_Station_Starter_res: IA :=
IAutomaton.hiding
 ( IAutomaton.restriction Vehicle_Station_Starter (ASet.GenActs [&"emrg"]) )
 (ASet.GenActs [&"reset"]).

Definition Vehicle_Station_Starter_rep: IA :=
IAutomaton.hiding
 ( IAutomaton.replacement Vehicle_Station_Starter (&"tau") (ASet.GenActs [&"emrg"]) )
 (ASet.GenActs [&"reset"]).

Eval compute in :> Vehicle_Station_Starter_hid.
Eval compute in :> Vehicle_Station_Starter_res.
Eval compute in :> Vehicle_Station_Starter_rep.
Eval compute in SIRGNNI_refinement Vehicle_Station_Starter_res Vehicle_Station_Starter_hid.
Eval compute in SMENI_refinement Vehicle_Station_Starter_rep Vehicle_Station_Starter_hid.

Definition Emergency_halt: IA := parse
 "IA [s0,s1] (s0) [reset] [emrg] [] [s0->(emrg)s1, s1->(reset)s0]".

Eval compute in IAutomaton.b_compatible Vehicle_Station_Starter Emergency_halt.
Definition Sys: IA := IAutomaton.composition Vehicle_Station_Starter Emergency_halt.
Eval compute in :> Sys.


Require Import ZArith.
Require Import Basic_type.

Definition zn2z_word_comm : forall w n, zn2z (word w n) = word (zn2z w) n.
 fix zn2z_word_comm 2.
 intros w n; case n.
  reflexivity.
  intros n0;simpl.
  case (zn2z_word_comm w n0).
  reflexivity.
Defined.

Fixpoint extend (n:nat) {struct n} : forall w:Set, zn2z w -> word w (S n) :=
 match n return forall w:Set, zn2z w -> word w (S n) with
 | O => fun w x => x
 | S m =>
   let aux := extend m in
   fun w x => WW W0 (aux w x)
 end.

Section ExtendMax.

 Variable w:Set.

 Definition Tmax n m :=
  (  {p:nat| word (word w n) p = word w m}
    + {p:nat| word (word w m) p = word w n})%type.

 Definition max : forall n m, Tmax n m.
  fix max 1;intros n.
  case n.
  intros m;left;exists m;exact (refl_equal (word w m)).
  intros n0 m;case m.
  right;exists (S n0);exact (refl_equal (word w (S n0))).
  intros m0;case (max n0 m0);intros H;case H;intros p Heq.
  left;exists p;simpl.
   case (zn2z_word_comm (word w n0) p).
   case Heq.
   exact (refl_equal (zn2z (word (word w n0) p))).
  right;exists p;simpl.
   case (zn2z_word_comm (word w m0) p).
   case Heq.
   exact (refl_equal (zn2z (word (word w m0) p))).
 Defined.

 Definition extend_to_max :
  forall n m (x:zn2z (word w n)) (y:zn2z (word w m)),
        (zn2z (word w m) + zn2z (word w n))%type.
  intros n m x y.
   case (max n m);intros (p, Heq).
   left; case Heq;exact (extend p (word w n) x).
   right;case Heq;exact (extend p (word w m) y).
 Defined.

End ExtendMax.

Section Reduce.

 Variable w : Set.
 Variable nT : Set.
 Variable N0 : nT.
 Variable eq0 : w -> bool.
 Variable reduce_n : w -> nT.
 Variable zn2z_to_Nt : zn2z w -> nT.

 Definition reduce_n1 (x:zn2z w) :=
  match x with
  | W0 => N0
  | WW xh xl =>
    if eq0 xh then reduce_n xl
    else zn2z_to_Nt x
  end.

End Reduce.

Section ReduceRec.

 Variable w : Set.
 Variable nT : Set.
 Variable N0 : nT.
 Variable reduce_1n : zn2z w -> nT.
 Variable c : forall n, word w (S n) -> nT.

 Fixpoint reduce_n (n:nat) : word w (S n) -> nT :=
  match n return word w (S n) -> nT with
  | O => reduce_1n
  | S m => fun x =>
    match x with
    | W0 => N0
    | WW xh xl =>
      match xh with
      | W0 => @reduce_n m xl
      | _ => @c (S m) x
      end
    end
  end.

End ReduceRec.

Definition opp_compare cmp :=
  match cmp with
  | Lt => Gt
  | Eq => Eq
  | Gt => Lt
  end.

Section CompareRec.

 Variable wm w : Set.
 Variable w_0 : w.
 Variable compare : w -> w -> comparison.
 Variable compare0_m : wm -> comparison.
 Variable compare_m : wm -> w -> comparison.

 Fixpoint compare0_mn (n:nat) : word wm n -> comparison :=
  match n return word wm n -> comparison with
  | 0 => compare0_m
  | S m => fun x =>
    match x with
    | W0 => Eq
    | WW xh xl =>
      match compare0_mn m xh with
      | Eq => compare0_mn m xl
      | r  => Lt
      end
    end
  end.

 Fixpoint compare_mn_1 (n:nat) : word wm n -> w -> comparison :=
  match n return word wm n -> w -> comparison with
  | 0 => compare_m
  | S m => fun x y =>
    match x with
    | W0 => compare w_0 y
    | WW xh xl =>
      match compare0_mn m xh with
      | Eq => compare_mn_1 m xl y
      | r  => Gt
      end
    end
  end.

End CompareRec.


(** * A construction of the interval using propositional truncation *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.NullHomotopies.
Require Import UniMath.MoreFoundations.Notations.

Definition interval := ∥ bool ∥.
Definition left := hinhpr true : interval.
Definition right := hinhpr false : interval.
Definition interval_path : left = right := squash_path true false.
Definition interval_map {Y} {y y':Y} : y = y' -> interval -> Y.
Proof.
  intros e. set (f := λ t:bool, if t then y else y').
  refine (cone_squash_map f (f false) _).
  intros v. induction v.
  { exact e. }
  { reflexivity. }
Defined.

Goal ∏ Y {y y':Y} (e : y = y'), interval_map e left = y.
   reflexivity.
Qed.

Goal ∏ Y {y y':Y} (e : y = y'), interval_map e right = y'.
   reflexivity.
Qed.

(** ** An easy proof of functional extensionality for sections using the interval, which is derived
       from formal properlties of propositional truncation, but notice that propositional truncation
       uses functional extensionality for functions, already. *)

Definition funextsec2 X (Y:X->Type) (f g:∏ x,Y x) :
           (∏ x, f x = g x) -> f = g.
Proof.
  intros e. exact (maponpaths (λ h x, interval_map (e x) h) interval_path).
Defined.


(**************************************************************************)
(*  This is part of STATES, it is distributed under the terms of the      *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2014: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                        *)
(**************************************************************************)

Require Import Relations Morphisms.
Require Import Program.
Require Memory Terms Decorations.
Set Implicit Arguments.
Require Import ZArith.
Open Scope Z_scope.
Require Import Bool.

Module Make(Import M: Memory.T).
  Module Export Derived_TermsExp := Decorations.Make(M).

 Definition id  {X: Type}     : term X X       := tpure id.
 Definition pi1 {X Y: Type}   : term X (X*Y)   := tpure fst.
 Definition pi2 {X Y: Type}   : term Y (X*Y)   := tpure snd.
 Definition forget {X}        : term unit X    := tpure (fun _ => tt).
(* Definition constant (v: Z)   : term Z unit    := tpure (fun _ => v).
   Definition constant {X Y: Type} (v: Y): term Y X := tpure (fun _ => v). *)

 Definition loopdec (b: term (unit+unit) unit) (f: term unit unit) : term unit unit
    := tpure(fun tt => tt).

 Definition copi1 {X Y}       : term (X+Y) X  := tpure inl.
 Definition copi2 {X Y}       : term (X+Y) Y  := tpure inr.
 Definition empty {X} (x: X)  : term X empty_set:= tpure (fun _ => x).
 Definition constant {X: Type} (v: X): term X unit := tpure (fun _ => v).

 Definition add (p: Z * Z) := match p with
                                | (x, y) => x + y
                              end.

 Definition mlt (p: Z * Z) := match p with
                                | (x, y) => x * y
                              end.

 Definition chkgt (p: Z * Z) : bool := match p with
                                              | (a1, a2) => match (a1 ?= a2)%Z with
                                                              | Gt => true
                                                              | _  => false
                                                            end
                                            end.

 Definition chkge (p: Z * Z) : bool := match p with
                                              | (a1, a2) => match (a1 ?= a2)%Z with
                                                              | Lt => false
                                                              | _  => true
                                                           end
                                            end.

 Definition chklt (p: Z * Z) : bool := match p with
                                              | (a1, a2) => match (a1 ?= a2)%Z with
                                                              | Lt => true
                                                              | _  => false
                                                            end
                                            end.

 Definition chkle (p: Z * Z) : bool := match p with
                                              | (a1, a2) => match (a1 ?= a2)%Z with
                                                              | Gt => false
                                                              | _  => true
                                                            end
                                            end.

 Definition chkeq (p: Z * Z) : bool := match p with
                                              | (a1, a2) => match (a1 ?= a2)%Z with
                                                              | Eq => true
                                                              | _  => false
                                                            end
                                            end.

 Definition chkneq (p: Z * Z) : bool := match p with
                                               | (a1, a2) => match (a1 ?= a2)%Z with
                                                               | Eq => false
                                                               | _  => true
                                                             end
                                             end.

 Definition ve (p: bool * bool): bool := match p with
                                                | (x, y) => match (x && y) with
                                                               | false => false
                                                               | true  => true
                                                             end
                                              end.

 Definition yada (p: bool * bool): bool := match p with
                                                  | (x, y) => match (x || y) with
                                                                | false => false
                                                                | true  => true
                                                              end
                                                end.

 Definition bool_to_two (b: bool): unit + unit :=
    match b with
       | false => inr tt
       | true  => inl tt
    end.

 Definition bool_to_prop (b: bool): Prop :=
     match b with
       | false => False
       | true  => True
    end.

 Check tt.

 Definition passbool: term (unit + unit) bool := tpure bool_to_two.

 Definition prod_forget {X Y}: term unit (X*Y) := forget.
 Definition iso {X}: term (X*unit) X := pair id forget.
 Definition inv_pi1 {X}: term (X*unit) X := pair id forget.
 Definition permut {X Y}: term (X*Y) (Y*X) := pair pi2 pi1.

 Definition perm_pair {X Y Z} (f: term Y X) (g: term Z X): term (Y*Z) X
 := permut o pair g f.
 Definition prod {X Y X' Y'} (f: term X X') (g: term Y Y'): term (X*Y) (X'*Y')
 := pair (f o pi1) (g o pi2).
 Definition perm_prod {X Y X' Y'} (f: term X X') (g: term Y Y') := permut o pair (g o pi2) (f o pi1).
 (*Definition perm_prod {X Y X' Y'} (f: term X X') (g: term Y Y'): term (X*Y) (X'*Y')
 := perm_pair (f o pi1) (g o pi2).*)

 Definition ttrue  : term (unit+unit) unit := copi1.
 Definition ffalse : term (unit+unit) unit := copi2.

 Lemma is_loopdec: forall k (b: term (unit+unit) unit) (f: term unit unit),
 is k b -> is k f -> is pure (loopdec b f).
 Proof. intros. decorate. Qed.

 Lemma is_prod_forget X Y: is pure (@prod_forget X Y).
 Proof. decorate. Qed.

 Lemma is_inv_pi1 X: is pure (@inv_pi1 X).
 Proof. decorate. Qed.

 Lemma is_permut X Y: is pure (@permut X Y).
 Proof. decorate. Qed.

 Lemma is_perm_pair: forall k X Y Z (f: term Y X) (g: term Z X),
 is k f -> is k g -> is k (perm_pair f g).
 Proof. intros. induction k; decorate. Qed.

 Lemma is_prod: forall k X' X Y' Y (f: term X X') (g: term Y Y'),
 is k f -> is k g -> is k (prod f g).
 Proof. intros. induction k; decorate. Qed.

 Lemma is_perm_prod: forall k X' X Y' Y (f: term X X') (g: term Y Y'),
 is k f -> is k g -> is k (perm_prod f g).
 Proof. intros. induction k; decorate. Qed.

 Lemma is_ttrue: is pure (@copi1 unit unit).
 Proof. decorate. Qed.

 Lemma is_ffalse: is pure (@copi2 unit unit).
 Proof. decorate. Qed.

 Lemma is_id X: is pure (@id X).
 Proof. decorate. Qed.

 Lemma is_pi1 X Y: is pure (@pi1 X Y).
 Proof. decorate. Qed.

 Lemma is_pi2 X Y: is pure (@pi2 X Y).
 Proof. decorate. Qed.

 Lemma is_forget X: is pure (@forget X).
 Proof. apply is_tpure. Qed.

 Lemma is_constant (v: Z): is pure (constant v).
 Proof. apply is_tpure. Qed.

 Lemma is_copi1 X Y: is pure (@copi1 X Y).
 Proof. decorate. Qed.

 Lemma is_copi2 X Y: is pure (@copi2 X Y).
 Proof. decorate. Qed.

 Lemma is_empty {X: Type} (x: X): is pure (@empty X x).
 Proof. decorate. Qed.

(* Lemma is_plus: is pure (plus).
 Proof. decorate. Qed.

 Lemma is_mult: is pure (mult).
 Proof. decorate. Qed.

 Lemma is_gt: is pure (gt).
 Proof. decorate. Qed.

 Lemma is_ge: is pure (ge).
 Proof. decorate. Qed.

 Lemma is_lt: is pure (lt).
 Proof. decorate. Qed.

 Lemma is_le: is pure (le).
 Proof. decorate. Qed.

 Lemma is_eq: is pure (eq).
 Proof. decorate. Qed.

 Lemma is_neq: is pure (neq).
 Proof. decorate. Qed.

 Lemma is_and: is pure (and).
 Proof. decorate. Qed.

 Lemma is_or: is pure (or).
 Proof. decorate. Qed. *)

 Lemma is_passbool: is pure (passbool).
 Proof. decorate. Qed.

End Make.


(** Definition of type syntax and related definitions **)

Require Import Utils.

(* definition of a trust annotation *)

Inductive secty : Type := Trust : secty | Untrust : secty.

(* decidable equality on trust annotations *)

Definition secty_eq_dec : forall (s s' : secty), {s = s'} + {s <> s'}.
  decide equality.
Defined.

(* definition of type syntax.
   We only consider a base type: bool.
   Each type must have its trust annotation *)

Inductive ty : Type :=
  | ty_bool : secty -> ty
  | arrow : ty -> ty -> secty -> ty.

(* decidable equality for types *)

Definition ty_eq_dec : forall (t t' : ty), {t = t'} + {t <> t'}.
  pose secty_eq_dec.
  decide equality.
Defined.

Tactic Notation "ty_cases" tactic(first) ident(c) :=
  first ; [Case_aux c "base" | Case_aux c "arrow"].

(** definition of a type size,
    this is used to ensure termination
    of subtyping algorithm **)

Fixpoint ty_size (T : ty) : nat :=
  match T with
    | arrow l r _ => 1 + (ty_size l) + (ty_size r)
    | _           => 0
  end.


Require Export XR_R.
Require Export XR_Rmult.
Require Export XR_Rmult_0_r.
Require Export XR_Ropp.
Require Export XR_Ropp_involutive.
Require Export XR_Ropp_mult_distr_l.
Require Export XR_Rplus_eq_reg_r.
Require Export XR_Rplus_opp_r.
Require Export XR_Rmult_plus_distr_l.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Rmult_opp_opp : forall r1 r2, - r1 * - r2 = r1 * r2.
Proof.
  intros x y.
  apply Rplus_eq_reg_r with (-(-x*-y)).
  rewrite Rplus_opp_r.
  rewrite Ropp_mult_distr_l.
  rewrite Ropp_involutive.
  rewrite <- Rmult_plus_distr_l.
  rewrite Rplus_opp_r.
  rewrite Rmult_0_r.
  reflexivity.
Qed.


Require Import Iron.Language.SimpleRef.Step.
Require Import Iron.Language.SimpleRef.SubstExpExp.
Require Import Iron.Language.SimpleRef.Ty.

(* If a closed, well typed expression takes an evaluation step
   then the result has the same type as before. *)
Theorem preservation
 :  forall se h x h' x' t
 ,  TYPEH se h
 -> TYPE  nil se x  t
 -> STEP  h x h' x'
 -> (exists se', extends se' se
              /\ TYPEH se' h'
              /\ TYPE  nil se' x' t).
Proof.
 intros se h x h' x' t HTH HT HS. gen t.
 induction HS; intros.

 Case "EsContext".
  specializes IHHS HTH.
  destruct H; try
   (inverts HT;
    edestruct IHHS as [se2]; eauto;
    exists se2;
    splits; burn).

 Case "EsLamApp".
  inverts_type.
  exists se. splits; auto.
  eapply subst_exp_exp; eauto.

 Case "EsLamNewRef".
  inverts_type.
  exists (tData <: se). splits.
   eauto.
   eapply Forall2_snoc.
    eapply type_stenv_snoc. auto.
    eapply Forall2_impl.
    eapply type_stenv_snoc. auto.
   eapply TyLoc.
    assert (length h = length se) as HL.
     eapply Forall2_length; eauto.
     rewrite HL. auto.

 Case "EsReadRef".
  inverts_type.
  exists se. splits; auto.
  eapply Forall2_get_get_same; eauto.

 Case "EsWriteRef".
  inverts_type.
  exists se. splits; eauto.
  eapply Forall2_update_right; eauto.
  unfold xUnit.
  unfold tUnit. eauto.
Qed.

(* If a closed, well typed expression takes several evaluation steps
   then the result has the same type as before.
   Usses the left linearised version of steps judement. *)
Lemma preservation_stepsl
 :  forall se h x t h' x'
 ,  TYPEH se h
 -> TYPE  nil se x t
 -> STEPSL h x h' x'
 -> (exists se', extends se' se
              /\ TYPEH se' h'
              /\ TYPE  nil se' x' t).
Proof.
 intros se h x t h' x' HTH HT HS. gen se.
 induction HS; intros.
  Case "EslNone".
   eauto.
  Case "EslCons".
   lets D: preservation HTH HT H.
    destruct D as [se2].
    inverts H0. inverts H2.
   spec IHHS H0 H3.
    destruct IHHS as [se3].
    inverts H2. inverts H5.
    exists se3. splits; auto.
    eapply extends_trans; eauto.
Qed.

(* If a closed, well typed expression takes several evaluation steps
   then the result has the same type as before. *)
Lemma preservation_steps
 :  forall se h x t h' x'
 ,  TYPEH se h
 -> TYPE  nil se x t
 -> STEPS h x h' x'
 -> (exists se', extends se' se
              /\ TYPEH se' h'
              /\ TYPE  nil se' x' t).
Proof.
 intros se h x t h' x' HTH HT HS.
 eapply stepsl_of_steps in HS.
 eapply preservation_stepsl; eauto.
Qed.


(*******************************************************************)
(*  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: untyped generalised regular expressions *)

(** we define here the syntax for untyped generalised regular expressions
   which we will actually use in computations *)

Require Import kat lsyntax positives sups glang comparisons boolean.
Set Implicit Arguments.

Section l.
Variable Pred: nat.
Notation Sigma := positive.
Notation Atom := (ord (pow2 Pred)).
Notation uglang := (traces_monoid_ops Atom traces_tt traces_tt).

(** * Syntax *)

(** we declare strict iteration as primitive for efficiency reasons:
   Kleene star is derived from strict iteration in a linear way,
   while deriving strict iteration out of Kleene star requires duplication. *)
Inductive ugregex :=
| u_var(i: Sigma)
| u_prd(p: expr (ord Pred))
| u_pls(e f: ugregex)
| u_dot(e f: ugregex)
| u_itr(e: ugregex).

(** [zer] and [one] are also derived operations *)
Definition u_zer := u_prd e_bot.
Definition u_one := u_prd e_top.
Definition u_str e := u_pls u_one (u_itr e).

(** * Language *)

(** we define the untyped guarded string language of an expression
   algebraically (by induction on the expression) ; below we
   characterise it coalgebraically *)

Fixpoint lang (e: ugregex): uglang :=
  match e with
    | u_var a => tsingle a
    | u_prd p => tinj (fun i => eval (set.mem i) p)
    | u_pls e f => lang e + lang f
    | u_dot e f => lang e * lang f
    | u_itr e => lang e ^+
  end.

(** we get a KA structure, by interpretation into languages *)

Definition u_leq e f := lang e <== lang f.
Definition u_weq e f := lang e == lang f.

Canonical Structure ugregex_lattice_ops :=
  lattice.mk_ops _ u_leq u_weq u_pls u_pls id u_zer u_zer.

CoInductive ugregex_unit := ugregex_tt.

Canonical Structure ugregex_monoid_ops :=
  monoid.mk_ops ugregex_unit _
  (fun _ _ _ => u_dot) (fun _ => u_one) (fun _ => u_itr) (fun _ => u_str)
  (fun _ _ _ => u_zer) (fun _ _ _ _ _ => u_zer) (fun _ _ _ _ _ => u_zer).

(* Canonical Structure ugregex_kat_ops :=  *)
(*   kat.mk_ops ugregex_monoid_ops (fun _ => lsyntax.expr_ops _ BL) (fun _ => u_prd). *)

Notation tt := ugregex_tt.
Notation ugregex' := (ugregex_monoid_ops tt tt).

Global Instance ugregex_monoid_laws: monoid.laws BKA ugregex_monoid_ops.
Proof.
  apply (laws_of_faithful_functor (f:=fun _ _: ugregex_unit => lang)).
  constructor; simpl ob. intros ? ?. constructor.
   now intros ? ? ?.
   now intros ? ? ?.
   now intros _ ? ?.
   discriminate.
   intros _ [a|]; simpl; intuition; discriminate.
   discriminate.
   discriminate.
   reflexivity.
   intros ? [a|]; simpl; intuition.
   reflexivity.
   intros _ ? x. rewrite str_itr. simpl (lang _). apply cup_weq. 2: reflexivity.
   intros [|]; simpl. intuition. tauto.
   discriminate.
   discriminate.
   discriminate.
  now intros ? ? ?.
  now intros ? ? ?.
Qed.

Global Instance ugregex_lattice_laws: lattice.laws BKA ugregex_lattice_ops.
Proof. apply (@lattice_laws _ _ ugregex_monoid_laws tt tt). Qed.

(** Note that [ugregex] actually comes with a KAT structure, but we do not need it *)
(* Global Instance ugregex_kat_laws: kat.laws ugregex_kat_ops. *)

(** folding expressions *)
Ltac fold_ugregex := ra_fold ugregex_monoid_ops tt.

(** * Coalgebraic characterisation of the language recognised by an expression *)

(** epsilon (optimised since it's quite simple) *)

Fixpoint epsilon_pred a (e: expr_ops (ord Pred) BL) :=
  match e with
    | e_bot => false
    | e_top => true
    | e_var i => a i
    | e_cup e f => epsilon_pred a e ||| epsilon_pred a f
    | e_cap e f => epsilon_pred a e &&& epsilon_pred a f
    | e_neg e => negb (epsilon_pred a e)
  end.

Fixpoint epsilon a (e: ugregex) :=
  match e with
    | u_var _ => false
    | u_prd p => epsilon_pred a p
    | u_pls e f => epsilon a e ||| epsilon a f
    | u_dot e f => epsilon a e &&& epsilon a f
    | u_itr e => epsilon a e
  end.

(** derivatives (specification, unoptimised)  *)

Fixpoint deriv a i (e: ugregex'): ugregex' :=
  match e with
    | u_prd _ => 0
    | u_var j => ofbool (eqb_pos i j)
    | u_pls e f => deriv a i e + deriv a i f
    | u_dot e f => deriv a i e * f + ofbool (epsilon (set.mem a) e) * deriv a i f
    | u_itr e => deriv a i e * (e: ugregex')^*
  end.

(** corresponding coalgebraic notion of language *)

Fixpoint lang' (e: ugregex') (w: trace Atom) :=
  match w with
    | tnil a => is_true (epsilon (set.mem a) e)
    | tcons a i w => lang' (deriv a i e) w
  end.

(** characterisation of [epsilon] through languages  *)

Lemma epsilon_iff_lang_nil a e: epsilon (set.mem a) e <-> (lang e) (tnil a).
Proof.
 induction e; simpl.
  intuition discriminate.
   apply eq_bool_iff. simpl epsilon. induction p; simpl.
    reflexivity.
    reflexivity.
    rewrite <-Bool.orb_lazy_alt. congruence.
    rewrite <-Bool.andb_lazy_alt. congruence.
    congruence.
    reflexivity.
  setoid_rewrite Bool.orb_true_iff. now apply cup_weq.
  setoid_rewrite Bool.andb_true_iff. setoid_rewrite traces_dot_nil. now apply cap_weq.
  split. exists O. simpl. tauto.
  intros [i Hi]. rewrite IHe. clear IHe. induction i. assumption.
  apply IHi. setoid_rewrite traces_dot_nil in Hi. apply Hi.
Qed.

Lemma lang_0: lang u_zer == 0.
Proof. intros [?|???]; simpl; intuition; discriminate. Qed.

Lemma lang_1: lang u_one == 1.
Proof. intros [a|???]; simpl. intuition. reflexivity. Qed.

Lemma lang_ofbool b: lang (ofbool b: ugregex') == ofbool b.
Proof. case b. apply lang_1. apply lang_0. Qed.

Global Instance lang_leq: Proper (leq ==> leq) lang.
Proof. now intros ? ?. Qed.
Global Instance lang_weq: Proper (weq ==> weq) lang.
Proof. now intros ? ?. Qed.

Lemma lang_sup J: lang (sup id J) == sup lang J.
Proof. apply f_sup_weq. apply lang_0. reflexivity. Qed.

Lemma deriv_sup a i J: deriv a i (sup id J) = sup (deriv a i) J.
Proof. apply f_sup_eq; now f_equal. Qed.

(** characterisation of derivatives through languages *)

Lemma deriv_traces a i e: lang (deriv a i e) == traces_deriv a i (lang e).
Proof.
  symmetry. induction e; simpl deriv. simpl lang.
   rewrite lang_ofbool. apply traces_deriv_single.
   rewrite lang_0. apply traces_deriv_inj.
   setoid_rewrite traces_deriv_pls. now apply cup_weq.
   generalize (epsilon_iff_lang_nil a e1). case epsilon; intro He1.
    fold_ugregex. setoid_rewrite dot1x. simpl lang.
    setoid_rewrite traces_deriv_dot_1. now rewrite IHe1, IHe2.
     now rewrite <-He1.
    fold_ugregex. setoid_rewrite dot0x. rewrite cupxb. simpl lang.
    setoid_rewrite traces_deriv_dot_2. now rewrite IHe1.
     rewrite <-He1. discriminate.
   simpl lang.
    setoid_rewrite traces_deriv_itr. now rewrite IHe, str_itr, <-inj_top.
Qed.

(** the two definitions of languages (algebraic and coalgebraic) coincide,
   by unicity of the coalgebra morphism from expressions to languages *)

Theorem lang_lang' e: lang e == lang' e.
Proof.
  symmetry. intro w. revert e. induction w as [a|a i w IH]; simpl lang'; intro e.
  - apply epsilon_iff_lang_nil.
  - rewrite IH. apply deriv_traces.
Qed.

(** as a consequence, [lang'] preserves equality *)
Corollary lang'_weq: Proper (weq ==> weq) lang'.
Proof. intros ? ? H. apply lang_weq in H. now rewrite 2 lang_lang' in H. Qed.

(** * Comparing expressions *)

Fixpoint ugregex_compare (x y: ugregex) :=
  match x,y with
    | u_prd a, u_prd b
    | u_var a, u_var b       => cmp a b
    | u_pls x x', u_pls y y'
    | u_dot x x', u_dot y y' => lex (ugregex_compare x y) (ugregex_compare x' y')
    | u_itr x, u_itr y       => ugregex_compare x y
    | u_var _, _             => Lt
    | _, u_var _             => Gt
    | u_prd _, _             => Lt
    | _, u_prd _             => Gt
    | u_itr _ , _            => Lt
    | _, u_itr _             => Gt
    | u_pls _ _ , _          => Lt
    | _, u_pls _ _           => Gt
  end.

Lemma ugregex_compare_spec x y: compare_spec (x=y) (ugregex_compare x y).
Proof.
  revert y; induction x; destruct y; try (constructor; congruence); simpl.
  case cmp_spec; constructor; congruence.
  case cmp_spec; constructor; congruence.
  eapply lex_spec; eauto. intuition congruence.
  eapply lex_spec; eauto. intuition congruence.
  case IHx; constructor; congruence.
Qed.

Canonical Structure ugregex_cmp := mk_simple_cmp _ ugregex_compare_spec.

End l.


Require Import List.

Fixpoint prisoo' nd n k accu :=
  match nd with
    | O => rev accu
    | S nd' => let ra := match k with
                 | O => (true, S n, (n + n))
                 | S k' => (false, n, k')
               end in
               prisoo' nd' (snd (fst ra)) (snd ra) ((fst (fst ra))::accu)
  end.

Definition prisoo n := prisoo' n 1 0 nil.


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(**********************************************************************
    LucasLehamer.v

    Build the sequence for the primality test of Mersenne numbers

    Definition: LucasLehmer
  **********************************************************************)
Require Import ZArith.
Require Import ZAux.
Require Import Tactic.
Require Import Wf_nat.
Require Import NatAux.
Require Import UList.
Require Import ListAux.
Require Import FGroup.
Require Import EGroup.
Require Import PGroup.
Require Import IGroup.

Open Scope Z_scope.

(**************************************
  The seeds of the serie
 **************************************)

Definition w := (2, 1).

Definition v := (2, -1).

Theorem w_plus_v: pplus w v = (4, 0).
simpl; auto.
Qed.

Theorem w_mult_v : pmult w v = (1, 0).
simpl; auto.
Qed.

(**************************************
  Definition of the power function for pairs p^n
 **************************************)

Definition ppow p n := match n with  Zpos q => iter_pos q _ (pmult p) (1, 0)  | _ => (1, 0) end.

(**************************************
  Some properties of ppow
 **************************************)

Theorem ppow_0: forall n, ppow n 0 = (1, 0).
simpl; auto.
Qed.

Theorem ppow_1: forall n, ppow (1, 0) n = (1, 0).
intros n; case n; simpl; auto.
intros p; apply iter_pos_invariant with (Inv := fun x => x = (1, 0)); auto.
intros x H; rewrite H; auto.
Qed.

Theorem ppow_op: forall a b p, iter_pos p _ (pmult a) b = pmult (iter_pos p _ (pmult a) (1, 0)) b.
intros a b p; generalize b; elim p; simpl; auto; clear  b p.
intros p Rec b.
rewrite (Rec b).
try rewrite (fun x y => Rec (pmult x y)); try rewrite (fun x y => Rec (iter_pos p _ x y)); auto.
repeat rewrite pmult_assoc; auto.
intros p Rec b.
rewrite (Rec b); try rewrite (fun x y => Rec (pmult x y)); try rewrite (fun x y => Rec (iter_pos p _ x y)); auto.
repeat rewrite pmult_assoc; auto.
intros b; rewrite pmult_1_r; auto.
Qed.

Theorem ppow_add: forall n m p, 0 <= m -> 0 <= p ->  ppow n (m + p) = pmult (ppow n m) (ppow n p).
intros n m; case m; clear m.
intros p _ _; rewrite ppow_0; rewrite pmult_1_l; auto.
2: intros p m H; contradict H; auto with zarith.
intros p1 m _; case m.
intros _; rewrite Zplus_0_r; simpl; apply sym_equal; apply pmult_1_r.
2: intros p2 H; contradict H; auto with zarith.
intros p2 _; simpl.
rewrite iter_pos_plus.
rewrite ppow_op; auto.
Qed.

Theorem ppow_ppow: forall n m p, 0 <= n -> 0 <= m -> ppow p (n * m ) = ppow (ppow p n) m.
intros n m; case n.
intros p _ Hm; rewrite Zmult_0_l.
rewrite ppow_0; apply sym_equal; apply ppow_1.
2: intros p p1 H; contradict H; auto with zarith.
intros p1 p _; case m; simpl; auto.
intros p2 _;  pattern p2; apply Pind; simpl; auto.
rewrite Pmult_1_r; rewrite pmult_1_r; auto.
intros p3 Rec; rewrite Pplus_one_succ_r; rewrite Pmult_plus_distr_l.
rewrite Pmult_1_r.
simpl; repeat rewrite iter_pos_plus; simpl.
rewrite pmult_1_r.
rewrite ppow_op; try rewrite Rec; auto.
apply sym_equal; apply ppow_op; auto.
Qed.

Theorem ppow_mult: forall n m p, 0 <= n -> ppow (pmult m p) n = pmult (ppow m n) (ppow p n).
intros n m p; case n; simpl; auto.
intros p1 _; pattern p1; apply Pind; simpl; auto.
repeat rewrite pmult_1_r; auto.
intros p3 Rec; rewrite Pplus_one_succ_r.
repeat rewrite iter_pos_plus; simpl.
repeat rewrite (fun x y z => ppow_op x (pmult y z)) ; auto.
rewrite Rec.
repeat rewrite pmult_1_r; auto.
repeat rewrite <- pmult_assoc; try eq_tac; auto.
rewrite (fun x y => pmult_comm (iter_pos p3 _ x y) p); auto.
rewrite (pmult_assoc m); try apply pmult_comm; auto.
Qed.

(**************************************
  We can now define our series of pairs s
 **************************************)

Definition s n := pplus (ppow w (2 ^ n)) (ppow v (2 ^ n)).

(**************************************
  Some properties of s
 **************************************)

Theorem s0 : s 0 = (4, 0).
simpl; auto.
Qed.

Theorem sn_aux: forall n, 0 <= n -> s (n+1) = (pplus (pmult (s n) (s n)) (-2, 0)).
intros n Hn.
assert (Hu: 0 <= 2 ^n); auto with zarith.
apply Zlt_le_weak; apply Zpower_lt_0; auto with zarith.
set (y := (fst (s n) * fst (s n) - 2, 0)).
unfold s; simpl; rewrite Zpower_exp; auto with zarith.
rewrite Zpower_exp_1; rewrite ppow_ppow; auto with zarith.
repeat rewrite pplus_pmult_dist_r || rewrite pplus_pmult_dist_l.
repeat rewrite <- pplus_assoc.
eq_tac; auto.
pattern 2 at 2; replace 2 with (1 + 1); auto with zarith.
rewrite ppow_add; auto with zarith; simpl.
rewrite pmult_1_r; auto.
rewrite Zmult_comm; rewrite ppow_ppow; simpl; auto with zarith.
repeat rewrite <- ppow_mult; auto with zarith.
rewrite (pmult_comm v w); rewrite w_mult_v.
rewrite ppow_1.
repeat rewrite tpower_1.
rewrite pplus_comm; repeat rewrite <- pplus_assoc;
rewrite pplus_comm; repeat rewrite <- pplus_assoc.
simpl; case (ppow (7, -4) (2 ^n)); simpl; intros z1 z2; eq_tac; auto with zarith.
Qed.

Theorem sn_snd: forall n, snd (s n) = 0.
intros n; case n; simpl; auto.
intros p; pattern p; apply Pind; auto.
intros p1 H; rewrite Zpos_succ_morphism; unfold Zsucc.
rewrite sn_aux; auto with zarith.
generalize H; case (s (Zpos p1)); simpl.
intros x y H1; rewrite H1; auto with zarith.
Qed.

Theorem sn: forall n, 0 <= n -> s (n+1) = (fst (s n) * fst  (s n) -2, 0).
intros n Hn; rewrite sn_aux; generalize (sn_snd n); case (s n); auto.
intros x y H; simpl in H; rewrite H; simpl.
eq_tac; ring.
Qed.

Theorem sn_w: forall n, 0 <= n ->  ppow w (2 ^ (n + 1)) = pplus (pmult (s n) (ppow w (2 ^ n))) (- 1, 0).
intros n H; unfold s; simpl; rewrite Zpower_exp; auto with zarith.
assert (Hu: 0 <= 2 ^n); auto with zarith.
apply Zlt_le_weak; apply Zpower_lt_0; auto with zarith.
rewrite Zpower_exp_1; rewrite ppow_ppow; auto with zarith.
repeat rewrite pplus_pmult_dist_r || rewrite pplus_pmult_dist_l.
pattern 2 at 2; replace 2 with (1 + 1); auto with zarith.
rewrite ppow_add; auto with zarith; simpl.
rewrite pmult_1_r; auto.
repeat rewrite <- ppow_mult; auto with zarith.
rewrite (pmult_comm v w); rewrite w_mult_v.
rewrite ppow_1; simpl.
simpl; case (ppow (7, 4) (2 ^n)); simpl; intros z1 z2; eq_tac; auto with zarith.
Qed.

Theorem sn_w_next: forall n, 0 <= n ->  ppow w (2 ^ (n + 1)) = pplus (pmult (s n) (ppow w (2 ^ n))) (- 1, 0).
intros n H; unfold s; simpl; rewrite Zpower_exp; auto with zarith.
assert (Hu: 0 <= 2 ^n); auto with zarith.
apply Zlt_le_weak; apply Zpower_lt_0; auto with zarith.
rewrite Zpower_exp_1; rewrite ppow_ppow; auto with zarith.
repeat rewrite pplus_pmult_dist_r || rewrite pplus_pmult_dist_l.
pattern 2 at 2; replace 2 with (1 + 1); auto with zarith.
rewrite ppow_add; auto with zarith; simpl.
rewrite pmult_1_r; auto.
repeat rewrite <- ppow_mult; auto with zarith.
rewrite (pmult_comm v w); rewrite w_mult_v.
rewrite ppow_1; simpl.
simpl; case (ppow (7, 4) (2 ^n)); simpl; intros z1 z2; eq_tac; auto with zarith.
Qed.

Section Lucas.

Variable p: Z.

(**************************************
  Definition of the mersenne number
 **************************************)

Definition Mp := 2^p -1.

Theorem mersenne_pos:  1 < p -> 1 < Mp.
intros H; unfold Mp; assert (2 < 2 ^p); auto with zarith.
apply Zlt_le_trans with (2^2); auto with zarith.
refine (refl_equal _).
apply Zpower_le_monotone; auto with zarith.
Qed.

Hypothesis p_pos2: 2 < p.

(**************************************
  We suppose that the mersenne number divides s
 **************************************)

Hypothesis Mp_divide_sn: (Mp  | fst (s (p - 2))).

Variable q: Z.

(**************************************
  We take a divisor of Mp and shows that Mp <= q^2, hence Mp is prime
 **************************************)

Hypothesis q_divide_Mp: (q | Mp).

Hypothesis q_pos2: 2 < q.

Theorem q_pos: 1 < q.
apply Zlt_trans with (2 := q_pos2); auto with zarith.
Qed.

(**************************************
  The definition of the groups of inversible pairs
 **************************************)

Definition pgroup := PGroup q q_pos.

Theorem w_in_pgroup: (In w pgroup.(FGroup.s)).
generalize q_pos; intros HM.
generalize q_pos2; intros HM2.
assert (H0: 0 < q); auto with zarith.
simpl; apply isupport_is_in; auto.
assert (zpmult q w (2, q - 1) = (1, 0)).
unfold zpmult, w, pmult, base; repeat (rewrite Zmult_1_r || rewrite Zmult_1_l).
eq_tac.
apply trans_equal with ((3 * q + 1) mod q).
eq_tac; auto with zarith.
rewrite Zmod_plus; auto.
rewrite Zmod_mult; auto.
rewrite Z_mod_same; auto with zarith.
rewrite Zmult_0_r; repeat rewrite Zmod_def_small; auto with zarith.
apply trans_equal with (2 * q mod q).
eq_tac; auto with zarith.
apply Zdivide_mod; auto with zarith; exists 2; auto with zarith.
apply is_inv_true with (2, q - 1); auto.
apply mL_in; auto with zarith.
intros; apply zpmult_1_l; auto with zarith.
intros; apply zpmult_1_r; auto with zarith.
rewrite zpmult_comm; auto.
apply mL_in; auto with zarith.
unfold w; apply mL_in; auto with zarith.
Qed.

Theorem e_order_divide_order: (e_order P_dec w pgroup | g_order pgroup).
apply e_order_divide_g_order.
apply w_in_pgroup.
Qed.

Theorem order_lt:  g_order pgroup < q * q.
unfold g_order, pgroup, PGroup; simpl.
rewrite <- (Z_of_nat_Zabs_nat (q * q)); auto with zarith.
rewrite <- mL_length; auto with zarith.
apply inj_lt; apply isupport_length_strict with (0, 0).
apply mL_ulist.
apply mL_in; auto with zarith.
intros a _; left; rewrite zpmult_0_l; auto with zarith.
intros; discriminate.
Qed.

(**************************************
  The power function zpow: a^n
 **************************************)

Definition zpow a := gpow a pgroup.

(**************************************
  Some properties of zpow
 **************************************)

Theorem zpow_def:
  forall a b, In a pgroup.(FGroup.s) -> 0 <= b ->
     zpow a b = ((fst (ppow a b)) mod q, (snd (ppow a b)) mod q).
generalize q_pos; intros HM.
generalize q_pos2; intros HM2.
assert (H0: 0 < q); auto with zarith.
intros a b Ha Hb; generalize Hb; pattern b; apply natlike_ind; auto.
intros _; repeat rewrite Zmod_def_small; auto with zarith.
rewrite ppow_0; simpl; auto with zarith.
unfold zpow; intros n1 H Rec _; unfold Zsucc.
rewrite gpow_add; auto with zarith.
rewrite ppow_add; simpl; try rewrite pmult_1_r; auto with zarith.
rewrite Rec; unfold zpmult; auto with zarith.
case (ppow a n1); case a; unfold pmult, fst, snd.
intros x y z t.
repeat (rewrite Zmult_1_r || rewrite Zmult_0_r || rewrite Zplus_0_r || rewrite Zplus_0_l); eq_tac.
repeat rewrite (fun u v => Zmod_plus (u * v)); auto.
eq_tac; try eq_tac; auto.
repeat rewrite (Zmod_mult z); auto with zarith.
repeat rewrite (fun u v => Zmod_mult (u * v)); auto.
eq_tac; try eq_tac; auto with zarith.
repeat rewrite (Zmod_mult base); auto with zarith.
eq_tac; try eq_tac; auto with zarith.
apply Zmod_mod; auto.
apply Zmod_mod; auto.
repeat rewrite (fun u v => Zmod_plus (u * v)); auto.
eq_tac; try eq_tac; auto.
repeat rewrite (Zmod_mult z); auto with zarith.
repeat rewrite (Zmod_mult t); auto with zarith.
Qed.

Theorem zpow_w_n_minus_1: zpow w (2 ^ (p - 1)) = (-1 mod q, 0).
generalize q_pos; intros HM.
generalize q_pos2; intros HM2.
assert (H0: 0 < q); auto with zarith.
rewrite zpow_def.
replace (p - 1) with ((p - 2) + 1); auto with zarith.
rewrite sn_w; auto with zarith.
generalize Mp_divide_sn (sn_snd (p - 2)); case (s (p -2)); case (ppow w (2 ^ (p -2))).
unfold fst, snd; intros x y z t H1 H2; unfold pmult, pplus; subst.
repeat (rewrite Zmult_0_l || rewrite Zmult_0_r || rewrite Zplus_0_l || rewrite Zplus_0_r).
assert (H2: z mod q = 0).
case H1; intros q1 Hq1; rewrite Hq1.
case q_divide_Mp; intros q2 Hq2; rewrite Hq2.
rewrite Zmod_mult; auto.
rewrite (Zmod_mult q2); auto.
rewrite Z_mod_same; auto with zarith.
repeat (rewrite Zmult_0_r; rewrite (Zmod_def_small 0)); auto with zarith.
assert (H3:  forall x, (z * x) mod q = 0).
intros y1; rewrite Zmod_mult; try rewrite H2; auto.
assert (H4:  forall x y,  (z * x +  y) mod q = y mod q).
intros x1 y1; rewrite Zmod_plus; try rewrite H3; auto.
rewrite Zplus_0_l; apply Zmod_mod; auto.
eq_tac; auto.
apply w_in_pgroup.
apply Zlt_le_weak; apply Zpower_lt_0; auto with zarith.
Qed.

Theorem zpow_w_n: zpow w (2 ^ p) = (1, 0).
generalize q_pos; intros HM.
generalize q_pos2; intros HM2.
assert (H0: 0 < q); auto with zarith.
replace p with ((p - 1) + 1); auto with zarith.
rewrite Zpower_exp; try rewrite Zpower_exp_1; auto with zarith.
unfold zpow; rewrite gpow_gpow; auto with zarith.
generalize zpow_w_n_minus_1; unfold zpow; intros H1; rewrite H1; clear H1.
simpl; unfold zpmult, pmult.
repeat (rewrite Zmult_0_l || rewrite Zmult_0_r || rewrite Zplus_0_l ||
              rewrite Zplus_0_r || rewrite Zmult_1_r).
eq_tac; auto.
pattern (-1 mod q) at 1; rewrite <- (Zmod_mod (-1) q); auto with zarith.
repeat rewrite <- Zmod_mult; auto.
rewrite Zmod_def_small; auto with zarith.
apply w_in_pgroup.
apply Zlt_le_weak; apply Zpower_lt_0; auto with zarith.
Qed.

(**************************************
  As e = (1, 0), the previous equation implies that the order of the group divide 2^p
 **************************************)

Theorem e_order_divide_pow: (e_order P_dec w pgroup | 2 ^ p).
generalize q_pos; intros HM.
generalize q_pos2; intros HM2.
assert (H0: 0 < q); auto with zarith.
apply e_order_divide_gpow.
apply w_in_pgroup.
apply Zlt_le_weak; apply Zpower_lt_0; auto with zarith.
exact zpow_w_n.
Qed.

(**************************************
  So it is less than equal
 **************************************)

Theorem e_order_le_pow : e_order P_dec w pgroup <= 2 ^ p.
apply Zdivide_le.
apply Zlt_le_weak; apply e_order_pos.
apply Zpower_lt_0; auto with zarith.
apply e_order_divide_pow.
Qed.

(**************************************
  So order(w) must be 2^q
 **************************************)

Theorem e_order_eq_pow:  exists q, (e_order P_dec w pgroup)  = 2 ^ q.
case (Zdivide_power_2 (e_order P_dec w pgroup) p); auto with zarith.
apply Zlt_le_weak; apply e_order_pos.
apply e_order_divide_pow; auto.
intros x H; exists x; auto with zarith.
Qed.

(**************************************
  Buth this q can only be p otherwise it would contradict w^2^(p -1) = (-1, 0)
 **************************************)

Theorem e_order_eq_p: e_order P_dec w pgroup = 2 ^ p.
case (Zdivide_power_2 (e_order P_dec w pgroup) p); auto with zarith.
apply Zlt_le_weak; apply e_order_pos.
apply e_order_divide_pow; auto.
intros p1 Hp1.
case (Zle_lt_or_eq p1 p); try (intro H1; subst; auto; fail).
case (Zle_or_lt p1 p); auto; intros H1.
absurd (2 ^ p1 <= 2 ^ p); auto with zarith.
apply Zlt_not_le; apply Zpower_lt_monotone; auto with zarith.
apply Zdivide_le.
apply Zlt_le_weak; apply Zpower_lt_0; auto with zarith.
apply Zpower_lt_0; auto with zarith.
rewrite <- Hp1; apply e_order_divide_pow.
intros H1.
assert (Hu: 0 <= p1).
generalize Hp1; case p1; simpl; auto with zarith.
intros p2 Hu; absurd (0 < e_order  P_dec w pgroup).
rewrite Hu; auto with zarith.
apply e_order_pos.
absurd (zpow w (2 ^ (p - 1)) = (1, 0)).
rewrite zpow_w_n_minus_1.
intros H2; injection H2; clear H2; intros H2.
assert (H0: 0 < q); auto with zarith.
absurd (0 mod q = 0).
pattern 0 at 1; replace 0 with (-1 + 1); auto with zarith.
rewrite Zmod_plus; auto with zarith.
rewrite H2; rewrite (Zmod_def_small 1); auto with zarith.
rewrite Zmod_def_small; auto with zarith.
rewrite Zmod_def_small; auto with zarith.
unfold zpow; apply (gpow_pow _ _ w pgroup) with p1; auto with zarith.
apply w_in_pgroup.
rewrite <- Hp1.
apply (gpow_e_order_is_e _ P_dec _ w pgroup).
apply w_in_pgroup.
Qed.

(**************************************
  We have then the expected conclusion
 **************************************)

Theorem q_more_than_square:  Mp <  q * q.
unfold Mp.
assert (2 ^ p <= q * q); auto with zarith.
rewrite <- e_order_eq_p.
apply Zle_trans with (g_order pgroup).
apply Zdivide_le; auto with zarith.
apply Zlt_le_weak; apply e_order_pos; auto with zarith.
2: apply e_order_divide_order.
2: apply Zlt_le_weak; apply order_lt.
apply Zlt_le_trans with 2; auto with zarith.
replace 2 with (Z_of_nat (length ((1, 0)::w::nil))); auto.
unfold g_order; apply inj_le.
apply ulist_incl_length.
apply ulist_cons; simpl; auto.
unfold w; intros [H2 | H2];  try (case H2; fail); discriminate.
intro a; simpl; intros [H1 | [H1 | H1]]; subst.
assert (In (1, 0) (mL q)).
apply mL_in; auto with zarith.
apply isupport_is_in; auto.
apply is_inv_true with (1, 0); simpl; auto.
intros; apply zpmult_1_l; auto with zarith.
intros; apply zpmult_1_r; auto with zarith.
rewrite zpmult_1_r; auto with zarith.
rewrite zpmult_1_r; auto with zarith.
exact w_in_pgroup.
case H1.
Qed.

End Lucas.

(**************************************
  We build the sequence in Z
 **************************************)

Definition SS p :=
  let n := Mp p in
  match p - 2 with
    Zpos p1 => iter_pos p1 _ (fun x => Zmodd (Zsquare x - 2) n) (Zmodd 4 n)
  | _ => (Zmodd 4 n)
  end.

Theorem SS_aux_correct:
  forall p z1 z2 n, 0 <= n -> 0 < z1 -> z2 = fst (s n) mod z1 ->
        iter_pos p _ (fun x => Zmodd (Zsquare x - 2) z1) z2 = fst (s (n + Zpos p)) mod z1.
intros p; pattern p; apply Pind.
simpl.
intros z1 z2 n Hn H H1; rewrite sn; auto; rewrite H1;  rewrite Zmodd_correct; rewrite Zsquare_correct; simpl.
unfold Zminus; rewrite Zmod_plus; auto.
rewrite (Zmod_plus (fst (s n) * fst (s n))); auto with zarith.
eq_tac; auto.
eq_tac; auto.
apply sym_equal; apply Zmod_mult; auto.
intros n Rec z1 z2 n1 Hn1 H1 H2.
rewrite Pplus_one_succ_l; rewrite iter_pos_plus.
rewrite Rec with (n0 := n1); auto.
replace (n1 + Zpos (1 + n)) with ((n1 + Zpos n) + 1); auto with zarith.
rewrite sn; simpl; try rewrite Zmodd_correct; try rewrite Zsquare_correct; simpl; auto with zarith.
unfold Zminus; rewrite Zmod_plus; auto.
unfold Zmodd.
rewrite (Zmod_plus (fst (s (n1 + Zpos n)) * fst (s (n1 + Zpos n)))); auto with zarith.
eq_tac; auto.
eq_tac; auto.
apply sym_equal; apply Zmod_mult; auto.
rewrite Zpos_plus_distr; auto with zarith.
Qed.

Theorem SS_prop: forall n, 1 < n -> SS n = fst(s (n -2)) mod (Mp n).
intros n Hn; unfold SS.
cut (0 <= n - 2); auto with zarith.
case (n - 2).
intros _; rewrite Zmodd_correct; rewrite s0; auto.
intros p1 H2; rewrite SS_aux_correct with (n := 0); auto with zarith.
apply Zle_lt_trans with 1; try apply mersenne_pos; auto with zarith.
rewrite Zmodd_correct; rewrite s0; auto.
intros p1 H2; case H2; auto.
Qed.

Theorem SS_prop_cor: forall p, 1 < p -> SS p = 0 -> (Mp p | fst(s (p -2))).
intros p H H1.
apply Zmod_divide.
assert (Mp p > 0).
apply Zlt_gt; apply Zlt_trans with 1; try apply mersenne_pos; auto with zarith.
omega.
apply trans_equal with (2:= H1); apply sym_equal; apply SS_prop; auto.
Qed.

Theorem LucasLehmer:  forall p, 2 < p -> SS p = 0 -> prime (Mp p).
intros p H H1; case (prime_dec (Mp p)); auto; intros H2.
case Zdivide_div_prime_le_square with (2 := H2).
apply mersenne_pos; apply Zlt_trans with 2; auto with zarith.
intros q (H3, (H4, H5)).
contradict H5; apply Zlt_not_le.
apply q_more_than_square; auto.
apply SS_prop_cor; auto.
apply Zlt_trans with 2; auto with zarith.
case (Zle_lt_or_eq 2 q); auto.
apply prime_le_2; auto.
intros H5; subst.
absurd (2 <= 1); auto with arith.
apply Zdivide_le; auto with zarith.
case H4; intros x Hx.
exists (2 ^ (p -1) - x).
rewrite Zmult_minus_distr_r; rewrite <- Hx; unfold Mp.
pattern 2 at 2; rewrite <- Zpower_exp_1; rewrite <- Zpower_exp; auto with zarith.
replace (p - 1 + 1) with p; auto with zarith.
Qed.

(**************************************
  The test
 **************************************)

Definition lucas_test  n :=
   if Z_lt_dec 2 n then if Z_eq_dec (SS n) 0 then true else false else false.

Theorem LucasTest: forall n, lucas_test n = true -> prime (Mp n).
intros n; unfold lucas_test; case (Z_lt_dec 2 n); intros H1; try (intros; discriminate).
case (Z_eq_dec (SS n) 0); intros H2; try (intros; discriminate).
intros _; apply LucasLehmer; auto.
Qed.

Theorem prime7: prime 7.
exact (LucasTest 3 (refl_equal _)).
Qed.

Theorem prime31: prime 31.
exact (LucasTest 5 (refl_equal _)).
Qed.

Theorem prime127: prime 127.
exact (LucasTest 7 (refl_equal _)).
Qed.

Theorem prime8191: prime 8191.
exact (LucasTest 13 (refl_equal _)).
Qed.

Theorem prime131071: prime 131071.
exact (LucasTest 17 (refl_equal _)).
Qed.

Theorem prime524287: prime 524287.
exact (LucasTest 19 (refl_equal _)).
Qed.