Require Import VST.floyd.base.
Require Import VST.floyd.val_lemmas.
Require Import VST.floyd.typecheck_lemmas.
Require Import compcert.cfrontend.Ctypes.

Definition const_only_isUnOpResultType {CS: compspecs} op (typeof_a:type) valueof_a ty : bool :=
match op with
  | Cop.Onotbool => match typeof_a with
                    | Tint _ _ _
                    | Tlong _ _
                    | Tfloat _ _ => is_int_type ty
                    | Tpointer _ _ =>
                        if Archi.ptr64
                        then match valueof_a with
                             | Vlong v =>
                                andb (negb (eqb_type (typeof_a) int_or_ptr_type))
                                     (andb (is_int_type ty) (Z.eqb 0 (Int64.unsigned v)))
                             | _ => false
                             end
                        else match valueof_a with
                             | Vint v =>
                                andb (negb (eqb_type typeof_a int_or_ptr_type))
                                     (andb (is_int_type ty) (Z.eqb 0 (Int.unsigned v)))
                             | _ => false
                             end
                    | _ => false
                    end
  | Cop.Onotint => match Cop.classify_notint (typeof_a) with
                   | Cop.notint_default => false
                   | Cop.notint_case_i _ => (is_int32_type ty)
                   | Cop.notint_case_l _ => (is_long_type ty)
                   end
  | Cop.Oneg => match Cop.classify_neg (typeof_a) with
                    | Cop.neg_case_i sg =>
                          andb (is_int32_type ty)
                          match (typeof_a) with
                          | Tint _ Signed _ =>
                            match valueof_a with
                            | Vint v => negb (Z.eqb (Int.signed v) Int.min_signed)
                            | _ => false
                            end
                          | Tlong Signed _ =>
                            match valueof_a with
                            | Vlong v => negb (Z.eqb (Int64.signed v) Int64.min_signed)
                            | _ => false
                            end
                          | _ => true
                          end
                    | Cop.neg_case_f => is_float_type ty
                    | Cop.neg_case_s => is_single_type ty
                    | _ => false
                    end
  | Cop.Oabsfloat =>match Cop.classify_neg (typeof_a) with
                    | Cop.neg_case_i sg => is_float_type ty
                    | Cop.neg_case_l _ => is_float_type ty
                    | Cop.neg_case_f => is_float_type ty
                    | Cop.neg_case_s => is_float_type ty
                    | _ => false
                    end
end.

(* TODO: binarithType would better be bool type *)
Definition const_only_isBinOpResultType {CS: compspecs} op typeof_a1 valueof_a1 typeof_a2 valueof_a2 ty : bool :=
  match op with
  | Cop.Oadd =>
      match Cop.classify_add (typeof_a1) (typeof_a2) with
      | Cop.add_case_pi t _ | Cop.add_case_pl t =>
        andb
          (andb
             (andb (match valueof_a1 with Vptr _ _ => true | _ => false end) (complete_type cenv_cs t))
             (negb (eqb_type (typeof_a1) int_or_ptr_type)))
          (is_pointer_type ty)
    | Cop.add_case_ip _ t | Cop.add_case_lp t =>
        andb
          (andb
             (andb (match valueof_a2 with Vptr _ _ => true | _ => false end) (complete_type cenv_cs t))
             (negb (eqb_type (typeof_a2) int_or_ptr_type)))
          (is_pointer_type ty)
    | Cop.add_default => false
      end
  | _ => false (* TODO *)
  end.

Definition const_only_isCastResultType {CS: compspecs} (t1 t2: type) (valueof_a: val)  : bool :=
  is_neutral_cast t1 t2 ||
  match t1, t2 with
  | Tint _ _ _, Tlong _ _ => true
  | _, _ => false
  end.

Fixpoint const_only_eval_expr {cs: compspecs} (e: Clight.expr): option val :=
  match e with
  | Econst_int i (Tint I32 _ _) => Some (Vint i)
  | Econst_int _ _ => None
  | Econst_long i ty => None
  | Econst_float f (Tfloat F64 _) => Some (Vfloat f)
  | Econst_float _ _ => None
  | Econst_single f (Tfloat F32 _) => Some (Vsingle f)
  | Econst_single _ _ => None
  | Etempvar id ty => None
  | Evar _ _ => None
  | Eaddrof a ty => None
  | Eunop op a ty =>
      match const_only_eval_expr a with
      | Some v => if const_only_isUnOpResultType op (typeof a) v ty
                  then Some (eval_unop op (typeof a) v)
                  else None
      | None => None
      end
  | Ebinop op a1 a2 ty =>
      match (const_only_eval_expr a1), (const_only_eval_expr a2) with
      | Some v1, Some v2 =>
          if const_only_isBinOpResultType op (typeof a1) v1 (typeof a2) v2 ty
          then Some (eval_binop op (typeof a1) (typeof a2) v1 v2)
          else None
      | _, _ => None
      end
  | Ecast a ty =>
      match const_only_eval_expr a with
      | Some v => if const_only_isCastResultType (typeof a) ty v
                  then Some (eval_cast (typeof a) ty v)
                  else None
      | None => None
      end
  | Ederef a ty => None
  | Efield a i ty => None
  | Esizeof t t0 =>
    if andb (complete_type cenv_cs t) (eqb_type t0 size_t)
    then Some (Vptrofs (Ptrofs.repr (sizeof t)))
    else None
  | Ealignof t t0 =>
    if andb (complete_type cenv_cs t) (eqb_type t0 size_t)
    then Some (Vptrofs (Ptrofs.repr (alignof t)))
    else None
  end.

