(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Correctness proof for constant propagation (processor-dependent part). *)

Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Events.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import ConstpropOp.
Require Import Constprop.

(** * Correctness of the static analysis *)

Section ANALYSIS.

Variable ge: genv.
Variable sp: val.

(** We first show that the dataflow analysis is correct with respect
  to the dynamic semantics: the approximations (sets of values)
  of a register at a program point predicted by the static analysis
  are a superset of the values actually encountered during concrete
  executions.  We formalize this correspondence between run-time values and
  compile-time approximations by the following predicate. *)

Definition val_match_approx (a: approx) (v: val) : Prop :=
  match a with
  | Unknown => True
  | I p => v = Vint p
  | F p => v = Vfloat p
  | L p => v = Vlong p
  | G symb ofs => v = symbol_address ge symb ofs
  | S ofs => v = Val.add sp (Vint ofs)
  | _ => False
  end.

Inductive val_list_match_approx: list approx -> list val -> Prop :=
  | vlma_nil:
      val_list_match_approx nil nil
  | vlma_cons:
      forall a al v vl,
      val_match_approx a v ->
      val_list_match_approx al vl ->
      val_list_match_approx (a :: al) (v :: vl).

Ltac SimplVMA :=
  match goal with
  | H: (val_match_approx (I _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (F _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (L _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (G _ _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (S _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | _ =>
      idtac
  end.

Ltac InvVLMA :=
  match goal with
  | H: (val_list_match_approx nil ?vl) |- _ =>
      inv H
  | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ =>
      inv H; SimplVMA; InvVLMA
  | _ =>
      idtac
  end.

(** We then show that [eval_static_operation] is a correct abstract
  interpretations of [eval_operation]: if the concrete arguments match
  the given approximations, the concrete results match the
  approximations returned by [eval_static_operation]. *)

Lemma eval_static_condition_correct:
  forall cond al vl m b,
  val_list_match_approx al vl ->
  eval_static_condition cond al = Some b ->
  eval_condition cond vl m = Some b.
Proof.
  intros until b.
  unfold eval_static_condition.
  case (eval_static_condition_match cond al); intros;
  InvVLMA; simpl; congruence.
Qed.

Remark shift_symbol_address:
  forall symb ofs n,
  symbol_address ge symb (Int.add ofs n) = Val.add (symbol_address ge symb ofs) (Vint n).
Proof.
  unfold symbol_address; intros. destruct (Genv.find_symbol ge symb); auto.
Qed.

Lemma eval_static_operation_correct:
  forall op al vl m v,
  val_list_match_approx al vl ->
  eval_operation ge sp op vl m = Some v ->
  val_match_approx (eval_static_operation op al) v.
Proof.
  intros until v.
  unfold eval_static_operation.
  case (eval_static_operation_match op al); intros;
  InvVLMA; simpl in *; FuncInv; try subst v; auto.

  destruct (propagate_float_constants tt); simpl; auto.

  rewrite shift_symbol_address; auto.

  rewrite Int.add_commut. rewrite shift_symbol_address. rewrite Val.add_commut. auto.

  rewrite Int.add_commut; auto.

  rewrite Val.add_assoc. rewrite Int.add_commut. auto.

  change (Val.add (Vint n1) (Val.add sp (Vint n2)) = Val.add sp (Vint (Int.add n1 n2))).
  rewrite Val.add_permut. auto.

  rewrite shift_symbol_address; auto.

  rewrite Val.add_assoc; auto.

  unfold symbol_address. destruct (Genv.find_symbol ge s1); auto.

  rewrite Val.sub_add_opp. rewrite Val.add_assoc. simpl. rewrite Int.sub_add_opp. auto.

  destruct (Int.eq n2 Int.zero). inv H0.
  destruct (Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); inv H0; simpl; auto.
  destruct (Int.eq n2 Int.zero); inv H0; simpl; auto.

  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.
  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.
  destruct (Int.ltu n Int.iwordsize); simpl; auto.
  destruct (Int.ltu n (Int.repr 31)); inv H0. simpl; auto.
  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.

  unfold eval_static_intoffloat. destruct (Float.intoffloat n1); simpl in H0; inv H0.
  simpl; auto.

  destruct (propagate_float_constants tt); simpl; auto.

  unfold eval_static_condition_val, Val.of_optbool.
  destruct (eval_static_condition c vl0) eqn:?.
  rewrite (eval_static_condition_correct _ _ _ m _ H Heqo).
  destruct b; simpl; auto.
  simpl; auto.
Qed.

Lemma eval_static_addressing_correct:
  forall addr al vl v,
  val_list_match_approx al vl ->
  eval_addressing ge sp addr vl = Some v ->
  val_match_approx (eval_static_addressing addr al) v.
Proof.
  intros until v. unfold eval_static_addressing.
  case (eval_static_addressing_match addr al); intros;
  InvVLMA; simpl in *; FuncInv; try subst v; auto.
  rewrite shift_symbol_address; auto.
  rewrite Val.add_assoc. auto.
  repeat rewrite shift_symbol_address. auto.
  fold (Val.add (Vint n1) (symbol_address ge id ofs)).
  repeat rewrite shift_symbol_address. apply Val.add_commut.
  repeat rewrite Val.add_assoc. auto.
  fold (Val.add (Vint n1) (Val.add sp (Vint ofs))).
  rewrite Val.add_permut. decEq. rewrite Val.add_commut. auto.
  rewrite shift_symbol_address. auto.
Qed.

(** * Correctness of strength reduction *)

(** We now show that strength reduction over operators and addressing
  modes preserve semantics: the strength-reduced operations and
  addressings evaluate to the same values as the original ones if the
  actual arguments match the static approximations used for strength
  reduction. *)

Section STRENGTH_REDUCTION.

Variable app: D.t.
Variable rs: regset.
Variable m: mem.
Hypothesis MATCH: forall r, val_match_approx (approx_reg app r) rs#r.

Ltac InvApproxRegs :=
  match goal with
  | [ H: _ :: _ = _ :: _ |- _ ] =>
        injection H; clear H; intros; InvApproxRegs
  | [ H: ?v = approx_reg app ?r |- _ ] =>
        generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs
  | _ => idtac
  end.

Lemma cond_strength_reduction_correct:
  forall cond args vl,
  vl = approx_regs app args ->
  let (cond', args') := cond_strength_reduction cond args vl in
  eval_condition cond' rs##args' m = eval_condition cond rs##args m.
Proof.
  intros until vl. unfold cond_strength_reduction.
  case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVMA.
  rewrite H0. apply Val.swap_cmp_bool.
  rewrite H. auto.
  rewrite H0. apply Val.swap_cmpu_bool.
  rewrite H. auto.
  auto.
Qed.

Lemma make_addimm_correct:
  forall n r,
  let (op, args) := make_addimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.add rs#r (Vint n)) v.
Proof.
  intros. unfold make_addimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst. exists (rs#r); split; auto. destruct (rs#r); simpl; auto; rewrite Int.add_zero; auto.
  exists (Val.add rs#r (Vint n)); auto.
Qed.

Lemma make_shlimm_correct:
  forall n r1 r2,
  rs#r2 = Vint n ->
  let (op, args) := make_shlimm n r1 r2 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shl rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shlimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shl_zero. auto.
  destruct (Int.ltu n Int.iwordsize) eqn:?; intros.
  rewrite Val.shl_rolm; auto. econstructor; split; eauto. auto.
  econstructor; split; eauto. simpl. congruence.
Qed.

Lemma make_shrimm_correct:
  forall n r1 r2,
  rs#r2 = Vint n ->
  let (op, args) := make_shrimm n r1 r2 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shr rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shrimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shr_zero. auto.
  destruct (Int.ltu n Int.iwordsize) eqn:?.
  econstructor; split; eauto. simpl. auto.
  econstructor; split; eauto. simpl. congruence.
Qed.

Lemma make_shruimm_correct:
  forall n r1 r2,
  rs#r2 = Vint n ->
  let (op, args) := make_shruimm n r1 r2 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shru rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shruimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shru_zero. auto.
  destruct (Int.ltu n Int.iwordsize) eqn:?; intros.
  rewrite Val.shru_rolm; auto. econstructor; split; eauto. auto.
  econstructor; split; eauto. simpl. congruence.
Qed.

Lemma make_mulimm_correct:
  forall n r1 r2,
  rs#r2 = Vint n ->
  let (op, args) := make_mulimm n r1 r2 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mul rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_mulimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (Vint Int.zero); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.one; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_one; auto.
  destruct (Int.is_power2 n) eqn:?; intros.
  rewrite (Val.mul_pow2 rs#r1 _ _ Heqo). rewrite Val.shl_rolm.
  econstructor; split; eauto. auto.
  eapply Int.is_power2_range; eauto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_divimm_correct:
  forall n r1 r2 v,
  Val.divs rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_divimm n r1 r2 in
  exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divimm.
  destruct (Int.is_power2 n) eqn:?.
  destruct (Int.ltu i (Int.repr 31)) eqn:?.
  exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence.
  exists v; auto.
  exists v; auto.
Qed.

Lemma make_divuimm_correct:
  forall n r1 r2 v,
  Val.divu rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_divuimm n r1 r2 in
  exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divuimm.
  destruct (Int.is_power2 n) eqn:?.
  econstructor; split. simpl; eauto.
  exploit Int.is_power2_range; eauto. intros RANGE.
  rewrite <- Val.shru_rolm; auto. rewrite H0 in H.
  destruct (rs#r1); simpl in *; inv H.
  destruct (Int.eq n Int.zero); inv H2.
  rewrite RANGE. rewrite (Int.divu_pow2 i0 _ _ Heqo). auto.
  exists v; auto.
Qed.

Lemma make_andimm_correct:
  forall n r,
  let (op, args) := make_andimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.and rs#r (Vint n)) v.
Proof.
  intros; unfold make_andimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (Vint Int.zero); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.mone; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_mone; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_orimm_correct:
  forall n r,
  let (op, args) := make_orimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.or rs#r (Vint n)) v.
Proof.
  intros; unfold make_orimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.mone; intros.
  subst n. exists (Vint Int.mone); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_mone; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_xorimm_correct:
  forall n r,
  let (op, args) := make_xorimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.xor rs#r (Vint n)) v.
Proof.
  intros; unfold make_xorimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.xor_zero; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma op_strength_reduction_correct:
  forall op args vl v,
  vl = approx_regs app args ->
  eval_operation ge sp op rs##args m = Some v ->
  let (op', args') := op_strength_reduction op args vl in
  exists w, eval_operation ge sp op' rs##args' m = Some w /\ Val.lessdef v w.
Proof.
  intros until v; unfold op_strength_reduction;
  case (op_strength_reduction_match op args vl); simpl; intros.
(* add *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.add_commut. apply make_addimm_correct.
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_addimm_correct.
(* sub *)
  InvApproxRegs; SimplVMA. inv H0. rewrite H1. econstructor; split; eauto.
  InvApproxRegs; SimplVMA. inv H0. rewrite H. rewrite Val.sub_add_opp. apply make_addimm_correct.
(* mul *)
  InvApproxRegs; SimplVMA. inv H0. rewrite H1. rewrite Val.mul_commut. apply make_mulimm_correct; auto.
  InvApproxRegs; SimplVMA. inv H0. rewrite H. apply make_mulimm_correct; auto.
(* divs *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
  apply make_divimm_correct; auto.
(* divu *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
  apply make_divuimm_correct; auto.
(* and *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.and_commut. apply make_andimm_correct.
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_andimm_correct.
(* or *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.or_commut. apply make_orimm_correct.
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_orimm_correct.
(* xor *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.xor_commut. apply make_xorimm_correct.
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_xorimm_correct.
(* shl *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_shlimm_correct; auto.
(* shr *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_shrimm_correct; auto.
(* shru *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_shruimm_correct; auto.
(* cmp *)
  generalize (cond_strength_reduction_correct c args0 vl0).
  destruct (cond_strength_reduction c args0 vl0) as [c' args']; intros.
  rewrite <- H1 in H0; auto. econstructor; split; eauto.
(* default *)
  exists v; auto.
Qed.

Lemma addr_strength_reduction_correct:
  forall addr args vl,
  vl = approx_regs app args ->
  let (addr', args') := addr_strength_reduction addr args vl in
  eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args.
Proof.
  intros until vl. unfold addr_strength_reduction.
  destruct (addr_strength_reduction_match addr args vl); simpl; intros; InvApproxRegs; SimplVMA.
  rewrite H; rewrite H0. rewrite shift_symbol_address. auto.
  rewrite H; rewrite H0. rewrite Int.add_commut. rewrite shift_symbol_address. rewrite Val.add_commut; auto.
  rewrite H; rewrite H0. rewrite Val.add_assoc; auto.
  rewrite H; rewrite H0. rewrite Val.add_permut; auto.
  rewrite H0. auto.
  rewrite H. rewrite Val.add_commut. auto.
  rewrite H0. rewrite Val.add_commut; auto.
  rewrite H; auto.
  rewrite H. rewrite shift_symbol_address. auto.
  rewrite H. rewrite shift_symbol_address. auto.
  rewrite H. rewrite Val.add_assoc. auto.
  auto.
Qed.

End STRENGTH_REDUCTION.

End ANALYSIS.


Require Import Algebra.Monad.Utils Algebra.SetoidCat SetoidUtils Algebra.Functor Algebra.Applicative Tactics Algebra.SetoidCat.PairUtils Algebra.Monad.

Require Import RelationClasses Relation_Definitions Morphisms SetoidClass.

Open Scope type_scope.

Section Instances.
Instance monadFunctor  {m mS} {mnd : @Monad m mS} : @Functor m mS.
Proof.
  exists (@monad_fmap m mS mnd).
  intros. simpl. arrequiv. normalize_monad. bindproper. simpl. arrequiv. unfold comp. rewrite left_unit. simpl. reflexivity.
  intros. simpl. arrequiv. rewrite right_unit_equiv. reflexivity. simpl. arrequiv.
Defined.

End Instances.


(** Commutation of groupoid quotient with sums *)
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.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Groupoids.

Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.

Require Import signature.hit_signature.
Require Import prelude.all.
Require Import algebra.one_types_polynomials.
Require Import algebra.groupoid_polynomials.

Local Open Scope cat.

Opaque comp_psfunctor.

Definition gquot_inl_grpd
           {P₁ P₂ : poly_code}
           {G : groupoid}
  : gquot (poly_act_groupoid P₁ G) → gquot (poly_act_groupoid (P₁ + P₂) G).
Proof.
  use gquot_rec.
  - exact (λ z, gcl (poly_act_groupoid (P₁ + P₂) G) (inl z)).
  - exact (λ a₁ a₂ g, @gcleq (poly_act_groupoid (P₁ + P₂) G) (inl a₁) (inl a₂) g).
  - exact (λ _, ge _ _).
  - exact (λ a₁ a₂ a₃ g₁ g₂,
           @gconcat
             (poly_act_groupoid (P₁ + P₂) G)
             (inl a₁) (inl a₂) (inl a₃) g₁ g₂).
  - apply gtrunc.
Defined.

Definition gquot_inr_grpd
           {P₁ P₂ : poly_code}
           {G : groupoid}
  : gquot (poly_act_groupoid P₂ G) → gquot (poly_act_groupoid (P₁ + P₂) G).
Proof.
  use gquot_rec.
  - exact (λ z, gcl (poly_act_groupoid (P₁ + P₂) G) (inr z)).
  - exact (λ a₁ a₂ g, @gcleq (poly_act_groupoid (P₁ + P₂) G) (inr a₁) (inr a₂) g).
  - exact (λ _, ge _ _).
  - exact (λ a₁ a₂ a₃ g₁ g₂,
           @gconcat
             (poly_act_groupoid (P₁ + P₂) G)
             (inr a₁) (inr a₂) (inr a₃) g₁ g₂).
  - apply gtrunc.
Defined.

Section GQuotSum.
  Context {P₁ P₂ : poly_code}
          (IHP₁ : pstrans
                    (comp_psfunctor (⟦ P₁ ⟧) gquot_psfunctor)
                    (comp_psfunctor gquot_psfunctor ⦃ P₁ ⦄))
          (IHP₂ : pstrans
                    (comp_psfunctor (⟦ P₂ ⟧) gquot_psfunctor)
                    (comp_psfunctor gquot_psfunctor ⦃ P₂ ⦄)).

  Definition sum_gquot_data_comp
             (X : grpd_bicat)
    : (comp_psfunctor (⟦ P₁ + P₂ ⟧) gquot_psfunctor) X
      -->
      (comp_psfunctor gquot_psfunctor ⦃ P₁ + P₂ ⦄) X.
  Proof.
    intro z.
    induction z as [z | z].
    - exact (gquot_inl_grpd (IHP₁ X z)).
    - exact (gquot_inr_grpd (IHP₂ X z)).
  Defined.

  Definition gquot_inl_grpd_gquot_functor
             {X Y : grpd_bicat}
             (f : X --> Y)
    : ∏ (z : gquot (⦃ P₁ ⦄ X)),
      # (comp_psfunctor gquot_psfunctor ⦃ P₁ + P₂ ⦄) f (gquot_inl_grpd z)
      =
      gquot_inl_grpd (gquot_functor_map (# ⦃ P₁ ⦄ f) z).
  Proof.
    use gquot_ind_set.
    - exact (λ _, idpath _).
    - abstract
        (intros a₁ a₂ g ;
         use map_PathOver ;
         refine (whisker_square
                   (idpath _)
                   _
                   _
                   (idpath _)
                   _) ;
           [ refine (!(!(maponpathscomp _ _ _) @ _)) ;
             refine (maponpaths
                       (maponpaths (gquot_functor_map (poly_act_functor (P₁ + P₂) f)))
                       (gquot_rec_beta_gcleq _ _ _ _ _ _ _ _ _ _) @ _) ;
             apply gquot_rec_beta_gcleq
           | refine (!(!(maponpathscomp _ _ _) @ _)) ;
             refine (maponpaths
                       (maponpaths gquot_inl_grpd)
                       (gquot_rec_beta_gcleq _ _ _ _ _ _ _ _ _ _) @ _) ;
             apply gquot_rec_beta_gcleq
           | apply vrefl]).
    - intro.
      exact (gtrunc _ _ _).
  Defined.

  Definition sum_gquot_data_nat_inl
             {X Y : grpd_bicat}
             (f : X --> Y)
             (z : ⟦ P₁ ⟧ (gquot_psfunctor X) : one_type)
    : # (comp_psfunctor gquot_psfunctor ⦃ P₁ + P₂ ⦄) f (gquot_inl_grpd (IHP₁ X z))
      =
      sum_gquot_data_comp Y (inl (# (⟦ P₁ ⟧) (gquot_functor_map f) z)).
  Proof.
    refine (_ @ maponpaths gquot_inl_grpd (pr1 (psnaturality_of IHP₁ f) z)).
    exact (gquot_inl_grpd_gquot_functor f (IHP₁ X z)).
  Defined.

  Definition gquot_inr_grpd_gquot_functor
             {X Y : grpd_bicat}
             (f : X --> Y)
    : ∏ (z : gquot (⦃ P₂ ⦄ X)),
      # (comp_psfunctor gquot_psfunctor ⦃ P₁ + P₂ ⦄) f (gquot_inr_grpd z)
      =
      gquot_inr_grpd (gquot_functor_map (# ⦃ P₂ ⦄ f) z).
  Proof.
    use gquot_ind_set.
    - exact (λ _, idpath _).
    - abstract
        (intros a₁ a₂ g ;
         use map_PathOver ;
         refine (whisker_square
                   (idpath _)
                   _
                   _
                   (idpath _)
                   _) ;
           [ refine (!(!(maponpathscomp _ _ _) @ _)) ;
             refine (maponpaths
                       (maponpaths (gquot_functor_map (poly_act_functor (P₁ + P₂) f)))
                       (gquot_rec_beta_gcleq _ _ _ _ _ _ _ _ _ _) @ _) ;
             apply gquot_rec_beta_gcleq
           | refine (!(!(maponpathscomp _ _ _) @ _)) ;
             refine (maponpaths
                       (maponpaths gquot_inr_grpd)
                       (gquot_rec_beta_gcleq _ _ _ _ _ _ _ _ _ _) @ _) ;
             apply gquot_rec_beta_gcleq
           | apply vrefl]).
    - intro.
      exact (gtrunc _ _ _).
  Defined.

  Definition sum_gquot_data_nat_inr
             {X Y : grpd_bicat}
             (f : X --> Y)
             (z : ⟦ P₂ ⟧ (gquot_psfunctor X) : one_type)
    : # (comp_psfunctor gquot_psfunctor ⦃ P₁ + P₂ ⦄) f (gquot_inr_grpd (IHP₂ X z))
      =
      sum_gquot_data_comp Y (inr (# (⟦ P₂ ⟧) (gquot_functor_map f) z)).
  Proof.
    refine (_ @ maponpaths gquot_inr_grpd (pr1 (psnaturality_of IHP₂ f) z)).
    exact (gquot_inr_grpd_gquot_functor f (IHP₂ X z)).
  Defined.

  Definition sum_gquot_data
    : pstrans_data
        (comp_psfunctor (⟦ P₁ + P₂ ⟧) gquot_psfunctor)
        (comp_psfunctor gquot_psfunctor ⦃ P₁ + P₂ ⦄).
  Proof.
    use make_pstrans_data.
    - exact sum_gquot_data_comp.
    - intros X Y f.
      use make_invertible_2cell.
      + intro z.
        induction z as [z | z].
        * exact (sum_gquot_data_nat_inl f z).
        * exact (sum_gquot_data_nat_inr f z).
      + apply one_type_2cell_iso.
  Defined.

  Definition sum_gquot_naturality_help_inl
             {X Y : grpd_bicat}
             {f g : grpd_bicat ⟦ X, Y ⟧}
             (p : f ==> g)
    : ∏ (z : gquot (⦃ P₁ ⦄ X)),
      (gquot_inl_grpd_gquot_functor f z)
        @ maponpaths
            gquot_inl_grpd
            (gquot_functor_cell
               (poly_act_nat_trans P₁ p) z)
      =
      (gquot_functor_cell
        (poly_act_nat_trans (P₁ + P₂) p) (gquot_inl_grpd z))
      @ gquot_inl_grpd_gquot_functor g z.
  Proof.
    use gquot_ind_prop.
    - intro a.
      refine (!_).
      refine (pathscomp0rid _ @ _).
      refine (!_).
      exact (gquot_rec_beta_gcleq _ _ _ _ _ _ _ _ _ (pr1 (## ⦃ P₁ ⦄ p) a)).
    - intro.
      exact (gtrunc _ _ _ _ _).
  Qed.

  Definition sum_gquot_naturality_help_inr
             {X Y : grpd_bicat}
             {f g : grpd_bicat ⟦ X, Y ⟧}
             (p : f ==> g)
    : ∏ (z : gquot (⦃ P₂ ⦄ X)),
      (gquot_inr_grpd_gquot_functor f z)
        @ maponpaths gquot_inr_grpd
            (gquot_functor_cell
               (poly_act_nat_trans P₂ p) z)
      =
      gquot_functor_cell
        (poly_act_nat_trans (P₁ + P₂) p) (gquot_inr_grpd z)
      @ gquot_inr_grpd_gquot_functor g z.
    Proof.
    use gquot_ind_prop.
    - intro a.
      refine (!_).
      refine (pathscomp0rid _ @ _).
      refine (!_).
      exact (gquot_rec_beta_gcleq _ _ _ _ _ _ _ _ _ (pr1 (## ⦃ P₂ ⦄ p) a)).
    - intro.
      exact (gtrunc _ _ _ _ _).
  Qed.

  Definition sum_gquot_id_help_inl
             {X : grpd_bicat}
    : ∏ z,
      maponpaths
        gquot_inl_grpd
        ((pr122 (pr1 (comp_psfunctor gquot_psfunctor ⦃ P₁ ⦄))) X z)
      =
      (pr122 (pr1 (comp_psfunctor gquot_psfunctor ⦃ P₁ + P₂ ⦄)))
        X (gquot_inl_grpd z)
        @ gquot_inl_grpd_gquot_functor (id₁ X) z.
  Proof.
    use gquot_ind_prop.
    - intro a.
      refine (!_).
      refine (pathscomp0rid _ @ _).
      refine (!_).
      exact (gquot_rec_beta_gcleq _ _ _ _ _ _ _ _ _ (pr1 (pr122 (pr1 ⦃ P₁⦄) X) a)).
    - intro.
      exact (gtrunc _ _ _ _ _).
  Qed.

  Definition sum_gquot_id_help_inr
             {X : grpd_bicat}
    : ∏ z,
      maponpaths
        gquot_inr_grpd
        ((pr122 (pr1 (comp_psfunctor gquot_psfunctor ⦃ P₂ ⦄))) X z)
      =
      (pr122 (pr1 (comp_psfunctor gquot_psfunctor ⦃ P₁ + P₂ ⦄)))
        X (gquot_inr_grpd z)
        @ gquot_inr_grpd_gquot_functor (id₁ X) z.
  Proof.
    use gquot_ind_prop.
    - intro a.
      refine (!_).
      refine (pathscomp0rid _ @ _).
      refine (!_).
      exact (gquot_rec_beta_gcleq _ _ _ _ _ _ _ _ _ (pr1 (pr122 (pr1 ⦃ P₂ ⦄) X) a)).
    - intro.
      exact (gtrunc _ _ _ _ _).
  Qed.

  Definition sum_gquot_pstrans_comp_inl_help
             {X Y Z : grpd_bicat}
             (f : X --> Y) (g : Y --> Z)
             {x y : gquot (⦃ P₁ ⦄ Y)}
             (p : x = y)
    : maponpaths
        (gquot_functor_map (# ⦃ P₁ + P₂ ⦄ g))
        (maponpaths gquot_inl_grpd p)
        @ gquot_inl_grpd_gquot_functor
            g y
      =
      (gquot_inl_grpd_gquot_functor _ _)
        @ maponpaths
        gquot_inl_grpd
        (maponpaths
           (gquot_functor_map (# ⦃ P₁ ⦄ g))
           p).
  Proof.
    induction p.
    refine (!_).
    apply pathscomp0rid.
  Qed.

  Definition sum_gquot_pstrans_comp_inl_help_two
             {X Y Z : grpd_bicat}
             (f : X --> Y) (g : Y --> Z)
    : ∏ (z : gquot (⦃ P₁ ⦄ X)),
      maponpaths
        (gquot_functor_map (poly_act_functor (P₁ + P₂) g))
        (gquot_inl_grpd_gquot_functor f z)
    @ gquot_inl_grpd_gquot_functor
        g
        (gquot_functor_map (poly_act_functor P₁ f) z)
    @ maponpaths
        gquot_inl_grpd
        (gquot_functor_composition
           (poly_act_functor P₁ f)
           (poly_act_functor P₁ g)
           z
    @ gquot_functor_cell
           (poly_act_functor_composition P₁ f g)
           z)
    =
      (gquot_functor_composition
         (poly_act_functor (P₁ + P₂) f)
         (poly_act_functor (P₁ + P₂) g)
         (gquot_inl_grpd z)
    @ gquot_functor_cell
        (poly_act_functor_composition (P₁ + P₂) f g)
        (gquot_inl_grpd z))
    @ gquot_inl_grpd_gquot_functor (f ∙ g) z.
  Proof.
    use gquot_ind_prop.
    - intro a.
      refine (!_).
      refine (pathscomp0rid _ @ _).
      refine (!_).
      exact (gquot_rec_beta_gcleq
                _ _ _ _ _ _ _ _ _
                (pr1 ((pr222 (pr1 ⦃ P₁ ⦄)) X Y Z f g) a)).
    - intro.
      exact (gtrunc _ _ _ _ _).
  Qed.

  Definition sum_gquot_pstrans_comp_inr_help
             {X Y Z : grpd_bicat}
             (f : X --> Y) (g : Y --> Z)
             {x y : gquot (⦃ P₂ ⦄ Y)}
             (p : x = y)
    : maponpaths
        (gquot_functor_map (# ⦃ P₁ + P₂ ⦄ g))
        (maponpaths gquot_inr_grpd p)
      @ gquot_inr_grpd_gquot_functor
          g y
      =
      (gquot_inr_grpd_gquot_functor _ _)
      @ maponpaths
          gquot_inr_grpd
          (maponpaths
             (gquot_functor_map (# ⦃ P₂ ⦄ g))
             p).
  Proof.
    induction p.
    refine (!_).
    apply pathscomp0rid.
  Qed.

  Definition sum_gquot_pstrans_comp_inr_help_two
             {X Y Z : grpd_bicat}
             (f : X --> Y) (g : Y --> Z)
    : ∏ (z : gquot (⦃ P₂ ⦄ X)),
      maponpaths
        (gquot_functor_map (poly_act_functor (P₁ + P₂) g))
        (gquot_inr_grpd_gquot_functor f z)
    @ gquot_inr_grpd_gquot_functor
        g
        (gquot_functor_map (poly_act_functor P₂ f) z)
    @ maponpaths
        gquot_inr_grpd
        (gquot_functor_composition
           (poly_act_functor P₂ f)
           (poly_act_functor P₂ g)
           z
    @ gquot_functor_cell
           (poly_act_functor_composition P₂ f g)
           z)
    =
      (gquot_functor_composition
         (poly_act_functor (P₁ + P₂) f)
         (poly_act_functor (P₁ + P₂) g)
         (gquot_inr_grpd z)
    @ gquot_functor_cell
        (poly_act_functor_composition (P₁ + P₂) f g)
        (gquot_inr_grpd z))
    @ gquot_inr_grpd_gquot_functor (f ∙ g) z.
  Proof.
    use gquot_ind_prop.
    - intro a.
      refine (!_).
      refine (pathscomp0rid _ @ _).
      refine (!_).
      exact (gquot_rec_beta_gcleq
                _ _ _ _ _ _ _ _ _
                (pr1 ((pr222 (pr1 ⦃ P₂ ⦄)) X Y Z f g) a)).
    - intro.
      exact (gtrunc _ _ _ _ _).
  Qed.

  Definition sum_gquot_is_pstrans
    : is_pstrans sum_gquot_data.
  Proof.
    repeat split.
    - intros X Y f g p.
      use funextsec.
      intro z.
      induction z as [z | z].
      + refine (!_).
        etrans.
        {
          etrans.
          {
            refine (maponpaths (λ z, _ @ z) _).
            refine (maponpathscomp inl (sum_gquot_data_comp Y) _  @ _).
            exact (!(maponpathscomp (IHP₁ Y) gquot_inl_grpd _)).
          }
          refine (!(path_assoc _ _ _) @ _).
          refine (maponpaths (λ z, _ @ z) _).
          refine (!(maponpathscomp0 _ _ _) @ _).
          refine (maponpaths
                   (maponpaths gquot_inl_grpd)
                   (!(eqtohomot (psnaturality_natural IHP₁ X Y f g p) z)) @ _).
          exact (maponpathscomp0 _ _ _).
        }
        refine (path_assoc _ _ _ @ _ @ !(path_assoc _ _ _)).
        refine (maponpaths (λ z, z @ _) _).
        exact (sum_gquot_naturality_help_inl p (IHP₁ X z)).
      + refine (!_).
        etrans.
        {
          etrans.
          {
            refine (maponpaths (λ z, _ @ z) _).
            refine (maponpathscomp inr (sum_gquot_data_comp Y) _  @ _).
            exact (!(maponpathscomp (IHP₂ Y) gquot_inr_grpd _)).
          }
          refine (!(path_assoc _ _ _) @ _).
          refine (maponpaths (λ z, _ @ z) _).
          refine (!(maponpathscomp0 _ _ _) @ _).
          refine (maponpaths
                    (maponpaths gquot_inr_grpd)
                    (!(eqtohomot (psnaturality_natural IHP₂ X Y f g p) z)) @ _).
          exact (maponpathscomp0 _ _ _).
        }
        refine (path_assoc _ _ _ @ _ @ !(path_assoc _ _ _)).
        refine (maponpaths (λ z, z @ _) _).
        exact (sum_gquot_naturality_help_inr p (IHP₂ X z)).
    - intros X.
      use funextsec.
      intro z.
      induction z as [z | z].
      + refine (!_).
        etrans.
        {
          refine (maponpathscomp0 (sum_gquot_data_comp X) _ _ @ _).
          etrans.
          {
            refine (maponpaths (λ z, z @ _) _).
            refine (maponpathscomp inl (sum_gquot_data_comp X) _  @ _).
            exact (!(maponpathscomp (IHP₁ X) gquot_inl_grpd _)).
          }
          etrans.
          {
            refine (maponpaths (λ z, _ @ z) _).
            refine (maponpathscomp inl (sum_gquot_data_comp X) _  @ _).
            exact (!(maponpathscomp (IHP₁ X) gquot_inl_grpd _)).
          }
          refine (!(maponpathscomp0 gquot_inl_grpd _ _) @ _).
          refine (maponpaths (maponpaths gquot_inl_grpd) _).
          refine (!(maponpathscomp0 (IHP₁ X) _ _) @ _).
          exact (!(eqtohomot (pstrans_id IHP₁ X) z)).
        }
        refine (maponpathscomp0 gquot_inl_grpd _ _ @ _).
        refine (_ @ !(path_assoc _ _ _)).
        apply maponpaths_2.
        apply sum_gquot_id_help_inl.
      + refine (!_).
        etrans.
        {
          refine (maponpathscomp0 (sum_gquot_data_comp X) _ _ @ _).
          etrans.
          {
            refine (maponpaths (λ z, z @ _) _).
            refine (maponpathscomp inr (sum_gquot_data_comp X) _  @ _).
            exact (!(maponpathscomp (IHP₂ X) gquot_inr_grpd _)).
          }
          etrans.
          {
            refine (maponpaths (λ z, _ @ z) _).
            refine (maponpathscomp inr (sum_gquot_data_comp X) _  @ _).
            exact (!(maponpathscomp (IHP₂ X) gquot_inr_grpd _)).
          }
          refine (!(maponpathscomp0 gquot_inr_grpd _ _) @ _).
          refine (maponpaths (maponpaths gquot_inr_grpd) _).
          refine (!(maponpathscomp0 (IHP₂ X) _ _) @ _).
          exact (!(eqtohomot (pstrans_id IHP₂ X) z)).
        }
        refine (maponpathscomp0 gquot_inr_grpd _ _ @ _).
        refine (_ @ !(path_assoc _ _ _)).
        apply maponpaths_2.
        apply sum_gquot_id_help_inr.
    - intros X Y Z f g.
      use funextsec.
      intro z.
      induction z as [z | z].
      + refine (!_).
        etrans.
        {
          refine (maponpaths (λ z, z @ _) (_ @ _)).
          { apply pathscomp0rid. }
          refine (maponpaths (λ z, z @ _) _).
          apply pathscomp0rid.
        }
        etrans.
        {
          refine (maponpaths (λ z, _ @ z) _).
          refine (maponpathscomp0 (sum_gquot_data_comp Z) _ _ @ _).
          etrans.
          {
            refine (maponpaths (λ z, z @ _) _).
            refine (maponpathscomp inl (sum_gquot_data_comp Z) _  @ _).
            exact (!(maponpathscomp (IHP₁ Z) gquot_inl_grpd _)).
          }
          etrans.
          {
            refine (maponpaths (λ z,
                                maponpaths
                                  gquot_inl_grpd
                                  (maponpaths
                                     (IHP₁ Z)
                                     _
                                  )
                                  @ z) _).
            refine (maponpathscomp inl (sum_gquot_data_comp Z) _  @ _).
            exact (!(maponpathscomp (IHP₁ Z) gquot_inl_grpd _)).
          }
          refine (!(maponpathscomp0 gquot_inl_grpd _ _) @ _).
          refine (maponpaths (maponpaths gquot_inl_grpd) _).
          exact (!(maponpathscomp0 (IHP₁ Z) _ _)).
        }
        etrans.
        {
          refine (maponpaths (λ z, (z @ _) @ _) _).
          exact ((maponpathscomp0 (gquot_functor_map _) _ _)).
        }
        do 2 (refine (!(path_assoc _ _ _) @ _)).
        etrans.
        {
          refine (maponpaths (λ z, _ @ z) _).
          etrans.
          {
            refine (maponpaths (λ z, _ @ z) _).
            refine (!(path_assoc _ _ _) @ _).
            refine (maponpaths (λ z, _ @ z) _).
            exact (!(maponpathscomp0 gquot_inl_grpd _ _)).
          }
          refine (path_assoc _ _ _ @ _).
          refine (maponpaths (λ z, z @ _) _).
          exact (sum_gquot_pstrans_comp_inl_help f g ((pr1 (psnaturality_of IHP₁ f)) z)).
        }
        etrans.
        {
          refine (maponpaths (λ z, _ @ z) _).
          refine (!(path_assoc _ _ _) @ _).
          refine (maponpaths (λ z, _ @ z) _).
          refine (!(maponpathscomp0 gquot_inl_grpd _ _) @ _).
          refine (maponpaths (maponpaths gquot_inl_grpd) _).
          refine (path_assoc _ _ _ @ _).
          etrans.
          {
            refine (maponpaths (λ z, z @ _) _).
            refine (!(pathscomp0rid _) @ _).
            refine (maponpaths (λ z, (z @ _) @ _) _).
            exact (!(pathscomp0rid _)).
          }
          exact (!(eqtohomot (pstrans_comp IHP₁ f g) z)).
        }
        etrans.
        {
          refine (maponpaths (λ z, _ @ (_ @ z)) _).
          exact (maponpathscomp0 gquot_inl_grpd _ _).
        }
        do 2 (refine (path_assoc _ _ _ @ _)).
        refine (_ @ !(path_assoc _ _ _)).
        apply maponpaths_2.
        refine (!(path_assoc _ _ _) @ _).
        exact (sum_gquot_pstrans_comp_inl_help_two f g (IHP₁ X z)).
      + refine (!_).
        etrans.
        {
          refine (maponpaths (λ z, z @ _) (_ @ _)).
          { apply pathscomp0rid. }
          refine (maponpaths (λ z, z @ _) _).
          apply pathscomp0rid.
        }
        etrans.
        {
          refine (maponpaths (λ z, _ @ z) _).
          refine (maponpathscomp0 (sum_gquot_data_comp Z) _ _ @ _).
          etrans.
          {
            refine (maponpaths (λ z, z @ _) _).
            refine (maponpathscomp inr (sum_gquot_data_comp Z) _  @ _).
            exact (!(maponpathscomp (IHP₂ Z) gquot_inr_grpd _)).
          }
          etrans.
          {
            refine (maponpaths (λ z,
                                maponpaths
                                  gquot_inr_grpd
                                  (maponpaths
                                     (IHP₂ Z)
                                     _
                                  )
                                  @ z) _).
            refine (maponpathscomp inr (sum_gquot_data_comp Z) _  @ _).
            exact (!(maponpathscomp (IHP₂ Z) gquot_inr_grpd _)).
          }
          refine (!(maponpathscomp0 gquot_inr_grpd _ _) @ _).
          refine (maponpaths (maponpaths gquot_inr_grpd) _).
          exact (!(maponpathscomp0 (IHP₂ Z) _ _)).
        }
        etrans.
        {
          refine (maponpaths (λ z, (z @ _) @ _) _).
          exact ((maponpathscomp0 (gquot_functor_map _) _ _)).
        }
        do 2 (refine (!(path_assoc _ _ _) @ _)).
        etrans.
        {
          refine (maponpaths (λ z, _ @ z) _).
          etrans.
          {
            refine (maponpaths (λ z, _ @ z) _).
            refine (!(path_assoc _ _ _) @ _).
            refine (maponpaths (λ z, _ @ z) _).
            exact (!(maponpathscomp0 gquot_inr_grpd _ _)).
          }
          refine (path_assoc _ _ _ @ _).
          refine (maponpaths (λ z, z @ _) _).
          exact (sum_gquot_pstrans_comp_inr_help f g ((pr1 (psnaturality_of IHP₂ f)) z)).
        }
        etrans.
        {
          refine (maponpaths (λ z, _ @ z) _).
          refine (!(path_assoc _ _ _) @ _).
          refine (maponpaths (λ z, _ @ z) _).
          refine (!(maponpathscomp0 gquot_inr_grpd _ _) @ _).
          refine (maponpaths (maponpaths gquot_inr_grpd) _).
          refine (path_assoc _ _ _ @ _).
          etrans.
          {
            refine (maponpaths (λ z, z @ _) _).
            refine (!(pathscomp0rid _) @ _).
            refine (maponpaths (λ z, (z @ _) @ _) _).
            exact (!(pathscomp0rid _)).
          }
          exact (!(eqtohomot (pstrans_comp IHP₂ f g) z)).
        }
        etrans.
        {
          refine (maponpaths (λ z, _ @ (_ @ z)) _).
          exact (maponpathscomp0 gquot_inr_grpd _ _).
        }
        do 2 (refine (path_assoc _ _ _ @ _)).
        refine (_ @ !(path_assoc _ _ _)).
        apply maponpaths_2.
        refine (!(path_assoc _ _ _) @ _).
        exact (sum_gquot_pstrans_comp_inr_help_two f g (IHP₂ X z)).
  Qed.

  Definition sum_gquot
    : pstrans
        (comp_psfunctor (⟦ P₁ + P₂ ⟧) gquot_psfunctor)
        (comp_psfunctor gquot_psfunctor ⦃ P₁ + P₂ ⦄).
  Proof.
    use make_pstrans.
    - exact sum_gquot_data.
    - exact sum_gquot_is_pstrans.
  Defined.
End GQuotSum.


(* Copyright (c) 2008, Harvard University
 * All rights reserved.
 *
 * Author: Ryan Wisnesky
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 *
 * - Redistributions of source code must retain the above copyright notice,
 *   this list of conditions and the following disclaimer.
 * - Redistributions in binary form must reproduce the above copyright notice,
 *   this list of conditions and the following disclaimer in the documentation
 *   and/or other materials provided with the distribution.
 * - The names of contributors may not be used to endorse or promote products
 *   derived from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 * POSSIBILITY OF SUCH DAMAGE.
 *)

Module Type NONDEP_ASSOCIATION.
  (* This is weaker than the real ynot finite map because the
     type of a value does not depend on its key.
     However, it corresponds to Jahob when V := ptr. *)
  Variables K V : Set.
  Variable  eqK : forall (k1 k2: K), {k1 = k2} + {k1 <> k2}.
End NONDEP_ASSOCIATION.

Module NondepAssocListModel(A : NONDEP_ASSOCIATION).
 Export A.
 Require Export List.
 Set Implicit Arguments.

 (* This model is slightly different from Jahob's model
    using sets.  We expose lists, but with the with unique
    keys invariant, these operations can implement
    the same list mutations that Jahob gets using set deletion
    and union. *)

 Fixpoint delete (l: list (prod K V)) (k: K) :=
   match l with
     | nil => nil
     | (k', v')::b => if eqK k k'  then delete b k  else (k',v') :: (delete b k)
   end.

 Fixpoint lookup l (k: K) : option V         :=
   match l with
     | nil => None
     | (k', v)::b   => if eqK k k'  then Some v      else lookup b k
   end.

 Definition head (ls : list (prod K V)) :=
   match ls with
     | nil => None
     | x :: _ => Some x
   end.

 Definition tail (ls : list (prod K V)) :=
   match ls with
     | nil => nil
     | _ :: ls' => ls'
   end.

End NondepAssocListModel.

(* This is the interface for the Jahob AssocList example,
   as expressed in Y0. *)
Module Type JAHOB_ASSOC_LIST.
 Require Export List.
 Declare Module A  : NONDEP_ASSOCIATION.
 Module AL := NondepAssocListModel(A).
 Import AL.

 Require Export Ynot.
 Open Scope hprop_scope.

 Parameter t   : Set.
 Parameter rep : t -> list (prod K V) -> hprop.

 Parameter new : STsep __ (fun r => rep r nil).
 Parameter free: forall (p: t),
   STsep (rep p nil) (fun _: unit => __).

 Parameter add: forall k v (p: t) (m: [list (prod K V)]),
   STsep (m ~~ rep p m * [lookup m k = None])
         (fun _:unit => m ~~ rep p ((k,v)::m)).

 Parameter put: forall k v (p: t) (m: [list (prod K V)]),
   STsep (m ~~ rep p m)
         (fun r => m ~~ [lookup m k = r] * rep p ((k,v)::(delete m k))).

 Parameter get: forall k   (p: t) (m: [list (prod K V)]),
   STsep (m ~~ rep p m)
         (fun r:option V => m ~~ rep p m * [lookup m k = r] ).

 Parameter isEmpty: forall (p: t) (m: [list (prod K V)]),
   STsep (m ~~ rep p m) (fun r:bool => m ~~ rep p m * if r then [m = nil] else [m <> nil]).

 Parameter remove : forall k (p: t) (m: [list (prod K V)]),
                     STsep (m ~~ rep p m * Exists v :@ V, [lookup m k = Some v])
                (fun r:V => m ~~ rep p (delete m k) *     [lookup m k = Some r]).

 Parameter replace: forall k v (p: t) (m: [list (prod K V)]),
  STsep (m ~~             rep p m * Exists v0 :@ V,     [lookup m k = Some v0] )
        (fun r:V => m ~~  rep p ((k,v)::(delete m k)) * [lookup m k = Some r ] ).

(* technically want rep -> uniq lemma *)

(* drop contains key *)

End JAHOB_ASSOC_LIST.

(* This uses the same algorithms as Jahob *)
Module JahobAssocList(A : NONDEP_ASSOCIATION) : JAHOB_ASSOC_LIST with Module A := A.
 Module A := A.
 Module AL := NondepAssocListModel(A).
 Require Import Ynot.
 Import AL.

 Open Scope hprop_scope.

(* Representation ***********************************************)

  Definition t : Set := ptr.

  Record Node : Set := node {
    key  : K;
    value: V;
    next : option ptr
  }.

  Fixpoint rep' (op: option ptr) m {struct m} :=
    match op with
      | None => [m = nil]
      | Some h => match m with
                    | (k,v) :: b =>  Exists nxt :@ option ptr,
                          h --> node k v nxt * rep' nxt b * [lookup b k = None]
                    | nil => [False]
                   end
    end.

  Definition rep p m : hprop :=
    Exists n :@ option ptr, p --> n * rep' n m.

(* Reasoning **************************************************)

Ltac simplr := repeat (try discriminate;
  match goal with
    | [ H : head ?x = Some _ |- _ ] =>
      destruct x; simpl in *; [
        discriminate
        | injection H; clear H; intros; subst
      ]
    | [ |- match ?v with
             | Some _ => _
             | None   => _
           end ==> _] => destruct v
    | [ |- _ ==> match ?v with
             | Some _ => _
                   | None   => _
                 end ] =>
      match type of v with
        | option ?T => equate v (@None T)
      end
    | [ H : _ :: _ = _ :: _ |- _ ] => injection H; clear H; intros; subst
    | [ H : next _ = _ |- _ ] => rewrite -> H
    | [ H : Some _ = Some _ |- _ ] => inversion H; clear H
    | [  H : ?a = ?b -> False , HH : (if (eqK ?a ?b) then Some _ else None) = Some _  |- _ ] =>
            destruct (eqK a b) ; [ contradiction | discriminate ]
    | [  HH : (if (eqK ?a ?b) then Some _ else _) = None  |- _ ] =>
            destruct (eqK a b) ; [ discriminate | idtac ]
    | [  H : ?a = ?b -> False , HH : (if (eqK ?a ?b) then Some _ else Some ?v1) =
             Some ?v  |- context[Some ?v1 = Some ?v] ] =>
           destruct (eqK a b) ; [ try congruence | try contradiction ]
    | [ _ : ?a = ?b -> False ,  HH : (if (eqK ?a ?b) then _ else ?c) = ?d  |- _ ] =>
           destruct (eqK a b) ; [ contradiction | idtac ]
    | [ |- context[ if eqK ?a ?a then _ else _ ] ] => destruct (eqK a a)
    | [ H : ?a = ?b -> False |- context[ if eqK ?a ?b then _ else _ ] ] =>
             destruct (eqK a b); [ contradiction | idtac ]
    | [  H : next ?nn = ?a |- ?n = node (key ?nn) (value ?nn) ?a ] =>
              rewrite <- H; destruct n; reflexivity
    | [ _ : (if eqK ?a ?b then Some _ else None) = Some _ |- _ ] =>
           destruct (eqK a b); [ idtac | discriminate ]
    | [ _ : (if eqK ?a ?a then _ else _) = _ |- _ ] => destruct (eqK a a); [ idtac | intuition ]
  end).

Ltac t := unfold rep; unfold rep'; sep fail simplr.
Ltac f := fold rep'; fold rep.

Lemma eta_node : forall fn, fn = node (key fn) (value fn) (next fn).
  destruct fn; reflexivity.
Qed.

Hint Resolve eta_node.

Lemma ll_concat : forall nde a b c hd, Some (key nde, value nde) = head a ->
  rep' (next nde) (tail a ++ b :: c) * hd --> nde *
   [lookup (tail a ++ b :: c) (key nde) = None] ==> rep' (Some hd) (a ++ b :: c)  .
  induction a; t.
Qed.

Hint Resolve ll_concat.
Lemma cons_nil : forall l2 x0 x, rep' l2 x0 * rep' None x ==> rep' l2 (x ++ x0).
  destruct x; t.
Qed.
Lemma node_next : forall nde p,  next nde = p -> nde = node (key nde) (value nde) p.
  destruct nde; simpl; congruence.
Qed.

Hint Resolve cons_nil.
Hint Resolve node_next.

Lemma lkup: forall m k x,
 lookup m x = None -> lookup (delete m k) x = None.
intros. induction m. t. trivial. simpl in *. destruct a. t.
 destruct (eqK x k0). t. destruct (eqK k k0). t. t. Qed.

(* Hint Resolve lkup. *)

Theorem rep'_None : forall ls,
  rep' None ls ==> [ls = nil].
  destruct ls; sep fail idtac.
Qed.

Theorem rep'_Some : forall ls hd,
  rep' (Some hd) ls ==> Exists k :@ K, Exists v :@ V,
    Exists t :@ list (prod K V), Exists p :@ option ptr,
  [ls = (k,v) :: t] * hd --> node k v p * [lookup t k = None] * rep' p t.
  destruct ls; sep fail ltac:(try discriminate).
Qed.

Lemma node_eta : forall fn k v x,
  [fn = node k v x] ==> [key fn = k] * [value fn = v] * [next fn = x].
  destruct fn; sep fail ltac:(try congruence).
Qed.

Lemma cons_eta : forall x h t,
  [x = h :: t] ==> [head x = Some h] * [tail x = t].
  destruct x; sep fail ltac:(try congruence).
Qed.

Lemma rep'_eq : forall m x v0 v1 x0 fn,
  m = [x]%inhabited
  -> (m ~~~ tail m) = [x0]%inhabited
  -> tail x = v0
  -> next fn = v1
  -> rep' v1 v0 ==> rep' (next fn) x0.
  t.
Qed.

Hint Resolve rep'_eq.

Theorem rep_rep' : forall m p, rep p m ==>
  Exists n :@ option ptr, p --> n * rep' n m. t. Qed.

Hint Resolve rep_rep'.

Lemma repl : forall m p k, (rep p m * Exists v :@ V, [lookup m k = Some v]) ==>
 Exists x :@ option ptr, p --> x * (Exists cur :@ ptr, [x = Some cur] * rep' (Some cur) m * Exists v :@ V, [lookup m k = Some v]).
Proof.
  induction m. intros. sep fail auto. instantiate (1 := v). instantiate (1 := p). inversion H0.
  intros. destruct a. unfold rep; case_eq (eqK k k0); intros; subst; inhabiter.
  unfold lookup. rewrite H. simpl. destruct v0. sep fail auto. sep fail auto.
  instantiate (1 := None). instantiate (1:= p). inversion H3.
  simpl. rewrite H in *. destruct v0. inhabiter. sep fail auto. instantiate (1 := v1).
  sep fail auto.
  intro_pure. inversion H3.
Qed.

Hint Resolve repl.

Ltac simp_prem :=
  simpl_IfNull;
  repeat simpl_prem ltac:(apply rep'_None || apply rep'_Some || apply repl ||
                          apply node_eta || apply cons_eta || apply rep_rep');
    unpack_conc.

Ltac destr := match goal with [ x : list (prod K V) |- context[rep' None ?x] ] => destruct x; try t end.

Ltac t'' := unfold rep; fold rep'; sep simp_prem simplr.

Ltac t' := match goal with
             | [ |- _ ==> ?P ] =>
               match P with
                 | context[rep' (next _) _] =>
                   inhabiter; simp_prem;
                   intro_pure; simpl_prem ltac:(solve [ eauto ]); unintro_pure; canceler; t''
               end
             | _ => t''
           end.

Theorem lkup0 : forall ls k,
  lookup ls k = None -> ls = delete ls k.
 intros. induction ls. t. t. destruct a. destruct (eqK k k0). t. pose (IHls H). rewrite <- e. trivial. Qed.

Lemma lkpdel : forall m k, lookup (delete m k) k = None.
 intros. induction m. trivial. simpl. destruct a. destruct (eqK k k0). assumption. simpl.
 destruct (eqK k k0). contradiction. assumption. Qed.

Ltac tx := match goal with | [ H : lookup ?ls ?n = None |- rep' ?x ?ls ==> rep' ?x (delete ?ls ?n) ] =>  rewrite <- (lkup0 ls n H) ; t end.

(* Implementation ***************************************************)

  Open Scope stsepi_scope.

  Definition new : STsep __ (fun r => rep r nil).
    refine {{ New (@None ptr) }}; t. Qed.

  Definition free  p: STsep (rep p nil) (fun _:unit => __).
  intros; refine {{ Free p }}; t. Qed.

  Definition add: forall k v (p: t) (m: [list (prod K V)]),
   STsep (m ~~ rep p m * [lookup m k = None])
         (fun _:unit => m ~~ rep p ((k,v)::m)).
   intros. refine ( op <- ! p ;
                    n  <- New (node k v op) ;
                    {{ p ::= (Some n) }} ); t. Qed.

 (* Get           **********)

 Definition get' : forall (k: K) (hd: option ptr) (m: [list (prod K V)]),
    STsep (m ~~ rep' hd m) (fun r => m ~~ [lookup m k = r] * rep' hd m).
  intro k.
  refine (Fix2
    (fun hd m => m ~~ rep' hd m)
    (fun hd m r => m ~~ [lookup m k = r] * rep' hd m)
    (fun self hd m =>
      IfNull hd
      Then  {{ Return None }}
      Else  fn <- ! hd ;
            if eqK k (key fn)
            then {{ Return (Some (value fn)) }}
            else {{ self (next fn) (m ~~~ tail m)  <@> _  }})); pose lkup.
  (** TODO **)
  t'. t'. t'. t'. t'. t'. t'.
  Admitted.

  Definition get (k: K) (p: ptr) (m: [list (prod K V)]) :
    STsep (m ~~ rep p m)
          (fun r:option V => m ~~ rep p m * [lookup m k = r] ).
  intros; refine (hd <- !p;
                  {{ get' k hd m  <@> (p --> hd) }}); t. Qed.

 (* isEmpty         ********)

 Definition isEmpty: forall (p: t) (m: [list (prod K V)]),
   STsep (m ~~ rep p m) (fun r:bool => m ~~ rep p m * if r then [m = nil] else [m <> nil]).
   intros; refine ( ohd <- (p !! (fun ohd => m ~~ rep' ohd m))%stsep  ;
                    IfNull ohd
                    Then  {{ Return true  }}
                    Else  {{ Return false }} ); t'.
 Qed.

 (* Remove         *********)

Definition remove_pre' k ls prev pn cur n :=
 Exists t :@ list (K*V), prev --> pn * rep' (next n) t *
(Exists v :@ V, [lookup ((key n, value n)::t) k = Some v] * [key n <> key pn] *
   [ls = (key pn, value pn)::(key n, value n)::t] * [key pn <> k] *
   [next pn = Some cur] * [lookup ((key n, value n)::t) (key pn) = None] *
   [lookup t (key n) = None]).

Definition remove_pre k ls prev pn cur := (ls ~~ Exists n :@ Node, cur --> n * remove_pre' k ls prev pn cur n).

Definition remove_post k ls prev (pn:Node) (_:ptr) :=
(fun r:V => ls ~~ Exists pk :@ K, Exists pv :@ V, Exists x :@ list (prod K V),
          [ls = (pk,pv) :: x] * rep' (Some prev) ((pk,pv)::(delete x k)) * [lookup x k = Some r]).

Definition remove_frame ls pn n k prev cur := Exists t :@ list (prod K V), [lookup t (key pn) = None] *
  [ls = (key pn, value pn) :: (key n, value n) :: t]  * [k <> key n] *
  [key pn <> key n] * prev --> node (key pn) (value pn) (Some cur).

Definition remove'' : forall k ls prev pn cur, STsep (remove_pre k ls prev pn cur) (remove_post k ls prev pn cur).
intro k. refine (Fix4 (remove_pre k) (remove_post k)
 (fun self ls prev pn cur =>
  n <- (cur !! (fun n => ls ~~ remove_pre' k ls prev pn cur n))%stsep;
  if eqK k (key n)
  then Free cur ;;
        prev ::= node (key pn) (value pn) (next n) ;;
        {{ Return (value n) }}
  else IfNull (next n) As nt
       Then  {{ !!! }}
       Else {{ self (ls ~~~ tail ls) cur n nt <@> (ls ~~ remove_frame ls pn n k prev cur)  }}));
unfold remove_pre; unfold remove_pre'; unfold remove_post; unfold remove_frame; pose lkup; pose lkup.
t. instantiate (1:=v1). t. t. t. t. t. t. t. t. fold rep'. erewrite <- lkup0; eauto.
t.
(** TODO **)
Admitted.

 Definition remove : forall k (p: t) (m: [list (prod K V)]),
                     STsep (m ~~ rep p m * Exists v :@ V, [lookup m k = Some v])
                (fun r:V => m ~~ rep p (delete m k) *     [lookup m k = Some r]).
 intros. refine (
  hdptr <- ! p ;
  IfNull hdptr
  Then {{ !!! }}
  Else hd <- (hdptr !! (fun hd => m ~~ Exists tl :@ list (prod K V), p --> Some hdptr * Exists v :@ V, [lookup m k = Some v] *
                                       [m = (key hd, value hd)::tl] * rep' (next hd) tl * [lookup tl (key hd) = None]))%stsep   ;
          if eqK k (key hd)
          then Free hdptr ;;
               p ::= next hd ;;
               {{ Return (value hd) }}
          else IfNull (next hd) As nt
               Then {{ !!! }}
               Else {{ remove'' k m hdptr hd nt <@> (m ~~ p --> Some hdptr * [head m = Some (key hd, value hd)] ) }}
  ); unfold remove_pre; unfold remove_pre'; unfold remove_post; pose lkup; pose lkup0; pose lkpdel.
(** TODO **)
Admitted.
(*
t. instantiate (1:=v0). t. t. instantiate (1:= v1). t. t'. t. t'. instantiate (1:=v0). t. t. instantiate (1:= v1). t.
t. t. t. t. t. t'. tx. sep fail auto. t'. t. t'. instantiate (1:=v0). t. t. Qed.
*)

 (* Replace        **********)

 Definition replace: forall k v (p: t) (m: [list (prod K V)]),
  STsep (m ~~             rep p m * Exists v0 :@ V,    [lookup m k = Some v0] )
        (fun r:V => m ~~  rep p ((k,v)::(delete m k)) * [lookup m k = Some r ]).
 intros. refine ( x <- remove k p m ;
                  add k v p (m ~~~ delete m k)  <@> (m ~~ [lookup m k = Some x]) ;;
                  {{ Return x }} ); pose lkup; pose lkup0; pose lkpdel.
 sep fail auto. instantiate (1:=v0). t. t. t. t. t. t. Qed.

 (* Put           *********)

Definition put k v (p: t) (m: [list (prod K V)]):
   STsep (m ~~ rep p m)
         (fun r => m ~~ [lookup m k = r] * rep p ((k,v)::(delete m k))).
intros.
refine ( x <- get k p m ;
          (match x as x0 return STsep (m ~~ rep p m * [x =lookup m k] * [x = x0])
                                    (fun _:unit => m ~~ rep p (delete m k) * [x = lookup m k])  with
             | Some xx =>  z <- remove k p m <@> (m ~~ [Some xx =lookup m k] * [x = Some xx]) ;
                             {{ Return  tt  }}
            | None => {{  Return tt }}
          end)  ;;
          add k v p (m ~~~ delete m k) <@> (m ~~ [x = lookup m k]) ;;
         {{ Return x }}
         ); pose lkup; pose lkpdel; pose lkup0; try solve [ t | t' | sep fail auto; symmetry in H; t'; tx ].
 sep fail auto. f. instantiate (1:=xx). t. t'. tx. Qed.

End JahobAssocList.


Require Import Coq.Bool.Bool.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Applicative.
Require Import ExtLib.Tactics.Consider.
Require Import ExtLib.Tactics.

Require Import MirrorCore.TypesI.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.ExprVariables.
Require Import MirrorCore.Lambda.ExprTac.
Require Import MirrorCore.Lambda.Ptrns.
Require Import MirrorCore.SymI.
Require Import MirrorCore.Views.FuncView.
Require Import MirrorCore.Views.Ptrns.
Require Import MirrorCore.Reify.ReifyClass.

Set Implicit Arguments.
Set Strict Implicit.
Set Maximal Implicit Insertion.

Inductive ap_func (typ : Set) : Set :=
| pPure (_ : typ)
| pAp (_ _ : typ).

Arguments ap_func _ : clear implicits.

Section ApplicativeFuncInst.
  Context {typ func : Set} {RType_typ : RType typ}.
  Context {Heq : RelDec (@eq typ)} {HC : RelDec_Correct Heq}.
  Context {T : Type -> Type} {Applicative_T : Applicative T}.

  Context {Typ2_tyArr : Typ2 _ RFun}.
  Context {Typ1_T : Typ1 _ T}.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.
  Let tyT : typ -> typ := @typ1 _ _ _ _.

  Definition typeof_ap_func (f : ap_func typ) : option typ :=
    match f with
    | pPure t => Some (tyArr t (tyT t))
    | pAp t u => Some (tyArr (tyT (tyArr t u)) (tyArr (tyT t) (tyT u)))
    end.

  Global Instance RelDec_ap_func : RelDec (@eq (ap_func typ)) :=
  { rel_dec := fun a b =>
	         match a, b with
	  	       | pPure t, pPure t' => t ?[eq] t'
	  	       | pAp t u, pAp t' u' => t ?[eq] t' && u ?[eq] u'
	  	       | _, _ => false
	         end
  }.

  Global Instance RelDec_Correct_ap_func : RelDec_Correct RelDec_ap_func.
  Proof.
    constructor.
    destruct x; destruct y; simpl; try rewrite andb_true_iff;
    repeat rewrite rel_dec_correct; try intuition congruence.
  Qed.

  Definition pureR t : typD (tyArr t (tyT t)) :=
    castR id (RFun (typD t) (T (typD t))) (@pure T Applicative_T (typD t)).

  Definition apR t u : typD (tyArr (tyT (tyArr t u)) (tyArr (tyT t) (tyT u))) :=
    castR id (RFun (T (RFun (typD t) (typD u))) (RFun (T (typD t)) (T (typD u))))
          (@ap T Applicative_T (typD t) (typD u)).

  Definition ap_func_symD f : match typeof_ap_func f return Type with
	                      | Some t => typD t
	                      | None => unit
	                      end :=
    match f as f return match typeof_ap_func f return Type with
			| Some t => typD t
			| None => unit
			end with
    | pPure t => pureR t
    | pAp t u => apR t u
    end.

    Global Instance RSym_ApFunc : SymI.RSym (ap_func typ) := {
      typeof_sym := typeof_ap_func;
      symD := ap_func_symD;
      sym_eqb := (fun a b => Some (rel_dec a b))
    }.

  Global Instance RSymOk_lopen_func : SymI.RSymOk RSym_ApFunc.
  Proof.
    constructor.
    intros. unfold sym_eqb; simpl.
    consider (a ?[ eq ] b); auto.
  Qed.

End ApplicativeFuncInst.

Section MakeApplicative.
  Context {typ func : Set} {RType_typ : RType typ}.
  Context {FV : PartialView func (ap_func typ)}.
  Context {Typ2_tyArr : Typ2 _ RFun}.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

  Definition fPure t := f_insert (pPure t).
  Definition fAp t u := f_insert (pAp t u).

  Definition mkPure (t : typ) (f : expr typ func) : expr typ func := App (Inj (fPure t)) f.
  Definition mkAp (t u : typ) (f a : expr typ func) := App (App (Inj (fAp t u)) f) a.

  Fixpoint mkAps f es t :=
    match es with
    | nil => mkPure t f
    | (e, t')::es => mkAp t' t (mkAps f es (tyArr t' t)) e
    end.

  Definition fptrnPure {T : Type} (p : Ptrns.ptrn typ T) : ptrn (ap_func typ) T :=
    fun f U good bad =>
      match f with
      | pPure t => p t U good (fun _ => bad (pPure t))
      | pAp t u => bad (pAp t u)
      end.

  Definition fptrnAp {T : Type} (p : Ptrns.ptrn (typ * typ) T) : ptrn (ap_func typ) T :=
    fun f U good bad =>
      match f with
      | pPure t => bad (pPure t)
      | pAp t u => p (t, u) U good (fun _ => bad (pAp t u))
      end.

  Global Instance fptrnPure_ok {T : Type} {p : ptrn typ T} {Hok : ptrn_ok p} :
    ptrn_ok (fptrnPure p).
  Proof.
    red; intros.
    destruct x; simpl; [destruct (Hok t) |].
    { left. destruct H; exists x. revert H. compute; intros.
      rewrite H. reflexivity. }
    { right; unfold Fails in *; intros; simpl; rewrite H; reflexivity. }
    { right; unfold Fails; reflexivity. }
  Qed.

  Global Instance fptrnAp_ok {T : Type} {p : ptrn (typ * typ) T} {Hok : ptrn_ok p} :
    ptrn_ok (fptrnAp p).
  Proof.
    red; intros.
    destruct x; simpl; [|destruct (Hok (t, t0))].
    { right; unfold Fails; reflexivity. }
    { left. destruct H; exists x; revert H; compute; intros.
      rewrite H. reflexivity. }
    { right; unfold Fails in *; intros; simpl; rewrite H; reflexivity. }
  Qed.

  Lemma Succeeds_fptrnPure {T : Type} (f : ap_func typ) (p : ptrn typ T) (res : T)
        {pok : ptrn_ok p} (H : Succeeds f (fptrnPure p) res) :
    exists t, Succeeds t p res /\ f = pPure t.
  Proof.
    unfold Succeeds, fptrnPure in H.
    unfold ptrn_ok in pok.
    specialize (H (option T) Some (fun _ => None)).
    destruct f; try congruence.
    specialize (pok t).
    destruct pok; [|rewrite H0 in H; congruence].
    destruct H0.
    rewrite H0 in H; inv_all; subst.
    exists t; split; [assumption | reflexivity].
  Qed.

  Lemma Succeeds_fptrnAp {T : Type} (f : ap_func typ) (p : ptrn (typ * typ) T) (res : T)
        {pok : ptrn_ok p} (H : Succeeds f (fptrnAp p) res) :
    exists t u, Succeeds (t, u) p res /\ f = pAp t u.
  Proof.
    unfold Succeeds, fptrnAp in H.
    unfold ptrn_ok in pok.
    specialize (H (option T) Some (fun _ => None)).
    destruct f; try congruence.
    specialize (pok (t, t0)).
    destruct pok; [|rewrite H0 in H; congruence].
    destruct H0.
    rewrite H0 in H; inv_all; subst.
    exists t, t0; split; [assumption | reflexivity].
  Qed.

  Global Instance fptrnPure_SucceedsE {T : Type} {f : ap_func typ}
         {p : ptrn typ T} {res : T} {pok : ptrn_ok p} :
    SucceedsE f (fptrnPure p) res := {
      s_result := exists t, Succeeds t p res /\ f = pPure t;
      s_elim := @Succeeds_fptrnPure T f p res pok
    }.

  Global Instance fptrnAp_SucceedsE {T : Type} {f : ap_func typ}
         {p : ptrn (typ * typ) T} {res : T} {pok : ptrn_ok p} :
    SucceedsE f (fptrnAp p) res :=
  { s_result := exists t u, Succeeds (t, u) p res /\ f = pAp t u
  ; s_elim := @Succeeds_fptrnAp T f p res pok
  }.

  Definition applicative_ptrn_cases {T : Type}
             (do_pure : typ  -> expr typ func -> T)
             (do_ap : typ -> typ -> expr typ func -> expr typ func -> T) :=
    por (appr (inj (ptrn_view _ (fptrnPure (pmap do_pure Ptrns.get)))) Ptrns.get)
        (appr (appr (inj (ptrn_view _ (fptrnAp (pmap (fun x a b => do_ap (fst x) (snd x) a b)
                                                     Ptrns.get))))
                    Ptrns.get)
              Ptrns.get).

Definition applicative_cases {T : Type}
           (do_pure : typ  -> expr typ func -> T)
           (do_ap : typ -> typ -> expr typ func -> expr typ func -> T)
  : Ptrns.ptrn (expr typ func) T :=
  applicative_ptrn_cases do_pure do_ap.

End MakeApplicative.

Section PtrnApplicative.
  Context {typ func : Set} {RType_typ : RType typ}.
  Context {FV : PartialView func (ap_func typ)}.

(* Putting this in the previous sectioun caused universe inconsistencies
  when calling '@mkAp typ func' in JavaFunc (with typ and func instantiated) *)

  Definition ptrnPure {T A : Type}
             (p : ptrn typ T)  (a : ptrn (expr typ func) A)
  : ptrn (expr typ func) (T * A):=
    app (inj (ptrn_view _ (fptrnPure p))) a.

  Definition ptrnAp {A B T : Type}
             (p : ptrn (typ * typ) T)
             (a : ptrn (expr typ func) A)
             (b : ptrn (expr typ func) B) : ptrn (expr typ func) (T * A * B) :=
    app (app (inj (ptrn_view _ (fptrnAp p))) a) b.

End PtrnApplicative.

Section ReifyApplicative.
  Context {typ func : Set} {FV : PartialView func (ap_func typ)}.
  Context {T : Type -> Type} {IH : Applicative T}.
  Context {t : Reify typ}.

  Definition reify_pure : Command (expr typ func) :=
    CPattern (ls := (typ:Type)::nil)
             (RApp (RApp (RExact (@pure T)) RIgnore) (RGet 0 RIgnore))
             (fun (x : function (CCall (reify_scheme typ))) => Inj (fPure x)).

  Definition reify_ap : Command (expr typ func) :=
    CPattern (ls := (typ:Type)::(typ:Type)::nil)
             (RApp (RApp (RApp (RExact (@pure T)) RIgnore) (RGet 0 RIgnore)) (RGet 1 RIgnore))
             (fun (x y : function (CCall (reify_scheme typ))) => Inj (fAp x y)).

  Definition reify_applicative : Command (expr typ func) :=
    CFirst (reify_pure :: reify_ap :: nil).

End ReifyApplicative.

Arguments reify_applicative _ _ {_} _ {_}.


(*
 * © 2020 Massachusetts Institute of Technology.
 * MIT Proprietary, Subject to FAR52.227-11 Patent Rights - Ownership by the Contractor (May 2014)
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List.

From SPICY Require Import
     MyPrelude
     Maps
     ChMaps
     Messages
     Keys
     Automation
     Tactics
     Simulation
     SyntacticallySafe
     AdversaryUniverse

     ModelCheck.Commutation
     ModelCheck.InvariantSearch
     ModelCheck.ProtocolFunctions
     ModelCheck.ModelCheck
     ModelCheck.SilentStepElimination
     ModelCheck.SteppingTactics
     ModelCheck.UniverseInversionLemmas
.

From protocols Require Import
     AvgSalary.

From SPICY Require IdealWorld RealWorld.

Import IdealWorld.IdealNotations
       RealWorld.RealWorldNotations
       SimulationAutomation.

From Frap Require Import Sets.

Module Foo <: Sets.EMPTY.
End Foo.
Module Import SN := Sets.SetNotations(Foo).

Set Implicit Arguments.

Open Scope protocol_scope.

Module AvgSalaryProtocolSecure <: AutomatedSafeProtocolSS.

  Import AvgSalaryProtocol.

  (* Some things may need to change here.  t__hon is where we place the
   * type that the protocol computes.  It is set to Nat now, because we
   * return a natual number.
   *)
  Definition t__hon := Nat.
  Definition t__adv := Unit.
  Definition b    := tt.

  (* These two variables hook up the starting points for both specification and
   * implementation universes.  If you followed the template above, this shouldn't
   * need to be changed.
   *)
  Definition iu0  := ideal_univ_start.
  Definition ru0  := real_univ_start.

  Import Gen Tacs.

  (* These are here to help the proof automation.  Don't change. *)
  #[export] Hint Unfold t__hon t__adv b ru0 iu0 ideal_univ_start real_univ_start : core.
  #[export] Hint Unfold
       mkiU mkiUsr mkrU mkrUsr
       mkKeys
    : core.

  Lemma finitelyRuns : exists n, runningTimeMeasure ru0 n.
  Proof.
    autounfold; simpl.
    eexists.
    econstructor; simpl; find_runtime.

    Unshelve.
    all: exact 0.
  Qed.

  Lemma typechecks : syntactically_safe_U ru0.
  Proof.
    unfold syntactically_safe_U; intros.
    autounfold
    ; subst
    ; simpl in *.

    unfold compute_ids; simpl.

    focus_user; simpl
    ; try solve [ do 2 eexists; split
                  ; [ unshelve (repeat typechecks1)
                      ; match goal with
                        | [ |- bool ] => exact true
                        | [ |- list safe_typ ] => exact []
                        end
                    | repeat verify_context_soundness ] ].

    Unshelve.
    all : exact TyDontCare.
  Qed.

  Lemma summarizable : exists summaries, summarize_univ ru0 summaries.
  Proof.
    autounfold; unfold summarize_univ; simpl; intros.
    unshelve (
        eexists; intros; focus_user; simpl
        ; (exists useless_summary; split; [ build_summary |]; eauto using useless_summary_summarizes)
      ) ; exact $0.
  Qed.

  Lemma lameness : @lameAdv t__adv b (RealWorld.adversary ru0).
  Proof.
    unfold lameAdv; autounfold; simpl; eauto.
  Qed.

  Set Ltac Profiling.

  Lemma safe_invariant :
    invariantFor
      {| Initial := {(ru0, iu0, true)}; Step := @stepSS t__hon t__adv  |}
      (@noresends_inv t__hon t__adv).
      (* (fun st => safety st /\ alignment st /\ returns_align st). *)
  Proof.
    unfold invariantFor
    ; unfold Initial, Step
    ; intros
    ; simpl in *
    ; split_ors
    ; try contradiction
    ; subst.

    autounfold in H0
    ; unfold fold_left, fst, snd in *; rwuf; simpl in H0.

    time (
        repeat transition_system_step
      ).

    Unshelve.
    all: exact 0 || contradiction || auto.
  Qed.

  Show Ltac Profile.

  Lemma U_good : @universe_starts_sane _ Unit b ru0.
  Proof.
    autounfold;
      unfold universe_starts_sane; simpl.
    repeat (apply conj); intros; eauto.
    - focus_user; auto.
    - econstructor.
    - unfold AdversarySafety.keys_honest; rewrite Forall_natmap_forall; intros.
      unfold mkrUsr; simpl.
      rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty; eauto.
    - unfold lameAdv; simpl; eauto.
  Qed.

  Lemma universe_starts_safe : universe_ok ru0.
  Proof.
    pose proof (adversary_is_lame_adv_univ_ok_clauses U_good).

    unfold universe_ok
    ; autounfold
    ; simpl
    ; intuition eauto
    .

    - econstructor; eauto.
    - unfold keys_and_permissions_good; solve_simple_maps; intuition eauto.
      solve_simple_maps; eauto.

      rewrite Forall_natmap_forall; intros.

      solve_simple_maps; simpl
      ; unfold permission_heap_good; intros;
        solve_simple_maps; solve_concrete_maps; eauto.

    - unfold user_cipher_queues_ok.
      rewrite Forall_natmap_forall; intros.
      focus_user
      ; simpl in *; econstructor; eauto.

    - unfold honest_nonces_ok, honest_user_nonces_ok, honest_nonces_ok
      ; repeat simple apply conj
      ; intros
      ; clean_map_lookups
      ; intros
      ; focus_user
      ; try contradiction; try discriminate; simpl;
        repeat (apply conj); intros; clean_map_lookups; eauto.

    - unfold honest_users_only_honest_keys; intros.
      focus_user;
        subst;
        simpl in *;
        clean_map_lookups;
        unfold mkrUsr; simpl;
          rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty;
          eauto;
          simpl in *;
          solve_concrete_perm_merges;
          solve_concrete_maps;
          solve_simple_maps;
          eauto.
  Qed.

End AvgSalaryProtocolSecure.


Require Import AutoSep.
Require Import List.

Set Implicit Arguments.

(** The king of the abstract predicates *)

Module Type SINGLY_LINKED_LIST.
  Parameter sll : list W -> W -> HProp.

  Axiom sll_extensional : forall ls p, HProp_extensional (sll ls p).

  Axiom nil_fwd : forall ls (p : W), p = 0
    -> sll ls p ===> [| ls = nil |].

  Axiom nil_bwd : forall ls (p : W), p = 0
    -> [| ls = nil |] ===> sll ls p.

  Axiom cons_fwd : forall ls (p : W), p <> 0
    -> sll ls p ===> Ex x, Ex ls', [| ls = x :: ls' |] * Ex p', (p ==*> x, p') * sll ls' p'.

  Axiom cons_bwd : forall ls (p : W), p <> 0
    -> (Ex x, Ex ls', [| ls = x :: ls' |] * Ex p', (p ==*> x, p') * sll ls' p') ===> sll ls p.
End SINGLY_LINKED_LIST.

Module SinglyLinkedList : SINGLY_LINKED_LIST.
  Open Scope Sep_scope.

  Fixpoint sll (ls : list W) (p : W) : HProp :=
    match ls with
      | nil => [| p = 0 |]
      | x :: ls' => [| p <> 0 |] * Ex p', (p ==*> x, p') * sll ls' p'
    end.

  Theorem sll_extensional : forall ls (p : W), HProp_extensional (sll ls p).
    destruct ls; reflexivity.
  Qed.

  Theorem nil_fwd : forall ls (p : W), p = 0
    -> sll ls p ===> [| ls = nil |].
    destruct ls; sepLemma.
  Qed.

  Theorem nil_bwd : forall ls (p : W), p = 0
    -> [| ls = nil |] ===> sll ls p.
    destruct ls; sepLemma.
  Qed.

  Theorem cons_fwd : forall ls (p : W), p <> 0
    -> sll ls p ===> Ex x, Ex ls', [| ls = x :: ls' |] * Ex p', (p ==*> x, p') * sll ls' p'.
    destruct ls; sepLemma.
  Qed.

  Theorem cons_bwd : forall ls (p : W), p <> 0
    -> (Ex x, Ex ls', [| ls = x :: ls' |] * Ex p', (p ==*> x, p') * sll ls' p') ===> sll ls p.
    destruct ls; sepLemma;
      match goal with
        | [ H : _ :: _ = _ :: _ |- _ ] => injection H; sepLemma
      end.
  Qed.
End SinglyLinkedList.

Import SinglyLinkedList.
Hint Immediate sll_extensional.

(*TIME Clear Timing Profile. *)

Definition hints : TacPackage.
(*TIME idtac "sll:prepare". Time *)
  prepare (nil_fwd, cons_fwd) (nil_bwd, cons_bwd).
(*TIME Time *)
Defined.

Definition null A (ls : list A) : bool :=
  match ls with
    | nil => true
    | _ => false
  end.

Definition nullS : spec := SPEC("x") reserving 0
  Al ls,
  PRE[V] sll ls (V "x")
  POST[R] [| R = null ls |] * sll ls (V "x").

Definition lengthS : spec := SPEC("x") reserving 1
  Al ls,
  PRE[V] sll ls (V "x")
  POST[R] [| R = length ls |] * sll ls (V "x").

Definition revS : spec := SPEC("x") reserving 3
  Al ls,
  PRE[V] sll ls (V "x")
  POST[R] sll (rev ls) R.

Definition appendS : spec := SPEC("x", "y") reserving 2
  Al ls1, Al ls2,
  PRE[V] sll ls1 (V "x") * sll ls2 (V "y")
  POST[R] sll (ls1 ++ ls2) R.

Definition sllM := bmodule "sll" {{
  bfunction "null"("x") [nullS]
    If ("x" = 0) {
      Return 1
    } else {
      Return 0
    }
  end with bfunction "length"("x", "n") [lengthS]
    "n" <- 0;;
    [Al ls,
      PRE[V] sll ls (V "x")
      POST[R] [| R = V "n" ^+ (length ls : W) |] * sll ls (V "x")]
    While ("x" <> 0) {
      "n" <- "n" + 1;;
      "x" <- "x" + 4;;
      "x" <-* "x"
    };;
    Return "n"
  end with bfunction "rev"("x", "acc", "tmp1", "tmp2") [revS]
    "acc" <- 0;;
    [Al ls, Al accLs,
      PRE[V] sll ls (V "x") * sll accLs (V "acc")
      POST[R] Ex ls', [| ls' = rev_append ls accLs |] * sll ls' R ]
    While ("x" <> 0) {
      "tmp2" <- "x";;
      "tmp1" <- "x" + 4;;
      "x" <-* "tmp1";;
      "tmp1" *<- "acc";;
      "acc" <- "tmp2"
    };;
    Return "acc"
  end with bfunction "append"("x", "y", "r", "tmp") [appendS]
    If ("x" = 0) {
      Return "y"
    } else {
      "r" <- "x";;
      "tmp" <- "x" + 4;;
      "tmp" <-* "tmp";;
      [Al p1, Al x, Al ls1, Al ls2,
        PRE[V] [| V "x" <> $0 |] * [| V "tmp" = p1 |]
          * V "x" =*> x * (V "x" ^+ $4) =*> p1 * sll ls1 p1 * sll ls2 (V "y")
        POST[R] [| R = V "r" |] * sll (x :: ls1 ++ ls2) (V "x") ]
      While ("tmp" <> 0) {
        "x" <- "tmp";;
        "tmp" <- "x" + 4;;
        "tmp" <-* "tmp"
      };;

      "tmp" <- "x" + 4;;
      "tmp" *<- "y";;
      Return "r"
    }
  end
}}.

Ltac notConst x :=
  match x with
    | O => fail 1
    | S ?x' => notConst x'
    | _ => idtac
  end.

Ltac finish := repeat match goal with
                        | [ H : _ = _ |- _ ] => rewrite H
                      end; simpl;
               repeat match goal with
                        | [ |- context[natToW (S ?x)] ] =>
                          notConst x; rewrite (natToW_S x)
                      end; try rewrite <- rev_alt;
               congruence || W_eq || reflexivity || tauto || eauto.

Theorem sllMOk : moduleOk sllM.
(*TIME idtac "sll:verify". Time *)
  vcgen; abstract (sep hints; finish).
(*TIME Time *)
Qed.

(*TIME Print Timing Profile. *)


(** ** Trakhtenbrot's Theorem *)

From Undecidability.PCP Require Import PCP_undec.
From Undecidability.Synthetic Require Import Undecidability ReducibilityFacts DecidabilityFacts.
From Undecidability.FOL.Semantics.FiniteTarski Require Fragment Full DoubleNegation.
From Undecidability.FOL Require Import FSAT Reductions.FSATd_to_FSATdc Reductions.PCPb_to_FSAT.

Section Full.
  Import Full.
  Theorem FSAT_undec :
    undecidable FSAT.
  Proof.
    apply (undecidability_from_reducibility dPCPb_undec).
    exists (finsat_formula). intros x. apply FSAT_reduction.
  Qed.

  Theorem FSATd_undec :
    undecidable FSATd.
  Proof.
    apply (undecidability_from_reducibility dPCPb_undec).
    exists (finsat_formula). intros x. apply FSATd_reduction.
  Qed.

  Theorem FSATdc_undec :
    undecidable FSATdc.
  Proof.
   apply (undecidability_from_reducibility FSATd_undec).
   apply FSATd_to_FSATdc.reduction.
  Qed.
End Full.

Section Fragment.
  Import Fragment DoubleNegation.

  Theorem FSAT_undec_frag :
    undecidable FSAT.
  Proof.
    apply (undecidability_from_reducibility (FSAT_undec)).
    exists translate_form.
    intros k. split; intros (D & I & rho & (l & Hlist) & Hdec & H).
    - exists D, (full_tarski_tarski_interp I), rho; repeat split.
      + now exists l.
      + destruct I; apply Hdec.
      + rewrite <- (full_interp_inverse_1 I) in H.
        destruct (Hdec FSAT.P) as [fP HfP].
        destruct (Hdec FSAT.less) as [fL HfL].
        destruct (Hdec FSAT.equiv) as [fE HfE].
        unshelve now eapply translate_form_correct in H.
        intros ff phi rho'. apply Full.general_decider. 1: now exists l.
        rewrite full_interp_inverse_1. intros ff' [] v ee; cbn;
        apply DecidabilityFacts.decidable_iff'.
        1: now exists fP. 1: now exists fL. now exists fE.
    - exists D, (tarski_full_tarski_interp I), rho; repeat split.
      + now exists l.
      + destruct I; apply Hdec.
      + destruct (Hdec FSAT.P) as [fP HfP].
        destruct (Hdec FSAT.less) as [fL HfL].
        destruct (Hdec FSAT.equiv) as [fE HfE].
        unshelve now eapply translate_form_correct.
        intros ff phi rho'. apply Full.general_decider. 1: now exists l.
        intros ff' [] v ee; cbn;
        apply DecidabilityFacts.decidable_iff'; destruct I.
        1: now exists fP. 1: now exists fL. now exists fE.
  Qed.

  Theorem FSATd_undec_frag :
    undecidable FSATd.
  Proof.
    apply (undecidability_from_reducibility (FSATd_undec)).
    exists translate_form.
    intros k. split; intros (D & I & rho & (l & Hlist) & Hdisc & Hdec & H).
    - exists D, (full_tarski_tarski_interp I), rho; repeat split.
      + now exists l.
      + easy.
      + destruct I; apply Hdec.
      + rewrite <- (full_interp_inverse_1 I) in H.
        destruct (Hdec FSAT.P) as [fP HfP].
        destruct (Hdec FSAT.less) as [fL HfL].
        destruct (Hdec FSAT.equiv) as [fE HfE].
        unshelve now eapply translate_form_correct in H.
        intros ff phi rho'. apply Full.general_decider. 1: now exists l.
        rewrite full_interp_inverse_1. intros ff' [] v ee; cbn;
        apply DecidabilityFacts.decidable_iff'.
        1: now exists fP. 1: now exists fL. now exists fE.
    - exists D, (tarski_full_tarski_interp I), rho; repeat split.
      + now exists l.
      + easy.
      + destruct I; apply Hdec.
      + destruct (Hdec FSAT.P) as [fP HfP].
        destruct (Hdec FSAT.less) as [fL HfL].
        destruct (Hdec FSAT.equiv) as [fE HfE].
        unshelve now eapply translate_form_correct.
        intros ff phi rho'. apply Full.general_decider. 1: now exists l.
        intros ff' [] v ee; cbn;
        apply DecidabilityFacts.decidable_iff'; destruct I.
        1: now exists fP. 1: now exists fL. now exists fE.
  Qed.

  Theorem FSATdc_undec_frag :
    undecidable FSATdc.
  Proof.
    apply (undecidability_from_reducibility FSATdc_undec).
    unshelve eexists translate_form_closed. 1-2: unfold Dec.dec; repeat decide equality.
    intros [k Hclosed]. split; intros (D & I & rho & (l & Hlist) & Hdisc & Hdec & H).
    - exists D, (full_tarski_tarski_interp I), rho; repeat split.
      + now exists l.
      + easy.
      + destruct I; apply Hdec.
      + rewrite <- (full_interp_inverse_1 I) in H.
        destruct (Hdec FSAT.P) as [fP HfP].
        destruct (Hdec FSAT.less) as [fL HfL].
        destruct (Hdec FSAT.equiv) as [fE HfE].
        unshelve now eapply translate_form_correct in H.
        intros ff phi rho'. apply Full.general_decider. 1: now exists l.
        rewrite full_interp_inverse_1. intros ff' [] v ee; cbn;
        apply DecidabilityFacts.decidable_iff'.
        1: now exists fP. 1: now exists fL. now exists fE.
    - exists D, (tarski_full_tarski_interp I), rho; repeat split.
      + now exists l.
      + easy.
      + destruct I; apply Hdec.
      + destruct (Hdec FSAT.P) as [fP HfP].
        destruct (Hdec FSAT.less) as [fL HfL].
        destruct (Hdec FSAT.equiv) as [fE HfE].
        unshelve now eapply translate_form_correct.
        intros ff phi rho'. apply Full.general_decider. 1: now exists l.
        intros ff' [] v ee; cbn;
        apply DecidabilityFacts.decidable_iff'; destruct I.
        1: now exists fP. 1: now exists fL. now exists fE.
  Qed.
End Fragment.


(** a generalization of Σ-monoids to monoidal categories in place of functor categories

author: Kobe Wullaert 2023
*)

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.Core.NaturalTransformations.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories.
Require Import UniMath.CategoryTheory.Monoidal.CategoriesOfMonoids.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.SubstitutionSystems.GeneralizedSubstitutionSystems.

Local Open Scope cat.

Import BifunctorNotations.

Definition SigmaMonoid_characteristic_equation {V : category} {Mon_V : monoidal V} {H : V ⟶ V}
    (x : V) (η : V ⟦ monoidal_unit Mon_V, x ⟧)
    (μ : V ⟦ x ⊗_{ Mon_V} x, x ⟧) (τ :  V ⟦ H x, x ⟧)
    (st : V ⟦ x ⊗_{ Mon_V} H x, H (x ⊗_{ Mon_V} x) ⟧) : UU
    := st · #H μ · τ = x ⊗^{Mon_V}_{l} τ · μ.

Section SigmaMonoid.

  Context {V : category}
          {Mon_V : monoidal V}
          {H : V ⟶ V}
          (θ : pointedtensorialstrength Mon_V H).

  Definition SigmaMonoid_disp_cat_no_compatibility : disp_cat V
    := dirprod_disp_cat (algebra_disp_cat H) (monoid_disp_cat Mon_V).

  Definition SigmaMonoid_compatibility
             (X : total_category SigmaMonoid_disp_cat_no_compatibility) : UU.
  Proof.
    set (x := pr1 X).
    set (η := monoid_data_unit _ (pr22 X : monoid _ _)).
    set (μ := monoid_data_multiplication _ (pr22 X : monoid _ _)).
    set (τ := pr12 X : H x --> x).
    set (st := pr1 θ (x ,, η) x).
    exact (SigmaMonoid_characteristic_equation x η μ τ st).
  Defined.

  Definition SigmaMonoid_disp_cat_without_sigma_constr
    : disp_cat (total_category SigmaMonoid_disp_cat_no_compatibility)
    := disp_full_sub
         (total_category SigmaMonoid_disp_cat_no_compatibility)
         SigmaMonoid_compatibility.

  Definition SigmaMonoid_disp_cat
    : disp_cat V
    := sigma_disp_cat SigmaMonoid_disp_cat_without_sigma_constr.

  Definition SigmaMonoid : category
    := total_category SigmaMonoid_disp_cat.

  Definition SigmaMonoid_carrier (σ : SigmaMonoid) : V := pr1 σ.
  Definition SigmaMonoid_η (σ : SigmaMonoid) : V ⟦ monoidal_unit Mon_V, SigmaMonoid_carrier σ ⟧
    := monoid_data_unit _ (pr212 σ : monoid _ _).
  Definition SigmaMonoid_μ (σ : SigmaMonoid) :
    V ⟦ SigmaMonoid_carrier σ ⊗_{ Mon_V} SigmaMonoid_carrier σ, SigmaMonoid_carrier σ ⟧
    := monoid_data_multiplication _ (pr212 σ : monoid _ _).
  Definition SigmaMonoid_τ (σ : SigmaMonoid) : V ⟦ H (SigmaMonoid_carrier σ), SigmaMonoid_carrier σ⟧
    := pr112 σ.

  Lemma SigmaMonoid_is_compatible (σ : SigmaMonoid) :
    SigmaMonoid_characteristic_equation (SigmaMonoid_carrier σ)
      (SigmaMonoid_η σ) (SigmaMonoid_μ σ) (SigmaMonoid_τ σ)
      (pr1 θ (SigmaMonoid_carrier σ ,, SigmaMonoid_η σ) (SigmaMonoid_carrier σ)).
  Proof.
    exact (pr22 σ).
  Qed.

  Let MON := category_of_monoids_in_monoidal_cat Mon_V.

  (** the following should be an instance of general results on projection into constituents *)
  Definition SigmaMonoid_to_monoid_data : functor_data SigmaMonoid MON.
  Proof.
    use make_functor_data.
    - intro σ. exact (pr1 σ,, pr212 σ).
    - intros σ1 σ2 m. exact (pr1 m,, pr212 m).
  Defined.

  Lemma SigmaMonoid_to_monoid_laws : is_functor SigmaMonoid_to_monoid_data.
  Proof.
    split.
    - intro. apply idpath.
    - intro; intros. apply idpath.
  Qed.

  Definition SigmaMonoid_to_monoid : functor SigmaMonoid MON :=
    SigmaMonoid_to_monoid_data,,SigmaMonoid_to_monoid_laws.

End SigmaMonoid.

Section GHSS_to_SigmaMonoid.

  Context {V : category}
          {Mon_V : monoidal V}
          {H : V ⟶ V}
          (θ : pointedtensorialstrength Mon_V H).

  Definition ghhs_to_sigma_monoid (t : ghss Mon_V H θ)
    : SigmaMonoid θ.
  Proof.
    exists (pr1 t).
    exists (tau_from_alg Mon_V H θ t ,, ghss_monoid Mon_V H θ t).
    exact (gfbracket_τ Mon_V H θ t (Z :=  (pr1 t,, μ_0 Mon_V H θ t)) (identity _)).
  Defined.

End GHSS_to_SigmaMonoid.


(* From Coq Require Import Program.Wf. *)
From Coq Require Import Relation_Definitions.
From Relational Require Import OrderEnrichedCategory OrderEnrichedRelativeMonadExamples.
From Mon Require Import SPropBase.
Set Warnings "-notation-overridden,-ambiguous-paths".
From mathcomp Require Import all_ssreflect (*boolp*).
Set Warnings "notation-overridden,ambiguous-paths".
From Crypt Require Import Axioms OrderEnrichedRelativeAdjunctions LaxFunctorsAndTransf LaxMorphismOfRelAdjunctions TransformingLaxMorph OrderEnrichedRelativeAdjunctionsExamples ThetaDex SubDistr Theta_exCP ChoiceAsOrd FreeProbProg UniversalFreeMap RelativeMonadMorph_prod LaxComp chUniverse.
(* From Crypt Require Import only_prob.Rules. *)

Import SPropNotations.

(*In this file we transform the lax relative monad morphism thetaDex : FreeProb² → Wrelprop
into a stateful effect observation stT_thetaDex : StT(FreeProb²) → StT(Wrelprop)*)

(*
We also subsequently make the domain of stT_thetaDex free by precomposing with a morphism
with type FreeStateProb² → StT(FreeProb²)
*)

Section StT_thetaDex_definition.

  Let myThetaDex :=  thetaDex.

  Context {S1 S2 : choiceType}.
  Let TingAdj1_0 := Chi_DomainStateAdj S1 S2.
  Let TingAdj2_0 :=  Chi_CodomainStateAdj S1 S2.

  Let myJMWprod :=
    @RelativeMonadMorph_prod.JMWprod _ _ (ord_functor_id TypeCat) _ _ (ord_functor_id TypeCat).

  Program Definition state_beta' :  lnatTrans
    (lord_functor_comp (strict2laxFunc (binaryToTheS S1 S2))
       (strict2laxFunc (ord_functor_comp myJMWprod Jprod)))
    (lord_functor_comp (strict2laxFunc (ord_functor_comp myJMWprod Jprod))
       (strict2laxFunc (ToTheS_OrdCat S1 S2))) :=
    mkLnatTrans _ _.
  Next Obligation.
    move=> [A1 A2]. simpl.
    unshelve econstructor.
    move=> [g1 g2]. unshelve econstructor.
    move=> [s1 s2]. exact ⟨ g1 s1 , g2 s2 ⟩.
    cbv. move=> x y. move=> Hxy. destruct Hxy. reflexivity.
    cbv. move=> x y. move=> Hxy. move=> [s1 s2]. destruct Hxy. reflexivity.
  Defined.

  (*this is a morphism between the transformed adjunctions. see rlmm_from_lmla below
   to conclude the def of stT_thetaDex*)
  Program Definition stT_thetaDex_adj :=
    Transformed_lmla myThetaDex TingAdj1_0 TingAdj2_0 state_beta' _ _.
  Next Obligation.
    move=> [A1 A2 [a1 a2] [s1 s2]].
    (*Unfortunately we have to manually destruct A1 and A2 because functions were defined like this in
     Theta_exCP.v*)
    move: A1 a1. move=> [A1 chA1] a1.
    move: A2 a2. move=> [A2 chA2] a2.
    cbv. reflexivity.
  Qed.
  Next Obligation.
    move=> [[A1 chA1] [A2 chA2]] [Y1 Y2] [g1 g2]. simpl.
    apply sig_eq. simpl. apply boolp.funext. move=> [[a1 s1] [a2 s2]].
    simpl. reflexivity.
  Qed.

  Definition stT_thetaDex := rlmm_from_lmla stT_thetaDex_adj.

End StT_thetaDex_definition.

Section GetDomainAndCodomain.
  Context {C D1 D2 : ord_category} {J1 : ord_functor C D1} {J12 : ord_functor D1 D2} {J2 : ord_functor C D2}
          {phi : natIso J2 (ord_functor_comp J1 J12)} (psi := ni_inv phi)
          {M1 : ord_relativeMonad J1} {M2: ord_relativeMonad J2}.

  Definition rlmm_domain (smTheta :  relativeLaxMonadMorphism J12 phi M1 M2)
    : ord_relativeMonad J1
    := M1.
  Definition rlmm_codomain (smTheta :  relativeLaxMonadMorphism J12 phi M1 M2)
    : ord_relativeMonad J2
    := M2.

End GetDomainAndCodomain.

(*
Here we build a unary choiceType relative monad, free, with a stateful-probabilistic
signature.
*)
Section FreeStateProbMonad.

  Context {S : choiceType}. (*the set of states is itself a choiceType*)

(*old formulation*)
  (* Inductive stateE : Type -> Type := *)
  (* |gett : stateE S *)
  (* |putt : S -> stateE unit. *)

  Inductive S_OP :=
    |sgett : S_OP
    |sputt : S -> S_OP.

  Definition S_AR : S_OP -> choiceType := fun sop =>
    match sop with
    |sgett => S
    |sputt _ => chUnit
    end.

  (*Now how can we combine state and probabilities?*)
  (*operations are either stateful or probabilistic...*)
  Inductive SP_OP :=
    |gett : SP_OP
    |putt : S -> SP_OP
    |samplee : P_OP -> SP_OP.

  Definition SP_AR : SP_OP -> choiceType := fun stpOp =>
    match stpOp with
    |gett => S
    |putt _ => chUnit
    |samplee p_op => chElement (projT1 p_op)
    end.

  Definition op_iota : P_OP -> SP_OP := samplee.

  Lemma computational_sliceMorph (o : P_OP) :
    P_AR o = SP_AR ( samplee o ).
  Proof.
    reflexivity.
  Qed.

  (*retro comp*)
  Definition ops_StP := SP_OP.
  Definition ar_StP := SP_AR.

  (*Here is our free choiceType relative monad with a stateful probabilistic signature*)
  Definition FrStP := rFree ops_StP ar_StP.

End FreeStateProbMonad.

(*Now we build a relative monad morphism from FrStP to StT(Frp). In other words
we interpret the stateful part of the signature of FrStP, but not the probabilistic
one*)
Section UnaryInterpretState.

  Context {S : choiceType}.

  (*The domain of the intended morphism is FrStP ...*)
  Let FrStP_filled := @FrStP S.

  (*The codomain is StT(Frp)*)

  Let prob_ops :=  P_OP.
  Let prob_ar :=  P_AR.

  Definition Frp :=  rFree prob_ops prob_ar.
  Let myLflat :=  unaryTimesS1 S.
  Let myR := ToTheS S.
  Notation FrpF := (rFreeF prob_ops prob_ar).

  Program Definition unaryStTransfromingAdj :
  leftAdjunctionSituation choice_incl (ord_functor_comp myLflat choice_incl) myR :=
    mkNatIso _ _ _ _ _ _ _.
  Next Obligation. (*ni_map*)
    move=> [A T]. simpl. unshelve econstructor.
      move=> g a s. exact (g (a,s)).
      cbv. move=> g1 g2. move=> Hg12. move=> a.
      apply boolp.funext. move=> s.
      move: Hg12 => /(_ (a,s)) Hg12.
      assumption.
  Defined.
  Next Obligation. (*ni_inv*)
    move=> [A T]. simpl. unshelve econstructor.
    move=> g [a s]. exact (g a s).
    cbv. move=> g1 g2. move=> Hg12. move=> [a s].
    move: Hg12 => /(_ a) Hg12.
    destruct Hg12. reflexivity.
  Defined.
  Next Obligation.
    move=> [A T]. move=> [A' T'].
    move=> [p q]. simpl in *.
    apply sig_eq. simpl. apply boolp.funext. move=> g.
    apply boolp.funext. move=> a'. apply boolp.funext.
    move=> s. simpl.
    unfold OrderEnrichedRelativeAdjunctionsExamples.ToTheS_obligation_1.
    reflexivity.
  Qed.
  Next Obligation.
    move=> [A T].
    apply sig_eq. simpl.
    apply boolp.funext. move=> g. cbv.
    apply boolp.funext. move=> a. reflexivity.
  Qed.
  Next Obligation.
    move=> [A T].
    apply sig_eq. simpl.
    apply boolp.funext. move=> g. cbv.
    apply boolp.funext. move=> [a s].
    reflexivity.
  Qed.

  (*This is StT(Frp)*)
  Definition stT_Frp := AdjTransform Frp myLflat myR unaryStTransfromingAdj.

  (*Let us define get and put in this monad ...*)
  Let retrFree_filled (X:choiceType) := retrFree prob_ops prob_ar X.

  Definition getStP : stT_Frp S :=
    fun s : S => retrFree_filled (F_choice_prod_obj ⟨ S, S ⟩) (s, s).

  Definition putStP : S -> stT_Frp unit_choiceType := fun new_s old_s =>
    retrFree_filled (F_choice_prod ⟨ unit_choiceType, S ⟩) (tt, new_s).

  Definition probopStP {T : chUniverse} (sd: SDistr T) : stT_Frp (chElement T).
    move=> s. simpl.
    unshelve eapply ropr.
      unshelve econstructor. exact T. exact sd.
    cbn. move=> t. eapply retrFree_filled. simpl. exact ( (t,s) ).
  Defined.

  Let ops_StP_filled :=  @ops_StP S.
  Let ar_StP_filled := @ar_StP S.

  Definition sigMap : forall op : ops_StP_filled, stT_Frp( ar_StP_filled op ).
  move=> op. cbv in op. destruct op.
  - exact getStP.
  - cbn. exact (putStP s).
  - cbn. apply probopStP. destruct p. cbn.  assumption.
  Defined.

  Definition unaryIntState
  : relativeMonadMorphism _ _ (FrStP_filled) stT_Frp
  := @outOfFree (ops_StP_filled) (ar_StP_filled) stT_Frp sigMap.

End UnaryInterpretState.

(*now we square this morphism to get a relative monad morphism FrStP² → stT(Frp)²*)
Section SquareUnaryIntState.

  Context {S1 S2 : choiceType}.

  Let unaryIntState_filled_left := @unaryIntState S1.
  Let unaryIntState_filled_right := @unaryIntState S2.
  Definition preInterpretState :=
  prod_relativeMonadMorphism
    unaryIntState_filled_left unaryIntState_filled_right.

End SquareUnaryIntState.

(*We also need an additional bit stT(Frp)² → stT(Frp²), the latter being the domain
of stT_thetaDex *)
Section StT_vs_squaredMonads.

  Context {S1 S2 : choiceType}.

  Let preInterpretState_filled := @preInterpretState S1 S2.
  Let stT_thetaDex_filled := @stT_thetaDex S1 S2.

  (*domain of the additional morphism*)
  Let squOf_stT_Frp := rlmm_codomain preInterpretState_filled.
  (*and codomain*)
  Let stT_squOf_Frp := rlmm_domain stT_thetaDex_filled.

  (*base square*)
  Definition BinaryTrivialChi :
  natIso ( prod_functor choice_incl choice_incl )
         (ord_functor_comp (prod_functor choice_incl choice_incl)
                           (ord_functor_id (prod_cat TypeCat TypeCat))).
  apply natIso_sym. apply ord_functor_unit_right.
  Defined.

  Notation Frpp := (rFreeF P_OP P_AR).

  Program Definition additionalIntState :
  relativeMonadMorphism (ord_functor_id _) BinaryTrivialChi squOf_stT_Frp stT_squOf_Frp :=
    mkRelMonMorph (ord_functor_id _) BinaryTrivialChi squOf_stT_Frp stT_squOf_Frp _ _ _.
  Next Obligation.
    move=> [A1 A2]. unshelve econstructor.
      easy.
      easy.
  Defined.

End StT_vs_squaredMonads.

(*And now we are finally ready to define the intended theta *)
Section MakeTheDomainFree.

  Context {S1 S2 : choiceType}.

  Let preInterpretState_filled := @preInterpretState S1 S2.
  Let addIntState_filled := @additionalIntState S1 S2.
  Let stT_thetaDex_filled := @stT_thetaDex S1 S2.

  (*FrStP² → stT(Frp²) part*)
  Definition justInterpState :=
  rlmm_comp _ _ _ _ _ _ _ preInterpretState_filled addIntState_filled.

  (*the other part is stT_thetaDex : stT(Frp²) → Wstrelprop*)

  (*we now combine those two morphisms *)
  Definition thetaFstdex := rlmm_comp _ _ _ _ _ _ _ justInterpState stT_thetaDex_filled.

  (*
    Fstdex because:
       start with theta dex = θex ∘ θdens : Frp² → Wrelprop
       then state transform ; stT( θdex ) : StT( Frp² ) → WStRelprop
       then make the domain free ; θFstdex : FrStP ² → WStRelprop

  *)

  (*thetaFdex : FrStP² → Wrelprop *)
(*
  Eval hnf in rlmm_domain thetaFstdex.
  Eval hnf in rlmm_codomain thetaFstdex.
*)

End MakeTheDomainFree.