Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

Require Import Coq.Classes.Morphisms.
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrbool ssrnat.
Require Import Sets Tactics.
Require Import Recdef.
Require Import List.

Require Import ZArith ZArith.Znat Arith.

Require Import Producer Generators Enumerators.

Set Bullet Behavior "Strict Subproofs".

Local Open Scope set_scope.

(** Apply a function n times *)
Fixpoint appn {A} (f : A -> A) (n : nat) : A ->  A :=
  fun x =>
    match n with
      | 0%nat => x
      | S n' => f (appn f n' x)
    end.

Infix "^" := appn (at level 30, right associativity) : fun_scope.

(** Instance Hierarchy

   GenSized
      |
      |
     Gen   Shrink
       \    /
        \  /
      Arbitrary
*)

(** * Generator-related classes *)

(* begin gen_sized_class *)
Class GenSized (A : Type) :=
  { arbitrarySized : nat -> G A }.
(* end gen_sized_class *)

(* begin gen_class *)
Class Gen (A : Type) := { arbitrary : G A }.
(* end gen_class *)

(** Shrink class *)
Class Shrink (A : Type) :=
  { shrink : A -> list A }.

(** Arbitrary Class *)
Class Arbitrary (A : Type) `{Gen A} `{Shrink A}.

Class Fuzzy (A : Type) := { fuzz : A -> G A }.

(* TODO: should be able to fail? i.e. outputs G (option A) instead *)
Class Mutate (A : Type) := { mutate : A -> G A }.

Class EnumSized (A : Type) := { enumSized : nat -> E A }.

Class Enum (A : Type) := { enum : E A }.

Class Sized (A : Type) :=
  { size : A -> nat }.

