(**
SimSoC-Cert, a toolkit for generating certified processor simulators.

See the COPYRIGHTS and LICENSE files.

Formalization of the ARM architecture version 6 following the:

ARM Architecture Reference Manual, Issue I, July 2005.

Page numbers refer to ARMv6.pdf.

Configuration of a ARM processor (IMPLEMENTATION DEFINED parameters).
*)

Set Implicit Arguments.

Require Import Integers Bitvec ZArith.
Import Int.

(****************************************************************************)
(** Architecture versions (p. 13) *)
(****************************************************************************)

Inductive version : Type :=
(* All architecture names prior to ARMv4 are now OBSOLETE *)
| ARMv4 | ARMv4T
| ARMv5T | ARMv5TExP (*for legacy reasons only*) | ARMv5TE | ARMv5TEJ
| ARMv6.

(****************************************************************************)
(** A2.4.3 Reading the program counter (p. 47) *)
(****************************************************************************)

Inductive store_PC_offset_value : Type := O8 | O12.

Definition word_of_store_PC_offset_value (v : store_PC_offset_value) : word :=
  match v with
    | O8 => repr 8
    | O12 => repr 12
  end.

(****************************************************************************)
(** A2.6.5 Abort models (p. 61) *)
(****************************************************************************)

Inductive abort_model : Type := Restored | Updated.

(****************************************************************************)
(** IMPLEMENTATION DEFINED parameters *)
(****************************************************************************)

Module Type CONFIG.

(*WARNING: only ARMv6 is supported currently

  (* Architecture versions (p. 13) *)
  Variable version : version.*)

(*WARNING: only O8 is supported currently

  (* A2.4.3 Reading the program counter (p. 47) *)
  Variable store_PC_offset : store_PC_offset_value.*)

(*WARNING: vectorized interrupts are not supported *)
  (* A2.6 Exceptions (p. 54) *)
  Variable VE_IRQ_address : word.
  Variable VE_FIQ_address : word.

(*WARNING: data aborts are not supported

  (* A2.6.5 Abort models (p. 61) *)
  (*Variable abort_model : abort_model.*)

  (* A2.6.7 Imprecise data aborts (p. 61) *)
  Variable imprecise_aborts_max : Z.*)

(*WARNING: high vectors are always supported in ARMv6

  (* A2.6.11 High Vectors (p. 64) *)
  Variable high_vectors_supported : bool.*)

(*WARNING: not supported

  (* A2.7.3 Endian configuration and control (p. 72) *)
  Variable BE32_support : bool.*)

(*WARNING: should be set to true, otherwise BKPT leaves the state
unchanged in the current semantics*)
  (* A4.1.7 BKPT (p. 164) *)
  Variable not_overridden_by_debug_hardware : bool.

(*WARNING: Jazelle instruction set not supported*)
  (* A4.1.11 BXJ (p. 172) *)
  Variable JE_bit_of_Main_Configuration_register : bool.
  Variable CV_bit_of_Jazelle_OS_Control_register : bool.
  Variable jpc_SUB_ARCHITECTURE_DEFINED_value : word.
  Variable invalidhandler_SUB_ARCHITECTURE_DEFINED_value : word.
  Variable Jazelle_Extension_accepts_opcode_at : word -> bool.
  Variable IMPLEMENTATION_DEFINED_CONDITION : bool.

End CONFIG.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal31.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (x:lst) (IHx:@eq lst (qreva (qreva x Nil) Nil) x):@eq lst (qreva (qreva x (Cons n Nil)) Nil) (Cons n x).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal31_qreva_qreva_67_qreva_nil/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
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 : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (x:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"x:" ++ "(" ++ show x ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  x.
QuickChick collect_data.
Success.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool eqtype seq.
Require Import ssrZ ZArith_ext seq_ext.
Require Import machine_int.
Import MachineInt.
Require Import mips_cmd mips_tactics mips_contrib uniq_tac.
Import expr_m.
Require Import multi_zero_u_prg.

Local Open Scope machine_int_scope.
Local Open Scope mips_expr_scope.
Local Open Scope mips_cmd_scope.

Lemma multi_zero_u_termination s h k z ext M_ :
  uniq (k :: z :: ext :: M_ :: r0 :: nil) ->
  { si | Some (s, h) -- multi_zero_u k z ext M_ ---> si }.
Proof.
move=> Hset; rewrite /multi_zero_u.
apply exists_addiu_seq.
rewrite sext_0 addi0.
apply exists_addiu_seq.
rewrite sext_0 addi0.
repeat Reg_upd.
set s0 := store.upd _ _ _.
have [next Hext] : { kext | u2Z [ext]_s0 = Z_of_nat kext }.
  have [zext Hext] : { zext | u2Z ([ext]_s0) = zext} by eapply exist; reflexivity.
  have : 0 <= zext by rewrite -Hext; apply min_u2Z.
  case/Z_of_nat_complete_inf => next Hzext.
  by exists next; rewrite -Hzext.
move: next s0 Hext h; elim.
- move=> s0 Hext h.
  eapply exist.
  apply while.exec_while_false => /=.
  by rewrite negbK store.get_r0 Z2uK // Hext.
- move=> next IH s0 Hext h; apply exists_while.
  + by rewrite /= store.get_r0 Z2uK // Hext.
  + apply exists_seq_P2 with (fun st => u2Z [ext]_(fst st) = Z_of_nat next).
    * exists_sw_P l Hl z0 Hz0.
      apply exists_addiu_seq_P.
      apply exists_addiu_P.
      rewrite /=.
      repeat Reg_upd.
      rewrite sext_Z2s // u2Z_add_Z2s // Hext Z_S -addZA /= addZC //=; by apply Zle_0_nat.
    * move=> [ si hi ] Hsi.
      by apply IH.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*          Jacques-Henri Jourdan, INRIA Paris-Rocquencourt            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Architecture-dependent parameters for PowerPC *)

Require Import ZArith.
Require Import Fappli_IEEE.
Require Import Fappli_IEEE_bits.

Definition ptr64 := false.

Definition big_endian := true.

Definition align_int64 := 8%Z.
Definition align_float64 := 8%Z.

(** Can we use the 64-bit extensions to the PowerPC architecture? *)
Parameter ppc64 : bool.

Definition splitlong := negb ppc64.

Lemma splitlong_ptr32: splitlong = true -> ptr64 = false.
Proof.
  reflexivity.
Qed.

Program Definition default_pl_64 : bool * nan_pl 53 :=
  (false, iter_nat 51 _ xO xH).

Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) :=
  false.                        (**r always choose first NaN *)

Program Definition default_pl_32 : bool * nan_pl 24 :=
  (false, iter_nat 22 _ xO xH).

Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) :=
  false.                        (**r always choose first NaN *)

Definition float_of_single_preserves_sNaN := true.

Global Opaque ptr64 big_endian splitlong
              default_pl_64 choose_binop_pl_64
              default_pl_32 choose_binop_pl_32
              float_of_single_preserves_sNaN.


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 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 FinProof.ProgrammingWith.

Require Import UMLang.UrsusLib.

Require Import UrsusStdLib.Cpp.stdTypes.
Require Import UrsusStdLib.Cpp.stdErrors.
Require Import UrsusStdLib.Cpp.stdFunc.
Require Import UrsusStdLib.Cpp.stdNotations.
Require Import UrsusStdLib.Cpp.stdUFunc.

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

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

(*Fully qualified name are mandatory in multi-contract environment*)
Require Import DFromGiver.Ledger.
Require Import DFromGiver.ClassTypesNotations.
Require Import DFromGiver.ClassTypes.
Require Import DFromGiver.Functions.FuncSig.
Require Import DFromGiver.Functions.FuncNotations.
Require Import DFromGiver.Functions.Funcs.

(* Require Import Blank.ClassTypesNotations. *)

Set Typeclasses Iterative Deepening.
(* Set Typeclasses Depth 100. *)

Import UrsusNotations.
Local Open Scope ursus_scope.
Local Open Scope ucpp_scope.
Local Open Scope struct_scope.
Local Open Scope N_scope.
Local Open Scope string_scope.
Local Open Scope xlist_scope.

(* Require Import Logic.FunctionalExtensionality.
From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Open Scope qc_scope.
Import GenLow GenHigh.
Set Warnings "-extraction-opaque-accessed,-extraction".
 *)
Require Import Project.CommonQCEnvironment.
(* Require Import DFromGiver.QuickChicks.QCEnvironment.
 *)
Definition UinterpreterL := @Uinterpreter XBool XUInteger XMaybe XList XProd XHMap _ _ _ _ _ _
                             LedgerLRecord ContractLRecord LocalStateLRecord VMStateLRecord
                             MessagesAndEventsLRecord GlobalParamsLRecord
                             OutgoingMessageParamsLRecord ledgerClass .
Arguments UinterpreterL {_} {_} {_}.

