Require Import FP.Data.String.
Require Import FP.Data.Function.
Require Import FP.Data.Identity.
Require Import FP.Data.Sum.
Require Import FP.Data.Unit.
Require Import FP.Data.SumRelations.
Require Import FP.Structures.Additive.
Require Import FP.Structures.EqvEnv.
Require Import FP.Structures.Comonad.
Require Import FP.Structures.EqDec.
Require Import FP.Structures.Eqv.
Require Import FP.Structures.Foldable.
Require Import FP.Structures.Lattice.
Require Import FP.Structures.Functor.
Require Import FP.Structures.Functor.
Require Import FP.Structures.Monad.
Require Import FP.Structures.Applicative.
Require Import FP.Structures.Counit.
Require Import FP.Structures.Injection.
Require Import FP.Structures.FUnit.
Require Import FP.Structures.Injection.
Require Import FP.Structures.Monad.
Require Import FP.Structures.MonadError.
Require Import FP.Structures.Proxy.
Require Import FP.Structures.Deriving.
Require Import FP.Structures.FUnit.
Require Import FP.Structures.FUnitDeriving.
Require Import FP.Structures.MonadReader.
Require Import FP.Structures.MonadState.
Require Import FP.Structures.MonadReader.
Require Import FP.Structures.MonadDeriving.
Require Import FP.Structures.MonadTrans.
Require Import FP.Structures.Monoid.
Require Import FP.Structures.Ord.
Require Import FP.Relations.RelDec.
Require Import FP.Relations.Setoid.
Require Import FP.Relations.Function.

Import AdditiveNotation.
Import EqvNotation.
Import FunctionNotation.
Import FunctorNotation.
Import MonadNotation.
Import ProperNotation.

Arguments Some {A} _.
Arguments None {A}.

Section sum_Bijection.
  Context {A:Type}.

  Definition option_to_sum (aM:option A) : unit + A :=
    match aM with
    | None => inl tt
    | Some a => inr a
    end.
  Global Instance option_to_sum_InjectionResp_eq
      : InjectionRespect (option A) (unit+A) option_to_sum eq eq.
  Proof.
    constructor ; unfold Proper ; simpl in * ; intros ; try congruence.
    destruct x,y ; simpl in * ; congruence.
  Qed.

  Definition sum_to_option (aM:unit+A) : option A :=
    match aM with
    | inl tt => None
    | inr a => Some a
    end.
  Global Instance sum_to_option_InjectionInverse_eq
      : InjectionInverse (unit+A) (option A) sum_to_option option_to_sum eq.
  Proof.
    constructor ; intros.
    destruct x ; [ destruct u | idtac ] ; simpl in * ; auto.
  Qed.
End sum_Bijection.

Module option_DTKS1_Arg <: DerivingTheKitchenSink1_Arg.
  Definition T A := option A.
  Definition U A := (unit:Type)+A.
  Definition to {A} (x:T A) := option_to_sum x.
  Definition from {A} (x:U A) := sum_to_option x.
  Definition InjResp A : InjectionRespect (T A) (U A) to eq eq := _.
  Definition InjInv A : InjectionInverse (U A) (T A) from to eq := _.
  Definition U_EqDec :
    forall {A} {EqDec_:EqDec A},
    EqDec (U A) := _.
  Definition U_EqDec_RDC :
    forall {A} {EqDec_:EqDec A} {EqDec_RDC:RelDecCorrect A eq eq_dec},
    RelDecCorrect (U A) eq eq_dec := _.
  Definition U_Eqv :
    forall {A} {Eqv_:Eqv A},
    Eqv (U A) := _.
  Definition U_Eqv_PE_WF :
    forall {A} {Eqv_:Eqv A} {Eqv_PE_WF_:Eqv_PE_WF A},
    Eqv_PE_WF (U A) := _.
  Definition U_Eqv_E_WF :
    forall {A} {Eqv_:Eqv A} {Eqv_PE_WF_:Eqv_E_WF A},
    Eqv_E_WF (U A) := _.
  Definition U_EqvDec :
    forall {A} {EqvDec_:EqvDec A},
    EqvDec (U A) := _.
  Definition U_EqvDec_RDC :
    forall {A} {Eqv_:Eqv A} {EqvDec_:EqvDec A} {EqvDec_RDC_:RelDecCorrect A eqv eqv_dec},
    RelDecCorrect (U A) eqv eqv_dec := _.
  Definition U_Ord :
    forall {A} {Ord_:Ord A},
    Ord (U A) := _.
  Definition U_OrdWF :
    forall {A} {Eqv_:Eqv A} {Eqv_E_WF_:Eqv_E_WF A} {Ord_:Ord A} {OrdWF_:OrdWF A},
    OrdWF (U A) := _.
  Definition U_OrdDec :
    forall {A} {OrdDec_:OrdDec A},
    OrdDec (U A) := _.
  Definition U_ODC :
    forall {A} {Eqv_:Eqv A} {Ord_:Ord A} {OrdDec_:OrdDec A} {ODC_:OrdDecCorrect A},
    OrdDecCorrect (U A) := _.
  Definition U_Lattice :
    forall {A} {Lattice_:Lattice A},
    Lattice (U A) := _.
  Definition U_LatticeWF :
    forall {A}
      {Eqv_:Eqv A} {Eqv_E_WF_:Eqv_E_WF A}
      {Ord_:Ord A} {OrdWF_:OrdWF A}
      {Lattice_:Lattice A} {LatticeWF_:LatticeWF A},
    LatticeWF (U A) := _.
  Definition U_BoundedLattice :
    forall {A} {BoundedLattice_:BoundedLattice A},
    BoundedLattice (U A) := _.
  Definition U_BoundedLatticeWF :
    forall {A}
      {Eqv_:Eqv A} {Eqv_E_WF_:Eqv_E_WF A}
      {Ord_:Ord A} {OrdWF_:OrdWF A}
      {Lattice_:Lattice A} {LatticeWF_:LatticeWF A}
      {BoundedLattice_:BoundedLattice A} {BoundedLatticeWF_:BoundedLatticeWF A},
    BoundedLatticeWF (U A) := _.
End option_DTKS1_Arg.

Module option_DTKS1 := DerivingTheKitchenSink1 option_DTKS1_Arg.
Import option_DTKS1.

Instance Some_InjectionRespect_eqv {A} {Eqv_:Eqv A} :
  InjectionRespect A (option A) Some eqv eqv.
Proof.
  constructor ; unfold Proper,"==>","<==" ; intros.
  constructor ; auto.
  inversion H ; auto.
Qed.

Instance None_Proper {A} {Eqv_:Eqv A} :
  Proper eqv (None (A:=A)).
Proof.
  unfold Proper,eqv ; simpl.
  eapply InjectionRespect_eta ; reflexivity.
Qed.

Instance Some_Proper {A} {Eqv_:Eqv A} :
  Proper eqv (Some (A:=A)).
Proof.
  apply eqv_env_logical_intro_eqv.
  apply InjectionRespect_eta.
Qed.

Ltac destruct_option_eqv x y :=
  match goal with
  | [ e : eqv x y |- _ ] =>
      destruct x,y ;
      [ apply InjectionRespect_beta in e
      | inversion e
      | inversion e
      | idtac ]
  end.

Definition option_elim {A C} (aM:option A) (z:C) (f:A -> C) : C :=
  match aM with
  | None => z
  | Some a => f a
  end.

Global Instance option_elim_respect {A C} {aP:Eqv A} {cP:Eqv C} :
  Proper eqv (option_elim (A:=A) (C:=C)).
Proof.
  unfold option_elim.
  logical_eqv_eqv.
  destruct_option_eqv x y ; logical_eqv_eqv.
Qed.

Ltac fold_option_elim :=
  match goal with
  | [ |- context
         [ match ?aM with
           | None => ?z
           | Some a => (@?f a)
           end
         ]
    ] => fold (option_elim aM z f)
  end.

Definition from_option {A} (a:A) (aM:option A) : A :=
  match aM with
  | None => a
  | Some a' => a'
  end.

Section throw_msg_option.
  Context {m E} {mM:Monad m} {mE:MError E m} {eI:HasInjection string E}.

  Definition throw_msg_option {A} (msg:string) (xM:option A) : m A :=
    match xM with
    | None => throw_msg msg
    | Some x => ret x
    end.
