(** * Utils *)
(** Common definitions including:
 -  theorems about lists and permutation.
 -  the induction scheme for Strong Induction
 -  some arithmetic results (specially dealing with [max] and [min])
 *)

Require Export Coq.Relations.Relations.
Require Export Coq.Classes.Morphisms.
Require Export Permutation.
Require Import Coq.Relations.Relations.
Require Import Coq.Setoids.Setoid.
Require Export Coq.Sorting.PermutSetoid.
Require Export Coq.Sorting.PermutEq.
Require Import Coq.Program.Equality.
Require Export Coq.Lists.List.
Require Export Coq.Sorting.Permutation.
Require Export Coq.Arith.Arith.
Require Export Coq.Init.Nat.
Require Import Lia.

Export ListNotations.

Set Implicit Arguments.

Lemma NatComp : forall x y, x >= y + 1 -> S x - y - 2 = x - y - 1.
Proof with subst;auto. lia.
Qed.

(** ** Additional results about permutations *)
Section Permutations.

  Variable A:Type.

Lemma ListConsApp (a b: A) : forall L M , a :: L = M ++ [b] ->
       (L=[]/\M=[]/\a=b) \/ exists X, M = a :: X /\ L = X++[b].
Proof with subst;auto.
  induction M; intros...
  * inversion H...
  * rewrite <- app_comm_cons in H.
    inversion H;subst...
    right.
    exists M...
 Qed.

 Lemma ListConsApp' (a b: A) : forall L M1 M2 , a :: L = M1 ++ [b] ++ M2 ->
        (L=M2/\M1=[]/\a=b) \/
       exists X, M1 = a :: X /\ L = X++[b]++M2.
Proof with subst;auto.
  destruct M1;intros...
  * inversion H;subst...
  * rewrite <- app_comm_cons in H.
    inversion H;subst...
    right.
    exists M1...
 Qed.

  Lemma ListConsApp'' (a : A) M1: forall L M2 , a :: L = M1 ++ M2 ->
       (M1=[ ]/\M2=a::L) \/
       exists X, M1 = a :: X /\ L = X++M2.
