(*
 * Copyright (c) 2009-2011, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

Require Import VST.msl.base.
Require Import VST.msl.ageable.
Require Import VST.msl.knot.
Require Import VST.msl.knot_hered.
Require Import VST.msl.functors.

Import CovariantFunctor.
Import CovariantFunctorLemmas.
Import CovariantFunctorGenerator.

Module Knot_Lemmas (K : KNOT).
  Import K.TF.
  Import K.

  Lemma unsquash_inj : forall k1 k2,
    unsquash k1 = unsquash k2 ->
    k1 = k2.
  Proof.
(* Goal: None *)
    intros.
(* Goal: None *)
    rewrite <- (squash_unsquash k1).
(* Goal: None *)
    rewrite <- (squash_unsquash k2).
(* Goal: None *)
    rewrite H.
(* Goal: None *)
    trivial.
  Qed.
  Arguments unsquash_inj [k1 k2] _.

  Lemma squash_surj : forall k, exists n, exists Fp,
    squash (n, Fp) = k.
  Proof.
(* Goal: None *)
  intros.
(* Goal: None *)
  remember (unsquash k).
(* Goal: None *)
  destruct p as [n f].
(* Goal: None *)
  exists n.
(* Goal: None *)
  exists f.
(* Goal: None *)
  rewrite Heqp.
(* Goal: None *)
  rewrite squash_unsquash.
(* Goal: None *)
  trivial.
  Qed.

  Lemma unsquash_approx : forall k n Fp,
    unsquash k = (n, Fp) ->
    Fp = fmap F (approx n) Fp.
  Proof.
(* Goal: None *)
    intros.
(* Goal: None *)
    generalize H; intro.
(* Goal: None *)
    rewrite <- (squash_unsquash k) in H.
(* Goal: None *)
    rewrite H0 in H.
(* Goal: None *)
    rewrite unsquash_squash in H.
(* Goal: None *)
    inversion H.
(* Goal: None *)
    rewrite H2.
(* Goal: None *)
    symmetry.
(* Goal: None *)
    trivial.
  Qed.
  Arguments unsquash_approx [k n Fp] _.

  Lemma approx_approx1 : forall m n,
    approx n = approx n oo approx (m+n).
  Proof.
(* Goal: None *)
    intros.
(* Goal: None *)
    extensionality p x; destruct x as [k o].
(* Goal: None *)
    unfold approx, compose; simpl.
(* Goal: None *)
    destruct (le_gt_dec n (level k)); auto.
(* Goal: None *)
    destruct (le_gt_dec (m+n) (level k)); auto.
(* Goal: None *)
    elimtype False; omega.
  Qed.

  Lemma approx_approx2 : forall m n,
    approx n = approx (m+n) oo approx n.
  Proof.
(* Goal: None *)
    intros.
(* Goal: None *)
    extensionality p x; destruct x as [k o].
(* Goal: None *)
    unfold approx, compose; simpl.
(* Goal: None *)
    destruct (le_gt_dec (m+n) (level k)); auto.
(* Goal: None *)
    destruct (le_gt_dec n (level k)); auto.
(* Goal: None *)
    elimtype False; omega.
  Qed.

  (* These are provided since sometimes it is tedious to break things out;
      they are not interesting except as engineering artifacts. *)
  Lemma unsquash_squash_unfolded : forall nf,
    unsquash (squash nf) = (fst nf, fmap F (approx (fst nf)) (snd nf)).
  Proof.
(* Goal: None *)
    intros.
(* Goal: None *)
    destruct nf.
(* Goal: None *)
    apply unsquash_squash.
  Qed.

  Lemma unsquash_approx_unfolded : forall k,
    unsquash k = (fst (unsquash k), fmap F (approx (fst (unsquash k))) (snd (unsquash k))).
  Proof.
(* Goal: None *)
    intros.
(* Goal: None *)
    case_eq (unsquash k); intros.
(* Goal: None *)
    simpl.
(* Goal: None *)
    apply injective_projections; simpl; trivial.
(* Goal: None *)
    apply (unsquash_approx H).
  Qed.

(*
  Lemma unsquash_not_surj :
    (exists rbot : rhs, rbot <> rhs_top) ->
    (exists Fp : F predicate, True) ->
    forall n, exists Fp, forall k, unsquash k <> (n, Fp).
  Proof.
(* Goal: None *)
  intros.
  destruct H as [bot ?].
  destruct H0 as [anF _].
  remember (fun (p : predicate) (w : knot * other) => bot) as badf.
  remember (fmap badf anF) as badF.
  exists badF.
  repeat intro.
  generalize (unsquash_approx H0); intro.
  rewrite HeqbadF in H1.
  replace (fmap (approx n) (fmap badf anF)) with
(* Goal: None *)
    ((fmap (approx n) oo fmap badf) anF) in H1 by trivial.
  rewrite fmap_comp in H1.
  XXXXX  (* Gah, annoying *)
*)

End Knot_Lemmas.

Module KnotHered_Lemmas (K : KNOT_HERED).
  Import K.TF.
  Import K.

  Lemma predicate_eq : forall (p1 p2:predicate),
    proj1_sig p1 = proj1_sig p2 ->
    p1 = p2.
  Proof.
(* Goal: None *)
    intros; destruct p1; destruct p2; simpl in H.
(* Goal: None *)
    subst x0.
(* Goal: None *)
    replace h0 with h by apply proof_irr.
(* Goal: None *)
    auto.
  Qed.

  Lemma unsquash_inj : forall k1 k2,
    unsquash k1 = unsquash k2 ->
    k1 = k2.
  Proof.
(* Goal: None *)
    intros.
(* Goal: None *)
    rewrite <- (squash_unsquash k1).
(* Goal: None *)
    rewrite <- (squash_unsquash k2).
(* Goal: None *)
    rewrite H.
(* Goal: None *)
    trivial.
  Qed.
  Arguments unsquash_inj [k1 k2] _.

  Lemma squash_surj : forall k, exists n, exists Fp,
    squash (n, Fp) = k.
  Proof.
(* Goal: None *)
  intros.
(* Goal: None *)
  remember (unsquash k).
(* Goal: None *)
  destruct p as [n f].
(* Goal: None *)
  exists n.
(* Goal: None *)
  exists f.
(* Goal: None *)
  rewrite Heqp.
(* Goal: None *)
  rewrite squash_unsquash.
(* Goal: None *)
  trivial.
  Qed.

  Lemma unsquash_approx : forall k n Fp,
    unsquash k = (n, Fp) ->
    Fp = fmap F (approx n) Fp.
  Proof.
(* Goal: None *)
    intros.
(* Goal: None *)
    generalize H; intro.
(* Goal: None *)
    rewrite <- (squash_unsquash k) in H.
(* Goal: None *)
    rewrite H0 in H.
(* Goal: None *)
    rewrite unsquash_squash in H.
(* Goal: None *)
    inversion H.
(* Goal: None *)
    rewrite H2.
(* Goal: None *)
    symmetry.
(* Goal: None *)
    trivial.
  Qed.
  Arguments unsquash_approx [k n Fp] _.

  Lemma approx_approx1 : forall m n,
    approx n = approx n oo approx (m+n).
  Proof.
(* Goal: None *)
    intros.
    extensionality p.
    apply predicate_eq.
    extensionality x; destruct x as [k o].
    unfold compose.
    repeat rewrite approx_spec.
    apply prop_ext. intuition.
  Qed.

  Lemma approx_approx2 : forall m n,
    approx n = approx (m+n) oo approx n.
  Proof.
(* Goal: None *)
    intros.
    extensionality p. apply predicate_eq.
    extensionality x; destruct x as [k o].
    unfold compose. repeat rewrite approx_spec.
    apply prop_ext. intuition.
  Qed.

  (* These are provided since sometimes it is tedious to break things out;
      they are not interesting except as engineering artifacts. *)
  Lemma unsquash_squash_unfolded : forall nf,
    unsquash (squash nf) = (fst nf, fmap F (approx (fst nf)) (snd nf)).
  Proof.
(* Goal: None *)
    intros.
(* Goal: None *)
    destruct nf.
(* Goal: None *)
    apply unsquash_squash.
  Qed.

  Lemma unsquash_approx_unfolded : forall k,
    unsquash k = (fst (unsquash k), fmap F (approx (fst (unsquash k))) (snd (unsquash k))).
  Proof.
(* Goal: None *)
    intros.
(* Goal: None *)
    case_eq (unsquash k); intros.
(* Goal: None *)
    simpl.
(* Goal: None *)
    apply injective_projections; simpl; trivial.
(* Goal: None *)
    apply (unsquash_approx H).
  Qed.

End KnotHered_Lemmas.
