From mathcomp Require Import ssreflect seq ssrint ssrfun.
From Coq.Strings Require Import Ascii String.
Require Import Coq.Program.Basics.

Require Import Syntax Common State Types State Memory.

Require Import Operational.

Open Scope string.

Definition iptr b o := AnyPtr Int64 $ Goodptr Int64 b o.

Definition testfun instr := mk_fun 0 "main" nil instr.
Definition tproc pid  cont : proc_state := mk_proc_state pid nil nil nil nil nil nil cont nil nil nil.
Definition teststate instr := MGood  [:: tproc 0 nil ; tproc 1 [:: instr ] ]
                                     [:: testfun instr].
Definition empty2 instr := MGood [:: tproc 0 nil ; tproc 1 nil ] [:: testfun instr].

Theorem test_skip:  ss_reduce (teststate Skip) (empty2 Skip).
    by eapply ( ss_skip _ _ 1). Qed.

Import Relation_Operators.

Theorem ss_implies_bs s s': ss_reduce s s' -> bs_reduce s s'.
  move=> H.
  eapply rt1n_trans.
  eapply H.
  eapply rt1n_refl.
Qed.

Theorem test_skip_bs: bs_reduce (teststate Skip) (empty2 Skip).
  by eapply ss_implies_bs ; eapply (ss_skip _ _ 1).
Qed.

Definition reduce_interp s := ss_reduce s (interpret_ss s 1).

(*** TESTS ***)

Theorem test_skip': reduce_interp (teststate Skip).
  by eapply (ss_skip _ _ 1).
Qed.

Theorem test_alloc_anon: reduce_interp (teststate (Alloc Stack Int64 None 1)).
    by eapply (ss_alloc_anon _ _ 1).
Qed.

Theorem test_alloc: reduce_interp (teststate (Alloc Stack Int64 (Some "hey") 1)).
    by eapply (ss_alloc _ _ 1).
Qed.

Definition prog_if_true := If (Lit (ValueI64 (Posz 4))) (Alloc Stack Int64 None 1) (Alloc Stack Int64 None 2).

Theorem test_if_true: reduce_interp (teststate prog_if_true).
    by eapply (ss_if_true _ _ 1).
Qed.

Compute interpret_ss (teststate prog_if_true) 1.

Definition prog_if_false := If (Lit (ValueI8 (Posz 0))) (Alloc Stack Int64 None 1) (Alloc Stack Int64 None 2).

Theorem test_if_false: reduce_interp (teststate prog_if_false).
    by eapply (ss_if_false _ _ 1).
Qed.

Definition prog_while_true := While (Lit (ValueI64 (Posz 1))) (Alloc Stack Int64 None 0).
Definition prog_while_false := While (Lit (ValueI64 (Posz 0))) (Alloc Stack Int64 None 0).

Theorem test_while_true: reduce_interp (teststate prog_while_true).
    by eapply (ss_while_true _ _ 1).
Qed.

Theorem test_while_false: reduce_interp (teststate prog_while_false).
    by eapply (ss_while_false _ _ 1).
Qed.

Theorem test_codeblock: reduce_interp (teststate $ CodeBlock [:: Alloc Stack Int64 None 0 ] ).
    by eapply (ss_codeblock _ _ 1).
Qed.

Definition state_with_mem := interpret_ss (teststate $ Alloc Stack Int64 (Some "x") 1) 1.

Definition mix_statement ms pid stat := ms_mod_proc pid (ps_mod_cont (cons stat)) ms.

Compute  mix_statement state_with_mem 1 $ Assign (Lit (ValuePtr (AnyPtr Int64 (Goodptr Int64 0 0)))) (Lit (ValueI64 (Posz 11))).
Compute interpret_ss  ( mix_statement state_with_mem 1 $ Assign (Lit (ValuePtr (AnyPtr Int64 (Goodptr Int64 0 0)))) (Lit (ValueI64 (Posz 11)))) 1.

Theorem test_assign: reduce_interp (mix_statement state_with_mem 1 $ Assign (Lit (ValuePtr (AnyPtr Int64 (Goodptr Int64 0 0)))) (Lit (ValueI64 (Posz 11)))).
  by eapply (ss_assign _ _ 1).
Qed.

Theorem test_assign_type_conv: reduce_interp (mix_statement state_with_mem 1 $ Assign (Lit (ValuePtr (AnyPtr Int32 (Goodptr _ 0 0)))) (Lit (ValueI64 (Posz 11)))).
  by eapply (ss_assign _ _ 1).
Qed.

Definition simple_state pid vars mem cont := mk_proc_state pid vars nil nil nil nil mem cont nil nil nil.

Definition call_state := MGood [::
                                  simple_state 0 nil nil nil;
                                 simple_state 1 nil nil [:: Call "f" nil]
                               ] [:: mk_fun 0 "main" nil Skip;
                                   mk_fun 1 "f" nil $ Alloc Stack Int64 (Some "x") 1 ].

Theorem test_call: reduce_interp call_state.
   by eapply (ss_call _ _ 1).
Qed.

Theorem test_enter: reduce_interp (teststate Enter).
 by eapply (ss_enter _ _ 1).
Qed.

Definition LocVarBlock id t v := mk_block Stack id (size_of t) t [:: v].
Definition LocVarBlockInt64 id v := LocVarBlock id Int64 (ValueI64 v).

Definition test_leave_state := MGood
                                 [::
                                    simple_state 0 nil nil nil;
                                   simple_state 1 [:: [:: declare_var "x" Int64 0 ] ; [:: declare_var "y" Int32 1 ] ]
                                                [:: LocVarBlockInt64 0 6; LocVarBlockInt64 1 4]
                                                    [:: Leave]
                                 ] [:: ].
Compute interpret_ss test_leave_state 1.

Theorem test_leave: reduce_interp test_leave_state.
    by  eapply (ss_leave _ _ 1).
Qed.

Definition pushreg_state := MGood [::
                                     simple_state 0 nil nil nil;
                                    simple_state 1 nil [:: LocVarBlockInt64 0 6 ]
                                                 [::
                                                    BspPushReg
                                                    (Lit (ValuePtr (AnyPtr Int32 (Goodptr _ 0 0))))
                                                    (Lit (ValueI64 (Posz (size_of Int64)))) ]
                                  ]
                                  nil.

Theorem test_pushreg: reduce_interp pushreg_state.
    by eapply (ss_bsp_push _ _ 1).
Qed.

Compute interpret_ss pushreg_state 1.

Definition popreg_state := MGood [::
                                     simple_state 0 nil nil nil;
                                    simple_state 1 nil [:: LocVarBlockInt64 0 6 ]
                                                 [::
                                                    BspPopReg
                                                    (Lit (ValuePtr (AnyPtr Int32 (Goodptr _ 0 0)))) ]
                                  ]
                                  nil.

Theorem test_popreg: reduce_interp popreg_state.
    by eapply (ss_bsp_pop _ _ 1).
Qed.

Definition IntPtr b o:=  AnyPtr Int64 ( Goodptr _ b o).
Definition VIntPtr b o := ValuePtr $ IntPtr b o.

Theorem test_get: reduce_interp ( teststate $
                                             BspGet
                                             (Lit $ ValueI64 0)
                                             (Lit $ VIntPtr 0 0)
                                             (Lit $ ValueI64 0)
                                             (Lit $ VIntPtr 0 0)
                                             (Lit $ ValueI64 (Posz 0))).
    by  eapply (ss_bsp_get _ _ 1).
Qed.

Notation "{* b o : t }" := (AnyPtr t (Goodptr t b o)) (at level 55, no associativity).

Definition test_put_state := MGood
                                     [::
                                        mk_proc_state
                                        0
                                        nil
                                        nil
                                        [:: nil ; nil ]
                                        nil
                                        nil
                                        [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11]
                                        nil
                                        [:: ( IntPtr 0 0, 8 )]
                                        nil
                                        nil ;
                                       mk_proc_state
                                         1
                                         nil
                                         nil
                                         [:: nil; nil]
                                         nil
                                         nil
                                         [:: LocVarBlockInt64 0 4; LocVarBlockInt64 1 5; LocVarBlockInt64 2 6 ]
                                         [:: BspPut (Lit $ ValueI64 0)
                                            (Lit $ VIntPtr 2 0)
                                            (Lit $ ValueI64 0)
                                            (Lit $ VIntPtr 1 0)
                                            (Lit $ ValueI64 8) ]

                                         [:: ( IntPtr 2 0, 8 )]

                                         nil
                                         nil ] nil.

Compute interpret_ss test_put_state 1.

Definition test_put: reduce_interp test_put_state.
  by eapply (ss_bsp_put _ _ 1).
Qed.

Theorem test_sync_end1 : ss_reduce (MGood [::
                                             simple_state 0 nil nil  [:: BspSync] ;
                                            simple_state 1 nil nil [:: BspSync]
                                          ]
                                          nil)
                                   (MGood [::
                                             simple_state 0 nil nil  nil ;
                                            simple_state 1 nil nil nil
                                          ]
                                          nil).