Definition ledger_prop1 (l: LedgerLRecord) := true.

(* Set Typeclasses Debug. *)

(* Time QuickChick ledger_prop1.*)

Import FinProof.Common.  (*for eqb!!!*)
Require Import FinProof.CommonInstances.

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

(* ---------------------------------------------*)
Notation ControlResult := (@ControlResultL) .
Definition isError {R b} (cr : ControlResult R b) : bool :=
 match cr with
 | ControlValue _ _ => false
 | _ => true
 end.
 *)(* ---------------------------------------------*)
(* constructor *)
(* #[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.
 *)
Definition MessagesAndEventsDefault : MessagesAndEventsLRecord:= Eval compute in default.
Definition VMStateDefault : VMStateLRecord  := Eval compute in default.

Definition constructor_requires  (GFM :  uint128)
(lock_time :  XUInteger32 ) (unlock_time :  XUInteger32 )
                           ( l: LedgerLRecord )  : Prop :=
let fund_address := toValue (eval_state (sRReader || fund_address_  || ) l) in
let intS := toValue (eval_state (sRReader || int_sender () || ) l) in
let tn := toValue (eval_state (sRReader || tvm_now () || ) l) in
let require1 := ( intS) <> ( fund_address) in
let require2 := ( fund_address = default ) in
let require3 :=  (uint2N tn >= uint2N lock_time)  in
let require4 :=  (uint2N lock_time >= uint2N unlock_time)  in
 require1 \/ require2  \/ require3 \/ require4.

Definition constructor_isError_prop (GFM :  uint128)
(lock_time :  XUInteger32 ) (unlock_time :  XUInteger32 )
                           ( l: LedgerLRecord )  : Prop :=
isError (eval_state (UinterpreterL (constructor_   (KWMessages_ι_GAS_FOR_FUND_MESSAGE_:= GFM) lock_time unlock_time )) l)
<-> constructor_requires GFM lock_time unlock_time l.

 Definition constructor_exec_prop
 (GFM :  uint128)
 (lock_time :  XUInteger32 ) (unlock_time :  XUInteger32 )
 ( l: LedgerLRecord )  : Prop :=
