Require Import DataTypes Coq.Lists.Streams Coq.Logic.Classical_Prop Tree List MsiState Coq.Relations.Relation_Operators.

Record BaseMesg :=
  { fromB: State;
    toB: State;
    addrB: Addr;
    dataBM: Data;
    type: ChannelType
  }.

Record GlobalState :=
  { dt: Cache -> Addr -> Data;
    ch: ChannelType -> Cache -> Cache -> list BaseMesg;
    st: Cache -> Addr -> State;
    dirSt: Cache -> Cache -> Addr -> State;
    wt: Cache -> Addr -> bool;
    wtS: Cache -> Addr -> State;
    dirWt: Cache -> Cache -> Addr -> bool;
    dirWtS: Cache -> Cache -> Addr -> State;
    req: Addr -> Cache -> nat
  }.

Definition dmy := Build_BaseMesg In In zero (initData zero) mch.

Inductive Transition (s: GlobalState) : GlobalState -> Set :=
| LoadReq: forall {c a}, defined c -> leaf c -> desc (reqFn a c (req s a c)) = Ld ->
                       sle Sh (st s c a) ->
                       Transition s {|
                                    dt := dt s;
                                    ch := ch s;
                                    st := st s;
                                    dirSt := dirSt s;
                                    wt := wt s;
                                    wtS := wtS s;
                                    dirWt := dirWt s;
                                    dirWtS := dirWtS s;
                                    req := fun w t =>
                                             match decAddr w a with
                                               | left _ =>
                                                   match decTree t c with
                                                     | left _ => S (req s w t)
                                                     | _ => req s w t
                                                   end
                                               | right _ => req s w t
                                             end
                                  |}
| StoreReq: forall {c a}, defined c -> leaf c -> desc (reqFn a c (req s a c)) = St ->
                        (st s c a = Mo) ->
                        Transition s {|
                                     dt := fun t w => match decTree t c with
                                                      | left _ => match decAddr w a with
                                                                    | left _ => dataQ (reqFn a t (req s w t))
                                                                    | right _ => dt s t w
                                                                  end
                                                      | right _ => dt s t w
                                                      end;
                                     ch := ch s;
                                     st := st s;
                                     dirSt := dirSt s;
                                     wt := wt s;
                                     wtS := wtS s;
                                     dirWt := dirWt s;
                                     dirWtS := dirWtS s;
                                     req := fun w t =>
                                             match decAddr w a with
                                               | left _ =>
                                                   match decTree t c with
                                                     | left _ => S (req s w t)
                                                     | _ => req s w t
                                                   end
                                               | right _ => req s w t
                                             end
                                   |}
| ChildSendReq: forall {p c}, defined p -> defined c -> parent c p ->
                              forall {x a}, slt (st s c a) x -> wt s c a = false ->
                                            Transition s {|
                                                         dt := dt s;
                                                         ch := fun t w z =>
                                                                 match t, decTree w c,
                                                                       decTree z p with
                                                                   | rch, left _, left _ =>
                                                                       (Build_BaseMesg
                                                                          (st s w a)
                                                                          x a (initData zero) rch)
                                                                         :: ch s t w z
                                                                   | _, _, _ => ch s t w z
                                                                 end;
                                                         st := st s;
                                                         dirSt := dirSt s;
                                                         wt := fun t w => match decTree t c, decAddr w a with
                                                                            | left _, left _ => true
                                                                            | _, _ => wt s t w
                                                                          end;
                                                         wtS := fun t w => match decTree t c, decAddr w a with
                                                                             | left _, left _ => x
                                                                             | _, _ => wtS s t w
                                                                           end;
                                                         dirWt := dirWt s;
                                                         dirWtS := dirWtS s;
                                                         req := req s
                                                       |}
| ParentRecvReq: forall {p c}, defined p -> defined c -> parent c p ->
                               ch s rch c p <> nil -> let r := last (ch s rch c p) dmy in
                                                        let fromR := fromB r in
                                                          let toR := toB r in
                                                            let a := addrB r in
                                                              sle toR (st s p a) ->
                               (forall i, defined i -> i <> c -> parent i p ->
                                          sle (dirSt s p i a)
                                              match toR with
                                                | Mo => In
                                                | Sh => Sh
                                                | In => Mo
                                              end) ->
                               dirWt s p c a = false ->
                               sle (dirSt s p c a) fromR ->
                               Transition s {| ch := fun t w z =>
                                                       match t with
                                                         | mch => match decTree w p,
                                                                        decTree z c with
                                                         | left _, left _ =>
                                                             (Build_BaseMesg
                                                                (dirSt s w z a) toR a (dt s w a) mch)
                                                               :: ch s t w z
                                                         | _, _ => ch s t w z
                                                                  end
                                                         | rch =>
                                                             match decTree w c,
                                                                   decTree z p with
                                                               | left _, left _ => removelast
                                                                                (ch s t w z)
                                                               | _, _ => ch s t w z
                                                             end
                                                       end;
                                               dt := dt s;
                                               st := st s;
                                               dirSt := fun t w z => match decTree t p, decTree w c,
                                                                           decAddr z a with
                                                                       | left _, left _, left _ => toR
                                                                       | _, _, _ => dirSt s t w z
                                                                     end;
                                               wt := wt s;
                                               wtS := wtS s;
                                               dirWt := dirWt s;
                                               dirWtS := dirWtS s;
                                               req := req s
                                            |}