by  eapply (ss_sync_end ).
Qed.
(*
Definition test_sync_pop_state :=
  ms_mod_proc 1 (
                ps_mod_queue_pop (cons $ Pop $  IntPtr 0 0 )
c                                 \o ps_mod_reg_loc ( cons ( IntPtr 0 0 , 8) )
                                 \o ps_mod_cont (cons BspSync)
                                 \o ps_mod_mem (const
              )
$  empty_state 2.*)

Definition test_sync_pop_state := MGood [::
                                              mk_proc_state
                                                0
                                                nil
                                                nil
                                                nil
                                                [:: Pop $ IntPtr 0 0]
                                                nil
                                                [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11]
                                                [:: BspSync]
                                                [:: ( IntPtr 0 0, 8 )]
                                                nil
                                                nil ;
                                             mk_proc_state
                                                1
                                                nil
                                                nil
                                                nil
                                                [:: Pop $ IntPtr 1 0]
                                                nil
                                                [:: LocVarBlockInt64 0 11; LocVarBlockInt64 1 4; LocVarBlockInt64 2 13 ]
                                                [:: BspSync]
                                                [:: ( IntPtr 1 0, 8 )]
                                                nil
                                                nil ] nil.

Theorem test_sync_pop : ss_reduce test_sync_pop_state  (apply_pop_regs_one test_sync_pop_state).
  eapply (ss_sync_pop _ _); try done.
Qed.

Definition test_sync_push_state := MGood
                                     [::
                                        mk_proc_state
                                        0
                                        nil
                                        nil
                                        nil
                                        nil
                                        [:: Push (IntPtr 0 0) (size_of Int64) ]
                                        [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11]
                                        [:: BspSync]
                                        nil
                                        nil
                                        nil ;
                                       mk_proc_state
                                         1
                                         nil
                                         nil
                                         nil
                                         nil
                                         [:: Push (IntPtr 1 0) (size_of Int64) ]
                                         [:: LocVarBlockInt64 0 11; LocVarBlockInt64 1 4; LocVarBlockInt64 2 13 ]
                                         [:: BspSync]
                                         nil
                                         nil
                                         nil ] nil.

Definition test_sync_push_state' := MGood
                                     [::
                                        mk_proc_state
                                        0
                                        nil
                                        nil
                                        nil
                                        nil
                                        nil
                                        [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11]
                                        [:: BspSync]
                                        [:: ( IntPtr 0 0, 8 )]
                                        nil
                                        nil ;
                                       mk_proc_state
                                         1
                                         nil
                                         nil
                                         nil
                                         nil
                                         nil
                                         [:: LocVarBlockInt64 0 11; LocVarBlockInt64 1 4; LocVarBlockInt64 2 13 ]
                                         [:: BspSync]
                                         [:: ( IntPtr 1 0, 8 )]

                                         nil
                                         nil ] nil.

Theorem test_sync_push: ss_reduce test_sync_push_state test_sync_push_state'.
    by eapply (ss_sync_push _ _). Qed.

Definition test_sync_get_state := MGood
                                     [::
                                        mk_proc_state
                                        0
                                        nil
                                        [:: Get _ 1 (Goodptr Int64 0 0) (Posz 0) (Goodptr Int64 0 0) 8 ]
                                        nil
                                        nil
                                        nil
                                        [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11]
                                        [:: BspSync]
                                        [:: ( IntPtr 0 0, 8 )]
                                        nil
                                        nil ;
                                       mk_proc_state
                                         1
                                         nil
                                         nil
                                         nil
                                         nil
                                         nil
                                         [:: LocVarBlockInt64 0 4; LocVarBlockInt64 1 5; LocVarBlockInt64 2 6 ]
                                         [:: BspSync]
                                         [:: ( IntPtr 1 0, 8 )]

                                         nil
                                         nil ] nil.
Definition test_sync_get_state':= MGood
                                     [::
                                        mk_proc_state
                                        0
                                        nil
                                        [:: Get _ 1 (Goodptr Int64 0 0) (Posz 0) (Goodptr Int64 0 0) 8 ]
                                        nil
                                        nil
                                        nil
                                        [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11]
                                        [:: BspSync]
                                        [:: ( IntPtr 0 0, 8 )]
                                        nil
                                        nil ;
                                       mk_proc_state
                                         1
                                         nil
                                         nil
                                         nil
                                         nil
                                         nil
                                         [:: LocVarBlockInt64 0 4; LocVarBlockInt64 1 5; LocVarBlockInt64 2 6 ]
                                         [:: BspSync]
                                         [:: ( IntPtr 1 0, 8 ) ]

                                         nil
                                         nil ] nil.

Theorem test_sync_get : ss_reduce  test_sync_get_state test_sync_get_state'.
    by eapply (ss_sync_get _ _ 0).
Qed.

Definition test_sync_put_state :=  MGood
                                     [::
                                        mk_proc_state
                                        0
                                        nil
                                        nil
                                        [:: nil; [:: Put  _ (ValueI64 6) (Goodptr Int64 0 0) 0 ]]
                                        nil
                                        nil
                                        [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11]
                                        [:: BspSync]
                                        [:: ( IntPtr 0 0, 8 )]
                                        nil
                                        nil ;
                                       mk_proc_state
                                         1
                                         nil
                                         nil
                                         nil
                                         nil
                                         nil
                                         [:: LocVarBlockInt64 0 4; LocVarBlockInt64 1 5; LocVarBlockInt64 2 6 ]
                                         [:: BspSync]
                                         [:: ( IntPtr 1 0, 8 ) ]

                                         nil
                                         nil ] nil.
Definition test_sync_put_state' :=  MGood
                                     [::
                                        mk_proc_state
                                        0
                                        nil
                                        nil
                                        [:: nil; nil]
                                        nil
                                        nil
                                        [:: LocVarBlockInt64 0 6; LocVarBlockInt64 1 11]
                                        [:: BspSync]
                                        [:: ( IntPtr 0 0, 8 )]
                                        nil
                                        nil ;
                                       mk_proc_state
                                         1
                                         nil
                                         nil
                                         nil
                                         nil
                                         nil
                                         [:: LocVarBlockInt64 0 4; LocVarBlockInt64 1 5; LocVarBlockInt64 2 6 ]
                                         [:: BspSync]
                                         [:: ( IntPtr 1 0, 8 ) ]

                                         nil
                                         nil ] nil.

Theorem test_sync_put : ss_reduce test_sync_put_state test_sync_put_state'.
by  eapply (ss_sync_put _ _ 0 1).
Qed.

Definition test_hpput_state :=  MGood [::
                                        mk_proc_state
                                        0
                                        nil
                                        nil
                                        [:: nil ; nil ]
                                        nil
                                        nil
                                        [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11]
                                        nil
                                        [:: ( IntPtr 0 0, 8 )]
                                        nil
                                        nil ;
                                       mk_proc_state
                                         1
                                         nil
                                         nil
                                         [:: nil; nil]
                                         nil
                                         nil
                                         [:: LocVarBlockInt64 0 4; LocVarBlockInt64 1 5; LocVarBlockInt64 2 6 ]
                                         [:: BspHpPut (Lit $ ValueI64 0)
                                            (Lit $ VIntPtr 2 0)
                                            (Lit $ ValueI64 0)
                                            (Lit $ VIntPtr 1 0)
                                            (Lit $ ValueI64 8) ]

                                         [:: ( IntPtr 2 0, 8 )]

                                         nil
                                         nil ] nil.

Theorem test_hpput: reduce_interp test_hpput_state.
    by  eapply (ss_bsp_hpput _ _ 1).
Qed.

Definition test_hpget_state :=  MGood [::
                                        mk_proc_state
                                        0
                                        nil
                                        nil
                                        [:: nil ; nil ]
                                        nil
                                        nil
                                        [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11]
                                        nil
                                        [:: ( IntPtr 0 0, 8 )]
                                        nil
                                        nil ;
                                       mk_proc_state
                                         1
                                         nil
                                         nil
                                         [:: nil; nil]
                                         nil
                                         nil
                                         [:: LocVarBlockInt64 0 4; LocVarBlockInt64 1 5; LocVarBlockInt64 2 6 ]
                                         [:: BspHpGet (Lit $ ValueI64 0)
                                            (Lit $ VIntPtr 2 0)
                                            (Lit $ ValueI64 0)
                                            (Lit $ VIntPtr 1 0)
                                            (Lit $ ValueI64 8) ]

                                         [:: ( IntPtr 2 0, 8 )]

                                         nil
                                         nil ] nil.

Compute interpret_ss test_hpget_state 1.

Theorem test_hpget: reduce_interp test_hpget_state.
  by  eapply (ss_bsp_hpget _ _ 1); try done.
Qed.

Definition test_hpput_sync: ss_reduce ( MGood [::
                                                 mk_proc_state 0 nil nil nil nil nil
                                                 [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11;
                                                  LocVarBlockInt64 2 12; LocVarBlockInt64 3 13 ]
                                                 [:: BspSync]
                                                 [:: (iptr 0 0, 8 ) ]
                                                 [:: nil; [::
                                                             HpPutQuery
                                                             (iptr 1 0)
                                                             (iptr 0 0)
                                                             0] ]
                                                 nil ;

                                                 mk_proc_state 1 nil nil nil nil nil
                                                 [:: LocVarBlockInt64 0 20; LocVarBlockInt64 1 21;
                                                  LocVarBlockInt64 2 22; LocVarBlockInt64 3 23 ]
                                                 [:: BspSync]
                                                 [:: ( iptr 1 0 , 8 ) ]
                                                 [:: nil; nil]
                                                 nil
                                              ] [::] )
                                      (
                                        MGood [::
                                                 mk_proc_state 0 nil nil nil nil nil
                                                 [:: LocVarBlockInt64 0 21; LocVarBlockInt64 1 11;
                                                  LocVarBlockInt64 2 12; LocVarBlockInt64 3 13 ]
                                                 [:: BspSync]
                                                 [:: ( iptr 0 0, 8 ) ]
                                                 [:: nil; [::] ]
                                                 nil ;

                                                 mk_proc_state 1 nil nil nil nil nil
                                                 [:: LocVarBlockInt64 0 20; LocVarBlockInt64 1 21;
                                                  LocVarBlockInt64 2 22; LocVarBlockInt64 3 23 ]
                                                 [:: BspSync]
                                                 [:: ( iptr 1 0 , 8 ) ]
                                                 [:: nil; nil]
                                                 nil
      ] [::] ).
 by eapply (ss_sync_hpput _ _ 0 1).
Qed.

Definition test_hpget_sync: ss_reduce ( MGood [::
                                                 mk_proc_state 0 nil nil nil nil nil
                                                 [:: LocVarBlockInt64 0 10; LocVarBlockInt64 1 11;
                                                  LocVarBlockInt64 2 12; LocVarBlockInt64 3 13 ]
                                                 [:: BspSync]
                                                 [:: (iptr 0 0, 8 ) ]
                                                 nil
                                                 [:: nil; [::
                                                             HpGetQuery
                                                             (iptr 1 0)
                                                             (iptr 0 0)
                                                             0] ]
                                                 ;

                                                 mk_proc_state 1 nil nil nil nil nil
                                                 [:: LocVarBlockInt64 0 20; LocVarBlockInt64 1 21;
                                                  LocVarBlockInt64 2 22; LocVarBlockInt64 3 23 ]
                                                 [:: BspSync]
                                                 [:: ( iptr 1 0 , 8 ) ]
                                                 nil
                                                 nil
                                              ] [::] )
                                      (
                                        MGood [::
                                                 mk_proc_state 0 nil nil nil nil nil
                                                 [:: LocVarBlockInt64 0 21; LocVarBlockInt64 1 11;
                                                  LocVarBlockInt64 2 12; LocVarBlockInt64 3 13 ]
                                                 [:: BspSync]
                                                 [:: ( iptr 0 0, 8 ) ]
                                                 nil
                                                 [:: nil; nil]  ;

                                                 mk_proc_state 1 nil nil nil nil nil
                                                 [:: LocVarBlockInt64 0 20; LocVarBlockInt64 1 21;
                                                  LocVarBlockInt64 2 22; LocVarBlockInt64 3 23 ]
                                                 [:: BspSync]
                                                 [:: ( iptr 1 0 , 8 ) ]
                                                 nil
                                                 nil
      ] [::] ).
  by eapply (ss_sync_hpget _ _ 0 1).
Qed.


Require Import Bool.
Require Import Word.
Require Import Balloc.
Require Import BFile Bytes Rec Inode.
Require Import String.
Require Import Pred.
Require Import Arith.
Require Import List ListUtils.
Require Import FunctionalExtensionality.
Require Import AsyncDisk.
Require Import DirCache.
Require Import DirTreeDef.
Require Import FSLayout.
Require Import GenSepN.
Require Import SepAuto.
Require Import DirTreePred.

Import ListNotations.

Set Implicit Arguments.

  (**
   *
   * The dirtree representation invariant
   *
   * [F] represents the other parts of the file system above [tree],
   * in cases where [tree] is a subdirectory somewhere in the tree.
   *)

  Definition rep fsxp F tree ilist frees ms sm :=
    (exists bflist freeinodes freeinode_pred,
     BFILE.rep (FSXPBlockAlloc fsxp) sm fsxp.(FSXPInode) bflist ilist frees
        (BFILE.MSAllocC ms) (BFILE.MSCache ms) (BFILE.MSICache ms) (BFILE.MSDBlocks ms) *
     IAlloc.rep BFILE.freepred fsxp freeinodes freeinode_pred (IAlloc.Alloc.mk_memstate (BFILE.MSLL ms) (BFILE.MSIAllocC ms)) *
     [[ (F * tree_pred fsxp tree * freeinode_pred)%pred (list2nmem bflist) ]]
    )%pred.

  Theorem rep_length : forall fsxp F tree ilist frees ms sm,
    rep fsxp F tree ilist frees ms sm =p=>
    (rep fsxp F tree ilist frees ms sm *
     [[ length ilist = ((INODE.IRecSig.RALen (FSXPInode fsxp)) * INODE.IRecSig.items_per_val)%nat ]])%pred.
  Proof.
    unfold rep; intros.
    norml; unfold stars; simpl.
    rewrite BFILE.rep_length_pimpl at 1.
    cancel.
  Qed.

  Theorem dirtree_update_free : forall tree fsxp F F0 ilist freeblocks ms sm v bn m flag,
    (F0 * rep fsxp F tree ilist freeblocks ms sm)%pred (list2nmem m) ->
    BFILE.block_is_unused (BFILE.pick_balloc freeblocks flag) bn ->
    (F0 * rep fsxp F tree ilist freeblocks ms sm)%pred (list2nmem (updN m bn v)).
  Proof.
    intros.
    unfold rep in *.
    destruct_lift H.
    eapply pimpl_apply; [ | eapply BFILE.rep_safe_unused; eauto; pred_apply; cancel ].
    cancel.
  Qed.

  Theorem dirtree_rep_used_block_eq : forall pathname F0 tree fsxp F ilist freeblocks ms inum off bn m sm f,
    (F0 * rep fsxp F tree ilist freeblocks ms sm)%pred (list2nmem m) ->
    find_subtree pathname tree = Some (TreeFile inum f) ->
    BFILE.block_belong_to_file ilist bn inum off ->
    selN (DFData f) off ($0, nil) = selN m bn ($0, nil).
  Proof.
    intros.

    unfold rep in *.
    destruct_lift H.

    erewrite <- BFILE.rep_used_block_eq with (m := m).
    2: pred_apply; cancel.
    2: eauto.
    f_equal.
    f_equal.

    rewrite subtree_extract in * by eassumption.
    simpl in *.
    apply eq_sym.
    eapply BFILE.rep_used_block_eq_Some_helper.

    destruct_lifts.
    assert (inum < Datatypes.length dummy) as Hlt by ( eapply list2nmem_inbound; pred_apply; cancel ).

    pose proof (list2nmem_sel_inb dummy BFILE.bfile0 Hlt) as Hx.
    eapply pimpl_trans in H2; [ | apply pimpl_refl | ].
    eapply ptsto_valid in H2.
    rewrite Hx in H2; clear Hx.
    2: cancel.
    inversion H2; clear H2.
    rewrite H4; simpl.
    auto.
  Qed.

  Lemma tree_pred_ino_goodSize : forall F Fm xp tree m d frees prd allocc,
    (Fm * (IAlloc.rep BFILE.freepred xp frees prd allocc))%pred m ->
    (F * tree_pred xp tree)%pred d ->
    goodSize addrlen (dirtree_inum tree).
  Proof.
    induction tree using dirtree_ind2; simpl; intros.
    destruct_lift H0.
    eapply IAlloc.ino_valid_goodSize; eauto.
    unfold tree_dir_names_pred in H1; destruct_lift H1.
    eapply IAlloc.ino_valid_goodSize; eauto.
  Qed.

  Lemma find_subtree_inum_valid : forall F F' xp m s tree inum f,
    find_subtree s tree = Some (TreeFile inum f)
    -> (F * tree_pred xp tree * F')%pred m
    -> IAlloc.ino_valid xp inum.
  Proof.
    unfold rep; intros.
    destruct_lift H0.
    rewrite subtree_extract in H0 by eauto.
    simpl in H0; destruct_lift H0; auto.
  Qed.

  Theorem mscs_same_except_log_rep' : forall mscs1 mscs2 fsxp F tree ilist frees sm,
    BFILE.mscs_same_except_log mscs1 mscs2 ->
    rep fsxp F tree ilist frees mscs1 sm =p=> rep fsxp F tree ilist frees mscs2 sm.
  Proof.
    unfold BFILE.mscs_same_except_log; unfold rep; intros.
    intuition msalloc_eq.
    apply pimpl_refl.
  Qed.

  Theorem mscs_same_except_log_rep : forall mscs1 mscs2 fsxp F tree ilist frees sm,
    BFILE.mscs_same_except_log mscs1 mscs2 ->
    rep fsxp F tree ilist frees mscs1 sm <=p=> rep fsxp F tree ilist frees mscs2 sm.
  Proof.
    split; eapply mscs_same_except_log_rep'; eauto.
    unfold BFILE.mscs_same_except_log in *; intuition eauto.
  Qed.


Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Language.
From PromisingLib Require Import Event.

Require Import Time.
Require Import View.
Require Import BoolMap.
Require Import Promises.
Require Import Cell.
Require Import Memory.
Require Import Global.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import SimMemory.
Require Import SimGlobal.

Set Implicit Arguments.

Variant sim_local (lc_src lc_tgt: Local.t): Prop :=
| sim_local_intro
    (TVIEW: TView.le (Local.tview lc_src) (Local.tview lc_tgt))
    (PROMISES: Local.promises lc_src = Local.promises lc_tgt)
    (RESERVES: Local.reserves lc_src = Local.reserves lc_tgt)
.
#[export] Hint Constructors sim_local: core.

Global Program Instance sim_local_PreOrder: PreOrder sim_local.
Next Obligation.
  ii. destruct x. econs; refl.
Qed.
Next Obligation.
  ii. destruct x, y, z. inv H. inv H0. ss. subst.
  econs; ss. etrans; eauto.
Qed.

Lemma sim_local_promises_bot
      lc_src lc_tgt
      (SIM: sim_local lc_src lc_tgt):
  Local.promises lc_src = BoolMap.bot <->
  Local.promises lc_tgt = BoolMap.bot.
Proof.
  inv SIM. rewrite PROMISES. ss.
Qed.

Lemma sim_local_is_terminal
      lc_src lc_tgt
      (SIM: sim_local lc_src lc_tgt):
  Local.is_terminal lc_src <-> Local.is_terminal lc_tgt.
Proof.
  exploit sim_local_promises_bot; eauto. i. des.
  split; i; inv H; eauto.
Qed.

Lemma sim_local_internal
      lc1_src gl1_src
      lc1_tgt gl1_tgt
      lc2_tgt gl2_tgt
      e
      (LOCAL1: sim_local lc1_src lc1_tgt)
      (GLOBAL1: sim_global gl1_src gl1_tgt)
      (WF1_SRC: Local.wf lc1_src gl1_src)
      (WF1_TGT: Local.wf lc1_tgt gl1_tgt)
      (GL1_SRC: Global.wf gl1_src)
      (GL1_TGT: Global.wf gl1_tgt)
      (STEP_TGT: Local.internal_step e lc1_tgt gl1_tgt lc2_tgt gl2_tgt):
  exists lc2_src gl2_src,
    <<STEP_SRC: Local.internal_step e lc1_src gl1_src lc2_src gl2_src >> /\
    <<LOCAL2: sim_local lc2_src lc2_tgt>> /\
    <<GL2: sim_global gl2_src gl2_tgt>>.
Proof.
  inv LOCAL1. inv GLOBAL1. inv STEP_TGT.
  { inv LOCAL. inv PROMISE. esplits; eauto.
    { econs 1; eauto. econs; eauto. econs; eauto.
      { rewrite PROMISES. eauto. }
      { rewrite PROMISES0. eauto. }
    }
    { econs; eauto. }
    { econs; eauto. }
  }
  { inv LOCAL. inv RESERVE.
    hexploit sim_memory_add_exists; eauto. i. des. esplits.
    { econs 2. econs; eauto. econs; eauto.
      rewrite RESERVES. eauto.
    }
    { econs; eauto. }
    { econs; eauto. }
  }
  { inv LOCAL. inv CANCEL.
    hexploit Memory.remove_exists.
    { eapply WF1_SRC. rewrite RESERVES. eapply Memory.remove_get0. eauto. }
    i. des.
    hexploit sim_memory_remove; try exact MEMORY; eauto.
    i. esplits.
    { econs 3. econs; eauto. econs; eauto.
      rewrite RESERVES. eauto.
    }
    { econs; eauto. }
    { econs; eauto. }
  }
Qed.

Lemma sim_local_read
      lc1_src gl1_src
      lc1_tgt gl1_tgt
      lc2_tgt
      loc ts val released_tgt ord_src ord_tgt
      (LOCAL1: sim_local lc1_src lc1_tgt)
      (GLOBAL1: sim_global gl1_src gl1_tgt)
      (ORD: Ordering.le ord_src ord_tgt)
      (LC_WF1_TGT: Local.wf lc1_tgt gl1_tgt)
      (GL_WF1_TGT: Global.wf gl1_tgt)
      (STEP_TGT: Local.read_step lc1_tgt gl1_tgt loc ts val released_tgt ord_tgt lc2_tgt):
  exists released_src lc2_src,
    <<REL: View.opt_le released_src released_tgt>> /\
    <<STEP_SRC: Local.read_step lc1_src gl1_src loc ts val released_src ord_src lc2_src>> /\
    <<LOCAL2: sim_local lc2_src lc2_tgt>>.
Proof.
  inv LOCAL1. inv GLOBAL1. inv STEP_TGT.
  exploit sim_memory_get; try apply GET; eauto. i. des.
  inv MSG. esplits; eauto.
  - econs; eauto; (try by etrans; eauto).
    eapply TViewFacts.readable_mon; eauto. apply TVIEW.
  - econs; eauto. s. apply TViewFacts.read_tview_mon; auto.
    + apply LC_WF1_TGT.
    + inv GL_WF1_TGT. inv MEM_CLOSED.
      exploit CLOSED; eauto. i. des. inv MSG_WF. auto.
Qed.

Lemma ord_implb
      ord_src ord_tgt ord
      (ORD: Ordering.le ord_src ord_tgt):
  implb (Ordering.le ord_tgt ord) (Ordering.le ord_src ord).
Proof.
  destruct ord_src, ord_tgt, ord; ss.
Qed.

Lemma sim_local_fulfill
      lc1_src gl1_src
      lc1_tgt gl1_tgt
      loc ord_src ord_tgt prm2 gprm2
      (LOCAL1: sim_local lc1_src lc1_tgt)
      (GLOBAL1: sim_global gl1_src gl1_tgt)
      (ORD: Ordering.le ord_src ord_tgt)
      (FULFILL_TGT: Promises.fulfill lc1_tgt.(Local.promises) gl1_tgt.(Global.promises) loc ord_tgt prm2 gprm2):
  Promises.fulfill lc1_src.(Local.promises) gl1_src.(Global.promises) loc ord_src prm2 gprm2.
Proof.
  destruct lc1_src, lc1_tgt, gl1_src, gl1_tgt.
  inv LOCAL1. inv GLOBAL1. ss. subst.
  inv FULFILL_TGT; eauto.
Qed.

Lemma sim_local_write
      lc1_src gl1_src
      lc1_tgt gl1_tgt
      lc2_tgt gl2_tgt
      loc from to val releasedm_src releasedm_tgt released_tgt ord_src ord_tgt
      (LOCAL1: sim_local lc1_src lc1_tgt)
      (GLOBAL1: sim_global gl1_src gl1_tgt)
      (ORD: Ordering.le ord_src ord_tgt)
      (LC_WF1_SRC: Local.wf lc1_src gl1_src)
      (LC_WF1_TGT: Local.wf lc1_tgt gl1_tgt)
      (RELM: View.opt_le releasedm_src releasedm_tgt)
      (RELM_WF_SRC: View.opt_wf releasedm_src)
      (RELM_WF_TGT: View.opt_wf releasedm_tgt)
      (STEP_TGT: Local.write_step lc1_tgt gl1_tgt loc from to val releasedm_tgt released_tgt ord_tgt lc2_tgt gl2_tgt):
  exists released_src lc2_src gl2_src,
    <<STEP_SRC: Local.write_step lc1_src gl1_src loc from to val releasedm_src released_src ord_src lc2_src gl2_src>> /\
    <<RELEASED: View.opt_le released_src released_tgt>> /\
    <<LOCAL2: sim_local lc2_src lc2_tgt>> /\
    <<GLOBAL2: sim_global gl2_src gl2_tgt>>.
Proof.
  inv STEP_TGT.
  exploit sim_local_fulfill; eauto. intro FULFILL_SRC.
  assert (RELT_LE:
   View.opt_le
     (TView.write_released (Local.tview lc1_src) loc to releasedm_src ord_src)
     (TView.write_released (Local.tview lc1_tgt) loc to releasedm_tgt ord_tgt)).
  { apply TViewFacts.write_released_mon; ss.
    - apply LOCAL1.
    - apply LC_WF1_TGT.
  }
  assert (RELT_WF:
   View.opt_wf (TView.write_released (Local.tview lc1_src) loc to releasedm_src ord_src)).
  { unfold TView.write_released. condtac; econs.
    repeat (try condtac; viewtac; try apply LC_WF1_SRC).
  }
  exploit sim_memory_add_exists; try exact WRITE.
  { econs 1. exact RELT_WF. }
  { econs 1; try exact RELT_LE; try refl.
    eapply ord_implb. eassumption.
  }
  { apply GLOBAL1. }
  i. des. esplits.
  - econs; eauto.
    eapply TViewFacts.writable_mon; try exact WRITABLE; eauto. apply LOCAL1.
  - ss.
  - econs; eauto; s; try apply LOCAL1.
    apply TViewFacts.write_tview_mon; ss; try apply LOCAL1.
    apply LC_WF1_TGT.
  - econs; ss; try apply GLOBAL1.
Qed.

Lemma sim_local_update
      lc1_src gl1_src
      lc1_tgt gl1_tgt
      loc ts1 val1 released1_tgt ord1_src ord1_tgt lc2_tgt
      from2 to2 val2 released2_tgt ord2_src ord2_tgt lc3_tgt gl3_tgt
      (LOCAL1: sim_local lc1_src lc1_tgt)
      (GLOBAL1: sim_global gl1_src gl1_tgt)
      (ORD1: Ordering.le ord1_src ord1_tgt)
      (ORD2: Ordering.le ord2_src ord2_tgt)
      (LC_WF1_SRC: Local.wf lc1_src gl1_src)
      (LC_WF1_TGT: Local.wf lc1_tgt gl1_tgt)
      (GL_WF1_SRC: Global.wf gl1_src)
      (GL_WF1_TGT: Global.wf gl1_tgt)
      (STEP1_TGT: Local.read_step lc1_tgt gl1_tgt loc ts1 val1 released1_tgt ord1_tgt lc2_tgt)
      (STEP2_TGT: Local.write_step lc2_tgt gl1_tgt loc from2 to2 val2
                    released1_tgt released2_tgt ord2_tgt lc3_tgt gl3_tgt):
  exists released1_src released2_src lc2_src lc3_src gl3_src,
    <<STEP1_SRC: Local.read_step lc1_src gl1_src loc ts1 val1 released1_src ord1_src lc2_src>> /\
    <<STEP2_SRC: Local.write_step lc2_src gl1_src loc from2 to2 val2
                   released1_src released2_src ord2_src lc3_src gl3_src>> /\
    <<REL1: View.opt_le released1_src released1_tgt>> /\
    <<REL2: View.opt_le released2_src released2_tgt>> /\
    <<LOCAL3: sim_local lc3_src lc3_tgt>> /\
    <<GLOBAL3: sim_global gl3_src gl3_tgt>>.
Proof.
  exploit sim_local_read; try exact STEP1_TGT; eauto. i. des.
  exploit Local.read_step_future; try exact STEP1_TGT; eauto. i. des.
  exploit Local.read_step_future; try exact STEP_SRC; eauto. i. des.
  hexploit sim_local_write; eauto. i. des.
  esplits; eauto.
Qed.

Lemma sim_local_fence
      lc1_src gl1_src
      lc1_tgt gl1_tgt
      lc2_tgt gl2_tgt
      ordr_src ordw_src
      ordr_tgt ordw_tgt
      (STEP_TGT: Local.fence_step lc1_tgt gl1_tgt ordr_tgt ordw_tgt lc2_tgt gl2_tgt)
      (LOCAL1: sim_local lc1_src lc1_tgt)
      (GLOBAL1: sim_global gl1_src gl1_tgt)
      (LC_WF1_SRC: Local.wf lc1_src gl1_src)
      (LC_WF1_TGT: Local.wf lc1_tgt gl1_tgt)
      (ORDR: Ordering.le ordr_src ordr_tgt)
      (ORDW: Ordering.le ordw_src ordw_tgt):
  exists lc2_src gl2_src,
    <<STEP_SRC: Local.fence_step lc1_src gl1_src ordr_src ordw_src lc2_src gl2_src>> /\
    <<LOCAL2: sim_local lc2_src lc2_tgt>> /\
    <<GLOBAL2: sim_global gl2_src gl2_tgt>>.
Proof.
  inv GLOBAL1. inv STEP_TGT.
  esplits; eauto.
  - econs; eauto. i.
    erewrite sim_local_promises_bot; eauto.
  - econs; try apply LOCAL1. s.
    apply TViewFacts.write_fence_tview_mon; auto; try refl; cycle 1.
    { eapply TViewFacts.read_fence_future; apply LC_WF1_SRC. }
    apply TViewFacts.read_fence_tview_mon; auto; try refl.
    + apply LOCAL1.
    + apply LC_WF1_TGT.
  - econs; ss.
    apply TViewFacts.write_fence_sc_mon; auto; try refl.
    apply TViewFacts.read_fence_tview_mon; auto; try refl.
    + apply LOCAL1.
    + apply LC_WF1_TGT.
Qed.

Lemma sim_local_is_racy
      lc1_src gl1_src
      lc1_tgt gl1_tgt
      loc to ord_src ord_tgt
      (LOCAL1: sim_local lc1_src lc1_tgt)
      (GLOBAL1: sim_global gl1_src gl1_tgt)
      (ORD: Ordering.le ord_src ord_tgt)
      (RACE_TGT: Local.is_racy lc1_tgt gl1_tgt loc to ord_tgt):
  <<RACE_SRC: Local.is_racy lc1_src gl1_src loc to ord_src>>.
Proof.
  inv LOCAL1. inv GLOBAL1.
  inv RACE_TGT; [econs 1; congr|].
  exploit sim_memory_get; eauto. i. des. inv MSG0.
  econs; eauto.
  - eapply TViewFacts.racy_view_mon; eauto. apply TVIEW.
  - i. exploit MSG; try by destruct ord_src, ord_tgt; ss.
    i. subst. destruct na1; ss.
Qed.

Lemma sim_local_racy_read
      lc1_src gl1_src
      lc1_tgt gl1_tgt
      loc to val ord_src ord_tgt
      (LOCAL1: sim_local lc1_src lc1_tgt)
      (GLOBAL1: sim_global gl1_src gl1_tgt)
      (ORD: Ordering.le ord_src ord_tgt)
      (STEP_TGT: Local.racy_read_step lc1_tgt gl1_tgt loc to val ord_tgt):
  <<STEP_SRC: Local.racy_read_step lc1_src gl1_src loc to val ord_src>>.
Proof.
  inv STEP_TGT.
  exploit sim_local_is_racy; eauto.
Qed.

Lemma sim_local_racy_write
      lc1_src gl1_src
      lc1_tgt gl1_tgt
      loc to ord_src ord_tgt
      (LOCAL1: sim_local lc1_src lc1_tgt)
      (GLOBAL1: sim_global gl1_src gl1_tgt)
      (ORD: Ordering.le ord_src ord_tgt)
      (STEP_TGT: Local.racy_write_step lc1_tgt gl1_tgt loc to ord_tgt):
  <<STEP_SRC: Local.racy_write_step lc1_src gl1_src loc to ord_src>>.
Proof.
  inv STEP_TGT.
  exploit sim_local_is_racy; eauto.
Qed.

Lemma sim_local_racy_update
      lc1_src gl1_src
      lc1_tgt gl1_tgt
      loc to ordr_src ordw_src ordr_tgt ordw_tgt
      (LOCAL1: sim_local lc1_src lc1_tgt)
      (GLOBAL1: sim_global gl1_src gl1_tgt)
      (ORDR: Ordering.le ordr_src ordr_tgt)
      (ORDW: Ordering.le ordw_src ordw_tgt)
      (STEP_TGT: Local.racy_update_step lc1_tgt gl1_tgt loc to ordr_tgt ordw_tgt):
  <<STEP_SRC: Local.racy_update_step lc1_src gl1_src loc to ordr_src ordw_src>>.
Proof.
  inv STEP_TGT; eauto.
  exploit sim_local_is_racy; try exact RACE; eauto.
Qed.

Lemma sim_local_program_step
      lang
      th1_src
      th1_tgt th2_tgt e_tgt
      (STATE1: (Thread.state th1_src) = (Thread.state th1_tgt))
      (LOCAL1: sim_local (Thread.local th1_src) (Thread.local th1_tgt))
      (GLOBAL1: sim_global (Thread.global th1_src) (Thread.global th1_tgt))
      (LC_WF1_SRC: Local.wf (Thread.local th1_src) (Thread.global th1_src))
      (LC_WF1_TGT: Local.wf (Thread.local th1_tgt) (Thread.global th1_tgt))
      (GL_WF1_SRC: Global.wf (Thread.global th1_src))
      (GL_WF1_TGT: Global.wf (Thread.global th1_tgt))
      (STEP_TGT: @Thread.step lang e_tgt th1_tgt th2_tgt)
      (EVENT: ThreadEvent.is_program e_tgt):
  exists e_src th2_src,
    <<STEP_SRC: @Thread.step lang e_src th1_src th2_src>> /\
    <<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>> /\
    <<STATE2: (Thread.state th2_src) = (Thread.state th2_tgt)>> /\
    <<LOCAL2: sim_local (Thread.local th2_src) (Thread.local th2_tgt)>> /\
    <<GLOBAL2: sim_global (Thread.global th2_src) (Thread.global th2_tgt)>>.
Proof.
  destruct th1_src as [st1_src lc1_src gl1_src],
      th1_tgt as [st1_tgt lc1_tgt gl1_tgt]. ss. subst.
  inv STEP_TGT; ss.
  { exploit sim_local_internal; eauto. i. des.
    esplits; eauto.
  }
  inv LOCAL; ss.
  - esplits; (try by econs; [|econs 1]; eauto); ss.
  - exploit sim_local_read; eauto; try refl. i. des.
    esplits; (try by econs; [|econs 2]; eauto); ss.
  - exploit sim_local_write; eauto; try refl. i. des.
    esplits; (try by econs; [|econs 3]; eauto); ss.
  - exploit sim_local_update; eauto; try refl. i. des.
    esplits; (try by econs; [|econs 4]; eauto); ss.
  - exploit sim_local_fence; eauto; try refl. i. des.
    esplits; (try by econs; [|econs 5]; eauto); ss.
  - exploit sim_local_fence; eauto; try refl. i. des.
    esplits; (try by econs; [|econs 6]; eauto); ss.
  - esplits; (try by econs; [|econs 7]; eauto); ss.
  - exploit sim_local_racy_read; eauto; try refl. i. des.
    esplits; (try by econs; [|econs 8]; eauto); ss.
  - exploit sim_local_racy_write; eauto; try refl. i. des.
    esplits; (try by econs; [|econs 9]; eauto); ss.
  - exploit sim_local_racy_update; eauto; try refl. i. des.
    esplits; (try by econs; [|econs 10]; eauto); ss.
Qed.


Set Implicit Arguments.

From ITree Require Import
     ITree ITreeFacts.
Import ITreeNotations.
Local Open Scope itree_scope.

From Paco Require Import paco.

From Coq Require Import
     Basics
     Morphisms
     List
     PeanoNat.

Require Import misc.
Require Import tree.
Require Import unbiased_itree.

Section itree_notau.
  Context {A : Type} {E : Type -> Type}.

  Inductive itree_notauF (R : itree E A -> Prop) : itree' E A -> Prop :=
  | itree_notauF_ret : forall x, itree_notauF R (RetF x)
  | itree_notauF_vis : forall {A} (e : E A) f,
      (forall x, R (f x)) ->
      itree_notauF R (VisF e f).

  Definition itree_notau_ R : itree E A -> Prop :=
    fun t => itree_notauF R (observe t).

  Lemma itree_notauF_mono R R' t
        (IN: itree_notauF R t)
        (LE: R <1= R') :
    itree_notauF R' t.
  Proof. intros; induction IN; econstructor; eauto. Qed.

  Lemma itree_notau__mono : monotone1 (itree_notau_).
  Proof. do 2 red. intros. eapply itree_notauF_mono; eauto. Qed.
  Hint Resolve itree_notau__mono : paco.

  Definition itree_notau : itree E A -> Prop :=
    paco1 itree_notau_ bot1.

  Global Instance Proper_itree_notau
    : Proper (eq_itree eq ==> iff) itree_notau.
  Proof.
    intros x y Heq; split.
    - revert x y Heq; pcofix CH; intros x y Heq Hnotau.
      punfold Hnotau; unfold itree_notau_ in Hnotau.
      punfold Heq; unfold eqit_ in Heq.
      pstep; unfold itree_notau_.
      destruct (observe x).
      + inversion Heq; subst; try congruence; constructor.
      + inversion Hnotau.
      + inversion Heq; subst; try congruence.
        apply Eqdep.EqdepTheory.inj_pair2 in H1; subst.
        apply Eqdep.EqdepTheory.inj_pair2 in H2; subst.
        inversion Hnotau; subst.
        apply Eqdep.EqdepTheory.inj_pair2 in H2; subst.
        apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
        unfold id in REL.
        constructor; intro z.
        specialize (H1 z).
        specialize (REL z).
        repeat destruct_upaco.
        right; eapply CH; eauto.
    - revert x y Heq; pcofix CH; intros x y Heq Hnotau.
      punfold Hnotau; unfold itree_notau_ in Hnotau.
      punfold Heq; unfold eqit_ in Heq.
      pstep; unfold itree_notau_.
      destruct (observe y).
      + inversion Heq; subst; try congruence; constructor.
      + inversion Hnotau.
      + inversion Heq; subst; try congruence.
        apply Eqdep.EqdepTheory.inj_pair2 in H2; subst.
        apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
        inversion Hnotau; subst.
        apply Eqdep.EqdepTheory.inj_pair2 in H2; subst.
        apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
        unfold id in REL.
        constructor; intro z.
        specialize (H1 z).
        specialize (REL z).
        repeat destruct_upaco.
        right; eapply CH; eauto.
  Qed.
End itree_notau.
Hint Resolve itree_notau__mono : paco.

Section itree_onetau.
  Context {A : Type} {E : Type -> Type}.

  Definition notau (t : itree E A) : Prop :=
    match observe t with
    | RetF _ => True
    | TauF _ => False
    | VisF _ _ => True
    end.

  Lemma notau_eq_itree (t1 t2 : itree E A) :
    eq_itree eq t1 t2 ->
    notau t1 ->
    notau t2.
  Proof.
    unfold notau; intros Heq Hnotau.
    punfold Heq; unfold eqit_ in Heq.
    destruct (observe t1); inversion Heq; congruence.
  Qed.

  Inductive itree_onetauF (R : itree E A -> Prop) : itree' E A -> Prop :=
  | itree_onetauF_ret : forall x, itree_onetauF R (RetF x)
  | itree_onetauF_tau : forall t,
      R t ->
      notau t ->
      itree_onetauF R (TauF t)
  | itree_onetauF_vis : forall {A} (e : E A) f,
      (forall x, R (f x)) ->
      itree_onetauF R (VisF e f).

  Definition itree_onetau_ R : itree E A -> Prop :=
    fun t => itree_onetauF R (observe t).

  Lemma itree_onetauF_mono R R' t
        (IN: itree_onetauF R t)
        (LE: R <1= R') :
    itree_onetauF R' t.
  Proof. intros; induction IN; econstructor; eauto. Qed.

  Lemma itree_onetau__mono : monotone1 itree_onetau_.
  Proof. do 2 red. intros. eapply itree_onetauF_mono; eauto. Qed.
  Hint Resolve itree_onetau__mono : paco.

  Definition itree_onetau : itree E A -> Prop :=
    paco1 itree_onetau_ bot1.

  Global Instance Proper_itree_onetau
    : Proper (eq_itree eq ==> iff) itree_onetau.
  Proof.
    intros x y Heq; split.
    - revert x y Heq; pcofix CH; intros x y Heq Htau.
      punfold Htau; unfold itree_onetau_ in Htau.
      punfold Heq; unfold eqit_ in Heq.
      pstep; unfold itree_onetau_.
      destruct (observe x).
      + inversion Heq; subst; try congruence; constructor.
      + inversion Htau; subst.
        inversion Heq; subst; try congruence.
        repeat destruct_upaco.
        constructor.
        * right; eapply CH; eauto.
        * eapply notau_eq_itree; eauto.
      + inversion Heq; subst; try congruence.
        apply Eqdep.EqdepTheory.inj_pair2 in H1; subst.
        apply Eqdep.EqdepTheory.inj_pair2 in H2; subst.
        inversion Htau; subst.
        apply Eqdep.EqdepTheory.inj_pair2 in H2; subst.
        apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
        unfold id in REL.
        constructor; intro z.
        specialize (H1 z).
        specialize (REL z).
        repeat destruct_upaco.
        right; eapply CH; eauto.
    - revert x y Heq; pcofix CH; intros x y Heq Htau.
      punfold Htau; unfold itree_onetau_ in Htau.
      punfold Heq; unfold eqit_ in Heq.
      pstep; unfold itree_onetau_.
      destruct (observe y).
      + inversion Heq; subst; try congruence; constructor.
      + inversion Htau; subst.
        inversion Heq; subst; try congruence.
        repeat destruct_upaco.
        constructor.
        * right; eapply CH; eauto.
        * eapply notau_eq_itree; eauto.
          symmetry; auto.
      + inversion Heq; subst; try congruence.
        apply Eqdep.EqdepTheory.inj_pair2 in H2; subst.
        apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
        inversion Htau; subst.
        apply Eqdep.EqdepTheory.inj_pair2 in H2; subst.
        apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
        unfold id in REL.
        constructor; intro z.
        specialize (H1 z).
        specialize (REL z).
        repeat destruct_upaco.
        right; eapply CH; eauto.
  Qed.
End itree_onetau.
Hint Resolve itree_onetau__mono : paco.

Section itree_fintau.
  Context {A : Type} {E : Type -> Type}.

  (* Finite number of taus at the head. *)
  Inductive fintau : itree E A -> Prop :=
  | fintau_ret : forall t x,
      observe t = RetF x ->
      fintau t
  | fintau_tau : forall t t',
      observe t = TauF t' ->
      fintau t' ->
      fintau t
  | fintau_vis : forall X t (e : E X) (k : X -> itree E A),
      observe t = VisF e k ->
      fintau t.

  Lemma fintau_eq_itree (t1 t2 : itree E A) :
    eq_itree eq t1 t2 ->
    fintau t1 ->
    fintau t2.
  Proof.
    intros Heq Hfintau.
    revert Heq. revert t2.
    induction Hfintau; intros t2 Heq.
    - punfold Heq; unfold eqit_ in Heq; rewrite H in Heq.
      inversion Heq; subst; try congruence.
      econstructor; eauto.
    - punfold Heq; unfold eqit_ in Heq; rewrite H in Heq.
      inversion Heq; subst; try congruence.
      destruct_upaco.
      eapply fintau_tau; eauto.
    - punfold Heq; unfold eqit_ in Heq; rewrite H in Heq.
      inversion Heq; subst; try congruence.
      apply Eqdep.EqdepTheory.inj_pair2 in H2; subst.
      apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
      eapply fintau_vis; eauto.
  Qed.

  Inductive itree_fintauF (R : itree E A -> Prop) : itree' E A -> Prop :=
  | itree_fintauF_ret : forall x, itree_fintauF R (RetF x)
  | itree_fintauF_tau : forall t,
      R t ->
      fintau t ->
      itree_fintauF R (TauF t)
  | itree_fintauF_vis : forall {A} (e : E A) f,
      (forall x, R (f x)) ->
      itree_fintauF R (VisF e f).

  Definition itree_fintau_ R : itree E A -> Prop :=
    fun t => itree_fintauF R (observe t).

  Lemma itree_fintauF_mono R R' t
        (IN: itree_fintauF R t)
        (LE: R <1= R') :
    itree_fintauF R' t.
  Proof. intros; induction IN; econstructor; eauto. Qed.

  Lemma itree_fintau__mono : monotone1 itree_fintau_.
  Proof. do 2 red. intros. eapply itree_fintauF_mono; eauto. Qed.
  Hint Resolve itree_fintau__mono : paco.

  Definition itree_fintau : itree E A -> Prop :=
    paco1 itree_fintau_ bot1.

  Global Instance Proper_fintau
    : Proper (eq_itree eq ==> iff) fintau.
  Proof.
    intros x y Heq; split.
    - intro Hfin; revert Heq. revert y.
      induction Hfin; intros y Heq; punfold Heq; unfold eqit_ in Heq;
        rewrite H in Heq; inversion Heq; subst; try congruence.
      + econstructor; eauto.
      + destruct_upaco; eapply fintau_tau; eauto.
      + eapply fintau_vis; eauto.
    - intro Hfin; revert Heq. revert x.
      induction Hfin; intros z Heq; punfold Heq; unfold eqit_ in Heq;
        rewrite H in Heq; inversion Heq; subst; try congruence.
      + econstructor; eauto.
      + destruct_upaco; eapply fintau_tau; eauto.
      + eapply fintau_vis; eauto.
  Qed.

  Global Instance Proper_itree_fintau
    : Proper (eq_itree eq ==> iff) itree_fintau.
  Proof.
    intros x y Heq; split; revert Heq; revert x y;
      pcofix CH; intros x y Heq Hfin;
        punfold Heq; unfold eqit_ in Heq;
          punfold Hfin; unfold itree_fintau_ in Hfin;
            pstep; unfold itree_fintau_.
    - destruct (observe x); inversion Heq; subst; try congruence.
      + constructor.
      + inversion Hfin; subst.
        repeat destruct_upaco.
        constructor; eauto.
        rewrite <- REL; auto.
      + apply Eqdep.EqdepTheory.inj_pair2 in H1; subst.
        apply Eqdep.EqdepTheory.inj_pair2 in H2; subst.
        inversion Hfin; subst.
        apply Eqdep.EqdepTheory.inj_pair2 in H2; subst.
        apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
        constructor; intro z.
        specialize (REL z); specialize (H1 z); unfold id in REL.
        repeat destruct_upaco.
        right; eapply CH; eauto.
    - destruct (observe y); inversion Heq; subst; try congruence.
      + constructor.
      + inversion Hfin; subst.
        repeat destruct_upaco.
        constructor; eauto.
        rewrite  REL; auto.
      + apply Eqdep.EqdepTheory.inj_pair2 in H2; subst.
        apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
        inversion Hfin; subst.
        apply Eqdep.EqdepTheory.inj_pair2 in H2; subst.
        apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
        constructor; intro z.
        specialize (REL z); specialize (H1 z); unfold id in REL.
        repeat destruct_upaco.
        right; eapply CH; eauto.
  Qed.
End itree_fintau.
Hint Resolve itree_fintau__mono : paco.

Lemma onetau_fintau {E : Type -> Type} {A : Type} (t : itree E A) :
  notau t ->
  fintau t.
Proof.
  unfold notau.
  destruct (observe t) eqn:Ht; try contradiction; intros _.
  - eapply fintau_ret; eauto.
  - eapply fintau_vis; eauto.
Qed.

Lemma itree_onetau_itree_fintau {E : Type -> Type} {A : Type} (t : itree E A) :
  itree_onetau t ->
  itree_fintau t.
Proof.
  revert t; pcofix CH; intros t Hone.
  punfold Hone; unfold itree_onetau_ in Hone.
  pstep; unfold itree_fintau_.
  destruct (observe t).
  - constructor.
  - inversion Hone; subst.
    destruct_upaco.
    constructor; auto.
    apply onetau_fintau; auto.
  - inversion Hone; subst.
    apply Eqdep.EqdepTheory.inj_pair2 in H1; subst.
    apply Eqdep.EqdepTheory.inj_pair2 in H2; subst.
    constructor; intro x; right.
    apply CH; specialize (H0 x); destruct_upaco; auto.
Qed.

(** [itree_reachable P t] iff [Ret x] is finitely reachable in t for
    some x such that [P x]. *)
Inductive itree_reachable {E : Type -> Type} {A : Type} (P : A -> Prop) : itree E A -> Prop :=
| itree_reachable_ret : forall x t,
    P x ->
    observe t = RetF x ->
    itree_reachable P t
| itree_reachable_tau : forall t t',
    observe t = TauF t' ->
    itree_reachable P t' ->
    itree_reachable P t
| itree_reachable_vis : forall t X (e : E X) k y,
    observe t = VisF e k ->
    itree_reachable P (k y) ->
    itree_reachable P t.

(* Helper definition for reasoning about iter. *)
Definition ret_reachable {E I R} : itree E (I + R) -> Prop :=
  itree_reachable (fun s => match s with
                         | inl _ => False
                         | inr _ => True
                         end).

Lemma itree_fintau_impl {E A} (t : itree E A) (r1 r2 : itree E A -> Prop) :
  (forall t, r1 t -> r2 t) ->
  paco1 itree_fintau_ r1 t ->
  paco1 itree_fintau_ r2 t.
Proof.
  revert t.
  pcofix CH; intros t Himpl Hfin.
  punfold Hfin; unfold itree_fintau_ in Hfin.
  pstep; unfold itree_fintau_.
  destruct (observe t) eqn:Ht.
  - constructor.
  - inversion Hfin; subst.
    constructor; auto.
    destruct H0 as [H0 | H0]; right; auto.
  - inversion Hfin; subst.
    apply Eqdep.EqdepTheory.inj_pair2 in H1; subst.
    apply Eqdep.EqdepTheory.inj_pair2 in H2; subst.
    constructor; intro x.
    specialize (H0 x); destruct H0; right; auto.
Qed.

Lemma itree_fintau_unfold_iter {E : Type -> Type} {A B : Type} (f : A -> itree E (A + B)) x r :
  paco1 itree_fintau_ r (lr <- f x ;; match lr with
                                     | inl l => Tau (ITree.iter f l)
                                     | inr r => Ret r
                                     end) ->
  paco1 itree_fintau_ r (ITree.iter f x).
Proof.
  revert f x r.
  pcofix CH; intros f x H.
  punfold H; unfold itree_fintau_ in H.
  unfold ITree.bind in H.
  unfold ITree.subst in H.
  compute in H.
  pstep; unfold itree_fintau_.
  rewrite 2!_observe_observe in H.
  unfold ITree.iter. compute.
  rewrite 2!_observe_observe.
  destruct (observe (f x)) eqn:Hfx; simpl in *.
  - destruct r1; simpl in *.
    + inversion H; subst.
      constructor; auto.
      destruct H1 as [H1 | H1]; auto.
      left; eapply itree_fintau_impl; eauto.
    + constructor.
  - inversion H; subst.
    constructor; auto.
    destruct H1 as [H1 | H1]; auto.
    left; eapply itree_fintau_impl; eauto.
  - inversion H; subst.
    apply Eqdep.EqdepTheory.inj_pair2 in H2; subst.
    apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
    constructor.
    intro y; specialize (H1 y).
    destruct H1 as [H1 | H1]; auto.
    left; eapply itree_fintau_impl; eauto.
Qed.

Lemma fintau_subst {E I R} t k :
  fintau t ->
  (forall i, fintau (k i)) ->
  fintau
    ((cofix _subst (u : itree E (I + R)) : itree E R :=
        match _observe u with
        | RetF (inl l) => Tau (k l)
        | RetF (inr r2) => Ret r2
        | TauF t0 => Tau (_subst t0)
        | @VisF _ _ _ X e h => Vis e (fun x : X => _subst (h x))
        end) t).
Proof.
  intro Hfin; revert k; induction Hfin; intros f Hk.
  - destruct x.
    + eapply fintau_tau; compute.
      * rewrite 2!_observe_observe.
        rewrite H; reflexivity.
      * auto.
    + eapply fintau_ret; compute.
      * rewrite 2!_observe_observe.
        rewrite H; reflexivity.
  - eapply fintau_tau; compute.
    * rewrite 2!_observe_observe.
      rewrite H; reflexivity.
    * apply IHHfin; auto.
  - eapply fintau_vis; compute.
    * rewrite 2!_observe_observe.
      rewrite H; reflexivity.
Qed.

Lemma itree_fintau_bind {E I R} (t : itree E (I + R)) k (r : itree E R -> Prop) :
  itree_fintau t ->
  (forall i, r (k i)) ->
  (forall i, fintau (k i)) ->
  paco1 itree_fintau_ r
        (lr <- t;; match lr with
                  | inl l => Tau (k l)
                  | inr r0 => Ret r0
                  end).
Proof.
  revert t k r; pcofix CH; intros t k Hfintau Hr Hfin.
  (* revert t k r; pcofix CH; intros t k Hr Hfin. *)
  unfold ITree.bind, ITree.subst.
  pstep; unfold itree_fintau_.
  compute.
  rewrite 2!_observe_observe.
  destruct (observe t) eqn:Ht; simpl.
  - destruct r1; constructor; auto.
  - punfold Hfintau; unfold itree_fintau_ in Hfintau.
    rewrite Ht in Hfintau; inversion Hfintau; subst.
    destruct_upaco.
    constructor.
    + right; apply CH; auto.
    + apply fintau_subst; auto.
  - constructor; intro x.
    punfold Hfintau; unfold itree_fintau_ in Hfintau.
    rewrite Ht in Hfintau; inversion Hfintau; subst.
    apply Eqdep.EqdepTheory.inj_pair2 in H1; subst.
    apply Eqdep.EqdepTheory.inj_pair2 in H2; subst.
    right; apply CH; auto.
    + specialize (H0 x); destruct_upaco; auto.
Qed.

Lemma itree_fintau_iter {E I R} (k : I -> itree E (I + R)) (i : I) :
  (forall j, itree_fintau (k j)) ->
  (forall j, fintau (ITree.iter k j)) ->
  (forall j, ret_reachable (k j)) ->
  itree_fintau (ITree.iter k i).
Proof.
  revert k i; pcofix CH; intros k i Hfin Hfin' Hreach.
  apply itree_fintau_unfold_iter.
  apply itree_fintau_bind; auto.
Qed.

Lemma fintau_bind {E A B} (t : itree E A) (f : A -> itree E B) :
  fintau t ->
  (forall x, fintau (f x)) ->
  fintau (x <- t;; f x).
Proof.
  induction 1; intros Hfin.
  - unfold ITree.bind, ITree.subst.
    destruct (observe (f x)) eqn:Hfx.
    + eapply fintau_ret; compute.
      rewrite 2!_observe_observe, H; eauto.
    + eapply fintau_tau; compute.
      rewrite 2!_observe_observe, H; eauto.
      specialize (Hfin x).
      inversion Hfin; congruence.
    + eapply fintau_vis; compute.
      rewrite 2!_observe_observe, H; eauto.
  - unfold ITree.bind, ITree.subst.
    eapply fintau_tau.
    + compute; rewrite 2!_observe_observe, H; reflexivity.
    + apply IHfintau; auto.
  - eapply fintau_vis; compute.
    rewrite 2!_observe_observe; rewrite H; reflexivity.
Qed.

Lemma itree_fintau_fintau {E A} (t : itree E A) :
  itree_fintau t ->
  fintau t.
Proof.
  intro Hfin.
  punfold Hfin; unfold itree_fintau_ in Hfin.
  destruct (observe t) eqn:Ht.
  - eapply fintau_ret; eauto.
  - inversion Hfin; subst; eapply fintau_tau; eauto.
  - eapply fintau_vis; eauto.
Qed.

Lemma itree_fintau_bind' {E A B} (t : itree E A) (f : A -> itree E B) :
  itree_fintau t ->
  (forall x, itree_fintau (f x)) ->
  itree_fintau (x <- t;; f x).
Proof.
  revert t f.
  pcofix CH; intros t f H0 H1.
  punfold H0; unfold itree_fintau_ in H0.
  pstep; unfold itree_fintau_.
  compute.
  rewrite 2!_observe_observe.
  destruct (observe t) eqn:Ht.
  - specialize (H1 r0).
    eapply itree_fintau_impl in H1.
    + punfold H1.
    + intros ? [].
  - inversion H0; subst.
    destruct_upaco.
    constructor.
    + right; apply CH; auto.
    + apply fintau_bind; auto.
      intro x; apply itree_fintau_fintau; auto.
  - inversion H0; subst.
    apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
    apply Eqdep.EqdepTheory.inj_pair2 in H4; subst.
    constructor; intro x.
    specialize (H2 x); destruct_upaco; right; apply CH; auto.
Qed.

Instance Proper_itree_reachable {E A P} : Proper (eq_itree eq ==> iff) (@itree_reachable E A P).
Proof.
  intros x y Heq; split; intro H.
  - revert Heq. revert y.
    induction H; intros z Heq.
    + punfold Heq; unfold eqit_ in Heq; rewrite H0 in Heq.
      inversion Heq; subst; try congruence.
      eapply itree_reachable_ret; eauto.
    + punfold Heq; unfold eqit_ in Heq; rewrite H in Heq.
      inversion Heq; subst; try congruence.
      destruct_upaco.
      eapply itree_reachable_tau; eauto.
    + punfold Heq; unfold eqit_ in Heq; rewrite H in Heq.
      inversion Heq; subst; try congruence.
      apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
      apply Eqdep.EqdepTheory.inj_pair2 in H4; subst.
      eapply itree_reachable_vis; eauto.
      specialize (REL y); unfold id in REL.
      destruct_upaco.
      apply IHitree_reachable; eauto.
  - revert Heq. revert x.
    induction H; intros z Heq.
    + punfold Heq; unfold eqit_ in Heq; rewrite H0 in Heq.
      inversion Heq; subst; try congruence.
      eapply itree_reachable_ret; eauto.
    + punfold Heq; unfold eqit_ in Heq; rewrite H in Heq.
      inversion Heq; subst; try congruence.
      destruct_upaco.
      eapply itree_reachable_tau; eauto.
    + symmetry in Heq; punfold Heq; unfold eqit_ in Heq; rewrite H in Heq.
      inversion Heq; subst; try congruence.
      apply Eqdep.EqdepTheory.inj_pair2 in H3; subst.
      apply Eqdep.EqdepTheory.inj_pair2 in H4; subst.
      eapply itree_reachable_vis; eauto.
      specialize (REL y); unfold id in REL.
      destruct_upaco.
      apply IHitree_reachable; eauto.
      symmetry; eauto.
Qed.

Instance Proper_ret_reachable {E I R} : Proper (eq_itree eq ==> iff) (@ret_reachable E I R).
Proof. apply Proper_itree_reachable. Qed.

Lemma ret_reachable_bind {E A B C} (t : itree E (A + (B + C))) (k : A -> itree E (B + C)) :
  itree_reachable (fun x => match x with
                         | inr (inr _) => True
                         | _ => False
                         end) t ->
  ret_reachable (lr <- t;; match lr with
                          | inl l => k l
                          | inr r => Ret r
                          end).
Proof.
  unfold ret_reachable.
  intro H.
  induction H.
  - destruct x; try contradiction.
    destruct s; try contradiction.
    econstructor.
    2: { compute; rewrite 2!_observe_observe, H0; reflexivity. }
    apply I.
  - eapply itree_reachable_tau; eauto.
    compute; rewrite 2!_observe_observe, H; reflexivity.
  - eapply itree_reachable_vis.
    + compute; rewrite 2!_observe_observe, H; reflexivity.
    + apply IHitree_reachable.
Qed.

Lemma itree_reachable_bind' {E A B} (t : itree E (A + B)) (k : A -> itree E B) :
  itree_reachable (fun x => match x with
                         | inr _ => True
                         | _ => False
                         end) t ->
  itree_reachable (const True) (lr <- t;; match lr with
                                      | inl l => k l
                                      | inr r => Ret r
                                      end).
Proof.
  unfold ret_reachable.
  intro H.
  induction H.
  - destruct x; try contradiction.
    econstructor.
    2: { compute; rewrite 2!_observe_observe, H0; reflexivity. }
    apply I.
  - eapply itree_reachable_tau; eauto.
    compute; rewrite 2!_observe_observe, H; reflexivity.
  - eapply itree_reachable_vis.
    + compute; rewrite 2!_observe_observe, H; reflexivity.
    + apply IHitree_reachable.
Qed.

Lemma ret_reachable_iter {E A B} (k : unit -> itree E (unit + (A + B))) :
  itree_reachable (fun x => match x with
                         | inr (inr _) => True
                         | _ => False
                         end) (k tt) ->
  ret_reachable (ITree.iter k tt).
Proof. rewrite unfold_iter; apply ret_reachable_bind. Qed.

Lemma ret_reachable_iter' {E R} (k : unit -> itree E (unit + R)) :
  itree_reachable (fun x => match x with
                         | inr _ => True
                         | _ => False
                         end) (k tt) ->
  itree_reachable (const True) (ITree.iter k tt).
Proof. rewrite unfold_iter; apply itree_reachable_bind'. Qed.

Lemma ret_reachable_bind' {E A} (t : itree E (nat + A)) n :
  ret_reachable t ->
  itree_reachable
    (fun x : unit + (nat + A) => match x with
                                 | inr (inr _) => True
                                 | _ => False
                                 end)
    (x <- t;;
     match x with
     | inl n0 => if PeanoNat.Nat.eqb n0 n then Ret (inl tt) else Ret (inr (inl n0))
     | inr y => Ret (inr (inr y))
     end).
Proof.
  intro H; induction H; subst.
  - destruct x; try contradiction.
    eapply itree_reachable_ret.
    2: { compute; rewrite 2!_observe_observe, H0; reflexivity. }
    apply I.
  - eapply itree_reachable_tau; eauto.
    compute; rewrite 2!_observe_observe, H; reflexivity.
  - eapply itree_reachable_vis.
    + compute; rewrite 2!_observe_observe, H; reflexivity.
    + apply IHitree_reachable.
Qed.

Lemma leaf_reachable'_ret_reachable {A : Type} (t : tree A) :
  leaf_reachable' t ->
  ret_reachable (unbiased_tree_to_itree t).
Proof.
  induction 1; simpl.
  - econstructor.
    2: reflexivity.
    apply I.
  - eapply itree_reachable_vis with (y:=true).
    + reflexivity.
    + apply IHleaf_reachable'.
  - eapply itree_reachable_vis with (y:=false).
    + reflexivity.
    + apply IHleaf_reachable'.
  - apply ret_reachable_iter.
    apply ret_reachable_bind'; auto.
Qed.

Lemma itree_reachable_fintau {E A} P (t : itree E A) :
  itree_reachable P t ->
  fintau t.
Proof.
  induction 1.
  - econstructor; eauto.
  - eapply fintau_tau; eauto.
  - eapply fintau_vis; eauto.
Qed.

Lemma itree_reachable_impl {E A} (P Q : A -> Prop) (t : itree E A) :
  (forall x, P x -> Q x) ->
  itree_reachable P t ->
  itree_reachable Q t.
Proof.
  intros Himpl H; induction H.
  - eapply itree_reachable_ret; eauto.
  - eapply itree_reachable_tau; eauto.
  - eapply itree_reachable_vis; eauto.
Qed.

Lemma itree_reachable_n_bind {E A} (t : itree E (nat + A)) (n : nat) :
  itree_reachable (fun x => match x with
                         | inl m => m <> n
                         | _ => False
                         end) t ->
  itree_reachable (fun x => match x with
                         | inl _ => False
                         | inr _ => True
                         end)
                  (x <- t;;
                   match x with
                   | inl n1 => if n1 =? n then Ret (inl tt) else Ret (inr (inl n1))
                   | inr y => Ret (inr (inr y))
                   end).
Proof.
  induction 1.
  - destruct x; try contradiction.
    eapply itree_reachable_ret.
    2: { compute; rewrite 2!_observe_observe, H0.
         apply Nat.eqb_neq in H; compute in H; rewrite H; reflexivity. }
    apply I.
  - eapply itree_reachable_tau; eauto.
    compute; rewrite 2!_observe_observe, H; reflexivity.
  - eapply itree_reachable_vis.
    { compute; rewrite 2!_observe_observe, H; reflexivity. }
    apply IHitree_reachable.
Qed.

Lemma itree_reachable_n_bind' {E A} (t : itree E (nat + A)) (n k : nat) :
  k <> n ->
  itree_reachable (fun x => match x with
                         | inl m => m = k
                         | _ => False
                         end) t ->
  itree_reachable (fun x => match x with
                         | inl _ => False
                         | inr _ => True
                         end)
                  (x <- t;;
                   match x with
                   | inl n1 => if n1 =? n then Ret (inl tt) else Ret (inr (inl n1))
                   | inr y => Ret (inr (inr y))
                   end).
Proof.
  intros Hneq H. revert Hneq. revert n.
  induction H; intros n Hneq.
  - destruct x; subst; try contradiction.
    eapply itree_reachable_ret.
    2: { compute; rewrite 2!_observe_observe, H0.
         apply Nat.eqb_neq in Hneq; compute in Hneq; rewrite Hneq; reflexivity. }
    apply I.
  - eapply itree_reachable_tau; eauto.
    compute; rewrite 2!_observe_observe, H; reflexivity.
  - eapply itree_reachable_vis.
    { compute; rewrite 2!_observe_observe, H; reflexivity. }
    apply IHitree_reachable; auto.
Qed.

Lemma itree_reachable_bind {E A B} (t : itree E (unit + (A + B))) k P :
  itree_reachable (fun x => match x with
                         | inl _ => False
                         | inr y => P y
                         end) t ->
  itree_reachable P
    (lr <- t;; match lr with
              | inl l => k l
              | inr r => Ret r
              end).
Proof.
  induction 1.
  - destruct x; try contradiction.
    eapply itree_reachable_ret; eauto.
    compute; rewrite 2!_observe_observe, H0; reflexivity.
  - eapply itree_reachable_tau; eauto.
    compute; rewrite 2!_observe_observe, H; reflexivity.
  - eapply itree_reachable_vis.
    { compute; rewrite 2!_observe_observe, H; reflexivity. }
    apply IHitree_reachable.
Qed.

Lemma itree_reachable_iter {E A B} (k : unit -> itree E (unit + (A + B))) P :
  itree_reachable (fun x => match x with
                         | inr y => P y
                         | _ => False
                         end) (k tt) ->
  itree_reachable P (ITree.iter k tt).
Proof. rewrite unfold_iter; apply itree_reachable_bind. Qed.

Lemma itree_reachable_n_bind'' {E A} (t : itree E (nat + A)) (f : unit -> itree E (nat + A)) (k n : nat) :
  k <> n ->
  itree_reachable (fun x => match x with
                         | inl m => m = k
                         | inr _ => False
                         end) t ->
  itree_reachable (fun x => match x with
                         | inl m => m = k
                         | inr _ => False
                         end)
                  (lr <-
                   (x <- t;;
                    match x with
                    | inl n0 => if n0 =? n then Ret (inl tt) else Ret (inr (inl n0))
                    | inr y => Ret (inr (inr y))
                    end);;
                   match lr with
                   | inl l => f l
                   | inr r => Ret r
                   end).
Proof.
  intros Hneq H.
  revert Hneq. revert n.
  induction H; intros n Hneq.
  - destruct x; try contradiction; subst.
    eapply itree_reachable_ret.
    2: { compute; rewrite 3!_observe_observe, H0.
         apply Nat.eqb_neq in Hneq; compute in Hneq; rewrite Hneq.
         reflexivity. }
    reflexivity.
  - eapply itree_reachable_tau.
    { compute; rewrite 3!_observe_observe, H.
      reflexivity. }
    apply IHitree_reachable; auto.
  - eapply itree_reachable_vis.
    { compute; rewrite 3!_observe_observe, H.
      reflexivity. }
    apply IHitree_reachable; auto.
Qed.

Lemma itree_reachable_n_iter {E A} (t : itree E (nat + A)) k n :
  k <> n ->
  itree_reachable (fun x => match x with
                         | inl m => m = k
                         | inr _ => False
                         end) t ->
  itree_reachable (fun x => match x with
                         | inl m => m = k
                         | inr _ => False
                         end)
    (ITree.iter
       (fun _ : unit =>
        x <- t;;
        match x with
        | inl n0 => if n0 =? n then Ret (inl tt) else Ret (inr (inl n0))
        | inr y => Ret (inr (inr y))
        end) tt).
Proof.
  intros Hneq H.
  rewrite unfold_iter.
  apply itree_reachable_n_bind''; auto.
Qed.

Lemma fail_reachable'_itree_reachable {A} (t : tree A) (k : nat) :
  not_bound_in k t ->
  fail_reachable' k t ->
  itree_reachable (fun x => match x with
                         | inl m => m = k
                         | inr _ => False
                         end) (unbiased_tree_to_itree t).
Proof.
  intros Hnotbound H.
  revert Hnotbound.
  induction H; simpl; intros Hnotbound.
  - eapply itree_reachable_ret; try reflexivity.
    apply eq_refl.
  - inversion Hnotbound; subst.
    eapply itree_reachable_vis with (y:=true); try reflexivity.
    apply IHfail_reachable'; auto.
  - inversion Hnotbound; subst.
    eapply itree_reachable_vis with (y:=false); try reflexivity.
    apply IHfail_reachable'; auto.
  - inversion Hnotbound; subst.
    apply itree_reachable_n_iter; auto.
Qed.

Lemma kdfg {A} (t : tree A) (k n : nat) :
  not_bound_in k t ->
  fail_reachable' k t ->
  k <> n ->
  itree_reachable (const True)
                  (ITree.iter
                     (fun _ : unit =>
                        x <- unbiased_tree_to_itree t;;
                        match x with
                        | inl n1 => if n1 =? n then Ret (inl tt) else Ret (inr (inl n1))
                        | inr y => Ret (inr (inr y))
                        end) tt).
Proof.
  intros Hnotbound Hfail Hneq.
  apply ret_reachable_iter'.
  apply itree_reachable_n_bind' with k; auto.
  apply fail_reachable'_itree_reachable; auto.
Qed.

Lemma nondivergent'_itree_fintau {A : Type} (t : tree A) (lbls : list nat) :
  wf_tree t ->
  (forall n, bound_in n t -> ~ In n lbls) ->
  nondivergent' lbls t ->
  itree_fintau (unbiased_tree_to_itree t).
Proof.
  revert lbls.
  induction t; simpl; intros lbls Hwf Hnotin Hnd.
  - pstep; constructor.
  - pstep; constructor.
  - inversion Hnd; subst.
    inversion Hwf; subst.
    pstep; constructor; intros []; left.
    + eapply IHt1; eauto.
      intros n Hbound Hin; eapply Hnotin; eauto; constructor; auto.
    + eapply IHt2; eauto.
      intros n Hbound Hin; eapply Hnotin; eauto; solve[constructor; auto].
  - inversion Hnd; subst.
    inversion Hwf; subst.
    destruct H2 as [Hleaf | [k [Hin Hreach]]].
    + apply itree_fintau_iter.
      * intros _; apply itree_fintau_bind'; eauto.
        -- eapply IHt; eauto.
           intros m Hbound Hin.
           destruct (Nat.eqb_spec n m); subst.
           ++ apply bound_in_not_bound_in in H4; congruence.
           ++ destruct Hin; try congruence.
              eapply Hnotin; eauto; constructor; auto.
        -- intros [m | x].
           ++ destruct (PeanoNat.Nat.eqb m n); pstep; constructor.
           ++ pstep; constructor.
      * intros [].
        eapply itree_reachable_fintau, ret_reachable_iter, ret_reachable_bind'.
        apply leaf_reachable'_ret_reachable, leaf_reachable_leaf_reachable'; auto.
      * intros _.
        eapply itree_reachable_impl.
        2: { apply ret_reachable_bind'.
             apply leaf_reachable'_ret_reachable.
             apply leaf_reachable_leaf_reachable'; auto. }
        intros [? | [? | ?]]; auto.
    + destruct (Nat.eqb_spec k n); subst.
      { exfalso; eapply Hnotin; eauto; constructor. }
      apply itree_fintau_iter.
      * intros _; apply itree_fintau_bind'; eauto.
        -- eapply IHt; eauto.
           intros m Hbound Hin'.
           destruct (Nat.eqb_spec m n); subst.
           ++ apply bound_in_not_bound_in in H4; congruence.
           ++ destruct Hin'; try congruence.
              eapply Hnotin; eauto; constructor; auto.
        -- intros [m | x].
           ++ destruct (PeanoNat.Nat.eqb m n); pstep; constructor.
           ++ pstep; constructor.
      * intros [].
        eapply itree_reachable_fintau.
        eapply kdfg.
        2: { apply fail_reachable_fail_reachable'; eauto. }
        -- apply bound_in_not_bound_in; intro Hbound.
           eapply Hnotin; eauto.
           constructor; auto.
        -- auto.
      * intros [].
        eapply itree_reachable_impl.
        2: {
          eapply itree_reachable_n_bind'; eauto.
          apply fail_reachable'_itree_reachable; auto.
          -- apply bound_in_not_bound_in; intro Hbound.
             eapply Hnotin; eauto.
             constructor; auto.
          -- apply fail_reachable_fail_reachable'; auto. }
        intros [? | [? | ?]]; auto.
Qed.

Lemma itree_reachable_bind'' {E A} (t : itree E (nat + A)) :
  itree_reachable (fun x => match x with
                         | inl _ => False
                         | inr _ => True
                         end) t ->
  itree_reachable (fun x : unit + A => match x with
                                    | inl _ => False
                                    | inr _ => True
                                    end)
                  (x <- t;;
                   match x with
                   | inl _ => ret (inl tt)
                   | inr r => ret (inr r)
                   end).
Proof.
  induction 1.
  - destruct x; try contradiction.
    eapply itree_reachable_ret.
    2: { compute; rewrite 2!_observe_observe, H0; reflexivity. }
    apply I.
  - eapply itree_reachable_tau.
    { compute; rewrite 2!_observe_observe, H; reflexivity. }
    apply IHitree_reachable.
  - eapply itree_reachable_vis.
    { compute; rewrite 2!_observe_observe, H; reflexivity. }
    apply IHitree_reachable.
Qed.

Theorem nondivergent''_itree_fintau {A : Type} (t : tree A) (n : nat) :
  wf_tree t ->
  not_bound_in n t ->
  nondivergent'' n t ->
  itree_fintau (unbiased_tree_to_itree' t).
Proof.
  intros Hwf Hnotbound Hnd.
  unfold nondivergent'' in Hnd.
  unfold unbiased_tree_to_itree'.
  unfold tie_itree'.
  inversion Hnd; subst.
  apply itree_fintau_iter.
  - intros _.
    apply itree_fintau_bind'.
    + eapply nondivergent'_itree_fintau; eauto.
      intros m Hbound [? | []]; subst.
      apply bound_in_not_bound_in in Hnotbound; congruence.
    + intros []; pstep; constructor.
  - intros [].
    destruct H2 as [Hleaf | [k [Hin Hreach]]].
    + eapply itree_reachable_fintau, ret_reachable_iter', itree_reachable_bind''.
      apply leaf_reachable'_ret_reachable, leaf_reachable_leaf_reachable'; auto.
    + inversion Hin.
  - intros [].
    destruct H2 as [Hleaf | [k [Hin Hreach]]].
    + apply itree_reachable_bind''.
      apply leaf_reachable'_ret_reachable, leaf_reachable_leaf_reachable'; auto.
    + inversion Hin.
Qed.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.
Require Import VerdiRaft.SpecLemmas.
Require Import VerdiRaft.RefinementSpecLemmas.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Require Import VerdiRaft.AllEntriesTermSanityInterface.

Section AllEntriesTermSanity.

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

  Context {rri: raft_refinement_interface}.

  Lemma handleAppendEntries_currentTerm_monotonic:
    forall h st (d : raft_data)
      (m : msg) (t : term) (n : name) (pli : logIndex)
      (plt : term) (es : list entry) (ci : logIndex),
      handleAppendEntries h st t n pli plt es
                          ci = (d, m) ->
      currentTerm st <= currentTerm d.
  Proof using.
    intros.
    unfold handleAppendEntries in *.
    repeat break_match; simpl in *; do_bool; repeat find_inversion; auto; try lia;
    simpl in *;
    unfold advanceCurrentTerm in *; repeat break_match; do_bool; auto.
  Qed.

  Lemma allEntries_term_sanity_append_entries :
    refined_raft_net_invariant_append_entries allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros. simpl in *.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_copy_eapply_lem_hyp update_elections_data_appendEntries_allEntries_term'; eauto.
    intuition.
    find_apply_lem_hyp handleAppendEntries_currentTerm_monotonic;
      find_apply_hyp_hyp; lia.
  Qed.

  Lemma allEntries_term_sanity_append_entries_reply :
    refined_raft_net_invariant_append_entries_reply allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_apply_lem_hyp handleAppendEntriesReply_type_term. intuition; repeat find_rewrite; eauto.
    find_apply_hyp_hyp. lia.
  Qed.

  Lemma allEntries_term_sanity_request_vote :
    refined_raft_net_invariant_request_vote allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_rewrite_lem update_elections_data_requestVote_allEntries.
    find_apply_lem_hyp handleRequestVote_type_term. intuition; repeat find_rewrite; eauto.
    find_apply_hyp_hyp. lia.
  Qed.

  Lemma allEntries_term_sanity_request_vote_reply :
    refined_raft_net_invariant_request_vote_reply allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_rewrite_lem update_elections_data_requestVoteReply_allEntries.
    find_apply_hyp_hyp.
    unfold handleRequestVoteReply, advanceCurrentTerm.
    repeat break_match; simpl in *; repeat find_inversion; do_bool; simpl in *; auto.
    lia.
  Qed.

  Lemma allEntries_term_sanity_client_request :
    refined_raft_net_invariant_client_request allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_copy_apply_lem_hyp update_elections_data_client_request_allEntries.
    find_apply_lem_hyp handleClientRequest_type.
    intuition; repeat find_rewrite;
    try find_apply_hyp_hyp; auto.
    break_exists.
    intuition; repeat find_rewrite;
    simpl in *.
    intuition; simpl in *;
    try match goal with
      | H : context [ _ :: _ ] |- _ => clear H
    end; repeat tuple_inversion; eauto.
  Qed.

  Lemma allEntries_term_sanity_timeout :
    refined_raft_net_invariant_timeout allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_rewrite_lem update_elections_data_timeout_allEntries.
    find_apply_lem_hyp handleTimeout_type_strong.
    intuition; repeat find_rewrite; eauto.
  Qed.

  Lemma allEntries_term_sanity_do_leader :
    refined_raft_net_invariant_do_leader allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_apply_lem_hyp doLeader_type. intuition.
    repeat find_rewrite. eauto.
  Qed.

  Lemma allEntries_term_sanity_do_generic_server :
    refined_raft_net_invariant_do_generic_server allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_apply_lem_hyp doGenericServer_type. intuition.
    repeat find_rewrite. eauto.
  Qed.

  Lemma allEntries_term_sanity_reboot :
    refined_raft_net_invariant_reboot allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
  Qed.

  Lemma allEntries_term_sanity_state_same_packet_subset :
    refined_raft_net_invariant_state_same_packet_subset allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros.
    find_reverse_higher_order_rewrite. eauto.
  Qed.

  Lemma allEntries_term_sanity_init :
    refined_raft_net_invariant_init allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros. simpl in *. intuition.
  Qed.

  Instance aetsi : allEntries_term_sanity_interface.
  Proof.
    split.
    intros.
    apply refined_raft_net_invariant; auto.
    - apply allEntries_term_sanity_init.
    - apply allEntries_term_sanity_client_request.
    - apply allEntries_term_sanity_timeout.
    - apply allEntries_term_sanity_append_entries.
    - apply allEntries_term_sanity_append_entries_reply.
    - apply allEntries_term_sanity_request_vote.
    - apply allEntries_term_sanity_request_vote_reply.
    - apply allEntries_term_sanity_do_leader.
    - apply allEntries_term_sanity_do_generic_server.
    - apply allEntries_term_sanity_state_same_packet_subset.
    - apply allEntries_term_sanity_reboot.
  Qed.
End AllEntriesTermSanity.