let l' := exec_state (UinterpreterL (constructor_   (KWMessages_ι_GAS_FOR_FUND_MESSAGE_:= GFM) lock_time unlock_time)) l in
let mm := toValue (eval_state (sRReader IBlankPtr_messages_right ) l') in
let a := toValue (eval_state (sRReader || fund_address_ || ) l) in
let non := toValue (eval_state (sRReader || nonce_ || ) l) in
let giver_address := toValue (eval_state (sRReader || giver_address_ || ) l) in
let params:InternalMessageParamsLRecord := (GFM, (true, Build_XUBInteger 1)) in
let func: Interfaces.IBlank.IBlank.Interface.IBlank :=
          Interfaces.IBlank.IBlank.Interface.IacknowledgeDeploy giver_address non in
let message := OutgoingInternalMessage params func in
let ms := isMessageSent message a 0 mm             in
( ~ (constructor_requires GFM lock_time unlock_time l)  ) ->
(uint2N (toValue (eval_state (sRReader || balance_ || ) l')) =  0  /\
 (toValue (eval_state (sRReader || fund_ready_flag_ || ) l')) =  false /\
uint2N (toValue (eval_state (sRReader || lock_time_ || ) l')) =  uint2N  lock_time /\
uint2N (toValue (eval_state (sRReader || unlock_time_ || ) l')) =  uint2N  unlock_time
 /\ VMState_ι_accepted (Ledger_VMState l') = true
 /\ ms = true ).

 Definition constructor_noexec_prop
 (GFM :  uint128)
 (lock_time :  XUInteger32 ) (unlock_time :  XUInteger32 )
 (l: LedgerLRecord )  : Prop :=
let l' := exec_state (UinterpreterL (constructor_  (KWMessages_ι_GAS_FOR_FUND_MESSAGE_:= GFM) lock_time unlock_time)) l in
constructor_requires GFM lock_time unlock_time l ->
Ledger_MainState l = Ledger_MainState l'.

(* ---------------------------------- *)
(* receive *)
Definition receive_requires (MB : uint128) ( GFM  : uint128) (  EB : uint128)
                           ( l: LedgerLRecord )  : Prop :=
let mv := toValue (eval_state (sRReader || int_value() || ) l) in
let intS := toValue (eval_state (sRReader || int_sender() || ) l) in
let tb := toValue (eval_state (sRReader || tvm_balance() || ) l) in
let tn := toValue (eval_state (sRReader || tvm_now() || ) l) in
let lock_time := toValue (eval_state (sRReader || lock_time_ || ) l) in
let giver_address := toValue (eval_state (sRReader || giver_address_ || ) l) in
let balance := toValue (eval_state (sRReader || balance_ || ) l) in

let if1 := uint2N mv > uint2N MB in
let require1 := intS <> giver_address in
let require2 :=  uint2N tn >= uint2N lock_time in
let require3 :=  uint2N tb <= uint2N mv + uint2N balance + (uint2N GFM + uint2N EB) in
if1 /\ (require1 \/ require2 \/ require3).

Definition receive_isError_prop (MB : uint128) ( GFM  : uint128) (  EB : uint128)
                           ( l: LedgerLRecord )  : Prop :=
isError (eval_state (UinterpreterL (receive_ ( KWMessages_ι_FG_MIN_BALANCE_ := MB) (KWMessages_ι_GAS_FOR_FUND_MESSAGE_ := GFM) (KWMessages_ι_EPSILON_BALANCE_ := EB) )) l)
 <->  (receive_requires MB GFM EB l) .

Definition receive_exec_prop
(MB : uint128) ( GFM  : uint128) (  EB : uint128)
                             ( l: LedgerLRecord )  : Prop :=
let l' := exec_state (UinterpreterL (receive_  ( KWMessages_ι_FG_MIN_BALANCE_ := MB) (KWMessages_ι_GAS_FOR_FUND_MESSAGE_ := GFM) (KWMessages_ι_EPSILON_BALANCE_ := EB) )) l in

let mv := toValue (eval_state (sRReader || int_value() || ) l) in
let balance := toValue (eval_state (sRReader || balance_ || ) l) in
let mm := toValue (eval_state (sRReader IBlankPtr_messages_right ) l') in
let a := toValue (eval_state (sRReader || fund_address_ || ) l) in
let non := toValue (eval_state (sRReader || nonce_ || ) l) in
let giver_address := toValue (eval_state (sRReader || giver_address_ || ) l) in
let params:InternalMessageParamsLRecord := (GFM, (true, Build_XUBInteger 1)) in
let func: Interfaces.IBlank.IBlank.Interface.IBlank :=
          Interfaces.IBlank.IBlank.Interface.InotifyRight giver_address non balance mv in
let message := OutgoingInternalMessage params func in
let ms := isMessageSent message a 0 mm             in

( uint2N mv > uint2N MB ) /\ (~ (receive_requires  MB GFM EB l)) ->
VMState_ι_accepted (Ledger_VMState l') = true
 /\ ms = true
 /\ uint2N (toValue (eval_state (sRReader || balance_ || ) l')) = uint2N balance + uint2N mv.

Definition receive_noexec_prop
(MB : uint128) ( GFM  : uint128) (  EB : uint128)
                             ( l: LedgerLRecord )  : Prop :=
let l' := exec_state (UinterpreterL (receive_  ( KWMessages_ι_FG_MIN_BALANCE_ := MB) (KWMessages_ι_GAS_FOR_FUND_MESSAGE_ := GFM) (KWMessages_ι_EPSILON_BALANCE_ := EB) )) l in
(receive_requires MB GFM EB l) ->
Ledger_MainState l = Ledger_MainState l'.

(* ---------------------------------- *)
(* notifyParticipant *)
Definition notifyParticipant_requires (  EB : uint128)  (giveup :  boolean  ) (investors_adj_summa_ :  uint128 ) (summa_givers :  uint128 )
                           ( l: LedgerLRecord )  : Prop :=
let ms := toValue (eval_state (sRReader || int_sender() || ) l) in
let tn := toValue (eval_state (sRReader || tvm_now () || ) l) in
let fa := toValue (eval_state (sRReader || fund_address_ || ) l) in
let lock_time := toValue (eval_state (sRReader || lock_time_ || ) l) in
let unlock_time := toValue (eval_state (sRReader || unlock_time_ || ) l) in
let fund_ready_flag := toValue (eval_state (sRReader || fund_ready_flag_ || ) l) in
let balance := toValue (eval_state (sRReader || balance_ || ) l) in
let intValue := toValue (eval_state (sRReader || int_value() || ) l) in
let tb := toValue (eval_state (sRReader || tvm_balance() || ) l) in

let require1 := ms <> fa in
let require2 :=  (((uint2N tn) < (uint2N lock_time)) \/ ((uint2N tn) > (uint2N unlock_time))) in
let require3 := fund_ready_flag = true in
let require4 :=  (uint2N tb) < (( uint2N intValue) + (uint2N balance) + (uint2N EB)) in
require1 \/ require2 \/ require3 \/ require4.

Definition notifyParticipant_isError_prop (  EB : uint128)  (giveup :  boolean  ) (investors_adj_summa_ :  uint128 ) (summa_givers :  uint128 )
                           ( l: LedgerLRecord )  : Prop :=
isError (eval_state (UinterpreterL (notifyParticipant_ (KWMessages_ι_EPSILON_BALANCE_ := EB)  giveup investors_adj_summa_ summa_givers )) l)
 <->  (notifyParticipant_requires EB giveup investors_adj_summa_ summa_givers l) .

Definition notifyParticipant_exec_prop
(  EB : uint128)  (giveup :  boolean  ) (investors_adj_summa_ :  uint128 ) (summa_givers :  uint128 )
                             ( l: LedgerLRecord )  : Prop :=
let l' := exec_state (UinterpreterL (notifyParticipant_  (KWMessages_ι_EPSILON_BALANCE_ := EB)  giveup investors_adj_summa_ summa_givers )) l in
let mm := toValue (eval_state (sRReader IBlankPtr_messages_right ) l') in
let intValue := toValue (eval_state (sRReader || int_value() || ) l) in
let fund_address := toValue (eval_state (sRReader || fund_address_ || ) l) in
let giver_address := toValue (eval_state (sRReader || giver_address_ || ) l) in
let non := toValue (eval_state (sRReader || nonce_ || ) l) in
let balance := toValue (eval_state (sRReader || balance_ || ) l) in
let balance' := toValue (eval_state (sRReader || balance_ || ) l') in
let dead_giver := ( (* giveup  \\ *) (N.eqb (uint2N balance)   0 ) ) in
let params:InternalMessageParamsLRecord := (intValue, (true, Build_XUBInteger 1)) in
let func: Interfaces.IBlank.IBlank.Interface.IBlank :=
          Interfaces.IBlank.IBlank.Interface.IacknowledgeFinalizeRight giver_address non dead_giver in
let message := OutgoingInternalMessage params func in
let ms := isMessageSent message fund_address 0 mm             in
let mm2 : XHMap address (XQueue (OutgoingMessage PhantomType)) := toValue (eval_state (sRReader IDefaultPtr_messages_right ) l') in
let params2 : InternalMessageParamsLRecord := ( balance, (true, Build_XUBInteger 1)) in
let message2 := EmptyMessage PhantomType params2 in
let ms2 := isMessageSent message2 giver_address 0 mm2 in
let flag := N.lor (N.lor (N.lor (uint2N SEND_ALL_GAS) (uint2N SENDER_WANTS_TO_PAY_FEES_SEPARATELY))
                 (uint2N DELETE_ME_IF_I_AM_EMPTY))
						     (uint2N IGNORE_ACTION_ERRORS) in
let params3:InternalMessageParamsLRecord := (Build_XUBInteger 0, (false, Build_XUBInteger flag)) in
let message3 := EmptyMessage _ params3 in
let ms3 := isMessageSent message3 fund_address 0 mm2 in
let extra := (* Build_XUBInteger *) ((uint2N balance) * ((uint2N  summa_givers) - (uint2N investors_adj_summa_)) / (uint2N summa_givers) ) in
let params4 : InternalMessageParamsLRecord := ( (Build_XUBInteger extra), (true, Build_XUBInteger 1)) in
let message4 := EmptyMessage PhantomType params4 in
let ms4 := isMessageSent message4 giver_address 0 mm2 in

(~ (notifyParticipant_requires  EB giveup investors_adj_summa_ summa_givers l)) ->
VMState_ι_accepted (Ledger_VMState l') = true
/\ ms = true
/\ ((giveup = true) ->
               ((uint2N  balance > 0)  -> (ms2 = true))
               /\  VMState_ι_isTVMExited (Ledger_VMState l') = true
                                                /\ ms3 = true)
/\ ((giveup  = false ) ->
               (toValue (eval_state (sRReader || fund_ready_flag_ || ) l') = true)
               /\ (((uint2N summa_givers) > (uint2N  investors_adj_summa_) )  ->
                                                                        (* (let extra := (* Build_XUBInteger *) ((uint2N balance) * ((uint2N investors_adj_summa_) - (uint2N summa_givers)) / (uint2N investors_adj_summa_) ) in *)
                                                                      (((uint2N balance') = (uint2N balance) - ( extra) )
                                                                      /\ ms4 = true
                                                                      /\ ((  ( uint2N balance) = 0  ) -> ms3 =true)
                                                                      ))).

Definition notifyParticipant_noexec_prop
(  EB : uint128)  (giveup :  boolean  ) (investors_adj_summa_ :  uint128 ) (summa_givers :  uint128 )
                             ( l: LedgerLRecord )  : Prop :=
let l' := exec_state (UinterpreterL (notifyParticipant_  (KWMessages_ι_EPSILON_BALANCE_ := EB)  giveup investors_adj_summa_ summa_givers )) l in
(notifyParticipant_requires EB giveup investors_adj_summa_ summa_givers l) ->
Ledger_MainState l = Ledger_MainState l'.

(* ---------------------------------- *)
(* returnFunds *)
Definition returnFunds_requires (  EB : uint128)
                           ( l: LedgerLRecord )  : Prop :=
let tb := toValue (eval_state (sRReader || tvm_balance () || ) l) in
let tn := toValue (eval_state (sRReader || tvm_now() || ) l) in
let unlock_time := toValue (eval_state (sRReader || unlock_time_ || ) l) in
let require1 := ((uint2N tn) <= (uint2N unlock_time))  in
let require2 := (uint2N tb < uint2N EB) in
require1 \/ require2.

Definition returnFunds_isError_prop (  EB : uint128)
                           ( l: LedgerLRecord )  : Prop :=
isError (eval_state (UinterpreterL (returnFunds_  (KWMessages_ι_EPSILON_BALANCE_ := EB)   )) l)
 <->  (returnFunds_requires  EB   l) .

Definition returnFunds_exec_prop
(  EB : uint128)
                             ( l: LedgerLRecord )  : Prop :=
let l' := exec_state (UinterpreterL (returnFunds_   (KWMessages_ι_EPSILON_BALANCE_ := EB)   )) l in
let balance := toValue (eval_state (sRReader || balance_ || ) l) in
let giver_address := toValue (eval_state (sRReader || giver_address_ || ) l) in
let fund_address := toValue (eval_state (sRReader || fund_address_ || ) l) in
let mm : XHMap address (XQueue (OutgoingMessage PhantomType)) := toValue (eval_state (sRReader IDefaultPtr_messages_right ) l') in
let params : InternalMessageParamsLRecord := ( balance, (true, Build_XUBInteger 1)) in
let message := EmptyMessage PhantomType params in
let ms := isMessageSent message giver_address 0 mm in
let flag := N.lor (N.lor (N.lor (uint2N SEND_ALL_GAS) (uint2N SENDER_WANTS_TO_PAY_FEES_SEPARATELY))
                 (uint2N DELETE_ME_IF_I_AM_EMPTY))
						     (uint2N IGNORE_ACTION_ERRORS) in
let params2:InternalMessageParamsLRecord := (Build_XUBInteger 0, (false, Build_XUBInteger flag)) in
let message2 := EmptyMessage _ params2 in
let ms2 := isMessageSent message2 fund_address 0 mm in
(~ (returnFunds_requires   EB   l)) ->
VMState_ι_accepted (Ledger_VMState l') = true
/\ ms2 = true
/\ ((uint2N balance > 0) -> ms = true).

Definition returnFunds_noexec_prop
(  EB : uint128)
                             ( l: LedgerLRecord )  : Prop :=
let l' := exec_state (UinterpreterL (returnFunds_   (KWMessages_ι_EPSILON_BALANCE_ := EB)   )) l in
(returnFunds_requires  EB   l) ->
Ledger_MainState l = Ledger_MainState l'.

(* ---------------------------------- *)
(* acknowledgeFunds *)
Definition acknowledgeFunds_requires
                           ( l: LedgerLRecord )  : Prop :=
let ms := toValue (eval_state (sRReader || int_sender() || ) l) in
let fa := toValue (eval_state (sRReader || fund_address_ || ) l) in
let require := ms <> fa in
require.

Definition acknowledgeFunds_isError_prop
                           ( l: LedgerLRecord )  : Prop :=
isError (eval_state (UinterpreterL (acknowledgeFunds_    )) l)
 <->  (acknowledgeFunds_requires    l) .

Definition acknowledgeFunds_exec_prop
                             ( l: LedgerLRecord )  : Prop :=
let l' := exec_state (UinterpreterL (acknowledgeFunds_     )) l in
let intS := toValue (eval_state (sRReader || int_sender() || ) l) in
let intV := toValue (eval_state (sRReader || int_value() || ) l) in
let fund_address := toValue (eval_state (sRReader || fund_address_ || ) l) in
let mm : XHMap address (XQueue (OutgoingMessage PhantomType)) := toValue (eval_state (sRReader IDefaultPtr_messages_right ) l') in
let params : InternalMessageParamsLRecord := ( intV, (false, Build_XUBInteger 1)) in
let message := EmptyMessage PhantomType params in
let ms := isMessageSent message intS 0 mm in
let flag := N.lor (N.lor (N.lor (uint2N SEND_ALL_GAS) (uint2N SENDER_WANTS_TO_PAY_FEES_SEPARATELY))
                 (uint2N DELETE_ME_IF_I_AM_EMPTY))
						     (uint2N IGNORE_ACTION_ERRORS) in
let params2:InternalMessageParamsLRecord := (Build_XUBInteger 0, (false, Build_XUBInteger flag)) in
let message2 := EmptyMessage _ params2 in
let ms2 := isMessageSent message2 fund_address 0 mm in
(~ (acknowledgeFunds_requires    l)) ->
(VMState_ι_accepted (Ledger_VMState l') = true
/\ ms = true
/\ ms2 = true).

Definition acknowledgeFunds_noexec_prop
                             ( l: LedgerLRecord )  : Prop :=
let l' := exec_state (UinterpreterL (acknowledgeFunds_     )) l in
(acknowledgeFunds_requires    l) ->
Ledger_MainState l = Ledger_MainState l'.

(* ---------------------------------- *)
(* sendFunds *)
Definition sendFunds_requires (EB: uint128) (NO_NAME0 :  cell_  )
                           ( l: LedgerLRecord )  : Prop :=

let ms := toValue (eval_state (sRReader || int_sender() || ) l) in
let fa := toValue (eval_state (sRReader || fund_address_ || ) l) in
let myaddr := toValue (eval_state (sRReader || tvm_myaddr() || ) l) in
let fund_ready_flag := toValue (eval_state (sRReader || fund_ready_flag_ || ) l) in
let tb := toValue (eval_state (sRReader || tvm_balance() || ) l) in
let intV := toValue (eval_state (sRReader || int_value() || ) l) in
let balance := toValue (eval_state (sRReader || balance_ || ) l) in

let require1 := ms <> fa in
(* let require2 := address_to = myaddr in
 *)let require3 := fund_ready_flag = false in
let require4 := (uint2N tb) <  (uint2N intV) + (uint2N balance) + (uint2N EB) in
require1 (* \/ require2 *) \/ require3 \/ require4.
Definition sendFunds_isError_prop (EB: uint128) (NO_NAME0 :  cell_  )
                           ( l: LedgerLRecord )  : Prop :=
isError (eval_state (UinterpreterL (sendFunds_  (KWMessages_ι_EPSILON_BALANCE_ := EB) NO_NAME0 )) l)
 <->  (sendFunds_requires  EB NO_NAME0  l) .

Definition sendFunds_exec_prop (EB: uint128) (NO_NAME0 :  cell_  )
                             ( l: LedgerLRecord )  : Prop :=
let l' := exec_state (UinterpreterL (sendFunds_  (KWMessages_ι_EPSILON_BALANCE_ := EB) NO_NAME0   )) l in
let intV := toValue (eval_state (sRReader || int_value() || ) l) in
let balance := toValue (eval_state (sRReader || balance_ || ) l) in
let non := toValue (eval_state (sRReader || nonce_ || ) l) in
let giver_address := toValue (eval_state (sRReader || giver_address_ || ) l) in

let mm := toValue (eval_state (sRReader IKWFundPtr_messages_right ) l') in
let fund_address := toValue (eval_state (sRReader || fund_address_ || ) l) in
let packParams_eval := toValue (eval_state (Uinterpreter ( packParams_  ) ) l) in
let mvalue := Build_XUBInteger ((uint2N balance) + (uint2N intV)) in
let params:InternalMessageParamsLRecord := (mvalue, (true, Build_XUBInteger 1)) in
let func: Interfaces.IKWFund.IKWFund.Interface.IKWFund :=
          Interfaces.IKWFund.IKWFund.Interface.IsendFromGiverParams giver_address non packParams_eval in
let message := OutgoingInternalMessage params func in
let ms := isMessageSent message fund_address 0 mm             in
(~ (sendFunds_requires  EB  NO_NAME0 l)) ->
(VMState_ι_accepted (Ledger_VMState l') = true
 /\ ms = true ).

Definition sendFunds_noexec_prop (EB: uint128) (NO_NAME0 :  cell_  )
                             ( l: LedgerLRecord )  : Prop :=
let l' := exec_state (UinterpreterL (sendFunds_  (KWMessages_ι_EPSILON_BALANCE_ := EB) NO_NAME0   )) l in
(sendFunds_requires EB  NO_NAME0  l) ->
Ledger_MainState l = Ledger_MainState l'.


Require Import Leapfrog.Benchmarks.ProofHeader.
Require Import Leapfrog.Benchmarks.Timestamp.

Notation H := (TimestampRefZeroSingle.header + TimestampSpecSingle.header).
Notation A := (Sum.sum TimestampRefZeroSingle.aut TimestampSpecSingle.aut).
Notation conf := (P4automaton.configuration (P4A.interp A)).
Notation start_left := TimestampRefZeroSingle.Start.
Notation start_right := TimestampSpecSingle.Start.

Definition r_states : {r : Reachability.state_pairs A & Reachability.reachable_states_wit start_left start_right r}.
  econstructor.
  unfold Reachability.reachable_states_wit.
  solve_fp_wit.
Defined.

(* Definition r_len := Eval vm_compute in (length r_states).

Print r_len. *)

Declare ML Module "mirrorsolve".

(*
RegisterEnvCtors
  (TimestampRefZeroSingle.Typ, FirstOrderConfRelSimplified.Bits 8)
  (TimestampRefZeroSingle.Len, FirstOrderConfRelSimplified.Bits 8)
  (TimestampRefZeroSingle.Value, FirstOrderConfRelSimplified.Bits 48)
  (TimestampRefZeroSingle.Scratch8, FirstOrderConfRelSimplified.Bits 8)
  (TimestampRefZeroSingle.Scratch16, FirstOrderConfRelSimplified.Bits 16)
  (TimestampRefZeroSingle.Scratch24, FirstOrderConfRelSimplified.Bits 24)
  (TimestampRefZeroSingle.Scratch32, FirstOrderConfRelSimplified.Bits 32)
  (TimestampRefZeroSingle.Scratch40, FirstOrderConfRelSimplified.Bits 40)
  (TimestampSpecSingle.Typ, FirstOrderConfRelSimplified.Bits 8)
  (TimestampSpecSingle.Len, FirstOrderConfRelSimplified.Bits 8)
  (TimestampSpecSingle.Scratch8, FirstOrderConfRelSimplified.Bits 8)
  (TimestampSpecSingle.Scratch16, FirstOrderConfRelSimplified.Bits 16)
  (TimestampSpecSingle.Scratch24, FirstOrderConfRelSimplified.Bits 24)
  (TimestampSpecSingle.Scratch32, FirstOrderConfRelSimplified.Bits 32)
  (TimestampSpecSingle.Scratch40, FirstOrderConfRelSimplified.Bits 40)
  (TimestampSpecSingle.Scratch48, FirstOrderConfRelSimplified.Bits 48)
  (TimestampSpecSingle.Pointer, FirstOrderConfRelSimplified.Bits 8)
  (TimestampSpecSingle.Overflow, FirstOrderConfRelSimplified.Bits 4)
  (TimestampSpecSingle.Flag, FirstOrderConfRelSimplified.Bits 4)
  (TimestampSpecSingle.Timestamp, FirstOrderConfRelSimplified.Bits 32).
*)

  Lemma prebisim_incremental_sep:
  forall q1 q2,
    interp_conf_rel' {| cr_st := {|
                        cs_st1 := {|
                          st_state := inl (inl (start_left));
                          st_buf_len := 0;
                        |};
                        cs_st2 := {|
                          st_state := inl (inr (start_right));
                          st_buf_len := 0;
                        |};
                      |};
                      cr_ctx := BCEmp;
                      cr_rel := btrue;
                   |} q1 q2 ->
  pre_bisimulation A
                   (projT1 r_states)
                   (wp (a := A))
                   []
                   (mk_init _ _ _ _ A start_left start_right)
                   q1 q2.
Proof.
  idtac "running timestamp single bisimulation".

  intros.
  set (a := A).
  set (rel0 := (mk_init _ _ _ _ _ _ _ _)).
  vm_compute in rel0.
  subst rel0.

  set (eight := 8).
  assert (H8 : 8 = eight); [subst eight; reflexivity|].
  set (sixteen := (Datatypes.S( Datatypes.S( Datatypes.S( Datatypes.S( Datatypes.S( Datatypes.S( Datatypes.S( Datatypes.S eight))))))))).
  assert (H16 : (Datatypes.S( Datatypes.S( Datatypes.S( Datatypes.S( Datatypes.S( Datatypes.S( Datatypes.S( Datatypes.S eight)))))))) = sixteen); [subst sixteen; reflexivity|].

  try rewrite H8;
  try rewrite H16;

  match goal with
  | |- pre_bisimulation _ _ _ _ ?R _ _ =>
    hashcons_list R
  end.

  time "build phase" repeat (run_bisim top top' r_states;
    try rewrite H8;
    try rewrite H16;
    try match goal with
    | |- pre_bisimulation _ _ _ (?N :: ?N' :: ?T) _ _ _  =>
      let rs := fresh "rs" in
      set (rs := N' :: T);
      let r := fresh "r" in
      set (r := N)

    | |- pre_bisimulation _ _ _ (?N :: nil) _ _ _  =>
      let r := fresh "r" in
      set (r := N)
    end
  ).
  time "close phase" close_bisim top'.

Time Admitted.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                          Lemmas_Comb_Behaviour.v                         *)
(****************************************************************************)

Require Export ElementComb_Behaviour.
Require Export SuccessfulInput.
Require Export Base_Struct.
Require Export Lemmas_on_fcts.
Require Export Lemmas_Struct.
Require Export ElementComb.

Set Implicit Arguments.
Unset Strict Implicit.

Definition Grant_for_Out (ltReq : d_list bool 4) (last : d_list bool 2) :=
  Convert_port_list2 (SuccessfulInput ltReq (Convert_list2_port last)).

Lemma Arbiter_last_tt :
 forall l : d_list bool 4,
 Ackor l = true ->
 Fst_of_l2 (Grant_for_Out l (List2 true true)) =
 Jk (Arb_xel (Scd_of_l4 l) true (Fth_of_l4 l) (Thd_of_l4 l))
   (Scd_of_l2 (Arbx true l)) true /\
 Scd_of_l2 (Grant_for_Out l (List2 true true)) =
 Jk (J_Arby true l) (Scd_of_l2 (Arby true l)) true.
intros l H.
unfold Grant_for_Out in |- *.
unfold SuccessfulInput in |- *.
rewrite RoundRobinArbiter_simpl.
unfold RoundRobin in |- *.
unfold Convert_list2_port in |- *; simpl in |- *.
elim
 (In_or_not eq_nat_dec
    (no_in (SUC_MODN (exist (fun p : nat => p < 4) 3 lt_3_4)))
    (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))));
 simpl in |- *.
intros H'.
unfold SUC_MODN in |- *;
 elim (less_or_eq (exist (fun p : nat => p < 4) 3 lt_3_4));
 simpl in |- *; auto.
intros Abs; absurd (4 < 4); auto with arith.
intros y'.
unfold Arbx in |- *.
unfold Arby in |- *.
unfold K_Arby in |- *.
unfold Scd_of_l2 in |- *; unfold List2 in |- *; unfold Arb_xel in |- *;
 simpl in |- *.
unfold Arb_yel in |- *.
rewrite d_In_SUC_SSSO_l4.
unfold AO in |- *; simpl in |- *.
elim orb_sym; auto.
auto.
intro non.
unfold Arbx in |- *.
unfold Arby in |- *.
unfold K_Arby in |- *.
unfold Scd_of_l2 in |- *; unfold List2 in |- *; unfold Arb_xel in |- *;
 simpl in |- *.
unfold Arb_yel in |- *.
rewrite not_d_In_SUC_SSSO_l4.
unfold AO in |- *; simpl in |- *.
elim orb_sym; simpl in |- *.
clear non.
elim
 (In_or_not eq_nat_dec
    (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 3 lt_3_4))))
    (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))));
 simpl in |- *.
intro H'.
unfold SUC_MODN in |- *;
 elim (less_or_eq (exist (fun p : nat => p < 4) 3 lt_3_4));
 simpl in |- *; auto.
intros Abs; absurd (4 < 4); auto with arith.
intro y'.
unfold SUC_MODN in |- *;
 elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen y')));
 simpl in |- *; auto.
intro y''.
rewrite d_In_SUCSUC_SSSO_l4.
simpl in |- *; auto.
auto.
intro Abs; absurd (1 = 4); auto.
intro non.
rewrite not_d_In_SUCSUC_SSSO_l4.
clear non.
elim
 (In_or_not eq_nat_dec
    (no_in
       (SUC_MODN
          (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 3 lt_3_4)))))
    (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))));
 simpl in |- *.
intros H'.
unfold SUC_MODN at 3 6 in |- *;
 elim (less_or_eq (exist (fun p : nat => p < 4) 3 lt_3_4));
 simpl in |- *; auto.
intro Abs; absurd (4 < 4); auto with arith.
intro y'.
unfold SUC_MODN at 2 4 in |- *;
 elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen y')));
 simpl in |- *; auto.
intro y''.
unfold SUC_MODN in |- *;
 elim (less_or_eq (exist (fun n : nat => n < 4) 1 y''));
 simpl in |- *; auto.
rewrite d_In_SUCSUCSUC_SSSO_l4.
intro y.
elim (less_or_eq (exist (fun p : nat => p < 4) 3 lt_3_4)); simpl in |- *.
intro Abs; absurd (4 < 4); auto with arith.
intro b.
elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen b)));
 simpl in |- *.
intro a; elim (less_or_eq (exist (fun n : nat => n < 4) 1 a)); simpl in |- *.
auto.
intro Abs; absurd (2 = 4); auto.
intro Abs; absurd (1 = 4); auto.
trivial.
intro Abs; absurd (2 = 4); auto.
intro Abs; absurd (1 = 4); auto.
intros.
rewrite not_d_In_SUCSUCSUC_SSSO_l4.
simpl in |- *.
elim
 (In_or_not eq_nat_dec
    (no_in
       (SUC_MODN
          (SUC_MODN
             (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 3 lt_3_4))))))
    (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))));
 simpl in |- *.
intros H'.
unfold Convert_port_list2 in |- *.
generalize eq_n_SM4_4_times; unfold SM4 in |- *; intros Sm4.
elim (Sm4 (exist (fun p : nat => p < 4) 3 lt_3_4)).
auto.
unfold SUC_MODN at 4 8 12 in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 3 lt_3_4)); simpl in |- *.
intro Abs; absurd (4 < 4); auto with arith.
intro b0.
intro.
unfold SUC_MODN at 3 6 in |- *; simpl in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen b0)));
 simpl in |- *.
