(****************************************************************************)
(*      Logically atomic specification of the Treiber stack algorithm       *)
(*                                                                          *)
(*         by Rodolphe Lepigre (with a lot of help from Ralf Jung)          *)
(*          see https://gitlab.mpi-sws.org/lepigre/treiber_stack            *)
(****************************************************************************)

From iris.algebra Require Import excl auth list.
From iris.base_logic.lib Require Import invariants.
From iris.program_logic Require Import atomic.
From iris.heap_lang Require Import proofmode notation.
From iris.prelude Require Import options.

(** * Definition of the functions *******************************************)

(** A stack is (physically) represented as a pointer to a linked list. When we
    create a new stack, it initially points to an empty list. And there is, of
    course, no potential race condition here since only the current thread can
    now the value of the freshly allocated pointer. *)
Definition new_stack : val :=
  λ: <>, ref NONEV.

(** To push an element on a stack we remember the old head of the pointed list
    list, create a new cell containing both the element and the old head,  and
    then we perform a CAS (Compare And Set). We thus (atomically) test whether
    the stack still points to the old head, and if that is indeed the case, we
    simultaneously set the stack to point to the newly created cell. Note that
    if the CAS was successful, then the element has been added to the list. If
    it failed, we start over from scratch with a recursive call. *)
Definition push_stack : val :=
  rec: "push" "elt" "stack" :=
    let: "old_head" := !"stack" in
    let: "cell" := ("elt", "old_head") in
    if: CAS "stack" "old_head" (SOME (ref "cell")) then #()
    else "push" "elt" "stack".

(** To pop an element from the stack, we first remember the head of the linked
    list, and then we match on its value. If it is the end of the list (NONE),
    then the function returns NONE. If the list is non-empty, we load the cell
    containing both: the head element and the pointer to the tail of the list.
    We then perform a CAS: if the stack still points to the (previous) head of
    the list, then we set it to point to the tail. If the CAS is successful we
    return the element (wrapped in a SOME). Otherwise we start over. Note that
    in the case where the pointed list is empty the linearization point occurs
    on the first access to the stack. Otherwise it occurs at the CAS. *)
Definition pop_stack : val :=
  rec: "pop" "stack" :=
    let: "old_top" := !"stack" in
    match: "old_top" with
      NONE     => NONE
    | SOME "p" =>
       let: "cell" := !"p" in
       if: CAS "stack" "old_top" (Snd "cell") then SOME (Fst "cell")
       else "pop" "stack"
    end.

(** * Definition of the required camera *************************************)

Class stackG Σ := StackG {
  stack_tokG :> inG Σ (authR (optionUR (exclR (listO valO)))) }.

Definition stackΣ : gFunctors :=
  #[GFunctor (authR (optionUR (exclR (listO valO))))].

Global Instance subG_stackΣ {Σ} : subG stackΣ Σ → stackG Σ.
Proof. solve_inG. Qed.

(* Put some things in the context. *)
Section treiber_stack.
Context `{!heapGS Σ, !stackG Σ}.
Context (N : namespace).
Notation iProp := (iProp Σ).

(** * Representation relations and invariant used in the specification ******)

(** Utility function injecting (optional) locations into values. *)
Definition to_val (lopt : option loc) : val :=
  match lopt with
  | None   => NONEV
  | Some ℓ => SOMEV #ℓ
  end%I.

(** Representation relation for lists: the (optional) location [lopt] (in fact
    [to_val lopt]) physically represents the (Coq) list [xs]. *)
Fixpoint phys_list (lopt : option loc) (xs : list val) : iProp :=
  match (lopt, xs) with
  | (None  , []     ) => True
  | (None  , _ :: _ ) => False
  | (Some _, []     ) => False
  | (Some ℓ, x :: xs) => ∃ r, ℓ ↦□ (x, to_val r) ∗ phys_list r xs
  end%I.

(** Representation relation for stacks: the location [ℓ] physically represents
    a stack whose elements are those of [xs]. More precisely, [ℓ] is a pointer
    to a linked list, representing [xs]. *)
Definition phys_stack (ℓ : loc) (xs : list val) : iProp :=
  (∃ r, ℓ ↦ to_val r ∗ phys_list r xs)%I.

(** Statement of the invariant maintained for a stack pointed to by (location)
    [ℓ], and uniquely identified by the global name [γ]. Intuitively, there is
    a coq list [xs] such that [ℓ] physically represents [xs], and the value of
    [xs] is stored in ghost state whose authoritative  part  is  (exclusively)
    owned by the invariants.  This always keeps the ghost state in  sync  with
    the physical state, meaning that the ownership of a fragment [own γ (◯ _)]
    actually becomes meaningful to make statements about the list because both
    are tied together by this invariant. *)
Definition stack_inv (ℓ : loc) (γ : gname) : iProp :=
  (∃ xs, phys_stack ℓ xs ∗ own γ (● (Some ((Excl xs)))))%I.

(** Invariant assertion for a stack pointed to by [ℓ], and uniquely identified
    by the global name [γ].  Note that the namespace [N] is quantified over in
    the whole section. It can thus be instantiated to fit any particular need,
    when using this module as a library. *)
Definition is_stack (ℓ : loc) (γ : gname) : iProp :=
  inv N (stack_inv ℓ γ).

(** Local view of the contents [xs] of the stack that is (uniquely) identified
    by the global name [γ]. Note that this proposition is independent from the
    particular location at which the stack is stored,  which can only be owned
    by one particular thread at a time. *)
Definition stack_cont (γ : gname) (xs : list val) : iProp :=
  (own γ (◯ (Some ((Excl xs)))))%I.

(** * Useful lemmas and typeclass instances *********************************)

(** Injectivity of [to_val]. *)
Instance to_val_inj : Inj (=) (=) to_val.
Proof.
  intros l1 l2 H. case l1, l2; try done. inversion H. reflexivity.
Qed.

(** Persistence of the [phys_list] relation. *)
Global Instance phys_list_dup l xs : Persistent (phys_list l xs).
Proof. revert l. induction xs; apply _. Qed.

(** Timelessness of the [phys_list] relation. *)
Global Instance phys_list_timeless l xs : Timeless (phys_list l xs).
Proof.
  revert l. induction xs; apply _.
Qed.

(** The following two lemmas have been borrowed from the POPL 18 Iris tutorial
    (see https://gitlab.mpi-sws.org/iris/tutorial-popl18). *)

(** The view of the authority agrees with the local view. *)
Lemma auth_agree γ xs ys :
  own γ (● (Excl' xs)) -∗ own γ (◯ (Excl' ys)) -∗ ⌜xs = ys⌝.
Proof.
  iIntros "Hγ● Hγ◯". by iDestruct (own_valid_2 with "Hγ● Hγ◯")
    as %[<-%Excl_included%leibniz_equiv _]%auth_both_valid_discrete.
Qed.

(** The view of the authority can be updated together with the local view. *)
Lemma auth_update γ ys xs1 xs2 :
  own γ (● (Excl' xs1)) -∗ own γ (◯ (Excl' xs2)) ==∗
    own γ (● (Excl' ys)) ∗ own γ (◯ (Excl' ys)).
Proof.
  iIntros "Hγ● Hγ◯".
  iMod (own_update_2 _ _ _ (● Excl' ys ⋅ ◯ Excl' ys)
    with "Hγ● Hγ◯") as "[$$]".
  { by apply auth_update, option_local_update, exclusive_local_update. }
  done.
Qed.

(** * Automation hints for [eauto] ******************************************)

(** The following hints allow [eauto] to work with the above definitions. When
    a simple goal involving only framing and the instantiation of existentials
    is encoutered, we can usually conclude with [eauto with iFrame]. The hints
    are mainly useful for unfolding definitions and instantiating existentials
    with a reasonable choice of head constructor. *)

Local Hint Extern 0 (environments.envs_entails _
  (phys_stack _ [])) => iExists None : core.

Local Hint Extern 0 (environments.envs_entails _
  (phys_stack _ (_ :: _))) => iExists (Some _) : core.

Local Hint Extern 10 (environments.envs_entails _
  (phys_stack _ _)) => unfold phys_stack : core.

Local Hint Extern 0 (environments.envs_entails _
  (stack_inv _ _)) => unfold stack_inv : core.

Local Hint Extern 0 (environments.envs_entails _
  (phys_list None [])) => simpl : core.

Local Hint Extern 0 (environments.envs_entails _
  (phys_list (Some _) (_ :: _))) => simpl : core.

(** * Specification *********************************************************)

(** The specification of [new_stack] is straightforward: with no precondition,
    the creation of a new stack yields a location that is pointing to a stack,
    and it is initially empty. The only interesting thing to note here is that
    an existential quantifier is used in the postcondition to obtain a (fresh)
    name [γ] for the created stack. This ensures that different stacks will be
    given different names. *)
Lemma new_stack_spec :
  {{{ True }}}
    new_stack #()
  {{{ ℓ γ, RET #ℓ; is_stack ℓ γ ∗ stack_cont γ [] }}}.
Proof.
  (* Introduce things into the Coq and Iris contexts. Throw away the [True]
     precondition. *)
  iIntros (Φ) "_ HΦ".
  (* We step through the program: β-reduce and allocate a location [ℓ]. *)
  wp_lam. wp_alloc ℓ as "Hl". (* We have full ownership of [ℓ] in [Hl]. *)
  (* We now need to establish the invariant. First, we allocate an instance of
     our camera named [γ], containing the empty list. This step (and the next)
     requires the fancy update modality that was introduced earlier. *)
  iMod (own_alloc (● (Some (Excl [])) ⋅ ◯ (Some (Excl []))))
    as (γ) "[Hγ● Hγ◯]";
    (* Validity is trivial. *) first by apply auth_both_valid_discrete.
  (* We can then allocate the invariant (with mask [N]).  Note that we can use
     [eauto 10 with iFrame] to prove [▷ stack_inv ℓ γ]. *)
  iMod (inv_alloc N _ (stack_inv ℓ γ) with "[Hl Hγ●]")
    as "#Inv"; first eauto 10 with iFrame.
  (* We can now eliminate the modality and establish the postcondition. *)
  iModIntro. iApply "HΦ". eauto with iFrame.
Qed.

(** The specification of [push_stack] depends on a location [ℓ] and a name [γ]
    assumed to correspond to a stack (created using [new_stack]),  and a value
    [v] that is being pushed. A logically atomic Hoare triple is used in order
    to ensure linearizability (i.e., the existence of a linearization point in
    the execution of the push operation). As a consequence the precondition of
    the triple can only be accessed during a physically atomic operation,  and
    the knowledge gained must then either be forgotten (abort operation) or it
    should lead to a one shot update (commit operation) during the same atomic
    operation where the precondition was accessed. In this second case we lose
    the possibility of accessing the precondition again, unlike with abort. *)
Lemma push_stack_spec (ℓ : loc) (γ : gname) (v : val) :
  is_stack ℓ γ -∗
  <<< ∀ (xs : list val), stack_cont γ xs >>>
    push_stack v #ℓ @ ↑N
  <<< stack_cont γ (v :: xs) , RET #() >>>.
Proof.
  (* Introduce things into the Coq and Iris contexts, and use induction. *)
  iIntros "#HInv" (Φ) "AU". iLöb as "IH".
  (* Evaluate the first steps of the program, and focus on the load. *)
  wp_lam. wp_let. wp_bind (! _)%E.
  (* Since an atomic operation is in focus we can access the invariant. Hence,
     we will be able to learn that [ℓ] actually points to something. *)
  iInv "HInv" as (xs) ">[HPhys Hγ●]".
  unfold phys_stack. iDestruct "HPhys" as (w) "[Hl HPhys]".
  (* We can now perform the load, and get rid of the modality. *)
  wp_load. iModIntro. iSplitL "Hl Hγ● HPhys"; first by eauto 10 with iFrame.
  (* We then resume stepping through the program, and focus on the CAS. *)
  wp_alloc r as "Hr". wp_inj. wp_bind (CmpXchg _ _ _)%E.
  (* Now, we need to use the invariant again to gain information on [ℓ]. *)
  iInv "HInv" as (ys) ">[HPhys Hγ●]". iDestruct "HPhys" as (u) "[Hl HPhys]".
  (* We now reason by case on the success/failure of the CAS. *)
  destruct (decide (u = w)) as [[= ->]|NE].
  - (* The CAS succeeded. *)
    wp_cmpxchg_suc. { case w; left; done. (* Administrative stuff. *) }
    (* This was the linearization point. We access the preconditon. *)
    iMod "AU" as (zs) "[Hγ◯ [_ HClose]]".
    (* Use agreement on ressource [γ] to learn [zs = ys]. *)
    iDestruct (auth_agree with "Hγ● Hγ◯") as %->.
    (* Update the value of [γ] to [v::zs]. *)
    iMod (auth_update γ (v::zs) with "Hγ● Hγ◯") as "[Hγ● Hγ◯]".
    (* Commit operation. *)
    iMod ("HClose" with "Hγ◯") as "H".
    (* We can eliminate the modality. *)
    iMod (mapsto_persist with "Hr") as "Hr".
    iModIntro. iSplitR "H"; first by eauto 10 with iFrame.
    (* And conclude the proof easily, after some computation steps. *)
    wp_pures. iExact "H".
  - (* The CAS failed. *)
    wp_cmpxchg_fail. { exact: not_inj.  }
    { case u, w; simpl; eauto. (* Administrative stuff. *) }
    (* We can eliminate the modality. *)
    iModIntro. iSplitL "Hγ● Hl HPhys"; first by eauto 10 with iFrame.
    (* And conclude the proof by induction hypothesis. *)
    wp_pures. iApply "IH". iExact "AU".
Qed.

(** As for [push_stack] the specification of [pop_stack] depends on a location
    [ℓ] and a name [γ] (corresponding to some stack). A logically atomic Hoare
    triple is again used to ensure linearizability, but it must be accessed in
    a slightly more complicated way. In particular, the linearization point is
    not in the same place depending on the emptiness of the stack.  Of course,
    the postcondition also depends on the emptiness of the stack. *)
Lemma pop_stack_spec (ℓ : loc) (γ : gname) :
  is_stack ℓ γ -∗
  <<< ∀ (xs : list val), stack_cont γ xs >>>
    pop_stack #ℓ @ ↑N
  <<< stack_cont γ (match xs with [] => [] | _::xs => xs end)
    , RET (match xs with [] => NONEV | v::_ => SOMEV v end) >>>.
Proof.
  (* As for [push_stack], we need to use induction and the focus on a load. *)
  iIntros "#HInv" (Φ) "AU". iLöb as "IH". wp_lam. wp_bind (! _)%E.
  (* We can then use the invariant to be able to perform the load. *)
  iInv "HInv" as (xs) ">[HPhys Hγ●]".
  iDestruct "HPhys" as (w) "[Hl #HPhys]". wp_load.
  (* We then inspect the contents of the stack and the optional location. They
     must agree, otherwise the proof is trivial. *)
  destruct w as [w|], xs as [|x xs]; try done; simpl.
  - (* The stack is non-empty, we eliminate the modality. *)
    iModIntro. iSplitL "Hl Hγ●"; first by eauto 10 with iFrame.
    (* We continue stepping through the program, and focus on the CAS. *)
    wp_let. wp_match. iDestruct "HPhys" as (r) "[Hw HP]".
    wp_load. wp_let. wp_proj. wp_bind (CmpXchg _ _ _)%E.
    (* We need to use the invariant again to gain information on [ℓ]. *)
    iInv "HInv" as (ys) ">[H Hγ●]".
    unfold phys_stack. iDestruct "H" as (u) "[Hl HPhys]".
    (* We get rid of useless hypotheses to cleanup the context. *)
    iClear "HP". clear xs.
    (* We reason by case on the success/failure of the CAS. *)
    destruct (decide (u = Some w)) as [[= ->]|Hx].
    * (* The CAS succeeded, so this is the linearization point. *)
      wp_cmpxchg_suc.
      (* The list [ys] must be non-empty, otherwise the proof is trivial. *)
      destruct ys as [|y ys]; first done.
      (* We access the precondition, prior to performing an update. *)
      iMod "AU" as (zs) "[Hγ◯ [_ HClose]]". unfold stack_cont.
      (* Use agreement on ressource [γ] to learn [v :: ys = zs]. *)
      iDestruct (auth_agree with "Hγ● Hγ◯") as %<-.
      (* Update the value of [γ] to [ys] (the tail of previous value). *)
      iMod (auth_update γ ys with "Hγ● Hγ◯") as "[Hγ● Hγ◯]".
      (* We need to learn that [r = u] (true since mapsto must agree). *)
      iDestruct "HPhys" as (u) "[Hw' HPhys]".
      iDestruct (mapsto_agree with "Hw Hw'") as %[=-> ->%to_val_inj].
      (* Perform the commit. *)
      iMod ("HClose" with "Hγ◯") as "HΦ".
      (* Eliminate the modality. *)
      iModIntro. iSplitR "HΦ"; first by eauto 10 with iFrame.
      (* And conclude the proof. *)
      wp_pures. iExact "HΦ".
    * (* The CAS failed. *)
      wp_cmpxchg_fail. { intro H. apply Hx. destruct u; inversion H; done. }
      (* We can eliminate the modality. *)
      iModIntro. iSplitR "AU"; first by eauto 10 with iFrame.
      (* And conclude the proof using the induction hypothesis. *)
      wp_pures. iApply "IH". iExact "AU".
  - (* The stack is empty, the load was the linearization point,  we can hence
       commit (without updating the stack). So we access the precondition. *)
    iMod "AU" as (xs) "[Hγ◯ [_ HClose]]".
    (* Thanks to agreement, we learn that [xs] must be the empty list. *)
    iDestruct (auth_agree with "Hγ● Hγ◯") as %<-.
    (* And we can commit (we are still at the linearization point). *)
    iMod ("HClose" with "Hγ◯") as "HΦ".
    (* We finally eliminate the modality and conclude the proof by taking some
       computation steps, and using our hypothesis. *)
    iModIntro. iSplitR "HΦ"; first by eauto 10 with iFrame.
    wp_pures. iExact "HΦ".
Qed.

End treiber_stack.

(** Make the exported Iris terms "Typeclass Opaque", so that clients using the
    library won't look into these definitions. *)
Typeclasses Opaque is_stack stack_cont.


(**************************************************************************)
(*                                                                        *)
(*     SMTCoq                                                             *)
(*     Copyright (C) 2011 - 2014                                          *)
(*                                                                        *)
(*     Michaël Armand                                                     *)
(*     Benjamin Grégoire                                                  *)
(*     Chantal Keller                                                     *)
(*                                                                        *)
(*     INRIA - École Polytechnique - MSR                                  *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

(*** Spl -- a small checker for simplifications ***)

(* Add LoadPath ".." as SMTCoq. *)
(* Add LoadPath "../lia" as SMTCoq.lia. *)
Require Import List PArray Bool Int31 ZMicromega.
Require Import Misc State SMT_terms.
Require Lia.

Local Open Scope array_scope.
Local Open Scope int31_scope.

(* Flattening and small arithmetic simplifications *)

Section CheckAtom.

  Import Atom.

  Variable t_i : PArray.array typ_eqb.
  Variable t_func : PArray.array (tval t_i).
  Variable t_atom : PArray.array atom.

  Local Notation get_atom := (PArray.get t_atom).

  Section AUX.

    Variable check_hatom : hatom -> hatom -> bool.

    Definition check_atom_aux a b :=
      match a, b with
        | Acop o1, Acop o2 => cop_eqb o1 o2

        (* Two ways to define a negative integer *)
        | Auop UO_Zopp p1, Auop UO_Zneg q =>
          match get_atom p1 with
            | Auop UO_Zpos p => check_hatom p q
            | _ => false
          end
        | Auop UO_Zneg p, Auop UO_Zopp q1 =>
          match get_atom q1 with
            | Auop UO_Zpos q => check_hatom p q
            | _ => false
          end

        | Auop o1 a, Auop o2 b => uop_eqb o1 o2 && check_hatom a b
        | Abop o1 a1 a2, Abop o2 b1 b2 =>
          match o1, o2 with
            | BO_Zplus, BO_Zplus
            | BO_Zmult, BO_Zmult => (check_hatom a1 b1 && check_hatom a2 b2) || (check_hatom a1 b2 && check_hatom a2 b1)
            | BO_Zminus, BO_Zminus
            | BO_Zlt, BO_Zlt
            | BO_Zle, BO_Zle
            | BO_Zge, BO_Zge
            | BO_Zgt, BO_Zgt  => check_hatom a1 b1 && check_hatom a2 b2
            | BO_Zge, BO_Zle
            | BO_Zle, BO_Zge
            | BO_Zgt, BO_Zlt
            | BO_Zlt, BO_Zgt => check_hatom a1 b2 && check_hatom a2 b1
            | BO_eq t1, BO_eq t2 =>
              Typ.eqb t1 t2 &&
              ((check_hatom a1 b1 && check_hatom a2 b2) ||
                (check_hatom a1 b2 && check_hatom a2 b1))
            | _, _ => false
          end
        | Anop o1 l1, Anop o2 l2 =>
          match o1, o2 with
            | NO_distinct t1, NO_distinct t2 => Typ.eqb t1 t2 && list_beq check_hatom l1 l2
          end
        | Aapp f1 aargs, Aapp f2 bargs =>(f1 == f2) && list_beq check_hatom aargs bargs

        | _, _ => false
      end.

    Hypothesis check_hatom_correct : forall h1 h2, check_hatom h1 h2 ->
      interp_hatom t_i t_func t_atom h1 = interp_hatom t_i t_func t_atom h2.
    Hypothesis Hwf: wf t_atom.
    Hypothesis Hd: default t_atom = Acop CO_xH.

    Lemma list_beq_correct : forall l1 l2,
      list_beq check_hatom l1 l2 = true ->
      List.map (interp_hatom t_i t_func t_atom) l1 =
      List.map (interp_hatom t_i t_func t_atom) l2.
    Proof.
      induction l1 as [ |h1 l1 IHl1]; intros [ |h2 l2]; simpl; try discriminate; auto; rewrite andb_true_iff; intros [H1 H2]; rewrite (IHl1 _ H2); rewrite (check_hatom_correct _ _ H1); auto.
    Qed.

    Lemma list_beq_compute_interp : forall t l1 l2,
      list_beq check_hatom l1 l2 = true -> forall acc,
      compute_interp t_i (interp_hatom t_i t_func t_atom) t acc l1 =
      compute_interp t_i (interp_hatom t_i t_func t_atom) t acc l2.
    Proof.
      intro t; induction l1 as [ |h1 l1 IHl1]; intros [ |h2 l2]; simpl; try discriminate; auto; rewrite andb_true_iff; intros [H1 H2] acc; rewrite (check_hatom_correct _ _ H1); destruct (interp_hatom t_i t_func t_atom h2) as [ta va]; destruct (Typ.cast ta t) as [ka| ]; auto.
    Qed.

    Lemma check_atom_aux_correct : forall a1 a2, check_atom_aux a1 a2 ->
      interp t_i t_func t_atom a1 = interp t_i t_func t_atom a2.
    Proof.
      intros [op1|op1 i1|op1 i1 j1|op1 li1|f1 args1]; simpl.
      (* Constants *)
      intros [op2|op2 i2|op2 i2 j2|op2 li2|f2 args2]; simpl; try discriminate; pose (H:=reflect_cop_eqb op1 op2); inversion H; try discriminate; subst op1; auto.
      (* Unary operators *)
      intros [op2|op2 i2|op2 i2 j2|op2 li2|f2 args2]; simpl; try discriminate; try (case op1; discriminate).
      case op1; case op2; try discriminate; try (unfold is_true; rewrite andb_true_iff; intros [_ H]; rewrite (check_hatom_correct _ _ H); auto).
      case_eq (get_atom i2); try discriminate; intros [ | | | | ] i Heq H; try discriminate; simpl; unfold apply_unop; rewrite (check_hatom_correct _ _ H); unfold interp_hatom; rewrite (t_interp_wf _ _ _ Hwf Hd i2), Heq; simpl; unfold apply_unop; destruct (t_interp t_i t_func t_atom .[ i]) as [A v]; destruct (Typ.cast A Typ.Tpositive) as [k| ]; auto.
      case_eq (get_atom i1); try discriminate; intros [ | | | | ] i Heq H; try discriminate; simpl; unfold apply_unop; rewrite <- (check_hatom_correct _ _ H); unfold interp_hatom; rewrite (t_interp_wf _ _ _ Hwf Hd i1), Heq; simpl; unfold apply_unop; destruct (t_interp t_i t_func t_atom .[ i]) as [A v]; destruct (Typ.cast A Typ.Tpositive) as [k| ]; auto.
      (* Binary operators *)
      intros [op2|op2 i2|op2 i2 j2|op2 li2|f2 args2]; simpl; try discriminate; case op1; case op2; try discriminate; try (unfold is_true; rewrite andb_true_iff; intros [H1 H2]; rewrite (check_hatom_correct _ _ H1), (check_hatom_correct _ _ H2); auto).
      unfold is_true, interp_bop, apply_binop. rewrite orb_true_iff, !andb_true_iff. intros [[H1 H2]|[H1 H2]]; rewrite (check_hatom_correct _ _ H1), (check_hatom_correct _ _ H2); destruct (interp_hatom t_i t_func t_atom i2) as [A v1]; destruct (interp_hatom t_i t_func t_atom j2) as [B v2]; destruct (Typ.cast B Typ.TZ) as [k2| ]; destruct (Typ.cast A Typ.TZ) as [k1| ]; auto; rewrite Z.add_comm; reflexivity.
      unfold is_true, interp_bop, apply_binop. rewrite orb_true_iff, !andb_true_iff. intros [[H1 H2]|[H1 H2]]; rewrite (check_hatom_correct _ _ H1), (check_hatom_correct _ _ H2); destruct (interp_hatom t_i t_func t_atom i2) as [A v1]; destruct (interp_hatom t_i t_func t_atom j2) as [B v2]; destruct (Typ.cast B Typ.TZ) as [k2| ]; destruct (Typ.cast A Typ.TZ) as [k1| ]; auto; rewrite Z.mul_comm; reflexivity.
      unfold interp_bop, apply_binop; destruct (interp_hatom t_i t_func t_atom j2) as [B v2]; destruct (interp_hatom t_i t_func t_atom i2) as [A v1]; destruct (Typ.cast B Typ.TZ) as [k2| ]; destruct (Typ.cast A Typ.TZ) as [k1| ]; auto; rewrite Z.gtb_ltb; auto.
      unfold interp_bop, apply_binop; destruct (interp_hatom t_i t_func t_atom j2) as [B v2]; destruct (interp_hatom t_i t_func t_atom i2) as [A v1]; destruct (Typ.cast B Typ.TZ) as [k2| ]; destruct (Typ.cast A Typ.TZ) as [k1| ]; auto; rewrite Z.geb_leb; auto.
      unfold interp_bop, apply_binop; destruct (interp_hatom t_i t_func t_atom j2) as [B v2]; destruct (interp_hatom t_i t_func t_atom i2) as [A v1]; destruct (Typ.cast B Typ.TZ) as [k2| ]; destruct (Typ.cast A Typ.TZ) as [k1| ]; auto; rewrite Z.geb_leb; auto.
      unfold interp_bop, apply_binop; destruct (interp_hatom t_i t_func t_atom j2) as [B v2]; destruct (interp_hatom t_i t_func t_atom i2) as [A v1]; destruct (Typ.cast B Typ.TZ) as [k2| ]; destruct (Typ.cast A Typ.TZ) as [k1| ]; auto; rewrite Z.gtb_ltb; auto.
      intros A B; unfold is_true; rewrite andb_true_iff, orb_true_iff; change (Typ.eqb B A = true) with (is_true (Typ.eqb B A)); rewrite Typ.eqb_spec; intros [H2 [H1|H1]]; subst B; rewrite andb_true_iff in H1; destruct H1 as [H1 H2]; rewrite (check_hatom_correct _ _ H1), (check_hatom_correct _ _ H2); auto; simpl; unfold apply_binop; destruct (interp_hatom t_i t_func t_atom j2) as [B v1]; destruct (interp_hatom t_i t_func t_atom i2) as [C v2]; destruct (Typ.cast B A) as [k1| ]; destruct (Typ.cast C A) as [k2| ]; auto; rewrite Typ.i_eqb_sym; auto.
      (* N-ary operators *)
      intros [op2|op2 i2|op2 i2 j2|op2 li2|f2 args2]; simpl; try discriminate; destruct op1 as [t1]; destruct op2 as [t2]; unfold is_true; rewrite andb_true_iff; change (Typ.eqb t1 t2 = true) with (is_true (Typ.eqb t1 t2)); rewrite Typ.eqb_spec; intros [H1 H2]; subst t2; rewrite (list_beq_compute_interp _ _ _ H2); auto.
      (* Application *)
      intros [op2|op2 i2|op2 i2 j2|op2 li2|f2 args2]; simpl; try discriminate; unfold is_true; rewrite andb_true_iff, Int31Properties.eqb_spec; intros [H2 H1]; subst f2; rewrite (list_beq_correct _ _ H1); auto.
    Qed.

  End AUX.

  Definition check_hatom h1 h2 :=
    foldi_down_cont
    (fun _ cont h1 h2 => (h1 == h2) || check_atom_aux cont (t_atom.[h1]) (t_atom.[h2]))
    (PArray.length t_atom) 0 (fun h1 h2 => false) h1 h2.

  Definition check_atom := check_atom_aux check_hatom.

  Definition check_neg_hatom h1 h2 :=
    match get_atom h1, get_atom h2 with
      | Abop op1 a1 a2, Abop op2 b1 b2 =>
        match op1, op2 with
          | BO_Zlt, BO_Zle => check_hatom a1 b2 && check_hatom a2 b1
          | BO_Zlt, BO_Zge => check_hatom a1 b1 && check_hatom a2 b2
          | BO_Zle, BO_Zlt => check_hatom a1 b2 && check_hatom a2 b1
          | BO_Zle, BO_Zgt => check_hatom a1 b1 && check_hatom a2 b2
          | BO_Zge, BO_Zlt => check_hatom a1 b1 && check_hatom a2 b2
          | BO_Zge, BO_Zgt => check_hatom a1 b2 && check_hatom a2 b1
          | BO_Zgt, BO_Zle => check_hatom a1 b1 && check_hatom a2 b2
          | BO_Zgt, BO_Zge => check_hatom a1 b2 && check_hatom a2 b1
          | _, _ => false
        end
      | _, _ => false
    end.

  (* TODO : move this *)
  Lemma Zge_is_ge_bool : forall x y, (x >= y) <-> (Zge_bool x y = true).
  Proof.
    intros x y;assert (W:=Zge_cases x y);destruct (Zge_bool x y).
    split;auto.
    split;[intros;elimtype false;auto with zarith | discriminate].
  Qed.

  (* Correctness of check_atom *)

  Lemma check_hatom_correct : wf t_atom ->
    default t_atom = Acop CO_xH ->
    forall h1 h2, check_hatom h1 h2 ->
      interp_hatom t_i t_func t_atom h1 = interp_hatom t_i t_func t_atom h2.
  Proof.
   unfold check_hatom;intros Hwf Hdef.
   apply foldi_down_cont_ind;try discriminate.
   intros i cont _ _ Hrec h1 h2.
   unfold is_true; rewrite orb_true_iff; intros [H|H].
   rewrite Int31Properties.eqb_spec in H; rewrite H; reflexivity.
   unfold interp_hatom;rewrite !t_interp_wf;trivial.
   apply check_atom_aux_correct with cont;trivial.
  Qed.

   Lemma check_atom_correct : wf t_atom ->
    default t_atom = Acop CO_xH ->
    forall a1 a2, check_atom a1 a2 ->
        interp t_i t_func t_atom a1 = interp t_i t_func t_atom a2.
  Proof.
   intros Hwf Hdef;unfold check_atom;apply check_atom_aux_correct; auto.
   apply check_hatom_correct;trivial.
  Qed.

  Lemma check_hatom_correct_bool : wf t_atom ->
    default t_atom = Acop CO_xH ->
    forall h1 h2, check_hatom h1 h2 ->
      interp_form_hatom t_i t_func t_atom h1 = interp_form_hatom t_i t_func t_atom h2.
  Proof.
    unfold interp_form_hatom; intros H1 H2 h1 h2 H3; rewrite (check_hatom_correct H1 H2 h1 h2 H3); auto.
  Qed.

  (* Correctness of check_neg_atom *)

  Lemma check_neg_hatom_correct : wt t_i t_func t_atom ->
    wf t_atom -> default t_atom = Acop CO_xH ->
    forall h1 h2, check_neg_hatom h1 h2 ->
      match interp_hatom t_i t_func t_atom h1, interp_hatom t_i t_func t_atom h2 with
        | Val Typ.Tbool v1, Val Typ.Tbool v2 => v1 = negb v2
        | Val _ _, Val _ _ => False
      end.
  Proof.
    unfold wt; unfold is_true at 1; rewrite forallbi_spec; intros Hwt Hwf Hdef h1 h2; unfold check_neg_hatom; case_eq (get_atom h1); try discriminate; intros b1 t11 t12 H1; case_eq (get_atom h2); try discriminate; intros b2 t21 t22 H2; assert (H7: h1 < length t_atom) by (apply PArray.get_not_default_lt; rewrite H1, Hdef; discriminate); generalize (Hwt _ H7); rewrite H1; simpl; generalize H1; case b1; try discriminate; clear H1 b1; simpl; intro H1; case (get_type' t_i (t_interp t_i t_func t_atom) h1); try discriminate; simpl; rewrite andb_true_iff; intros [H30 H31]; change (is_true (Typ.eqb (get_type' t_i (t_interp t_i t_func t_atom) t11) Typ.TZ)) in H30; change (is_true (Typ.eqb (get_type' t_i (t_interp t_i t_func t_atom) t12) Typ.TZ)) in H31; rewrite Typ.eqb_spec in H30, H31; generalize (check_aux_interp_hatom _ t_func _ Hwf t11), (check_aux_interp_hatom _ t_func _ Hwf t12); rewrite H30, H31; intros [v1 Hv1] [v2 Hv2]; generalize H2; case b2; try discriminate; clear H2 b2; intro H2; unfold is_true; rewrite andb_true_iff; intros [H3 H4]; generalize (check_hatom_correct Hwf Hdef _ _ H3), (check_hatom_correct Hwf Hdef _ _ H4); unfold interp_hatom; intros H5 H6; rewrite t_interp_wf; auto; rewrite H1; simpl; rewrite Hv1, Hv2; simpl; rewrite t_interp_wf; auto; rewrite H2; simpl; rewrite <- H5; rewrite <- H6, Hv1, Hv2; simpl.
    rewrite Z.ltb_antisym; auto.
    rewrite Z.geb_leb, Z.ltb_antisym; auto.
    rewrite Z.leb_antisym; auto.
    rewrite Z.gtb_ltb, Z.leb_antisym; auto.
    rewrite Z.geb_leb, Z.leb_antisym; auto.
    rewrite Z.geb_leb, Z.gtb_ltb, Z.leb_antisym; auto.
    rewrite Z.gtb_ltb, Z.ltb_antisym; auto.
    rewrite Z.geb_leb, Z.gtb_ltb, Z.ltb_antisym; auto.
  Qed.

  Lemma check_neg_hatom_correct_bool : wt t_i t_func t_atom ->
    wf t_atom -> default t_atom = Acop CO_xH ->
    forall h1 h2, check_neg_hatom h1 h2 ->
      interp_form_hatom t_i t_func t_atom h1 = negb (interp_form_hatom t_i t_func t_atom h2).
  Proof.
    unfold interp_form_hatom. intros Hwt H1 H2 h1 h2 H3. unfold interp_bool. generalize (check_neg_hatom_correct Hwt H1 H2 _ _ H3). case (interp_hatom t_i t_func t_atom h1). case (interp_hatom t_i t_func t_atom h2). simpl. intros [i| | | ] v1 [j| | | ] v2; intro H; inversion H. rewrite Typ.cast_refl. auto.
  Qed.

End CheckAtom.

(* Flattening *)

Section FLATTEN.

  Import Form.

  Variable t_form : PArray.array form.

  Local Notation get_form := (PArray.get t_form).

  Definition remove_not l :=
    match get_form (Lit.blit l) with
      | Fnot2 _ l' => if Lit.is_pos l then l' else Lit.neg l'
      | _ => l
    end.

  Definition get_and l :=
    let l := remove_not l in
      if Lit.is_pos l then
        match get_form (Lit.blit l) with
          | Fand args => Some args
          | _ => None
        end
        else None.

  Definition get_or l :=
    let l := remove_not l in
      if Lit.is_pos l then
        match get_form (Lit.blit l) with
          | For args => Some args
          | _ => None
        end
        else None.

  Definition flatten_op_body (get_op:_lit -> option (array _lit))
    (frec : list _lit -> _lit -> list _lit)
    (largs:list _lit) (l:_lit) : list _lit :=
    match get_op l with
      | Some a => PArray.fold_left frec largs a
      | None => l::largs
    end.
  Register flatten_op_body as PrimInline.

  Definition flatten_op_lit (get_op:_lit -> option (array _lit)) max :=
    foldi_cont (fun _ => flatten_op_body get_op) 0 max (fun largs l => l::largs).

  Definition flatten_and t :=
    PArray.fold_left (flatten_op_lit get_and (PArray.length t_form)) nil t.

  Definition flatten_or t :=
    PArray.fold_left (flatten_op_lit get_or (PArray.length t_form)) nil t.

  Variable check_atom check_neg_atom : atom -> atom -> bool.

  Definition check_flatten_body frec (l lf:_lit) :=
    let l := remove_not l in
      let lf := remove_not lf in
        if l == lf then true
          else if 1 land (l lxor lf) == 0 then
            match get_form (Lit.blit l), get_form (Lit.blit lf) with
              | Fatom a1, Fatom a2 => check_atom a1 a2
              | Ftrue, Ftrue => true
              | Ffalse, Ffalse => true
              | Fand args1, Fand args2 =>
                let args1 := flatten_and args1 in
                  let args2 := flatten_and args2 in
                    forallb2 frec args1 args2
              | For args1, For args2 =>
                let args1 := flatten_or args1 in
                  let args2 := flatten_or args2 in
                    forallb2 frec args1 args2
              | Fxor l1 l2, Fxor lf1 lf2 =>
                frec l1 lf1 && frec l2 lf2
              | Fimp args1, Fimp args2 =>
                if PArray.length args1 == PArray.length args2 then
                  PArray.forallbi (fun i l => frec l (args2.[i])) args1
                  else false
              | Fiff l1 l2, Fiff lf1 lf2 =>
                frec l1 lf1 && frec l2 lf2
              | Fite l1 l2 l3, Fite lf1 lf2 lf3 =>
                frec l1 lf1 && frec l2 lf2 && frec l3 lf3
              | _, _ => false
            end
            else
              match get_form (Lit.blit l), get_form (Lit.blit lf) with
                | Fatom a1, Fatom a2 => check_neg_atom a1 a2
                | _, _ => false (* We maybe need to extend the rule here ... *)
              end.
  Register check_flatten_body as PrimInline.

  Definition check_flatten_aux l lf :=
    foldi_cont (fun _ => check_flatten_body) 0 (PArray.length t_form) (fun _ _ => false) l lf.

  Definition check_flatten s cid lf :=
    match S.get s cid with
      | l :: nil =>
        if check_flatten_aux l lf then lf::nil else C._true
      | _ => C._true
    end.

  (** Correctness proofs *)
  Variable interp_atom : atom -> bool.
  Hypothesis default_thf : default t_form = Ftrue.
  Hypothesis wf_thf : wf t_form.
  Hypothesis check_atom_correct :
    forall a1 a2, check_atom a1 a2 -> interp_atom a1 = interp_atom a2.
  Hypothesis check_neg_atom_correct :
    forall a1 a2, check_neg_atom a1 a2 -> interp_atom a1 = negb (interp_atom a2).

  Local Notation interp_var := (interp_state_var interp_atom t_form).
  Local Notation interp_lit := (Lit.interp interp_var).

  Lemma interp_Fnot2 : forall i l, interp interp_atom t_form (Fnot2 i l) = interp_lit l.
  Proof.
    intros i l;simpl;apply fold_ind;trivial.
    intros a;rewrite negb_involutive;trivial.
  Qed.

  Lemma remove_not_correct :
    forall l, interp_lit (remove_not l) = interp_lit l.
  Proof.
    unfold remove_not;intros l.
    case_eq (get_form (Lit.blit l));intros;trivial.
    unfold Lit.interp, Var.interp.
    rewrite (wf_interp_form interp_atom t_form default_thf wf_thf (Lit.blit l)), H, interp_Fnot2.
    destruct(Lit.is_pos l);trivial.
    rewrite Lit.is_pos_neg, Lit.blit_neg;unfold Lit.interp;destruct (Lit.is_pos i0);trivial.
    rewrite negb_involutive;trivial.
  Qed.

  Lemma get_and_correct : forall l args, get_and l = Some args ->
    interp_lit l = interp interp_atom t_form (Fand args).
  Proof.
    unfold get_and;intros l args.
    rewrite <- remove_not_correct;unfold Lit.interp;generalize (remove_not l).
    intros l';unfold Var.interp.
    destruct (Lit.is_pos l');[ | discriminate].
    rewrite wf_interp_form;trivial.
    destruct (get_form (Lit.blit l'));intros Heq;inversion Heq;trivial.
  Qed.

  Lemma get_or_correct : forall l args, get_or l = Some args ->
    interp_lit l = interp interp_atom t_form (For args).
  Proof.
    unfold get_or;intros l args.
    rewrite <- remove_not_correct;unfold Lit.interp;generalize (remove_not l).
    intros l';unfold Var.interp.
    destruct (Lit.is_pos l');[ | discriminate].
    rewrite wf_interp_form;trivial.
    destruct (get_form (Lit.blit l'));intros Heq;inversion Heq;trivial.
  Qed.

  Lemma flatten_and_correct : forall args,
    List.fold_right (fun l res => andb res (interp_lit l)) true (flatten_and args) =
    afold_left _ _ true andb interp_lit args.
  Proof.
    intros;rewrite afold_left_spec;auto;unfold flatten_and.
    set (t:= true);unfold t at 2;
      change true with
        (List.fold_right (fun (l : int) (res : bool) => res && interp_lit l) true nil).
    unfold t;clear t.
    rewrite !fold_left_to_list.
    generalize (@nil int);induction (to_list args);simpl;trivial.
    intros l0;rewrite IHl.
    clear IHl;f_equal; unfold flatten_op_lit.
    clear l;revert a l0;apply foldi_cont_ind;simpl;trivial.
    intros i cont _ Hle Hrec a l;unfold flatten_op_body.
    case_eq (get_and a);intros;trivial.
    rewrite get_and_correct with (1:= H);simpl.
    rewrite afold_left_spec; auto; rewrite !fold_left_to_list.
    rewrite <- !fold_left_rev_right.
    clear H a;revert l;induction (List.rev (to_list a0));simpl.
    intros l;rewrite andb_true_r;trivial.
    intros;rewrite Hrec, IHl, andb_assoc;trivial.
  Qed.

  Lemma flatten_or_correct : forall args,
    List.fold_right (fun l res => orb res (interp_lit l)) false (flatten_or args) =
    afold_left _ _ false orb interp_lit args.
  Proof.
    intros;rewrite afold_left_spec;auto;unfold flatten_or.
    set (t:= false);unfold t at 2;
      change false with
        (List.fold_right (fun (l : int) (res : bool) => res || interp_lit l) false nil).
    unfold t;clear t.
    rewrite !fold_left_to_list.
    generalize (@nil int);induction (to_list args);simpl;trivial.
    intros l0;rewrite IHl.
    clear IHl;f_equal; unfold flatten_op_lit.
    clear l;revert a l0;apply foldi_cont_ind;simpl;trivial.
    intros i cont _ Hle Hrec a l;unfold flatten_op_body.
    case_eq (get_or a);intros;trivial.
    rewrite get_or_correct with (1:= H);simpl.
    rewrite afold_left_spec; auto; rewrite !fold_left_to_list.
    rewrite <- !fold_left_rev_right.
    clear H a;revert l;induction (List.rev (to_list a0));simpl.
    intros l;rewrite orb_false_r;trivial.
    intros;rewrite Hrec, IHl, orb_assoc;trivial.
  Qed.

  Lemma check_flatten_aux_correct : forall l lf,
    check_flatten_aux l lf = true ->
    interp_lit l = interp_lit lf.
  Proof.
    unfold check_flatten_aux.
    apply foldi_cont_ind.
    discriminate.
    intros i cont _ Hle Hrec l lf;unfold check_flatten_body.
    rewrite <- (remove_not_correct l), <- (remove_not_correct lf).
    generalize (remove_not l) (remove_not lf);clear l lf;intros l lf.
    destruct (reflect_eqb l lf);[ intros;subst;trivial | ].
    destruct (reflect_eqb (1 land (l lxor lf)) 0).
    unfold Lit.interp.
    assert (Lit.is_pos l = Lit.is_pos lf).
    unfold Lit.is_pos.
    rewrite <- eqb_spec, land_comm in e.
    change (is_true (is_even (l lxor lf))) in e.
    rewrite is_even_xor in e.
    destruct (is_even l);destruct (is_even lf);trivial;discriminate.
    rewrite H;match goal with
                |- ?P -> _ =>
                assert (W:P -> Var.interp interp_var (Lit.blit l) = Var.interp interp_var (Lit.blit lf));
                  [ | intros;rewrite W;trivial]
              end.
    unfold Var.interp;rewrite !wf_interp_form;trivial.
    clear e n H.
    destruct (get_form (Lit.blit l));
      destruct (get_form (Lit.blit lf));intros;try discriminate;simpl;trivial.
     (* atom *)
    apply check_atom_correct;trivial.
     (* and *)
    rewrite <- !flatten_and_correct.
    revert H;generalize (flatten_and a) (flatten_and a0);clear a a0.
    induction l0;intros l1;destruct l1;simpl;trivial;try discriminate.
    rewrite andb_true_iff;intros (H1, H2).
    rewrite (Hrec _ _ H1), (IHl0 _ H2);trivial.
     (* or *)
    rewrite <- !flatten_or_correct.
    revert H;generalize (flatten_or a) (flatten_or a0);clear a a0.
    induction l0;intros l1;destruct l1;simpl;trivial;try discriminate.
    rewrite andb_true_iff;intros (H1, H2).
    rewrite (Hrec _ _ H1), (IHl0 _ H2);trivial.
     (* implb *)
    revert H;destruct (reflect_eqb (length a) (length a0));[intros|discriminate].
    apply afold_right_eq;trivial.
    rewrite forallbi_spec in H;auto.
     (* xorb *)
    unfold is_true in H;rewrite andb_true_iff in H;destruct H as [H H0].
    rewrite (Hrec _ _ H), (Hrec _ _ H0);trivial.
    (* eqb (i.e iff) *)
    unfold is_true in H;rewrite andb_true_iff in H;destruct H as [H H0].
    rewrite (Hrec _ _ H), (Hrec _ _ H0);trivial.
     (* ifb *)
    unfold is_true in H;rewrite !andb_true_iff in H;destruct H as [[H H0] H1].
    rewrite (Hrec _ _ H), (Hrec _ _ H0), (Hrec _ _ H1);trivial.
     (** opposite sign *)
    assert (Lit.is_pos l = negb (Lit.is_pos lf)).
    unfold Lit.is_pos.
    rewrite <- eqb_spec, land_comm in n0.
    change (~is_true (is_even (l lxor lf))) in n0.
    rewrite is_even_xor in n0.
    destruct (is_even l);destruct (is_even lf);trivial;elim n0;reflexivity.
    unfold Lit.interp;rewrite H. match goal with
                                  |- ?P -> _ =>
                                  assert (W:P -> Var.interp interp_var (Lit.blit l) = negb (Var.interp interp_var (Lit.blit lf)));
                                    [ | intros;rewrite W;trivial]
                                end.
    unfold Var.interp;rewrite !wf_interp_form;trivial.
    destruct (get_form (Lit.blit l));try discriminate.
    destruct (get_form (Lit.blit lf));try discriminate.
    apply check_neg_atom_correct.
    rewrite negb_involutive;destruct (Lit.is_pos lf);trivial.
  Qed.

  Hypothesis Hwf: Valuation.wf interp_var.

  Lemma valid_check_flatten : forall s, S.valid interp_var s ->
    forall cid lf, C.valid interp_var (check_flatten s cid lf).
  Proof.
    unfold check_flatten; intros s Hs cid lf; case_eq (S.get s cid).
    intros; apply C.interp_true; auto.
    intros i [ |l q] Heq; try apply C.interp_true; auto; case_eq (check_flatten_aux i lf); intro Heq2; try apply C.interp_true; auto; unfold C.valid; simpl; rewrite <- (check_flatten_aux_correct _ _ Heq2); unfold S.valid in Hs; generalize (Hs cid); rewrite Heq; auto.
  Qed.

End FLATTEN.


(* see comment on answer https://stackoverflow.com/a/53549978/4084567 *)

Section Example.
  Context (A:Type).
  Parameter P Q: A -> Prop.
  Definition filter {a} : P a -> A := fun Pa => a.

  Lemma my_lemma:
    forall a b, Q b -> (Q b -> P a) ->
           exists a (H: P a), P (filter H).
  Proof.
    intros ?? H H0.
    do 2 eexists.
    unshelve instantiate (1 := _).
    eauto.
    auto.
  Qed.
End Example.


Require Import FP.Structures.Comonad.
Require Import FP.Data.Function.
Require Import FP.Data.Identity.
Require Import FP.Data.Susp.
Require Import FP.Structures.Monad.
Require Import FP.Structures.MonadState.
Require Import FP.Structures.Counit.
Require Import FP.Structures.Comonad.
Require Import FP.Data.Cont.
Require Import FP.Structures.MonadCont.
Require Import FP.Structures.MonadState.

Import FunctionNotation.
Import SuspNotation.
Import MonadNotation.

Class Peano T :=
  { pzero : T
  ; psucc : T -> T
  ; coloopr : forall {m} {M:Comonad m} {A}, (m A -> A) -> m A -> T -> A
  ; coloopl : forall {m} {M:Comonad m} {A}, (m A -> A) -> m A -> T -> A
  }.

Section pinc.
  Context {m} {Monad_:Monad m} {T} {Peano_:Peano T} {MState_:MState T m}.
  Definition pinc : m T :=
    p <- get ;;
    modify psucc ;;
    ret p.
End pinc.

Definition Coloop m T {A} := (m A -> A) -> m A -> T -> A.

Definition mk_loop {T A} (coloop:Coloop identity T) (f:A -> A) (a:A) : T -> A :=
  coloop (f '.' run_identity) (Identity a).

Definition mk_mloop {m} {M:Monad m} {T A}
    (coloop:Coloop identity T) (f:A -> m A) (a:A) : T -> m A :=
  mk_loop coloop (extend f) (ret a).

Definition mk_lazyloop {T A}
    (coloop:Coloop susp T) (f:forall {C}, (C -> A) -> C -> A) (a:A) : T -> A :=
  coloop (fun (aM:susp A) => f coret aM) (delay | a).

Definition loopr {T} {P:Peano T} {A}
  : (A -> A) -> A -> T -> A := mk_loop coloopr.

Definition miterr {T} {P:Peano T} {m} {M:Monad m} {A}
  : (A -> m A) -> A -> T -> m A := mk_mloop coloopr.

Definition lazyiterr {T} {P:Peano T} {A}
  : (forall {C}, (C -> A) -> C -> A) -> A -> T -> A := mk_lazyloop coloopr.

Definition loopr_fix {T} {P:Peano T} {A B} (ff:(A -> option B) -> A -> option B)
    : T -> A -> option B :=
  lazyiterr (fun _ k l => ff $ fun a => k l a) (const None).

Definition loopr_mfix {m} {M:Monad m} {T} {P:Peano T} {A B}
    (ff:(A -> m (option B)) -> A -> m (option B)) : T -> A -> m (option B) :=
  lazyiterr (fun _ k l => ff $ fun a => k l a) (const $ ret None).

Definition loopl {T} {P:Peano T} {A}
  : (A -> A) -> A -> T -> A := mk_loop coloopl.

Definition mloopl {T} {P:Peano T} {m} {M:Monad m} {A}
  : (A -> m A) -> A -> T -> m A := mk_mloop coloopl.

Definition lazyloopl {T} {P:Peano T} {A}
  : (forall {C}, (C -> A) -> C -> A) -> A -> T -> A := mk_lazyloop coloopl.


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

From Undecidability.Shared.Libs.DLW
  Require Import utils_tac.

Require Import Undecidability.Synthetic.Undecidability.

From Undecidability.ILL
  Require Import EILL ILL CLL ILL_undec EILL_CLL ILL_CLL.

Import UndecidabilityNotations.

(* Undecidability results *)

Local Hint Resolve rILL_rCLL_cf_PROVABILITY
                   EILL_CLL_cf_PROVABILITY
                 : core.

(* (!,&,-o) only fragment of CLL without cut *)

Theorem rCLL_cf_undec : undecidable rCLL_cf_PROVABILITY.
Proof. undec from rILL_cf_undec; auto. Qed.

(* full CLL without cut *)

Theorem CLL_cf_undec : undecidable CLL_cf_PROVABILITY.
Proof. undec from EILL_undec; auto. Qed.


(** The second layer of the construction of the bicategory of strict pseudofunctors consists of three parts.
    Third part: we add a 2-cell witnessing the strict preservation of composition.
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.

Local Open Scope cat.

Section StrictCompositor.
  Variable (C D : bicat).

  Definition strict_compositor_disp_cat_data
    : disp_cat_ob_mor (map1cells C D).
  Proof.
    use tpair.
    - exact (λ F,
             ∏ (X Y Z : C) (f : X --> Y) (g : Y --> Z),
             Fmor F f · Fmor F g = Fmor F (f · g)).
    - exact (λ F G Fcomp Gcomp η,
             ∏ (X Y Z : C) (f : X --> Y) (g : Y --> Z),
             (ηobj η X ◃ idtoiso_2_1 _ _ (Gcomp X Y Z f g))
               • ηmor η (f · g)
             =
             (lassociator (ηobj η X) (Fmor G f) (Fmor G g))
               • (ηmor η f ▹ (Fmor G g))
               • rassociator (Fmor F f) (ηobj η Y) (Fmor G g)
               • (Fmor F f ◃ ηmor η g)
               • lassociator (Fmor F f) (Fmor F g) (ηobj η Z)
               • (idtoiso_2_1 _ _ (Fcomp X Y Z f g) ▹ ηobj η Z)).
  Defined.

  Definition strict_compositor_disp_cat_id_comp
    : disp_cat_id_comp (map1cells C D) strict_compositor_disp_cat_data.
  Proof.
    split.
    - intros F Fcomp X Y Z f g ; cbn in *.
      rewrite <- rwhisker_vcomp.
      rewrite !vassocr.
      rewrite vcomp_lunitor.
      rewrite lunitor_triangle.
      rewrite !vassocl.
      apply maponpaths.
      rewrite <- lwhisker_vcomp.
      rewrite !vassocl.
      rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)).
      rewrite lwhisker_hcomp.
      rewrite triangle_l.
      rewrite <- rwhisker_hcomp.
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite rinvunitor_runitor, id2_rwhisker, id2_left.
      rewrite rinvunitor_triangle.
      rewrite rinvunitor_natural.
      rewrite <- rwhisker_hcomp.
      reflexivity.
    - intros F₁ F₂ F₃ η ε Fcomp₁ Fcomp₂ Fcomp₃ ηcomp εcomp X Y Z f g ; cbn in *.
      specialize (ηcomp X Y Z f g).
      specialize (εcomp X Y Z f g).
      rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp.
      etrans.
      {
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)).
        rewrite lwhisker_vcomp.
        apply maponpaths.
        do 3 apply maponpaths_2.
        apply maponpaths.
        apply εcomp.
      }
      clear εcomp.
      use vcomp_move_R_pM.
      { is_iso. }
      cbn.
      etrans.
      {
        rewrite <- !lwhisker_vcomp.
        rewrite !vassocl.
        do 5 (apply maponpaths).
        rewrite !vassocr.
        rewrite rwhisker_lwhisker.
        apply maponpaths_2.
        rewrite !vassocl.
        apply maponpaths.
        rewrite rwhisker_vcomp.
        apply maponpaths.
        apply ηcomp.
      }
      clear ηcomp.
      rewrite !vassocl.
      symmetry.
      etrans.
      {
        rewrite !vassocr.
        do 12 (apply maponpaths_2).
        rewrite rwhisker_hcomp.
        rewrite !vassocl, <- pentagon_2.
        rewrite <- lwhisker_hcomp.
        reflexivity.
      }
      rewrite !vassocl.
      apply maponpaths.
      etrans.
      {
        rewrite !vassocr.
        do 11 (apply maponpaths_2).
        symmetry.
        apply rwhisker_lwhisker.
      }
      rewrite !vassocl.
      apply maponpaths.
      use vcomp_move_L_pM.
      { is_iso. }
      cbn.
      etrans.
      {
        rewrite !vassocr.
        do 10 (apply maponpaths_2).
        rewrite !vassocl.
        rewrite lwhisker_hcomp, rwhisker_hcomp.
        symmetry.
        apply pentagon.
      }
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      symmetry.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        do 6 apply (maponpaths_2).
        rewrite vassocl.
        symmetry.
        rewrite lwhisker_hcomp, rwhisker_hcomp.
        apply pentagon.
      }
      etrans.
      {
        rewrite !vassocr.
        rewrite lwhisker_lwhisker.
        rewrite !vassocl.
        reflexivity.
      }
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        do 5 (apply maponpaths_2).
        rewrite rwhisker_rwhisker.
        reflexivity.
      }
      rewrite !vassocl.
      symmetry.
      etrans.
      {
        rewrite !vassocr.
        do 9 (apply maponpaths_2).
        apply rwhisker_rwhisker.
      }
      etrans.
      {
        do 7 (apply maponpaths_2).
        rewrite !vassocl.
        apply maponpaths.
        rewrite rwhisker_hcomp.
        rewrite <- inverse_pentagon_4.
        rewrite <- lwhisker_hcomp.
        reflexivity.
      }
      etrans.
      {
        do 6 (apply maponpaths_2).
        rewrite !vassocl.
        rewrite lwhisker_vcomp.
        rewrite lassociator_rassociator, lwhisker_id2, id2_right.
        reflexivity.
      }
      symmetry.
      etrans.
      {
        rewrite !vassocr.
        rewrite <- vcomp_whisker.
        reflexivity.
      }
      rewrite !vassocl.
      apply maponpaths.
      symmetry.
      etrans.
      {
        rewrite !vassocr.
        rewrite lwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        reflexivity.
      }
      apply maponpaths.
      use vcomp_move_L_pM.
      { is_iso. }
      cbn.
      etrans.
      {
        rewrite !vassocr.
        do 4 (apply maponpaths_2).
        rewrite inverse_pentagon.
        rewrite <- lwhisker_hcomp, <- rwhisker_hcomp.
        rewrite !vassocl.
        rewrite lwhisker_vcomp.
        rewrite rassociator_lassociator, lwhisker_id2, id2_right.
        reflexivity.
      }
      rewrite !vassocl.
      apply maponpaths.
      etrans.
      {
        rewrite !vassocr.
        rewrite rwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        apply maponpaths_2.
        rewrite !vassocl.
        symmetry.
        apply inverse_pentagon_2.
      }
      rewrite !vassocl, <- rwhisker_hcomp.
      do 2 apply maponpaths.
      symmetry.
      apply rwhisker_rwhisker_alt.
  Qed.

  Definition strict_compositor_disp_cat
    : disp_bicat (map1cells C D).
  Proof.
    use disp_cell_unit_bicat.
    use tpair.
    - exact strict_compositor_disp_cat_data.
    - exact strict_compositor_disp_cat_id_comp.
  Defined.

  Definition strict_compositor_is_disp_univalent_2_1
    : disp_univalent_2_1 strict_compositor_disp_cat.
  Proof.
    apply disp_cell_unit_bicat_univalent_2_1.
    intros F G η Fcomp Gcomp ; simpl in *.
    repeat (apply impred ; intro).
    apply D.
  Defined.

  Definition strict_compositor_is_disp_univalent_2_0
             (HD_2_1 : is_univalent_2_1 D)
    : disp_univalent_2_0 strict_compositor_disp_cat.
  Proof.
    use disp_cell_unit_bicat_univalent_2_0.
    - apply map1cells_is_univalent_2_1.
      exact HD_2_1.
    - intros ; simpl.
      repeat (apply impred ; intro).
      apply D.
    - intro ; cbn.
      repeat (apply impred_isaset ; intro).
      exact (univalent_bicategory_1_cell_hlevel_3 D HD_2_1 _ _ _ _).
    - intros F F₂ F₂' η ; cbn in *.
      induction η as [η₁ η₂].
      apply funextsec ; intro X.
      apply funextsec ; intro Y.
      apply funextsec ; intro Z.
      apply funextsec ; intro f.
      apply funextsec ; intro g.
      specialize (η₁ X Y Z f g).
      specialize (η₂ X Y Z f g).
      rewrite !vassocr in η₁.
      rewrite vcomp_lunitor in η₁.
      rewrite !vassocl in η₁.
      rewrite rinvunitor_natural in η₁.
      rewrite <- rwhisker_hcomp in η₁.
      rewrite !vassocr in η₁.
      assert (pr1 (idtoiso_2_1 _ _ (F₂ X Y Z f g))
              = pr1 (idtoiso_2_1 _ _ (F₂' X Y Z f g))) as H.
      {
        apply rwhisker_id_inj.
        use (vcomp_lcancel (lunitor _ • rinvunitor _)).
        { is_iso. }
        refine (_ @ !η₁).
        rewrite <- !rwhisker_vcomp.
        rewrite !vassocr.
        rewrite lunitor_triangle.
        apply maponpaths_2.
        rewrite !vassocl.
        apply maponpaths.
        rewrite <- rinvunitor_triangle.
        rewrite !vassocr.
        apply maponpaths_2.
        rewrite !vassocl.
        rewrite <- lwhisker_vcomp.
        rewrite !vassocr.
        rewrite lwhisker_hcomp, rwhisker_hcomp.
        rewrite <- triangle_r_inv.
        rewrite <- !lwhisker_hcomp.
        rewrite lwhisker_vcomp.
        rewrite linvunitor_lunitor, lwhisker_id2, id2_left.
        reflexivity.
      }
      assert (isotoid_2_1 HD_2_1 (idtoiso_2_1 _ _ (F₂ X Y Z f g))
              =
              isotoid_2_1 HD_2_1 (idtoiso_2_1 _ _ (F₂' X Y Z f g))) as H'.
      {
        apply maponpaths.
        apply subtypePath.
        { intro ; apply isaprop_is_invertible_2cell. }
        exact H.
      }
      refine (!_ @ H' @ _).
      + apply (homotinvweqweq (make_weq (idtoiso_2_1 _ _)
                                        (HD_2_1 _ _ _ _))).
      + apply (homotinvweqweq (make_weq (idtoiso_2_1 _ _)
                                        (HD_2_1 _ _ _ _))).
  Defined.

  Definition strict_compositor_is_disp_univalent_2
             (HD_2_1 : is_univalent_2_1 D)
    : disp_univalent_2 strict_compositor_disp_cat.
  Proof.
    split.
    - apply strict_compositor_is_disp_univalent_2_0; assumption.
    - exact strict_compositor_is_disp_univalent_2_1.
  Defined.
End StrictCompositor.


(** ** The equivalent of [pointwise_relation], but for [list]. *)
Require Import Ssreflect.ssreflect Ssreflect.seq.
Require Import Coq.Lists.List Coq.Classes.Morphisms.
Require Import Coq.Program.Basics.
Require Import Coq.Program.Tactics.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Setoids.Setoid.

(** Element-wise lifting *)
Fixpoint elementwise_relation {A} (R : relation A) (ls1 ls2 : list A) {struct ls1} : Prop
  := match ls1, ls2 with
       | nil, nil => True
       | _, nil => False
       | nil, _ => False
       | x::xs, y::ys => R x y /\ elementwise_relation R xs ys
     end.

Local Ltac list_rel_t' :=
  idtac;
  match goal with
    | _ => solve [ eauto ]
    | [ |- forall ls : Ssreflect.seq.seq ?T, _ ] => let ls := fresh "ls" in intro ls; induction ls
    | [ |- forall ls : list ?T, _ ] => let ls := fresh "ls" in intro ls; induction ls
    | [ H : _ /\ _ |- _ ] => destruct H
    | [ |- _ /\ _ ] => split
    | _ => progress hnf
    | _ => progress simpl in *
    | _ => progress unfold subrelation, impl, predicate_implication, respectful in *
    | _ => intro
    | [ H : False |- _ ] => solve [ destruct H ]
    | _ => solve [ etransitivity; eauto ]
  end.
Local Ltac list_rel_t := repeat list_rel_t'.

Local Obligation Tactic := list_rel_t.

Global Program Instance elementwise_subrelation {A} {R R'} `(sub : subrelation A R R')
: subrelation (elementwise_relation R) (elementwise_relation R') | 4.

Typeclasses Opaque elementwise_relation.
Arguments elementwise_relation A%type R%signature (_ _)%SEQ : clear implicits.

Program Instance elementwise_reflexive {A R} `{@Reflexive A R} : Reflexive (elementwise_relation A R).
Program Instance elementwise_symmetric {A R} `{@Symmetric A R} : Symmetric (elementwise_relation A R).
Program Instance elementwise_transitive {A R} `{@Transitive A R} : Transitive (elementwise_relation A R).
Program Instance elementwise_equivalence {A R} `{@Equivalence A R} : Equivalence (elementwise_relation A R).

Add Parametric Morphism A B R R' : (@List.map A B)
with signature (R ==> R') ==> elementwise_relation _ R ==> elementwise_relation _ R'
  as map_elementwise_mor.
Proof. list_rel_t. Qed.

Add Parametric Morphism A B R : (@List.map A B)
with signature (pointwise_relation _ R) ==> @eq (list A) ==> elementwise_relation _ R
  as map_elementwise_pointwise_mor.
Proof. list_rel_t. Qed.

Add Parametric Morphism A B R R' : (@Ssreflect.seq.map A B)
with signature (R ==> R') ==> elementwise_relation _ R ==> elementwise_relation _ R'
  as srrmap_elementwise_mor.
Proof. list_rel_t. Qed.

Add Parametric Morphism A B R : (@Ssreflect.seq.map A B)
with signature (pointwise_relation _ R) ==> @eq (list A) ==> elementwise_relation _ R
  as ssrmap_elementwise_pointwise_mor.
Proof. list_rel_t. Qed.

Add Parametric Morphism A B R R' : (@fold_left A B)
with signature (R ==> R' ==> R) ==> elementwise_relation B R' ==> R ==> R
  as fold_left_mor.
Proof. list_rel_t. Qed.

Add Parametric Morphism A B R R' : (@fold_right A B)
with signature (R' ==> R ==> R) ==> R ==> elementwise_relation B R' ==> R
  as fold_right_mor.
Proof. list_rel_t. Qed.

Add Parametric Morphism A B R R' : (@foldl A B)
with signature (R ==> R' ==> R) ==> R ==> elementwise_relation A R' ==> R
  as foldl_mor.
Proof. intros f g H x y H' ls1 ls2; revert ls1 ls2 x y H'. list_rel_t. Qed.

Add Parametric Morphism A B R R' : (@foldr A B)
with signature (R' ==> R ==> R) ==> R ==> elementwise_relation A R' ==> R
  as foldr_mor.
Proof. intros f g H x y H' ls1 ls2; revert ls1 ls2 x y H'. list_rel_t. Qed.