| ChildRecvResp: forall {p c}, defined p -> defined c -> parent c p ->
                               ch s mch p c <> nil ->
                               let m := last (ch s mch p c) dmy in
                                 let fromM := fromB m in
                                   let toM := toB m in
                                     let a := addrB m in
                                       let d := dataBM m in
                                       type m = mch ->
                                         Transition s {| dt := fun t w =>
                                                                 match decTree t c,
                                                                       decAddr w a with
                                                                   | left _, left _ =>
                                                                     match fromB m with
                                                                       | In => d
                                                                       | _ => dt s t w
                                                                     end
                                                                   | _, _ => dt s t w
                                                                 end;
                                                         ch := fun t w z =>
                                                                 match t, decTree w p,
                                                                       decTree z c with
                                                                   | mch, left _, left _ => removelast (ch s t w z)
                                                                   | _, _, _ => ch s t w z
                                                                 end;
                                                         st := fun t w => match decTree t c, decAddr w a with
                                                                            | left _, left _ => toM
                                                                            | _, _ => st s t w
                                                                          end;
                                                         dirSt := dirSt s;
                                                         wt := fun t w => match decTree t c, decAddr w a with
                                                                            | left _, left _ =>
                                                                                match decSle (wtS s t w) toM with
                                                                                | true => false
                                                                                | _ => wt s t w
                                                                                end
                                                                            | _, _ => wt s t w
                                                                          end;
                                                         wtS := wtS s;
                                                         dirWt := dirWt s;
                                                         dirWtS := dirWtS s;
                                                         req := req s
                                                      |}
| ParentSendReq: forall {p c}, defined p -> defined c -> parent c p ->
                               forall {x a}, slt x (dirSt s p c a) -> dirWt s p c a = false ->
                                             Transition s {|
                                                          dt := dt s;
                                                          ch := fun t w z =>
                                                                  match t, decTree w p,
                                                                        decTree z c with
                                                                    | mch, left _, left _ =>
                                                                        (Build_BaseMesg
                                                                           (dirSt s w z a)
                                                                           x a (initData zero) rch)
                                                                          :: ch s t w z
                                                                    | _, _, _ => ch s t w z
                                                                  end;
                                                          st := st s;
                                                          dirSt := dirSt s;
                                                          wt := wt s;
                                                          wtS := wtS s;
                                                          dirWt := fun t w z => match decTree t p, decTree w c,
                                                                                decAddr z a
                                                                                with
                                                                                | left _, left _, left _ =>
                                                                                true
                                                                                | _, _, _ => dirWt s t w z
                                                                                end;
                                                          dirWtS := fun t w z => match decTree t p, decTree w c,
                                                                                decAddr z a with
                                                                                | left _, left _, left _ => x
                                                                                | _, _, _ => dirWtS s t w z
                                                                                end;
                                                          req := req s

                                                        |}
| ChildRecvReq: forall {p c}, defined p -> defined c -> parent c p ->
                              ch s mch p c <> nil ->
                              let r := last (ch s mch p c) dmy in
                                let fromR := fromB r in
                                  let toR := toB r in
                                    let a := addrB r in
                                      let d := dataBM r in
                                      type r = rch ->
                                        slt toR (st s c a) ->
                              (forall {i}, defined i -> parent i c -> sle (dirSt s c i a) toR) ->
                              Transition s {| ch := fun t w z =>
                                                      match t with
                                                        | mch =>
                                                          match decTree w c, decTree z p with
                                                            | left _, left _ =>
                                                              (Build_BaseMesg (st s w a) toR a
                                                                              (dt s w a) mch)
                                                                :: ch s t w z
                                                            | left _, _ => ch s t w z
                                                            | _, _ => match decTree w p,
                                                                           decTree z c with
                                                                       | left _, left _ =>
                                                                         removelast (ch s t w z)
                                                                       | _, _ => ch s t w z
                                                                     end
                                                          end
                                                        | _ => ch s t w z
                                                      end;
                                              dt := dt s;
                                              st := fun t w => match decTree t c, decAddr w a with
                                                                 | left _, left _ => toR
                                                                 | _, _ => st s t w
                                                               end;
                                              dirSt := dirSt s;
                                              wt := wt s;
                                              wtS := wtS s;
                                              dirWt := dirWt s;
                                              dirWtS := dirWtS s;
                                              req := req s
                                           |}