Lemma const_only_isUnOpResultType_spec: forall {cs: compspecs} rho u e t P,
  const_only_isUnOpResultType u (typeof e) (eval_expr e rho) t = true ->
  P |-- denote_tc_assert (isUnOpResultType u e t) rho.
Proof.
  intros.
  unfold isUnOpResultType.
  unfold const_only_isUnOpResultType in H.
  destruct u.
  + destruct (typeof e);
      try solve [inv H | rewrite H; exact (@prop_right mpred _ True _ I)].
    rewrite !denote_tc_assert_andp.
    match goal with
    | |- context [denote_tc_assert (tc_test_eq ?a ?b)] =>
      change (denote_tc_assert (tc_test_eq a b)) with (expr2.denote_tc_assert (tc_test_eq a b))
    end.
    rewrite binop_lemmas2.denote_tc_assert_test_eq'.
    simpl expr2.denote_tc_assert.
    unfold_lift. simpl.
    unfold tc_int_or_ptr_type.
    destruct Archi.ptr64 eqn:HH.
    - destruct (eval_expr e rho); try solve [inv H].
      rewrite !andb_true_iff in H.
      destruct H as [? [? ?]].
      rewrite H, H0.
      rewrite Z.eqb_eq in H1.
      apply andp_right; [exact (@prop_right mpred _ True _ I) |].
      apply andp_right; [exact (@prop_right mpred _ True _ I) |].
      simpl.
      rewrite HH.
      change (P |-- (!! (i = Int64.zero)) && (!! (Int64.zero = Int64.zero)))%logic.
      apply andp_right; apply prop_right; auto.
      rewrite <- (Int64.repr_unsigned i), <- H1.
      auto.
    - destruct (eval_expr e rho); try solve [inv H].
      rewrite !andb_true_iff in H.
      destruct H as [? [? ?]].
      rewrite H, H0.
      rewrite Z.eqb_eq in H1.
      apply andp_right; [exact (@prop_right mpred _ True _ I) |].
      apply andp_right; [exact (@prop_right mpred _ True _ I) |].
      simpl.
      rewrite HH.
      change (P |-- (!! (i = Int.zero)) && (!! (Int.zero = Int.zero)))%logic.
      apply andp_right; apply prop_right; auto.
      rewrite <- (Int.repr_unsigned i), <- H1.
      auto.
  + destruct (Cop.classify_notint (typeof e));
      try solve [inv H | rewrite H; exact (@prop_right mpred _ True _ I)].
  + destruct (Cop.classify_neg (typeof e));
      try solve [inv H | rewrite H; exact (@prop_right mpred _ True _ I)].
    rewrite !andb_true_iff in H.
    destruct H.
    rewrite H; simpl.
    destruct (typeof e) as [| ? [|] | [|] | | | | | |];
      try solve [exact (@prop_right mpred _ True _ I)].
    - simpl.
      unfold_lift.
      unfold denote_tc_nosignedover.
      destruct (eval_expr e rho); try solve [inv H0].
      rewrite negb_true_iff in H0.
      rewrite Z.eqb_neq in H0.
      apply prop_right.
      change (Int.signed Int.zero) with 0.
      rep_lia.
    - simpl.
      unfold_lift.
      unfold denote_tc_nosignedover.
      destruct (typeof e) as [ | _ [ | ] _ | | | | | | | ];
      destruct (eval_expr e rho); try solve [inv H0];
      rewrite negb_true_iff in H0;
      rewrite Z.eqb_neq in H0;
      apply prop_right;
      change (Int64.signed Int64.zero) with 0;
      rep_lia.
  + destruct (Cop.classify_neg (typeof e)); try solve [inv H | rewrite H; exact (@prop_right mpred _ True _ I)].
Qed.

Lemma const_only_isBinOpResultType_spec: forall {cs: compspecs} rho b e1 e2 t P,
  const_only_isBinOpResultType b (typeof e1) (eval_expr e1 rho) (typeof e2) (eval_expr e2 rho) t = true ->
  P |-- denote_tc_assert (isBinOpResultType b e1 e2 t) rho.
Proof.
  intros.
  unfold isBinOpResultType.
  unfold const_only_isBinOpResultType in H.
  destruct b.
  + destruct (Cop.classify_add (typeof e1) (typeof e2)).
    - rewrite !denote_tc_assert_andp; simpl.
      unfold_lift.
      unfold tc_int_or_ptr_type, denote_tc_isptr.
      destruct (eval_expr e1 rho); inv H.
      rewrite !andb_true_iff in H1.
      destruct H1 as [[? ?] ?].
      rewrite H, H0, H1.
      simpl.
      repeat apply andp_right; apply prop_right; auto.
    - rewrite !denote_tc_assert_andp; simpl.
      unfold_lift.
      unfold tc_int_or_ptr_type, denote_tc_isptr.
      destruct (eval_expr e1 rho); inv H.
      rewrite !andb_true_iff in H1.
      destruct H1 as [[? ?] ?].
      rewrite H, H0, H1.
      simpl.
      repeat apply andp_right; apply prop_right; auto.
    - rewrite !denote_tc_assert_andp; simpl.
      unfold_lift.
      unfold tc_int_or_ptr_type, denote_tc_isptr.
      destruct (eval_expr e2 rho); inv H.
      rewrite !andb_true_iff in H1.
      destruct H1 as [[? ?] ?].
      rewrite H, H0, H1.
      simpl.
      repeat apply andp_right; apply prop_right; auto.
    - rewrite !denote_tc_assert_andp; simpl.
      unfold_lift.
      unfold tc_int_or_ptr_type, denote_tc_isptr.
      destruct (eval_expr e2 rho); inv H.
      rewrite !andb_true_iff in H1.
      destruct H1 as [[? ?] ?].
      rewrite H, H0, H1.
      simpl.
      repeat apply andp_right; apply prop_right; auto.
    - inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
