Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Require Import FinProof.CommonProofs.

Require Import depoolContract.SolidityNotations.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolSpec.
(* Require Import MultiSigWallet.Proofs.Tactics. *)

Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Local Open Scope struct_scope.
Local Open Scope Z_scope.

Module CommonModelProofs (sm: StateMonadSig).
Export sm.
Existing Instance monadStateT.
Existing Instance monadStateStateT.

(*TODO: wrong module to import!*)

Module DePoolSpec := DePoolSpec ProofEnvironment.XTypesSig sm.
Import DePoolSpec.
Import LedgerClass.
Import SolidityNotations.

Local Open Scope solidity_scope.

Set Typeclasses Iterative Deepening.
(*Set Typeclasses Depth 1.
Set Typeclasses Strict Resolution. *)
(* Set Typeclasses Debug.  *)
(* Set Typeclasses Unique Instances.
Unset Typeclasses Unique Solutions. *)

(* Existing Instance monadStateT.
Existing Instance monadStateStateT. *)

(* more generic proofs *)

Ltac destructMonads := compute; destruct monadStateStateT; destruct monadStateT.

(* Lemma requireOldM_eval_correct1: forall {S X} (b:bool) (f: StateT S  (option X)) l,
                         b = true ->
                         eval_state (requireOldM b f) l = eval_state f l.
Proof.
 intros. rewrite H. compute. auto.
Qed.

Lemma requireOldM_eval_correct2: forall {S X} (b:bool) (f: StateT S (option X)) l,
                         b = false ->
                         eval_state (requireOldM b f) l = None.
Proof.
 intros. rewrite H. destructMonads. rewrite rununit. auto.
Qed.

Lemma requireOld_eval_correct1: forall {S X} (b:bool) (f: StateT S  X) l,
                         b = true ->
                         eval_state (requireOld b f) l = Some (eval_state f l).
Proof.
 intros. rewrite H. destructMonads.
 rewrite runbind. remember (run X f l). destruct p. rewrite rununit. auto.
Qed.

Lemma requireOld_eval_correct2: forall {S X} (b:bool) (f: StateT S  X) l,
                         b = false ->
                         eval_state (requireOld  b f) l = None.
Proof.
 intros. rewrite H. destructMonads. rewrite rununit. auto.
Qed.

Lemma requireOld_exec_correct1: forall {S X} (b:bool) (f: StateT S  X) l,
                         b = true ->
                         exec_state (requireOld b f) l = exec_state f l.
Proof.
 intros. rewrite H. destructMonads.
 rewrite runbind. remember (run X f l). destruct p. rewrite rununit. auto.
Qed.

Lemma requireOld_exec_correct2: forall {S X} (b:bool) (f: StateT S X) l,
                         b = false ->
                         exec_state (requireOld b f) l = l.
Proof.
 intros. rewrite H. destructMonads. rewrite rununit. auto.
Qed.
*)
(* Check eval_state (do _ ← require _ _ ??; _) _. *)
Lemma requireE_eval_correct1: forall {S X E} (b:bool) (e: E) (f: StateT S (ErrorValue X E) ) l,
                         b = true ->
                         eval_state (do _ ← require b e ??; f) l = eval_state f l.
Proof.
 intros. rewrite H. unfold require. simpl. rewrite left_unit. simpl. auto.
Qed.

Lemma requireE_eval_correct2: forall {S X E} (b:bool) (e: E) (f: StateT S (ErrorValue X E)) l,
                         b = false ->
                         eval_state (do _ ← require b e ??; f) l = Error e.
Proof.
 intros. rewrite H. unfold require. simpl. rewrite left_unit. simpl. rewrite eval_unit. auto.
Qed.

Lemma requireE_eval_correct3: forall {S X E} (b:bool) (e x: E) (f: StateT S (ErrorValue X E)) l,
                         (b = false /\ (x = e))  \/ (b = true /\ eval_state f l = Error x) <->
                         eval_state (do _ ← require b e ??; f) l = Error x.
Proof.
 intros. split. intros. inversion H. rewrite requireE_eval_correct2.
 inversion H0. congruence. inversion H0. congruence.
 inversion H0. rewrite requireE_eval_correct1. auto. auto.
 intros. destruct b. right. split. auto. rewrite requireE_eval_correct1 in H. auto.
 auto. left. rewrite requireE_eval_correct2 in H. split. auto. inversion H.  auto.
 auto.
Qed.

Lemma requireE_eval_correct4: forall {S X E} (b:bool) e (v: X) (f: StateT S (ErrorValue X E)) l,
                         (b = true /\ eval_state f l = Value v) <->
                         eval_state (do _ ← require b e ??; f) l = Value v.
Proof.
 intros. split. intros. inversion H.
 rewrite requireE_eval_correct1; auto.
 intros. split. destruct b. auto.
 rewrite requireE_eval_correct2 in H. inversion H. auto.
 destruct b. rewrite requireE_eval_correct1 in H. auto. auto.
 rewrite requireE_eval_correct2 in H. inversion H. auto.
Qed.

Lemma require_eval_correct1: forall {S X E} (b:bool) (e: E) (f: StateT S X) l,
                         b = true ->
                         eval_state (do _ ← require b e ?; f) l = Value (eval_state f l).
Proof.
 intros. rewrite H. unfold require. simpl. rewrite left_unit. simpl.
 rewrite eval_bind2. rewrite eval_unit.
 auto.
Qed.

Lemma require_eval_correct2: forall {S X E} (b:bool) (e: E) (f: StateT S X) l,
                         b = false <->
                         eval_state (do _ ← require b e ?; f) l = Error e.
Proof.
 intros. split; intros. rewrite H.
 unfold require. simpl. rewrite left_unit. simpl. rewrite eval_unit. auto.
 intros. destruct b. rewrite require_eval_correct1 in H. inversion H.
 auto. auto.
Qed.

Lemma require_eval_correct2': forall {S X E} (b:bool) (x e: E) (f: StateT S X) l,
                         b = false /\ x = e <->
                         eval_state (do _ ← require b e ?; f) l = Error x .
Proof.
 intros. split; intros. inversion_clear H.
 rewrite (require_eval_correct2 (S:=S) (X:=X) (E:=E)) in H0.
 rewrite H0. congruence. remember b. destruct b0.
 rewrite require_eval_correct1 in H.
 discriminate. auto. split. auto.
 rewrite Heqb0 in H. symmetry in Heqb0.
 rewrite (require_eval_correct2 (S:=S) (X:=X) (E:=E)) in Heqb0.
 rewrite H in Heqb0. congruence.
Qed.

Lemma require_exec_correct1: forall {S X E} (b:bool) (e: E) (f: StateT S X) l,
                            b = true ->
                            exec_state (do _ ← require b e ?; f) l = exec_state f l.
Proof.
 intros. rewrite H.
 unfold require. simpl. rewrite left_unit. simpl.
  rewrite exec_bind. rewrite exec_unit. auto.
Qed.

Lemma require_exec_correct2: forall {S X E} (b:bool) (e: E) (f: StateT S X) l,
                         b = false ->
                         exec_state (do _ ← require b e ?; f) l = l.
Proof.
 intros. rewrite H.
 unfold require. simpl. rewrite left_unit. simpl. rewrite exec_unit. auto.
Qed.

Lemma requireE_exec_correct1: forall {S X E} (b:bool) (e: E) (f: StateT S (ErrorValue X E)) (l:S),
                         b = false ->
                         exec_state (do _ ← require b e ??; f) l = l.
Proof.
 intros. rewrite H.
 unfold require. simpl. rewrite left_unit. simpl. rewrite exec_unit. auto.
Qed.

Lemma requireE_exec_correct2: forall {S X E} (b:bool) (e: E) (f: StateT S (ErrorValue X E)) l,
                            b = true ->
                            exec_state (do _ ← require b e ??; f) l = exec_state f l.
Proof.
 intros. rewrite H.
 unfold require. simpl. rewrite left_unit. simpl. auto.
Qed.

Lemma errorBindCorrect1: forall (S X Y E: Type) (f:StateT S (ErrorValue X E))
                                      (g: X -> StateT S Y) l n,
eval_state f l = Error n ->
eval_state (do x ← f ?; g x) l = Error n.
Proof.
 intros. rewrite eval_bind2.
 rewrite H. simpl.
 rewrite eval_unit. auto.
Qed.

Lemma errorBindCorrect2: forall S X Y E (f:StateT S (ErrorValue X E))
                                (g: X -> StateT S Y) l x,
eval_state f l = Value x ->
eval_state (do x ← f ?; g x) l = Value (eval_state (g x) (exec_state f l)).
Proof.
 intros. rewrite eval_bind2.
 rewrite H. simpl.
 rewrite eval_bind2. rewrite eval_unit. auto.
Qed.

Lemma errorBindCorrect3: forall S X Y E (f:StateT S (ErrorValue X E))
                                      (g: X -> StateT S (ErrorValue Y E)) l n,
eval_state f l = Error n ->
eval_state (do x ← f ??; g x) l = Error n.
Proof.
 intros. rewrite eval_bind2.
 rewrite H. simpl. rewrite eval_unit. auto.
Qed.

Lemma errorBindCorrect4: forall S X Y E (f:StateT S (ErrorValue X E))
                                (g: X -> StateT S (ErrorValue Y E)) l x,
eval_state f l = Value x ->
eval_state (do x ← f ??; g x) l = eval_state (g x) (exec_state f l).
Proof.
 intros. rewrite eval_bind2.
 rewrite H. simpl. auto.
Qed.

Lemma errorBindCorrect5: forall S X Y E (f:StateT S (ErrorValue X E))
                                (g: X -> StateT S (ErrorValue Y E)) l x,
eval_state f l = Value x ->
exec_state (do x ← f ??; g x) l = exec_state (g x) (exec_state f l).
Proof.
 intros. rewrite exec_bind.
 rewrite H. simpl. auto.
Qed.

Lemma errorBindCorrect3': forall S X Y E (f:StateT S (ErrorValue X E))
                                      (g: X -> StateT S (ErrorValue Y E)) l n,
eval_state (do x ← f ??; g x) l = Error n <->
(eval_state f l = Error n) \/
(exists v, eval_state f l = Value v /\ eval_state (g v) (exec_state f l) = Error n).
Proof.
 split. intros.
rewrite eval_bind2 in H.
 remember (eval_state f l).
  destruct e. unfold xErrorMapDefaultF in H.
 unfold errorMapDefaultF in H. simpl in H. rewrite eval_unit in H.
  inversion H. left. auto.
 right.  exists x. split; auto.
 intros.
 inversion_clear H. apply errorBindCorrect3. apply H0.
 inversion_clear H0. inversion_clear H.
 rewrite <- H1.
 apply errorBindCorrect4. apply H0.
Qed.

(*TODO: define notModifedState by equalRelativeState*)
Definition notModifiedState {S X Y} (f: StateT S X) (m: StateT S Y) := forall s,
                        eval_state f s = eval_state f (exec_state m s).

Lemma notModifiedState_correct: forall {S X Y} (f: StateT S X) (m: StateT S Y) s,
                 notModifiedState f m ->
                 eval_state f s = eval_state f (exec_state m s).
Proof. auto. Qed.

Definition equalRelativeState {S X Y1 Y2} (f: StateT S X) (m1: StateT S Y1) (m2: StateT S Y2) := forall s,
                        eval_state f (exec_state m1 s) = eval_state f (exec_state m2 s).

Definition commuteRelativeState {S X Y1 Y2} (f: StateT S X) (m1: StateT S Y1) (m2: StateT S Y2) := forall s,
                        eval_state f (exec_state (m1 >> m2)  s) = eval_state f (exec_state (m2 >> m1) s).

Lemma equalRelativeState_correct: forall {S X Y1 Y2} (f: StateT S X) (m1: StateT S Y1) (m2: StateT S Y2) s,
                 equalRelativeState f m1 m2 ->
                 eval_state f (exec_state m1 s) = eval_state f (exec_state m2 s).
Proof. auto. Qed.

Lemma equalRelativeState_sym: forall {S X Y1 Y2} (f: StateT S X) (m1: StateT S Y1) (m2: StateT S Y2),
                 equalRelativeState f m1 m2 -> equalRelativeState f m2 m1.
Proof.
 intros. unfold equalRelativeState. unfold equalRelativeState in H.
 intros. auto.
 Qed.

Lemma equalStatesRight: forall {S  X Y Y1} (f: StateT S X)
                       (m1: StateT S Y1) (m: StateT S Y),
                       notModifiedState f m ->
                       equalRelativeState f (m1 >> m) m1.
Proof.
 intros. unfold equalRelativeState.
 intros. rewrite ?exec_bind'.
 unfold  notModifiedState in H.
 rewrite <- H. auto.
Qed.

Lemma equalStatesLeft: forall {S  X Y Y1} (f: StateT S X)
                       (m1: StateT S Y1) (m: StateT S Y) s,
                       equalRelativeState f m1 (m >> m1) ->
                        eval_state f (exec_state m1 s) =
                        eval_state f (exec_state m1 (exec_state m s)).
Proof.
 intros. rewrite (equalRelativeState_correct f  m1 (m>>m1)).
 rewrite exec_bind'. auto. apply H.
 Qed.

Lemma equalRelativeState_notModified: forall {S  X Y} (f: StateT S X) (m: StateT S Y),
                         notModifiedState f m <-> equalRelativeState f get m.
Proof.
 intros. split. unfold notModifiedState. unfold equalRelativeState.
 intros. unfold exec_state. rewrite runget.
 simpl. rewrite H. unfold exec_state. auto.
 unfold notModifiedState. unfold equalRelativeState.
 intros. unfold exec_state in H. unfold exec_state.
 rewrite <- H. rewrite runget. simpl. auto.
Qed.

Lemma notModifiedLeft: forall {S  X Y} (f: StateT S X)
                       (m1: StateT S Y) (m2: StateT S Y) s,
               equalRelativeState f m2 (m1 >> m2) ->
               eval_state f (exec_state (m1 >> m2) s) = eval_state f (exec_state m2 s).
Proof.
  intros. rewrite exec_bind'.
  unfold equalRelativeState in H.
  remember (H s). clear Heqe.
  rewrite exec_bind' in e.  auto.
  Qed.