intro a.
unfold SUC_MODN at 2 4 in |- *; simpl in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 1 a)); simpl in |- *.
intro a0.
unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 2 a0)); simpl in |- *.
auto.
intro Abs; absurd (3 = 4); auto.
intro Abs; absurd (2 = 4); auto.
intro Abs; absurd (1 = 4); auto.
auto.
auto.
auto.
auto.
Qed.

Lemma Arbiter_last_tf :
 forall l : d_list bool 4,
 Ackor l = true ->
 Fst_of_l2 (Grant_for_Out l (List2 true false)) =
 Jk (Arb_xel (Scd_of_l4 l) false (Fth_of_l4 l) (Thd_of_l4 l))
   (Scd_of_l2 (Arbx false l)) true /\
 Scd_of_l2 (Grant_for_Out l (List2 true false)) =
 Jk (J_Arby true l) (Scd_of_l2 (Arby true l)) false.
intros l H.
unfold Grant_for_Out in |- *.
unfold SuccessfulInput in |- *.
rewrite RoundRobinArbiter_simpl.
unfold RoundRobin in |- *.
unfold Convert_list2_port in |- *; simpl in |- *.
elim
 (In_or_not eq_nat_dec
    (no_in (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4)))
    (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))));
 simpl in |- *.
intro H'.
unfold SUC_MODN in |- *;
 elim (less_or_eq (exist (fun p : nat => p < 4) 2 lt_2_4));
 simpl in |- *; auto.
