Require Import Bool.
Require Import Word.
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 DirName.
Require Import DirTreeDef.
Require Import DirTreePath.
Require Import DirTreePred.
Require Import DirTreeRep.
Require Import SepAuto.

Import ListNotations.
Set Implicit Arguments.

  (**
   * Names in a directory are unique.
   *)

  Inductive tree_names_distinct : dirtree -> Prop :=
  | TND_file : forall inum f, tree_names_distinct (TreeFile inum f)
  | TND_dir : forall inum tree_ents,
    Forall tree_names_distinct (map snd tree_ents) ->
    NoDup (map fst tree_ents) ->
    tree_names_distinct (TreeDir inum tree_ents).

  Lemma rep_tree_names_distinct' : forall tree F xp m,
    (F * tree_pred xp tree)%pred m ->
    tree_names_distinct tree.
  Proof.
    induction tree using dirtree_ind2; simpl; intros.
    - constructor.
    - constructor.
      2: rewrite dir_names_distinct in H0; destruct_lift H0; eauto.

      apply Forall_forall. intros.
      rewrite Forall_forall in H.
      specialize (H x H1).

      apply in_map_iff in H1; repeat deex.
      destruct x0; simpl in *.
      apply in_split in H3; repeat deex.

      rewrite dirlist_pred_split in H0. simpl in H0.
      eapply H with (xp := xp).
      pred_apply' H0.
      cancel.
  Qed.

  Lemma rep_tree_names_distinct : forall tree F fsxp Ftop m ilist frees ms sm,
    (F * rep fsxp Ftop tree ilist frees ms sm)%pred m ->
    tree_names_distinct tree.
  Proof.
    unfold rep; intros.
    destruct_lift H.
    eapply rep_tree_names_distinct' with (xp := fsxp).
    pred_apply' H1.
    cancel.
  Qed.

  Lemma tree_names_distinct_update_subtree : forall pn t subtree,
    tree_names_distinct t ->
    tree_names_distinct subtree ->
    tree_names_distinct (update_subtree pn subtree t).
  Proof.
    induction pn; simpl; eauto; intros.
    destruct t; eauto.
    constructor.
    - induction l; simpl; constructor.
      + destruct a0; simpl.
        inversion H; simpl in *; subst.
        inversion H3; subst.
        destruct (string_dec s a); subst; simpl; eauto.
      + eapply IHl.
        inversion H; subst.
        inversion H3; subst.
        inversion H4; subst.
        constructor; eauto.
    - inversion H; subst.
      replace (map fst (map (update_subtree_helper (update_subtree pn subtree) a) l)) with (map fst l); eauto.
      clear H H3 H4.
      induction l; simpl; eauto.
      f_equal; eauto.
      destruct a0; simpl.
      destruct (string_dec s a); eauto.
  Qed.

  Theorem tree_names_distinct_head : forall n a d l,
    tree_names_distinct (TreeDir n ((a, d) :: l)) ->
    tree_names_distinct (TreeDir n ([(a, d)])).
  Proof.
    intros.
    constructor.
    inversion H.
    simpl in *.
    inversion H2.
    constructor; eauto.
    constructor.
    inversion H.
    simpl in *. subst.
    constructor.
    simpl in *; auto.
    constructor.
  Qed.

  Theorem tree_names_distinct_child : forall n a d l,
    tree_names_distinct (TreeDir n ((a, d) :: l)) ->
    tree_names_distinct d.
  Proof.
    intros.
    inversion H; simpl in *.
    inversion H2; eauto.
  Qed.

  Hint Resolve tree_names_distinct_child.

  Lemma tree_names_distinct_next : forall n s d l,
    tree_names_distinct (TreeDir n ((s, d) :: l)) ->
    tree_names_distinct (TreeDir n l).
  Proof.
    intros.
    inversion H.
    constructor.
    inversion H2; eauto.
    inversion H3; eauto.
  Qed.

  Hint Resolve tree_names_distinct_next.

  Lemma tree_names_distinct_head_not_rest : forall inum e ents name path subtree,
    tree_names_distinct (TreeDir inum (e :: ents)) ->
    find_subtree (name::path) (TreeDir inum ents) = Some subtree ->
    find_subtree (name::path) (TreeDir inum (e :: ents)) = Some subtree.
  Proof.
    destruct e; simpl; intros.
    destruct (string_dec s name); eauto; subst.
    inversion H.
    inversion H4; subst.
    clear H H3 H4 H8.
    exfalso.
    induction ents; simpl in *; try congruence.
    destruct a; simpl in *; intuition.
    destruct (string_dec s name); simpl in *; try congruence.
    eapply IHents; eauto.
  Qed.

 Lemma tree_names_distinct_head_name : forall inum name subtree rest,
    tree_names_distinct (TreeDir inum ((name, subtree) :: rest)) ->
    ~ In name (map fst rest).
  Proof.
    inversion 1.
    simpl in *.
    inversion H3; auto.
  Qed.

  Lemma tree_name_distinct_rest: forall inum x l,
        tree_names_distinct (TreeDir inum (x::l)) ->
        tree_names_distinct (TreeDir inum l).
  Proof.
    intros.
    inversion H.
    rewrite map_cons in H2.
    apply Forall_cons2 in H2.
    rewrite map_cons in H3.
    rewrite NoDup_cons_iff in H3.
    intuition.
    constructor; eauto.
  Qed.

  Lemma tree_name_distinct_head: forall inum name l t,
        tree_names_distinct (TreeDir inum ((name, t)::l)) ->
        tree_names_distinct t.
  Proof.
    intros.
    destruct t.
    constructor.
    inversion H.
    rewrite map_cons in H2.
    apply Forall_inv in H2.
    simpl in H2.
    inversion H2.
    constructor; eauto.
  Qed.

  Lemma tree_names_distinct_subtree : forall path tree subtree,
    tree_names_distinct tree ->
    find_subtree path tree = Some subtree ->
    tree_names_distinct subtree.
  Proof.
    induction path.
    intros; inversion H0; subst; auto.
    induction tree; simpl; try congruence; intros.
    inversion H0; subst.

    induction l; simpl in *; try congruence.
    destruct a0; simpl in *.
    destruct (string_dec s a); subst; simpl in *.
    - inversion H; inversion H4; subst; simpl in *.
      eapply IHpath; eauto.
    - inversion H; inversion H4; subst; simpl in *.
      apply IHl; eauto.
  Qed.

 Lemma tree_names_distinct_nodup : forall dnum ents,
    tree_names_distinct (TreeDir dnum ents) ->
    NoDup (map fst ents).
  Proof.
    intros; inversion H; auto.
  Qed.

  Lemma tree_names_distinct_delete_from_list : forall l n name,
    tree_names_distinct (TreeDir n l) ->
    tree_names_distinct (TreeDir n (delete_from_list name l)).
  Proof.
    induction l; simpl; intros; auto.
    destruct a; simpl in *.
    inversion H; subst; simpl in *.
    inversion H2; inversion H3; subst.
    destruct (string_dec s name); subst; auto.
    constructor; auto.
    constructor.
    rewrite Forall_forall in *; simpl in *; intuition.
    apply H5.
    eapply In_delete_from_list_snd; eauto.
    simpl; constructor.
    contradict H8.
    eapply In_delete_from_list_fst; eauto.
    apply NoDup_delete_from_list; auto.
  Qed.

  Lemma tree_names_distinct_delete_ne: forall l path name' n subtree,
    NoDup (map fst l) ->
    (~ pathname_prefix [name'] path) ->
    tree_names_distinct (TreeDir n l) ->
    find_subtree path (delete_from_dir name' (TreeDir n l)) = Some subtree ->
    tree_names_distinct subtree.
  Proof.
    induction path; intros; auto.
    - unfold find_subtree in H2; subst; simpl.
      inversion H2.
      eapply tree_names_distinct_delete_from_list; eauto.
    - rewrite find_subtree_delete_ne in H2; eauto.
      eapply tree_names_distinct_subtree; eauto.
      intro.
      eapply pathname_prefix_head_neq'; eauto.
  Qed.

  Lemma tree_names_distinct_prune_child_subtree: forall path suffix tree name subtree n l,
    tree_names_distinct tree ->
    find_subtree (path ++ suffix) tree = Some (TreeDir n l) ->
    find_subtree path (update_subtree (path++suffix) (delete_from_dir name (TreeDir n l)) tree)
      = Some subtree ->
    tree_names_distinct subtree.
  Proof.
    intros.
    eapply find_subtree_app' in H0 as H0'.
    destruct H0'; intuition.
    erewrite find_subtree_update_subtree_child in H1; eauto.
    inversion H1.
    eapply tree_names_distinct_update_subtree.
    eapply tree_names_distinct_subtree; eauto.
    eapply tree_names_distinct_delete_from_list; eauto.
    eapply tree_names_distinct_subtree; eauto.
  Qed.

 Lemma update_subtree_path_notfound: forall p tree subtree,
    tree_names_distinct tree ->
    find_subtree p tree = None ->
    update_subtree p subtree tree = tree.
  Proof.
    induction p; intros; subst.
    - simpl in *. exfalso. inversion H0.
    - destruct tree; simpl; eauto.
      f_equal.
      induction l; subst; simpl; eauto.
      destruct a0.
      destruct (string_dec a s); subst.
      simpl.
      destruct (string_dec s s); try congruence.
      rewrite update_subtree_notfound; eauto.
      erewrite IHp; eauto.
      simpl in H0.
      destruct (string_dec s s) in H0; try congruence.
      eapply tree_names_distinct_nodup in H.
      simpl in H.
      inversion H; eauto.
      simpl.
      destruct (string_dec s a); try congruence.
      f_equal.
      eapply IHl.
      eapply tree_name_distinct_rest in H; eauto.
      simpl in H0.
      destruct (string_dec s a) in H0; try congruence.
      simpl; eauto.
  Qed.

  Lemma find_subtree_update_subtree_ne_path : forall p1 p2 tree subtree,
    tree_names_distinct tree ->
    (~ pathname_prefix p2 p1) ->
    (~ pathname_prefix p1 p2) ->
    find_subtree p1 (update_subtree p2 subtree tree) = find_subtree p1 tree.
  Proof.
    induction p1; intros; auto.
    - exfalso.
      unfold pathname_prefix in *.
      eapply H1.
      exists p2; eauto.
    - destruct (pathname_decide_prefix [a] p2).
      + deex; subst.
        case_eq(find_subtree [a] tree); intros; subst; try congruence.
          --
            case_eq(find_subtree ([a]++suffix) tree); intros; subst; try congruence.
            eapply find_subtree_update_trim; eauto.
            eapply find_subtree_app' in H3 as H3'.
            deex.
            rewrite H5 in H2.
            inversion H2; subst.
            eauto.
            eapply IHp1; eauto.
            eapply tree_names_distinct_subtree; eauto.
            setoid_rewrite cons_app in H0 at 3.
            rewrite <- pathname_prefix_trim in H0; eauto.
            rewrite cons_app in H1.
            rewrite <- pathname_prefix_trim in H1; eauto.
            erewrite update_subtree_path_notfound; eauto.
          --  (* a is None *)
          rewrite cons_app.
          erewrite find_subtree_app_none; eauto.
          erewrite find_subtree_app_none; eauto.
          eapply find_subtree_update_subtree_none; eauto.
      + (* p2 doesn't start with a *)
        rewrite cons_app.
        subst; try congruence.
        ++ case_eq(find_subtree [a] tree); intros; subst; try congruence.
          -- (* a is a directory or file *)
            case_eq(find_subtree p2 tree); intros; subst; try congruence.
            erewrite find_subtree_app.
            2: erewrite find_subtree_update_subtree_oob'' with (pn := p2); eauto.
            erewrite find_subtree_app; eauto.
            intro; subst.
            eapply H0.
            unfold pathname_prefix.
            eexists (a::p1); eauto.
            unfold pathname_prefix; intro; apply H2.
            destruct H5.
            exists x; eauto.
            erewrite update_subtree_path_notfound; eauto.
          -- (* a is not present *)
            repeat erewrite find_subtree_app_none; eauto.
            erewrite find_subtree_update_subtree_oob''; eauto.
            intro; subst.
            eapply H0.
            unfold pathname_prefix.
            eexists (a::p1); eauto.
            unfold pathname_prefix; intro; apply H2.
            destruct H4.
            exists x; eauto.
  Qed.

  Lemma tree_names_distinct_prune_subtree : forall path tree path' name subtree n l,
    tree_names_distinct tree ->
    find_subtree path' tree = Some (TreeDir n l) ->
    find_subtree path (tree_prune n l path' name tree) = Some subtree ->
    tree_names_distinct subtree.
  Proof.
    intros.
    unfold tree_prune in *.
    destruct (pathname_decide_prefix path' path).
    + (* path is inside of tree pointed to by path' *)
      (* name cannot be on path because path isn't pruned (H1) *)
      destruct (list_eq_dec string_dec path' path); subst.
      - erewrite find_update_subtree in H1; eauto.
        inversion H1; subst.
        eapply tree_names_distinct_delete_from_list; eauto.
        eapply tree_names_distinct_subtree; eauto.
      - (* compare first component of suffix with name *)
        destruct H2; subst.
        erewrite find_subtree_app in H1; eauto.
        destruct (pathname_decide_prefix [name] x).
        destruct H2; subst.
        -- (* if equal to name -> contradiction with H1 *)
          erewrite find_subtree_app_none in H1.
          exfalso; congruence.
          erewrite find_subtree_delete_same; eauto.
          eapply tree_names_distinct_nodup.
          eapply tree_names_distinct_subtree; eauto.
         -- (* not equal to name, so not effect *)
          eapply tree_names_distinct_delete_ne; eauto.
          eapply tree_names_distinct_nodup.
          eapply tree_names_distinct_subtree; eauto.
          eapply pathname_prefix_neq; eauto.
          eapply tree_names_distinct_subtree; eauto.
    + destruct (pathname_decide_prefix path path').
      - (* path' is inside of path *)
        destruct H3; subst.
        eapply tree_names_distinct_prune_child_subtree; eauto.
      - (* paths are disjoint, pruning path1 doesn't effect path *)
        erewrite find_subtree_update_subtree_ne_path in H1; eauto.
        eapply tree_names_distinct_subtree; eauto.
        eapply pathname_prefix_neq; eauto.
        eapply pathname_prefix_neq; eauto.
  Qed.

 Lemma tree_names_distinct_prune_subtree' : forall inum ents base name tree,
    tree_names_distinct tree ->
    find_subtree base tree = Some (TreeDir inum ents) ->
    tree_names_distinct (tree_prune inum ents base name tree).
  Proof.
    intros.
    eapply tree_names_distinct_prune_subtree with (path := nil) in H0.
    eauto.
    eauto.
    simpl; eauto.
  Qed.

  Lemma find_subtree_add_to_list_oob: forall ents dnum s name subtree d,
    tree_names_distinct (TreeDir dnum ents) ->
    s <> name ->
    find_subtree [s] (TreeDir dnum (add_to_list name subtree ents)) = Some d ->
    find_subtree [s] (TreeDir dnum ents) = Some d.
  Proof.
    induction ents; intros; subst.
    + simpl in H1.
      destruct (string_dec name s); try congruence.
    + destruct a; simpl.
      unfold add_to_list in H1.
      destruct (string_dec s0 name) in H1; try congruence.
      ++
        destruct (string_dec s0 s); try congruence.
        simpl in H1.
        destruct (string_dec name s); try congruence.
      ++
        destruct (string_dec s0 s); try congruence.
        simpl in H1.
        destruct (string_dec s0 s) in H1; try congruence.
        rewrite find_subtree_head_ne in H1.
        unfold find_subtree in IHents.
        eapply IHents; eauto.
        try congruence.
  Qed.

  Lemma find_subtree_add_to_dir_oob: forall suffix name dnum ents subtree inum f,
     tree_names_distinct (TreeDir dnum ents) ->
     (~pathname_prefix [name] suffix) ->
     find_subtree suffix (add_to_dir name subtree (TreeDir dnum ents)) = Some (TreeFile inum f)->
     find_subtree suffix (add_to_dir name subtree (TreeDir dnum ents)) = find_subtree suffix (TreeDir dnum ents).
  Proof.
    intros.
    destruct suffix.
    - unfold add_to_dir in *. simpl in *.
      inversion H1.
    - destruct (string_dec s name); subst.
      + exfalso.
        eapply H0;  unfold pathname_prefix.
        exists suffix; eauto.
      + erewrite cons_app. erewrite cons_app in H1.
        eapply find_subtree_app' in H1.
        deex.
        erewrite find_subtree_app.
        2: eauto.
        erewrite find_subtree_app; eauto.
        unfold add_to_dir in H2.
        eapply find_subtree_add_to_list_oob; eauto.
  Qed.

  Lemma find_subtree_add_to_dir_oob': forall suffix name tree subtree inum f,
     tree_names_distinct tree ->
     (~pathname_prefix [name] suffix) ->
     find_subtree suffix (add_to_dir name subtree tree) = Some (TreeFile inum f)->
     find_subtree suffix (add_to_dir name subtree tree) = find_subtree suffix tree.
  Proof.
    intros. destruct tree.
    - simpl in H1.
      destruct suffix.
      + simpl; eauto.
      + unfold find_subtree in H1; simpl.
        inversion H1.
    - erewrite find_subtree_add_to_dir_oob; eauto.
  Qed.

  Lemma find_subtree_rename_oob: forall x n l n' l' dnum ents inum f srcpath srcname dstpath dstname mvtree,
    tree_names_distinct (TreeDir dnum ents) ->
    ~pathname_prefix [dstname] x ->
    find_subtree srcpath (TreeDir dnum ents) = Some (TreeDir n l) ->
    find_dirlist srcname l = Some mvtree ->
    find_subtree dstpath (tree_prune n l srcpath srcname (TreeDir dnum ents)) =
       Some (TreeDir n' l') ->
    find_subtree (dstpath ++ x) (tree_graft n' l' dstpath dstname mvtree
            (tree_prune n l srcpath srcname (TreeDir dnum ents))) =
      Some (TreeFile inum f) ->
    find_subtree (dstpath ++ x) (TreeDir dnum ents) = Some (TreeFile inum f).
  Proof.
    intros; cbn.
    unfold tree_prune, tree_graft in *.
    destruct (pathname_decide_prefix srcpath dstpath).
    + repeat deex.
      erewrite find_update_subtree_suffix in H4; eauto.
      erewrite find_update_subtree_suffix in H3; eauto.
      destruct suffix; subst; try congruence.
      -- (* suffix is nil *)
        destruct x; repeat rewrite app_nil_r in *.
        {
          (* x is nil *)
          simpl in H4.
          inversion H4.
        }
        destruct (string_dec srcname s); subst; try congruence.
        ++ (* x starts with srcname *)
          erewrite find_subtree_add_to_dir_oob in H4; eauto.
          simpl in H3.
          inversion H3; subst.
          rewrite find_subtree_delete_same' in H4.
          exfalso; inversion H4.
          eapply tree_names_distinct_nodup.
          eapply tree_names_distinct_subtree; eauto.
          simpl in H3; subst.
          inversion H3.
          rewrite <- H6.
          eapply tree_names_distinct_delete_from_list.
          eapply tree_names_distinct_subtree; eauto.
        ++ (* x doesn't start with srcname *)
          erewrite find_subtree_add_to_dir_oob in H4; eauto.
          simpl in H3.
          inversion H3; subst.
          erewrite find_subtree_delete_ne' in H4; eauto.
          erewrite find_subtree_app; eauto.
          eapply tree_names_distinct_nodup.
          eapply tree_names_distinct_subtree; eauto.
          simpl in H3; subst.
          inversion H3.
          rewrite <- H6.
          eapply tree_names_distinct_delete_from_list.
          eapply tree_names_distinct_subtree; eauto.
      -- (* suffix starts with s *)
        destruct (string_dec s srcname); subst; try congruence.
        {
          rewrite find_subtree_delete_same in H3. exfalso; inversion H3.
          eapply tree_names_distinct_nodup.
          eapply tree_names_distinct_subtree; eauto.
        }
        { (* s <> srcname *)
          rewrite find_subtree_delete_ne in H3; eauto.
          destruct x; repeat rewrite app_nil_r in *.
          { (* x is nil *)
            simpl in H4.
            inversion H4.
          }
          erewrite find_subtree_add_to_dir_oob in H4; eauto.
          erewrite find_subtree_app; eauto.
          erewrite find_subtree_app; eauto.
          eapply tree_names_distinct_subtree in H3; eauto.
          eapply tree_names_distinct_subtree; eauto.
          eapply tree_names_distinct_nodup.
          eapply tree_names_distinct_subtree; eauto.
        }
    + destruct (pathname_decide_prefix dstpath srcpath).
      - (* dstpath is a prefix of srcpath *)
        deex.
        erewrite find_update_subtree_suffix in H4; eauto.
        eapply find_subtree_app' in H1.
        deex.
        erewrite find_subtree_app. 2:eauto.
        destruct suffix; subst; try congruence.
        -- (* dstpath = srcpath *)
          simpl in H7. inversion H7. subst.
          clear H7.
          repeat rewrite app_nil_r in *.
          erewrite find_update_subtree in H3; eauto.
          inversion H3.
          rewrite <- H8 in *. clear H8. subst.
          unfold add_to_dir, delete_from_dir in *. clear H3.
          destruct H5.
          exists []; rewrite app_nil_r; eauto.
        -- {(* suffix starts with s: srcpath = dstpath+s+suffix *)
            destruct (pathname_decide_prefix (s::suffix++[srcname]) x).
            - (* x is a prefix of s::suffix++srcname. srcname is equal or below x
               * s <> dstname, because x doesn't start with dstname *)
              deex. subst.
              erewrite find_subtree_add_to_dir_oob in H4; eauto.
              erewrite find_subtree_extend with (p1 := dstpath) in H4.
              2: eauto.
              replace (dstpath ++ (s :: suffix ++ [srcname]) ++ suffix0) with
                      ((dstpath ++ s :: suffix)++([srcname]++suffix0)) in H4.
              erewrite find_update_subtree_suffix in H4.
              rewrite <- cons_app in H4.
              unfold delete_from_dir in H4.
              erewrite find_subtree_delete_same' in H4.
              inversion H4.
              eapply tree_names_distinct_nodup with (dnum:= n).
              eapply tree_names_distinct_subtree in H7; eauto.
              eapply tree_names_distinct_subtree in H6; eauto.
              erewrite find_subtree_app; eauto.
              rewrite <- app_assoc. f_equal. rewrite app_assoc. f_equal.
              eapply tree_names_distinct_subtree. 2: eauto.
              eapply tree_names_distinct_update_subtree;eauto.
              eapply tree_names_distinct_delete_from_list; eauto.
              eapply tree_names_distinct_subtree in H7; eauto.
              eapply tree_names_distinct_subtree in H6; eauto.
            - (* s::suffix++[srcname] isn't a prefix of x *)
              erewrite find_subtree_extend with (p1 := dstpath) in H4.
              2: eauto.
              erewrite find_update_subtree_suffix in H4; eauto.
              erewrite find_subtree_add_to_dir_oob in H4; eauto.
              erewrite find_subtree_extend with (p1 := dstpath) in H4.
              2: eauto.
              destruct (pathname_decide_prefix x ([s]++suffix)).
              ++ (* x is a prefix of [s]++suffix *)
                deex.
                rewrite cons_app in H4.
                rewrite H8 in H4.
                rewrite cons_app in H3.
                rewrite H8 in H3.
                rewrite cons_app in H7.
                rewrite H8 in H7.
                eapply find_subtree_app' in H7.
                deex; intuition.
                erewrite find_subtree_app in H4.
                2: eauto.
                erewrite find_subtree_update_subtree_child in H3.
                2: eauto.
                inversion H3.
                rewrite <- H11 in H4.
                clear H3. clear H11.
                destruct suffix0.
                -- (* x is [s]++suffix] *)
                  rewrite app_nil_r in *.
                  erewrite find_update_subtree in H4; eauto. inversion H4.
                --
                  erewrite find_subtree_update_subtree_child in H4; eauto.
                  destruct subtree_base0.
                  unfold find_subtree in H10; inversion H10.
                  unfold update_subtree in H4; simpl in *.
                  inversion H4.
              ++ (* x isn't a prefix of [s]++suffix *)
                destruct (pathname_decide_prefix ([s]++suffix) x).
                +++ (* [s]++suffix is prefix of x *)
                  deex.
                  rewrite app_assoc in H4.
                  erewrite find_update_subtree_suffix in H4.
                  unfold delete_from_dir in H4.
                  destruct suffix0.
                  simpl in H4; inversion H4.
                  erewrite find_subtree_delete_ne' in H4.
                  erewrite find_subtree_app; eauto.
                  eapply tree_names_distinct_nodup with (dnum:= n).
                  eapply tree_names_distinct_subtree in H7; eauto.
                  eapply tree_names_distinct_subtree in H6; eauto.
                  intro.
                  exfalso. eapply H1.
                  eexists suffix0.
                  subst.
                  rewrite cons_app with (a := srcname).
                  rewrite app_assoc with (l := [s]++suffix).
                  f_equal.
                  erewrite find_subtree_app; eauto.
                +++ (* neither is a prefix of the other *)
                  rewrite find_subtree_update_subtree_ne_path in H4.
                  erewrite find_subtree_app in H4; eauto.
                  eauto.
                  rewrite <- pathname_prefix_trim.
                  unfold pathname_prefix.
                  intro.
                  eapply H9.
                  deex.
                  exists suffix0.
                  f_equal.
                  rewrite <- pathname_prefix_trim.
                  unfold pathname_prefix.
                  intro. eapply H8.
                  deex. eexists suffix0.
                  rewrite cons_app in H10.
                  rewrite <- H10. reflexivity.
              ++
                  eapply tree_names_distinct_subtree in H3; eauto.
                  eapply tree_names_distinct_update_subtree;eauto.
                  eapply tree_names_distinct_delete_from_list; eauto.
                  eapply tree_names_distinct_subtree in H7; eauto.
                  eapply tree_names_distinct_subtree in H6; eauto.
         }
      - (* dstpath isn't a prefix of srcpath *)
        erewrite find_update_subtree_suffix in H4; eauto.
        erewrite find_subtree_update_subtree_ne_path in H3; eauto.
        erewrite find_subtree_add_to_dir_oob in H4; eauto.
        eapply find_subtree_app with (p1 := x) in H3; eauto.
        rewrite H4 in H3; eauto.
        eapply tree_names_distinct_subtree; eauto.
        eapply pathname_prefix_neq; eauto.
        eapply pathname_prefix_neq; eauto.
  Qed.

  (* pathname outside of srcpath++srcname and dst tree, but maybe in srcpath *)
  Lemma find_subtree_rename_oob_srcname_dst: forall pathname dstpath dstname srcpath srcname n l dnum ents inum f,
    (~pathname_prefix (srcpath++[srcname]) pathname) ->
    (~pathname_prefix (dstpath++[dstname]) pathname) ->
    (~pathname_prefix dstpath pathname) ->
    tree_names_distinct (TreeDir dnum ents) ->
    find_subtree srcpath (TreeDir dnum ents) = Some (TreeDir n l) ->
    find_subtree pathname
       (update_subtree srcpath (TreeDir n (delete_from_list srcname l))
          (TreeDir dnum ents)) = Some (TreeFile inum f) ->
    find_subtree pathname (TreeDir dnum ents) = Some (TreeFile inum f).
  Proof.
    intros; cbn.
    destruct (pathname_decide_prefix srcpath pathname).
    -- (* srcpath is a prefix of pathname *)
      deex.
      denote update_subtree as Hx.
      erewrite find_update_subtree_suffix in Hx; eauto.
      {
        destruct suffix.
        - rewrite app_nil_r in *. unfold find_subtree in Hx; inversion Hx.
        - destruct (string_dec srcname s); subst.
          + exfalso. eapply H. exists suffix. rewrite <- app_assoc.
            f_equal.
          + erewrite find_subtree_delete_ne' in Hx.
            erewrite find_subtree_app; eauto.
            eapply tree_names_distinct_nodup; eauto.
            eapply tree_names_distinct_subtree; eauto.
            congruence.
      }
    -- destruct (pathname_decide_prefix pathname srcpath).
      {
        deex.
        eapply find_subtree_app' in H3. deex; intuition.
        destruct subtree_base; try congruence.
        + unfold find_subtree in H7.
          destruct suffix; try congruence.
        + erewrite find_subtree_update_subtree_child in H4; eauto.
          destruct suffix; unfold update_subtree in H4; try congruence.
       }
      (* pathname has nothing in common with srcpath and dstpath *)
      erewrite find_subtree_update_subtree_ne_path in H4; eauto.
      eapply pathname_prefix_neq; eauto.
      eapply pathname_prefix_neq; eauto.
  Qed.

  Theorem update_subtree_app : forall p0 p1 tree subtree t,
    tree_names_distinct tree ->
    find_subtree p0 tree = Some subtree ->
    update_subtree (p0 ++ p1) t tree = update_subtree p0 (update_subtree p1 t subtree) tree.
  Proof.
    induction p0; simpl; intros.
    congruence.
    destruct tree; try congruence.
    f_equal.
    induction l; simpl in *; intros; try congruence.
    destruct a0; simpl in *.
    destruct (string_dec s a); subst; eauto.
    - erewrite IHp0; eauto.
      f_equal.
      repeat rewrite update_subtree_notfound; eauto.
      inversion H; inversion H4; eauto.
      inversion H; inversion H4; eauto.
    - f_equal.
      eapply IHl; eauto.
  Qed.

  Lemma find_subtree_dir_after_update_subtree : forall base pn t num ents subtree,
    tree_names_distinct t ->
    find_subtree pn t = Some (TreeDir num ents) ->
    ~ (exists suffix : list string, pn = base ++ suffix) ->
    exists ents,
    find_subtree pn (update_subtree base subtree t) = Some (TreeDir num ents).
  Proof.
    induction base; intros.
    - simpl in *.
      contradiction H1; eauto.
    - destruct pn; simpl in *.
      + destruct t; try congruence.
        inversion H0; subst. eauto.
      + destruct t; simpl in *; try congruence.
        induction l; simpl in *; eauto.
        destruct a0. simpl in *.
        destruct (string_dec s0 s); destruct (string_dec s0 a); repeat subst; simpl in *.
        * destruct (string_dec a a); subst; try congruence.
          eapply IHbase; eauto.
          intro. deex. eauto.
        * destruct (string_dec s s); try congruence; eauto.
        * destruct (string_dec a s); try congruence; eauto.
        * destruct (string_dec s0 s); try congruence; eauto.
  Qed.

  Lemma find_subtree_none_after_update_subtree : forall base pn t subtree,
    tree_names_distinct t ->
    find_subtree pn t = None ->
    ~ (exists suffix : list string, pn = base ++ suffix) ->
    find_subtree pn (update_subtree base subtree t) = None.
  Proof.
    induction base; intros.
    - simpl in *.
      contradiction H1; eauto.
    - destruct pn; simpl in *.
      + destruct t; try congruence.
      + destruct t; simpl in *; try congruence.
        induction l; simpl in *; eauto.
        destruct a0. simpl in *.
        destruct (string_dec s0 s); destruct (string_dec s0 a); repeat subst; simpl in *.
        * destruct (string_dec a a); subst; try congruence.
          eapply IHbase; eauto.
          intro. deex. eauto.
        * destruct (string_dec s s); try congruence; eauto.
        * destruct (string_dec a s); try congruence; eauto.
        * destruct (string_dec s0 s); try congruence; eauto.
  Qed.

  Lemma find_subtree_tree_names_distinct: forall pn t subtree,
      tree_names_distinct t ->
      find_subtree pn t = Some subtree ->
      tree_names_distinct subtree.
  Proof.
    induction pn; intros; simpl in *.
    - congruence.
    - destruct t; try congruence.
      induction l.
      -- simpl in *; try congruence.
      -- destruct a0; subst; simpl in *.
        destruct (string_dec s a); subst; simpl in *.
        + eapply IHpn. 2: eauto.
          eapply tree_names_distinct_child; eauto.
        + eapply IHl; eauto.
  Qed.

  Lemma find_subtree_before_prune_general : forall pn t num ents base name subtree,
    tree_names_distinct t ->
    find_subtree base t = Some (TreeDir num ents) ->
    find_subtree pn (tree_prune num ents base name t) = Some subtree ->
    exists subtree',
      find_subtree pn t = Some subtree' /\
      dirtree_inum subtree = dirtree_inum subtree' /\
      dirtree_isdir subtree = dirtree_isdir subtree'.
  Proof.
    unfold tree_prune; intros.
    destruct (pathname_decide_prefix base pn).
    - deex.
      erewrite find_subtree_app in H1; eauto.
      cut (exists subtree',
                find_subtree (suffix) (TreeDir num ents) = Some subtree' /\
                dirtree_inum subtree = dirtree_inum subtree' /\
                dirtree_isdir subtree = dirtree_isdir subtree').
      intros.
      deex.
      eexists.
      erewrite find_subtree_app; eauto.
      eapply find_subtree_tree_names_distinct in H; eauto.
      clear H0.
      destruct suffix; simpl in *.
      + inversion H1; subst.
        eauto.
      +
        induction ents; simpl in *.
        * destruct suffix; simpl in *.
          inversion H1; subst.
          eexists; eauto.
        * destruct a; simpl in *.
          destruct (string_dec s0 name); subst.
          ** rewrite H1; simpl.
             destruct (string_dec name s); subst; try congruence.
             eapply dirtree_name_in_dents in H1; eauto.
             inversion H.
             inversion H4; eauto.
             exfalso; eauto.
             eauto.
          ** simpl in *.
             destruct (string_dec s0 s); subst; eauto.
    - clear H0.
      generalize dependent (delete_from_dir name (TreeDir num ents)).
      generalize dependent pn.
      generalize dependent t.
      induction base; intros.
      + simpl in *.
        contradiction H2.
        eauto.
      + destruct pn.
        ++ simpl in *.
            destruct t.
            inversion H1; subst; eauto.
            inversion H1; subst; eauto.
        ++ destruct t; simpl in *; try congruence.
           induction l.
           * simpl in *; try congruence.
           * destruct a0. simpl in *.
             destruct (string_dec s0 s); destruct (string_dec s0 a); repeat subst; simpl in *.
             -- destruct (string_dec s s); subst; try congruence.
                eapply IHbase; eauto.
                intro. deex.
                apply H2. subst. eexists.
                eauto.
             -- destruct (string_dec s s); try congruence; eauto.
             -- destruct (string_dec a s); try congruence; eauto.
             -- destruct (string_dec s0 s); try congruence; eauto.
  Qed.

  Lemma find_subtree_before_prune : forall pn t num ents base name dnum0 ents0,
    tree_names_distinct t ->
    find_subtree base t = Some (TreeDir num ents) ->
    find_subtree pn (tree_prune num ents base name t) = Some (TreeDir dnum0 ents0) ->
    exists ents1,
    find_subtree pn t = Some (TreeDir dnum0 ents1).
  Proof.
    intros.
    edestruct find_subtree_before_prune_general; eauto.
    intuition.
    destruct x; simpl in *; try congruence; subst.
    eexists; eauto.
  Qed.

  Lemma find_subtree_pruned_none : forall tree base name basenum basedents,
    tree_names_distinct tree ->
    find_subtree base tree = Some (TreeDir basenum basedents) ->
    find_subtree (base ++ [name]) (tree_prune basenum basedents base name tree) = None.
  Proof.
    intros.
    unfold tree_prune.
    erewrite find_subtree_app.
    2: erewrite find_update_subtree; eauto.
    simpl.
    eapply find_subtree_tree_names_distinct in H0; eauto.
    inversion H0; clear H0; subst.
    clear H3.
    induction basedents; simpl in *; eauto.
    destruct a.
    destruct (string_dec s name); subst.
    - rewrite find_subtree_ents_not_in; eauto.
      inversion H4; eauto.
    - simpl.
      destruct (string_dec s name); try congruence.
      eapply IHbasedents.
      inversion H4; eauto.
  Qed.

  Lemma update_name_twice: forall tree_elem name tree subtree subtree' dnum,
    tree_names_distinct
      (update_subtree ([name]) subtree'
         (update_subtree [] (add_to_dir name subtree (TreeDir dnum tree_elem))
            tree)) ->
    update_subtree [name] subtree' (update_subtree [] (add_to_dir name subtree (TreeDir dnum tree_elem)) tree) =
    update_subtree [] (add_to_dir name subtree' (TreeDir dnum tree_elem)) tree.
  Proof.
    induction tree_elem; intros; subst; simpl.
    - destruct (string_dec name name).
      reflexivity.
      congruence.
    - destruct a.
      destruct (string_dec s name); subst; simpl in *.
      destruct (string_dec name name); try congruence.
      rewrite update_subtree_notfound.
      reflexivity.
      erewrite <- tree_names_distinct_head_name'.
      eapply tree_names_distinct_head_name.
      simpl in H.
      destruct (string_dec name name); try congruence.
      apply H.
      destruct (string_dec s name); try congruence.
      simpl in H.
      apply tree_name_distinct_rest in H.
      specialize (IHtree_elem name d subtree subtree' dnum H).
      inversion IHtree_elem.
      rewrite H1.
      reflexivity.
  Qed.

  (* Rewrite using the tree induction principle doesn't really work out *)
  Lemma update_update_subtree_twice: forall prefix name subtree' subtree d dnum tree_elem,
    tree_names_distinct
       (update_subtree (prefix ++ [name]) subtree'
          (update_subtree prefix
             (add_to_dir name subtree (TreeDir dnum tree_elem)) d)) ->
    update_subtree (prefix ++ [name]) subtree'
       (update_subtree prefix (add_to_dir name subtree (TreeDir dnum tree_elem)) d) =
        update_subtree prefix (add_to_dir name subtree' (TreeDir dnum tree_elem)) d.
  Proof.
   induction prefix; intros.
   - rewrite app_nil_l.
     rewrite update_name_twice by auto.
     reflexivity.
   - destruct d.
     simpl.
     reflexivity.
     induction l; subst; simpl.
     + reflexivity.
     + destruct a0.
      simpl in *.
      destruct (string_dec s a).
      simpl in *.
      destruct (string_dec s a).
      subst; simpl in *.
      erewrite IHprefix.
      apply tree_name_distinct_rest in H.
      specialize (IHl H).
      inversion IHl.
      rewrite H1.
      eauto.
      eapply tree_name_distinct_head.
      eauto.
      exfalso.
      congruence.
      simpl in *.
      destruct (string_dec s a).
      exfalso.
      congruence.
      simpl in *.
      apply tree_name_distinct_rest in H.
      specialize (IHl H).
      inversion IHl.
      rewrite H1.
      eauto.
  Qed.

 Theorem update_subtree_tree_graft:
    forall prefix name tree dnum tree_elem subtree subtree' F Ftop m fsxp ilist frees ms sm,
    (F * rep fsxp Ftop (update_subtree (prefix++[name]) subtree'
                        (tree_graft dnum tree_elem prefix name subtree tree)) ilist frees ms sm)%pred m ->
    find_subtree prefix tree = Some (TreeDir dnum tree_elem) ->
    update_subtree (prefix++[name]) subtree' (tree_graft dnum tree_elem prefix name subtree tree) =
            (tree_graft dnum tree_elem prefix name subtree' tree).
  Proof.
    intros.
    unfold tree_graft in *.
    erewrite update_update_subtree_twice with (dnum := dnum) (tree_elem := tree_elem).
    reflexivity.
    eapply rep_tree_names_distinct.
    eauto.
  Qed.


From Coq Require Import Lists.List.
From Coq Require Import Arith.Arith.
From Coq Require Import Lia.
From Coq Require Strings.String.

From Elo Require Import Util.
From Elo Require Import Array.
From Elo Require Import Map.
From Elo Require Import Core.
From Elo Require Import ValidAddresses.
From Elo Require Import Access.
From Elo Require Import References.

(* ------------------------------------------------------------------------- *)
(* memtyp preservation                                                       *)
(* ------------------------------------------------------------------------- *)

Reserved Notation " m 'extends' m' " (at level 20, no associativity).

(* array extension for memory types *)
Inductive extension : mem -> mem -> Prop :=
  | extension_nil : forall m,
    m extends nil

  | extension_cons : forall m m' v v' Tr,
    m extends m' ->
    ((v, Tr) :: m) extends ((v', Tr) :: m')

  where " m 'extends' m' " := (extension m m').

Module Extension.
  Ltac nil_false :=
    match goal with
    F : nil extends (_ :: _) |- _ => inversion F
    end.

  Lemma refl : forall m,
    m extends m.
  Proof.
    intros. induction m; eauto using extension.
    match goal with |- (?vTr :: _) extends _ => destruct vTr end.
    eauto using extension.
  Qed.

  Lemma trans : forall m m' m'',
    m  extends m'  ->
    m' extends m'' ->
    m  extends m''.
  Proof.
    intros * Hext ?. generalize dependent m''.
    induction Hext; intros; destruct m''; eauto using extension; try nil_false.
    match goal with
    | H : (_ :: _) extends (_ :: _) |- _ => inversion H; subst
    end.
    eauto using extension.
  Qed.

  Lemma add : forall m vTr,
    (m +++ vTr) extends m.
  Proof.
    intros. induction m; unfold add; eauto using extension. simpl in *.
    match goal with |- (?vTr :: _) extends _ => destruct vTr end.
    eauto using extension.
  Qed.

  Lemma get : forall m m' ad,
    ad < #m' ->
    m extends m' ->
    m[ad].typ = m'[ad].typ.
  Proof.
    intros * Hlen Hext. generalize dependent ad. generalize dependent m.
    induction m'; intros; try solve [inversion Hlen].
    destruct m; try nil_false. inversion_subst_clear Hext.
    destruct ad; simpl; eauto using lt_S_n.
  Qed.

  Lemma set : forall m ad v Tr,
    m[ad].typ = Tr ->
    m[ad <- (v, Tr)] extends m.
  Proof.
    intros * Heq. generalize dependent ad. induction m; intros; simpl in *;
    eauto using extension. simpl in *. destruct ad;
    match goal with |- _ extends (?vTr :: _) => destruct vTr end;
    simpl in *; subst; eauto using refl, extension.
  Qed.
End Extension.

Local Lemma mstep_memtyp_preservation : forall m m' t t' eff,
  well_typed_references m t ->
  m / t ==[eff]==> m' / t' ->
  m' extends m.
Proof.
  intros. inversion_clear_mstep; eauto using Extension.refl, Extension.add.
  eapply Extension.set. induction_step; intros; inversion_wtr; eauto.
  inversion_wtr; eauto.
Qed.

Corollary cstep_memtyp_preservation : forall m m' ths ths' tid eff,
  forall_threads ths (well_typed_references m) ->
  m / ths ~~[tid, eff]~~> m' / ths' ->
  m' extends m.
Proof.
  intros. inversion_cstep;
  eauto using Extension.refl, mstep_memtyp_preservation.
Qed.

(* TODO *)
Corollary cstep_memtyp : forall m m' ths ths' tid eff ad,
  forall_threads ths (well_typed_references m) ->
  m / ths ~~[tid, eff]~~> m' / ths' ->
  ad < #m ->
  m'[ad].typ = m[ad].typ.
Proof.
  intros. assert (m' extends m) by eauto using cstep_memtyp_preservation.
  eapply Extension.get; eauto.
Qed.

(* ------------------------------------------------------------------------- *)
(*                                                                           *)
(* ------------------------------------------------------------------------- *)

Local Lemma safe_preserves_inclusion : forall Gamma Gamma',
  Gamma includes Gamma' ->
  (safe Gamma) includes (safe Gamma').
Proof.
  unfold inclusion, safe. intros * H *.
  destruct (Gamma k) eqn:E1; destruct (Gamma' k) eqn:E2;
  solve [ intros F; inversion F
        | eapply H in E2; rewrite E1 in E2; inversion E2; subst; trivial
        ].
Qed.

Local Lemma update_safe_includes_safe_update : forall Gamma k T,
  (safe Gamma)[k <== T] includes (safe Gamma[k <== T]).
Proof.
  intros ? ? ? k' ? H. unfold safe in H.
  destruct (String.string_dec k k'); subst.
  - rewrite lookup_update_eq in *. destruct T; inversion H; subst; trivial.
  - rewrite lookup_update_neq in *; trivial.
Qed.

Local Lemma context_weakening : forall Gamma Gamma' t T,
  Gamma' |-- t is T ->
  Gamma includes Gamma' ->
  Gamma  |-- t is T.
Proof.
  intros. generalize dependent Gamma.
  induction_type; intros;
  eauto using well_typed_term, safe_preserves_inclusion,
    MapInclusion.update_inclusion.
Qed.

Local Lemma context_weakening_empty : forall Gamma t T,
  empty |-- t is T ->
  Gamma |-- t is T.
Proof.
  intros. eapply (context_weakening _ empty); trivial. discriminate.
Qed.

Local Lemma subst_type_preservation : forall t tx T Tx Tx' Gamma x,
  Gamma |-- <{ fn x Tx --> t }> is <{{  Tx' --> T }}> ->
  empty |-- tx is Tx' ->
  Gamma |-- [x := tx] t is T.
Proof.
  assert (forall t tx T Tx Gamma x,
    Gamma[x <== Tx] |-- t is T ->
    empty |-- tx is Tx ->
    Gamma |-- ([x := tx] t) is T
  ). {
    unfold subst. intros ?.
    induction t; intros * Htype ?;
    try (destruct String.string_dec); try inversion_type;
    eauto using well_typed_term, context_weakening, context_weakening_empty,
      MapInclusion.update_overwrite, MapInclusion.update_permutation,
      update_safe_includes_safe_update;
    match goal with
    | H : _[_ <== _] _ = _ |- _ =>
      try (erewrite lookup_update_eq in H || erewrite lookup_update_neq in H);
      inversion H; subst;
      eauto using context_weakening_empty, well_typed_term
    end.
  }
  intros * ?. inversion_type. intros. eauto.
Qed.

(* ------------------------------------------------------------------------- *)
(* term preservation                                                         *)
(* ------------------------------------------------------------------------- *)

Local Lemma step_read_type_preservation : forall m t t' ad T,
  well_typed_references m t ->
  empty |-- t is T ->
  t --[EF_Read ad m[ad].tm]--> t' ->
  empty |-- t' is T.
Proof.
  intros. remember empty as Gamma. generalize dependent t'.
  induction_type; intros; inversion_wtr; inversion_step;
  eauto using well_typed_term, subst_type_preservation;
  inversion_type; inversion_wtr; trivial;
  eauto using context_weakening_empty.
Qed.

Local Lemma mstep_type_preservation : forall m m' t t' eff T,
  well_typed_references m t ->
  empty |-- t is T ->
  m / t ==[eff]==> m' / t' ->
  empty |-- t' is T.
Proof.
  intros. inversion_clear_mstep; generalize dependent t';
  remember empty as Gamma;
  induction_type; intros; inversion_step; inversion_wtr;
  eauto using well_typed_term, subst_type_preservation;
  inversion_type; inversion_wtr;
  eauto using context_weakening_empty.
Qed.

(* ------------------------------------------------------------------------- *)
(* memory preservation                                                       *)
(* ------------------------------------------------------------------------- *)

Local Lemma mstep_mem_type_preservation : forall m m' t t' eff ad T M,
  well_typed_references m t ->
  ad < length m ->
  empty |-- t is T ->
  empty |-- m[ad].tm is M ->
  m / t ==[eff]==> m' / t' ->
  empty |-- m'[ad].tm is M.
Proof.
  intros * ? ? Htype ? ?. rename ad into ad'.
  inversion_clear_mstep; try simpl_array; trivial.
  decompose sum (lt_eq_lt_dec ad' ad); subst; simpl_array; trivial.
  generalize dependent t'. remember empty as Gamma.
  induction Htype; inversion HeqGamma; subst; intros;
  inversion_wtr; inversion_step; eauto.
  inversion_type; inversion_wtr; apply_deterministic_typing. eauto.
Qed.

(*
Ltac solve_with_steps :=
  eexists; eexists; eexists; eauto using step, mstep.

Ltac destruct_IH :=
  match goal with
  | IH : valid_accesses _ _ -> value _ \/ _ |- _ =>
    destruct IH as [? | [[eff [? [? ?]]] | [? [? ?]]]]; trivial
  end.

Ltac solve_mstep_progress :=
  match goal with
  | eff : effect |- _ =>
    try solve [solve_with_steps];
    destruct eff; inversion_mstep; try solve [solve_with_steps]
  end.

Theorem progress : forall m t T,
  valid_accesses m t ->
  empty |-- t is T ->
  (value t
    \/ (exists eff m' t', m / t ==[eff]==> m' / t')
    \/ (exists block t', t --[EF_Spawn block]--> t')).
Proof.
  intros. induction_type; try inversion_va;
  try solve [left; eauto using value]; right;
  try solve [right; eauto using step];
  try solve [left; solve_mstep_progress].
  - destruct_IH.
    + left. solve_with_steps.
    + left. destruct eff; inversion_mstep; solve_with_steps.
    + right. eauto using step.
  - destruct_IH.
    + left. solve_with_steps.
    + left. destruct eff; inversion_mstep; solve_with_steps.
    + right. eauto using step.
  - destruct_IH.
    + left. inversion H1; subst; inversion_type.
      eexists. eexists. eexists. eauto using step, mstep, access.
    + left. destruct eff; inversion_mstep; solve_with_steps.
    + right. eauto using step.
  - destruct_IH.
    + left. inversion H1; subst; inversion_type.
      eexists. eexists. eexists. eauto using step, mstep, access.
    + left. destruct eff; inversion_mstep; solve_with_steps.
    + right. eauto using step.
  - shelve.
  - shelve.
  - shelve.
Qed.
*)


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import PSCIAux2.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition psci_affinity_info_spec (rec: Pointer) (target_affinity: Z64) (lowest_affinity_level: Z64) (adt: RData) : option RData :=
    match target_affinity, lowest_affinity_level with
    | VZ64 target, VZ64 lowest =>
      rely is_int64 target; rely is_int64 lowest;
      if lowest =? 0 then
        when'' target_base, target_offset, adt == psci_lookup_target_spec rec (VZ64 target) adt;
        rely is_int target_offset;
        if ptr_eq (target_base, target_offset) NULL then
          Some adt {priv: (priv adt) {psci_x0: PSCI_RETURN_INVALID_PARAMS}}
        else
          rely (peq target_base ginfo_loc);
          let gidx := target_offset in
          rely is_gidx gidx;
          rely prop_dec ((buffer (priv adt)) @ SLOT_REC_TARGET = None);
          let gn := (gs (share adt)) @ gidx in
          rely g_tag (ginfo gn) =? GRANULE_STATE_REC;
          rely prop_dec (glock gn = Some CPU_ID);
          let e := EVT CPU_ID (REL gidx gn) in
          rely (gtype gn =? g_tag (ginfo gn));
          rely is_int (g_runnable (gnorm gn));
          if g_runnable (gnorm gn) =? 1 then
            Some adt {log: e :: log adt} {priv: (priv adt) {psci_x0: 0}}
                 {share: (share adt) {gs: (gs (share adt)) # gidx == (gn {glock: None})}}
          else
            Some adt {log: e :: log adt} {priv: (priv adt) {psci_x0: 1}}
                 {share: (share adt) {gs: (gs (share adt)) # gidx == (gn {glock: None})}}
      else
        Some adt {priv: (priv adt) {psci_x0: PSCI_RETURN_INVALID_PARAMS}}
    end.

End Spec.


(**  We develop a deep embedding of a crowdfunding contract and prove some of its functional correctness properties using the corresponding shallow embedding *)

Require Import String ZArith Basics.
From ConCert.Embedding Require Import Ast Notations CustomTactics
     PCUICTranslate PCUICtoTemplate Utils.

From ConCert.Embedding.Examples Require Import Prelude SimpleBlockchain CrowdfundingData.

Require Import List PeanoNat ssrbool.

Import ListNotations.
From MetaCoq.Template Require Import All.

Import MonadNotation.
Import BaseTypes.
Open Scope list.

Import Lia.

(** Note that we define the deep embedding (abstract syntax trees) of the data structures and programs using notations. These notations are defined in  [Ast.v] and make use of the "custom entries" feature. *)

(** Brackets like [[\ \]] delimit the scope of data type definitions and like [[| |]] the scope of programs *)

(** * The crowdfunding contract *)

Module CrowdfundingContract.

  Import AcornBlockchain.

  (** ** AST of the [init] function *)
  Module Init.
    Import Notations.
    Definition crowdfunding_init : expr :=
      [| \c : SCtx => \dl : Nat => \g : Money => mkState 0z MNil dl (ctx_from c) False g |].

    Make Definition init :=
      (expr_to_tc Σ' (indexify nil crowdfunding_init)).

    Check init.
 End Init.

 (** ** AST of the [receive] function *)
 Module Receive.
   Import Notations.

   (** We specialise some polymorphic constructors to avoid writing types all the time *)
   Notation "'#Just' a" := [| {eConstr "option" "Some"}  {eTy [! Result!]} {a}|]
                           (in custom expr at level 0,
                               a custom expr at level 1).

   Notation "'#Pair' a b" := [| {eConstr "prod" "pair"}
                               {eTy (tyInd State)}
                               {eTy actions_ty} {a} {b} |]
                           (in custom expr at level 0,
                               a custom expr at level 1,
                               b custom expr at level 1).

   Notation "'#Nothing'" := (eApp (eConstr "option" "None") (eTy [!Result!]))
                             (in custom expr at level 0).

   Notation SCtx := "SimpleContractCallContext".
   Notation SChain := "SimpleChain".

   Definition crowdfunding : expr :=
    [| \chain : SChain =>  \c : SCtx => \m : Msg => \s : State =>
         let bal : Money := balance s in
         let now : Nat := cur_time chain in
         let tx_amount : Money := amount c in
         let sender : Address := ctx_from c in
         let own : Address := owner s in
         let accs : Map := donations s in
         case m : Msg return Maybe Result of
            | GetFunds ->
             if (own == sender) && (deadline s <n now) && (goal s <= bal)  then
               #Just (#Pair (mkState 0z accs own (deadline s) True (goal s))
                          [Transfer bal sender])
             else #Nothing : Maybe Result
           | Donate -> if now <=n deadline s then
             (case (mfind accs sender) : Maybe Money return Maybe Result of
               | Just v ->
                 let newmap : Map := madd sender (v + tx_amount) accs in
                 #Just (#Pair (mkState (tx_amount + bal) newmap own (deadline s) (done s) (goal s))
                            Nil)
               | Nothing ->
                 let newmap : Map := madd sender tx_amount accs in
                 #Just (#Pair (mkState (tx_amount + bal) newmap own (deadline s) (done s) (goal s))
                            Nil))
               else #Nothing : Maybe Result
           | Claim ->
             if (deadline s <n now) && (bal < goal s) && (~ done s) then
             (case (mfind accs sender) : Maybe Money return Maybe Result of
              | Just v -> let newmap : Map := madd sender 0z accs in
                  #Just (#Pair (mkState (bal-v) newmap own (deadline s) (done s) (goal s))
                       [Transfer v sender])
               | Nothing -> #Nothing)
              else #Nothing : Maybe Result
    |].

  Compute (expr_to_tc Σ' (indexify nil crowdfunding)).

  Make Definition receive :=
    (expr_to_tc Σ' (indexify nil crowdfunding)).
  Check receive.
  End Receive.
End CrowdfundingContract.

Import CrowdfundingContract.

(** * Properties of the crowdfunding contract *)

Module CrowdfundingProperties.
  Import AcornBlockchain.
    Ltac inv_andb H := apply Bool.andb_true_iff in H;destruct H.
  Ltac split_andb := apply Bool.andb_true_iff;split.

  Open Scope nat.
  Open Scope bool.

  Import Lia.

  Definition deadline_passed now (s : State_coq) := s.(deadline_coq) <? now.

  Definition goal_reached (s : State_coq) := (s.(goal_coq) <=? s.(balance_coq))%Z.

  Definition funded now (s : State_coq) :=
    deadline_passed now s && goal_reached s.

  Lemma not_leb n m : ~~ (n <=? m) -> m <? n.
  Proof.
   intros.
   unfold Nat.ltb in *.
   unfold is_true in *. rewrite Bool.negb_true_iff in *.
   rewrite Nat.leb_gt in *. rewrite Nat.leb_le in *. lia.
  Qed.

  Lemma not_ltb n m : ~~ (n <? m) -> m <=? n.
  Proof.
   intros.
   unfold Nat.ltb in *.
   unfold is_true in *. rewrite Bool.negb_true_iff in *.
   rewrite Nat.leb_gt in *. rewrite Nat.leb_le in *. lia.
  Qed.

  Lemma Znot_leb n m : ~~ (n <=? m)%Z -> (m <? n)%Z.
  Proof.
   intros.
   unfold is_true in *. rewrite Bool.negb_true_iff in *.
   rewrite Z.leb_gt in *. now rewrite Z.ltb_lt in *.
  Qed.

  Lemma Znot_ltb n m : ~~ (n <? m)%Z -> (m <=? n)%Z.
  Proof.
   intros.
   unfold is_true in *. rewrite Bool.negb_true_iff in *.
   rewrite Z.ltb_nlt in *. rewrite Z.leb_le in *. lia.
  Qed.

  (** This lemma states that the only relevant part of the blockchain state is the current slot, because we check if the deadline have passed by comparing the deadline recoded in the internal state with the current slot number.*)
  Lemma receive_blockchain_state height1 height2 cur_slot fheight1 fheight2 bal1 bal2 msg st ctx :
    Receive.receive (Build_chain height1 cur_slot fheight1 bal1) ctx msg st  =
    Receive.receive (Build_chain height2 cur_slot fheight2 bal2) ctx msg st.
  Proof.
    destruct msg;
      simpl;
      (match goal with
       | [ |- context[(if ?x then _ else _ )] ] => destruct x eqn:Hx
       end);eauto.
  Qed.

  (** This function is a simplistic execution environment that performs one step of execution *)
  Definition run (receive : State_coq -> option (State_coq * list SimpleActionBody) ) (init : State_coq)
    : State_coq * list SimpleActionBody :=
    match receive init with
    | Some (fin, out) => (fin, out)
    | None => (init, []) (* if an error occurs, the state remains the same *)
    end.

  (** A wrapper for the assertions about the contract execution *)
  Definition assertion (pre : State_coq -> Prop)
             (entry : State_coq -> option (State_coq * list SimpleActionBody))
             (post : State_coq -> list SimpleActionBody -> Prop) :=
    forall init, pre init -> exists fin out, run entry init = (fin, out) /\ post fin out.

  Notation "{{ P }} c {{ Q }}" := (assertion P c Q)( at level 50).

  (** The donations can be paid back to the backers if the goal is not
reached within a deadline *)

  Lemma get_money_back_guarantee CallCtx BC (sender := CallCtx.(Ctx_from)) v :
      (* pre-condition *)
      {{ fun init =>
         deadline_passed BC.(Current_slot) init
       /\ ~~ (goal_reached init)
       /\ ~~ init.(done_coq)
       /\ lookup_map init.(donations_coq) sender = Some v }}

        (* contract call *)
       Receive.receive BC CallCtx Claim_coq

       (* post-condition *)
       {{fun fin out => lookup_map fin.(donations_coq) sender = Some 0%Z
         /\ In (Act_transfer sender v) out}}.
  Proof.
    unfold assertion. intros init H. simpl.
    destruct H as [Hdl [Hgoal [Hndone Hlook]]].
    unfold deadline_passed,goal_reached in *;simpl in *.
    repeat eexists. unfold run. simpl.
    assert (balance_coq init <? goal_coq init = true)%Z by now apply Znot_leb.
    repeat destruct (_ <? _)%Z;tryfalse. destruct (_ <? _);tryfalse.
    destruct (~~ done_coq _)%bool;tryfalse.
    destruct (lookup_map _ _);tryfalse;inversion Hlook;subst;clear Hlook.
    repeat split;cbn. apply lookup_map_add. now constructor.
  Qed.

  (** New donations are recorded correctly in the contract's state *)

  Lemma new_donation_correct CallCtx BC (sender := CallCtx.(Ctx_from))
        (donation := CallCtx.(Ctx_amount)) :

    {{ fun init =>
          sender ∉ init.(donations_coq) (* the sender have not donated before *)
       /\ ~~ deadline_passed BC.(Current_slot) init }}

      (* contract call *)
    Receive.receive BC CallCtx Donate_coq

    {{ fun fin out =>
         (* nothing gets transferred *)
         out = []
         (* donation has been accepted *)
         /\ lookup_map fin.(donations_coq) sender = Some donation  }}.
  Proof.
    unfold assertion. intros init H. simpl.
    destruct H as [Hnew_sender Hdl].
    unfold deadline_passed in *;simpl in *.
    unfold run.
    repeat eexists.
    simpl in *. apply not_ltb in Hdl.
    destruct (_ <=? _);tryfalse.
    unfold inmap_map in *.
    destruct (lookup_map _ _);tryfalse.
    repeat split;eauto. simpl. now rewrite lookup_map_add.
  Qed.

  (** Existing donations are updated correctly in the contract's state *)

  Lemma existing_donation_correct BC CallCtx (sender := CallCtx.(Ctx_from))
        (new_don := CallCtx.(Ctx_amount)) old_don :
    {{ fun init =>
         (* the sender has already donated before *)
         lookup_map init.(donations_coq) sender = Some old_don

       /\ ~~ deadline_passed BC.(Current_slot) init }}

     Receive.receive BC CallCtx Donate_coq

    {{ fun fin out =>
         (* nothing gets transferred *)
         out = []
         (* donation has been added *)
       /\ lookup_map fin.(donations_coq) sender = Some (old_don + new_don)%Z }}.
  Proof.
    unfold assertion. intros init H. simpl.
    subst sender new_don.
    destruct H as [Hsender Hdl].
    unfold deadline_passed in *;simpl in *.
    subst;simpl in *.
    eexists. eexists.
    unfold run. simpl in *. apply not_ltb in Hdl.
    destruct (_ <=? _);tryfalse.
    destruct (lookup_map _ _);tryfalse.
    inversion Hsender;subst.
    repeat split;simpl;eauto. now rewrite lookup_map_add.
  Qed.

  Fixpoint sum_map (m : addr_map) : Z :=
    match m with
    | mnil => 0
    | mcons _ v m' => v + sum_map m'
    end.

  Lemma all_non_neg_sum_map m :
    map_forallb (Z.leb 0) m ->
    (sum_map m >= 0)%Z.
  Proof.
    intros H.
    induction m.
    + simpl;lia.
    + simpl in *. inv_andb H.
      specialize (IHm H0). Zleb_ltb_to_prop. lia.
  Qed.

  Lemma sum_map_add_in m : forall n0 (v' v : Z) k,
      lookup_map m k = Some n0 ->
      sum_map m = v ->
      sum_map (add_map k (n0+v') m) = (v' + v)%Z.
  Proof.
    intros;subst.
    revert dependent n0. revert v' k.
    induction m;intros;subst.
    + inversion H.
    + simpl in *. destruct (k =? n) eqn:Hkn.
      * simpl in *. inversion H. subst. lia.
      * simpl in *. rewrite IHm;auto. lia.
  Qed.

  Lemma sum_map_add_not_in m : forall v' v k,
      lookup_map m k = None ->
      sum_map m = v ->
      sum_map (add_map k v' m) = (v' + v)%Z.
  Proof.
    intros;subst.
    revert dependent k. revert v'.
    induction m;intros;subst.
    + reflexivity.
    + simpl in *. destruct (k =? n) eqn:Hkn.
      * inversion H.
      * simpl in *. rewrite IHm;auto. lia.
  Qed.

  Lemma sum_map_sub_in m k z v :
    lookup_map m k = Some z ->
    sum_map m = v ->
    sum_map (add_map k 0 m) = (v - z)%Z.
  Proof.
    intros;subst.
    revert dependent k. revert z.
    induction m;intros;subst;tryfalse.
    simpl in *. destruct (k =? n) eqn:Hkn.
    + inversion H;subst.
      simpl in *. lia.
    + simpl. now erewrite IHm;eauto.
  Qed.

  (** The contract does no leak funds: the overall balance before the deadline is always equal to the sum of individual donations *)

  Definition consistent_balance_deadline current_slot state :=
    ~~ deadline_passed current_slot state ->
  sum_map (donations_coq state) = balance_coq state.

  (** This lemma holds for any message  *)
  Lemma contract_backed BC CallCtx msg :

    {{ consistent_balance_deadline (Current_slot BC) }}

      Receive.receive BC CallCtx msg

    {{ fun fin _ => consistent_balance_deadline (Current_slot BC) fin }}.
  Proof.
    intros init H.
    (* destruct H as [Hdl Hsum]. *)
    destruct msg.
    + (* Donate *)
      simpl in *.
      (* specialize Hdl as Hdl'. *)
      unfold consistent_balance_deadline,deadline_passed in H.
      unfold run,consistent_balance_deadline.
      (* apply not_ltb in Hdl.  simpl. *)
      simpl.
      destruct (_ <=? _);tryfalse.
      * destruct (lookup_map _ _) eqn:Hlook.
        ** repeat eexists;intro Hdl;eauto. now apply sum_map_add_in.
        ** repeat eexists;intro Hdl;eauto. now apply sum_map_add_not_in.
      * repeat eexists;intro Hdl;eauto.
    + (* GetFunds *)
      unfold consistent_balance_deadline in *.
      unfold deadline_passed in *.
      unfold run. simpl.
      destruct (deadline_coq init <? Current_slot BC) eqn:Hdl.
      **  (* it is not possible to get funds before the deadline, so the state is not modified *)
         (match goal with
          | [ |- context[(if ?x then _ else _ )] ] => destruct x eqn:Hx
          end);eauto; repeat eexists; simpl in *; intros;
           destruct (_ <? _);tryfalse.
      ** destruct (_ <? _);tryfalse. rewrite Bool.andb_false_r. simpl.
         repeat eexists;eauto.
    + (* Claim *)
      unfold consistent_balance_deadline in *.
      unfold deadline_passed in *.
      unfold run. simpl.
      destruct (deadline_coq init <? Current_slot BC) eqn:Hdl.
      **  (* it is not possible to get funds before the deadline, so the state is not modified *)
         (match goal with
          | [ |- context[(if ?x then _ else _ )] ] => destruct x eqn:Hx
          end);
          simpl in *;try destruct (lookup_map _ _);repeat eexists;eauto; intros;destruct (_ <? _);tryfalse.
      ** destruct (_ <? _);tryfalse. rewrite Bool.andb_false_l. simpl.
         repeat eexists;eauto.
  Qed.

  Definition consistent_balance state :=
    ~~ state.(done_coq) ->
  sum_map (donations_coq state) = balance_coq state.

  (** This lemma holds for any message  *)
  Lemma contract_state_consistent BC CallCtx msg :
    {{ consistent_balance }}

      Receive.receive BC CallCtx msg

    {{ fun fin _ => consistent_balance fin }}.
  Proof.
        intros init H.
    (* destruct H as [Hdl Hsum]. *)
    destruct msg.
    + (* Donate *)
      simpl in *.
      (* specialize Hdl as Hdl'. *)
      unfold consistent_balance,deadline_passed in H.
      unfold run,consistent_balance.
      (* apply not_ltb in Hdl.  simpl. *)
      simpl.
      destruct (_ <=? _);tryfalse.
      * destruct (lookup_map _ _) eqn:Hlook.
        ** repeat eexists;intro Hdl;eauto. now apply sum_map_add_in.
        ** repeat eexists;intro Hdl;eauto. now apply sum_map_add_not_in.
      * repeat eexists;intro Hdl;eauto.
    + (* GetFunds *)
      unfold consistent_balance in *.
      unfold run. simpl.
         (match goal with
          | [ |- context[(if ?x then _ else _ )] ] => destruct x eqn:Hx
          end);eauto; repeat eexists; simpl in *; intros;
           destruct (_ <? _);tryfalse.
    + (* Claim *)
      unfold consistent_balance in *.
      unfold deadline_passed in *.
      unfold run. simpl.
      destruct (done_coq _) eqn:Hdone.
      * rewrite Bool.andb_false_r. repeat eexists;eauto.
        intros. destruct (done_coq _);tryfalse.
      * (match goal with
         | [ |- context[(if ?x then _ else _ )] ] => destruct x eqn:Hx
         end);
          simpl in *;try destruct (lookup_map _ _) eqn:Hlook;repeat eexists;eauto; intros;destruct (_ <? _);tryfalse.
        cbn.  now apply sum_map_sub_in.
  Qed.

  Definition donations_non_neg init := map_forallb (Z.leb 0%Z) init.(donations_coq) = true.

  Lemma non_neg_add_in m : forall n0 (v' : Z) k,
      (0 <= v')%Z ->
      lookup_map m k = Some n0 ->
      map_forallb (Z.leb 0%Z) m ->
      map_forallb (Z.leb 0%Z) (add_map k (n0+v') m).
  Proof.
    intros;subst.
    revert dependent n0. revert k.
    induction m;intros k n0 Hlook;subst.
    + inversion Hlook.
    + simpl in *. destruct (k =? n) eqn:Hkn.
      * simpl in *. inversion Hlook.
        inv_andb H1. rewrite Nat.eqb_eq in *;subst.
        subst;split_andb;auto.
        Zleb_ltb_to_prop;lia.
      * simpl in *.
        inv_andb H1. Zleb_ltb_to_prop.
        split_andb;auto. now Zleb_ltb_to_prop.
        rewrite IHm;auto.
  Qed.

  Lemma non_neg_add_not_in m : forall (v' : Z) k,
      (0 <= v')%Z ->
      lookup_map m k = None ->
      map_forallb (Z.leb 0%Z) m ->
      map_forallb (Z.leb 0%Z) (add_map k v' m).
  Proof.
    induction m;intros ? ? Hnneg Hlook H;subst.
    + simpl in *. split_andb;now Zleb_ltb_to_prop.
    + simpl in *. destruct (k =? n) eqn:Hkn.
      * simpl in *.
        inv_andb H. rewrite Nat.eqb_eq in *;subst.
        subst;split_andb;auto.
        Zleb_ltb_to_prop;lia.
      * simpl in *.
        inv_andb H. Zleb_ltb_to_prop.
        split_andb;auto. now Zleb_ltb_to_prop.
        rewrite IHm;auto.
  Qed.

  Lemma non_neg_add_0 m k :
    map_forallb (Z.leb 0%Z) m ->
    map_forallb (Z.leb 0%Z) (add_map k 0 m).
  Proof.
    induction m;intros.
    + easy.
    + simpl in *. destruct (k =? n) eqn:Hkn.
      * simpl in *.
        now inv_andb H.
      * simpl in *.
        inv_andb H. Zleb_ltb_to_prop.
        split_andb;auto. now Zleb_ltb_to_prop.
        rewrite IHm;auto.
  Qed.

  (** All the entries in the table of contributions contain non-negative amounts  *)
  Lemma contract_state_donation_non_neg BC CallCtx msg :
    (0 <= CallCtx.(Ctx_amount))%Z ->

    {{ donations_non_neg }}

      Receive.receive BC CallCtx msg

    {{ fun fin _ => donations_non_neg fin }}.
  Proof.
    intros Hamount init H.
    destruct msg.
    + (* Donate *)
      simpl in *.
      (* specialize Hdl as Hdl'. *)
      unfold consistent_balance,deadline_passed in H.
      unfold run,consistent_balance.
      (* apply not_ltb in Hdl.  simpl. *)
      simpl.
      destruct (_ <=? _);tryfalse.
      * destruct (lookup_map _ _) eqn:Hlook.
        ** repeat eexists;eauto.
           assert (0 <=? z)%Z by now eapply map_forallb_lookup_map.
           unfold donations_non_neg. cbn.
           eapply non_neg_add_in;eauto.
        ** repeat eexists;eauto.
           unfold donations_non_neg. cbn.
           eapply non_neg_add_not_in;eauto.
      * repeat eexists;eauto.
    + (* GetFunds *)
      unfold donations_non_neg in *.
      unfold run. simpl.
         (match goal with
          | [ |- context[(if ?x then _ else _ )] ] => destruct x eqn:Hx
          end);eauto; repeat eexists; simpl in *; intros;
           destruct (_ <? _);tryfalse.
    + (* Claim *)
      unfold donations_non_neg in *.
      unfold run. simpl.
      (match goal with
         | [ |- context[(if ?x then _ else _ )] ] => destruct x eqn:Hx
       end);
        simpl in *;try destruct (lookup_map _ _) eqn:Hlook;repeat eexists;eauto.
      simpl. now apply non_neg_add_0.
  Qed.

  (** The owner gets the money after the deadline, if the goal is reached *)

  Lemma GetFunds_correct BC CallCtx (OwnerAddr := CallCtx.(Ctx_from)) (funds : Z) :
    {{ fun init => funded BC.(Current_slot) init
       /\ init.(owner_coq) =? OwnerAddr
       /\ balance_coq init = funds }}

    Receive.receive BC CallCtx GetFunds_coq

    {{ fun fin out =>
       (* the money are sent back *)
       In (Act_transfer OwnerAddr funds) out
       (* set balance to 0 after withdrawing by the owner *)
       /\  fin.(balance_coq) = 0%Z
       (* set the "done" flag *)
       /\ fin.(done_coq) = true}}.
  Proof.
    unfold assertion. intros init H. simpl.
    destruct H as [Hfunded [Hown Hbalance]]. unfold funded,goal_reached,deadline_passed in *.
    subst. simpl in *.
    unfold run. simpl in *. subst OwnerAddr. eexists. eexists.
    destruct (_ <? _);tryfalse. destruct ( _ =? _);tryfalse. simpl in *.
    destruct (_ <=? _)%Z;tryfalse. repeat split;eauto.
    now constructor.
  Qed.

  (** Backers cannot claim their money if the campaign have succeed (but owner haven't claimed the money yet, so the "done" flag is not set to [true]) *)
  Lemma no_claim_if_succeeded BC CallCtx the_state:
    {{ fun init =>
         funded BC.(Current_slot) init
         /\ ~~ init.(done_coq)
         /\ init = the_state }}

      Receive.receive BC CallCtx Claim_coq

    (* Nothing happens - the stated stays the same and no outgoing transfers *)
    {{ fun fin out => fin = the_state /\ out = [] }}.
  Proof.
    unfold assertion. intros init H. simpl.
    unfold funded,deadline_passed,goal_reached in *. subst. simpl in *.
    destruct H as [Hdl [Hgoal Hst]].
    inv_andb Hdl. subst. unfold run. simpl.
    exists the_state. eexists.
    destruct the_state as [i_balance i_dons i_own i_dl i_done i_goal].
    destruct CallCtx. simpl in *.

    destruct (_ <? _);tryfalse.
    replace (i_balance <? i_goal)%Z with false by
        (symmetry;rewrite Z.ltb_ge in *; rewrite Z.leb_le in *;lia).
    now simpl.
  Qed.

  (** Backers cannot claim their money if the contract is marked as "done" *)
  Lemma no_claim_after_done BC CallCtx the_state :
    {{ fun init => init.(done_coq) /\ init = the_state }}

     Receive.receive BC CallCtx Claim_coq
    (* Nothing happens - the stated stays the same and no outgoing transfers *)
    {{ fun fin out => fin = the_state /\ out = [] }}.
  Proof.
    unfold assertion. intros init H. simpl. destruct H. subst.
    unfold funded,deadline_passed,goal_reached in *. subst. simpl in *.
    exists the_state. eexists.
    unfold run. simpl in *. destruct (done_coq _);tryfalse. simpl in *.
    now rewrite Bool.andb_false_r.
  Qed.

End CrowdfundingProperties.


(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model Generate co's *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
(* Definition of co_locs already included in the prelude *)
(* Definition of cross already included in the prelude *)
Definition generate_orders s pco := cross (co_locs pco (partition s)).
Definition generate_cos pco := generate_orders W pco.
Definition cobase := co0.
Variable co : relation events.
Definition coi := co ⊓ int.
Definition coe := co ⊓ !coi.
Definition fr := rf° ⋅ co ⊓ !id.
Definition fri := fr ⊓ int.
Definition fre := fr ⊓ !fri.
Definition witness_conditions := generate_cos cobase co.
Definition model_conditions := True.
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW generate_orders generate_cos cobase coi coe fr fri fre witness_conditions model_conditions : cat.

Definition valid (c : candidate) :=
  exists co : relation (events c),
    witness_conditions c co /\
    True.

(* End of translation of model Generate co's *)


Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.LetIn.
Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Require Import Rewriter.Language.UnderLets.
Require Import Crypto.AbstractInterpretation.AbstractInterpretation.
Require Import Crypto.Rewriter.All.
Require Import Crypto.MiscCompilerPasses.
Require Import Crypto.Stringification.C.
Import ListNotations. Local Open Scope Z_scope.

Import Language.Compilers.
Import UnderLets.Compilers.
Import AbstractInterpretation.Compilers.
Import Rewriter.All.Compilers.
Import MiscCompilerPasses.Compilers.
Import Stringification.C.Compilers.
Import Language.API.Compilers.
Local Coercion Z.of_nat : nat >-> Z.
Import Compilers.API.

Local Notation "x + y"
  := ((#ident.Z_add @ x @ y)%expr)
     : expr_scope.
Local Notation "x * y"
  := ((#ident.Z_mul @ x @ y)%expr)
     : expr_scope.
Local Notation "x" := (expr.Var x) (only printing, at level 9) : expr_scope.
Local Notation cstZ r := (#ident.Z_cast @ #(@ident.Literal base.type.zrange r%zrange))%expr.
Local Notation cstZZ r1 r2 := (#ident.Z_cast2 @ (#(@ident.Literal base.type.zrange r1%zrange), #(@ident.Literal base.type.zrange r2%zrange)))%expr.

Example test1 : True.
Proof.
  let v := Reify ((fun x => 2^x) 255)%Z in
  pose v as E.
  vm_compute in E.
  pose (PartialEvaluate RewriteRules.default_opts E) as E'.
  vm_compute in E'.
  lazymatch (eval cbv delta [E'] in E') with
  | (fun var => expr.Ident (ident.Literal ?v)) => idtac
  end.
  constructor.
Qed.
Module testrewrite.
  Import expr.
  Import ident.

  Redirect "log" Eval compute in RewriteRules.RewriteNBE RewriteRules.default_opts (fun var =>
                          (#ident.fst @ (expr_let x := ##10 in ($x, $x)))%expr).

  Notation "x + y" := (@expr.Ident base.type ident _ _ ident.Z_add @ x @ y)%expr : expr_scope.

  Redirect "log" Eval compute in RewriteRules.RewriteNBE RewriteRules.default_opts (fun var =>
                          ((\ x , expr_let y := ##5 in #ident.fst @ $x + (#ident.fst @ $x + ($y + $y)))
                             @ (##1, ##1))%expr).

  Redirect "log" Eval compute in RewriteRules.RewriteNBE RewriteRules.default_opts (fun var =>
                          ((\ x , expr_let y := ##5 in $y + ($y + (#ident.fst @ $x + #ident.snd @ $x)))
                             @ (##1, ##7))%expr).

  Redirect "log" Eval cbv in partial.eval_with_bound partial.default_relax_zrange false (@ident.is_comment) false
                                      (RewriteRules.RewriteNBE RewriteRules.default_opts (fun var =>
                (\z , ((\ x , expr_let y := ##5 in $y + ($z + (#ident.fst @ $x + #ident.snd @ $x)))
                         @ (##1, ##7)))%expr) _)
                (Datatypes.Some r[0~>100]%zrange, Datatypes.tt).
End testrewrite.
Module testpartial.
  Import expr.
  Import ident.

  Redirect "log" Eval compute in partial.eval
                          (#ident.fst @ (expr_let x := ##10 in ($x, $x)))%expr.

  Notation "x + y" := (@expr.Ident base.type ident _ _ (ident.Z_add) @ x @ y)%expr : expr_scope.

  Redirect "log" Eval compute in partial.eval
                          ((\ x , expr_let y := ##5 in #ident.fst @ $x + (#ident.fst @ $x + ($y + $y)))
                             @ (##1, ##1))%expr.

  Redirect "log" Eval compute in partial.eval
                          ((\ x , expr_let y := ##5 in $y + ($y + (#ident.fst @ $x + #ident.snd @ $x)))
                             @ (##1, ##7))%expr.

  Redirect "log" Eval cbv in partial.eval_with_bound
                partial.default_relax_zrange
                false (@ident.is_comment) false
                (\z , ((\ x , expr_let y := ##5 in $y + ($z + (#ident.fst @ $x + #ident.snd @ $x)))
                         @ (##1, ##7)))%expr
                (Datatypes.Some r[0~>100]%zrange, Datatypes.tt).
End testpartial.

Module test2.
  Example test2 : True.
  Proof.
    let v := Reify (fun y : Z
                    => (fun k : Z * Z -> Z * Z
                        => dlet_nd x := (y * y) in
                            dlet_nd z := (x * x) in
                            k (z, z))
                         (fun v => v)) in
    pose v as E.
    vm_compute in E.
    pose (partial.Eval E) as E'.
    vm_compute in E'.
    lazymatch (eval cbv delta [E'] in E') with
    | (fun var : type -> Type =>
         (λ x : var _,
                expr_let x0 := ($x * $x) in
              expr_let x1 := ($x0 * $x0) in
              ($x1, $x1))%expr) => idtac
    end.
    pose (partial.EvalWithBound partial.default_relax_zrange false (@ident.is_comment) false E' (Some r[0~>10]%zrange, tt)) as E''.
    lazy in E''.
     lazymatch (eval cbv delta [E''] in E'') with
     | (fun var : type -> Type =>
          (λ x : var _,
                 expr_let y := (cstZ r[0 ~> 100]) @ (((cstZ r[0 ~> 10]) @ $x) * ((cstZ r[0 ~> 10]) @ $x)) in
               expr_let y0 := (cstZ r[0 ~> 10000]) @ (((cstZ r[0 ~> 100]) @ $y) * ((cstZ r[0 ~> 100]) @ $y)) in
               ((cstZ r[0 ~> 10000]) @ $y0, (cstZ r[0 ~> 10000]) @ $y0))%expr)
      => idtac
    end.
    constructor.
  Qed.
End test2.
Module test3.
  Example test3 : True.
  Proof.
    let v := Reify (fun y : Z
                    => dlet_nd x := dlet_nd x := (y * y) in
                        (x * x) in
                        dlet_nd z := dlet_nd z := (x * x) in
                        (z * z) in
                        (z * z)) in
    pose v as E.
    vm_compute in E.
    pose (partial.Eval E) as E'.
    vm_compute in E'.
    lazymatch (eval cbv delta [E'] in E') with
    | (fun var : type -> Type =>
         (λ x : var _,
                expr_let x0 := $x * $x in
              expr_let x1 := $x0 * $x0 in
              expr_let x2 := $x1 * $x1 in
              expr_let x3 := $x2 * $x2 in
              $x3 * $x3)%expr)
      => idtac
    end.
    pose (partial.EvalWithBound partial.default_relax_zrange false (@ident.is_comment) false E' (Some r[0~>10]%zrange, tt)) as E'''.
    lazy in E'''.
    lazymatch (eval cbv delta [E'''] in E''') with
    | (fun var : type -> Type =>
          (λ x : var _,
           expr_let y := (cstZ r[0 ~> 100]) @ (((cstZ r[0 ~> 10]) @ $x) * ((cstZ r[0 ~> 10]) @ $x)) in
           expr_let y0 := (cstZ r[0 ~> 10000]) @ (((cstZ r[0 ~> 100]) @ $y) * ((cstZ r[0 ~> 100]) @ $y)) in
           expr_let y1 := (cstZ r[0 ~> 100000000]) @ (((cstZ r[0 ~> 10000]) @ $y0) * ((cstZ r[0 ~> 10000]) @ $y0)) in
           expr_let y2 := (cstZ r[0 ~> 10000000000000000]) @ (((cstZ r[0 ~> 100000000]) @ $y1) * ((cstZ r[0 ~> 100000000]) @ $y1)) in
           (cstZ r[0 ~> 100000000000000000000000000000000]) @ (((cstZ r[0 ~> 10000000000000000]) @ $y2) * ((cstZ r[0 ~> 10000000000000000]) @ $y2)))%expr)
      => idtac
    end.
    constructor.
  Qed.
End test3.
Module test3point5.
  Example test3point5 : True.
  Proof.
    let v := Reify (fun y : (list Z) => List.nth_default (-1) y 0) in
    pose v as E.
    vm_compute in E.
    pose (partial.EvalWithBound partial.default_relax_zrange false (@ident.is_comment) false E (Some [Some r[0~>10]%zrange], tt)) as E'.
    lazy in E'.
    clear E.
    lazymatch (eval cbv delta [E'] in E') with
    | (fun var : type -> Type =>
         (λ x : var _,
          (cstZ r[0 ~> 10]) @ (#ident.List_nth_default @ #(ident.Literal (0)%Z) @ $x @ #(ident.Literal 0%nat)))%expr)
      => idtac
    end.
    constructor.
  Qed.
End test3point5.
Module test4.
  Example test4 : True.
  Proof.
    let v := Reify (fun y : (list Z * list Z)
                    => dlet_nd x := List.nth_default (-1) (fst y) 0 in
                        dlet_nd z := List.nth_default (-1) (snd y) 0 in
                        dlet_nd xz := (x * z) in
                        (xz :: xz :: nil)) in
    pose v as E.
    vm_compute in E.
    pose (partial.Eval E) as E'.
    lazy in E'.
    clear E.
    pose (Some [Some r[0~>10]%zrange],Some [Some r[0~>10]%zrange], Datatypes.tt) as bound.
    pose (partial.EtaExpandWithListInfoFromBound E' bound) as E''.
    lazy in E''.
    clear E'.
    pose (PartialEvaluate RewriteRules.default_opts E'') as E'''.
    lazy in E'''.
    pose (partial.EvalWithBound partial.default_relax_zrange false (@ident.is_comment) false E''' bound) as E''''.
    lazy in E''''.
    clear E'' E'''.
    lazymatch (eval cbv delta [E''''] in E'''') with
    | (fun var : type -> Type =>
         (λ x : var _,
          expr_let y := (cstZ r[0 ~> 10]) @
                        (#ident.List_nth_default @ #(ident.Literal (0)%Z) @ (#ident.fst @ $x) @ #(ident.Literal 0%nat)) in
          expr_let y0 := (cstZ r[0 ~> 10]) @
                          (#ident.List_nth_default @ #(ident.Literal (0)%Z) @ (#ident.snd @ $x) @ #(ident.Literal 0%nat)) in
          expr_let y1 := (cstZ r[0 ~> 100]) @ (((cstZ r[0 ~> 10]) @ $y) * ((cstZ r[0 ~> 10]) @ $y0)) in
          (cstZ r[0 ~> 100]) @ $y1 :: (cstZ r[0 ~> 100]) @ $y1 :: [])%expr)
      => idtac
    end.
    constructor.
  Qed.
End test4.
Module test5.
  Example test5 : True.
  Proof.
    let v := Reify (fun y : (Z * Z)
                    => dlet_nd x := (13 * (fst y * snd y)) in
                        x) in
    pose v as E.
    vm_compute in E.
    pose (RewriteRules.RewriteArith (2^8) RewriteRules.default_opts (partial.Eval E)) as E'.
    lazy in E'.
    clear E.
    lazymatch (eval cbv delta [E'] in E') with
    | (fun var =>
         expr.Abs (fun v
              => (expr_let v0 := (#ident.Z_mul @ (#ident.fst @ $v) @ (#ident.Z_mul @ (#ident.snd @ $v) @ #(ident.Literal 13))) in
                      $v0)%expr))
      => idtac
    end.
    constructor.
  Qed.

  Example test5_2 : True.
  Proof.
    let v := Reify (fun y : (Z * Z)
                    => dlet_nd x := (2 * (19 * (fst y * snd y))) in
                        x) in
    pose v as E.
    vm_compute in E.
    pose (RewriteRules.RewriteArith (2^8) RewriteRules.default_opts (partial.Eval E)) as E'.
    lazy in E'.
    clear E.
    lazymatch (eval cbv delta [E'] in E') with
    | (fun var =>
         expr.Abs (fun v
              => (expr_let v0 := (#ident.Z_mul @ (#ident.fst @ $v) @ (#ident.Z_mul @ (#ident.snd @ $v) @ (#ident.Z_mul @ #(ident.Literal 2) @ #(ident.Literal 19)))) in
                      $v0)%expr))
      => idtac
    end.
    constructor.
  Qed.
End test5.
Module test6.
  (* check for no dead code with if *)
  Example test6 : True.
  Proof.
    let v := Reify (fun y : Z
                    => if 0 =? 1
                       then dlet_nd x := (y * y) in
                                x
                       else y) in
    pose v as E.
    vm_compute in E.
    pose (PartialEvaluate RewriteRules.default_opts E) as E''.
    lazy in E''.
    lazymatch eval cbv delta [E''] in E'' with
    | fun var : type -> Type => (λ x : var _, $x)%expr
      => idtac
    end.
    exact I.
  Qed.
End test6.
Module test7.
  Example test7 : True.
  Proof.
    let v := Reify (fun y : Z
                    => dlet_nd x := y + y in
                        dlet_nd z := x in
                        dlet_nd z' := z in
                        dlet_nd z'' := z in
                        z'' + z'') in
    pose v as E.
    vm_compute in E.
    pose (Subst01.Subst01 ident.is_comment (DeadCodeElimination.EliminateDead ident.is_comment E)) as E''.
    lazy in E''.
    lazymatch eval cbv delta [E''] in E'' with
    | fun var : type -> Type => (λ x : var _, expr_let v0 := $x + $x in $v0 + $v0)%expr
      => idtac
    end.
    exact I.
  Qed.
End test7.
Module test8.
  Example test8 : True.
  Proof.
    let v := Reify (fun y : Z
                    => dlet_nd x := y + y in
                        dlet_nd z := x in
                        dlet_nd z' := z in
                        dlet_nd z'' := z in
                        z'' + z'') in
    pose v as E.
    vm_compute in E.
    pose (GeneralizeVar.GeneralizeVar (E _)) as E''.
    lazy in E''.
    unify E E''.
    exact I.
  Qed.
End test8.
Module test9.
  Example test9 : True.
  Proof.
    let v := Reify (fun y : list Z => (hd 0%Z y, tl y)) in
    pose v as E.
    vm_compute in E.
    pose (PartialEvaluate RewriteRules.default_opts E) as E'.
    lazy in E'.
    clear E.
    lazymatch (eval cbv delta [E'] in E') with
    | (fun var
       => (λ x,
           (#ident.list_case
              @ (λ _, #(ident.Literal 0%Z))
              @ (λ x0 _, $x0)
              @ $x,
            #ident.list_case
              @ (λ _, #ident.nil)
              @ (λ _ x1, $x1)
              @ $x))%expr)
      => idtac
    end.
    exact I.
  Qed.
End test9.
(*
Module test10.
  Example test10 : True.
  Proof.
    let v := Reify (fun (f : Z -> Z -> Z) x y => f (x + y) (x * y))%Z in
    pose v as E.
    vm_compute in E.
    pose (Uncurry.expr.Uncurry (partial.Eval true (canonicalize_list_recursion E))) as E'.
    lazy in E'.
    clear E.
    lazymatch (eval cbv delta [E'] in E') with
    | (fun var =>
         (λ v,
          ident.fst @@@ $v @
                    (ident.fst @@@ (ident.snd @@@ $v) + ident.snd @@@ (ident.snd @@@ $v)) @
                    (ident.fst @@@ (ident.snd @@@ $v) * ident.snd @@@ (ident.snd @@@ $v)))%expr)
      => idtac
    end.
    constructor.
  Qed.
End test10.
 *)
(*
Module test11.
  Example test11 : True.
  Proof.
    let v := Reify (fun x y => (fun f a b => f a b) (fun a b => a + b) (x + y) (x * y))%Z in
    pose v as E.
    vm_compute in E.
    pose (Uncurry.expr.Uncurry (partial.Eval true (canonicalize_list_recursion E))) as E'.
    lazy in E'.
    clear E.
    lazymatch (eval cbv delta [E'] in E') with
    | (fun var =>
         (λ x,
          ident.fst @@@ $x + ident.snd @@@ $x + ident.fst @@@ $x * ident.snd @@@ $x)%expr)
      => idtac
    end.
    constructor.
  Qed.
End test11.
 *)
Module test12.
  Example test12 : True.
  Proof.
    let v := Reify (fun y : list Z => repeat y 2) in
    pose v as E.
    vm_compute in E.
    pose (Some (repeat (@None zrange) 3), Datatypes.tt) as bound.
    pose (PartialEvaluate RewriteRules.default_opts (partial.EtaExpandWithListInfoFromBound E bound)) as E'.
    lazy in E'.
    clear E.
    lazymatch (eval cbv delta [E'] in E') with
    | (fun var
       => (λ x, [ [ $x[[0]] ; $x[[1]]; $x[[2]] ] ; [ $x[[0]] ; $x[[1]]; $x[[2]] ] ])%expr)
      => idtac
    end.
    exact I.
  Qed.
End test12.
Module test13.
  Example test13 : True.
  Proof.
    let v0 := constr:(nat_rect (fun _ => nat -> nat) (fun v => v) (fun n' rec v => (n' + rec (S v))%nat) 3 0%nat) in
    let v := Reify v0 in
    pose v as E;
      pose v0 as exp.
    vm_compute in E.
    vm_compute in exp.
    pose (PartialEvaluate RewriteRules.default_opts E) as E'.
    vm_compute in E'.
    clear E.
    let r := Reify exp in
    unify r E'.
    exact I.
  Qed.
End test13.
Module test14.
  Import PreExtra.
  Local Open Scope string_scope.
  Example test14 : True.
  Proof.
    let v := Reify (fun y : Z
                    => dlet_nd x := y + y in
                        dlet_nd z := y + y in
                        dlet_nd w := y + y in
                        dlet_nd v := y + y in
                        dlet_nd __ := ident.comment ("note", (x, x, z, z)) in
                        dlet_nd __ := ident.comment_no_keep ("note", (w, w, v, v)) in
                        y) in
    pose v as E.
    vm_compute in E.
    pose (Subst01.Subst01 ident.is_comment (DeadCodeElimination.EliminateDead ident.is_comment E)) as E''.
    lazy in E''.
    pose (PartialEvaluate RewriteRules.default_opts E'') as E'''.
    vm_compute in E'''.
    pose (partial.EvalWithBound partial.default_relax_zrange false (@ident.is_comment) true E''' (Some r[0~>1]%zrange, tt)) as E''''.
    lazy in E''''.
    unify E E''.
    unify E'' E'''.
    lazymatch (eval cbv [E''''] in E'''') with
    | fun var : type -> Type =>
        (λ x : var (type.base (base.type.type_base Compilers.Z)),
               expr_let v := cstZ r[0 ~> 2] @
                                  (cstZ r[0 ~> 1] @ $x + cstZ r[0 ~> 1] @ $x) in
             expr_let v0 := cstZ r[0 ~> 2] @
                                 (cstZ r[0 ~> 1] @ $x + cstZ r[0 ~> 1] @ $x) in
             expr_let v1 := cstZ r[0 ~> 2] @
                                 (cstZ r[0 ~> 1] @ $x + cstZ r[0 ~> 1] @ $x) in
             expr_let v2 := cstZ r[0 ~> 2] @
                                 (cstZ r[0 ~> 1] @ $x + cstZ r[0 ~> 1] @ $x) in
             expr_let _ := #Compilers.ident_comment @ (###_, ($v, $v, $v0, $v0)) in
             expr_let _ := #Compilers.ident_comment_no_keep @
                            (###_, ($v1, $v1, $v2, $v2)) in
             cstZ r[0 ~> 1] @ $x)%expr
      => idtac
    end.
    exact I.
  Qed.
End test14.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

Require Export Relations_1.
Require Export Relations_1_facts.
Require Export Relations_2.
Require Export Relations_2_facts.
Require Export Relations_3.

Theorem Rstar_imp_coherent :
 forall (U:Type) (R:Relation U) (x y:U), Rstar U R x y -> coherent U R x y.
Proof.
intros U R x y H'; red in |- *.
exists y; auto with sets.
Qed.
Hint Resolve Rstar_imp_coherent.

Theorem coherent_symmetric :
 forall (U:Type) (R:Relation U), Symmetric U (coherent U R).
Proof.
unfold coherent at 1 in |- *.
intros U R; red in |- *.
intros x y H'; elim H'.
intros z H'0; exists z; tauto.
Qed.

Theorem Strong_confluence :
 forall (U:Type) (R:Relation U), Strongly_confluent U R -> Confluent U R.
Proof.
intros U R H'; red in |- *.
intro x; red in |- *; intros a b H'0.
unfold coherent at 1 in |- *.
generalize b; clear b.
elim H'0; clear H'0.
intros x0 b H'1; exists b; auto with sets.
intros x0 y z H'1 H'2 H'3 b H'4.
generalize (Lemma1 U R); intro h; lapply h;
 [ intro H'0; generalize (H'0 x0 b); intro h0; lapply h0;
    [ intro H'5; generalize (H'5 y); intro h1; lapply h1;
       [ intro h2; elim h2; intros z0 h3; elim h3; intros H'6 H'7;
          clear h h0 h1 h2 h3
       | clear h h0 h1 ]
    | clear h h0 ]
 | clear h ]; auto with sets.
generalize (H'3 z0); intro h; lapply h;
 [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9; clear h h0 h1
 | clear h ]; auto with sets.
exists z1; split; auto with sets.
apply Rstar_n with z0; auto with sets.
Qed.

Theorem Strong_confluence_direct :
 forall (U:Type) (R:Relation U), Strongly_confluent U R -> Confluent U R.
Proof.
intros U R H'; red in |- *.
intro x; red in |- *; intros a b H'0.
unfold coherent at 1 in |- *.
generalize b; clear b.
elim H'0; clear H'0.
intros x0 b H'1; exists b; auto with sets.
intros x0 y z H'1 H'2 H'3 b H'4.
cut (ex (fun t:U => Rstar U R y t /\ R b t)).
intro h; elim h; intros t h0; elim h0; intros H'0 H'5; clear h h0.
generalize (H'3 t); intro h; lapply h;
 [ intro h0; elim h0; intros z0 h1; elim h1; intros H'6 H'7; clear h h0 h1
 | clear h ]; auto with sets.
exists z0; split; [ assumption | idtac ].
apply Rstar_n with t; auto with sets.
generalize H'1; generalize y; clear H'1.
elim H'4.
intros x1 y0 H'0; exists y0; auto with sets.
intros x1 y0 z0 H'0 H'1 H'5 y1 H'6.
red in H'.
generalize (H' x1 y0 y1); intro h; lapply h;
 [ intro H'7; lapply H'7;
    [ intro h0; elim h0; intros z1 h1; elim h1; intros H'8 H'9;
       clear h H'7 h0 h1
    | clear h ]
 | clear h ]; auto with sets.
generalize (H'5 z1); intro h; lapply h;
 [ intro h0; elim h0; intros t h1; elim h1; intros H'7 H'10; clear h h0 h1
 | clear h ]; auto with sets.
exists t; split; auto with sets.
apply Rstar_n with z1; auto with sets.
Qed.

Theorem Noetherian_contains_Noetherian :
 forall (U:Type) (R R':Relation U),
   Noetherian U R -> contains U R R' -> Noetherian U R'.
Proof.
unfold Noetherian at 2 in |- *.
intros U R R' H' H'0 x.
elim (H' x); auto with sets.
Qed.

Theorem Newman :
 forall (U:Type) (R:Relation U),
   Noetherian U R -> Locally_confluent U R -> Confluent U R.
Proof.
intros U R H' H'0; red in |- *; intro x.
elim (H' x); unfold confluent in |- *.
intros x0 H'1 H'2 y z H'3 H'4.
generalize (Rstar_cases U R x0 y); intro h; lapply h;
 [ intro h0; elim h0;
    [ clear h h0; intro h1
    | intro h1; elim h1; intros u h2; elim h2; intros H'5 H'6;
       clear h h0 h1 h2 ]
 | clear h ]; auto with sets.
elim h1; auto with sets.
generalize (Rstar_cases U R x0 z); intro h; lapply h;
 [ intro h0; elim h0;
    [ clear h h0; intro h1
    | intro h1; elim h1; intros v h2; elim h2; intros H'7 H'8;
       clear h h0 h1 h2 ]
 | clear h ]; auto with sets.
elim h1; generalize coherent_symmetric; intro t; red in t; auto with sets.
unfold Locally_confluent, locally_confluent, coherent in H'0.
generalize (H'0 x0 u v); intro h; lapply h;
 [ intro H'9; lapply H'9;
    [ intro h0; elim h0; intros t h1; elim h1; intros H'10 H'11;
       clear h H'9 h0 h1
    | clear h ]
 | clear h ]; auto with sets.
clear H'0.
unfold coherent at 1 in H'2.
generalize (H'2 u); intro h; lapply h;
 [ intro H'0; generalize (H'0 y t); intro h0; lapply h0;
    [ intro H'9; lapply H'9;
       [ intro h1; elim h1; intros y1 h2; elim h2; intros H'12 H'13;
          clear h h0 H'9 h1 h2
       | clear h h0 ]
    | clear h h0 ]
 | clear h ]; auto with sets.
generalize Rstar_transitive; intro T; red in T.
generalize (H'2 v); intro h; lapply h;
 [ intro H'9; generalize (H'9 y1 z); intro h0; lapply h0;
    [ intro H'14; lapply H'14;
       [ intro h1; elim h1; intros z1 h2; elim h2; intros H'15 H'16;
          clear h h0 H'14 h1 h2
       | clear h h0 ]
    | clear h h0 ]
 | clear h ]; auto with sets.
red in |- *; (exists z1; split); auto with sets.
apply T with y1; auto with sets.
apply T with t; auto with sets.
Qed.