(*
Lemma requireOldNotModifiedState {S  X} (f: StateT S X) (m: StateT S True) (b:bool):
                              notModifiedState f m ->
                              notModifiedState f (requireOld b m).
Proof.
 intros. destruct b. unfold notModifiedState. intros.
 rewrite requireOld_exec_correct1. apply H. auto.
 unfold notModifiedState. intros.
 rewrite requireOld_exec_correct2. auto. auto.
 Qed.
*)
Lemma notModifiedRequire {S E X} (f: StateT S X) (m: StateT S True) (b:bool) (e: E):
                              notModifiedState f m ->
                              notModifiedState f (do _ ← require b e ?; m).
Proof.
 intros. destruct b. unfold notModifiedState. intros.
 rewrite require_exec_correct1. apply H. auto.
 unfold notModifiedState. intros.
 rewrite require_exec_correct2. auto. auto.
 Qed.

Lemma notModifiedBind_: forall {S  X Y1 Y2} (f: StateT S X) (m1: StateT S Y1) (m2: StateT S Y2),
                       notModifiedState f m1 ->
                       notModifiedState f m2 ->
                       notModifiedState f (m1 >> m2).
Proof.
 intros. unfold notModifiedState in H.
 unfold notModifiedState in H0. unfold notModifiedState.
 intros. rewrite exec_bind'. rewrite <-  H0.
 auto.
Qed.

Lemma notModifiedBind: forall {S  X Y1 Y2} (f: StateT S X) (m1: StateT S Y1) (m2: Y1 -> StateT S Y2),
                       notModifiedState f m1 ->
                       (forall y, notModifiedState f (m2 y)) ->
                       notModifiedState f (m1 >>= m2).
Proof.
 intros. unfold notModifiedState in H.
 unfold notModifiedState in H0. unfold notModifiedState.
 intros. rewrite exec_bind. rewrite <-  H0.
 auto.
Qed.

Lemma equalRelativeBind: forall {S  X Y1 Y2 U T} (f: StateT S X)
                                (m1: StateT S Y1) (m2: Y1 -> StateT S Y2) (h: StateT S T) (g: StateT S U),
                       equalRelativeState f h g ->
                       equalRelativeState f (m1 >> h) g ->
                       (forall y, equalRelativeState f (m2 y >> h) g) ->
                       equalRelativeState f ((m1 >>= m2) >> h) g.
Proof.
 intros.
 unfold equalRelativeState in H.
 unfold equalRelativeState in H0.
 unfold equalRelativeState.
 unfold equalRelativeState in H1. intros.
 rewrite exec_bind'. rewrite exec_bind.
 remember (H1 (eval_state m1 s) (exec_state m1 s)).
 clear Heqe. rewrite exec_bind' in e.
 rewrite e. rewrite <- ?H.
 rewrite <- exec_bind'. rewrite H0.
 rewrite H. auto.
 Qed.

Lemma equalRelativeBind_: forall {S  X Y1 Y2 U T} (f: StateT S X)
                                (m1: StateT S Y1) (m2:StateT S Y2) (h: StateT S T) (g: StateT S U),
                       equalRelativeState f h g ->
                       equalRelativeState f (m1 >> h) g ->
                       equalRelativeState f (m2 >> h) g ->
                       equalRelativeState f (m1 >> m2 >> h) g.
Proof.
 intros. unfold bind_. apply equalRelativeBind.
 auto. auto. intros. auto.
Qed.

(*FIXME: find the less weak conditions*)
Lemma equalRelativeBind_': forall {S  X Y1 Y2 T} (f: StateT S X)
                                (m1: StateT S Y1) (m2:StateT S Y2) (h: Y2 -> StateT S T),
                       notModifiedState m2 m1 ->
                       commuteRelativeState get m1 m2 ->
                       equalRelativeState f (m1 >> m2 >>= h) (m2 >>= (fun x => m1 >> h x)).
Proof.
 intros.
 intros. unfold commuteRelativeState in H.
 unfold equalRelativeState. intros. unfold bind_.
 rewrite ?exec_bind. rewrite eval_bind2.
 rewrite <- ?exec_bind'. rewrite <- H.
 rewrite <- ?bind_assoc_.
 rewrite exec_bind'. symmetry. rewrite exec_bind'.
 unfold commuteRelativeState in H0.
 remember (H0 s). unfold eval_state in e. clear Heqe.
 rewrite ?runget in e. simpl in e. rewrite e. auto.
Qed.

Lemma notModifiedFold: forall {S  X A B}
                              (f: StateT S X) (m: B -> StateT S A) (l:list B) (a0:StateT S A),
                       notModifiedState f a0 ->
                       (forall (x:B), notModifiedState f (m x)) ->
                       notModifiedState f (fold_left (fun a i => a >> m i) l a0).
Proof.
 intros. generalize dependent a0. induction l;intros. simpl. auto.
 simpl. apply IHl. apply notModifiedBind_. auto. auto.
 Qed.

Lemma notModifiedUnit: forall {S  X A}
                               (f: StateT S X) (a: A),
                       notModifiedState f (return! a).
Proof.
 intros. destructMonads.
 intros. rewrite rununit. auto.
Qed.

Lemma notModifiedFold2: forall {S  X A B}
                               (f: StateT S X) (m: (bool*A)%type -> B -> StateT S (bool*A)%type)
                               (l:list B) (a0: StateT S (bool * A)%type),
                       notModifiedState f a0 ->
                       (forall p (x:B), notModifiedState f (m p x)) ->
                       notModifiedState f (fold_left (fun (a: StateT S (bool * A)%type) (i:B) => do p ← a;
                                                        if (fst p:bool) then return! p else (m p i)) l a0).
Proof.
 intros. generalize dependent a0. induction l;intros. simpl. auto.
 simpl. apply IHl. apply notModifiedBind. auto. intros.
 destruct (fst y). apply notModifiedUnit. auto.
 Qed.

Lemma notModifiedEFoldLeftBreakable: forall {S X A B}
                               (f: StateT S  X) (m: B -> StateT S  (bool*A)%type)
                               (l:list B) (a0: A),
                       (forall (x:B), notModifiedState f (m x)) ->
                       notModifiedState f (listEFoldLeftBreakableM m l a0).
Proof.
 intros. unfold listEFoldLeftBreakableM.
 apply notModifiedFold2. apply notModifiedUnit.
 auto.
Qed.

Lemma notModifiedFold': forall {S  X A B}
                              (f: StateT S X) (m: B -> StateT S A) (l:list B) (a0:StateT S A),
                       notModifiedState f a0 ->
                       (forall (x:B), notModifiedState f (a0 >> m x)) ->
                       (forall (x y:B), notModifiedState f (m x >> m y)) ->
                       notModifiedState f (fold_left (fun a i => a >> m i) l a0).
Proof.
 intros. generalize dependent a0. induction l; intros. simpl. auto.
 simpl. apply IHl. auto. intros. rewrite bind_assoc_.
 apply notModifiedBind_. auto. auto.
 Qed.

Lemma notModifiedFold'': forall {S  X A B}
                              (f: StateT S X) (m: B -> StateT S A) (l:list B) (a0:StateT S A),
                       notModifiedState f a0 ->
                       (forall (x:B), notModifiedState f (a0 >> m x)) ->
                       (forall (x y:B) s, eval_state f (exec_state (m x >> m y) s) = eval_state f (exec_state (m x) s)\/
                                          eval_state f (exec_state (m x >> m y) s) = eval_state f (exec_state (m y) s)) ->
                       notModifiedState f (fold_left (fun a i => a >> m i) l a0).
Proof.
 intros. generalize dependent a0. induction l; intros. simpl. auto.
 simpl. apply IHl. auto. intros.
 rewrite bind_assoc_. unfold notModifiedState. intros.
 rewrite exec_bind'.
 remember (H1 a x (exec_state a0 s)). clear Heqo. clear H1.
 inversion o. rewrite H1. unfold notModifiedState in H0.
 rewrite H0 with (x:=a). rewrite exec_bind'. auto.
 rewrite H1. unfold notModifiedState in H0.
 rewrite H0 with (x:=x). rewrite exec_bind'. auto.
Qed.

Lemma equalRelativeFold: forall {S  X Y T A B}
                              (f: StateT S X) (g: StateT S Y) (h: StateT S T) (m: B -> StateT S A) (l:list B) (a0:StateT S A),
                       equalRelativeState f h g ->
                       equalRelativeState f (a0 >> h) g ->
                       (forall (x:B), equalRelativeState f (m x >> h) g) ->
                       equalRelativeState f ((fold_left (fun a i => a >> m i) l a0) >> h) g.
Proof.
 intros. generalize dependent a0. induction l;intros. simpl. auto.
 simpl. apply IHl. apply equalRelativeBind_. auto. auto. auto.
 Qed.

Lemma foldStateToAccumulator: forall {S  X Y A B}
                              (f: StateT S X) (m: B -> StateT S A) (l:list B) (a0:StateT S A) (a: StateT S Y) (s:S),
                      eval_state f (exec_state (fold_left (fun a i => a >> m i) l a0) (exec_state a s)) =
                      eval_state f (exec_state (fold_left (fun a i => a >> m i) l (a >> a0)) s).
Proof.
 intros. rewrite <- exec_bind'.
 generalize dependent a0. induction l; intros. simpl. auto.
 simpl. rewrite IHl. rewrite bind_assoc_. auto.
Qed.

Lemma notModifiedFoldWithProp:
                      forall {S X A B}
                      (f: StateT S X) (m: B -> StateT S A) (l:list B)
                      (a0: StateT S A) (P: StateT S Prop),
                      notModifiedState f a0 ->
                      (forall s i, (eval_state P s: Prop) -> (eval_state P (exec_state (m i) s)): Prop) ->
                      (forall s, eval_state P (exec_state a0 s) : Prop) ->
                      (forall s i, (eval_state P s: Prop) ->
                      eval_state f (exec_state (m i) s) = eval_state f s) ->
                       notModifiedState f (fold_left (fun a i => a >> m i) l a0).
Proof.
 intros. generalize dependent a0. induction l; intros.

 simpl. auto.
 simpl. apply IHl.
 unfold notModifiedState.
 intros. rewrite exec_bind'.
 rewrite H2. auto. auto.
 intros. rewrite exec_bind'.
 apply H0. auto.
Qed.

(* a > 0 -> a + 1 > 0
a >? 0 = true  -> a + 1 >?0 = true   *)

Lemma notModifiedFoldWithBool:
                      forall {S X A B}
                      (f: StateT S X) (m: B -> StateT S A) (l:list B)
                      (a0: StateT S A) (P: StateT S bool),
                      notModifiedState f a0 ->
                      (forall s i, (eval_state P s = true) -> (eval_state P (exec_state (m i) s)) = true) ->
                      (forall s, eval_state P (exec_state a0 s) = true) ->
                      (forall s i, (eval_state P s = true) ->
                      eval_state f (exec_state (m i) s) = eval_state f s) ->
                       notModifiedState f (fold_left (fun a i => a >> m i) l a0).
Proof.
 intros. generalize dependent a0. induction l; intros.

 simpl. auto.
 simpl. apply IHl.
 unfold notModifiedState.
 intros. rewrite exec_bind'.
 rewrite H2. auto. auto.
 intros. rewrite exec_bind'.
 apply H0. auto.
Qed.

Lemma notModifiedFoldWithBoolWeak:
                      forall {S X A B}
                      (f: StateT S X) (m: B -> StateT S A) (l:list B)
                      (a0: StateT S A) (P: StateT S bool) s,
                      eval_state f (exec_state a0 s) =  eval_state f s ->
                      eval_state P (exec_state a0 s) =  true ->
                      (forall s i, (eval_state P s = true) -> (eval_state P (exec_state (m i) s)) = true) ->
                      (forall s i, (eval_state P s = true) ->
                      eval_state f (exec_state (m i) s) = eval_state f s) ->
                       eval_state f (exec_state (fold_left (fun a i => a >> m i) l a0) s) = eval_state f s.
Proof.
 intros. generalize dependent a0. induction l; intros.

 simpl. apply H.
 simpl. apply IHl.
 rewrite exec_bind'.
 rewrite H2. apply H. apply H0. rewrite exec_bind'.
 rewrite H1. auto. apply H0.
Qed.

Lemma foldExecConj: forall {S X K} (s: S) (a0: StateT S X)
                           (f: K -> StateT S X) (l: list K) (x: K),
exec_state (fold_left (fun a0 (i : K) => a0 >> f i) (l ++ [ x ]) a0) s =
exec_state (f x)
           (exec_state (fold_left (fun a0  (i : K) => a0 >> f i) l a0) s).
Proof.
 intros. generalize dependent a0.
 induction l; intros.
 simpl. rewrite exec_bind'.
 auto.
 simpl. rewrite IHl. auto.
Qed.

Lemma foldExecEq: forall {S X K} (s: S) (a0: StateT S X)
                           (f g: K -> StateT S X) (l: list K),
(forall i, In i l -> f i = g i) ->
exec_state (fold_left (fun a0 (i : K) => a0 >> f i) l a0) s =
exec_state (fold_left (fun a0  (i : K) => a0 >> g i) l a0) s.
Proof.
 intros. generalize dependent a0. induction l; intros.
 simpl. auto.
 simpl. rewrite <- IHl.
 replace (g a) with (f a). auto.
 apply H. constructor. auto.
 intros. apply H. simpl. right. auto.
Qed.

Lemma foldExecBreakableEq: forall {S X K} (s: S) (a0: StateT S X)
                           (f g: X -> K -> StateT S X) (l: list K),
(forall p i, In i l -> f p i = g p i) ->
exec_state (fold_left (fun a0 (i : K) => do p ← a0; f p i) l a0) s =
exec_state (fold_left (fun a0  (i : K) => do p ← a0; g p i) l a0) s.
Proof.
 intros. generalize dependent a0. induction l; intros.
 simpl. auto.
 simpl. rewrite <- IHl.
 replace (do p ← a0; g p a) with (do p ← a0; f p a). auto.
 apply bind_eq. extensionality p.
 apply H. constructor. auto. intros.
 apply H. simpl. right. auto.
Qed.

Lemma foldEvalBreakableEq: forall {S X K} (s: S) (a0: StateT S X)
                           (f g: X -> K -> StateT S X) (l: list K),