intro y'.
  unfold Arbx in |- *; unfold J_Arby in |- *.
rewrite d_In_SUC_SSO_l4.
auto.
auto.
intro Abs; absurd (3 = 4); auto.
intro non.
  unfold Arbx in |- *; unfold J_Arby in |- *.
rewrite not_d_In_SUC_SSO_l4.
clear non.
elim
 (In_or_not eq_nat_dec
    (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4))))
    (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))));
 simpl in |- *.
intro H'.
unfold SUC_MODN at 2 4 in |- *.
 elim (less_or_eq (exist (fun p : nat => p < 4) 2 lt_2_4));
 simpl in |- *; auto.
intro y'.
unfold SUC_MODN in |- *.
 elim (less_or_eq (exist (fun p : nat => p < 4) 3 y'));
 simpl in |- *; auto.
intro Abs; absurd (4 < 4); auto with arith.
rewrite d_In_SUCSUC_SSO_l4; simpl in |- *; auto with arith.
intro b; absurd (3 = 4); auto with arith.
intro b.
elim
 (In_or_not eq_nat_dec
    (no_in
       (SUC_MODN
          (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4)))))
    (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))));
 simpl in |- *.
intro H'.
unfold SUC_MODN at 3 6 in |- *;
 elim (less_or_eq (exist (fun p : nat => p < 4) 2 lt_2_4));
 simpl in |- *; auto.
