Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Cat.Cat.
Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations.
Require Import NatTrans.NatTrans NatTrans.Operations NatTrans.Func_Cat
        NatTrans.NatIso.

(** Facts about products of acategories involving natural transformations. *)

Local Obligation Tactic := idtac.

Section Prod_Functor_NatTrans.
  Context {C D : Category}
          {F G : (C –≻ D)%functor}
          (N : (F –≻ G)%nattrans)
          {C' D' : Category}
          {F' G' : (C' –≻ D')%functor}
          (N' : (F' –≻ G')%nattrans).

  Program Definition Prod_Functor_NatTrans :
    ((Prod_Functor F F') –≻ (Prod_Functor G G'))%nattrans :=
    {|
      Trans := fun c => (Trans N (fst c), Trans N' (snd c))
    |}.

  Next Obligation.
    basic_simpl.
    do 2 rewrite Trans_com; trivial.
  Qed.

  Next Obligation.
    symmetry.
    apply Prod_Functor_NatTrans_obligation_1.
  Qed.

End Prod_Functor_NatTrans.

Section Prod_Functor_NatTrans_id.
  Context {C D : Category} (F : (C –≻ D)%functor)
          {C' D' : Category} {F' : (C' –≻ D')%functor}.

  Theorem Prod_Functor_NatTrans_id :
    Prod_Functor_NatTrans (NatTrans_id F) (NatTrans_id F') =
    NatTrans_id (Prod_Functor F F').
  Proof.
    apply NatTrans_eq_simplify; trivial.
  Qed.

End Prod_Functor_NatTrans_id.

Section Prod_Functor_NatTrans_compose.
  Context {C D : Category}
          {F G H : (C –≻ D)%functor}
          (N1 : (F –≻ G)%nattrans)
          (N2 : (G –≻ H)%nattrans)
          {C' D' : Category}
          {F' G' H' : (C' –≻ D')%functor}
          (N1' : (F' –≻ G')%nattrans)
          (N2' : (G' –≻ H')%nattrans).

  Theorem Prod_Functor_NatTrans_compose :
    ((Prod_Functor_NatTrans N2 N2') ∘ (Prod_Functor_NatTrans N1 N1') =
     Prod_Functor_NatTrans (N2 ∘ N1) (N2' ∘ N1'))%nattrans.
  Proof.
    apply NatTrans_eq_simplify; trivial.
  Qed.

End Prod_Functor_NatTrans_compose.

Section Prod_Functor_NatIso.
  Context {C D : Category}
          {F G : (C –≻ D)%functor}
          (N : (F ≃ G)%natiso)
          {C' D' : Category}
          {F' G' : (C' –≻ D')%functor}
          (N' : (F' ≃ G')%natiso)
  .

  Program Definition Prod_Functor_NatIso :
    ((Prod_Functor F F') ≃ (Prod_Functor G G'))%natiso :=
    {|
      iso_morphism := Prod_Functor_NatTrans (iso_morphism N) (iso_morphism N');
      inverse_morphism :=
        Prod_Functor_NatTrans (inverse_morphism N) (inverse_morphism N')
    |}.

  Next Obligation.
    cbn.
    rewrite Prod_Functor_NatTrans_compose.
    change ((N ⁻¹)%morphism ∘ (iso_morphism N))%nattrans with (N⁻¹ ∘ N)%morphism.
    change ((N' ⁻¹)%morphism ∘ (iso_morphism N'))%nattrans with (N'⁻¹ ∘ N')%morphism.
    do 2 rewrite (left_inverse).
    apply Prod_Functor_NatTrans_id.
  Qed.

  Next Obligation.
    cbn.
    rewrite Prod_Functor_NatTrans_compose.
    change ((iso_morphism N) ∘ (N ⁻¹)%morphism)%nattrans with (N ∘ N⁻¹)%morphism.
    change ((iso_morphism N') ∘ (N' ⁻¹)%morphism)%nattrans with (N' ∘ N'⁻¹)%morphism.
    do 2 rewrite (right_inverse).
    apply Prod_Functor_NatTrans_id.
  Qed.

End Prod_Functor_NatIso.

Section Fix_Bi_Func_1_NatTrans.
  Context {B C D E : Category}
          {F F' : (((Func_Cat C D) × B) –≻ E)%functor}
          (N : (F –≻ F')%nattrans)
          (G : (C –≻ D)%functor)
  .

  Program Definition Fix_Bi_Func_1_NatTrans :
    ((@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F) –≻ (@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F'))%nattrans
    :=
    {|
      Trans := fun c => Trans N (G, c)
    |}.

  Next Obligation.
  Proof.
    intros c c' h.
    apply (@Trans_com _ _ _ _ N (G, c) (G, c') (NatTrans_id _, h)).
  Qed.

  Next Obligation.
  Proof.
    intros c c' h.
    apply (@Trans_com_sym _ _ _ _ N (G, c) (G, c') (NatTrans_id _, h)).
  Qed.

End Fix_Bi_Func_1_NatTrans.

Section Fix_Bi_Func_1_NatIso.
  Context {B C D E : Category}
          {F F' : (((Func_Cat C D) × B) –≻ E)%functor}
          (N : (F ≃ F')%natiso)
          (G : (C –≻ D)%functor)
  .

  Program Definition Fix_Bi_Func_1_NatIso :
    ((@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F)
       ≃ (@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F'))%natiso
    :=
    {|
      iso_morphism := Fix_Bi_Func_1_NatTrans (iso_morphism N) G;
      inverse_morphism := Fix_Bi_Func_1_NatTrans (inverse_morphism N) G
    |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c.
    cbn.
    change (Trans (inverse_morphism N) (G, c) ∘ Trans (iso_morphism N) (G, c))%morphism with (Trans ((inverse_morphism N) ∘ (iso_morphism N)) (G, c)).
    cbn_rewrite (left_inverse N); trivial.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c; cbn.
    change (Trans (iso_morphism N) (G, c) ∘ Trans (inverse_morphism N) (G, c))%morphism with (Trans ((iso_morphism N) ∘ (inverse_morphism N)) (G, c)).
    cbn_rewrite (right_inverse N); trivial.
  Qed.

End Fix_Bi_Func_1_NatIso.

Section Fix_Bi_Func_2_NatTrans.
  Context {B C D E : Category}
          {F F' : ((B × (Func_Cat C D)) –≻ E)%functor}
          (N : (F –≻ F')%nattrans)
          (G : (C –≻ D)%functor)
  .

  Program Definition Fix_Bi_Func_2_NatTrans :
    ((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F) –≻ (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F'))%nattrans
    :=
    {|
      Trans := fun c => Trans N (c, G)
    |}.

  Next Obligation.
  Proof.
    intros; apply (@Trans_com _ _ _ _ N).
  Qed.

  Next Obligation.
  Proof.
    intros; apply (@Trans_com_sym _ _ _ _ N).
  Qed.

End Fix_Bi_Func_2_NatTrans.

Section Fix_Bi_Func_2_NatIso.
  Context {B C D E : Category}
          {F F' : ((B × (Func_Cat C D)) –≻ E)%functor}
          (N : (F ≃ F')%natiso)
          (G : (C –≻ D)%functor)
  .

  Program Definition Fix_Bi_Func_2_NatIso :
    (
      (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F)
        ≃ (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F'))%natiso
    :=
      {|
        iso_morphism := Fix_Bi_Func_2_NatTrans (iso_morphism N) G;
        inverse_morphism := Fix_Bi_Func_2_NatTrans (inverse_morphism N) G
      |}
  .

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c.
    cbn.
    change (Trans (inverse_morphism N) (c, G) ∘
                  Trans (iso_morphism N) (c, G))%morphism
    with (Trans ((inverse_morphism N) ∘ (iso_morphism N)) (c, G)).
    cbn_rewrite (left_inverse N); trivial.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c.
    cbn.
    change (Trans (iso_morphism N) (c, G) ∘
                  Trans (inverse_morphism N) (c, G))%morphism
    with (Trans ((iso_morphism N) ∘ (inverse_morphism N)) (c, G)).
    cbn_rewrite (right_inverse N); trivial.
  Qed.

End Fix_Bi_Func_2_NatIso.

Section Fix_Bi_Func_1_Functor_id_swap_NatIso.
  Context {B B' C D E E' : Category}
          (F : (B –≻ B')%functor)
          (F' : (((Func_Cat C D) × B') –≻ E)%functor)
          (G : (C –≻ D)%functor)
  .

  Local Obligation Tactic := cbn; auto.

  Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn.

  Program Definition Fix_Bi_Func_1_Functor_id_swap_NatIso :
    (
      (@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G
                      ( F' ∘ (Prod_Functor (Functor_id _) F)))%functor
        ≃ ((@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F') ∘ F)%functor)%natiso :=
    {|
      iso_morphism :=
        {|
          Trans := fun c => id
        |};
      inverse_morphism :=
        {|
          Trans := fun c => id
        |}
    |}.

End Fix_Bi_Func_1_Functor_id_swap_NatIso.

Section Fix_Bi_Func_2_Functor_id_swap_NatIso.
  Context {B B' C D E E' : Category}
          (F : (B –≻ B')%functor)
          (F' : ((B' × (Func_Cat C D)) –≻ E)%functor)
          (G : (C –≻ D)%functor)
  .

  Local Obligation Tactic := cbn; auto.

  Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn.

  Program Definition Fix_Bi_Func_2_Functor_id_swap_NatIso :
    (
      ((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G
                       (F' ∘ (Prod_Functor F (Functor_id _))))%functor)
        ≃((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F') ∘ F)%functor)%natiso :=
    {|
      iso_morphism :=
        {|
          Trans := fun c => id
        |};
      inverse_morphism :=
        {|
          Trans := fun c => id
        |}
    |}.

End Fix_Bi_Func_2_Functor_id_swap_NatIso.

Section Fix_Bi_1_Func_Prod_Func_NatIso.
  Context {A B C D E : Category}
          (F : (A –≻ C)%functor)
          (F' : (B –≻ D)%functor)
          (G : ((C × D) –≻ E)%functor)
          (x : A)
  .

  Local Obligation Tactic := cbn; auto.

  Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn.

  Program Definition Fix_Bi_1_Func_Prod_Func_NatIso :
    (
      ((Fix_Bi_Func_1 x (G ∘ (Prod_Functor F F')))%functor)
        ≃ ((Fix_Bi_Func_1 (F _o x)
                          (G ∘ (Prod_Functor (Functor_id C) F')))
          )%functor
    )%natiso :=
    {|
      iso_morphism := {|Trans := fun c => id|};
      inverse_morphism := {|Trans := fun c => id|}
    |}.

End Fix_Bi_1_Func_Prod_Func_NatIso.

Section Fix_Bi_2_Func_Prod_Func_NatIso.
  Context {A B C D E : Category}
          (F : (A –≻ C)%functor)
          (F' : (B –≻ D)%functor)
          (G : ((C × D) –≻ E)%functor)
          (x : B)
  .

  Local Obligation Tactic := cbn; auto.

  Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn.

  Program Definition Fix_Bi_2_Func_Prod_Func_NatIso :
    (
      ((Fix_Bi_Func_2 x (G ∘ (Prod_Functor F F')))%functor)
        ≃ (Fix_Bi_Func_2 (F' _o x)
                         (G ∘  (Prod_Functor F (Functor_id D)))
          )%functor
    )%natiso :=
    {|
      iso_morphism := {|Trans := fun c => id|};
      inverse_morphism := {|Trans := fun c => id|}
    |}.

End Fix_Bi_2_Func_Prod_Func_NatIso.

Section Func_Prod_of_ids_NatIso.
  Context {C D E : Category} (F : ((C × D) –≻ E)%functor).

  Local Obligation Tactic := cbn; auto.

  Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn.

  Program Definition Func_Prod_of_ids_NatIso :
    ((F ∘ (Prod_Functor (Functor_id C) (Functor_id D)))%functor ≃ F )%natiso :=
    {|
      iso_morphism := {|Trans := fun c => id|};
      inverse_morphism := {|Trans := fun c => id|}
    |}.

End Func_Prod_of_ids_NatIso.

Section Fix_Bi_Func_1_object_NatTrans.
  Context {B C D E : Category}
          (F : (((Func_Cat C D) × B) –≻ E)%functor)
          {G G' : (C –≻ D)%functor}
          (N : (G –≻ G')%nattrans)
  .

  Program Definition Fix_Bi_Func_1_object_NatTrans :
    ((@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F)
       –≻ (@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G' F))%nattrans
     :=
    {|
      Trans := fun c => (F @_a (G, c) (G', c) (N, id))%morphism
    |}.

  Next Obligation.
  Proof.
    intros c c' h.
    cbn.
    repeat rewrite <- F_compose.
    cbn.
    rewrite NatTrans_id_unit_left, NatTrans_id_unit_right.
    auto.
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Fix_Bi_Func_1_object_NatTrans_obligation_1.
  Qed.

End Fix_Bi_Func_1_object_NatTrans.

Section Fix_Bi_Func_1_object_NatIso.
  Context {B C D E : Category}
          (F : (((Func_Cat C D) × B) –≻ E)%functor)
          {G G' : (C –≻ D)%functor}
          (N : (G ≃ G')%natiso)
  .

  Program Definition Fix_Bi_Func_1_object_NatIso :
    (
      ((@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F)%functor)
        ≃ (@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G' F)%functor)%natiso :=
    {|
      iso_morphism := Fix_Bi_Func_1_object_NatTrans F (iso_morphism N);
      inverse_morphism := Fix_Bi_Func_1_object_NatTrans F (inverse_morphism N)
    |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c; cbn.
    rewrite <- F_compose; cbn.
    cbn_rewrite (left_inverse N).
    simpl_ids.
    change (NatTrans_id G, id) with (id ((Func_Cat _ _) × B) (G, c)).
    auto.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c; cbn.
    rewrite <- F_compose; cbn.
    cbn_rewrite (right_inverse N).
    simpl_ids.
    change (NatTrans_id G', id) with (id ((Func_Cat _ _) × B) (G', c)).
    auto.
  Qed.

End Fix_Bi_Func_1_object_NatIso.

Section Fix_Bi_Func_2_object_NatTrans.
  Context {B C D E : Category} (F : ((B × (Func_Cat C D)) –≻ E)%functor)
          {G G' : (C –≻ D)%functor}
          (N : (G –≻ G')%nattrans)
  .

  Program Definition Fix_Bi_Func_2_object_NatTrans :
    ((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F)
       –≻ (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G' F))%nattrans
    :=
    {|
      Trans := fun c => (F @_a (c, G) (c, G') (id, N))%morphism
    |}.

  Next Obligation.
  Proof.
    intros c c' h; cbn.
    repeat rewrite <- F_compose; cbn.
    rewrite NatTrans_id_unit_left, NatTrans_id_unit_right.
    auto.
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Fix_Bi_Func_2_object_NatTrans_obligation_1.
  Qed.

End Fix_Bi_Func_2_object_NatTrans.

Section Fix_Bi_Func_2_object_NatIso.
  Context {B C D E : Category}
          (F : ((B × (Func_Cat C D)) –≻ E)%functor)
          {G G' : (C –≻ D)%functor}
          (N : (G ≃ G')%natiso).

  Program Definition Fix_Bi_Func_2_object_NatIso :
    (((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F)%functor)
       ≃ (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G' F)%functor)%natiso :=
    {|
      iso_morphism := Fix_Bi_Func_2_object_NatTrans F (iso_morphism N);
      inverse_morphism := Fix_Bi_Func_2_object_NatTrans F (inverse_morphism N)
    |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c; cbn.
    rewrite <- F_compose; cbn.
    simpl_ids.
    cbn_rewrite (left_inverse N).
    change (id, NatTrans_id G) with (id (B × (Func_Cat _ _)) (c, G)).
    auto.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c; cbn.
    rewrite <- F_compose; cbn.
    simpl_ids.
    cbn_rewrite (right_inverse N).
    change (id, NatTrans_id G') with (id (B × (Func_Cat _ _)) (c, G')).
    auto.
  Qed.

End Fix_Bi_Func_2_object_NatIso.


(* In this file we explain how to do the "list examples" from the
   Chapter on Separation Logic for Sequential Programs in the
   Iris Lecture Notes *)

(* Contains definitions of the weakest precondition assertion, and its basic rules. *)
From iris.program_logic Require Export weakestpre.

(* Instantiation of Iris with the particular language. The notation file
   contains many shorthand notations for the programming language constructs, and
   the lang file contains the actual language syntax. *)
From iris.heap_lang Require Export notation lang.

(* Files related to the interactive proof mode. The first import includes the
   general tactics of the proof mode. The second provides some more specialized
   tactics particular to the instantiation of Iris to a particular programming
   language. *)
From iris.proofmode Require Export tactics.
From iris.heap_lang Require Import proofmode.

(* The following line makes Coq check that we do not use any admitted facts /
   additional assumptions not in the statement of the theorems being proved. *)
Set Default Proof Using "Type".

(*  ---------------------------------------------------------------------- *)

Section list_model.
  (* This section contains the definition of our model of lists, i.e.,
     definitions relating pointer data structures to our model, which is
     simply mathematical sequences (Coq lists). *)

(* In order to do the proof we need to assume certain things about the
   instantiation of Iris. The particular, even the heap is handled in an
   analogous way as other ghost state. This line states that we assume the
   Iris instantiation has sufficient structure to manipulate the heap, e.g.,
   it allows us to use the points-to predicate. *)
Context `{!heapGS Σ}.
Implicit Types l : loc.

(* The variable Σ has to do with what ghost state is available, and the type
     of Iris propositions (written Prop in the lecture notes) depends on this Σ.
     But since Σ is the same throughout the development we shall define
     shorthand notation which hides it. *)
Notation iProp := (iProp Σ).

(* Here is the basic is_list representation predicate:
    is_list hd xs holds if hd points to a linked list consisting of
   the elements in the mathematical sequence (Coq list) xs.
 *)
Fixpoint is_list (hd : val) (xs : list val) : iProp :=
  match xs with
  | [] => ⌜hd = NONEV⌝
  | x :: xs => ∃ l hd', ⌜hd = SOMEV #l⌝ ∗ l ↦ (x,hd') ∗ is_list hd' xs
end%I.

(* The following predicate
     is_listP P hd xs
   holds if hd points to a linked list consisting of the elements in xs and
   each of those elements satisfy P.
 *)
Fixpoint is_listP P (hd : val) (xs : list val) : iProp :=
  match xs with
  | [] => ⌜hd = NONEV⌝
  | x :: xs => ∃ l hd', ⌜hd = SOMEV #l⌝ ∗ l ↦ (x,hd') ∗ is_listP P hd' xs ∗ P x
end%I.

(* about_isList expresses how is_listP P hd xs can be seen as a combination of the
   basic is_list predicate and the property that P holds for all the elements in xs.
 *)
Lemma about_isList P hd xs :
  is_listP P hd xs ⊣⊢ is_list hd xs ∗ [∗ list] x ∈ xs, P x.
Proof.
  generalize dependent hd.
  induction xs as [| x xs' IHxs]; simpl; intros hd; iSplit.
  - eauto.
  - by iIntros "(? & _)".
  - iDestruct 1 as (l hd') "(? & ? & H & ?)". rewrite IHxs. iDestruct "H" as "(H_isListxs' & ?)".
    iFrame. iExists l, hd'. iFrame.
  - iDestruct 1 as "(H_isList & ? & H)". iDestruct "H_isList" as (l hd') "(? & ? & ?)".
    iExists l, hd'. rewrite IHxs. iFrame.
Qed.

(* The predicate
      is_list_nat hd xs
   holds if hd is a pointer to a linked list of numbers (integers).
*)
Fixpoint is_list_nat (hd : val) (xs : list Z) : iProp :=
  match xs with
  | [] => ⌜hd = NONEV⌝
  | x :: xs => ∃ l hd', ⌜hd = SOMEV #l⌝ ∗ l ↦ (#x,hd') ∗ is_list_nat hd' xs
  end%I.

(* The reverse function on Coq lists is defined in the Coq library. *)
Definition reverse (l : list val) := List.rev l.

Definition inj {A B : Type} (f : A -> B) : Prop :=
  forall (x y : A),
    f x = f y -> x = y.

Lemma map_injective {A B : Type} :
  forall xs ys (f : A -> B), inj f -> map f xs = map f ys
           -> xs = ys.
Proof.
  intros xs. induction xs as [|x xs IHxs]; intros ys f H_f H_map.
  - symmetry in H_map. by apply map_eq_nil in H_map.
  - destruct ys as [|y ys].
    + by apply map_eq_nil in H_map.
    + specialize (IHxs ys f). inversion H_map as [H_a].
      rewrite -> IHxs; try done.
      apply H_f in H_a. by rewrite H_a.
Qed.

End list_model.

(*  ---------------------------------------------------------------------- *)

Section list_code.
  (* This section contains the code of the list functions we specify *)

  (* Function inc hd assumes all values in the linked list pointed to by hd
     are numbers and increments them by 1, in-place *)
  Definition inc : val :=
  rec: "inc" "hd" :=
    match: "hd" with
      NONE => #()
    | SOME "l" =>
       let: "tmp1" := Fst !"l" in
       let: "tmp2" := Snd !"l" in
       "l" <- (("tmp1" + #1), "tmp2");;
       "inc" "tmp2"
    end.

  (* Function app l l' appends linked list l' to end of linked list l *)
  Definition app : val :=
  rec: "app" "l" "l'" :=
    match: "l" with
      NONE => "l'"
    | SOME "hd" =>
      let: "tmp1" := !"hd" in
      let: "tmp2" := "app" (Snd "tmp1") "l'" in
      "hd" <- ((Fst "tmp1"), "tmp2");;
           "l"
    end.

  (* Function rev l acc reverses all the pointers in linked list l and stiches
     the accumulator argument acc at the end *)
  Definition rev : val :=
  rec: "rev" "l" "acc" :=
    match: "l" with
      NONE => "acc"
    | SOME "p" =>
       let: "h" := Fst !"p" in
       let: "t" := Snd !"p" in
       "p" <- ("h", "acc");;
       "rev" "t" "l"
    end.

  (* Function len l returns the lenght of linked list l *)
  Definition len : val :=
  rec: "len" "l" :=
    match: "l" with
      NONE => #0
    | SOME "p" =>
      ("len" (Snd !"p") + #1)
    end.

  (* Function foldr f a l is the usual fold right function for linked list l, with
     base value a and combination function f *)
  Definition foldr : val :=
  rec: "foldr" "f" "a" "l" :=
    match: "l" with
      NONE => "a"
    | SOME "p" =>
      let: "hd" := Fst !"p" in
      let: "t" := Snd !"p" in
      "f" ("hd", ("foldr" "f" "a" "t"))
    end.

  (* sum_list l returns the sum of the list of numbers in linked list l,
     implemented by call to foldr *)
  Definition sum_list : val :=
  rec: "sum_list" "l" :=
    let: "f'" := (λ: "p", let: "x" := Fst "p" in
                         let: "y" := Snd "p" in
                         "x" + "y")
    in
    (foldr  "f'" #0 "l").

  Definition cons : val := (λ: "x" "xs",
                          let: "p" := ("x", "xs") in
                          SOME (Alloc("p"))).

  Definition empty_list : val := NONEV.

  (* filter prop l is the usual filter function on linked lists, prop is supposed
     to be a function from values to booleans. Implemented using foldr. *)
  Definition filter : val :=
  rec: "filter" "prop" "l" :=
    let: "f" :=  (λ: "p",
                  let: "x" := Fst "p" in
                  let: "xs" := Snd "p" in
                  if: ("prop" "x")
                  then (cons "x" "xs")
                  else "xs")
    in (foldr "f" empty_list "l").

  (* map_list f l is the usual map function on linked lists with f the function
     to be mapped over the list l. Implemented using foldr. *)
  Definition map_list : val :=
  rec: "map_list" "f" "l" :=
    let: "f'" :=  (λ: "p",
                   let: "x" := Fst "p" in
                   let: "xs" := Snd "p" in
                   (cons ("f" "x") "xs"))
    in
    (foldr "f'" empty_list "l").

  (* incr l is another variant of the increment function on linked lists, implemented using map. *)
  Definition incr : val :=
    rec: "incr" "l" :=
     map_list (λ: "n", "n" + #1)%I "l".

End list_code.

(*  ---------------------------------------------------------------------- *)

Section list_spec.
  (* This section contains the specifications and proofs for the list functions.
     The specifications and proofs are explained in the Iris Lecture Notes
   *)

  Context `{!heapGS Σ}.

Lemma inc_spec hd xs :
  {{{ is_list_nat hd xs }}}
    inc hd
  {{{ w, RET w; ⌜w = #()⌝ ∗ is_list_nat hd (List.map Z.succ xs) }}}.
Proof.
  iIntros (ϕ) "Hxs H".
  iLöb as "IH" forall (hd xs ϕ). wp_rec. destruct xs as [|x xs]; iSimplifyEq.
   - wp_match. iApply "H". done.
   - iDestruct "Hxs" as (l hd') "(% & Hx & Hxs)". iSimplifyEq.
     wp_match. do 2 (wp_load; wp_proj; wp_let). wp_op.
     wp_store. iApply ("IH" with "Hxs").
     iNext. iIntros (w) "H'". iApply "H". iDestruct "H'" as "[Hw Hislist]".
     iFrame. iExists l, hd'. iFrame. done.
Qed.

Lemma app_spec xs ys (l l' : val) :
  {{{ is_list l xs ∗ is_list l' ys }}}
    app l l'
  {{{ v, RET v; is_list v (xs ++ ys) }}}.
Proof.
  iIntros (ϕ) "[Hxs Hys] H".
  iLöb as "IH" forall (l xs l' ys ϕ).
  destruct xs as [| x xs']; iSimplifyEq.
   - wp_rec. wp_let. wp_match. iApply "H". done.
   - iDestruct "Hxs" as (l0 hd0) "(% & Hx & Hxs)". iSimplifyEq.
     wp_rec. wp_let. wp_match. wp_load. wp_let. wp_proj. wp_bind (app _ _)%E.
     iApply ("IH" with "Hxs Hys").
     iNext. iIntros (v) "?". wp_let. wp_proj. wp_store. iSimplifyEq. iApply "H".
     iExists l0, _. iFrame. done.
Qed.

Lemma rev_spec vs us (l acc : val) :
  {{{ is_list l vs ∗ is_list acc us }}}
    rev l acc
  {{{ w, RET w; is_list w (reverse vs ++ us) }}}.
Proof.
  iIntros (ϕ) "[H1 H2] HL".
  iInduction vs as [| v vs'] "IH" forall (acc l us).
   - iSimplifyEq. wp_rec. wp_let. wp_match. iApply "HL". done.
   - simpl. iDestruct "H1" as (l' t) "(%H & H3 & H1)". wp_rec. wp_let.
     rewrite -> H at 1. wp_match. do 2 (wp_load; wp_proj; wp_let).
     wp_store. iSpecialize ("IH" $! l t ([v] ++ us)).
     iApply ("IH" with "[H1] [H3 H2]").
     + done.
     + simpl. iExists l', acc. iFrame. done.
     + iNext. rewrite -> app_assoc. done.
Qed.

Lemma len_spec (l : val) xs :
  {{{ is_list l xs }}}
    len l
  {{{ v, RET v; ⌜v = #(length xs)⌝ }}}.
Proof.
  iIntros (ϕ) "Hl H".
  iInduction xs as [| x xs'] "IH" forall (l ϕ); iSimplifyEq.
   - wp_rec. wp_match. iApply "H". done.
   - iDestruct "Hl" as (p hd') "(% & Hp & Hhd')". wp_rec. iSimplifyEq.
     wp_match. wp_load. wp_proj. wp_bind (len hd')%I. iApply ("IH" with "[Hhd'] [Hp H]"); try done.
     iNext. iIntros. iSimplifyEq. wp_op. iApply "H". iPureIntro. do 2 f_equal. lia.
Qed.

(* The following specifications for foldr are non-trivial because the code is higher-order
   and hence the specifications involved nested triples.
   The specifications are explained in the Iris Lecture Notes. *)

Lemma foldr_spec_PI P I  (f a hd : val) (xs : list val) :
  {{{ (∀ (x a' : val) (ys : list val),
          {{{ P x ∗ I ys a'}}}
            f (x, a')
          {{{r, RET r; I (x::ys) r }}})
        ∗ is_list hd xs
        ∗ ([∗ list] x ∈ xs, P x)
        ∗ I [] a
  }}}
    foldr f a hd
  {{{
       r, RET r; is_list hd xs
                 ∗ I xs r
  }}}.
Proof.
  iIntros (ϕ) "(#H_f & H_isList & H_Px & H_Iempty) H_inv".
  iInduction xs as [|x xs'] "IH" forall (ϕ a hd); wp_rec; do 2 wp_let; iSimplifyEq.
  - wp_match. iApply "H_inv". eauto.
  - iDestruct "H_isList" as (l hd') "[% [H_l H_isList]]".
    iSimplifyEq.
    wp_match. do 2 (wp_load; wp_proj; wp_let).
    wp_bind (((foldr f) a) hd').
    iDestruct "H_Px" as "(H_Px & H_Pxs')".
    iApply ("IH" with "H_isList H_Pxs' H_Iempty [H_l H_Px H_inv]").
    iNext. iIntros (r) "(H_isListxs' & H_Ixs')".
    iApply ("H_f" with "[$H_Ixs' $H_Px] [H_inv H_isListxs' H_l]").
    iNext. iIntros (r') "H_inv'". iApply "H_inv". iFrame.
    iExists l, hd'. by iFrame.
Qed.

Lemma foldr_spec_PPI P I (f a hd : val) (xs : list val) :
  {{{ (∀ (x a' : val) (ys : list val),
          {{{ P x ∗ I ys a'}}}
            f (x, a')
          {{{r, RET r; I (x::ys) r }}})
        ∗ is_listP P hd xs
        ∗ I [] a
  }}}
    foldr f a hd
  {{{
       r, RET r; is_listP (fun x => True) hd xs
                 ∗ I xs r
  }}}.
Proof.
  iIntros (ϕ) "(#H_f & H_isList & H_Iempty) H_inv".
  rewrite about_isList. iDestruct "H_isList" as "(H_isList & H_Pxs)".
  iApply (foldr_spec_PI with "[-H_inv]").
  - iFrame. by iFrame "H_f".
  - iNext. iIntros (r) "(H_isList & H_Ixs)".
    iApply "H_inv". iFrame. rewrite about_isList. iFrame. by rewrite big_sepL_forall.
Qed.

Lemma sum_spec (hd: val) (xs: list Z) :
  {{{ is_list hd (map (fun (n : Z) => #n) xs)}}}
    sum_list hd
  {{{ v, RET v; ⌜v = # (fold_right Z.add 0 xs)⌝ }}}.
Proof.
  iIntros (ϕ) "H_is_list H_later".
  wp_rec. wp_pures.
  iApply (foldr_spec_PI
            (fun x => (∃ (n : Z), ⌜x = #n⌝)%I)
            (fun xs' acc => ∃ ys,
                 ⌜acc = #(fold_right Z.add 0 ys)⌝
               ∗ ⌜xs' = map (fun (n : Z) => #n) ys⌝
               ∗ ([∗ list] x ∈ xs',∃ (n' : Z), ⌜x = #n'⌝))%I
            with "[$H_is_list] [H_later]").
  - iSplitR.
    + iIntros (x a' ys). iModIntro. iIntros (ϕ') "(H1 & H2) H3".
      do 5 (wp_pure _).
      iDestruct "H2" as (zs) "(% & % & H_list)".
      iDestruct "H1" as (n2) "%". iSimplifyEq. wp_pures. iModIntro.
      iApply "H3". iExists (n2::zs). repeat (iSplit; try done).
      by iExists _.
    + iSplit.
      * induction xs as [|x xs IHxs]; iSimplifyEq; first done.
        iSplit; [iExists _; done | apply IHxs].
      * iExists []. eauto.
  - iNext. iIntros (r) "(H1 & H2)".
    iApply "H_later". iDestruct "H2" as (ys) "(% & % & H_list)".
    iSimplifyEq. rewrite (map_injective xs ys (λ n : Z, #n)); try done.
    unfold inj. intros x y H_xy. by inversion H_xy.
Qed.

Lemma filter_spec (hd p : val) (xs : list val) (P : val -> bool) :
  {{{ is_list hd xs
      ∗ (∀ x : val ,
           {{{ True }}}
           p x
           {{{r, RET r; ⌜r = #(P x)⌝ }}})
  }}}
  filter p hd
  {{{ v, RET v; is_list hd xs
                ∗ is_list v (List.filter P xs)
  }}}.
Proof.
  iIntros (ϕ) "[H_isList #H_p] H_ϕ". wp_rec. wp_pures.
  iApply (foldr_spec_PI (fun x => True)%I
                        (fun xs' acc => is_list acc (List.filter P xs'))%I
                  with "[$H_isList] [H_ϕ]").
  - iSplitL.
    + iIntros (x a' ?) "!# %ϕ'". iIntros "[_ H_isList] H_ϕ'".
      repeat (wp_pure _). wp_bind (p x). iApply "H_p"; first done.
      iNext. iIntros (r) "H". iSimplifyEq. destruct (P x); wp_if.
      * wp_rec. wp_pures. wp_alloc l. wp_pures. iApply "H_ϕ'".
        iExists l, a'. by iFrame.
      * by iApply "H_ϕ'".
    + iSplit; last done.
      rewrite big_sepL_forall. eauto.
  - iNext. iApply "H_ϕ".
Qed.

Lemma map_spec P Q (f hd : val) (xs : list val) :
  {{{
       is_list hd xs
        ∗ (∀ (x : val), {{{ P x }}}
                          f x
                        {{{r, RET r; Q x r}}})
        ∗ [∗ list] x ∈ xs, P x
  }}}
    map_list f hd
  {{{
       r, RET r; ∃ (ys : list val),  is_list r ys
                                     ∗ ([∗ list] p ∈ zip xs ys, Q (fst p) (snd p))
                                     ∗ ⌜List.length ys = List.length xs⌝
  }}}.
Proof.
  iIntros (ϕ) "[H_is_list [#H1 H_P_xs]] H_ϕ".
  wp_rec. wp_pures.
  iApply (foldr_spec_PI
            P
            (fun xs acc => ∃ ys,  (is_list acc ys)
                                 ∗ ([∗ list] p ∈ zip xs ys, Q (fst p) (snd p))
                                 ∗ ⌜length xs = length ys⌝)%I
            with "[H_is_list H1 H_P_xs] [H_ϕ]").
  - iSplitR "H_is_list H_P_xs".
    + iIntros (x a' ys). iModIntro. iIntros (ϕ') "(H_Px & H_Q) H_ϕ'". wp_pures.
      wp_bind (f x). iApply ("H1" with "[H_Px][H_Q H_ϕ']"); try done.
      iNext. iIntros (r) "H_Qr". wp_rec. wp_alloc l. wp_pures. iApply "H_ϕ'".
      iDestruct "H_Q" as (ys') "(H_is_list_ys' & H_Qys' & %)". iExists (r::ys').
      iSplitR "H_Qr H_Qys'".
      * unfold is_list. iExists l, a'. fold is_list. by iFrame.
      * iSimplifyEq. iFrame. eauto.
    + iFrame. iExists []. iSplit; by simpl.
  - iNext. iIntros (r) "H". iApply "H_ϕ". iDestruct "H" as "(_ & H_Q)".
    iDestruct "H_Q" as (ys) "(H_isList & H_Q & %)". iExists ys. by iFrame.
Qed.

Lemma about_length {A : Type} (xs : list A) (n : nat) :
  length xs = S n -> exists x xs', xs = x::xs'.
Proof.
  intro H. induction xs as [| x xs' ].
  - inversion H.
  - by exists x, xs'.
Qed.

Lemma inc_with_map hd (xs : list Z) :
  {{{ is_list hd (List.map (fun (n : Z) => #n) xs) }}}
    incr hd
  {{{ v, RET v; is_list v (List.map (fun (n : Z) => #n) (List.map Z.succ xs)) }}}.
Proof.
  iIntros (ϕ) "H_isList H_ϕ". wp_rec. wp_pures.
  wp_apply (map_spec
             (fun x => (∃ (n : Z), ⌜x = #n⌝)%I)
             (fun x r =>  (∃ (n' : Z),
                             ⌜r = #(Z.succ n')⌝
                                ∗ ⌜x = #n'⌝)%I)
           with "[$H_isList] [H_ϕ]").
  - iSplit. iIntros (x) "!#". iIntros (ϕ') "H1 H2". wp_lam. iDestruct "H1" as (n) "H_x".
    iSimplifyEq. wp_binop. iApply "H2". by iExists n.
    rewrite big_sepL_fmap. rewrite big_sepL_forall. eauto.
  - iNext. iIntros (r) "H". iApply "H_ϕ". iDestruct "H" as (ys) "(H_isList & H_post & H_length)".
    iAssert (⌜ys = (List.map (λ n : Z, #n) (List.map Z.succ xs))⌝)%I with "[-H_isList]" as %->.
    { iInduction ys as [| y ys'] "IH" forall (xs); iDestruct "H_length" as %H.
       - simpl. destruct xs. by simpl. inversion H.
       - rewrite fmap_length in H. symmetry in H. simpl in H.
         destruct (about_length _ _ H) as (x & xs' & ->). simpl.
         iDestruct "H_post" as "(H_head & H_tail)".
         iDestruct "H_head" as (n') "(% & %)". iSimplifyEq.
         iDestruct ("IH" with "H_tail []") as %->. by rewrite fmap_length. done.
    }
    iFrame.
Qed.

End list_spec.


Require Export Utlc.SpecScoping.
Require Export Utlc.SpecEvaluation.

Definition PCtxEquivalent (γ: Dom) (t₁ t₂: UTm) : Prop :=
  ∀ C,
    ⟨ ⊢ C : γ → 0 ⟩ →
    (pctx_app t₁ C)⇓ ↔ (pctx_app t₂ C)⇓.
Notation "⟨  γ ⊢ t₁ ≃ t₂ ⟩" :=
  (PCtxEquivalent γ t₁ t₂)
  (at level 0, γ at level 10, t₁ at level 10, t₂ at level 10).

Definition PCtxEquivalentCtx (γᵢ : Dom) (C₁ C₂: PCtx) : Prop :=
  ∀ t,
    wsUTm γᵢ t ->
    (* ⟨ γᵢ ⊢ t ⟩ → *)
    (pctx_app t C₁)⇓ ↔ (pctx_app t C₂)⇓.
Notation "⟨ ⊢ C₁ ≃ C₂ : γᵢ → 0 ⟩" :=
  (PCtxEquivalentCtx γᵢ C₁ C₂)
  (at level 0, γᵢ at level 10, C₁ at level 10, C₂ at level 10).

Lemma pctx_equiv_symm {γ t₁ t₂} :
  ⟨ γ ⊢ t₁ ≃ t₂ ⟩ → ⟨ γ ⊢ t₂ ≃ t₁ ⟩.
Proof.
  unfold PCtxEquivalent.
  intros equiv C wsc; split;
  apply (equiv C wsc).
Qed.

Lemma pctx_equiv_ctx_symm {γᵢ C₁ C₂} :
  ⟨ ⊢ C₁ ≃ C₂ : γᵢ → 0 ⟩ ->
  ⟨ ⊢ C₂ ≃ C₁ : γᵢ → 0 ⟩.
Proof.
  intros equiv C wsc; split;
  apply (equiv C wsc).
Qed.


Require Import Tapl.Stlc.Base.
Require Import Tapl.Stlc.Exp.
Require Import Tapl.Stlc.Subst.
Require Import Tapl.Stlc.Typing.

(* Progress: Every well-typed term is either a value or can take a step. *)
Theorem progress : forall t T,
    nil ⊢ t ∈ T ->
    value t ∨ exists t', t --> t'.
Proof with auto.
  intros.
  remember nil as G.
  induction H; subst.
  - (* If ⊢ t was derived from the variable rule, this is a contradiction since there are no free variables in the empty context. *)
    exfalso. apply get_nil in H...
  - (* If ⊢ t was derived from the abstraction rule, t is a value, so we're done. *)
    left; split... apply wf_abs. eauto.
  - (* By our inductive hypothesis, t1 is either a value, or it can step to t1'.
       If it can step, then we just follow st_app1. If it is a value, then t2 is either a value or it can step to t2'.
       If it can step to t2', then we just follow st_app2. If t2 is a value, then since by the canonical arrow lemma, t1 must be an abstraction, so we can follow st_appAbs. *)
    right.
    pose proof (IHhas_type1 eq_refl).
    pose proof (IHhas_type2 eq_refl).
    destruct H1.
    + destruct H2.
      * pose proof (canonical_forms_arrow t1 T1 T2 H H1).
        destruct H3 as [t' H3]. subst.
        exists (substX 0 t2 t')...
      * destruct H2 as [t2' H2].
        exists (tm_app t1 t2')...
    + destruct H1 as [t1' H1]. exists (tm_app t1' t2)...
  - (* If ⊢ t was derived from the unit rule, t is a value. *)
    left; split; unfold closed...
Qed.

(* Preservation: If t has type T and steps to t', then t' also has type T. *)
Theorem preservation : forall t t' T,
    t --> t' ->
    nil ⊢ t ∈ T ->
    nil ⊢ t' ∈ T.
Proof with eauto.
  intros.
  generalize dependent t'.
  remember nil as Γ.
  induction H0; intros; subst.
  - exfalso. apply get_nil in H...
  - inversion H.
  - inversion H; subst...
    + apply subst_preserves_typing with T1...
      inversion H0_; subst...
  - inversion H.
Qed.

(* Type safety: If t has type T, then it never reaches a stuck state. *)
Definition stuck (t : term) := ¬ value t ∧ ¬ exists t', t --> t'.

Theorem soundness : ∀ t t' T,
  nil ⊢ t ∈ T →
  t -->* t' →
  ¬ (stuck t).
Proof with eauto.
  intros.
  unfold stuck.
  induction H0; unfold not; intros [HA HB].
  - apply progress in H. destruct H as [vt | [t' Ht]]...
  - apply (preservation a b T) in H...
Qed.


Require Export Limits.
Require Import Common Duals SpecializedCommaCategory FunctorCategory.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Local Open Scope category_scope.

Section Pullback.
  (* Quoting nCatLab (http://ncatlab.org/nlab/show/pullback):

     A pullback is a limit of a diagram like this:
     [[
        a       b
         \     /
        f \   / g
           ↘ ↙
            c
     ]]
   *)

  Context `(C : @SpecializedCategory objC).
  Section pullback.
    Variables a b c : objC.
    Variable f : C.(Morphism) a c.
    Variable g : C.(Morphism) b c.

    Inductive PullbackThree := PullbackA | PullbackB | PullbackC.

    Definition PullbackIndex_Morphism (a b : PullbackThree) : Set :=
      match (a, b) with
        | (PullbackA, PullbackA) => unit
        | (PullbackB, PullbackB) => unit
        | (PullbackC, PullbackC) => unit
        | (PullbackA, PullbackC) => unit
        | (PullbackB, PullbackC) => unit
        | _ => Empty_set
      end.

    Global Arguments PullbackIndex_Morphism a b /.

           Definition PullbackIndex_Compose s d d' (m1 : PullbackIndex_Morphism d d') (m2 : PullbackIndex_Morphism s d) :
      PullbackIndex_Morphism s d'.
             destruct s, d, d'; simpl in *; trivial.
           Defined.

    Definition PullbackIndex : @SpecializedCategory PullbackThree.
      refine (@Build_SpecializedCategory _
                                         PullbackIndex_Morphism
                                         (fun x => match x as p return (PullbackIndex_Morphism p p) with
                                                       PullbackA => tt | PullbackB => tt | PullbackC => tt
                                                   end)
                                         PullbackIndex_Compose
                                         _
                                         _
                                         _);
      abstract (
          intros; destruct_type PullbackThree; simpl in *; destruct_type Empty_set; trivial
        ).
    Defined.

    Definition PullbackDiagram_ObjectOf x :=
      match x with
        | PullbackA => a
        | PullbackB => b
        | PullbackC => c
      end.

    Global Arguments PullbackDiagram_ObjectOf x / .

    Definition PullbackDiagram_MorphismOf s d (m : Morphism PullbackIndex s d) :
      Morphism C (PullbackDiagram_ObjectOf s) (PullbackDiagram_ObjectOf d).
      destruct s, d; simpl in *;
      try apply Identity;
      try assumption;
      try solve [ destruct m ].
    Defined.

    Definition PullbackDiagram : SpecializedFunctor PullbackIndex C.
      match goal with
        | [ |- SpecializedFunctor ?C ?D ] =>
          refine (Build_SpecializedFunctor C D
                                           PullbackDiagram_ObjectOf
                                           PullbackDiagram_MorphismOf
                                           _
                                           _
                 )
      end;
      abstract (
          unfold PullbackDiagram_MorphismOf; simpl; intros;
          destruct_type PullbackThree;
          repeat rewrite LeftIdentity; repeat rewrite RightIdentity;
          trivial; try destruct_to_empty_set
        ).
    Defined.

    Definition Pullback := Limit PullbackDiagram.
    Definition IsPullback := IsLimit (F := PullbackDiagram).
  End pullback.

  Section pullback_functorial.
    Local Infix "/" := SliceSpecializedCategoryOver.

    Variable c : C.

    Definition PullbackDiagramFunctor_ObjectOf : ((C / c) * (C / c)) -> (C ^ PullbackIndex)%category
      := fun fg => PullbackDiagram _ _ c (projT2 (fst fg)) (projT2 (snd fg)).

    Definition PullbackDiagramFunctor_MorphismOf_ComponentsOf s d (m : Morphism ((C / c) * (C / c)) s d)
    : forall x, Morphism _ (PullbackDiagramFunctor_ObjectOf s x) (PullbackDiagramFunctor_ObjectOf d x)
      := fun x => match x with
                    | PullbackA => (fst (proj1_sig (fst m)))
                    | PullbackB => (fst (proj1_sig (snd m)))
                    | PullbackC => Identity _
                  end.

    Definition PullbackDiagramFunctor_MorphismOf s d (m : Morphism ((C / c) * (C / c)) s d)
    : Morphism (C ^ PullbackIndex) (PullbackDiagramFunctor_ObjectOf s) (PullbackDiagramFunctor_ObjectOf d).
      exists (PullbackDiagramFunctor_MorphismOf_ComponentsOf m).
      abstract (
          destruct m as [[[]] [[]]];
          simpl in *;
            intros [] [] [];
          simpl in *;
            autorewrite with morphism in *;
            trivial
        ).
    Defined.

    Definition PullbackDiagramFunctor : SpecializedFunctor ((C / c) * (C / c)) (C ^ PullbackIndex).
      match goal with
        | [ |- SpecializedFunctor ?C ?D ] =>
          refine (Build_SpecializedFunctor C D
                                           PullbackDiagramFunctor_ObjectOf
                                           PullbackDiagramFunctor_MorphismOf
                                           _
                                           _)
      end;
      abstract (
          repeat intros [[[[? []] ?]] [[[? []] ?]]];
          simpl in *;
            nt_eq;
          destruct_head PullbackThree;
          autorewrite with morphism;
          trivial
        ).
    Defined.
  End pullback_functorial.

  Section pushout.
    Variables a b c : objC.
    Variable f : C.(Morphism) c a.
    Variable g : C.(Morphism) c b.

    Definition PushoutIndex := OppositeCategory PullbackIndex.
    Definition PushoutDiagram_ObjectOf := PullbackDiagram_ObjectOf a b c.

    Global Arguments PushoutDiagram_ObjectOf x / .

    Definition PushoutDiagram_MorphismOf s d (m : Morphism PushoutIndex s d) :
      Morphism C (PushoutDiagram_ObjectOf s) (PushoutDiagram_ObjectOf d).
      destruct s, d; simpl in *;
      try apply Identity;
      try assumption;
      try solve [ destruct m ].
    Defined.

    Definition PushoutDiagram : SpecializedFunctor PushoutIndex C.
      match goal with
        | [ |- SpecializedFunctor ?C ?D ] =>
          refine (Build_SpecializedFunctor C D
                                           PushoutDiagram_ObjectOf
                                           PushoutDiagram_MorphismOf
                                           _
                                           _
                 )
      end;
      abstract (
          unfold PushoutDiagram_MorphismOf; simpl; intros;
          destruct_type PullbackThree;
          repeat rewrite LeftIdentity; repeat rewrite RightIdentity;
          trivial; try destruct_to_empty_set
        ).
    Defined.

    Definition Pushout := Colimit PushoutDiagram.
    Definition IsPushout := IsColimit (F := PushoutDiagram).
  End pushout.

  Section pushout_functorial.
    Variable c : C.

    Definition PushoutDiagramFunctor_ObjectOf : ((c \ C) * (c \ C)) -> (C ^ PushoutIndex)%category
      := fun fg => PushoutDiagram _ _ c (projT2 (fst fg)) (projT2 (snd fg)).

    Definition PushoutDiagramFunctor_MorphismOf_ComponentsOf s d (m : Morphism ((c \ C) * (c \ C)) s d)
    : forall x, Morphism _ (PushoutDiagramFunctor_ObjectOf s x) (PushoutDiagramFunctor_ObjectOf d x)
      := fun x => match x with
                    | PullbackA => (snd (proj1_sig (fst m)))
                    | PullbackB => (snd (proj1_sig (snd m)))
                    | PullbackC => Identity _
                  end.

    Definition PushoutDiagramFunctor_MorphismOf s d (m : Morphism ((c \ C) * (c \ C)) s d)
    : Morphism (C ^ PushoutIndex) (PushoutDiagramFunctor_ObjectOf s) (PushoutDiagramFunctor_ObjectOf d).
      exists (PushoutDiagramFunctor_MorphismOf_ComponentsOf m).
      abstract (
          destruct m as [[[]] [[]]];
          simpl in *;
            intros [] [] [];
          simpl in *;
            autorewrite with morphism in *;
            trivial
        ).
    Defined.

    Definition PushoutDiagramFunctor : SpecializedFunctor ((c \ C) * (c \ C)) (C ^ PushoutIndex).
      match goal with
        | [ |- SpecializedFunctor ?C ?D ] =>
          refine (Build_SpecializedFunctor C D
                                           PushoutDiagramFunctor_ObjectOf
                                           PushoutDiagramFunctor_MorphismOf
                                           _
                                           _)
      end;
      abstract (
          repeat intros [[[[? []] ?]] [[[? []] ?]]];
          simpl in *;
            nt_eq;
          destruct_head PullbackThree;
          autorewrite with morphism;
          trivial
        ).
    Defined.
  End pushout_functorial.
End Pullback.

Section PullbackObjects.
  Context `{C : @SpecializedCategory objC}.
  Variables a b c : objC.

  (** Does an object [d] together with the functions [i] and [j]
    fit into a pullback diagram?

    [[
           i
        d ----> a
        |       |
      j |       | f
        ↓       ↓
        b ----> c
           g
    ]]
   *)

  Local Ltac t :=
    intros;
    destruct_head_hnf PullbackThree;
    destruct_head_hnf Empty_set;
    destruct_head_hnf unit;
    autorewrite with morphism;
    trivial.

  Definition IsPullbackGivenMorphisms_Object
             (f : Morphism C a c)
             (g : Morphism C b c)
             PullbackObject
             (i : Morphism C PullbackObject a)
             (j : Morphism C PullbackObject b)
             (PullbackCompatible : Compose f i = Compose g j)
  : CommaCategory_Object (DiagonalFunctor C PullbackIndex)
                         (SliceCategory_Functor
                            (FunctorCategory.FunctorCategory PullbackIndex C)
                            (PullbackDiagram C a b c f g)).
    exists (PullbackObject, tt).
    exists (fun x => match x as x return (Morphism C PullbackObject (PullbackDiagram_ObjectOf a b c x)) with
                       | PullbackA => i
                       | PullbackB => j
                       | PullbackC => Compose f i
                     end);
      simpl;
      abstract t.
  Defined.

  Definition IsPullbackGivenMorphisms
             (f : Morphism C a c)
             (g : Morphism C b c)
             PullbackObject
             (i : Morphism C PullbackObject a)
             (j : Morphism C PullbackObject b)
             (PullbackCompatible : Compose f i = Compose g j)
    := @IsPullback _ _ a b c f g (IsPullbackGivenMorphisms_Object f g PullbackObject i j PullbackCompatible).

  Definition IsPushoutGivenMorphisms_Object
             (f : Morphism C c a)
             (g : Morphism C c b)
             PushoutObject
             (i : Morphism C a PushoutObject)
             (j : Morphism C b PushoutObject)
             (PushoutCompatible : Compose j g = Compose i f)
  : CommaCategory_Object (SliceCategory_Functor
                            (FunctorCategory.FunctorCategory PushoutIndex C)
                            (PushoutDiagram C a b c f g))
                         (DiagonalFunctor C PushoutIndex).
    exists (tt, PushoutObject).
    exists (fun x => match x as x return (Morphism C (PushoutDiagram_ObjectOf a b c x) PushoutObject) with
                       | PullbackA => i
                       | PullbackB => j
                       | PullbackC => Compose i f
                     end);
      simpl;
      abstract t.
  Defined.

  Definition IsPushoutGivenMorphisms
             (f : Morphism C c a)
             (g : Morphism C c b)
             PushoutObject
             (i : Morphism C a PushoutObject)
             (j : Morphism C b PushoutObject)
             (PushoutCompatible : Compose j g = Compose i f)
    := @IsPushout _ _ a b c f g (IsPushoutGivenMorphisms_Object f g PushoutObject i j PushoutCompatible).
End PullbackObjects.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Require Import Nat.

Inductive lst : Type :=
  | Nil : lst
  | Cons : nat -> lst -> lst.

Inductive queue : Type :=
  | Queue : lst -> lst -> queue.

Fixpoint len (l : lst) : nat :=
match l with
  | Nil => 0
  | Cons a l1 => 1 + (len l1)
end.

Lemma len_pos: forall l, (len l) >= 0.
Proof.
  induction l.
  - simpl. apply le_0_n.
  - simpl. apply le_0_n.
Qed.

Definition qlen (q : queue) : nat :=
match q with
  | Queue l1 l2 => (len l1) + (len l2)
end.

Fixpoint app (l : lst) (m: lst): lst :=
match l with
  | Nil => m
  | Cons a l1 => Cons a (app l1 m)
end.

Fixpoint rev (l: lst): lst :=
match l with
  | Nil => Nil
  | Cons a l1 => app (rev l1) (Cons a Nil)
end.

Fixpoint leb (n m : nat) : bool :=
match (n, m) with
  | (0, _) => true
  | (S n', S m') => leb n' m'
  | _ => false
end.

Definition amortizeQueue (l1 l2 : lst) : queue :=
  if leb (len l2)  (len l1) then Queue l1 l2
  else Queue (app l1 (rev l2)) Nil.

Lemma len_app : forall l1 l2, len (app l1 l2) = (len l1) + (len l2).
Proof.
  intros. induction l1.
  - reflexivity.
  - simpl. rewrite IHl1. reflexivity.
Qed.

Lemma plus_comm: forall m n, m + n = n + m.
Proof.
induction m.
- intros. simpl. rewrite <- plus_n_O. reflexivity.
- intros. simpl. rewrite IHm. rewrite plus_n_Sm. reflexivity.
Qed.

Lemma len_rev : forall l, len (rev l) = len l.
Proof.
induction l.
- reflexivity.
- simpl. rewrite len_app. simpl. lfind. Admitted.


Require Import Coq.Logic.FunctionalExtensionality.
From mathcomp Require Import ssreflect ssrfun eqtype bigop choice path seq.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
    From mathcomp Require Import ssrbool.
Set Warnings "parsing".
Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Require Import Path ntPathPairs PathAlgebraMul FormalLC Quiver.
Set Implicit Arguments.
Unset Strict Implicit.

Open Scope ring_scope.
Module PathAlg.

  Section Def.
  Variables (R : comRingType) (Q : finQuiverType).
  Local Notation lmod := (R \LC^(pathType Q)).
  Local Notation Add := (@GRing.add lmod).
  Local Notation Neg := (@GRing.opp lmod).
  Local Notation Zero := (@GRing.zero lmod).
  Local Notation Scale := (@GRing.scale lmod).
  Local Notation Mul := (PAMul.Mul R Q).
  Local Notation One := (PAMul.One R Q).
  Local Notation addXr := (PAMul.addXr).
  Local Notation addrX := (PAMul.addrX).

  Section Ring.
    Lemma left_d : left_distributive Mul Add.
    Proof. move=>x y z.
      rewrite /Mul/Add/Neg/Zero; apply functional_extensionality=>p/=.
      rewrite /formalLC.Add.
      induction p; by rewrite  (eq_bigr _ (fun _ _ => (GRing.mulrDl _ _ _))) big_split=>/=.
    Qed.

    Lemma right_d : right_distributive Mul Add.
    Proof. move=>x y z.
      rewrite /Mul/Add/Neg/Zero; apply functional_extensionality=>p/=.
      rewrite /formalLC.Add.
      induction p; by rewrite  (eq_bigr _ (fun _ _ => (GRing.mulrDr _ _ _))) big_split=>/=.
    Qed.

    Lemma one_neq_zero : One != Zero.
    Proof. rewrite /One/Zero.
      apply (rwP negP).
      rewrite /not -(rwP eqP)=>H.
      assert (A:=equal_f H (\e_(Quiver.getOneVertex Q))); clear H; move:A=>/=A.
      assert(B := GRing.oner_neq0 R); move: B=>/=.
      rewrite /negb A.
      case ((GRing.zero R) == (GRing.zero R)) as []eqn:E.
      rewrite E//; move: E.
      by rewrite eq_refl.
    Qed.
    Definition PathAlg_ringMixin := RingMixin
        (PAMul.MulA R Q) (PAMul.left_id1 R Q) (PAMul.right_id1 R Q)
        left_d right_d one_neq_zero.

    Definition ring
      := RingType lmod PathAlg_ringMixin.
  End Ring.

  Section Lalg.
    Lemma lalgAxiom
     : @GRing.Lalgebra.axiom R lmod Mul.
    Proof. move=> a u1 u2.
      rewrite /(GRing.scale _)=>/=; rewrite /PAMul.Mul/formalLC.Scale.
      apply functional_extensionality=>p.
      rewrite GRing.mulr_sumr.
      refine (eq_bigr _ _)=>[[q1 q2] _]=>/=.
      by rewrite GRing.mulrA.
    Qed.
    Definition lalg := LalgType R ring lalgAxiom.
  End Lalg.

  Section Alg.
    Lemma algAxiom : @GRing.Algebra.axiom R lalg.
    Proof. move=>r x y.
      rewrite lalgAxiom/(GRing.scale _)/(GRing.mul _)=>/=.
      rewrite /formalLC.Scale/Mul.
      apply functional_extensionality=>p.
      refine (eq_bigr _ _); move=> [q1 q2] _=>/=.
      by rewrite !GRing.mulrA (@GRing.mulrC R r (x _)).
    Qed.

    Definition alg := AlgType R lalg algAxiom.
  End Alg.
  End Def.

  Close Scope ring_scope.

  Module Exports.
    Canonical lalg.
    Canonical alg.

    Notation pathAlgType := alg.
  End Exports.

End PathAlg.
Export PathAlg.Exports.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                                                                      *)
(* Micromega: A reflexive tactic using the Positivstellensatz           *)
(*                                                                      *)
(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
(*                                                                      *)
(************************************************************************)

Require Import OrderedRing.
Require Import RingMicromega.
Require Import ZCoeff.
Require Import Refl.
Require Import ZArith.
Require Import List.
Require Import Bool.
(*Declare ML Module "micromega_plugin".*)

Ltac flatten_bool :=
  repeat match goal with
           [ id : (_ && _)%bool = true |- _ ] =>  destruct (andb_prop _ _ id); clear id
           |  [ id : (_ || _)%bool = true |- _ ] =>  destruct (orb_prop _ _ id); clear id
         end.

Ltac inv H := inversion H ; try subst ; clear H.

Require Import EnvRing.

Open Scope Z_scope.

Lemma Zsor : SOR 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt.
Proof.
  constructor ; intros ; subst ; try (intuition (auto  with zarith)).
  apply Zsth.
  apply Zth.
  destruct (Ztrichotomy n m) ; intuition (auto with zarith).
  apply Zmult_lt_0_compat ; auto.
Qed.

Lemma ZSORaddon :
  SORaddon 0 1 Zplus Zmult Zminus Zopp  (@eq Z) Zle (* ring elements *)
  0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *)
  Zeq_bool Zle_bool
  (fun x => x) (fun x => x) (pow_N 1 Zmult).
Proof.
  constructor.
  constructor ; intros ; try reflexivity.
  apply Zeq_bool_eq ; auto.
  constructor.
  reflexivity.
  intros x y.
  apply Zeq_bool_neq ; auto.
  apply Zle_bool_imp_le.
Qed.

Fixpoint Zeval_expr (env : PolEnv Z) (e: PExpr Z) : Z :=
  match e with
    | PEc c => c
    | PEX x => env x
    | PEadd e1 e2 => Zeval_expr env e1 + Zeval_expr env e2
    | PEmul e1 e2 => Zeval_expr env e1 * Zeval_expr env e2
    | PEpow e1 n  => Zpower (Zeval_expr env e1) (Z_of_N n)
    | PEsub e1 e2 => (Zeval_expr env e1) - (Zeval_expr env e2)
    | PEopp e   => Zopp (Zeval_expr env e)
  end.

Definition eval_expr := eval_pexpr  Zplus Zmult Zminus Zopp (fun x => x) (fun x => x) (pow_N 1 Zmult).

Lemma ZNpower : forall r n, r ^ Z_of_N n = pow_N 1 Zmult r n.
Proof.
  destruct n.
  reflexivity.
  simpl.
  unfold Zpower_pos.
  replace (pow_pos Zmult r p) with (1 * (pow_pos Zmult r p)) by ring.
  generalize 1.
  induction p; simpl ; intros ; repeat rewrite IHp ; ring.
Qed.

Lemma Zeval_expr_compat : forall env e, Zeval_expr env e = eval_expr env e.
Proof.
  induction e ; simpl ; try congruence.
  reflexivity.
  rewrite ZNpower. congruence.
Qed.

Definition Zeval_op2 (o : Op2) : Z -> Z -> Prop :=
match o with
| OpEq =>  @eq Z
| OpNEq => fun x y  => ~ x = y
| OpLe => Zle
| OpGe => Zge
| OpLt => Zlt
| OpGt => Zgt
end.

Definition Zeval_formula (env : PolEnv Z) (f : Formula Z):=
  let (lhs, op, rhs) := f in
    (Zeval_op2 op) (Zeval_expr env lhs) (Zeval_expr env rhs).

Definition Zeval_formula' :=
  eval_formula  Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt (fun x => x) (fun x => x) (pow_N 1 Zmult).

Lemma Zeval_formula_compat : forall env f, Zeval_formula env f <-> Zeval_formula' env f.
Proof.
  destruct f ; simpl.
  rewrite Zeval_expr_compat. rewrite Zeval_expr_compat.
  unfold eval_expr.
  generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
        (fun x : N => x) (pow_N 1 Zmult) env Flhs).
  generalize ((eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
        (fun x : N => x) (pow_N 1 Zmult) env Frhs)).
  destruct Fop ; simpl; intros ; intuition (auto with zarith).
Qed.

Definition eval_nformula :=
  eval_nformula 0 Zplus Zmult  (@eq Z) Zle Zlt (fun x => x) .

Definition Zeval_op1 (o : Op1) : Z -> Prop :=
match o with
| Equal => fun x : Z => x = 0
| NonEqual => fun x : Z => x <> 0
| Strict => fun x : Z => 0 < x
| NonStrict => fun x : Z => 0 <= x
end.

Lemma Zeval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d).
Proof.
  intros.
  apply (eval_nformula_dec Zsor).
Qed.

Definition ZWitness := Psatz Z.

Definition ZWeakChecker := check_normalised_formulas 0 1 Zplus Zmult Zeq_bool Zle_bool.

Lemma ZWeakChecker_sound :   forall (l : list (NFormula Z)) (cm : ZWitness),
  ZWeakChecker l cm = true ->
  forall env, make_impl (eval_nformula env) l False.
Proof.
  intros l cm H.
  intro.
  unfold eval_nformula.
  apply (checker_nf_sound Zsor ZSORaddon l cm).
  unfold ZWeakChecker in H.
  exact H.
Qed.

Definition psub  := psub Z0  Zplus Zminus Zopp Zeq_bool.

Definition padd  := padd Z0  Zplus Zeq_bool.

Definition norm  := norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool.

Definition eval_pol := eval_pol 0  Zplus Zmult (fun x => x).

Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub  lhs rhs) = eval_pol env lhs - eval_pol env rhs.
Proof.
  intros.
  apply (eval_pol_sub Zsor ZSORaddon).
Qed.

Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd  lhs rhs) = eval_pol env lhs + eval_pol env rhs.
Proof.
  intros.
  apply (eval_pol_add Zsor ZSORaddon).
Qed.

Lemma eval_pol_norm : forall env e, eval_expr env e = eval_pol env (norm e) .
Proof.
  intros.
  apply (eval_pol_norm Zsor ZSORaddon).
Qed.

Definition xnormalise (t:Formula Z) : list (NFormula Z)  :=
  let (lhs,o,rhs) := t in
    let lhs := norm lhs in
      let rhs := norm rhs in
    match o with
      | OpEq =>
        ((psub lhs (padd  rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil
      | OpNEq => (psub lhs rhs,Equal) :: nil
      | OpGt   => (psub rhs lhs,NonStrict) :: nil
      | OpLt => (psub lhs rhs,NonStrict) :: nil
      | OpGe => (psub rhs (padd lhs (Pc 1)),NonStrict) :: nil
      | OpLe => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil
    end.

Require Import Tauto.

Definition normalise (t:Formula Z) : cnf (NFormula Z) :=
  List.map  (fun x => x::nil) (xnormalise t).

Lemma normalise_correct : forall env t, eval_cnf (eval_nformula env) (normalise t) <-> Zeval_formula env t.
Proof.
  Opaque padd.
  unfold normalise, xnormalise  ; simpl; intros env t.
  rewrite Zeval_formula_compat.
  unfold eval_cnf.
  destruct t as [lhs o rhs]; case_eq o; simpl;
    repeat rewrite eval_pol_sub;
      repeat rewrite eval_pol_add;
      repeat rewrite <- eval_pol_norm ; simpl in *;
  unfold eval_expr;
  generalize (   eval_pexpr  Zplus Zmult Zminus Zopp (fun x : Z => x)
    (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs);
  generalize (eval_pexpr  Zplus Zmult Zminus Zopp (fun x : Z => x)
    (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; subst;
    intuition (auto with zarith).
  Transparent padd.
Qed.

Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z)  :=
  let (lhs,o,rhs) := t in
    let lhs := norm lhs in
      let rhs := norm rhs in
    match o with
      | OpEq  => (psub lhs rhs,Equal) :: nil
      | OpNEq => ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil
      | OpGt  => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil
      | OpLt  => (psub rhs (padd lhs (Pc 1)),NonStrict) :: nil
      | OpGe  => (psub lhs rhs,NonStrict) :: nil
      | OpLe  => (psub rhs lhs,NonStrict) :: nil
    end.

Definition negate (t:RingMicromega.Formula Z) : cnf (NFormula Z) :=
  List.map  (fun x => x::nil) (xnegate t).

Lemma negate_correct : forall env t, eval_cnf (eval_nformula env) (negate t) <-> ~ Zeval_formula env t.
Proof.
Proof.
  Opaque padd.
  intros env t.
  rewrite Zeval_formula_compat.
  unfold negate, xnegate  ; simpl.
  unfold eval_cnf.
  destruct t as [lhs o rhs]; case_eq o; simpl;
    repeat rewrite eval_pol_sub;
      repeat rewrite eval_pol_add;
      repeat rewrite <- eval_pol_norm ; simpl in *;
  unfold eval_expr;
  generalize (   eval_pexpr  Zplus Zmult Zminus Zopp (fun x : Z => x)
    (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs);
  generalize (eval_pexpr  Zplus Zmult Zminus Zopp (fun x : Z => x)
    (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; subst;
    intuition (auto with zarith).
  Transparent padd.
Qed.

Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool :=
  @tauto_checker (Formula Z) (NFormula Z) normalise negate  ZWitness ZWeakChecker f w.

(* To get a complete checker, the proof format has to be enriched *)

Require Import Zdiv.
Open Scope Z_scope.

Definition ceiling (a b:Z) : Z :=
  let (q,r) := Zdiv_eucl a b in
    match r with
      | Z0 => q
      | _  => q + 1
    end.

Lemma narrow_interval_lower_bound : forall a b x, a > 0 -> a * x  >= b -> x >= ceiling b a.
Proof.
  unfold ceiling.
  intros.
  generalize (Z_div_mod b a H).
  destruct (Zdiv_eucl b a).
  intros.
  destruct H1.
  destruct H2.
  subst.
  destruct (Ztrichotomy z0 0) as [ HH1 | [HH2 | HH3]]; destruct z0 ; try auto with zarith ; try discriminate.
  assert (HH :x >= z \/ x < z) by (destruct (Ztrichotomy x z) ; auto with zarith).
  destruct HH ;auto.
  generalize (Zmult_lt_compat_l _ _ _ H3 H1).
  auto with zarith.
  clear H2.
  assert (HH :x >= z +1 \/ x <= z) by (destruct (Ztrichotomy x z) ; intuition (auto with zarith)).
  destruct HH ;auto.
  assert (0 < a) by auto with zarith.
  generalize (Zmult_lt_0_le_compat_r _ _ _ H2 H1).
  intros.
  rewrite Zmult_comm  in H4.
  rewrite (Zmult_comm z)  in H4.
  auto with zarith.
Qed.

(** NB: narrow_interval_upper_bound is Zdiv.Zdiv_le_lower_bound *)

Require Import QArith.

Inductive ZArithProof : Type :=
| DoneProof
| RatProof : ZWitness -> ZArithProof -> ZArithProof
| CutProof : ZWitness -> ZArithProof -> ZArithProof
| EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof.

(* n/d <= x  -> d*x - n >= 0 *)
(*
Definition makeLb (v:PExpr Z) (q:Q) : NFormula Z :=
  let (n,d) := q in (PEsub (PEmul (PEc (Zpos d)) v) (PEc  n),NonStrict).

(* x <= n/d  -> d * x <= d  *)
Definition makeUb (v:PExpr Z) (q:Q) : NFormula Z :=
  let (n,d) := q in
    (PEsub (PEc n) (PEmul (PEc (Zpos d)) v), NonStrict).

Definition qceiling (q:Q) : Z :=
  let (n,d) := q in ceiling n (Zpos d).

Definition qfloor (q:Q) : Z :=
  let (n,d) := q in Zdiv n (Zpos d).

Definition makeLbCut (v:PExprC Z) (q:Q) : NFormula Z :=
  (PEsub v  (PEc (qceiling  q)), NonStrict).

Definition neg_nformula (f : NFormula Z) :=
  let (e,o) := f in
    (PEopp (PEadd e (PEc 1%Z)), o).

Lemma neg_nformula_sound : forall env f, snd f = NonStrict ->( ~ (Zeval_nformula env (neg_nformula f)) <-> Zeval_nformula env f).
Proof.
  unfold neg_nformula.
  destruct f.
  simpl.
  intros ; subst ; simpl in *.
  split;  auto with zarith.
Qed.
*)

(* In order to compute the 'cut', we need to express a polynomial P as a * Q + b.
   - b is the constant
   - a is the gcd of the other coefficient.
*)
Require Import Znumtheory.

Definition isZ0 (x:Z) :=
  match x with
    | Z0 => true
    | _  => false
  end.

Lemma isZ0_0 : forall x, isZ0 x = true <-> x = 0.
Proof.
  destruct x ; simpl ; intuition congruence.
Qed.

Lemma isZ0_n0 : forall x, isZ0 x = false <-> x <> 0.
Proof.
  destruct x ; simpl ; intuition congruence.
Qed.

Definition ZgcdM (x y : Z) := Zmax (Zgcd x y) 1.

Fixpoint Zgcd_pol (p : PolC Z) : (Z * Z) :=
  match p with
    | Pc c => (0,c)
    | Pinj _ p => Zgcd_pol p
    | PX p _ q =>
      let (g1,c1) := Zgcd_pol p in
        let (g2,c2) := Zgcd_pol q in
          (ZgcdM (ZgcdM g1 c1) g2 , c2)
  end.

(*Eval compute in (Zgcd_pol ((PX (Pc (-2)) 1 (Pc 4)))).*)

Fixpoint Zdiv_pol (p:PolC Z) (x:Z) : PolC Z :=
  match p with
    | Pc c => Pc (Zdiv c x)
    | Pinj j p => Pinj j (Zdiv_pol p x)
    | PX p j q => PX (Zdiv_pol p x) j (Zdiv_pol q x)
  end.

Inductive Zdivide_pol (x:Z): PolC Z -> Prop :=
| Zdiv_Pc : forall c, (x | c) -> Zdivide_pol x (Pc c)
| Zdiv_Pinj : forall p, Zdivide_pol x p ->  forall j, Zdivide_pol x (Pinj j p)
| Zdiv_PX   : forall p q, Zdivide_pol x p -> Zdivide_pol x q -> forall j, Zdivide_pol x (PX p j q).

Lemma Zdiv_pol_correct : forall a p, 0 < a -> Zdivide_pol a p  ->
  forall env, eval_pol env p =  a * eval_pol env (Zdiv_pol p a).
Proof.
  intros until 2.
  induction H0.
  (* Pc *)
  simpl.
  intros.
  apply Zdivide_Zdiv_eq ; auto.
  (* Pinj *)
  simpl.
  intros.
  apply IHZdivide_pol.
  (* PX *)
  simpl.
  intros.
  rewrite IHZdivide_pol1.
  rewrite IHZdivide_pol2.
  ring.
Qed.

Lemma Zgcd_pol_ge : forall p, fst (Zgcd_pol p) >= 0.
Proof.
  induction p.
  simpl. auto with zarith.
  simpl. auto.
  simpl.
  case_eq (Zgcd_pol p1).
  case_eq (Zgcd_pol p3).
  intros.
  simpl.
  unfold ZgcdM.
  generalize (Zgcd_is_pos z1 z2).
  generalize (Zmax_spec (Zgcd z1 z2) 1).
  generalize (Zgcd_is_pos (Zmax (Zgcd z1 z2) 1) z).
  generalize (Zmax_spec (Zgcd (Zmax (Zgcd z1 z2) 1) z) 1).
  auto with zarith.
Qed.

Lemma Zdivide_pol_Zdivide : forall p x y, Zdivide_pol x p -> (y | x) ->  Zdivide_pol y p.
Proof.
  intros.
  induction H.
  constructor.
  apply Zdivide_trans with (1:= H0) ; assumption.
  constructor. auto.
  constructor ; auto.
Qed.

Lemma Zdivide_pol_one : forall p, Zdivide_pol 1 p.
Proof.
  induction p ; constructor ; auto.
  exists c. ring.
Qed.

Lemma Zgcd_minus : forall a b c, (a | c - b ) -> (Zgcd a b | c).
Proof.
  intros a b c (q,Hq).
  destruct (Zgcd_is_gcd a b) as [(a',Ha) (b',Hb) _].
  set (g:=Zgcd a b) in *; clearbody g.
  exists (q * a' + b').
  symmetry in Hq. rewrite <- Zeq_plus_swap in Hq.
  rewrite <- Hq, Hb, Ha. ring.
Qed.

Lemma Zdivide_pol_sub : forall p a b,
  0 < Zgcd a b ->
  Zdivide_pol a (PsubC Zminus p b) ->
   Zdivide_pol (Zgcd a b) p.
Proof.
  induction p.
  simpl.
  intros. inversion H0.
  constructor.
  apply Zgcd_minus ; auto.
  intros.
  constructor.
  simpl in H0. inversion H0 ; subst; clear H0.
  apply IHp ; auto.
  simpl. intros.
  inv H0.
  constructor.
  apply Zdivide_pol_Zdivide with (1:= H3).
  destruct (Zgcd_is_gcd a b) ; assumption.
  apply IHp2 ; assumption.
Qed.

Lemma Zdivide_pol_sub_0 : forall p a,
  Zdivide_pol a (PsubC Zminus p 0) ->
   Zdivide_pol a p.
Proof.
  induction p.
  simpl.
  intros. inversion H.
  constructor.  replace (c - 0) with c in H1 ; auto with zarith.
  intros.
  constructor.
  simpl in H. inversion H ; subst; clear H.
  apply IHp ; auto.
  simpl. intros.
  inv H.
  constructor. auto.
  apply IHp2 ; assumption.
Qed.

Lemma Zgcd_pol_div : forall p g c,
  Zgcd_pol p = (g, c) -> Zdivide_pol g (PsubC Zminus p c).
Proof.
  induction p ; simpl.
  (* Pc *)
  intros. inv H.
  constructor.
  exists 0. now ring.
  (* Pinj *)
  intros.
  constructor.  apply IHp ; auto.
  (* PX *)
  intros g c.
  case_eq (Zgcd_pol p1) ; case_eq (Zgcd_pol p3) ; intros.
  inv H1.
  unfold ZgcdM at 1.
  destruct (Zmax_spec (Zgcd (ZgcdM z1 z2) z) 1) as [HH1 | HH1];
  destruct HH1 as [HH1 HH1'] ; rewrite HH1'.
  constructor.
  apply Zdivide_pol_Zdivide with (x:= ZgcdM z1 z2).
  unfold ZgcdM.
  destruct (Zmax_spec  (Zgcd z1 z2)  1) as [HH2 | HH2].
  destruct HH2.
  rewrite H2.
  apply Zdivide_pol_sub ; auto.
  auto with zarith.
  destruct HH2. rewrite H2.
  apply Zdivide_pol_one.
  unfold ZgcdM in HH1. unfold ZgcdM.
  destruct (Zmax_spec  (Zgcd z1 z2)  1) as [HH2 | HH2].
  destruct HH2. rewrite H2 in *.
  destruct (Zgcd_is_gcd (Zgcd z1 z2) z); auto.
  destruct HH2. rewrite H2.
  destruct (Zgcd_is_gcd 1  z); auto.
  apply Zdivide_pol_Zdivide with (x:= z).
  apply (IHp2 _ _ H); auto.
  destruct (Zgcd_is_gcd (ZgcdM z1 z2) z); auto.
  constructor. apply Zdivide_pol_one.
  apply Zdivide_pol_one.
Qed.

Lemma Zgcd_pol_correct_lt : forall p env g c, Zgcd_pol p = (g,c) -> 0 < g -> eval_pol env p = g * (eval_pol env (Zdiv_pol (PsubC Zminus p c) g))  + c.
Proof.
  intros.
  rewrite <- Zdiv_pol_correct ; auto.
  rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon).
  unfold eval_pol. ring.
  (**)
  apply Zgcd_pol_div ; auto.
Qed.

Definition makeCuttingPlane (p : PolC Z) : PolC  Z * Z :=
  let (g,c) := Zgcd_pol p in
    if Zgt_bool g Z0
      then (Zdiv_pol (PsubC Zminus p c) g , Zopp (ceiling (Zopp c) g))
      else (p,Z0).

Definition genCuttingPlane (f : NFormula Z) : option (PolC Z * Z * Op1) :=
  let (e,op) := f in
    match op with
      | Equal => let (g,c) := Zgcd_pol e in
        if andb (Zgt_bool g Z0) (andb (Zgt_bool c Z0) (negb (Zeq_bool (Zgcd g c) g)))
          then None (* inconsistent *)
          else Some (e, Z0,op) (* It could still be inconsistent -- but not a cut *)
      | NonEqual => Some (e,Z0,op)
      | Strict   =>  let (p,c) := makeCuttingPlane (PsubC Zminus e 1) in
        Some (p,c,NonStrict)
      | NonStrict => let (p,c) := makeCuttingPlane e  in
        Some (p,c,NonStrict)
    end.

Definition nformula_of_cutting_plane (t : PolC Z * Z * Op1) : NFormula Z :=
  let (e_z, o) := t in
    let (e,z) := e_z in
      (padd e (Pc z) , o).

Definition is_pol_Z0 (p : PolC Z) : bool :=
  match p with
    | Pc Z0 => true
    |   _   => false
  end.

Lemma is_pol_Z0_eval_pol : forall p, is_pol_Z0 p = true -> forall env, eval_pol env p = 0.
Proof.
  unfold is_pol_Z0.
  destruct p ; try discriminate.
  destruct z ; try discriminate.
  reflexivity.
Qed.

Definition eval_Psatz  : list (NFormula Z) -> ZWitness ->  option (NFormula Z) :=
  eval_Psatz 0 1 Zplus Zmult Zeq_bool Zle_bool.

Definition check_inconsistent := check_inconsistent 0 Zeq_bool Zle_bool.

Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof)  {struct pf} : bool :=
  match pf with
    | DoneProof => false
    | RatProof w pf =>
      match eval_Psatz l w  with
        | None => false
        | Some f =>
          if check_inconsistent f then true
            else ZChecker (f::l) pf
      end
    | CutProof w pf =>
      match eval_Psatz l w with
        | None => false
        | Some f =>
          match genCuttingPlane f with
            | None => true
            | Some cp => ZChecker (nformula_of_cutting_plane cp::l) pf
          end
      end
    | EnumProof w1 w2 pf =>
      match eval_Psatz l w1 , eval_Psatz l w2 with
        |  Some f1 , Some f2 =>
          match genCuttingPlane f1 , genCuttingPlane f2 with
            |Some (e1,z1,op1) , Some (e2,z2,op2) =>
              match op1 , op2 with
                | NonStrict , NonStrict =>
                  if is_pol_Z0 (padd e1 e2)
                    then
                      (fix label (pfs:list ZArithProof) :=
                        fun lb ub =>
                          match pfs with
                            | nil => if Zgt_bool lb ub then true else false
                            | pf::rsr => andb (ZChecker  ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub)
                          end)
                      pf (Zopp z1)  z2
                    else false
                |   _    ,   _   => false
              end
            |   _   ,  _ => false
          end
        |   _   , _  => false
      end
      end.

Fixpoint bdepth (pf : ZArithProof) : nat :=
  match pf with
    | DoneProof  => O
    | RatProof _ p =>  S (bdepth p)
    | CutProof _  p =>   S  (bdepth p)
    | EnumProof _ _ l => S (List.fold_right (fun pf x => Max.max (bdepth pf) x)   O l)
  end.

Require Import Wf_nat.

Lemma in_bdepth : forall l a b  y, In y l ->  ltof ZArithProof bdepth y (EnumProof a b  l).
Proof.
  induction l.
  (* nil *)
  simpl.
  tauto.
  (* cons *)
  simpl.
  intros.
  destruct H.
  subst.
  unfold ltof.
  simpl.
  generalize (         (fold_right
            (fun (pf : ZArithProof) (x : nat) => Max.max (bdepth pf) x) 0%nat l)).
  intros.
  generalize (bdepth y) ; intros.
  generalize (Max.max_l n0 n) (Max.max_r n0 n).
  auto with zarith.
  generalize (IHl a0 b  y  H).
  unfold ltof.
  simpl.
  generalize (      (fold_right (fun (pf : ZArithProof) (x : nat) => Max.max (bdepth pf) x) 0%nat
         l)).
  intros.
  generalize (Max.max_l (bdepth a) n) (Max.max_r (bdepth a) n).
  auto with zarith.
Qed.

Lemma eval_Psatz_sound : forall env w l f',
  make_conj (eval_nformula env) l ->
  eval_Psatz l w  = Some f' ->  eval_nformula env f'.
Proof.
  intros.
  apply (eval_Psatz_Sound Zsor ZSORaddon) with (l:=l) (e:= w) ; auto.
  apply make_conj_in ; auto.
Qed.

Lemma makeCuttingPlane_sound : forall env e e' c,
  eval_nformula env (e, NonStrict) ->
  makeCuttingPlane e = (e',c) ->
  eval_nformula env (nformula_of_cutting_plane (e', c, NonStrict)).
Proof.
  unfold nformula_of_cutting_plane.
  unfold eval_nformula. unfold RingMicromega.eval_nformula.
  unfold eval_op1.
  intros.
  rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon).
  simpl.
  (**)
  unfold makeCuttingPlane in H0.
  revert H0.
  case_eq (Zgcd_pol e) ; intros g c0.
  generalize (Zgt_cases g 0) ; destruct (Zgt_bool g 0).
  intros.
  inv H2.
  change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in *.
  apply Zgcd_pol_correct_lt with (env:=env) in H1.
  generalize (narrow_interval_lower_bound g (- c0) (eval_pol env (Zdiv_pol (PsubC Zminus e c0) g)) H0).
  auto with zarith.
  auto with zarith.
  (* g <= 0 *)
  intros. inv H2. auto with zarith.
Qed.

Lemma cutting_plane_sound : forall env f p,
  eval_nformula env f ->
  genCuttingPlane f = Some p ->
   eval_nformula env (nformula_of_cutting_plane p).
Proof.
  unfold genCuttingPlane.
  destruct f as [e op].
  destruct op.
  (* Equal *)
  destruct p as [[e' z] op].
  case_eq (Zgcd_pol e) ; intros g c.
  destruct (Zgt_bool g 0 && (Zgt_bool c 0 && negb (Zeq_bool (Zgcd g c) g))) ; [discriminate|].
  intros. inv H1. unfold nformula_of_cutting_plane.
  unfold eval_nformula in *.
  unfold RingMicromega.eval_nformula in *.
  unfold eval_op1 in *.
  rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon).
  simpl. rewrite H0. reflexivity.
  (* NonEqual *)
  intros.
  inv H0.
  unfold eval_nformula in *.
  unfold RingMicromega.eval_nformula in *.
  unfold nformula_of_cutting_plane.
  unfold eval_op1 in *.
  rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon).
  simpl. auto with zarith.
  (* Strict *)
  destruct p as [[e' z] op].
  case_eq (makeCuttingPlane (PsubC Zminus e 1)).
  intros.
  inv H1.
  apply makeCuttingPlane_sound with (env:=env) (2:= H).
  simpl in *.
  rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon).
  auto with zarith.
  (* NonStrict *)
  destruct p as [[e' z] op].
  case_eq (makeCuttingPlane e).
  intros.
  inv H1.
  apply makeCuttingPlane_sound with (env:=env) (2:= H).
  assumption.
Qed.

Lemma  genCuttingPlaneNone : forall env f,
  genCuttingPlane f = None ->
  eval_nformula env f -> False.
Proof.
  unfold genCuttingPlane.
  destruct f.
  destruct o.
  case_eq (Zgcd_pol p) ; intros g c.
  case_eq (Zgt_bool g 0 && (Zgt_bool c 0 && negb (Zeq_bool (Zgcd g c) g))).
  intros.
  flatten_bool.
  rewrite negb_true_iff in H5.
  apply Zeq_bool_neq in H5.
  contradict H5.
  rewrite <- Zgt_is_gt_bool in H3.
  rewrite <- Zgt_is_gt_bool in H.
  apply Zis_gcd_gcd; auto with zarith.
  constructor; auto with zarith.
  change (eval_pol env p = 0) in H2.
  rewrite Zgcd_pol_correct_lt with (1:= H0) in H2; auto with zarith.
  set (x:=eval_pol env (Zdiv_pol (PsubC Zminus p c) g)) in *; clearbody x.
  exists (-x).
  rewrite <- Zopp_mult_distr_l, Zmult_comm; auto with zarith.
  (**)
  discriminate.
  discriminate.
  destruct (makeCuttingPlane (PsubC Zminus p 1)) ; discriminate.
  destruct (makeCuttingPlane p) ; discriminate.
Qed.

Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl  (eval_nformula env)  l False.
Proof.
  induction w    using (well_founded_ind (well_founded_ltof _ bdepth)).
  destruct w as [ | w pf | w pf | w1 w2 pf].
  (* DoneProof *)
  simpl. discriminate.
  (* RatProof *)
  simpl.
  intro l. case_eq (eval_Psatz l w) ; [| discriminate].
  intros f Hf.
  case_eq (check_inconsistent f).
  intros.
  apply (checker_nf_sound Zsor ZSORaddon l w).
  unfold check_normalised_formulas.  unfold eval_Psatz in Hf. rewrite Hf.
  unfold check_inconsistent in H0. assumption.
  intros.
  assert (make_impl  (eval_nformula env) (f::l) False).
   apply H with (2:= H1).
   unfold ltof.
   simpl.
   auto with arith.
  destruct f.
  rewrite <- make_conj_impl in H2.
  rewrite make_conj_cons in H2.
  rewrite <- make_conj_impl.
  intro.
  apply H2.
  split ; auto.
  apply eval_Psatz_sound with (2:= Hf) ; assumption.
  (* CutProof *)
  simpl.
  intro l.
  case_eq (eval_Psatz l w) ; [ | discriminate].
  intros f' Hlc.
  case_eq (genCuttingPlane f').
  intros.
  assert (make_impl (eval_nformula env) (nformula_of_cutting_plane p::l) False).
   eapply (H pf) ; auto.
   unfold ltof.
   simpl.
   auto with arith.
  rewrite <- make_conj_impl in H2.
  rewrite make_conj_cons in H2.
  rewrite <- make_conj_impl.
  intro.
  apply H2.
  split ; auto.
  apply eval_Psatz_sound with (env:=env) in Hlc.
  apply cutting_plane_sound with (1:= Hlc) (2:= H0).
  auto.
  (* genCuttingPlane = None *)
  intros.
  rewrite <- make_conj_impl.
  intros.
  apply eval_Psatz_sound with (2:= Hlc) in H2.
  apply genCuttingPlaneNone with (2:= H2) ; auto.
  (* EnumProof *)
  intro.
  simpl.
  case_eq (eval_Psatz l w1) ; [  | discriminate].
  case_eq (eval_Psatz l w2) ; [  | discriminate].
  intros f1 Hf1 f2 Hf2.
  case_eq (genCuttingPlane f2) ;  [  | discriminate].
  destruct p as [ [p1 z1] op1].
  case_eq (genCuttingPlane f1) ;  [  | discriminate].
  destruct p as [ [p2 z2] op2].
  case_eq op1 ; case_eq op2 ; try discriminate.
  case_eq (is_pol_Z0 (padd p1 p2)) ; try discriminate.
  intros.
  (* get the bounds of the enum *)
  rewrite <- make_conj_impl.
  intro.
  assert (-z1 <= eval_pol env p1 <= z2).
   split.
   apply  eval_Psatz_sound with (env:=env) in Hf2 ; auto.
   apply cutting_plane_sound with (1:= Hf2) in H4.
   unfold nformula_of_cutting_plane in H4.
   unfold eval_nformula in H4.
   unfold RingMicromega.eval_nformula in H4.
   change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in H4.
   unfold eval_op1 in H4.
   rewrite eval_pol_add in H4. simpl in H4.
   auto with zarith.
   (**)
   apply is_pol_Z0_eval_pol with (env := env) in H0.
   rewrite eval_pol_add in H0.
   replace (eval_pol env p1) with (- eval_pol env p2) by omega.
   apply  eval_Psatz_sound with (env:=env) in Hf1 ; auto.
   apply cutting_plane_sound with (1:= Hf1) in H3.
   unfold nformula_of_cutting_plane in H3.
   unfold eval_nformula in H3.
   unfold RingMicromega.eval_nformula in H3.
   change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in H3.
   unfold eval_op1 in H3.
   rewrite eval_pol_add in H3. simpl in H3.
   omega.
  revert H5.
  set (FF := (fix label (pfs : list ZArithProof) (lb ub : Z) {struct pfs} : bool :=
    match pfs with
      | nil => if Z_gt_dec lb ub then true else false
      | pf :: rsr =>
        (ZChecker ((PsubC Zminus p1  lb, Equal) :: l) pf &&
          label rsr (lb + 1)%Z ub)%bool
    end)).
  intros.
  assert (HH :forall x, -z1 <= x <= z2 -> exists pr,
    (In pr pf /\
      ZChecker  ((PsubC Zminus p1 x,Equal) :: l) pr = true)%Z).
  clear H.
  clear H0 H1 H2 H3 H4 H7.
  revert H5.
  generalize (-z1). clear z1. intro z1.
  revert z1 z2.
  induction pf;simpl ;intros.
  generalize (Zgt_cases z1 z2).
  destruct (Zgt_bool z1 z2).
  intros.
  apply False_ind ; omega.
  discriminate.
  flatten_bool.
  assert (HH:(x = z1 \/ z1 +1 <=x)%Z) by omega.
  destruct HH.
  subst.
  exists a ; auto.
  assert (z1 + 1 <= x <= z2)%Z by omega.
  destruct (IHpf _ _ H1 _ H3).
  destruct H4.
  exists x0 ; split;auto.
  (*/asser *)
  destruct (HH _ H7) as [pr [Hin Hcheker]].
  assert (make_impl (eval_nformula env) ((PsubC Zminus p1 (eval_pol env p1),Equal) :: l) False).
   apply (H pr);auto.
   apply in_bdepth ; auto.
  rewrite <- make_conj_impl in H8.
  apply H8.
  rewrite  make_conj_cons.
  split ;auto.
  unfold  eval_nformula.
  unfold RingMicromega.eval_nformula.
  simpl.
  rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon).
  unfold eval_pol. ring.
Qed.

Definition ZTautoChecker  (f : BFormula (Formula Z)) (w: list ZArithProof): bool :=
  @tauto_checker (Formula Z) (NFormula Z) normalise negate  ZArithProof ZChecker f w.

Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f  (Zeval_formula env)  f.
Proof.
  intros f w.
  unfold ZTautoChecker.
  apply (tauto_checker_sound  Zeval_formula eval_nformula).
  apply Zeval_nformula_dec.
  intros env t.
  rewrite normalise_correct ; auto.
  intros env t.
  rewrite negate_correct ; auto.
  intros t w0.
  apply ZChecker_sound.
Qed.

Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof)  : list nat :=
  match pt with
    | DoneProof => acc
    | RatProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt
    | CutProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt
    | EnumProof c1 c2 l =>
      let acc := xhyps_of_psatz base (xhyps_of_psatz base acc c2) c1 in
        List.fold_left (xhyps_of_pt (S base)) l acc
  end.

Definition hyps_of_pt (pt : ZArithProof) : list nat := xhyps_of_pt 0 nil pt.

(*Lemma hyps_of_pt_correct : forall pt l, *)

Open Scope Z_scope.

(** To ease bindings from ml code **)
(*Definition varmap := Quote.varmap.*)
Definition make_impl := Refl.make_impl.
Definition make_conj := Refl.make_conj.

Require VarMap.

(*Definition varmap_type := VarMap.t Z. *)
Definition env := PolEnv Z.
Definition node := @VarMap.Node Z.
Definition empty := @VarMap.Empty Z.
Definition leaf := @VarMap.Leaf Z.

Definition coneMember := ZWitness.

Definition eval := eval_formula.

Definition prod_pos_nat := prod positive nat.

Definition n_of_Z (z:Z) : BinNat.N :=
  match z with
    | Z0 => N0
    | Zpos p => Npos p
    | Zneg p => N0
  end.

(* Local Variables: *)
(* coding: utf-8 *)
(* End: *)


(* The order of a permutation group given a generating set. *)

From stdpp Require Import finite.
From permlib Require Import util perm.

Notation comp := (foldr (⋅) ∅).

Lemma comp_app w1 w2 :
  comp (w2 ++ w1) ≡ comp w2 ⋅ comp w1.
Proof.
induction w2; cbn; intros; symmetry.
apply (left_id ∅ (⋅)). rewrite <-(assoc (⋅)), IHw2; done.
Qed.

Theorem perm_order (π : perm) :
  ∃ k, comp (repeat π (S k)) ≡ ∅.
Proof.
pose (r := permutations (values π));
pose (n := S (length r));
pose (s := values ∘ comp ∘ repeat π <$> seq 1 n);
destruct (list_pigeonhole s r) as (i & j & ps & H1 & H2 & H3).
- unfold s, r; intros xs H; apply elem_of_list_fmap in H as (k & -> & H).
  apply elem_of_seq in H; destruct k; [lia|clear].
  unfold compose; apply permutations_Permutation.
  induction k; cbn in *.
  + rewrite <-?perm_Permutation, keys_perm_compose; done.
  + rewrite IHk, <-?perm_Permutation, keys_perm_compose with (τ:=_⋅_).
    rewrite list_union_sym, list_union_cancel. done.
    rewrite keys_perm_compose; set_solver. all: apply NoDup_keys.
- unfold s, n, r; rewrite fmap_length, seq_length; auto.
- unfold s, compose in H2, H3.
  exists (j - 1 - i)%nat; replace (S (j - 1 - i)) with (j - i)%nat by lia.
  apply list_lookup_fmap_inv in H2 as (i' & -> & Hi'), H3 as (j' & H2 & Hj');
  apply lookup_seq in Hi' as [-> _], Hj' as [-> _]; apply perm_eq_values in H2.
  apply group_compose_cancel with (z:=comp (repeat π (1 + i))).
  rewrite (left_id ∅ (⋅)), <-comp_app, <-repeat_app.
  replace (j - i + (1 + i))%nat with (1 + j)%nat by lia; done.
Qed.

Section Generating_set.

Variable gen : list perm.

Definition Generates (π : perm) :=
  ∃ w, w ⊆ gen ∧ π ≡ comp w.

Record Group_Order (ord : positive) := Group_Enumeration {
  enum : positive -> perm;
  enum_gen : ∀ i, i ≤ ord -> Generates (enum i);
  enum_inj : ∀ i j, i ≤ ord -> j ≤ ord -> enum i ≡ enum j -> i = j;
  enum_surj : ∀ π, Generates π -> ∃ i, i ≤ ord ∧ π ≡ enum i;
}.

Lemma generates_e :
  Generates ∅.
Proof.
exists []; split; [|done].
apply list_subseteq_nil.
Qed.

Lemma generates_generator σ :
  σ ∈ gen -> Generates σ.
Proof.
exists [σ]; split; cbn. set_solver.
symmetry; apply (right_id ∅ (⋅)).
Qed.

Lemma generates_compose τ π :
  Generates τ -> Generates π -> Generates (π⋅τ).
Proof.
intros [w_τ [H1 H2]] [w_π [H3 H4]]; exists (w_π ++ w_τ); split.
set_solver. rewrite comp_app, H2, H4; done.
Qed.

Lemma generates_inv π :
  Generates π -> Generates (inv π).
Proof.
intros [w [H1 H2]]; destruct (perm_order π) as [k H3]; cbn in H3.
exists (concat (repeat w k)); split.
- clear H2 H3; induction k; cbn; set_solver.
- assert (H4 : inv π ≡ comp (repeat π k)).
  + symmetry; rewrite <-(left_id ∅ (⋅)), <-(left_inv π) at 1.
    rewrite <-(assoc (⋅)), H3, (right_id ∅ (⋅)); done.
  + rewrite H4; clear H1 H3 H4; induction k; cbn in *. done.
    rewrite IHk; rewrite H2, comp_app; done.
Qed.

End Generating_set.

Lemma unit_group_order :
  Group_Order [] 1.
Proof.
exists (λ _, ∅); intros. apply generates_e. lia. destruct H as [w []].
apply list_nil_subseteq in H as ->; exists 1; done.
Qed.


Load "eztactics.v".

Require Import List.

(* Add LoadPath "../Listkit" as Listkit. *)

Require Import Listkit.logickit.

Require Import Listkit.Sets.

Lemma map_lemma:
  forall (A B :Set) (f:A->B) (x:A) xs,
    map f (x::xs) = (f x) :: (map f xs).
Proof.
  unfold map; trivial.
Qed.

(** Might be in standard library? *)
Lemma map_app_commutes:
  forall (A B:Set) f l1 l2,
    map (A:=A)(B:=B) f (l1 ++ l2) = map f l1 ++ map f l2.
 intros.
 induction l1.
 replace (nil ++ l2) with l2; auto.
 replace ((a :: l1) ++ l2) with (a :: (l1 ++ l2)); auto.
 simpl.
 rewrite IHl1; trivial.
Qed.

Lemma map_idy : forall A xs, map (idy A) xs = xs.
Proof.
 induction xs.
  auto.
 simpl.
 unfold idy at 1.
 rewrite IHxs.
 auto.
Qed.

Lemma map_extensionality:
  forall A B (f g:A->B) xs,
    (forall x, set_In x xs -> f x = g x)
     -> map f xs = map g xs.
Proof.
 induction xs; simpl; intros; auto.
 rewrite IHxs; auto.
 rewrite H; auto.
Qed.

Lemma set_map_extensionality:
  forall A B B_eq_dec (f g:A->B) xs,
    (forall x, set_In x xs -> f x = g x)
     -> set_map B_eq_dec f xs = set_map B_eq_dec g xs.
Proof.
 induction xs; simpl; intros; auto.
 rewrite IHxs; auto.
 rewrite H; auto.
Qed.

(* Consider the nearly identical, but stronger, set_In_map_image in Sets. *)
Lemma map_image:
  forall A B (f:A->B) x xs,
    set_In x (map f xs) -> exists x', x = f x' /\ set_In x' xs.
Proof.
 induction xs.
  simpl; contradiction.
 simpl.
 intuition.
  exists a; auto.
 firstorder.
Qed.

Lemma set_map_idy_ext :
  forall A eq_dec (f:A->A) xs,
    (* TODO: Consider using set_In here? *)
    (forall x, true = set_mem eq_dec x xs -> f x = x)
    -> eq_sets _ (set_map eq_dec f xs) xs.
Proof.
 induction xs.
  auto.
 simpl.
 intros.
 pose (H0 := H a).
 assert (f a = a).
 apply H0.
 case (eq_dec a a).
 auto.
 intuition.
 replace (f a) with a.
 rewrite IHxs.
  sauto.
 intuition.
 apply H.
 case (eq_dec x a); intuition.
Qed.

Lemma set_map_idy :
  forall A eq_dec (xs:set A),
    eq_sets _ (set_map eq_dec (idy A) xs) xs.
Proof.
 induction xs; simpl.
  auto.
 unfold idy at 1.
 rewrite IHxs.
 auto.
Qed.

Lemma set_map_map :
  forall A B eq_dec f (g:A->B) xs,
    eq_sets _
      (set_map eq_dec f (set_map eq_dec g xs))
      (set_map eq_dec (fun x => f (g x)) xs).
Proof.
 induction xs; simpl; intros.
  auto.
 unfold eq_sets in IHxs |- *.
 destruct IHxs as [IHxs1 IHxs2].
 split.
  rewrite map_add_comm.
  rewrite IHxs1; auto.
(* Check (flip Basics.impl). *)
 rewrite map_add_comm.
 rewrite IHxs2; auto.
Qed.


(* This file is generated by Why3's Coq 8.4 driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Reals.R_sqrt.
Require BuiltIn.
Require real.Real.
Require real.Square.

(* Why3 assumption *)
Definition dot (x1:R) (x2:R) (y1:R) (y2:R): R :=
  ((x1 * y1)%R + (x2 * y2)%R)%R.

(* Why3 assumption *)
Definition norm2 (x1:R) (x2:R): R :=
  ((Reals.RIneq.Rsqr x1) + (Reals.RIneq.Rsqr x2))%R.

Axiom norm2_pos : forall (x1:R) (x2:R), (0%R <= (norm2 x1 x2))%R.

Axiom Lagrange : forall (a1:R) (a2:R) (b1:R) (b2:R), (((norm2 a1
  a2) * (norm2 b1 b2))%R = ((Reals.RIneq.Rsqr (dot a1 a2 b1
  b2)) + (Reals.RIneq.Rsqr ((a1 * b2)%R - (a2 * b1)%R)%R))%R).

Axiom CauchySchwarz_aux : forall (x1:R) (x2:R) (y1:R) (y2:R),
  ((Reals.RIneq.Rsqr (dot x1 x2 y1 y2)) <= ((norm2 x1 x2) * (norm2 y1
  y2))%R)%R.

(* Why3 assumption *)
Definition norm (x1:R) (x2:R): R := (Reals.R_sqrt.sqrt (norm2 x1 x2)).

Axiom norm_pos : forall (x1:R) (x2:R), (0%R <= (norm x1 x2))%R.

Require Import Why3.
Ltac ae := why3 "Alt-Ergo,0.95.1," timelimit 3.
Import R_sqrt.

Open Scope R_scope.

(* Why3 goal *)
Theorem sqr_le_sqrt : forall (x:R) (y:R), ((Reals.RIneq.Rsqr x) <= y)%R ->
  (x <= (Reals.R_sqrt.sqrt y))%R.
(* Why3 intros x y h1. *)
intros x y h1.
assert (0 <= Rsqr x) by ae.
assert (0 <= y) by ae.
assert (h : (x < 0 \/ x >= 0)%R).
  ae.
destruct h.
  ae.
replace x with (sqrt (Rsqr x)).
apply sqrt_le_1.
ae.
ae.
ae.
ae.
Qed.