| ParentRecvResp: forall {p c}, defined p -> defined c -> parent c p ->
                                ch s mch c p <> nil ->
                                let m := last (ch s mch c p) dmy in
                                  let fromM := fromB m in
                                    let toM := toB m in
                                      let a := addrB m in
                                        let d := dataBM m in
                                        fromM = dirSt s p c a ->
                                          Transition s {| dt := fun t w => match decTree t p, decAddr w a with
                                                                             | left _, left _ =>
                                                                                match fromB m with
                                                                                | Mo => d
                                                                                | _ => dt s t w
                                                                                end
                                                                             | _, _ => dt s t w
                                                                           end;
                                                          ch := fun t w z =>
                                                                  match t, decTree w c,
                                                                        decTree z p with
                                                                    | mch, left _, left _ => removelast (ch s t w z)
                                                                    | _, _, _ => ch s t w z
                                                                  end;
                                                          st := st s;
                                                          dirSt := fun t w z => match decTree t p, decTree w c,
                                                                                decAddr z a with
                                                                                | left _, left _, left _ => toM
                                                                                | _, _, _ => dirSt s t w z
                                                                                end;
                                                          wt := wt s;
                                                          wtS := wtS s;
                                                          dirWt := fun t w z => match decTree t p, decTree w c,
                                                                                decAddr z a with
                                                                                | left _, left _, left _ =>
                                                                                match decSle toM (dirWtS s t w z)
                                                                                with
                                                                                | true => false
                                                                                | _ => dirWt s t w z
                                                                                end
                                                                                | _, _, _ => dirWt s t w z
                                                                                end;
                                                          dirWtS := dirWtS s;
                                                          req := req s
                                                       |}

| ChildVolResp: forall {p c}, defined p -> defined c -> parent c p ->
                              forall {x a},
                                slt x (st s c a) ->
                                (forall {i}, defined i -> parent i c -> sle (dirSt s c i a) x) ->
                                wt s c a = false ->
                                Transition s {| ch := fun t w z =>
                                                        match t, decTree w c,
                                                              decTree z p with
                                                          | mch, left _, left _ =>
                                                              (Build_BaseMesg
                                                                 (st s w a) x a (dt s w a) mch)
                                                                :: ch s t w z
                                                          | _, _, _ => ch s t w z
                                                        end;
                                                dt := dt s;
                                                st := fun t w => match decTree t c, decAddr w a with
                                                                   | left _, left _ => x
                                                                   | _, _ => st s t w
                                                                 end;
                                                dirSt := dirSt s;
                                                wt := wt s;
                                                wtS := wtS s;
                                                dirWt := dirWt s;
                                                dirWtS := dirWtS s;
                                                req := req s
                                             |}
| ChildDropReq: forall {p c}, defined p -> defined c -> parent c p ->
                              ch s mch p c <> nil ->
                              let r := last (ch s mch p c) dmy in
                                let fromR := fromB r in
                                  let toR := toB r in
                                    let a := addrB r in
                                      let d := dataBM r in
                                      type r = rch ->
                                        sle (st s c a) toR ->
                              Transition s {| ch := fun t w z =>
                                                      match t, decTree w p,
                                                            decTree z c with
                                                        | mch, left _, left _ => removelast
                                                                                (ch s t w z)
                                                        | _, _, _ => ch s t w z
                                                      end;
                                              dt := dt s;
                                              st := st s;
                                              dirSt := dirSt s;
                                              wt := wt s;
                                              wtS := wtS s;
                                              dirWt := dirWt s;
                                              dirWtS := dirWtS s;
                                              req := req s
                                           |}.

Definition initGlobalState :=
  {| dt := fun t w => if (decTree t hier) then initData w else initData zero;
     ch := fun t w z => nil;
     st := fun t w => match decTree t hier with
                        | left _ => Mo
                        | right _ => In
                      end;
     dirSt := fun t w z => In;
     wt := fun t w => false;
     wtS := fun t w => In;
     dirWt := fun t w z => false;
     dirWtS := fun t w z => In;
     req := fun t w => 0
  |}.

Record Behavior := {
                    sys: Time -> GlobalState;
                    init: sys 0 = initGlobalState;
                    trans: forall t, Transition (sys t) (sys (S t))
                  }.

Parameter oneBeh: Behavior.