Qed.

Lemma const_only_isCastResultType_spec: forall {cs: compspecs} rho e t P,
  const_only_isCastResultType (typeof e) t (eval_expr e rho) = true ->
  P |-- denote_tc_assert (isCastResultType (typeof e) t e) rho.
Proof.
  intros.
  unfold const_only_isCastResultType in H.
  rewrite orb_true_iff in H.
  destruct H.
  apply neutral_isCastResultType; auto.
  destruct (typeof e); inv H.
  destruct t; inv H1.
  simpl. apply TT_right.
Qed.

Lemma const_only_eval_expr_eq: forall {cs: compspecs} rho e v,
  const_only_eval_expr e = Some v ->
  eval_expr e rho = v.
Proof.
  intros.
  revert v H; induction e; try solve [intros; inv H; auto].
  + intros.
    simpl in *.
    destruct t as [| [| | |] | | | | | | |]; inv H.
    auto.
  + intros.
    simpl in *.
    destruct t as [| | | [|] | | | | |]; inv H.
    auto.
  + intros.
    simpl in *.
    destruct t as [| | | [|] | | | | |]; inv H.
    auto.
  + intros.
    simpl in *.
    unfold option_map in H.
    destruct (const_only_eval_expr e); inv H.
    destruct (const_only_isUnOpResultType u (typeof e) v0 t); inv H1.
    specialize (IHe _ eq_refl).
    unfold_lift.
    rewrite IHe; auto.
  + intros.
    simpl in *.
    unfold option_map in H.
    destruct (const_only_eval_expr e1); inv H.
    destruct (const_only_eval_expr e2); inv H1.
    destruct (const_only_isBinOpResultType b (typeof e1) v0 (typeof e2) v1 t); inv H0.
    specialize (IHe1 _ eq_refl).
    specialize (IHe2 _ eq_refl).
    unfold_lift.
    rewrite IHe1, IHe2; auto.
  + intros.
    simpl in *.
    unfold option_map in H.
    destruct (const_only_eval_expr e); inv H.
    destruct (const_only_isCastResultType (typeof e) t v0) eqn:?H; inv H1.
    unfold_lift. erewrite IHe by reflexivity. auto.
  + intros.
    simpl in *.
    destruct (complete_type cenv_cs t); inv H.
    destruct (eqb_type t0 size_t); inv H1.
    auto.
  + intros.
    simpl in *.
    destruct (complete_type cenv_cs t); inv H.
    destruct (eqb_type t0 size_t); inv H1.
    auto.
Qed.

Lemma const_only_eval_expr_tc: forall {cs: compspecs} Delta e v P,
  const_only_eval_expr e = Some v ->
  P |-- tc_expr Delta e.
Proof.
  intros.
  intro rho.
  revert v H; induction e; try solve [intros; inv H].
  + intros.
    inv H.
    destruct t as [| [| | |] | | | | | | |]; inv H1.
    exact (@prop_right mpred _ True _ I).
  + intros.
    inv H.
    destruct t as [| | | [|] | | | | |]; inv H1.
    exact (@prop_right mpred _ True _ I).
  + intros.
    inv H.
    destruct t as [| | | [|] | | | | |]; inv H1.
    exact (@prop_right mpred _ True _ I).
  + intros.
    unfold tc_expr in *.
    simpl in *.
    unfold option_map in H.
    destruct (const_only_eval_expr e) eqn:HH; inv H.
    specialize (IHe _ eq_refl).
    unfold_lift.
    rewrite denote_tc_assert_andp; simpl; apply andp_right; auto.
    apply const_only_isUnOpResultType_spec.
    apply (const_only_eval_expr_eq rho) in HH.
    rewrite HH.
    destruct (const_only_isUnOpResultType u (typeof e) v0 t); inv H1; auto.
  + intros.
    unfold tc_expr in *.
    simpl in *.
    unfold option_map in H.
    destruct (const_only_eval_expr e1) eqn:HH1; inv H.
    destruct (const_only_eval_expr e2) eqn:HH2; inv H1.
    specialize (IHe1 _ eq_refl).
    specialize (IHe2 _ eq_refl).
    unfold_lift.
    rewrite !denote_tc_assert_andp; simpl; repeat apply andp_right; auto.
    apply const_only_isBinOpResultType_spec.
    apply (const_only_eval_expr_eq rho) in HH1.
    apply (const_only_eval_expr_eq rho) in HH2.
    rewrite HH1, HH2.
    destruct (const_only_isBinOpResultType b (typeof e1) v0 (typeof e2) v1 t); inv H0; auto.
  + intros.
    unfold tc_expr in *.
    simpl in *.
    unfold option_map in H.
    destruct (const_only_eval_expr e) eqn:HH; inv H.
    destruct (const_only_isCastResultType (typeof e) t v0) eqn:?H; inv H1.
    rewrite denote_tc_assert_andp.
    simpl.
    apply andp_right; eauto.
    apply const_only_isCastResultType_spec; auto.
  + intros.
    inv H.
    unfold tc_expr.
    simpl typecheck_expr.
    simpl.
    destruct (complete_type cenv_cs t && eqb_type t0 size_t) eqn:HH; inv H1.
    rewrite andb_true_iff in HH.
    unfold tuint in HH; destruct HH.
    rewrite H, H0.
    exact (@prop_right mpred _ True _ I).
  + intros.
    inv H.
    unfold tc_expr.
    simpl typecheck_expr.
    simpl.
    destruct (complete_type cenv_cs t && eqb_type t0 size_t) eqn:HH; inv H1.
    rewrite andb_true_iff in HH.
    unfold tuint in HH; destruct HH.
    rewrite H, H0.
    exact (@prop_right mpred _ True _ I).