intro y'.
unfold SUC_MODN at 2 4 in |- *;
 elim (less_or_eq (exist (fun n : nat => n < 4) 3 y'));
 simpl in |- *; auto.
intro Abs; absurd (4 < 4); auto with arith.
intro y''.
unfold SUC_MODN in |- *;
 elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen y'')));
 simpl in |- *; auto.
clear y''; intro y''.
rewrite d_In_SUCSUCSUC_SSO_l4.
elim (less_or_eq (exist (fun p : nat => p < 4) 2 lt_2_4)); simpl in |- *.
intro a.
elim (less_or_eq (exist (fun n : nat => n < 4) 3 a)); simpl in |- *.
intro Abs; absurd (4 < 4); auto with arith.
intro a'.
unfold SUC_MODN in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen a')));
 simpl in |- *.
intro a0.
rewrite not_d_In_SUCSUC_SSO_l4.
auto.
auto.
intro Abs; absurd (1 = 4); auto.
intro Abs; absurd (3 = 4); auto.
auto.
intro Abs; absurd (1 = 4); auto.
intro Abs; absurd (3 = 4); auto.
intro H'.
rewrite not_d_In_SUCSUCSUC_SSO_l4.
elim
 (In_or_not eq_nat_dec
    (no_in
       (SUC_MODN
          (SUC_MODN
             (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 2 lt_2_4))))))
    (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l)))).
intro H''.
unfold Convert_port_list2 in |- *.
generalize eq_n_SM4_4_times; unfold SM4 in |- *; intros Sm4.
elim (Sm4 (exist (fun p : nat => p < 4) 2 lt_2_4)).
simpl in |- *.
rewrite not_d_In_SUCSUC_SSO_l4.
simpl in |- *; auto.
auto.
intro H''.
unfold SUC_MODN at 4 8 in |- *; simpl in |- *.
unfold Convert_port_list2 in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 2 lt_2_4)); simpl in |- *.
intro a0.
unfold SUC_MODN at 3 6 in |- *; simpl in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 3 a0)); simpl in |- *.
intro a1.
unfold SUC_MODN at 2 4 in |- *; simpl in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 4 a1)); simpl in |- *.
intro Abs; absurd (5 < 4); auto with arith.
intro Abs; absurd (5 = 4); auto.
intro b0.
unfold SUC_MODN at 2 4 in |- *; simpl in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen b0)));
 simpl in |- *.
unfold SUC_MODN at 1 2 in |- *; simpl in |- *.
intro a1.
elim (less_or_eq (exist (fun n : nat => n < 4) 1 a1)); simpl in |- *.
rewrite not_d_In_SUCSUC_SSO_l4.
auto.
auto.
intro Abs; absurd (2 = 4); auto.
intro Abs; absurd (1 = 4); auto.
intro Abs; absurd (3 = 4); auto.
auto.
auto.
auto.
Qed.

Lemma Arbiter_last_ft :
 forall l : d_list bool 4,
 Ackor l = true ->
 Fst_of_l2 (Grant_for_Out l (List2 false true)) =
 Jk (Arb_xel (Scd_of_l4 l) true (Fth_of_l4 l) (Thd_of_l4 l))
   (Scd_of_l2 (Arbx true l)) false /\
 Scd_of_l2 (Grant_for_Out l (List2 false true)) =
 Jk (J_Arby false l) (Scd_of_l2 (Arby false l)) true.

intros l H.
unfold Grant_for_Out in |- *.
unfold SuccessfulInput in |- *.
rewrite RoundRobinArbiter_simpl.
unfold RoundRobin in |- *.
unfold Convert_list2_port in |- *; simpl in |- *.
elim
 (In_or_not eq_nat_dec
    (no_in (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4)))
    (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))));
 simpl in |- *.
intro H'.
unfold SUC_MODN in |- *;
 elim (less_or_eq (exist (fun p : nat => p < 4) 1 lt_1_4));
 simpl in |- *; auto.
unfold Arby in |- *; unfold K_Arby in |- *.
rewrite d_In_SUC1_l4.
elim orb_sym; auto.
auto.
intro Abs; absurd (2 = 4); auto.
intro non.
unfold Arby in |- *; unfold K_Arby in |- *.
rewrite not_d_In_SUC1_l4.
clear non.
elim
 (In_or_not eq_nat_dec
    (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4))))
    (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))));
 simpl in |- *.
intro H'.
unfold SUC_MODN at 2 4 in |- *;
 elim (less_or_eq (exist (fun p : nat => p < 4) 1 lt_1_4));
 simpl in |- *; auto.
intro y'.
unfold SUC_MODN in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 2 y')); simpl in |- *.
intro a0.
rewrite d_In_SUCSUC1_l4.
auto.
auto.
intro Abs; absurd (3 = 4); auto.
intro Abs; absurd (2 = 4); auto.
intro non.
rewrite not_d_In_SUCSUC1_l4.
elim
 (In_or_not eq_nat_dec
    (no_in
       (SUC_MODN
          (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4)))))
    (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))));
 simpl in |- *.
intro H'.
rewrite d_In_SUCSUCSUC_SO_l4.
auto.
unfold SUC_MODN at 3 6 in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 1 lt_1_4)); simpl in |- *.
intro a; unfold SUC_MODN at 2 4 in |- *; simpl in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 2 a)); simpl in |- *.
unfold SUC_MODN in |- *; intro a0.
elim (less_or_eq (exist (fun n : nat => n < 4) 3 a0)); simpl in |- *.
intro Abs; absurd (4 < 4); auto with arith.
auto.
intro Abs; absurd (3 = 4); auto.
intro Abs; absurd (2 = 4); auto.
auto.
intro H'.
unfold Convert_port_list2 in |- *; simpl in |- *.
elim
 (In_or_not eq_nat_dec
    (no_in
       (SUC_MODN
          (SUC_MODN
             (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 1 lt_1_4))))))
    (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))));
 simpl in |- *.
intro H''.
simpl in |- *.
unfold SUC_MODN at 4 8 in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 1 lt_1_4)); simpl in |- *.
intro a.
unfold SUC_MODN at 3 6 in |- *; simpl in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 2 a)); simpl in |- *.
intro a0.
unfold SUC_MODN at 2 4 in |- *; simpl in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 3 a0)); simpl in |- *.
intro Abs; absurd (4 < 4); auto with arith.
intro b; unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen b)));
 simpl in |- *.
intro b0.
rewrite not_d_In_SUCSUCSUC_SO_l4.
auto.
auto.
intro Abs; absurd (1 = 4); auto.
intro Abs; absurd (3 = 4); auto.
intro Abs; absurd (2 = 4); auto.
intro H''.
unfold SUC_MODN at 4 8 in |- *; simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 1 lt_1_4)); simpl in |- *.
intro a.
unfold SUC_MODN at 3 6 in |- *; simpl in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 2 a)); simpl in |- *.
intro a0.
unfold SUC_MODN at 2 4 in |- *; simpl in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 3 a0)); simpl in |- *.
intro Abs; absurd (4 < 4); auto with arith.
intro b; unfold SUC_MODN in |- *; simpl in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 0 (Ex_n_lt_gen b)));
 simpl in |- *.
intro b0.
rewrite not_d_In_SUCSUCSUC_SO_l4.
auto.
auto.
intro Abs; absurd (1 = 4); auto.
intro Abs; absurd (3 = 4); auto.
intro Abs; absurd (2 = 4); auto.
auto.
auto.
auto.
Qed.

Lemma Arbiter_last_ff :
 forall l : d_list bool 4,
 Ackor l = true ->
 Fst_of_l2 (Grant_for_Out l (List2 false false)) =
 Jk (Arb_xel (Scd_of_l4 l) false (Fth_of_l4 l) (Thd_of_l4 l))
   (Scd_of_l2 (Arbx false l)) false /\
 Scd_of_l2 (Grant_for_Out l (List2 false false)) =
 Jk (J_Arby false l) (Scd_of_l2 (Arby false l)) false.
intros l H.
unfold Grant_for_Out in |- *.
unfold SuccessfulInput in |- *.
rewrite RoundRobinArbiter_simpl.
unfold RoundRobin in |- *.
unfold Convert_list2_port in |- *; simpl in |- *.
elim
 (In_or_not eq_nat_dec
    (no_in (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4)))
    (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))));
 simpl in |- *.