(forall p i, In i l -> f p i = g p i) ->
eval_state (fold_left (fun a0 (i : K) => do p ← a0; f p i) l a0) s =
eval_state (fold_left (fun a0 (i : K) => do p ← a0; g p i) l a0) s.
Proof.
 intros. generalize dependent a0. induction l; intros.
 simpl. auto.
 simpl. rewrite <- IHl.
 replace (do p ← a0; g p a) with (do p ← a0; f p a). auto.
 apply bind_eq. extensionality p.
 apply H. constructor. auto. intros.
 apply H. simpl. right. auto.
Qed.

Lemma foldRunBreakableEq: forall {S X K} (s: S) (a0: StateT S X)
                           (f g: X -> K -> StateT S X) (l: list K),
(forall p i, In i l -> f p i = g p i) ->
run (fold_left (fun a0 (i : K) => do p ← a0; f p i) l a0) s =
run (fold_left (fun a0  (i : K) => do p ← a0; g p i) l a0) s.
Proof.
intros.
assert (forall X (f: StateT S X) (l: S), run f l = (eval_state f l, exec_state f l)).
intros. unfold exec_state. unfold eval_state.
destruct (run f0 l0). auto.
rewrite 2H0. rewrite (foldEvalBreakableEq s a0 f g l).
rewrite (foldExecBreakableEq s a0 f g l). auto.
auto. auto.
Qed.

Lemma fold_left_cons: forall A B (f: A -> B -> A) x l a,
fold_left f (x::l) a = fold_left f l (f a x).
Proof.
 intros. simpl. auto.
Qed.

Lemma foldBreakableExec: forall S X Y y a0 (l:S) f,
exec_state
  (fold_left
     (fun (a : StateT S X) (y0 : Y) => do p ← a; f p y0) y a0) l =
exec_state
  (a0 >> fold_left
     (fun (a : StateT S X) (y0 : Y) => do p ← a; f p y0) y (return! (eval_state a0 l))) l.
Proof.
 intros. generalize dependent a0.
 generalize dependent l.
 induction y; intros.
 Opaque unit bind bind_. simpl.
 rewrite exec_bind'. rewrite exec_unit. auto.
 rewrite 2fold_left_cons.
 rewrite IHy. symmetry. rewrite exec_bind'.
 rewrite IHy. rewrite ?exec_bind'.
 rewrite eval_bind2. rewrite eval_unit.
 rewrite exec_unit. rewrite exec_bind.
 rewrite eval_unit. rewrite exec_unit.
 rewrite eval_bind2. rewrite exec_bind.
 auto.
 Transparent unit bind bind_.
Qed.

Lemma foldBreakableEval: forall S X Y y a0 (l:S) f,
eval_state
  (fold_left
     (fun (a : StateT S X) (y0 : Y) => do p ← a; f p y0) y a0) l =
eval_state
  (a0 >> fold_left
     (fun (a : StateT S X) (y0 : Y) => do p ← a; f p y0) y (return! (eval_state a0 l))) l.
Proof.
 intros. generalize dependent a0.
 generalize dependent l.
 induction y; intros.
 Opaque unit bind bind_. simpl.
 rewrite eval_bind. rewrite eval_unit. auto.
 rewrite 2fold_left_cons.
 rewrite IHy. symmetry. rewrite eval_bind.
 rewrite IHy. rewrite ?eval_bind.
 rewrite eval_bind2. rewrite eval_unit.
 rewrite exec_unit. rewrite exec_bind.
 rewrite eval_unit. rewrite exec_unit.
 rewrite eval_bind2. rewrite exec_bind.
 auto.
 Transparent unit bind bind_.
Qed.

Lemma foldBreakableRun: forall S X Y y a0 (l:S) f,
run
  (fold_left
     (fun (a : StateT S X) (y0 : Y) => do p ← a; f p y0) y a0) l =
run
  (a0 >> fold_left
     (fun (a : StateT S X) (y0 : Y) => do p ← a; f p y0) y (return! (eval_state a0 l))) l.
Proof.
intros.
 assert (forall X (f: StateT S X) (l: S), run f l = (eval_state f l, exec_state f l)).
 intros. unfold exec_state. unfold eval_state.
 destruct (run f0 l0). auto.
 rewrite 2H. rewrite foldBreakableEval.
 rewrite foldBreakableExec. auto.
 Qed.

Lemma foldBreakableExecConj: forall {S X K} (a0: StateT S X)
                           (f: X -> K -> StateT S X) (s: list K) (x: K) (l:S),
exec_state
  (fold_left
     (fun (a : StateT S X) (y0 : K) => do p ← a; f p y0) (s ++ [x]) a0) l  =

exec_state
  (do p ← fold_left (fun (a : StateT S X) (y0 : K) => do p ← a; f p y0) s a0;
   f p x) l.

Proof.
 intros. generalize dependent a0.
 induction s; intros.
 simpl. rewrite ?exec_bind. auto.
 simpl. rewrite IHs. auto.
Qed.

Lemma foldBreakableEvalConj: forall {S X K} (a0: StateT S X)
                           (f: X -> K -> StateT S X) (s: list K) (x: K) (l:S),
eval_state
  (fold_left
     (fun (a : StateT S X) (y0 : K) => do p ← a; f p y0) (s ++ [x]) a0) l  =

eval_state
  (do p ← fold_left (fun (a : StateT S X) (y0 : K) => do p ← a; f p y0) s a0;
   f p x) l.

Proof.
 intros. generalize dependent a0.
 induction s; intros.
 simpl. rewrite ?exec_bind. auto.
 simpl. rewrite IHs. auto.
Qed.

Lemma foldBreakableRunConj: forall {S X K} (a0: StateT S X)
                           (f: X -> K -> StateT S X) (s: list K) (x: K) (l:S),
run (fold_left
        (fun (a : StateT S X) (y0 : K) => do p ← a; f p y0) (s ++ [x]) a0) l  =
run
(do p ← fold_left (fun (a : StateT S X) (y0 : K) => do p ← a; f p y0) s a0;
 f p x) l.
Proof.
 intros.
 assert (forall X (f: StateT S X) (l: S), run f l = (eval_state f l, exec_state f l)).
 intros. unfold exec_state. unfold eval_state.
 destruct (run f0 l0). auto.
 rewrite 2H. rewrite foldBreakableEvalConj.
 rewrite foldBreakableExecConj. auto.
 Qed.

(* Lemma foldExec2: forall S X Y y a0 (l:S) (b: X -> bool) f,
exec_state
  (fold_left
     (fun (a : StateT S X) (y0 : Y) => do p ← a; if b p then a else f y0) y a0) l =
exec_state
  (a0 >> fold_left
     (fun (a : StateT S X) (y0 : Y) => do p ← a; if b p then a else f y0) y (return! (eval_state a0 l))) l.
Proof.
 intros. generalize dependent a0.
 generalize dependent l.
 induction y; intros.
 Opaque unit bind bind_. simpl.
 rewrite exec_bind'. rewrite exec_unit. auto.
 rewrite 2fold_left_cons.
 rewrite IHy. symmetry. rewrite exec_bind'.
 rewrite IHy. rewrite ?exec_bind'.
 rewrite eval_bind2. rewrite eval_unit.
 rewrite exec_unit. rewrite ifEval.
 rewrite eval_unit. rewrite exec_bind.
 rewrite eval_unit. rewrite exec_unit.
 rewrite ifExec. rewrite exec_unit.
 rewrite eval_bind2. rewrite ifEval.
 rewrite exec_bind. rewrite ifExec.
 rewrite ?H. auto.

 rewrite exec_bind. rewrite eval_unit.
 rewrite exec_unit. destructIf.
 rewrite exec_unit. auto.
 auto.
 Transparent unit bind bind_.
Qed. *)

Lemma foldBreakableBreakExec: forall S X l a y f,
exec_state
  (fold_left
     (fun (mbx : StateT S (bool * True)) (y0 : X) =>
      do p ← mbx;
      if (fst p: bool) then (return! p) else (f y0)) y a) l =
if (fst (eval_state a l): bool) then exec_state a l else
exec_state
  (fold_left
     (fun (mbx : StateT S (bool * True)) (y0 : X) =>
      do p ← mbx;
      if (fst p: bool) then (return! p) else (f y0)) y (return! (false, I))) (exec_state a l).
Proof.
 intros. remember (eval_state a l) as p.
 rewrite foldBreakableExec. rewrite exec_bind'.
 rewrite <- Heqp.
 destruct p. destruct b; unfold fst; destruct t; auto.
 generalize dependent a. induction y; intros.
 simpl. rewrite exec_unit. auto.
 rewrite fold_left_cons. rewrite foldBreakableExec.
 rewrite exec_bind'. rewrite eval_bind2.
 rewrite eval_unit. rewrite eval_unit.
 rewrite exec_bind. rewrite eval_unit.
 rewrite exec_unit. rewrite exec_unit.
 rewrite IHy. auto.
 auto.
Qed.

Lemma foldBreakableBreakEval: forall S X l a y f,
eval_state
  (fold_left
     (fun (mbx : StateT S (bool * True)) (y0 : X) =>
      do p ← mbx;
      if (fst p: bool) then (return! p) else (f y0)) y a) l =
if (fst (eval_state a l): bool) then (true, I) else
eval_state
  (fold_left
     (fun (mbx : StateT S (bool * True)) (y0 : X) =>
      do p ← mbx;
      if (fst p: bool) then (return! p) else (f y0)) y (return! (false, I))) (exec_state a l).
Proof.
 intros. remember (eval_state a l) as p.
 rewrite foldBreakableEval. rewrite eval_bind.
 rewrite <- Heqp.
 destruct p. destruct b; unfold fst; destruct t; auto.
 generalize dependent a. induction y; intros.
 simpl. rewrite eval_unit. auto.
 rewrite fold_left_cons. rewrite foldBreakableEval.
 rewrite eval_bind. rewrite eval_bind2.
 rewrite eval_unit. rewrite eval_unit.
 rewrite exec_bind. rewrite eval_unit.
 rewrite exec_unit. rewrite exec_unit.
 rewrite IHy. auto.
 auto.
Qed.

Lemma foldBreakableBreakRun: forall S X l a y f,
run
  (fold_left
     (fun (mbx : StateT S (bool * True)) (y0 : X) =>
      do p ← mbx;
      if (fst p: bool) then (return! p) else (f y0)) y a) l =
if (fst (eval_state a l): bool) then ((true, I), exec_state a l) else
run
  (fold_left
     (fun (mbx : StateT S (bool * True)) (y0 : X) =>
      do p ← mbx;
      if (fst p: bool) then (return! p) else (f y0)) y (return! (false, I))) (exec_state a l).
Proof.
 intros. rewrite 2run_eval_exec.
 rewrite foldBreakableBreakEval.
 rewrite foldBreakableBreakExec.
 destruct (fst (eval_state a l)); auto.
Qed.

(* Lemma foldExecEq2: forall {S X K} (s1 s2: S) (a0: StateT S (bool*X))
                         (f: K -> StateT S (bool*X)) (l1 l2: list K) (d: K) (t: K->K),
(l2 = List.map t l1) ->
exec_state a0 s1 = s1 ->
exec_state a0 s2 = s2 ->
fst (eval_state a0 s1) = false ->
fst (eval_state a0 s2) = false ->
(forall i, exec_state (f (nth i l1 d)) s1 = exec_state (f (nth i l2 d)) s2 /\
           (fst (eval_state (f (nth i l1 d)) s1) = true <-> fst (eval_state (f (nth i l2 d)) s2) = true)) ->
exec_state (fold_left (fun (a0: StateT S (bool*X)) (i : K) => do p ← a0; if (fst p: bool) then (return! p) else f i) l1 a0) s1 =
exec_state (fold_left (fun (a0: StateT S (bool*X)) (i : K) => do p ← a0; if (fst p: bool) then (return! p) else f i) l2 a0) s2.
Proof.
 intros. generalize dependent a0.
 generalize dependent l2. induction l1; intros.
 simpl in H. rewrite H. simpl. auto.
 simpl in H. rewrite H. simpl.
 rewrite foldExec.
 rewrite exec_bind'.
 rewrite eval_bind2.
 rewrite exec_bind. rewrite H1.

Abort.  *)

Lemma notModifiedEmbed: forall{S T X Y}`{EmbeddedType S T}
                              (f: StateT S X) (m: T -> Y),
                        notModifiedState f (↑ (ε m)).
Proof.
 intros. compute. intros. repeat destructMonads.
 rewrite runbind. rewrite runget.
 rewrite runembed0. rewrite runbind.
 rewrite runput. rewrite rununit. destruct H.
 rewrite injproj. auto.
 Qed.

Lemma equalStateEmbed: forall{S T X Y U W}`{EmbeddedType S T}
                              (f: StateT S X) (m: T -> Y) (h: StateT S U) (g: StateT S W),
                        equalRelativeState f h g ->
                        equalRelativeState f (↑ (ε m) >> h) g.
Proof.
 intros. unfold equalRelativeState in H0. compute in H0.
 repeat destructMonads.
 intros.
 rewrite ?runbind. rewrite runget.
 rewrite runembed0. rewrite runbind.
 rewrite runput. rewrite rununit. destruct H.
 rewrite injproj.  auto.
 Qed.

Lemma notModifiedLifted: forall {S T X Y}`{EmbeddedType S T}
                          (f: T -> X) (m: StateT T Y),
                          notModifiedState (ε f) m ->
                          notModifiedState (↑ (ε f)) (↑ m).
Proof.
 intros. unfold notModifiedState. intros.
 rewrite liftEmbeddedStateExec2.
 rewrite eval_bind. rewrite eval_embed.
 rewrite eval_lift_embed. unfold notModifiedState in H0.
 remember (H0 (projEmbed s)). clear Heqe.
 rewrite ?eval_embed in e. auto.
Qed.

Lemma notModifiedWithMap: forall {S T X Y A B}`{EmbeddedType S T}`{XBoolEquable bool A}`{XDefault B}
                          (f: StateT S X) (g: B -> StateT S Y) (m: T -> listPair A B) (i:A),
                          (forall k, notModifiedState f (g k)) ->
                          notModifiedState f (withEmbeddedMapDefault m i g).
Proof. intros.
  unfold withEmbeddedMapDefault.
  apply notModifiedBind.
  apply notModifiedEmbed. intros.
  apply H2.
  Qed.