Qed.


Require Import Coq.Program.Basics.
Require Import Coq.Strings.String.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.
Require Import Coq.Program.Equality.
Require Import Logic.FunctionalExtensionality.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import seq ssreflect ssrbool ssrnat eqtype.

Require Import FinProof.Common.
Require Import FinProof.MonadTransformers21.
Require Import FinProof.Common.
Require Import FinProof.StateMonad21.
Require Import FinProof.StateMonad21Instances.
Require Import FinProof.Types.IsoTypes.

Require Import UMLang.UrsusLib.

Require Import UrsusStdLib.Cpp.stdTypes.

Require Import UrsusTVM.Cpp.tvmTypes.
Require Import UrsusTVM.Cpp.tvmFunc.
Require Import UrsusTVM.Cpp.tvmNotations.
Require Import UrsusTVM.Cpp.tvmCells.

Require Import Project.CommonConstSig.
Require Import Project.CommonTypes.

From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Open Scope qc_scope.
Import GenLow GenHigh.
Set Warnings "-extraction-opaque-accessed,-extraction".

(*string*)

Derive Show for ascii.
Derive Shrink for ascii.
Derive GenSized for ascii.

Derive Show for string.
Derive Shrink for string.
Derive GenSized for string.

Derive Show for unit.
Derive Shrink for unit.
Derive GenSized for unit.

Local Open  Scope N_scope.

Notation " x 'deciever' " := ( N.mul x 1 ) (at level 100).

(*move these two instances to another file*)
#[global, program]
Instance commonConsts: KWMessagesCommonConsts.
Next Obligation.
refine (Build_XUBInteger 180). (* MIN_VOTING_TIME *)
Defined.
Next Obligation.
refine (Build_XUBInteger 345600). (* TIME_FOR_SETCODE_PREPARE *)
Defined.
Next Obligation.
refine (Build_XUBInteger 259200). (* TIME_FOR_FUNDS_COLLECTING *)
Defined.
Next Obligation.
refine (Build_XUBInteger (5 deciever)). (* VOTING_FEE *)
Defined.
Next Obligation.
refine (Build_XUBInteger 64). (* MSG_VALUE_BUT_FEE_FLAGS *)
Defined.
Next Obligation.
refine (Build_XUBInteger 0). (* DEFAULT_MSG_FLAGS *)
Defined.
Next Obligation.
refine (Build_XUBInteger 128). (* ALL_BALANCE_MSG_FLAG *)
Defined.
Next Obligation.
refine (Build_XUBInteger (50 deciever) ). (* FG_MIN_BALANCE *)
Defined.
Next Obligation.
refine (Build_XUBInteger (5 deciever) ). (* GAS_FOR_FUND_MESSAGE *)
Defined.
Next Obligation.
refine (Build_XUBInteger (50 deciever) ).  (* KWD_MIN_BALANCE *)
Defined.
Next Obligation.
refine (Build_XUBInteger (5 deciever) ). (* GAS_FOR_PARTICIPANT_MESSAGE *)
Defined.
Next Obligation.
refine (Build_XUBInteger (5 deciever) ). (* EPSILON_BALANCE *)
Defined.
Next Obligation.
refine (Build_XUBInteger (500 deciever) ). (* RESPAWN_BALANCE *)
Defined.
Next Obligation.
refine (Build_XUBInteger (200 deciever) ). (* BLANK_MIN_BALANCE *)
Defined.
(*Next Obligation.
refine (Build_XUBInteger 1). (* FEE_SEPARATE_MSG_FLAGS *)
Defined. *)
Fail Next Obligation.

#[global, program]
Instance commonErrors: KWErrorsCommonErrors.
Next Obligation.
refine  101.
Defined.
Next Obligation.
refine  102.
Defined.
Next Obligation.
refine  103.
Defined.
Next Obligation.
refine  104.
Defined.
Next Obligation.
refine  105.
Defined.
Next Obligation.
refine  106.
Defined.
Next Obligation.
refine  107.
Defined.
Next Obligation.
refine  108.
Defined.
Next Obligation.
refine  109.
Defined.
Next Obligation.
refine  110.
Defined.
Next Obligation.
refine  111.
Defined.
Next Obligation.
refine  112.
Defined.
Next Obligation.
refine  113.
Defined.
Next Obligation.
refine  114.
Defined.
Next Obligation.
refine  115.
Defined.
Next Obligation.
refine  116.
Defined.
Next Obligation.
refine  117.
Defined.
Next Obligation.
refine  118.
Defined.
Next Obligation.
refine  119.
Defined.
Next Obligation.
refine  120.
Defined.
Next Obligation.
refine  121.
Defined.
Next Obligation.
refine  122.
Defined.
Next Obligation.
refine  123.
Defined.
Next Obligation.
refine  124.
Defined.
Next Obligation.
refine  125.
Defined.
Next Obligation.
refine  126.
Defined.
Next Obligation.
refine  127.
Defined.
Next Obligation.
refine  128.
Defined.
Next Obligation.
refine  129.
Defined.
Next Obligation.
refine  130.
Defined.
Next Obligation.
refine  131.
Defined.
Next Obligation.
refine  132.
Defined.
Next Obligation.
refine  133.
Defined.
Next Obligation.
refine  134.
Defined.
Fail Next Obligation.