intros H'.
unfold Convert_port_list2 in |- *.
replace (no_in (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4))) with 1;
 simpl in |- *; auto.
unfold J_Arby in |- *.
rewrite d_In_SUC0_l2.
unfold Arb_yel in |- *; unfold Arb_xel in |- *; unfold AO in |- *;
 simpl in |- *.
elim orb_sym; auto.
auto.
unfold SUC_MODN in |- *;
 elim (less_or_eq (exist (fun p : nat => p < 4) 0 lt_O_4));
 simpl in |- *; auto.
intros Abs; absurd (1 = 4); auto.
intro non.
unfold J_Arby in |- *.
rewrite not_d_In_SUC0_l2.
clear non.
elim
 (In_or_not eq_nat_dec
    (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4))))
    (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))));
 simpl in |- *.
intro H'.
unfold Convert_port_list2 in |- *.
replace (no_in (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4))))
 with 2; simpl in |- *; auto.
rewrite d_In_SUC1_l3.
elim orb_sym; auto.
auto.
unfold SUC_MODN at 2 in |- *;
 elim (less_or_eq (exist (fun p : nat => p < 4) 0 lt_O_4));
 simpl in |- *; auto.
intro y'.
unfold SUC_MODN in |- *;
 elim (less_or_eq (exist (fun n : nat => n < 4) 1 y'));
 simpl in |- *; auto.
intro Abs; absurd (2 = 4); auto with arith.
intro Abs; absurd (1 = 4); auto.
intro non.
rewrite not_d_In_SUC1_l3.
clear non.
elim
 (In_or_not eq_nat_dec
    (no_in
       (SUC_MODN
          (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4)))))
    (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))));
 simpl in |- *.
intro H'.
unfold SUC_MODN at 3 6 in |- *;
 elim (less_or_eq (exist (fun p : nat => p < 4) 0 lt_O_4));
 simpl in |- *; auto.
intro a.
unfold SUC_MODN at 2 4 in |- *; simpl in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 1 a)); simpl in |- *.
intro a0.
unfold SUC_MODN in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 2 a0)); simpl in |- *.
intro a1.
unfold Convert_port_list2 in |- *; simpl in |- *.
rewrite d_In_SUC2_l4.
auto.
auto.
intro Abs; absurd (3 = 4); auto.
intro Abs; absurd (2 = 4); auto.
intro Abs; absurd (1 = 4); auto.
intro non.
elim
 (In_or_not eq_nat_dec
    (no_in
       (SUC_MODN
          (SUC_MODN
             (SUC_MODN (SUC_MODN (exist (fun p : nat => p < 4) 0 lt_O_4))))))
    (d_map (no_in (i:=4)) (list_dlist (RequestsToArbitrate l))));
 simpl in |- *.
intro H'.
unfold Convert_port_list2 in |- *.
generalize eq_n_SM4_4_times; unfold SM4 in |- *; intros Sm4.
unfold SUC_MODN at 4 8 in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 0 lt_O_4)); simpl in |- *.
intro a.
unfold SUC_MODN at 3 6 in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 1 a)); simpl in |- *.
intro a0.
unfold SUC_MODN at 2 4 in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 2 a0)); simpl in |- *.
intro a1.
unfold SUC_MODN in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 3 a1)); simpl in |- *.
intro Abs; absurd (4 < 4); auto with arith.
intro H0.
rewrite not_d_In_SUC2_l4.
auto.
auto.
intro Abs; absurd (3 = 4); auto.
intro Abs; absurd (2 = 4); auto.
intro Abs; absurd (1 = 4); auto.
intro H'.
unfold Convert_port_list2 in |- *.
unfold SUC_MODN at 4 8 in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun p : nat => p < 4) 0 lt_O_4)); simpl in |- *.
intro a.
unfold SUC_MODN at 3 6 in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 1 a)); simpl in |- *.
intro a0.
unfold SUC_MODN at 2 4 in |- *.
simpl in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 2 a0)); simpl in |- *.
intro a1.
unfold SUC_MODN in |- *.
elim (less_or_eq (exist (fun n : nat => n < 4) 3 a1)); simpl in |- *.
intro Abs; absurd (4 < 4); auto with arith.
intro H0.
rewrite not_d_In_SUC2_l4.
auto.
auto.
intro Abs; absurd (3 = 4); auto.
intro Abs; absurd (2 = 4); auto.
intro Abs; absurd (1 = 4); auto.
auto.
auto.
auto.
Qed.

Lemma Arbiter_last :
 forall (l : d_list bool 4) (b1 b2 : bool),
 Ackor l = true ->
 Fst_of_l2 (Grant_for_Out l (List2 b1 b2)) =
 Jk (Arb_xel (Scd_of_l4 l) b2 (Fth_of_l4 l) (Thd_of_l4 l))
   (Scd_of_l2 (Arbx b2 l)) b1 /\
 Scd_of_l2 (Grant_for_Out l (List2 b1 b2)) =
 Jk (J_Arby b1 l) (Scd_of_l2 (Arby b1 l)) b2.
intros l b1 b2 H.
elim b1; elim b2.
apply Arbiter_last_tt; try trivial.
apply Arbiter_last_tf; try trivial.
apply Arbiter_last_ft; try trivial.
apply Arbiter_last_ff; try trivial.
Qed.

Lemma Ackor_ltReq_false :
 forall (l : d_list bool 4) (g1 g2 : bool),
 Ackor l = false ->
 Jk (Arb_xel (Scd_of_l4 l) g2 (Fth_of_l4 l) (Thd_of_l4 l))
   (Scd_of_l2 (Arbx g2 l)) g1 = g1 /\
 Jk (J_Arby g1 l) (Scd_of_l2 (Arby g1 l)) g2 = g2.
intros l g1 g2 H.
unfold Arbx in |- *; unfold Arby in |- *; unfold J_Arby in |- *;
 unfold Arb_xel in |- *; unfold Arb_yel in |- *; unfold K_Arby in |- *;
 unfold Scd_of_l2 in |- *; unfold List2 in |- *; simpl in |- *.
unfold Arb_yel in |- *; unfold AO in |- *; unfold AND2 in |- *;
 unfold OR2 in |- *.
rewrite (Ackor_false_fst H).
rewrite (Ackor_false_scd H).
rewrite (Ackor_false_thd H).
rewrite (Ackor_false_fth H); simpl in |- *.
elim g1; elim g2; simpl in |- *; auto.
Qed.

Lemma Ackor_false :
 forall l : d_list bool 4,
 Ackor l = false ->
 Fst_of_l4 l = false /\
 Scd_of_l4 l = false /\ Thd_of_l4 l = false /\ Fth_of_l4 l = false.