(* ZP: This is not longer usefull *)
(*
(** * Sizes of types *)

Class Sized (A : Type) :=
  { size : A -> nat }.

Class CanonicalSized (A : Type) `{Sized A} :=
  {
    zeroSized : set A;
    succSized : set A -> set A;

    zeroSized_spec : zeroSized <--> [ set x : A | size x = 0 ];
    succSized_spec :
      forall n, succSized [ set x : A | size x <= n ] <--> [ set x : A | size x <= S n ]

  }.

Lemma size_ind (A : Type) `{Hyp : Sized A} :
  forall (P : A -> Prop), (forall y, (forall x, size x < size y -> P x) -> P y) -> (forall x, P x).
Proof.
  intros P H1.
  intros x.
  assert (Hin : [ set y :  A | size y <= size x] x); eauto.
  revert Hin.
  generalize (size x). intros n.
  revert x. induction n.
  - intros x Hl. apply H1. intros x1 Hlt. ssromega.
  - intros x Hleq. eapply H1. intros x1 Hlt.
    eapply IHn. ssromega.
Qed.

Lemma size_lfp (A : Type) `{Hyp : CanonicalSized A} :
  [set x : A | True ] <--> \bigcup_(s : nat) [set x : A | size x <= s ].
Proof.
  intros a; split; eauto. intros _.
  exists (size a). split; eauto. constructor.
Qed.

Lemma succ_lfp (A : Type) `{Hyp : CanonicalSized A}
      `{Proper _ (respectful set_eq set_eq) succSized} s :
  [set x : A | size x <= s ] <-->  (succSized ^ s) zeroSized.
Proof.
  induction s.
  simpl.
  - rewrite zeroSized_spec.
    split; intros; ssromega.
  - simpl. rewrite <- succSized_spec.
    rewrite IHs. reflexivity.
Qed.
*)
(* Lemma succ_lfp' (A : Type) `{Hyp : CanonicalSized A} : *)
(*   \bigcup_(s : nat)  (succSized ^ s) zeroSized <--> [ set x : A | True ]. *)
(* Proof. *)
(*   intros. split; eauto. *)
(*   intros _. *)
(*   eapply set_eq_trans. *)
(*   Focus 2. symmetry. *)
(*   eapply succ_lfp. *)
(*   simpl.  *)
(*   rewrite succ_lfp at 2. *)
(* split. *)
(*     split. rewrite IHs. firstorder. *)
(*     IHs. *)
(*   firstorder. reflexivity. split; intros; eauto. *)
(*   exists (size a). *)
(*   remember (size a) as s. *)
(*   revert a Heqs. induction s; intros. *)
(*   - split. constructor. *)
(*     simpl. eapply zeroSized_spec. now eauto. *)
(*   - split. constructor. *)
(*     simpl. *)
(*     eapply (succSized_spec. *)
(*     eassumption. *)
(*   eapply size_ind. *)

(*   [set x : A | True ] <-->  . *)

(** * Correctness classes *)

(** Correctness of sized generators *)

Class CorrectSized {A : Type} {G} `{Producer G} (g : nat -> G A)  :=
  { prodCorrectSized :
      [ set n | exists s, semProd (g s) n ] <--> [set : A]
  }.

(** Correctness of generators *)
Class Correct (A : Type) {G} `{Producer G} (g : G A)  :=
  {
    prodCorrect : semProd g <--> [set : A]
  }.

(** * Monotonic generators *)

(** Monotonicity of size parametric generators *)
Class GenSizedMonotonic (A : Type) `{GenSized A}
      `{forall s, SizeMonotonic (arbitrarySized s)}.

(** Monotonicity of size parametric generators v2 *)
Class GenSizedSizeMonotonic (A : Type) `{GenSized A}
        `{SizedMonotonic A G arbitrarySized}.

Class GenMonotonic (A : Type) `{Gen A} `{@SizeMonotonic A G ProducerGen arbitrary}.

(** Monotonicity of size parametric generators *)
Class EnumSizedMonotonic (A : Type) `{EnumSized A}
      `{forall s, @SizeMonotonic A E ProducerEnum (enumSized s)}.

(** Monotonicity of size parametric generators v2 *)
Class EnumSizedSizeMonotonic (A : Type) `{EnumSized A}
        `{@SizedMonotonic A E ProducerEnum enumSized}.

Class EnumMonotonic (A : Type) `{Enum A}
        `{@SizeMonotonic A E ProducerEnum enum}.

(** * Correct generators *)

Class GenSizedCorrect (A : Type) `{GenSized A}
      `{@CorrectSized A G ProducerGen arbitrarySized}.

Class GenCorrect (A : Type) `{Gen A}
        `{@Correct A G ProducerGen arbitrary}.

(* Monotonic and Correct generators *)
Class GenMonotonicCorrect (A : Type)
      `{Gen A}
      `{@SizeMonotonic A G ProducerGen arbitrary}
      `{@Correct  A G ProducerGen arbitrary}.

Class EnumSizedCorrect (A : Type)
        `{EnumSized A} `{@CorrectSized A E ProducerEnum enumSized}.

Class EnumCorrect (A : Type) `{Enum A}
        `{@Correct A E ProducerEnum enum}.

(* Monotonic and Correct generators *)
Class EnumMonotonicCorrect (A : Type)
      `{Enum A}
      `{@SizeMonotonic A E ProducerEnum enum}
      `{@Correct A E ProducerEnum enum}.

(** Coercions *)

#[global] Instance GenSizedMonotonicOfSizeMonotonic
         (A : Type) (Hgen : GenSized A) (Hmon : forall s, @SizeMonotonic A G ProducerGen (arbitrarySized s))
: @GenSizedMonotonic A Hgen Hmon := {}.

#[global] Instance GenMonotonicOfSizeMonotonic
         (A : Type) (Hgen : Gen A) (Hmon : @SizeMonotonic A G ProducerGen arbitrary)
: @GenMonotonic A Hgen Hmon := {}.

#[global] Instance GenSizedCorrectOfSizedCorrect
         (A : Type) (Hgen : GenSized A)
         `{Hcor : @CorrectSized A G ProducerGen arbitrarySized}
: @GenSizedCorrect A Hgen Hcor := {}.

#[global] Instance GenMonotonicCorrectOfMonotnicCorrect
         (A : Type) (Hgen : Gen A)
         (Hmon : @SizeMonotonic A G ProducerGen arbitrary)
         `{Hcor : @Correct A G ProducerGen arbitrary}
  : @GenMonotonicCorrect A Hgen Hmon Hcor := {}.

#[global] Instance GenSizedSizeMonotonicOfSizedMonotonic
         (A : Type) (Hgen : GenSized A) (Hmon : @SizedMonotonic A G ProducerGen arbitrarySized)
: @GenSizedSizeMonotonic A Hgen ProducerGen Hmon := {}.

#[global] Instance GenOfGenSized {A} `{GenSized A} : Gen A :=
  {| arbitrary := sized arbitrarySized |}.

#[global] Instance ArbitraryOfGenShrink {A} `{Gen A} `{Shrink A} : Arbitrary A := {}.

Generalizable Variables PSized PMon PSMon PCorr.

#[global] Instance GenMonotonicOfSized (A : Type)
         `{H : GenSized A}
         `{@GenSizedMonotonic A H PMon}
         `{@GenSizedSizeMonotonic A H ProducerGen PSMon}
  : @GenMonotonic A
                  (@GenOfGenSized A H)
                  (@sizedSizeMonotonic G ProducerGen _ A
                                       (@arbitrarySized A H)
                                       PMon PSMon) := {}.

#[global] Instance GenCorrectOfSized (A : Type)
         {H : GenSized A}
         `{@GenSizedMonotonic A H PMon}
         `{@GenSizedSizeMonotonic A H ProducerGen PSMon}
         `{@GenSizedCorrect A H PCorr} : Correct A arbitrary.
Proof.
  constructor. unfold arbitrary, GenOfGenSized.
  eapply set_eq_trans.
  - eapply semSized_alt; now eauto with typeclass_instances.
  - destruct PCorr.
    rewrite <- prodCorrectSized0.

    split. intros [n [? H3]]. eexists. eassumption.

    intros [s H4]. eexists; split; eauto. reflexivity.
Qed.

(*
Lemma nat_set_ind (A : Type) `{GenSized A} `{Hyp : CanonicalSized A} :
  (semProd (arbitrarySized 0) <--> zeroSized) ->
  (forall (s : nat) (elems : set A),
     semProd (arbitrarySized s) <--> elems ->
     semProd (arbitrarySized (s.+1)) <--> succSized elems) ->
  (forall s : nat, semProd (arbitrarySized s) <--> (fun x : A => size x <= s)).
Proof.
  intros HO IH. intros n; induction n.
  - eapply set_eq_trans with (B := (fun x : A => size x = 0)).
    rewrite -zeroSized_spec //=.
    intros s. destruct (size s). now firstorder.
    split; intros; ssromega.
  - rewrite -succSized_spec. eauto.
Qed.
 *)

#[global] Instance EnumSizedMonotonicOfSizeMonotonic
         (A : Type) (Hgen : EnumSized A) (Hmon : forall s, @SizeMonotonic A E ProducerEnum (enumSized s))
: @EnumSizedMonotonic A Hgen Hmon := {}.

#[global] Instance EnumMonotonicOfSizeMonotonic
         (A : Type) (Hgen : Enum A) (Hmon : @SizeMonotonic A E ProducerEnum enum)
: @EnumMonotonic A Hgen Hmon := {}.

#[global] Instance EnumSizedCorrectOfSizedCorrect
         (A : Type) (Hgen : EnumSized A)
         `{Hcor : @CorrectSized A E ProducerEnum enumSized}
: @EnumSizedCorrect A Hgen Hcor := {}.

#[global] Instance EnumCorrectOfCorrect
         (A : Type) (Hgen : Enum A)
         `{Hcor : @Correct A E ProducerEnum enum}
: @EnumCorrect A Hgen Hcor := {}.

#[global] Instance EnumMonotonicCorrectOfMonotnicCorrect
         (A : Type) (Hgen : Enum A)
         (Hmon : @SizeMonotonic A E ProducerEnum enum)
         `{Hcor : @Correct A E ProducerEnum enum}
  : @EnumMonotonicCorrect A Hgen Hmon Hcor := {}.

#[global] Instance EnumSizedSizeMonotonicOfSizedMonotonic
         (A : Type) (Hgen : EnumSized A) (Hmon : @SizedMonotonic A E ProducerEnum enumSized)
: @EnumSizedSizeMonotonic A Hgen Hmon := {}.

#[global] Instance EnumOfEnumSized {A} `{EnumSized A} : Enum A :=
  {| enum := sized enumSized |}.

(*
#[global] Instance EnumOfGenShrink {A} `{Gen A} `{Shrink A} : Arbitrary A := {}.
 *)

#[global] Instance EnumMonotonicOfSized (A : Type)
         `{H : EnumSized A}
         `{@EnumSizedMonotonic A H PMon}
         `{@EnumSizedSizeMonotonic A H PSMon}
  : @EnumMonotonic A
                  (@EnumOfEnumSized A H)
                  (@sizedSizeMonotonic E ProducerEnum _ A
                                       (@enumSized A H)
                                       PMon PSMon) := {}.

#[global] Instance EnumCorrectOfSized' (A : Type)
         {H : EnumSized A}
         `{@EnumSizedMonotonic A H PMon}
         `{@EnumSizedSizeMonotonic A H PSMon}
         `{@EnumSizedCorrect A H PCorr} : Correct A enum.
Proof.
  constructor. unfold arbitrary, EnumOfEnumSized.
  eapply set_eq_trans.
  - eapply semSized_alt; eauto with typeclass_instances.
  - destruct PCorr.
    rewrite <- prodCorrectSized0.

    split. intros [n [? H3]]. eexists. eassumption.

    intros [s H4]. eexists; split; eauto. reflexivity.
Qed.

#[global] Instance EnumCorrectOfSized (A : Type)
         (H1 : EnumSized A)
         (H3 : forall s : nat, SizeMonotonic (enumSized s))
         (H4 : SizedMonotonic enumSized)
         (H5 : CorrectSized enumSized)
  : Correct A enum.
Proof.
  eapply EnumCorrectOfSized'; eauto.
  constructor; eauto.
  constructor; eauto.
  constructor; eauto.
Qed.

Lemma enumerating_complete A (e : E A) {Hc : Correct A e} ch :
  (exists x, ch x = Some true) ->
  exists s, enumerating e ch s = Some true.
Proof.
  intros [x Hch].
  unfold enumerating.
  assert (Hin : semProd e x).
  { eapply Hc. reflexivity. }
  destruct Hin as [s [_ Hsem]]. simpl in *.
  unfold semEnumSize in *.
  exists s. revert Hsem.
  generalize (Enumerators.run e s), false.
  induction l; intros b Hin; inv Hin; simpl.
  - rewrite Hch. reflexivity.
  - destruct (ch a); eauto.
    destruct b0; eauto.
Qed.

Lemma lazylist_backtrack_opt_is_true A (l: LazyList.LazyList (option A)) ch b :
  lazylist_backtrack_opt l ch true = Some b -> b = true.
Proof.
  induction l.
  - simpl. congruence.
  - simpl in *.
    destruct a.
    + destruct (ch a) eqn:Heq. destruct b0. congruence.
      now eauto. now eauto.
    + eauto.
Qed.

Lemma lazylist_backtrack_opt_is_false A (l: LazyList.LazyList (option A)) ch b :
  lazylist_backtrack_opt l ch b = Some false -> b = false.
Proof.
  revert b; induction l; intros b.
  - simpl. destruct b; try congruence.
  - simpl in *.
    destruct a.
    + destruct (ch a) eqn:Heq. destruct b0. congruence.
      now eauto. intros Hin. eapply H in Hin. congruence.
    + intros Hn. eapply lazylist_backtrack_opt_is_true in Hn.
      congruence.
Qed.

Lemma lazylist_backtrack_opt_true A (l: LazyList.LazyList (option A)) ch b :
  lazylist_backtrack_opt l ch b = Some true <->
  exists x, LazyList.In_ll (Some x) l /\ ch x = Some true.
Proof.
  revert b; induction l; intros b.
  - simpl. split; intros Hc; try congruence.
    destruct b; congruence.
    destruct Hc. inv H; exfalso; eauto.
  - split.
    + intros Hl.
      simpl in *. destruct a.
      destruct (ch a) eqn:Heq.
      * destruct b0.
        -- eexists. split; eauto.
        -- eapply H in Hl. destruct Hl. inv H0.
           eexists; split; eauto.
      * eapply H in Hl. destruct Hl. inv H0.
        eexists; split; eauto.
      * eapply H in Hl. destruct Hl. inv H0.
        eexists; split; eauto.
    + intros Hc; inv Hc. inv H0. simpl in *. destruct a.
      * inv H1. inv H3. rewrite H2. reflexivity.
        destruct (ch a) eqn:Heq. destruct b0. reflexivity.
        eapply H. eexists. now split; eauto.
        eapply H. eexists. now split; eauto.
      * inv H1. congruence. eapply H. eexists. now split; eauto.
Qed.

Lemma lazylist_backtrack_opt_false A (l: LazyList.LazyList (option A)) ch :
  lazylist_backtrack_opt l ch false = Some false <->
  (forall x, LazyList.In_ll (Some x) l -> ch x = Some false) /\
  ~ LazyList.In_ll None l.
Proof.
  induction l.
  - simpl. split; intros Hc.
    split; eauto. intros. now inv H.
    reflexivity.
  - split.
    + intros Hl.
      simpl in *.
      destruct a.
      * destruct (ch a) eqn:Heq. destruct b.
        congruence.

        -- eapply H in Hl. inv Hl.
           split.
           intros. inv H2; eauto. inv H3. eassumption.

           intros Hc; inv Hc. congruence. eauto.

        -- eapply lazylist_backtrack_opt_is_false in Hl. congruence.

      * eapply lazylist_backtrack_opt_is_false in Hl. congruence.

    + intros [H1 H2].
      simpl.
      destruct a.
      * destruct (ch a) eqn:Heq. destruct b.
        rewrite H1 in Heq. congruence.
        now left.
        eapply H. split. intros. eapply H1.
        right. eassumption.
        intros Hc. eapply H2. right. eassumption.
        rewrite H1 in Heq. congruence. now left.

      * exfalso. eapply H2. now left.
Qed.

Lemma enumeratingOpt_monotonic A (e : E (option A))
      {Hc : SizeMonotonicOpt e} {Hfp : SizeFP e}
      ch1 ch2 s1 s2 b :
  (s1 <= s2)%coq_nat ->
  (forall x, ch1 x = Some b -> ch2 x = Some b) ->
  enumeratingOpt e ch1 s1 = Some b ->
  enumeratingOpt e ch2 s2 = Some b.
Proof.
  intros Hleq Hall Hen.

  specialize (Hc _ _ Hleq).
  specialize (Hfp _ _ Hleq).

  unfold enumeratingOpt in *.
  unfold semProdSizeOpt in *. simpl in *.
  unfold semEnumSize in *.
  revert Hc Hfp Hen.

  generalize (run e s1), (run e s2).

  intros l1 l2 Hs1 Hs2 Hl.
  destruct b.

  - eapply lazylist_backtrack_opt_true in Hl.
    destruct Hl. destruct H.

    eapply lazylist_backtrack_opt_true.
    eexists. split.
    eapply Hs1. eassumption.
    eapply Hall. eassumption.

  - eapply lazylist_backtrack_opt_false in Hl.
    destruct Hl.

    eapply lazylist_backtrack_opt_false.

    split. intros x Hin. eapply Hall. eapply H.
    eapply Hs2. eassumption. eassumption.

    intros Hc. eapply H0. eapply Hs2. eassumption. eassumption.
Qed.


Load PredMonad.

(* The satisfiability order on monadic predicates, where leqM P1 P2 means that
anything satisfying P1 satisfies P2; we will require this to be a complete
lattice (meets and joins over arbitrary sets) below *)
Class PredMonadOrder (PM: Type -> Type) : Type :=
  leqP : forall {A}, relation (PM A).

(***
 *** Weak Predicate Monad Axioms (as a Typeclass)
 ***)

(* A weak predicate monad, where impliesP, forallP, and existsP are not quite
equivalent to their corresponding logical connectives; I think this becomes
equivalent to the standard PredMonad class if we require the topology to be
preregular (R1), meaning that every pair of non-equal monadic computations
satisfy, respectively, a pair of monadic predicates that are disjoint. *)

Class WeakPredMonad
      {M: Type -> Type} {PM : Type -> Type}
      {PredMonadRet:MonadRet PM} {PredMonadBind:MonadBind PM}
      {PredMonadEquiv:MonadEquiv PM}
      {MonadRet:MonadRet M} {MonadBind:MonadBind M} {MonadEquiv:MonadEquiv M}
      {PredMonadOrder:@PredMonadOrder PM}
      {PredMonadSatisfaction:@PredMonadSatisfaction M PM}
      {PredMonadForall:@PredMonadForall PM}
      {PredMonadExists:@PredMonadExists PM}
      {PredMonadImplication:@PredMonadImplication PM}
  : Prop :=
  {
    (* Both M and PM must be monads *)
    weakpredmonad_monad_M :> Monad M;
    weakpredmonad_monad_PM :> Monad PM;

    (* The satisfiability order is a partial order w.r.t. eqM *)
    weakpredmonad_leqP_preorder :> forall {A}, PreOrder (leqP (A:=A));
    weakpredmonad_leqP_antisymmetric :>
      forall {A}, Antisymmetric (eqM (A:=A)) leqP;
    weakpredmonad_leqP_proper :>
      forall {A}, Proper (eqM (A:=A) ==> eqM (A:=A) ==> impl) leqP;

    (* Satisfaction is monotone with respect to the satisfiability order *)
    weakpredmonad_satisfiesP_monotone :>
      forall {A}, Proper (eqM (A:=A) ==> leqP ==> impl) satisfiesP;

    (* Forall and exists are complete meet and join operators, respectively *)
    weakpredmonad_forallP_lower_bound :
      forall {A B} (f: A -> PM B) a, leqP (forallP f) (f a);
    weakpredmonad_forallP_greatest_lower_bound :
      forall {A B} (f: A -> PM B) P,
        (forall a, leqP P (f a)) -> leqP P (forallP f);
    weakpredmonad_existsP_upper_bound :
      forall {A B} (f: A -> PM B) a, leqP (f a) (existsP f);
    weakpredmonad_existsP_least_upper_bound :
      forall {A B} (f: A -> PM B) P,
        (forall a, leqP (f a) P) ->  leqP (existsP f) P;

    (* The fact that true always holds and false never does is equivalent to the
    existence, for each m, of predicates that m does and does not satisfy,
    respectively. We state the latter property as an axiom, and the former
    properties follow from them. *)
    weakpredmonad_separation :
      forall {A} (m:M A), exists P1 P2, m |= P1 /\ ~(m |= P2);

    (* Implication makes a predicate monad into a complete Heyting algebra,
    which means there is a Galois connection between implication and the andP
    operation.  Note that this is weaker than making PM a Boolean algebra,
    which would be inherently non-constructive. *)
    weakpredmonad_heyting_algegbra :
      forall {A} (P1 P2 P3: PM A),
        leqP (andP P1 P2) P3 <-> leqP P1 (impliesP P2 P3);

    (* Return in the predicate monad precisely characterizes return in M *)
    weakpredmonad_return_return :
      forall {A} (x:A) m, m |= returnM x <-> m == returnM x;

    weakpredmonad_bind_bind :
      forall {A B} (m:M B) (P: PM A) (Q: A -> PM B),
        m |= bindM P Q <->
        (exists (phi:A -> Prop) (m': M {x:A | phi x}) (f : A -> M B),
           (bindM m' (fun x => returnM (proj1_sig x))) |= P /\
           (forall x, phi x -> f x |= Q x) /\
           eqM m (bindM m' (fun x => f (proj1_sig x))))

    (* FIXME: need to commute return and bind with logical operators! *)
  }.

(***
 *** Theorems about predicate monads
 ***)

Section WeakPredMonad_thms.

Context `{WeakPredMonad}.

Theorem existsP_exists_weak {A B} m (P: A -> PM B) :
  (exists x, m |= P x) -> m |= existsP P.
  intro H0; destruct H0.
  apply (weakpredmonad_satisfiesP_monotone m m (reflexivity m) (P x));
    [ apply weakpredmonad_existsP_upper_bound | assumption ].
Qed.

Theorem forallP_forall_weak {A B} m (P: A -> PM B) :
  m |= forallP P -> forall x, m |= P x.
  intros.
  apply (weakpredmonad_satisfiesP_monotone m m (reflexivity m) (forallP P));
    [ apply weakpredmonad_forallP_lower_bound | assumption ].
Qed.

Theorem andP_and_weak {A} m (P1 P2: PM A) :
  m |= andP P1 P2 -> m |= P1 /\ m |= P2.
  intros; split.
  apply (weakpredmonad_satisfiesP_monotone m m (reflexivity m) (andP P1 P2));
    [ | assumption ].
  apply (weakpredmonad_forallP_lower_bound
           (fun (b:bool) => if b then P1 else P2) true); assumption.
  apply (weakpredmonad_satisfiesP_monotone m m (reflexivity m) (andP P1 P2));
    [ | assumption ].
  apply (weakpredmonad_forallP_lower_bound
           (fun (b:bool) => if b then P1 else P2) false); assumption.
Qed.

(* FIXME HERE *)
(*
Theorem impliesP_implies {A} m (P1 P2: PM A) :
  m |= impliesP P1 P2 -> m |= P1 -> m |= P2.
  intros.
*)

End WeakPredMonad_thms.


Inductive RoseTree (A : Type) : Type :=
| L : A -> RoseTree A
| N : list (RoseTree A) -> RoseTree A.

Scheme RoseTree_ind' := Induction for RoseTree Sort Prop.

Check RoseTree_ind'.


Require Import List.
Import ListNotations.
Require Import Nat.
Require Import Coq.Program.Wf.
Require Import Coq.omega.Omega.
Require Import FSets FSets.FMapAVL FSets.FMapFacts.
Require Import Ascii.

From Verbatim Require Import ltac.
From Verbatim Require Import Orders.

Module Type SIGMA.
  Parameter Sigma : Type.
  Parameter SigmaEnum : list Sigma.
  Parameter Sigma_finite : forall a, In a SigmaEnum.
  Parameter Sigma_dec : forall(a a' : Sigma), {a = a'} + {a <> a'}.

  Parameter compareT : Sigma -> Sigma -> comparison.
  Parameter compareT_eq : forall x y : Sigma,
      compareT x y = Eq <-> x = y.

  Parameter compareT_trans : forall c x y z,
      compareT x y = c -> compareT y z = c -> compareT x z = c.

  (* This is a bit superfluous and probably needs some validation unless its identity *)
  Parameter ascii2Sigma : ascii -> Sigma.

End SIGMA.

Module DefsFn (Ty : SIGMA).

  Import Ty.

  Module T_as_UCT <: UsualComparableType.
    Definition t             := Sigma.
    Definition compare       := compareT.
    Definition compare_eq    := compareT_eq.
    Definition compare_trans := compareT_trans.
  End T_as_UCT.

  Module T_as_UOT <: UsualOrderedType := UOT_from_UCT T_as_UCT.

  Module SigFS := FSetAVL.Make T_as_UOT.
  Module SigFSF := FSetFacts.Facts SigFS.

  Module SigFM := FMapAVL.Make T_as_UOT.
  Module SigFMF := FMapFacts.Facts SigFM.

  Module Export Strings.

    Set Warnings "-implicit-core-hint-db,-deprecated".
    Hint Resolve Sigma_dec.

    Definition String : Type := list Sigma.

    Lemma String_dec : forall s s' : String, {s = s'} + {s <> s'}.
    Proof. decide equality. Qed.

    (** * *Should deprecate/move String lemmas *)
    Lemma nil_right : forall(s : String), s ++ [] = s.
    Proof.
      induction s.
      - simpl. reflexivity.
      - simpl. rewrite IHs. reflexivity.
    Qed.

    Lemma nil_left : forall(s : String), [] ++ s = s.
    Proof.
      intros s. simpl. reflexivity.
    Qed.

    Lemma empty_app : forall(s1 s2 : String), s1 ++ s2 = [] -> s1 = [] /\ s2 = [].
    Proof.
      intros s1 s2 H. destruct s1; destruct s2; try(simpl in H; discriminate).
      - split; reflexivity.
    Qed.

    Definition rm_empty (yss : list String) :=
      filter (fun l => match l with | [] => false | _ => true end) yss.

    Lemma rm_empty_mute : forall(yss : list String),
        concat (rm_empty yss) = concat yss.
    Proof.
      intros yss. induction yss.
      - simpl. reflexivity.
      - simpl. destruct a.
        + simpl. apply IHyss.
        + simpl. rewrite IHyss. reflexivity.
    Qed.

    Lemma rm_empty_no_empty : forall(ys : String) (yss : list String),
        In ys (rm_empty yss) -> ys <> [].
    Proof.
      intros ys yss H. unfold not. intros C. rewrite C in H.
      unfold rm_empty in H. induction yss.
      - simpl in H. contradiction.
      - simpl in H. destruct a.
        + apply IHyss in H. contradiction.
        + simpl in H. destruct H.
          * discriminate.
          * apply IHyss in H. contradiction.
    Qed.

    Lemma filtered_subset : forall(xs : String) (yss : list String),
        In xs (rm_empty yss) -> In xs yss.
    Proof.
      intros xs yss. generalize dependent xs. induction yss; intros xs H.
      - simpl in H. contradiction.
      - simpl. destruct a.
        + simpl in H. right. apply IHyss. apply H.
        + simpl in H. destruct H.
          * left. apply H.
          * right. apply IHyss. apply H.
    Qed.

  End Strings.

  Module Export Regexes.

    Inductive regex : Type :=
    | EmptySet
    | EmptyStr
    | Char (t : Sigma)
    | App (r1 r2 : regex)
    | Union (r1 r2 : regex)
    | Star (r : regex).

    Lemma regex_dec : forall r r' : regex, {r = r'} + {r <> r'}.
    Proof. decide equality. Qed.

    (** * *Should rename to re_equal *)
    Fixpoint regex_eq (r1 r2 : regex) : bool :=
      match r1, r2 with
      | EmptyStr, EmptyStr => true
      | EmptySet, EmptySet => true
      | Char a, Char b => if (Ty.Sigma_dec a b) then true else false
      | App x1 y1, App x2 y2 => andb (regex_eq x1 x2) (regex_eq y1 y2)
      | Union x1 y1, Union x2 y2 => andb (regex_eq x1 x2) (regex_eq y1 y2)
      | Star a, Star b => regex_eq a b
      | _, _ => false
      end.

    Lemma regex_eq_correct : forall r1 r2,
        r1 = r2 <-> regex_eq r1 r2 = true.
    Proof.
      induction r1; intros r2; split; intros H; subst; try(auto);
        try(unfold regex_eq in H; repeat dmh; subst; auto; discriminate).
      - simpl. dmg; [reflexivity | contradiction].
      - assert(A1 : regex_eq r1_1 r1_1 = true). apply IHr1_1; reflexivity.
        assert(A2 : regex_eq r1_2 r1_2 = true). apply IHr1_2; reflexivity.
        simpl. rewrite A1. rewrite A2. auto.
      - destruct r2; simpl in H; try(discriminate).
        destruct (regex_eq r1_1 r2_1) eqn:E1; destruct (regex_eq r1_2 r2_2) eqn:E2; try(discriminate).
        apply IHr1_1 in E1. apply IHr1_2 in E2. subst. reflexivity.
      - assert(A1 : regex_eq r1_1 r1_1 = true). apply IHr1_1; reflexivity.
        assert(A2 : regex_eq r1_2 r1_2 = true). apply IHr1_2; reflexivity.
        simpl. rewrite A1. rewrite A2. auto.
      - destruct r2; simpl in H; try(discriminate).
        destruct (regex_eq r1_1 r2_1) eqn:E1; destruct (regex_eq r1_2 r2_2) eqn:E2; try(discriminate).
        apply IHr1_1 in E1. apply IHr1_2 in E2. subst. reflexivity.
      - assert(A : regex_eq r1 r1 = true). apply IHr1; reflexivity.
        simpl. apply A.
      - destruct r2; simpl in H; try(discriminate). apply IHr1 in H. subst; reflexivity.
    Qed.

    Lemma regex_eq_refl : forall e, regex_eq e e = true.
      intros. induction e; auto.
      - simpl. dm.
      - simpl. apply Bool.andb_true_iff. split; auto.
      - simpl. apply Bool.andb_true_iff. split; auto.
    Qed.

    Fixpoint nullable' (r : regex) : bool:=
      match r with
      | EmptySet => false
      | EmptyStr => true
      | Char _ => false
      | App r1 r2 => andb (nullable' r1) (nullable' r2)
      | Union r1 r2 => orb (nullable' r1) (nullable' r2)
      | Star _ => true
      end.

    Fixpoint nullable (r : regex) : bool:=
      match r with
      | EmptySet => false
      | EmptyStr => true
      | Char _ => false
      | App r1 r2 => if negb (nullable r2) (* short circuit and *)
                    then false
                    else (nullable r1)
      | Union r1 r2 => if (nullable r2)    (* short circuit or *)
                      then true
                      else (nullable r1)
      | Star _ => true
      end.

    Fixpoint derivative (a : Sigma) (r : regex) :=
      match r with
      | EmptySet => EmptySet
      | EmptyStr => EmptySet
      | Char x => if Ty.Sigma_dec x a then EmptyStr else EmptySet
      | App r1 r2 => if (nullable r1) then Union (App (derivative a r1) r2) (derivative a r2)
                    else (App (derivative a r1) r2)
      | Union r1 r2 => Union (derivative a r1) (derivative a r2)
      | Star r => App (derivative a r) (Star r)
      end.

    Fixpoint derivative_list (bs : list Sigma) (e : regex) :=
      match bs with
      | [] => e
      | c :: cs => derivative_list cs (derivative c e)
      end.

    Fixpoint re_compare (e1 e2 : regex) : comparison :=
      match e1, e2 with
      | EmptyStr, EmptyStr => Eq
      | EmptyStr, _ => Lt
      | _, EmptyStr => Gt
      | EmptySet, EmptySet => Eq
      | EmptySet, _ => Lt
      | _, EmptySet => Gt
      | Char a, Char b => compareT a b
      | Char _, _ => Lt
      | _, Char _ => Gt
      | App e1 e2, App e3 e4 =>
        match re_compare e1 e3 with
        | Eq => re_compare e2 e4
        | comp => comp
        end
      | App _ _, _ => Lt
      | _, App _ _ => Gt
      | Star e1, Star e2 => re_compare e1 e2
      | Star _, _ => Lt
      | _, Star _ => Gt
      | Union e1 e2, Union e3 e4 =>
        match re_compare e1 e3 with
        | Eq => re_compare e2 e4
        | comp => comp
        end
      end.

    Lemma re_compare_eq : forall x y : regex, re_compare x y = Eq <-> x = y.
    Proof.
      induction x; destruct y; split;
        try(reflexivity);
        try(simpl; intros; discriminate).
      - simpl. intros. apply compareT_eq in H. subst. auto.
      - simpl. intros. injection H; intros; subst. apply compareT_eq. auto.
      - intros. specialize (IHx1 y1). specialize (IHx2 y2). simpl in H.
        destruct (re_compare x1 y1) eqn:E; try(discriminate).
        destruct IHx1. destruct H0. auto. destruct (re_compare x2 y2); try(discriminate).
        destruct IHx2. destruct H0; auto.
      - intros. injection H. intros; subst. simpl.
        destruct (regex_eq y1 y1) eqn:E.
        + apply regex_eq_correct in E. apply IHx1 in E. rewrite E.
          destruct (regex_eq y2 y2) eqn:E1.
          * apply regex_eq_correct in E1. apply IHx2 in E1. auto.
          * apply false_not_true in E1. destruct E1. apply regex_eq_correct. auto.
        + apply false_not_true in E. destruct E. apply regex_eq_correct. auto.
      - intros. specialize (IHx1 y1). specialize (IHx2 y2). simpl in H.
        destruct (re_compare x1 y1) eqn:E; try(discriminate).
        destruct IHx1. destruct H0. auto. destruct (re_compare x2 y2); try(discriminate).
        destruct IHx2. destruct H0; auto.
      - intros. injection H. intros; subst. simpl.
        destruct (regex_eq y1 y1) eqn:E.
        + apply regex_eq_correct in E. apply IHx1 in E. rewrite E.
          destruct (regex_eq y2 y2) eqn:E1.
          * apply regex_eq_correct in E1. apply IHx2 in E1. auto.
          * apply false_not_true in E1. destruct E1. apply regex_eq_correct. auto.
        + apply false_not_true in E. destruct E. apply regex_eq_correct. auto.
      - intros. specialize (IHx y). simpl in H. apply IHx in H. subst. auto.
      - intros. injection H. intros. subst. simpl. apply IHx. auto.
    Qed.

    Lemma re_compare_eq' : forall x,
        re_compare x x = Eq.
    Proof.
      intros. apply re_compare_eq. auto.
    Qed.

    Lemma re_compare_trans : forall c x y z,
        re_compare x y = c -> re_compare y z = c -> re_compare x z = c.
    Proof.
      induction x; destruct y; destruct z; intros; auto;
        try(simpl in *; subst; discriminate).
      - simpl in *. eapply compareT_trans; eauto.
      - simpl in *.
        destruct(re_compare x1 y1) eqn:E; destruct(re_compare x2 y2) eqn:E0;
          destruct(re_compare y1 z1) eqn:E1; destruct(re_compare y2 z2) eqn:E2;
            try(rewrite re_compare_eq in *; subst; repeat rewrite re_compare_eq' in *; auto);
            try(discriminate);
            try(specialize (IHx2 y2 z2); apply IHx2; auto);
            try(rewrite E0; rewrite E1; auto);
            try(rewrite E1; auto);
            try(rewrite E; auto);
            try(specialize (IHx1 y1 z1); rewrite IHx1; [reflexivity|auto|auto]);
            try(subst; specialize (IHx1 y1 z1); specialize (IHx2 y2 z2);
                rewrite IHx1; [reflexivity|auto|auto]); try(discriminate).
      - simpl in *.
        destruct(re_compare x1 y1) eqn:E; destruct(re_compare x2 y2) eqn:E0;
          destruct(re_compare y1 z1) eqn:E1; destruct(re_compare y2 z2) eqn:E2;
            try(rewrite re_compare_eq in *; subst; repeat rewrite re_compare_eq' in *; auto);
            try(discriminate);
            try(specialize (IHx2 y2 z2); apply IHx2; auto);
            try(rewrite E0; rewrite E1; auto);
            try(rewrite E1; auto);
            try(rewrite E; auto);
            try(specialize (IHx1 y1 z1); rewrite IHx1; [reflexivity|auto|auto]);
            try(subst; specialize (IHx1 y1 z1); specialize (IHx2 y2 z2);
                rewrite IHx1; [reflexivity|auto|auto]); try(discriminate).
      - simpl in *. eapply IHx; eauto.
    Qed.

  End Regexes.

  Module regex_as_UCT <: UsualComparableType.
    Definition t := regex.
    Definition compare := re_compare.
    Definition compare_eq := re_compare_eq.
    Definition compare_trans := re_compare_trans.
  End regex_as_UCT.

  Module regex_as_UOT <: UsualOrderedType := UOT_from_UCT regex_as_UCT.

  Module reFS := FSetAVL.Make regex_as_UOT.
  Module reFSF := FSetFacts.Facts reFS.

  Module reFM := FMapAVL.Make regex_as_UOT.
  Module reFMF := FMapFacts.Facts reFM.

  Module Export MatchSpec.

    Inductive exp_match : String -> regex -> Prop :=
    | MEmpty : exp_match [] EmptyStr
    | MChar x : exp_match [x] (Char x)
    | MApp s1 re1 s2 re2
           (H1 : exp_match s1 re1)
           (H2 : exp_match s2 re2) :
        exp_match (s1 ++ s2) (App re1 re2)
    | MUnionL s1 re1 re2
              (H1 : exp_match s1 re1) :
        exp_match s1 (Union re1 re2)
    | MUnionR re1 s2 re2
              (H2 : exp_match s2 re2) :
        exp_match s2 (Union re1 re2)
    | MStar0 re : exp_match [] (Star re)
    | MStarApp s1 s2 re
               (H1 : exp_match s1 re)
               (H2 : exp_match s2 (Star re)) :
        exp_match (s1 ++ s2) (Star re).

    Definition re_equiv (e1 e2 : regex) : Prop :=
      forall z, exp_match z e1 <-> exp_match z e2.

  End MatchSpec.

  Module Export MatchSpecLemmas.

    Theorem nullable_bridge : forall(r : regex),
      true = nullable r <-> exp_match [] r.
    Proof.
      intros r. split; intros H.
      - induction r; try(simpl in H; discriminate).
        + apply MEmpty.
        + simpl in H. destruct (nullable r1); destruct (nullable r2); try(simpl in H; discriminate).
          rewrite <- nil_left with (s := []). apply MApp.
          * apply IHr1. reflexivity.
          * apply IHr2. reflexivity.
        + simpl in H.  destruct (nullable r1); destruct (nullable r2).
          * apply MUnionL. apply IHr1. reflexivity.
          * apply MUnionL. apply IHr1. reflexivity.
          * apply MUnionR. apply IHr2. reflexivity.
          * simpl in H. discriminate.
        + apply MStar0.
      - induction r.
        + inversion H.
        + simpl. reflexivity.
        + inversion H.
        + simpl. inversion H. apply empty_app in H1. destruct H1.
          rewrite H1 in H3. rewrite H5 in H4.
          apply IHr1 in H3. apply IHr2 in H4.
          rewrite <- H3. rewrite <- H4. simpl. reflexivity.
        + simpl. inversion H.
          * apply IHr1 in H2. rewrite <- H2. destruct (nullable r2); simpl; reflexivity.
          * apply IHr2 in H1. rewrite <- H1. destruct (nullable r1); simpl; reflexivity.
        + simpl. reflexivity.
    Qed.

    Theorem nullable_bridge' : forall(r : regex),
        nullable r = true <-> exp_match [] r.
    Proof.
      split; intros.
      - symmetry in H. apply nullable_bridge; auto.
      - symmetry. apply nullable_bridge; auto.
    Qed.

    (* star_concat upto concat_star necessary for hard star case of der_match *)
    Lemma star_concat :
      forall s r',
        exp_match s (Star r')
        -> (exists xss : list (list Sigma),
              s = concat xss
              /\ (forall xs,
                    In xs xss
                    -> exp_match xs r')).
    Proof.
      intros s r' hm.
      remember (Star r') as r. generalize dependent r'.
      induction hm; intros r' heq; inv heq.
      - exists []; split; auto.
        intros xs hi; inv hi.
      - destruct (IHhm2 r') as (xss' & heq & hall); subst; auto.
        exists (s1 :: xss'); split; auto.
        intros xs hi.
        destruct hi as [hh| ht]; subst; auto.
    Qed.

    Lemma star_concat_no_empt : forall(s : String) (r' : regex),
        s <> []
        -> exp_match s (Star r')
        -> (exists xss : list (list Sigma),
              s = concat xss
              /\ (forall xs,
                    In xs xss
                    -> exp_match xs r' /\ xs <> [])).
    Proof.
      intros s r' Hempty Hstar. apply star_concat in Hstar.
      destruct Hstar as (yss & heq & hall).
      exists(rm_empty yss). split.
      - rewrite rm_empty_mute. apply heq.
      - intros xs H. split.
        + apply hall.  apply filtered_subset in H. apply H.
        + apply rm_empty_no_empty in H. apply H.
    Qed.

    Lemma concat_star : forall(xss : list String) (r : regex),
        (forall xs : list Sigma, In xs xss -> exp_match xs r) -> exp_match (concat xss) (Star r).
    Proof.
      intros xss r H. induction xss.
      - simpl. apply MStar0.
      - replace (concat (a :: xss)) with (a ++ (concat xss)).
        + apply MStarApp.
          * apply H. simpl. left. reflexivity.
          * apply IHxss. intros xs H1. apply H. simpl. right. apply H1.
        + simpl. reflexivity.
    Qed.

    Theorem der_match : forall(a : Sigma) (s : String) (r : regex),
        exp_match (a::s) r <-> exp_match s (derivative a r).
    Proof.
      intros a s r.
      split.
      {
        generalize dependent s. induction r; intros s H.
        - inv H.
        - inv H.
        - destruct s.
          + simpl. destruct (Sigma_dec t a).
            * apply MEmpty.
            * inv H. contradiction.
          + inv H.
        - simpl. destruct(nullable r1) eqn:E.
          + inv H. destruct s1.
            * apply MUnionR. apply IHr2. rewrite <- H1. simpl. apply H4.
            * apply MUnionL. simpl in H1. injection H1. intros Happ Hchar.
              rewrite <- Happ. rewrite Hchar in H3. apply IHr1 in H3.
              apply MApp.
              -- apply H3.
              -- apply H4.
          + inv H. destruct s1.
            * apply nullable_bridge in H3. rewrite E in H3. discriminate.
            * simpl in H1. injection H1. intros Happ Hchar.
              rewrite <- Happ. rewrite Hchar in H3. apply IHr1 in H3.
              apply MApp.
              -- apply H3.
              -- apply H4.
        - simpl. inv H.
          + apply IHr1 in H2. apply MUnionL. apply H2.
          + apply IHr2 in H1. apply MUnionR. apply H1.
        (* hard_star: This case was the hard one *)
        - apply star_concat_no_empt in H. destruct H as (xss & heq & hall).
          + assert (H : exists(s1 : String) (yss : list String),
                       ((a :: s1) :: yss) = xss).
            {
              destruct xss.
              - simpl in heq. discriminate.
              - simpl in heq. destruct l eqn:E.
                + apply hall in E.
                  * contradiction.
                  * rewrite E. simpl. left. reflexivity.
                + exists(l0). exists(xss). simpl in heq.
                  injection heq. intros I1 I2. rewrite I2. reflexivity.
            }
            destruct H as [s1]. destruct H as [yss].
            rewrite <- H in hall.
            assert (A : In (a :: s1) ((a :: s1) :: yss)).
            { simpl. left. reflexivity. }
            simpl. replace s with (s1 ++ (concat yss)).
            * apply MApp.
              -- apply IHr. apply hall in A. destruct A. apply H0.
              -- rewrite H in hall.
                 assert (A1 : forall xs : list Sigma, In xs xss -> exp_match xs r).
                 { intros xs. intros HA1. apply hall in HA1. destruct HA1. apply H0. }
                 apply concat_star. intros xs H1. apply A1.
                 rewrite <- H. simpl. right. apply H1.
            * assert (A1 : concat ((a :: s1) :: yss) = concat xss).
              { rewrite H. reflexivity. }
              assert (A2 : concat ((a :: s1) :: yss) = a :: (s1 ++ (concat yss))).
              { simpl. reflexivity. }
              rewrite <- A1 in heq. rewrite A2 in heq. injection heq.
              intros I. symmetry. apply I.
          + unfold not. intros C. discriminate.
      }
      {
        generalize dependent s. induction r; intros s H.
        - inv H.
        - inv H.
        - simpl in H. destruct (Sigma_dec t a); inv H. apply MChar.
        - simpl in H. destruct (nullable r1) eqn:E.
          + inv H.
            * inv H2. replace (a :: s1 ++ s2) with ((a :: s1) ++ s2).
              apply MApp.
              -- apply IHr1. apply H3.
              -- apply H4.
              -- reflexivity.
            * symmetry in E. apply nullable_bridge in E. rewrite <- nil_left with (s := (a :: s)).
              apply MApp.
              -- apply E.
              -- apply IHr2. apply H1.
          + inv H.
            * replace (a :: s1 ++ s2) with ((a :: s1) ++ s2).
              apply MApp.
              -- apply IHr1. apply H3.
              -- apply H4.
              -- reflexivity.
        - inv H.
          + apply MUnionL. apply IHr1. apply H2.
          + apply MUnionR. apply IHr2. apply H1.
        - simpl in H. inv H. replace (a :: s1 ++ s2) with ((a :: s1) ++ s2).
          + apply MStarApp.
            * apply IHr. apply H3.
            * apply H4.
          + reflexivity.
      }
    Qed.

    Lemma derivative_list_cons : forall bs b e,
        derivative_list (b :: bs) e = derivative_list bs (derivative b e).
    Proof.
      auto.
    Qed.

    Lemma derivative_list_str : forall bs e,
        exp_match [] (derivative_list bs e) <-> exp_match bs e.
    Proof.
      induction bs; intros; auto.
      - simpl. split; auto.
      - simpl. rewrite IHbs. split; apply der_match.
    Qed.

  End MatchSpecLemmas.

  Module Notations.

    Notation "e1 = e2 " := (regex_eq e1 e2) (at level 70).
    Notation "a ∂ r" := (derivative a r) (at level 75, right associativity).
    Notation ε := EmptyStr.
    Notation "e1 @ e2" := (App e1 e2) (at level 75).
    Notation "e1 # e2" := (Union e1 e2) (at level 75).

  End Notations.

  Module Helpers.

    Definition Plus (r : regex) : regex := App r (Star r).

    Fixpoint IterUnion (rs : list regex) :=
      match rs with
      | [] => EmptySet
      | [e] => e
      | h::t => Union h (IterUnion t)
      end.

    Fixpoint IterApp (rs : list regex) :=
      match rs with
      | [] => EmptyStr
      | [e] => e
      | h::t => App h (IterApp t)
      end.

    (* r? *)
    Definition Optional (r : regex) := Union EmptyStr r.

    Definition REString (z : String) := IterApp (map Char z).

  End Helpers.

End DefsFn.

Module Type DefsT (Ty : SIGMA).
  Include DefsFn Ty.
End DefsT.

Module Type T.
  Declare Module Ty : SIGMA.
  Declare Module Defs  : DefsT Ty.
  Export Defs.
End T.

Module regexTFn (Ty' : SIGMA) <: T.

  Module Export Ty := Ty'.
  Module Export Defs := DefsFn Ty.

End regexTFn.


Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.
Require Import List. Import ListNotations.
Require Import sha.general_lemmas.
Require Import sha.hmac_pure_lemmas.
Require Import sha.SHA256.
Require Import sha.pure_lemmas.
Require Import sha.functional_prog.
Require Import Lia.

(* Lemma 1: M = Prefix(Pad(M)) *)

(* TODO: replace InWords with InBlocks 4? *)
Inductive InWords : list byte -> Prop :=
  | words_nil : InWords []
  | words_word : forall (a b c d : byte) (msg : list byte),
                   InWords msg -> InWords (a :: b :: c :: d :: msg).

(* *** New definition for this lemma. *)
Definition pad (msg : list byte) : list byte :=
  let n := Zlength msg in
  msg ++ [Byte.repr 128%Z]
      ++ repeat Byte.zero (Z.to_nat (-(n + 9) mod 64))
      ++ intlist_to_bytelist (([Int.repr (n * 8 / Int.modulus); Int.repr (n * 8)])%list).

Definition generate_and_pad' (msg : list byte) : list int :=
  bytelist_to_intlist (pad msg).

(* ----------------- ^ Definitions *)

Lemma fstpad_len :
  forall (msg : list byte),
    Datatypes.length (msg ++ [Byte.repr 128]
                 ++ repeat Byte.zero (Z.to_nat (- (Zlength msg + 9) mod 64)))
= (Datatypes.length msg + (S (Z.to_nat (- (Zlength msg + 9) mod 64))))%nat.
Proof.
  intros msg.
  simpl.
  rewrite -> app_length.
  simpl.
  rewrite -> repeat_length.
  reflexivity.
Qed.

Lemma InWords_len4 : forall (l : list byte),
                       Nat.divide (Z.to_nat WORD) (length l) -> InWords l.
Proof.
  intros l [x H].
  revert l H.
  induction x.
  intros l H. simpl in H.
  destruct l.
    apply words_nil.
    simpl in H. inversion H.
  intros l H.
  destruct l as [ | a [ | b [ | c [ | d ? ]]]].
    inversion H.
    inversion H.
    inversion H.
    inversion H.
    specialize (IHx l).
      apply words_word.
      apply IHx.
      simpl in H. inversion H.
      simpl. apply H1.
Qed.

(* TODO: clear out the SearchAbouts / clean up proof *)
Lemma pad_len_64_mod : forall (msg : list byte),
                           (Zlength (pad msg)) mod 64 = 0.
Proof.
  intros msg.
  unfold pad.
  rewrite -> Zlength_correct.
  repeat rewrite -> app_length.
  simpl.
  assert (succ: forall (n : nat), S n = (n + 1)%nat).
    intros. induction n. reflexivity. lia.
  rewrite -> succ.
  assert ((length msg +
      (length (repeat Byte.zero (Z.to_nat (- (Zlength msg + 9) mod 64))) + 8 +
       1))%nat = (length msg +
      (length (repeat Byte.zero (Z.to_nat (- (Zlength msg + 9) mod 64))) + 9))%nat) by lia.
  rewrite -> H. clear H.

  rewrite -> Zlength_correct.
  rewrite -> repeat_length.

  repeat rewrite -> Nat2Z.inj_add.
  rewrite -> Z2Nat.id.

  assert (move : forall (a b c : Z), a + (b + c) = (a + c) + b).
  intros. lia.

  rewrite -> move.
  rewrite -> Zplus_mod_idemp_r.

  assert (Z_9 : 9 = Z.of_nat (9%nat)). reflexivity.
  rewrite -> Z_9.

  repeat rewrite <- Nat2Z.inj_add.

  assert (forall (x : Z), x + (-x) = 0). intros. lia.

  rewrite -> H.
  reflexivity.

  * apply Z.mod_pos_bound.
    lia.
Qed.

(* more usable versions *)
Lemma pad_len_64 : forall (msg : list byte), exists (n : Z),
                           Zlength (pad msg) = 64 * n /\ n >= 0.
Proof.
  intros msg.
  pose proof pad_len_64_mod msg as pad_len_mod.
  rewrite -> Zmod_divides in *. 2: lia.

  destruct pad_len_mod.
  exists x.
  split.
  apply H.
  specialize (Zlength_nonneg (pad msg)); intros. lia.
Qed.

Lemma pad_len_64_nat : forall (msg : list byte), exists (n : nat),
                           (length (pad msg))%nat = (64 * n)%nat.
Proof.
  intros msg.
  pose proof pad_len_64 msg as pad_len_64.

  rewrite -> Zlength_correct in *.
  destruct pad_len_64.
  exists (Z.to_nat x).
  destruct H.

  assert (app_each : Z.to_nat (Z.of_nat (length (pad msg))) = Z.to_nat (64 * x)).
    rewrite -> H. reflexivity.

  rewrite -> Nat2Z.id in app_each.

  rewrite -> app_each.
(*  SearchAbout (Z.to_nat (_ * _)).*)
  rewrite -> Z2Nat.inj_mul.
  assert (n_64 : Z.to_nat 64 = 64%nat). reflexivity.

  rewrite -> n_64.
  reflexivity.

  * lia.
  * lia.
Qed.

Lemma total_pad_len_Zlist : forall (msg : list byte), exists (n : nat),
     length
       (msg ++ [Byte.repr 128] ++ repeat Byte.zero (Z.to_nat (- (Zlength msg + 9) mod 64)))
     =  (n * Z.to_nat WORD (* 4 *))%nat.
Proof.
  intros msg.
  pose proof pad_len_64_nat msg as pad_len_64_nat.

  unfold pad in *.
  repeat rewrite -> app_length in *.
  destruct pad_len_64_nat.
  assert (sym: (64 * x)%nat = (x * 64)%nat) by lia.
  rewrite -> sym in *. clear sym.

  simpl in *.
  assert (Pos.to_nat 4 = 4%nat) by reflexivity.
  (*rewrite -> H0. clear H0.*)

  rewrite -> repeat_length in *.

  assert (add_both: (length msg + S (Z.to_nat (- (Zlength msg + 9) mod 64) ))%nat =
      (x * 64 - 8)%nat) by lia. clear H.

  rewrite -> add_both.
  assert ((x * 64 - 8)%nat = (4 * (16 * x - 2))%nat) by lia.

  rewrite -> H.
  exists (16 * x - 2)%nat.
  lia.
Qed.

Lemma pad_inwords :
  forall (msg : list byte),
    InWords (msg ++ [Byte.repr 128]
                 ++ repeat Byte.zero (Z.to_nat (- (Zlength msg + 9) mod 64))).
Proof.
  intros msg.
  apply InWords_len4.
  pose proof total_pad_len_Zlist.
  specialize (H msg).
  unfold Nat.divide.
  apply H.
Qed.

Definition fulllen (len : Z) :=
  len + 1%Z + (- (len + 9) mod 64).

Lemma app_left : forall (a b c d : list byte),
   a ++ b ++ c ++ d = (a ++ b ++ c) ++ d.
(* a ++ (b ++ (c ++ d)) = (a ++ (b ++ c)) ++ d *)
Proof.
   intros a b c d.
   assert (b ++ (c ++ d) = (b ++ c) ++ d) as assert1.
     rewrite -> app_assoc. reflexivity.
   rewrite -> assert1.
   rewrite -> app_assoc.
   reflexivity.
Qed.

(* can use extensionality *)
Theorem pad_compose_equal : forall (msg : list byte),
                              generate_and_pad' msg = generate_and_pad msg.
Proof.
  intros msg.
  unfold generate_and_pad'.
  unfold pad.
  unfold generate_and_pad.
  (* need il => ZIL (IZL il), and
     ZIL a ++ Zil b = ZIL (a ++ b) (with length a being a multiple of 4)
   *)
  pose proof pad_inwords as pad_inwords.
  specialize (pad_inwords msg).
  rewrite -> app_left.
  induction pad_inwords.
  (* case none *)
    assert (forall l : list byte, [] ++ l = l) as Happend. reflexivity.
    specialize (Happend (intlist_to_bytelist
        [Int.repr (Zlength msg * 8 / Int.modulus);
        Int.repr (Zlength msg * 8)])).
    rewrite -> Happend.
    rewrite -> intlist_to_bytelist_to_intlist.
    reflexivity.
  (* case a :: b :: c :: d :: msg0 *)
    Opaque intlist_to_bytelist.
    simpl.
    apply f_equal.
    apply IHpad_inwords.
Qed.

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

(* Lemma 2: |M1| = |M2| -> |Pad(M1)| = |Pad(M2)| *)

Theorem length_equal_pad_length : forall (msg1 : list byte) (msg2 : list byte),
     Zlength msg1  = Zlength msg2 ->
     Zlength (generate_and_pad msg1) = Zlength (generate_and_pad msg2).
Proof.
  intros m1 m2 H.
  repeat rewrite -> functional_prog.length_generate_and_pad.
  rewrite -> H.
  reflexivity.
Qed.

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

(* Lemma 3: |M1| =/= |M2| ->
last block of Pad(M1) =/= last block of Pad(M2)

or, if one-to-one property is desired (for HMAC), only need to prove that
the padded messages differ
*)


Require Import Coq.Lists.List.
Import ListNotations.

Require Import SecureCompartmentalization.fullabst.
Require Import SecureCompartmentalization.lib.

Arguments Some {A} _.
Arguments fst {_ _} _.
Arguments snd {_ _} _.

Class interface_language (interface: Type): Type :=
  {
    compatible: list interface -> Prop;
    complete: list interface -> Prop
  }.

Let comp
    {interface: Type}
    `{interface_language interface}
    (Is : list interface) := compatible Is /\ complete Is.

Class component_language
      {interface: Type} (il: interface_language interface)
      (component program: Type): Type :=
  {
    get_interface : component -> option interface;
    link : list component -> program;
    fully_defined : list component -> list interface -> Prop;
    beh_eq : program -> program -> Prop
  }.

Definition has_interface
           {interface: Type} {il: interface_language interface}
           {component program: Type}
           {L: component_language il component program}

           (C: component) (I: interface): Prop :=
  get_interface C = Some I.

Notation "P ~~ Q" := (beh_eq P Q) (at level 60, no associativity).

Fixpoint All {A} (P : A -> Prop) (l : list A) : Prop :=
  match l with
  | [] => True
  | a :: l' => P a /\ All P l'
  end.

Lemma All_app {A} (P : A -> Prop) (l1 l2 : list A) :
  All P l1 ->
  All P l2 ->
  All P (l1 ++ l2).
Proof.
  induction l1 as [|x l1 IH]; simpl; try solve [intuition].
Qed.

Lemma All_app_l {A} (P : A -> Prop) (l1 l2 : list A) :
  All P (l1 ++ l2) ->
  All P l1.
Proof.
  induction l1 as [|x l1 IH]; simpl; try solve [intuition].
Qed.

Lemma All_app_r {A} (P : A -> Prop) (l1 l2 : list A) :
  All P (l1 ++ l2) ->
  All P l2.
Proof.
  induction l1 as [|x l1 IH]; simpl; try solve [intuition].
Qed.

Fixpoint All2 {A B} (P : A -> B -> Prop) l1 l2 : Prop :=
  match l1, l2 with
  | [], [] => True
  | a :: l1', b :: l2' => P a b /\ All2 P l1' l2'
  | _, _ => False
  end.

Lemma All2_All {A B} (P : A -> B -> Prop) l1 l2 :
  All2 P l1 l2 ->
  All (fun p => P (fst p) (snd p)) (combine l1 l2).
Proof.
  revert l2.
  induction l1 as [|x l1 IH]; intros [|y l2]; simpl; try solve [intuition].
Qed.

Lemma All_All2 {A B} (P : A -> B -> Prop) l1 l2 :
  length l1 = length l2 ->
  All (fun p => P (fst p) (snd p)) (combine l1 l2) ->
  All2 P l1 l2.
Proof.
  revert l2.
  induction l1 as [|x l1 IH]; intros [|y l2]; simpl;
  try solve [intuition|discriminate].
Qed.

Lemma All2_length {A B} (P : A -> B -> Prop) l1 l2 :
  All2 P l1 l2 ->
  length l1 = length l2.
Proof.
  revert l2; induction l1 as [|x1 l1 IH]; intros [|x2 l2]; simpl; intuition.
Qed.

Definition secure_compartmentalization
  {interface: Type} {I : interface_language interface}
  {hcomponent hprogram: Type} {lcomponent lprogram: Type}

  (H: component_language I hcomponent hprogram)
  (L: component_language I lcomponent lprogram)
  (compile : hcomponent -> lcomponent) :=

  forall PIs AIs : list interface,
  comp (PIs ++ AIs) ->
  forall Ps : list hcomponent, All2 has_interface Ps PIs -> fully_defined Ps AIs ->
  forall Qs : list hcomponent, All2 has_interface Qs PIs -> fully_defined Qs AIs ->
  ((forall As : list hcomponent, All2 has_interface As AIs -> fully_defined As PIs ->
     link (Ps ++ As) ~~ link (Qs ++ As))
   <->
   (forall az : list lcomponent, All2 has_interface az AIs ->
         link (map compile Ps ++ az)
      ~~ link (map compile Qs ++ az))).

(* Instantiating structured full abstraction to obtain something
   stronger than secure compartmentalization (we will use this to
   prove sec. comp. for our compiler) *)

Coercion is_true : bool >-> Sortclass. (* Prop *)

Definition fst_map {A B C} (f : A -> C) (p : A * B) :=
  (f (fst p), snd p).

Fixpoint somes {A} (l : list (option A)) : list A :=
  match l with
  | [] => []
  | Some a :: l' => a :: somes l'
  | None :: l' => somes l'
  end.

Lemma somes_app {A} (l1 l2 : list (option A)) :
  somes (l1 ++ l2) = somes l1 ++ somes l2.
Proof.
  induction l1 as [|[x|] l1 IH]; simpl; trivial.
  now rewrite IH.
Qed.

Lemma somes_map {A} (l : list A) :
  somes (map Some l) = l.
Proof.
  now induction l as [|x l IH]; simpl; trivial; rewrite IH.
Qed.

Lemma somes_repeat_none {T} (n : nat) :
  somes (repeat (@None T) n) = [].
Proof. now induction n. Qed.

Definition isSome {A} (oa : option A) :=
  match oa with
  | Some _ => true
  | _ => false
  end.

Definition fsts {A B} (l : list (A * B)) : list A :=
  map fst l.

Definition snds {A B} (l : list (A * B)) : list B :=
  map snd l.

Lemma fsts_combine {A B} (l1 : list A) (l2 : list B) :
  length l1 = length l2 ->
  map fst (combine l1 l2) = l1.
Proof.
  revert l2.
  induction l1 as [|x l1 IH]; simpl; intros [|y l2];
  simpl; trivial; try discriminate.
  intros H. rewrite IH; congruence.
Qed.

Lemma snds_combine {A B} (l1 : list A) (l2 : list B) :
  length l1 = length l2 ->
  map snd (combine l1 l2) = l2.
Proof.
  revert l2.
  induction l1 as [|x l1 IH]; simpl; intros [|y l2];
  simpl; trivial; try discriminate.
  intros H. rewrite IH; congruence.
Qed.

Section SFAfromSC.

Context {interface: Type} {I: interface_language interface} {component program: Type}.
Context (compl : component_language I component program).

(* We take both SFA programs and contexts to be "partial programs"
   of the following type *)
Definition pprog := list (option (component*interface)).

Fixpoint merge (p:pprog) (q:pprog) : option pprog :=
  match p, q with
  | [], [] => Some []
  | Some (c,i1) :: p', None :: q'
  | None :: p', Some (c,i1) :: q' =>
    match merge p' q' with
    | Some pq' => Some (Some (c,i1) :: pq')
    | None     => None
    end
  | None :: p', None :: q' =>
    match merge p' q' with
    | Some pq' => Some (None :: pq')
    | None     => None
    end
  | _, _ => None
  end.