Derive Show for xprod.
Derive Shrink for xprod.
Derive GenSized for xprod.

Derive Show for prod.
Derive Shrink for prod.
Derive GenSized for prod.

(* Derive Show for option.
Derive Shrink for option.
Derive GenSized for option. *)

(*isotypes*)

#[local]
Instance iso_show : forall X Y`{IsoTypes X Y}`{Show Y},  Show X.
intros.
split.
intros.
refine (show (x2y X0)).
Defined.

#[local]
Instance iso_shrink : forall X Y`{IsoTypes X Y}`{Shrink Y}, Shrink X.
intros.
split.
intros.
pose proof (shrink (x2y X0)).
refine (List.map y2x X1).
Defined.

#[local]
Instance iso_genSized : forall X Y`{IsoTypes X Y}`{GenSized Y}, GenSized X.
intros.
split.
intros.
pose proof (arbitrarySized H1 : G Y).
refine (fmap y2x X0).
Defined.

#[local]
Remove Hints iso_show : typeclass_instances.
#[local]
Remove Hints iso_shrink : typeclass_instances.
#[local]
Remove Hints iso_genSized : typeclass_instances.

(* sum *)

#[global]
Instance sum_show : forall X Y`{Show X }`{Show Y}, Show (X + Y).
intros.
split.
intros.
destruct X0.
refine ( "left: " ++ (show x))%string.
refine ( "right: " ++ (show y))%string.
Defined.

#[global]
Instance sum_shrink : forall X Y`{Shrink X}`{Shrink Y}, Shrink (X+Y).
intros.
split.
intros.
destruct X0.
pose proof (shrink x).
refine (List.map inl X0).
pose proof (shrink y).
refine (List.map inr X0).
Defined.

#[global]
Instance sum_genSized : forall X Y`{GenSized X}`{GenSized Y}, GenSized (X+Y).
intros.
split.
intros.
pose proof (arbitrarySized H1: G bool).
Search (forall X Y, G X -> (X -> G Y) -> G Y).
eapply bindGen. { exact X0. }
intros b. destruct b.
-
pose proof (arbitrarySized H1: G X).
refine (fmap inl X1).
-
pose proof (arbitrarySized H1: G Y).
refine (fmap inr X1).
Defined.

(*uint*)

Definition uint_n_to_uint {n} (x: XUBInteger n) : XUInteger.
dependent destruction x.
exact x.
Defined.

#[global]
Instance iso_uint: forall n, IsoTypes (XUBInteger n) (XUInteger).
intros.
esplit with (x2y := fun x => uint_n_to_uint x ) (y2x := Build_XUBInteger); try reflexivity.
extensionality x.
unfold compose.
dependent destruction x.
reflexivity.
Defined.

#[global]
Instance iso_option: forall X, IsoTypes (option X) (unit + X).
intros.
esplit with (x2y := fun x => match x with
                             | Some x => inr x
                             | None => inl tt end  ) (y2x := fun y =>  match y with
                                                             | inr x => Some x
                                                             | inl tt => None end); try reflexivity.
extensionality x. unfold compose.
destruct x; try destruct u; reflexivity.
extensionality y. unfold compose.
destruct y; reflexivity.
Defined.

#[global]
Instance option_gensized: forall X`{GenSized X}, GenSized (option X).
intros.
eapply iso_genSized.
eapply iso_option.
eapply sum_genSized.
apply GenSizedunit.
apply H.
Defined.

#[global]
Instance uint_n_show: forall n, Show (XUBInteger n) .
intros.
eapply iso_show.
eapply iso_uint.
apply showN.
Defined.

#[global]
Instance uint_n_shrink: forall n, Shrink (XUBInteger n) .
intros.
eapply iso_shrink.
eapply iso_uint.
apply shrinkN.
Defined.

#[global]
Instance uint_n_genSized: forall n, GenSized (XUBInteger n) .
intros.
eapply iso_genSized.
eapply iso_uint.
apply genNSized.
Defined.

(*messages*)

Definition fromMessage {I} (m: OutgoingMessage I): (unit*InternalMessageParamsLRecord)+(I*InternalMessageParamsLRecord).
destruct m.
refine (inl (tt,i)).
refine (inr (i0,i)).
Defined.

Definition toMessage {I} (m: (unit*InternalMessageParamsLRecord)+(I*InternalMessageParamsLRecord)) : OutgoingMessage I.
destruct m. destruct p.
refine (EmptyMessage _ i).
destruct p.
refine (OutgoingInternalMessage i0 i).
Defined.

#[global]
Instance iso_OutgoingMessage: forall I , IsoTypes (OutgoingMessage I) ((unit*InternalMessageParamsLRecord)+I*InternalMessageParamsLRecord).
intros.
esplit with (x2y := fromMessage )
            (y2x := toMessage); try reflexivity.
all: unfold compose.
extensionality m.
destruct m.
simpl. destruct p. simpl. destruct u. reflexivity.
simpl. destruct p. reflexivity.
extensionality m.
destruct m.
simpl. reflexivity.
simpl. reflexivity.
Defined.

(*cells*)

#[global]
Instance iso_cell: forall n , IsoTypes (CellSliceBuilder n) TvmCell_.
intros.
esplit with (x2y := undressBuilder )
            (y2x := Build_CellSliceBuilder _); try reflexivity.
extensionality x.
destruct x; reflexivity.
Defined.

Derive Show for TvmCell_.
Derive Shrink for TvmCell_.
Derive GenSized for TvmCell_.

(*cell_*)

#[global]
Instance cell_show: Show cell_.
eapply iso_show.
eapply iso_cell.
apply ShowTvmCell_.
Defined.

#[global]
Instance cell_shrink: Shrink cell_.
eapply iso_shrink.
eapply iso_cell.
apply ShrinkTvmCell_.
Defined.

#[global]
Instance cell_genSized: GenSized cell_.
eapply iso_genSized.
eapply iso_cell.
apply GenSizedTvmCell_.
Defined.

(*builder_*)

#[global]
Instance builder_show: Show builder_.
eapply iso_show.
eapply iso_cell.
apply ShowTvmCell_.
Defined.

#[global]
Instance builder_shrink: Shrink builder_.
eapply iso_shrink.
eapply iso_cell.
apply ShrinkTvmCell_.
Defined.

#[global]
Instance builder_genSized: GenSized builder_.
eapply iso_genSized.
eapply iso_cell.
apply GenSizedTvmCell_.
Defined.

(*outgoing message*)

#[global]
Instance OutgoingMessage_show: forall I`{Show I}, Show (OutgoingMessage I).
intros.
eapply iso_show.
eapply iso_OutgoingMessage.
eapply sum_show.
eapply Showprod.
eapply Showprod.
Defined.