End throw_msg_option.

Section monoid_option.
  Context {T} {TM:Monoid T}.
  Definition monoid_option (xM:option T) : T :=
    match xM with
    | None => gunit
    | Some x => x
    end.
End monoid_option.

Section Foldable.
  Context {A:Type}.
  Definition option_cofold {m} {M:Comonad m} {B}
      (f:A -> m B -> B) (b:m B) (aM:option A) : B :=
    match aM with
    | None => counit b
    | Some a => f a b
    end.
  Global Instance option_Foldable : Foldable A (option A) :=
    { cofold := @option_cofold }.
End Foldable.

(* option_t *)

Inductive option_t m (A:Type) := OptionT { un_option_t : m (option A) }.
Arguments OptionT {m A} _.
Arguments un_option_t {m A} _.

Section m_option_Bijection.
  Context {m:Type -> Type} {A:Type}.

  Definition option_t_to_m_option : option_t m A -> m (option A) := un_option_t.
  Global Instance option_t_to_m_option_InjectionResp_eq
      : InjectionRespect (option_t m A) (m (option A)) option_t_to_m_option eq eq.
  Proof.
    constructor ; try congruence.
    unfold Proper,"<==" ; intros.
    destruct x,y ; simpl in * ; congruence.
  Qed.
  Arguments option_t_to_m_option _ /.

  Definition m_option_to_option_t : m (option A) -> option_t m A := OptionT.
  Global Instance m_option__to_option_t_InjectionInverse_eq
      : InjectionInverse (m (option A)) (option_t m A)
                         m_option_to_option_t option_t_to_m_option eq.
  Proof.
    constructor ; auto.
  Qed.
End m_option_Bijection.

Module option_t_DTKS2_Arg <: DerivingTheKitchenSink2_Arg.
  Definition T (m:Type->Type) A := option_t m A.
  Definition U (m:Type->Type) A := m (option A).
  Definition to {m A} (x:T m A) := option_t_to_m_option x.
  Definition from {m A} (x:U m A) := m_option_to_option_t x.
  Definition InjResp m A : InjectionRespect (T m A) (U m A) to eq eq := _.
  Definition InjInv m A : InjectionInverse (U m A) (T m A) from to eq := _.
  Section m.
    Context {m:Type->Type}.
    Definition U_EqDec :
      forall
        {EqDec_m :
           forall {X} {EqDec_:EqDec X},
           EqDec (m X)}
        {A} {EqDec_:EqDec A},
      EqDec (U m A) := _.
    Definition U_EqDec_RDC :
      forall
        {EqDec_m :
           forall {X} {EqDec_:EqDec X},
           EqDec (m X)}
        {EqDec_RDC_m :
           forall {X} {EqDec_:EqDec X} {EqDec_RDC_:RelDecCorrect X eq eq_dec},
           RelDecCorrect (m X) eq eq_dec}
        {A} {EqDec_:EqDec A} {RDC_A:RelDecCorrect A eq eq_dec},
      RelDecCorrect (U m A) eq eq_dec := _.
    Definition U_Eqv :
      forall
        {Eqv_m :
           forall {X} {Eqv_:Eqv X},
           Eqv (m X)}
        {A} {Eqv_:Eqv A},
      Eqv (U m A) := _.
    Definition U_Eqv_PE_WF :
      forall
        {Eqv_m :
           forall {X} {Eqv_:Eqv X},
           Eqv (m X)}
        {Eqv_PE_WF_m :
           forall {X} {Eqv_:Eqv X} {Eqv_PE_WF_:Eqv_PE_WF X},
           Eqv_PE_WF (m X)}
        {A} {Eqv_:Eqv A} {Eqv_PE_WF_:Eqv_PE_WF A},
      Eqv_PE_WF (U m A) := _.
    Definition U_Eqv_E_WF :
      forall
        {Eqv_m :
           forall {X} {Eqv_:Eqv X},
           Eqv (m X)}
        {Eqv_E_WF_m :
           forall {X} {Eqv_:Eqv X} {Eqv_E_WF_:Eqv_E_WF X},
           Eqv_E_WF (m X)}
        {A} {Eqv_:Eqv A} {Eqv_E_WF_:Eqv_E_WF A},
      Eqv_E_WF (U m A) := _.
    Definition U_EqvDec :
      forall
        {EqvDec_m :
           forall {X} {EqvDec_:EqvDec X},
            EqvDec (m X)}
        {A} {EqvDec_:EqvDec A},
      EqvDec (U m A) := _.
    Definition U_EqvDec_RDC :
      forall
        {Eqv_m :
           forall {X} {Eqv_:Eqv X},
           Eqv (m X)}
        {EqvDec_m :
           forall {X} {EqvDec_:EqvDec X},
           EqvDec (m X)}
        {EqvDec_RDC_m :
           forall
             {X} {Eqv_:Eqv X} {EqvDec_:EqvDec X}
             {RDC_A:RelDecCorrect X eqv eqv_dec},
           RelDecCorrect (m X) eqv eqv_dec}
        {A} {Eqv_:Eqv A} {EqvDec_:EqvDec A} {RDC_A:RelDecCorrect A eqv eqv_dec},
      RelDecCorrect (U m A) eqv eqv_dec := _.
    Definition U_Ord :
      forall
        {Ord_m :
           forall {X} {Ord_:Ord X},
           Ord (m X)}
        {A} {Ord_:Ord A},
      Ord (U m A) := _.
    Definition U_OrdWF :
      forall
        {Eqv_m :
           forall {X} {Eqv_:Eqv X},
           Eqv (m X)}
        {Eqv_E_WF_m :
           forall {X} {Eqv_:Eqv X} {Eqv_E_WF_:Eqv_E_WF X},
           Eqv_E_WF (m X)}
        {Ord_m :
           forall {X} {Ord_:Ord X},
           Ord (m X)}
        {OrdWF_m :
           forall
             {X}
             {Eqv_:Eqv X} {Eqv_E_WF_:Eqv_E_WF X}
             {Ord_:Ord X} {Ord_WF_:OrdWF X},
           OrdWF (m X)}
        {A}
        {Eqv_:Eqv A} {Eqv_E_WF_:Eqv_E_WF A}
        {Ord_:Ord A} {Ord_WF_:OrdWF A},
      OrdWF (U m A) := _.
    Definition U_OrdDec :
      forall
        {OrdDec_m :
           forall {X} {OrdDec_:OrdDec X},
           OrdDec (m X)}
        {A} {OrdDec_:OrdDec A},
      OrdDec (U m A) := _.
    Definition U_ODC :
      forall
        {Eqv_m :
           forall {X} {Eqv_:Eqv X},
           Eqv (m X)}
        {Ord_m :
           forall {X} {Ord_:Ord X},
           Ord (m X)}
        {OrdDec_m :
           forall {X} {OrdDec_:OrdDec X},
           OrdDec (m X)}
        {ODC_m :
           forall
             {X} {Eqv_:Eqv X}
             {Ord_:Ord X} {OrdDec_:OrdDec X} {ODC_A:OrdDecCorrect X},
           OrdDecCorrect (m X)}
        {A}
        {Eqv_:Eqv A}
        {Ord_:Ord A} {OrdDec_:OrdDec A} {ODC_A:OrdDecCorrect A},
      OrdDecCorrect (U m A) := _.
    Definition U_Lattice :
      forall
        {Lattice_m :
           forall {X} {Lattice_:Lattice X},
           Lattice (m X)}
        {A} {Lattice_:Lattice A},
      Lattice (U m A) := _.
    Definition U_LatticeWF :
      forall
        {Eqv_m :
           forall {X} {Eqv_:Eqv X},
           Eqv (m X)}
        {Eqv_E_WF_m :
           forall {X} {Eqv_:Eqv X} {Eqv_E_WF_:Eqv_E_WF X},
           Eqv_E_WF (m X)}
        {Ord_m :
           forall {X} {Ord_:Ord X},
           Ord (m X)}
        {OrdWF_m :
           forall
             {X}
             {Eqv_:Eqv X} {Eqv_E_WF_:Eqv_E_WF X}
             {Ord_:Ord X} {Ord_WF_:OrdWF X},
           OrdWF (m X)}
        {Lattice_m :
           forall {X} {Lattice_:Lattice X},
           Lattice (m X)}
        {LatticeWF_m :
           forall {X}
             {Eqv_:Eqv X} {Eqv_E_WF_:Eqv_E_WF X}
             {Ord_:Ord X} {OrdWF_:OrdWF X}
             {Lattice_:Lattice X} {LatticeWF_:LatticeWF X},
           LatticeWF (m X)}
        {A}
        {Eqv_:Eqv A} {Eqv_E_WF_:Eqv_E_WF A}
        {Ord_:Ord A} {OrdWF_:OrdWF A}
        {Lattice_:Lattice A} {LatticeWF_:LatticeWF A},
      LatticeWF (U m A) := _.
    Definition U_BoundedLattice :
      forall
        {BoundedLattice_m :
           forall {X} {BoundedLattice_:BoundedLattice X},
           BoundedLattice (m X)}
        {A} {BoundedLattice_:BoundedLattice A},
      BoundedLattice (U m A) := _.
    Definition U_BoundedLatticeWF :
      forall
        {Eqv_m :
           forall {X} {Eqv_:Eqv X},
           Eqv (m X)}
        {Eqv_E_WF_m :
           forall {X} {Eqv_:Eqv X} {Eqv_E_WF_:Eqv_E_WF X},
           Eqv_E_WF (m X)}
        {Ord_m :
           forall {X} {Ord_:Ord X},
           Ord (m X)}
        {OrdWF_m :
           forall
             {X}
             {Eqv_:Eqv X} {Eqv_E_WF_:Eqv_E_WF X}
             {Ord_:Ord X} {Ord_WF_:OrdWF X},
           OrdWF (m X)}
        {Lattice_m :
           forall {X} {Lattice_:Lattice X},
           Lattice (m X)}
        {LatticeWF_m :
           forall {X}
             {Eqv_:Eqv X} {Eqv_E_WF_:Eqv_E_WF X}
             {Ord_:Ord X} {OrdWF_:OrdWF X}
             {Lattice_:Lattice X} {LatticeWF_:LatticeWF X},
           LatticeWF (m X)}
        {BoundedLattice_m :
           forall {X} {BoundedLattice_:BoundedLattice X},
           BoundedLattice (m X)}
        {BoundedLatticeWF_m :
           forall {X}
             {Eqv_:Eqv X} {Eqv_E_WF_:Eqv_E_WF X}
             {Ord_:Ord X} {OrdWF_:OrdWF X}
             {Lattice_:Lattice X} {LatticeWF_:LatticeWF X}
             {BoundedLattice_:BoundedLattice X} {BoundedLatticeWF_:BoundedLatticeWF X},
           BoundedLatticeWF (m X)}
        {A}
        {Eqv_:Eqv A} {Eqv_E_WF_:Eqv_E_WF A}
        {Ord_:Ord A} {OrdWF_:OrdWF A}
        {Lattice_:Lattice A} {LatticeWF_:LatticeWF A}
        {BoundedLattice_:BoundedLattice A} {BoundedLatticeWF_:BoundedLatticeWF A},
      BoundedLatticeWF (U m A) := _.
  End m.