Lemma merge_app p1 p2 q1 q2 :
  length p1 = length q1 ->
  merge (p1 ++ p2) (q1 ++ q2) =
  match merge p1 q1, merge p2 q2 with
  | Some m1, Some m2 => Some (m1 ++ m2)
  | _, _ => None
  end.
Proof.
  revert q1.
  induction p1 as [|[[cp ip]|] p1 IH]; intros [|[[cq iq]|] q1];
  simpl; trivial; try discriminate.
  - now destruct (merge p2 q2).
  - intros H. inversion H as [H'].
    rewrite (IH _ H').
    destruct (merge p1 q1) as [m1|]; trivial.
    destruct (merge p2 q2) as [m2|]; trivial.
  - intros H. inversion H as [H'].
    rewrite (IH _ H').
    destruct (merge p1 q1) as [m1|]; trivial.
    destruct (merge p2 q2) as [m2|]; trivial.
  - intros H. inversion H as [H'].
    rewrite (IH _ H').
    destruct (merge p1 q1) as [m1|]; trivial.
    destruct (merge p2 q2) as [m2|]; trivial.
Qed.

Lemma merge_None_Some n Ps :
  n = length Ps ->
  merge (repeat None n) (map Some Ps) = Some (map Some Ps).
Proof.
  intros ->.
  induction Ps as [|[CP IP] Ps IH]; simpl; trivial.
  now rewrite IH.
Qed.

Lemma merge_Some_None n Ps :
  n = length Ps ->
  merge (map Some Ps) (repeat None n) = Some (map Some Ps).
Proof.
  intros ->.
  induction Ps as [|[CP IP] Ps IH]; simpl; trivial.
  now rewrite IH.
Qed.

Definition interfaces_ok (p:pprog) :=
  All (fun PIP => has_interface (fst PIP) (snd PIP)) (somes p).

Definition stat_eq (p q : pprog) :=
    All2 (fun optPIP optQIQ =>
            match optPIP, optQIQ with
            | None, None => True
            | Some (P, IP), Some (Q, IQ) =>
              has_interface P IP /\ has_interface Q IQ /\ IP = IQ
            | _, _ => False
            end) p q.

Lemma merge_stat_eq As Ps Qs CP :
  merge As Ps = Some CP ->
  stat_eq Ps Qs ->
  match merge As Qs with
  | Some CQ => snds (somes CP) = snds (somes CQ)
  | None => False
  end.
Proof.
revert Ps Qs CP. induction As as [|[[A IA]|] As IH].
- unfold stat_eq.
  intros [] []; simpl; try congruence.
  intros CP H. now inversion H.
- unfold stat_eq in *.
  intros [|[[P IP]|] Ps] [|[[Q IQ]|] Qs]; simpl; try solve [congruence|intuition].
  intros CP.
  destruct (merge As Ps) as [CP'|] eqn:mergeAsPs; try discriminate.
  intros H. inversion H; subst CP; clear H.
  intros [_ HPsQs].
  specialize (IH _ _ _ mergeAsPs HPsQs).
  destruct (merge As Qs) as [CQ'|] eqn:mergeAsQs; try solve [intuition].
  now simpl; rewrite IH.
- unfold stat_eq in *.
  intros [|[[P IP]|] Ps] [|[[Q IQ]|] Qs]; simpl; try solve [congruence|intuition].
  + intros CP.
    destruct (merge As Ps) as [CP'|] eqn:mergeAsPs; try discriminate.
    intros H. inversion H; subst CP; clear H.
    intros [[PI [QI H]] HPsQs]. subst IQ. rename IP into IPQ.
    specialize (IH _ _ _ mergeAsPs HPsQs).
    destruct (merge As Qs) as [CQ'|] eqn:mergeAsQs; try solve [intuition].
    now simpl; rewrite IH.
  + intros CP.
    destruct (merge As Ps) as [CP'|] eqn:mergeAsPs; try discriminate.
    intros H. inversion H; subst CP; clear H.
    intros [_ HPsQs].
    specialize (IH _ _ _ mergeAsPs HPsQs).
    destruct (merge As Qs) as [CQ'|] eqn:mergeAsQs; solve [intuition].
Qed.

Definition shape := list (bool*interface). (* replace (bool*interface) with option interface
                                              if dropping scl_program_has_shape *)
Definition flip_shape (s : shape): shape :=
  List.map (fun bi => match bi with (b, i) => (negb b, i) end) s.

Fixpoint context_has_shape (s : shape) (c : pprog) : Prop :=
  match s, c with
  | [], [] => true
  | (true,i1)::s', (Some (p,i2))::c' =>
    has_interface p i2 /\ i1 = i2 /\ context_has_shape s' c'
  | (false,_)::s', None::c' =>
    context_has_shape s' c'
  | _, _ => false
  end.

Lemma context_has_shape_app_l s1 s2 p :
  context_has_shape (s1 ++ s2) p ->
  exists p1 p2,
    p = p1 ++ p2
    /\ context_has_shape s1 p1
    /\ context_has_shape s2 p2.
Proof.
  revert p.
  induction s1 as [|[b i] s1 IH]; intros p.
  - exists [], p; simpl.
    repeat split; trivial.
  - destruct b, p as [|[[cp ip]|] p]; simpl; try discriminate.
    + intros [H1 [H2 H3]].
      specialize (IH _ H3).
      destruct IH as [p1 [p2 [Hp1 [Hp2 Hp3]]]].
      rewrite Hp1.
      exists (Some (cp, ip) :: p1), p2; repeat split; trivial.
    + intros H. specialize (IH _ H).
      destruct IH as [p1 [p2 [Hp1 [Hp2 Hp3]]]]. rewrite Hp1.
      exists (None :: p1), p2; repeat split; trivial.
Qed.

Lemma context_has_shape_app s1 s2 p1 p2 :
  context_has_shape s1 p1 ->
  context_has_shape s2 p2 ->
  context_has_shape (s1 ++ s2) (p1 ++ p2).
Proof.
  intros H1 H2. revert p1 H1.
  induction s1 as [|[[] i] s1 IH]; intros [|[[cp ip]|] ps]; simpl;
  try discriminate; trivial.
  - intros [H11 [H12 H13]].
    subst ip. repeat split; trivial.
    now eauto.
  - now eauto.
Qed.

Lemma context_has_shape_length s p :
  context_has_shape s p ->
  length s = length p.
Proof.
  revert p. induction s as [|[b i] s IH]; intros p; simpl.
  - destruct p; simpl; trivial; discriminate.
  - destruct b, p as [|[[cp ip]|] p]; simpl; try discriminate.
    + intros [_ [_ H]]. rewrite (IH _ H). reflexivity.
    + intros H. rewrite (IH _ H). reflexivity.
Qed.

Lemma context_has_shape_false PIs AA :
  context_has_shape (map (pair false) PIs) AA ->
  AA = repeat None (length PIs).
Proof.
  revert AA; induction PIs as [|Is PIs IH]; intros [|A AA]; simpl; trivial; try discriminate.
  destruct A; trivial; try discriminate.
  intros H. rewrite (IH _ H). reflexivity.
Qed.

Lemma context_has_shape_false_conv PIs n :
  n = length PIs ->
  context_has_shape (map (pair false) PIs) (repeat None n).
Proof.
  intros ->.
  induction PIs as [|PI PIs IH]; simpl; trivial; reflexivity.
Qed.

Lemma context_has_shape_true PIs AA :
  context_has_shape (map (pair true) PIs) AA ->
  exists AA',
    AA = map Some (combine AA' PIs)
    /\ All2 has_interface AA' PIs.
Proof.
  revert AA.
  induction PIs as [|PI PIs IH]; intros AA; simpl.
  - destruct AA; try discriminate.
    intros _. exists [].
    now split; simpl; trivial.
  - destruct AA as [|[[CA IA]|] AA]; try discriminate.
    intros [H1 [H2 H3]]. simpl.
    destruct (IH _ H3) as [AA' [? H4]].
    subst AA. exists (CA :: AA'). simpl. repeat split; congruence.
Qed.

Lemma context_has_shape_true_conv PIs AA :
  All2 has_interface AA PIs ->
  context_has_shape (map (pair true) PIs) (map Some (combine AA PIs)).
Proof.
  revert AA.
  induction PIs as [|PI PIs IH]; intros [|A AA]; simpl;
  try solve [intuition discriminate|reflexivity].
  intros [H1 H2]. repeat split; auto.
Qed.

Definition context_fully_defined (p : pprog) (s : shape) : Prop :=
  fully_defined (fsts (somes p))
                (somes (map (fun i : bool * _ => if fst i then None else Some (snd i)) s)).

Definition program_has_shape (s : shape) (p : pprog) : Prop :=
  context_has_shape (flip_shape s) p.

Definition program_fully_defined (p : pprog) (s : shape) : Prop :=
  context_fully_defined p (flip_shape s).

Lemma stat_eq_shape Ps Qs s :
  stat_eq Ps Qs ->
  program_has_shape s Ps ->
  program_has_shape s Qs.
Proof.
revert Qs s. unfold stat_eq.
induction Ps as [|[[P IP]|] Ps IH];
intros [|[[Q IQ]|] Qs] [|[b Is] s]; simpl; try solve [intuition].
- intros [[HPI [HQI HI]]]. subst IQ. rename IP into IPQ.
  unfold program_has_shape; simpl.
  destruct b; simpl; trivial.
  intros H [_ [HIs HPs]]. subst Is.
  repeat split; trivial.
  exact (IH _ _ H HPs).
- unfold program_has_shape; simpl.
  destruct b; simpl; trivial.
  intros [_ H] HPs.
  exact (IH _ _ H HPs).
Qed.

Definition insert c p :=
  match merge c p with
  | Some cp => cp
  | None => [] (* shouldn't happen *)
  end.

(* FIXME: It is a bit strange that [cl_compatible] is a property of [c]
   and [p] separately when in this instance we factor it through
   [merge c p]. This makes it very similar to how we use [cl_complete]
   in e.g. [cl_stat_eq_compatible_complete].  *)

Definition comp_compatible c p :=
  match merge c p with
  | Some cp => interfaces_ok cp /\ compatible (snds (somes cp))
  | None => False
  end.

Definition comp_complete (p : pprog) :=
  All isSome p /\ complete (snds (somes p)).

Lemma merge_shape As Ps :
  (match merge As Ps with
   | Some CP => interfaces_ok CP /\ All isSome CP
   | None => False
   end)
  <-> exists s : shape,
        context_has_shape s As /\
        program_has_shape s Ps.
Proof.
revert Ps. unfold interfaces_ok, program_has_shape.
induction As as [|[[A IA]|] As IH].
- intros [|[[P IP]|] Ps]; simpl; split; try solve [intuition].
  + intros _. exists []. simpl.
    now repeat split; trivial.
  + intros [s [HAs HPs]].
    destruct s as [|[[] ?] s]; simpl in *;
    solve [inversion HPs|inversion HAs].
  + intros [s [HAs HPs]].
    destruct s as [|[[] ?] s]; simpl in *;
    solve [inversion HPs|inversion HAs].
- intros [|[[P IP]|] Ps]; simpl; split; try solve [intuition].
  + intros [s [HAs HPs]].
    destruct s as [|[[] ?] s]; simpl in *;
    solve [inversion HPs|inversion HAs].
  + intros [s [HAs HPs]].
    destruct s as [|[[] ?] s]; simpl in *;
    solve [inversion HPs|inversion HAs].
  + specialize (IH Ps).
    destruct (merge As Ps) as [CP|] eqn:mergeAsPs; try solve [intuition].
    simpl.
    rewrite and_assoc, (and_comm true), <- (and_assoc _ _ true), IH.
    intros [HIA [[s [HAs HPs]] _]]. exists ((true, IA) :: s). simpl.
    repeat split; trivial.
  + specialize (IH Ps).
    intros [s [HAs HPs]].
    destruct s as [|[[] i] s]; simpl in *;
    try solve [inversion HPs|inversion HAs].
    destruct HAs as [HIA [? HAs]]. subst i.
    assert (H : exists s', context_has_shape s' As /\ context_has_shape (flip_shape s') Ps) by eauto.
    rewrite <- IH in H.
    destruct (merge As Ps) as [CP|] eqn:mergeAsPs; try solve [intuition].
    simpl. intuition (split; eauto).
- intros [|[[P IP]|] Ps]; simpl; split; try solve [intuition].
  + intros [s [HAs HPs]].
    destruct s as [|[[] ?] s]; simpl in *;
    solve [inversion HPs|inversion HAs].
  + specialize (IH Ps).
    destruct (merge As Ps) as [CP|] eqn:mergeAsPs; try solve [intuition].
    simpl.
    rewrite and_assoc, (and_comm true), <- (and_assoc _ _ true), IH.
    intros [HIA [[s [HAs HPs]] _]]. exists ((false, IP) :: s). simpl.
    repeat split; trivial.
  + specialize (IH Ps).
    intros [s [HAs HPs]].
    destruct s as [|[[] i] s]; simpl in *;
    try solve [inversion HPs|inversion HAs].
    destruct HPs as [HIP [? HPs]]. subst i.
    assert (H : exists s', context_has_shape s' As /\ context_has_shape (flip_shape s') Ps) by eauto.
    rewrite <- IH in H.
    destruct (merge As Ps) as [CP|] eqn:mergeAsPs; try solve [intuition].
    simpl. intuition (split; eauto).
  + specialize (IH Ps).
    destruct (merge As Ps) as [CP|] eqn:mergeAsPs; try solve [intuition].
    simpl. intros [_ [contra _]]. inversion contra.
  + intros [s [HAs HPs]].
    destruct s as [|[[] ?] s]; simpl in *;
    solve [inversion HPs|inversion HAs].
Qed.

Lemma stat_eq_compatible_complete Ps Qs :
  stat_eq Ps Qs ->
  forall A,
    comp_compatible A Ps /\ comp_complete (insert A Ps) ->
    comp_compatible A Qs /\ comp_complete (insert A Qs).
Proof.
  intros HPsQs As.
  unfold comp_compatible, comp_complete, insert in *.
  destruct (merge As Ps) as [CP|] eqn:mergeAsPs; try solve [intuition].
  intros [[int_CP comp_CP] [somes_AsPs compl_CP]].
  assert (H := merge_shape As Ps).
  rewrite mergeAsPs in H.
  assert (H' := conj int_CP somes_AsPs).
  rewrite H in H'. destruct H' as [s [HAs HPs]].
  assert (H' := stat_eq_shape Ps Qs s HPsQs HPs).
  assert (H'' : exists s, context_has_shape s As /\ program_has_shape s Qs) by eauto.
  rewrite <- merge_shape in H''.
  destruct (merge As Qs) as [CQ|] eqn:mergeAsQs; try solve [intuition].
  assert (H''' := merge_stat_eq _ _ _ _ mergeAsPs HPsQs).
  rewrite mergeAsQs in H'''.
  intuition congruence.
Qed.

Instance context_lang_from_component_lang :
     context_language pprog pprog :=
{
  cl_insert := insert;
  cl_compatible := comp_compatible;
  cl_complete := comp_complete;
  cl_stat_eq := stat_eq;
  cl_beh_eq p q := beh_eq (link (fsts (somes p))) (link (fsts (somes q)));
  cl_stat_eq_compatible_complete := @stat_eq_compatible_complete

}.

Instance structured_context_lang_from_component_lang :
     structured_context_language
       context_lang_from_component_lang
       shape :=
{
  scl_context_has_shape := context_has_shape;
  scl_context_fully_defined := context_fully_defined;
  scl_program_has_shape := program_has_shape;
  scl_program_fully_defined := program_fully_defined
}.

End SFAfromSC.

Section SFAimpliesSC.

Context {interface: Type} {I : interface_language interface}
        {hcomponent hprogram: Type} {lcomponent lprogram: Type}
        (H: component_language I hcomponent hprogram)
        (L: component_language I lcomponent lprogram)
        (compile : hcomponent -> lcomponent).

Hypothesis has_interface_compile :
  forall P PI, has_interface P PI ->
               has_interface (compile P) PI.

Definition map_compile (p:@pprog interface hcomponent) :
                          @pprog interface lcomponent :=
  List.map (option_map (fst_map compile)) p.

Theorem sfa_implies_sc :
  structured_full_abstraction
    (structured_context_lang_from_component_lang H)
    (structured_context_lang_from_component_lang L)
    map_compile ->
  secure_compartmentalization H L compile.
Proof.
intros Hsfa PIs AIs Hcomp Ps HPs HPs_def Qs HQs HQs_def.
assert (HPQ : @stat_eq _ _ _ _
                       H
                       (map Some (combine Ps PIs) ++ repeat None (length AIs))
                       (map Some (combine Qs PIs) ++ repeat None (length AIs))).
{ clear Hcomp Hsfa HPs_def HQs_def. revert Ps HPs Qs HQs. unfold stat_eq.
  induction PIs as [|PI PIs IH]; intros [|P Ps] HPs [|Q Qs] HQs; simpl in *; try solve [intuition].
  generalize (length AIs). clear AIs HPs HQs.
  now induction 0 as [|n IH]; split. }
assert (HPs' : @program_has_shape _ _ _ _
                                  H
                                  (map (pair false) PIs ++ map (pair true) AIs)
                                  (map Some (combine Ps PIs) ++ repeat None (length AIs))).
{ clear HPs_def Qs HQs HQs_def HPQ Hcomp.
  revert PIs HPs. unfold program_has_shape.
  induction Ps as [|P Ps IH]; simpl; intros PIs HPs.
  - destruct PIs as [|]; simpl in *; try solve [intuition].
    clear HPs.
    induction AIs as [|AI AIs IH]; simpl; trivial.
    reflexivity.
  - destruct PIs as [|PI PIs]; simpl in *; try solve [intuition]. }
assert (HPs_def' : @program_fully_defined _ _ _ _
                                          H
                                          (map Some (combine Ps PIs) ++ repeat None (length AIs))
                                          (map (pair false) PIs ++ map (pair true) AIs)).
{ unfold program_fully_defined, context_fully_defined.
  rewrite somes_app, somes_map, somes_repeat_none, app_nil_r.
  unfold fsts. rewrite fsts_combine; try now rewrite (All2_length _ _ _ HPs).
  unfold flip_shape. rewrite !map_app, !map_map. simpl.
  now rewrite somes_app, somes_map, map_const, somes_repeat_none. }
assert (HQs' : @program_has_shape _ _ _ _
                                  H
                                  (map (pair false) PIs ++ map (pair true) AIs)
                                  (map Some (combine Qs PIs) ++ repeat None (length AIs))).
{ clear Ps HPs HPs' HPs_def HPs_def' HQs_def HPQ Hcomp.
  revert PIs HQs. unfold program_has_shape.
  induction Qs as [|Q Qs IH]; simpl; intros PIs HQs.
  - destruct PIs as [|]; simpl in *; try solve [intuition].
    clear HQs.
    induction AIs as [|AI AIs IH]; simpl; trivial.
    reflexivity.
  - destruct PIs as [|PI PIs]; simpl in *; try solve [intuition]. }
assert (HQs_def' : @program_fully_defined _ _ _ _
                                          H
                                          (map Some (combine Qs PIs) ++ repeat None (length AIs))
                                          (map (pair false) PIs ++ map (pair true) AIs)).
{ unfold program_fully_defined, context_fully_defined.
  rewrite somes_app, somes_map, somes_repeat_none, app_nil_r.
  unfold fsts. rewrite fsts_combine; try now rewrite (All2_length _ _ _ HQs).
  unfold flip_shape. rewrite !map_app, !map_map. simpl.
  now rewrite somes_app, somes_map, map_const, somes_repeat_none. }
specialize (Hsfa (map (pair false) PIs ++ map (pair true) AIs)
                 (map Some (combine Ps PIs) ++ repeat None (length AIs))
                 (map Some (combine Qs PIs) ++ repeat None (length AIs))).
specialize (Hsfa HPQ HPs' HPs_def' HQs' HQs_def'). simpl in Hsfa.
clear HPs_def HPs_def' HQs_def HQs_def'.
simpl in *. split.
- (* -> *)
  intros Heq az Haz. destruct Hsfa as [Hsfa _].
  assert (H' : (forall AA : pprog,
                 context_has_shape H (map (pair false) PIs ++ map (pair true) AIs)
                                   AA ->
                 context_fully_defined H AA
                                       (map (pair false) PIs ++ map (pair true) AIs) ->
                 comp_compatible H AA
                                 (map Some (combine Ps PIs) ++ repeat None (length AIs)) ->
                 comp_complete
                   (insert AA
                           (map Some (combine Ps PIs) ++ repeat None (length AIs))) ->
                 link
                   (fsts
                      (somes
                         (insert AA
                                 (map Some (combine Ps PIs) ++ repeat None (length AIs))))) ~~
                   link
                   (fsts
                      (somes
                         (insert AA
                                 (map Some (combine Qs PIs) ++ repeat None (length AIs))))))).
  { intros AA Hshape Hdef HcompAA Hcompl.
    (* assert (Hdef' : @fully_defined _ _ _ _ H AA PIs).*)
    apply context_has_shape_app_l in Hshape.
    destruct Hshape as [AA1 [AA2 [E1 [E2 E3]]]].
    subst AA. unfold insert in *.
    assert (Hp : length AA1 = length (map Some (combine Ps PIs))).
    { rewrite map_length, combine_length, min_l.
      - rewrite <- (context_has_shape_length _ _ _ E2).
        rewrite map_length.
        now rewrite (All2_length _ _ _ HPs).
      - now rewrite (All2_length _ _ _ HPs). }
    rewrite (merge_app AA1 AA2 _ _ Hp) in *.
    assert (Hq : length AA1 = length (map Some (combine Qs PIs))).
    { rewrite map_length, combine_length, min_l.
      - rewrite <- (context_has_shape_length _ _ _ E2).
        rewrite map_length.
        now rewrite (All2_length _ _ _ HQs).
      - now rewrite (All2_length _ _ _ HQs). }
    rewrite (merge_app AA1 AA2 _ _ Hq) in *.
    pose proof (context_has_shape_false _ _ _ E2). subst AA1.
    rewrite merge_None_Some; try rewrite combine_length, min_r; trivial;
    try rewrite (All2_length _ _ _ HPs); trivial.
    rewrite merge_None_Some; try rewrite combine_length, min_r; trivial;
    try rewrite (All2_length _ _ _ HQs); trivial.
    apply context_has_shape_true in E3.
    destruct E3 as [AA2' [? HAA2']]. subst AA2.
    rewrite merge_Some_None; try rewrite combine_length, min_r; trivial;
    try rewrite (All2_length _ _ _ HAA2'); trivial.
    rewrite !somes_app, !somes_map.
    unfold fsts. rewrite !map_app.
    unfold context_fully_defined, fsts in Hdef.
    rewrite !somes_app, somes_repeat_none, somes_map in Hdef.
    simpl in Hdef.
    rewrite fsts_combine in Hdef; try now rewrite (All2_length _ _ _ HAA2').
    rewrite map_app, !map_map in Hdef. simpl in Hdef.
    rewrite somes_app, somes_map, map_const, somes_repeat_none, app_nil_r in Hdef.
    rewrite !fsts_combine; trivial; eauto.
    - apply (All2_length _ _ _ HQs).
    - apply (All2_length _ _ _ HAA2').
    - apply (All2_length _ _ _ HPs). }
  specialize (Hsfa H'). clear H'.
  specialize (Hsfa (repeat None (length PIs) ++ map Some (combine az AIs))).
  unfold map_compile, insert, program_has_shape, flip_shape in *.
  rewrite !map_app, !map_map in *. simpl in *.
  rewrite map_repeat in Hsfa. simpl in *.
  repeat rewrite <- (map_map (fst_map compile) Some) in Hsfa.
  rewrite merge_app in Hsfa;
  try rewrite repeat_length, !map_length, combine_length, min_r; trivial;
  try rewrite (All2_length _ _ _ HPs); trivial.
  rewrite merge_None_Some in Hsfa;
  try rewrite map_length, combine_length, min_r; trivial;
  try rewrite (All2_length _ _ _ HPs); trivial.
  rewrite merge_Some_None in Hsfa;
  try rewrite combine_length, min_r; trivial; try rewrite (All2_length _ _ _ Haz); trivial.
  rewrite somes_app, !somes_map in Hsfa.
  rewrite merge_app in Hsfa;
  try rewrite repeat_length, !map_length, combine_length, min_r; trivial;
  try rewrite (All2_length _ _ _ HQs); trivial.
  rewrite merge_None_Some in Hsfa;
  try rewrite map_length, combine_length, min_r; trivial;
  try rewrite (All2_length _ _ _ HQs); trivial.
  rewrite merge_Some_None in Hsfa;
  try rewrite map_length; try rewrite combine_length, min_r; trivial;
  try rewrite (All2_length _ _ _ Haz); trivial.
  unfold fsts in Hsfa.
  rewrite map_app, fsts_combine in Hsfa; try rewrite (All2_length _ _ _ Haz); trivial.
  rewrite somes_app, !somes_map, map_app, !(map_map _ fst) in Hsfa.
  rewrite fsts_combine in Hsfa; try rewrite (All2_length _ _ _ Haz); trivial.
  rewrite (map_ext (fun x => fst (fst_map compile x)) (fun x => compile (fst x))) in Hsfa;
  try now intros [].
  rewrite (map_ext (fun x => fst (fst_map compile x)) (fun x => compile (fst x))) in Hsfa;
  try now intros [].
  rewrite <- !(map_map fst), !fsts_combine in Hsfa;
  try rewrite (All2_length _ _ _ HPs); trivial;
  try rewrite (All2_length _ _ _ HQs); trivial.
  apply Hsfa; clear Hsfa; simpl; repeat split.
  + apply context_has_shape_app.
    * now apply context_has_shape_false_conv.
    * now apply context_has_shape_true_conv.
  + unfold comp_compatible.
    rewrite merge_app; try rewrite repeat_length, !map_length, combine_length, min_r; trivial;
    try rewrite (All2_length _ _ _ HPs); trivial.
    rewrite merge_None_Some; try rewrite map_length, combine_length, min_r; trivial;
    try rewrite (All2_length _ _ _ HPs); trivial.
    rewrite merge_Some_None; try rewrite combine_length, min_r; trivial;
    try rewrite (All2_length _ _ _ Haz); trivial.
    split.
    * unfold interfaces_ok.
      rewrite somes_app, !somes_map.
      apply All_app; try now apply All2_All.
      clear - Ps PIs HPs has_interface_compile.
      revert PIs HPs.
      now induction Ps as [|P Ps IH]; intros [|PI PIs]; simpl; intuition.
    * unfold snds.
      rewrite somes_app, !somes_map, map_app, snds_combine;
      try rewrite (All2_length _ _ _ Haz); trivial.
      rewrite map_map.
      rewrite (map_ext (fun x => snd (fst_map compile x)) snd); try now intros [].
      rewrite snds_combine; try rewrite (All2_length _ _ _ HPs); trivial.
      exact (proj1 Hcomp).
  + rewrite <- map_app.
    generalize (map (fst_map compile) (combine Ps PIs) ++ combine az AIs).
    clear.
    now intros PIs; induction PIs as [|PI PIs IH]; simpl; intuition.
  + unfold snds.
    rewrite somes_app, !somes_map, map_app, snds_combine;
    try rewrite (All2_length _ _ _ Haz); trivial.
    rewrite map_map.
    rewrite (map_ext (fun x => snd (fst_map compile x)) snd); try now intros [].
    rewrite snds_combine; try rewrite (All2_length _ _ _ HPs); trivial.
    exact (proj2 Hcomp).
- (* <- *)
  intros Heq As HAs HAs_def. destruct Hsfa as [_ Hsfa].
  assert (H' : forall aa : pprog,
                 context_has_shape L (map (pair false) PIs ++ map (pair true) AIs)
                                   aa ->
                 comp_compatible L aa
                                 (map_compile
                                    (map Some (combine Ps PIs) ++ repeat None (length AIs))) ->
                 comp_complete
                   (insert aa
                           (map_compile
                              (map Some (combine Ps PIs) ++ repeat None (length AIs)))) ->
                 link
                   (fsts
                      (somes
                         (insert aa
                                 (map_compile
                                    (map Some (combine Ps PIs) ++
                                         repeat None (length AIs)))))) ~~
                   link
                   (fsts
                      (somes
                         (insert aa
                                 (map_compile
                                    (map Some (combine Qs PIs) ++
                                         repeat None (length AIs))))))).
  { clear Hsfa. intros az'.
    unfold fsts, insert, map_compile in *.
    rewrite !map_app, !map_repeat; simpl.
    rewrite !map_map; simpl.
    intros H1'.
    destruct (context_has_shape_app_l _ _ _ _ H1') as [az'' [az [H1 [H2 H3]]]].
    subst az'. clear H1'.
    apply context_has_shape_false in H2. subst az''.
    apply context_has_shape_true in H3.
    destruct H3 as [aa [? Haa]]. subst az.
    unfold comp_compatible, interfaces_ok.
    rewrite merge_app;
    try rewrite repeat_length, map_length, combine_length, min_r; trivial;
    try rewrite (All2_length _ _ _ HPs); trivial.
    rewrite <- !(map_map (fst_map compile) Some).
    rewrite merge_None_Some; try rewrite map_length, combine_length, min_r; trivial;
    try rewrite (All2_length _ _ _ HPs); trivial.
    rewrite merge_app;
    try rewrite repeat_length, !map_length, combine_length, min_r; trivial;
    try rewrite (All2_length _ _ _ HQs); trivial.
    rewrite merge_Some_None; try rewrite map_length; try rewrite combine_length, min_r; trivial;
    try rewrite (All2_length _ _ _ Haa); trivial.
    rewrite merge_None_Some; try rewrite map_length, combine_length, min_r; trivial;
    try rewrite (All2_length _ _ _ HQs); trivial.
    rewrite !somes_app, !somes_map, !map_app.
    rewrite fsts_combine; try now rewrite (All2_length _ _ _ Haa).
    rewrite !(map_map _ fst).
    rewrite (map_ext (fun x => fst (fst_map compile x)) (fun x => compile (fst x))); try now intros [].
    rewrite <- (map_map fst compile), fsts_combine; try now rewrite (All2_length _ _ _ HPs).
    rewrite (map_ext (fun x => fst (fst_map compile x)) (fun x => compile (fst x))); try now intros [].
    rewrite <- (map_map fst compile), fsts_combine; try now rewrite (All2_length _ _ _ HQs).
    intros [HAll _] _. apply Heq. clear Heq.
    apply All_All2; try now rewrite (All2_length _ _ _ Haa).
    now apply All_app_r in HAll. }
  specialize (Hsfa H'). clear H'.
  specialize (Hsfa (repeat None (length PIs) ++ map Some (combine As AIs))).
  unfold insert in *.
  rewrite merge_app in Hsfa;
  try rewrite repeat_length, map_length, combine_length, min_r; trivial;
  try rewrite (All2_length _ _ _ HPs); trivial.
  rewrite merge_app in Hsfa;
  try rewrite repeat_length, map_length, combine_length, min_r; trivial;
  try rewrite (All2_length _ _ _ HQs); trivial.
  rewrite merge_None_Some in Hsfa;
  try rewrite combine_length, min_r; trivial;
  try rewrite (All2_length _ _ _ HPs); trivial.
  rewrite merge_None_Some in Hsfa;
  try rewrite combine_length, min_r; trivial;
  try rewrite (All2_length _ _ _ HQs); trivial.
  rewrite merge_Some_None in Hsfa;
  try rewrite combine_length, min_r; trivial;
  try rewrite (All2_length _ _ _ HAs); trivial.
  rewrite !somes_app, !somes_map in Hsfa.
  unfold fsts, snds in *.
  rewrite !map_app in Hsfa.
  rewrite fsts_combine in Hsfa; try rewrite (All2_length _ _ _ HPs); trivial.
  rewrite fsts_combine in Hsfa; try rewrite (All2_length _ _ _ HAs); trivial.
  rewrite fsts_combine in Hsfa; try rewrite (All2_length _ _ _ HQs); trivial.
  apply Hsfa; clear Hsfa; simpl; repeat split.
  + apply context_has_shape_app.
    * now apply context_has_shape_false_conv.
    * now apply context_has_shape_true_conv.
  + unfold context_fully_defined, fsts.
    rewrite somes_app, somes_repeat_none, somes_map; simpl.
    rewrite fsts_combine; try now rewrite (All2_length _ _ _ HAs).
    rewrite map_app, !map_map, somes_app; simpl.
    now rewrite map_const, somes_map, somes_repeat_none, app_nil_r.
  + unfold comp_compatible.
    rewrite merge_app; try rewrite repeat_length, map_length, combine_length, min_r; trivial;
    try rewrite (All2_length _ _ _ HPs); trivial.
    rewrite merge_None_Some; try rewrite combine_length, min_r; trivial;
    try rewrite (All2_length _ _ _ HPs); trivial.
    rewrite merge_Some_None; try rewrite combine_length, min_r; trivial;
    try rewrite (All2_length _ _ _ HAs); trivial.
    unfold interfaces_ok. rewrite !somes_app, !somes_map.
    unfold snds. rewrite map_app.
    rewrite snds_combine; try now rewrite (All2_length _ _ _ HPs).
    rewrite snds_combine; try now rewrite (All2_length _ _ _ HAs).
    split; try exact (proj1 Hcomp).
    apply All_app; try now apply All2_All.
  + rewrite <- map_app.
    generalize (combine Ps PIs ++ combine As AIs).
    clear.
    now intros Ps; induction Ps as [|P Ps IH]; simpl; intuition.
  + unfold snds.
    rewrite somes_app, !somes_map, map_app, !snds_combine;
    try rewrite (All2_length _ _ _ HPs); trivial;
    try rewrite (All2_length _ _ _ HAs); trivial.
    exact (proj2 Hcomp).
Qed.

End SFAimpliesSC.


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

Require Import VST.msl.base.
Require Import VST.msl.ageable.
Require Import Coq.Logic.Eqdep_dec.
Require Import VST.msl.functors.

Import CovariantFunctor.
Import CovariantFunctorLemmas.
Import CovariantFunctorGenerator.

Local Open Scope nat_scope.

Module Type TY_FUNCTOR.
  Parameter F : functor.

  Parameter T : Type.
  Parameter T_bot : T.

  Parameter other : Type.
End TY_FUNCTOR.

Module Type KNOT.
  Declare Module TF:TY_FUNCTOR.
  Import TF.

  Parameter knot : Type.

  Parameter ag_knot : ageable knot.
  Existing Instance ag_knot.
  Existing Instance ag_prod.

  Definition predicate := (knot * other) -> T.

  Parameter squash : (nat * F predicate) -> knot.
  Parameter unsquash : knot -> (nat * F predicate).

  Definition approx (n:nat) (p:predicate) : predicate :=
     fun w => if Compare_dec.le_gt_dec n (level w) then T_bot else p w.

  Axiom squash_unsquash : forall x, squash (unsquash x) = x.
  Axiom unsquash_squash : forall n x', unsquash (squash (n,x')) = (n,fmap F (approx n) x').

  Axiom knot_level : forall k:knot,
    level k = fst (unsquash k).

  Axiom knot_age1 : forall k:knot,
    age1 k =
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.

End KNOT.

Module Knot (TF':TY_FUNCTOR) : KNOT with Module TF:=TF'.
  Module TF := TF'.
  Import TF.

  (* Put the discrete pointed order on rhs *)
  Inductive leT : T -> T -> Prop :=
   | leT_refl : forall t, leT t t
   | leT_bot: forall t, leT T_bot t.

  Lemma leT_asym: forall t t',
    leT t t' -> leT t' t -> t = t'.
  Proof.
    intros.
    inversion H; subst; auto.
    inversion H0; subst; auto.
  Qed.

  Fixpoint sinv (n: nat) : Type :=
    match n with
      | O => unit
      | S n => prodT (sinv n) ((F (sinv n) * other) -> T)
    end.

  Fixpoint floor (m:nat) (n:nat) (p:sinv (m+n)) : sinv n :=
    match m as m' return forall (p : sinv (m'+n)), sinv n with
    | O => fun p => p
    | S m' => fun p => floor m' n (fst p)
    end p.

  Definition knot := { n:nat & F (sinv n) }.

  Definition predicate := knot * other -> T.

  Fixpoint stratify (n:nat) (Q:predicate) {struct n} : sinv n :=
    match n as n' return sinv n' with
    | O => tt
    | S n' => ( stratify n' Q, fun v => Q (existT (F oo sinv) n' (fst v),snd v) )
    end.

  Lemma decompose_nat : forall (x y:nat), { m:nat & y = (m + S x) } + { ge x y }.
  Proof.
    intros x y; revert x; induction y; simpl; intros.
    right; auto with arith.
    destruct (IHy x) as [[m H]|H].
    left; exists (S m); lia.
    destruct (Peano_dec.eq_nat_dec x y).
    left; exists O; lia.
    right; lia.
  Qed.

  Definition unstratify (n:nat) (p:sinv n) : predicate := fun w =>
    match w with (existT _ nw w',e) =>
      match decompose_nat nw n with
        | inleft (existT _ m Hm) => snd (floor m (S nw) (eq_rect  n _ p (m + S nw) Hm)) (w', e)
        | inright H => T_bot
      end
    end.

  Definition proof_irr_nat := eq_proofs_unicity Peano_dec.dec_eq_nat.
  Arguments proof_irr_nat [x] [y] _ _.

  Lemma floor_shuffle:
    forall (m1 n : nat)
      (p1 : sinv (m1 + S n)) (H1 : (m1 + S n) = (S m1 + n)),
      floor (S m1) n (eq_rect (m1 + S n) sinv p1 (S m1 + n) H1) = fst (floor m1 (S n) p1).
  Proof.
    intros.
    remember (fst (floor m1 (S n) p1)) as p.
    revert n p1 H1 p Heqp.
    induction m1; simpl; intros.
    replace H1 with (refl_equal (S n)) by (apply proof_irr_nat); simpl; auto.
    assert (m1 + S n = S m1 + n) by lia.
    destruct p1 as [p1 f'].
    generalize (IHm1 n p1 H p Heqp).
    simpl.
    clear.
    revert H1; generalize H.
    revert p1 f'.
    rewrite H.
    simpl; intros.
    replace H1 with (refl_equal (S (S (m1 + n)))) by (apply proof_irr_nat).
    simpl.
    replace H0 with (refl_equal (S (m1+n))) in H2 by (apply proof_irr_nat).
    simpl in H2.
    trivial.
  Qed.

  Lemma stratify_unstratify_more : forall n m1 m2 p1 p2,
    floor m1 n p1 = floor m2 n p2 ->

    (stratify n oo unstratify (m1+n)) p1 =
    (stratify n oo unstratify (m2+n)) p2.
  Proof.
    unfold compose; induction n; simpl; intros; auto.
    apply injective_projections; simpl; trivial.

    assert ((m1 + S n) =  (S m1 + n)) by lia.
    assert ((m2 + S n) =  (S m2 + n)) by lia.
    assert (floor (S m1) n (eq_rect (m1 + S n) _ p1 _ H0) = floor (S m2) n (eq_rect (m2 + S n) _ p2 _ H1)).
    do 2 rewrite floor_shuffle.
    congruence.
    generalize (IHn (S m1) (S m2) _ _ H2).
    clear.
    generalize H0 H1.
    revert p1 p2.
    rewrite H0; clear H0.
    rewrite H1; clear H1.
    intros p1 p2 H1 H2.
    replace H1 with (refl_equal (S m1 + n)) by (apply proof_irr_nat).
    replace H2 with (refl_equal (S m2 + n)) by (apply proof_irr_nat).
    simpl; auto.

    apply extensionality; intro v.
    unfold unstratify.
    destruct (decompose_nat n (m2 + S n)) as [[r Hr]|Hr].
    2: elimtype False; lia.
    destruct (decompose_nat n (m1 + S n)) as [[s Hs]|Hs].
    2: elimtype False; lia.
    assert (m2 = r) by lia; subst r.
    assert (m1 = s) by lia; subst s.
    simpl.
    replace Hr with (refl_equal (m2 + S n)) by (apply proof_irr_nat).
    replace Hs with (refl_equal (m1 + S n)) by (apply proof_irr_nat).
    simpl.
    rewrite H; auto.
  Qed.

  Lemma stratify_unstratify : forall n,
         stratify n oo unstratify n = id (sinv n).
  Proof.
    unfold id, compose; intro n; extensionality p; revert n p.
    induction n.

    intros; destruct p; auto.

    simpl; intros [p f].
    apply injective_projections; simpl; trivial.

    replace (stratify n (unstratify (S n) (p,f))) with
            (stratify n (unstratify n p)); auto.
    replace (stratify n (unstratify n p)) with
      ((stratify n oo unstratify (0+n)) p) by trivial.
    rewrite (stratify_unstratify_more _ 0 1 p (p,f)); trivial.

    extensionality v.

    destruct (decompose_nat n (S n)) as [[r Hr]|?]; auto.
    assert (r = O) by lia; subst r.
    simpl in *.
    replace Hr with (refl_equal (S n)) by (apply proof_irr_nat); simpl; auto.
    destruct v; auto.

    elimtype False.
    lia.
  Qed.

  Lemma unstratify_stratify1 : forall n (p:predicate) w,
    leT ((unstratify n oo stratify n) p w) (p w).
  Proof.
    unfold compose; induction n; simpl; intros; unfold unstratify.

    (* 0 case *)
    destruct w as [nw rm]; simpl.
    destruct nw as [nw e].
    destruct (decompose_nat nw O) as [[r Hr]|?].
    elimtype False; lia.
    apply leT_bot.

    (* S n case *)
    case_eq w; intros nw rm Hrm.
    destruct nw as [nw e].
    destruct (decompose_nat nw (S n)) as [[r Hr]|?]; try (apply lt_rhs_top).
    destruct r; simpl.

    assert (n = nw) by lia.
    subst nw.
    simpl in Hr.
    replace Hr with (refl_equal (S n)) by apply proof_irr_nat; simpl.
    unfold compose.
    destruct w.
    apply leT_refl.

    simpl in Hr.
    assert (n = r + S nw) by lia.
    revert Hr; subst n.
    intro Hr.
    replace Hr with (refl_equal (S (r+S nw))) by apply proof_irr_nat; simpl.
    clear Hr.

    generalize (IHn p w).
    unfold unstratify.
    rewrite Hrm.
    destruct (decompose_nat nw (r + S nw)) as [[x Hx]|?].
    assert (x = r) by lia; subst x.
    replace Hx with (refl_equal (r + S nw)) by apply proof_irr_nat.
    simpl; auto.
    elimtype False; lia.
    apply leT_bot.
  Qed.

  Lemma unstratify_stratify2 : forall n p w,
     projT1 (fst w) < n ->
        leT (p w) ((unstratify n oo stratify n) p w).
  Proof.
    unfold compose.
    induction n; simpl; intros.

    (* 0 case *)
    inversion H.

    (* S n case *)
    unfold unstratify.
    case_eq w; intros [m rm] e Hw.
    assert (projT1 (fst w) = m).
    rewrite Hw; auto.

    destruct (decompose_nat m (S n)) as [[r Hr]|?].
    destruct r; simpl.

    assert (n = m) by lia.
    move H0 after H1.
    subst m. fold sinv. simpl in Hr. rewrite (proof_irr_nat Hr (refl_equal _)). clear Hr.
    simpl.
    unfold compose.
    rewrite <- Hw.
    apply leT_refl.

    simpl in Hr.
    assert (n = r + S m) by lia.
    revert Hr; subst n.
    intro Hr.
    replace Hr with (refl_equal (S (r+S m))) by apply proof_irr_nat; simpl.
    clear Hr.
    rewrite H0 in H.
    assert (m < (r +  S m)) by lia.
    specialize ( IHn p w).
    rewrite H0 in IHn.
    specialize ( IHn H1).
    revert IHn.
    unfold unstratify.
    rewrite Hw.
    destruct (decompose_nat m (r + S m)) as [[x Hx]|?].
    assert (x = r) by lia; subst x.
    replace Hx with (refl_equal (r + S m)) by apply proof_irr_nat.
    simpl; auto.
    elimtype False; lia.
    elimtype False; lia.
  Qed.

  Lemma unstratify_stratify3 : forall n (p:predicate) w,
    projT1 (fst w) >= n -> leT ((unstratify n oo stratify n) p w) T_bot.
  Proof.
    unfold compose, unstratify; intros n p w H.
    case_eq w; intros [wn rm] e.
    intro Hrm.
    rewrite Hrm in H; simpl in H.
    destruct (decompose_nat wn n) as [[r Hr]|?].
    elimtype False; lia.
    apply leT_bot.
  Qed.

  Definition squash (x:nat * F predicate) : knot :=
    match x with (n,y) => existT (F oo sinv) n (fmap F (stratify n) y) end.

  Definition unsquash (x:knot) : (nat * F predicate) :=
    match x with existT _ n y => (n, fmap F (unstratify n) y) end.

  Definition def_knot_level (k:knot) := fst (unsquash k).

  Definition def_knot_age1 (k:knot) : option knot :=
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.

  Definition def_knot_unage (k:knot) : knot :=
    match unsquash k with
    | (n,x) => squash (S n,x)
    end.

  Definition approx (n:nat) (p:predicate) : predicate :=
     fun w => if Compare_dec.le_gt_dec n (def_knot_level (fst w)) then T_bot else p w.

  Lemma squash_unsquash : forall x, squash (unsquash x) = x.
  Proof.
    intros; destruct x as [x f]; simpl.
    unfold compose.
    replace (fmap F (stratify x) (fmap F (unstratify x) f)) with
      ((fmap F (stratify x) oo fmap F (unstratify x)) f) by trivial.
    rewrite fmap_comp.
    replace (stratify x oo unstratify x) with (id (sinv x)).
    rewrite fmap_id; simpl; auto.
    unfold compose.
    extensionality z.
    replace (stratify x (unstratify x z)) with ((stratify x oo unstratify x) z) by trivial.
    rewrite stratify_unstratify; auto.
  Qed.

  Lemma unsquash_squash : forall n x', unsquash (squash (n,x')) = (n,fmap F (approx n) x').
  Proof.
    intros.
    simpl.
    replace (fmap F  (unstratify n) (fmap F (stratify n) x')) with
      ((fmap F (unstratify n) oo fmap F (stratify n)) x') by trivial.
    rewrite fmap_comp.
    apply injective_projections; simpl; trivial.
    replace (unstratify n oo stratify n) with (approx n); auto.
    extensionality p z.
    apply leT_asym.

    intuition.
    case (Compare_dec.le_gt_dec n (def_knot_level a)); intro.
    replace (approx n p (a, b)) with T_bot.
    apply leT_bot.
    unfold approx.
    simpl.
    case (Compare_dec.le_gt_dec n (def_knot_level a)); intro.
    trivial.
    elimtype False.
    lia.
    replace (approx n p (a,b)) with (p (a,b)).
    apply unstratify_stratify2.
    simpl.
    destruct a.
    unfold level in g.
    simpl in *.
    auto.
    unfold approx.
    simpl.
    case (Compare_dec.le_gt_dec n (def_knot_level a)); intro.
    elimtype False.
    lia.
    trivial.

    intuition.
    destruct (Compare_dec.le_lt_dec n (def_knot_level a)).
    replace (approx n p (a, b)) with T_bot.
    apply unstratify_stratify3; auto.
    simpl.
    destruct a.
    unfold level in l.
    simpl in *.
    auto.
    unfold approx.
    simpl.
    case (Compare_dec.le_gt_dec n (def_knot_level a)); auto.
    intro.
    elimtype False.
    lia.
    replace (approx n p (a, b)) with (p (a, b)).
    apply unstratify_stratify1; auto.
    unfold approx.
    simpl.
    case (Compare_dec.le_gt_dec n (def_knot_level a)); auto.
    intro.
    elimtype False.
    lia.
  Qed.

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

  Lemma ag_knot_facts : ageable_facts knot def_knot_level def_knot_age1.
  Proof.
    constructor.

   unfold def_knot_age1; unfold def_knot_level; simpl; intros x'.
    case_eq (unsquash x'); intros.
    destruct x' as [n' xx']. simpl in *. inv H.
    exists (squash (S n, fmap F (unstratify n) xx')).
    rewrite unsquash_squash.
    f_equal.
    f_equal.
    transitivity ((fmap F (stratify n) oo fmap F (approx (S n)) oo fmap F (unstratify n)) xx'); auto.
    do 2 rewrite fmap_comp.
    replace (stratify n oo approx (S n) oo unstratify n) with (@id (sinv n)).
    rewrite fmap_id. auto.
   clear.
    rewrite <- (stratify_unstratify n).
    f_equal. extensionality  a w.
    unfold approx, compose. destruct w.
    simpl fst.
    destruct (Compare_dec.le_gt_dec (S n) (def_knot_level k)); auto.
    destruct k. simpl in *.
    unfold def_knot_level in l.
    simpl in *.
    destruct (decompose_nat x n); auto.
    destruct s. elimtype False.
    lia.

    intros.
    unfold def_knot_age1, def_knot_level.
    destruct (unsquash x); simpl.
    destruct n; intuition; try discriminate.

    unfold def_knot_age1, def_knot_level; intros.
    destruct (unsquash x).
    destruct n; inv H; simpl; auto.
  Qed.

  Definition ag_knot : ageable knot :=
    mkAgeable knot def_knot_level def_knot_age1 ag_knot_facts .
  Existing Instance ag_knot.
  Existing Instance ag_prod.

  Lemma knot_level : forall k:knot,
    level k = fst (unsquash k).
  Proof (fun k => refl_equal (def_knot_level k)).

  Lemma knot_age1 : forall k:knot,
    age1 k =
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.
  Proof (fun k => refl_equal (def_knot_age1 k)).

End Knot.