(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                     SF_Eval.v                                      *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith Max.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Wave_as_SF.SF_Terms.
Require Import IntensionalLib.Wave_as_SF.SF_Tactics.
Require Import IntensionalLib.Wave_as_SF.SF_reduction.
Require Import IntensionalLib.Wave_as_SF.SF_Normal.
Require Import IntensionalLib.Wave_as_SF.SF_Closed.
Require Import IntensionalLib.Wave_as_SF.Substitution.

Definition eval_app M N :=
match M with
| App (App (Op Node) (Op Node)) M1  => M1
| App (App (Op Node) (App (Op Node) M1)) M2 =>
      App (App M2 N) (App M1 N)
| App (App (Op Node) (App (App (Op Node) M1) M2)) M3 =>
    App (App N M1) M2
| x => App x N
end.

Lemma eval_app_from_SF : forall M N, sf_red (App M N) (eval_app M N).
Proof.
induction M; split_all.
gen_case IHM1 M1. gen_case IHM1 s.  gen_case IHM1 o.
gen_case IHM1 s0.
(* 2 *)
case o0; auto. red; one_step.
(* 1 *)
case s1; split_all.
(* 2 *)
case o0; split_all. red; one_step.
(* 1 *)
case s3; split_all. case o0; split_all. red; one_step.
Qed.

Fixpoint eval0 (M: SF) :=
match M with
| Ref i => Ref i
| Op o => Op o
| App (Op Fop) M11 => App (Op Fop) (eval0 M11)
| App M1 M11 => eval_app (eval0 M1) M11
end.

Lemma eval0_from_SF : forall M, sf_red M (eval0 M).
Proof.
induction M; split_all.
eapply transitive_red.
eapply preserves_app_sf_red. eapply2 IHM1. auto.
eapply transitive_red.
eapply2 eval_app_from_SF.
case M1; split_all.
case o; split_all.
eapply preserves_app_sf_red. auto. eapply2 IHM2.
Qed.

Ltac eval_tac := unfold_op;
match goal with
| |-  sf_red ?M _ => red; eval_tac
| |-  multi_step sf_red1 ?M _ =>
  (apply transitive_red with (eval0 M);
[eapply2 eval0_from_SF |
  unfold eval0, eval_app;  unfold subst; split_all])
| _ => auto
end.

(* Boolean operations *)

Definition not M := App (App M (App k_op i_op)) k_op.

Lemma not_true : sf_red (not k_op) (App k_op i_op).
Proof. unfold not; eval_tac. Qed.

Lemma not_false : sf_red (not (App k_op i_op)) k_op.
Proof. eval_tac.  eval_tac.  Qed.

Definition  iff M N := App (App M N) (not N).

Lemma true_true : sf_red (iff k_op k_op) k_op.
Proof. unfold iff; unfold not; eval_tac; split_all. Qed.
Lemma true_false : sf_red (iff k_op (App k_op i_op)) (App k_op i_op).
Proof. unfold iff; unfold not; eval_tac; split_all. Qed.
Lemma false_true : sf_red (iff (App k_op i_op) k_op) (App k_op i_op).
Proof. unfold iff; unfold not; eval_tac; eval_tac; eval_tac; eval_tac; split_all. Qed.
Lemma false_false : sf_red (iff (App k_op i_op) (App k_op i_op)) k_op.
Proof.
unfold iff, not. unfold_op. repeat eval_tac. Qed.


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 Oprime Aprime Bprime : Universe, ((wd_ B Bprime /\ (wd_ Bprime C /\ (wd_ O A /\ (wd_ Oprime Aprime /\ (wd_ A C /\ (wd_ Aprime Bprime /\ (wd_ B C /\ (wd_ A Aprime /\ (wd_ O Aprime /\ (wd_ A Bprime /\ (wd_ C Aprime /\ (wd_ O Oprime /\ (wd_ A Oprime /\ (col_ O A B /\ (col_ O B C /\ (col_ O A C /\ (col_ Oprime Aprime Bprime /\ (col_ B Bprime C /\ (col_ Bprime Bprime C /\ col_ Oprime Bprime Bprime))))))))))))))))))) -> col_ A C B)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Coq Require Import ssreflect ssrfun ssrbool.
From Coq Require FunctionalExtensionality.

From Mon Require Export Base.
From Coq Require Import Relation_Definitions Morphisms.
From Mon Require Import SPropBase SPropMonadicStructures
  MonadExamples SpecificationMonads DijkstraMonadExamples.
From Relational Require Import OrderEnrichedCategory
  OrderEnrichedRelativeMonadExamples.

Section Commutations.
  Context {M:Monad}.

  Definition commute {A B} (ma : M A) (mb : M B) :=
    bind ma (fun a => bind mb (fun b => ret ⟨a,b⟩)) =
    bind mb (fun b => bind ma (fun a => ret ⟨a,b⟩)).

  Definition swap {A B} (ab : A × B) : B × A := ⟨nsnd ab, nfst ab⟩.

  Import FunctionalExtensionality.
  Lemma eq_bind {A B} (m : M A) :
    forall (f1 f2 : A -> M B), (forall a, f1 a = f2 a) -> bind m f1 = bind m f2.
  Proof. move=> ? ? /functional_extensionality -> //. Qed.

  Lemma map_ret {A B} (f : A -> B) (a : A) : f <$> ret a = @ret M _ (f a).
  Proof. rewrite /map /bind monad_law1 //. Qed.

  Lemma commute_elim {A B C} (f : A × B -> M C) (ma : M A) (mb : M B) :
    commute ma mb ->
    bind ma (fun a=> bind mb (fun b => f ⟨a,b⟩)) = bind mb (fun b=> bind ma (fun a=> f ⟨a,b⟩)).
  Proof.
    rewrite /commute=> /(f_equal (fun t => bind t f)).
    rewrite /bind !monad_law3. repeat rewrite -/bind.
    under eq_bind => a do (rewrite /bind !monad_law3 -/bind ; under eq_bind => b do rewrite monad_law1).
    under (@eq_bind B _) => a do (rewrite /bind !monad_law3 -/bind ; under eq_bind => b do rewrite monad_law1).
    done.
  Qed.

  Lemma commute_sym {A B} (ma : M A) (mb : M B)
    : commute ma mb -> commute mb ma.
  Proof.
    move=> /(commute_elim (fun p => ret (swap p))) //=.
  Qed.

  Import FunctionalExtensionality.
  Lemma commute_ret {A B} (a : A) (mb : M B) : commute (ret a) mb.
  Proof.
    rewrite /commute /bind monad_law1 ; f_equal.
    extensionality a2; rewrite monad_law1 //.
  Qed.

  Ltac apply_commute_elim H :=
    match goal with
    | [|- context c [bind ?m1 (fun a1 => bind ?m2 (fun a2 => @?f a1 a2))]] =>
      move: (commute_elim (fun p => f (nfst p) (nsnd p)) m1 m2 H) => /= ->
    end.

  Lemma commute_bind {A1 A2 B} (m1 : M A1) (f1 : A1 -> M A2) (m2:M B)
    : commute m1 m2 -> (forall a1, commute (f1 a1) m2) -> commute (bind m1 f1) m2.
  Proof.
    move=> Hm Hf ; rewrite /commute /bind monad_law3. repeat rewrite -/bind.
    under eq_bind => a1 do rewrite (Hf a1).
    apply_commute_elim Hm.
    under eq_bind => b do rewrite /bind -monad_law3.
    done.
  Qed.
End Commutations.

Ltac apply_commute_elim H :=
  match goal with
  | [|- context c [bind ?m1 (fun a1 => bind ?m2 (fun a2 => @?f a1 a2))]] =>
    move: (commute_elim (fun p => f (nfst p) (nsnd p)) m1 m2 H) => /= ->
  end.

Section FromFreeCommute.
  Context (W : OrderedMonad).
  Context {S1:Type} {P1:S1 -> Type} (wop1 : forall s1, W (P1 s1)).
  Context {S2:Type} {P2:S2 -> Type} (wop2 : forall s2, W (P2 s2)).
  Context (Hcom : forall s1 s2, commute (wop1 s1) (wop2 s2)).

  Let θ1 := OpSpecEffObs wop1.
  Let θ2 := OpSpecEffObs wop2.

  Import FunctionalExtensionality.
  Lemma fromFreeCommute A1 A2 : forall c1 c2, commute (θ1 A1 c1) (θ2 A2 c2).
  Proof.
    move=> c1.
    elim: c1 A2 => [a1|s1 k1 IH1] A2 c2; first by apply commute_ret.
    simpl; apply commute_bind ; last by move=> a1; apply: IH1.
    elim: c2 => [a2| s2 k2 IH2] ; first by apply commute_sym, commute_ret.
    simpl ; apply commute_sym, commute_bind; first by apply commute_sym, Hcom.
    move=> a2; apply commute_sym, IH2.
  Qed.

End FromFreeCommute.

Section CommuteEffectObs.
  Context (W : OrderedMonad) (M1 M2:Monad).
  Context (θ1 : MonadMorphism M1 W) (θ2 : MonadMorphism M2 W).
  Context (Hcom : forall A1 A2 c1 c2, commute (θ1 A1 c1) (θ2 A2 c2)).

  Definition Wrel : RelationalSpecMonad0 :=
    relativeMonad_precomposition typeCat_prod (ordmonad_to_relmon W).

  Import SPropNotations.
  Import FunctionalExtensionality.
  Program Definition commute_effObs : RelationalEffectObservation0 M1 M2 Wrel
    :=
      mkREO0 M1 M2 Wrel
             (fun '⟨A1,A2⟩ => ⦑fun '⟨c1,c2⟩ => bind (θ1 A1 c1) (fun a1=> bind (θ2 A2 c2)
                                               (fun a2=> ret ⟨a1,a2⟩))⦒) _ _.
  Next Obligation. move=> ? ? H ; induction H; reflexivity. Qed.
  Next Obligation.
    apply sig_eq=> /= ; extensionality a=> /=.
    now do 2 rewrite mon_morph_ret /bind monad_law1.
  Qed.
  Next Obligation.
    apply sig_eq=> /= ; extensionality x=> /=.
    rewrite mon_morph_bind {1 2}/bind monad_law3; repeat rewrite -/bind.
    under eq_bind => a.
      under eq_bind => b.
        rewrite mon_morph_bind /bind monad_law3 ; repeat rewrite -/bind.
        over.
      apply_commute_elim (Hcom _ _ (nfst f a) (nsnd x)).
      over.
    rewrite /bind monad_law3; repeat rewrite -/bind.
    f_equal ; extensionality a1.
    rewrite /bind monad_law3; repeat rewrite -/bind.
    f_equal ; extensionality a2.
    rewrite /bind monad_law1 //.
  Qed.

End CommuteEffectObs.

Section ConverseCommute.
  Context (M1 M2 : Monad).
  Context (W : OrderedMonad).
  Let Wrel := relativeMonad_precomposition typeCat_prod (ordmonad_to_relmon W).

  Context (θ : RelationalEffectObservation0 M1 M2 Wrel).

  Let θapp (A B : Type) := proj1_sig (θ ⟨A , B⟩).

  Definition unitt : Type := unit.

  Import FunctionalExtensionality.

  Lemma θret (A B : Type) (a : A) (b : B) : θapp A B ⟨ ret a, ret b ⟩ = ret ⟨ a, b ⟩.

    move: (rmm_law1 _ _ _ _ θ ⟨A,B⟩) => /(f_equal sval) e.
    apply (equal_f e ⟨a, b ⟩).
  Qed.

  Lemma θbind (A1 A2 B1 B2 : Type) (m1 : M1 A1) (f1 : A1 -> M1 B1) (m2 : M2 A2) (f2 : A2 -> M2 B2) : θapp B1 B2 ⟨ bind m1 f1 ,  bind m2 f2 ⟩ = bind (θapp A1 A2 ⟨m1, m2⟩) (fun p => θapp B1 B2 ⟨ f1 (nfst p), f2 (nsnd p) ⟩).
    move: (rmm_law2 _ _ _ _ θ ⟨A1,A2⟩ ⟨B1, B2⟩ (⟨f1, f2⟩)) => /(f_equal sval) e.
    apply (equal_f e ⟨m1, m2⟩).
  Qed.

  Lemma bind_comm : forall (M : Monad) A1 A2 A3 (f : A1 -> A2) (m : M A1) (k : A2 -> M A3), bind (f <$> m) k = bind m (fun a => k (f a)).
    move=> M A1 A2 A3 f m k //=.
    rewrite /bind (monad_law3 m).
    f_equal; extensionality a; rewrite (monad_law1); reflexivity.
  Qed.

  Program Definition effobs_from_releffobs1 : MonadMorphism M1 W := @mkMorphism _ _ (fun A v => nfst <$> θapp A unitt ⟨ v, ret tt ⟩) _ _.
  Next Obligation.
    rewrite /map θret.
    rewrite /bind /ret monad_law1. reflexivity.
  Qed.
  Next Obligation.
    rewrite bind_comm.
    rewrite <- (monad_law2 (ret tt)) at 1.
    rewrite θbind //.
    rewrite /map /bind monad_law3. f_equal; extensionality a; destruct a as [a []].
    reflexivity.
  Qed.

  Let θ1 := effobs_from_releffobs1.

  Program Definition effobs_from_releffobs2 : MonadMorphism M2 W := @mkMorphism _ _ (fun A v => nsnd <$> θapp unitt A ⟨ ret tt, v ⟩) _ _.
  Next Obligation.
    rewrite /map θret.
    rewrite /bind /ret monad_law1. reflexivity.
  Qed.
  Next Obligation.
    rewrite bind_comm.
    rewrite <- (monad_law2 (ret tt)) at 1.
    rewrite θbind //.
    rewrite /map /bind monad_law3. f_equal; extensionality a; destruct a as [[] a]. reflexivity.
  Qed.

  Let θ2 := effobs_from_releffobs2.

  Lemma releffobs_eq_effobs1 :
    forall A1 A2 c1 c2,
      θapp A1 A2 ⟨c1, c2⟩ =
      bind (θ1 A1 c1) (fun a : A1 => bind (θ2 A2 c2) (fun b : A2 => ret ⟨ a, b ⟩)).
  Proof.
    move=> A1 A //= c1 c2.
    rewrite <- (monad_law2 c1) at 1.
    rewrite <- (monad_law1 tt (fun _ => c2)) at 1.
    rewrite θbind /=. rewrite bind_comm.
    apply (f_equal (bind (θapp A1 unit ⟨ c1, monad_ret M2 tt ⟩))).
    extensionality a. destruct a as [a1 []].
    rewrite bind_comm //=.
    rewrite <- (monad_law2 c2) at 1.
    rewrite <- (monad_law1 tt (fun _ => monad_ret M1 a1)).
    rewrite θbind.
    apply (f_equal (bind (θapp unit A ⟨ monad_ret M1 tt, c2 ⟩))).
    extensionality b. destruct b as [[] a2].
    apply θret.
  Qed.

  Lemma releffobs_eq_effobs2 : forall A1 A2 c1 c2, θapp A1 A2 ⟨c1, c2⟩ = bind (θ2 A2 c2) (fun b : A2 => bind (θ1 A1 c1) (fun a : A1 => ret ⟨ a, b ⟩)).
    move=> A1 A2 //= c1 c2.
    rewrite <- (monad_law2 c2) at 1.
    rewrite <- (monad_law1 tt (fun _ => c1)) at 1.
    rewrite θbind /=. rewrite bind_comm.
    congr bind.
    extensionality a. destruct a as [[] a2].
    rewrite bind_comm //=.
    rewrite <- (monad_law2 c1) at 1. rewrite <- (monad_law1 tt (fun _ => monad_ret M2 a2)).
    rewrite θbind.
    congr bind. extensionality b. destruct b as [a1 []].
    apply θret.
  Qed.

  Lemma effobs12_commute : forall A1 A2 c1 c2, commute (θ1 A1 c1) (θ2 A2 c2).
    move=> A1 A2 c1 c2. unfold commute.
    rewrite /commute -releffobs_eq_effobs1 -releffobs_eq_effobs2. reflexivity.
  Qed.

  Let θ' : RelationalEffectObservation0 M1 M2 Wrel := commute_effObs _ _ _ θ1 θ2 effobs12_commute.

  Theorem converse_to_commute_effObs : forall A1 A2 c1 c2,
      proj1_sig (θ ⟨ A1, A2 ⟩) ⟨ c1, c2 ⟩  = proj1_sig (θ' ⟨ A1, A2 ⟩) ⟨ c1, c2 ⟩.
    move=> A1 A2 //= c1 c2. apply releffobs_eq_effobs1.
  Qed.
End ConverseCommute.


(*

Author:  Adam Petz, ampetz@ku.edu
*)

Require Import Coq.ZArith.ZArith_base Coq.Strings.String Coq.Strings.Ascii.
Require Import ExtLib.Data.Monads.StateMonad ExtLib.Data.Monads.ReaderMonad ExtLib.Structures.Monads ExtLib.Data.Monads.IdentityMonad.
Require Import List.

Import MonadNotation.
Import ListNotations.
Local Open Scope monad_scope.

Record Env : Type := mk_Env
                          { envA : nat}.

Record St : Type := mk_St
                         { stB : nat}.

Definition M := readerT Env (stateT St ident).
(*Context {State_m: MonadReader Env M}.*)

Definition empty_state := (mk_St 0).
Definition init_env := (mk_Env 0).

Definition inc : M nat :=
  myEnvVal <- asks envA ;;
  myState <- get ;;
  let oldStVal := (stB myState) in
  put (mk_St (oldStVal + 1)) ;;
      ret oldStVal.

Check runReaderT.

Definition incVal :=
  evalStateT (runReaderT inc init_env) empty_state.

Definition incSt : ident St :=
  execStateT (runReaderT inc init_env) empty_state.

Compute (unIdent incVal).
Compute (unIdent incSt).

Definition inc_no_reader : M nat :=
  myState <- get ;;
  let oldStVal := (stB myState) in
  put (mk_St (oldStVal + 1)) ;;
  ret oldStVal.

Definition inc_no_reader_Val : ident nat :=
  evalStateT (inc_no_reader) empty_state.

Definition inc_no_reader_St : ident St :=
  execStateT (inc_no_reader) empty_state.

Compute (unIdent inc_no_reader_Val).
Compute (stB (unIdent inc_no_reader_St)).

Definition just_reader : M nat :=
  myEnvVal <- asks envA ;;
           ret 42.

Definition just_reader_Val : ident nat :=
  evalStateT (just_reader) empty_state.

Definition just_reader_St : ident St :=
  execStateT (just_reader) empty_state.

Compute (unIdent just_reader_Val).
Compute (stB (unIdent just_reader_St)).

Definition R := readerT Env (ident).
Context {asdf: MonadState St R}.


(* Paolo Torrini,
   Universite' Lille-1 - CRIStAL-CNRS
*)
(* example of concrete module *)

Require Import EnvLibA.
Require Import IdModTypeA.
Require Import PRelLibA.
Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.

Module ModNat1 <: IdModType.

  Definition Id := string.

  Definition IdEqDec := string_dec.

  Instance IdEq2 : DEq Id :=
  {
  dEq := IdEqDec
  }.

  Definition IdEq := IdEq2.

  Definition W := nat.

  Definition Loc_PI := valTyp_irrelevance.

  Definition BInit := 0.

  Instance WP2 : PState W :=
  {
  loc_pi := Loc_PI;

  b_init := BInit
  }.

  Definition WP := WP2.

End ModNat1.


From App Require Export
     AppMessage.
From ITree Require Export
     ITree.
From HTTP Require Export
     Semantics.

Variant appE {requestT responseT server_state} : Type -> Type :=
  App__Recv : server_state -> appE (clientT * requestT)
| App__Send : clientT -> responseT -> appE unit.
Arguments appE : clear implicits.

Inductive exp : Type -> Type :=
  Exp__Var   : var -> exp N
| Exp__Const : N   -> exp N
| Exp__Nth   : exp N -> list (exp N) -> exp nat.

Fixpoint exp_eq {X Y} (x : exp X) (y : exp Y) : bool :=
  match x, y with
  | Exp__Var   a, Exp__Var   b
  | Exp__Const a, Exp__Const b => a = b?
  | Exp__Nth x l, Exp__Nth y m => exp_eq x y &&& eqb_list exp_eq l m
  | _, _ => false
  end.

Fixpoint exp_to_sexp {T} (e : exp T) : sexp :=
  match e with
  | Exp__Var   x => [Atom "Variable"; Atom x]
  | Exp__Const n => [Atom "Number"; Atom n]
  | Exp__Nth x l => [Atom "Nth"; exp_to_sexp x; List (map exp_to_sexp l)]
  end%sexp.

#[global]
Instance Serialzie__exp {T} : Serialize (exp T) := exp_to_sexp.

Variant symE : Type -> Type :=
  Sym__Fresh : symE (exp N)
| Sym__Eval  : exp nat -> symE nat.

Class  Is__smE q r s E `{appE q r s -< E} `{symE -< E}.
Notation smE q r s := (appE q r s +' symE).
#[global]
Instance smE_Is__smE {q r s} : Is__smE q r s (smE q r s). Defined.

Definition server_smi {q r s E} `{Is__smE q r s E}
           (handler : forall {F} `{symE -< F}, q -> Monads.stateT s (itree F) r)
  : s -> itree E void :=
  iter_forever
    (fun ss : s =>
       '(c, req) <- embed App__Recv ss;;
       '(ss', res) <- handler req ss;;
       embed App__Send c res;;
       ret ss) .

Definition swap_state exp_ : Type :=
  list (accountT exp_) * list (orderT exp_).

Definition findAccount {exp_} (uid : user_id) (ticker : assetT)
           (a : accountT exp_) : bool :=
  let '(_, (u, t, _)) := a in
  (uid =? u) &&& (ticker =? t).

Definition getx {V E} `{symE -< E} (k : exp N) (l : list (exp N * V))
  : itree E (option V) :=
  n <- embed Sym__Eval (Exp__Nth k (map fst l));;
  ret (snd <$> nth_error l n).

Definition replace {V} (n : nat) (v : V) (l : list V) : list V :=
  firstn n l ++ v :: skipn (S n) l.

Definition updatex {V E} `{symE -< E} (k : exp N) (v : V) (l : list (exp N * V))
  : itree E (list (exp N * V)) :=
  n <- embed Sym__Eval (Exp__Nth k (map fst l));;
  ret (replace n (k, v) l).

Definition credit {E} `{symE -< E} (aid : exp account_id) (amount : amountT)
  : Monads.stateT (swap_state exp) (itree E) (swap_response exp) :=
  fun ss =>
    let (accounts, orders) := ss in
    oa <- getx aid accounts;;
    if oa is Some (uid, ticker, x)
    then let acnt' := (uid, ticker, x + amount) in
         accounts' <- updatex aid acnt' accounts;;
         ret (accounts', orders, Response__Account (aid, acnt'))
    else ret (ss, Response__NotFound).

Definition create {E} `{symE -< E} (uid : user_id) (ticker : assetT)
  : Monads.stateT (swap_state exp) (itree E) (exp account_id) :=
  fun ss =>
    let (accounts, orders) := ss in
    xaid <- trigger Sym__Fresh;;
    ret (put xaid (uid, ticker, 0) accounts, orders, xaid).

Definition locate {E} `{symE -< E} (uid : user_id) (ticker : assetT)
  : Monads.stateT (swap_state exp) (itree E) (exp account_id) :=
  fun ss =>
    let (accounts, orders) := ss in
    if find (findAccount uid ticker) accounts is Some (aid, _)
    then ret (ss, aid)
    else create uid ticker ss.

Definition deposit {E} `{symE -< E}
           (uid : user_id) (ticker : assetT) (amount : amountT)
  : Monads.stateT (swap_state exp) (itree E) (swap_response exp) :=
  fun ss =>
    if min (String.length ticker) $ N.to_nat $ N.min uid amount is O
    then ret (ss, Response__BadRequest)
    else let (accounts, orders) := ss in
         '(s1, aid) <- locate uid ticker ss;;
         credit aid amount s1.

Definition debit {E} `{symE -< E} (aid : exp account_id) (amount : amountT)
  : Monads.stateT (swap_state exp) (itree E) (swap_response exp) :=
  fun ss =>
    let (accounts, orders) := ss in
    oa <- getx aid accounts;;
    if oa is Some (uid, ticker, x)
    then if amount <=? x
         then let acnt' := (uid, ticker, x - amount) in
              accounts' <- updatex aid acnt' accounts;;
              ret (accounts', orders, Response__Account (aid, acnt'))
         else ret (ss, Response__InsufficientFund)
    else ret (ss, Response__NotFound).

Definition withdraw {E} `{symE -< E}
           (uid : user_id) (ticker : assetT) (amount : amountT)
  : Monads.stateT (swap_state exp) (itree E) (swap_response exp) :=
  fun ss =>
    if min (String.length ticker) $ N.to_nat $ N.min uid amount is O
    then ret (ss, Response__BadRequest)
    else let (accounts, orders) := ss in
         if find (findAccount uid ticker) accounts is Some (aid, _)
         then debit aid amount ss
         else ret (ss, Response__InsufficientFund).

Definition swap_handler E `(symE -< E) (req : swap_request id)
  : Monads.stateT (swap_state exp) (itree E) (swap_response exp) :=
  fun ss =>
    let (accounts, orders) := ss in
    match req with
    | Request__Clean => ret ([], [], Response__NoContent)
    | Request__ListOrders => ret (ss, Response__ListOrders orders)
    | Request__ListAccount uid =>
      if uid is 0 then ret (ss, Response__BadRequest) else
      let acs : list (accountT exp) :=
          filter (N.eqb uid ∘ fst ∘ fst ∘ snd) accounts in
      ret (ss, Response__ListAccount acs)
    | Request__Deposit  uid ticker amount => deposit uid ticker amount ss
    | Request__Withdraw uid ticker amount => withdraw uid ticker amount ss
    | Request__MakeOrder uid bt ba st sa =>
      '(s1, r1) <- withdraw uid st sa ss;;
      if r1 is Response__Account (sid, _)
      then
        if min (String.length bt) $ N.to_nat ba is O
        then ret (ss, Response__BadRequest)
        else
          '(s2, bid) <- locate uid bt s1;;
          let (a2, o2) := s2 : swap_state exp in
           oid <- trigger Sym__Fresh;;
           let order : orderT exp := (oid, (bid, ba, sid, sa)) in
           ret (a2, order::o2, Response__Order order)
      else ret (ss, r1)
    | Request__TakeOrder uid oid =>
      if N.min uid oid is 0 then ret (ss, Response__BadRequest) else
      let coid : exp order_id := Exp__Const oid in
      oo <- getx coid orders;;
      if oo is Some (bid, ba, sid, sa)
      then
        ob <- getx bid accounts;;
        os <- getx sid accounts;;
        if (ob, os) is (Some (_, bt, _), Some (_, st, _))
        then
          '(s1, r1) <- withdraw uid bt ba ss;;
          if r1 is Response__Account _
          then
            '(s2, r2) <- credit bid ba s1;;
            if r2 is Response__Account _
            then
              '(s3, r3) <- deposit uid st sa s2;;
              ret (if r3 is Response__Account _ then s3 else ss, r3)
            else ret (ss, r2)
          else ret (ss, r1)
        else ret (ss, Response__NotFound)
      else ret (ss, Response__NotFound)
    end.

Definition swap_smi := server_smi swap_handler.


(*|
#############################
Definition by property in Coq
#############################

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

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

I am having trouble with formalizing definitions of the following
form: define an integer such that some property holds.

Let's say that I formalized the definition of the property:

.. code-block:: coq

    Definition IsGood (x : Z) : Prop := ...

Now I need a definition of the form:

.. code-block:: coq

    Definition Good : Z := ...

assuming that I proved that an integer with the property exists and is
unique:

.. code-block:: coq

    Lemma Lemma_GoodExistsUnique : exists! (x : Z), IsGood x.

Is there an easy way of defining ``Good`` using ``IsGood`` and
``Lemma_GoodExistsUnique``?

Since, the property is defined on integer numbers, it seems that no
additional axioms should be necessary. In any event, I don't see how
adding something like the axiom of choice can help with the
definition.

Also, I am having trouble with formalizing definitions of the
following form (I suspect this is related to the problem I described
above, but please indicate if that is not the case): for every ``x``,
there exists ``y``, and these ``y`` are different for different ``x``.
Like, for example, how to define that there are ``N`` distinct good
integer numbers using ``IsGood``:

.. code-block:: coq

    Definition ThereAreNGoodIntegers (N : Z) (IsGood : Z -> Prop) := ...?

In real-world mathematics, definitions like that occur every now and
again, so this should not be difficult to formalize if Coq is intended
to be suitable for practical mathematics.
|*)

(*|
Answer
******

The short answer to your first question is: in general, it is not
possible, but in your particular case, yes.

In Coq's theory, propositions (i.e., ``Prop``\ s) and their proofs
have a very special status. In particular, it is in general not
possible to write a choice operator that extracts the witness of an
existence proof. This is done to make the theory compatible with
certain axioms and principles, such as proof irrelevance, which says
that all proofs of a given proposition are equal to each other. If you
want to be able to do this, you need to add this choice operator as an
additional axiom to your theory, as in the `standard library
<https://coq.inria.fr/distrib/current/stdlib/Coq.Logic.Epsilon.html>`__.

However, in certain particular cases, it *is* possible to extract a
witness out of an abstract existence proof without recurring to any
additional axioms. In particular, it is possible to do this for
countable types (such as ``Z``) when the property in question is
decidable. You can for instance use the ``choiceType`` interface in
the `Ssreflect
<http://ssr.msr-inria.inria.fr/~jenkins/current/mathcomp.ssreflect.choice.html>`__
library to get exactly what you want (look for the ``xchoose``
function).

That being said, I would usually advice *against* doing things in this
style, because it leads to unnecessary complexity. It is probably
easier to define ``Good`` directly, without resorting to the existence
proof, and then prove separately that ``Good`` has the sought
property.
|*)