Lemma notModifiedWithMap': forall {S T X Y A B}`{EmbeddedType S T}`{XBoolEquable bool A}`{XDefault B}
                          (f: StateT S X) (g: B -> StateT S Y) (m: T -> listPair A B) (i:A) s,
                          (forall k, eval_state f (exec_state (g k) s) = eval_state f s) ->
                          eval_state f (exec_state (withEmbeddedMapDefault m i g) s) = eval_state f s.
Proof.
 intros. unfold withEmbeddedMapDefault.
 rewrite exec_bind. rewrite exec_lift_embed.
 remember (eval_state (↑ (ε m)) s).
 setoid_rewrite <- Heql. apply H2.
Qed.

Lemma equalStatesWithMap: forall {S T X Y U W A B}`{EmbeddedType S T}`{XBoolEquable bool A}`{XDefault B}
                          (f: StateT S X) (g: B -> StateT S Y) (m: T -> listPair A B) (i:A) (h: StateT S U) (r: StateT S W),
                          equalRelativeState f h r ->
                          (forall k, equalRelativeState f (g k >> h) r) ->
                          equalRelativeState f (withEmbeddedMapDefault m i g >> h) r.
Proof.
 intros. unfold withEmbeddedMapDefault.
 apply equalRelativeBind. auto. apply equalStateEmbed. auto.
 intros. apply H3.
 Qed.

Lemma withMapOnExecWeak: forall {S T X Y U A B}`{EmbeddedType S T}`{XBoolEquable bool A}`{XDefault B}
                              (f: StateT S X) (m: T -> listPair A B) (i:A) (s:S) (a: StateT S Y) (g: B -> StateT S U),
                      notModifiedState (↑ (ε m)) a ->
                      eval_state f (exec_state (withEmbeddedMapDefault m i g) (exec_state a s)) =
                      eval_state f (exec_state (withEmbeddedMapDefault m i (fun x => a >> g x)) s).
Proof.
 intros. rewrite <- exec_bind'.
 unfold withEmbeddedMapDefault.
 apply equalRelativeState_correct.
 unfold bind_. rewrite <- bind_assoc2.
 apply equalRelativeBind_' .
 auto. unfold commuteRelativeState.
 intros. rewrite ?exec_bind'.
 unfold exec_state. unfold liftEmbeddedState. rewrite ?runbind.
 rewrite ?runget.
 rewrite ?runembed. rewrite ?injproj.
 rewrite ?runbind'. remember (run a s0). destruct p. simpl.
 rewrite ?runput. rewrite ?rununit. simpl. rewrite <- Heqp. simpl.
 auto.
Qed.

Lemma ifBindCommute: forall {S  X Y} (m: StateT S X) (m1: StateT S Y) (m2: StateT S Y) (b:bool),
                       m >> (if b then m1 else m2) = if b then (m >> m1) else (m >> m2).
Proof.
 intros. destruct b; auto.
Qed.

Lemma notModifiedIf: forall {S  X Y} (f: StateT S X) (m1: StateT S Y) (m2: StateT S Y) (b:bool),
                       notModifiedState f m1 ->
                       notModifiedState f m2 ->
                       notModifiedState f (if b then m1 else m2).
Proof.
 intros. unfold notModifiedState in H.
 unfold notModifiedState in H0. unfold notModifiedState.
 intros. destruct b; auto.
Qed.

Lemma notModifiedIf': forall {S  X Y} (f: StateT S X) (m1: StateT S Y) (m2: StateT S Y) (b:bool) s,
                       eval_state f (exec_state m1 s) = eval_state f s ->
                       eval_state f (exec_state m2 s) = eval_state f s ->
                       eval_state f (exec_state (if b then m1 else m2) s) = eval_state f s.
Proof.
 intros. destruct b; auto.
Qed.

Lemma notModifiedBreakBind_: forall {S  X}
                       (f: StateT S X) (m1 m2: StateT S (bool*True)%type),
                       notModifiedState f m1 ->
                       notModifiedState f m2 ->
                       notModifiedState f (break_bind m1 m2).
Proof.
 intros. unfold notModifiedState in H.
 unfold notModifiedState in H0. unfold notModifiedState.
 intros. unfold break_bind.
 rewrite exec_bind. simpl.
 rewrite <- notModifiedIf. auto. auto. auto.
Qed.

Lemma equalRelativeIf: forall {S  X Y T U} (f: StateT S X)
                       (m1: StateT S Y) (m2: StateT S Y) (g:StateT S T) (h: StateT S U) (b:bool),
                       equalRelativeState f (m1 >> h) g ->
                       equalRelativeState f (m2 >> h) g ->
                       equalRelativeState f ((if b then (m1) else (m2)) >> h) g.
Proof.
 intros. destruct b; auto.
 Qed.

Lemma ifExec: forall {S X}
                     (m1: StateT S X) (m2: StateT S X)
                     (s:S) (b:bool),
              exec_state (if b then m1 else m2) s =
              if b then (exec_state m1 s) else (exec_state m2 s).
Proof.
 intros. destruct b; auto.
Qed.

Lemma ifEval: forall {S X}
                     (m1: StateT S X) (m2: StateT S X)
                     (s:S) (b:bool),
              eval_state (if b then m1 else m2) s =
              if b then (eval_state m1 s) else (eval_state m2 s).
Proof.
 intros. destruct b; auto.