intro l.
elim (non_empty l).
intros a H; elim H; clear H.
intros t H; rewrite H; simpl in |- *.
elim (non_empty t).
intros b H0; elim H0; clear H0.
intros t0 H0; rewrite H0; simpl in |- *.
elim (non_empty t0).
intros c H'; elim H'; clear H'.
intros t' H'; rewrite H'; simpl in |- *.
elim (non_empty t').
intros d H''; elim H''; clear H''.
intros t'' H''; rewrite H''; simpl in |- *.
replace t'' with (d_nil bool); auto.
unfold Ackor in |- *; simpl in |- *.
elim a; elim b; elim c; elim d; simpl in |- *; auto.
Qed.


Require Import List Bool.
Require Import ExtLib.Tactics.Consider.
Require MirrorShard.CancelTacBedrock.
Require MirrorShard.ExprUnify.
Require Import MirrorShard.Expr.
Require Import MirrorShard.Provers.
Require Import MirrorShard.SepExprTac.
Require Import ILEnv SepIL TacPackIL.

Set Implicit Arguments.
Set Strict Implicit.

Module CANCEL_TAC :=
  CancelTacBedrock.Make SepIL.ST SepIL.SEP SepIL.SH
                        TacPackIL.SEP_LEMMA
                        SUBST
                        UNIFY
                        UNF.

Module SEP_TAC := MirrorShard.SepExprTac.Make SepIL.ST SepIL.SEP.

Section canceller.
  Variable ts : list Expr.type.
  Let types := Env.repr BedrockCoreEnv.core ts.

  Definition nexistsSubst (not : Prop -> Prop) (types : list type) (funcs : functions types) (sub : SUBST.Subst types) :=
    fix existsSubst (meta vars : env types) (from : nat)
    (vals : list tvar) (ret : env types -> Prop) {struct vals} : Prop :=
    match vals with
      | nil => ret meta
      | t :: ts =>
        match SUBST.Subst_lookup from sub with
          | Some v =>
            match exprD funcs meta vars v t with
              | Some v0 =>
                existsSubst (meta ++ existT (tvarD types) t v0 :: nil) vars
                (S from) ts ret
              | None =>
                exists x : tvarD types t,
                  existsSubst (meta ++ existT (tvarD types) t x :: nil) vars
                  (S from) ts
                  (fun g : env types =>
                    match exprD funcs g vars v t with
                      | Some y => x = y /\ ret g
                      | None => False
                    end)
            end
          | None =>
            exists x : tvarD types t,
              existsSubst (meta ++ existT (tvarD types) t x :: nil) vars
              (S from) ts ret
        end
    end.

  Theorem nexistsSubst_existsSubst : nexistsSubst not = CANCEL_TAC.INS.existsSubst.
  Proof. reflexivity. Qed.

  Definition nSubst_equations_to (not : Prop -> Prop) (types : list type) (funcs : functions types) (uenv venv : env types)
    (subst : SUBST.Subst types) from ls (rr : Prop) :=
    (fix Subst_equations_to (from : nat) (ls : env types) {struct ls} : Prop :=
    match ls with
      | nil => rr
      | l :: ls0 =>
        match SUBST.Subst_lookup from subst with
          | Some e =>
            match ExprTac.nexprD not types funcs uenv venv e (projT1 l) with
              | Some v => projT2 l = v
              | None => False
            end
          | None => True
        end /\ Subst_equations_to (S from) ls0
    end) from ls.

  Theorem nSubst_equations_to_Subst_equations_to : forall ts fs u v s r ls from,
    @nSubst_equations_to not ts fs u v s from ls r <-> @SUBST.Subst_equations_to ts fs u v s from ls /\ r.
  Proof.
    induction ls; simpl.
    { intuition. }
    { intros. rewrite IHls. intuition. }
  Qed.

  Definition cancel (himp : hprop -> hprop -> Prop) (emp : hprop) (star : hprop -> hprop -> hprop)
    (ex : forall T : Type, (T -> hprop) -> hprop) (inj : Prop -> hprop) (not : Prop -> Prop)
    (boundf boundb : nat)
    (ts : list Expr.type)
    (funcs : Expr.functions (Env.repr ILEnv.BedrockCoreEnv.core ts))
    (preds : SEP.predicates (Env.repr ILEnv.BedrockCoreEnv.core ts))
    (algos : TacPackIL.ILAlgoTypes.AllAlgos (Env.repr ILEnv.BedrockCoreEnv.core ts))
    (uvars : Expr.env (Env.repr ILEnv.BedrockCoreEnv.core ts))
    (lhs rhs : SEP.sexpr (Env.repr ILEnv.BedrockCoreEnv.core ts))
    (hyps : Expr.exprs (Env.repr ILEnv.BedrockCoreEnv.core ts)) : Prop :=
    let types := Env.repr ILEnv.BedrockCoreEnv.core ts in
    let hints :=
      match TacPackIL.ILAlgoTypes.Hints algos with
        | Some x => x
        | None =>
          {| TacPackIL.UNF.Forward := nil
           ; TacPackIL.UNF.Backward := nil |}
      end in
    let prover :=
      match TacPackIL.ILAlgoTypes.Prover algos with
        | Some x => x
        | None =>
          Provers.trivialProver (Env.repr ILEnv.BedrockCoreEnv.core ts)
      end in
    let tfuncs := typeof_funcs funcs in
    let tpreds := SEP.typeof_preds preds in
    if SEP.WellTyped_sexpr tfuncs tpreds (typeof_env uvars) nil rhs then
      match CANCEL_TAC.canceller tpreds (TacPackIL.UNF.Forward hints) (TacPackIL.UNF.Backward hints) prover boundf boundb (typeof_env uvars) hyps lhs rhs with
        | None =>
          himp (SEP_TAC.nsexprD not emp star ex inj types funcs preds uvars nil lhs)
               (SEP_TAC.nsexprD not emp star ex inj types funcs preds uvars nil rhs)
        | Some {| CANCEL_TAC.AllExt := new_vars
                ; CANCEL_TAC.ExExt := new_uvars
                ; CANCEL_TAC.Lhs := lhs'
                ; CANCEL_TAC.Rhs := rhs'
                ; CANCEL_TAC.Subst := subst |} =>
          forallEach new_vars (fun nvs : env types =>
             let var_env := nvs in
             ExprTac.nAllProvable_impl not _ funcs uvars var_env
               (nexistsSubst not funcs subst uvars var_env (length uvars) new_uvars
                 (fun meta_env0 : env types =>
                    nSubst_equations_to not funcs meta_env0 var_env subst 0 uvars
                      (ExprTac.nAllProvable_and not _ funcs meta_env0 var_env
                        (himp
                           (SEP_TAC.nsexprD not emp star ex inj types funcs preds meta_env0 var_env
                              (SH.sheapD
                                 {| SH.impures := SH.impures lhs'
                                  ; SH.pures := nil
                                  ; SH.other := SH.other lhs' |}))
                           (SEP_TAC.nsexprD not emp star ex inj types funcs preds meta_env0 var_env
                              (SH.sheapD
                                 {| SH.impures := SH.impures rhs'
                                  ; SH.pures := nil
                                  ; SH.other := SH.other rhs' |})))
                        (SH.pures rhs')))) (SH.pures lhs'))

        end
    else
      himp (SEP_TAC.nsexprD not emp star ex inj types funcs preds uvars nil lhs)
           (SEP_TAC.nsexprD not emp star ex inj types funcs preds uvars nil rhs).

  Theorem ApplyCancelSep_slice (boundf boundb : nat) : forall (ts : list Expr.type)
      (funcs : Expr.functions (Env.repr ILEnv.BedrockCoreEnv.core ts))
      (preds : SEP.predicates (Env.repr ILEnv.BedrockCoreEnv.core ts))
      (algos : TacPackIL.ILAlgoTypes.AllAlgos
        (Env.repr ILEnv.BedrockCoreEnv.core ts)),
      TacPackIL.ILAlgoTypes.AllAlgos_correct (types := Env.repr ILEnv.BedrockCoreEnv.core ts) funcs preds algos ->
      forall (uvars : Expr.env (Env.repr ILEnv.BedrockCoreEnv.core ts))
        (lhs rhs : SEP.sexpr (Env.repr ILEnv.BedrockCoreEnv.core ts))
        (hyps : Expr.exprs (Env.repr ILEnv.BedrockCoreEnv.core ts)),
        Expr.AllProvable funcs uvars nil hyps ->
        (cancel himp emp star ex inj not boundf boundb funcs preds algos uvars lhs rhs hyps) ->
        SEP.himp funcs preds uvars nil lhs rhs.
  Proof.
    Opaque Env.repr.
    intros. unfold cancel in *; simpl in *.
    consider (SEP.WellTyped_sexpr (typeof_funcs funcs) (SEP.typeof_preds preds) (typeof_env uvars) nil rhs); intros; eauto.
    consider (CANCEL_TAC.canceller (SEP.typeof_preds preds)
           (UNF.Forward
              match ILAlgoTypes.Hints algos with
              | Some x => x
              | None => {| UNF.Forward := nil; UNF.Backward := nil |}
              end)
           (UNF.Backward
              match ILAlgoTypes.Hints algos with
              | Some x => x
              | None => {| UNF.Forward := nil; UNF.Backward := nil |}
              end)
           match ILAlgoTypes.Prover algos with
           | Some x => x
           | None => trivialProver (Env.repr BedrockCoreEnv.core ts0)
           end boundf boundb (typeof_env uvars) hyps lhs rhs); intros.
    { eapply CANCEL_TAC.ApplyCancelSep_with_eq in H1; eauto.
      { destruct X. destruct (ILAlgoTypes.Hints algos); eauto using UNF.ForwardOk.
        simpl. constructor. }
      { destruct X. destruct (ILAlgoTypes.Hints algos); eauto using UNF.BackwardOk.
        simpl. constructor. }
      { destruct X. destruct (ILAlgoTypes.Prover algos); eauto using trivialProver_correct. }
      { eapply typeof_funcs_WellTyped_funcs. }
      { rewrite nexistsSubst_existsSubst in *.
        destruct c. apply forallEach_sem. intros.
        eapply forallEach_sem in H2; eauto.
        rewrite ExprTac.nAllProvable_impl_AllProvable_impl in H2.
        apply AllProvable_impl_sem; intros.
        apply AllProvable_impl_sem in H2; eauto.
        eapply CANCEL_TAC.INS.existsSubst_sem in H2. eapply existsEach_sem in H2. destruct H2; intuition.
        eapply CANCEL_TAC.INS.existsSubst_sem. eapply existsEach_sem. exists x.
        change (fun A : Prop => A -> False) with not in *.
        rewrite nSubst_equations_to_Subst_equations_to in *. intuition.
        rewrite ExprTac.nAllProvable_and_AllProvable_and in H8. intuition. } }
    { apply H2. }
  Qed.

End canceller.