Require Import ZArith. (* .none *)
Definition Good : Z. (* ... *) Admitted.
Definition IsGood (z : Z) : Prop. (* ... *) Admitted.

Lemma GoodIsGood : IsGood Good.
Proof. (* ... *) Admitted.

Lemma GoodUnique : forall z : Z, IsGood z -> z = Good.
Proof. (* ... *) Admitted.

(*|
If you absolutely want to define ``Good`` with an existence proof, you
can also change the proof of ``Lemma_GoodExistsUnique`` to use a
connective in ``Type`` instead of ``Prop``, since it allows you to
extract the witness directly using the ``proj1_sig`` function:
|*)

Lemma Lemma_GoodExistsUnique :
  {z : Z | IsGood z /\ forall z', IsGood z' -> z' = z}.
Proof. (* ... *) Admitted.

(*|
As for your second question, yes, it is a bit related to the first
point. Once again, I would recommend that you write down a function
``y_from_x`` with type ``Z -> Z`` that will compute ``y`` given ``x``,
and then prove separately that this function relates inputs and
outputs in a particular way. Then, you can say that the ``y``\ s are
different for different ``x``\ s by proving that ``y_from_x`` is
injective.

On the other hand, I'm not sure how your last example relates to this
second question. If I understand what you want to do correctly, you
can write something like
|*)

Require Import List. (* .none *)
Definition ThereAreNGoodIntegers (N : Z) (IsGood : Z -> Prop) :=
  exists zs : list Z,
    Z.of_nat (length zs) = N
    /\ NoDup zs
    /\ Forall IsGood zs.

(*|
Here, ``Z.of_nat : nat -> Z`` is the canonical injection from naturals
to integers, ``NoDup`` is a predicate asserting that a list doesn't
contain repeated elements, and ``Forall`` is a higher-order predicate
asserting that a given predicate (in this case, ``IsGood``) holds of
all elements of a list.

As a final note, I would advice against using ``Z`` for things that
can only involve natural numbers. In your example, your using an
integer to talk about the cardinality of a set, and this number is
always a natural number.
|*)


(**************************************)
(**************************************)
(****                              ****)
(****   The preservation theorem   ****)
(****                              ****)
(**************************************)
(**************************************)

Require Import Coq.Bool.Bool.
Require Import Coq.Lists.List.
Require Import Main.SystemF.Context.
Require Import Main.SystemF.FreeVar.
Require Import Main.SystemF.Name.
Require Import Main.SystemF.OpeningSubstitution.
Require Import Main.SystemF.Semantics.
Require Import Main.SystemF.Substitution.
Require Import Main.SystemF.Syntax.
Require Import Main.SystemF.Typing.
Require Import Main.Tactics.

Theorem eSubstitutionPreservesTyping :
  forall c1 c2 e1 e2 t1 t2 x,
  hasType (cConcat (cEExtend c1 x t2) c2) e1 t1 ->
  hasType c1 e2 t2 ->
  hasType (cConcat c1 c2) (eeSub e1 x e2) t1.
Proof.
  clean. remember (cConcat (cEExtend c1 x t2) c2). outro c2.
  induction H; eSearch; clean.
  - destruct (nameEq x x0); clean.
    + pose proof (cELookupNone (cEExtend c1 x0 t2) c2 t2 x0). clean.
      pose proof (cELookupConcatLeft (cEExtend c1 x0 t2) c2 t2 x0). clean.
      assert (t = t2); search. clean. clear H3.
      replace (cConcat c1 c2) with (cConcat (cConcat c1 c2) cEmpty); search.
      apply contextWeakening; search. clean.
      apply cWellFormedESkip with (t := t2) (x := x0). search.
    + constructor.
      * apply cWellFormedESkip with (t := t2) (x := x). search.
      * clear H H0. induction c2; search.
  - apply htAbs with (l := x :: l). clean.
    specialize (H1 x0). feed H1.
    replace (
      cEExtend (cConcat c1 c2) x0 t0
    ) with (
      cConcat c1 (cEExtend c2 x0 t0)
    ); search.
    pose proof (typingRegularity c1 e2 t2).
    replace (eFreeVar x0) with (eeSub (eFreeVar x0) x e2); search.
    rewrite <- eeeeSubOpen with (it := 0); search.
  - apply htTAbs with (l := x :: l). clean.
    specialize (H1 x0). feed H1.
    replace (
      cTExtend (cConcat c1 c2) x0
    ) with (
      cConcat c1 (cTExtend c2 x0)
    ); search.
    pose proof (typingRegularity c1 e2 t2).
    rewrite <- eeetSubOpen with (ie := 0); search.
  - apply htTApp; search.
    unfold tWellFormed in *. clean. split; search.
    unfold incl in *. clean. specialize (H2 a). clean.
    rewrite tDomainConcat in *. clean. search.
Qed.

#[export] Hint Resolve eSubstitutionPreservesTyping : main.

Theorem tSubstitutionPreservesTyping :
  forall c1 c2 e t1 t2 x,
  hasType (cConcat (cTExtend c1 x) c2) e t1 ->
  tWellFormed c1 t2 ->
  hasType (cConcat c1 (cSub c2 x t2)) (etSub e x t2) (ttSub t1 x t2).
Proof.
  clean. remember (cConcat (cTExtend c1 x) c2). outro c2.
  induction H; eSearch; clean.
  - constructor.
    + apply cWellFormedTSkip; search.
    + clear H0. induction c2; invert H; search; clean.
      rewrite tttSubBound; search.
      pose proof (tWellFormedClosed c1 t x).
      feed H. apply tLookupWellFormed with (x := x0); search.
  - apply htAbs with (l := x :: l). clean.
    specialize (H1 x0). feed H1.
    replace (
      cEExtend (cConcat c1 (cSub c2 x t2)) x0 (ttSub t0 x t2)
    ) with (
      cConcat c1 (cEExtend (cSub c2 x t2) x0 (ttSub t0 x t2))
    ); search.
    unfold tWellFormed in H0.
    replace (eFreeVar x0) with (etSub (eFreeVar x0) x t2); search.
    rewrite <- eteeSubOpen; search.
    replace (
      cEExtend (cSub c2 x t2) x0 (ttSub t0 x t2)
    ) with (
      cSub (cEExtend c2 x0 t0) x t2
    ); search.
  - apply htTAbs with (l := x :: l). clean.
    specialize (H1 x0). feed H1.
    replace (
      cTExtend (cConcat c1 (cSub c2 x t2)) x0
    ) with (
      cConcat c1 (cSub (cTExtend c2 x0) x t2)
    ); search.
    unfold tWellFormed in H0.
    replace (tFreeVar x0) with (ttSub (tFreeVar x0) x t2); search.
    rewrite <- etetSubOpen; search.
    rewrite <- ttttSubOpen; search.
  - unfold tWellFormed in H0.
    rewrite ttttSubOpen; search.
    apply htTApp; search.
    unfold tWellFormed in *. clean.
    split; search.
    apply incl_tran with (
      m := tFreeVars t2 ++ remove nameEq x (tFreeVars t0)
    ); search.
    unfold incl in *. clean.
    pose proof (
      in_app_or (tFreeVars t2) (remove nameEq x (tFreeVars t0)) a H4
    ).
    clear H4. destruct H5; search.
    rewrite tDomainConcat in *.
    pose proof (nameInRemove (tFreeVars t0) a x H4). clean. clear H4.
    specialize (H3 a). feed H3.
    rewrite cSubTDomain.
    pose proof (in_app_or (tDomain c2) (x :: tDomain c1) a H3).
    destruct H4; search.
Qed.

#[export] Hint Resolve tSubstitutionPreservesTyping : main.

Theorem preservation :
  forall e1 e2 t,
  hasType cEmpty e1 t ->
  step e1 e2 ->
  hasType cEmpty e2 t.
Proof.
  clean. outro e2. remember cEmpty. induction H; search; clean.
  - invert H; search; invert H1; eSearch.
    pose proof (nameFresh (eeFreeVars e ++ l)). clean.
    specialize (H5 x). feed H5.
    rewrite eeSubIntro with (x := x); search.
    replace cEmpty with (cConcat cEmpty cEmpty); eSearch.
  - invert H0; search; invert H1; search.
    pose proof (nameFresh (etFreeVars e0 ++ tFreeVars t1 ++ l)). clean.
    specialize (H5 x). feed H5.
    rewrite etSubIntro with (x := x); search.
    rewrite ttSubIntro with (x := x); search.
    replace cEmpty with (cConcat cEmpty (cSub cEmpty x t2)); eSearch.
Qed.

#[export] Hint Resolve preservation : main.