#[global]
Instance OutgoingMessage_shrink: forall I`{Shrink I}, Shrink (OutgoingMessage I).
intros.
eapply iso_shrink.
eapply iso_OutgoingMessage.
eapply sum_shrink.
eapply Shrinkprod.
eapply Shrinkprod.
Defined.

#[global]
Instance OutgoingMessage_genSized: forall I`{GenSized I}, GenSized (OutgoingMessage I).
intros.
eapply iso_genSized.
eapply iso_OutgoingMessage.
eapply sum_genSized.
eapply GenSizedprod.
eapply GenSizedprod.
Defined.

(* Print Instances GenSized. *)

(*interfaces*)

Require Import Interfaces.IBlank.IBlank.Interface.
Derive Show for IBlank.
Derive Shrink for IBlank.
Derive GenSized for IBlank.

Require Import Interfaces.IKWFund.IKWFund.Interface.
Derive Show for IKWFund.
Derive Shrink for IKWFund.
Derive GenSized for IKWFund.

Require Import Interfaces.IKWFundParticipant.IKWFundParticipant.Interface.
Derive Show for IKWFundParticipant.
Derive Shrink for IKWFundParticipant.
Derive GenSized for IKWFundParticipant.

Require Import Contracts.KWDPool.DKWDPool.Interface.
Derive Show for IDKWDPool.
Derive Shrink for IDKWDPool.
Derive GenSized for IDKWDPool.

Require Import Contracts.FromGiver.DFromGiver.Interface.
Derive Show for IDFromGiver.
Derive Shrink for IDFromGiver.
Derive GenSized for IDFromGiver.

(*PhantomType*)

#[global]
Instance iso_phantom: IsoTypes PhantomType unit.
esplit with (x2y:=fun  _ => tt) (y2x:=fun _ => PhantomPoint).
extensionality x.
unfold compose.
destruct x. reflexivity.
extensionality x.
unfold compose.
apply phantom_all.
Defined.

#[global]
Instance phantom_show: Show PhantomType .
eapply iso_show.
apply iso_phantom.
apply Showunit.
Defined.

#[global]
Instance phantom_shrink: Shrink PhantomType .
eapply iso_shrink.
apply iso_phantom.
apply Shrinkunit.
Defined.

#[global]
Instance phantom_genSized: GenSized PhantomType .
eapply iso_genSized.
apply iso_phantom.
apply GenSizedunit.
Defined.

(*MessagesAndEvents*)

#[local]
Remove Hints isoid : typeclass_instances.
#[local]
Remove Hints iso_show : typeclass_instances.
#[local]
Remove Hints iso_shrink : typeclass_instances.
#[local]
Remove Hints iso_genSized : typeclass_instances.

(*VMState*)

#[global]
Instance VMState_Show: Show VMStateLRecord.
refine Showxprod.
Defined.

#[global]
Instance VMState_Shrink: Shrink VMStateLRecord.
refine Shrinkxprod.
Defined.

#[global]
Instance VMState_GenSized: GenSized VMStateLRecord.
refine GenSizedxprod.
Defined.

Definition implb (a b: bool) := orb (negb a) b.

Definition bimplb (a b: bool) := andb  (implb a b)  (implb b a).

#[global]
Instance ge_dec: forall m n, Dec (N.ge m n).
intros.
esplit.
unfold decidable.
remember (N.ltb m n).
destruct b.
symmetry in Heqb.
apply N.ltb_lt in Heqb.
right. lia.
symmetry in Heqb.
apply N.ltb_ge in Heqb.
left. lia.
Defined.

#[global]
Instance lt_dec: forall m n, Dec (N.lt m n).
intros.
esplit.
unfold decidable.
remember (N.ltb m n).
destruct b.
symmetry in Heqb.
apply N.ltb_lt in Heqb.
left. lia.
symmetry in Heqb.
apply N.ltb_ge in Heqb.
right. lia.
Defined.

