Require Import Coq.Logic.Classical_Prop.
Require Import Common.Definitions.
Require Import Common.Values.
Require Import Common.Memory.
Require Import Lib.Extra.
Require Import Lia.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq eqtype path fingraph fintype.

  (* Define reachability using the ssreflect fingraph library. *)
  Definition node_t : Type := Component.id * Block.id.

  Definition apply_load_block_seq (m: Memory.t) (pair: node_t) : seq node_t :=
    match m (fst pair) with
    | None => nil
    | Some compMem => ComponentMemory.load_block compMem (snd pair)
    end.

  Lemma apply_load_block_load :
    forall m nd ndres,
      In ndres (apply_load_block_seq m nd) <->
      exists ndresoff ndoff,
        Memory.load m (Permission.data, nd.1, nd.2, ndoff) =
        Some (Ptr (Permission.data, ndres.1, ndres.2, ndresoff)).
  Proof.
    intros m nd ndres.
    unfold apply_load_block_seq. unfold Memory.load. simpl.
    split; destruct (m nd.1) as [compMem |].
    - destruct (ComponentMemory.load_block_load compMem nd.2 ndres.1 ndres.2) as [l r].
      rewrite <- surjective_pairing in l.
      intros Hin. apply l. exact Hin.
    - intros Hin. exfalso. apply (List.in_nil Hin).
    - intros [ndresoff [ndoff Hload]].
      destruct (ComponentMemory.load_block_load compMem nd.2 ndres.1 ndres.2) as [l r].
      rewrite <- surjective_pairing in r. apply r.
      exists ndresoff. exists ndoff. exact Hload.
    - intros [ndresoff [_ contra]]. discriminate.
  Qed.

  Definition apply_load_block (m: Memory.t) (pair: node_t) : list (node_t) :=
    match m (fst pair) with
    | None => nil
    | Some compMem => ComponentMemory.load_block compMem (snd pair)
    end.

  Definition max_ptr_per_compMem (m: Memory.t) :=
    mapm ComponentMemory.max_ptr m.

  Definition max_ptr (m: Memory.t) : node_t :=
    fold_max (map snd (max_ptr_per_compMem m)).

  Lemma apply_load_block_max_ptr_per_compMem_or_less :
    forall x x0 m,
      In x (apply_load_block_seq m x0) ->
      exists n nd, (max_ptr_per_compMem m) n = Some nd /\ x.1 <= nd.1 /\ x.2 <= nd.2.
  Proof.
    unfold apply_load_block_seq.
    intros x x0 m Hinloadblock.
    destruct (m x0.1) as [t |] eqn:e.
    - exists x0.1.
      exists (ComponentMemory.max_ptr t).
      split.
      + unfold max_ptr_per_compMem.
        unfold mapm. simpl. rewrite mapimE. rewrite e. auto.
      + apply ComponentMemory.max_ptr_load_block_out with (b := x0.2). auto.
    - exfalso. pose (List.in_nil Hinloadblock). auto.
  Qed.

  Lemma max_ptr_In_leq :
    forall m x,
      (exists n nd, (max_ptr_per_compMem m) n = Some nd /\ x.1 <= nd.1 /\ x.2 <= nd.2) ->
      x.1 <= (max_ptr m).1 /\ x.2 <= (max_ptr m).2.
  Proof.
    unfold max_ptr.
    intros m x [n [nd [Hin [H1 H2]]]].
    - pose (In_innd := In_in nd (map snd (max_ptr_per_compMem m))).
      split.
      + apply leq_trans with (n := nd.1). trivial. apply fold_max_In_leq.
        erewrite <- In_innd. apply/mapP. exists (n, nd).
        * apply/getmP. exact Hin.
        * auto.
      + apply leq_trans with (n := nd.2). trivial. apply fold_max_In_leq.
        erewrite <- In_innd. apply/mapP. exists (n, nd).
        * apply/getmP. exact Hin.
        * auto.
  Qed.

  Lemma In_apply_load_block_seq_max_ptr :
    forall x x0 m,
      In x (apply_load_block_seq m x0) ->
      x.1 <= (max_ptr m).1 /\ x.2 <= (max_ptr m).2.
  Proof.
    intros x x0 m Hin.
    unfold max_ptr.
    apply max_ptr_In_leq.
    apply apply_load_block_max_ptr_per_compMem_or_less with (x0 := x0). trivial.
  Qed.

  Lemma In_apply_load_block_seq_max_ptr_less :
    forall x x0 m,
      In x (apply_load_block_seq m x0) ->
      x.1 < S (max_ptr m).1 /\ x.2 < S (max_ptr m).2.
  Proof.
    intros x x0 m Hinload.
    pose (Hleq := In_apply_load_block_seq_max_ptr x x0 m Hinload).
    destruct Hleq as [H1 H2].
    split; rewrite ltnS; trivial.
  Qed.

  Fixpoint nth_default_or_In_proof T (x_default: T) s n : T + sig (fun (x:T) => In x s) :=
    match s with
    | nil => inl x_default
    | x0 :: s' =>
      match n with
      | 0 => inr
               (exist
                  (fun x => In x (x0 :: s'))
                  x0
                  (in_eq x0 s')
               )
      | S n' =>
        match nth_default_or_In_proof T x_default s' n' with
        | inl x => inl x
        | inr (exist x's' x'Ins') => inr
                                       (exist
                                          (fun x => In x (x0 :: s'))
                                          x's'
                                          (List.in_cons x0 x's' s' x'Ins')
                                       )
        end
      end
    end.

  Lemma nlt0_False :
    forall n, n < 0 -> False.
  Proof.
    intros n. induction n.
    - intros nlt0. unfold is_true in nlt0.
      pose (zeroeq1 := anti_leq (andb_true_intro (conj nlt0 (leqnSn 0)))).
      discriminate.
    - intros n1lt0. pose (nlt0 := leq_trans (leqnSn n.+1) n1lt0). auto.
  Qed.

  (*
     Here, we get rid of the default value
     (i.e., get rid of the left value of the return type of nth_default_or_In_proof)
     by passing a proof that n < length s, thus that n is a valid index.

     So, let's define "nth with an In-proof" using the proof mode first.
   *)
  Fixpoint nth_In_proof T s n (pf_nlt : n < length s) : sig (fun (x:T) => In x s).
  Proof.
    induction s.
    - simpl in pf_nlt.
      exfalso.
      apply nlt0_False with (n := n). auto.
    - destruct (n < length s).
      + assert (IHs' : {x : T | In x s}) by now auto.
        destruct IHs' as [x' x'In].
        exact (exist (fun x => In x (a :: s)) x' (List.in_cons a x' s x'In)).
      + exact (exist
                  (fun x => In x (a :: s))
                  a
                  (in_eq a s)).
  Defined.

  Fixpoint construct_seq_using_nth_In_proof T s n (pf_nlt: n < length s) :
    seq (sig (fun (x:T) => In x s)).
  Proof.
    induction n.
    - exact [nth_In_proof T s 0 pf_nlt].
    - assert (n_len_s: n < length s).
      {
        auto.
      }
      exact (cons (nth_In_proof T s (n.+1) pf_nlt) (IHn n_len_s)).
  Defined.

  Definition proofize_seq T s : seq (sig (fun (x:T) => In x s)).
  Proof.
    pose (n := length s).
    destruct (length s) eqn:e.
    - exact nil.
    - apply construct_seq_using_nth_In_proof with (n := n0).
      rewrite e. auto.
  Defined.

  (*Compute (proofize_seq nat (5 :: (6 :: (4 :: nil)))).*)

  Lemma construct_seq_using_nth_In_proof_0 T s (pf_nlt: 0 < length s) :
    construct_seq_using_nth_In_proof T s 0 pf_nlt = [nth_In_proof T s 0 pf_nlt].
  Proof.
    (* compute. *)
    unfold construct_seq_using_nth_In_proof.
    (* unfold nat_rect. *)
  Admitted.

  Lemma construct_seq_using_nth_In_proof_S T s n pf_nlt :
    exists pf_n'lt,
      construct_seq_using_nth_In_proof T s (S n) pf_nlt =
      cons (nth_In_proof T s (n.+1) pf_nlt)
           (construct_seq_using_nth_In_proof T s n pf_n'lt).
  Proof.
    eexists. unfold construct_seq_using_nth_In_proof.
    (* Check ltnW. *)
    (* SearchAbout nat_rect *)
    (* compute. *)
    (* rewrite nat_rect_succ_r. *)
  Admitted.

  Lemma construct_seq_using_nth_In_proof_length T s n pf_nlt:
    length (construct_seq_using_nth_In_proof T s n pf_nlt) = n.+1.
  Proof.
    induction n.
    - rewrite construct_seq_using_nth_In_proof_0. auto.
    - pose proof construct_seq_using_nth_In_proof_S T s n pf_nlt as [pf_n'lt IHeq].
      rewrite IHeq. simpl.
      rewrite (IHn pf_n'lt). reflexivity.
  Qed.

  Lemma size_proofize_seq : forall T s, length (proofize_seq T s) = length s.
  Proof.
    intros.
    induction s.
    - auto.
    - simpl.
      unfold proofize_seq.
      destruct (length (a :: s) == 0) eqn:Hlen_cons.
      + rewrite eq_sym in Hlen_cons.
        pose proof (eqP Hlen_cons) as Hlen0.
        simpl in Hlen0.
        apply O_S in Hlen0.
        exfalso. assumption.
      + (*SearchAbout eq 0 false.*)
        apply neq0_lt0n in Hlen_cons.
        (*SearchAbout 0 lt.*)
        unfold length.
      simpl.
      (*SearchAbout nat_rect.*)
  Admitted.

  (*SearchAbout sig.*)

  Definition deproofize_one A P y := @proj1_sig A P y.

  (*SearchAbout proj1_sig.*)
  (*Check sval.*)

  (*TODO: Check the lemmas about proj1_sig and sval. They may help in
   proving a spec for proofize_seq. *)

  Lemma proofize_seq_cons :
    forall T a s,
    exists ap sp, proofize_seq T (a :: s) = ap :: sp.
  Proof.
    intros T a s. simpl. eexists. eexists.
    unfold proofize_seq.
    (* destruct (length (a :: s)) *) (* Does not work. *)
  Admitted.

  Lemma proofize_seq_spec :
    forall T s spf,
      spf = proofize_seq T s ->
      map (@proj1_sig T _) spf = s.
  Proof.
    induction s as [| a s IHs]; simpl; intros spf H.
    - rewrite H. auto.
    - (* PROBLEM: The induction hypothesis IHs expects a sequence with proofs of In x s
       instead of proofs of In x (a :: s) *)
      destruct (proofize_seq_cons T a s) as [ap [sp pr_eq]].
      rewrite H. rewrite pr_eq.
      rewrite map_cons.
  Admitted.

  (* Next, this was an attempt to define nth_In_proof but WITHOUT using the proof mode.

     The reason I wanted to do it without the proof mode is to have more control
     over the term that is generated.

     This control may be needed if we want to prove something about nth_In_proof.
   *)

  (*
  Fixpoint nth_In_proof T (x_default: T) s n (pf_nlt : n < length s) : sig (fun (x:T) => In x s) :=
    match s return sig (fun (x:T) => In x s) with
    | nil => let x_pf := False_ind (In x_default nil) (nlt0_False n pf_nlt) in
             (* x_pf does not type-check. In particular, the information that we are in
                the nil case is not substituted in the type of pf_nlt.*)
             exist (fun x => In x nil) x_default x_pf
    | a :: s' => exist
                   (fun x => In x (a :: s'))
                   a
                   (in_eq a s')
                   (* This is the wrong return value, but it is here just to pass the syntax check. *)
    end.
  *)

  Lemma nth_len_inr :
    forall T x_default s n,
      n < length s ->
      exists pf, nth_default_or_In_proof T x_default s n = inr pf.
  Proof.
    induction s.
    - simpl. intros n nlt0. pose (F := nlt0_False n nlt0). discriminate.
    - intros n nlt.
      destruct (n < length s) eqn:e.
      + pose (pfIns := IHs n e).
        destruct pfIns as [[memberS proofInS] pf_s_eq_inr].
        (*SearchAbout In cons.*)
        pose (proofInAS := List.in_cons a memberS s proofInS).
        exists (exist (fun x => In x (a :: s)) memberS proofInAS).
        unfold nth_default_or_In_proof.
        simpl.
        admit.
      + admit.
  Admitted.

  Definition finitize_ptr (ptr : Component.id * Block.id) :
    ordinal (S (fst ptr)) * ordinal (S (snd ptr)) :=
    (inord (fst ptr), inord (snd ptr)).

  Definition cast_to_bigger_ordinal_right {l1 : nat} {r1 : nat} (l2: nat) (r2: nat)
             (ptr : ordinal l1 * ordinal r1) :
    (ordinal (ssrnat.maxn l1 l2) * ordinal (ssrnat.maxn r1 r2)).
    destruct ptr as [l r].
    destruct l. destruct r.
    assert (lp: ssrnat.leq (S m) (ssrnat.maxn l1 l2)).
    {
      apply ssrnat.leq_trans with (n := l1).
      - exact i.
      - apply ssrnat.leq_maxl.
    }
    assert (rp: ssrnat.leq (S m0) (ssrnat.maxn r1 r2)).
    {
      apply ssrnat.leq_trans with (n := r1).
      - exact i0.
      - apply ssrnat.leq_maxl.
    }
    exact (Ordinal lp, Ordinal rp).
  Defined.

  Definition cast_to_bigger_ordinal_left {l2 : nat} {r2 : nat} (l1: nat) (r1: nat)
             (ptr : ordinal l2 * ordinal r2) :
    (ordinal (ssrnat.maxn l1 l2) * ordinal (ssrnat.maxn r1 r2)).
    destruct ptr as [l r].
    destruct l. destruct r.
    assert (lp: ssrnat.leq (S m) (ssrnat.maxn l1 l2)).
    {
      apply ssrnat.leq_trans with (n := l2).
      - exact i.
      - apply ssrnat.leq_maxr.
    }
    assert (rp: ssrnat.leq (S m0) (ssrnat.maxn r1 r2)).
    {
      apply ssrnat.leq_trans with (n := r2).
      - exact i0.
      - apply ssrnat.leq_maxr.
    }
    exact (Ordinal lp, Ordinal rp).
  Defined.

  (* FINITIZE MEMORY USING MAX_PTR *)

  Definition apply_load_block_seq_fin
             (m: Memory.t)
             (nd1: nat) (nd2: nat)
             (nd : ordinal (ssrnat.maxn (S (max_ptr m).1) nd1) *
                   ordinal (ssrnat.maxn (S (max_ptr m).2) nd2))
    : seq (ordinal (ssrnat.maxn (S (max_ptr m).1) nd1) *
           ordinal (ssrnat.maxn (S (max_ptr m).2) nd2)) :=
    map
      (fun node_inPf =>
         match node_inPf with | exist x In_x_applyloadblock =>
                                cast_to_bigger_ordinal_right nd1 nd2
                                               (Ordinal (
                                                    (In_apply_load_block_seq_max_ptr_less
                                                       x
                                                       (nat_of_ord nd.1, nat_of_ord nd.2)
                                                       m
                                                       In_x_applyloadblock).1
                                                  ),
                                 Ordinal
                                   (
                                     (In_apply_load_block_seq_max_ptr_less
                                        x
                                        (nat_of_ord nd.1, nat_of_ord nd.2)
                                        m
                                        In_x_applyloadblock).2
                                   )
                                )
         end)
      (proofize_seq node_t (apply_load_block_seq m (nat_of_ord nd.1, nat_of_ord nd.2)))
  .

  Definition fingraph_of_mem
             (m: Memory.t)
             (nd1: nat) (nd2: nat)
    := apply_load_block_seq_fin m nd1 nd2.

  Definition reachable_nodes m (x: Component.id * Block.id)
    := dfs
         (fingraph_of_mem m (S x.1) (S x.2))
         ((maxn (S (max_ptr m).1) x.1.+1) * (maxn (S (max_ptr m).2) x.2.+1))
         nil
         (cast_to_bigger_ordinal_left
            (S (max_ptr m).1)
            (S (max_ptr m).2)
            (finitize_ptr x)
         ).

  Lemma dfs_path_fin_mem:
    forall m x y,
      reflect (dfs_path
                 (fingraph_of_mem m (S x.1) (S x.2))
                 nil
                 (cast_to_bigger_ordinal_left
                    (S (max_ptr m).1)
                    (S (max_ptr m).2)
                    (finitize_ptr x)
                 )
                 y
              )
              (y \in reachable_nodes m x).
  Proof.
    intros m x y.
    apply dfs_pathP.
    - simpl.
      rewrite card_prod. rewrite card_ord. rewrite card_ord.
      rewrite card0. rewrite add0n. auto.
    - auto.
  Qed.

  Lemma dfs_path_fin_mem_iff:
    forall m x y,
      (dfs_path
         (fingraph_of_mem m (S x.1) (S x.2))
         nil
         (cast_to_bigger_ordinal_left
            (S (max_ptr m).1)
            (S (max_ptr m).2)
            (finitize_ptr x)
         )
         y
      )
      <->
      (y \in reachable_nodes m x).
  Proof.
    split; intros H; apply/dfs_path_fin_mem; auto.
  Qed.

  Definition nat_node_of_ord_node {n: nat} {m: nat} (x: ordinal n * ordinal m) :=
    let (cid, bid) := x in (nat_of_ord cid, nat_of_ord bid).

  Definition reachable_nodes_nat m x := map nat_node_of_ord_node (reachable_nodes m x).

  Lemma reachable_nodes_reachable_nodes_nat :
    forall x m y,
      y \in reachable_nodes m x ->
      nat_node_of_ord_node y \in reachable_nodes_nat m x.
  Proof.
    intros. unfold reachable_nodes_nat. apply map_f. auto.
  Qed.

  Lemma reachable_nodes_nat_reachable_nodes :
    forall x m y_nat,
      y_nat \in reachable_nodes_nat m x ->
      exists y, y \in reachable_nodes m x /\ nat_node_of_ord_node y = y_nat.
  Proof.
    unfold reachable_nodes_nat. intros x m y_nat Hreachnat.
    destruct (mapP Hreachnat) as [x0 Hx0 Hx0nat].
    exists x0. split; auto.
  Qed.

  Lemma nat_node_of_ord_node_cast_to_bigger_ordinal:
    forall l2 r2 l1 r1 x, nat_node_of_ord_node (cast_to_bigger_ordinal_left l1 r1 x) =
                          @nat_node_of_ord_node l2 r2 x.
  Proof.
    intros l2 r2 l1 r1 x.
    destruct x as [xl xr] eqn:ex.
    unfold cast_to_bigger_ordinal_left.
    simpl. destruct xl as [xlval xlpf] eqn:exl.
    simpl. destruct xr as [xrval xrpf] eqn:exr.
    auto.
  Qed.

  Lemma nat_node_of_ord_node_finitize_ptr:
    forall x, nat_node_of_ord_node (finitize_ptr x) = x.
  Proof. intros x. destruct x as [xl xr]. unfold finitize_ptr. simpl.
         assert (xleq: (@nat_of_ord (S xl) (@inord xl xl)) = xl).
         { apply inordK. auto. }
         rewrite xleq.
         assert (xreq: (@nat_of_ord (S xr) (@inord xr xr)) = xr).
         { apply inordK. auto. }
         rewrite xreq.
         auto.
  Qed.

  Lemma reachable_nodes_expansive:
    forall m x, exists y, y \in reachable_nodes m x /\ nat_node_of_ord_node y = x.
  Proof.
    intros m x. eexists. split.
    rewrite <- dfs_path_fin_mem_iff.
    apply/dfs_pathP; auto.
    Focus 2. apply/dfsP. exists nil. auto. reflexivity.
    rewrite card0. auto. unfold last.
    rewrite nat_node_of_ord_node_cast_to_bigger_ordinal.
    rewrite nat_node_of_ord_node_finitize_ptr.
    auto.
  Qed.

  Lemma reachable_nodes_nat_expansive :
    forall x m,
    exists y,
      (@nat_node_of_ord_node
         (maxn (max_ptr m).1.+1 x.1.+1)
         (maxn (max_ptr m).2.+1 x.2.+1)
         y) \in
        reachable_nodes_nat m x
        /\ nat_node_of_ord_node y = x.
  Proof. intros x m. unfold reachable_nodes_nat.
         destruct (reachable_nodes_expansive m x) as [y [y_in yx]].
         eexists y. rewrite map_f; auto.
  Qed.

  (*Definition is_reachable_from m y x := y \in reachable_nodes_nat m x.

  Lemma get_path_from_to m x y ()
   *)
  (*In order to write this lemma properly, one would need to rely on the
   fact that the finitized graph and the original graph are equal.*)

  Lemma eq_reachable_eq_path :
    forall m m' x y,
      (reachable_nodes_nat m x = reachable_nodes_nat m' x)
      ->
      dfs_path
        (fingraph_of_mem m (S x.1) (S x.2))
        nil
        (cast_to_bigger_ordinal_left
           (S (max_ptr m).1)
           (S (max_ptr m).2)
           (finitize_ptr x)
        )
        y
      ->
      exists y',
        dfs_path
          (fingraph_of_mem m' (S x.1) (S x.2))
          nil
          (cast_to_bigger_ordinal_left
             (S (max_ptr m').1)
             (S (max_ptr m').2)
             (finitize_ptr x)
          )
          y'
        /\
        nat_node_of_ord_node y = nat_node_of_ord_node y'.
  Proof.
    intros m m' x y Hreacheq Hdfs_path.
    apply dfs_path_fin_mem_iff in Hdfs_path.
    apply reachable_nodes_reachable_nodes_nat in Hdfs_path.
    rewrite Hreacheq in Hdfs_path.
    remember (nat_node_of_ord_node y) as z.
    destruct (reachable_nodes_nat_reachable_nodes x m' z  Hdfs_path) as [x0 [P H]].
    exists x0.
    split.
    - apply/dfs_path_fin_mem. exact P.
    - auto.
  Qed.

  Inductive Reachable (m: Memory.t) (bs : {fset node_t}) : node_t -> Prop :=
  | Reachable_refl : forall b, b \in bs -> Reachable m bs b
  | Reachable_step : forall cid bid b' compMem,
      Reachable m bs (cid, bid) ->
      m (cid) = Some compMem ->
      b' \in ComponentMemory.load_block compMem bid ->
             Reachable m bs b'.

  Lemma Reachable_transitive mem addrs addr addr':
    Reachable mem addrs addr ->
    Reachable mem (fset1 addr) addr' ->
    Reachable mem addrs addr'.
  Proof.
    intros Hreach Hreach1. induction Hreach1; subst.
    - assert (b = addr). by (apply/fset1P). subst. auto.
    - eapply Reachable_step; eauto.
  Qed.

  Lemma Reachable_fset0 mem addr:
    Reachable mem fset0 addr -> False.
  Proof.
    intros Hreach. induction Hreach; auto.
  Qed.

  Lemma Reachable_Memory_store mem mem' ptr v start_set reached:
    Memory.store mem ptr v = Some mem' ->
    Reachable mem' start_set reached ->
    (
      Reachable mem start_set reached
      \/
      exists cptr bptr optr cv bv ov,
        v = Ptr (Permission.data, cv, bv, ov)
        /\
        ptr = (Permission.data, cptr, bptr, optr)
        /\
        Reachable mem start_set (cptr, bptr)
        /\
        Reachable mem (fset1 (cv, bv)) reached
    ).
  Proof.
    intros Hstore Hreachmem'.
    destruct (classic (Reachable mem start_set reached)) as [G|Hnotreach];
      [by left|].
    induction Hreachmem'.
    - exfalso. apply Hnotreach. by constructor.
    - destruct b' as [creached breached].
      assert (exists optr oload,
                 Memory.load
                   mem'
                   (Permission.data, cid, bid, oload)
                 = Some (Ptr (Permission.data, creached, breached, optr))
             ) as [optr_ [oload Hload]].
      {
        unfold Memory.load. simpl. rewrite H.
        rewrite -ComponentMemory.load_block_load. by apply In_in in H0.
      }
      erewrite (Memory.load_after_store _ _ _ _ _ Hstore) in Hload.
      destruct (Pointer.eq (Permission.data, cid, bid, oload) ptr) eqn:eptr;
        move : eptr => /Pointer.eqP => eptr.
      + inversion Hload; subst. clear Hload.
        destruct (classic (Reachable mem start_set (cid, bid)))
          as [Hreachmem|IHinst].
        * right. do 6 eexists.
          split; [reflexivity|
                  split; [reflexivity|
                          split; [exact Hreachmem|
                                  apply Reachable_refl; by rewrite in_fset1
                 ]]].
        * specialize (IHHreachmem' IHinst)
            as [|[cptr [bptr [optr [cv [bv [ov [eq1 [eq2 [reach1 reach2]]]]]]]]]].
          -- by intuition.
          -- inversion eq1. inversion eq2. subst. by intuition.
      + destruct (classic (Reachable mem start_set (cid, bid)))
          as [Hreachmem|IHinst].
        * left.
          unfold Memory.load in Hload. simpl in *.
          destruct (mem cid) as [compMem_|] eqn:emem; last discriminate.
          eapply Reachable_step; [exact Hreachmem | exact emem | apply In_in].
          rewrite ComponentMemory.load_block_load. eauto.
        * specialize (IHHreachmem' IHinst)
            as [|[cptr [bptr [optr [cv [bv [ov [eq1 [eq2 [reach1 reach2]]]]]]]]]].
          -- by intuition.
          -- subst. right.
             unfold Memory.load in Hload. simpl in *.
             destruct (mem cid) as [compMem_|] eqn:emem; last discriminate.
             do 6 eexists.
             split; [reflexivity|
                     split; [reflexivity|
                             split; [exact reach1|
                                     eapply Reachable_step;
                                     [exact reach2| exact emem | apply In_in]
                    ]]].
             rewrite ComponentMemory.load_block_load. eauto.
  Qed.

  Lemma Reachable_Memory_alloc mem mem' c sz ptr start_set reached:
    Memory.alloc mem c sz = Some (mem', ptr) ->
    Reachable mem' start_set reached ->
    Reachable mem start_set reached.
  Proof.
    intros Halloc Hreachmem'.
    destruct (classic (Reachable mem start_set reached)) as [G|Hnotreach];
      [easy|].
    induction Hreachmem'.
    - exfalso. apply Hnotreach. by constructor.
    - destruct b' as [creached breached].
      assert (exists optr oload,
                 Memory.load
                   mem'
                   (Permission.data, cid, bid, oload)
                 = Some (Ptr (Permission.data, creached, breached, optr))
             ) as [optr_ [oload Hload]].
      {
        unfold Memory.load. simpl. rewrite H.
        rewrite -ComponentMemory.load_block_load. by apply In_in in H0.
      }
      destruct ((cid, bid) == (Pointer.component ptr, Pointer.block ptr))
      eqn:eptr; move : eptr => /eqP => eptr.
      + inversion eptr. subst. clear eptr.
        specialize (Memory.load_after_alloc_eq
                      _ _ _ _ _
                      (Permission.data, Pointer.component ptr,
                       Pointer.block ptr, oload) Halloc Logic.eq_refl)
          as Hrewr.
        simpl in *. rewrite Hrewr in Hload.
        destruct ((oload <? Z.of_nat sz)%Z); last discriminate.
        destruct ((0 <=? oload)%Z); last discriminate.
        discriminate.
      + erewrite (Memory.load_after_alloc _ _ _ _ _ _ Halloc) in Hload;
          last (simpl; congruence).
        unfold Memory.load in Hload. simpl in *.
        destruct (mem cid) as [cMem|] eqn:ecMem ; last discriminate.
        eapply Reachable_step.
        * destruct (classic (Reachable mem start_set (cid, bid))) as [G|contra];
            [eassumption|by apply IHHreachmem' in contra].
        * eassumption.
        * apply In_in. rewrite ComponentMemory.load_block_load; by eauto.
  Qed.

  Lemma Reachable_exists_one_start mem start_set reached:
    Reachable mem start_set reached ->
    exists start,
      start \in start_set /\ Reachable mem (fset1 start) reached.
  Proof.
    intros Hreach.
    induction Hreach.
    - exists b. split; [assumption|apply Reachable_refl; by rewrite in_fset1].
    - destruct IHHreach as [start [Hstart Hreach1]].
      exists start. split; [assumption|eapply Reachable_transitive; eauto].
      eapply Reachable_step; eauto.
      eapply Reachable_refl; by rewrite in_fset1.
  Qed.

  Lemma Reachable_dfs_path m bs cid bid:
    Reachable m bs (cid, bid) <->
    (exists b n_f,
        b \in bs
              /\
              dfs_path
                (fingraph_of_mem m (S b.1) (S b.2))
                nil (* Is nil here alright? *)
                (cast_to_bigger_ordinal_left
                   (S (max_ptr m).1)
                   (S (max_ptr m).2)
                   (finitize_ptr b)
                )
                n_f
              /\
              nat_node_of_ord_node n_f = (cid, bid)
    ).
  Proof.
    split.
    - intros Hreach. induction Hreach as
          [b Hin|b4lastc b4lastb lastnode compMem Hreach IH HcompMem Hload_block].
      + exists b. exists (cast_to_bigger_ordinal_left
                            (S (max_ptr m).1)
                            (S (max_ptr m).2)
                            (finitize_ptr b)
                         ).
        split; auto. split.
        * apply DfsPath with (p := nil); auto. rewrite disjoint_sym  disjoint0. auto.
        * rewrite nat_node_of_ord_node_cast_to_bigger_ordinal
                  nat_node_of_ord_node_finitize_ptr. reflexivity.
      + destruct IH as [b [n_f [Hin [Hdfs Hn_f_b4last]]]].
        pose proof (dfs_path_fin_mem_iff m b n_f) as [Hif _].
        apply Hif in Hdfs.
        unfold reachable_nodes in Hdfs.
        exists b. eexists. split; auto.
        split.
        * apply/dfs_pathP; auto.
          Focus 2.
          apply/dfsP.
          pose proof (@dfsP
                     (prod_finType (ordinal_finType (maxn (max_ptr m).1.+1 b.1.+1))
                                   (ordinal_finType (maxn (max_ptr m).2.+1 b.2.+1)))
                     (fingraph_of_mem m b.1.+1 b.2.+1)
                     (cast_to_bigger_ordinal_left
                        (max_ptr m).1.+1 (max_ptr m).2.+1 (finitize_ptr b))
                     n_f
                     ) as pf.
          rewrite card_prod !card_ord in pf.
          pose proof (pf Hdfs) as [p Hp Hlast].
          (*SearchAbout max_ptr.*)
          assert (exists (lastnode_fin: ('I_(maxn (max_ptr m).1.+1 b.1.+1) *
                                         'I_(maxn (max_ptr m).2.+1 b.2.+1))%type),
                     nat_node_of_ord_node lastnode_fin = lastnode) as Hlastnode_fin.
          {
            admit.
          }
          destruct Hlastnode_fin as [lastnode_fin Hlastnode_fin_lastnode].
          exists (rcons p lastnode_fin).
          rewrite rcons_path Hp. unfold fingraph_of_mem.
          (*SearchAbout apply_load_block_seq.*)
          (*Locate apply_load_block_seq_fin.*)
  Admitted.

  (* Taking inspiration from mathcomp.ssreflect.path, make path be the type of
     non-empty sequences.
     A path is thus a head and a tail. The head is of type node_t, and the tail of type
     seq node_t.
     Our path is also uniq, i.e., no cycles.
   *)
  Definition path_t : Type := node_t * (seq node_t).
  (* uniq means that it does not contain cycles. *)
  Definition uniq_path_t (p : path_t) : bool := uniq (p.1 :: p.2).
  Definition size_of_path (p : path_t) : nat := (size p.2) + 1.
  Hint Unfold size_of_path.

  Lemma count_of_distinct_blocks_in_uniq_path_is_same_as_its_size :
    forall p : path_t,
      uniq_path_t p ->
      size (fset (p.1 :: p.2)) = size_of_path p.
  Proof.
    rewrite /uniq_path_t /size_of_path.
    move => p.
    rewrite (uniq_size_fset (p.1 :: p.2)).
    rewrite eqE => H.
    pose (H' := eqnP H).
    erewrite <- H'.
    simpl.
    rewrite addn1.
    reflexivity.
  Qed.

  Definition extend_path' (m : Memory.t) (p : path_t) : list path_t :=
    map (fun x => (x, p.1 :: p.2))
        (filter (fun x => (x \notin p.2) && (x != p.1)) (apply_load_block m p.1)).

  Lemma extend_path'_returns_extensions :
    forall m p ps,
      extend_path' m p = ps -> all (fun x => (x.2 == p.1 :: p.2)) ps.
  Proof.
    intros. subst ps. unfold extend_path'.
    rewrite all_map. simpl.
    unfold preim. simpl.
    rewrite eq_refl.
    apply all_predT.
  Qed.

  Lemma extension_of_path_increases_its_size_by_one :
    forall x p,
      x.2 == p.1 :: p.2 ->
      size_of_path x =? size_of_path p + 1.
  Proof.
    intros x p H.
    simpl.
    pose (H' := eqP H).
    unfold size_of_path.
    rewrite H'.
    apply/Nat.eqb_spec.
    assert (size (p.1 :: p.2) = size p.2 + 1).
    {
      destruct (p.1 :: p.2) eqn:e.
      - discriminate e.
      - simpl.
        assert (s :: l == p.1 :: p.2).
        {
          rewrite e. apply eq_refl.
        }
        rewrite eqseq_cons in H0.
        pose (H1 := andP H0).
        destruct H1 as [_ H2].
        pose (H3 := eqP H2).
        rewrite H3.
        rewrite addn1.
        reflexivity.
    }
    rewrite H0.
    reflexivity.
  Qed.

  Lemma extend_path'_increases_length :
    forall m p lp,
      extend_path' m p = lp ->
      all (fun x => size_of_path x =? size_of_path p + 1) lp.
  Proof.
    intros m p lp H.
    pose (H' := extend_path'_returns_extensions m p lp H).
    eapply sub_all with
        (a1 := fun x : node_t * seq_eqType (prod_eqType nat_eqType nat_eqType) => x.2 == p.1 :: p.2).
    unfold subpred.
    intros x.
    apply extension_of_path_increases_its_size_by_one.
    apply H'.
  Qed.

  Lemma extend_path'_preserves_uniq :
    forall m p0 ps,
      uniq_path_t p0 ->
      extend_path' m p0 = ps ->
      all uniq_path_t ps.
  Proof.
    move => m p0 ps. rewrite /uniq_path_t cons_uniq => /andP[??] <-.
    unfold extend_path'.
    rewrite all_map. simpl.
    unfold preim. simpl.

    apply/allP => x /=. rewrite mem_filter.
    move => /andP [/andP[/negP H1 /negP H2] H3].
    apply/and3P. split; auto.
    apply/memPn => y Hnotin. apply/negP => /eqP?. subst y.
    move: Hnotin. rewrite in_cons => /orP[?|]; auto.
  Qed.

  Definition access_step_paths' (m: Memory.t) (ps: {fset path_t}) (cur_path_size: nat) : {fset path_t} :=
    fsetU ps (fset
                (concat (List.map (extend_path' m)
                                  (filter (fun p => size_of_path p =? cur_path_size) ps)
                        )
                )
             ).

  Lemma access_step_paths'_expansive :
  forall m ps sz,
    fsubset ps (access_step_paths' m ps sz).
  Proof.
    intros. unfold access_step_paths'. apply fsubsetUl.
  Qed.

  Corollary access_step_paths'_never_produces_cycles :
  forall m (ps: {fset path_t}) (sz: nat),
    all uniq_path_t (val ps) ->
    all uniq_path_t (val (access_step_paths' m ps sz)).
  Proof.
    move => m ps sz H.
    apply/allP => p.
    rewrite /access_step_paths' in_fsetU => pHyp.
    pose (pHypProp := orb_prop _ _ pHyp).
    destruct pHypProp as [inPs | inExtend].
    - move: inPs.
      apply/allP; auto.
    - rewrite <- flat_map_concat_map in inExtend.
      (* Want to use in_flat_map. Wanted: In p (flat_map (exte..) ps) *)
      rewrite in_fset in inExtend.
      apply In_in in inExtend.
      apply in_flat_map in inExtend.
      destruct inExtend as [p0 [p0InPs pInExtendPs]].
      rewrite <- (In_in p0) in p0InPs.
      rewrite mem_filter in p0InPs.
      pose (p0InPs' := andb_prop _ _ p0InPs).
      destruct p0InPs' as [_ p0InPs''].
      apply/allP.
      apply (extend_path'_preserves_uniq m p0).
      apply/allP.
      exact H.
      auto.
      reflexivity.
      rewrite <- (In_in p) in pInExtendPs.
      exact pInExtendPs.
  Qed.

  (*
     The fuel decreases, and the count of steps increases.
  *)
  Fixpoint reachable_paths_with_fuel' (m: Memory.t) (ps: {fset path_t})
           (fuel: nat) (cur_path_length: nat) : {fset path_t} :=
  match fuel with
  | 0 => ps
  | S fuel_1 => reachable_paths_with_fuel'
                  m (access_step_paths' m ps cur_path_length) fuel_1 (S cur_path_length)
  end.

  Definition component_memories_of_memory (m: Memory.t) : seq ComponentMemory.t :=
    map snd (elementsm m).

  Definition list_of_per_component_set_of_block_ids (m: Memory.t) : seq {fset Block.id} :=
    map ComponentMemory.domm (component_memories_of_memory m).

  Definition count_of_allocated_blocks_of_memory (m: Memory.t) : nat :=
    sumn (map (fun (x:{fset Block.id}) => size x) (list_of_per_component_set_of_block_ids m)).

  (* Presumably, the size of a path in ps is 1.*)
  Definition reachable_paths' (m: Memory.t) (ps: {fset path_t}) :=
    reachable_paths_with_fuel' m ps (count_of_allocated_blocks_of_memory m) 1.

  Definition max_path_size_in_seq (s: seq path_t) : nat :=
    foldl max 0 (map size_of_path s).

  Definition max_path_size_in_set (ps : {fset path_t}) : nat :=
    max_path_size_in_seq (val ps).

  (*Lemma reachable_paths_with_fuel'_expansive :
    forall m ps fuel cur_path_length,
      fsubset
        reachable_paths_with_fuel' m () fuel_1 (S cur_path_length)
        reachable_paths_with_fuel' m ps (S fuel1) cur_path_length
  *)

  Lemma foldl_max_default :
    forall l mx d,
      mx = foldl max d l -> max d mx = mx.
  Proof.
    intros l. induction l; simpl.
    - intros mx d H. subst mx. rewrite Nat.max_idempotent. reflexivity.
    - intros mx d H.
      destruct (max d a =? d) eqn:da.
      + move : da. rewrite Nat.eqb_eq. move => da. rewrite da in H.
        apply IHl with (mx := mx) (d := d). exact H.
      + move : da. rewrite Nat.eqb_neq. move => da.
        pose (dec := Nat.max_dec d a).
        destruct dec as [F | T].
        * rewrite F in da. pose (contra := Nat.eq_refl d). pose (bot := da contra). contradiction.
        * rewrite T in H.
          destruct (max d mx =? a) eqn:dmx.
          -- move : dmx. rewrite Nat.eqb_eq. move => dmx.
             rewrite dmx.
             pose (IHlinst := IHl mx a).
             pose (IHlinst2 := IHlinst H).
             assert (alemx : (a <= mx)%coq_nat).
             {
               ++ rewrite <- IHlinst2.
                  apply Nat.le_max_l.
             }
             apply Nat.le_antisymm.
             ++ exact alemx.
             ++ rewrite <- dmx.
                apply Nat.le_max_r.
          -- pose (IHlinst := IHl mx a H).
             apply Nat.max_r.
             apply Nat.le_trans with (m := a).
             ++ pose (dlea := Nat.le_max_l d a). erewrite T in dlea. exact dlea.
             ++ pose (alemx := Nat.le_max_l a mx). erewrite IHlinst in alemx. exact alemx.
  Qed.

  Lemma max_in_seq_has :
    forall l default mx,
      mx = foldl max default l ->
      mx != default ->
      (has (fun x => x =? mx) l
       /\ forall lelem, has (fun x => x =? lelem) l -> max lelem mx = mx).
  Proof.
    intros l. simpl. induction l.
    - simpl. intros mx default Hmx Hmx0. rewrite Hmx in Hmx0.
      (* Show false from Hmx0. Should be able to simplify this proof. *)
      unfold is_true in Hmx0.
      pose (iff := negb_true_iff (mx == mx)).
      destruct iff as [Hif _].
      pose (F:= eq_true_false_abs (mx == mx) (eq_refl mx) (Hif Hmx0)). contradiction.
    - intros default mx Hmx Hmxdefault.
      rewrite Hmx in Hmxdefault.
      destruct (a =? mx) eqn:mxa.
      + simpl. rewrite mxa. simpl. split.
        * auto.
        * intros lelem H.
          apply Is_true_eq_left in H.
          apply orb_prop_elim in H.
          destruct H as [H1 | H2].
          -- move : mxa.
             rewrite Nat.eqb_eq.
             apply Is_true_eq_true in H1.
             move : H1.
             rewrite Nat.eqb_eq.
             intros H0 H1. subst a. rewrite H1.
             apply Nat.max_idempotent.
          -- move : mxa.
             rewrite Nat.eqb_eq.
             move => mxa.
             rewrite <- mxa.
             rewrite <- mxa in Hmx.
             pose (IHlInst := IHl a a).
             (*SearchAbout "max".*)
  Admitted.

  (* Use the lemma has_fset together with max_in_seq_has to prove "max_in_fset_has" *)

  Lemma foldl_max_property :
    forall l n new_max mx_so_far,
      foldl max n l = mx_so_far ->
      new_max > mx_so_far ->
      foldl max n (l ++ [new_max]) = new_max.
  Proof.
    intros l.
    induction l.
    - simpl. intros n new_max mx_so_far H Hnewmax. rewrite H.
      pose (max_spec := Nat.max_spec mx_so_far new_max).
      destruct max_spec as [[Truth Concl] | [Falsity _]]; auto.
      + admit (* Here, derive false from Falsity and Hnewmax. *).
      + unfold foldl. (*Search "" "foldl".*)
    Admitted.

  Lemma max_path_size_in_set_spec :
    forall ps sz,
      sz != 0 ->
      (max_path_size_in_set ps = sz <->
       ((has (fun p => size_of_path p =? sz) ps) = true /\
        (has (fun p => size_of_path p > sz) ps) = false)).
  Proof.
    intros.
  Admitted.

  Lemma max_path_size_in_set_distributes :
    forall bs bs',
      max_path_size_in_set (bs :|: bs')%fset =
      max (max_path_size_in_set bs) (max_path_size_in_set bs').
  Proof.
    move => bs bs'.
    rewrite /max_path_size_in_set.
    (*Search "" "fsetU".*)
    (*Search "" "map".*)
  Admitted.

  (* Not sure if needed. *)
  Lemma max_path_size_in_set_seq :
    forall bs,
      max_path_size_in_set (fset (val bs)) = max_path_size_in_set bs.
  Proof.
    unfold max_path_size_in_set.
    (* Here, need to cancel out "val fset val" *)
    (*SearchAbout fsubset.*)
  Admitted.

  Lemma notsubset_exists_in :
    forall (T:ordType) (s: {fset T}) (t: {fset T}),
      ~~fsubset t s ->
      exists x, x \in t /\ x \notin s.
  Proof.
    (*SearchAbout "fsubsetPn".*)
    (* This is exactly what we need. Why is it not available in?
       It is available here: https://github.com/math-comp/finmap/blob/48c1330c43194c566410bb1dcb1af623b679cc2e/finmap.v#L1834
     *)
    Admitted.

  (* The following lemma is needed because max_path_size_in_set is the metric for progress.
     It is important to show that this metric never decreases by making a step.
     This lemma asserts this fact.
   *)

  Lemma access_step_never_decreases_path_length :
    forall m p ps ps' sz,
      sz != 0 ->
      access_step_paths' m ps sz = ps' ->
      p \in ps' ->
            (p \in ps \/ size_of_path p = sz + 1).
  Proof.
    intros m p ps ps' sz Hsz Hps' Hp.
    destruct (size_of_path p =? sz + 1) eqn:sz_p.
    - right.
      apply/Nat.eqb_spec. auto.
    - left.
      subst ps'. unfold access_step_paths' in Hp.
      (* move: Hp. *)
      (* apply/fsetUP => Hp. *)
      (* TODO: Cannot apply view fsetUP. Any idea how to deal with this error? *)
      (* SearchAbout "fsetUP". *)
      assert (Hp_fsetUP_applied : p \in ps \/
                                         p \in fset (concat
                                                       (List.map
                                                          (extend_path' m)
                                                          [seq p0 <- ps | size_of_path p0 =? sz]
                                                       )
                                                    )
             ).
      {
        admit.
      }
      destruct Hp_fsetUP_applied.
      + assumption.
      + assert (all_sz1 : all (fun x => size_of_path x =? sz + 1)
                              (concat
                                 (List.map
                                    (extend_path' m)
                                    [seq p0 <- ps | size_of_path p0 =? sz]))).
        {
          * (* SearchAbout concat. *)
            (* TODO: Don't know how to deal with concat. *)
            admit.
        }
        (* erewrite <- all_fset in all_sz1. *)
        (* Search "" "all_fset". *)
        (* TODO: Found no subterm matching "all ?M1660 ?M1661" in all_sz1. Why?*)

        (* TODO: Do not know how to write "all" for fset. It expects a seq. *)
        (*
        assert (all_sz1_rewritten: all (fun x => size_of_path x =? sz + 1)
                                       fset (concat
                                               (List.map
                                                  (extend_path' m)
                                                  [seq p0 <- ps | size_of_path p0 =? sz]
                                               )
                                            )
               ).
        *)
        (*Use /allP*)

        Admitted.

  Lemma access_step_never_decreases_max_path_length :
    forall m ps ps' sz,
      sz != 0 ->
      max_path_size_in_set ps = sz ->
      access_step_paths' m ps sz = ps' ->
      (ps = ps' /\
       max_path_size_in_set ps' = sz)
      \/
      max_path_size_in_set ps' = sz + 1.
  Proof.
    intros m ps ps' sz Hsz H H0.
    destruct (ps == ps') eqn:e.
    - pose (e' := eqP e).
      left. split. trivial. rewrite <- H. rewrite e'. trivial.
    - right.
      rewrite eqEfsubset in e.
      pose (e1 := access_step_paths'_expansive m ps sz).
      erewrite H0 in e1.
      pose (subOrsub := andb_false_iff (fsubset ps ps') (fsubset ps' ps)).
      edestruct subOrsub as [H1 _].
      pose (subOrsubConc := H1 e).
      destruct subOrsubConc as [psSubps'f | ps'Subpsf].
    - pose (F := eq_true_false_abs (fsubset ps ps') e1 psSubps'f).
      contradiction.
      (* Here, there are two reasons why this goal is true.
         The first reason is extend_path'_increases_length.
         The second reason is H.
       *)

      (* Use ps'Subpsf to obtain a path that is not in ps *)
      assert (existsPath: exists p, p \in ps' /\ p \notin ps).
      {
        - apply notsubset_exists_in. apply eq_true_not_negb.
          rewrite not_true_iff_false. exact ps'Subpsf.
      }
      subst ps'.
      unfold access_step_paths' in existsPath.
      destruct existsPath as [p [pInU pNotin]].
      rewrite in_fsetU in pInU.
      apply orb_prop in pInU.
      destruct pInU as [pInps | pInConcat].
      + rewrite <- negb_false_iff in pInps.
        unfold is_true in pNotin.
        pose (F := eq_true_false_abs (p \notin ps) pNotin pInps).
        contradiction.
      + unfold access_step_paths'.
        rewrite max_path_size_in_set_distributes.
        pose (maxSpec := Max.max_spec
                           (max_path_size_in_set ps)
                           (max_path_size_in_set
                              (fset (concat (List.map (extend_path' m) [seq p0 <- ps | size_of_path p0 =? sz]))))).
        destruct maxSpec as [[TrueCond Rewr] | [Impossible _]].
        * rewrite Rewr.
          (* Search "" "map" "all". *)

          (*
          assert (all_all_size1:
                    all (all (fun x => size_of_path x =? size_of_path p + 1))
                        (List.map (extend_path' m) [seq p0 <- ps | size_of_path p0 =? sz])).
                 {
                   -- rewrite all_map.
                      unfold preim.
                      (* SearchAbout all. *)
                      assert (HpredT:
                                [pred x |
                                 all
                                   (fun x0 : path_t => size_of_path x0 =? size_of_path p + 1)
                                   (extend_path' m x)
                                ] = predT).
                      unfold predT.
                      assert (extIncLen:
                                forall pth,
                                  all
                                    (fun x0 : path_t => size_of_path x0 =? size_of_path pth + 1)
                                    (extend_path' m pth)
                                = true).
                      {
                        ++ intros pth.
                           pose (goal :=
                                   extend_path'_increases_length m pth (extend_path' m pth)).
                           unfold is_true in goal.
                           eapply goal.
                           reflexivity.
                      }
                      unfold simpl_pred.
                     (*
                      SearchAbout pred.
                      rewrite extIncLen.
                      SearchAbout pred.
                      apply all_predT.
                      Search "" "all" "filter".
                      *)
                 }
           *)

          (* SearchAbout Init.Nat.max.*)
          (* Probably do not need this assertion anymore. *)
          assert (sizeOfFilter: size [seq p <- ps | size_of_path p =? sz] > 0).
          {
            - assert (existsPsz: exists p, p \in ps /\ size_of_path p = sz).
              {
                (* This should follow from H somehow. *)
                - admit.
              }
              rewrite size_filter.
              rewrite <- has_count.
              apply/hasP.
              destruct existsPsz as [pMx [pInps pSz]].
              eexists pMx.
              + exact pInps.
              + apply/Nat.eqb_spec. exact pSz.
          }

  (*rewrite (andb_false_iff (fsubset ps ps') (fsubset ps' ps)) in e.
      rewrite <- negb_true_iff in e.
      unfold negb.
      Search "" "fsubset".
      assert (ps <> ps)
      Search "" "_ != _".
      pose (e' := eqP e).

    destruct (fsubset ps' ps) eqn:e.
    - left.
      assert (pseqps': ps = ps').
      apply: fsubset_sizeP.
      * pose (e1 := access_step_paths'_expansive m ps).
        erewrite H in e1.
        pose (e1size := fsubset_leq_size e1).
        pose (esize := fsubset_leq_size e).
        (*SearchAbout "<=".*)
        apply anti_leq.
        (*SearchAbout "<=".*)
        Print antisymmetric.
        (*SearchAbout "&&".*)
        (*SearchAbout is_true.*)
        unfold is_true in e1size.
        unfold is_true in esize.
        rewrite e1size. rewrite esize. auto.
      * pose (e1 := access_step_paths'_expansive m ps).
        erewrite H in e1. trivial.
        split.
      + trivial.
      + rewrite pseqps'. trivial.
    - right.
      pose (e1 := access_step_paths'_expansive m ps).
      erewrite H in e1.
      (*SearchAbout fsubset.*)
      pose (eqn := eqEfsubset ps ps').
      erewrite e in eqn.
      erewrite andb_false_r in eqn.
      subst ps'.
      unfold access_step_paths' in eqn.
      (*SearchAbout fset.*)
      (* Attempting to prove that the RHS of the union is not empty *)
      destruct (size(fset (concat [seq extend_path' m i | i <- val ps])%fset)) eqn:isEmpty.
      (*SearchAbout size fset.*)
      (*SearchAbout fsubset.*)
      unfold max_path_size_in_set.

      SearchAbout Init.Nat.max.*)
  Admitted.


(** * Autosubst Header for Scoped Syntax
    Our development utilises well-scoped de Bruijn syntax. This means that the de Bruijn indices are taken from finite types. As a consequence, any kind of substitution or environment used in conjunction with well-scoped syntax takes the form of a mapping from some finite type _I^n_. In particular, _renamings_ are mappings _I^n -> I^m_. Here we develop the theory of how these parts interact.

Version: December 11, 2019.
*)
Require Export axioms.
Set Implicit Arguments.
Unset Strict Implicit.

Definition ap {X Y} (f : X -> Y) {x y : X} (p : x = y) : f x = f y :=
  match p with eq_refl => eq_refl end.

Definition apc {X Y} {f g : X -> Y} {x y : X} (p : f = g) (q : x = y) : f x = g y :=
  match q with eq_refl => match p with eq_refl => eq_refl end end.

(** ** Primitives of the Sigma Calculus
    We implement the finite type with _n_ elements, _I^n_, as the _n_-fold iteration of the Option Type. _I^0_ is implemented as the empty type.
*)

Fixpoint fin (n : nat) : Type :=
  match n with
  | 0 => False
  | S m => option (fin m)
  end.

(** Renamings and Injective Renamings
     _Renamings_ are mappings between finite types.
*)
Definition ren (m n : nat) : Type := fin m -> fin n.

Definition id {X} (x : X) := x.

Definition idren {k: nat} : ren k k :=
  fun x => x.

(** We give a special name, to the newest element in a non-empty finite type, as it usually corresponds to a freshly bound variable. *)
Definition var_zero {n : nat} : fin (S n) := None.

Definition null {T} (i : fin 0) : T := match i with end.

Definition shift {n : nat} : ren n (S n) :=
  Some.

Definition comp := @funcomp.

(** Extension of Finite Mappings
    Assume we are given a mapping _f_ from _I^n_ to some type _X_, then we can _extend_ this mapping with a new value from _x : X_ to a mapping from _I^n+1_ to _X_. We denote this operation by _x . f_ and define it as follows:
*)
Definition scons {X : Type} {n : nat} (x : X) (f : fin n -> X) (m : fin (S n)) : X :=
  match m with
  | None => x
  | Some i => f i
  end.

(** ** Type Class Instances for Notation *)

(** *** Type classes for renamings. *)

Class Ren1 (X1  : Type) (Y Z : Type) :=
  ren1 : X1 -> Y -> Z.

Class Ren2 (X1 X2 : Type) (Y Z : Type) :=
  ren2 : X1 -> X2 -> Y -> Z.

Class Ren3 (X1 X2 X3 : Type) (Y Z : Type) :=
  ren3 : X1 -> X2 -> X3 -> Y -> Z.

Class Ren4 (X1 X2 X3 X4 : Type) (Y Z : Type) :=
  ren4 : X1 -> X2 -> X3 -> X4 -> Y -> Z.

Class Ren5 (X1 X2 X3 X4 X5 : Type) (Y Z : Type) :=
  ren5 : X1 -> X2 -> X3 -> X4 -> X5 -> Y -> Z.

Notation "s ⟨ xi1 ⟩" := (ren1  xi1 s) (at level 7, left associativity, format "s  ⟨ xi1 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ⟩" := (ren3 xi1 xi2 xi3 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩" := (ren4  xi1 xi2 xi3 xi4 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩" := (ren5  xi1 xi2 xi3 xi4 xi5 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩") : subst_scope.

Notation "⟨ xi ⟩" := (ren1 xi) (at level 1, left associativity, format "⟨ xi ⟩") : fscope.

Notation "⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2) (at level 1, left associativity, format "⟨ xi1 ; xi2 ⟩") : fscope.

(** *** Type Classes for Substiution *)

Class Subst1 (X1 : Type) (Y Z: Type) :=
  subst1 : X1 -> Y -> Z.

Class Subst2 (X1 X2 : Type) (Y Z: Type) :=
  subst2 : X1 -> X2 -> Y  -> Z.

Class Subst3 (X1 X2 X3 : Type) (Y Z: Type) :=
  subst3 : X1 -> X2 -> X3 ->  Y  -> Z.

Class Subst4 (X1 X2 X3 X4: Type) (Y Z: Type) :=
  subst4 : X1 -> X2 -> X3 -> X4 -> Y  -> Z.

Class Subst5 (X1 X2 X3 X4 X5 : Type) (Y Z: Type) :=
  subst5 : X1 -> X2 -> X3 -> X4 -> X5  -> Y  -> Z.

Notation "s [ sigma ]" := (subst1 sigma s) (at level 7, left associativity, format "s '/' [ sigma ]") : subst_scope.

Notation "s [ sigma ; tau ]" := (subst2 sigma tau s) (at level 7, left associativity, format "s '/' [ sigma ; '/'  tau ]") : subst_scope.

(** ** Type Class for Variables *)
Class Var X Y :=
  ids : X -> Y.

(** ** Proofs for substitution primitives *)

(** Forward Function Composition
    Substitutions represented as functions are ubiquitious in this development and we often have to compose them, without talking about their pointwise behaviour.
    That is, we are interested in the forward compostion of functions, _f o g_, for which we introduce a convenient notation, "f >> g". The direction of the arrow serves as a reminder of the _forward_ nature of this composition, that is first apply _f_, then _g_. *)

Arguments funcomp {X Y Z} (g)%fscope (f)%fscope.

Notation "f >> g" := (funcomp g f) (at level 50).
Open Scope subst_scope.

Notation "x .: f" := (@scons _ _ x f) (at level 55) : subst_scope.

(** Generic lifting operation for renamings *)
Definition up_ren m n (xi : ren m n) : ren (S m) (S n) :=
  var_zero .: xi >> shift.

(** Generic proof that lifting of renamings composes. *)
Lemma up_ren_ren k l m (xi: ren k l) (zeta : ren l m) (rho: ren k m) (E: forall x, (xi >> zeta) x = rho x) :
  forall x, (up_ren xi >> up_ren zeta) x = up_ren rho x.
Proof.
  intros [x|].
  - simpl. unfold funcomp. now rewrite <- E.
  - reflexivity.
Qed.

Arguments up_ren_ren {k l m} xi zeta rho E.

Lemma scons_eta {T} {n : nat} (f : fin (S n) -> T) :
  f var_zero .: shift >> f = f.
Proof. fext. intros [x|]; reflexivity.  Qed.

Lemma scons_eta_id {n : nat} : var_zero .: shift = id :> (fin (S n) -> fin (S n)).
Proof. fext. intros [x|]; reflexivity. Qed.

Lemma scons_comp (T: Type) U {m} (s: T) (sigma: fin m -> T) (tau: T -> U ) :
  (s .: sigma) >> tau = (tau s) .: (sigma >> tau) .
Proof.
  fext. intros [x|]. reflexivity. simpl. reflexivity.
Qed.

Lemma fin_eta {X} (f g : fin 0 -> X) :
  forall x, f x = g x.
Proof. intros []. Qed.

(** ** Variadic Substitution Primitives *)

Fixpoint shift_p (p : nat) {n} : ren n (p + n) :=
  fun n => match p with
        | 0 => n
        | S p => Some (shift_p p n)
        end.

Fixpoint scons_p {X: Type} {m : nat} : forall {n} (f : fin m -> X) (g : fin n -> X), fin (m + n)  -> X.
Proof.
  destruct m.
  - intros n f g. exact g.
  - intros n f g. cbn. apply scons.
    + exact (f var_zero).
    + apply scons_p.
      * intros z. exact (f (Some z)).
      * exact g.
Defined.

Definition zero_p {m : nat} {n} : fin m -> fin (m + n).
Proof.
  induction m.
  - intros [].
  - intros [x|].
    + exact (shift_p 1 (IHm x)).
    + exact var_zero.
Defined.

Lemma scons_p_head' {X} {m n} (f : fin m -> X) (g : fin n -> X) z:
  (scons_p  f g) (zero_p  z) = f z.
Proof.
 induction m.
  - inversion z.
  - destruct z.
    + simpl. simpl. now rewrite IHm.
    + reflexivity.
Qed.

Lemma scons_p_head X m n (f : fin m -> X) (g : fin n -> X) :
  (zero_p  >> scons_p f g) = f.
Proof. fext. intros z. unfold funcomp. apply scons_p_head'. Qed.

Lemma scons_p_tail' X  m n (f : fin m -> X) (g : fin n -> X) z :
  scons_p  f g (shift_p m z) = g z.
Proof. induction m; cbn; eauto. Qed.

Lemma scons_p_tail X  m n (f : fin m -> X) (g : fin n -> X) :
  shift_p m  >> scons_p f g = g.
Proof. fext. intros z. unfold funcomp. apply scons_p_tail'. Qed.

Lemma destruct_fin {m n} (x : fin (m + n)):
  (exists x', x = zero_p  x') \/ exists x', x = shift_p m x'.
Proof.
  induction m; simpl in *.
  - right. eauto.
  - destruct x as [x|].
    + destruct (IHm x) as [[x' ->] |[x' ->]].
      * left. now exists (Some x').
      * right. eauto.
    + left. exists None. eauto.
Qed.

Lemma scons_p_comp' X Y m n (f : fin m -> X) (g : fin n -> X) (h : X -> Y) x:
 h (scons_p  f g x)  = scons_p (f >> h) (g >> h) x.
Proof.
  destruct (destruct_fin x) as [[x' ->]|[x' ->]].
  - now rewrite !scons_p_head'.
  - now rewrite !scons_p_tail'.
Qed.

Lemma scons_p_comp {X Y m n} {f : fin m -> X} {g : fin n -> X} {h : X -> Y} :
  (scons_p f g) >> h = scons_p   (f >> h) (g >> h).
Proof. fext. intros z. unfold funcomp. apply scons_p_comp'. Qed.

Lemma scons_p_congr {X} {m n} (f f' : fin m -> X) (g g': fin n -> X) z:
  (forall x, f x = f' x) -> (forall x, g x = g' x) -> scons_p f g z = scons_p f' g' z.
Proof. intros H1 H2. induction m; eauto. cbn. destruct z; eauto. Qed.

(** Generic n-ary lifting operation. *)
Definition upRen_p p { m : nat } { n : nat } (xi : (fin) (m) -> (fin) (n)) : fin (p + m) -> fin (p + n)  :=
   scons_p  (zero_p ) (xi >> shift_p _).

Arguments upRen_p p {m n} xi.

(** Generic proof for composition of n-ary lifting. *)
Lemma up_ren_ren_p p k l m (xi: ren k l) (zeta : ren l m) (rho: ren k m) (E: forall x, (xi >> zeta) x = rho x) :
  forall x, (upRen_p p xi >> upRen_p p zeta) x = upRen_p p rho x.
Proof.
  intros x. destruct (destruct_fin x) as [[? ->]|[? ->]].
  - unfold upRen_p. unfold funcomp. now repeat rewrite scons_p_head'.
  - unfold upRen_p. unfold funcomp. repeat rewrite scons_p_tail'.
    now rewrite <- E.
Qed.

Arguments zero_p m {n}.
Arguments scons_p  {X} m {n} f g.

Lemma scons_p_eta {X} {m n} {f : fin m -> X}
      {g : fin n -> X} (h: fin (m + n) -> X) {z: fin (m + n)}:
  (forall x, g x = h (shift_p m x)) -> (forall x, f x = h (zero_p m x)) -> scons_p m f g z = h z.
Proof.
  intros H1 H2. destruct (destruct_fin z) as [[? ->] |[? ->]].
  - rewrite scons_p_head'. eauto.
  - rewrite scons_p_tail'. eauto.
Qed.

Arguments scons_p_eta {X} {m n} {f g} h {z}.
Arguments scons_p_congr {X} {m n} {f f'} {g g'} {z}.

Opaque scons.
Opaque var_zero.
Opaque null.
Opaque shift.
Opaque up_ren.
Opaque var_zero.
Opaque idren.
Opaque comp.
Opaque funcomp.
Opaque id.

(** ** Notations for Scoped Syntax *)

Module CommaNotation.
Notation "s , sigma" := (scons s sigma) (at level 60, format "s ,  sigma", right associativity) : subst_scope.
End CommaNotation.

Notation "s '..'" := (scons s ids) (at level 1, format "s ..") : subst_scope.

Notation "↑" := (shift) : subst_scope.

Ltac unfold_funcomp := match goal with
                           | |-  context[(?f >> ?g) ?s] => change ((f >> g) s) with (g (f s))
                           end.

(** ** Tactics for Scoped Syntax *)

(** Generic fsimpl tactic: simplifies the above primitives in a goal. *)
Ltac fsimpl :=
  repeat match goal with
         | [|- context[id >> ?f]] => change (id >> f) with f (* AsimplCompIdL *)
         | [|- context[?f >> id]] => change (f >> id) with f (* AsimplCompIdR *)
         | [|- context [id ?s]] => change (id s) with s
         | [|- context[comp ?f ?g]] => change (comp f g) with (g >> f) (* AsimplCompIdL *)
         | [|- context[(?f >> ?g) >> ?h]] =>
           change ((f >> g) >> h) with (f >> (g >> h)) (* AsimplComp *)

         | [|- zero_p >> scons_p ?f ?g] => rewrite scons_p_head

         | [|- context[(?s.:?sigma) var_zero]] => change ((s.:sigma) var_zero) with s
         | [|- context[(?s.:?sigma) (shift ?m)]] => change ((s.:sigma) (shift m)) with (sigma m)

         | [|- context[idren >> ?f]] => change (idren >> f) with f
         | [|- context[?f >> idren]] => change (f >> idren) with f
         | [|- context[?f >> (?x .: ?g)]] => change (f >> (x .: g)) with g
         | [|- context[?x2 .: shift >> ?f]] => change x2 with (f var_zero); rewrite (@scons_eta _ _ f)
         | [|- context[?f var_zero .: ?g]] => change g with (shift >> f); rewrite scons_eta

         |[|- _ =  ?h (?f ?s)] => change (h (f s)) with ((f >> h) s)
         |[|-  ?h (?f ?s) = _] => change (h (f s)) with ((f >> h) s)

         | _ => first [progress (rewrite scons_comp) |  progress (rewrite scons_eta_id) | progress (autorewrite with FunctorInstances)]
         end.

(** Generic fsimpl tactic: simplifies the above primitives in the context *)
Ltac fsimplc :=
  repeat match goal with
         | [H: context[id >> ?f] |- _] => change (id >> f) with f in H(* AsimplCompIdL *)
         | [H: context[?f >> id]|- _] => change (f >> id) with f in H(* AsimplCompIdR *)
         | [H: context [id ?s]|- _] => change (id s) with s in H
         | [H: context[comp ?f ?g]|- _] => change (comp f g) with (g >> f) in H (* AsimplCompIdL *)
         | [H: context[(?f >> ?g) >> ?h]|- _] =>
           change ((f >> g) >> h) with (f >> (g >> h)) in H (* AsimplComp *)
         | [H: context[(?s.:?sigma) var_zero]|- _] => change ((s.:sigma) var_zero) with s in H
         | [H: context[(?s.:?sigma) var_zero]|- _] => change ((s.:sigma) var_zero) with s in H
         | [H: context[(?s.:?sigma) (shift ?m)]|- _] => change ((s.:sigma) (shift m)) with (sigma m) in H
                                                                                |[H : context[ _ =  ?h (?f ?s)]|- _] => change (h (f s)) with ((f >> h) s) in H
         |[H: context[?h (?f ?s) = _]|- _] => change (h (f s)) with ((f >> h) s) in H
         | [H: context[idren >> ?f]|- _] => change (idren >> f) with f in H
         | [H: context[?f >> idren]|- _] => change (f >> idren) with f in H
         | [H: context[?f >> (?x .: ?g)]|- _] =>
           change (f >> (x .: g)) with g in H
         | [H: context[?x2 .: shift >> ?f]|- _] =>
           change x2 with (f var_zero) in H; rewrite (@scons_eta _ _ f) in H
         | [H: context[?f var_zero .: ?g]|- _] =>
           change g with (shift >> f) in H; rewrite scons_eta in H
         | _ => first [progress (rewrite scons_comp in *) | progress (rewrite scons_eta_id in *) | progress (autorewrite with FunctorInstances in *)]
         end.

(** Simplification in both the goal and the context *)
Tactic Notation "fsimpl" "in" "*" :=
  fsimpl; fsimplc.

Tactic Notation "auto_case" tactic(t) :=  (match goal with
                                           | [|- forall (i : fin 0), _] => intros []; t
                                           | [|- forall (i : fin (S (S (S (S _))))), _] => intros [[[[|]|]|]|]; t
                                           | [|- forall (i : fin (S (S (S _)))), _] => intros [[[|]|]|]; t
                                           | [|- forall (i : fin (S (S _))), _] => intros [[?|]|]; t
                                           | [|- forall (i : fin (S _)), _] =>  intros [?|]; t
                                           end).

(** Functor instances which can be added later on. *)
Hint Rewrite  @scons_p_comp scons_p_head scons_p_tail @scons_p_head' @scons_p_tail': FunctorInstances.


(*
 * Copyright (C) 2020 BedRock Systems, Inc.
 * All rights reserved.
 *
 * SPDX-License-Identifier: Apache-2.0
 *)
Require Import bedrock.lang.cpp.
Import cQp_compat.
#[local] Set Warnings "-non-recursive". (* disable warning about [llistR] *)

#[local] Open Scope Z_scope.

(** * Sequential Specs *)

Section with_Sigma.
Context `{Sigma:cpp_logic} {CU: genv}.

(** ** Range

Consider the following stub

[[
class Range {
private:
    unsigned long _begin;
    size_t _size;
    ...
};
]]

of a [Range] class in C++ implementing contiguous address sets as intervals.
To write specs for C++ functions that operate on [Range]s, we:

(1) Implement a Coq model of the [Range] class;

(2) Write a representation predicate that connects Coq [Range]s to the
    representation of C++ Ranges in memory.

*** Coq Model of [Range]

Let's consider the Coq model first. We build it as a Coq [Record] with
two fields, [begin] and [size], corresponding the the fields of the C++
struct. In our model, we represent both values as [Z]; our representation
predicate will impose additional nonnegativity constraints.
*)

Record Range := { begin : Z; size : Z }.

(**
An example [Range], the interval (inclusive 10, 13), is built as:
 *)

Example range_ex : Range := {| begin := 10; size := 3 |}.

(**
To extract the [begin] and [size] of a [Range] like
[range_ex], one can use projections corresponding to the fields:
 *)

Compute range_ex.(begin).
(**
     = 10
     : Z
*)

Compute range_ex.(size).
(**
     = 3
     : Z
 *)

(** *** [Range]: Representation Predicate

Now let's write the representation predicate. It will refer to the
[_begin] and [_size] fields of the C++ struct, which are autogenerated
by cpp2v as:
*)

Notation "'::Range::_begin'" :=
{| f_type := "_Z5Range" ; f_name := "_begin"
 |} (in custom cppglobal at level 0).
Notation "'::Range::_size'" :=
{| f_type := "_Z5Range" ; f_name := "_size"
 |} (in custom cppglobal at level 0).

Definition _begin := _field `::Range::_begin`.
Definition _size := _field `::Range::_size`.

(** Here's the first version, which follows the style
discussed in the first chapter.
It's a [Definition] in Coq that takes two
parameters, the fractional permission [q] (which could be 1, indicating
write permission), and [r : Range], the Coq model of the range.
*)

Definition RangeR3 (q : Qp) (r : Range) : Rep :=
  _begin |-> ulongR q r.(begin) ** (*rep star*)
  _size  |-> ulongR q r.(size).

(**
[RangeR3] is a function (predicate), which when applied to a start address ("this"),
will assert the memory representation starting at that address.
This function nature can be made explicit using [as_Rep], which gives
us explicit access to the this pointer as a function argument.
*)
Definition RangeR2 (q : Qp) (r : Range) : Rep :=
  as_Rep (fun this =>
            this |-> (_begin |-> ulongR q r.(begin) ** (*rep star*)
                      _size  |-> ulongR q r.(size))
         ).

(** To make thigs even more explicit, we can distribute the
 [this |->] over the [**]: *)
Definition RangeR1 (q : Qp) (r : Range) : Rep :=
  as_Rep (fun this =>
            this |-> (_begin |-> ulongR q r.(begin)) ** (*mpred star*)
            this |-> (_begin  |-> ulongR q r.(size))
         ).

(**
[[
this |-> (_begin |-> ulongR q r.(begin))
]]

means "at the address [this + offset_of(_begin)]", there's an
unsigned integer r.(begin) held with permission [q].

Access to the "this" pointer is usually not necessary and only adds verbosity.
However, at some places, e.g. in doubly linked lists, it is necessary:
for example, the next node of a doubly linked list stores
the "this" pointer in its prev field.
*)

Definition RangeR := RangeR2.

(** ** Binary Search Trees

In this section, we implement the representation predicate for binary search trees
corresponding to the following C++ struct:

[[
template <typename T = int>
struct Tree {
  T _data;
  Tree<T>* _left;
  Tree<T>* _right;
};
]]

*)

Parameter _data : field.
Parameter _left : field.
Parameter _right : field.
Parameter _Tree : type.

(** *** Unsorted Binary Trees

Following our recipe, we first define a Coq model of (unsorted) trees: *)

Inductive tree (A : Type) : Type :=
| leaf
| node (data : A) (left : tree A) (right : tree A).
Arguments leaf {_}.
Arguments node {_} _ _ _.

(** [leaf] is the empty tree. [node d l r] is the tree node containing
data [d], left subtree [l] and right subtree [r]. [tree] is polymorphic;
it contains data [d] of type [A] for any type [A]. Below, we'll instantiate
[tree] to [A := Z] and to other types.
*)

(** For example, here's the tree with root [3], left child [1], and right
child [5]. *)
Definition ex_tree : tree Z :=
  node 3 (node 1 leaf leaf) (node 5 leaf leaf).

(** We can define pure Coq functions on [tree] for use in specs. For example,
[in_tree x t] is the proposition that reads "tree [x] contains key [t]".
It's defined by recursion on [t].

A leaf never contains a key (represented by [False]).

Key [x] is [in_tree] [node y l r] when:

(1) [x = y]; or

(2) [x] is in the left subtree [l]; or

(3) [x] is in the right subtree [r].
*)

Fixpoint in_tree {A:Type} (x : A) (t : tree A) : Prop :=
  match t with
  | leaf => False
  | node y l r => x=y \/ in_tree x l \/ in_tree x r
  end.

(** Now we define the representation predicate [treeR] for [tree]s.
[treeR] is parameterized inside a [Section] by:

(1) [A : Type], the type of data stored in the trees; and

(2) [R : Qp -> A -> Rep], a representation predicate for [A].

We'll use [R] to define how that data stored in the tree is represented
in memory.
*)

Section treeR.
Context {A : Type} (R : Qp -> A -> Rep).

Fixpoint treeR (q : Qp) (t : tree A) : Rep :=
  as_Rep (fun this =>
            match t with
            | leaf => [| this = nullptr |] (*this |-> nullR*)
            | node d l r =>
              Exists (lp : ptr) (rp : ptr),
              lp |-> treeR q l **
              rp |-> treeR q r **
              this |-> (_field _data |-> R q d **
                        _field _left |-> ptrR<_Tree> q lp **
                        _field _right |-> ptrR<_Tree> q rp)
            end
         ).

(** The [treeR] predicate is defined by recursion on the Coq
tree [t]. Leaves are represented by the [nullptr], which we write as:
[[
[| this = nullptr |]
]]

When the tree is a [node d l r], we assert that field [_data] contains
[R q d] (representation of [d] with permission [q]) and that there exist
pointers [lp] and [rp] stored at the [_left] and [_right] fields.

We separately assert that:

(1) At [lp], there's a [treeR q l], memory implementing the left subtree; and

(2) At [rp], there's a [treeR q r], memory implementing the right subtree.

*)

End treeR.

(** *** Sorted Binary Trees

To build sorted trees from unsorted ones, we define a Coq predicate, [sorted t].
A [leaf] is always sorted. A [node d l r] when [l] is sorted, [r] is sorted,
all the values in [l] are less than [d], and all the values in [r] are greater
than [d]. This definition additionally implies that the tree contains no duplicate
keys.
*)

Section sorted.
Context {A} (lt : A -> A -> Prop).

Fixpoint sorted (t : tree A) : Prop :=
  match t with
  | leaf => True
  | node d l r =>
    sorted l /\
    sorted r /\
    (forall x, in_tree x l -> lt x d) /\
    (forall y, in_tree y r -> lt d y)
  end.
End sorted.

(** The representation predicate [ZbstR q t] uses [sorted] to lift
[treeR] to sorted trees of [Z]s. *)
Definition ZbstR (q : Qp) (t : tree Z) : Rep :=
  treeR (fun q z => uintR q z) q t ** [| sorted Z.lt t |].

(** [(fun q z => uintR q z)] instantiates [treeR]'s parameter [R] to the
representation predicate of unsigned integers. *)

(** *** Count

[count] is a Coq function that computes the number of nodes in a [Coq] tree. *)
Fixpoint count (t : tree Z) : Z :=
  match t with
  | leaf => 0
  | node d l r => 1 + count l + count r
  end.

Compute count leaf.
(**     = 0
        : Z *)
Compute count ex_tree.
(**     = 3
        : Z *)

(** [count_spec] uses Coq [count] to specify a C++ function that counts the
number of nodes in a BST:

[[
unsigned int Tree::count() const;
]]
 *)
Definition count_spec (this : ptr) :=
  cpp_spec Tint [] $
  \with (q : Qp) (t : tree Z)
  \prepost this |-> treeR (fun q z => uintR q z) q t
  \post{}[Vint (trim 32 (count t))] emp.

(**
For more details the syntax/notations for writing the specifications of functions,
please refer to #cpp2v/doc/specs.md#.

We [trim] the count in the postcondition since it might overflow.
Alternatively, we could impose a bounds condition in the precondition:

[[
  \pre [| bound W64 Unsigned (count t) |]
]]

[count] doesn't require that [t] be sorted so the prepost uses just
[treeR], not [ZbstR].
*)

(** *** Insert *)

(** Here's the spec for a function that inserts a key into a tree:

[[
bool Tree::insert(int);
]]

On duplicate keys, [insert] does nothing (we treat the tree as a set rather
than a multiset).
 *)
Definition insert_spec (this : ptr) :=
  cpp_spec Tbool [Tint] $
    \with (t : tree Z)
    \arg{x} "x" (Vint x)
    \pre this |-> ZbstR 1 t
    \post Exists t',
        this |-> ZbstR 1 t' **
        [| forall y, in_tree y t' <-> (y=x \/ in_tree y t) |].

(** More intensionally, we could write this spec using a Coq implementation of
[insert]:
*)
Fixpoint insert x (t : tree Z) : tree Z :=
  match t with
  | leaf => node x leaf leaf
  | node y l r =>
    if Z.ltb x y then node y (insert x l) r
    else if Z.ltb y x then node y l (insert x r)
         else t
  end.

Definition insert_spec' (this : ptr) :=
  cpp_spec Tbool [Tint] $
    \with (t : tree Z)
    \arg{x} "x" (Vint x)
    \pre this |-> ZbstR 1 t
    \post this |-> ZbstR 1 (insert x t).

(** ** EXERCISE: Linked Lists

[FILL_IN] in the representation predicate for linked lists, represented in
Coq by the datatype [llist] and in C++ by the struct:

[[
struct List {
  int _data;
  List* next;
};
]]

The empty linked list is represented by [nullptr].

*)

Parameter _List : type.
Parameter _next : field.

Inductive llist : Type :=
| nil : llist
| cons : Z -> llist -> llist.

Axiom FILL_IN : forall {T}, T. (* Used to mark exercises in this file *)

Fixpoint llistR (q : Qp) (l : llist) : Rep := FILL_IN.

(** ** Range Maps

Here's a Coq model and representation predicate for "Range Maps", binary
trees of [Entries] that associate ranges of addresses to payloads.

[[
  template<typename T>
  struct Entry {
    Range _range;
    T _payload;
  };

  template<typename T>
  using EntryTree = Tree<Entry<T>>;
]]

*)

Parameter _Entry : globname.
Parameter _range : field.
Parameter _payload : field.

(** The Coq model of an [Entry] tracks [Range]s and payloads of type [T]. *)
Record Entry {T : Type} :=
  { range : Range;
    payload : T }.
Arguments Entry _ : clear implicits.

(** Here's the corresponding representation predicate: *)
Definition EntryR (q : Qp) (e : Entry Z) : Rep :=
  _field _range |-> RangeR q e.(range) **
  _field _payload |-> intR q e.(payload).

(** One range is less than another if its [begin] value is less-than. *)
Definition Range_lt (r1 r2 : Range) : Prop :=
  r1.(begin) < r2.(begin).

(** [Entries] are less-than when their [Range]s are less-than. *)
Definition Entry_lt {A} (e1 e2 : Entry A) : Prop :=
  Range_lt e1.(range) e2.(range).

(** A [tree] of [Entries] is sorted if the [Entries] are sorted by [Entry_lt]. *)
Definition Entry_sorted {T} (t : tree (Entry T)) :=
  sorted Entry_lt t.

(** The representation predicate of an [Entry] [BST]: *)
Definition Entry_bstR (q : Qp) (t : tree (Entry Z)) : Rep :=
  treeR EntryR q t ** [| Entry_sorted t |].

(** Putting the pieces together, here's the function spec for
[lookup], which maps an address [x] in a [tree]s of [Entries] to the
corresponding [Entry], if any.  *)

Definition in_range (r : Range) (x : Z) :=
  r.(begin) <= x /\ x < r.(begin) + r.(size).

Definition payload_of_address (t : tree (Entry Z)) (x : Z) (p : Z) : Prop :=
  exists e : Entry Z,
   in_tree e t /\ in_range e.(range) x /\ p = e.(payload).

(** [borrow_from all borrow], which is used in [lookup_spec] below, encapsulates
a pattern for "borrowing" the resources [borrow] from a larger world [all].

With [borrow_from] you get access to two disjoint resources:

(1) You have access to [borrow]; and

(2) If you give up [borrow], you get back [all].
 *)
Definition borrow_from (all borrow : mpred) : mpred :=
  borrow ** (borrow -* all).

(**
Using borrow, we can write the specification for [lookup]:
 *)
Definition lookup_spec (this : ptr) :=
  cpp_spec Tbool [Tint; Tptr Tint] $
    \arg{x} "x" (Vint x)
    \arg{out} "out" (Vptr out)
    \with (q : Qp) (t : tree (Entry Z))
    \pre out |-> anyR (Tptr (Tnamed _Entry)) 1
    \prepost this |-> Entry_bstR q t
    \post{r}[Vbool r]
      (** The postcondition is keyed on the Boolean result [r], with [r=true]
      indicating a successful lookup.*)
      if r then
        (Exists e,
          [| in_tree e t |] **
          [| in_range e.(range) x |] **
          Exists p,
            (** A pointer to the looked-up entry is passed in the
            out parameter [out].*)
            out |-> ptrR<Tnamed _Entry> q p **
            (** We also return a "borrow" from the [Entry_bstR q t], the fact
            that at [p] there's an [EntryR q e] with a matching [Range]. *)
            borrow_from (this |-> Entry_bstR q t) (p |-> EntryR q e))
      else
        (** When [r=false], we assert that there was no payload [p] corresponding
        to the looked-up value [x]. *)
        [| ~exists p, payload_of_address t x p |] **
        (** (Note: This spec allows the implementation to change the [out] parameter
        arbitrarily in the [error] case.) *)
        out |-> anyR Tint 1 **
        this |-> Entry_bstR q t.

End with_Sigma.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2009-10-14

conversion of a TRS with unary symbols only into an SRS
*)

Set Implicit Arguments.

From CoLoR Require Import LogicUtil RelUtil SN ListUtil Srs ATrs AUnary VecUtil
     EqUtil NatUtil ListMax.

Section S.

(***********************************************************************)
(** term signature *)

  Variable ASig : Signature.

  Notation term := (term ASig). Notation context := (context ASig).
  Notation rule := (rule ASig). Notation rules := (list rule).

  Variable is_unary_sig : is_unary ASig.

  Notation Fun1 := (Fun1 is_unary_sig). Notation Cont1 := (Cont1 is_unary_sig).
  Notation cont := (cont is_unary_sig). Notation red1 := (red1 is_unary_sig).
  Notation term_ind_forall := (term_ind_forall is_unary_sig).

(***********************************************************************)
(** corresponding string signature *)

  Definition SSig_of_ASig := VSignature.mkSignature (@beq_symb_ok ASig).

  Notation SSig := SSig_of_ASig. Notation string := (string SSig).
  Notation srule := (Srs.rule SSig).

(***********************************************************************)
(** conversion term <-> string *)

  Fixpoint term_of_string (s : string) : term :=
    match s with
      | List.nil => Var 0
      | a :: w => Fun1 a (term_of_string w)
    end.

  Lemma var_term_of_string : forall s, var (term_of_string s) = 0.

  Proof. induction s. refl. simpl term_of_string. rewrite var_fun1. hyp. Qed.

  Fixpoint string_of_term (t : term) : string :=
    match t with
      | Var _ => List.nil
      | Fun f ts => f :: Vmap_first List.nil string_of_term ts
    end.

  Lemma string_of_term_fun1 : forall f t,
    string_of_term (Fun1 f t) = f :: string_of_term t.

  Proof.
    intros. unfold AUnary.Fun1. unfold string_of_term; fold string_of_term.
    rewrite Vmap_first_cast. refl.
  Qed.

  Lemma string_of_term_epi : forall s, string_of_term (term_of_string s) = s.

  Proof.
    induction s; intros. refl. simpl term_of_string.
    rewrite string_of_term_fun1, IHs. refl.
  Qed.

  Lemma term_of_string_epi : forall t, maxvar t = 0 ->
    term_of_string (string_of_term t) = t.

  Proof.
    intro t; pattern t; apply term_ind_forall; clear t.
    simpl in *. intros. subst. refl.
    intros f t IH. rewrite maxvar_fun1. intro.
    rewrite string_of_term_fun1. simpl. rewrite IH. refl. hyp.
  Qed.

  Arguments term_of_string_epi [t] _.

  Lemma string_of_term_sub : forall s l,
    string_of_term (sub s l) = string_of_term l ++ string_of_term (s (var l)).

  Proof.
    intro s. apply term_ind_forall. refl. intros f t IH.
    rewrite sub_fun1, !string_of_term_fun1, IH, var_fun1. refl.
  Qed.

(***********************************************************************)
(** conversion context <-> string *)

  Fixpoint string_of_cont (c : context) : string :=
    match c with
      | Hole => List.nil
      | @Cont _ f _ _ _ _ d _ => f :: string_of_cont d
    end.

  Lemma string_of_cont_cont : forall t,
    string_of_cont (cont t) = string_of_term t.

  Proof.
    apply term_ind_forall. refl. intros f t IH.
    rewrite string_of_term_fun1, cont_fun1. simpl. rewrite IH. refl.
  Qed.

  Lemma string_of_cont_comp : forall c d,
    string_of_cont (comp c d) = string_of_cont c ++ string_of_cont d.

  Proof. induction c; simpl; intros. refl. rewrite IHc. refl. Qed.

  Lemma string_of_term_fill : forall t c,
    string_of_term (fill c t) = string_of_cont c ++ string_of_term t.

  Proof.
    induction c. refl. simpl. rewrite Vmap_first_cast. arity1 is_unary_sig.
    simpl. rewrite IHc. refl.
  Qed.

  Fixpoint cont_of_string (s : string) : context :=
    match s with
      | List.nil => Hole
      | f :: s' => Cont1 f (cont_of_string s')
    end.

(***********************************************************************)
(** conversion string <-> substitution *)

  Definition sub_of_string s := single 0 (term_of_string s).

  Lemma term_of_string_fill : forall c s,
    term_of_string (SContext.fill c s) = fill (cont_of_string (lft c))
    (sub (sub_of_string (rgt c)) (term_of_string s)).

  Proof.
    intros [l r] s. elim l. unfold SContext.fill. simpl.
    elim s. refl. intros. simpl term_of_string. rewrite H, sub_fun1.
    refl.
    unfold SContext.fill. simpl lft. simpl rgt. intros. simpl term_of_string.
    simpl cont_of_string. rewrite fill_cont1. apply args_eq.
    apply Vcast_eq_intro.
    apply Vcons_eq_intro. 2: refl. hyp.
  Qed.

(***********************************************************************)
(** rules *)

  Definition srule_of_rule (x : rule) :=
    Srs.mkRule (string_of_term (lhs x)) (string_of_term (rhs x)).

  Definition srs_of_trs := List.map srule_of_rule.

(***********************************************************************)
(** invariance under reset *)

  Lemma string_of_term_reset :
    forall t, string_of_term (reset t) = string_of_term t.

  Proof.
    intro t; pattern t; apply term_ind_forall; clear t; intros; unfold reset.
    simpl. unfold swap, single. rewrite (beq_refl beq_nat_ok). refl.
    rewrite sub_fun1, !string_of_term_fun1, var_fun1. fold (reset t).
    rewrite H. refl.
  Qed.

  Lemma srule_of_rule_reset :
    forall a, srule_of_rule (reset_rule a) = srule_of_rule a.

  Proof.
    intros [l r]. unfold srule_of_rule, reset_rule. simpl.
    rewrite !string_of_term_reset. refl.
  Qed.

  Lemma srs_of_trs_reset : forall R, srs_of_trs (reset_rules R) = srs_of_trs R.

  Proof.
    unfold srs_of_trs, reset_rules. induction R; simpl; intros. refl.
    rewrite IHR, srule_of_rule_reset. refl.
  Qed.

  Section reset.

    Variables (R : rules) (h1 : rules_preserve_vars R)
      (h2 : forall l r, List.In (mkRule l r) R -> maxvar l = 0).

    Lemma red_of_sred_reset : forall t u,
      Srs.red (srs_of_trs R) t u -> red R (term_of_string t) (term_of_string u).

    Proof.
      intros. Srs.redtac. subst. rewrite !term_of_string_fill.
      destruct (in_map_elim H). destruct H0. destruct x as [l' r'].
      unfold srule_of_rule in H1. simpl in H1. inversion H1.
      rewrite !term_of_string_epi. 3:{ eapply h2. apply H0. }
      2:{ ded (h2 _ _ H0). cut (maxvar r' <= maxvar l'). lia.
      rewrite !maxvar_lmax. apply incl_lmax. apply h1. hyp. }
      apply red_rule. hyp.
    Qed.

  End reset.

(***********************************************************************)
(** rewriting *)

  Section sred_of_red.

    Variables (R : rules) (hR : rules_preserve_vars R).

    Lemma sred_of_red : forall t u,
      red R t u -> Srs.red (srs_of_trs R) (string_of_term t) (string_of_term u).

    Proof.
      intros. rewrite (red1_ok is_unary_sig hR) in H. destruct H. decomp H.
      rewrite H0; clear H0. rewrite H3; clear H3.
      rewrite !string_of_term_fill, !string_of_cont_comp, !string_of_cont_cont.
      simpl. rewrite <- !app_nil_end.
      set (c := SContext.mkContext (string_of_cont x1) (string_of_cont x2)).
      change (Srs.red (srs_of_trs R) (SContext.fill c (string_of_term x))
        (SContext.fill c (string_of_term x0))). apply Srs.red_rule. clear c.
      change (List.In (srule_of_rule (mkRule x x0)) (srs_of_trs R)).
      apply in_map. hyp.
    Qed.

    Lemma rtc_sred_of_red : forall t u, red R # t u ->
      Srs.red (srs_of_trs R) # (string_of_term t) (string_of_term u).

    Proof.
      induction 1. apply rt_step. apply sred_of_red. hyp.
      apply rt_refl. apply rt_trans with (string_of_term y); hyp.
    Qed.

    Lemma red_of_sred : forall t u,
      Srs.red (srs_of_trs R) t u -> red R (term_of_string t) (term_of_string u).

    Proof.
      intros. rewrite red_reset. apply red_of_sred_reset.
      apply rules_preserve_vars_reset. hyp. intros. destruct (in_map_elim H0).
      destruct H1. unfold reset_rule in H2. inversion H2. rewrite maxvar_var.
      rewrite var_reset. refl. hyp. hyp. rewrite srs_of_trs_reset. hyp. hyp.
      hyp.
    Qed.

    Lemma rtc_red_of_sred : forall t u, Srs.red (srs_of_trs R) # t u ->
      red R # (term_of_string t) (term_of_string u).

    Proof.
      induction 1. apply rt_step. apply red_of_sred. hyp.
      apply rt_refl. apply rt_trans with (term_of_string y); hyp.
    Qed.

  End sred_of_red.

(***********************************************************************)
(** reflexion of termination *)

  Variables (R : rules) (hR : rules_preserve_vars R).

  Section red_mod.

    Variables (E : rules) (hE : rules_preserve_vars E).

    Lemma sred_mod_of_red_mod : forall x y, red_mod E R x y -> Srs.red_mod
      (srs_of_trs E) (srs_of_trs R) (string_of_term x) (string_of_term y).

    Proof.
      intros. do 2 destruct H. exists (string_of_term x0). split.
      apply (rtc_sred_of_red hE). hyp. apply (sred_of_red hR). hyp.
    Qed.

    Lemma WF_red_mod_of_WF_sred_mod :
      WF (Srs.red_mod (srs_of_trs E) (srs_of_trs R)) -> WF (red_mod E R).

    Proof.
      unfold WF. intro H.
      cut (forall s t, s = string_of_term t -> SN (red_mod E R) t).
      intros. apply H0 with (string_of_term x). refl.
      intro s. gen (H s). induction 1. intros. apply SN_intro. intros.
      apply H1 with (string_of_term y). 2: refl. subst x.
      apply sred_mod_of_red_mod. hyp.
    Qed.

(***********************************************************************)
(** preservation of termination *)

    Lemma red_mod_of_sred_mod : forall t u,
      Srs.red_mod (srs_of_trs E) (srs_of_trs R) t u ->
      red_mod E R (term_of_string t) (term_of_string u).

    Proof.
      intros. do 2 destruct H. exists (term_of_string x); split.
      apply rtc_red_of_sred; hyp. apply red_of_sred; hyp.
    Qed.

    Lemma WF_sred_mod_of_WF_red_mod :
      WF (red_mod E R) -> WF (Srs.red_mod (srs_of_trs E) (srs_of_trs R)).

    Proof.
      intros H. cut (forall t, SN (red_mod E R) t -> forall s,
      t = term_of_string s -> SN (Srs.red_mod (srs_of_trs E) (srs_of_trs R)) s).
      intros. intro s. apply H0 with (term_of_string s). apply H. refl.
      induction 1. intros. subst. apply SN_intro; intros.
      apply H1 with (term_of_string y). apply red_mod_of_sred_mod. hyp. refl.
    Qed.

    Lemma WF_red_mod :
      WF (red_mod E R) <-> WF (Srs.red_mod (srs_of_trs E) (srs_of_trs R)).

    Proof.
      split; intro. apply WF_sred_mod_of_WF_red_mod. hyp.
      apply WF_red_mod_of_WF_sred_mod. hyp.
    Qed.

  End red_mod.

  Lemma WF_red : WF (red R) <-> WF (Srs.red (srs_of_trs R)).

  Proof.
    rewrite <- red_mod_empty, <- Srs.red_mod_empty. apply WF_red_mod.
    unfold rules_preserve_vars. simpl. tauto.
  Qed.

End S.

(***********************************************************************)
(** signature functor *)

Module Make (S : ASignature.FSIG) <: VSignature.FSIG.
  Definition Sig := SSig_of_ASig S.Sig.
  Definition Fs := S.Fs.
  Definition Fs_ok := S.Fs_ok.
End Make.

(***********************************************************************)
(** tactics for Rainbow *)

From CoLoR Require Import AVariables.

Ltac as_srs_cond Fs_ok :=
  match goal with
    | |- is_unary _ => is_unary Fs_ok
    | |- rules_preserve_vars _ => rules_preserve_vars
    | |- WF _ => idtac
  end.

Ltac as_srs Fs_ok :=
  (rewrite WF_red_mod || rewrite WF_red); as_srs_cond Fs_ok.


(** * VLisp: a verified Lisp

This is a Coq source file, documented and annotated using
_coqdoc_. It aims to document the semantics and syntax of a
formally-verified Lisp, built from McCarthy's Equations of
Software.

The Lisp 1.5 manual distinguishes between two types of
expressions. _S-expressions_ are the symbolic expressions that
comprise Lisp programs; _M-expressions_ are the _source language which
specifies in what way the S-expressions are to be processed_. It is
the job of the interpreter to convert S-expressions into
M-expressions; this program will attempt to codify a representation of
M-expressions.

*)

(* begin hide *)
Require Import Bool.
(*end hide *)

(** ** Symbolic Expressions

Atoms are the basic building blocks of Lisp; the Lisp 1.5 manual notes
the distinction between _atomic symbols_:

<<
Definition: an atomic symbol is a string of no more than thirty
numerals and capital letters; the first character must be a letter.
>>

and _atom_, the predicate:

<<
atom[EXTRALONGSTRINGOFLETTERS]=T
atom[(U . V)]=F
atom[car[(U . V)]]=T
>>

*)

Inductive atomic_symbol : Set :=  .

(** A cell (as represented by an S-expression) contains of a first and second element; it is essentially a tuple (x, y) where x and y may be either an atomic symbol or a cell.*)

Inductive cell : Set := NIL.

(** ** Elementary Functions

_cons_ is used to build S-expressions from atomic symbols and other S-expressions.

<<
cons[A;B]=(A . B)
cons[(A . B);C]=((A . B) . C)
cons[cons[A;B];C]=((A . B) . C)
>>
*)

Definition cons (a b : cell) : cell := NIL.

(** _car_ and _cdr_ do the opposite of _cons_: they extract elements
from an S-expression.

<<
The function car has one argument. Its value is the first part of
its composite argument. car of an atomic symbol is undefined.
>>
*)

Definition car (a : cell) : cell := NIL.

(**
<<
The function cdr has one argument. Its value is the second part of its
composite argument. cdr is also undefined if its argument is atomic.
>>
*)

Definition cdr (a : cell) : cell := NIL.

(**
<<
Given any S-expression, it is possible to produce any subexpression of it by a suitable composition of car's and cdr's. If _x_ and _y_ represent any two S-expressions, the following identities are true:

	car[cons[x;y]]=x
	cdr[cons[x;y]]=y

The following identity is also true for any S-expression x such that x
is composite (non-atomic):

	cons[car[x];cdr[x]]=x

>>
 *)

Theorem car_x_is_x : forall x y : cell, car (cons x y) = x.
Abort.

Theorem cdr_x_is_y : forall x y : cell, cdr (cons x y) = y.
Abort.

(*NOTE: these are candidates for theorems to be proved.*)

(** Variables are used to give names to S-expressions. *)

(**
<<
A function whose value is either true or false is called a
predicate. In LISP the values true and false are represented by the
atomic symbols T and F, respectively. A LISP predicate is therefore a
function whose value is either T or F.

The predicate eq is a test for equality on atomic symbols. It is
undefined for non-atomic arguments.
>>
*)

Inductive pred : atomic_symbol -> bool -> Set :=.
Definition eq  (x y : atomic_symbol) : bool := false.


Require Import ClassicalFacts.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.micromega.Psatz.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.Equivalence.
Require Import VCF.BoubakiWitt.
Require Import VCF.KnasterTarski.
Require Import VCF.InfSem.

Module L.

(** TODO:Dependent **)

Record FixPointTheoremStatement: Type := {
  OrderAssumption: forall A (eqA R: A -> A -> Prop), Type;
  FunctionAssumption: forall A (eqA R: A -> A -> Prop), OrderAssumption A eqA R -> (A -> A) -> Type;
  Fix: forall A (eqA R: A -> A -> Prop)(OA: OrderAssumption A eqA R) (F: A -> A) (F_ass: FunctionAssumption A eqA R OA F),
   A;
  FPSound: forall A (eqA R: A -> A -> Prop) (OA: OrderAssumption A eqA R) (F: A -> A)(F_ass: FunctionAssumption A eqA R OA F),
    eqA (F (Fix A eqA R OA F F_ass)) (Fix A eqA R OA F F_ass);
  FPLeast: forall A (eqA R: A -> A -> Prop) (OA: OrderAssumption A eqA R) (F: A -> A)(F_ass: FunctionAssumption A eqA R OA F),
    forall x, eqA (F x) x -> R (Fix A eqA R OA F F_ass) x
}.

Section Two_d_fixpoint.

Context      {stmt1: FixPointTheoremStatement}
             {stmt2: FixPointTheoremStatement}.

Class Two_d_orderassumption (AB: Type) (eqAB RAB: AB -> AB -> Prop):Type:={
  A:Type;
  B:Type;
  RA: A -> A -> Prop;
  eqA: A -> A -> Prop;
  RB: B -> B -> Prop;
  eqB: B -> B -> Prop;
  projA: AB -> A;
  projB: AB -> B;
  BuildAB: A -> B -> AB;
  CombineAB: forall c, BuildAB (projA c) (projB c) = c;
  SplitA: forall a b, projA (BuildAB a b) = a;
  SplitB: forall a b, projB (BuildAB a b) = b;
  POA: PartialOrder_Setoid RA eqA;
  POB: PartialOrder_Setoid RB eqB;
  EB: Equivalence eqB;
  OA: OrderAssumption stmt1 A eqA RA;
  OB: OrderAssumption stmt2 B eqB RB;
  L1: forall c1 c2, RAB c1 c2 <-> (RA (projA c1) (projA c2) /\ ~ RA (projA c2) (projA c1))\/ (RA (projA c1) (projA c2) /\ RA (projA c2) (projA c1) /\ RB (projB c1)  (projB c2));
  L2: forall c1 c2, eqAB c1 c2 <-> eqA (projA c1) (projA c2) /\ eqB (projB c1) (projB c2);
}.

Class Two_d_functionassumption (AB: Type) (eqAB RAB: AB -> AB -> Prop) (OAB:Two_d_orderassumption AB eqAB RAB)(h: AB -> AB):Type:={
  f: A -> A ;
  g: A -> B -> B;
  Split: forall c, h c = BuildAB (f (projA c)) (g (projA c) (projB c));
  Proper_f: Proper (eqA ==> eqA) f;
  Proper_g: Proper (eqA ==> eqB ==> eqB) g;
  f_ass: FunctionAssumption stmt1 A eqA RA OA f;
  g_ass: forall a, FunctionAssumption stmt2 B eqB RB OB (g a);
}.

Definition Two_d_fix (AB:Type) (eqAB RAB: AB -> AB -> Prop) (OAB:Two_d_orderassumption AB eqAB RAB) (h: AB -> AB) (F_ass: Two_d_functionassumption AB eqAB RAB OAB h):=BuildAB (Fix stmt1 A eqA RA OA f f_ass)
(Fix stmt2 B eqB RB OB (g (Fix stmt1 A eqA RA OA f f_ass)) (g_ass (Fix stmt1 A eqA RA OA f f_ass))).

Theorem Two_d_FPSound (AB:Type) (eqAB RAB: AB -> AB -> Prop) (OAB:Two_d_orderassumption AB eqAB RAB) (h: AB -> AB) (F_ass: Two_d_functionassumption AB eqAB RAB OAB h):
eqAB (h (Two_d_fix AB eqAB RAB OAB h F_ass)) (Two_d_fix AB eqAB RAB OAB h F_ass).
Proof.
  apply L2;split.
  - rewrite Split, SplitA.
    unfold Two_d_fix;rewrite SplitA.
    apply (FPSound stmt1 A eqA RA OA f f_ass).
  - rewrite Split, SplitB.
    unfold Two_d_fix.
    rewrite SplitA, SplitB.
    apply (FPSound stmt2 B eqB RB OB (g (Fix stmt1 A eqA RA OA f f_ass))
    (g_ass (Fix stmt1 A eqA RA OA f f_ass))).
Qed.

Theorem Two_d_FPLeast (AB:Type) (eqAB RAB: AB -> AB -> Prop) (OAB:Two_d_orderassumption AB eqAB RAB) (h: AB -> AB) (F_ass: Two_d_functionassumption AB eqAB RAB OAB h):
forall x, eqAB (h x) x -> RAB (Two_d_fix AB eqAB RAB OAB h F_ass) x.
Proof.
  intros;apply L1.
  pose proof classic (RA (projA x) (projA (Two_d_fix AB eqAB RAB OAB h F_ass))) as H0;destruct H0.
  - right;split.
    + unfold Two_d_fix. rewrite SplitA.
      rewrite L2 in H. destruct H.
      rewrite <- (CombineAB x) in H.
      rewrite Split in H.
      repeat rewrite SplitA in H.
      apply FPLeast. auto.
    + split;eauto.
      rewrite L2 in H;destruct H.
      pose proof FPLeast stmt2 B eqB RB OB (g (projA (Two_d_fix AB eqAB RAB OAB h F_ass))) (g_ass (projA (Two_d_fix AB eqAB RAB OAB h F_ass))) (projB x).
      unfold Two_d_fix. rewrite SplitB.
      unfold Two_d_fix in H2,H0;rewrite SplitA in H2,H0.
      apply H2. clear H2.
      rewrite Split,SplitA in H.
      rewrite Split,SplitB in H1.
      pose proof POA. destruct H2.
      pose proof FPLeast stmt1 A eqA RA OA f f_ass (projA x) H.
      assert (eqA (Fix stmt1 A eqA RA OA f f_ass) (projA x)).
      {apply PO_AntiSymmetric_Setoid;eauto. }
      clear H2 H0 PO_AntiSymmetric_Setoid PO_Reflexive_Setoid PO_Transitive.
      pose proof EB. destruct H0.
      eapply Equivalence_Transitive;[|apply H1].
      apply Proper_g;auto.
   - left;split.
     rewrite L2 in H. destruct H.
     rewrite Split,SplitA in H.
     pose proof FPLeast stmt1 A eqA RA OA f f_ass (projA x) H.
     + unfold Two_d_fix. rewrite SplitA;auto.
     + auto.
Qed.

Definition Two_d_FixPointTheoremStatement:FixPointTheoremStatement:={|
  OrderAssumption:=Two_d_orderassumption;
  FunctionAssumption:=Two_d_functionassumption;
  Fix:=Two_d_fix;
  FPSound:=Two_d_FPSound;
  FPLeast:=Two_d_FPLeast;
|}.

End Two_d_fixpoint.


(* File reduced by coq-bug-finder from original input, then from 669 lines to 79 lines, then from 89 lines to 44 lines *)
Set Primitive Projections.
Reserved Notation "g 'o' f" (at level 40, left associativity).
Inductive paths {A : Type} (a : A) : A -> Type :=
  idpath : paths a a.
Notation "x = y" := (@paths _ x y) : type_scope.

Set Implicit Arguments.

Record PreCategory :=
  Build_PreCategory' {
      object :> Type;
      morphism : object -> object -> Type;

      identity : forall x, morphism x x;
      compose : forall s d d',
                  morphism d d'
                  -> morphism s d
                  -> morphism s d'
                              where "f 'o' g" := (compose f g);

      left_identity : forall a b (f : morphism a b), identity b o f = f
    }.

Hint Rewrite @left_identity. (* stack overflow *)