Fixpoint labelCh t ch src dst :=
  match t with
    | 0 => nil
    | S t => match (trans oneBeh) t with
               | ChildSendReq p c _ _ _ _ _ _ _ =>
                 match ch with
                   | rch =>
                     if (decTree src c)
                     then if (decTree dst p)
                          then t :: labelCh t ch src dst
                          else labelCh t ch src dst
                     else labelCh t ch src dst
                   | mch => labelCh t ch src dst
                 end
               | ParentRecvReq p c _ _ _ _ _ _ _ _ =>
                 match ch with
                   | rch =>
                     if (decTree dst p)
                     then if (decTree src c)
                          then removelast (labelCh t ch src dst)
                          else labelCh t ch src dst
                     else labelCh t ch src dst
                   | mch =>
                     if (decTree dst c)
                     then if (decTree src p)
                          then t :: labelCh t ch src dst
                          else labelCh t ch src dst
                     else labelCh t ch src dst
                 end
               | ChildRecvResp p c _ _ _ _ _ =>
                 match ch with
                   | mch =>
                     if (decTree src p)
                     then if (decTree dst c)
                          then removelast (labelCh t ch src dst)
                          else labelCh t ch src dst
                     else labelCh t ch src dst
                   | rch => labelCh t ch src dst
                 end
               | ParentSendReq p c _ _ _ _ _ _ _ =>
                 match ch with
                   | mch =>
                     if (decTree src p)
                     then if (decTree dst c)
                          then t :: labelCh t ch src dst
                          else labelCh t ch src dst
                     else labelCh t ch src dst
                   | rch => labelCh t ch src dst
                 end
               | ChildRecvReq p c _ _ _ _ _ _ _ =>
                 match ch with
                   | mch =>
                     match decTree dst p, decTree src c with
                       | left _, left _ => t :: labelCh t ch src dst
                       | left _, _ => labelCh t ch src dst
                       | _, _ =>
                         match decTree dst c, decTree src p with
                                   | left _, left _ =>
                                                         removelast (labelCh t ch src dst)
                                   | _, _ => labelCh t ch src dst
                                 end
                     end
                   | rch => labelCh t ch src dst
                 end
               | ParentRecvResp p c _ _ _ _ _ =>
                 match ch with
                   | mch =>
                     if (decTree src c)
                     then if (decTree dst p)
                          then removelast (labelCh t ch src dst)
                          else labelCh t ch src dst
                     else labelCh t ch src dst
                   | rch => labelCh t ch src dst
                 end
               | ChildVolResp p c _ _ _ _ _ _ _ _ =>
                 match ch with
                   | mch =>
                     if (decTree src c)
                     then if (decTree dst p)
                          then t :: labelCh t ch src dst
                          else labelCh t ch src dst
                     else labelCh t ch src dst
                   | rch => labelCh t ch src dst
                 end
               | ChildDropReq p c _ _ _ _ _ _ =>
                 match ch with
                   | mch =>
                     if (decTree src p)
                     then if (decTree dst c)
                          then removelast (labelCh t ch src dst)
                          else labelCh t ch src dst
                     else labelCh t ch src dst
                   | rch => labelCh t ch src dst
                 end
               | _ => labelCh t ch src dst
             end
  end.

Module mkDataTypes <: DataTypes.

  Definition state c a t := st ((sys oneBeh) t) c a.
  Definition dir p c a t := dirSt ((sys oneBeh) t) p c a.
  Definition wait c a t := wt ((sys oneBeh) t) c a.
  Definition waitS c a t := wtS ((sys oneBeh) t) c a.
  Definition dwait p c a t := dirWt ((sys oneBeh) t) p c a.
  Definition dwaitS p c a t := dirWtS ((sys oneBeh) t) p c a.
  Definition data c a t := dt ((sys oneBeh) t) c a.

  Definition mark chn src dst t m := match ((trans oneBeh) t) with
                                       | ChildSendReq p c _ _ _ x a _ _ =>
                                         c = src /\ p = dst /\ chn = rch /\
                                         from m = (st ((sys oneBeh) t) c a) /\
                                         to m = x /\ addr m = a /\
                                         dataM m = initData zero /\
                                         msgId m = t
                                       | ParentRecvReq p c _ _ _ _ _ _ _ _ =>
                                         p = src /\ c = dst /\ chn = mch /\
                                         let r := last (ch ((sys oneBeh) t) rch c p) dmy in
                                         let a := addrB r in
                                         from m = (dirSt ((sys oneBeh) t) p c a) /\
                                         to m = toB r /\
                                         addr m = a /\
                                         dataM m = dt ((sys oneBeh) t) p a /\
                                         msgId m = t
                                       | ParentSendReq p c _ _ _ x a _ _ =>
                                         p = src /\ c = dst /\ chn = rch /\
                                         from m = (dirSt ((sys oneBeh) t) p c a) /\
                                         to m = x /\ addr m = a /\
                                         dataM m = initData zero /\
                                         msgId m = t
                                       | ChildRecvReq p c _ _ _ _ _ _ _ =>
                                         c = src /\ p = dst /\ chn = mch /\
                                         let r := last (ch ((sys oneBeh) t) mch p c) dmy in
                                         let a := addrB r in
                                         from m = (st ((sys oneBeh) t) c a) /\
                                         to m = toB r /\
                                         addr m = a /\
                                         dataM m = dt ((sys oneBeh) t) c a /\
                                         msgId m = t
                                       | ChildVolResp p c _ _ _ x a _ _ _ =>
                                         c = src /\ p = dst /\ chn = mch /\
                                         from m = (st ((sys oneBeh) t) c a) /\
                                         to m = x /\ addr m = a /\
                                         dataM m = dt (sys oneBeh t) c a /\
                                         msgId m = t
                                       | _ => False
                                     end.

  Definition recv chn src dst t m := match ((trans oneBeh) t) with
                                       | ParentRecvReq p c _ _ _ _ _ _ _ _ =>
                                         c = src /\ p = dst /\
                                         let r := last (ch ((sys oneBeh) t) rch c p) dmy in
                                         chn = type r /\
                                         from m = fromB r /\
                                         to m = toB r /\ addr m = addrB r /\
                                         dataM m = dataBM r /\
                                         msgId m = last (labelCh t rch c p) 0
                                       | ChildRecvResp p c _ _ _ _ _ =>
                                         p = src /\ c = dst /\
                                         let r := last (ch ((sys oneBeh) t) mch p c) dmy in
                                         chn = type r /\
                                         from m = fromB r /\
                                         to m = toB r /\ addr m = addrB r /\
                                         dataM m = dataBM r /\
                                         msgId m = last (labelCh t mch p c) 0
                                       | ChildRecvReq p c _ _ _ _ _ _ _ =>
                                         p = src /\ c = dst /\
                                         let r := last (ch ((sys oneBeh) t) mch p c) dmy in
                                         chn = type r /\
                                         from m = fromB r /\
                                         to m = toB r /\ addr m = addrB r /\
                                         dataM m = dataBM r /\
                                         msgId m = last (labelCh t mch p c) 0
                                       | ParentRecvResp p c _ _ _ _ _ =>
                                         c = src /\ p = dst /\
                                         let r := last (ch ((sys oneBeh) t) mch c p) dmy in
                                         chn = type r /\
                                         from m = fromB r /\
                                         to m = toB r /\ addr m = addrB r /\
                                         dataM m = dataBM r /\
                                         msgId m = last (labelCh t mch c p) 0
                                       | ChildDropReq p c _ _ _ _ _ _ =>
                                         p = src /\ c = dst /\
                                         let r := last (ch ((sys oneBeh) t) mch p c) dmy in
                                         chn = type r /\
                                         from m = fromB r /\
                                         to m = toB r /\ addr m = addrB r /\
                                         dataM m = dataBM r /\
                                         msgId m = last (labelCh t mch p c) 0
                                       | _ => False
                                     end.
  Definition markc t :=
    match (trans oneBeh t) with
      | ChildSendReq _ _ _ _ _ _ _ _ _ => rch
      | _ => mch
    end.

  Definition recvc t :=
    match (trans oneBeh t) with
      | ParentRecvReq _ _ _ _ _ _ _ _ _ _ => rch
      | _ => mch
    end.

  Definition invmark t :=
    match trans oneBeh t with
      | ChildSendReq _ _ _ _ _ _ _ _ _ => rch
      | ParentSendReq _ _ _ _ _ _ _ _ _ => rch
      | _ => mch
    end.

  Definition invrecv t :=
    match trans oneBeh t with
      | ParentRecvReq _ _ _ _ _ _ _ _ _ _ => rch
      | ChildRecvReq _ _ _ _ _ _ _ _ _ => rch
      | ChildDropReq _ _ _ _ _ _ _ _ => rch
      | _ => mch
    end.

  Definition send := mark.
  Definition proc := recv.
  Definition deq := recv.

  Definition deqR a c i t := match (trans oneBeh) t with
                                   | LoadReq ca aa _ _ _ _ =>
                                     aa = a /\ ca = c /\ req (sys oneBeh t) a c = i
                                   | StoreReq ca aa _ _ _ _ =>
                                     aa = a /\ ca = c /\ req (sys oneBeh t) a c = i
                                   | _ => False
                                 end.
