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: Cache -> nat
  }.

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

Inductive Transition (s: GlobalState) : GlobalState -> Set :=
| LoadReq: forall {c}, defined c -> leaf c -> desc (reqFn c (req s c)) = Ld ->
                       sle Sh (st s c (loc (reqFn c (req s c)))) ->
                       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 t => match decTree t c with
                                                      | left _ => S (req s t)
                                                      | _ => req s t
                                                    end
                                  |}
| StoreReq: forall {c}, defined c -> leaf c -> desc (reqFn c (req s c)) = St ->
                        (st s c (loc (reqFn c (req s c))) = Mo) ->
                        Transition s {|
                                     dt := fun t w => match decTree t c with
                                                      | left _ => match decAddr w (loc (reqFn t (req s t))) with
                                                                    | left _ => dataQ (reqFn t (req s 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 t => match decTree t c with
                                                       | left _ => S (req s t)
                                                       | _ => req s 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 => 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 c i t := match (trans oneBeh) t with
                                   | LoadReq ca _ _ _ _ =>
                                     ca = c /\ req (sys oneBeh t) c = i
                                   | StoreReq ca _ _ _ _ =>
                                     ca = c /\ req (sys oneBeh t) c = i
                                   | _ => False
                                 end.

  Definition enqLd c i sl t := match (trans oneBeh) t with
                                 | LoadReq ca _ _ _ _ =>
                                   ca = c /\ req (sys oneBeh t) c = i /\
                                   dt (sys oneBeh t) c (loc (reqFn c i)) = sl
                                 | _ => False
                               end.

  Definition enqSt c i t := match (trans oneBeh) t with
                              | StoreReq ca _ _ _ _ =>
                                ca = c /\ req (sys oneBeh t) c = i
                              | _ => False
                            end.

End mkDataTypes.


(* This file is the first file with the purpose of showing that any monoidal category admits a 'Monoidal Rezk-completion'.
More precisely: Assume that a category C is weakly equivalent to a univalent category D, by a functor H : C → D.
Then, given a product/tensor T : C ⊠ C → C, we construct a product TD on D such that H preserves the product in a 'strong sense'.
Then, we show that (D,TD) is universal along univalent categories with a product in the sense that
(D,TD) is the free univalent category equipped with a tensor of (C,T).
A more detailled explanation of the universality and the Rezk-completion is in LiftedMonoidal.v
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.PrecompEquivalence.
Require Import UniMath.CategoryTheory.catiso.

Require Import UniMath.CategoryTheory.ProductCategory.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.

Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored.
Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalFunctorCategory.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.

Require Import UniMath.CategoryTheory.DisplayedCats.TotalCategoryFacts.

Local Open Scope mor_disp.
Local Open Scope cat.

Section TensorRezk.

  Context {C D E : category} {H : functor C D}
          (Duniv : is_univalent D)
          (Euniv : is_univalent E)
          (H_eso : essentially_surjective H)
          (H_ff : fully_faithful H).

  Context (TC : functor (C ⊠ C) C)
          (TE : functor (E ⊠ E) E).

  Local Notation HH := (pair_functor H H).
  Let HH_eso := pair_functor_eso H H H_eso H_eso.
  Let HH_ff := pair_functor_ff H H H_ff H_ff.

  Definition TransportedTensor
    : functor (D ⊠ D) D
    := lift_functor_along (_,,Duniv) HH HH_eso HH_ff (functor_composite TC H).

  Definition TransportedTensorComm
    : nat_z_iso (HH ∙ TransportedTensor)
                (functor_composite TC H)
    := lift_functor_along_comm (_,,Duniv) HH HH_eso HH_ff (functor_composite TC H).

  Let TD := TransportedTensor.

  Definition precompT_data
    : disp_functor_data (pre_composition_functor _ _ E H)
                   (functor_tensor_disp_cat TD TE)
                   (functor_tensor_disp_cat TC TE).
  Proof.
    exists (λ G GG, functor_tensor_composition (pr1 (TransportedTensorComm)) GG).
    intros G1 G2 GG1 GG2 β ββ.
    intros x y.
    simpl.
    rewrite assoc.
    etrans. { apply maponpaths_2 ; exact (ββ (H x) (H y)). }
    do 2 rewrite assoc'.
    apply maponpaths.
    exact (! pr2 β _ _ (pr1 (pr1 (TransportedTensorComm)) (x, y))).
  Defined.

  Definition HT
    : disp_functor (pre_composition_functor _ _ E H)
                   (functor_tensor_disp_cat TD TE)
                   (functor_tensor_disp_cat TC TE).
  Proof.
    exists precompT_data.
    abstract (split ; intro ; intros ; apply isaprop_is_nat_trans_tensor).
  Defined.

  Definition lifted_functor_tensor
             {G : D ⟶ E}
             (HGG : functor_tensor TC TE (functor_compose H G))
    : functor_tensor TD TE G.
  Proof.
    use (lift_nat_trans_along (_,,Euniv) _ HH_eso HH_ff).
    use (nat_trans_comp _ _ _ HGG _).
    exact (post_whisker (nat_z_iso_inv TransportedTensorComm) G).
  Defined.

  Definition HT_eso : disp_functor_disp_ess_split_surj HT.
  Proof.
    intros G HGG.
    exists (lifted_functor_tensor HGG).
    use Isos.make_z_iso_disp.
    - intros c1 c2.
      simpl.
      rewrite id_right.
      rewrite (functor_id TE).
      rewrite id_left.

      (* In order to use lift_nat_along_comm, we need β to be of type
         HH · _ -> HH · _, the domain of β is not definitially
         of this form, hence, I have to do a manual 'casting' *)
      set (β :=
             nat_trans_comp
               (functor_tensor_map_dom TE (functor_compose H G))
               (functor_tensor_map_codom TC (functor_compose H G))
               (HH ∙ functor_tensor_map_codom TD G) HGG
               (post_whisker
                  (nat_z_iso_inv TransportedTensorComm)
                  G
               )
             : (nat_trans
                                 (HH  ∙ ((pair_functor G G) ∙ TE))
                                 ( HH ∙ functor_tensor_map_codom TD G))
          ).

      set (p := toforallpaths _ _ _ (base_paths _ _
                                                (lift_nat_trans_along_comm (_,,Euniv) _ HH_eso HH_ff β)) (c1,c2)).
      etrans.
      2: {
        apply maponpaths_2.
        exact (! p).
      }
      clear p.
      unfold β.

      unfold nat_trans_comp.
      unfold pr1.
      rewrite assoc'.
      etrans.
      2: {
        apply maponpaths.
        apply (functor_comp G).
      }

      etrans.
      2: {
        do 2 apply maponpaths.
        apply (! pr22 (pr2 (TransportedTensorComm) (c1,c2))).
      }
      rewrite functor_id.
      apply (! id_right _).
    - use tpair.
      2: { split ; apply isaprop_is_nat_trans_tensor. }
      intros c1 c2.
      simpl.
      rewrite id_right.
      rewrite (functor_id TE).
      rewrite id_left.
      unfold lifted_functor_tensor.

      set (β :=
             nat_trans_comp
               (functor_tensor_map_dom TE (functor_compose H G))
               (functor_tensor_map_codom TC (functor_compose H G))
               (HH ∙ functor_tensor_map_codom TD G) HGG
               (post_whisker
                  (nat_z_iso_inv TransportedTensorComm)
                  G
               )
             : (nat_trans
                                 (HH  ∙ ((pair_functor G G) ∙ TE))
                                 ( HH ∙ functor_tensor_map_codom TD G))
          ).

      set (p := toforallpaths _ _ _ (base_paths _ _
                                                (lift_nat_trans_along_comm (_,,Euniv) _ HH_eso HH_ff β)) (c1,c2)).
      etrans. {
        apply maponpaths_2.
        exact p.
      }
      clear p.
      unfold β.

      unfold nat_trans_comp.
      unfold pr1.
      rewrite assoc'.
      etrans. {
        apply maponpaths.
        apply (! functor_comp G _ _).
      }

      etrans. {
        do 2 apply maponpaths.
        apply (pr22 (pr2 (TransportedTensorComm) (c1,c2))).
      }
      rewrite functor_id.
      apply id_right.
  Qed.

  Definition HT_is_faithful
             {G1 G2 : [D, E]}
             (GG1 : functor_tensor_disp_cat TD TE G1)
             (GG2 : functor_tensor_disp_cat TD TE G2)
             (β : [D, E] ⟦ G1, G2 ⟧)
    : isincl (λ ff : GG1 -->[ β] GG2, ♯ HT ff).
  Proof.
    do 3 intro.
    assert (p : isaset ( hfiber (λ ff : GG1 -->[ β] GG2, ♯ HT ff) y)).
    {
      use isaset_hfiber ; use isasetaprop ; apply isaprop_is_nat_trans_tensor.
    }

    use tpair.
    + use total2_paths_f.
      { apply isaprop_is_nat_trans_tensor. }
      use proofirrelevance.
      use hlevelntosn.
      apply isaprop_is_nat_trans_tensor.
    + intro ; apply p.
  Qed.

  Definition HT_is_full
             {G1 G2 : [D, E]}
             (GG1 : functor_tensor_disp_cat TD TE G1)
             (GG2 : functor_tensor_disp_cat TD TE G2)
             (β : [D, E] ⟦ G1, G2 ⟧)
    :   issurjective (λ ff : GG1 -->[ β] GG2, ♯ HT ff).
  Proof.
    intro βHH.
    apply hinhpr.
    use tpair.
    2: apply isaprop_is_nat_trans_tensor.

    use is_nat_trans_tensor_to_characterization.
    use (lift_nat_trans_eq_along (_,,Euniv) _ HH_eso HH_ff).
    use nat_trans_eq.
    { apply homset_property. }
    intro cc.

    set (t := βHH (pr1 cc) (pr2 cc)).
    simpl.

    transparent assert ( ff : (E ⟦ functor_tensor_map_codom TC (pre_composition_functor C D E H G2) (pr1 cc, pr2 cc),
                                   functor_tensor_map_codom TD G2 (H (pr1 cc), H (pr2 cc)) ⟧) ).
    {
      apply #(pr1 G2).
      exact (pr1 (pr2 TransportedTensorComm  (pr1 cc, pr2 cc))).
    }

    assert (p : pr1 GG2 (H (pr1 cc), H (pr2 cc)) = (pr1 (HT G2 GG2) (pr1 cc, pr2 cc)) · ff).
    {
      etrans.
      2: {
        simpl.
        rewrite assoc'.
        apply maponpaths.
        unfold ff.
        rewrite <- (functor_comp G2).
        apply maponpaths.
        simpl.
        apply (! pr12 (pr2 TransportedTensorComm _)).
      }
      rewrite (functor_id G2).
      apply (! id_right _).
    }

    etrans. { apply maponpaths ; exact p. }
    clear p.
    rewrite assoc.
    etrans. { apply maponpaths_2 ; exact t. }
    clear t.
    simpl.
    do 2 rewrite assoc'.
    apply maponpaths.
    unfold ff.
    set (q := pr2 β _ _ (pr1 (pr2 TransportedTensorComm (pr1 cc, pr2 cc)))).
    etrans. {
      apply maponpaths.
      exact (! q).
    }
    clear q.

    rewrite assoc.
    rewrite <- (functor_comp G1).
    etrans. {
      apply maponpaths_2.
      apply maponpaths.
      apply (pr2 TransportedTensorComm).
    }
    rewrite functor_id.
    apply id_left.
  Qed.

  Definition HT_ff : disp_functor_ff HT.
  Proof.
    intro ; intros.
    apply isweqinclandsurj.
    - apply HT_is_faithful.
    - apply HT_is_full.
  Qed.

  Definition precomp_tensor_is_ff
    : fully_faithful (total_functor HT).
  Proof.
    use disp_functor_ff_to_total_ff.
    - apply precomp_fully_faithful.pre_composition_with_ess_surj_and_fully_faithful_is_fully_faithful.
      + exact H_eso.
      + exact H_ff.
    - exact HT_ff.
  Qed.

  Definition precomp_tensor_is_eso
    : essentially_surjective (total_functor HT).
  Proof.
    use disp_functor_eso_to_total_eso.
    - apply precomp_ess_surj.pre_composition_essentially_surjective.
      + exact Euniv.
      + exact H_eso.
      + exact H_ff.
    - exact HT_eso.
    - use Fibrations.iso_cleaving_category.
      apply is_univalent_functor_category.
      exact Euniv.
  Qed.

  Definition precomp_tensor_adj_equiv
    : adj_equivalence_of_cats (total_functor HT).
  Proof.
    apply rad_equivalence_of_cats.
    - apply is_univalent_total_category.
      + apply is_univalent_functor_category.
        exact Euniv.
      + apply functor_tensor_disp_cat_is_univalent.
    - exact precomp_tensor_is_ff.
    - exact precomp_tensor_is_eso.
  Defined.

  Definition precomp_tensor_catiso
    : catiso (total_category (functor_tensor_disp_cat TransportedTensor TE))
             (total_category (functor_tensor_disp_cat TC TE)).
  Proof.
    use (adj_equivalence_of_cats_to_cat_iso precomp_tensor_adj_equiv _ _).
    - apply (is_univalent_total_category (is_univalent_functor_category _ _ Euniv) (functor_tensor_disp_cat_is_univalent _ _)).
    - apply (is_univalent_total_category (is_univalent_functor_category _ _ Euniv) (functor_tensor_disp_cat_is_univalent _ _)).
  Defined.

End TensorRezk.


Require Import Raft.
Require Import RaftMsgRefinementInterface.

Section GhostLogsLogProperties.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition msg_log_property (P : list entry -> Prop) :=
    forall net h,
      msg_refined_raft_intermediate_reachable net ->
      P (log (snd (nwState net h))).

  Definition log_properties_hold_on_ghost_logs net :=
    forall P p,
      msg_log_property P ->
      In p (nwPackets net) ->
      P (fst (pBody p)).

  Class log_properties_hold_on_ghost_logs_interface : Prop :=
    {
      log_properties_hold_on_ghost_logs_invariant :
        forall (net : network),
          msg_refined_raft_intermediate_reachable net ->
          log_properties_hold_on_ghost_logs net
    }.

End GhostLogsLogProperties.


Require Import Raft.
Require Import RaftRefinementInterface.

Require Import CommonDefinitions.

Section LeaderLogsLogMatching.

  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition leaderLogs_entries_match_host (net : network) : Prop :=
    forall h h' t ll,
      In (t, ll) (leaderLogs (fst (nwState net h'))) ->
      entries_match (log (snd (nwState net h))) ll.

  Class leaderLogs_entries_match_interface : Prop :=
    {
      leaderLogs_entries_match_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          leaderLogs_entries_match_host net
    }.
End LeaderLogsLogMatching.


From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.
From BitBlasting Require Import QFBV CNF BBCommon BBAdd.
From ssrlib Require Import ZAriths Tactics Bools Seqs.
From nbits Require Import NBits.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* ===== bit_blast_uaddo ===== *)

Definition bit_blast_uaddo g ls1 ls2: generator * cnf * literal :=
  let '(g', cs, cout, lrs) := bit_blast_full_adder g lit_ff ls1 ls2 in
  (g', cs, cout).

Lemma bit_blast_uaddo_correct g bs1 bs2 E ls1 ls2 g' cs lr :
  bit_blast_uaddo g ls1 ls2 = (g', cs, lr) ->
  size ls1 == size ls2 ->
  enc_bits E ls1 bs1 -> enc_bits E ls2 bs2 ->
  interp_cnf E (add_prelude cs) ->
  enc_bit E lr (carry_addB bs1 bs2).
Proof.
  rewrite /bit_blast_uaddo.
  case Hblast: (bit_blast_full_adder g lit_ff ls1 ls2) => [[[og ocs] olcout] olrs].
  case HadcB: (adcB false bs1 bs2) => [obcout obrs].
  case=> _ Hocs Holr => Hsz Henc1 Henc2 Hcs.
  rewrite -Hocs in Hcs.
  rewrite -Holr.
  move: (add_prelude_enc_bit_ff Hcs) => Hff.
  move: (bit_blast_full_adder_correct2 Hblast Henc1 Henc2 Hff Hcs HadcB (eqP Hsz)).
  by rewrite/carry_addB HadcB.
Qed.

Definition mk_env_uaddo E g ls1 ls2: env * generator * cnf * literal :=
  let '(E', g', cs, cout, lrs) := mk_env_full_adder E g lit_ff ls1 ls2 in
  (E', g', cs, cout).

Lemma mk_env_uaddo_is_bit_blast_uaddo E g ls1 ls2 E' g' cs lr:
    mk_env_uaddo E g ls1 ls2 = (E', g', cs, lr) ->
    bit_blast_uaddo g ls1 ls2 = (g', cs, lr).
Proof.
  rewrite /mk_env_uaddo /bit_blast_uaddo.
  case Hmk: (mk_env_full_adder E g lit_ff ls1 ls2 ) => [[[[E'0 g'0] cs0] cout] lrs0].
  move : (mk_env_full_adder_is_bit_blast_full_adder Hmk) => Hbb.
  rewrite Hbb. move =>[] _ <- <- <-.
  done.
Qed.

Lemma mk_env_uaddo_newer_gen E g ls1 ls2 E' g' cs lr :
    mk_env_uaddo E g ls1 ls2 = (E', g', cs, lr) ->
    (g <=? g')%positive.
Proof.
  rewrite /mk_env_uaddo.
  case Hmk: (mk_env_full_adder E g lit_ff ls1 ls2) => [[[[E'0 g'0] cs0] cout] lrs0]. move => [] _ <- _ _.
  apply (mk_env_full_adder_newer_gen Hmk).
Qed.

Lemma mk_env_uaddo_newer_res E g ls1 ls2 E' g' cs lr :
    mk_env_uaddo E g ls1 ls2 = (E', g', cs, lr) ->
    newer_than_lit g lit_tt ->
    newer_than_lit g' lr.
Proof.
  rewrite /mk_env_uaddo.
  case Hmk: (mk_env_full_adder E g lit_ff ls1 ls2) => [[[[E'0 g'0] cs0] cout] lrs0].
  move => [] _ <- _ <- Hngtt.
  apply (mk_env_full_adder_newer_cout Hmk Hngtt).
Qed.

Lemma mk_env_uaddo_newer_cnf E g ls1 ls2 E' g' cs lr:
  mk_env_uaddo E g ls1 ls2 = (E', g', cs, lr) ->
  newer_than_lit g lit_tt ->
  newer_than_lits g ls1 ->
  newer_than_lits g ls2 ->
  newer_than_cnf g' cs.
Proof.
  rewrite /mk_env_uaddo.
  case Hmk: (mk_env_full_adder E g lit_ff ls1 ls2) => [[[[E'0 g'0] cs0] cout] lrs0].
  case=> _ <- <- _ Hgtt Hgls1 Hgls2.
  generalize Hgtt; rewrite newer_than_lit_tt_ff => Hgff .
  exact (mk_env_full_adder_newer_cnf Hmk Hgls1 Hgls2 Hgtt Hgff).
Qed.

Lemma mk_env_uaddo_preserve E g ls1 ls2 E' g' cs lr :
    mk_env_uaddo E g ls1 ls2 = (E', g', cs, lr) ->
    env_preserve E E' g.
Proof.
  rewrite /mk_env_uaddo.
  case Hmk: (mk_env_full_adder E g lit_ff ls1 ls2) => [[[[E'0 g'0] cs0] cout] lrs0].
  move => [] <- _ _ _.
  apply (mk_env_full_adder_preserve Hmk).
Qed.

Lemma mk_env_uaddo_sat E g ls1 ls2 E' g' cs lr :
  mk_env_uaddo E g ls1 ls2 = (E', g', cs, lr) ->
  newer_than_lit g lit_tt ->
  newer_than_lits g ls1 ->
  newer_than_lits g ls2 ->
  interp_cnf E' cs.
Proof.
  rewrite /mk_env_uaddo.
  case Hmk: (mk_env_full_adder E g lit_ff ls1 ls2) => [[[[E'0 g'0] cs0] cout] lrs0].
  move => [] <- _ <- _ Hgtt Hgls1 Hgls2.
  exact: (mk_env_full_adder_sat Hmk Hgls1 Hgls2 Hgtt).
Qed.

Lemma mk_env_uaddo_env_equal E1 E2 g ls1 ls2 E1' E2' g1' g2' cs1 cs2 lr1 lr2 :
  env_equal E1 E2 ->
  mk_env_uaddo E1 g ls1 ls2 = (E1', g1', cs1, lr1) ->
  mk_env_uaddo E2 g ls1 ls2 = (E2', g2', cs2, lr2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lr1 = lr2.
Proof.
  rewrite /mk_env_uaddo => Heq.
  dcase (mk_env_full_adder E1 g lit_ff ls1 ls2)
  => [[[[[E_add1 g_add1] cout_add1] cs_add1] lrs_add1] Hadd1].
  dcase (mk_env_full_adder E2 g lit_ff ls1 ls2)
  => [[[[[E_add2 g_add2] cout_add2] cs_add2] lrs_add2] Hadd2].
  move: (mk_env_full_adder_env_equal Heq Hadd1 Hadd2)
  => {Heq Hadd1 Hadd2} [Heq [? [? [? ?]]]]; subst.
  case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
Qed.


Require Import Heaps Reflect.
Require SepExpr Expr Unfolder.
Require Decidables.
Import Expr.
Require Import EquivDec.
Require Import List.

Set Implicit Arguments.

Module Make (ST : SepTheoryX.SepTheoryXType).
  Module SEP := SepExpr.Make ST.
  Module U := Unfolder.Make SEP.
  Module PACK := U.PACK.

  (** Just some test separation logic predicates **)
  Section Tests.
    Variables pc state : Type.

    Variable f : nat -> ST.hprop pc state nil.
    Variable h : bool -> unit -> ST.hprop pc state nil.
    Variable g : bool -> nat -> nat -> nat.

    Ltac isConst e :=
      match e with
        | true => true
        | false => true
        | O => true
        | S ?e => isConst e
        | _ => false
      end.

    Definition nat_type := {|
      Impl := nat;
      Eq := fun x y => match equiv_dec x y with
                         | left pf => Some pf
                         | _ => None
                       end
      |}.

    Definition bool_type := {|
      Impl := bool;
      Eq := fun x y => match equiv_dec x y with
                         | left pf => Some pf
                         | _ => None
                       end
      |}.

    Definition unit_type := {|
      Impl := unit;
      Eq := fun x y => match equiv_dec x y with
                         | left pf => Some pf
                         | _ => None
                       end
      |}.

    Definition types0 := nat_type :: bool_type :: unit_type :: nil.

    Definition env0 : PACK.TypeEnv (Env.listToRepr ({| Impl := pc ; Eq := fun _ _ => None |} :: {| Impl := state ; Eq := fun _ _ => None |} :: nil) EmptySet_type) (tvType 0) (tvType 1) :=
      {| PACK.Types := Env.nil_Repr EmptySet_type
       ; PACK.Funcs := fun ts => Env.nil_Repr (Default_signature _)
       ; PACK.Preds := fun ts => Env.nil_Repr (SEP.Default_predicate _ _ _)
      |}.

    Fixpoint assumptionProver (types : list type) (Hs : list (expr types)) (P : expr types) :=
      match Hs with
        | nil => false
        | H :: Hs' => match expr_seq_dec H P with
                        | Some _ => true
                        | None => assumptionProver Hs' P
                      end
      end.

    Hypothesis Hemp : forall cs, ST.himp cs (ST.emp pc state) (ST.emp pc state).
    Hypothesis Hf : forall cs, ST.himp cs (f 0) (ST.emp _ _).
    Hypothesis Hh : forall cs, ST.himp cs (h true tt) (ST.star (h true tt) (f 13)).

    Hypothesis Hf0 : forall n cs, ST.himp cs (f n) (ST.emp _ _).
    Hypothesis Hh0 : forall b u cs, ST.himp cs (h b u) (ST.star (h (negb b) tt) (f 13)).

    Hypothesis Hf1 : forall n, n <> 0 -> forall cs, ST.himp cs (f n) (ST.emp _ _).
    Hypothesis Hh1 : forall b u, b = false -> u <> tt -> forall cs, ST.himp cs (h b u) (ST.star (h b tt) (f 13)).

    (** * Creating hint databases *)

    Ltac prepare := U.prepareHints ltac:(fun x => x) pc state isConst env0.

    Definition hints_tt : U.hints.
      prepare tt tt ltac:(fun x => refine x).
    Defined.
    (*Print hints_tt.*)

    Definition hints_emp : U.hints.
      prepare Hemp Hemp ltac:(fun x => refine x).
    Defined.
    (*Print hints_emp.*)

    Definition hints_Hf : U.hints.
      prepare Hf Hemp ltac:(fun x => refine x).
    Defined.
    (* Print hints_Hf. *)

    Definition hints_Hh : U.hints.
      prepare (Hemp, Hf) (Hemp, Hf, Hh) ltac:(fun x => refine x).
    Defined.
    (* Print hints_Hh. *)

    Definition hints_Hf0 : U.hints.
      prepare Hf0 tt ltac:(fun x => refine x).
    Defined.
    (* Print hints_Hf0. *)

    Definition hints_glom : U.hints.
      prepare (Hemp, Hf, Hh, Hf0) (Hemp, Hf0, tt) ltac:(fun x => refine x).
    Defined.
    (* Print hints_glom. *)

    Definition hints_Hh0 : U.hints.
      prepare Hh0 tt ltac:(fun x => refine x).
    Defined.
    (* Print hints_Hh0. *)

    Definition hints_Hf1 : U.hints.
      prepare Hf1 tt ltac:(fun x => refine x).
    Defined.
    (* Print hints_Hf1. *)

    Definition hints_Hh1 : U.hints.
      prepare Hh1 tt ltac:(fun x => refine x).
    Defined.
    (* Print hints_Hh1. *)

    (** * Simplifying some goals *)

    Import U.
    Import SEP.

    Ltac exec hs := cbv beta iota zeta delta [SEP.hash forallEach Vars UVars Heap
      forward backward unfoldForward unfoldBackward fmFind Unfolder.FM.fold
        SEP.impures SEP.pures SEP.other
        Unfolder.FM.add star_SHeap multimap_join liftSHeap
        SepExpr.FM.empty SepExpr.FM.map SepExpr.FM.find ExprUnify.empty_Subst
        app rev_append map length Compare_dec.lt_eq_lt_dec
        findWithRest findWithRest' find Forward Backward
        Types PcType StateType Hints Lhs Rhs
        equiv_dec ExprUnify.exprUnifyArgs ExprUnify.fold_left_2_opt
        ExprUnify.exprUnify exprSubstU sheapSubstU EqDec_tvar tvar_rec tvar_rect sumbool_rec sumbool_rect
        eq_rec_r eq_rec eq_rect eq_sym f_equal ExprUnify.get_Eq
        nth_error value error Eq liftExpr Decidables.seq_dec ExprUnify.Subst_lookup SHeap_empty
        exists_subst ExprUnify.env_of_Subst fst snd tvarD sexprD
        Impl sheapD starred fold_right applyD
        SEP.SDomain SEP.SDenotation exprD Domain Range Denotation
        ExprUnify.Subst Compare_dec.lt_dec Compare_dec.le_dec Foralls plus minus
        Compare_dec.le_gt_dec Compare_dec.le_lt_dec
        ExprUnify.Subst_replace SemiDec_expr expr_seq_dec
        lookupAs projT1 projT2 Unfolder.allb andb Hyps
        substExpr substSexpr tvar_val_sdec

        hs
        Peano_dec.eq_nat_dec nat_eq_eqdec nat_rec nat_rect
        bool_eqdec Bool.bool_dec bool_rec bool_rect
        unit_eqdec unit_rec unit_rect
        assumptionProver EquivDec_nat EquivDec_bool substV Impl_
        SEP.hash'
        Prover.Prove Provers.reflexivityProver
        Prover.Summarize
        Provers.reflexivityProve expr_seq_dec
    ].

    Ltac unfolder' hs n := U.unfolder isConst hs n.
    Ltac unfolder hs := unfolder' hs 10; exec hs.
    Ltac unfolder_noexec hs := unfolder' hs 10.

    Theorem f_easy : forall cs, ST.himp cs (f 0) (ST.emp _ _).
      Time unfolder hints_Hf.
      reflexivity.
    Qed.

    Theorem f_easy2 : forall cs, ST.himp cs (ST.star (f 0) (f 0)) (ST.emp _ _).
      Time unfolder hints_Hf.
      reflexivity.
    Qed.

    Theorem f_easy3 : forall cs, ST.himp cs (ST.star (f 0) (ST.star (f 0) (f 0))) (ST.emp _ _).
      Time unfolder hints_Hf.
      reflexivity.
    Qed.

    Hypothesis Hh' : forall cs, ST.himp cs (h true tt) (ST.emp _ _).

    Definition hints_Hf_Hh' : U.hints.
      prepare (Hf, Hh') tt ltac:(fun x => refine x).
    Defined.

    Theorem f_and_h : forall cs, ST.himp cs (ST.star (h true tt) (f 0)) (ST.emp _ _).
      Time unfolder hints_Hf_Hh'.
      reflexivity.
    Qed.

    Theorem f0 : forall cs, ST.himp cs (f 42) (ST.emp _ _).
      Time unfolder hints_Hf0.
      reflexivity.
    Qed.

    Theorem f04 : forall cs, ST.himp cs (ST.star (ST.star (f 42) (f 42)) (ST.star (f 42) (f 42))) (ST.emp _ _).
      Time unfolder hints_Hf0.
      reflexivity.
    Qed.

    Hypothesis fex : forall cs, ST.himp cs (f 0) (ST.ex (fun b => h b tt)).
    Hypothesis hgo : forall b u cs, ST.himp cs (h b u) (ST.emp _ _).

    Definition hints_fex : U.hints.
      prepare (fex, hgo) tt ltac:(fun x => refine x).
    Defined.

    Theorem test_fex : forall cs, ST.himp cs (f 0) (ST.emp _ _).
      Time unfolder hints_fex.
      reflexivity.
    Qed.

    (** Backward time! *)

    Hypothesis Hb_f : forall cs, ST.himp cs (ST.emp _ _) (f 0).

    Definition hints_Hb_f : U.hints.
      prepare tt Hb_f ltac:(fun x => refine x).
    Defined.

    Theorem test_Hb_f : forall cs, ST.himp cs (ST.emp _ _) (f 0).
      Time unfolder hints_Hb_f.
      reflexivity.
    Qed.

    Theorem test_Hb_f3 : forall cs, ST.himp cs (ST.emp _ _) (ST.star (f 0) (ST.star (f 0) (f 0))).
      Time unfolder hints_Hb_f.
      reflexivity.
    Qed.

    Hypothesis f02 : forall cs, ST.himp cs (f 0) (f 2).
    Hypothesis f21 : forall cs, ST.himp cs (f 2) (f 1).

    Definition hints_f2 : U.hints.
      prepare f02 f21 ltac:(fun x => refine x).
    Defined.

    Theorem test_f2 : forall cs, ST.himp cs (f 0) (f 1).
      Time unfolder hints_f2.
      reflexivity.
    Qed.

    Theorem test_f2' : forall cs, ST.himp cs (ST.star (f 0) (ST.star (f 0) (f 0))) (ST.star (ST.star (f 1) (f 1)) (f 1)).
      Time unfolder hints_f2.
      reflexivity.
    Qed.

    Hypothesis Hb_f0 : forall n cs, ST.himp cs (ST.emp _ _) (f n).

    Definition hints_Hb_f0 : U.hints.
      prepare tt Hb_f0 ltac:(fun x => refine x).
    Defined.

    Theorem test_Hb_f0 : forall cs, ST.himp cs (ST.emp _ _) (f 42).
      Time unfolder hints_Hb_f0.
      reflexivity.
    Qed.

    Theorem test_Hb_f0' : forall cs, ST.himp cs (ST.emp _ _) (ST.star (f 42) (f 19)).
      Time unfolder hints_Hb_f0.
      reflexivity.
    Qed.

    Hypothesis fexb : forall cs, ST.himp cs (ST.ex (fun b => ST.star (h b tt) (h b tt))) (f 0).
    Hypothesis hgob : forall u b cs, ST.himp cs (ST.emp _ _) (h b u).

    Definition hints_fexb : U.hints.
      prepare tt (fexb, hgob) ltac:(fun x => refine x).
    Defined.

    Theorem test_fexb : forall cs, ST.himp cs (ST.emp _ _) (f 0).
      Time unfolder hints_fexb.
      exists true; reflexivity.
    Qed.

    Theorem test_fexb' : forall cs, ST.himp cs (ST.emp _ _) (ST.star (f 0) (f 0)).
      Time unfolder hints_fexb.
      repeat exists true; reflexivity.
    Qed.

    Hypothesis fexb' : forall cs, ST.himp cs (ST.ex (fun u => h true u)) (f 1).

    Definition hints_fexb' : U.hints.
      prepare tt (fexb, fexb', hgob) ltac:(fun x => refine x).
    Defined.

    Theorem test_fexb'' : forall cs, ST.himp cs (ST.emp _ _) (ST.star (f 0) (f 1)).
      Time unfolder hints_fexb'.
      exists true; exists tt; reflexivity.
    Qed.

    (** * Pure conjuncts *)

    Ltac easy := intros; hnf; PropXTac.propxFo.

    Theorem simple : forall cs, ST.himp cs (ST.inj (PropX.Inj True)) (ST.inj (PropX.Inj (pc := pc) (state := state) (1 = 1))).
      Time unfolder hints_tt.
    Abort.

    Hypothesis Hf1' : False -> forall cs, ST.himp cs (f 0) (ST.emp _ _).

    Definition hints_Hf1' : U.hints.
      prepare Hf1' tt ltac:(fun x => refine x).
    Defined.

    Theorem test_Hf1' : forall cs, ST.himp cs (ST.star (ST.inj (PropX.Inj False)) (f 0)) (ST.emp _ _).
      Time unfolder hints_Hf1'.
    Abort.

    Theorem test_Hf1'_bad : forall cs, ST.himp cs (ST.star (ST.inj (PropX.Inj True)) (f 0)) (ST.emp _ _).
      Time unfolder hints_Hf1'.
    Abort.

    Hypothesis Hf_eq0 : 0 = 0 -> forall cs, ST.himp cs (f 0) (ST.emp _ _).

    Definition hints_Hf_eq0 : U.hints.
      prepare Hf_eq0 tt ltac:(fun x => refine x).
    Defined.

    Theorem test_Hf_eq0 : forall cs, ST.himp cs (ST.star (ST.inj (PropX.Inj (0 = 0))) (f 0)) (ST.emp _ _).
      Time unfolder hints_Hf_eq0.
    Abort.

    Theorem test_Hf_eq0_wrong : forall cs, ST.himp cs (ST.star (ST.inj (PropX.Inj (0 <> 0))) (f 0)) (ST.emp _ _).
      Time unfolder hints_Hf_eq0.
    Abort.

    Hypothesis Hf_eqn : forall n, n = n -> forall cs, ST.himp cs (f n) (ST.emp _ _).

    Definition hints_Hf_eqn : U.hints.
      prepare Hf_eqn tt ltac:(fun x => refine x).
    Defined.

    Theorem test_Hf_eqn : forall n cs, ST.himp cs (ST.star (ST.inj (PropX.Inj (n = n))) (f n)) (ST.emp _ _).
      Time unfolder hints_Hf_eqn.
    Abort.

    Theorem test_Hf_eqn_wrong : forall n cs, ST.himp cs (ST.star (ST.inj (PropX.Inj (n <> n))) (f n)) (ST.emp _ _).
      Time unfolder hints_Hf_eqn.
      (* Also broken by change to [himp] *)
    Abort.

    (** Reflection performance testing *)

    Fixpoint many_f n :=
      match n with
        | O => f 0
        | S n' => ST.star (f 0) (many_f n')
      end.

    Theorem test_many : forall cs, ST.himp cs (many_f 19) (ST.emp _ _).
      simpl.
      Time unfolder' hints_Hf 20; exec hints_Hf.
      easy.
    Qed.

  End Tests.

End Make.


Require Import ExtLib.Core.RelDec.

Require Import MirrorCore.RTac.RTac.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.ExprSubst.
Require Import MirrorCore.SymI.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.SubstI.
Require Import MirrorCore.Lambda.ExprUnify_simul.

Section EAutoTac.
	Context {typ func : Type}.
	Context {RType_typ : RType typ}.
	Context {Typ2_typ : Typ2 RType_typ Fun}.
	Context {Typ0_typ : Typ0 RType_typ Prop}.
	Context {RSym_func : @RSym _ RType_typ func}.
	Context {EU : ExprUVar (expr typ func)}.
	Context {MA : MentionsAny (expr typ func)}.

	Definition EAPPLY := @EAPPLY typ (expr typ func) RType_typ Typ0_typ EU MA
                      (@vars_to_uvars _ _)
                      (fun subst SS SU tus tvs n l r t s =>
                         @exprUnify subst typ func RType_typ RSym_func Typ2_typ
                                    SS SU 10 tus tvs n l r t s).

End EAutoTac.

Implicit Arguments EAPPLY [[RType_typ] [Typ2_typ] [Typ0_typ] [RSym_func] [EU] [MA]].