#[global]
Instance le_dec: forall m n, Dec (N.le m n).
intros.
esplit.
unfold decidable.
remember (N.leb m n).
destruct b.
symmetry in Heqb.
apply N.leb_le in Heqb.
left. lia.
symmetry in Heqb.
apply N.leb_gt in Heqb.
right. lia.
Defined.

#[global]
Instance gt_dec: forall m n, Dec (N.gt m n).
intros.
esplit.
unfold decidable.
remember (N.leb m n).
destruct b.
symmetry in Heqb.
apply N.leb_le in Heqb.
right. lia.
symmetry in Heqb.
apply N.leb_gt in Heqb.
left. lia.
Defined.

Notation ControlResult := (@ControlResultL) .
Definition isError {R b} (cr : ControlResult R b) : Prop :=
 match cr with
 | ControlValue _ _ => False
 | _ => True
 end.

#[global]
Instance isError_Dec {R b}: forall  (cr : ControlResult R b), Dec (isError cr).
intros.
esplit.
unfold decidable.
dependent destruction cr.
now right.
all: now left.
Defined.

#[global]
Instance Dec_equiv : forall {P Q : Prop}, Dec P -> Dec Q -> Dec (P <-> Q) .
intros.
eapply Dec_conj.
Defined.

Definition uint2N {n} (x: XUBInteger n) : N.
dependent destruction x.
refine x.
Defined.

#[global] Instance prod_Dec: forall X Y (x1 x2: X) (y1 y2: Y) `{Dec (x1=x2)}`{Dec (y1=y2)}, Dec (pair x1 y1 = pair x2 y2).
intros.
esplit.
unfold decidable.
destruct H, H0.
destruct dec, dec0.
left.
congruence.
right.
unfold not.
intros.
inversion H.
contradiction.
right.
unfold not.
intros.
inversion H.
contradiction.
right.
unfold not.
intros.
inversion H.
contradiction.
Defined.

#[global] Instance xprod_Dec: forall X Y (x1 x2: X) (y1 y2: Y) `{Dec (x1=x2)}`{Dec (y1=y2)}, Dec (xpair x1 y1 = xpair x2 y2).
intros.
esplit.
unfold decidable.
destruct H, H0.
destruct dec, dec0.
left.
congruence.
right.
unfold not.
intros.
inversion H.
contradiction.
right.
unfold not.
intros.
inversion H.
contradiction.
right.
unfold not.
intros.
inversion H.
contradiction.
Defined.

#[global]
Instance XUBIntegerEq_Dec {n} (a b: XUBInteger n): Dec (a = b).
destruct a,b.
esplit.
unfold decidable.
decide equality.
decide equality.
decide equality.
Defined.

#[global]
Instance addressEq_Dec (a b: address): Dec (a = b).
destruct a,b.
esplit.
unfold decidable.
eapply prod_Dec.
esplit.
unfold decidable.
decide equality.
decide equality.
decide equality.
esplit.
unfold decidable.
decide equality.
decide equality.
decide equality.
Defined.

#[global]
Instance cellEq_Dec (a b: cell_): Dec (a = b).
esplit.
unfold decidable.
decide equality.
decide equality.
decide equality.
decide equality.
Defined.

#[global]
Instance cellBoolEq: XBoolEquable bool cell_ .
esplit.
intros.
pose proof (cellEq_Dec H H0).
destruct H1.
destruct dec.
refine true.
refine false.
Defined.