Qed.
(*
Lemma modifyMapCorrect: forall {S  X}
                        (f: S -> listPair Z X) (l:S) (x:X) (n:Z) (i:listPair Z X -> S -> S),
                        (forall x l, f (i x l) = x) ->
       eval_state (do m ← ε f;
                   return! hmapLookup Z.eqb n m)
       (exec_state (modifyXHMap1 f i n x) l) = Some x.
Proof.
 intros. unfold modifyXHMap1.
 unfold hmapInsert.
 Opaque hmapIsMember get put run bind bind_ embed_fun unit modify exec_state.
 rewrite exec_bind.
 rewrite eval_bind2. unfold eval_state. rewrite rununit.
 rewrite runembed.
 simpl fst.
 rewrite exec_bind'. rewrite exec_unit.
 Transparent exec_state. unfold exec_state. rewrite runembed. simpl.
 Transparent modify. unfold modify. unfold compose.
 rewrite getput. rewrite runbind. rewrite runembed.
 rewrite runput. simpl.
 Transparent get put run bind bind_ embed_fun unit modify exec_state.
 rewrite H.
 Opaque hmapLookup hmapIsMember adjustListPair Z.eqb. compute.
 apply modifyMapCorrect_helper. unfold boolEquivalence. intros.
 apply intBoolEquivalence.  intros. apply zeqb_refl.
 Transparent hmapLookup hmapIsMember adjustListPair Z.eqb.
Qed.

Lemma modifyMapCorrect': forall {S T X}`{EmbeddedType T S}
                        (f: S -> listPair Z X) (l:T) (x:X) (n:Z) (i:listPair Z X -> S -> S),
                        (forall x l, f (i x l) = x) ->
       eval_state (do m ← ↑ (ε f);
                   return! hmapLookup Z.eqb n m)
       (exec_state (↑ (modifyXHMap1 f i n x)) l) = Some x.
Proof.
 intros. rewrite liftEmbeddedStateBind.
 rewrite liftEmbeddedStateExec. rewrite  eval_bind.
 rewrite eval_embed_bind. apply modifyMapCorrect.
 auto.
Qed.

Lemma modifyMapDefaultCorrect': forall {S T X}`{EmbeddedType T S}
                        (f: S -> listPair Z X) (l:T) (x:X) (n:Z) (i:listPair Z X -> S -> S) d,
                        (forall x l, f (i x l) = x) ->
       eval_state (do m ← ↑ (ε f);
                   return! hmapFindWithDefault d Z.eqb n m)
       (exec_state (↑ (modifyXHMap1 f i n x)) l) = x.
Proof.
 intros. unfold hmapFindWithDefault.
 rewrite eval_bind2. rewrite eval_unit.
 remember (modifyMapCorrect' f l x n i H0). clear Heqe.
 rewrite eval_bind2 in e. rewrite eval_unit in e.
 setoid_rewrite e. auto.
Qed.
*)

Lemma modifyMapCorrect2: forall {S  X}
                        (f: S -> listPair Z X) (l:S) (x:X) (n k:Z) (i:listPair Z X -> S -> S),
                        (forall x l, f (i x l) = x) ->
       n <> k ->
       eval_state (do m ← ε f;
                   return! hmapLookup Z.eqb n m)
       (exec_state (modifyXHMap1 f i k x) l) =
      eval_state (do m ← ε f;
                   return! hmapLookup Z.eqb n m) l.
Proof.
 intros. unfold modifyXHMap1.
 unfold hmapInsert.
 Opaque hmapIsMember get put run bind bind_ embed_fun unit modify exec_state.
 rewrite ?exec_bind. rewrite exec_embed. rewrite eval_embed.
 rewrite ?eval_bind2. unfold eval_state.
 rewrite ?rununit.
 rewrite ?runembed. simpl.
 rewrite exec_bind'. rewrite exec_unit.
 Transparent exec_state. unfold exec_state.
 Transparent modify. unfold modify. unfold compose.
 rewrite getput. rewrite runbind. rewrite runembed.
 rewrite runput. simpl. Transparent hmapIsMember get put run bind bind_ embed_fun unit modify exec_state.
 rewrite H. unfold Datatypes.id.
 apply modifyMapCorrect2_helper.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 auto.
Qed.

Lemma modifyMapCorrect2': forall {S T  X}`{EmbeddedType T S}
                        (f: S -> listPair Z X) (l:T) (x:X) (n k:Z) (i:listPair Z X -> S -> S),
                        (forall x l, f (i x l) = x) ->
                        n <> k ->
       eval_state (do m ← ↑ (ε f);
                   return! hmapLookup Z.eqb n m)
       (exec_state (↑ (modifyXHMap1 f i k x)) l) =
      eval_state (do m ← ↑ (ε f);
                   return! hmapLookup Z.eqb n m) l.

Proof.
 intros. rewrite ?liftEmbeddedStateBind.
 rewrite ?liftEmbeddedStateExec. rewrite  ?eval_bind.
 rewrite ?eval_embed_bind.
 rewrite modifyMapCorrect2. rewrite ?eval_bind2.
 rewrite ?exec_embed. rewrite eval_embed.
 unfold eval_state. rewrite rununit.
 unfold embed_funInducted. rewrite runembed. simpl.
 unfold compose.
 auto. auto. auto.
Qed.

Lemma modifyMapDefaultCorrect2': forall {S T X}`{EmbeddedType T S}
                        (f: S -> listPair Z X) (l:T) (x:X) (n k:Z) (i:listPair Z X -> S -> S) d,
                        (forall x l, f (i x l) = x) ->
       n <> k ->
       eval_state (do m ← ↑ (ε f);
                   return! hmapFindWithDefault d Z.eqb n m)
       (exec_state (↑ (modifyXHMap1 f i k x)) l) =
       eval_state (do m ← ↑ (ε f);
                   return! hmapFindWithDefault d Z.eqb n m) l.
Proof.
 intros. unfold hmapFindWithDefault.
 rewrite eval_bind2. rewrite eval_unit.
 remember (modifyMapCorrect2' f l x n k i H0 H1). clear Heqe.
 rewrite eval_bind2 in e. rewrite eval_unit in e.
 setoid_rewrite e. symmetry.
 rewrite eval_bind2. rewrite eval_unit.
 rewrite eval_bind2. rewrite eval_unit.
 auto.
Qed.

(*
(fun r : PendingLimitP =>
              ProgrammingWith.wrapWith r votes_ι_PendingLimit
                (votes_ι_PendingLimit r) [sender]← xBoolFalse
                Struct_PendingLimit Acc_PendingLimit__votes)
                f [k] ^ g [n]
*)

Existing Instance xint_booleq.
(*
Lemma modifyMapFieldMapCorrect:  forall {S T X}`{XDefault X}`{XDefault T}
                                 (f: S -> listPair Z T) (l:S)
                                 (x:X) (n k:Z) (i:listPair Z T -> S -> S)
                                 (g: T -> listPair Z X) (s:X) t z,
                                 hmapLookup Z.eqb k (f l) = Some z ->
                                 g default = [ ] ->
                                 (forall x l, f (i x l) = x) ->
                                 (forall r, ((t r) ->> g) [n] = s) ->
((eval_state (ε f)
    (exec_state
       ((modifyXHMapRecordByFun f i t k)) l)) [k] ->> g) [n] = s.
Proof.
 intros. unfold modifyXHMapRecordByFun.
 rewrite exec_bind.
 rewrite exec_embed.
 remember ((eval_state (ε f) l) [k] ?).
 setoid_rewrite <- Heqy.
 destruct y. simpl.
 unfold modify. rewrite exec_bind'.
 rewrite exec_unit.
 rewrite exec_bind.
 unfold compose.
 rewrite exec_get.
 rewrite eval_get.
 rewrite exec_put.
 rewrite 2eval_embed. rewrite eval_embed in Heqy.
 rewrite H3. unfold hmapFindWithDefault.
 unfold hmapInsert.
 assert (hmapIsMember Z.eqb k (f l) = true).
 apply memberLookup.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 exists t0. rewrite Heqy. simpl. auto.
 setoid_rewrite H5. simpl.
 rewrite lookupAdjust2.
 simpl. unfold Datatypes.id.
 unfold hmapFindWithDefault in H4.
 unfold Datatypes.id in H4.
 rewrite H4. auto.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 auto.  simpl.
 rewrite eval_embed. rewrite exec_unit.
 unfold hmapFindWithDefault.
 assert (hmapLookup Z.eqb k (f l) = None).
 rewrite  eval_embed in Heqy.
 rewrite Heqy.
 simpl. auto.
 rewrite H5. simpl. unfold get_field.
 rewrite H2.
 unfold  hmapLookup.
 simpl. congruence.
Qed.

Lemma modifyMapFieldMapCorrect2:  forall {S T X}`{XDefault X}`{XDefault T}
                                 (f: S -> listPair Z T) (l:S)
                                 (x:X) (n k:Z) (i:listPair Z T -> S -> S)
                                 (g: T -> listPair Z X) (s:X) t,
                                 (* hmapLookup Z.eqb k (f l) = Some z ->  *)
                                 g default = [ ] ->
                                 (forall x l, f (i x l) = x) ->
                                 (forall r, ((t r) ->> g) [n] = s) ->
((eval_state (ε f)
    (exec_state
       ((modifyXHMapRecordByFunDefault f i t k)) l)) [k] ->> g) [n] = s.
Proof.
intros. unfold modifyXHMapRecordByFunDefault.
 rewrite exec_bind.
 rewrite exec_embed.
 rewrite ?eval_embed.
 unfold modify. rewrite exec_bind'.
 rewrite exec_unit.
 rewrite exec_bind.
 unfold compose.
 rewrite exec_get.
 rewrite eval_get.
 rewrite exec_put.
 rewrite H2.
 unfold hmapFindWithDefault.
 unfold hmapInsert. simpl.
 remember (hmapIsMember Z.eqb k (f l)).
 setoid_rewrite <- Heqb.
 destruct b.
 rewrite lookupAdjust2.
 simpl. unfold Datatypes.id.
 assert (exists y, hmapLookup Z.eqb k (f l) = Some y).
 apply memberLookup.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 auto. inversion H4. setoid_rewrite H5.
 simpl. unfold hmapFindWithDefault in H3.
 rewrite H3. auto.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 auto. unfold Datatypes.id.
 unfold hmapLookup.
 simpl. assert (k =? k = true).
 apply Z.eqb_eq. auto.
 rewrite H4. simpl.
 unfold Datatypes.id.
 match goal with
 | |- optionMapDefault (fun x0 : X => x0)
  (hd_error ?m) default = s => remember m
 end. unfold get_field in Heql0.
 unfold hmapFindWithDefault in H3.
 match goal with
 | H: l0 = List.map snd
          (filter (fun p : Z * X => n =? fst p)
             (g
                (t ?r))) |- _ => remember r
 end.
 rewrite Heql0.
 unfold Datatypes.id in H3.
 unfold hmapLookup in H3.
 simpl in H3.
 unfold Datatypes.id in H3.
 unfold get_field in H3.
 rewrite H3. auto.
Qed.

Lemma modifyMapFieldMapCorrectLift: forall {S T L X}`{XDefault X}`{XDefault T}`{EmbeddedType L S}
                                 (f: S -> listPair Z T) (l:L)
                                 (x:X) (n k:Z) (i:listPair Z T -> S -> S)
                                 (g: T -> listPair Z X) (s:X) t z,
                                 hmapLookup Z.eqb k (f (projEmbed l)) = Some z ->
                                 g default = [ ] ->
                                 (forall x l, f (i x l) = x) ->
                                 (forall r, ((t r) ->> g) [n] = s) ->
((eval_state (↑(ε f))
    (exec_state
       (↑ (modifyXHMapRecordByFun f i t k)) l)) [k] ->> g) [n] = s.
Proof.
 intros.
 rewrite liftEmbeddedStateExec2.
 rewrite eval_bind.
 apply (modifyMapFieldMapCorrect f (projEmbed l) x n k i g s t z).
 auto. auto. auto. auto.
Qed.

Lemma modifyMapFieldMapCorrect3:  forall {S T X}`{XDefault X}`{XDefault T}
                                 (f: S -> listPair Z T) (l:S)
                                 (x:X) (k:Z) (i:listPair Z T -> S -> S)
                                 (s:T) t z,
                                 hmapLookup Z.eqb k (f l) = Some z ->
                                 (forall x l, f (i x l) = x) ->
                                 t z = s ->
((eval_state (ε f)
    (exec_state
       ((modifyXHMapRecordByFun f i t k)) l)) [k]) = s.
Proof.
 intros.
 unfold modifyXHMapRecordByFun.
 rewrite exec_bind.
 rewrite exec_embed.
 remember ((eval_state (ε f) l) [k] ?).
 setoid_rewrite <- Heqy.
 destruct y. simpl.
 unfold modify. rewrite exec_bind'.
 rewrite exec_unit.
 rewrite exec_bind.
 unfold compose.
 rewrite exec_get.
 rewrite eval_get.
 rewrite exec_put.
 rewrite 2eval_embed. rewrite eval_embed in Heqy.
 assert (Some t0 = Some z).
 rewrite Heqy. rewrite <- H1. simpl. auto.
 inversion H4.
 rewrite H3. unfold hmapFindWithDefault.
 unfold hmapInsert.
 assert (hmapIsMember Z.eqb k (f l) = true).
 apply memberLookup.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 exists t0. rewrite Heqy. simpl. auto.
 setoid_rewrite H5. simpl.
 unfold Datatypes.id. rewrite H2.
 rewrite lookupAdjust2. simpl. auto.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 auto.  simpl.
 rewrite eval_embed. rewrite exec_unit.
 unfold hmapFindWithDefault.
 assert (hmapLookup Z.eqb k (f l) = None).
 rewrite  eval_embed in Heqy.
 rewrite Heqy.
 simpl. auto.
 rewrite H4. simpl.  congruence.
Qed.

Lemma modifyMapFieldMapCorrect3':  forall {S T X}`{XDefault X}`{XDefault T}
                                 (f: S -> listPair Z T) (l:S)
                                 (x:X) (k:Z) (i:listPair Z T -> S -> S)
                                  t,
                                 hmapLookup Z.eqb k (f l) = None ->
                                 (forall x l, f (i x l) = x) ->
((eval_state (ε f)
    (exec_state
       ((modifyXHMapRecordByFun f i t k)) l)) [k]) = default.
Proof.
 intros.
 unfold modifyXHMapRecordByFun.
 rewrite exec_bind.
 rewrite exec_embed.
 remember ((eval_state (ε f) l) [k] ?).
 setoid_rewrite <- Heqy.
 destruct y. rewrite eval_embed in Heqy.
 simpl in Heqy.
 congruence. simpl.
 rewrite eval_embed. rewrite exec_unit.
 unfold hmapFindWithDefault.
 rewrite H1. compute. auto.
Qed.
*)
Lemma modifyMapCorrect3: forall {X}`{XDefault X}
                        (m: listPair Z X) (k:Z) (x:X),
                        (m [k]← x) [k] = x.
Proof.
 intros. unfold hmapFindWithDefault.
 remember (m [k]← x [k] ?).
 destruct y. symmetry in Heqy.
 assert (exists z : X, hmapLookup Z.eqb k (m [k]← x) = Some z).
 exists x0. auto.
 apply memberLookup in H0.
 remember ((hmapIsMember eqb k m)).
 unfold hmapInsert in H0.  unfold hmapInsert in Heqy.
 destruct y. rewrite <- Heqy0 in H0.
 rewrite <- Heqy0 in Heqy. simpl in H0.
 remember (adjustListPair Z.eqb (fun _ : X => x) k m).
 remember Heql.
 symmetry in Heqy0. apply memberLookup in Heqy0.
 inversion Heqy0. clear Heqe.
 apply (lookupAdjust1  (z:=x1) (k:=k)) in e.
 inversion_clear e. inversion_clear H3.
 simpl. unfold Datatypes.id.
 apply H4 in H1. unfold hmapInsert in Heqy.
 simpl in Heqy.
 rewrite <- Heql in Heqy. setoid_rewrite Heqy in H1.
 inversion H1. auto.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 simpl. rewrite <- Heqy0 in  H0. rewrite <- Heqy0 in  Heqy.
 simpl in H0. simpl in Heqy.
 unfold Datatypes.id in Heqy. unfold Datatypes.id in H0.
 unfold hmapLookup in Heqy. simpl in Heqy.
 rewrite Z.eqb_refl in Heqy.
 simpl in Heqy. inversion Heqy. compute. auto.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 unfold hmapInsert in Heqy.
 remember (hmapIsMember eqb k m).
 simpl. destruct y. simpl in Heqy.
 remember (adjustListPair Z.eqb (fun _ : X => x) k m).
 symmetry in Heqy0. apply memberLookup in Heqy0. inversion Heqy0.
 apply (lookupAdjust1  (z:=x0) (k:=k)) in Heql.
 inversion_clear Heql. inversion_clear H2.
 apply H3 in H0. setoid_rewrite <- Heqy in H0.
 inversion H0.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 simpl in Heqy. unfold hmapLookup in Heqy.
 simpl in Heqy. rewrite Z.eqb_refl in Heqy.  simpl in Heqy.
 inversion Heqy.
Qed.

Lemma modifyMapFieldMapCorrect3Default:  forall {S T X}`{XDefault X}`{XDefault T}
                                 (f: S -> listPair Z T) (l:S)
                                 (x:X) (k:Z) (i:listPair Z T -> S -> S)
                                 (s:T) t,
                                 (forall x l, f (i x l) = x) ->
                                 t (f l) [k] = s ->
((eval_state (ε f)
    (exec_state
       ((modifyXHMapRecordByFunDefault f i t k)) l)) [k]) = s.
Proof.
 intros.
 unfold modifyXHMapRecordByFunDefault.
 rewrite exec_bind.
 rewrite exec_embed.
 (* remember ((eval_state (ε f) l) [k] ?).
 setoid_rewrite <- Heqy.
 destruct y. simpl.*)
 unfold modify. rewrite exec_bind'.
 rewrite exec_unit.
 rewrite exec_bind.
 unfold compose.
 rewrite exec_get.
 rewrite eval_get.
 rewrite exec_put.
 rewrite 2eval_embed.
 rewrite ?H1.
 rewrite modifyMapCorrect3.
 auto.
 Qed.

Lemma modifyStateCorrect: forall {S T X}`{EmbeddedType S T} (f:T->X) (l:S) m,
eval_state (↑ (ε f)) (exec_state (↑ (modify m)) l) = f (m (projEmbed l)).
Proof.
 intros. rewrite liftEmbeddedStateExec2.
 rewrite eval_bind. unfold modify.
 rewrite exec_bind. unfold compose.
 rewrite exec_put. rewrite eval_embed.
 rewrite eval_get. auto.
Qed.

Lemma adjustListPairDouble:
forall X x y k m,
adjustListPair Z.eqb (fun _ : X => y) k
  (adjustListPair Z.eqb (fun _ : X => x) k m) =
adjustListPair Z.eqb (fun _ : X => y) k m.
Proof.
 intros. induction m.
 simpl. auto.
 simpl. destruct a.
 remember (k =? z).
 destruct  b.
 simpl. rewrite Z.eqb_refl.
 rewrite IHm. auto.
 simpl. rewrite <- Heqb. rewrite IHm.  auto.
 Qed.
(*
Lemma memberFalseAdjust:
forall X x k m, hmapIsMember eqb k m = false ->
      adjustListPair Z.eqb (fun _ : X => x) k m = m.
Proof.
 intros.
 induction m.
 simpl. auto.
 simpl. destruct a.
 replace (k =? z) with false.
 rewrite IHm. auto.
 simpl in H. apply memberLookup2.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 apply memberLookup2 in H.
 unfold  hmapLookup in H.
 simpl in H.
 remember (k=?z). destruct b.
 simpl in H. inversion H.
 apply H.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 apply memberLookup2 in H.
 unfold  hmapLookup in H.
 simpl in H.
 remember (k=?z). destruct b.
 simpl in H. inversion H. auto.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 Qed.

Lemma modifyMapCorrect4: forall {X}`{XDefault X}
                        (m: listPair Z X) (k:Z) (x y:X),
                        (m [k]← x) [k] ← y =
                        (m [k]← y).
Proof.
 intros.
 unfold hmapInsert.
 remember (hmapIsMember eqb k m).
 destruct  y0.
 simpl.
 replace (hmapIsMember Z.eqb k
    (adjustListPair Z.eqb (fun _ : X => x) k m)) with true.
 apply adjustListPairDouble.
 symmetry.
 apply memberLookup.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 exists x.
 apply lookupAdjust2.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 auto.
 simpl. unfold Datatypes.id.
 rewrite Z.eqb_refl.
 replace (hmapIsMember Z.eqb k ((k, x) :: m)) with true.
 rewrite memberFalseAdjust.
 auto. auto.  symmetry.
 apply memberLookup.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 exists x.
 unfold hmapLookup.
 simpl. rewrite Z.eqb_refl.
 simpl.  auto.
Qed.

Lemma modifyMapFieldsCommute:
forall {S T}`{XDefault T}
(f: S -> listPair Z T) i (n: Z) (s: S) t1 t2,
(forall x l, f (i x l) = x) ->
(forall x y l, i x (i y l) = i x l) ->
(forall t, t1 (t2 t) = t2 (t1 t)) ->
exec_state
  (modifyXHMapRecordByFunDefault f i t1 n)
  (exec_state
     (modifyXHMapRecordByFunDefault f i t2 n) s) =
exec_state
  (modifyXHMapRecordByFunDefault f i t2 n)
  (exec_state
     (modifyXHMapRecordByFunDefault f i t1 n) s).
Proof.
 intros.
 unfold modifyXHMapRecordByFunDefault.
 rewrite ?exec_bind.
 rewrite ?eval_embed.
 unfold modify.
 rewrite ?exec_embed.
 rewrite ?exec_bind'.
 rewrite ?exec_bind.
 unfold compose.
 rewrite ?exec_get.
 rewrite ?exec_unit.
 rewrite ?exec_put.
 rewrite ?eval_get.
 rewrite ?H0.
 remember (f s).
 remember (l [n]).
 setoid_rewrite <- Heqt.
 rewrite ?modifyMapCorrect3.
 rewrite ?H1.
 rewrite ?modifyMapCorrect4.
 rewrite H2.
 auto.
Qed.

Lemma hmapDoubleInsert: forall X m (k: Z) (x y: X),
(m [k] ← x) [k] ← y = m [k] ← y.
Proof.
 intros. unfold hmapInsert.
 simpl. unfold Datatypes.id.
 remember (hmapIsMember Z.eqb k m). destruct b.
 replace (hmapIsMember Z.eqb k
    (adjustListPair Z.eqb (fun _ : X => x) k m)) with true.
 rewrite adjustListPairDouble. auto.
 symmetry.
 apply memberLookup.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 symmetry in Heqb. remember Heqb. clear Heqe.
 apply memberLookup in Heqb. inversion Heqb.
 exists x.
 apply lookupAdjust2.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
 auto. unfold boolEquivalence. intros. apply intBoolEquivalence.
 simpl. rewrite Z.eqb_refl.
 unfold hmapIsMember. simpl. rewrite Z.eqb_refl. simpl.
 rewrite memberFalseAdjust. auto. auto.
Qed.

Lemma hmapDoubleInsertNeq: forall X`{XDefault X} (m: listPair Z X) (k n: Z) (x y: X),
k <> n  ->
(((m [k] ← x) [n] ← y) [k]) = x.
Proof.
 intros.
 remember (m [k]← x)  as m'.
 remember (modifyMapCorrect2_helper (K:=Z) (V:=X) (m:=m') (x:=y)  (n:=k) (k:=n)  (eqK := Z.eqb)).
 apply e in H0. clear Heqe.
 unfold hmapFindWithDefault.
 unfold hmapInsert.
 remember(hmapIsMember Z.eqb n m').
 setoid_rewrite <- Heqb.
 unfold xBoolIfElse.
 unfold xiBoolFunRec.
 unfold xlIntFunRec.
 unfold xhmListFunRec.
 unfold hmfr.
 unfold hmapFunRec.
 unfold listFunRec.
 unfold intFunRec.
 unfold boolFunRec.
 setoid_rewrite H0.
 rewrite Heqm'. apply modifyMapCorrect3.
 unfold boolEquivalence. intros. apply intBoolEquivalence.
Qed.

Lemma hmapDeleteInsert: forall X (k:Z) (x: X) m,
deleteListPair Z.eqb k (m [k] ← x) =
deleteListPair Z.eqb k m.
Proof.
 intros. induction m.
 simpl. rewrite Z.eqb_refl. auto.
 simpl. destruct a.
 unfold hmapInsert.
 simpl. unfold hmapIsMember. simpl.
 remember (z=?k).
 replace (k=?z) with b.
 unfold Datatypes.id.
 unfold hmapInsert in IHm.
 simpl in IHm. unfold Datatypes.id  in IHm.
 unfold hmapIsMember in IHm.
 destruct b. simpl. rewrite Z.eqb_refl.
 remember (xListIn Z.eqb k (xHMapKeys m)).
 destruct b.
 auto. rewrite memberFalseAdjust. auto.
 unfold hmapIsMember. auto.
 simpl. remember (bIn Z.eqb k (List.map fst m)).
 destruct b. setoid_rewrite <- Heqb0 in IHm.
 rewrite <- IHm. simpl.
 replace (k=?z) with false. auto.
 symmetry. rewrite Z.eqb_sym. auto.
 simpl. rewrite Z.eqb_refl.
 replace (k=?z) with false.
 auto. rewrite Z.eqb_sym. auto.
 rewrite Z.eqb_sym. auto.
Qed.
*)
Lemma hmapIsMemberDelete: forall X (k:Z) m,
hmapIsMember (V:=X) Z.eqb k (deleteListPair Z.eqb k m) = false.
Proof.
 intros.
 induction m.
 simpl. auto.
 simpl. destruct a. remember (k =? z).
 destruct b. auto.
 unfold hmapIsMember. simpl.
 replace (z =? k) with false.
 simpl. apply IHm.
 symmetry. rewrite Z.eqb_sym. auto.
Qed.

End CommonModelProofs.


From Coq Require Import ssreflect ssrfun ssrbool.

From Ltac2 Require Import Ltac2.

From Coq Require Import Ensembles Bool String Btauto.
From Coq.Logic Require Import FunctionalExtensionality Eqdep_dec.
From Equations Require Import Equations.

Require Import Coq.Program.Tactics.

From MatchingLogic Require Import Syntax
                                  ProofSystem
                                  wftactics
                                  NamedAxioms
                                  IndexManipulation.

From stdpp Require Import list tactics fin_sets coGset gmap sets.

From MatchingLogic.Utils Require Import stdpp_ext.

Import extralibrary.

Import
  MatchingLogic.Syntax.Notations
  MatchingLogic.DerivedOperators_Syntax.Notations
  MatchingLogic.ProofSystem.Notations_private
.

Set Default Proof Mode "Classic".

Open Scope ml_scope.

Section with_signature.
  Context {Σ : Signature}.
  (* TODO make this return well-formed patterns. *)
  Fixpoint framing_patterns Γ ϕ (pf : Γ ⊢H ϕ) : gset wfPattern :=
  match pf with
  | hypothesis _ _ _ _ => ∅
  | P1 _ _ _ _ _ => ∅
  | P2 _ _ _ _ _ _ _ => ∅
  | P3 _ _ _ => ∅
  | Modus_ponens _ _ _ m0 m1
    => (@framing_patterns _ _ m0) ∪ (@framing_patterns _ _ m1)
  | Ex_quan _ _ _ _ => ∅
  | Ex_gen _ _ _ x _ _ pf _ => @framing_patterns _ _ pf
  | Prop_bott_left _ _ _ => ∅
  | Prop_bott_right _ _ _ => ∅
  | Prop_disj_left _ _ _ _ _ _ _ => ∅
  | Prop_disj_right _ _ _ _ _ _ _ => ∅
  | Prop_ex_left _ _ _ _ _ => ∅
  | Prop_ex_right _ _ _ _ _ => ∅
  | Framing_left _ _ _ psi wfp m0 => {[(exist _ psi wfp)]} ∪ (@framing_patterns _ _ m0)
  | Framing_right _ _ _ psi wfp m0 => {[(exist _ psi wfp)]} ∪ (@framing_patterns _ _ m0)
  | Svar_subst _ _ _ _ _ _ m0 => @framing_patterns _ _ m0
  | Pre_fixp _ _ _ => ∅
  | Knaster_tarski _ _ phi psi m0 => @framing_patterns _ _ m0
  | Existence _ => ∅
  | Singleton_ctx _ _ _ _ _ _ => ∅
  end.

  Fixpoint uses_ex_gen (EvS : EVarSet) Γ ϕ (pf : ML_proof_system Γ ϕ) :=
  match pf with
  | hypothesis _ _ _ _ => false
  | P1 _ _ _ _ _ => false
  | P2 _ _ _ _ _ _ _ => false
  | P3 _ _ _ => false
  | Modus_ponens _ _ _ m0 m1
    => uses_ex_gen EvS _ _ m0
        || uses_ex_gen EvS _ _ m1
  | Ex_quan _ _ _ _ => false
  | Ex_gen _ _ _ x _ _ pf _ => if decide (x ∈ EvS) is left _ then true else uses_ex_gen EvS _ _ pf
  | Prop_bott_left _ _ _ => false
  | Prop_bott_right _ _ _ => false
  | Prop_disj_left _ _ _ _ _ _ _ => false
  | Prop_disj_right _ _ _ _ _ _ _ => false
  | Prop_ex_left _ _ _ _ _ => false
  | Prop_ex_right _ _ _ _ _ => false
  | Framing_left _ _ _ _ _ m0 => uses_ex_gen EvS _ _ m0
  | Framing_right _ _ _ _ _ m0 => uses_ex_gen EvS _ _ m0
  | Svar_subst _ _ _ _ _ _ m0 => uses_ex_gen EvS _ _ m0
  | Pre_fixp _ _ _ => false
  | Knaster_tarski _ _ phi psi m0 => uses_ex_gen EvS _ _ m0
  | Existence _ => false
  | Singleton_ctx _ _ _ _ _ _ => false
  end.

Fixpoint uses_of_ex_gen Γ ϕ (pf : ML_proof_system Γ ϕ) : EVarSet :=
  match pf with
  | hypothesis _ _ _ _ => ∅
  | P1 _ _ _ _ _ => ∅
  | P2 _ _ _ _ _ _ _ => ∅
  | P3 _ _ _ => ∅
  | Modus_ponens _ _ _ m0 m1
    => uses_of_ex_gen _ _ m0
        ∪ uses_of_ex_gen _ _ m1
  | Ex_quan _ _ _ _ => ∅
  | Ex_gen _ _ _ x _ _ pf _ => {[x]} ∪ uses_of_ex_gen _ _ pf
  | Prop_bott_left _ _ _ => ∅
  | Prop_bott_right _ _ _ => ∅
  | Prop_disj_left _ _ _ _ _ _ _ => ∅
  | Prop_disj_right _ _ _ _ _ _ _ => ∅
  | Prop_ex_left _ _ _ _ _ => ∅
  | Prop_ex_right _ _ _ _ _ => ∅
  | Framing_left _ _ _ _ _ m0 => uses_of_ex_gen _ _ m0
  | Framing_right _ _ _ _ _ m0 => uses_of_ex_gen _ _ m0
  | Svar_subst _ _ _ _ _ _ m0 => uses_of_ex_gen _ _ m0
  | Pre_fixp _ _ _ => ∅
  | Knaster_tarski _ _ phi psi m0 => uses_of_ex_gen _ _ m0
  | Existence _ => ∅
  | Singleton_ctx _ _ _ _ _ _ => ∅
  end.

  Lemma uses_of_ex_gen_correct Γ ϕ (pf : ML_proof_system Γ ϕ) (x : evar) :
    x ∈ uses_of_ex_gen Γ ϕ pf <-> uses_ex_gen {[x]} Γ ϕ pf = true.
  Proof.
    induction pf; simpl; try set_solver.
    {
      rewrite orb_true_iff. set_solver.
    }
    {
      rewrite elem_of_union. rewrite IHpf.
      destruct (decide (x0 ∈ {[x]})) as [Hin|Hnotin].
      {
        rewrite elem_of_singleton in Hin. subst.
        split; intros H. reflexivity. left. rewrite elem_of_singleton.
        reflexivity.
      }
      {
        split; intros H.
        {
          destruct H as [H|H].
          {
            exfalso. set_solver.
          }
          exact H.
        }
        {
          right. exact H.
        }
      }
    }
  Qed.

  Fixpoint uses_svar_subst (S : SVarSet) Γ ϕ (pf : Γ ⊢H ϕ) :=
    match pf with
    | hypothesis _ _ _ _ => false
    | P1 _ _ _ _ _ => false
    | P2 _ _ _ _ _ _ _ => false
    | P3 _ _ _ => false
    | Modus_ponens _ _ _ m0 m1
      => uses_svar_subst S _ _ m0
         || uses_svar_subst S _ _ m1
    | Ex_quan _ _ _ _ => false
    | Ex_gen _ _ _ _ _ _ pf' _ => uses_svar_subst S _ _ pf'
    | Prop_bott_left _ _ _ => false
    | Prop_bott_right _ _ _ => false
    | Prop_disj_left _ _ _ _ _ _ _ => false
    | Prop_disj_right _ _ _ _ _ _ _ => false
    | Prop_ex_left _ _ _ _ _ => false
    | Prop_ex_right _ _ _ _ _ => false
    | Framing_left _ _ _ _ _ m0 => uses_svar_subst S _ _ m0
    | Framing_right _ _ _ _ _ m0 => uses_svar_subst S _ _ m0
    | Svar_subst _ _ _ X _ _ m0 => if decide (X ∈ S) is left _ then true else uses_svar_subst S _ _ m0
    | Pre_fixp _ _ _ => false
    | Knaster_tarski _ _ phi psi m0 => uses_svar_subst S _ _ m0
    | Existence _ => false
    | Singleton_ctx _ _ _ _ _ _ => false
    end.

  Fixpoint uses_of_svar_subst Γ ϕ (pf : Γ ⊢H ϕ) : SVarSet :=
    match pf with
    | hypothesis _ _ _ _ => ∅
    | P1 _ _ _ _ _ => ∅
    | P2 _ _ _ _ _ _ _ => ∅
    | P3 _ _ _ => ∅
    | Modus_ponens _ _ _ m0 m1
      => uses_of_svar_subst _ _ m0
          ∪ uses_of_svar_subst _ _ m1
    | Ex_quan _ _ _ _ => ∅
    | Ex_gen _ _ _ _ _ _ pf' _ => uses_of_svar_subst _ _ pf'
    | Prop_bott_left _ _ _ => ∅
    | Prop_bott_right _ _ _ => ∅
    | Prop_disj_left _ _ _ _ _ _ _ => ∅
    | Prop_disj_right _ _ _ _ _ _ _ => ∅
    | Prop_ex_left _ _ _ _ _ => ∅
    | Prop_ex_right _ _ _ _ _ => ∅
    | Framing_left _ _ _ _ _ m0 => uses_of_svar_subst _ _ m0
    | Framing_right _ _ _ _ _ m0 => uses_of_svar_subst _ _ m0
    | Svar_subst _ _ _ X _ _ m0 => {[X]} ∪ uses_of_svar_subst _ _ m0
    | Pre_fixp _ _ _ => ∅
    | Knaster_tarski _ _ phi psi m0 => uses_of_svar_subst _ _ m0
    | Existence _ => ∅
    | Singleton_ctx _ _ _ _ _ _ => ∅
    end.

  Lemma uses_of_svar_subst_correct Γ ϕ (pf : ML_proof_system Γ ϕ) (X : svar) :
    X ∈ uses_of_svar_subst Γ ϕ pf <-> uses_svar_subst {[X]} Γ ϕ pf = true.
  Proof.
    induction pf; simpl; try set_solver.
    {
      rewrite orb_true_iff. set_solver.
    }
    {
      rewrite elem_of_union. rewrite IHpf. clear IHpf.
      destruct (decide (X0 ∈ {[X]})) as [Hin|Hnotin].
      {
        rewrite elem_of_singleton in Hin. subst.
        split; intros H. reflexivity. left. rewrite elem_of_singleton.
        reflexivity.
      }
      {
        split; intros H.
        {
          destruct H as [H|H].
          {
            exfalso. set_solver.
          }
          exact H.
        }
        {
          right. exact H.
        }
      }
    }
  Qed.

  Fixpoint uses_kt Γ ϕ (pf : Γ ⊢H ϕ) :=
    match pf with
    | hypothesis _ _ _ _ => false
    | P1 _ _ _ _ _ => false
    | P2 _ _ _ _ _ _ _ => false
    | P3 _ _ _ => false
    | Modus_ponens _ _ _ m0 m1
      => uses_kt _ _ m0 || uses_kt _ _ m1
    | Ex_quan _ _ _ _ => false
    | Ex_gen _ _ _ _ _ _ pf' _ => uses_kt _ _ pf'
    | Prop_bott_left _ _ _ => false
    | Prop_bott_right _ _ _ => false
    | Prop_disj_left _ _ _ _ _ _ _ => false
    | Prop_disj_right _ _ _ _ _ _ _ => false
    | Prop_ex_left _ _ _ _ _ => false
    | Prop_ex_right _ _ _ _ _ => false
    | Framing_left _ _ _ _ _ m0 => uses_kt _ _ m0
    | Framing_right _ _ _ _ _ m0 => uses_kt _ _ m0
    | Svar_subst _ _ _ X _ _ m0 => uses_kt _ _ m0
    | Pre_fixp _ _ _ => false
    | Knaster_tarski _ _ phi psi m0 => true
    | Existence _ => false
    | Singleton_ctx _ _ _ _ _ _ => false
    end.

  Fixpoint propositional_only Γ ϕ (pf : Γ ⊢H ϕ) :=
    match pf with
    | hypothesis _ _ _ _ => true
    | P1 _ _ _ _ _ => true
    | P2 _ _ _ _ _ _ _ => true
    | P3 _ _ _ => true
    | Modus_ponens _ _ _ m0 m1
      => propositional_only _ _ m0 && propositional_only _ _ m1
    | Ex_quan _ _ _ _ => false
    | Ex_gen _ _ _ _ _ _ pf' _ => false
    | Prop_bott_left _ _ _ => false
    | Prop_bott_right _ _ _ => false
    | Prop_disj_left _ _ _ _ _ _ _ => false
    | Prop_disj_right _ _ _ _ _ _ _ => false
    | Prop_ex_left _ _ _ _ _ => false
    | Prop_ex_right _ _ _ _ _ => false
    | Framing_left _ _ _ _ _ m0 => false
    | Framing_right _ _ _ _ _ m0 => false
    | Svar_subst _ _ _ X _ _ m0 => false
    | Pre_fixp _ _ _ => false
    | Knaster_tarski _ _ phi psi m0 => false
    | Existence _ => false
    | Singleton_ctx _ _ _ _ _ _ => false
    end.

  Lemma propositional_implies_no_frame Γ ϕ (pf : Γ ⊢H ϕ) :
    propositional_only Γ ϕ pf = true -> framing_patterns Γ ϕ pf = ∅.
  Proof.
    intros H.
    induction pf; simpl in *; try apply reflexivity; try congruence.
    {
      destruct_and!. specialize (IHpf1 ltac:(assumption)). specialize (IHpf2 ltac:(assumption)).
      rewrite IHpf1. rewrite IHpf2. set_solver.
    }
  Qed.

  Lemma propositional_implies_noKT Γ ϕ (pf : Γ ⊢H ϕ) :
    propositional_only Γ ϕ pf = true -> uses_kt Γ ϕ pf = false.
  Proof.
    induction pf; simpl; intros H; try reflexivity; try congruence.
    { destruct_and!. rewrite IHpf1;[assumption|]. rewrite IHpf2;[assumption|]. reflexivity. }
  Qed.

  Lemma propositional_implies_no_uses_svar Γ ϕ (pf : ML_proof_system Γ ϕ) (SvS : SVarSet) :
    propositional_only Γ ϕ pf = true -> uses_svar_subst SvS Γ ϕ pf = false.
  Proof.
    induction pf; simpl; intros H; try reflexivity; try congruence.
    { destruct_and!. rewrite IHpf1;[assumption|]. rewrite IHpf2;[assumption|]. reflexivity. }
  Qed.

  Lemma propositional_implies_no_uses_ex_gen Γ ϕ (pf : ML_proof_system Γ ϕ) (EvS : EVarSet) :
    propositional_only Γ ϕ pf = true -> uses_ex_gen EvS Γ ϕ pf = false.
  Proof.
    induction pf; simpl; intros H; try reflexivity; try congruence.
    { destruct_and!. rewrite IHpf1;[assumption|]. rewrite IHpf2;[assumption|]. reflexivity. }
  Qed.

  Lemma propositional_implies_no_uses_ex_gen_2 Γ ϕ (pf : ML_proof_system Γ ϕ) :
    propositional_only Γ ϕ pf = true -> uses_of_ex_gen Γ ϕ pf = ∅.
  Proof.
    induction pf; simpl; intros H; try reflexivity; try congruence.
    { destruct_and!. rewrite IHpf1;[assumption|]. rewrite IHpf2;[assumption|]. set_solver. }
  Qed.

  Lemma propositional_implies_no_uses_svar_2 Γ ϕ (pf : ML_proof_system Γ ϕ)  :
    propositional_only Γ ϕ pf = true -> uses_of_svar_subst Γ ϕ pf = ∅.
  Proof.
    induction pf; simpl; intros H; try reflexivity; try congruence.
    { destruct_and!. rewrite IHpf1;[assumption|]. rewrite IHpf2;[assumption|]. set_solver. }
  Qed.

  Definition proofbpred := forall (Γ : Theory) (ϕ : Pattern),  Γ ⊢H ϕ -> bool.

  Definition indifferent_to_cast (P : proofbpred)
    := forall (Γ : Theory) (ϕ ψ : Pattern) (e: ψ = ϕ) (pf : Γ ⊢H ϕ),
         P Γ ψ (cast_proof e pf) = P Γ ϕ pf.

  Lemma indifferent_to_cast_uses_svar_subst SvS:
    indifferent_to_cast (uses_svar_subst SvS).
  Proof.
   unfold indifferent_to_cast. intros Γ ϕ ψ e pf.
   induction pf; unfold cast_proof; unfold eq_rec_r;
     unfold eq_rec; unfold eq_rect; unfold eq_sym; simpl; auto;
     pose proof (e' := e); move: e; rewrite e'; clear e'; intros e;
     match type of e with
     | ?x = ?x => replace e with (@erefl _ x) by (apply UIP_dec; intros x' y'; apply Pattern_eqdec)
     end; simpl; try reflexivity.
  Qed.

  Lemma indifferent_to_cast_uses_kt:
    indifferent_to_cast uses_kt.
  Proof.
   unfold indifferent_to_cast. intros Γ ϕ ψ e pf.
   induction pf; unfold cast_proof; unfold eq_rec_r;
     unfold eq_rec; unfold eq_rect; unfold eq_sym; simpl; auto;
     pose proof (e' := e); move: e; rewrite e'; clear e'; intros e;
     match type of e with
     | ?x = ?x => replace e with (@erefl _ x) by (apply UIP_dec; intros x' y'; apply Pattern_eqdec)
     end; simpl; try reflexivity.
  Qed.

  Lemma indifferent_to_cast_uses_ex_gen EvS:
    indifferent_to_cast (uses_ex_gen EvS).
  Proof.
   unfold indifferent_to_cast. intros Γ ϕ ψ e pf.
   induction pf; unfold cast_proof; unfold eq_rec_r;
     unfold eq_rec; unfold eq_rect; unfold eq_sym; simpl; auto;
     pose proof (e' := e); move: e; rewrite e'; clear e'; intros e;
     match type of e with
     | ?x = ?x => replace e with (@erefl _ x) by (apply UIP_dec; intros x' y'; apply Pattern_eqdec)
     end; simpl; try reflexivity.
  Qed.

End with_signature.

Definition has_bound_variable_under_mu {Σ : Signature} (ϕ : Pattern) : bool
:= let x := fresh_evar ϕ in
  mu_in_evar_path x (bsvar_subst (patt_free_evar x) 0 ϕ) 0
.

Fixpoint uses_kt_unreasonably {Σ : Signature} Γ ϕ (pf : ML_proof_system Γ ϕ) :=
  match pf with
  | ProofSystem.hypothesis _ _ _ _ => false
  | ProofSystem.P1 _ _ _ _ _ => false
  | ProofSystem.P2 _ _ _ _ _ _ _ => false
  | ProofSystem.P3 _ _ _ => false
  | ProofSystem.Modus_ponens _ _ _ m0 m1
    => uses_kt_unreasonably _ _ m0 || uses_kt_unreasonably _ _ m1
  | ProofSystem.Ex_quan _ _ _ _ => false
  | ProofSystem.Ex_gen _ _ _ _ _ _ pf' _ => uses_kt_unreasonably _ _ pf'
  | ProofSystem.Prop_bott_left _ _ _ => false
  | ProofSystem.Prop_bott_right _ _ _ => false
  | ProofSystem.Prop_disj_left _ _ _ _ _ _ _ => false
  | ProofSystem.Prop_disj_right _ _ _ _ _ _ _ => false
  | ProofSystem.Prop_ex_left _ _ _ _ _ => false
  | ProofSystem.Prop_ex_right _ _ _ _ _ => false
  | ProofSystem.Framing_left _ _ _ _ _ m0 => uses_kt_unreasonably _ _ m0
  | ProofSystem.Framing_right _ _ _ _ _ m0 => uses_kt_unreasonably _ _ m0
  | ProofSystem.Svar_subst _ _ _ X _ _ m0 => uses_kt_unreasonably _ _ m0
  | ProofSystem.Pre_fixp _ _ _ => false
  | ProofSystem.Knaster_tarski _ phi psi wf m0 =>
    has_bound_variable_under_mu phi || uses_kt_unreasonably _ _ m0
  | ProofSystem.Existence _ => false
  | ProofSystem.Singleton_ctx _ _ _ _ _ _ => false
  end.

  Lemma indifferent_to_cast_uses_kt_unreasonably {Σ : Signature}:
    indifferent_to_cast uses_kt_unreasonably.
  Proof.
   unfold indifferent_to_cast. intros Γ ϕ ψ e pf.
   induction pf; unfold cast_proof; unfold eq_rec_r;
     unfold eq_rec; unfold eq_rect; unfold eq_sym; simpl; auto;
     pose proof (e' := e); move: e; rewrite e'; clear e'; intros e;
     match type of e with
     | ?x = ?x => replace e with (@erefl _ x) by (apply UIP_dec; intros x' y'; apply Pattern_eqdec)
     end; simpl; try reflexivity.
  Qed.

Lemma kt_unreasonably_implies_somehow {Σ : Signature} Γ ϕ (pf : ML_proof_system Γ ϕ) :
  uses_kt_unreasonably Γ ϕ pf -> uses_kt Γ ϕ pf.
Proof.
  induction pf; cbn; auto with nocore.
  { intros H. unfold is_true in *. rewrite orb_true_iff in H.
    destruct H as [H|H].
    {
      specialize (IHpf1 H).
      rewrite IHpf1.
      reflexivity.
    }
    {
      specialize (IHpf2 H).
      rewrite IHpf2.
      rewrite orb_true_r.
      reflexivity.
    }
  }
  {
    intros _. reflexivity.
  }
Qed.

Arguments uses_svar_subst {Σ} S {Γ} {ϕ} pf : rename.
Arguments uses_kt {Σ} {Γ} {ϕ} pf : rename.
Arguments uses_kt_unreasonably {Σ} {Γ} {ϕ} pf : rename.
Arguments uses_ex_gen {Σ} E {Γ} {ϕ} pf : rename.

Section proof_constraint.
  Context {Σ : Signature}.

  Lemma instantiate_named_axiom (NA : NamedAxioms) (name : (NAName NA)) :
    (theory_of_NamedAxioms NA) ⊢H (@NAAxiom Σ NA name).
  Proof.
    apply hypothesis.
    { apply NAwf. }
    unfold theory_of_NamedAxioms.
    apply propset.elem_of_PropSet.
    exists name.
    reflexivity.
  Defined.

  Definition coEVarSet := coGset evar.
  Definition coSVarSet := coGset svar.
  Definition WfpSet := gmap.gset wfPattern.
  Definition coWfpSet := coGset wfPattern.

  Record ProofInfo :=
    mkProofInfo
    {
      pi_generalized_evars : coEVarSet ;
      pi_substituted_svars : coSVarSet ;
      pi_uses_kt : bool ;
      pi_uses_advanced_kt : bool ;
      (* pi_framing_patterns : coWfpSet ;  *)
    }.

  Definition ProofInfoLe (i₁ i₂ : ProofInfo) : Prop :=
    pi_generalized_evars i₁ ⊆ pi_generalized_evars i₂ /\
    pi_substituted_svars i₁ ⊆ pi_substituted_svars i₂ /\
    (pi_uses_kt i₁ ==> pi_uses_kt i₂) /\
    (pi_uses_advanced_kt i₁ ==> pi_uses_advanced_kt i₂)
  .

  (* A proof together with some properties of it. *)
  Record ProofInfoMeaning
    (Γ : Theory)
    (ϕ : Pattern)
    (pwi_pf : Γ ⊢H ϕ)
    (pi : ProofInfo)
    : Prop
    :=
  mkProofInfoMeaning
  {
    pwi_pf_ge : gset_to_coGset (@uses_of_ex_gen Σ Γ ϕ pwi_pf) ⊆ pi_generalized_evars pi ;
    pwi_pf_svs : gset_to_coGset (@uses_of_svar_subst Σ Γ ϕ pwi_pf) ⊆ pi_substituted_svars pi ;
    pwi_pf_kt : implb (@uses_kt Σ Γ ϕ pwi_pf) (pi_uses_kt pi) ;
    pwi_pf_kta : implb (@uses_kt_unreasonably Σ Γ ϕ pwi_pf) (pi_uses_advanced_kt pi && (@uses_kt Σ Γ ϕ pwi_pf)) ;
    (* pwi_pf_fp : gset_to_coGset (@framing_patterns Σ Γ ϕ pwi_pf) ⊆ (pi_framing_patterns pi) ; *)
  }.

  Definition ProofLe (i₁ i₂ : ProofInfo) :=
    forall (Γ : Theory) (ϕ : Pattern) (pf : Γ ⊢H ϕ),
      @ProofInfoMeaning Γ ϕ pf i₁ -> @ProofInfoMeaning Γ ϕ pf i₂.

  Lemma ProofInfoLe_ProofLe (i₁ i₂ : ProofInfo) :
    ProofInfoLe i₁ i₂ -> ProofLe i₁ i₂.
  Proof.
    intros H. intros Γ φ pf Hpf. destruct Hpf.
    destruct H as [HEV [HSV [HKT HKTA] ] ].
    constructor. 1-2: set_solver.
    {
      apply implb_true_iff.
      pose proof (proj1 (implb_true_iff _ _) HKT).
      pose proof (proj1 (implb_true_iff _ _) pwi_pf_kt0).
      tauto.
    }
    {
      apply implb_true_iff.
      pose proof (H1 := proj1 (implb_true_iff _ _) HKTA).
      pose proof (H2 := proj1 (implb_true_iff _ _) pwi_pf_kta0).
      intro H.
      rewrite andb_true_iff.
      specialize (H2 H).
      unfold is_true in pwi_pf_kta0.
      rewrite implb_true_iff in pwi_pf_kta0.
      specialize (pwi_pf_kta0 H).
      split.
      {
        apply H1. clear H1.
        rewrite andb_true_iff in pwi_pf_kta0.
        apply pwi_pf_kta0.
      }
      rewrite andb_true_iff in H2. apply H2.
    }
  Qed.

End proof_constraint.

  Ltac convert_implb :=
  unfold is_true in *;
  match goal with
  | |- context G [implb _ _ = true] => rewrite implb_true_iff
  | H : context G [implb _ _ = true] |- _ => rewrite implb_true_iff in H
  end.

  Ltac convert_orb :=
  unfold is_true in *;
  match goal with
  | |- context G [orb _ _ = true] => rewrite orb_true_iff
  | H : context G [orb _ _ = true] |- _ => rewrite orb_true_iff in H
  end.

  Ltac convert_andb :=
  unfold is_true in *;
  match goal with
  | |- context G [orb _ _ = true] => rewrite andb_true_iff
  | H : context G [orb _ _ = true] |- _ => rewrite andb_true_iff in H
  end.

  Ltac destruct_pile :=
    match goal with
    | H : @ProofInfoLe _ _ _ |- _ => destruct H as [? [? ?] ]
    end.

  (** To solve goals shaped like: ProofInfoLe i₁ i₂ *)
  Ltac try_solve_pile :=
    assumption + (* optimization *)
    (repeat destruct_pile;
    simpl in *;
    split; [try set_solver|split;[try set_solver
    |try (repeat convert_implb;
          repeat convert_orb;
          repeat convert_andb;
          set_solver)] ]).

Section proof_info.
  Context {Σ : Signature}.
  Import Notations_private.
  (*
  #[global]
  Instance
  *)
  Lemma pile_refl (i : ProofInfo) : ProofInfoLe i i.
  Proof.
    try_solve_pile.
  Qed.

  (*
  #[global]
  Instance
  *)
  Lemma pile_trans
    (i₁ i₂ i₃ : ProofInfo) (PILE12 : ProofInfoLe i₁ i₂) (PILE23 : ProofInfoLe i₂ i₃)
  : ProofInfoLe i₁ i₃.
  Proof.
    try_solve_pile.
  Qed.

  Definition BasicReasoning : ProofInfo := ((@mkProofInfo _ ∅ ∅ false false)).
  Definition AnyReasoning : ProofInfo := (@mkProofInfo _ ⊤ ⊤ true true).

  Definition derives_using Γ ϕ pi
  := ({pf : Γ ⊢H ϕ | @ProofInfoMeaning _ _ _ pf pi }).

  Definition derives Γ ϕ
  := derives_using Γ ϕ AnyReasoning.

  Definition raw_proof_of {Γ} {ϕ} {pi}:
    derives_using Γ ϕ pi ->
    ML_proof_system Γ ϕ
  := fun pf => proj1_sig pf.

End proof_info.

Module Notations.

Notation "Γ '⊢i' ϕ 'using' pi"
:= (derives_using Γ ϕ pi)  (at level 95, no associativity).

Notation "Γ ⊢ ϕ" := (derives Γ ϕ)
(at level 95, no associativity).

Notation "'ExGen' ':=' evs ',' 'SVSubst' := svs ',' 'KT' := bkt ',' 'AKT' := akt"
  := (@mkProofInfo _ evs svs bkt akt) (at level 95, no associativity).

End Notations.

(* We cannot turn a proof into wellformedness hypotheses
   if there is a ProofLe hypothesis depending on the proof
  *)
Ltac2 clear_piles () :=
  repeat (
    lazy_match! goal with
    | [ h : @ProofInfoLe _ _ _ |- _]
      => clear $h
      | [ h : @ProofLe _ _ _ |- _]
      => clear $h
      | [ h : @ProofInfoMeaning _ _ _ _ _ |- _]
      => clear $h
    end
  )
.

Ltac2 pfs_to_wfs () :=
  repeat (
    match! goal with
    | [h : @derives _ _ _ |- _]
      => unfold derives
    | [h : @derives_using _ _ _ _ |- _]
      => apply @raw_proof_of in $h
    | [ h: @ML_proof_system _ _ _ |- _]
      => apply @proved_impl_wf in $h
    end
  ).

Ltac2 Set proved_hook_wfauto as oldhook
:= (fun () => (*Message.print (Message.of_string "hook_wfauto p2w");*) clear_piles (); pfs_to_wfs () (*; oldhook ()*)).

(*
Ltac2 Set hook_wfauto
:= (fun () => Message.print (Message.of_string "hook_wfauto p2w")).
*)

(** For goals shaped like ProoInforMeeaning _ _ _ BasicReasoning *)
Ltac solve_pim_simple := constructor; simpl;[(set_solver)|(set_solver)|(reflexivity)|(reflexivity)].

Import Notations.

Lemma useBasicReasoning {Σ : Signature} {Γ : Theory} {ϕ : Pattern} (i : ProofInfo) :
  Γ ⊢i ϕ using BasicReasoning ->
  Γ ⊢i ϕ using i.
Proof.
  intros H.
  pose proof (Hpf := proj2_sig H).
  remember (proj1_sig H) as _H.
  exists (_H).
  clear Heq_H.
  destruct Hpf as [Hpf1 Hpf2 Hpf3 Hpf4].
  destruct i; constructor; simpl in *;
  [set_solver|set_solver|idtac|idtac].
  {
    (destruct (uses_kt _H); simpl in *; try congruence).
  }
  {
    (destruct (uses_kt_unreasonably _H); simpl in *; try congruence).
  }
Defined.

Tactic Notation "remember_constraint" "as" ident(i') :=
    match goal with
    | [|- (_ ⊢i _ using ?constraint)] => remember constraint as i'
    end.

Lemma useGenericReasoning  {Σ : Signature} (Γ : Theory) (ϕ : Pattern) i' i:
  (ProofInfoLe i' i) ->
  Γ ⊢i ϕ using i' ->
  Γ ⊢i ϕ using i.
Proof.
  intros pile [pf Hpf].
  exists pf.

  destruct Hpf as [Hpf2 Hpf3 Hpf4 Hpf5].
  destruct i, i'; cbn in *.
  destruct pile as [H [H0 H1] ].
  constructor; simpl.
  { set_solver. }
  { set_solver. }
  { simpl in *. apply implb_true_iff.
    unfold is_true in *. rewrite implb_true_iff in Hpf4 H1.
    set_solver.
  }
  {
    simpl in *. apply implb_true_iff.
    unfold is_true in *. rewrite implb_true_iff in Hpf5 H1.
    destruct H1 as [H11 H12].
    rewrite implb_true_iff in H11.
    rewrite implb_true_iff in H12.
    intros H'.
    naive_solver.
  }
Defined.

Tactic Notation "gapply" uconstr(pf) := eapply useGenericReasoning;[|eapply pf].

Tactic Notation "gapply" uconstr(pf) "in" ident(H) :=
  eapply useGenericReasoning in H;[|apply pf].

Lemma pile_any {Σ : Signature} i:
  ProofInfoLe i AnyReasoning.
Proof.
  try_solve_pile.
Qed.

Tactic Notation "aapply" uconstr(pf)
  := gapply pf; try apply pile_any.

Lemma pile_basic_generic {Σ : Signature} i:
  ProofInfoLe BasicReasoning i.
Proof.
  try_solve_pile.
Qed.

Lemma pile_impl_allows_gen_x {Σ : Signature} x gpi svs kt:
  ProofInfoLe ( (ExGen := {[x]}, SVSubst := svs, KT := kt, AKT := false)) ( gpi) ->
  x ∈ pi_generalized_evars gpi.
Proof.
  destruct gpi. intro H.
  destruct_pile. set_solver.
Qed.

Lemma pile_impl_uses_kt {Σ : Signature} gpi evs svs:
  ProofInfoLe ( (ExGen := evs, SVSubst := svs, KT := true, AKT := false)) ( gpi) ->
  pi_uses_kt gpi.
Proof.
  destruct gpi. intro H.
  destruct_pile. set_solver.
Qed.

Lemma pile_impl_allows_svsubst_X {Σ : Signature} gpi evs X kt:
  ProofInfoLe ( (ExGen := evs, SVSubst := {[X]}, KT := kt, AKT := false)) ( gpi) ->
  X ∈ pi_substituted_svars gpi.
Proof.
  destruct gpi. intro H.
  destruct_pile. set_solver.
Qed.

Lemma liftProofLe {Σ : Signature} (Γ : Theory) (ϕ : Pattern) (i₁ i₂ : ProofInfo)
  {pile : ProofLe i₁ i₂}
  :
  Γ ⊢i ϕ using i₁ ->
  Γ ⊢i ϕ using i₂.
Proof.
    intros [pf Hpf].
    apply pile in Hpf.
    exists pf.
    exact Hpf.
Qed.

Lemma liftProofInfoLe {Σ : Signature} (Γ : Theory) (ϕ : Pattern) (i₁ i₂ : ProofInfo)
  {pile : ProofInfoLe i₁ i₂}
  :
  Γ ⊢i ϕ using i₁ ->
  Γ ⊢i ϕ using i₂.
Proof.
    intros H.
    eapply liftProofLe.
    apply ProofInfoLe_ProofLe.
    all: eassumption.
Qed.

Tactic Notation "use" constr(i) "in" ident(H) :=
  apply liftProofInfoLe with (i₂ := i) in H; [|try_solve_pile].

Close Scope ml_scope.


(************************************************************
* Core Caml                                                 *
* Syntax                                                    *
*************************************************************)

Set Implicit Arguments.
Require Export Common LibHeap.
Module Heap := LibHeap.HeapList.
Notation "x ~~ a" := (single x a)
  (at level 27, left associativity) : env_scope.

(*==========================================================*)
(* * Definitions *)

(************************************************************)
(* ** Auxiliary definitions for the syntax *)

(** Representation of record labels *)

Definition lab := var.

(** Representation of constructors *)

Definition constr := var.

(** Particular exceptions *)

Parameter constr_unit : constr.
Parameter constr_div_by_zero : constr.
Parameter constr_matching_failure : constr.
Parameter constr_assert_failure : constr.

(** Representation of locations *)

Definition loc := var.

(** Representation of the direction of a for-loop *)

Inductive dir : Type := dir_upto | dir_downto.

(** Grammar of primitive operators *)

Inductive prim : Type :=
  | prim_raise : prim
  | prim_eq : prim
  | prim_not : prim
  | prim_neg : prim
  | prim_add : prim
  | prim_sub : prim
  | prim_mul : prim
  | prim_div : prim
  | prim_and : prim
  | prim_or : prim.

(** Grammar of constants *)

Inductive cst : Type :=
  | cst_bool : bool -> cst
  | cst_int : int -> cst.

(** Grammar of patterns *)

Inductive pat : Type :=
  | pat_var : var -> pat
  | pat_wild : pat
  | pat_alias : pat -> var -> pat
  | pat_or : pat -> pat -> pat
  | pat_cst : cst -> pat
  | pat_constr : constr -> list pat -> pat
  | pat_tuple : list pat -> pat
  | pat_record : list (lab*pat) -> pat.

(** Grammar of terms *)

Inductive trm : Type :=
  | trm_var : var -> trm
  | trm_cst : cst -> trm
  | trm_abs : option var -> pat -> trm -> trm
  | trm_constr : constr -> list trm -> trm
  | trm_tuple : list trm -> trm
  | trm_record : list (lab*trm) -> trm
  | trm_unary : prim -> trm -> trm
  | trm_binary : prim -> trm -> trm -> trm
  | trm_lazy_binary : prim -> trm -> trm -> trm
  | trm_app : trm -> trm -> trm
  | trm_seq : trm -> trm -> trm
  | trm_let : pat -> trm -> trm -> trm
  | trm_get : trm -> lab -> trm
  | trm_set : trm -> lab -> trm -> trm
  | trm_if : trm -> trm -> option trm -> trm
  | trm_while : trm -> trm -> trm
  | trm_for : var -> dir -> trm -> trm -> trm -> trm
  | trm_match : trm -> list branch -> trm
  | trm_try : trm -> list branch -> trm
  | trm_assert : trm -> trm
  | trm_rand : trm

with branch : Type :=
  | branch_intro : pat -> option trm -> trm -> branch.

(** Grammar of values *)

Inductive val : Type :=
  | val_cst : cst -> val
  | val_loc : loc -> val
  | val_abs : option var -> pat -> trm -> val
  | val_constr : constr -> list val -> val
  | val_tuple : list val -> val
  | val_record : list (lab*val) -> val.

(** Representation of the memory store *)

Definition mem := Heap.heap loc val.

(************************************************************)
(* ** Auxiliary definitions *)

(** Substitution *)

Definition inst := LibEnv.env val.

Parameter subst : forall (x:var) (v:val) (t:trm), trm.
Parameter substs : forall (i:inst) (t:trm), trm.

(** [val] is inhabited *)

Instance val_inhab : Inhab val.
Proof. intros. apply (Inhab_of_val (val_cst (cst_bool true))). Qed.

(** Shortnames for lists of terms and values *)

Definition trms := list trm.
Definition vals := list val.
Definition labtrms := list (lab*trm).
Definition labvals := list (lab*val).
Definition branches := list branch.

(** Shortcuts for building terms and values *)

Definition val_exn k := val_constr k nil.

Definition val_unit := val_constr constr_unit nil.

(** Coercions *)

Coercion val_exn : constr >-> val.
Coercion cst_int : Z >-> cst.
Coercion cst_bool : bool >-> cst.
Coercion pat_var : var >-> pat.
Coercion val_loc : loc >-> val.
Coercion val_cst : cst >-> val.
Coercion trm_cst : cst >-> trm.

(** Fresh locations *)

Definition fresh (m:mem) l :=
  ~ Heap.indom m l.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal80.

From lfind Require Import LFind.
Lemma lfind_state  (y:lst):@eq lst y (append y Nil).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal80_theorem0_58_append_nil/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : lst -> string -> lst.
Extract Constant print => "Extract.print".
Definition collect_data  (y:lst) :=
 let lfind_var := "y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print y lfind_var
 in lfind_state lfind_v .
QuickChick collect_data.
Success.