End mkDataTypes.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.

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

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.NewProofs.ProofHelpers.
Require Import depoolContract.DePoolFunc.

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

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Require Import depoolContract.DePoolConsts.
Module DePoolContract_Ф_ticktock (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Module ProofHelpers := ProofHelpers dc.

Import dc.
Import ProofHelpers.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo deleteListPair.

Opaque DePoolContract_Ф_updateRounds
       DePoolContract_Ф_checkPureDePoolBalance
       DePoolContract_Ф__returnChange.

Opaque DePoolFuncs.DePoolContract_Ф_updateRounds
       DePoolFuncs.DePoolContract_Ф_checkPureDePoolBalance
       DePoolFuncs.DePoolContract_Ф__returnChange.

(* Definition DePoolContract_Ф_ticktock' :  LedgerT ( XErrorValue True XInteger ) :=
 Require2 {{ msg_sender () ?!= $xInt0, $ Errors_ι_IS_EXT_MSG }} ;
 If! (DePoolContract_Ф_checkPureDePoolBalance () ) then
 { U0! _ ?:= DePoolContract_Ф_updateRounds () ; $I } ;
 (If (msg_sender () ?!= tvm_address () ) then {
    DePoolContract_Ф__returnChange ()
 }).    *)

 Definition DePoolContract_Ф_ticktock_tailer: LedgerT True :=
  If (msg_sender () ?!= tvm_address () ) then {
     DePoolContract_Ф__returnChange ()
  }.

Definition DePoolContract_Ф_ticktock_header :  LedgerT ( XErrorValue True XInteger ) :=
 Require2 {{ msg_sender () ?!= $ xInt0, $ Errors_ι_IS_EXT_MSG }} ;
 If! (DePoolContract_Ф_checkPureDePoolBalance () ) then
 { U0! _ ?:= DePoolContract_Ф_updateRounds () ; $I } ; DePoolContract_Ф_ticktock_tailer.

 Lemma DePoolContract_Ф_ticktock_header_eq:
  DePoolContract_Ф_ticktock = DePoolContract_Ф_ticktock_header .
 Proof.
   intros. auto.
 Qed.

Lemma DePoolContract_Ф_ticktock_tailer_exec : forall (l: Ledger),
let if1 : bool := negb ( eval_state msg_sender l =? eval_state tvm_address l) in

exec_state DePoolContract_Ф_ticktock_tailer l =
if if1 then exec_state (↓ DePoolContract_Ф__returnChange) l else l.
Proof.

intros.

  destructLedger l.
  compute. idtac.
  repeat destructIf_solve.
Qed.

Opaque DePoolContract_Ф_ticktock_tailer.

Lemma DePoolContract_Ф_ticktock_header_exec : forall  (l: Ledger) ,
let req : bool := negb (eval_state msg_sender l =? 0)  in
let (if1, l_checkPureDePoolBalance) := run ( ↓ DePoolContract_Ф_checkPureDePoolBalance ) l in
let (r, l_updateRounds) := run ( ↓ DePoolContract_Ф_updateRounds ) l_checkPureDePoolBalance in
let l' := if if1 then l_updateRounds else l_checkPureDePoolBalance in
exec_state DePoolContract_Ф_ticktock_header l =
if req then
if if1 then errorMapDefaultF (fun _ =>  exec_state DePoolContract_Ф_ticktock_tailer l') r (fun _ => l')
       else exec_state DePoolContract_Ф_ticktock_tailer l_checkPureDePoolBalance
else l .
Proof.

  intros.

  destructLedger l.
  compute. idtac.

  destructFunction0 DePoolContract_Ф_checkPureDePoolBalance; auto. idtac.
  destructFunction0 DePoolContract_Ф_updateRounds; auto. idtac.
  repeat destructIf_solve. idtac.
  all: try rewrite <- Heqr; auto. idtac.
  all: try rewrite H0; auto. idtac.
  all: try rewrite <- Heqr0; auto. idtac.
  all: try rewrite H1; auto. idtac.
  all: try destructFunction0 DePoolContract_Ф_ticktock_tailer; auto.
 Qed.

Lemma DePoolContract_Ф_ticktock_header_eval : forall  (l: Ledger) ,
let req : bool := negb (eval_state msg_sender l =? 0)  in
let (if1, l_checkPureDePoolBalance) := run ( ↓ DePoolContract_Ф_checkPureDePoolBalance ) l in
let (r, l_updateRounds) := run ( ↓ DePoolContract_Ф_updateRounds ) l_checkPureDePoolBalance in
let l' := if if1 then l_updateRounds else l_checkPureDePoolBalance in
eval_state DePoolContract_Ф_ticktock_header  l =
if req then
if if1 then errorMapDefaultF (fun _ =>  Value (eval_state DePoolContract_Ф_ticktock_tailer l')) r (fun e => Error e)
       else Value (eval_state DePoolContract_Ф_ticktock_tailer l_checkPureDePoolBalance)
else Error Errors_ι_IS_EXT_MSG .
Proof.
  intros.

  destructLedger l.
  compute. idtac.

  destructFunction0 DePoolContract_Ф_checkPureDePoolBalance; auto. idtac.
  destructFunction0 DePoolContract_Ф_updateRounds; auto. idtac.

  repeat destructIf_solve. idtac.
  all: try rewrite <- Heqr; auto. idtac.
  all: try rewrite H0; auto. idtac.
  all: try rewrite <- Heqr0; auto. idtac.
  all: try destructFunction0 DePoolContract_Ф_ticktock_tailer; auto.

  destruct x0; auto. idtac.
  rewrite <- Heqr1.
  auto.
Qed.

Transparent  DePoolContract_Ф_ticktock_tailer.
Lemma DePoolContract_Ф_ticktock_tailer_eval : forall (l: Ledger),
let if1 : bool := negb ( eval_state msg_sender l =? eval_state tvm_address l) in

eval_state DePoolContract_Ф_ticktock_tailer l = I.
Proof.
intros.
  destructLedger l.
  compute. idtac.
  repeat destructIf_solve.
Qed.

(*good sample how to transform partial proofs to full one*)
Opaque exec_state eval_state run.
Opaque DePoolContract_Ф_ticktock_header DePoolContract_Ф_ticktock_tailer.

Lemma DePoolContract_Ф_ticktock_exec : forall (l: Ledger),
let req : bool := negb (eval_state msg_sender l =? 0)  in
let (if1, l_checkPureDePoolBalance) := run ( ↓ DePoolContract_Ф_checkPureDePoolBalance ) l in
let (r, l_updateRounds) := run ( ↓ DePoolContract_Ф_updateRounds ) l_checkPureDePoolBalance in
let l' := if if1 then l_updateRounds else l_checkPureDePoolBalance in

let if2' : bool := negb ( eval_state msg_sender l' =? eval_state tvm_address l') in
let l'' := if if2' then exec_state (↓ DePoolContract_Ф__returnChange) l' else l' in

let if2'' : bool := negb ( eval_state msg_sender l_checkPureDePoolBalance =? eval_state tvm_address l_checkPureDePoolBalance) in
let l''' := if if2'' then exec_state (↓ DePoolContract_Ф__returnChange) l_checkPureDePoolBalance else l_checkPureDePoolBalance in

exec_state DePoolContract_Ф_ticktock l =
if req then
if if1 then errorMapDefaultF (fun _ => l'') r (fun _ => l')
       else l'''
else l .

Proof.
  intros.
  rewrite DePoolContract_Ф_ticktock_header_eq.
  remember (run (↓ DePoolContract_Ф_checkPureDePoolBalance) l).
  destruct p.
  remember (run (↓ DePoolContract_Ф_updateRounds) l0).
  destruct p.
  intros.

  remember (DePoolContract_Ф_ticktock_header_exec l).
  clear Heqy.
  rewrite <- Heqp in y.
  compute in y. compute in Heqp0.
  rewrite <- Heqp0 in y.
  rewrite ?DePoolContract_Ф_ticktock_tailer_exec in y.

  setoid_rewrite y.  auto.
Qed.

Lemma DePoolContract_Ф_ticktock_eval : forall (l: Ledger),
let req : bool := negb (eval_state msg_sender l =? 0)  in
let (if1, l_checkPureDePoolBalance) := run ( ↓ DePoolContract_Ф_checkPureDePoolBalance ) l in
let (r, l_updateRounds) := run ( ↓ DePoolContract_Ф_updateRounds ) l_checkPureDePoolBalance in
let l' := if if1 then l_updateRounds else l_checkPureDePoolBalance in

eval_state DePoolContract_Ф_ticktock l =

if req then
if if1 then errorMapDefaultF (fun _ =>  Value I) r (fun e => Error e)
       else Value I
else Error Errors_ι_IS_EXT_MSG .

Proof.
  intros.
  rewrite DePoolContract_Ф_ticktock_header_eq.
  remember (run (↓ DePoolContract_Ф_checkPureDePoolBalance) l).
  destruct p.
  remember (run (↓ DePoolContract_Ф_updateRounds) l0).
  destruct p.
  intros.

  remember (DePoolContract_Ф_ticktock_header_eval l).
  clear Heqy.
  rewrite <- Heqp in y.
  compute in y. compute in Heqp0.
  rewrite <- Heqp0 in y.
  rewrite ?DePoolContract_Ф_ticktock_tailer_eval in y.

  setoid_rewrite y. auto.
Qed.

End DePoolContract_Ф_ticktock.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O B A0 A1 C Cprime P Q R Aprime A Pprime Qprime Rprime Aprimeprime : Universe, ((wd_ O A0 /\ (wd_ B A0 /\ (wd_ A0 A1 /\ (wd_ O A1 /\ (wd_ O B /\ (wd_ A0 Aprime /\ (wd_ C Cprime /\ (wd_ A0 Cprime /\ (wd_ A Aprime /\ (wd_ A O /\ (wd_ P Q /\ (wd_ Aprime O /\ (wd_ R Q /\ (wd_ O Aprimeprime /\ (wd_ Aprime Aprimeprime /\ (wd_ A0 Aprimeprime /\ (wd_ Pprime Qprime /\ (wd_ Rprime Qprime /\ (col_ A0 O Aprimeprime /\ (col_ A0 Aprimeprime B /\ (col_ A0 A1 Aprimeprime /\ (col_ A0 A Aprime /\ (col_ A0 Aprime B /\ (col_ A0 A1 Aprime /\ (col_ A0 C Cprime /\ col_ A0 A1 B))))))))))))))))))))))))) -> col_ Aprime O Aprimeprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From OGS Require Import Utils EventD ITreeD CatD AngelicD.

Definition iter {I} {E : event I I} {X Y : I -> Type} (body : X ⇒ᵢ itree E (X +ᵢ Y))
  : X ⇒ᵢ itree E Y :=
  cofix _iter i x :=
    bind (body i x) (fun _ y => match y with
                            | inl x' => Tau (_iter _ x')
                            | inr y => Ret y
                            end).

Instance ITreeMonadIter {I} (E : event I I) : MonadIter (itree E) :=
  Build_MonadIter _ (fun X Y => @iter I E X Y).

Definition translate {I} {E F : event I I} (f : E ⇒ₑ F) : itree E ⇒f itree F :=
  fun _ => cofix _translate _ u :=
    match (observe u) with
    | RetF x => Ret x
    | TauF t => Tau (_translate _ t)
    | VisF e k => let (e1, k1) := f _ e in
                 Vis e1 (fun r => match k1 r with Fib a => _translate _ (k a) end)
     end.

Definition translate_fwd {I J} {E : event I I} {F : event J J} (f0 : I -> J)
           (f : (f0 >ₑ E) ⇒ₑ (F <ₑ f0))
           X : (itree E (X ∘ f0)) ⇒ᵢ (itree F X ∘ f0) :=
  cofix _translate i u :=
    match (observe u) with
    | RetF x => @ITreeD.ret _ _ _ (f0 i) x
    | TauF t => @ITreeD.tau _ _ _ (f0 i) (_translate _ t)
    | VisF e k => let (e1, k1) := f _ e in
                 Vis e1 (fun r => fiber_rect _ _ _ (fun i _ => itree _ _ i)
                                 (fun a => _translate _ (k a)) _ (k1 r))
    end.

Definition translate_bwd {I J} {E : event I I} {F : event J J} (f0 : J -> I)
           (f : (E <ₑ f0) ⇒ₑ (f0 >ₑ F))
           X : (itree E X ∘ f0) ⇒ᵢ (itree F (X ∘ f0)) :=
  cofix _translate i u :=
    match (observe u) with
    | RetF x => Ret x
    | TauF t => Tau (_translate _ t)
    | VisF e k => let (e1, k1) := f _ e in
                 Vis e1 (fun r => _translate _ (fiber_rect _ _ _ (fun i _ => itree _ _ i)
                                                        k _ (k1 r)))
    end.

Definition comp (X : Type) : Type := itree₀ ∅ₑ X.
Definition emb_comp {I} {E : event I I} X i : comp X -> itree E (X @ i) i.
  refine (fun t => translate_fwd (fun _ => i) (fun _ (i : qry (_ >ₑ ∅ₑ) _) => ex_falso i)
                              (X @ i) t1_0 (t >>= _)).
  refine (fun 't1_0 '(Fib a) => Ret (Fib a)).
Defined.

Definition interp {I} {E : event I I}
           {M : psh I -> psh I} {MF : Functor M} {MM : Monad M} {MI : MonadIter M}
           (h : E ₑ⇒ M)
           : itree E ⇒f M :=
  fun _ => CatD.iter (fun i x => match (observe x) with
            | RetF x => CatD.ret _ (inr x)
            | TauF t => CatD.ret _ (inl t)
            | VisF e k => CatD.fmap (fun _ => inl) _ (e_arrow_eval h _ _ (existT _ e k))
            end).

Definition interp_mrec {I} {E F : event I I}
           (body : E ₑ⇒ itree (esum E F))
           : itree (esum E F) ⇒f itree F :=
  fun _ => iter (fun _ (t : itree (esum E F) _ _) => match (observe t) with
              | RetF r => Ret (inr r)
              | TauF t => Ret (inl t)
              | VisF (inl q) k => Ret (inl (body _ q >>= fiber_into _ k))
              | VisF (inr q) k => Vis q (fun r => Ret (inl (k r)))
              end).

Definition mrec {I} {E F : event I I} (body : E ₑ⇒ itree (esum E F)) : E ₑ⇒ itree F :=
  fun _ q => interp_mrec body _ _ (body _ q).

Definition trigger {I} {E : event I I} : E ₑ⇒ itree E :=
  fun _ q => Vis q (fun r => Ret (Fib r)).

Definition trigger₀ {E : event₀} (q : qry₀ E) : itree₀ E (rsp₀ E q) := vis₀ q ret₀.

Definition ecall (A : Type) (B : A -> Type) : event₀ := Event₀ A B.
Definition call {A B} : forall a, itree₀ (ecall A B) (B a) := @trigger₀ (ecall A B).
Definition rec {A B} (body : forall a, itree₀ (ecall A B) (B a)) : forall a, itree₀ ∅ₑ (B a) :=
  mrec (fun 't1_0 (a : qry₀ (ecall A B)) => translate inlₑ (B a @ _) _ (body a)) _.


Require Import FunctionalExtensionality.
Require Import Vector_of_tuple.

Ltac functional_extensionality_pair_l :=
  match goal with
    | [ |- context[(?f, ?b) = (?g, ?b)]] =>
      rewrite (functional_extensionality f g ); reflexivity
    | [ |- context[(?a, ?f) = (?a, ?g)]] =>
      rewrite (functional_extensionality f g ); reflexivity
    | _ => idtac
  end.
Ltac functional_extensionality_pair_r :=
  match goal with
    | [ |- context[(?f, ?b) = (?g, ?b)]] =>
      rewrite <- (functional_extensionality f g); try reflexivity
    | [ |- context[(?a, ?f) = (?a, ?g)]] =>
      rewrite <- (functional_extensionality f g); try reflexivity
    | _ => idtac
  end.
Ltac functional_extensionality_dep_pair_l :=
  match goal with
    | [ |- context[(?f, ?b) = (?g, ?b)]] =>
      rewrite (functional_extensionality_dep f g ); reflexivity
    | [ |- context[(?a, ?f) = (?a, ?g)]] =>
      rewrite (functional_extensionality_dep f g ); reflexivity
    | _ => idtac
  end.
Ltac functional_extensionality_dep_pair_r :=
  match goal with
    | [ |- context[(?f, ?b) = (?g, ?b)]] =>
      rewrite <- (functional_extensionality_dep f g); try reflexivity
    | [ |- context[(?a, ?f) = (?a, ?g)]] =>
      rewrite <- (functional_extensionality_dep f g); try reflexivity
    | _ => idtac
  end.

Definition Vector_of_tuple := Vector_of_tuple.Vector_of_tuple.
Definition tuple_of_Vector := Vector_of_tuple.tuple_of_Vector.