Proof with subst;auto.
  induction M1;intros...
  rewrite <- app_comm_cons in H.
   inversion H;subst...
   right.
   exists M1...
 Qed.

  Lemma Perm_swap_inv : forall (x y : A) (N M : list A),
      Permutation (x :: N) (y :: x :: M) ->
      Permutation N ( y :: M).
    intros.
    rewrite perm_swap in H.
    apply Permutation_cons_inv in H;auto.
  Qed.

  Lemma Perm_swap_inv_app : forall y N M (x : A) ,
      Permutation (x :: N) (y ++ x :: M) ->
      Permutation N ( y ++ M).
    intros.
    rewrite  (Permutation_cons_append M x) in H.
    rewrite  Permutation_cons_append in H.
    rewrite app_assoc in H.
    rewrite  <- Permutation_cons_append in H.
    rewrite  <- (Permutation_cons_append (y ++ M) x ) in H.
    apply Permutation_cons_inv in H;auto.
  Qed.

  Theorem PermutConsApp: forall (a : A) l1 b l2,
      Permutation (a :: l1 ++ b :: l2) (b :: a :: l1 ++ l2).
    intros.
    rewrite perm_swap.
    rewrite <- Permutation_middle.
    auto.
  Qed.

  Lemma PermutationInCons : forall (F:A) M N,
      Permutation (F::M) N -> In F N.
    intros.
    eapply Permutation_in with (x:= F) (l':=N);eauto.
    constructor;auto.
  Qed.

  (** A slightly different version of  [Permutation_map] *)
  Lemma PermuteMap : forall (L L' : list A) (f: A->Prop),
      Forall f L -> Permutation L L'-> Forall f L'.
    intros.
    apply Permutation_sym in H0.
    assert(forall x, In x L' -> In x L) by eauto using Permutation_in.
    rewrite Forall_forall in H.
    rewrite Forall_forall;intros.
    firstorder.
  Qed.

(* Permutation_app_inv *)
  Lemma Permutation_mid : forall (F:A) l1 l2 l1' l2',
      Permutation (l1 ++ F :: l2) (l1' ++ F :: l2') ->
      Permutation (l1 ++ l2) (l1' ++ l2').
    intros.
    assert(Permutation (F::l2) (l2 ++ [F]))
      by  apply Permutation_cons_append.
    rewrite H0 in H.
    assert(Permutation (F::l2') (l2' ++ [F]))
      by  apply Permutation_cons_append.
    rewrite H1 in H.
    apply Permutation_app_inv_r with (l:= [F]).
    do 2 rewrite app_assoc_reverse;auto.
  Qed.

 (* perm_takeit_5 *)
  Lemma Permutation_midle : forall  (F:A) l1 l2,
      Permutation (l1 ++ F :: l2) ( F :: l1  ++ l2).
    intros.
    generalize (Permutation_cons_append  l1 F);intro.
    change (F::l1++l2) with ( (F::l1) ++ l2).
    rewrite H.
    assert(l1 ++ F :: l2 = (l1 ++ [F]) ++ l2).
    rewrite app_assoc_reverse;auto.
    rewrite H0.
    auto.
  Qed.

(* Permutation_app_swap_app *)
  Lemma Permutation_midle_app : forall  (la lb lc: list A),
      Permutation (la ++ lb ++ lc) ( lb ++ la  ++ lc).
    intros.
    rewrite <- app_assoc_reverse.
    rewrite Permutation_app_comm with (l:=la).
    rewrite app_assoc_reverse;auto.
  Qed.

  Lemma InPermutation : forall (l:A) L,
      In l L -> exists L', Permutation L (l :: L').
    induction L;intros.
    inversion H.
    inversion H;subst.
    exists L;auto.
    apply IHL in H0.
    destruct H0 as [L' H0].
    exists (a :: L').
    rewrite H0.
    constructor.
  Qed.

End Permutations.

(** ** Strong Induction *)

Section StrongIndPrinciple.

  Variable P: nat -> Prop.

  Hypothesis P0: P O.

  Hypothesis Pn: forall n, (forall m, m<=n -> P m) -> P (S n).

  Lemma strind_hyp : forall n, (forall m, ((m <= n) -> P m)).
  Proof.
    induction n; intros m H;inversion H;auto.
  Qed.
  (** Strong induction principle *)
  Theorem strongind: forall n, P n.
  Proof.
    induction n; auto.
    apply Pn.
    apply strind_hyp.
  Qed.

End StrongIndPrinciple.

(** ** Aditional results on Arithmentic *)
Section Arithmentic.

  Lemma MaxPlus : forall a b, (max a b <= plus a  b).
    intros;lia.
  Qed.

  Lemma MaxPlus' : forall a b c, (plus a b <= c -> max a b <= c).
    intros;lia.
  Qed.

  Theorem GtExists : forall n, n>0 -> exists n', n = S n'.
    intros.
    destruct n;inversion H;subst;eauto.
  Qed.

End Arithmentic.

Ltac mgt0 := let H := fresh "H" in
             match goal with [_ :  ?m >= S _ |- _] =>
                             assert(H : m>0) by lia;
                             apply GtExists in H;
                             destruct H;subst
             end.

Section Pairs.

Variable S:Type. (* SubExps *)
Variable F:Type. (* Formulas *)

(* fst (split L) *)
Definition first (L:list (S * F)) :=  map fst L.
(* snd (split L) *)
Definition second (L:list (S * F)) := map snd L.

Lemma secondApp C1 C2 : second (C1 ++ C2) = second C1 ++ second C2.
Proof.
  induction C1;simpl.
  reflexivity.
  rewrite IHC1.
  reflexivity. Qed.

Lemma firstApp C1 C2 : first (C1 ++ C2) = first C1 ++ first C2.
Proof.
  induction C1;simpl.
  reflexivity.
  rewrite IHC1.
  reflexivity. Qed.

Lemma InFirst c B : In c B -> In (fst c) (first B).
Proof.
 induction B;intros;auto.
 unfold second.
 inversion H;subst;auto;
 simpl;auto.
 Qed.

Lemma InSecond c B : In c B -> In (snd c) (second B).
Proof.
 induction B;intros;auto.
 unfold second.
 inversion H;subst;auto;
 simpl;auto.
 Qed.

 Lemma InSecondInv i A B : In (i,A) B -> In A (second B).
Proof.
 induction B;intros;auto.
 inversion H;subst;auto;
 simpl;auto.
 Qed.

 End Pairs.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Require Import Classical.

Coq < Section Exercise_8.

Coq < Goal forall j k b s:Prop, (~(j \/ k) /\ (b -> k) /\ (s -> b)) -> (~s /\ ~j).
1 subgoal

  ============================
   forall j k b s : Prop, ~ (j \/ k) /\ (b -> k) /\ (s -> b) -> ~ s /\ ~ j

Unnamed_thm < intros.
1 subgoal

  j : Prop
  k : Prop
  b : Prop
  s : Prop
  H : ~ (j \/ k) /\ (b -> k) /\ (s -> b)
  ============================
   ~ s /\ ~ j

Unnamed_thm < elim H.
1 subgoal

  j : Prop
  k : Prop
  b : Prop
  s : Prop
  H : ~ (j \/ k) /\ (b -> k) /\ (s -> b)
  ============================
   ~ (j \/ k) -> (b -> k) /\ (s -> b) -> ~ s /\ ~ j

Unnamed_thm < intro.
1 subgoal

  j : Prop
  k : Prop
  b : Prop
  s : Prop
  H : ~ (j \/ k) /\ (b -> k) /\ (s -> b)
  H0 : ~ (j \/ k)
  ============================
   (b -> k) /\ (s -> b) -> ~ s /\ ~ j

Unnamed_thm < intro.
1 subgoal

  j : Prop
  k : Prop
  b : Prop
  s : Prop
  H : ~ (j \/ k) /\ (b -> k) /\ (s -> b)
  H0 : ~ (j \/ k)
  H1 : (b -> k) /\ (s -> b)
  ============================
   ~ s /\ ~ j

Unnamed_thm < apply conj.
2 subgoals

  j : Prop
  k : Prop
  b : Prop
  s : Prop
  H : ~ (j \/ k) /\ (b -> k) /\ (s -> b)
  H0 : ~ (j \/ k)
  H1 : (b -> k) /\ (s -> b)
  ============================
   ~ s

subgoal 2 is:
 ~ j

Unnamed_thm < firstorder.
1 subgoal

  j : Prop
  k : Prop
  b : Prop
  s : Prop
  H : ~ (j \/ k) /\ (b -> k) /\ (s -> b)
  H0 : ~ (j \/ k)
  H1 : (b -> k) /\ (s -> b)
  ============================
   ~ j

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
apply conj.
 firstorder .

 firstorder .

Unnamed_thm is defined

Coq <
*)

Require Import Classical.
Section Exercise_8.
Goal forall j k b s:Prop, (~(j \/ k) /\ (b -> k) /\ (s -> b)) -> (~s /\ ~j).
intros.
elim H.
intro.
intro.
apply conj.
 firstorder.
 firstorder.
Qed.


Require Import List.

Inductive RoseTree (A : Type) : Type :=
| E : RoseTree A
| N : A -> list (RoseTree A) -> RoseTree A.

(** Okazuje się, że [decide_equality] potrafi udowodnić, że [RoseTree A] ma rozstrzygalną równość. *)
Lemma RoseTree_eq_dec :
  forall
    (A : Type) (A_eq_dec : forall x y : A, {x = y} + {x <> y})
      (x y : RoseTree A), {x = y} + {x <> y}.
Proof.
  fix RoseTree_eq_dec 3.
  decide equality.
  apply list_eq_dec. apply RoseTree_eq_dec. assumption.
Defined.

(** Uwaga: to całkiem dziwne, że poszło aż tak łatwo, bo przecież funkcja którą definiujemy
    jest użyta rekurencyjnie jako argument [list_eq_dec], tzn. mamy do czynienia z rekursją
    wyższego rzędu. *)


Require Import Coq.Relations.Relation_Definitions.
Require Export Coq.Classes.SetoidClass.
Require Import Coq.Classes.Equivalence.

Require Import Quotient.quotient.
From Quotient.Construction Require Import function_util equalizer coequalizer.

Open Scope equiv_scope.

Program Definition power_setoid {A: Type} : Setoid (A -> bool) := {| setoid_equiv := @pointwise_equivalence A _ eq _ |}.

Definition power_exists := forall (A : Type), quotient (A -> bool) power_setoid.
Class axiom_power_exists :=
  {
    proof_power_exists : power_exists
  }.

Section Power.

  Context {instance_power_exists : axiom_power_exists}.

  Definition power (A : Type) : Type := q_type _ _ (proof_power_exists A).
  Definition to_power {A : Type} : (A -> bool) -> power A := q_proj _ _ (proof_power_exists A).

  Lemma epi_to_power {A} : epi (@to_power A).
  Proof.
    apply quotient_proj_epi.
  Qed.

  Global Instance to_power_Proper {A} : Proper (Equivalence.equiv ==> eq) (@to_power A).
  Proof.
    intros f1 f2 eqf1f2.
    apply quotient_comp.
    assumption.
  Qed.

  Section Power_Univ.

    Variable A : Type.
    Variable T : Type.
    Variable F : (A -> bool) -> T.
    Variable F_proper : Proper (Equivalence.equiv ==> eq) F.

    Definition power_quotient_sig : {f : (power A) -> T | F === f_comp f to_power} :=
      (quotient_factor _ _ (proof_power_exists A))
        F F_proper.

    Definition power_quotient_f : (power A) -> T := proj1_sig power_quotient_sig.
    Definition power_quotient_f_eq : F === f_comp power_quotient_f to_power := proj2_sig power_quotient_sig.

  End Power_Univ.

  Section Power_of_power.

    Context {A : Type}.
    Definition app_bool_inv : A -> (A -> bool) -> bool := fun a f => f a.

    Lemma app_bool_inv_proper : forall a, Proper (Equivalence.equiv ==> eq) (app_bool_inv a).
    Proof.
      intro a.
      intros p1 p2 eqp.
      unfold app_bool_inv.
      apply eqp.
    Qed.

    Definition of_power (p : power A) : A -> bool := fun a => power_quotient_f _ _ _ (app_bool_inv_proper a) p.

    Lemma of_to_power_eq : forall p, of_power (to_power p) === p.
    Proof.
      intro p.
      unfold of_power.
      intro a.
      transitivity ((app_bool_inv a) p).
      rewrite (power_quotient_f_eq A bool (app_bool_inv a) (app_bool_inv_proper a) p).
      reflexivity.
      reflexivity.
    Qed.

    Lemma to_of_power_eq : forall p, to_power (of_power p) = p.
    Proof.
      apply epi_to_power.
      unfold f_comp.
      intro p.
      rewrite of_to_power_eq.
      reflexivity.
    Qed.

  End Power_of_power.

  Lemma power_extentionality : forall {A} (p1 p2 : power A), (forall a, of_power p1 a = of_power p2 a) -> p1 = p2.
  Proof.
    intros A p1 p2 ext.
    rewrite <- (to_of_power_eq p1).
    rewrite <- (to_of_power_eq p2).
    apply to_power_Proper.
    intro a.
    apply ext.
  Qed.

  Lemma power_extentionality_inv : forall {A} (p1 p2 : power A), p1 = p2 -> (forall a, of_power p1 a = of_power p2 a).
  Proof.
    intros A p1 p2 ext a.
    rewrite ext.
    reflexivity.
  Qed.

  Section Power_f.

    (* power f := S \subType B |-> { a \in A | f(a) \in S } *)
    Definition power_f {A B : Type} (f : A -> B) : (power B) -> (power A) :=
      fun pb => to_power (fun a => (of_power pb) (f a)).

    (* power_epsilon A := { S \subType A | a \in S } *)
    Definition power_epsilon (A : Type) : A -> power (power A) :=
      fun a => to_power (fun pa => (of_power pa) a).

    Global Instance power_f_Proper {A B : Type} : Proper ( Equivalence.equiv ==> Equivalence.equiv ) (@power_f A B).
    Proof.
      intros f1 f2 eqf.
      intro pb.
      apply power_extentionality.
      intro a.
      unfold power_f.
      rewrite of_to_power_eq.
      rewrite of_to_power_eq.
      rewrite eqf.
      reflexivity.
    Qed.

    Lemma power_f_comp_comm :
      forall {A B C : Type} (f : B -> C) (g : A -> B),
        power_f (f_comp f g) === f_comp (power_f g) (power_f f).
    Proof.
      intros A B C f g.
      intro pc.
      apply power_extentionality.
      apply f_equiv_eq.
      unfold power_f.
      unfold f_comp.
      intro a.
      rewrite of_to_power_eq.
      rewrite of_to_power_eq.
      rewrite of_to_power_eq.
      reflexivity.
    Qed.

    Lemma power_f_id :
      forall {A : Type},
        power_f (@id A) === id.
    Proof.
      intro A.
      unfold power_f.
      intro pa.
      unfold id.
      apply power_extentionality.
      intro a.
      rewrite of_to_power_eq.
      reflexivity.
    Qed.

    Lemma power2_epsilon_natural :
      forall {A B : Type} (f : A -> B),
        f_comp (power_epsilon B) f === f_comp (power_f (power_f f)) (power_epsilon A).
    Proof.
      intros A B f.
      intro a.
      unfold f_comp.
      unfold power_epsilon.
      unfold power_f.
      apply power_extentionality.
      intro pb.
      rewrite of_to_power_eq.
      rewrite of_to_power_eq.
      rewrite of_to_power_eq.
      rewrite of_to_power_eq.
      reflexivity.
    Qed.

    Lemma triangle_power_f :
      forall {A B C D : Type} (f : A -> B) (g : B -> D) (h : A -> C) (i : C -> D),
        f_comp g f === f_comp i h -> f_comp (power_f f) (power_f g) === f_comp (power_f h) (power_f i).
    Proof.
      intros A B C D f g h i eqH.
      rewrite <- power_f_comp_comm.
      rewrite <- power_f_comp_comm.
      rewrite eqH.
      reflexivity.
    Qed.

    Lemma principle_equalizer_eq :
      forall {A : Type}, f_comp (power_epsilon (power (power A))) (power_epsilon A) === f_comp (power_f (power_f (power_epsilon A))) (power_epsilon A).
    Proof.
      intro A.
      apply power2_epsilon_natural.
    Qed.

    Lemma power_epsilon_unit_counit :
      forall {A : Type},
        f_comp (power_f (power_epsilon A)) (power_epsilon (power A)) === id.
    Proof.
      intro A.
      intro pa.
      unfold f_comp.
      unfold id.
      apply power_extentionality.
      intro a.
      unfold power_f.
      rewrite of_to_power_eq.
      unfold power_epsilon.
      repeat rewrite of_to_power_eq.
      reflexivity.
    Qed.

  End Power_f.

  (* empty *)
  Definition empty_power (A : Type) : power A := to_power (fun a => false).
  Lemma empty_power_false : forall A a, of_power (empty_power A) a = false.
  Proof.
    intros A a.
    unfold empty_power.
    rewrite of_to_power_eq.
    reflexivity.
  Qed.
  Lemma power_f_empty_eq_empty : forall {A B : Type} (f : A -> B), power_f f (empty_power B) === empty_power A.
  Proof.
    intros A B f.
    apply power_extentionality.
    intros a.
    unfold power_f.
    rewrite of_to_power_eq.
    repeat rewrite empty_power_false.
    reflexivity.
  Qed.

  (* subset *)
  Definition subset {A : Type} (S1 S2 : power A) := forall a, of_power S1 a = true -> of_power S2 a = true.
  Lemma subset_antisym : forall A (S1 S2 : power A), subset S1 S2 -> subset S2 S1 -> S1 = S2.
  Proof.
    unfold subset.
    intros A S1 S2 subH1 subH2.
    apply power_extentionality.
    unfold subset.
    intro a.
    remember (of_power S1 a) as b1.
    destruct b1.
    symmetry.
    apply subH1.
    rewrite Heqb1.
    reflexivity.
    symmetry.
    apply Neqtrue.
    intro HH.
    symmetry in Heqb1.
    apply Neqtrue_inv in Heqb1.
    apply Heqb1.
    apply subH2.
    assumption.
  Qed.

  (* Some Axioms *)
  Definition power_reflects_iso :=
    forall (A B : Type) (f : A -> B),
      {Pg | isIsomorphism (power_f f) Pg} ->
      {g | isIsomorphism f g}.
  Definition power_f_faithful :=
    forall (A B : Type) (f1 f2 : A -> B),
      power_f f1 === power_f f2 -> f1 === f2.
  Definition preserve_reflexive_equalizer :=
    forall (A B C : Type) (g : A -> B) (f1 f2 : B -> C) (d : C -> B),
      isEqualizer f1 f2 g ->
      (f_comp d f1 === id /\ f_comp d f2 === id) ->
      isCoequalizer (power_f f1) (power_f f2) (power_f g).

  Class axiom_power_reflects_iso :=
    {
      proof_power_reflects_iso : power_reflects_iso
    }.
  Class axiom_power_f_faithful :=
    {
      proof_power_f_faithful : power_f_faithful
    }.
  Class axiom_preserve_reflexive_equalizer :=
    {
      proof_preserve_reflexive_equalizer : preserve_reflexive_equalizer
    }.

End Power.


Generalizable All Variables.
Set Implicit Arguments.
Unset Strict Implicit.
Require Export setoid monoid.

Declare Scope group_scope.
Delimit Scope group_scope with grp.
Open Scope setoid_scope.
Open Scope monoid_scope.
Open Scope group_scope.

Class LInvertible {X : Setoid} (op : X -> X -> X) e (inv : X -> X) := {
  invl : forall x, op (inv x) x == e
}.

Class RInvertible {X : Setoid} (op : X -> X -> X) e (inv : X -> X) := {
  invr : forall x, op x (inv x) == e
}.

Class Invertible `{X : Setoid} (op : X -> X -> X) e (inv : X -> X) := {
  inv_invl :> LInvertible op e inv;
  inv_invr :> RInvertible op e inv
}.
#[global] Existing Instances inv_invl inv_invr.

Class IsGroup `(mul : Binop supp) (inv : Ope supp) e :=
{
  assocg :> Associative mul;
  identrg :> RIdentical mul e;
  invrg :> RInvertible mul e inv
}.
#[global] Existing Instances assocg identrg invrg.

Structure Group := {
  gcarrier :> Setoid;
  mulg : Binop gcarrier;
  invg : Ope gcarrier;
  idg : gcarrier;

  groupsprf : IsGroup mulg invg idg
}.
#[global] Existing Instance groupsprf.

Arguments mulg {_}.
Arguments invg {_}.
Arguments idg {_}.

#[global]
Instance identlg {G} : LIdentical (@mulg G) idg.
Proof.
  split. intros x. rewrite <-identr.
  rewrite <-(invr (invg x)) at 2.
  now rewrite assoc, <-(assoc idg), invr, identr,
    <-(invr x), <-assoc, invr, identr.
Qed.

Program Coercion grps_mnds (G : Group) :=
  [ gcarrier G | *: mulg, 1: idg ].
Next Obligation.
  destruct G as [s mul inv id [A RI RV]]; split;
  [|split]; intuition.
Defined.

Program Definition ensg_ensm {X : Group} (G : {ens X})
  : {ens grps_mnds X} := G.

Notation "[ A | *: op , !: inv , 1: id ]" :=
  (@Build_Group A op inv id _)
  (at level 0, A, op, inv, id at level 99) : group_scope.
Notation "(  * 'in' G  )" := (@mulg G) : group_scope.
Notation "( * )" := ( * in _ ) : group_scope.
Notation "g * h 'in' G" := (@mulg G g h)
  (at level 40, h at next level, left associativity)
  : group_scope.
Notation "g * h" := (g * h in _) : group_scope.
Notation "1 'in' G" := (@idg G)
  (at level 0, G at level 99, no associativity) : group_scope.
Notation "1" := (1 in _) : group_scope.
Notation "(  ! 'in' G  ) " := (@invg G) : group_scope.
Notation "( ! )" := ( ! in _ ) : group_scope.
Notation "! g 'in' G" := (@invg G g)
  (at level 35, g at level 35, right associativity,
  format "! g  'in'  G") : group_scope.
Notation "! g" := ( ! g in _ )
  (at level 35, right associativity,
  format "! g") : group_scope.

Program Definition conjg {G : Group} :=
  dmap (h : G) g => !g * (h * g).
Next Obligation.
  intros g1 g2 E1 h1 h2 E2. now rewrite E1, E2.
Defined.
Notation "g ^ h" := (@conjg _ g h) : group_scope.

#[global]
Instance invlg {G} : LInvertible ( * in G ) 1 ( ! ).
Proof.
  split. intros x. rewrite <-identr. rewrite <-(invr (!x)) at 1.
  now rewrite assoc, <-(assoc _ x), invr, identr, invr.
Qed.

Section GroupTheory.
  Context {G : Group}.
  Implicit Types x y g : G.
  Lemma mulgA : forall {x y z}, x * (y * z) == (x * y) * z.
  Proof. now destruct G as [a b c d [[e] f g]]. Qed.

  Lemma mulg1 : forall x, x * 1 == x.
  Proof. now destruct G as [a b c d [e [f] g]]. Qed.

  Lemma mulgV : forall x, x * !x == 1.
  Proof. now destruct G as [a b c d [e f [g]]]. Qed.

  Lemma mul1g : forall x, 1 * x == x.
  Proof. now destruct (@identlg G). Qed.

  Lemma mulVg : forall x, !x * x == 1.
  Proof. now destruct (@invlg G). Qed.

  Lemma mulgI g {x y} : (x == y) == (x * g == y * g).
  Proof.
    split; intros H; [|rewrite <-mulg1, <-(mulg1 y),
    <-(invr g), 2!assoc]; now rewrite H.
  Qed.

  Lemma mulIg g {x y} : (x == y) == (g * x == g * y).
  Proof.
    split; intros H; [|rewrite <-mul1g, <-(mul1g y),
    <-(invl g), <-2!assoc]; now rewrite H.
  Qed.

  Lemma mulTg {g x y} : (x == !g * y) == (g * x == y).
  Proof.
    split; intros H.
    - now rewrite H, assoc, mulgV, mul1g.
    - now rewrite <-H, assoc, mulVg, mul1g.
  Qed.

  Lemma mulgT {g x y} : (x == y * !g) == (x * g == y).
  Proof.
    split; intros H.
    - now rewrite H, <-assoc, mulVg, mulg1.
    - now rewrite <-H, <-assoc, mulgV, mulg1.
  Qed.

  Lemma invgK x : !!x == x.
  Proof. apply (@mulgI (!x)). now rewrite invl, invr. Qed.

  Lemma eq_invg_sym {x y} : (!x == y) == (x == !y).
  Proof.
    split; intros H; now rewrite2 H; rewrite invgK.
  Qed.

  Lemma invMg {x y} : !(x * y) == !y * !x.
  Proof.
    rewrite <-(identr (!x)). apply mulTg, mulTg.
    now rewrite assoc, invr.
  Qed.

  Lemma invg1 : !(1 in G) == 1.
  Proof.
    rewrite <-(identr (!1)). symmetry; apply mulTg, identl.
  Qed.

  Lemma invg_inj {x y} : (y == !x) == (x * y == 1).
  Proof.
    split; intros H.
    - now rewrite H, mulgV.
    - now rewrite <-(mulg1 (!x)), <-H, assoc, mulVg, mul1g.
  Qed.

  Lemma invJK x y : ((x ^ y) ^ !y) == x.
  Proof.
    simpl. now rewrite invgK, !assoc,
      mulgV, mul1g, <-assoc, mulgV, mulg1.
  Qed.
End GroupTheory.

Class IsMorph {G H : Group} (f : Map G H) := {
  morph : forall x y, f (x * y) == (f x) * (f y) in H
}.

Structure Morph (G H : Group) := {
  homfun :> Map G H;
  homprf : IsMorph homfun
}.
#[global] Existing Instance homprf.

Notation "'hom' 'on' f" := (@Build_Morph _ _ f _)
  (at level 200, no associativity) : group_scope.
Notation "'hom' 'by' f " := (hom on (map by f))
  (at level 200, no associativity) : group_scope.
Notation " 'hom' x => m " := (hom by fun x => m)
  (at level 200, x binder, no associativity) : group_scope.
Notation "G ~~> H" := (@Morph G H)
  (at level 99, no associativity) : group_scope.

Definition morpheq {X Y} (f g : Morph X Y) :=
  homfun f == homfun g.
Program Canonical Structure MorphSetoid (X Y : Group) :=
  [ Morph X Y | ==: morpheq ].
Notation "[ G ~> H ]" := (@MorphSetoid G H)
  (at level 0, G, H at level 99, no associativity) : group_scope.

Structure Isomorph (G H : Group) := {
  isofun :> Morph G H;
  isoprf : Bijective isofun
}.
#[global] Existing Instance isoprf.

Notation "'iso' 'on' f" := (@Build_Isomorph _ _ f _)
  (at level 200, no associativity) : group_scope.
Notation "'iso' x => m " := (iso on hom x => m)
  (at level 200, x binder, no associativity) : group_scope.
Notation "G <~> H" := (@Isomorph G H)
  (at level 95, no associativity) : group_scope.

Program Definition homcomp {G1 G2 G3} (f : G1 ~~> G2)
  (g : G2 ~~> G3) : G1 ~~> G3 := hom on (g o f).
Next Obligation. split. intros x y. simpl. now rewrite 2!morph. Defined.
Notation "g '<o~' f" := (homcomp f g)
  (at level 60, right associativity) : group_scope.

Program Definition isocomp {G1 G2 G3} (f : G1 <~> G2)
  (g : G2 <~> G3) : G1 <~> G3 := iso on (g <o~ f).
Next Obligation.
  split; split; simpl.
  - intros x y Heq. now repeat apply inj in Heq.
  - intros z. destruct (surj g z) as [y E1].
    destruct (surj f y) as [x E2]. exists x. now rewrite E1, E2.
Defined.
Notation "g '<o>' f" := (isocomp f g)
  (at level 60, right associativity) : group_scope.

Section HomTheory.
  Context `{f: Morph G H}.
  Lemma morph1 : f 1 == 1.
  Proof.
    now rewrite (mulgI (f 1)), <-morph, 2!mul1g.
  Qed.

  Lemma morphV : forall x, f (!x) == !(f x).
  Proof.
    intros x. now rewrite <-(mulg1 (!f x)), mulTg,
     <-morph, invr, morph1.
  Qed.
End HomTheory.

Class IsSubg {X : Group} (G : {ens X}) := {
  fermg : forall x y : G, G (x * !y);
  idgF : G 1
}.

Structure Subg (X : Group) := {
  suppg :> {ens X};
  groupprf : IsSubg suppg
}.
#[global] Existing Instance groupprf.

Notation "< G >" := (@Build_Subg _ G _)
  (at level 200, G at level 0, no associativity) : group_scope.
Notation "{ 'subg' X }" := (@Subg X)
  (at level 0, format "{ 'subg'  X }") : group_scope.

Definition subg_eq {X} (G H : {subg X}) :=
  suppg G == suppg H.
Program Canonical Structure SubgSetoid (X : Group) :=
  [ {subg X} | ==: subg_eq ].
Notation "[ 'subg' X ]" := (@SubgSetoid X)
  (at level 0, format "[ 'subg'  X ]") : group_scope.
Program Canonical Structure suppgM {X : Group}
  : Map {subg X} {ens X} := map x => suppg x.

Definition subgconf `(G : {subg X}) := fun x => (suppg G) x.

Section GroupTheory.
  Context {X : Group} {G : {subg X}}.
  Implicit Types x y : G.
  Lemma invgF x : G (!x).
  Proof.
    rewrite <-mul1g, (val_sval idgF). apply fermg.
  Qed.

  Lemma mulgF x y : G (x * y).
  Proof.
    rewrite <-(invgK y), 2!(val_sval (invgF _)).
    apply fermg.
  Qed.
End GroupTheory.

Program Coercion grp_grpS `(G : {subg X}) : Group :=
  [ G | *: (dmap g h => $[_, mulgF g h]),
        !: (map g => $[_, invgF g]),
        1: $[_, idgF] ].
Next Obligation.
  intros g g0 Eg h h0 Eh. simpeq. now rewrite Eg, Eh.
Defined.
Next Obligation.
  intros g g0 Eg. simpeq. now rewrite Eg.
Defined.
Next Obligation.
  split; split; intros; simpeq;
  now rewrite assoc || rewrite mulg1 || rewrite mulgV.
Defined.

Program Definition inclhom {X} {H G : {subg X}}
   (L : H <= G) : H ~~> G := hom on (inclmap L).
Next Obligation.
  split. intros x y. now simpeq.
Defined.

Program Canonical Structure IsSubgM {X : Group} :=
  map by (@IsSubg X).
Next Obligation.
  intros A A0 E. split; intros [C I]; split; simpl;
  try (now rewrite map_comap in I; rewrite2_in E I);
  intros [x Hx] [y Hy]; simpl; rewrite map_comap;
  rewrite map_comap in Hx; rewrite map_comap in Hy;
  [rewrite <-E in * | rewrite E in *];
  simpl in *; sapply (C $[_, Hx] $[_, Hy]).
Defined.

Program Definition subgTfor (X : Group) := <(ensTfor X)>.

Program Definition subgI {X} (H0 H1 : {subg X})
  := <(H0 :&: H1)>.
Next Obligation.
  split.
  - intros [x [H0x H1x]] [y [H0y H1y]]. split; simpl.
  + apply (fermg $[_, H0x] $[_, H0y]).
  + apply (fermg $[_, H1x] $[_, H1y]).
  - split; simpl; apply idgF.
Defined.

Lemma subgIInf_subg {X : Group} (S : {ens {ens X}}) :
  (forall U, S U -> @IsSubg X U) -> IsSubg (ensIInf S).
Proof.
  intros H. split.
  - intros [x Hx] [y Hy]. simpl in *.
    intros [U HU]. simpl. destruct (H U HU).
    sapply (fermg0 $[_, Hx $[_, HU]] $[_, Hy $[_, HU]]).
  - intros [U HU]. destruct (H $[_, HU]); now simpl.
Defined.

Program Definition generated {X : Group} (A : {ens X}) :=
  <(ensIInf [ B : {ens X} | IsSubg B /\ A <= B ])>.
Next Obligation.
  intros B B0 E. split; intros [H H0]; split;
  try rewrite map_comap; now rewrite2 E.
Defined.
Next Obligation.
  apply subgIInf_subg. now intros U [Usg AB].
Defined.

Lemma gensubg_eq_subg {X : Group} {A : {ens X}} :
  IsSubg A -> A == generated A.
Proof.
  intros H a a0 E. rewrite E. split; intros H0.
  - intros U. destruct U. destruct m.
    now pose (d $[_, H0]).
  - simpl in *. sapply (forall_sigS H0).
    split; intuition. now destruct x.
Qed.

Lemma gen_compat_lt {X : Group} {A B : {ens X}} :
  A <= B -> generated A <= generated B.
Proof.
  intros H a U. destruct U. simpl in *.
  destruct m. destruct a. simpl in *.
  sigapply m. split; intuition.
  apply (H1 (inclmap H x)).
Qed.

Definition conjugate {G : Group} :=
  dmap21 (imens o1 ((@conjg G)^~)).
Notation "A :^ x" := (conjugate A x)
  (at level 35, right associativity) : group_scope.

Program Definition normaliser {G : Group} (A : {ens G})
  := [ x | A :^ x <= A ].
Next Obligation.
  intros x y E. split; intros H [g [a H0]];
  sigapply H; exists a; now rewrite2 E.
Defined.

Class IsNormal `(N : {subg G}) := {
  normal : forall g : G, N :^ g <= N
}.

Structure Normalsg (X : Group) := {
  suppsg :> {subg X};
  nsgprf :> IsNormal suppsg
}.
#[global] Existing Instance nsgprf.

Notation "<| G" := (@Normalsg G)
  (at level 70, no associativity) : group_scope.
Notation "N <<| G" := (@Build_Normalsg G N _)
  (at level 70, no associativity) : group_scope.

Definition nsg_eq {X} (G H : <| X) :=
  suppsg G == suppsg H.
Program Canonical Structure NormalsgSetoid
  (X : Group) := [ <| X | ==: nsg_eq ].
Notation "[ 'nsg' X ]" := (@NormalsgSetoid X)
  (at level 0, format "[ 'nsg'  X ]") : group_scope.
Program Canonical Structure suppsgM {X : Group}
  : Map (<| X) {subg X} := map x => suppsg x.

Lemma normalJF `{N : <| X} {n g : X} : N n -> N (n ^ g).
Proof.
  intros Nn. sigapply (normal(g := g)).
  now existsS n.
Qed.

Lemma normalVJF `{N : <|X} {n} g : N (n ^ g) -> N n.
Proof.
  intros Nng. rewrite <-(invJK _ g). now apply normalJF.
Qed.

Program Definition imsubg {X Y : Group} :=
  dmap (f : Morph X Y) (G : {subg X}) => <(f @: G)>.
Next Obligation.
  split.
  - intros [y0 [g0 H0]] [y1 [g1 H1]]. existsS (g0 * !g1).
    apply fermg. now rewrite morph, morphV, H0, H1.
  - existsS (1 in X). apply idgF. now rewrite morph1.
Defined.
Next Obligation.
  intros f g H A B. now apply setoid.imens_obligation_2.
Defined.

Notation "f <@> G" := (@imsubg _ _ f G)
  (at level 24, right associativity) : group_scope.

Program Definition preimsubg {X Y : Group} :=
  dmap (f : Morph X Y) (H : {subg Y}) => <(f -@: H)>.
Next Obligation.
  split; simpl.
  - intros [x Hx] [y Hy]. simpl in *. rewrite morph, morphV.
    apply (mulgF $[_, Hx] $[_, invgF $[_, Hy]]).
  - rewrite morph1. apply idgF.
Defined.
Next Obligation.
  intros f g H A B. now apply setoid.preimens_obligation_2.
Defined.

Notation "f <-@> G" := (@preimsubg _ _ f G)
  (at level 24, right associativity) : group_scope.

Program Definition preimnsg {X Y : Group} :=
  dmap (f : Morph X Y) (N : <| Y) => (preimsubg f N) <<| X.
Next Obligation.
  split. simpl. intros g [h [[a Ha] Hh]]. simpl in *.
  rewrite Hh, !morph, morphV. now apply normalJF.
Defined.
Next Obligation.
  intros f g H A B. now apply preimsubg_obligation_2.
Defined.

Program Definition idnsg {X : Group} := <[ == 1]> <<| X.
Next Obligation.
  split; simpl; try reflexivity. intros [a Ha] [b Hb].
  simpl in *. now rewrite Ha, Hb, identl, invg1.
Defined.
Next Obligation.
  split. intros g [a [[i Hi] HN]]. simpl in *.
  now rewrite HN, Hi, identl, invl.
Defined.

Notation "<1>" := (idnsg) : group_scope.

Program Definition kernel {X Y : Group} :=
  map (f : Morph X Y) => preimnsg f <1>.
Next Obligation. intros f f0 Ef. now rewrite Ef. Defined.

Definition coset_eq `{G : {subg X}} (x y : X) :=
  G (x * !y).
#[global] Hint Unfold coset_eq : eq.
Program Definition Coset `(G : {subg X}) :=
  [ X | ==: @coset_eq _ G ].
Next Obligation.
  split; simpeq.
  - intros x. rewrite invr. apply idgF.
  - intros x y H. rewrite <-(invgK y), <-invMg.
    apply (invgF $[_, H]).
  - intros x y z H1 H2.
    rewrite <-(mulg1 x), <-(mulVg y), assoc, <-assoc.
    apply (mulgF $[_, H1] $[_, H2]).
Defined.
Notation "X / G" := (@Coset X G) : group_scope.

Program Definition projmap `{G : {subg X}} : Map X (X / G)
  := map x => x.
Next Obligation.
  intros x x0 E. simpeq. rewrite E, mulgV. apply idgF.
Defined.

Program Definition CosetGroup `(N : <| X) :=
  [ X / N | *: (dmap xN yN => xN * yN),
            !: (map xN => !xN),
            1: 1 ].
Next Obligation.
  intros x x0 Ex y y0 Ey. simpeq_all.
  rewrite invMg, assoc, <-(assoc x), <-(assoc).
  rewrite <-(mulg1 x), <-(mulVg x0), (assoc x), <-(assoc _ x0).
  sigapply (mulgF $[_, Ex]). rewrite <-(invgK x0) at 1.
  now apply normalJF.
Defined.
Next Obligation.
  intros x x0 E. simpeq_all. rewrite invgK.
  apply (normalVJF(g:=!x0)). simpl.
  rewrite <-assoc, mulgV, mulg1, <-invMg.
  sapply (invgF $[_, E]).
Defined.
Next Obligation.
  split; split; simpeq; intros.
  - rewrite assoc, mulgV. apply idgF.
  - rewrite mulg1, mulgV. apply idgF.
  - rewrite mulgV, mul1g, invg1. apply idgF.
Defined.

Notation "X </> N" := (@CosetGroup X N)
  (at level 35, right associativity) : group_scope.

Program Definition projhom `{N : <| G} : G ~~> G </> N
  := hom on projmap.

#[global]
Instance projhom_surj `{N : <| G} : Surjective (@projhom _ N).
Proof.
  split. intros y. exists y. simpeq. rewrite mulgV. apply idgF.
Qed.

Lemma projhom_ker `{N : <| G} (g : G)
  : N g == (@projhom _ N g == 1).
Proof. simpeq. now rewrite invg1, mulg1. Qed.

Program Definition Iso1 `(f : G ~~> H)
  : (G </> kernel f) <~> (f <@> subgTfor G)
  := iso x => $[f x, _].
Next Obligation. now existsS x. Defined.
Next Obligation.
  intros x x0 E. simpeq_all.
  now rewrite <-(invgK (f x0)), <-(mul1g (!! f x0)), mulgT,
  <-morphV, <-morph.
Defined.
Next Obligation.
  split. intros x y. simpeq. apply morph.
Defined.
Next Obligation.
  split; split.
  - intros x y E. simpeq_all.
    now rewrite morph, morphV, <-mulgT, mul1g, invgK.
  - intros [y [[x T] Hx]]. exists x. now simpeq_all.
Defined.

Program Definition commg {G : Group} : Binop G :=
  dmap (x : G) y => !x * x ^ y.
Next Obligation.
  intros x x0 E y y0 E0. now rewrite E, E0.
Defined.
Notation "[ g , h ]" := (@commg _ g h)
  (at level 0, g, h at level 99, format "[ g ,  h ]")
  : group_scope.

Program Definition commorig {G : Group} (A B : {ens G}) :=
  [ g : G | exists (a : A) (b : B), g == [a, b] ].
Next Obligation.
  intros C C0 E. simpeq_all. split; intros [a [b H]];
  exists a, b; now rewrite2 E.
Defined.

Definition commutator {G : Group} (A B : {ens G}) :=
  generated (commorig A B).
Notation "[: A , B :]" := (@commutator _ A B)
  (at level 0, A, B at level 99, format "[: A  ,  B :]")
  : group_scope.

Program Definition derived (G : Group) :=
  [:subgTfor G, subgTfor G:] <<| G.
Next Obligation.
  split. intros g [h [[a H] E]] U. simpl. pose (H U).
  rewrite E. simpl. destruct U. destruct m0.
  pose (Usg := Build_Subg i). simpl in *.
  pose (forall_sigS d). simpl in m0.
  assert (sval (!a * (!g * (a * g) ))).
  { apply m0. now exists (@Build_sigS _ idTmap a I)
  , (@Build_sigS _ idTmap g I). }
  pose (@mulgF _ Usg $[_, m] $[_, H0]). simpl in m1.
  now rewrite assoc, mulgV, mul1g in m1.
Defined.

Class Commute {X : Setoid} (op : X -> X -> X) := {
  commute : forall a b, op a b == op b a
}.

Definition IsCommgrp (G : Group) := Commute (@mulg G).

Lemma CG_commg1 {G : Group}
 : IsCommgrp G == (forall x y : G, [x, y] == 1).
Proof.
  split; intros H; simpl in *.
  - intros x y. rewrite sym, !mulTg, mulg1. now destruct H.
  - split. intros a b. pose (H b a) as H0.
    now rewrite sym, !mulTg, mulg1 in H0.
Qed.

Lemma quotDG_comm (G : Group) : IsCommgrp (G </> derived G).
Proof.
  split. intros a b.
  destruct (surj projhom a) as [a0 Ha].
  destruct (surj projhom b) as [b0 Hb].
  rewrite Ha, Hb, <-(invgK (_ * projhom a0)), <-(mulg1 (!!_)),
    mulTg, invMg, <-assoc, <-!morphV, <-!morph, <-projhom_ker.
  intros [U [H H0]]. sigapply H0. now exists (inT a0), (inT b0).
Defined.

Lemma hom_hold_comm `{f : G ~~> H} {x y : G}
  : f [x, y] == [f x, f y].
Proof. simpl. now rewrite !morph, !morphV. Qed.

Lemma quot_comm_NDG `(N : <| G) :
  IsCommgrp (G </> N) -> derived G <= N.
Proof.
  intros H.
  assert (commorig (subgTfor G) (subgTfor G) <= N). {
    rewrite CG_commg1 in H.
    intros a. destruct a. destruct m. destruct e.
    simpl. rewrite e, projhom_ker.
    rewrite <-(H (projhom x) (projhom x0)).
    apply hom_hold_comm.
  }
  rewrite (gensubg_eq_subg(A := N));
  [now apply gen_compat_lt | intuition].
Qed.

Require Import Sorted.
Check HdRel.

(* Definition solvable (G : Group)  *)

Close Scope group_scope.
Close Scope setoid_scope.


From DEZ.Has Require Export
  Homomorphism EquivalenceRelation GroupOperation GroupIdentity GroupInverse.
From DEZ.Is Require Export
  MonoidHomomorphism Group.
From DEZ.ShouldHave Require Import
  AdditiveGroupNotations.

Class IsGroupHomomorphism {A B : Type}
  {A_has_eqv : HasEqv A} (A_has_opr : HasOpr A)
  (A_has_idn : HasIdn A) (A_has_inv : HasInv A)
  {B_has_eqv : HasEqv B} (B_has_opr : HasOpr B)
  (B_has_idn : HasIdn B) (B_has_inv : HasInv B)
  (has_hom : HasHom A B) : Prop := {
  A_B_opr_idn_opr_idn_hom_is_monoid_homomorphism :>
    IsMonoidHomomorphism (A := A) (B := B) opr idn opr idn hom;
  A_opr_idn_inv_is_group :> IsGroup (A := A) opr idn inv;
  B_opr_idn_inv_is_group :> IsGroup (A := B) opr idn inv;
}.

(** We can derive these theorems
    without knowing about the monoidal structure. *)

Section Context.

Context {A B : Type} `{is_group_homomorphism : IsGroupHomomorphism A B}.

Theorem hom_preserves_identity : hom 0 == 0.
Proof.
  apply (opr_left_injective (hom 0) 0 (hom 0)).
  rewrite <- (preserves_operation 0 0).
  rewrite (right_identifiable 0).
  rewrite (right_identifiable (hom 0)).
  reflexivity. Qed.

Theorem hom_preserves_inverse : forall x : A,
  hom (- x) == - hom x.
Proof.
  intros x.
  apply (opr_left_injective (hom (- x)) (- hom x) (hom x)).
  rewrite <- (preserves_operation x (- x)).
  rewrite (right_invertible x).
  rewrite (right_invertible (hom x)).
  rewrite hom_preserves_identity.
  reflexivity. Qed.

End Context.


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

Require Import List Arith Omega Bool.

Require Import utils pos vec.
Require Import subcode sss.
Require Import list_bool.

Set Implicit Arguments.

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

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

(** * Binary Stack Machines
   Binary stack machines have n stacks and there are just two instructions

   1/ POP s p q : pops the value on stack s and
                  if Empty then jumps to q
                  if Zero then jumps to p
                  if One then jumps to next instruction,
   2/ PUSH s b : pushes the value b on stack s and jumps to next instructions

 *)

Inductive bsm_instr n : Set :=
  | bsm_pop  : pos n -> nat -> nat -> bsm_instr n
  | bsm_push : pos n -> bool -> bsm_instr n
  .

Notation POP  := bsm_pop.
Notation PUSH := bsm_push.

(** ** Semantics for BSM *)

Section Binary_Stack_Machine.

  Variable (n : nat).

  Definition bsm_state := (nat*vec (list bool) n)%type.

  Inductive bsm_sss : bsm_instr n -> bsm_state -> bsm_state -> Prop :=
    | in_bsm_sss_pop_E : forall i x p q v,    v#>x = nil      -> POP x p q // (i,v) -1> (  q,v)
    | in_bsm_sss_pop_0 : forall i x p q v ll, v#>x = Zero::ll -> POP x p q // (i,v) -1> (  p,v[ll/x])
    | in_bsm_sss_pop_1 : forall i x p q v ll, v#>x = One ::ll -> POP x p q // (i,v) -1> (1+i,v[ll/x])
    | in_bsm_sss_push  : forall i x b v,                         PUSH x b  // (i,v) -1> (1+i,v[(b::v#>x)/x])
  where "i // s -1> t" := (bsm_sss i s t).

  Ltac mydiscr :=
      match goal with H: ?x = _, G : ?x = _ |- _ => rewrite H in G; discriminate end.

  Ltac myinj :=
      match goal with H: ?x = _, G : ?x = _ |- _ => rewrite H in G; inversion G; subst; auto end.

  (* bsm_sss is a functional relation *)

  Fact bsm_sss_fun i s t1 t2 : i // s -1> t1 -> i // s -1> t2 -> t1 = t2.
  Proof. intros []; subst; inversion 1; subst; auto; try mydiscr; myinj. Qed.

  (* bsm_sss is an informativelly total relation *)

  Fact bsm_sss_total ii s : { t | ii // s -1> t }.
  Proof.
    destruct s as (i,v).
    destruct ii as [ x p q | x b ].
    + case_eq (v#>x); [ intros Hx | intros [] l Hx ].
      * exists (q,v); constructor; trivial.
      * exists (1+i,v[l/x]); constructor; trivial.
      * exists (p,v[l/x]); constructor; trivial.
    + exists (1+i,v[(b::v#>x)/x]); constructor.
  Qed.

  Fact bsm_sss_total' ii s : exists t, ii // s -1> t.
  Proof.
    destruct (bsm_sss_total ii s); firstorder.
  Qed.

  (* Hence computations can only stop at instructions which lie outside the code
     Stalling means no instruction can be executed anymore. It DOES NOT mean
     that the state cannot change anymore (this is a strictly lesser requirement).
  *)

  Fact bsm_sss_stall : forall P s, sss_step_stall bsm_sss P s -> out_code (fst s) P.
  Proof.
    intros (i,P) (q,v) H; unfold fst.
    red in H.
    destruct (in_out_code_dec q (i,P)) as [ H1 | ]; auto; exfalso.
    apply in_code_subcode in H1.
    destruct H1 as (ii & l & r & H1 & H2).
    simpl in H1.
    destruct (bsm_sss_total ii (q,v)) as (t & Ht).
    apply (H t); subst; apply in_sss_step; auto.
  Qed.

  Notation "P // s -[ k ]-> t" := (sss_steps bsm_sss P k s t).
  Notation "P // s ->> t" := (sss_compute bsm_sss P s t).

  Fact bsm_compute_POP_E P i x p q v st :
         (i,POP x p q::nil) <sc P
      -> v#>x = nil
      -> P // (q,v) ->> st
      -> P // (i,v) ->> st.
  Proof.
    intros H1 H2.
    apply subcode_sss_compute_trans with (1 := H1).
    exists 1; apply sss_steps_1.
    apply in_sss_step with (l := nil).
    simpl; omega.
    constructor; auto.
  Qed.

  Fact bsm_compute_POP_0 P i x p q ll v st :
         (i,POP x p q::nil) <sc P
      -> v#>x = Zero::ll
      -> P // (p,v[ll/x]) ->> st
      -> P // (i,v) ->> st.
  Proof.
    intros H1 H2.
    apply subcode_sss_compute_trans with (1 := H1).
    exists 1; apply sss_steps_1.
    apply in_sss_step with (l := nil).
    simpl; omega.
    constructor; auto.
  Qed.

  Fact bsm_compute_POP_1 P i x p q ll v st :
         (i,POP x p q::nil) <sc P
      -> v#>x = One::ll
      -> P // (1+i,v[ll/x]) ->> st
      -> P // (i,v) ->> st.
  Proof.
    intros H1 H2.
    apply subcode_sss_compute_trans with (1 := H1).
    exists 1; apply sss_steps_1.
    apply in_sss_step with (l := nil).
    simpl; omega.
    constructor; auto.
  Qed.

  Fact bsm_compute_POP_any P i x p q b ll v st :
         (i,POP x p q::nil) <sc P
      -> v#>x = b::ll
      -> p = 1+i
      -> P // (1+i,v[ll/x]) ->> st
      -> P // (i,v) ->> st.
  Proof.
    destruct b; intros H1 H2 H3.
    apply bsm_compute_POP_1 with p q; auto.
    apply bsm_compute_POP_0 with q; subst; auto.
  Qed.

  Fact bsm_compute_PUSH P i x b v st :
         (i,PUSH x b::nil) <sc P
      -> P // (1+i,v[(b::v#>x)/x]) ->> st
      -> P // (i,v) ->> st.
  Proof.
    intros H1.
    apply subcode_sss_compute_trans with (1 := H1).
    exists 1; apply sss_steps_1.
    apply in_sss_step with (l := nil).
    simpl; omega.
    constructor; auto.
  Qed.

  Fact bsm_steps_POP_0_inv a P i x p q ll v st :
         (i,POP x p q::nil) <sc P
      -> v#>x = Zero::ll
      -> st <> (i,v)
      -> P // (i,v) -[a]-> st
      -> { b | b < a /\ P // (p,v[ll/x]) -[b]-> st }.
  Proof.
    intros H1 H2 H3 H4.
    apply sss_steps_inv in H4.
    destruct H4 as [ (_ & ?) | (b & H4) ]; subst.
    destruct H3; auto.
    exists b.
    destruct H4 as (st2 & ? & H4 & H5); subst.
    split.
    omega.
    apply sss_step_subcode_inv with (1 := H1) in H4.
    inversion H4; subst; try mydiscr; myinj.
  Qed.

  Fact bsm_steps_POP_1_inv a P i x p q ll v st :
         (i,POP x p q::nil) <sc P
      -> v#>x = One::ll
      -> st <> (i,v)
      -> P // (i,v) -[a]-> st
      -> { b | b < a /\ P // (1+i,v[ll/x]) -[b]-> st }.
  Proof.
    intros H1 H2 H3 H4.
    apply sss_steps_inv in H4.
    destruct H4 as [ (_ & ?) | (b & H4) ]; subst.
    destruct H3; auto.
    exists b.
    destruct H4 as (st2 & ? & H4 & H5); subst.
    split.
    omega.
    apply sss_step_subcode_inv with (1 := H1) in H4.
    inversion H4; subst; try mydiscr; myinj.
  Qed.

  Fact bsm_steps_POP_any_inv a P i x p q b ll v st :
         (i,POP x p q::nil) <sc P
      -> v#>x = b::ll
      -> p = 1+i
      -> st <> (i,v)
      -> P // (i,v) -[a]-> st
      -> { b | b < a /\ P // (1+i,v[ll/x]) -[b]-> st }.
  Proof.
    intros.
    destruct b.
    apply bsm_steps_POP_1_inv with p q; auto.
    apply bsm_steps_POP_0_inv with i q; subst; auto.
  Qed.

  Fact bsm_steps_POP_E_inv a P i x p q v st :
         (i,POP x p q::nil) <sc P
      -> v#>x = nil
      -> st <> (i,v)
      -> P // (i,v) -[a]-> st
      -> { b | b < a /\ P // (q,v) -[b]-> st }.
  Proof.
    intros H1 H2 H3 H4.
    apply sss_steps_inv in H4.
    destruct H4 as [ (? & ?) | (b & H4) ]; subst; auto.
    destruct H3; auto.
    exists b.
    destruct H4 as (st2 & ? & H4 & H5); subst.
    split.
    omega.
    apply sss_step_subcode_inv with (1 := H1) in H4.
    inversion H4; subst; try mydiscr; myinj.
  Qed.

  Fact bsm_steps_PUSH_inv k P i x b v st :
         (i,PUSH x b::nil) <sc P
      -> st <> (i,v)
      -> P // (i,v) -[k]-> st
      -> { a | a < k /\ P // (1+i,v[(b::v#>x)/x]) -[a]-> st }.
  Proof.
    intros H1 H2 H4.
    apply sss_steps_inv in H4.
    destruct H4 as [ (? & ?) | (a & H4) ]; subst; auto.
    destruct H2; auto.
    exists a.
    destruct H4 as (st2 & ? & H4 & H5); subst.
    split.
    omega.
    apply sss_step_subcode_inv with (1 := H1) in H4.
    inversion H4; subst; auto.
  Qed.

End Binary_Stack_Machine.

Tactic Notation "bsm" "sss" "POP" "empty" "with" uconstr(a) constr(b) constr(c) :=
     apply bsm_compute_POP_E with (x := a) (p := b) (q := c); auto.

Tactic Notation "bsm" "sss" "POP" "0" "with" uconstr(a) constr(b) constr(c) uconstr(d) :=
     apply bsm_compute_POP_0 with (x := a) (p := b) (q := c) (ll := d); auto.

Tactic Notation "bsm" "sss" "POP" "1" "with" uconstr(a) constr(b) constr(c) uconstr(d) :=
     apply bsm_compute_POP_1 with (x := a) (p := b) (q := c) (ll := d); auto.

Tactic Notation "bsm" "sss" "POP" "any" "with" uconstr(a) constr(c) constr(d) constr(e) constr(f) :=
     apply bsm_compute_POP_any with (x := a) (p := c) (q := d) (b := e) (ll := f); auto.

Tactic Notation "bsm" "sss" "PUSH" "with" uconstr(a) constr(q) :=
     apply bsm_compute_PUSH with (x := a) (b := q); auto.

Tactic Notation "bsm" "sss" "stop" := exists 0; apply sss_steps_0; auto.

Tactic Notation "bsm" "inv" "POP" "empty" "with" hyp(H) constr(a) constr(b) constr(c) constr(d) :=
     apply bsm_steps_POP_E_inv with (x := a) (p := b) (q := c) (ll := d) in H; auto.

Tactic Notation "bsm" "inv" "POP" "0" "with" hyp(H) constr(a) constr(b) constr(c) constr(d) :=
     apply bsm_steps_POP_0_inv with (x := a) (p := b) (q := c) (ll := d) in H; auto.

Tactic Notation "bsm" "inv" "POP" "1" "with" hyp(H) constr(a) constr(b) constr(c) constr(d) :=
     apply bsm_steps_POP_1_inv with (x := a) (p := b) (q := c) (ll := d) in H; auto.

Tactic Notation "bsm" "inv" "POP" "any" "with" hyp(H) constr(a) constr(c) constr(d) constr(e) constr(f) :=
     apply bsm_steps_POP_any_inv with (x := a) (p := c) (q := d) (b := e) (ll := f) in H; auto.

Tactic Notation "bsm" "inv" "PUSH" "with" hyp(H) constr(a) constr(c) :=
     apply bsm_steps_PUSH_inv with (x := a) (b := c) in H; auto.

Hint Immediate bsm_sss_fun.

(* The Halting problem for BSM *)

Definition BSM_PROBLEM := { n : nat & { i : nat & { P : list (bsm_instr n) & vec (list bool) n } } }.

Local Notation "P // s ↓" := (sss_terminates (@bsm_sss _) P s).

Definition BSM_HALTING (P : BSM_PROBLEM) :=
  match P with existT _ n (existT _ i (existT _ P v)) => (i,P) // (i,v) ↓ end.


Require Export semantics.
Require Export typing.

(* Definition 1 : Low Equivalence *)

Definition lowEquivalentMem (M1 M2: memory):  Prop :=
 (forall x v,
 		(M1 x = Some (vint v low)) <-> (M2 x = Some (vint v low)))
 	/\
 (forall x v,
		(M1 x = Some (varr v low)) <-> (M2 x = Some (varr v low))).

(* Definition 2 : Gamma Validity *)

Definition gammavalid (gamma:environment) (M:memory) : Prop :=
	forall x l,
	((gamma x = Some (lnat l)) <-> (exists n, (M x = Some (vint n l))))
	/\
	((gamma x = Some (larr l)) <-> (exists a, (M x = Some (varr a l)))).

(* Definition 3 : Memory Trace Obliviousness *)

Definition memTraceObliv (gamma:environment) (S:program) : Prop :=
	forall M1 M2 t1 M1' t2 M2',
	(lowEquivalentMem M1 M2) ->
	(gammavalid gamma M1) ->
	(gammavalid gamma M2) ->
	(progSem M1 S t1 M1') ->
	(progSem M2 S t2 M2') ->

		((traceequiv t1 t2) /\ (lowEquivalentMem M1' M2')).


Require Import Coq.Classes.Equivalence.
Require Import Coq.Lists.List.
Require Import Coq.Unicode.Utf8.
Require Import Iteration.Lattice.

Generalizable All Variables.

Local Open Scope equiv_scope.

Definition inf {X} `{Lattice A} (G : list (X → A)) (x : X) :=
  List.fold_right (λ g a, a ⊓ g x) top G.

(* We use the paper's equivalent definition since it's simpler to write *)
Definition lower_selection {X} `{Lattice A} (G : list (X → A)) : Prop :=
  ∀ x, Exists (λ g, g x === inf G x) G.

Definition fixed_point `{Equivalence A} (f : A → A) (x : A) : Prop :=
  x === f x.

Definition least_fixed_point `{Lattice A} (f : A → A) (x : A) : Prop :=
  fixed_point f x ∧ ∀ y, fixed_point f y → Lattice.le_meet x y.


Require Import init.

Require Import order_minmax.

Require Export analysis_norm.
Require Import analysis_series.

(* If I ever want to do analysis on an ordered field that's not the real
 * numbers, I'll figure it out then.
 *)
(* begin hide *)
Section AnalysisOrder.

Existing Instance abs_metric.
(* end hide *)
Theorem seq_lim_pos : ∀ xf x, (∀ n, 0 ≤ xf n) → seq_lim xf x → 0 ≤ x.
Proof.
    intros xf x xf_pos x_lim.
    rewrite metric_seq_lim in x_lim.
    classic_contradiction contr.
    rewrite nle_lt in contr.
    apply neg_pos2 in contr.
    specialize (x_lim _ contr) as [N x_lim].
    specialize (x_lim N (refl N)).
    cbn in x_lim.
    rewrite abs_minus in x_lim.
    apply (le_lt_trans (abs_le_pos _)) in x_lim.
    unfold real_neg in x_lim.
    rewrite <- (plus_lid (-x)) in x_lim at 2.
    apply lt_plus_rcancel in x_lim.
    destruct (le_lt_trans (xf_pos N) x_lim); contradiction.
Qed.

Theorem seq_lim_le : ∀ xf yf x y,
    (∀ n, xf n ≤ yf n) → seq_lim xf x → seq_lim yf y → x ≤ y.
Proof.
    intros xf yf x y f_leq x_lim y_lim.
    pose (xyf n := yf n - xf n).
    apply le_plus_0_anb_b_a.
    apply (seq_lim_pos xyf).
    -   intros n; unfold xyf.
        apply le_plus_0_anb_b_a.
        apply f_leq.
    -   apply seq_lim_plus.
        +   exact y_lim.
        +   apply seq_lim_neg.
            exact x_lim.
Qed.

Theorem seq_lim_le_constant : ∀ xf x y,
    (∀ n, xf n ≤ y) → seq_lim xf x → x ≤ y.
Proof.
    intros xf x y f_leq x_lim.
    apply (seq_lim_le xf (λ _, y)).
    -   exact f_leq.
    -   exact x_lim.
    -   apply constant_seq_lim.
Qed.

Theorem seq_lim_ge_constant : ∀ yf x y,
    (∀ n, x ≤ yf n) → seq_lim yf y → x ≤ y.
Proof.
    intros yf x y f_leq y_lim.
    apply (seq_lim_le (λ _, x) yf).
    -   exact f_leq.
    -   apply constant_seq_lim.
    -   exact y_lim.
Qed.

Theorem increasing_seq_converges : ∀ f : nat → real,
    (∃ M, ∀ n, |f n| ≤ M) → (∀ n, f n ≤ f (nat_suc n)) →
    seq_converges f.
Proof.
    intros f [M M_bound] f_inc.
    assert (∀ m n, m ≤ n → f m ≤ f n) as f_inc2.
    {
        intros m n leq.
        apply nat_le_ex in leq as [c eq].
        subst n.
        nat_induction c.
        -   rewrite plus_rid.
            apply refl.
        -   apply (trans IHc).
            rewrite nat_plus_rsuc.
            apply f_inc.
    }
    pose (S x := ∃ n, f n = x).
    assert (∃ x, S x) as S_ex by (exists (f 0); exists 0; reflexivity).
    assert (has_upper_bound le S) as S_bound.
    {
        exists M.
        intros x [n x_eq]; subst x.
        apply (trans (abs_le_pos _)).
        apply M_bound.
    }
    pose proof (sup_complete S S_ex S_bound) as [x [x_bound x_least]].
    exists x.
    rewrite metric_seq_lim.
    intros ε ε_pos.
    assert (¬is_upper_bound le S (x - ε)) as xε_lt.
    {
        intros contr.
        specialize (x_least _ contr).
        rewrite <- (plus_rid x) in x_least at 1.
        apply le_plus_lcancel in x_least.
        apply pos_neg2 in ε_pos.
        destruct (le_lt_trans x_least ε_pos); contradiction.
    }
    unfold is_upper_bound in xε_lt.
    rewrite not_all in xε_lt.
    destruct xε_lt as [y xε_lt].
    rewrite not_impl in xε_lt.
    destruct xε_lt as [[N y_eq] ltq]; subst y.
    rewrite nle_lt in ltq.
    exists N.
    intros n n_geq.
    cbn.
    rewrite abs_pos_eq.
    2: {
        apply le_plus_0_anb_b_a.
        apply x_bound.
        exists n.
        reflexivity.
    }
    apply lt_plus_rrmove.
    rewrite <- (neg_neg ε).
    apply lt_plus_llmove.
    rewrite plus_comm.
    apply (lt_le_trans ltq).
    apply f_inc2.
    exact n_geq.
Qed.

Theorem decreasing_seq_converges : ∀ f : nat → real,
    (∃ M, ∀ n, |f n| ≤ M) → (∀ n, f (nat_suc n) ≤ f n) →
    seq_converges f.
Proof.
    intros f [M M_bound] f_dec.
    pose (g n := -f n).
    assert (seq_converges g) as [x x_lim].
    {
        apply increasing_seq_converges.
        -   exists M.
            unfold g.
            setoid_rewrite abs_neg.
            exact M_bound.
        -   intros n.
            unfold g.
            rewrite <- le_neg.
            apply f_dec.
    }
    exists (-x).
    apply seq_lim_neg in x_lim.
    unfold g in x_lim.
    assert ((λ n, --f n) = (λ n, f n)) as f_eq.
    {
        apply functional_ext.
        intros n.
        apply neg_neg.
    }
    rewrite f_eq in x_lim.
    exact x_lim.
Qed.

Theorem real_complete : complete real.
Proof.
    intros f f_cauchy.
    pose (fn m n := f (m + n)).
    assert (∀ m, cauchy_seq (fn m)) as fn_cauchy.
    {
        intros m.
        intros ε ε_pos.
        specialize (f_cauchy ε ε_pos) as [N f_cauchy].
        exists N.
        intros i j i_ge j_ge.
        unfold fn.
        apply f_cauchy.
        all: rewrite <- (plus_lid N).
        all: apply le_lrplus.
        1, 3: apply nat_pos.
        1, 2: assumption.
    }
    assert (∀ m, seq_norm_bounded (fn m)) as fn_bounded.
    {
        intros m.
        apply seq_bounded_norm_bounded.
        apply cauchy_bounded.
        apply fn_cauchy.
    }
    pose (S m x := ∃ n, x = fn m n).
    assert (∀ m, ∃ a, is_supremum le (S m) a) as sup_ex.
    {
        intros m.
        apply sup_complete.
        -   exists (fn m 0).
            exists 0.
            reflexivity.
        -   specialize (fn_bounded m) as [M M_bound].
            exists M.
            unfold is_upper_bound; cbn.
            intros y [n y_eq]; subst y.
            apply (trans2 (M_bound n)).
            apply abs_le_pos.
    }
    pose (a m := ex_val (sup_ex m)).
    assert (seq_converges a) as [x x_lim].
    {
        apply decreasing_seq_converges.
        -   pose proof (fn_bounded 0) as [M M_bound].
            unfold fn in M_bound.
            setoid_rewrite plus_lid in M_bound.
            exists M.
            intros n.
            unfold a.
            rewrite_ex_val A A_sup.
            destruct A_sup as [A_upper A_least].
            unfold abs; cbn; case_if.
            +   apply A_least.
                intros y [m y_eq]; subst y.
                unfold fn.
                apply (trans2 (M_bound (n + m))).
                apply abs_le_pos.
            +   rewrite nle_lt in n0.
                assert (S n (fn n 0)) as fn_in by (exists 0; reflexivity).
                specialize (A_upper (fn n 0) fn_in).
                apply le_neg in A_upper.
                apply (trans A_upper).
                unfold fn.
                rewrite plus_rid.
                apply (trans2 (M_bound n)).
                apply abs_le_neg.
        -   intros m.
            unfold a.
            rewrite_ex_val A [A_upper A_least].
            rewrite_ex_val B [B_upper B_least].
            apply A_least.
            intros y [n y_eq]; subst y.
            apply B_upper.
            unfold S, fn.
            exists (nat_suc n).
            rewrite nat_plus_lrsuc.
            reflexivity.
    }
    exists x.
    rewrite metric_seq_lim in *; cbn in *.
    intros ε ε_pos.
    pose proof (half_pos ε_pos) as ε2_pos.
    pose proof (half_pos ε2_pos) as ε4_pos.
    specialize (f_cauchy _ ε2_pos) as [N1 f_cauchy]; cbn in f_cauchy.
    specialize (x_lim _ ε4_pos) as [N2 x_lim].
    pose (N := max N1 N2).
    exists N.
    intros n n_ge.
    assert (∃ n', N ≤ n' ∧ |a N - f n'| < ε/2/2) as [n' [n'_ge af_leq]].
    {
        unfold a.
        rewrite_ex_val A A_sup.
        destruct A_sup as [A_upper' A_least'].
        unfold is_upper_bound, S in A_upper'.
        assert (∀ n, fn N n ≤ A) as A_upper.
        {
            intros m.
            apply A_upper'.
            exists m.
            reflexivity.
        }
        assert (∀ y, (∀ n, fn N n ≤ y) → A ≤ y) as A_least.
        {
            intros y y_leq.
            apply A_least'.
            intros z [m z_eq]; subst z.
            apply y_leq.
        }
        clear A_upper' A_least'.
        classic_contradiction contr.
        rewrite not_ex in contr.
        assert (A ≤ A - ε/2/2) as leq.
        {
            apply A_least.
            intros m.
            unfold fn.
            specialize (contr (N + m)).
            rewrite not_and, nle_lt, nlt_le in contr.
            destruct contr as [contr|contr].
            -   rewrite <- (plus_rid N) in contr at 2.
                apply lt_plus_lcancel in contr.
                contradiction (nat_neg2 contr).
            -   specialize (A_upper m).
                unfold fn in A_upper.
                apply le_plus_0_anb_b_a in A_upper.
                unfold abs in contr; cbn in contr; case_if; try contradiction.
                apply le_plus_lrmove.
                apply le_plus_rrmove in contr.
                rewrite neg_neg, plus_comm in contr.
                exact contr.
        }
        rewrite <- (plus_rid A) in leq at 1.
        apply le_plus_lcancel in leq.
        apply pos_neg in leq.
        rewrite neg_neg in leq.
        clear - leq ε4_pos.
        destruct (lt_le_trans ε4_pos leq); contradiction.
    }
    specialize (x_lim N (rmax _ _)).
    specialize (f_cauchy n' n (trans (lmax _ _) n'_ge) (trans (lmax _ _) n_ge)).
    clear - f_cauchy x_lim af_leq.
    pose proof (lt_lrplus x_lim af_leq) as ltq.
    rewrite plus_half in ltq.
    apply (le_lt_trans (abs_tri _ _)) in ltq.
    rewrite <- plus_assoc in ltq.
    rewrite plus_llinv in ltq.
    clear - f_cauchy ltq.
    pose proof (lt_lrplus ltq f_cauchy) as eq.
    rewrite plus_half in eq.
    apply (le_lt_trans (abs_tri _ _)) in eq.
    rewrite <- plus_assoc in eq.
    rewrite plus_llinv in eq.
    exact eq.
Qed.

Theorem series_le_converge : ∀ a b,
    seq_converges (series b) → (∀ n, 0 ≤ a n) → (∀ n, a n ≤ b n) →
    seq_converges (series a).
Proof.
    intros a b b_conv a_pos ab.
    apply cauchy_series_converges.
    1: exact real_complete.
    apply series_converges_cauchy in b_conv.
    intros ε ε_pos.
    specialize (b_conv ε ε_pos) as [N b_conv].
    exists N.
    intros i j leq.
    specialize (b_conv i j leq).
    apply (le_lt_trans2 b_conv).
    clear - a_pos ab.
    assert (0 ≤ sum a i j) as sum_a_pos.
    {
        clear - a_pos.
        nat_induction j.
        -   apply refl.
        -   cbn.
            specialize (a_pos (i + j)).
            pose proof (le_lrplus IHj a_pos) as leq.
            rewrite plus_rid in leq.
            exact leq.
    }
    assert (0 ≤ sum b i j) as sum_b_pos.
    {
        clear - a_pos ab.
        nat_induction j.
        -   apply refl.
        -   cbn.
            specialize (a_pos (i + j)).
            specialize (ab (i + j)).
            pose proof (le_lrplus IHj (trans a_pos ab)) as leq.
            rewrite plus_rid in leq.
            exact leq.
    }
    unfold abs; cbn.
    case_if; case_if; try contradiction.
    clear l l0 sum_a_pos sum_b_pos.
    nat_induction j.
    -   unfold zero; cbn.
        apply refl.
    -   cbn.
        apply le_lrplus.
        +   exact IHj.
        +   apply ab.
Qed.

Theorem seq_squeeze : ∀ an bn cn l, (∀ n, an n ≤ bn n ∧ bn n ≤ cn n) →
    seq_lim an l → seq_lim cn l → seq_lim bn l.
Proof.
    intros an bn cn l leqs anl cnl.
    rewrite metric_seq_lim in *.
    intros ε ε_pos.
    cbn in *.
    specialize (anl ε ε_pos) as [N1 anl].
    specialize (cnl ε ε_pos) as [N2 cnl].
    exists (max N1 N2).
    intros n n_geq.
    specialize (anl n (trans (lmax N1 N2) n_geq)).
    specialize (cnl n (trans (rmax N1 N2) n_geq)).
    specialize (leqs n) as [leq1 leq2].
    rewrite abs_minus in *.
    apply abs_lt.
    apply abs_lt in anl as [anl1 anl2].
    apply abs_lt in cnl as [cnl1 cnl2].
    split.
    -   apply (lt_le_trans anl1).
        apply le_rplus.
        exact leq1.
    -   apply (le_lt_trans2 cnl2).
        apply le_rplus.
        exact leq2.
Qed.

(* begin hide *)
Local Open Scope nat_scope.
(* end hide *)
Theorem alternating_series_test : ∀ an,
    (∀ n, an (nat_suc n) ≤ an n) →
    seq_lim an 0 →
    seq_converges (series (λ n, (-(1))^n * an n)).
Proof.
    intros an an_dec an0'.
    pose proof an0' as an0.
    rewrite metric_seq_lim in an0.
    pose (an' n := (-(1))^n * an n).
    fold an'.
    pose (an'_even n := series an' (2*n)).
    pose (an'_odd n := series an' (2*n + 1)).
    assert (∀ n, an'_odd n = an'_even n + an (2*n)) as even_odd.
    {
        intros n.
        unfold an'_odd, an'_even.
        rewrite plus_comm.
        change (1 + 2*n) with (nat_suc (2*n)).
        cbn.
        rewrite plus_lid.
        unfold an' at 2.
        rewrite nat_pow_neg_even.
        rewrite mult_lid.
        reflexivity.
    }
    assert (∀ m n, an (m + n) ≤ an n) as an_dec2.
    {
        intros m n.
        nat_induction m.
        -   rewrite plus_lid.
            apply refl.
        -   rewrite nat_plus_lsuc.
            apply (trans2 IHm).
            apply an_dec.
    }
    assert (∀ n, 0 ≤ an n) as an_pos.
    {
        intros n.
        classic_contradiction contr.
        rewrite nle_lt in contr.
        apply neg_pos2 in contr.
        specialize (an0 _ contr) as [N an0].
        destruct (connex n N) as [leq|leq].
        -   specialize (an0 N (refl N)).
            cbn in an0.
            rewrite plus_lid in an0.
            apply nat_le_ex in leq as [c eq]; subst N.
            specialize (an_dec2 c n).
            apply le_neg in an_dec2.
            pose proof (lt_le_trans an0 an_dec2) as ltq.
            pose proof (lt_le_trans contr an_dec2) as pos.
            rewrite plus_comm in ltq.
            rewrite abs_pos_eq in ltq by apply pos.
            destruct ltq; contradiction.
        -   specialize (an0 n leq).
            cbn in an0.
            rewrite plus_lid in an0.
            rewrite abs_pos_eq in an0 by apply contr.
            destruct an0; contradiction.
    }
    assert (∀ n, 0 ≤ an'_even n) as even_pos.
    {
        intros n.
        nat_induction n.
        -   unfold an'_even.
            rewrite mult_ranni.
            apply refl.
        -   unfold an'_even.
            rewrite nat_mult_rsuc.
            change (2 + 2*n) with (nat_suc (nat_suc (2*n))).
            cbn.
            do 2 rewrite plus_lid.
            rewrite <- (plus_rid 0).
            rewrite <- plus_assoc.
            apply le_lrplus; [>exact IHn|].
            unfold an'.
            change (nat_suc (2*n)) with (1 + 2*n).
            rewrite (plus_comm 1 (2*n)).
            rewrite nat_pow_neg_even.
            rewrite nat_pow_neg_odd.
            rewrite mult_lid.
            rewrite mult_neg_one.
            apply le_plus_0_anb_b_a.
            rewrite plus_comm.
            apply an_dec.
    }
    assert (∀ n, 0 ≤ an'_odd n) as odd_pos.
    {
        intros n.
        rewrite even_odd.
        rewrite <- (plus_rid 0).
        apply le_lrplus.
        -   apply even_pos.
        -   apply an_pos.
    }
    assert (seq_converges an'_odd) as [l l_odd].
    {
        apply decreasing_seq_converges.
        -   exists (an 0).
            intros n.
            rewrite abs_pos_eq by apply odd_pos.
            nat_induction n.
            +   unfold an'_odd.
                rewrite mult_ranni, plus_lid.
                unfold one; cbn.
                do 2 rewrite plus_lid.
                unfold an'; cbn.
                rewrite mult_lid.
                apply refl.
            +   apply (trans2 IHn).
                unfold an'_odd.
                rewrite nat_mult_rsuc.
                rewrite <- plus_assoc.
                change (2 + (2*n + 1)) with (nat_suc (nat_suc (2*n + 1))).
                cbn.
                do 2 rewrite plus_lid.
                unfold series.
                rewrite <- (plus_rid (sum _ _ _)) at 2.
                rewrite <- plus_assoc.
                apply le_lplus.
                unfold an'.
                change (nat_suc (2 * n + 1)) with (1 + (2*n + 1)) at 1.
                rewrite (plus_comm 1 (2*n + 1)).
                rewrite <- plus_assoc.
                rewrite <- (mult_rid 2) at 4.
                rewrite <- ldist.
                rewrite nat_pow_neg_even, nat_pow_neg_odd.
                rewrite mult_lid, mult_neg_one.
                apply le_plus_nab_0_b_a.
                apply an_dec.
        -   intros n.
            unfold an'_odd.
            rewrite nat_mult_rsuc.
            rewrite <- plus_assoc.
            change (2 + (2*n + 1)) with (nat_suc (nat_suc (2*n + 1))).
            cbn.
            rewrite <- (plus_rid (series _ _)).
            rewrite <- plus_assoc.
            apply le_lplus.
            do 2 rewrite plus_lid.
            unfold an'.
            rewrite nat_pow_suc.
            rewrite nat_pow_neg_odd.
            do 2 rewrite mult_neg_one.
            rewrite neg_neg.
            rewrite mult_lid.
            apply le_plus_nab_0_b_a.
            apply an_dec.
    }
    assert (seq_lim an'_even l) as l_even.
    {
        replace an'_even with (λ n, an'_odd n - an (2 * n)).
        2: {
            apply functional_ext; intros n.
            rewrite <- plus_rrmove.
            apply even_odd.
        }
        rewrite <- (plus_rid l).
        apply seq_lim_plus; [>exact l_odd|].
        rewrite <- neg_zero.
        apply seq_lim_neg.
        apply (subsequence_lim_eq _ _ _ an0').
        exists (λ n, 2*n).
        split; [>|reflexivity].
        split.
        -   rewrite nat_mult_rsuc.
            rewrite <- (plus_lid (2*n)) at 1.
            apply le_rplus.
            exact true.
        -   intros contr.
            rewrite nat_mult_rsuc in contr.
            rewrite <- (plus_lid (2*n)) in contr at 1.
            apply plus_rcancel in contr.
            inversion contr.
    }
    exists l.
    apply seq_lim_even_odd.
    -   exact l_even.
    -   exact l_odd.
Qed.
(* begin hide *)
End AnalysisOrder.
(* end hide *)