(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

Set Implicit Arguments.

Require Import FCF.FCF.
Require Import FCF.CompFold.
Local Open Scope list_scope.

Fixpoint hasDups (A : Set)(eqd : EqDec A)(ls : list A) :=
  match ls with
    | nil => false
    | a :: ls' =>
      if (in_dec (EqDec_dec _) a ls') then true else
        (hasDups _ ls')
  end.

Theorem hasDups_false_NoDup :
  forall (A : Set)(eqd : EqDec A)(ls : list A),
    hasDups _ ls = false <->
    NoDup ls.

  induction ls; intuition; simpl in *.
  econstructor.

  destruct (in_dec (EqDec_dec eqd) a ls).
  discriminate.
  econstructor; intuition.

  inversion H1; clear H1; subst.
  destruct (in_dec (EqDec_dec eqd) a ls);
    intuition.

Qed.

Theorem hasDups_true_not_NoDup :
  forall (A : Set)(eqd : EqDec A)(ls : list A),
    hasDups eqd ls = true <-> (~ NoDup ls).

  induction ls; intuition; simpl in *.
  exfalso.
  eapply H.
  econstructor.

  inversion H2; clear H2; subst.
  destruct (in_dec (EqDec_dec eqd) a ls); intuition.
  destruct (in_dec (EqDec_dec eqd) a ls); intuition.
  eapply H0.
  intuition.
  eapply H1.
  econstructor; intuition.

Qed.

Theorem hasDups_inj_equiv :
  forall (A B : Set)(eqda : EqDec A)(eqdb : EqDec B)(lsa : list A)(inj : A -> B),
    (forall a1 a2, inj a1 = inj a2 -> a1 = a2) ->
    hasDups _ lsa = hasDups _ (map inj lsa).

  induction lsa; intuition; simpl in *.
  destruct (in_dec (EqDec_dec eqda) a lsa);
    destruct (in_dec (EqDec_dec eqdb) (inj a) (map inj lsa));
    intuition.
  exfalso.
  apply n.
  apply in_map_iff.
  econstructor.
  intuition.
  apply in_map_iff in i.
  destruct i.
  intuition.
  apply H in H1.
  subst.
  intuition.
Qed.

Require Import Permutation.

Theorem Permutation_hasDups :
  forall (A : Set)(eqd : EqDec A)(ls1 ls2 : list A),
    Permutation ls1 ls2 ->
    hasDups eqd ls1 = hasDups eqd ls2.

  intuition.
  case_eq ( hasDups eqd ls1); intuition.
  apply hasDups_true_not_NoDup in H0.
  intuition.
  case_eq (hasDups eqd ls2); intuition.
  apply hasDups_false_NoDup in H1; intuition.

  exfalso.
  eapply H0.
  eapply permutation_NoDup.
  eapply Permutation_sym.
  eauto.
  trivial.

  eapply hasDups_false_NoDup in H0; intuition.
  case_eq (hasDups eqd ls2); intuition.
  apply hasDups_true_not_NoDup in H1.
  exfalso.
  apply H1.
  eapply permutation_NoDup;
    eauto.

Qed.

Require Import FCF.RndInList.

Section DupProb.

  Variable A B : Set.
  Hypothesis eqdb : EqDec B.
  Variable eta : nat.

  Theorem dupProb :
    forall (ls : list A),
      Pr[x <-$ compMap _ (fun _ => {0, 1}^eta) ls; ret (hasDups _ x)] <=
      (length ls ^ 2 / 2 ^ eta).

    Local Opaque evalDist.

    induction ls; intuition; simpl in *.

    comp_simp.
    simpl.
    rewrite evalDist_ret_0.
    eapply rat0_le_all.
    intuition.

    assert (
        Pr
   [x <-$
    (b <-$ { 0 , 1 }^eta;
     lsb' <-$ compMap (Bvector_EqDec eta) (fun _ : A => { 0 , 1 }^eta) ls;
     ret b :: lsb'); ret hasDups (Bvector_EqDec eta) x ]
   ==
   Pr
   [p <-$
      (b <-$ { 0 , 1 }^eta;
       lsb' <-$ compMap (Bvector_EqDec eta) (fun _ : A => { 0 , 1 }^eta) ls;
       ret (b, lsb'));
     ret hasDups (Bvector_EqDec eta) (snd p) || if (in_dec (EqDec_dec _) (fst p) (snd p)) then true else false ]
   ).

    inline_first.
    comp_skip.
    inline_first.
    comp_skip.
    comp_simp.
    simpl.
    destruct (in_dec (EqDec_dec (Bvector_EqDec eta)) x x0).
    rewrite orb_true_r.
    reflexivity.
    rewrite orb_false_r.
    reflexivity.
    rewrite H.
    clear H.

    rewrite evalDist_orb_le.

    assert (
        (length ls / 2^eta + (length ls ^ 2) / 2 ^ eta)
          <=
        (S (length ls * 1 + length ls * S (length ls * 1)) / 2 ^ eta)
              ).

    eapply leRat_trans.
    2:{
      eapply leRat_terms.
      eapply le_n_Sn.
      reflexivity.
    }

    eapply leRat_trans.
    2:{
      eapply eqRat_impl_leRat.
      symmetry.
      eapply ratAdd_num.
    }

    eapply ratAdd_leRat_compat.
    eapply leRat_terms; lia.
    eapply leRat_terms; intuition.
    simpl.
    eapply mult_le_compat; intuition.

    eapply leRat_trans.
    2:{
      eapply H.
    }
    rewrite ratAdd_comm.
    eapply ratAdd_leRat_compat.

    assert (
        Pr
   [x <-$
    (b <-$ { 0 , 1 }^eta;
     lsb' <-$ compMap (Bvector_EqDec eta) (fun _ : A => { 0 , 1 }^eta) ls;
     ret (b, lsb'));
    ret (if in_dec (EqDec_dec (Bvector_EqDec eta)) (fst x) (snd x)
         then true
         else false) ]
   ==
   Pr
   [
     lsb' <-$ compMap (Bvector_EqDec eta) (fun _ : A => { 0 , 1 }^eta) ls;
     b <-$ { 0 , 1 }^eta;
     ret (if in_dec (EqDec_dec (Bvector_EqDec eta)) b lsb'
         then true
         else false) ]
   ).

    comp_swap_r.
    inline_first.
    comp_skip.
    inline_first.
    comp_skip.
    simpl.
    reflexivity.
    rewrite H0.
    clear H0.
    comp_irr_l.
    eapply compMap_wf.
    intuition.
    wftac.
    eapply RndInList_prob.
    erewrite compMap_length; eauto.

    eapply leRat_trans.
    2:{
      eapply IHls.
    }
    inline_first.
    comp_irr_l.
    wftac.
    inline_first.
    comp_skip.
    simpl.
    reflexivity.
  Qed.

End DupProb.


Require Import Coq.Lists.List.
Set Implicit Arguments.

Inductive Step A S :=
	| Done : Step A S
	| Skip : S -> Step A S
	| Yield: A -> S -> Step A S.

Inductive Stream A S : S -> Type :=
	| StreamC : forall (s:S),
		(S -> Step A S) -> Stream A s.

(* repeated application of step/next function.
   needs to be an inductive type instead of a fixpoint because
   the fixpoint wouldn't terminate given e.g. (fun s => Skip s) *)
Inductive StepEval A S (f : S -> Step A S): S -> Step A S -> Type :=
	| SE_Done: forall (s : S),
		f s = Done A S ->
		StepEval f s (Done A S)
        | SE_Skip: forall (s s': S) (st: Step A S),
		f s' = st ->
		f s = Skip A s' ->
		StepEval f s' st ->
		StepEval f s (Skip A s')
	| SE_Yield: forall (a : A) (s s' : S) (st: Step A S),
		f s' = st ->
		f s = Yield a s' ->
		StepEval f s' st -> StepEval f s (Yield a s').

Inductive StreamEval A S (f: S -> Step A S) (s: S): Stream A s -> Type :=
	| StreamE :
		StepEval f s (f s) ->
		StreamEval f (StreamC s f).

(* can convert a list to a stream very simply *)
Definition stream_next {A} (ls : list A) :=
  match ls with
  | nil   => Done A (list A)
  | x::xs => Yield x xs
  end.

Definition stream {A} (ls: list A) : Stream A ls :=
  StreamC ls stream_next.

(* harder if you want to know results *)
Definition streamE_next:
	forall {A : Type} (ls : list A),
	StepEval stream_next ls (stream_next ls).
  intros A ls.
  induction ls.
    constructor. reflexivity.
  apply SE_Yield with (st := stream_next ls).
    reflexivity.
    reflexivity.
    apply IHls.
Defined.

Definition streamE {A : Type} (ls : list A):
	StreamEval stream_next (stream ls) :=
  StreamE (streamE_next ls).

(* however, if you want to convert a stream to a list you need to have
   the steps already evaluated so you know it's finite *)
Fixpoint unstream_unfold {A S} (next : S -> Step A S) (s : S) (st : Step A S) (seval : StepEval next s st) :=
  match seval with
  | SE_Done h s' => nil
  | SE_Skip s s' st h1 h2 se' => unstream_unfold se'
  | SE_Yield a s s' st h1 h2 se' => a :: unstream_unfold se'
  end.

Definition unstream {A S : Type} {f : S -> Step A S}
	{s : S}
	{str : Stream A s}
	(strE: StreamEval f str)
	: list A :=
  match strE with
  | StreamE steps => unstream_unfold steps
  end.

(* converting a list to a stream and then back should be exactly the same *)
Theorem unstream_stream__id: forall A (ls: list A),
	unstream (streamE ls) = ls.
  intros A ls.
  simpl.
  induction ls.
    reflexivity.
    simpl. rewrite IHls. reflexivity.
Qed.

(* the actual rewrite rule in the paper is
	forall s. stream (unstream s) => s
   but because stream.unstream will eliminate skips, can't say "=".
   instead we'll say conversion to list is the same.
   paper seems to suggest just filtering skip to check equivalence.
   fine, but I already had 'unstream' defined.
*)

Definition StreamEquiv {A S1 S2 : Type}
	(f1   : S1 -> Step A S1)
	(s1   : S1)
	(str1 : Stream A s1)
	(strE1: StreamEval f1 str1)

	(f2   : S2 -> Step A S2)
	(s2   : S2)
	(str2 : Stream A s2)
	(strE2: StreamEval f2 str2)
	 := unstream strE1 = unstream strE2.

Theorem stream_unstream__id: forall {A S : Type}
	(f   : S -> Step A S)
	(s   : S)
	(str : Stream A s)
	(strE: StreamEval f str),
	StreamEquiv
		strE
		(streamE (unstream strE)).
  intros A S f s str strE.
  unfold StreamEquiv.
  rewrite unstream_stream__id.
  reflexivity.
Qed.

(* apply single function to each step *)
Definition map_next {A B S} (f: A -> B) (step: Step A S) : Step B S :=
  match step with
  | Done => Done B S
  | Skip s' => Skip B s'
  | Yield x s' => Yield (f x) s'
  end.

(* slightly easier to work with - updated next function *)
Definition map_f {A B S} (f: A -> B) (next : S -> Step A S) (s : S) : Step B S :=
  map_next f (next s).

(* map whole step evaluation - including its children *)
Definition map_step {A B S} (f : A -> B)
	(next: S -> Step A S)
	(s   : S)
	(step: Step A S)
	(se: StepEval next s step):

	(StepEval (map_f f next) s (map_next f step)).
  intros A B S f next s step se.
  unfold map_f.
  induction se.
  eapply SE_Done. rewrite e. reflexivity.
  eapply SE_Skip.
    reflexivity.
    rewrite e0. reflexivity.
    rewrite e. apply IHse.
  eapply SE_Yield.
    reflexivity.
    rewrite e0. reflexivity.
    rewrite e. apply IHse.
Defined.

(* map a whole evaluated stream *)
Definition map_s {A B S} (f : A -> B)
	(next: S -> Step A S)
	(s   : S)
	(str : Stream A s)
	(strE: StreamEval next str):

	(StreamEval (map_f f next) (StreamC s (map_f f next))) :=
  match strE with
  | StreamE step => StreamE (map_step f step)
  end.

Theorem map__map_s: forall {A B}
	(f : A -> B)
	(ls: list A),
	map f ls = unstream (map_s f (streamE ls)).
Proof.
  intros A B f ls.
  induction ls.
  reflexivity.
  simpl. rewrite IHls. reflexivity.
Qed.

(* should be trivial to prove that
   forall f g ls,
     map (f.g) ls =
     (map f . map g) ls =
     unstream . map_s f . map_s g . streamE =
     unstream . map_s f . streamE . unstream . map_s g . streamE =
   and so on... *)


Require Import ProofIrrelevance.
From Cat Require Import Instances.SETOID.

(** Alternative formalization using SProp, the universe of definitionally
    irrelevant propositions.

    Mostly copy-pasted from the other file. *)

Class ReflexiveGraphCategory : Type :=
{
  Ob  : Type;

  Mor : Ob -> Ob -> Type;

  mid   : forall {X : Ob}, Mor X X;
  mcomp : forall {X Y Z : Ob}, Mor X Y -> Mor Y Z -> Mor X Z;

  mcomp_mid_l : forall {X Y : Ob} (f : Mor X Y), mcomp mid f = f;

  mcomp_mid_r : forall {X Y : Ob} (f : Mor X Y), mcomp f mid = f;

  mcomp_assoc :
    forall {A B C D : Ob} (f : Mor A B) (g : Mor B C) (h : Mor C D),
      mcomp (mcomp f g) h = mcomp f (mcomp g h);

  Rel : Ob -> Ob -> Type;

  rid : forall {X : Ob}, Rel X X;

  fill :
    forall {X X' Y Y' : Ob},
      Mor X Y -> Mor X' Y' -> Rel X X' -> Rel Y Y' -> SProp;

  fill_mid :
    forall {X Y : Ob} (R : Rel X Y), fill mid mid R R;

  fill_rid :
    forall {X Y : Ob} (f : Mor X Y),
      fill f f rid rid;

  fcomp :
    forall {X X' Y Y' Z Z' : Ob}
      {f1 : Mor X Y} {f2 : Mor Y Z} {g1 : Mor X' Y'} {g2 : Mor Y' Z'}
      {R : Rel X X'} {S : Rel Y Y'} {T : Rel Z Z'},
        fill f1 g1 R S -> fill f2 g2 S T ->
          fill (mcomp f1 f2) (mcomp g1 g2) R T;
}.

Arguments Ob    : clear implicits.
Arguments Mor   : clear implicits.
Arguments mid   : clear implicits.
Arguments mcomp {_ X Y Z} _ _.

Inductive Box (A : Type) : SProp :=
| box : A -> Box A.

#[export] Hint Constructors Box : core.

Arguments box {A} _.

#[refine]
#[export]
Instance SETFunRel : ReflexiveGraphCategory :=
{
  Ob := Type;

  Mor X Y := X -> Y;
  mid X := fun x : X => x;
  mcomp _ _ _ f g := fun x => g (f x);

  Rel X Y := X -> Y -> Prop;
  rid A := eq;

  fill X X' Y Y' f g R S :=
    Box (forall x x', R x x' -> S (f x) (g x'));
}.
Proof.
  - easy.
  - easy.
  - easy.
  - now constructor.
  - now constructor; congruence.
  - now intros * [] []; auto.
Defined.

Class SetoidRel (X Y : Setoid') : Type :=
{
  srel : X -> Y -> Type;
  srel_pres :
    forall (x1 x2 : X) (y1 y2 : Y),
      equiv x1 x2 -> equiv y1 y2 -> srel x1 y1 -> srel x2 y2;
}.

#[refine]
#[export]
Instance SetoidRelId (X : Setoid') : SetoidRel X X :=
{|
  srel := equiv;
|}.
Proof.
  now setoid.
Defined.

#[refine]
#[export]
Instance SetoidFunRel : ReflexiveGraphCategory :=
{
  Ob := Setoid';

  Mor := SetoidHom;
  mid := SetoidId;
  mcomp := SetoidComp;

  Rel := SetoidRel;
  rid := SetoidRelId;

  fill X X' Y Y' f g R S :=
    Box (forall (x : X) (x' : X'), srel x x' -> srel (f x) (g x'));
}.
Proof.
  - unfold SetoidId, SetoidComp; intros X Y []; cbn in *.
    now f_equal; apply proof_irrelevance.
  - unfold SetoidId, SetoidComp; intros X Y []; cbn in *.
    now f_equal; apply proof_irrelevance.
  - unfold SetoidId, SetoidComp; intros A B C D [] [] []; cbn in *.
    now f_equal; apply proof_irrelevance.
  - now auto.
  - now constructor; cbn; intros x x' ->.
  - now intros * [] []; constructor; cbn; auto.
Defined.


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

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

Print Assumptions carry.


Section Interval.
    Inductive I :=
    | zero : I
    | one : I.

    Axiom path : zero = one.

    Theorem function_extensionality :
        forall (X Y : Type) (f g : X -> Y),  (forall (x : X), f x = g x) -> f = g.
    Proof.
        intros.
        set (q :=
            fun (i : I) => fun (x : X) =>
            match i with
            | zero => f x
            | one => g x
            end).
        assert (q zero = q one) by (rewrite path; reflexivity).
        unfold q in H. simpl in H.
        repeat change (fun x => ?h x) with h in H.
        assumption.
    Qed.
Section End.


(*************************************************************

 Pullback functors

 In this file, we look at the change of base functors arising
 from pullbacks. We look at two version:

 1. Change of base for slice bicategories
 2. Change of base for slices of display map bicategories
 3. Change of base in the discrete case

 *************************************************************)
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.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Limits.Pullbacks.
Require Import UniMath.Bicategories.Limits.PullbackFunctions.
Require Import UniMath.Bicategories.Limits.Examples.OpCellBicatLimits.
Import PullbackFunctions.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Slice.
Require Import UniMath.Bicategories.Logic.DisplayMapBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayMapBicatSlice.

Local Open Scope cat.

(**
 1. Change of base for slice bicategories
 *)
Section PullbackFunctor.
  Context (B : bicat_with_pb)
          {b₁ b₂ : B}
          (f : b₁ --> b₂).

  Definition pb_psfunctor_data
    : psfunctor_data
        (slice_bicat b₂)
        (slice_bicat b₁).
  Proof.
    use make_psfunctor_data.
    - exact (λ g, pb_obj f (pr2 g) ,, pb_pr1 f (pr2 g)).
    - simple refine (λ g₁ g₂ α, _ ,, _).
      + exact (f /≃₁ pr2 α).
      + exact (inv_of_invertible_2cell (pb_on_1cell_pr1 f (pr2 α))).
    - intros g₁ g₂ α β p.
      simple refine (_ ,, _).
      + exact (f /≃₂ pr2 p).
      + exact (pb_on_2cell_coh (pr2 α) (pr2 β) (pr1 p) (pr2 p)).
    - intro g.
      simple refine (_ ,, _).
      + exact (pb_1cell_on_id f (pr2 g)).
      + exact (pb_1cell_on_id_coh f (pr2 g)).
    - intros g₁ g₂ g₃ α β ; cbn.
      simple refine (_ ,, _).
      + exact (pb_1cell_on_comp f (pr2 α) (pr2 β)).
      + exact (pb_1cell_on_comp_coh f (pr2 α) (pr2 β)).
  Defined.

  Definition pb_psfunctor_laws
    : psfunctor_laws pb_psfunctor_data.
  Proof.
    repeat split.
    - intros g₁ g₂ α.
      use eq_2cell_slice ; cbn.
      apply pb_2cell_on_id.
    - intros g₁ g₂ α β γ p q.
      use eq_2cell_slice ; cbn.
      apply pb_2cell_on_comp.
    - intros g₁ g₂ α.
      use eq_2cell_slice ; cbn.
      apply pb_2cell_on_lunitor.
    - intros g₁ g₂ α.
      use eq_2cell_slice ; cbn.
      apply pb_2cell_on_runitor.
    - intros g₁ g₂ g₃ g₄ α β γ.
      use eq_2cell_slice ; cbn.
      apply pb_2cell_on_lassociator.
    - intros g₁ g₂ g₃ α β₁ β₂ p.
      use eq_2cell_slice ; cbn.
      apply pb_2cell_on_lwhisker.
    - intros g₁ g₂ g₃ α₁ α₂ β p.
      use eq_2cell_slice ; cbn.
      apply pb_2cell_on_rwhisker.
  Qed.

  Definition pb_psfunctor_invertible_cells
    : invertible_cells pb_psfunctor_data.
  Proof.
    split.
    - intro.
      apply is_invertible_2cell_in_slice_bicat ; cbn.
      use is_invertible_2cell_pb_ump_cell.
      + is_iso.
      + is_iso.
    - intros.
      apply is_invertible_2cell_in_slice_bicat ; cbn.
      use is_invertible_2cell_pb_ump_cell.
      + is_iso.
        * apply property_from_invertible_2cell.
        * apply property_from_invertible_2cell.
      + is_iso.
        * apply property_from_invertible_2cell.
        * apply property_from_invertible_2cell.
  Defined.

  Definition pb_psfunctor
    : psfunctor
        (slice_bicat b₂)
        (slice_bicat b₁).
  Proof.
    use make_psfunctor.
    - exact pb_psfunctor_data.
    - exact pb_psfunctor_laws.
    - exact pb_psfunctor_invertible_cells.
  Defined.
End PullbackFunctor.

(**
 2. Change of base for slices of display map bicategories
 *)
Section DispMapPullbackFunctor.
  Context (B : bicat_with_pb)
          (D : disp_map_bicat B)
          {b₁ b₂ : B}
          (f : b₁ --> b₂).

  Section PredMor_for_PB_Mor.
    Context {g₁ g₂ : disp_map_slice_bicat D b₂}
            (α : g₁ --> g₂).

    Let γ : invertible_2cell
              ((π₂ : f /≃ pr12 g₁ --> pr1 g₁) · pr1 α · pr12 g₂)
              (π₁ · id₁ b₁ · f)
      := comp_of_invertible_2cell
           (rassociator_invertible_2cell _ _ _)
           (comp_of_invertible_2cell
              (lwhisker_of_invertible_2cell
                 _
                 (inv_of_invertible_2cell (pr22 α)))
              (comp_of_invertible_2cell
                 (inv_of_invertible_2cell (pb_cell f (pr12 g₁)))
                 (rwhisker_of_invertible_2cell
                    _
                    (rinvunitor_invertible_2cell _)))).

    Definition help_pred_mor_pb_on_1cell
      : pb_ump_mor
          (mirror_has_pb_ump (pb_obj_has_pb_ump f (pr12 g₂)))
          (make_pb_cone
             (f /≃ pr12 g₁)
             ((π₂ : B ⟦ f /≃ pr12 g₁, pr1 g₁ ⟧) · pr1 α)
             (π₁ · id₁ b₁)
             γ)
        ==>
        f /≃₁ pr22 α.
    Proof.
      use pb_ump_cell.
      - apply (mirror_has_pb_ump (pb_obj_has_pb_ump f (pr12 g₂))).
      - exact (pb_ump_mor_pr2
                 (pb_obj_has_pb_ump f (pr12 g₂))
                 (mirror_cone (make_pb_cone (f /≃ pr12 g₁) (π₂ · pr1 α) (π₁ · id₁ b₁) γ))
               • (pb_on_1cell_pr2 _ _)^-1).
      - exact (pb_ump_mor_pr1
                 (pb_obj_has_pb_ump f (pr12 g₂))
                 (mirror_cone (make_pb_cone (f /≃ pr12 g₁) (π₂ · pr1 α) (π₁ · id₁ b₁) γ))
               • runitor _
               • (pb_on_1cell_pr1 _ _)^-1).
      - abstract
          (cbn ;
           rewrite <- !rwhisker_vcomp ;
           rewrite !vassocl ;
           use vcomp_move_R_pM ; [ is_iso | ] ;
           cbn ;
           refine (!_) ;
           etrans ;
           [ apply maponpaths_2 ;
             exact (pb_ump_mor_cell
                      (pb_obj_has_pb_ump f (pr12 g₂))
                      (mirror_cone
                         (make_pb_cone
                            (f /≃ pr12 g₁)
                            (π₂ · pr1 α)
                            (π₁ · id₁ b₁)
                            γ)))
           | ] ;
           rewrite !vassocl ;
           apply maponpaths ;
           etrans ;
           [ do 3 apply maponpaths ;
             rewrite !vassocr ;
             rewrite rassociator_lassociator ;
             rewrite id2_left ;
             rewrite !vassocl ;
             apply idpath
           | ] ;
           etrans ;
           [ do 2 apply maponpaths ;
             rewrite !vassocr ;
             rewrite rwhisker_vcomp ;
             rewrite vcomp_linv ;
             rewrite id2_rwhisker ;
             rewrite id2_left ;
             rewrite !vassocl ;
             apply idpath
           | ] ;
           rewrite !vassocr ;
           use vcomp_move_R_Mp ; [ is_iso | ] ;
           cbn ;
           rewrite pb_on_1cell_cell ;
           rewrite !vassocl ;
           refine (!_) ;
           etrans ;
           [ do 3 apply maponpaths ;
             rewrite !vassocr ;
             rewrite rassociator_lassociator ;
             rewrite id2_left ;
             rewrite !vassocl ;
             apply idpath
           | ] ;
           etrans ;
           [ do 2 apply maponpaths ;
             rewrite !vassocr ;
             rewrite rwhisker_vcomp ;
             rewrite vcomp_linv ;
             rewrite id2_rwhisker ;
             rewrite id2_left ;
             rewrite !vassocl ;
             apply idpath
           | ];
           apply idpath).
    Defined.

    Definition pred_mor_pb_on_1cell
      : pred_mor D π₁ π₁ (f /≃₁ pr22 α).
    Proof.
      pose (pred_mor_closed_under_pb_ump_mor
              D
              _ _ _ _ _ _ _ _ _
              (mirror_has_pb_ump (pb_obj_has_pb_ump f (pr12 g₂)))
              _
              _
              _ _
              (id₁ _)
              γ
              (pr22 g₂)
              (mor_of_pb_preserves_pred_ob
                 D
                 (pr22 g₂)
                 (mirror_has_pb_ump (pb_obj_has_pb_ump f (pr12 g₂))))
              (comp_pred_mor
                 D
                 (mor_of_pb_preserves_pred_ob
                    D
                    (pr22 g₁)
                    (mirror_has_pb_ump (pb_obj_has_pb_ump f (pr12 g₁))))
                 (pr12 α)))
        as c.
      use (invertible_pred_mor_3 _ _ c).
      use make_invertible_2cell.
      - apply help_pred_mor_pb_on_1cell.
      - use is_invertible_2cell_pb_ump_cell.
        + is_iso.
          apply property_from_invertible_2cell.
        + is_iso.
          apply property_from_invertible_2cell.
    Qed.
  End PredMor_for_PB_Mor.

  Definition disp_map_pb_psfunctor_data
    : psfunctor_data
        (disp_map_slice_bicat D b₂)
        (disp_map_slice_bicat D b₁).
  Proof.
    use make_psfunctor_data.
    - exact (λ g,
             pb_obj f (pr12 g)
             ,,
             pb_pr1 f (pr12 g)
             ,,
             pb_preserves_pred_ob
               D
               (pr22 g)
               (mirror_has_pb_ump (pb_obj_has_pb_ump f (pr12 g)))).
    - simple refine (λ g₁ g₂ α, _ ,, _ ,, _).
      + exact (f /≃₁ pr22 α).
      + apply pred_mor_pb_on_1cell.
      + exact (inv_of_invertible_2cell (pb_on_1cell_pr1 f (pr22 α))).
    - intros g₁ g₂ α β p.
      simple refine (_ ,, _).
      + exact (f /≃₂ pr2 p).
      + exact (pb_on_2cell_coh (pr22 α) (pr22 β) (pr1 p) (pr2 p)).
    - intro g.
      simple refine (_ ,, _).
      + exact (pb_1cell_on_id f (pr12 g)).
      + exact (pb_1cell_on_id_coh f (pr12 g)).
    - intros g₁ g₂ g₃ α β ; cbn.
      simple refine (_ ,, _).
      + exact (pb_1cell_on_comp f (pr22 α) (pr22 β)).
      + exact (pb_1cell_on_comp_coh f (pr22 α) (pr22 β)).
  Defined.

  Definition disp_map_pb_psfunctor_laws
    : psfunctor_laws disp_map_pb_psfunctor_data.
  Proof.
    repeat split.
    - intros g₁ g₂ α.
      use eq_2cell_disp_map_slice ; cbn.
      apply pb_2cell_on_id.
    - intros g₁ g₂ α β γ p q.
      use eq_2cell_disp_map_slice ; cbn.
      apply pb_2cell_on_comp.
    - intros g₁ g₂ α.
      use eq_2cell_disp_map_slice ; cbn.
      apply pb_2cell_on_lunitor.
    - intros g₁ g₂ α.
      use eq_2cell_disp_map_slice ; cbn.
      apply pb_2cell_on_runitor.
    - intros g₁ g₂ g₃ g₄ α β γ.
      use eq_2cell_disp_map_slice ; cbn.
      apply pb_2cell_on_lassociator.
    - intros g₁ g₂ g₃ α β₁ β₂ p.
      use eq_2cell_disp_map_slice ; cbn.
      apply pb_2cell_on_lwhisker.
    - intros g₁ g₂ g₃ α₁ α₂ β p.
      use eq_2cell_disp_map_slice ; cbn.
      apply pb_2cell_on_rwhisker.
  Qed.

  Definition disp_map_pb_psfunctor_invertible_cells
    : invertible_cells disp_map_pb_psfunctor_data.
  Proof.
    split.
    - intro.
      apply is_invertible_2cell_in_disp_map_slice_bicat ; cbn.
      use is_invertible_2cell_pb_ump_cell.
      + is_iso.
      + is_iso.
    - intros.
      apply is_invertible_2cell_in_disp_map_slice_bicat ; cbn.
      use is_invertible_2cell_pb_ump_cell.
      + is_iso.
        * apply property_from_invertible_2cell.
        * apply property_from_invertible_2cell.
      + is_iso.
        * apply property_from_invertible_2cell.
        * apply property_from_invertible_2cell.
  Defined.

  Definition disp_map_pb_psfunctor
    : psfunctor
        (disp_map_slice_bicat D b₂)
        (disp_map_slice_bicat D b₁).
  Proof.
    use make_psfunctor.
    - exact disp_map_pb_psfunctor_data.
    - exact disp_map_pb_psfunctor_laws.
    - exact disp_map_pb_psfunctor_invertible_cells.
  Defined.
End DispMapPullbackFunctor.

(**
 3. Change of base in the discrete case
 *)
Section DiscreteDispMapPullbackFunctor.
  Context (B : bicat_with_pb)
          (HB : is_univalent_2_1 B)
          (D : disp_map_bicat B)
          (HD₁ : arrow_subbicat_props D)
          (HD₂ : contained_in_discrete D)
          {b₁ b₂ : B}
          (f : b₁ --> b₂).

  Definition discrete_disp_map_pb_functor_data
    : functor_data
        (discrete_disp_map_slice HB HD₁ HD₂ b₂)
        (discrete_disp_map_slice HB HD₁ HD₂ b₁).
  Proof.
    use make_functor_data.
    - exact (λ g, disp_map_pb_psfunctor B D f g).
    - exact (λ g₁ g₂ α, #(disp_map_pb_psfunctor B D f) α).
  Defined.

  Definition discrete_disp_map_pb_is_functor
    : is_functor discrete_disp_map_pb_functor_data.
  Proof.
    split.
    - intro g.
      refine (!_).
      apply isotoid_2_1.
      + apply is_univalent_2_1_disp_map_slice.
        * exact HB.
        * exact HD₁.
      + exact (psfunctor_id (disp_map_pb_psfunctor B D f) g).
    - intros g₁ g₂ g₃ α β.
      refine (!_).
      apply isotoid_2_1.
      + apply is_univalent_2_1_disp_map_slice.
        * exact HB.
        * exact HD₁.
      + exact (psfunctor_comp (disp_map_pb_psfunctor B D f) α β).
  Qed.

  Definition discrete_disp_map_pb_functor
    : discrete_disp_map_slice HB HD₁ HD₂ b₂
      ⟶
      discrete_disp_map_slice HB HD₁ HD₂ b₁.
  Proof.
    use make_functor.
    - exact discrete_disp_map_pb_functor_data.
    - exact discrete_disp_map_pb_is_functor.
  Defined.
End DiscreteDispMapPullbackFunctor.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require option.Option.

(* Why3 goal *)
Definition nth: forall {a:Type} {a_WT:WhyType a}, Z -> (list a) ->
  (option a).
intros a a_WT.
exact (fix nth n l := match l with nil => None | cons h t => if Zeq_bool n Z0 then Some h else nth (n - 1)%Z t end).
Defined.

(* Why3 goal *)
Lemma nth_def :
forall {a:Type} {a_WT:WhyType a},
forall (n:Z) (l:(list a)),
 match l with
 | Init.Datatypes.nil => ((nth n l) = Init.Datatypes.None)
 | (Init.Datatypes.cons x r) =>
     ((n = 0%Z) -> ((nth n l) = (Init.Datatypes.Some x)))
     /\ ((~ (n = 0%Z)) -> ((nth n l) = (nth (n - 1%Z)%Z r)))
 end.
Proof.
intros a a_WT n l.
revert n.
induction l.
easy.
intros n.
split.
intros ->.
easy.
simpl.
generalize (Zeq_bool_if n 0).
now case Zeq_bool.
Qed.


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

Require Import List Arith Bool Lia Eqdep_dec.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list utils_nat finite.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.TRAKHTENBROT
  Require Import notations utils fol_ops fo_sig fo_terms fo_logic fo_sat.

Import fol_notations.

Set Implicit Arguments.

(* * From binary singleton to a n-ary function and a unary relation *)

Local Notation ø := vec_nil.
Local Notation Σ2 := (Σrel 2).

Definition Σn1 (n : nat) : fo_signature.
Proof.
  exists unit unit.
  + exact (fun _ => n).
  + exact (fun _ => 1).
Defined.

Local Definition PSSn1 n (x y : nat) := @fol_atom (Σn1 (S (S n))) tt ((@in_fot  _ (ar_syms (Σn1 (S (S n)))) tt (£x##vec_set_pos (fun _ => £y)))##ø).

Section Sig2_SigSSn1_encoding.

  Variable n : nat.

  Fixpoint Σ2_ΣSSn1 (d : nat) (A : fol_form Σ2) : fol_form (Σn1 (S (S n))) :=
    match A with
      | ⊥              => ⊥
      | fol_atom r v   => PSSn1 n (Σrel_var (vec_head v)) (Σrel_var (vec_head (vec_tail v)))
      | fol_bin b A B  => fol_bin b (Σ2_ΣSSn1 d A) (Σ2_ΣSSn1 d B)
      | fol_quant fol_fa A  => ∀ PSSn1 n (S d) 0 ⤑ Σ2_ΣSSn1 (S d) A
      | fol_quant fol_ex A  => ∃ PSSn1 n (S d) 0 ⟑ Σ2_ΣSSn1 (S d) A
    end.

  Variable (X : Type) (M2  : fo_model Σ2 X).
  Variable (Y : Type) (MSSn1 : fo_model (Σn1 (S (S n))) Y).

  Let Q x1 x2 := fom_rels M2 tt (x1##x2##ø).
  Let f y1 y2 := fom_syms MSSn1 tt (y1##vec_set_pos (fun _ => y2)).
  Let P y := fom_rels MSSn1 tt (y##ø).

  Variable R : X -> Y -> Prop.

  Variable (d : nat) (φ : nat -> X) (ψ : nat -> Y)
           (H1 : forall x1 x2 y1 y2, R x1 y1 -> R x2 y2 -> Q x1 x2 <-> P (f y1 y2))
           (H2 : forall x, exists y, R x y /\ P (f (ψ d) y))
           (H3 : forall y, P (f (ψ d) y) -> exists x, R x y).

  Theorem Σ2_ΣSSn1_correct A :
           (forall x, In x (fol_vars A) -> R (φ x) (ψ x))
        -> fol_sem M2 φ A <-> fol_sem MSSn1 ψ (Σ2_ΣSSn1 d A).
  Proof.
    revert d φ ψ H2 H3.
    induction A as [ | [] v | b A HA B HB | [] A HA ];
      intros d φ ψ H2 H3 H.
    + simpl; tauto.
    + simpl in v; revert H.
      vec split v with x1; vec split v with x2; vec nil v; clear v.
      revert x1 x2; intros [ x1 | [] ] [ x2 | [] ] H; simpl in H.
      unfold Q in H1; simpl fol_sem at 1.
      rewrite H1.
      2-3: apply H; auto.
      unfold P, f; simpl.
      apply fol_equiv_ext; do 5 f_equal.
      apply vec_pos_ext; intro p.
      rewrite vec_pos_map; rew vec.
    + simpl; apply (fol_bin_sem_ext _).
      * apply HA; auto; intros; apply H, in_app_iff; auto.
      * apply HB; auto; intros; apply H, in_app_iff; auto.
    + simpl; split.
      * intros (x & Hx).
        destruct (H2 x) as (y & Hy1 & Hy2).
        exists y; split; auto.
        - revert Hy2; unfold P, f; simpl.
          apply fol_equiv_ext; do 5 f_equal.
          apply vec_pos_ext; intro p.
          rewrite vec_pos_map; rew vec.
        - revert Hx; apply HA; simpl; auto.
          intros [|i] Hi; simpl; auto.
          apply H; simpl; apply in_flat_map.
          exists (S i); simpl; auto.
      * intros (y & G1 & G2).
        destruct (H3 y) as (x & Hx).
        - revert G1; unfold P, f; simpl.
          apply fol_equiv_ext; do 5 f_equal.
          apply vec_pos_ext; intro p.
          rewrite vec_pos_map; rew vec.
        - exists x; revert G2; apply HA; simpl; auto.
          intros [|i] Hi; simpl; auto.
          apply H; simpl; apply in_flat_map.
          exists (S i); simpl; auto.
    + simpl; split.
      * intros G y Hy.
        destruct (H3 y) as (x & Hx).
        - revert Hy; unfold P, f; simpl.
          apply fol_equiv_ext; do 5 f_equal.
          apply vec_pos_ext; intro p.
          rewrite vec_pos_map; rew vec.
        - generalize (G x); apply HA; simpl; auto.
          intros [|i] Hi; simpl; auto.
          apply H; simpl; apply in_flat_map.
          exists (S i); simpl; auto.
      * intros G x.
        destruct (H2 x) as (y & Hy1 & Hy2).
        specialize (G y).
        spec in G.
        - revert Hy2; unfold P, f; simpl.
          apply fol_equiv_ext; do 5 f_equal.
          apply vec_pos_ext; intro p.
          rewrite vec_pos_map; rew vec.
        - revert G; apply HA; simpl; auto.
          intros [|i] Hi; simpl; auto.
          apply H; simpl; apply in_flat_map.
          exists (S i); simpl; auto.
  Qed.

End Sig2_SigSSn1_encoding.

Section Σ2_ΣSSn1_enc.

  Variable (n : nat) (A : fol_form Σ2).

  Let d := S (lmax (fol_vars A)).

  Definition Σ2_ΣSSn1_enc := fol_lconj (map (PSSn1 n d) (fol_vars A))
                            ⟑ PSSn1 n d 0
                            ⟑ Σ2_ΣSSn1 n d A.

End Σ2_ΣSSn1_enc.

Section Σ2_ΣSSn1_enc_sound.

  Variable (n : nat) (A : fol_form Σ2) (X : Type) (M2 : fo_model Σ2 X) (φ : nat -> X)
           (HA : fol_sem M2 φ A).

  Let Y := (bool + X + X*X)%type.

  Let i := S (lmax (fol_vars A)).

  Let d : Y := inl (inl true).

  Let MSSn1 : fo_model (Σn1 (S (S n))) Y.
  Proof.
    split.
    + simpl; intros _ v.
      exact (match (vec_head v), (vec_head (vec_tail v)) with
        | inl (inl true), inl (inr x)  => inl (inr x)
        | inl (inr x1),   inl (inr x2) => inr (x1,x2)
        | _           ,   _            => inl (inl false)
      end).
    + simpl; intros _ v.
      exact (match vec_head v with
        | inl (inr _) => True
        | inr (x1,x2) => fom_rels M2 tt (x1##x2##ø)
        | _           => False
      end).
  Defined.

  Let ψ n : Y :=
    if eq_nat_dec i n then d else inl (inr (φ n)).

  Let phi_i : ψ i = d.
  Proof.
    unfold ψ.
    destruct (eq_nat_dec i i) as [ | [] ]; auto.
  Qed.

  Let phi_x j : In j (fol_vars A) -> ψ j = inl (inr (φ j)).
  Proof.
    intros H.
    assert (D : lmax (fol_vars A) < i).
    { apply le_refl. }
    unfold ψ.
    destruct (eq_nat_dec i j); auto.
    apply lmax_prop in H; lia.
  Qed.

  Let R x (y : Y) := y = inl (inr x).

  Let sem_Σ2_ΣSSn1_enc : fol_sem MSSn1 ψ (Σ2_ΣSSn1_enc n A).
  Proof.
    simpl; msplit 2.
    - rewrite fol_sem_lconj; intros ?; rewrite in_map_iff.
      intros (j & <- & Hj); simpl.
      fold i; rewrite phi_i; simpl.
      rewrite phi_x; auto.
    - fold i; rewrite phi_i; simpl; auto.
    - revert HA; apply Σ2_ΣSSn1_correct with (R := R).
      + intros x1 x2 y1 y2; unfold R; simpl; intros -> ->; tauto.
      + intros x; exists (inl (inr x)); split.
        * red; auto.
        * fold i; rewrite phi_i; unfold d; simpl; auto.
      + fold i; rewrite phi_i; intros [ [ [] | x ] | (x1,x2) ]; simpl; try tauto.
        exists x; red; auto.
      + intros j Hj; rewrite (phi_x _ Hj); red; auto.
  Qed.

  Hypothesis (HX : finite_t X)
             (M2_dec : fo_model_dec M2).

  Hint Resolve finite_t_sum finite_t_bool finite_t_prod : core.

  Theorem Σ2_ΣSSn1_enc_sound : fo_form_fin_dec_SAT (Σ2_ΣSSn1_enc n A).
  Proof.
    exists Y, MSSn1.
    exists. { unfold Y; auto. }
    exists.
    { intros []; simpl; intros v.
      vec split v with x; vec nil v; clear v; simpl.
      destruct x as [ [ [] | x ] | (x1,x2) ]; try tauto.
      apply M2_dec. }
    exists ψ; auto.
  Qed.

End Σ2_ΣSSn1_enc_sound.

Section Σ2_ΣSSn1_enc_complete.

  Variable (n : nat) (A : fol_form Σ2) (Y : Type) (MSSn1 : fo_model (Σn1 (S (S n))) Y)
           (MSSn1_dec : fo_model_dec MSSn1) (ψ : nat -> Y).

  Let i := S (lmax (fol_vars A)).
  Let d := ψ i.

  Let f u v := fom_syms MSSn1 tt (u##vec_set_pos (fun _ => v)).

  Let P y := fom_rels MSSn1 tt (f d y##ø).

  Hypothesis (HA : fol_sem MSSn1 ψ (Σ2_ΣSSn1_enc n A)).

  Let Q y := (if @MSSn1_dec tt (f d y##ø) then true else false) = true.

  Let Q_spec y : Q y <-> P y.
  Proof.
    unfold P, Q.
    destruct (MSSn1_dec (f d y##ø)); split; auto; discriminate.
  Qed.

  Let H1 j : In j (fol_vars A) -> Q (ψ j).
  Proof.
    intros Hj; apply Q_spec.
    simpl in HA; apply proj1 in HA.
    rewrite fol_sem_lconj in HA.
    unfold P.
    specialize (HA (PSSn1 n i j)).
    spec in HA.
    - apply in_map_iff.
      exists j; split; auto.
    - revert HA; apply fol_equiv_ext.
      unfold f; simpl; do 5 f_equal.
      apply vec_pos_ext; intro p.
      rewrite vec_pos_map; rew vec.
  Qed.

  Let H2 : Q (ψ 0).
  Proof.
    apply Q_spec.
    unfold P, f.
    simpl in HA.
    apply proj2, proj1 in HA.
    revert HA.
    apply fol_equiv_ext.
    simpl; do 5 f_equal.
    apply vec_pos_ext; intro p.
    rewrite vec_pos_map; rew vec.
  Qed.

  Let H3 : fol_sem MSSn1 ψ (Σ2_ΣSSn1 n i A).
  Proof. apply HA. Qed.

  Let X := sig Q.

  Let M2 : fo_model Σ2 X.
  Proof.
    split.
    + intros [].
    + intros r; simpl; intros v.
      exact (fom_rels MSSn1 tt (f (proj1_sig (vec_head v)) (proj1_sig (vec_head (vec_tail v)))##ø)).
  Defined.

  Let φ n : X :=
    match in_dec eq_nat_dec n (fol_vars A) with
      | left H  => exist _ _ (H1 n H)
      | right _ => exist _ _ H2
    end.

  Let R (x : X) (y : Y) := proj1_sig x = y.

  Let sem_A : fol_sem M2 φ A.
  Proof.
    revert H3; apply Σ2_ΣSSn1_correct with (R := R).
    + intros (x1 & E1) (x2 & E2) y1 y2; unfold R; simpl.
      intros <- <-; tauto.
    + intros (x & Hx); exists x; split.
      * red; simpl; auto.
      * apply Q_spec in Hx; auto.
    + intros y Hy; apply Q_spec in Hy.
      exists (exist _ y Hy); red; auto.
    + intros j Hj; unfold φ.
      destruct (in_dec eq_nat_dec j (fol_vars A)) as [ | [] ]; auto.
      red; simpl; auto.
  Qed.

  Hypothesis HY : finite_t Y.

  Theorem Σ2_ΣSSn1_enc_complete : fo_form_fin_dec_SAT A.
  Proof.
    exists X, M2.
    exists.
    { unfold X; apply fin_t_finite_t.
      + intros; apply eq_bool_pirr.
      + unfold Q; apply finite_t_fin_t_dec; auto.
        intros; apply bool_dec. }
    exists.
    { intros [] v; simpl; apply MSSn1_dec. }
    exists φ; auto.
  Qed.

End Σ2_ΣSSn1_enc_complete.


(** This module defines the syntax of terms, values, and types in
Rattus. *)

From Coq Require Export Nat.

Definition loc : Set := nat.
Definition index := nat.

(* Types *)
Inductive type : Set :=
(* Standard λ-calculus with sums and products *)
| Unit    : type
| Nat     : type
| TypeVar : index -> type
| Times   : type -> type -> type
| Plus    : type -> type -> type
| Arrow   : type -> type -> type
(* Reactive types *)
| Delay   : type -> type
| Box     : type -> type
(* Temporal recursive types *)
| Fix     : type -> type.

Bind Scope type_scope with type.
Open Scope type_scope.

(* Notation for pretty types *)

(*  Terms  *)
Inductive term :  Type :=
(* λ-calculus with sums and products *)
| var     : index -> term
| unit    : term
| natlit  : nat -> term
| add     : term -> term -> term
| abs     : term -> term
| letin   : term -> term -> term
| app     : term -> term -> term
| pair    : term -> term -> term
| pr1     : term -> term
| pr2      : term -> term
| in1     : term -> term
| in2     : term -> term
| case    : term -> term -> term -> term
(* Reactive terms *)
| delay   : term -> term
| adv     : term -> term
| ref     : loc  -> term
| box     : term -> term
| unbox   : term -> term
(* Temporal recursive terms *)
| out     : term -> term
| into    : term -> term
| fixp    : term -> term.

Inductive isvalue : term -> Prop :=
| value_unit : isvalue unit
| value_nat n : isvalue (natlit n)
| value_ref l : isvalue (ref l)
| value_abs t : isvalue (abs t)
| value_box t : isvalue (box t)
| value_into v : isvalue v -> isvalue (into v)
| value_pair v1 v2 : isvalue v1 -> isvalue v2 -> isvalue (pair v1 v2)
| value_in1 v: isvalue v -> isvalue (in1 v)
| value_in2 v: isvalue v -> isvalue (in2 v).

#[global] Hint Constructors isvalue : core.


Require Import simple.

Require Import List.
Require Import ZArith.

Definition minimum_code :=
  SIf (BLt (EVar "x") (EVar "y"))
      (SReturn (EVar "x"))
      (SReturn (EVar "y")).

Hint Resolve Z.min_l Z.min_r : done_hints.

Lemma minimum_spec :
  forall c, kcell c = kra (KStmt minimum_code) kdot ->
  forall xv yv m, store c ~=
    ("x" s|-> KInt xv :* "y" s|-> KInt yv :* m) ->
  sound kstep (returns c (Z.min xv yv)).
Proof. simple_solver. Qed.


(** Wzięte
    #<a class='link' href='https://personal.cis.strath.ac.uk/neil.ghani/papers/ghani-hosc09.pdf'
    stąd.#. *)

From Typonomikon Require Import D5.

Set Universe Polymorphism.

Unset Positivity Checking.
Inductive Bush (A : Type) : Type :=
| Leaf : Bush A
| Node : A -> Bush (Bush A) -> Bush A.
Set Positivity Checking.

Arguments Leaf {A}.
Arguments Node {A} _ _.

Fixpoint map {A B : Type} (f : A -> B) (b : Bush A) {struct b} : Bush B :=
match b with
| Leaf      => Leaf
| Node v bs => Node (f v) (map (map f) bs)
end.

Unset Guard Checking.
Fixpoint sum (b : Bush nat) : nat :=
match b with
| Leaf => 0
| Node n bs => n + sum (map sum bs)
end.
Set Guard Checking.

Unset Guard Checking.
Fixpoint size {A : Type} (b : Bush A) {struct b} : nat :=
match b with
| Leaf => 0
| Node v bs => 1 + sum (map size bs)
end.
Set Guard Checking.

Unset Guard Checking.
Fixpoint toList {A : Type} (b : Bush A) {struct b} : list A :=
match b with
| Leaf      => []
| Node v bs => v :: join (toList (map toList bs))
end.
Set Guard Checking.

Fixpoint replicate (h : nat) {A : Type} (x : A) : Bush A :=
match h with
| 0    => Leaf
| S h' => Node x (replicate h' (replicate h' x))
end.

Fixpoint count {A : Type} (p : A -> nat) (b : Bush A) {struct b} : nat :=
match b with
| Leaf => 0
| Node x b' => p x + count (count p) b'
end.

(*
Fixpoint app {A : Type} (b1 b2 : Bush A) : Bush A :=
match b1 with
| Leaf     => b2
| Node h t => Node h (
*)

(*
Fixpoint join {A : Type} (b : Bush (Bush A)) {struct b} : Bush A.
*)

Compute (replicate 3 (Node 5 Leaf)).

Unset Guard Checking.
Fixpoint nums (n : nat) : Bush nat :=
match n with
| 0 => Node 0 Leaf
| S n' => Node n (map nums (nums n'))
end.
Set Guard Checking.

Compute size (nums 4).

(* Compute count (fun n => if even n then 1 else 0) (nums 10). *)

Require Import FunctionalExtensionality.

Unset Positivity Checking.
Inductive Bush' {A : Type} (P : A -> Type) : Bush A -> Type :=
| Leaf' : Bush' P Leaf
| Node' :
    forall (x : A) (b : Bush (Bush A)),
      P x -> Bush' (Bush' P) b -> Bush' P (Node x b).
Set Positivity Checking.

Fixpoint Bush_ind_deep
  (P : forall (A : Type) (Q : A -> Type), Bush A -> Type)
  (leaf : forall (A : Type) (Q : A -> Type), P A Q Leaf)
  (node : forall (A : Type) (Q : A -> Type) (x : A) (b : Bush (Bush A)),
            Q x -> P (Bush A) (Bush' Q) b -> P A Q (Node x b))
  {A : Type} (Q : A -> Type)
  {b : Bush A} (b' : Bush' Q b) {struct b'} : P A Q b.
Proof.
  destruct b' as [| x b Qx Pb].
  - apply leaf.
  - apply node.
    + exact Qx.
    + apply Bush_ind_deep; try assumption.
Defined.

Fixpoint Bush'_True {A : Type} {Q : A -> Type} (b : Bush A) {struct b} :
  (forall x : A, Q x) -> Bush' Q b.
Proof.
  destruct b as [| x b']; intros H.
  - now constructor.
  - constructor; [easy |].
    apply Bush'_True.
    intros b''.
    now apply Bush'_True.
Defined.

Fixpoint Bush_ind
  (P : forall (A : Type), Bush A -> Type)
  (leaf : forall (A : Type), P A Leaf)
  (node : forall (A : Type) (x : A) (b : Bush (Bush A)),
            P (Bush A) b -> P A (Node x b))
  {A : Type}
  {b : Bush A} {struct b} : P A b.
Proof.
  refine (@Bush_ind_deep (fun A _ => P A) _ _ A (fun _ => True) b _); intros.
  - apply leaf.
  - apply node; assumption.
  - now apply Bush'_True.
Defined.

(*
Fixpoint Bush_ind_deep'
  (P : forall (A : Type) (Q : A -> Type), Bush A -> Type)
  (leaf : forall (A : Type) (Q : A -> Type), P A Q Leaf)
  (node : forall (A : Type) (Q : A -> Type) (x : A) (b : Bush (Bush A)),
            Q x -> P (Bush A) (P A Q) b -> P A Q (Node x b))
  {A : Type} (Q : A -> Type)
  {b : Bush A} (b' : Bush' Q b) {struct b'} : P A Q b.
Proof.
  destruct b' as [| x b Qx Pb].
    apply leaf.
    apply node.
      exact Qx.
      apply Bush_ind_deep'; try assumption. revert P Q leaf node Qx b Pb. fix IH 6.
        destruct 4; constructor.
          apply Bush_ind_deep'; assumption. Check Bush'.
          specialize (IH (fun A Q => Bush' (P A Q))). assumption.
Defined.
*)

Fixpoint Bush_ind_deep''
  {A : Type} (Q : A -> Type) (P : Bush A -> Type)
  (leaf : P Leaf)
  (node : forall (x : A) (b : Bush (Bush A)),
            Q x -> Bush' P b -> P (Node x b))
  {b : Bush A} (b' : Bush' Q b) {struct b'} : P b.
Proof.
  destruct b' as [| x b Qx Pb].
    apply leaf.
    apply node.
      exact Qx.
      revert P Q leaf node Qx b Pb. fix IH 6; intros.
        destruct Pb; constructor.
          apply (Bush_ind_deep'' A Q P); assumption.
Abort.

Lemma map_map :
  forall {A B C : Type} (f : A -> B) (g : B -> C) (b : Bush A),
    map g (map f b) = map (fun x => g (f x)) b.
Proof.
  intro.
  pose (P := (fun (A : Type) (b : Bush A) => forall (B C : Type) (f : A -> B) (g : B -> C)
    (b : Bush A), map g (map f b) = map (fun x => g (f x)) b)).
  refine (Bush_ind P _ _).
  - unfold P; cbn; intros.
Abort.

Unset Guard Checking.
Lemma map_map :
  forall {A B C : Type} (f : A -> B) (g : B -> C) (b : Bush A),
    map g (map f b) = map (fun x => g (f x)) b.
Proof.
  fix IH 6.
  destruct b as [| h t]; cbn.
  - reflexivity.
  - rewrite IH.
    do 2 f_equal.
    extensionality bb.
    now rewrite IH.
Qed.
Set Guard Checking.


(** * HoareAsLogic: Hoare Logic as a Logic *)

(* $Date: 2011-04-16 14:56:54 -0400 (Sat, 16 Apr 2011) $ *)

Require Export Hoare.

(** The presentation of Hoare logic in chapter [Hoare] could be
    described as "model-theoretic": the proof rules for each of the
    constructors were presented as _theorems_ about the evaluation
    behavior of programs, and proofs of program correctness (validity
    of Hoare triples) were constructed by combining these theorems
    directly in Coq.

    Another way of presenting Hoare logic is to define a completely
    separate proof system -- a set of axioms and inference rules that
    talk about commands, Hoare triples, etc. -- and then say that a
    proof of a Hoare triple is a valid derivation in _that_ logic.  We
    can do this by giving an inductive definition of _valid
    derivations_ in this new logic. *)

Inductive hoare_proof : Assertion -> com -> Assertion -> Type :=
  | H_Skip : forall P,
      hoare_proof P (SKIP) P
  | H_Asgn : forall Q V a,
      hoare_proof (assn_sub V a Q) (V ::= a) Q
  | H_Seq  : forall P c Q d R,
      hoare_proof P c Q -> hoare_proof Q d R -> hoare_proof P (c;d) R
  | H_If : forall P Q b c1 c2,
    hoare_proof (fun st => P st /\ bassn b st) c1 Q ->
    hoare_proof (fun st => P st /\ ~(bassn b st)) c2 Q ->
    hoare_proof P (IFB b THEN c1 ELSE c2 FI) Q
  | H_While : forall P b c,
    hoare_proof (fun st => P st /\ bassn b st) c P ->
    hoare_proof P (WHILE b DO c END) (fun st => P st /\ ~ (bassn b st))
  | H_Consequence  : forall (P Q P' Q' : Assertion) c,
    hoare_proof P' c Q' ->
    (forall st, P st -> P' st) ->
    (forall st, Q' st -> Q st) ->
    hoare_proof P c Q
  | H_Consequence_pre  : forall (P Q P' : Assertion) c,
    hoare_proof P' c Q ->
    (forall st, P st -> P' st) ->
    hoare_proof P c Q
  | H_Consequence_post  : forall (P Q Q' : Assertion) c,
    hoare_proof P c Q' ->
    (forall st, Q' st -> Q st) ->
    hoare_proof P c Q.

Tactic Notation "hoare_proof_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "H_Skip" | Case_aux c "H_Asgn" | Case_aux c "H_Seq"
  | Case_aux c "H_If" | Case_aux c "H_While" | Case_aux c "H_Consequence"
  | Case_aux c "H_Consequence_pre" | Case_aux c "H_Consequence_post" ].

(** For example, let's construct a proof object representing a
    derivation for the hoare triple
      {{assn_sub X (X+1) (assn_sub X (X+2) (X=3))}} X::=X+1; X::=X+2 {{X=3}}.
    We can use Coq's tactics to help us construct the proof object. *)

Example sample_proof
             : hoare_proof
                 (assn_sub X (APlus (AId X) (ANum 1))
                   (assn_sub X (APlus (AId X) (ANum 2))
                     (fun st => st X = 3) ))
                 (X ::= APlus (AId X) (ANum 1); (X ::= APlus (AId X) (ANum 2)))
                 (fun st => st X = 3).
Proof.
  apply H_Seq with (assn_sub X (APlus (AId X) (ANum 2))
                     (fun st => st X = 3)).
  apply H_Asgn. apply H_Asgn.
Qed.

(*
Print sample_proof.
====>
  H_Seq
    (assn_sub X (APlus (AId X) (ANum 1))
       (assn_sub X (APlus (AId X) (ANum 2)) (fun st : state => st X = VNat 3)))
    (X ::= APlus (AId X) (ANum 1))
    (assn_sub X (APlus (AId X) (ANum 2)) (fun st : state => st X = VNat 3))
    (X ::= APlus (AId X) (ANum 2)) (fun st : state => st X = VNat 3)
    (H_Asgn
       (assn_sub X (APlus (AId X) (ANum 2)) (fun st : state => st X = VNat 3))
       X (APlus (AId X) (ANum 1)))
    (H_Asgn (fun st : state => st X = VNat 3) X (APlus (AId X) (ANum 2)))
*)

(** **** Exercise: 2 stars *)
(** Prove that such proof objects represent true claims. *)

Theorem hoare_proof_sound : forall P c Q,
  hoare_proof P c Q -> {{P}} c {{Q}}.
Proof.
  intros.
  hoare_proof_cases (induction X) Case; subst; simpl.
  Case "H_Skip".
    apply hoare_skip.
  Case "H_Asgn".
    apply hoare_asgn.
  Case "H_Seq".
    apply hoare_seq with (Q); assumption.
  Case "H_If".
    apply hoare_if; assumption.
  Case "H_While".
    apply hoare_while.
    assumption.
  Case "H_Consequence".
    apply hoare_consequence with P' Q'; assumption.
  Case "H_Consequence_pre".
    apply hoare_consequence_pre with P'; assumption.
  Case "H_Consequence_post".
    apply hoare_consequence_post with Q'; assumption.
Qed.

(** We can also use Coq's reasoning facilities to prove metatheorems
    about Hoare Logic.  For example, here are the analogs of two
    theorems we saw in chapter [Hoare] -- this time expressed in terms
    of the syntax of Hoare Logic derivations (provability) rather than
    directly in terms of the semantics of Hoare triples.

    The first one says that, for every [P] and [c], the assertion
    [{{P}} c {{True}}] is _provable_ in Hoare Logic.  Note that the
    proof is more complex than the semantic proof in [Hoare]: we
    actually need to perform an induction over the structure of the
    command [c]. *)

Theorem H_Post_True_deriv:
  forall c P, hoare_proof P c (fun _ => True).
Proof.
  intro c.
  com_cases (induction c) Case; intro P.
  Case "SKIP".
    eapply H_Consequence_pre.
    apply H_Skip.
    (* Proof of True *)
    intros. apply I.
  Case "::=".
    eapply H_Consequence_pre.
    apply H_Asgn.
    intros. apply I.
  Case ";".
    eapply H_Consequence_pre.
    eapply H_Seq.
    apply (IHc1 (fun _ => True)).
    apply IHc2.
    intros. apply I.
  Case "IFB".
    apply H_Consequence_pre with (fun _ => True).
    apply H_If.
    apply IHc1.
    apply IHc2.
    intros. apply I.
  Case "WHILE".
    eapply H_Consequence.
    eapply H_While.
    eapply IHc.
    intros; apply I.
    intros; apply I.
Qed.

(** Similarly, we can show that [{{False}} c {{Q}}] is provable for
    any [c] and [Q]. *)

Lemma False_and_P_imp: forall P Q,
  False /\ P -> Q.
Proof.
  intros P Q [CONTRA HP].
  destruct CONTRA.
Qed.

Tactic Notation "pre_false_helper" constr(CONSTR) :=
  eapply H_Consequence_pre;
    [eapply CONSTR | intros ? CONTRA; destruct CONTRA].

Theorem H_Pre_False_deriv:
  forall c Q, hoare_proof (fun _ => False) c Q.
Proof.
  intros c.
  com_cases (induction c) Case; intro Q.
  Case "SKIP". pre_false_helper H_Skip.
  Case "::=". pre_false_helper H_Asgn.
  Case ";". pre_false_helper H_Seq. apply IHc1. apply IHc2.
  Case "IFB".
    apply H_If; eapply H_Consequence_pre.
    apply IHc1. intro. eapply False_and_P_imp.
    apply IHc2. intro. eapply False_and_P_imp.
  Case "WHILE".
    eapply H_Consequence_post.
    eapply H_While.
    eapply H_Consequence_pre.
      apply IHc.
      intro. eapply False_and_P_imp.
    intro. simpl. eapply False_and_P_imp.
Qed.

(** This style of presentation gives a clearer picture of what it
    means to "give a proof in Hoare logic."  However, it is not
    entirely satisfactory from the point of view of writing down such
    proofs in practice: it is quite verbose.  The section of chapter
    [Hoare] on formalizing decorated programs shows how we can do even
    better. *)


Require Import CaMain.
Require Import ReoCA.
Import ListNotations.

Obligation Tactic := program_simpl ; congruence.

(*Two bisimilar automata from Baier et al.'s 2006 paper introducing Constraint Automata *)

Inductive automatonStates := q1 | p1 | r1 | q2 | p2 | r2 | p2' | q3 | u3.
Inductive automatonPorts := A | B | C.

Program Instance automatonStatesEq : EqDec automatonStates eq :=
	{equiv_dec x y :=
		match x, y with
		| q1,q1 => in_left
		| p1,p1 => in_left
 		| r1,r1 => in_left
		| q2,q2 => in_left
    | p2,p2 => in_left
		| r2,r2 => in_left
    | p2',p2' => in_left
    | q3, q3 => in_left
    | u3, u3 => in_left
    | q1,p1 | q1, r1 | q1,q2 | q1,p2 | q1, r2 | q1,p2' | q1,q3 | q1,u3 => in_right
    | p1,q1 | p1, r1 | p1,q2 | p1,p2 | p1, r2 | p1,p2' | p1,q3 | p1,u3 => in_right
    | r1,q1 | r1,p1  | r1,q2 | r1,p2 | r1, r2 | r1,p2' | r1,q3 | r1,u3 => in_right
    | q2,q1 | q2, p1 | q2,r1 | q2,p2 | q2, r2 | q2,p2' | q2,q3 | q2,u3 => in_right
    | p2,q1 | p2, p1 | p2,r1 | p2,q2 | p2, r2 | p2,p2' | p2,q3 | p2,u3 => in_right
    | r2,q1 | r2, p1 | r2,q2 | r2,p2 | r2, r1 | r2,p2' | r2,q3 | r2,u3 => in_right
    | p2',q1 | p2', p1 | p2',q2 | p2',p2 | p2', r1 | p2',r2 | p2',q3 | p2',u3 => in_right
    | q3,q1 | q3,p1 | q3, r1 | q3,q2 | q3,p2 | q3, r2 | q3,p2' | q3,u3 => in_right
    | u3,q1 | u3,p1 | u3, r1 | u3,q2 | u3,p2 | u3, r2 | u3,p2' | u3,q3 => in_right
		end
	}.

Program Instance automatonPortsEq : EqDec automatonPorts eq :=
	{equiv_dec x y :=
		match x, y with
		| A,A => in_left
		| B,B => in_left
    | C,C => in_left
		| A,B => in_right
		| B,A => in_right
    | A,C => in_right
    | B,C => in_right
    | C,A => in_right
    | C,B => in_right
		end
	}.

Close Scope Q_scope.

  Definition dataAssignmentA n :=
    match n with
    | 0 =>  1
    | 1 =>  (1)
    | 2 =>  0
    | S n =>  0
    end.

  Definition dataAssignmentB n :=
    match n with
    | 0 =>  1
    | 1 =>  (1)
    | 2 =>  0
    | S n =>  0
    end.

   Definition timeStampAutomatonA(n:nat) : QArith_base.Q :=
    match n with
    | 0 => 1#1
    | 1 => 5#1
    | 2 => 8#1
    | 3 => 11#1
    | 4 => 14#1
    | 5 => 17#1
    | S n =>  Z.of_nat (S n) + 16#1
    end.

  Definition timeStampAutomatonB (n:nat) : QArith_base.Q :=
    match n with
    | 0 => 2#1
    | 1 => 6#1
    | 2 => 9#1
    | 3 => 12#1
    | 4 => 15#1
    | 5 => 18#1
    | S n =>  Z.of_nat(S n) + 170#1
    end.

  Lemma timeStampAutomatonAHolds : forall n,
    Qlt (timeStampAutomatonA n) (timeStampAutomatonA (S n)).
  Proof.
  intros. destruct n. unfold timeStampAutomatonA. reflexivity.
  unfold timeStampAutomatonA. case (n). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. unfold Qlt. apply orderZofNat.  Defined.

  Lemma timeStampAutomatonBHolds : forall n,
    Qlt (timeStampAutomatonB n) (timeStampAutomatonB (S n)).
  Proof.
  intros. destruct n. unfold timeStampAutomatonB. reflexivity.
  unfold timeStampAutomatonB. case (n). reflexivity.
  intros n0. case (n0). reflexivity.
  intros n1. case (n1). reflexivity.
  intros n2. case (n2). reflexivity.
  intros n3. case (n3). reflexivity.
  intros n4. apply orderZofNat. Defined.

  Definition portA := {|
        ConstraintAutomata.id := A;
        ConstraintAutomata.dataAssignment := dataAssignmentA;
        ConstraintAutomata.timeStamp := timeStampAutomatonA;
        ConstraintAutomata.tdsCond := timeStampAutomatonAHolds;
        ConstraintAutomata.index := 0 |}.

  Definition portB := {|
        ConstraintAutomata.id := B;
        ConstraintAutomata.dataAssignment := dataAssignmentB;
        ConstraintAutomata.timeStamp := timeStampAutomatonB;
        ConstraintAutomata.tdsCond := timeStampAutomatonBHolds;
        ConstraintAutomata.index := 0 |}.

  Definition automaton1Transition (s:automatonStates):=
    match s with
    | q1 => [([A], (ConstraintAutomata.tDc automatonPorts nat), p1);
             ([A], (ConstraintAutomata.tDc automatonPorts nat), r1)]
    | p1 => [([B], (ConstraintAutomata.tDc automatonPorts nat), q1)]
    | r1 => [([C], (ConstraintAutomata.tDc automatonPorts nat), q1)]
    | _ => []
    end.

  (*Automaton 1*)
  Definition firstAutomaton := ConstraintAutomata.CA ([q1;p1;r1]) ([A;B;C]) (automaton1Transition)
  ([q1]).

  (* We parametrize the data item as in the example *)
  Definition automaton2Transition (n:nat) (s:automatonStates) :
  set (set automatonPorts * ConstraintAutomata.DC automatonPorts nat * automatonStates) :=
    match s with
    | q2  => [([A], (ConstraintAutomata.dc A n), p2);
              ([A], ((ConstraintAutomata.negDc (ConstraintAutomata.dc A n))), p2');
              ([A], (ConstraintAutomata.tDc automatonPorts nat), r2)]
    | r2  => [([C], (ConstraintAutomata.tDc automatonPorts nat), q2)]
    | p2  => [([B], (ConstraintAutomata.tDc automatonPorts nat), q2)]
    | p2' => [([B], (ConstraintAutomata.tDc automatonPorts nat), q2)]
    | _ => []
    end.

  Definition secondAutomaton := ConstraintAutomata.CA ([q2;p2;p2';r2]) ([A;B;C]) (automaton2Transition 0)
  ([q2]).

  (* firstAutomaton and secondAutomaton are bisimilar *)
  Eval compute in ConstraintAutomata.bisimulation firstAutomaton secondAutomaton.

  (* Therefore, they are language equivalent *)
  Eval compute in ConstraintAutomata.areBisimilar firstAutomaton secondAutomaton.

  (* We also implement the non bisimilar automaton provided in the aforementioned example *)

  Definition automaton3Transition (n:nat) (s:automatonStates) :
  set (set automatonPorts * ConstraintAutomata.DC automatonPorts nat * automatonStates) :=
    match s with
    | q3  => [([A], (ConstraintAutomata.tDc automatonPorts nat), u3)]
    | u3  => [([B], (ConstraintAutomata.tDc automatonPorts nat), q3);
              ([C], (ConstraintAutomata.tDc automatonPorts nat), q3)]
    | _ => []
    end.

  Definition thirdAutomaton := ConstraintAutomata.CA ([q3;u3]) ([A;B;C]) (automaton3Transition 0)
  ([q3]).

  (* And we may verify that they are not bisimilar *)
  Eval compute in ConstraintAutomata.bisimulation firstAutomaton thirdAutomaton.

  Eval compute in ConstraintAutomata.areBisimilar firstAutomaton thirdAutomaton.


From Hammer Require Import Tactics Reflect Hints.
From Hammer Require Import Hammer.

From mathcomp Require Import ssreflect ssrfun zmodp ssrbool ssrnat ssralg seq fintype finalg tuple eqtype.

From Coq Require Import FunctionalExtensionality.
From Coq Require Import Relation_Definitions RelationClasses.

Require Import CoqArith.Utils.

Require Import Program.

Section Sigma_1_1_Internal.

Inductive PolyTerm {A : nat -> nat} : Type :=
| PolyVar : nat -> PolyTerm
| PolyFun : forall i, (|[A i]| -> PolyTerm) -> PolyTerm
| PolyMinusOne : PolyTerm
| PolyPlusOne : PolyTerm
| PolyZero : PolyTerm
| PolyPlus : PolyTerm -> PolyTerm -> PolyTerm
| PolyTimes : PolyTerm -> PolyTerm -> PolyTerm
| PolyInd : PolyTerm -> PolyTerm -> PolyTerm.

Inductive ZerothOrderFormula {A} : Type :=
| ZONot : ZerothOrderFormula -> ZerothOrderFormula
| ZOAnd : ZerothOrderFormula -> ZerothOrderFormula -> ZerothOrderFormula
| ZOOr : ZerothOrderFormula -> ZerothOrderFormula -> ZerothOrderFormula
| ZOImp : ZerothOrderFormula -> ZerothOrderFormula -> ZerothOrderFormula
| ZOEq : @PolyTerm A -> @PolyTerm A -> ZerothOrderFormula.

Inductive QuantifiedFormula {A} : Type :=
| ZO : @ZerothOrderFormula A
    -> QuantifiedFormula
| QExists : forall (bs : seq (@PolyTerm A))
                   (y : @PolyTerm A),
            QuantifiedFormula
         -> QuantifiedFormula
| QForall : @PolyTerm A
         -> QuantifiedFormula
         -> QuantifiedFormula.

End Sigma_1_1_Internal.

Section Sigma_1_1_Denotation.

Variable (FSize : nat).

Record Sigma11Model : Type :=
  mkSigma11Model {
      V_F : nat -> 'F_FSize;
      F_E : nat -> nat;
      F_S : forall i, (|[F_E i]| -> 'F_FSize) -> option 'F_FSize;
  }.

Definition indFun {p} (x y : 'F_p) : 'F_p := if (x < y) then 1%R else 0%R.

Theorem FinFieEq {p} {a b : 'F_p} (e : a == b = true) : a = b.
Proof.
  destruct a, b.
  apply EEConvert in e; simpl in e.
  destruct e.
  by replace i with i0;[|apply eq_irrelevance].
Qed.

Program Fixpoint Poly_Denote (M : Sigma11Model)
  (r : @PolyTerm (F_E M)) : option ('F_FSize) :=
  match r with
  | PolyVar m => Some (V_F M m)
  | PolyFun i t =>
    let ds := option_fun (fun x => Poly_Denote M (t x)) in
    obind (fun t => (F_S M i) t) ds
  | PolyMinusOne => Some (-1)%R
  | PolyPlusOne => Some 1%R
  | PolyZero => Some 0%R
  | PolyPlus r1 r2 =>
    let d1 := Poly_Denote M r1 in
    let d2 := Poly_Denote M r2 in
    obind (fun r1 => obind (fun r2 => Some (r1 + r2)%R) d2) d1
  | PolyTimes r1 r2 =>
    let d1 := Poly_Denote M r1 in
    let d2 := Poly_Denote M r2 in
    obind (fun r1 => obind (fun r2 => Some (r1 * r2)%R) d2) d1
  | PolyInd r1 r2 =>
    let r1 := Poly_Denote M r1 in
    let r2 := Poly_Denote M r2 in
    obind (fun r1 => obind (fun r2 => Some (indFun r1 r2)) r2) r1
  end.

Fixpoint ZerothOrder_Denote (M : Sigma11Model)
  (f : ZerothOrderFormula) : option bool :=
  match f with
  | ZONot f =>
    let d := ZerothOrder_Denote M f in
    obind (fun d => Some (negb d)) d
  | ZOAnd f1 f2 =>
    let d1 := ZerothOrder_Denote M f1 in
    let d2 := ZerothOrder_Denote M f2 in
    obind (fun r1 => obind (fun r2 => Some (r1 && r2)) d2) d1
  | ZOOr f1 f2 =>
    let d1 := ZerothOrder_Denote M f1 in
    let d2 := ZerothOrder_Denote M f2 in
    obind (fun r1 => obind (fun r2 => Some (r1 || r2)) d2) d1
  | ZOImp f1 f2 =>
    let d1 := ZerothOrder_Denote M f1 in
    let d2 := ZerothOrder_Denote M f2 in
    obind (fun r1 => obind (fun r2 => Some (r1 ==> r2)) d2) d1
  | ZOEq r1 r2 =>
    let d1 := Poly_Denote M r1 in
    let d2 := Poly_Denote M r2 in
    obind (fun r1 => obind (fun r2 => Some (r1 == r2)) d2) d1
  end.

Definition AddModelV (M : Sigma11Model) (r : 'F_FSize) : Sigma11Model :=
  {| V_F := ExtendAt0 r (V_F M); F_S := F_S M |}.

Program Definition AddModelF  (M : Sigma11Model) newA (f : (|[newA]| -> 'F_FSize) -> option ('F_FSize))  :
  Sigma11Model := {| V_F := V_F M; F_E := ExtendAt0 newA (F_E M);
  F_S := fun i => (
  if i == 0 as b return i == 0 = b -> (|[ExtendAt0 newA (F_E M) i]| -> 'F_FSize) -> option 'F_FSize
  then fun _ => f
  else fun _ => F_S M (i.-1)
) (erefl _) |}.
Next Obligation. destruct i;auto. Qed.
Next Obligation. destruct i;auto. Qed.

Program Fixpoint FunBounds
  (M : Sigma11Model) {a}
  (ins : |[a]| -> 'F_FSize) (out : 'F_FSize)
  (insB : |[a]| -> @PolyTerm (F_E M)) (outB : @PolyTerm (F_E M)) : bool :=
  match a with
  | 0 =>
    match Poly_Denote M outB with
    | None => false
    | Some oB => out < oB
    end
  | n.+1 =>
    match Poly_Denote M (insB 0) with
    | None => false
    | Some iB => (ins 0 < iB) && @FunBounds (AddModelV M (ins 0)) n (fun x => ins (x.+1)) out (fun x => insB (x.+1)) outB
    end
  end.

Definition Fun_Bound_Check
  (M : Sigma11Model)
  {n : nat}
  (bs : |[n]| -> PolyTerm)
  (y : PolyTerm)
  (f : (|[n]| -> 'F_FSize) -> option ('F_FSize)) : Prop :=
forall (ins : |[n]| -> 'F_FSize) (out : 'F_FSize),
  f ins == Some out ->
  FunBounds M ins out bs y == true.

 Fixpoint QuantifiedFormula_Denote (M : Sigma11Model) (f : @QuantifiedFormula (F_E M)) : Prop :=
  match f with
  | ZO z => ZerothOrder_Denote M z == Some true
  | QExists bs y f =>
    exists (F : (|[length bs]| -> 'F_FSize) -> option ('F_FSize)),
    Fun_Bound_Check M (lnth bs) y F /\ QuantifiedFormula_Denote (AddModelF M (length bs) F) f
  | QForall b f =>
    match Poly_Denote M b with
    | None => False
    | Some p' => forall (r : 'F_FSize), r < p' -> QuantifiedFormula_Denote (AddModelV M r) f
    end
  end.
Next Obligation.

End Sigma_1_1_Denotation.


(*|
#########################
Heterogeneous list in Coq
#########################

:Link: https://stackoverflow.com/q/29404082
|*)

(*|
Question
********

I'm considering writing a Coq program to verify certain properties of
`relational algebra
<http://en.wikipedia.org/wiki/Relational_algebra>`__. I've got some of
the basic data types working, but concatenating tuples is giving me
some trouble.

Here's the relevant section of code:
|*)

Require Import List.
Require Import String.

(* An enum representing SQL types *)
Inductive sqlType : Set := Nat | Bool.

(* Defines a map from SQL types (which are just enum values) to Coq types. *)
Fixpoint toType (t : sqlType) : Set :=
  match t with
  | Nat => nat
  | Bool => bool
  end.

(* A column consists of a name and a type. *)
Inductive column : Set :=
| Col : string -> sqlType -> column.

(* A schema is a list of columns. *)
Definition schema : Set := list column.

(* Concatenates two schema together. *)
Definition concatSchema (r : schema) (s : schema) : schema := app r s.

(* Sends a schema to the corresponding Coq type. *)
Fixpoint tuple (s : schema) : Set :=
  match s with
  | nil => unit
  | cons (Col str t) sch => prod (toType t) (tuple sch)
  end.

Fail Fixpoint concatTuples {r : schema} {s : schema}
         (a : tuple r) (b : tuple s) : tuple (concatSchema r s) :=
  match r with
  | nil => b
  | cons _ _ => (fst a, concatTuples (snd a) b)
  end. (* .fails .unfold *)

(*|
I think I understand what's happening there; the type checker can't
figure out that ``s`` and ``concatSchema nil s`` are equal. But what I
find weirder is that when I add the following line:
|*)

Definition stupid {s : schema} (b : tuple s) : tuple (concatSchema nil s) := b.

(*|
and change the case to ``nil => stupid b``, it works. (Well, it still
complains at the cons case, but I think that means it's accepting the
``nil`` case.)

I have three questions about this:

1. Is there a way to eliminate ``stupid``? It seems like Coq knows the
   types are equal, it just needs some kind of hint.
2. How on earth can I do the cons case? I'm having lots of trouble
   writing a ``stupid``-like function.
3. Is this even the right approach to heterogeneous lists? It seems
   like the most straightforward one to me, but I have a very loose
   grasp of Curry-Howard, and what Coq code actually means.
|*)

(*|
Answer
******

This is one of the most recurrent problems for newcomers in Coq: not
being able to show Coq how to use the additional information one gains
in the branches of a ``match`` statement.

The solution is to use the so-called `convoy pattern
<http://adam.chlipala.net/cpdt/html/MoreDep.html>`__, re-abstracting
the arguments that depend on your scrutinee and making your ``match``
return a function:
|*)

Fixpoint concatTuples {r : schema} {s : schema} :
  tuple r -> tuple s -> tuple (concatSchema r s) :=
  match r return tuple r -> tuple s -> tuple (concatSchema r s) with
  | nil => fun a b => b
  | cons (Col _ t) _ => fun a b => (fst a, concatTuples (snd a) b)
  end.

(*|
In this particular case, the ``return`` annotation is not actually
needed, as Coq can infer it. However, omitting it can often lead to
incomprehensible error messages when things go a bit wrong, so it's a
nice idea to leave them in. Notice that we had to also include a
nested match on the first element of our list (the ``Col _ t``
pattern), in order to mimic the pattern in the definition of
``tuple``. Once again, `CPDT
<http://adam.chlipala.net/cpdt/html/MoreDep.html>`__ explains in great
detail what is going on here and how to write this sort of function in
Coq.

To answer your last question, many developments to heterogeneous lists
more or less in the same way you're doing here (I for instance have
`one development
<https://github.com/arthuraa/coq-utils/blob/master/theories/hseq.v>`__
that is pretty similar to this one). If I had to change anything, I
would remove the nested pattern in the definition of ``tuple``, which
allows you do write this sort of code while using less ``match``\ es
and annotations. Compare:
|*)

Reset tuple. (* .none *)
Definition typeOfCol c :=
  match c with
  | Col _ t => t
  end.

(* Sends a schema to the corresponding Coq type. *)
Fixpoint tuple (s : schema) : Set :=
  match s with
  | nil => unit
  | cons col sch => prod (toType (typeOfCol col)) (tuple sch)
  end.

Fixpoint concatTuples {r : schema} {s : schema} :
  tuple r -> tuple s -> tuple (concatSchema r s) :=
  match r return tuple r -> tuple s -> tuple (concatSchema r s) with
  | nil => fun a b => b
  | cons _ _ => fun a b => (fst a, concatTuples (snd a) b)
  end.

(*|
You can find other examples of this issue `here
<https://stackoverflow.com/questions/16952524/structural-recursion-on-a-dependent-parameter>`__
and `here
<https://stackoverflow.com/questions/28487158/implementing-vector-addition-in-coq>`__.
|*)


Require Import Reals Psatz.
From mathcomp Require Import all_ssreflect all_algebra finset seq.
From GraphTheory Require Import digraph.
From Coquelicot Require Import Lim_seq Rbar.
From mathcomp.analysis Require Import Rstruct.
From Coq Require Import Logic.FunctionalExtensionality.

Open Scope R_scope.
Open Scope ring_scope.

Delimit Scope ring_scope with Ri.
Delimit Scope R_scope with Re.

Import GRing.Theory Num.Def Num.Theory.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Notation diGraph := relType.
Notation di_edge := edge_rel.

(**** Define graph topology ******)

Variables (D: diGraph).

(** Define an F-paramter **)
Variable F:nat.

(** Define the vertex set **)
Definition Vertex : {set D}:= setT.

(** Define the set of advversary nodes **)
Definition Adversary (corrupt_choice:D -> bool):=
  [set x:D | corrupt_choice x == true].

(** Defines set of normal nodes **)
Definition Normal (corrupt_choice:D -> bool):=
  Vertex :\: Adversary corrupt_choice.

(** Define a set of in-neighbors :
  set of neighbors of i such that for any
  j in the set, j--i is a valid edge relation in the
  graph
**)
Definition in_neighbor (i:D) := [set j : D | j -- i].

(** Define the in-degree of i **)
Definition in_degree (i:D):= #|in_neighbor i|.

(** Define a set of out-neighbors:
  set of neigbors of i such that information
  flows from i to j
**)
Definition out_neighbor (i:D) := [set j:D | i -- j].

(** Define a set of inclusive neighbors:
  union of the set of in-neighbors and i itself **)
Definition inclusive_neigh (i:D) :=
   (in_neighbor i) :|: set1 i.

(** Define a r-reachable set **)
Definition r_reachable (r:nat) (S: {set D}):=
  S \proper Vertex /\ (#|S| > 0)%N /\
  (forall i:D, i \in S -> (#| (in_neighbor i) :\: S| >= r)%N).

(** Define a non-empty and non-trivial digraph **)
Definition nonempty_nontrivial_graph:= (#|D| >= 2)%N.

(** Define r-robustness **)
Definition r_robustness (r: nat):=
  nonempty_nontrivial_graph /\
  (forall (S1 S2: {set D}),
      (S1 \proper Vertex /\ (#|S1|>0)%N) ->
      (S2 \proper Vertex /\ (#|S2|>0)%N) ->
      [disjoint S1 & S2] ->
      (r_reachable r S1 \/ r_reachable r S2)).

(** Define (r,s)-reachable set **)

(* Define Xi_S_r **)
Definition Xi_S_r (S: {set D}) (r:nat):=
  [set i:D | i \in S & (#| (in_neighbor i) :\: S| >= r)%N].

(** Define (r,s)-reachability  **)
Definition r_s_reachable (S: {set D}) (r s:nat):=
  (S \proper Vertex /\ (#|S| > 0)%N) -> (#|Xi_S_r S r| >= s)%N.

(** Define (r,s)-robustness **)
Definition r_s_robustness (r s:nat):=
  nonempty_nontrivial_graph /\
  ( (1 <= s <= #|D|)%N ->
    forall (S1 S2: {set D}),
      (S1 \proper Vertex /\ (#|S1|>0)%N) ->
      (S2 \proper Vertex /\ (#|S2|>0)%N) ->
      [disjoint S1 & S2] ->
      ( (#|Xi_S_r S1 r| == #|S1|) ||
        (#|Xi_S_r S2 r| == #|S2|) ||
        (#|Xi_S_r S1 r| + #|Xi_S_r S2 r| >=s)%N )).

(*** Define the threat model and the W_MSR update ***)

Definition sorted_Dseq_rel (x: D -> R) (i j:D):=
if Rle_dec (x i) (x j) then if (x i == x j)%Re then
(index i (enum D) <= index j (enum D))%N else true
else false.
(**
if (x i == x j)%Re then (index i (enum D) < index j (enum D))%N else false.
**)
Definition sorted_seqD (l:seq D) (x:D -> R) :=
sort (sorted_Dseq_rel x) l.

Lemma pathP_D x p x0 (e:rel D) :
(forall i, (i < size p)%N -> e (nth x0 (x :: p) i) (nth x0 p i)) <->
(path e x p).
Proof.
split. intro. by apply /(pathP x0).
intro. by apply /pathP.
Qed.

(** define list of verticies **)
Definition inclusive_neighbor_list (i:D) (x:D -> R) := sort (sorted_Dseq_rel (x)) (enum (inclusive_neigh i)).

(** removes nodes in top F of list and greater than x t i or
in bottom F of list and less than x t i **)
Definition remove_extremes (i:D) (l:seq D) (x:D -> R) : (seq D) :=
  filter (fun (j:D) => (((Rge_dec (x j) (x i)) || (F <= (index j l))%N) &&
  ( Rle_dec (x j) (x i)  || (index j l <= ((size l) - F - 1))%N))) l.

(** gets inclusive neighbors of i and removes values **)
Definition incl_neigh_minus_extremes (i:D) (x:D -> R) : (seq D) :=
  remove_extremes i (inclusive_neighbor_list i x) x.

(** define the value of a node at time **)
Fixpoint x (mal:nat -> D -> R) (init:D -> R) (A:D -> bool) (w:nat -> D*D -> R) (t:nat) (i:D) :=
  match (A i) with
  |true => mal t i
  |false =>
  (match t with
    | O => init i
    | S t' => sum_f_R0 (fun n:nat => let j :=
       (nth i (incl_neigh_minus_extremes i (x mal init A w t')) n) in
       (((x mal init A w t') j) * (w t' (i,j)))%Re) ((size (incl_neigh_minus_extremes i (x mal init A w t')))-1)
   end)
  end.

(** Defines the set of nodes, greater than
 x mal init A w t i, with values
in the top F of the inclusive_neighbor_list **)
Definition R_i_greater_than
(mal:nat -> D -> R) (init:D -> R) (A:D -> bool) (w:nat -> D*D -> R) (i:D) (t:nat) :=
[set j | Rgt_dec ((x mal init A w t) j)
  ((x mal init A w t) i) &&
  (index j (inclusive_neighbor_list i (x mal init A w t)) >
    ((size (inclusive_neighbor_list i (x mal init A w t))) - F - 1))%N &&
    (j \in (inclusive_neighbor_list i (x mal init A w t)))].

(** Defines the set of nodes, greater than
 x mal init A w t i, with values
in the top F of the inclusive_neighbor_list, or potentially not in
inclusive_neighbor_list **)
Definition R_i_greater_than_maybe_not_neighbors
(mal:nat -> D -> R) (init:D -> R) (A:D -> bool) (w:nat -> D*D -> R) (i:D) (t:nat) :=
[set j | Rgt_dec ((x mal init A w t) j)
  ((x mal init A w t) i) &&
  (index j (inclusive_neighbor_list i (x mal init A w t)) >
    ((size (inclusive_neighbor_list i (x mal init A w t))) - F - 1))%N].

(** Defines the set of nodes, less than
 x mal init A w t i, with values
in the top bottom of the inclusive_neighbor_list, or potentially not in
inclusive_neighbor_list **)
Definition R_i_less_than_maybe_not_neighbors
(mal:nat -> D -> R) (init:D -> R) (A:D -> bool) (w:nat -> D*D -> R) (i:D) (t:nat) :=
[set j | (Rlt_dec ((x mal init A w t) j)
  ((x mal init A w t) i)) &&
  (index j (inclusive_neighbor_list i (x mal init A w t)) < F)%N].

(** Defines the set of nodes, less than
 x mal init A w t i, with values
in the bottom F of the inclusive_neighbor_list **)
Definition R_i_less_than
(mal:nat -> D -> R) (init:D -> R) (A:D -> bool) (w:nat -> D*D -> R) (i:D) (t:nat) :=
[set j | (Rlt_dec ((x mal init A w t) j)
  ((x mal init A w t) i)) &&
  (index j (inclusive_neighbor_list i (x mal init A w t)) < F)%N &&
    (j \in (inclusive_neighbor_list i (x mal init A w t)))].

(** Defines condition for a node to have malicious behavior at a
given time **)
Definition malicious_at_i_t
(mal:nat -> D -> R) (init:D -> R) (A:D -> bool)
(w:nat -> D*D -> R) (i:D) (t:nat): bool :=
(x mal init A w (t+1) i) !=
sum_f_R0 (fun n:nat =>
            let j := (nth i (incl_neigh_minus_extremes i (x mal init A w t)) n) in
            ((x mal init A w t j) * (w t (i,j)))%Re)
     ((size (incl_neigh_minus_extremes i (x mal init A w t)))-1).

(** Define maliciousness **)
Definition malicious
(mal:nat -> D -> R) (init:D -> R) (A:D -> bool) (w:nat -> D*D -> R) (i:D) :=
exists t:nat, malicious_at_i_t mal init A w i t.

(** defines condition for weights given in W-MSR at time t **)
Definition wts_well_behaved
(A:D -> bool) (mal:nat -> D -> R) (init:D -> R) (w:nat -> D*D -> R) :=
exists a:R,
(0<a)%Re /\ (a <1)%Re /\
(forall (t:nat) (i:D),
  let incl := (incl_neigh_minus_extremes i (x mal init A w t)) in
    (forall j:D, j \notin incl -> (w t (i,j) = 0)%Re) /\
    (forall j:D, j \in incl ->(a <= w t (i,j)))%Re /\
    sum_f_R0 (fun n:nat => let j := (nth i incl n) in
                           (w t (i,j))%Re) ((size incl)-1) = 1%Re).

(** Define an F_total set S **)
Definition F_total (S: {set D}) :=
  S \proper Vertex /\ (#|S| <= F)%N.

(** Define a F-totally bounded set of adversary nodes **)
Definition F_totally_bounded (A:D -> bool) :=
F_total (Adversary A).

(** Define an F-total malicious network **)
Definition F_total_malicious
(mal:nat -> D -> R) (init:D -> R) (A:D -> bool) (w:nat -> D*D -> R) :=
F_totally_bounded A /\
(forall i:D, i \in Adversary A -> malicious mal init A w i) /\
(forall j:D, j \in Normal A -> ~ (malicious mal init A w j)).

(** defines min and max values of normal nodes **)
Definition m (mal:nat -> D -> R) (init:D -> R) (A:D -> bool) (w:nat -> D*D -> R) (t:nat): R :=
  -(bigmaxr 0 ((map (fun i:D => -(x mal init A w t i)))
  (enum (Normal A)))).
Definition M (mal:nat -> D -> R) (init:D -> R) (A:D -> bool) (w:nat -> D*D -> R) (t:nat): R :=
  bigmaxr 0 (map (x mal init A w t) (enum (Normal A))).

(** defines resilient asymptotic consensus **)
Definition Resilient_asymptotic_consensus
(A:D -> bool) (mal:nat -> D -> R) (init:D -> R) (w:nat -> D*D -> R):=
(F_total_malicious mal init A w) ->
(exists L:Rbar,
  forall (i:D), i \in (Normal A) ->
  is_lim_seq (fun t: nat => x mal init A w t i) L) /\
(forall t:nat,  (m mal init A w 0 <= m mal init A w t)%Re /\
                (M mal init A w t <= M mal init A w 0)%Re).

(** we have to introduce a propositional completeness lemms
    to reason classically. This is consistent with
    the definition of prop_degeneracy from the Coq classical
    facts library.
**)
Axiom proposition_degeneracy :
  forall A:Prop, A = True \/ A = False.

Lemma P_not_not_P:
  forall (P:Prop), P <->  ~(~ P).
Proof.
intros. split.
+ intros.
  assert ( P = True \/ P = False).
  { by apply proposition_degeneracy. }
  destruct H0.
  - by rewrite H0.
  - by [].
+ intros.
  assert ( P = True \/ P = False).
  { by apply proposition_degeneracy. }
  destruct H0.
  - by rewrite H0.
  - contradict H. by rewrite H0.
Qed.


Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.monads MathClasses.theory.jections MathClasses.theory.monads.

Inductive option_equiv A `{Equiv A} : Equiv (option A) :=
  | option_equiv_Some : Proper ((=) ==> (=)) Some
  | option_equiv_None : None = None.

Existing Instance option_equiv.
Hint Constructors option_equiv.

Section contents.
  Context `{Setoid A}.

  Lemma Some_ne_None x : Some x ≠ None.
  Proof. intros E. inversion E. Qed.

  Lemma None_ne_Some x : None ≠ Some x.
  Proof. intros E. inversion E. Qed.

  Global Instance: Setoid (option A).
  Proof.
    split.
      intros [x|]. now apply option_equiv_Some. now apply option_equiv_None.
     red. induction 1. now apply option_equiv_Some. now apply option_equiv_None.
    intros x y z E. revert z. induction E.
     intros z E2. inversion_clear E2.
     apply option_equiv_Some. etransitivity; eassumption.
    easy.
  Qed.

  Global Instance: Setoid_Morphism Some.
  Proof. split; try apply _. now apply option_equiv_Some. Qed.

  Global Instance: Injective Some.
  Proof. split; try apply _. intros ? ? E. now inversion E. Qed.

  Global Instance option_zero: MonUnit (option A) := None.

  Global Instance option_op: SgOp (option A) := λ mx my,
    match mx with
    | Some x => Some x
    | None => my
    end.

  Instance: Proper ((=) ==> (=) ==> (=)) option_op.
  Proof. intros [?|] [?|] ? ???; simpl; try setoid_discriminate; auto. Qed.

  Global Instance: Monoid (option A).
  Proof. repeat (split; try apply _); now repeat intros [?|]. Qed.

  Lemma option_equiv_alt x y :
    x = y ↔ (∀ n, x = Some n ↔ y = Some n).
  Proof.
    split; intros E1.
     intro. now rewrite E1.
    destruct x, y.
       now apply E1.
      symmetry. now apply E1.
     now apply E1.
    easy.
  Qed.

  Global Program Instance option_dec `(A_dec : ∀ x y : A, Decision (x = y))
     : ∀ x y : option A, Decision (x = y) := λ x y,
    match x with
    | Some r =>
      match y with
      | Some s => match A_dec r s with left _ => left _ | right _ => right _ end
      | None => right _
      end
    | None =>
      match y with
      | Some s => right _
      | None => left _
      end
    end.
  Next Obligation. now apply (injective_ne Some). Qed.
  Next Obligation. setoid_discriminate. Qed.
  Next Obligation. setoid_discriminate. Qed.
End contents.

Hint Extern 10 (Equiv (option _)) => apply @option_equiv : typeclass_instances.

Lemma option_equiv_eq {A} (x y : option A) :
  @option_equiv A (≡) x y ↔ x ≡ y.
Proof.
  split.
   induction 1. now f_equal. reflexivity.
  intros. subst.
  now assert (@Setoid A (@eq A)) by (split; apply _).
Qed.

Instance option_ret: MonadReturn option := λ A x, Some x.
Instance option_bind: MonadBind option := λ A B f x,
  match x with
  | Some a => f a
  | None => None
  end.

Instance option_ret_proper `{Equiv A} : Proper ((=) ==> (=)) (option_ret A).
Proof. intros x y E. now apply option_equiv_Some. Qed.

Instance option_bind_proper `{Setoid A} `{Setoid (option B)}: Proper (=) (option_bind A B).
Proof.
  intros f₁ f₂ E1 x₁ x₂ [?|].
   unfold option_bind. simpl. now apply E1.
  easy.
Qed.

Instance: Monad option.
Proof.
  repeat (split; try apply _); unfold bind, ret, option_bind, option_ret, compose.
    intros. now apply setoids.ext_equiv_refl.
   now intros ? ? ? [?|].
  intros A ? B ? C ? ? f [???] g [???] [x|] [y|] E; try solve [inversion_clear E].
   setoid_inject. cut (g x = g y); [|now rewrite E].
   case (g x), (g y); intros E2; inversion_clear E2. now f_equiv. easy.
  easy.
Qed.

Instance option_map: SFmap option := option_map.

Instance: FullMonad option.
Proof. apply @monad_default_full_monad. apply _. Qed.

Section map.
  Context `{Setoid A} `{Setoid B} `{!Injective (f : A → B)}.

  Global Instance: Injective (sfmap f).
  Proof.
    pose proof (injective_mor f).
    repeat (split; try apply _).
    intros [x|] [y|] E; try solve [inversion E | easy].
    apply sm_proper. apply (injective f). now apply (injective Some).
  Qed.
End map.