End option_t_DTKS2_Arg.

Module option_DTKS2 := DerivingTheKitchenSink2 option_t_DTKS2_Arg.
Import option_DTKS2.

Section MonadTrans.
  Definition option_t_lift {m} {M:Monad m} {A} : m A -> option_t m A :=
    OptionT '.' bind_fmap Some.
  Global Instance option_t_MonadTrans : MonadTrans option_t :=
    { lift := @option_t_lift }.
End MonadTrans.

Section option_t_Monad.
  Context {m} {FUnit_:FUnit m} {MBind_:MBind m}.

  Definition run_option_t {A} : option_t m A -> m (option A) := un_option_t.

  Section Monad.
    Definition option_t_funit {A} (a:A) : option_t m A := OptionT $ ret $ Some a.
    Global Instance option_t_FUnit : FUnit (option_t m) :=
      { funit := @option_t_funit }.

    Definition option_t_bind {A B}
        (aMM:option_t m A) (f:A -> option_t m B) : option_t m B :=
      OptionT $ begin
        a <- un_option_t aMM ;;
        match a with
        | None => ret None
        | Some a => un_option_t $ f a
        end
      end.
    Global Instance option_t_MBind : MBind (option_t m) :=
      { bind := @option_t_bind }.
  End Monad.

  Global Instance option_t_FApply : FApply (option_t m) := Deriving_FApply_MBind.
  Global Instance option_t_FMap : FMap (option_t m) := Deriving_FMap_FApply.

  Section MonadWF.
    Local Instance EqvEnv_ : EqvEnv := eqv_EqvEnv.
    Local Instance EqvEnvLogical_ : EqvEnvLogical := eqv_EqvEnvLogical.
    Context {PE_R_m:forall {X} {aPER:Eqv X}, Eqv (m X)}.
    Context {PE_R_m': forall {X} {aPER:Eqv X} {blah:Eqv_PE_WF X}, Eqv_PE_WF (m X)}.

    Global Instance OptionT_respect {A} {aP:Eqv A} :
      Proper eqv (OptionT (m:=m) (A:=A)).
    Proof.
      unfold Proper ; logical_eqv_intro_eqv ; auto.
    Qed.

    Global Instance un_option_t_respect {A} {aP:Eqv A} :
      Proper eqv (un_option_t (m:=m) (A:=A)).
    Proof.
      unfold un_option_t ; simpl.
      logical_eqv_eqv.
    Qed.

    Context {FUnitWF_:FUnitWF m}.

    Global Instance option_t_FUnitWF : FUnitWF (option_t m).
    Proof.
      constructor ; intros.
      unfold Proper,env_eqv,funit ; simpl.
      logical_eqv_intro_eqv.
      unfold eqv ; simpl ; logical_eqv_eqv.
    Qed.

    Context {MonadWF_:MonadWF m}.

    Global Instance option_t_MonadWF : MonadWF (option_t m).
    Proof.
      Local Ltac my_logical_eqv :=
        repeat (try fold_option_elim ; logical_eqv_eqv).
      constructor ; intros ;
      unfold Proper,">>=",env_eqv ; simpl ; unfold "~=" ; simpl ;
      unfold option_t_to_m_option.
      - rewrite bind_left_unit_eqv ; my_logical_eqv.
      - transitivity (un_option_t aM >>= funit) ; my_logical_eqv.
        + destruct_option_eqv x y ; simpl ; my_logical_eqv.
        + rewrite bind_right_unit_eqv ; my_logical_eqv.
      - rewrite bind_associativity_eqv ; my_logical_eqv.
        destruct_option_eqv x y ; simpl ; my_logical_eqv.
        rewrite bind_left_unit_eqv ; my_logical_eqv.
      - change (let (eqv) := Px_Eqv in eqv)
        with (eqv (T:=option_t m A -> (A -> option_t m B) -> option_t m B)).
        unfold option_t_bind ; my_logical_eqv.
    Qed.

    Global Instance option_t_MonadRespApplicative : MonadRespApplicative (option_t m).
    Proof.
      constructor ; intros.
      change fapply with (bind_fapply (A:=A) (B:=B)).
      logical_eqv.
      assert (Proper env_eqv (bind_fapply (m:=option_t m) (A:=A) (B:=B))).
      pose (bind_fapply_respect (m:=option_t m) (A:=A) (B:=B)).
      Set Printing All.
      Show.
      simpl in p.
      apply p.
      Unset Printing All.
      Show.
      logical_eqv.
      logical_eqv.
      assert (P
  End MonadWF.

    Proof.
      constructor ; intros.
      change fapply with (bind_fapply (A:=A) (B:=B)).
      eapply Proper_PE_R_app.
      logical_eqv.
      eapply bind_fapply_respect.
      change env_eqv with (eqv (T:=option_t m B)).
      logical_eqv_eqv.
      eauto with typeclass_instances.
      unfold bind_fapply.
      logical_eqv.
      unfold fapply. unfold option_t_FApply. unfold Deriving_FApply_MBind.
      unfold deriving_FApply_MBind.
      logical_eqv_eqv.
      reflexivity.

    Global Instance option_t_ApplicativeWF : ApplicativeWF (option_t m) :=
        Deriving_ApplicativeWF_MonadWF.
  End ApplicativeWF.

  Section FPlus.
    Definition option_t_mzero {A} : option_t m A := OptionT $ ret None.
    Definition option_t_mplus {A} {B}
        (aMM:option_t m A) (bMM:option_t m B) : option_t m (A+B) :=
      OptionT $ begin
        a <- un_option_t aMM ;;
        match a with
        | None => un_option_t $ inr <$> bMM
        | Some x => un_option_t $ inl <$> aMM
        end
      end.

    Global Instance option_t_MonadPlus : MonadPlus (option_t m) :=
      { mzero := @option_t_mzero
      ; mplus := @option_t_mplus
      }.
  End FPlus.

  Section MonadError.
    Context {E} {ME:MonadError E m}.

    Definition option_t_throw {A} : E -> option_t m A := lift '.' throw.
    Definition option_t_catch {A}
        (aMM:option_t m A) : (E -> option_t m A) -> option_t m A :=
      OptionT '.' catch (un_option_t aMM) '.' compose un_option_t.
    Global Instance option_t_MonadError : MonadError E (option_t m) :=
      { throw := @option_t_throw
      ; catch := @option_t_catch
      }.
  End MonadError.
*)

  Section MonadReader.
    Context {R} {MR:MReader R m}.

    Definition option_t_ask : option_t m R := lift ask.
    Definition option_t_local {A} (f:R -> R) : option_t m A -> option_t m A :=
      OptionT '.' local f '.' un_option_t.
    Global Instance option_t_MonadReader : MReader R (option_t m) :=
      { ask := option_t_ask
      ; local := @option_t_local
      }.
  End MonadReader.

  Section MonadState.
    Context {S} {MS:MonadState S m}.

    Definition option_t_get : option_t m S := lift get.
    Definition option_t_put (s:S) : option_t m unit := lift $ put s.
    Global Instance option_t_MonadState : MonadState S (option_t m) :=
      { get := option_t_get
      ; put := option_t_put
      }.
  End MonadState.
End option_t_Monad.

Instance option_option_t_HasFunctorInjection
    : HasFunctorInjection option (option_t identity) :=
  { finject := fun _ => OptionT '.' Identity}.
Instance option_t_option_HasFunctorInjection
    : HasFunctorInjection (option_t identity) option :=
  { finject := fun _ => un_identity '.' un_option_t }.

Instance option_FUnit : FUnit option := Deriving_FUnit (option_t identity).
Instance option_MBind : MBind option := Deriving_MBind (option_t identity).
Instance option_FPlus : FPlus option := Deriving_FPlus (option_t identity).

(*
Section MonadPlus_passthrough.
  Context {m} {M:Monad m} {MP:MonadPlus m}.

  Definition option_t_mzero_passthrough {A} : option_t m A := OptionT $ mzero.
  Definition option_t_mplus_passthrough {A B}
      (aMM:option_t m A) (bMM:option_t m B) : option_t m (A+B) :=
    OptionT $ begin
      aMbM <- un_option_t aMM <+> un_option_t bMM ;;
      ret $
        match aMbM with
        | inl aM => inl <$> aM
        | inr bM => inr <$> bM
        end
    end.
  Definition option_t_MonadPlus_passthrough : MonadPlus (option_t m) :=
    {| mzero := @option_t_mzero_passthrough
     ; mplus := @option_t_mplus_passthrough
    |}.
End MonadPlus_passthrough.

*)


(* Default settings (from HsToCoq.Coq.Preamble) *)

Generalizable All Variables.

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

Require Coq.Program.Tactics.
Require Coq.Program.Wf.

(* Preamble *)

Require Import Coq.ZArith.BinInt.
Local Open Scope Z.
Require Import Utility.
Local Open Scope alu_scope.

(* Converted imports: *)

Require Decode.
Require Import Monads.
Require Import Program.
Require Import Utility.

(* No type declarations to convert. *)
(* Converted value declarations: *)

Definition execute {p} {t} `{(RiscvState p t)}
   : Decode.InstructionM -> p unit :=
  fun arg_0__ =>
    match arg_0__ with
    | Decode.Mul rd rs1 rs2 =>
        Bind (getRegister rs1) (fun x =>
                Bind (getRegister rs2) (fun y => setRegister rd (x * y)))
    | Decode.Mulh rd rs1 rs2 =>
        Bind (getRegister rs1) (fun x =>
                Bind (getRegister rs2) (fun y =>
                        setRegister rd (highBits (regToZ_signed x * regToZ_signed y) : t)))
    | Decode.Mulhsu rd rs1 rs2 =>
        Bind (getRegister rs1) (fun x =>
                Bind (getRegister rs2) (fun y =>
                        setRegister rd (highBits (regToZ_signed x * regToZ_unsigned y) : t)))
    | Decode.Mulhu rd rs1 rs2 =>
        Bind (getRegister rs1) (fun x =>
                Bind (getRegister rs2) (fun y =>
                        setRegister rd (highBits (regToZ_unsigned x * regToZ_unsigned y) : t)))
    | Decode.Div rd rs1 rs2 =>
        Bind (getRegister rs1) (fun x =>
                Bind (getRegister rs2) (fun y =>
                        let q :=
                          if andb (reg_eqb x minSigned) (reg_eqb y (negate (ZToReg 1))) : bool then x else
                          if reg_eqb y (ZToReg 0) : bool then negate (ZToReg 1) else
                          div x y in
                        setRegister rd q))
    | Decode.Divu rd rs1 rs2 =>
        Bind (getRegister rs1) (fun x =>
                Bind (getRegister rs2) (fun y =>
                        let q := if reg_eqb y (ZToReg 0) : bool then maxUnsigned else divu x y in
                        setRegister rd q))
    | Decode.Rem rd rs1 rs2 =>
        Bind (getRegister rs1) (fun x =>
                Bind (getRegister rs2) (fun y =>
                        let r :=
                          if andb (reg_eqb x minSigned) (reg_eqb y (negate (ZToReg 1))) : bool
                          then ZToReg 0 else
                          if reg_eqb y (ZToReg 0) : bool then x else
                          rem x y in
                        setRegister rd r))
    | Decode.Remu rd rs1 rs2 =>
        Bind (getRegister rs1) (fun x =>
                Bind (getRegister rs2) (fun y =>
                        let r := if reg_eqb y (ZToReg 0) : bool then x else remu x y in
                        setRegister rd r))
    | inst => Return tt
    end.

(* External variables:
     Bind Return RiscvState ZToReg andb bool div divu getRegister highBits
     maxUnsigned minSigned negate op_zt__ regToZ_signed regToZ_unsigned reg_eqb rem
     remu setRegister tt unit Decode.Div Decode.Divu Decode.InstructionM Decode.Mul
     Decode.Mulh Decode.Mulhsu Decode.Mulhu Decode.Rem Decode.Remu
*)


(* Completing the infrastructure of ett

   Current additions:
   - polymorphic functions (via canonical structures)
*)

Require Import FcEtt.ett_inf.
Require Import FcEtt.imports.

(**** Operators on syntactic sorts ****)

Module Operators.

  Module Close.

    Record class1 (ssort : Type) (vartype : Type) :=  Class1 {close_ : vartype -> ssort -> ssort; close_rec_ : nat -> vartype -> ssort -> ssort}.

    Record class (ssort : Type) := Class {class_tm : class1 ssort tmvar; class_co : class1 ssort covar}.

    Arguments Class {ssort} class_tm class_co.
    Arguments Class1 {ssort vartype} close_ close_rec_.

  End Close.

  Module Erase.

    Record class (ssort : Type) := Class {erase_ssort : ssort -> role -> ssort}.

    Arguments Class {ssort} erase_ssort.

  End Erase.

  Module FV.

    Record class (ssort : Type) := Class {fv_tm : ssort -> atoms; fv_co : ssort -> atoms}.

    Arguments Class {ssort} fv_tm fv_co.

  End FV.

  Structure type := Pack {stxsort : Type; class_close : Close.class stxsort; class_Erase : Erase.class stxsort; class_Fv : FV.class stxsort}.

End Operators.

(* Export Operators.Theory. *)

Definition tm_Closecl         : Operators.Close.class tm         := Operators.Close.Class (Operators.Close.Class1 close_tm_wrt_tm close_tm_wrt_tm_rec)                 (Operators.Close.Class1 close_tm_wrt_co close_tm_wrt_co_rec).
Definition co_Closecl         : Operators.Close.class co         := Operators.Close.Class (Operators.Close.Class1 close_co_wrt_tm close_co_wrt_tm_rec)                 (Operators.Close.Class1 close_co_wrt_co close_co_wrt_co_rec).
Definition brs_Closecl        : Operators.Close.class brs        := Operators.Close.Class (Operators.Close.Class1 close_brs_wrt_tm close_brs_wrt_tm_rec)               (Operators.Close.Class1 close_brs_wrt_co close_brs_wrt_co_rec).
Definition constraint_Closecl : Operators.Close.class constraint := Operators.Close.Class (Operators.Close.Class1 close_constraint_wrt_tm close_constraint_wrt_tm_rec) (Operators.Close.Class1 close_constraint_wrt_co close_constraint_wrt_co_rec).

Definition erase_co (_ : co) (_ : role) := g_Triv.

Definition tm_Erasecl         : Operators.Erase.class tm         := Operators.Erase.Class erase_tm.
Definition co_Erasecl         : Operators.Erase.class co         := Operators.Erase.Class erase_co.
Definition brs_Erasecl        : Operators.Erase.class brs        := Operators.Erase.Class erase_brs.
Definition constraint_Erasecl : Operators.Erase.class constraint := Operators.Erase.Class erase_constraint.

Definition tm_FVcl         : Operators.FV.class tm         := Operators.FV.Class fv_tm_tm_tm         fv_co_co_tm.
Definition co_FVcl         : Operators.FV.class co         := Operators.FV.Class fv_tm_tm_co         fv_co_co_co.
Definition brs_FVcl        : Operators.FV.class brs        := Operators.FV.Class fv_tm_tm_brs        fv_co_co_brs.
Definition constraint_FVcl : Operators.FV.class constraint := Operators.FV.Class fv_tm_tm_constraint fv_co_co_constraint.

Canonical Structure tm_OpsTy         : Operators.type := Operators.Pack tm_Closecl         tm_Erasecl         tm_FVcl.
Canonical Structure co_OpsTy         : Operators.type := Operators.Pack co_Closecl         co_Erasecl         co_FVcl.
Canonical Structure brs_OpsTy        : Operators.type := Operators.Pack brs_Closecl        brs_Erasecl        brs_FVcl.
Canonical Structure constraint_OpsTy : Operators.type := Operators.Pack constraint_Closecl constraint_Erasecl constraint_FVcl.


(* Project files imports *)
Require Import MyLists.
Require Import Sequent_Calculus.
Require Import Basic_Properties.

(* Other imports *)
From Coq Require Import Arith.Arith.
From Coq Require Import omega.Omega.
From Coq Require Import Lists.List.
Import ListNotations.

Theorem cut_atom : forall
    (n m a : nat)
    (A : formula)
    (Gamma Delta1 Delta2 : list formula),
    n; Gamma |- (Atom a)
       -> m; Delta1 ++ [Atom a] ++ Delta2 |- A
    -> exists z, z; (Gamma ++ Delta1 ++ Delta2) |- A.
Proof.
  intros n m a A Gamma Delta1 Delta2 LH.
  generalize dependent Delta2.
  generalize dependent Delta1.
  generalize dependent A.
  generalize dependent m.
  remember (Atom a) as cutformula.
  induction LH.

  (* Left premise is OneL *)
  - intros.
    specialize (IHLH Heqcutformula
                     m A0 Delta1 Delta2
                     H).
    destruct IHLH as [z Final].
    clear H. clear Heqcutformula.
    exists (S z).
    pose proof (OneL z (Gamma ++ Delta1 ++ Delta2) A0 Final).
    auto.

  (* Left premise is OneR *)
  - discriminate.

  - (* Left premise is Ax *)
    intros.
    simpl in *.
    subst.
    rename H into temp.
    assert (H: m; [] ++ Delta1 ++ Atom a :: Delta2 |- A0)
      by auto.
    apply exchange_with_env_l in H.
    exists (m + length Delta1).
    apply H.

  - (* Left premise is TensorL *)
    intros.
    subst.
    apply IHLH in H.
    + destruct H.
      exists (S x).
      simpl in *.
      apply (TensorL x (env ++ Delta1 ++ Delta2) A B A0).
      auto.
    + auto.

  - (* Left premise is TensorR *)
    discriminate.

  - (* Left premise is LolliL *)
    intros.
    subst.
    assert (eq0: Atom a = Atom a) by auto.
    apply (IHLH2 eq0) in H.
    destruct H.
    apply (level_depth n env1 A x
                       ((B :: env2) ++ Delta1 ++ Delta2) A0
                       LH1) in H.
    destruct H as [k [LH1' H]].
    exists (S k).
    simpl in *.
    rewrite <- app_assoc.
    apply (LolliL k
                  (env1) A
                  (env2 ++ Delta1 ++ Delta2) B A0
          ); assumption.

  (* Left premise is LolliR *)
  - discriminate.

  (* Left premise is WithL1 *)
  - intros m D Delta1 Delta2 RH.
    subst.
    assert (eq0: Atom a = Atom a) by auto.
    apply (IHLH eq0) in RH.
    destruct RH as [z  RH].
    simpl in *. clear eq0.

    exists (S z).
    apply WithL1; auto.

  (* Left premise is WithL2 *)
  - intros m D Delta1 Delta2 RH.
    subst.
    assert (eq0: Atom a = Atom a) by auto.
    apply (IHLH eq0) in RH.
    destruct RH as [z  RH].
    simpl in *. clear eq0.

    exists (S z).
    apply WithL2; auto.

  (* Left premise is WithR *)
  - discriminate.

  (* Left premise is OplusL *)
  - intros m D Delta1 Delta2 RH1.
    subst.
    assert (RH2: m; Delta1 ++ [Atom a] ++ Delta2 |- D)
      by auto.
    assert (eq0: Atom a = Atom a) by auto.
    apply (IHLH1 eq0) in RH1.
    apply (IHLH2 eq0) in RH2.
    destruct RH1 as [z  RH1].
    destruct RH2 as [z'  RH2].
    simpl in *. clear eq0.

    apply (level_depth z (A::Gamma ++ Delta1 ++ Delta2) D
                       z' (B::Gamma ++ Delta1 ++ Delta2) D
                       RH1) in RH2.
    destruct RH2 as [k [RH1' RH2']].

    exists (S k).
    apply OplusL; auto.

  (* Left premise is OplusR1 *)
  - discriminate.

  (* Left premise is OplusR1 *)
  - discriminate.

  (* Left premise is Perm *)
  - intros.
    subst.
    apply IHLH in H.
    + destruct H.
      exists (S x).
      repeat rewrite <- app_assoc.
      apply (Perm x Gamma (Delta++Delta1++Delta2) A B A0).
      repeat rewrite <- app_assoc in H.
      assumption.
    + auto.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import bedrock2.Syntax bedrock2.Semantics.
Require coqutil.Datatypes.String coqutil.Map.SortedList.
Require coqutil.Map.SortedListString coqutil.Map.SortedListWord.
Require Import coqutil.Map.Interface.
Require Import coqutil.Word.Interface.
Require Import coqutil.Word.Bitwidth32.
Require Import Bedrock2Experiments.LibBase.MMIOLabels.

Import String List.ListNotations.
Local Open Scope string_scope. Local Open Scope Z_scope. Local Open Scope list_scope.

(* Loosely based on bedrock2/FE310CSemantics.v *)

Module state_machine.
  Class parameters{word: word.word 32} :=
    { state : Type;
      register : Type;
      is_initial_state : state -> Prop;
      read_step (byte_count : nat) : state -> register -> word -> state -> Prop;
      write_step (byte_count : nat) : state -> register -> word -> state -> Prop;
      reg_addr : register -> word;
      isMMIOAddr : word -> Prop;
    }.

  Class ok{word: word.word 32}(M: parameters) :=
    { reg_addr_unique : forall r1 r2, reg_addr r1 = reg_addr r2 -> r1 = r2;
      read_step_isMMIOAddr : forall sz s r v s',
          read_step sz s r v s' -> forall a: word,
            word.unsigned (reg_addr r) <= word.unsigned a < word.unsigned (reg_addr r) + Z.of_nat sz ->
            isMMIOAddr a;
      write_step_isMMIOAddr : forall sz s r v s',
          write_step sz s r v s' -> forall a: word,
            word.unsigned (reg_addr r) <= word.unsigned a < word.unsigned (reg_addr r) + Z.of_nat sz ->
            isMMIOAddr a;
      read_step_is_aligned : forall sz s r v s',
          read_step sz s r v s' ->
          word.unsigned (reg_addr r) mod (Z.of_nat sz) = 0;
      write_step_is_aligned : forall sz s r v s',
          write_step sz s r v s' ->
          word.unsigned (reg_addr r) mod (Z.of_nat sz) = 0;
      read_step_size_valid : forall sz s r v s',
          read_step sz s r v s' ->
          List.In sz [1; 2; 4]%nat;
      write_step_size_valid : forall sz s r v s',
          write_step sz s r v s' ->
          List.In sz [1; 2; 4]%nat;
      read_step_bounded : forall sz s r v s',
          read_step sz s r v s' ->
          word.unsigned v < 2 ^ (Z.of_nat sz * 8);
      (* Note: It would be nice if we could allow too big writes and just ignore the upper
         bytes, but then we run into a specification issue: bedrock2 semantics of external
         calls (exec.interact) puts the whole unmodified word into the trace, and we want
         the trace of the risc-v machine to match the bedrock2 trace exactly (rather than
         introducing a notion of trace equivalence), but riscv-coq cannot put the upper
         ignored bits into the trace, because riscv.Spec.ExecuteI does not pass them
         to nonmem_store *)
      write_step_bounded : forall sz s r v s',
          write_step sz s r v s' ->
          word.unsigned v < 2 ^ (Z.of_nat sz * 8);
    }.
End state_machine.
Global Coercion state_machine.state : state_machine.parameters >-> Sortclass.

Section WithParameters.
  Import state_machine.
  Context {word: word.word 32} {mem: map.map word Byte.byte}
          {M: state_machine.parameters} {M_ok: state_machine.ok M}.

  Definition step
             (action : string) (s : state) (args rets : list word) (s' : state)
    : Prop :=
    if String.prefix WRITE_PREFIX action
    then match args with
         | [addr;val] =>
           (exists r sz, reg_addr r = addr /\ rets = [] /\
                         access_size_to_MMIO_write sz = action /\ write_step sz s r val s')
         | _ => False
         end
    else if String.prefix READ_PREFIX action
         then match args with
              | [addr] => (exists r val sz, reg_addr r = addr /\ rets = [val] /\
                                            access_size_to_MMIO_read sz = action /\
                                            read_step sz s r val s')
              | _ => False
              end
         else False.

  (* Computes the Prop that must hold for this state to be accurate after the
     trace *)
  Fixpoint execution (t : trace) (s : state) : Prop :=
    match t with
    | [] => is_initial_state s
    | (_,action,args,(_,rets)) :: t =>
      exists prev_state,
      execution t prev_state
      /\ step action prev_state args rets s
    end.

  Global Instance ext_spec: ExtSpec := fun
             (t : trace)
             (mGive : mem)
             (action : string)
             (args: list word)
             (post: mem -> list word -> Prop) =>
    if String.prefix WRITE_PREFIX action
    then
      (exists r addr val sz,
          args = [addr;val]
          /\ mGive = map.empty
          /\ reg_addr r = addr
          /\ access_size_to_MMIO_write sz = action
          (* there must exist *at least one* possible state given this trace,
             and one possible transition given these arguments *)
          /\ (exists s s', execution t s /\ write_step sz s r val s')
          (* postcondition must hold for *all* possible states/transitions *)
          /\ (forall s s',
                execution t s ->
                write_step sz s r val s' ->
                post Interface.map.empty []))
       else if String.prefix READ_PREFIX action
            then
              (exists r addr sz,
                  args = [addr]
                  /\ mGive = map.empty
                  /\ reg_addr r = addr
                  /\ access_size_to_MMIO_read sz = action
                  (* there must exist *at least one* possible state given this
                     trace, and one possible transition given these arguments *)
                  /\ (exists s s' val, execution t s /\ read_step sz s r val s')
                  (* postcondition must hold for *all* possible states/transitions *)
                  /\ (forall s s' val,
                        execution t s ->
                        read_step sz s r val s' ->
                        post Interface.map.empty [val]))
               else False.

  Global Instance ext_spec_ok : ext_spec.ok ext_spec.
  Proof.
    split;
    cbv [ext_spec Morphisms.Proper Morphisms.respectful Morphisms.pointwise_relation Basics.impl];
    intros.
    all :
    repeat match goal with
           | H : context[String.prefix ?x ?y] |- _ =>
             destruct (String.prefix x y)
           | H: exists _, _ |- _ => destruct H
           | H: _ /\ _ |- _ => destruct H
           | H : _ :: _  = _ :: _ |- _ => inversion H; clear H; subst
           | H : access_size_to_MMIO_read ?sz1 = access_size_to_MMIO_read ?sz2 |- _ =>
             apply access_size_to_MMIO_read_inj in H; subst sz1
           | H: False |- _ => destruct H
           | H : reg_addr _ = reg_addr _ |- _ => apply reg_addr_unique in H
           | _ => progress subst
           end; eauto 20 using Properties.map.same_domain_refl.
  Qed.

  Lemma read_step_isMMIOAddr0: forall sz s a v s',
      read_step sz s a v s' -> isMMIOAddr (reg_addr a).
  Proof.
    intros. eapply read_step_isMMIOAddr. 1: exact H.
    apply read_step_size_valid in H. simpl in H. Lia.lia.
  Qed.

  Lemma write_step_isMMIOAddr0: forall sz s a v s',
      write_step sz s a v s' -> isMMIOAddr (reg_addr a).
  Proof.
    intros. eapply write_step_isMMIOAddr. 1: exact H.
    apply write_step_size_valid in H. simpl in H. Lia.lia.
  Qed.

End WithParameters.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^266 - 3
Base: 64
***)

Definition curve : CurveParameters :=
  {|
    sz := 5%nat;
    base := 64;
    bitwidth := 64;
    s := 2^266;
    c := [(1, 3)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import
  Coq.Sets.Ensembles
  Coq.NArith.NArith
  Fiat.ADT
  Fiat.ADTNotation
  ByteString.Lib.ADTInduction
  ByteString.Lib.FromADT
  ByteString.Ens.HeapEns.

Open Scope N_scope.

Lemma empty_fromADT r :
  refine (callCons HeapSpec emptyS) (ret r) -> fromADT HeapSpec r.
Proof. check constructor (fromCons HeapSpec emptyS r). Qed.

Lemma alloc_fromADT r :
  fromADT HeapSpec r
    -> forall (len : N | 0 < len) v,
         refine (callMeth HeapSpec allocS r len) (ret v)
    -> fromADT HeapSpec (fst v).
Proof. intros; check method (fromMeth HeapSpec allocS r (fst v)). Qed.

Lemma free_fromADT r :
  fromADT HeapSpec r
    -> forall (addr : N) v,
         refine (callMeth HeapSpec freeS r addr) (ret v)
    -> fromADT HeapSpec (fst v).
Proof. intros; check method (fromMeth HeapSpec freeS r (fst v)). Qed.

Lemma realloc_fromADT r :
  fromADT HeapSpec r
    -> forall (addr : N) (len : N | 0 < len) v,
         refine (callMeth HeapSpec reallocS r addr len) (ret v)
    -> fromADT HeapSpec (fst v).
Proof. intros; check method (fromMeth HeapSpec reallocS r (fst v)). Qed.

Lemma peek_fromADT r :
  fromADT HeapSpec r
    -> forall (addr : N) v,
         refine (callMeth HeapSpec peekS r addr) (ret v)
    -> fromADT HeapSpec (fst v).
Proof. intros; check method (fromMeth HeapSpec peekS r (fst v)). Qed.

Lemma poke_fromADT r :
  fromADT HeapSpec r
    -> forall (addr : N) w v,
         refine (callMeth HeapSpec pokeS r addr w) (ret v)
    -> fromADT HeapSpec (fst v).
Proof. intros; check method (fromMeth HeapSpec pokeS r (fst v)). Qed.

Lemma memcpy_fromADT r :
  fromADT HeapSpec r
    -> forall (addr : N) (addr2 : N) (len : N) v,
         refine (callMeth HeapSpec memcpyS r addr addr2 len) (ret v)
    -> fromADT HeapSpec (fst v).
Proof. intros; check method (fromMeth HeapSpec memcpyS r (fst v)). Qed.

Lemma memset_fromADT r :
  fromADT HeapSpec r
    -> forall (addr : N) (len : N) (w : Word8) v,
         refine (callMeth HeapSpec memsetS r addr len w) (ret v)
    -> fromADT HeapSpec (fst v).
Proof. intros; check method (fromMeth HeapSpec memsetS r (fst v)). Qed.

Require Import
  Fiat.ADTRefinement
  Fiat.ADTRefinement.BuildADTRefinements.

Theorem HeapSpecADT : { adt : _ & refineADT HeapSpec adt }.
Proof.
  eexists.
  hone representation using
    (fun (or : Rep HeapSpec)
         (nr : { r : Rep HeapSpec | fromADT HeapSpec r }) => or = ` nr).
  resolve_constructor empty empty_fromADT.
  resolve_method r_n (alloc (` r_n) d)
                     (@alloc_fromADT _ (proj2_sig r_n) d).
  resolve_method r_n (free (` r_n) d)
                     (@free_fromADT _ (proj2_sig r_n) d).
  resolve_method r_n (realloc (` r_n) d d0)
                     (@realloc_fromADT _ (proj2_sig r_n) d d0).
  resolve_method r_n (peek (` r_n) d)
                     (@peek_fromADT _ (proj2_sig r_n) d).
  resolve_method r_n (poke (` r_n) d d0)
                     (@poke_fromADT _ (proj2_sig r_n) d d0).
  resolve_method r_n (memcpy (` r_n) d d0 d1)
                     (@memcpy_fromADT _ (proj2_sig r_n) d d0 d1).
  resolve_method r_n (memset (` r_n) d d0 d1)
                     (@memset_fromADT _ (proj2_sig r_n) d d0 d1).
  apply reflexivityT.
Defined.


Require Import Fiat.Computation.
Require Import Cat.PTStream.
Require Import Coq.Lists.List.

(** * Denotational semantics for the unix cat program

    cat turns a sequence of streams into one with them concatenated
    together. *)

Definition cat_spec (A : Type) (streams : list (pt_stream A)) : Comp (pt_stream A) :=
  { s | pt_stream_eq s (fold_right PTStream.app (PTStream.nil _) streams) }.


From iris.bi Require Export bi.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type*".

(** This proves that we need the ▷ in a "Saved Proposition" construction with
name-dependent allocation. *)
Module savedprop. Section savedprop.
  Context `{BiAffine PROP}.
  Notation "¬ P" := (□ (P → False))%I : bi_scope.
  Implicit Types P : PROP.

  Context (bupd : PROP → PROP).
  Notation "|==> Q" := (bupd Q)
    (at level 99, Q at level 200, format "|==>  Q") : bi_scope.

  Hypothesis bupd_intro : ∀ P, P ⊢ |==> P.
  Hypothesis bupd_mono : ∀ P Q, (P ⊢ Q) → (|==> P) ⊢ |==> Q.
  Hypothesis bupd_trans : ∀ P, (|==> |==> P) ⊢ |==> P.
  Hypothesis bupd_frame_r : ∀ P R, (|==> P) ∗ R ⊢ |==> (P ∗ R).

  Context (ident : Type) (saved : ident → PROP → PROP).
  Hypothesis sprop_persistent : ∀ i P, Persistent (saved i P).
  Hypothesis sprop_alloc_dep :
    ∀ (P : ident → PROP), (|==> ∃ i, saved i (P i))%I.
  Hypothesis sprop_agree : ∀ i P Q, saved i P ∧ saved i Q ⊢ □ (P ↔ Q).

  (** We assume that we cannot update to false. *)
  Hypothesis consistency : ¬(|==> False)%I.

  Instance bupd_mono' : Proper ((⊢) ==> (⊢)) bupd.
  Proof. intros P Q ?. by apply bupd_mono. Qed.
  Instance elim_modal_bupd p P Q : ElimModal True p false (|==> P) P (|==> Q) (|==> Q).
  Proof.
    by rewrite /ElimModal bi.intuitionistically_if_elim
      bupd_frame_r bi.wand_elim_r bupd_trans.
  Qed.

  (** A bad recursive reference: "Assertion with name [i] does not hold" *)
  Definition A (i : ident) : PROP := (∃ P, ¬ P ∗ saved i P)%I.

  Lemma A_alloc : (|==> ∃ i, saved i (A i))%I.
  Proof. by apply sprop_alloc_dep. Qed.

  Lemma saved_NA i : saved i (A i) ⊢ ¬ A i.
  Proof.
    iIntros "#Hs !# #HA". iPoseProof "HA" as "HA'".
    iDestruct "HA'" as (P) "[#HNP HsP]". iApply "HNP".
    iDestruct (sprop_agree i P (A i) with "[]") as "#[_ HP]".
    { eauto. }
    iApply "HP". done.
  Qed.

  Lemma saved_A i : saved i (A i) ⊢ A i.
  Proof.
    iIntros "#Hs". iExists (A i). iFrame "#".
    by iApply saved_NA.
  Qed.

  Lemma contradiction : False.
  Proof using All.
    apply consistency.
    iMod A_alloc as (i) "#H".
    iPoseProof (saved_NA with "H") as "HN".
    iApply bupd_intro. iApply "HN". iApply saved_A. done.
  Qed.
End savedprop. End savedprop.

(** This proves that we need the ▷ when opening invariants. *)
Module inv. Section inv.
  Context `{BiAffine PROP}.
  Implicit Types P : PROP.

  (** Assumptions *)
  (** We have the update modality (two classes: empty/full mask) *)
  Inductive mask := M0 | M1.
  Context (fupd : mask → PROP → PROP).
  Arguments fupd _ _%I.
  Hypothesis fupd_intro : ∀ E P, P ⊢ fupd E P.
  Hypothesis fupd_mono : ∀ E P Q, (P ⊢ Q) → fupd E P ⊢ fupd E Q.
  Hypothesis fupd_fupd : ∀ E P, fupd E (fupd E P) ⊢ fupd E P.
  Hypothesis fupd_frame_l : ∀ E P Q, P ∗ fupd E Q ⊢ fupd E (P ∗ Q).
  Hypothesis fupd_mask_mono : ∀ P, fupd M0 P ⊢ fupd M1 P.

  (** We have invariants *)
  Context (name : Type) (inv : name → PROP → PROP).
  Arguments inv _ _%I.
  Hypothesis inv_persistent : ∀ i P, Persistent (inv i P).
  Hypothesis inv_alloc : ∀ P, P ⊢ fupd M1 (∃ i, inv i P).
  Hypothesis inv_open :
    ∀ i P Q R, (P ∗ Q ⊢ fupd M0 (P ∗ R)) → (inv i P ∗ Q ⊢ fupd M1 R).

  (* We have tokens for a little "two-state STS": [start] -> [finish].
     state. [start] also asserts the exact state; it is only ever owned by the
     invariant.  [finished] is duplicable. *)
  (* Posssible implementations of these axioms:
     * Using the STS monoid of a two-state STS, where [start] is the
       authoritative saying the state is exactly [start], and [finish]
       is the "we are at least in state [finish]" typically owned by threads.
     * Ex () +_## ()
  *)
  Context (gname : Type).
  Context (start finished : gname → PROP).

  Hypothesis sts_alloc : fupd M0 (∃ γ, start γ).
  Hypotheses start_finish : ∀ γ, start γ ⊢ fupd M0 (finished γ).

  Hypothesis finished_not_start : ∀ γ, start γ ∗ finished γ ⊢ False.

  Hypothesis finished_dup : ∀ γ, finished γ ⊢ finished γ ∗ finished γ.

  (** We assume that we cannot update to false. *)
  Hypothesis consistency : ¬ (fupd M1 False).

  (** Some general lemmas and proof mode compatibility. *)
  Lemma inv_open' i P R : inv i P ∗ (P -∗ fupd M0 (P ∗ fupd M1 R)) ⊢ fupd M1 R.
  Proof.
    iIntros "(#HiP & HP)". iApply fupd_fupd. iApply inv_open; last first.
    { iSplit; first done. iExact "HP". }
    iIntros "(HP & HPw)". by iApply "HPw".
  Qed.

  Instance fupd_mono' E : Proper ((⊢) ==> (⊢)) (fupd E).
  Proof. intros P Q ?. by apply fupd_mono. Qed.
  Instance fupd_proper E : Proper ((⊣⊢) ==> (⊣⊢)) (fupd E).
  Proof.
    intros P Q; rewrite !bi.equiv_spec=> -[??]; split; by apply fupd_mono.
  Qed.

  Lemma fupd_frame_r E P Q : fupd E P ∗ Q ⊢ fupd E (P ∗ Q).
  Proof. by rewrite comm fupd_frame_l comm. Qed.

  Global Instance elim_fupd_fupd p E P Q :
    ElimModal True p false (fupd E P) P (fupd E Q) (fupd E Q).
  Proof.
    by rewrite /ElimModal bi.intuitionistically_if_elim
      fupd_frame_r bi.wand_elim_r fupd_fupd.
  Qed.

  Global Instance elim_fupd0_fupd1 p P Q :
    ElimModal True p false (fupd M0 P) P (fupd M1 Q) (fupd M1 Q).
  Proof.
    by rewrite /ElimModal bi.intuitionistically_if_elim
      fupd_frame_r bi.wand_elim_r fupd_mask_mono fupd_fupd.
  Qed.

  Global Instance exists_split_fupd0 {A} E P (Φ : A → PROP) :
    FromExist P Φ → FromExist (fupd E P) (λ a, fupd E (Φ a)).
  Proof.
    rewrite /FromExist=>HP. apply bi.exist_elim=> a.
    apply fupd_mono. by rewrite -HP -(bi.exist_intro a).
  Qed.

  (** Now to the actual counterexample. We start with a weird form of saved propositions. *)
  Definition saved (γ : gname) (P : PROP) : PROP :=
    (∃ i, inv i (start γ ∨ (finished γ ∗ □ P)))%I.
  Global Instance saved_persistent γ P : Persistent (saved γ P) := _.

  Lemma saved_alloc (P : gname → PROP) : fupd M1 (∃ γ, saved γ (P γ)).
  Proof.
    iIntros "". iMod (sts_alloc) as (γ) "Hs".
    iMod (inv_alloc (start γ ∨ (finished γ ∗ □ (P γ)))%I with "[Hs]") as (i) "#Hi".
    { auto. }
    iApply fupd_intro. by iExists γ, i.
  Qed.

  Lemma saved_cast γ P Q : saved γ P ∗ saved γ Q ∗ □ P ⊢ fupd M1 (□ Q).
  Proof.
    iIntros "(#HsP & #HsQ & #HP)". iDestruct "HsP" as (i) "HiP".
    iApply (inv_open' i). iSplit; first done.
    iIntros "HaP". iAssert (fupd M0 (finished γ)) with "[HaP]" as "> Hf".
    { iDestruct "HaP" as "[Hs | [Hf _]]".
      - by iApply start_finish.
      - by iApply fupd_intro. }
    iDestruct (finished_dup with "Hf") as "[Hf Hf']".
    iApply fupd_intro. iSplitL "Hf'"; first by eauto.
    (* Step 2: Open the Q-invariant. *)
    iClear (i) "HiP ". iDestruct "HsQ" as (i) "HiQ".
    iApply (inv_open' i). iSplit; first done.
    iIntros "[HaQ | [_ #HQ]]".
    { iExFalso. iApply finished_not_start. by iFrame. }
    iApply fupd_intro. iSplitL "Hf".
    { iRight. by iFrame. }
    by iApply fupd_intro.
  Qed.

  (** And now we tie a bad knot. *)
  Notation "¬ P" := (□ (P -∗ fupd M1 False))%I : bi_scope.
  Definition A i : PROP := (∃ P, ¬P ∗ saved i P)%I.
  Global Instance A_persistent i : Persistent (A i) := _.

  Lemma A_alloc : fupd M1 (∃ i, saved i (A i)).
  Proof. by apply saved_alloc. Qed.

  Lemma saved_NA i : saved i (A i) ⊢ ¬A i.
  Proof.
    iIntros "#Hi !# #HA". iPoseProof "HA" as "HA'".
    iDestruct "HA'" as (P) "#[HNP Hi']".
    iMod (saved_cast i (A i) P with "[]") as "HP".
    { eauto. }
    by iApply "HNP".
  Qed.

  Lemma saved_A i : saved i (A i) ⊢ A i.
  Proof.
    iIntros "#Hi". iExists (A i). iFrame "#".
    by iApply saved_NA.
  Qed.

  Lemma contradiction : False.
  Proof using All.
    apply consistency. iIntros "".
    iMod A_alloc as (i) "#H".
    iPoseProof (saved_NA with "H") as "HN".
    iApply "HN". iApply saved_A. done.
  Qed.
End inv. End inv.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O A B C Aprime Bprime Cprime : Universe, ((wd_ O Aprime /\ (wd_ O Bprime /\ (wd_ O Cprime /\ (wd_ A B /\ (wd_ A Aprime /\ (wd_ Aprime Bprime /\ (wd_ B C /\ (wd_ B Bprime /\ (wd_ C Cprime /\ (wd_ C Bprime /\ (wd_ Aprime B /\ (wd_ A C /\ (wd_ O C /\ (wd_ O B /\ (wd_ O A /\ (wd_ Bprime A /\ (col_ O A B /\ (col_ Aprime Bprime Cprime /\ (col_ O Aprime Bprime /\ (col_ B C Cprime /\ (col_ Bprime C Cprime /\ col_ A B C))))))))))))))))))))) -> col_ C B Bprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require SourceLang.
Require List.
Import List.ListNotations.

Open Scope list.

Definition node_name := bool.
Definition state := unit.
Definition msg := bool.
Definition input := unit.

Definition other (h : node_name) : node_name := negb h.

Definition ping : msg := true.
Definition pong : msg := false.

Definition initial_state : state := tt.

Definition handleInput (h : node_name) (i : input) (s : state)
  : state * list (node_name * msg) :=
  (s, [(other h, ping)]).

Definition handleMsg (dst : node_name) (m : msg) (s : state)
  : state * list (node_name * msg) :=
  if m
  then (* got ping; send pong *) (s, [(other dst, pong)])
  else (* got pong; yay! *) (s, [])
.

Definition initial_state_reflect_ty :=
  ltac:(let x := eval compute in unit in SourceLang.type_reflect x) : SourceLang.type.

Definition initial_state_reflect : SourceLang.expr [] initial_state_reflect_ty :=
  ltac:(let x := eval compute in initial_state in SourceLang.reflect x).

Definition handleInput_reflect_ty :=
  ltac:(let x := eval compute in (node_name -> input -> state -> state * list (node_name * msg)) in SourceLang.type_reflect x) : SourceLang.type.

Definition handleInput_reflect : SourceLang.expr [] handleInput_reflect_ty :=
  ltac:(let x := eval compute in handleInput in SourceLang.reflect x) : SourceLang.expr [] _ .

Definition handleMsg_reflect_ty :=
  ltac:(let x := eval compute in (node_name -> msg -> state -> state * list (node_name * msg)) in SourceLang.type_reflect x) : SourceLang.type.

Definition handleMsg_reflect : SourceLang.expr [] handleMsg_reflect_ty :=
  ltac:(let x := eval compute in handleMsg in SourceLang.reflect x).