#[global]
Instance optionEq_Dec {X}`{forall (a b:X),Dec (a=b) } (a b: option X): Dec (a = b).
esplit.
unfold decidable.
decide equality.
eapply H.
Defined.

#[global] Instance VMStateEq_Dec: forall (l1 l2: VMStateLRecord), Dec (l1 = l2).
intros.
esplit.
unfold decidable.
repeat decide equality.
Defined.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.

#[global]
Instance IKWFundParticipant_booleq : XBoolEquable bool
         Interfaces.IKWFundParticipant.IKWFundParticipant.Interface.IKWFundParticipant.
esplit.
intros.
case_eq H; intros; case_eq H0; intros.
refine (eqb x x0).
refine false. refine false. refine false. refine false. refine false. refine false.
refine true.
refine false. refine false. refine false. refine false. refine false. refine false.
refine true.
refine false. refine false. refine false. refine false. refine false. refine false.
refine (eqb c c0 ).
refine false. refine false. refine false. refine false. refine false. refine false.
refine (eqb x x4 && eqb x0 x5 && eqb x1 x6 && eqb x2 x7 && eqb x3 x8).
refine false. refine false. refine false. refine false. refine false. refine false.
refine (eqb x x2 && eqb x0 x3 && eqb x1 x4).
Defined.

#[global]
Instance IBlank_booleq : XBoolEquable bool
         Interfaces.IBlank.IBlank.Interface.IBlank.
esplit.
intros.
case_eq X; intros; case_eq X0; intros.
refine (eqb x x5 && eqb x0 x6 && eqb x1 x7 && eqb x2 x8 && eqb x3 x9 && eqb x4 x10).
refine false. refine false. refine false. refine false. refine false. refine false. refine false.
refine (eqb a a0 && eqb x x0 ).
refine false. refine false. refine false. refine false. refine false. refine false. refine false.
refine (eqb a a0 && eqb x x1 && eqb x0 x2 ).
refine false. refine false. refine false. refine false. refine false. refine false. refine false.
refine (eqb x x1 && eqb x0 x2 ).
refine false. refine false. refine false. refine false. refine false. refine false. refine false.
refine (eqb x x1 && eqb x0 x2 ).
refine false. refine false. refine false. refine false. refine false. refine false. refine false.
refine (eqb a a0 && eqb x x2 && eqb x0 x3 && eqb x1 x4 ).
refine false. refine false. refine false. refine false. refine false. refine false. refine false.
refine (eqb x x3 && eqb x0 x4 && eqb x1 x5 && eqb x2 x6).
Defined.

#[global]
Instance IKWFund_booleq : XBoolEquable bool
         Interfaces.IKWFund.IKWFund.Interface.IKWFund.
esplit.
intros.
case_eq X; intros; case_eq X0; intros.
refine (eqb x x1 && eqb x0 x2 && eqb c c0).
refine false. refine false.
refine (eqb a a0 && eqb x x0 && eqb c c0).
Defined.

#[global]
Instance IDFromGiver_booleq : XBoolEquable bool
         FromGiver.DFromGiver.Interface.IDFromGiver.
esplit.
intros.
case_eq H; intros; case_eq H0; intros.
refine true.
refine false. refine false. refine false. refine false. refine false.  refine false.  refine false.  refine false.  refine false.
refine (eqb x x0).
refine false. refine false. refine false. refine false. refine false.  refine false.  refine false.  refine false.  refine false.
refine true.
refine false. refine false. refine false. refine false. refine false.  refine false.  refine false.  refine false.  refine false.
refine (eqb c c0).
refine false. refine false. refine false. refine false. refine false.  refine false.  refine false.  refine false.  refine false.
refine true.
refine false. refine false. refine false. refine false. refine false.  refine false.  refine false.  refine false.  refine false.
refine (eqb x x2 && eqb x0 x3 && eqb x1 x4).
refine false. refine false. refine false. refine false. refine false.  refine false.  refine false.  refine false.  refine false.
refine true.
refine false. refine false. refine false. refine false. refine false.  refine false.  refine false.  refine false.  refine false.
refine (eqb x x4 && eqb x0 x5 && eqb x1 x6 && eqb x2 x7 && eqb x3 x8).
refine false. refine false. refine false. refine false. refine false.  refine false.  refine false.  refine false.  refine false.
refine (eqb x x1 && eqb x0 x2).
Defined.

#[global]
Instance OutgoingMessage_booleq: forall I `{XBoolEquable bool I}, XBoolEquable bool
         (OutgoingMessage I).
intros.
esplit.
intros.
case_eq X; intros; case_eq X0; intros.
refine true. refine false. refine false.
refine  (eqb i i1 && eqb i0 i2).
Defined.

Definition isMessageSent {I}`{XBoolEquable bool I} (m: OutgoingMessage I) (a: address) (n: N)
                         (l: XHMap address (XQueue (OutgoingMessage I))) : bool :=
  let subm := hmapFindWithDefault default a l in
  let maxk : option N := xHMapMaxKey subm in
  match maxk with
    | None => false
    | Some k =>
        match hmapLookup (k-n) subm with
        | None => false
        | Some m' => eqb m m'
        end
  end.

#[global] Instance phantom_booleq: XBoolEquable bool PhantomType := {eqb := fun _ _ => true}.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.lib.EnsemblesProperties.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Complete.Lindenbaum.
Require Import Logic.GeneralLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Trivial.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.MinimumLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Trivial.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.

Section Lindenbaum_Trivial.

Context {L: Language}
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {negpL: NegLanguage L}
        {iffpL: IffLanguage L}
        {truepL: TrueLanguage L}
        {GammaP: Provable L}
        {GammaD: Derivable L}
        {GammaPD: ProvableDerivable L GammaP GammaD}
        {bSC: BasicSequentCalculus L GammaD}
        {fwSC: FiniteWitnessedSequentCalculus L GammaD}
        {minSC: MinimumSequentCalculus L GammaD}
        {andpSC: AndSequentCalculus L GammaD}
        {orpSC: OrSequentCalculus L GammaD}
        {falsepSC: FalseSequentCalculus L GammaD}
        {inegpSC: IntuitionisticNegSequentCalculus L GammaD}
        {iffpSC: IffSequentCalculus L GammaD}
        {truepSC: TrueSequentCalculus L GammaD}
        {cpSC: ClassicalSequentCalculus L GammaD}
        {minAX: MinimumAxiomatization L GammaP}
        {andpAX: AndAxiomatization L GammaP}
        {orpAX: OrAxiomatization L GammaP}
        {falsepAX: FalseAxiomatization L GammaP}
        {inegpAX: IntuitionisticNegAxiomatization L GammaP}
        {iffpAX: IffAxiomatization L GammaP}
        {truepAX: TrueAxiomatization L GammaP}.

Lemma Lindenbaum_for_max_consistent: forall P,
  Lindenbaum_ensures P derivable_closed ->
  Lindenbaum_ensures P orp_witnessed ->
  Lindenbaum_ensures P consistent ->
  Lindenbaum_ensures P (maximal consistent).
Proof.
  intros.
  hnf; intros.
  apply DDCS_MCS; auto.
Qed.

Lemma Lindenbaum_cannot_derive_ensures_max_consistent
      {GammaDP: DerivableProvable L GammaP GammaD}:
  forall x, Lindenbaum_ensures (cannot_derive x) (maximal consistent).
Proof.
  intros.
  apply Lindenbaum_for_max_consistent.
  - apply Lindenbaum_cannot_derive_ensures_derivable_closed.
  - apply Lindenbaum_cannot_derive_ensures_orp_witnessed.
  - apply Lindenbaum_cannot_derive_ensures_consistent.
Qed.

End Lindenbaum_Trivial.