(******************************************************************************)
(* Copyright (c) 2020 Steven Keuchel, Dominique Devriese                      *)
(* All rights reserved.                                                       *)
(*                                                                            *)
(* Redistribution and use in source and binary forms, with or without         *)
(* modification, are permitted provided that the following conditions are     *)
(* met:                                                                       *)
(*                                                                            *)
(* 1. Redistributions of source code must retain the above copyright notice,  *)
(*    this list of conditions and the following disclaimer.                   *)
(*                                                                            *)
(* 2. Redistributions in binary form must reproduce the above copyright       *)
(*    notice, this list of conditions and the following disclaimer in the     *)
(*    documentation and/or other materials provided with the distribution.    *)
(*                                                                            *)
(* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS        *)
(* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED  *)
(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR *)
(* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR          *)
(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,      *)
(* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,        *)
(* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR         *)
(* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF     *)
(* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING       *)
(* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS         *)
(* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.               *)
(******************************************************************************)

From Coq Require Export
     Numbers.BinNums.
From Coq Require Import
     Bool.Bool
     Lists.List
     NArith.NArith
     Strings.String
     ZArith.BinInt.
From Katamaran Require Export
     Notations.
From Equations Require Import
     Equations.

(* stdpp changes a lot of flags and changes implicit arguments of standard
   library functions and constructors. Import the module here, so that the
   changes are consistently applied over our code base. *)
From stdpp Require
     base countable finite list.

Local Set Implicit Arguments.

Section Equality.

  Definition EqbSpecPoint {A} (eqb : A -> A -> bool) (x : A) : Type :=
    forall y, reflect (x = y) (eqb x y).

  Definition f_equal2' {A : Type} {B : A -> Type} {C : Type} (f : forall a, B a -> C)
    {a1 a2 : A} {b1 : B a1} {b2 : B a2} :
    sigmaI B a1 b1 = sigmaI B a2 b2 -> f a1 b1 = f a2 b2 :=
    DepElim.eq_simplification_sigma1_dep a1 a2 b1 b2
      (fun e => match e with eq_refl => fun b eb => f_equal (f a1) eb end b2).

  Definition f_equal_dec {A B : Type} (f : A -> B) {x y : A} (inj : f x = f y -> x = y)
             (hyp : dec_eq x y) : dec_eq (f x) (f y) :=
    match hyp with
    | left p => left (f_equal f p)
    | right p => right (fun e : f x = f y => p (inj e))
    end.

  Definition f_equal2_dec {A1 A2 B : Type} (f : A1 -> A2 -> B) {x1 y1 : A1} {x2 y2 : A2}
             (inj : f x1 x2 = f y1 y2 -> @sigmaI _ _ x1 x2 = @sigmaI _ _ y1 y2)
             (hyp1 : dec_eq x1 y1) (hyp2 : dec_eq x2 y2) :
    dec_eq (f x1 x2) (f y1 y2) :=
    match hyp1 , hyp2 with
    | left  p , left q  => left (eq_trans
                                   (f_equal (f x1) q)
                                   (f_equal (fun x => f x y2) p))
    | left  p , right q =>
      right (fun e => q (f_equal (@pr2 _ (fun _ => _)) (inj e)))
    | right p , _       =>
      right (fun e => p (f_equal (@pr1 _ (fun _ => _)) (inj e)))
    end.

  Local Set Transparent Obligations.

  #[export] Instance Z_eqdec : EqDec Z := Z.eq_dec.
  #[export] Instance string_eqdec : EqDec string := string_dec.
  Derive NoConfusion EqDec for Empty_set.

  #[export] Instance option_eqdec `{EqDec A} : EqDec (option A).
  Proof. eqdec_proof. Defined.

  Definition eq_dec_het {I} {A : I -> Type} `{eqdec : EqDec (sigT A)}
    {i1 i2} (x1 : A i1) (x2 : A i2) : dec_eq (existT i1 x1) (existT i2 x2) :=
    eq_dec (existT i1 x1) (existT i2 x2).

  #[export] Instance EqDecision_from_EqDec `{eqdec : EqDec A} :
    stdpp.base.EqDecision A | 10 := eqdec.

  Lemma cons_inj [A] (x y : A) (xs ys : list A) :
    x :: xs = y :: ys <-> x = y /\ xs = ys.
  Proof.
    split.
    - intros e. refine match e with eq_refl => conj eq_refl eq_refl end.
    - intros [e1 e2]. now apply f_equal2.
  Qed.

  Lemma inl_inj [A B] (x y : A) :
    @inl A B x = @inl A B y <-> x = y.
  Proof.
    split; intros e.
    - now apply noConfusion_inv in e.
    - now apply f_equal.
  Qed.

  Lemma inr_inj [A B] (x y : B) :
    @inr A B x = @inr A B y <-> x = y.
  Proof.
    split; intros e.
    - now apply noConfusion_inv in e.
    - now apply f_equal.
  Qed.

  Lemma some_inj [A] (x y : A) :
    @Some A x = @Some A y <-> x = y.
  Proof.
    split; intros e.
    - now apply noConfusion_inv in e.
    - now apply f_equal.
  Qed.

End Equality.

Ltac finite_from_eqdec :=
  match goal with
  | |- base.NoDup ?xs =>
      now apply (@decidable.bool_decide_unpack _ (list.NoDup_dec xs))
  | |- forall x : ?T, base.elem_of x _ =>
      lazymatch T with
      | sigT _ => intros [? []]
      | _      => intros []
      end;
      apply (@decidable.bool_decide_unpack _ (list.elem_of_list_dec _ _));
      auto
  end.

Section Finite.

  Import stdpp.finite.

  #[local] Set Equations With UIP.
  #[export,program] Instance Finite_sigT (A : Type) {eqA : EqDec A} {finA : Finite A}
    (B : A -> Type) {eqB : forall x, EqDec (B x)} {finB : forall x, Finite (B x)} :
    Finite {x : A & B x} :=
    {| enum := foldr (fun a xs => map (existT a) (enum (B a)) ++ xs) [] (enum A) |}.
  Next Obligation.
  Proof.
    intros A eqA finA B eqB finB.
    generalize (NoDup_enum A).
    generalize (enum A) as xs.
    induction xs; cbn.
    - intros _. constructor.
    - intros [HaIn NDxs]%NoDup_cons.
      apply NoDup_app. split; [|split].
      + apply NoDup_fmap. intros x y Heq.
        now dependent elimination Heq.
        apply NoDup_enum.
      + intros [a' b'] (b & Heq & HbIn)%elem_of_list_fmap.
        dependent elimination Heq.
        intros HxIn. apply HaIn.
        { clear - HxIn.
          induction xs; cbn in *.
          - inversion HxIn.
          - apply elem_of_app in HxIn.
            destruct HxIn as [HxIn|HxIn].
            + apply elem_of_list_fmap in HxIn.
              destruct HxIn as (b & Heq & HbIn).
              dependent elimination Heq.
              constructor.
            + constructor.
              now apply IHxs.
        }
      + now apply IHxs.
  Qed.
  Next Obligation.
  Proof.
    intros A eqA finA B eqB finB.
    intros [a b].
    generalize (elem_of_enum a).
    generalize (enum A) as xs. clear - finB.
    induction xs; cbn.
    - intros []%not_elem_of_nil.
    - intros [Ha|Ha]%elem_of_cons.
      + clear - Ha.
        apply elem_of_app. left. subst.
        apply elem_of_list_fmap_1.
        apply elem_of_enum.
      + apply elem_of_app. right.
        now apply IHxs.
  Qed.

  Lemma nodup_fixed `{EqDec A} (l : list A) : nodup eq_dec l = l -> NoDup l.
  Proof.
    intros <-.
    apply NoDup_ListNoDup.
    apply NoDup_nodup.
  Qed.

  #[local] Obligation Tactic := finite_from_eqdec.

  (* To avoid some coherence issues, we define our own Finite instance for bool
     that uses the EqDEc instance from the Equations library instead of the
     EqDecision instance from stdpp. *)
  #[export,program] Instance Finite_bool :
    @Finite bool EqDecision_from_EqDec :=
    {| enum := [true;false] |}.

End Finite.

Definition proof_irrelevance_True (p q : True) : p = q :=
  match p, q with I , I => eq_refl end.

Definition proof_irrelevance_is_true {b : bool} :
  forall (p q : Is_true b), p = q :=
  match b with
  | true  => proof_irrelevance_True
  | false => fun p => False_rect _ p
  end.

(* We define our own variant of a boolean 'is true' predicate to turn it into
   a typeclass and fill it in automatically during typechecking. *)
Module IsTrue.
  Class IsTrue (b : bool) : Prop := mk { from : Is_true b }.
  Definition proof_irrelevance {b} (p q : IsTrue b) : p = q :=
    match p , q with
      mk _ p , mk _ q => f_equal (mk b) (proof_irrelevance_is_true p q)
    end.

  (* Normalize proof terms, i.e. replace a potentially big proof term by the
     unique small one. See e.g.:
     http://poleiro.info/posts/2018-01-26-equality-in-coq.html *)
  Definition normalize {b} : IsTrue b -> IsTrue b :=
    match b with
    | true  => fun _ => mk true I
    | false => fun p => p
    end.

  Lemma normalize_identity {b} (p : IsTrue b) : normalize p = p.
  Proof. apply proof_irrelevance. Qed.

  #[global] Arguments mk [b] _, {b _}.
  #[global] Arguments from [b] _.
  (* Set the Hint Mode for IsTrue, so that it will only use the Hint Extern
     below if whatever b is unified with does not contain any existential
     variables anymore. This is mostly used in statically checking bitvector
     sizes. Essentially we want to delay checking the constraints until it is
     fully known, in particular when type information flows from a later program
     position to an earlier one, e.g. for sign extension from the type
     information from a variable reference flows to the variable declaration. *)
  #[export] Hint Mode IsTrue + : typeclass_instances.
  #[export] Hint Extern 10 (IsTrue ?b) =>
    refine (@mk true I) : typeclass_instances.

  (* The following two definition should never be added as instances themselves
     because they will easily lead to exponential blowup in proof search. Only
     use them locally in the definition of other instances. *)
  Definition andb_l {a b} : IsTrue (a && b) -> IsTrue a :=
    match a with
    | true  => fun _ => @IsTrue.mk true I
    | false => fun H => H
    end.

  Definition andb_r {a b} : IsTrue (a && b) -> IsTrue b :=
    match b , a with
    | true  , _     => fun _ => @IsTrue.mk true I
    | false , true  => fun H => H
    | false , false => fun H => H
    end.

End IsTrue.
Export (hints) IsTrue.
Export IsTrue (IsTrue).

Definition IsSome {A : Type} (m : option A) : Type :=
  match m with
  | Some _ => unit
  | None   => Empty_set
  end.

Definition fromSome {A : Type} (m : option A) : IsSome m -> A :=
  match m return IsSome m -> A with
  | Some a => fun _ => a
  | None   => fun p => match p with end
  end.

Section Countable.

  Import stdpp.countable.

  #[export,refine] Instance Countable_sigT {A B} {EqDecA : EqDecision A} {CountA: Countable A}
    {EqDecB : forall (a:A), EqDecision (B a)} {CountB: forall a, Countable (B a)} :
    @Countable (sigT B) (sigma_eqdec EqDecA EqDecB)  :=
    {| encode x := prod_encode (encode (projT1 x)) (encode (projT2 x));
       decode p :=
         a ← (prod_decode_fst p ≫= decode);
         b ← (prod_decode_snd p ≫= decode);
         mret (existT a b)
    |}.
  Proof.
    abstract
      (intros [a b];
       rewrite prod_decode_encode_fst; cbn;
       rewrite decode_encode, prod_decode_encode_snd;
       cbn; now rewrite decode_encode).
  Defined.

End Countable.

Module option.

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

  Definition IsSome {A} (m : option A) : Prop :=
    Is_true (isSome m).

  Definition fromSome {A} (m : option A) : IsSome m -> A :=
    match m with Some a => fun _ => a | None => fun p => match p with end end.

  Definition map {A B} (f : A -> B) (o : option A) : option B :=
    match o with Some a => Some (f a) | None => None end.
  Definition bind {A B} (a : option A) (f : A -> option B) : option B :=
    match a with Some x => f x | None => None end.
  Definition comp {A B C : Type} (f : A -> option B) (g : B -> option C) :=
    fun a => bind (f a) g.

  Arguments map {A B} f !o.
  Arguments bind {A B} !a f.

  Module Import notations.

    Notation "' x <- ma ;; mb" :=
      (bind ma (fun x => mb))
        (at level 80, x pattern, ma at next level, mb at level 200, right associativity,
          format "' x  <-  ma  ;;  mb").
    Notation "x <- ma ;; mb" :=
      (bind ma (fun x => mb))
        (at level 80, ma at next level, mb at level 200, right associativity).
    Notation "f <$> a" := (map f a).
    Notation "f <*> a" := (match f with Some g => map g a | None => None end).

  End notations.

  (* Easy eq patterns *)
  Lemma map_eq_some {A B} (f : A -> B) (o : option A) (a : A) :
    o = Some a ->
    map f o = Some (f a).
  Proof. now intros ->. Qed.

  Lemma bind_eq_some {A B} (f : A -> option B) (o : option A) (b : B) :
    (exists a, o = Some a /\ f a = Some b) <->
    bind o f = Some b.
  Proof.
    split.
    - now intros (a & -> & <-).
    - destruct o as [a|]; [ now exists a | discriminate ].
  Qed.

  (* Variant of Bool.reflect and BoolSpec for options, i.e.
     a weakest pre without effect observation. *)
  Inductive spec {A} (S : A -> Prop) (N : Prop) : option A -> Prop :=
  | specSome {a : A} : S a -> spec S N (Some a)
  | specNone         : N -> spec S N None.

  (* Total correctness weakest pre for option. Arguments are inversed. *)
  Inductive wp {A} (S : A -> Prop) : option A -> Prop :=
  | wpSome {a : A} : S a -> wp S (Some a).

  (* Partial correctness weakest pre for option. Arguments are inversed. *)
  Inductive wlp {A} (S : A -> Prop) : option A -> Prop :=
  | wlpSome {a : A} : S a -> wlp S (Some a)
  | wlpNone         : wlp S None.

  (* We define equivalent formulations using pattern matches and
     logical connectives plus constructors. *)
  Lemma spec_match {A S N} (o : option A) :
    spec S N o <-> match o with
                   | Some a => S a
                   | None   => N
                   end.
  Proof.
    split.
    - intros []; auto.
    - destruct o; now constructor.
  Qed.

  Lemma wp_match {A S} (o : option A) :
    wp S o <-> match o with
               | Some a => S a
               | None   => False
               end.
  Proof.
    split.
    - intros []; auto.
    - destruct o; [apply wpSome|contradiction].
  Qed.

  Lemma wp_exists {A} (Q : A -> Prop) (o : option A) :
    wp Q o <-> exists a, o = Some a /\ Q a.
  Proof.
    rewrite wp_match. split.
    - destruct o; eauto; contradiction.
    - now intros [a [-> HQ]].
  Qed.

  Lemma wlp_match {A S} (o : option A) :
    wlp S o <-> match o with
               | Some a => S a
               | None   => True
               end.
  Proof.
    split.
    - intros []; auto.
    - destruct o; auto using wlpSome, wlpNone.
  Qed.

  Lemma wlp_forall {A} (Q : A -> Prop) (o : option A) :
    wlp Q o <-> forall a, o = Some a -> Q a.
  Proof.
    rewrite wlp_match. split.
    - intros; subst; auto.
    - destruct o; auto.
  Qed.

  Lemma spec_some {A S N} (a : A) : spec S N (Some a) <-> S a.
  Proof. now rewrite spec_match. Qed.
  Lemma spec_none {A S N} : @spec A S N None <-> N.
  Proof. now rewrite spec_match. Qed.
  Lemma wp_some {A P} (a : A) : wp P (Some a) <-> P a.
  Proof. now rewrite wp_match. Qed.
  Lemma wp_none {A P} : @wp A P None <-> False.
  Proof. now rewrite wp_match. Qed.
  Lemma wlp_some {A P} (a : A) : wlp P (Some a) <-> P a.
  Proof. now rewrite wlp_match. Qed.
  Lemma wlp_none {A P} : @wlp A P None <-> True.
  Proof. now rewrite wlp_match. Qed.

  Section Bind.

    Context {A B} {S : B -> Prop} {N : Prop} (f : A -> option B) (o : option A).

    Local Ltac proof :=
      destruct o; rewrite ?spec_match, ?wp_match, ?wlp_match; auto.

    Lemma spec_bind : spec S N (bind o f) <-> spec (fun a => spec S N (f a)) N o.
    Proof. proof. Qed.
    Definition spec_bind_elim := proj1 spec_bind.
    Definition spec_bind_intro := proj2 spec_bind.

    Lemma wp_bind : wp S (bind o f) <-> wp (fun a => wp S (f a)) o.
    Proof. proof. Qed.
    Definition wp_bind_elim := proj1 wp_bind.
    Definition wp_bind_intro := proj2 wp_bind.

    Lemma wlp_bind : wlp S (bind o f) <-> wlp (fun a => wlp S (f a)) o.
    Proof. proof. Qed.

    Definition wlp_bind_elim := proj1 wlp_bind.
    Definition wlp_bind_intro := proj2 wlp_bind.

  End Bind.

  Lemma spec_map {A B S N} (f : A -> B) (o : option A) :
    spec S N (map f o) <-> spec (fun a => S (f a)) N o.
  Proof. do 2 rewrite spec_match; now destruct o. Qed.

  Lemma spec_ap {A B S N} (f : option (A -> B)) (o : option A) :
    spec S N (f <*> o) <->
    spec (fun f => spec (fun a => S (f a)) N o) N f.
  Proof.
    do 2 rewrite spec_match. destruct f; auto.
    rewrite spec_match; now destruct o.
  Qed.

  Lemma spec_monotonic {A} (S1 S2 : A -> Prop) (N1 N2 : Prop)
    (fS : forall a, S1 a -> S2 a) (fN: N1 -> N2) :
    forall (o : option A),
      spec S1 N1 o -> spec S2 N2 o.
  Proof. intros ? []; constructor; auto. Qed.

  Lemma wp_map {A B S} (f : A -> B) (o : option A) :
    wp S (map f o) <-> wp (fun a => S (f a)) o.
  Proof. do 2 rewrite wp_match; now destruct o. Qed.

  Lemma wp_ap {A B S} (f : option (A -> B)) (o : option A) :
    wp S (f <*> o) <->
    wp (fun f => wp (fun a => S (f a)) o) f.
  Proof.
    do 2 rewrite wp_match. destruct f; auto.
    rewrite wp_match; now destruct o.
  Qed.

  Lemma wp_monotonic {A} (S1 S2 : A -> Prop) (fS : forall a, S1 a -> S2 a)  :
    forall (o : option A), wp S1 o -> wp S2 o.
  Proof. intros ? []; constructor; auto. Qed.

  Lemma wlp_map {A B S} (f : A -> B) (o : option A) :
    wlp S (map f o) <-> wlp (fun a => S (f a)) o.
  Proof. do 2 rewrite wlp_match; now destruct o. Qed.

  Lemma wlp_ap {A B S} (f : option (A -> B)) (o : option A) :
    wlp S (f <*> o) <->
    wlp (fun f => wlp (fun a => S (f a)) o) f.
  Proof.
    do 2 rewrite wlp_match. destruct f; auto.
    rewrite wlp_match; now destruct o.
  Qed.

  Lemma wlp_monotonic {A} (S1 S2 : A -> Prop) (fS : forall a, S1 a -> S2 a)  :
    forall (o : option A), wlp S1 o -> wlp S2 o.
  Proof. intros ? []; constructor; auto. Qed.

  Module tactics.

    Ltac mixin :=
      lazymatch goal with
      | |- wp _ (Some _) => constructor
      | |- wp _ (map _ _) => apply wp_map
      | |- wp _ (bind _ _) => apply wp_bind_intro
      | |- wp _ (_ <*> _) => apply wp_ap
      | |- wlp _ (Some _) => constructor
      | |- wlp _ (map _ _) => apply wlp_map
      | |- wlp _ (bind _ _) => apply wlp_bind_intro
      | |- wlp _ (_ <*> _) => apply wlp_ap
      | H: wp _ ?x |- wp _ ?x => revert H; apply wp_monotonic; intros
      | H: wlp _ ?x |- wlp _ ?x => revert H; apply wlp_monotonic; intros
      end.

  End tactics.

  Section Traverse.
    Context {A B} (f : A -> option B).

    Fixpoint traverse_list (xs : list A) : option (list B) :=
      match xs with
      | nil       => Some nil
      | cons x xs => b <- f x ;; bs <- traverse_list xs ;; Some (cons b bs)
      end.

    Fixpoint traverse_vector {n} (xs : Vector.t A n) : option (Vector.t B n) :=
      match xs with
      | Vector.nil       => Some Vector.nil
      | Vector.cons x xs => b <- f x ;; bs <- traverse_vector xs ;; Some (Vector.cons b bs)
      end.

  End Traverse.

End option.

Lemma and_iff_compat_r' (A B C : Prop) :
  (B /\ A <-> C /\ A) <-> (A -> B <-> C).
Proof. intuition. Qed.

Lemma and_iff_compat_l' (A B C : Prop) :
  (A /\ B <-> A /\ C) <-> (A -> B <-> C).
Proof. intuition. Qed.

Lemma imp_iff_compat_l' (A B C : Prop) :
  ((A -> B) <-> (A -> C)) <-> (A -> B <-> C).
Proof. intuition. Qed.

Lemma rightid_and_true (A : Prop) :
  A /\ True <-> A.
Proof. intuition. Qed.

Lemma leftid_true_and (A : Prop) :
  True /\ A <-> A.
Proof. intuition. Qed.

Lemma exists_or_compat {A} (P Q : A -> Prop):
  (exists a, P a \/ Q a) <-> (exists a, P a) \/ (exists a, Q a).
Proof. firstorder. Qed.

Lemma forall_and_compat {A} (P Q : A -> Prop):
  (forall a, P a /\ Q a) <-> (forall a, P a) /\ (forall a, Q a).
Proof. firstorder. Qed.

Declare Scope alt_scope.
Declare Scope asn_scope.
Declare Scope exp_scope.
Declare Scope modal_scope.
Declare Scope mut_scope.
Declare Scope pat_scope.
Delimit Scope alt_scope with alt.
Delimit Scope asn_scope with asn.
Delimit Scope exp_scope with exp.
Delimit Scope modal_scope with modal.
Delimit Scope mut_scope with mut.
Delimit Scope pat_scope with pat.

Definition findAD {A} {B : A -> Type} {eqA: EqDec A} (a : A) :
  list (sigT B) -> option (B a) :=
  fix find (xs : list (sigT B)) : option (B a) :=
    match xs with
    | nil                   => None
    | cons (existT a' b) xs =>
        match eq_dec a a' with
        | left e  => Some (eq_rect_r B b e)
        | right _ => find xs
        end
    end.

Record Stats : Set :=
  { branches : N
  ; pruned   : N
  }.

Definition plus_stats (x y : Stats) : Stats :=
  {| branches := branches x + branches y;
     pruned   := pruned x + pruned y
  |}.
Definition empty_stats : Stats :=
  {| branches := 0; pruned   := 0|}.

Create HintDb katamaran.
#[global] Hint Rewrite
  andb_true_iff andb_false_iff negb_true_iff negb_false_iff orb_true_iff
  orb_false_iff cons_inj inl_inj inr_inj some_inj pair_equal_spec
  : katamaran.
#[global] Hint Rewrite
  @option.spec_ap    @option.wlp_ap   @option.wp_ap
  @option.spec_bind  @option.wlp_bind @option.wp_bind
  @option.spec_map   @option.wlp_map  @option.wp_map
  @option.spec_none  @option.wlp_none @option.wp_none
  @option.spec_some  @option.wlp_some @option.wp_some
  : katamaran.


Require Import Omega.
Require Import Bool.
Require Import RelationClasses.

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

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.

Require Import Event.
Require Import Time.
From PromisingLib Require Import Language.

Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.

Set Implicit Arguments.

Module ThreadEvent.
  Inductive program_t :=
  | silent
  | read (loc:Loc.t) (ts:Time.t) (val:Const.t) (released:option View.t) (ord:Ordering.t)
  | write (loc:Loc.t) (from to:Time.t) (val:Const.t) (released:option View.t) (ord:Ordering.t)
  | update (loc:Loc.t) (tsr tsw:Time.t) (valr valw:Const.t) (releasedr releasedw:option View.t) (ordr ordw:Ordering.t)
  | fence (ordr ordw:Ordering.t)
  | syscall (e:Event.t)
  .

  Inductive t :=
  | promise (loc:Loc.t) (from to:Time.t) (val:Const.t) (released:option View.t) (kind:Memory.op_kind)
  | program (event:program_t)
  .
  Coercion ThreadEvent.program: ThreadEvent.program_t >-> ThreadEvent.t.

  Definition get_event (e:t): option Event.t :=
    match e with
    | syscall e => Some e
    | _ => None
    end.

  Definition get_program_event (e:program_t) : ProgramEvent.t :=
    match e with
    | silent => ProgramEvent.silent
    | read loc _ val _ ord => ProgramEvent.read loc val ord
    | write loc _ _ val _ ord => ProgramEvent.write loc val ord
    | update loc _ _ valr valw _ _ ordr ordw => ProgramEvent.update loc valr valw ordr ordw
    | fence ordr ordw => ProgramEvent.fence ordr ordw
    | syscall ev => ProgramEvent.syscall ev
    end.

  Definition get_program (e:t): option program_t :=
    match e with
    | promise _ _ _ _ _ _ => None
    | program e => Some e
    end.

  Definition is_promising (e:t) : option (Loc.t * Time.t) :=
    match e with
    | promise loc from to v rel kind => Some (loc, to)
    | _ => None
    end.

  Definition is_lower_none (e:t) : bool :=
    match e with
    | promise loc from to v rel kind => Memory.op_kind_is_lower kind && negb rel
    | _ => false
    end.

  Definition is_reading (e:t): option (Loc.t * Time.t * Const.t * option View.t * Ordering.t) :=
    match e with
    | read loc ts val released ord => Some (loc, ts, val, released, ord)
    | update loc tsr _ valr _ releasedr _ ordr _ => Some (loc, tsr, valr, releasedr, ordr)
    | _ => None
    end.

  Definition is_writing (e:t): option (Loc.t * Time.t * Time.t * Const.t * option View.t * Ordering.t) :=
    match e with
    | write loc from to val released ord => Some (loc, from, to, val, released, ord)
    | update loc tsr tsw _ valw _ releasedw _ ordw => Some (loc, tsr, tsw, valw, releasedw, ordw)
    | _ => None
    end.

  Definition is_accessing (e:t): option (Loc.t * Time.t) :=
    match e with
    | read loc ts _ _ _ => Some (loc, ts)
    | write loc _ ts _ _ _ => Some (loc, ts)
    | update loc _ ts _ _ _ _ _ _ => Some (loc, ts)
    | _ => None
    end.

  Inductive le: forall (lhs rhs:t), Prop :=
  | le_promise
      loc from to val rel1 rel2 kind1 kind2
      (LEREL: View.opt_le rel1 rel2):
      le (promise loc from to val rel1 kind1) (promise loc from to val rel2 kind2)
  | le_silent:
      le (program silent) (program silent)
  | le_read
      loc ts val rel1 rel2 ord
      (LEREL: View.opt_le rel1 rel2):
      le (read loc ts val rel1 ord) (read loc ts val rel2 ord)
  | le_write
      loc from to val rel1 rel2 ord
      (LEREL: View.opt_le rel1 rel2):
      le (write loc from to val rel1 ord) (write loc from to val rel2 ord)
  | le_update
      loc tsr tsw valr valw relr1 relr2 relw1 relw2 ordr ordw
      (LEREL: View.opt_le relr1 relr2)
      (LEREL: View.opt_le relw1 relw2):
      le (update loc tsr tsw valr valw relr1 relw1 ordr ordw) (update loc tsr tsw valr valw relr2 relw2 ordr ordw)
  | le_fence ordr ordw:
      le (fence ordr ordw) (fence ordr ordw)
  | le_syscall e:
      le (syscall e) (syscall e)
  .

  Definition lift (ord0:Ordering.t) (e:program_t): program_t :=
    match e with
    | silent => silent
    | read loc ts val released ord =>
      read loc ts val released (Ordering.join ord0 ord)
    | write loc from to val released ord =>
      write loc from to val released (Ordering.join ord0 ord)
    | update loc tsr tsw valr valw releasedr releasedw ordr ordw =>
      update loc tsr tsw valr valw releasedr releasedw (Ordering.join ord0 ordr) (Ordering.join ord0 ordw)
    | fence ordr ordw =>
      fence (Ordering.join ord0 ordr) (Ordering.join ord0 ordw)
    | syscall e =>
      syscall e
    end.

  Lemma lift_plain e:
    lift Ordering.plain e = e.
  Proof. destruct e; ss. Qed.
End ThreadEvent.
Coercion ThreadEvent.program: ThreadEvent.program_t >-> ThreadEvent.t.

Inductive tau T (step: forall (e:ThreadEvent.t) (e1 e2:T), Prop) (e1 e2:T): Prop :=
| tau_intro
    e
    (TSTEP: step e e1 e2)
    (EVENT: ThreadEvent.get_event e = None)
.
Hint Constructors tau.

Inductive union E T (step: forall (e:E) (e1 e2:T), Prop) (e1 e2:T): Prop :=
| union_intro
    e
    (USTEP: step e e1 e2)
.
Hint Constructors union.

Lemma tau_mon T (step1 step2: forall (e:ThreadEvent.t) (e1 e2:T), Prop)
      (STEP: step1 <3= step2):
  tau step1 <2= tau step2.
Proof.
  i. inv PR. econs; eauto.
Qed.

Lemma union_mon E T (step1 step2: forall (e:E) (e1 e2:T), Prop)
      (STEP: step1 <3= step2):
  union step1 <2= union step2.
Proof.
  i. inv PR. econs; eauto.
Qed.

Lemma tau_union: tau <4= (@union ThreadEvent.t).
Proof.
  ii. inv PR. econs. eauto.
Qed.

Module Local.
  Structure t := mk {
    tview: TView.t;
    promises: Memory.t;
  }.

  Definition init := mk TView.bot Memory.bot.

  Inductive is_terminal (lc:t): Prop :=
  | is_terminal_intro
      (PROMISES: lc.(promises) = Memory.bot)
  .

  Inductive wf (lc:t) (mem:Memory.t): Prop :=
  | wf_intro
      (TVIEW_WF: TView.wf lc.(tview))
      (TVIEW_CLOSED: TView.closed lc.(tview) mem)
      (PROMISES: Memory.le lc.(promises) mem)
      (FINITE: Memory.finite lc.(promises))
  .

  Inductive disjoint (lc1 lc2:t): Prop :=
  | disjoint_intro
      (DISJOINT: Memory.disjoint lc1.(promises) lc2.(promises))
  .

  Global Program Instance disjoint_Symmetric: Symmetric disjoint.
  Next Obligation.
    econs. symmetry. apply H.
  Qed.

  Inductive promise_step (lc1:t) (mem1:Memory.t) (loc:Loc.t) (from to:Time.t) (val:Const.t) (released:option View.t): forall (lc2:t) (mem2:Memory.t) (kind:Memory.op_kind), Prop :=
  | promise_step_intro
      promises2 mem2 kind
      (PROMISE: Memory.promise lc1.(promises) mem1 loc from to val released promises2 mem2 kind)
      (CLOSED: Memory.closed_opt_view released mem2):
      promise_step lc1 mem1 loc from to val released (mk lc1.(tview) promises2) mem2 kind
  .

  Inductive read_step (lc1:t) (mem1:Memory.t) (loc:Loc.t) (to:Time.t) (val:Const.t) (released:option View.t) (ord:Ordering.t): forall (lc2:t), Prop :=
  | read_step_intro
      from
      tview2
      (GET: Memory.get loc to mem1 = Some (from, Message.mk val released))
      (READABLE: TView.readable lc1.(tview).(TView.cur) loc to released ord)
      (TVIEW: TView.read_tview lc1.(tview) loc to released ord = tview2):
      read_step lc1 mem1 loc to val released ord (mk tview2 lc1.(promises))
  .

  Inductive write_step (lc1:t) (sc1:TimeMap.t) (mem1:Memory.t) (loc:Loc.t) (from to:Time.t) (val:Const.t) (releasedm released:option View.t) (ord:Ordering.t): forall (lc2:t) (sc2:TimeMap.t) (mem2:Memory.t) (kind:Memory.op_kind), Prop :=
  | write_step_intro
      promises2 mem2 kind
      (RELEASED: released = TView.write_released lc1.(tview) sc1 loc to releasedm ord)
      (WRITABLE: TView.writable lc1.(tview).(TView.cur) sc1 loc to ord)
      (WRITE: Memory.write lc1.(promises) mem1 loc from to val released promises2 mem2 kind)
      (RELEASE: Ordering.le Ordering.strong_relaxed ord ->
                Memory.nonsynch_loc loc lc1.(promises) /\
                kind = Memory.op_kind_add):
      write_step lc1 sc1 mem1 loc from to val releasedm released ord
                 (mk (TView.write_tview lc1.(tview) sc1 loc to ord) promises2)
                 sc1 mem2 kind
  .

  Inductive fence_step (lc1:t) (sc1:TimeMap.t) (ordr ordw:Ordering.t): forall (lc2:t) (sc2:TimeMap.t), Prop :=
  | fence_step_intro
      tview2
      (READ: TView.read_fence_tview lc1.(tview) ordr = tview2)
      (RELEASE: Ordering.le Ordering.strong_relaxed ordw -> Memory.nonsynch lc1.(promises)):
      fence_step lc1 sc1 ordr ordw (mk (TView.write_fence_tview tview2 sc1 ordw) lc1.(promises)) (TView.write_fence_sc tview2 sc1 ordw)
  .

  Inductive program_step: forall (e:ThreadEvent.t) lc1 sc1 mem1 lc2 sc2 mem2, Prop :=
  | step_silent
      lc1 sc1 mem1:
      program_step ThreadEvent.silent lc1 sc1 mem1 lc1 sc1 mem1
  | step_read
      lc1 sc1 mem1
      loc ts val released ord lc2
      (LOCAL: Local.read_step lc1 mem1 loc ts val released ord lc2):
      program_step (ThreadEvent.read loc ts val released ord) lc1 sc1 mem1 lc2 sc1 mem1
  | step_write
      lc1 sc1 mem1
      loc from to val released ord lc2 sc2 mem2 kind
      (LOCAL: Local.write_step lc1 sc1 mem1 loc from to val None released ord lc2 sc2 mem2 kind):
      program_step (ThreadEvent.write loc from to val released ord) lc1 sc1 mem1 lc2 sc2 mem2
  | step_update
      lc1 sc1 mem1
      loc ordr ordw
      tsr valr releasedr releasedw lc2
      tsw valw lc3 sc3 mem3 kind
      (LOCAL1: Local.read_step lc1 mem1 loc tsr valr releasedr ordr lc2)
      (LOCAL2: Local.write_step lc2 sc1 mem1 loc tsr tsw valw releasedr releasedw ordw lc3 sc3 mem3 kind):
      program_step (ThreadEvent.update loc tsr tsw valr valw releasedr releasedw ordr ordw) lc1 sc1 mem1 lc3 sc3 mem3
  | step_fence
      lc1 sc1 mem1
      ordr ordw lc2 sc2
      (LOCAL: Local.fence_step lc1 sc1 ordr ordw lc2 sc2):
      program_step (ThreadEvent.fence ordr ordw) lc1 sc1 mem1 lc2 sc2 mem1
  | step_syscall
      lc1 sc1 mem1
      e lc2 sc2
      (LOCAL: Local.fence_step lc1 sc1 Ordering.seqcst Ordering.seqcst lc2 sc2):
      program_step (ThreadEvent.syscall e) lc1 sc1 mem1 lc2 sc2 mem1
  .

  Lemma promise_step_future lc1 sc1 mem1 loc from to val released lc2 mem2 kind
        (STEP: promise_step lc1 mem1 loc from to val released lc2 mem2 kind)
        (WF1: wf lc1 mem1)
        (SC1: Memory.closed_timemap sc1 mem1)
        (CLOSED1: Memory.closed mem1):
    <<WF2: wf lc2 mem2>> /\
    <<SC2: Memory.closed_timemap sc1 mem2>> /\
    <<CLOSED2: Memory.closed mem2>> /\
    <<FUTURE: Memory.future mem1 mem2>> /\
    <<TVIEW_FUTURE: TView.le lc1.(tview) lc2.(tview)>> /\
    <<REL_WF: View.opt_wf released>> /\
    <<REL_TS: Time.le (released.(View.unwrap).(View.rlx) loc) to>> /\
    <<REL_CLOSED: Memory.closed_opt_view released mem2>>.
  Proof.
    inv WF1. inv STEP.
    exploit Memory.promise_future; eauto. i. des.
    splits; ss.
    - econs; ss. eapply TView.future_closed; eauto.
    - eapply Memory.future_closed_timemap; eauto.
    - refl.
    - inv PROMISE.
      + inv PROMISES0. inv ADD. auto.
      + inv PROMISES0. inv SPLIT. auto.
      + inv PROMISES0. inv LOWER. auto.
    - by inv PROMISE.
  Qed.

  Lemma read_step_future lc1 mem1 loc ts val released ord lc2
        (STEP: read_step lc1 mem1 loc ts val released ord lc2)
        (WF1: wf lc1 mem1)
        (CLOSED1: Memory.closed mem1):
    <<WF2: wf lc2 mem1>> /\
    <<TVIEW_FUTURE: TView.le lc1.(tview) lc2.(tview)>> /\
    <<REL_WF: View.opt_wf released>> /\
    <<REL_CLOSED: Memory.closed_opt_view released mem1>>.
  Proof.
    inv WF1. inv STEP.
    exploit TViewFacts.read_future; eauto.
    { eapply CLOSED1. eauto. }
    inv CLOSED1. exploit CLOSED; eauto. i. des.
    splits; auto.
    - econs; eauto.
    - apply TViewFacts.read_tview_incr.
  Qed.

  Lemma write_step_future lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind
        (STEP: write_step lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind)
        (REL_WF: View.opt_wf releasedm)
        (REL_CLOSED: Memory.closed_opt_view releasedm mem1)
        (WF1: wf lc1 mem1)
        (SC1: Memory.closed_timemap sc1 mem1)
        (CLOSED1: Memory.closed mem1):
    <<WF2: wf lc2 mem2>> /\
    <<SC2: Memory.closed_timemap sc2 mem2>> /\
    <<CLOSED2: Memory.closed mem2>> /\
    <<TVIEW_FUTURE: TView.le lc1.(tview) lc2.(tview)>> /\
    <<SC_FUTURE: TimeMap.le sc1 sc2>> /\
    <<MEM_FUTURE: Memory.future mem1 mem2>> /\
    <<REL_WF: View.opt_wf released>> /\
    <<REL_TS: Time.le (released.(View.unwrap).(View.rlx) loc) to>> /\
    <<REL_CLOSED: Memory.closed_opt_view released mem2>>.
  Proof.
    inv WF1. inv STEP.
    exploit TViewFacts.write_future; eauto.
    { inv WRITE. eapply Memory.promise_op. eauto. }
    s. i. des.
    exploit Memory.write_future; try apply WRITE; eauto. i. des.
    exploit Memory.write_get2; try apply WRITE; eauto; try by viewtac. i. des.
    splits; eauto.
    - econs; ss.
    - apply TViewFacts.write_tview_incr. auto.
    - refl.
    - inv WRITE. inv PROMISE; auto.
  Qed.

  Lemma fence_step_future lc1 sc1 mem1 ordr ordw lc2 sc2
        (STEP: fence_step lc1 sc1 ordr ordw lc2 sc2)
        (WF1: wf lc1 mem1)
        (SC1: Memory.closed_timemap sc1 mem1)
        (CLOSED1: Memory.closed mem1):
    <<WF2: wf lc2 mem1>> /\
    <<SC2: Memory.closed_timemap sc2 mem1>> /\
    <<TVIEW_FUTURE: TView.le lc1.(tview) lc2.(tview)>> /\
    <<SC_FUTURE: TimeMap.le sc1 sc2>>.
  Proof.
    inv WF1. inv STEP.
    exploit TViewFacts.read_fence_future; eauto. i. des.
    exploit TViewFacts.write_fence_future; eauto. i. des.
    splits; eauto.
    - econs; eauto.
    - etrans.
      + apply TViewFacts.write_fence_tview_incr. auto.
      + apply TViewFacts.write_fence_tview_mon; eauto; try refl.
        apply TViewFacts.read_fence_tview_incr. auto.
    - apply TViewFacts.write_fence_sc_incr.
  Qed.

  Lemma program_step_future e lc1 sc1 mem1 lc2 sc2 mem2
        (STEP: program_step e lc1 sc1 mem1 lc2 sc2 mem2)
        (WF1: wf lc1 mem1)
        (SC1: Memory.closed_timemap sc1 mem1)
        (CLOSED1: Memory.closed mem1):
    <<WF2: wf lc2 mem2>> /\
    <<SC2: Memory.closed_timemap sc2 mem2>> /\
    <<CLOSED2: Memory.closed mem2>> /\
    <<TVIEW_FUTURE: TView.le lc1.(tview) lc2.(tview)>> /\
    <<SC_FUTURE: TimeMap.le sc1 sc2>> /\
    <<MEM_FUTURE: Memory.future mem1 mem2>>.
  Proof.
    inv STEP.
    - esplits; eauto; try refl.
    - exploit read_step_future; eauto. i. des.
      esplits; eauto; try refl.
    - exploit write_step_future; eauto; try by econs. i. des.
      esplits; eauto; try refl.
    - exploit read_step_future; eauto. i. des.
      exploit write_step_future; eauto; try by econs. i. des.
      esplits; eauto. etrans; eauto.
    - exploit fence_step_future; eauto. i. des. esplits; eauto; try refl.
    - exploit fence_step_future; eauto. i. des. esplits; eauto; try refl.
  Qed.

  Lemma promise_step_disjoint
        lc1 sc1 mem1 loc from to val released lc2 mem2 lc kind
        (STEP: promise_step lc1 mem1 loc from to val released lc2 mem2 kind)
        (WF1: wf lc1 mem1)
        (SC1: Memory.closed_timemap sc1 mem1)
        (CLOSED1: Memory.closed mem1)
        (DISJOINT1: disjoint lc1 lc)
        (WF: wf lc mem1):
    <<DISJOINT2: disjoint lc2 lc>> /\
    <<WF: wf lc mem2>>.
  Proof.
    inv WF1. inv DISJOINT1. inversion WF. inv STEP.
    exploit Memory.promise_future; try apply PROMISE; eauto. i. des.
    exploit Memory.promise_disjoint; try apply PROMISE; eauto. i. des.
    splits; ss. econs; eauto.
    eapply TView.future_closed; eauto.
  Qed.

  Lemma read_step_disjoint
        lc1 mem1 lc2 loc ts val released ord lc
        (STEP: read_step lc1 mem1 loc ts val released ord lc2)
        (WF1: wf lc1 mem1)
        (DISJOINT1: disjoint lc1 lc)
        (WF: wf lc mem1):
    disjoint lc2 lc.
  Proof.
    inv WF1. inv DISJOINT1. inv WF. inv STEP. ss.
  Qed.

  Lemma write_step_disjoint
        lc1 sc1 mem1 lc2 sc2 loc from to val releasedm released ord mem2 kind lc
        (STEP: write_step lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind)
        (WF1: wf lc1 mem1)
        (SC1: Memory.closed_timemap sc1 mem1)
        (CLOSED1: Memory.closed mem1)
        (DISJOINT1: disjoint lc1 lc)
        (WF: wf lc mem1):
    <<DISJOINT2: disjoint lc2 lc>> /\
    <<WF: wf lc mem2>>.
  Proof.
    inv WF1. inv DISJOINT1. inversion WF. inv STEP.
    exploit Memory.write_future0; try apply WRITE; eauto; try by viewtac. i. des.
    exploit Memory.write_disjoint; try apply WRITE; eauto. i. des.
    splits; ss. econs; eauto.
    inv WRITE. eapply TView.promise_closed; eauto.
  Qed.

  Lemma fence_step_disjoint
        lc1 sc1 mem1 lc2 sc2 ordr ordw lc
        (STEP: fence_step lc1 sc1 ordr ordw lc2 sc2)
        (WF1: wf lc1 mem1)
        (SC1: Memory.closed_timemap sc1 mem1)
        (DISJOINT1: disjoint lc1 lc)
        (WF: wf lc mem1):
    <<DISJOINT2: disjoint lc2 lc>> /\
    <<WF: wf lc mem1>>.
  Proof.
    inv WF1. inv DISJOINT1. inv WF. inv STEP. splits; ss.
  Qed.

  Lemma read_step_promises
        lc1 mem loc to val released ord lc2
        (READ: read_step lc1 mem loc to val released ord lc2):
    lc1.(promises) = lc2.(promises).
  Proof.
    inv READ. auto.
  Qed.

  Lemma program_step_disjoint
        e lc1 sc1 mem1 lc2 sc2 mem2 lc
        (STEP: program_step e lc1 sc1 mem1 lc2 sc2 mem2)
        (WF1: wf lc1 mem1)
        (SC1: Memory.closed_timemap sc1 mem1)
        (CLOSED1: Memory.closed mem1)
        (DISJOINT1: disjoint lc1 lc)
        (WF: wf lc mem1):
    <<DISJOINT2: disjoint lc2 lc>> /\
    <<WF: wf lc mem2>>.
  Proof.
    inv STEP.
    - esplits; eauto.
    - exploit read_step_disjoint; eauto.
    - exploit write_step_disjoint; eauto.
    - exploit read_step_future; eauto. i. des.
      exploit read_step_disjoint; eauto. i. des.
      exploit write_step_disjoint; eauto.
    - exploit fence_step_disjoint; eauto.
    - exploit fence_step_disjoint; eauto.
  Qed.
End Local.

Module Thread.
  Section Thread.
    Variable (lang:language).

    Structure t := mk {
      state: lang.(Language.state);
      local: Local.t;
      sc: TimeMap.t;
      memory: Memory.t;
    }.

    Inductive promise_step (pf:bool): forall (e:ThreadEvent.t) (e1 e2:t), Prop :=
    | promise_step_intro
        st lc1 sc1 mem1
        loc from to val released kind
        lc2 mem2
        (LOCAL: Local.promise_step lc1 mem1 loc from to val released lc2 mem2 kind)
        (PF: pf = andb (Memory.op_kind_is_lower kind) (negb released)):
        promise_step pf (ThreadEvent.promise loc from to val released kind) (mk st lc1 sc1 mem1) (mk st lc2 sc1 mem2)
    .

    (* NOTE: Syscalls act like an SC fence.
     *)
    Inductive program_step (e:ThreadEvent.program_t): forall (e1 e2:t), Prop :=
    | program_step_intro
        st1 lc1 sc1 mem1
        st2 lc2 sc2 mem2
        (STATE: lang.(Language.step) (ThreadEvent.get_program_event e) st1 st2)
        (LOCAL: Local.program_step e lc1 sc1 mem1 lc2 sc2 mem2):
        program_step e (mk st1 lc1 sc1 mem1) (mk st2 lc2 sc2 mem2)
    .
    Hint Constructors program_step.

    Inductive step: forall (pf:bool) (e:ThreadEvent.t) (e1 e2:t), Prop :=
    | step_promise
        pf e e1 e2
        (STEP: promise_step pf e e1 e2):
        step pf e e1 e2
    | step_program
        e e1 e2
        (STEP: program_step e e1 e2):
        step true e e1 e2
    .
    Hint Constructors step.

    Inductive step_allpf (e:ThreadEvent.t) (e1 e2:t): Prop :=
    | step_nopf_intro
        pf
        (STEP: step pf e e1 e2)
    .
    Hint Constructors step_allpf.

    Lemma allpf pf: step pf <3= step_allpf.
    Proof.
      i. econs. eauto.
    Qed.

    Definition pf_tau_step := tau (step true).
    Hint Unfold pf_tau_step.

    Definition tau_step := tau step_allpf.
    Hint Unfold tau_step.

    Definition all_step := union step_allpf.
    Hint Unfold all_step.

    Inductive opt_step: forall (e:ThreadEvent.t) (e1 e2:t), Prop :=
    | step_none
        e:
        opt_step ThreadEvent.silent e e
    | step_some
        pf e e1 e2
        (STEP: step pf e e1 e2):
        opt_step e e1 e2
    .
    Hint Constructors opt_step.

    Definition consistent (e:t): Prop :=
      forall sc1 mem1
        (FUTURE: Memory.future e.(memory) mem1)
        (FUTURE: TimeMap.le e.(sc) sc1)
        (WF: Local.wf e.(local) mem1)
        (SC: Memory.closed_timemap sc1 mem1)
        (MEM: Memory.closed mem1),
      exists e2,
        <<STEPS: rtc tau_step (mk e.(state) e.(local) sc1 mem1) e2>> /\
        <<PROMISES: e2.(local).(Local.promises) = Memory.bot>>.

    Lemma promise_step_future
          pf e e1 e2
          (STEP: promise_step pf e e1 e2)
          (WF1: Local.wf e1.(local) e1.(memory))
          (SC1: Memory.closed_timemap e1.(sc) e1.(memory))
          (CLOSED1: Memory.closed e1.(memory)):
      <<WF2: Local.wf e2.(local) e2.(memory)>> /\
      <<SC2: Memory.closed_timemap e2.(sc) e2.(memory)>> /\
      <<CLOSED2: Memory.closed e2.(memory)>> /\
      <<TVIEW_FUTURE: TView.le e1.(Thread.local).(Local.tview) e2.(Thread.local).(Local.tview)>> /\
      <<SC_FUTURE: TimeMap.le e1.(sc) e2.(sc)>> /\
      <<MEM_FUTURE: Memory.future e1.(memory) e2.(memory)>>.
    Proof.
      inv STEP. ss.
      exploit Local.promise_step_future; eauto. i. des.
      splits; eauto. refl.
    Qed.

    Lemma program_step_future e e1 e2
          (STEP: program_step e e1 e2)
          (WF1: Local.wf e1.(local) e1.(memory))
          (SC1: Memory.closed_timemap e1.(sc) e1.(memory))
          (CLOSED1: Memory.closed e1.(memory)):
      <<WF2: Local.wf e2.(local) e2.(memory)>> /\
      <<SC2: Memory.closed_timemap e2.(sc) e2.(memory)>> /\
      <<CLOSED2: Memory.closed e2.(memory)>> /\
      <<TVIEW_FUTURE: TView.le e1.(Thread.local).(Local.tview) e2.(Thread.local).(Local.tview)>> /\
      <<SC_FUTURE: TimeMap.le e1.(sc) e2.(sc)>> /\
      <<MEM_FUTURE: Memory.future e1.(memory) e2.(memory)>>.
    Proof.
      inv STEP. ss. eapply Local.program_step_future; eauto.
    Qed.

    Lemma step_future pf e e1 e2
          (STEP: step pf e e1 e2)
          (WF1: Local.wf e1.(local) e1.(memory))
          (SC1: Memory.closed_timemap e1.(sc) e1.(memory))
          (CLOSED1: Memory.closed e1.(memory)):
      <<WF2: Local.wf e2.(local) e2.(memory)>> /\
      <<SC2: Memory.closed_timemap e2.(sc) e2.(memory)>> /\
      <<CLOSED2: Memory.closed e2.(memory)>> /\
      <<TVIEW_FUTURE: TView.le e1.(Thread.local).(Local.tview) e2.(Thread.local).(Local.tview)>> /\
      <<SC_FUTURE: TimeMap.le e1.(sc) e2.(sc)>> /\
      <<MEM_FUTURE: Memory.future e1.(memory) e2.(memory)>>.
    Proof.
      inv STEP.
      - eapply promise_step_future; eauto.
      - eapply program_step_future; eauto.
    Qed.

    Lemma step_nonpf_future e e1 e2
          (STEP: step false e e1 e2)
          (WF1: Local.wf e1.(local) e1.(memory))
          (SC1: Memory.closed_timemap e1.(sc) e1.(memory))
          (CLOSED1: Memory.closed e1.(memory)):
      <<WF2: Local.wf e2.(local) e2.(memory)>> /\
      <<SC2: Memory.closed_timemap e2.(sc) e2.(memory)>> /\
      <<CLOSED2: Memory.closed e2.(memory)>> /\
      <<TVIEW_FUTURE: TView.le e1.(local).(Local.tview) e2.(local).(Local.tview)>> /\
      <<SC_FUTURE: TimeMap.le e1.(sc) e2.(sc)>> /\
      <<MEM_FUTURE: Memory.future e1.(memory) e2.(memory)>> /\
      <<STATE: e1.(state) = e2.(state)>>.
    Proof.
      inv STEP. inv STEP0. ss.
      exploit Local.promise_step_future; eauto. i. des.
      esplits; ss. refl.
    Qed.

    Lemma opt_step_future e e1 e2
          (STEP: opt_step e e1 e2)
          (WF1: Local.wf e1.(local) e1.(memory))
          (SC1: Memory.closed_timemap e1.(sc) e1.(memory))
          (CLOSED1: Memory.closed e1.(memory)):
      <<WF2: Local.wf e2.(local) e2.(memory)>> /\
      <<SC2: Memory.closed_timemap e2.(sc) e2.(memory)>> /\
      <<CLOSED2: Memory.closed e2.(memory)>> /\
      <<TVIEW_FUTURE: TView.le e1.(Thread.local).(Local.tview) e2.(Thread.local).(Local.tview)>> /\
      <<SC_FUTURE: TimeMap.le e1.(sc) e2.(sc)>> /\
      <<MEM_FUTURE: Memory.future e1.(memory) e2.(memory)>>.
    Proof.
      inv STEP.
      - esplits; eauto; refl.
      - eapply step_future; eauto.
    Qed.

    Lemma rtc_all_step_future e1 e2
          (STEP: rtc all_step e1 e2)
          (WF1: Local.wf e1.(local) e1.(memory))
          (SC1: Memory.closed_timemap e1.(sc) e1.(memory))
          (CLOSED1: Memory.closed e1.(memory)):
      <<WF2: Local.wf e2.(local) e2.(memory)>> /\
      <<SC2: Memory.closed_timemap e2.(sc) e2.(memory)>> /\
      <<CLOSED2: Memory.closed e2.(memory)>> /\
      <<TVIEW_FUTURE: TView.le e1.(Thread.local).(Local.tview) e2.(Thread.local).(Local.tview)>> /\
      <<SC_FUTURE: TimeMap.le e1.(sc) e2.(sc)>> /\
      <<MEM_FUTURE: Memory.future e1.(memory) e2.(memory)>>.
    Proof.
      revert WF1. induction STEP.
      - i. splits; ss; refl.
      - i. inv H. inv USTEP.
        exploit step_future; eauto. i. des.
        exploit IHSTEP; eauto. i. des.
        splits; ss; etrans; eauto.
    Qed.

    Lemma rtc_tau_step_future e1 e2
          (STEP: rtc tau_step e1 e2)
          (WF1: Local.wf e1.(local) e1.(memory))
          (SC1: Memory.closed_timemap e1.(sc) e1.(memory))
          (CLOSED1: Memory.closed e1.(memory)):
      <<WF2: Local.wf e2.(local) e2.(memory)>> /\
      <<SC2: Memory.closed_timemap e2.(sc) e2.(memory)>> /\
      <<CLOSED2: Memory.closed e2.(memory)>> /\
      <<TVIEW_FUTURE: TView.le e1.(Thread.local).(Local.tview) e2.(Thread.local).(Local.tview)>> /\
      <<SC_FUTURE: TimeMap.le e1.(sc) e2.(sc)>> /\
      <<MEM_FUTURE: Memory.future e1.(memory) e2.(memory)>>.
    Proof.
      apply rtc_all_step_future; auto.
      eapply rtc_implies; [|eauto].
      apply tau_union.
    Qed.

    Lemma rtc_step_nonpf_future e1 e2
          (STEP: rtc (union (step false)) e1 e2)
          (WF1: Local.wf e1.(local) e1.(memory))
          (SC1: Memory.closed_timemap e1.(sc) e1.(memory))
          (CLOSED1: Memory.closed e1.(memory)):
      <<WF2: Local.wf e2.(local) e2.(memory)>> /\
      <<SC2: Memory.closed_timemap e2.(sc) e2.(memory)>> /\
      <<CLOSED2: Memory.closed e2.(memory)>> /\
      <<TVIEW_FUTURE: TView.le e1.(local).(Local.tview) e2.(local).(Local.tview)>> /\
      <<SC_FUTURE: TimeMap.le e1.(sc) e2.(sc)>> /\
      <<MEM_FUTURE: Memory.future e1.(memory) e2.(memory)>> /\
      <<STATE: e1.(state) = e2.(state)>>.
    Proof.
      revert WF1. induction STEP.
      - i. splits; ss; refl.
      - inv H. i. exploit step_nonpf_future; eauto. i. des.
        exploit IHSTEP; eauto. i. des.
        splits; ss; etrans; eauto.
    Qed.

    Lemma promise_step_disjoint
          pf e e1 e2 lc
        (STEP: promise_step pf e e1 e2)
        (WF1: Local.wf e1.(local) e1.(memory))
        (SC1: Memory.closed_timemap e1.(sc) e1.(memory))
        (CLOSED1: Memory.closed e1.(memory))
        (DISJOINT1: Local.disjoint e1.(local) lc)
        (WF: Local.wf lc e1.(memory)):
      <<DISJOINT2: Local.disjoint e2.(local) lc>> /\
      <<WF: Local.wf lc e2.(memory)>>.
    Proof.
      inv STEP.
      exploit Local.promise_step_future; eauto. i. des.
      exploit Local.promise_step_disjoint; eauto.
    Qed.

    Lemma program_step_disjoint e e1 e2 lc
        (STEP: program_step e e1 e2)
        (WF1: Local.wf e1.(local) e1.(memory))
        (SC1: Memory.closed_timemap e1.(sc) e1.(memory))
        (CLOSED1: Memory.closed e1.(memory))
        (DISJOINT1: Local.disjoint e1.(local) lc)
        (WF: Local.wf lc e1.(memory)):
      <<DISJOINT2: Local.disjoint e2.(local) lc>> /\
      <<WF: Local.wf lc e2.(memory)>>.
    Proof.
      inv STEP. ss. eapply Local.program_step_disjoint; eauto.
    Qed.

    Lemma step_disjoint pf e e1 e2 lc
        (STEP: step pf e e1 e2)
        (WF1: Local.wf e1.(local) e1.(memory))
        (SC1: Memory.closed_timemap e1.(sc) e1.(memory))
        (CLOSED1: Memory.closed e1.(memory))
        (DISJOINT1: Local.disjoint e1.(local) lc)
        (WF: Local.wf lc e1.(memory)):
      <<DISJOINT2: Local.disjoint e2.(local) lc>> /\
      <<WF: Local.wf lc e2.(memory)>>.
    Proof.
      inv STEP.
      - eapply promise_step_disjoint; eauto.
      - eapply program_step_disjoint; eauto.
    Qed.

    Lemma opt_step_disjoint e e1 e2 lc
        (STEP: opt_step e e1 e2)
        (WF1: Local.wf e1.(local) e1.(memory))
        (SC1: Memory.closed_timemap e1.(sc) e1.(memory))
        (CLOSED1: Memory.closed e1.(memory))
        (DISJOINT1: Local.disjoint e1.(local) lc)
        (WF: Local.wf lc e1.(memory)):
      <<DISJOINT2: Local.disjoint e2.(local) lc>> /\
      <<WF: Local.wf lc e2.(memory)>>.
    Proof.
      inv STEP.
      - esplits; eauto.
      - eapply step_disjoint; eauto.
    Qed.

    Lemma rtc_all_step_disjoint e1 e2 lc
        (STEP: rtc all_step e1 e2)
        (WF1: Local.wf e1.(local) e1.(memory))
        (SC1: Memory.closed_timemap e1.(sc) e1.(memory))
        (CLOSED1: Memory.closed e1.(memory))
        (DISJOINT1: Local.disjoint e1.(local) lc)
        (WF: Local.wf lc e1.(memory)):
      <<DISJOINT2: Local.disjoint e2.(local) lc>> /\
      <<WF: Local.wf lc e2.(memory)>>.
    Proof.
      revert WF1 DISJOINT1 WF. induction STEP; eauto. i.
      inv H. inv USTEP.
      exploit step_future; eauto. i. des.
      exploit step_disjoint; eauto. i. des.
      exploit IHSTEP; eauto.
    Qed.

    Lemma rtc_tau_step_disjoint e1 e2 lc
        (STEP: rtc tau_step e1 e2)
        (WF1: Local.wf e1.(local) e1.(memory))
        (SC1: Memory.closed_timemap e1.(sc) e1.(memory))
        (CLOSED1: Memory.closed e1.(memory))
        (DISJOINT1: Local.disjoint e1.(local) lc)
        (WF: Local.wf lc e1.(memory)):
      <<DISJOINT2: Local.disjoint e2.(local) lc>> /\
      <<WF: Local.wf lc e2.(memory)>>.
    Proof.
      eapply rtc_all_step_disjoint; cycle 1; eauto.
      eapply rtc_implies; [|eauto].
      apply tau_union.
    Qed.
  End Thread.
End Thread.

Lemma promise_pf_inv
      (kind:Memory.op_kind)
      (released:option View.t)
      (PF: (Memory.op_kind_is_lower kind) && (negb released)):
  exists released0, kind = Memory.op_kind_lower released0 /\
               released = None.
Proof.
  apply andb_true_iff in PF. des.
  destruct kind; inv PF. destruct released; inv PF0.
  esplits; eauto.
Qed.

Lemma promise_pf_false_inv
      (kind:Memory.op_kind)
      (released:option View.t)
      (PF: false = (Memory.op_kind_is_lower kind) && (negb released)):
  Memory.op_kind_is_lower kind = false \/ released <> None.
Proof.
  symmetry in PF. apply andb_false_iff in PF. des; auto.
  destruct released; ss. right. ss.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime S U1 A AX B BX C CX BXMAX CXMAX AB AC IAC T A1 A2 BXprimeprime CXprime ABXprimeprime ACXprimeprime : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ A1 A2 /\ (wd_ C CXprime /\ (wd_ B BXprimeprime /\ (wd_ A BXprimeprime /\ (wd_ O E /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ S U1 /\ (col_ O E AX /\ (col_ O E BX /\ (col_ O E CX /\ (col_ O E BXMAX /\ (col_ O E CXMAX /\ (col_ O E T /\ (col_ O E AB /\ (col_ O E AC /\ (col_ O E IAC /\ (col_ A A1 A2 /\ (col_ O E ABXprimeprime /\ (col_ O E ACXprimeprime /\ (col_ A1 A2 BXprimeprime /\ (col_ S U1 B /\ (col_ A1 A2 C /\ (col_ S U1 CXprime /\ col_ A B C))))))))))))))))))))))))))) -> col_ A B BXprimeprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal29.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons Zero Nil).
Definition lfind_example_2  := ( Nil).
Definition lfind_example_3  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_4  := ( Nil).
Definition lfind_example_5  := ( Nil).
Definition lfind_example_6  := ( Cons Zero Nil).
Definition lfind_example_7  := ( Nil).
Definition lfind_example_8  := ( Cons (Succ (Succ (Succ (Succ Zero))))         (Cons (Succ Zero) (Cons Zero Nil))).
Definition lfind_example_9  := ( Nil).
Definition lfind_example_10  := ( Nil).
Definition lfind_example_11  := ( Cons (Succ Zero) Nil).
Definition lfind_example_12  := ( Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_13  := ( Cons (Succ (Succ (Succ Zero))) Nil).
Definition lfind_example_14  := ( Cons Zero Nil).
Definition lfind_example_15  := ( Nil).
Definition lfind_example_16  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_17  := ( Nil).
Definition lfind_example_18  := ( Nil).
Definition lfind_example_19  := ( Nil).
Definition lfind_example_20  := ( Cons Zero Nil).
Definition lfind_example_21  := ( Cons Zero Nil).
Definition lfind_example_22  := ( Cons Zero (Cons Zero (Cons (Succ Zero) Nil))).
Definition lfind_example_23  := ( Nil).
Definition lfind_example_24  := ( Nil).
Definition lfind_example_25  := ( Nil).
Definition lfind_example_26  := ( Cons (Succ (Succ Zero)) (Cons Zero Nil)).
Definition lfind_example_27  := ( Cons (Succ Zero) (Cons Zero (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_28  := ( Nil).
Definition lfind_example_29  := ( Cons Zero Nil).
Definition lfind_example_30  := ( Nil).
Definition lfind_example_31  := ( Nil).
Definition lfind_example_32  := ( Cons (Succ Zero) Nil).
Definition lfind_example_33  := ( Nil).
Definition lfind_example_34  := ( Cons Zero Nil).
Definition lfind_example_35  := ( Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal29_append_assoc_41_append_nil/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 lfind_example_19 lfind_example_20 lfind_example_21 lfind_example_22 lfind_example_23 lfind_example_24 lfind_example_25 lfind_example_26 lfind_example_27 lfind_example_28 lfind_example_29 lfind_example_30 lfind_example_31 lfind_example_32 lfind_example_33 lfind_example_34 lfind_example_35 .


(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
(* Module with Certified Checking
   of Single-Pass Module.

   Last Update: Wed, 24 May 2017
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)

Add LoadPath "../..".

Require Import ConceptParams.AuxTactics.LibTactics.
Require Import ConceptParams.AuxTactics.BasicTactics.

Require Import ConceptParams.SetMapLib.List2Set.
Require Import ConceptParams.SetMapLib.ListPair2FMap.

Require Import ConceptParams.GenericModuleLib.SharedDataDefs.

Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Bool.Bool.

Require Import Coq.Structures.Orders.
Require Import Coq.Structures.Equalities.

(* ***************************************************************** *)
(** * Single-Pass Module *)

(** Single-Pass Module is well-defined if
    all names are different
    and all members are well-defined with following elements
      refering to the previously defined ones via local context. *)
(* ***************************************************************** *)
(* ***************************************************************** *)

(* ################################################################# *)
(** ** Shared Parameters of all building blocks *)
(* ################################################################# *)

Module Type SinglePassModuleBase.
  Include ModuleBase.

  Declare Module MD : DataLC.
  Import MD.

  (** Initial local context *)
  Parameter ctxl_init : ctxloc.
  (** Update local context *)
  Parameter upd_ctxloc : ctxloc -> ctx -> id -> t -> ctxloc.
End SinglePassModuleBase.

(* ################################################################# *)
(** ** Propositional Part *)
(* ################################################################# *)

Module SinglePassModuleDefs (Import MMB : SinglePassModuleBase)
       (Import TOkD : DataLCOkDef MMB.MD).

  Module HelperD.
    Export MD.
    Definition dt := t.

    (** We can use generic implementation of single-pass module
        checking from the SharedDataDefs.
        For this we need several aux functions. *)

    Definition update_prop (ok : Prop) (c : ctx)
               (cl : ctxloc) (decl : id * dt) : Prop
      := (* check curr member in the local context *)
          TOkD.is_ok c cl (snd decl)
          (* and preserve previous members' part *)
          /\ ok.

    Definition update_ctxloc (cl : ctxloc) (c : ctx)
               (decl : id * dt) : ctxloc
      := match decl with (nm, d) => upd_ctxloc cl c nm d end.

    (** We can use generic implementation of module-welldefinedness *)
    Module MSP := SinglePassModule_ProcessMembers.
    Module MGM := GenericModule_ModuleOk MId.

    (** Aux function checking that all members are ok. *)
    Definition members_ok (c : ctx) (decls : list (id * dt)) : Prop :=
      MSP.members_ok ctx ctxloc (id * dt)
                     update_prop update_ctxloc c ctxl_init decls.

  End HelperD.
  Import HelperD.

  (** Single-Pass Module given as the AST [decls]
   ** is well-defined in the context [c]. *)
  Definition module_ok (c : ctx) (decls : list (id * dt)) : Prop :=
    MGM.module_ok dt ctx members_ok c decls.

  Ltac unfold_def G :=
    unfold module_ok, MGM.module_ok in G.

End SinglePassModuleDefs.

(* ################################################################# *)
(** ** Computable Part (static checker of the interpreter) *)
(* ################################################################# *)

Module SinglePassModuleInterp (Import MMB : SinglePassModuleBase)
       (Import TOkI : DataLCOkInterp MMB.MD).

  Module HelperI.
    Export MD.
    Definition dt := t.

    Definition check_member  (c : ctx) (cl : ctxloc) (decl : id * dt) : bool
      := TOkI.is_ok_b c cl (snd decl).

    Definition update_ctxloc (cl : ctxloc) (c : ctx)
               (decl : id * dt) : ctxloc
      := match decl with (nm, d) => upd_ctxloc cl c nm d end.

    Module MSP := SinglePassModule_ProcessMembers.
    Module MGM := GenericModule_ModuleOk MId.

    (** Aux function checking that all members are ok. *)
    Definition members_ok_b (c : ctx) (decls : list (id * dt)) : bool :=
      MSP.members_ok_b ctx ctxloc (id * dt)
                       check_member update_ctxloc c ctxl_init decls.

  End HelperI.
  Import HelperI.

  (** Checks that a module given as the AST [decls]
   ** is well-defined in the context [c]. *)
  Definition module_ok_b (c : ctx) (decls : list (id * dt)) : bool :=
    MGM.module_ok_b dt ctx members_ok_b c decls.

End SinglePassModuleInterp.

(* ################################################################# *)
(** ** Proofs of Correctness *)
(* ################################################################# *)

Module SinglePassModuleProps
       (Import MMB : SinglePassModuleBase)
       (Import TOkD : DataLCOkDef MMB.MD)
       (Import TOkI : DataLCOkInterp MMB.MD)
       (Import TOkP : DataLCOkProp MMB.MD TOkD TOkI)
.
  Module Import MMD := SinglePassModuleDefs   MMB TOkD.
  Module Import MMI := SinglePassModuleInterp MMB TOkI.
  Import MMD.HelperD. Import MMI.HelperI.

(* ----------------------------------------------------------------- *)
(** *** Helper Props  *)
(* ----------------------------------------------------------------- *)

  Module Helper.
    Import MMD.HelperD.

    Lemma check_member__sound :
      forall (c : ctx) (cl : ctxloc) (decl : id * dt) (P : Prop),
        P ->
        check_member c cl decl = true ->
        update_prop P c cl decl.
    Proof.
      intros c cl decl P HP H.
      unfold check_member in H. unfold update_prop.
      apply TOkP.is_ok_b__sound in H. tauto.
    Qed.

    Lemma check_member__complete :
      forall (c : ctx) (cl : ctxloc) (decl : id * dt) (P : Prop),
        P ->
        update_prop P c cl decl ->
        check_member c cl decl = true.
    Proof.
      intros c cl decl P HP H.
      unfold check_member. unfold update_prop in H.
      apply TOkP.is_ok_b__complete. tauto.
    Qed.

    Lemma update_prop__spec :
      forall (c : ctx) (cl : ctxloc) (decl : id * dt) (P : Prop),
        update_prop P c cl decl -> P.
    Proof.
      intros c cl decl P H.
      unfold update_prop in H. tauto.
    Qed.

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

    Module MSP := SinglePassModule_ProcessMembers.
    Module MGM := GenericModule_ModuleOk MId.

    Lemma members_ok_b__sound :
      forall (c : ctx) (decls : list (id * dt)),
      members_ok_b c decls = true ->
      members_ok c decls.
    Proof.
      intros c ds H.
      unfold members_ok_b in H.
      unfold members_ok.
      apply MSP.members_ok_b__sound with (update_prop := update_prop) in H.
      assumption.
      exact check_member__sound.
    Qed.

    Lemma members_ok_b__complete :
      forall (c : ctx) (decls : list (id * dt)),
        members_ok c decls ->
        members_ok_b c decls = true.
    Proof.
      intros c ds H.
      unfold members_ok in H.
      unfold members_ok_b.
      apply MSP.members_ok_b__complete with (check_member := check_member) in H.
      assumption.
      exact check_member__complete.
      exact update_prop__spec.
    Qed.

  End Helper.

(* ================================================================= *)
(** *** Properties *)
(* ================================================================= *)

  Theorem module_ok_b__sound : forall (c : ctx) (decls : list (id * dt)),
      module_ok_b c decls = true ->
      module_ok c decls.
  Proof.
    apply Helper.MGM.module_ok_b__sound.
    apply Helper.members_ok_b__sound.
  Qed.

  Theorem module_ok_b__complete : forall (c : ctx) (decls : list (id * dt)),
      module_ok c decls ->
      module_ok_b c decls = true.
  Proof.
    apply Helper.MGM.module_ok_b__complete.
    apply Helper.members_ok_b__complete.
  Qed.

End SinglePassModuleProps.


Set Warnings "-notation-overridden".

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Set Transparent Obligations.

(* Copyright (c) 2014, John Wiegley
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(** %\chapter{Category}% *)

Require Import Hask.Prelude.
Require Import Hask.Crush.
Require Import Coq.Unicode.Utf8.
Require Import FunctionalExtensionality.

Axiom propositional_extensionality : forall P : Prop, P -> P = True.
Axiom proof_irrelevance : forall (P : Prop) (u v : P), u = v.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
(* Unset Transparent Obligations. *)

(** * Category *)

(** Category theory is a language for reasoning about abstractions.
Awodey%\cite{Awodey}% calls it, "the algebra of abstract functions."  Its
power lies in relating ideas from differing disciplines, and unifying them
under a common framework.

At its heart we have the [Category].  Every category is characterized by
its objects, and the morphisms (also called arrows) between those
objects. *)

(* begin hide *)
Reserved Notation "a ~> b" (at level 70, right associativity).
Reserved Notation "f ∘ g" (at level 40, left associativity).
Reserved Notation "C ^op" (at level 90).
(* end hide *)

Class Category := {
    ob   : Type;
    (* These require Coq 8.5 and universe polymorphism. *)
    (* uhom := Type : Type; *)
    (* hom  : ob → ob → uhom where "a ~> b" := (hom a b); *)
    hom  : ob → ob → Type where "a ~> b" := (hom a b);
(**

It is important to note that objects and arrows have no inherent meaning: The
notion of a category requires only that they exist, and that they be
well-behaved.  Since all we can know about objects is that they exist, they
serve only to differentiate morphisms.  Conversely, morphisms are how we
characterize objects. *)

(** * Morphisms

In this formalization, as in many textbooks, morphisms are called [hom], for
"homomorphism" (algebraic structure-preserving maps).  Each morphism
represents the set of all morphism having that type, so they are also called
"hom-sets".

Since categories may have other categories as objects, we require that the
type of [hom] be larger than the type of its arguments.  This is the purpose
of the [uhom] type, allowing us to make use of Coq's support for universe
polymorphism.

*)

    c_id : ∀ {A}, A ~> A;
    c_comp : ∀ {A B C}, (B ~> C) → (A ~> B) → (A ~> C)
      where "f ∘ g" := (c_comp f g);
(**

If [ob] and [hom] are the nouns of category theory, [id] and [compose] are its
fundamental verbs.  Using only these notions we can reason about concepts such
as _idempotency_, _involution_, _section_ and _retraction_, _equalizers_ and
_co-equalizers_, and more.  Before we may do so, however, we must constrain
identity and composition under three laws:

*)

    c_right_id : ∀ A B (f : A ~> B), f ∘ c_id = f;
    c_left_id : ∀ A B (f : A ~> B), c_id ∘ f = f;
    c_comp_assoc : ∀ A B C D (f : C ~> D) (g : B ~> C) (h : A ~> B),
        f ∘ (g ∘ h) = (f ∘ g) ∘ h
}.

(**

Note the difference between the arrow used for function types in Coq, such as
[A → B], and for morphisms in a category [A ~> B].  If the category must be
indicated, it is stated in the arrow: [A ~{C}~> B]. *)

(* begin hide *)
(* Using a [Category] in a context requiring a [Type] will do what is expected
   using this coercion. *)
Coercion ob : Category >-> Sortclass.
(* Coercion hom : Category >-> Funclass. *)

Declare Scope category_scope.

Infix "~>"       := hom : category_scope.
Infix "~{ C }~>" := (@hom C) (at level 100) : category_scope.
Infix "∘"        := c_comp (at level 40, left associativity) : category_scope.

Notation "ob/ C" := (@ob C) (at level 1) : category_scope.
Notation "id/ X" := (@c_id _ X) (at level 1) : category_scope.

Open Scope category_scope.

Lemma cat_irrelevance `(C : Category) `(D : Category)
  : ∀ (m n : ∀ {A}, A ~> A)
      (p q : ∀ {A B C}, (B ~> C) → (A ~> B) → (A ~> C))
      l l' r r' c c',
  @m = @n →
  @p = @q →
  {| ob           := C
   ; hom          := @hom C
   ; c_id         := @m
   ; c_comp       := @p
   ; c_left_id    := l
   ; c_right_id   := r
   ; c_comp_assoc := c
 |} =
  {| ob           := C
   ; hom          := @hom C
   ; c_id         := @n
   ; c_comp       := @q
   ; c_left_id    := l'
   ; c_right_id   := r'
   ; c_comp_assoc := c'
 |}.
Proof.
  intros. subst. f_equal.
  apply proof_irrelevance.
  apply proof_irrelevance.
  apply proof_irrelevance.
Qed.

#[export] Hint Extern 1 => apply c_left_id : core.
#[export] Hint Extern 1 => apply c_right_id : core.

#[export] Hint Extern 4 (?A = ?A) => reflexivity : core.
#[export] Hint Extern 7 (?X = ?Z) =>
  match goal with
    [H : ?X = ?Y, H' : ?Y = ?Z |- ?X = ?Z] => transitivity Y
  end : core.

(* end hide *)

(**

We may now extend our discourse about functions, using only the few terms
we've defined so far:

*)

(* begin hide *)
Section Morphisms.
Context `{C : Category}.
(* end hide *)

Definition Idempotent `(f : X ~> X) := f ∘ f = f.
Definition Involutive `(f : X ~> X) := f ∘ f = c_id.

(**

We can also define relationships between two functions:

*)

Definition Section'   `(f : X ~> Y) := { g : Y ~> X & g ∘ f = c_id }.
Definition Retraction `(f : X ~> Y) := { g : Y ~> X & f ∘ g = c_id }.

Class SplitIdempotent {X Y : C} := {
    split_idem_retract := Y;

    split_idem       : X ~> X;
    split_idem_r     : X ~> split_idem_retract;
    split_idem_s     : split_idem_retract ~> X;
    split_idem_law_1 : split_idem_s ∘ split_idem_r = split_idem;
    split_idem_law_2 : split_idem_r ∘ split_idem_s = id/Y
}.

(**

A Σ-type (sigma type) is used to convey [Section'] and [Retraction] to make
the witness available to proofs.  The definition could be expressed with an
existential quantifier (∃), but it would not convey which [g] was chosen.

*)

Definition Epic  `(f : X ~> Y) := ∀ Z (g1 g2 : Y ~> Z), g1 ∘ f = g2 ∘ f → g1 = g2.
Definition Monic `(f : X ~> Y) := ∀ Z (g1 g2 : Z ~> X), f ∘ g1 = f ∘ g2 → g1 = g2.

Definition Bimorphic `(f : X ~> Y) := Epic f ∧ Monic f.
Definition SplitEpi  `(f : X ~> Y) := Retraction f.
Definition SplitMono `(f : X ~> Y) := Section' f.

(**

The only morphism we've seen so far is [id], but we can trivially prove it is
both _idempotent_ and _involutive_. *)

(* begin hide *)
Hint Unfold Idempotent : core.
Hint Unfold Involutive : core.
Hint Unfold Section' : core.
Hint Unfold Retraction : core.
Hint Unfold Epic : core.
Hint Unfold Monic : core.
Hint Unfold Bimorphic : core.
Hint Unfold SplitEpi : core.
Hint Unfold SplitMono : core.
(* end hide *)

Lemma id_idempotent : ∀ X, Idempotent (c_id (A := X)).
Proof. auto. Qed.

Lemma id_involutive : ∀ X, Involutive (c_id (A := X)).
Proof. auto. Qed.

(**

We can also prove some relationships among these definitions. *)

(* begin hide *)
Section Lemmas.
Variables X Y : C.
Variable f : X ~> Y.
(* end hide *)

Lemma retractions_are_epic : Retraction f → Epic f.
Proof.
  autounfold.
  intros.
  destruct X0.
  rewrite <- c_right_id.
  symmetry.
  rewrite <- c_right_id.
  rewrite <- e.
  repeat (rewrite c_comp_assoc); try f_equal; auto.
Qed.

Lemma sections_are_monic : Section' f → Monic f.
Proof.
  autounfold.
  intros.
  destruct X0.
  rewrite <- c_left_id.
  symmetry.
  rewrite <- c_left_id.
  rewrite <- e.
  repeat (rewrite <- c_comp_assoc); try f_equal; auto.
Qed.

(* begin hide *)
End Lemmas.
End Morphisms.
(* end hide *)

Definition epi_compose `{C : Category} {X Y Z : C}
  `(ef : @Epic C Y Z f) `(eg : @Epic C X Y g) : Epic (f ∘ g).
Proof.
  unfold Epic in *. intros.
  apply ef.
  apply eg.
  repeat (rewrite <- c_comp_assoc); auto.
Qed.

Definition monic_compose `{C : Category} {X Y Z : C}
  `(ef : @Monic C Y Z f) `(eg : @Monic C X Y g) : Monic (f ∘ g).
Proof.
  unfold Monic in *. intros.
  apply eg.
  apply ef.
  repeat (rewrite c_comp_assoc); auto.
Qed.

(** * Isomorphism

An isomorphism is a pair of mappings that establish an equivalence between
objects.  Using the language above, it is a pair of functions which are both
sections and retractions of one another.  That is, they compose to identity in
both directions:

*)

Class Isomorphism `{C : Category} (X Y : C) := {
  to       : X ~> Y;
  from     : Y ~> X;
  iso_to   : to ∘ from = id/Y;
  iso_from : from ∘ to = id/X
}.

(* begin hide *)
Lemma iso_irrelevance `(C : Category) {X Y : C}
  : ∀ (f g : X ~> Y) (k h : Y ~> X) tl tl' fl fl',
  @f = @g →
  @k = @h →
  {| to       := f
   ; from     := k
   ; iso_to   := tl
   ; iso_from := fl
  |} =
  {| to       := g
   ; from     := h
   ; iso_to   := tl'
   ; iso_from := fl'
  |}.
Proof.
  intros. subst. f_equal.
  apply proof_irrelevance.
  apply proof_irrelevance.
Qed.
(* end hide *)

(**

Typically isomorphisms are characterized by this pair of functions, but they
can also be expressed as an equivalence between objects using the notation [A
≅ B].  A double-tilde is used to express the same notion of equivalence
between value terms [a = b].

*)

Notation "X {≅} Y" :=
  (Isomorphism X Y) (at level 70, right associativity) : category_scope.
Notation "x {≡} y" :=
  (to x = y ∧ from y = x) (at level 70, right associativity).

(**

[id] witnesses the isomorphism between any object and itself.  Isomorphisms
are likewise symmetric and transitivity, making them parametric relations.
This will allows us to use them in proof rewriting as though they were
equalities.

*)

Program Definition iso_identity `{C : Category} (X : C) : X {≅} X := {|
    to   := id/X;
    from := id/X
|}.

Program Definition iso_symmetry `{C : Category} `(iso : X {≅} Y) : Y {≅} X := {|
    to   := @from C X Y iso;
    from := @to C X Y iso
|}.
(* begin hide *)
Obligation 1. apply iso_from. Qed.
Obligation 2. apply iso_to. Qed.
(* end hide *)

Program Definition iso_compose `{C : Category} {X Y Z : C}
    (iso_a : Y {≅} Z) (iso_b : X {≅} Y) : X {≅} Z := {|
    to   := (@to C Y Z iso_a) ∘ (@to C X Y iso_b);
    from := (@from C X Y iso_b) ∘ (@from C Y Z iso_a)
|}.
(* begin hide *)
Obligation 1.
  destruct iso_a.
  destruct iso_b. simpl.
  rewrite <- c_comp_assoc.
  rewrite (c_comp_assoc _ _ _ _ to1).
  rewrite iso_to1.
  rewrite c_left_id.
  assumption.
Qed.
Obligation 2.
  destruct iso_a.
  destruct iso_b. simpl.
  rewrite <- c_comp_assoc.
  rewrite (c_comp_assoc _ _ _ _ from0).
  rewrite iso_from0.
  rewrite c_left_id.
  assumption.
Qed.
(* end hide *)

(*
Definition iso_equiv `{C : Category} {a b : C} (x y : a ≅ b) : Prop :=
  match x with
  | Build_Isomorphism to0 from0 _ _ => match y with
    | Build_Isomorphism to1 from1 _ _ =>
      to0 = to1 ∧ from0 = from1
    end
  end.

Program Definition iso_equivalence `{C : Category} (a b : C)
  : Equivalence (@iso_equiv C a b).
Obligation 1.
  unfold Reflexive, iso_equiv. intros.
  destruct x. auto.
Defined.
Obligation 2.
  unfold Symmetric, iso_equiv. intros.
  destruct x. destruct y.
  inversion H.
  split; symmetry; assumption.
Defined.
Obligation 3.
  unfold Transitive, iso_equiv. intros.
  destruct x. destruct y. destruct z.
  inversion H. inversion H0.
  split. transitivity to1; auto.
  transitivity from1; auto.
Defined.

Add Parametric Relation `(C : Category) (a b : C) : (a ≅ b) (@iso_equiv C a b)
  reflexivity proved by  (@Equivalence_Reflexive  _ _ (iso_equivalence a b))
  symmetry proved by     (@Equivalence_Symmetric  _ _ (iso_equivalence a b))
  transitivity proved by (@Equivalence_Transitive _ _ (iso_equivalence a b))
    as parametric_relation_iso_eqv.

  Add Parametric Morphism `(C : Category) (a b c : C) : (@iso_compose C a b c)
    with signature (iso_equiv ==> iso_equiv ==> iso_equiv)
      as parametric_morphism_iso_comp.
    intros. unfold iso_equiv, iso_compose.
    destruct x. destruct y. destruct x0. destruct y0.
    simpl in *.
    inversion H. inversion H0.
    split; crush.
Defined.
*)

(**

A [Groupoid] is a [Category] where every morphism has an inverse, and is
therefore an isomorphism.

*)

Program Definition Groupoid `(C : Category) : Category := {|
    ob      := @ob C;
    hom     := @Isomorphism C;
    c_id    := @iso_identity C
|}.
(* begin hide *)
Next Obligation.
  unfold iso_compose, iso_identity.
  eapply iso_compose; eauto.
Defined.
Next Obligation.
  unfold Groupoid_obligation_1.
  unfold iso_compose, iso_identity.
  destruct f. simpl in *.
  apply iso_irrelevance.
  apply c_right_id.
  apply c_left_id.
Qed.
Next Obligation.
  unfold Groupoid_obligation_1.
  unfold iso_compose, iso_identity.
  destruct f. simpl in *.
  apply iso_irrelevance.
  apply c_left_id.
  apply c_right_id.
Qed.
Next Obligation.
  unfold Groupoid_obligation_1.
  unfold iso_compose.
  destruct f. destruct g. destruct h.
  simpl; apply iso_irrelevance;
  rewrite c_comp_assoc; reflexivity.
Qed.
(* end hide *)

(**

A function which is both a retraction and monic, or a section and epic, bears
an isomorphism with its respective witness.

*)

Program Definition Monic_Retraction_Iso `{C : Category}
  `(f : X ~{C}~> Y) (r : Retraction f) (m : Monic f) : X {≅} Y := {|
  to   := f;
  from := projT1 r
|}.
(* begin hide *)
Obligation 1.
  autounfold in *.
  destruct r.
  auto.
Qed.
Obligation 2.
  autounfold in *.
  destruct r.
  simpl.
  specialize (m X (x ∘ f) c_id).
  apply m.
  rewrite c_comp_assoc.
  rewrite e.
  auto.
  rewrite c_left_id.
  rewrite c_right_id.
  reflexivity.
Qed.
(* end hide *)

Program Definition Epic_Section_Iso
    `{C : Category} {X Y} `(s : Section' f) `(e : Epic f) : X {≅} Y := {|
    to   := f;
    from := projT1 s
|}.
(* begin hide *)
Obligation 1.
  autounfold in *.
  destruct s.
  simpl.
  specialize (e Y (f ∘ x) c_id).
  apply e.
  rewrite <- c_comp_assoc.
  rewrite e0.
  rewrite c_left_id.
  rewrite c_right_id.
  reflexivity.
Qed.
Obligation 2.
  autounfold in *.
  destruct s.
  specialize (e Y (f ∘ x) c_id).
  auto.
Qed.

#[export] Hint Unfold Idempotent : core.
#[export] Hint Unfold Involutive : core.
#[export] Hint Unfold Section' : core.
#[export] Hint Unfold Retraction : core.
#[export] Hint Unfold Epic : core.
#[export] Hint Unfold Monic : core.
#[export] Hint Unfold Bimorphic : core.
#[export] Hint Unfold SplitEpi : core.
#[export] Hint Unfold SplitMono : core.
(* end hide *)

(**

A section may be flipped using its witness to provide a retraction, and
vice-versa.

*)

Definition flip_section `{Category} `(f : X ~> Y)
  (s : @Section' _ X Y f) : @Retraction _ Y X (projT1 s).
Proof.
  autounfold.
  destruct s.
  exists f.
  crush.
Qed.

Definition flip_retraction `{Category} `(f : X ~> Y)
  (s : @Retraction _ X Y f) : @Section' _ Y X (projT1 s).
Proof.
  autounfold.
  destruct s.
  exists f.
  crush.
Qed.

(** * Sets

[Sets] is our first real category: the category of Coq types and functions.
The objects of this category are all the Coq types (including [Set], [Prop]
and [Type]), and its morphisms are functions from [Type] to [Type].  [id]
simply returns whatever object is passed, and [compose] is regular composition
between functions.  Proving it is a category in Coq is automatic.

Note that in many textbooks this category (or one similar to it) is called
just [Set], but since that name conflicts with types of the same name in Coq,
the plural is used instead.

*)

Program Definition Sets : Category := {|
    ob     := Type;
    hom    := fun X Y => X → Y;
    c_id   := fun _ x => x;
    c_comp := fun _ _ _ f g x => f (g x)
|}.
(**

Within the category of [Sets] we can prove that monic functions are injective,
and epic functions are surjective.  This is not necessarily true in other
categories.

*)

Notation "X ≅Sets Y" :=
  (@Isomorphism Sets X Y) (at level 70, right associativity) : category_scope.

Definition Injective `(f : X → Y) := ∀ x y, f x = f y → x = y.

Lemma injectivity_is_monic `(f : X → Y) : Injective f ↔ @Monic Sets _ _ f.
Proof.
  unfold Monic, Injective.
  split; intros; simpl in *.
  - extensionality z.
    apply H. apply (equal_f H0).
  - pose (fun (_ : unit) => x) as const_x.
    pose (fun (_ : unit) => y) as const_y.
    specialize (H unit const_x const_y).
    unfold const_x in H.
    unfold const_y in H.
    apply equal_f in H.
    + assumption.
    + extensionality tt. assumption.
    + constructor.
Qed.

Definition Surjective `(f : X → Y) := ∀ y, ∃ x, f x = y.

Lemma surjectivity_is_epic `(f : X → Y) : Surjective f ↔ @Epic Sets _ _ f.
Proof.
  unfold Epic, Surjective.
  split; intros; simpl in *.
  - extensionality y.
    specialize (H y).
    destruct H.
    rewrite <- H.
    apply (equal_f H0).
  - specialize H with (Z := Prop).
    specialize H with (g1 := fun y0 => ∃ x0, f x0 = y0).
    specialize H with (g2 := fun y  => True).
    eapply equal_f in H.
    erewrite H. constructor.
    extensionality x.
    apply propositional_extensionality.
    exists x. reflexivity.
Qed.

(** * Dual Category

The opposite, or dual, of a category is expressed [C^op].  It has the same
objects as its parent, but the direction of all morphisms is flipped.  Doing
this twice should result in the same category, making it an involutive
operation.

*)

Program Definition Opposite `(C : Category) : Category := {|
    ob     := @ob C;
    hom    := fun x y => @hom C y x;
    c_id   := @c_id C;
    c_comp := fun _ _ _ f g => g ∘ f
|}.
Obligation 3. rewrite c_comp_assoc. auto. Defined.

(* begin hide *)
Notation "C ^op" := (Opposite C) (at level 90) : category_scope.
(* end hide *)

Lemma op_involutive (C : Category) : (C^op)^op = C.
Proof.
  unfold Opposite.
  unfold Opposite_obligation_1.
  unfold Opposite_obligation_2.
  unfold Opposite_obligation_3.
  simpl. destruct C. simpl.
  apply f_equal3; repeat (extensionality e; simpl; crush).
  extensionality b.
  extensionality c.
  extensionality d.
  extensionality f.
  extensionality g.
  extensionality h. crush.
Qed.

(**

Using the functions [op] and [unop], we can "flip" a particular morphism by
mapping to its corresponding morphism in the dual category.

*)

Definition op `{C : Category} : ∀ {X Y}, (X ~{C^op}~> Y) → (Y ~{C}~> X).
Proof. auto. Defined.

Definition unop `{C : Category} : ∀ {X Y}, (Y ~{C}~> X) → (X ~{C^op}~> Y).
Proof. auto. Defined.


Require Import type.

Fixpoint instr_eq_dec i1 : forall i2 : instr, {i1 = i2} + {i1 <> i2}.
Proof. repeat decide equality. Defined.


Require Import VST.floyd.proofauto.
Require Import VST.floyd.VSU.
Require Import triang.
Require Import simple_spec_stdlib.
Require Import simple_spec_pile.
Require Import simple_spec_triang.
Require Import PileModel.

Definition triang_imported_specs:funspecs := PileASI.
Definition triang_internal_specs: funspecs := TriangASI.
Definition TriangVprog: varspecs. mk_varspecs prog. Defined.
Definition TriangGprog: funspecs := triang_imported_specs ++ triang_internal_specs.

Lemma body_Triang_nth: semax_body TriangVprog TriangGprog f_Triang_nth Triang_nth_spec.
Proof.
start_function.
forward_call gv.
Intros p.
forward_for_simple_bound n
  (EX i:Z,
   PROP() LOCAL(temp _p p; temp _n (Vint (Int.repr n)); gvars gv)
   SEP (pilerep (decreasing (Z.to_nat i)) p; pile_freeable p; mem_mgr gv)).
-
 entailer!.
- forward_call (p, i+1, decreasing(Z.to_nat i), gv).
rep_lia.
entailer!.
assert (Z.to_nat (i+1) = S (Z.to_nat i))
  by (rewrite <- Z2Nat.inj_succ by lia; f_equal).
rewrite H2.
unfold decreasing; fold decreasing.
rewrite inj_S.
rewrite Z2Nat.id by lia.
apply derives_refl.
-
forward_call (p, decreasing (Z.to_nat n)).
apply sumlist_decreasing_bound; auto.
forward_call (p, decreasing (Z.to_nat n), gv).
forward.
entailer!.
f_equal; f_equal.
clear.
induction (Z.to_nat n).
reflexivity.
simpl. congruence.
Qed.

Definition TriangVSU: @VSU NullExtension.Espec
      nil triang_imported_specs ltac:(QPprog prog) TriangASI emp.
  Proof.
    mkVSU prog triang_internal_specs.
    + solve_SF_internal body_Triang_nth.
  Qed.


(** * Definition of the system HR *)
Require Import Rpos.
Require Import RL.hr.term.
Require Import RL.hr.semantic.
Require Import RL.hr.hseq.

Require Import CMorphisms.
Require Import List.
Require Import Lra.

Require Import RL.OLlibs.Permutation_Type.
Require Import RL.OLlibs.Permutation_Type_more.
Require Import RL.OLlibs.Permutation_Type_solve.

Local Open Scope R_scope.

(** ** Fragments of the system HR, i.e. whether we can use the T rule, the M rule or the CAN rule *)
Record hr_frag := mk_hr_frag {
                      hr_T : bool;
                      hr_M : bool;
                      hr_CAN : bool }.

Definition le_hr_frag P Q :=
  prod (Bool.le (hr_T P) (hr_T Q))
       (prod (Bool.le (hr_M P) (hr_M Q))
             (Bool.le (hr_CAN P) (hr_CAN Q))).

Lemma le_hr_frag_trans : forall P Q R,
  le_hr_frag P Q -> le_hr_frag Q R -> le_hr_frag P R.
Proof.
intros P Q R H1 H2.
destruct H1 as (Ht1 & Hm1 & Hcan1).
destruct H2 as (Ht2 & Hm2 & Hcan2).
repeat split; destruct P; destruct Q; destruct R; Bool.destr_bool.
Qed.

Instance le_hr_frag_po : PreOrder le_hr_frag.
Proof.
split.
- repeat split; destruct x; Bool.destr_bool.
- intros P Q R.
  apply le_hr_frag_trans.
Qed.

Definition hr_frag_add_T P := mk_hr_frag true (hr_M P) (hr_CAN P).
Definition hr_frag_rm_T P := mk_hr_frag false (hr_M P) (hr_CAN P).
Definition hr_frag_add_M P := mk_hr_frag (hr_T P) true (hr_CAN P).
Definition hr_frag_rm_M P := mk_hr_frag (hr_T P) false (hr_CAN P).
Definition hr_frag_add_CAN P := mk_hr_frag (hr_T P) (hr_M P) true.
Definition hr_frag_rm_CAN P := mk_hr_frag (hr_T P) (hr_M P) false.

Lemma add_T_le_frag : forall P, le_hr_frag P (hr_frag_add_T P).
Proof.
  intros P.
  repeat split; destruct P; Bool.destr_bool.
Qed.
Lemma add_M_le_frag : forall P, le_hr_frag P (hr_frag_add_M P).
Proof.
  intros P.
  repeat split; destruct P; Bool.destr_bool.
Qed.
Lemma add_CAN_le_frag : forall P, le_hr_frag P (hr_frag_add_CAN P).
Proof.
  intros P.
  repeat split; destruct P; Bool.destr_bool.
Qed.
Lemma rm_T_le_frag : forall P, le_hr_frag (hr_frag_rm_T P) P.
Proof.
  intros P.
  repeat split; destruct P; Bool.destr_bool.
Qed.
Lemma rm_M_le_frag : forall P, le_hr_frag (hr_frag_rm_M P) P.
Proof.
  intros P.
  repeat split; destruct P; Bool.destr_bool.
Qed.
Lemma rm_CAN_le_frag : forall P, le_hr_frag (hr_frag_rm_CAN P) P.
Proof.
  intros P.
  repeat split; destruct P; Bool.destr_bool.
Qed.

(** only the following fragments are interesting for what we want to do *)
Definition hr_frag_M_can := (mk_hr_frag false true true).
Definition hr_frag_full := (mk_hr_frag true true true).
Definition hr_frag_T_M := (mk_hr_frag true true false).
Definition hr_frag_T := (mk_hr_frag true false false).
Definition hr_frag_M := (mk_hr_frag false true false).
Definition hr_frag_nothing := (mk_hr_frag false false false).

(** * Definition of hr *)
(** ** HR *)

Inductive HR P : hypersequent -> Type :=
| hrr_INIT : HR P (nil :: nil)
| hrr_W : forall G T, HR P G -> HR P (T :: G)
| hrr_C : forall G T, HR P (T :: T :: G) -> HR P (T :: G)
| hrr_S : forall G T1 T2, HR P ((T1 ++ T2) :: G) -> HR P (T1 :: T2 :: G)
| hrr_M {f : hr_M P = true} : forall G T1 T2, HR P (T1 :: G) -> HR P (T2 :: G) -> HR P ((T1 ++ T2) :: G)
| hrr_T {f : hr_T P = true} : forall G T r, HR P (seq_mul r T :: G) -> HR P (T :: G)
| hrr_ID : forall G T n r s, sum_vec r = sum_vec s -> HR P (T :: G) -> HR P ((vec s (HR_covar n) ++ vec r (HR_var n) ++ T) :: G)
| hrr_Z : forall G T r, HR P (T :: G) -> HR P ((vec r HR_zero ++ T) :: G)

| hrr_plus : forall G T A B r, HR P ((vec r A ++ vec r B ++ T) :: G) -> HR P ((vec r (A +S B) ++ T) :: G)
| hrr_mul : forall G T A r0 r, HR P ((vec (mul_vec r0 r) A ++ T) :: G) -> HR P ((vec r (r0 *S A) ++ T) :: G)
| hrr_max : forall G T A B r, HR P ((vec r B ++ T) :: (vec r A ++ T) :: G) -> HR P ((vec r (A \/S B) ++ T) :: G)
| hrr_min : forall G T A B r, HR P ((vec r A ++ T) :: G) -> HR P ((vec r B ++ T) :: G) -> HR P ((vec r (A /\S B) ++ T) :: G)
| hrr_ex_seq : forall G T1 T2, Permutation_Type T1 T2 -> HR P (T1 :: G) -> HR P (T2 :: G)
| hrr_ex_hseq : forall G H, Permutation_Type G H -> HR P G -> HR P H
| hrr_can {f : hr_CAN P = true} : forall G T A r s, sum_vec r = sum_vec s -> HR P ((vec s (-S A) ++ vec r A ++ T) :: G) -> HR P (T :: G).

(** HR with only can and M *)
Definition HR_M_can := HR hr_frag_M_can.
(** HR with every rule *)
Definition HR_full := HR hr_frag_full.
(** HR without the CAN rule *)
Definition HR_T_M := HR hr_frag_T_M.
(** HR with neither the CAN rule nor the M rule *)
Definition HR_T := HR hr_frag_T.
(** HR with only the M rule*)
Definition HR_M := HR hr_frag_M.
(** HR with neither the CAN rule nor the M rule nor the T rule*)
Definition HR_nothing := HR hr_frag_nothing.

(** ** Some basic properties for the system HR *)
Lemma HR_not_empty P : forall G, HR P G -> G <> nil.
Proof.
  intros G pi; induction pi; (try now auto).
  intros Heq; apply IHpi; apply Permutation_Type_nil.
  symmetry; now rewrite <- Heq.
Qed.

(** if we add some rules, we keep the derivability (for instance, a hypersequent provable without the T rule is provable with the T rule) *)
Lemma HR_le_frag : forall P Q,
    le_hr_frag P Q ->
    forall G, HR P G -> HR Q G.
Proof.
  intros P Q Hle G pi.
  induction pi;  destruct P as [HTP HMP HCANP]; destruct Q as [HTQ HMQ HCANQ]; destruct Hle as [HleT [HleM HleCAN]]; simpl in *; subst; try (now constructor).
  - apply hrr_T with r; assumption.
  - apply hrr_ex_seq with T1; assumption.
  - apply hrr_ex_hseq with G; assumption.
  - apply hrr_can with A r s; try assumption; try reflexivity.
Qed.

(** some others derivable rules *)
Lemma hrr_W_gen P : forall G H, HR P G -> HR P (H ++ G).
Proof.
  intros G H; revert G; induction H; intros G pi.
  - auto.
  - simpl; apply hrr_W; apply IHlist; apply pi.
Qed.

Lemma hrr_C_gen P : forall G H, HR P (H ++ H ++ G) -> HR P (H ++ G).
Proof.
  intros G H; revert P G; induction H as [ | T H]; intros P G pi.
  - apply pi.
  - simpl; apply hrr_C; try reflexivity.
    apply hrr_ex_hseq with (H ++ T :: T :: G); [ Permutation_Type_solve | ].
    apply IHH.
    eapply hrr_ex_hseq ; [ | apply pi].
    Permutation_Type_solve.
Qed.

Lemma hrr_C_copy P : forall G T n, HR P ((copy_seq (S n) T) :: G) -> HR P (T :: G).
Proof.
  intros G T n; revert G T; induction n; intros G T pi; simpl in *; try assumption.
  apply hrr_C.
  apply IHn.
  apply hrr_S.
  apply pi.
Qed.


From mathcomp Require Import all_ssreflect.
From chip Require Import extra connect close_dfs closure.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section InvRel.

Variable T : finType.

Definition rinv (r : rel T) := [rel x y | r y x].

End InvRel.

Notation "r ^-1" := (rinv r).

Section Checked.

(* artifact *)
Variable A : eqType.

(* paths *)
Variable V' : finType.

Variable f' : V' -> A.

(* old graph *)
Variable P : pred V'.

Local Notation V := (sig_finType P).

Variable f : V -> A.

Variable g : rel V.

Variable checkable : pred V'.

Variable R : eqType.

Variable check : V' -> R.

Definition freshV' : {set V'} := [set v | ~~ P v].

Lemma sub_freshV' v' :
  (~~ @insub _ _ [subType of V] v') = (v' \in freshV').
Proof.
case Hs: (~~ _); case Hf: (_ \in _) => //.
- move/negP: Hf; case.
  have H_sp := (insubP [subType of V] v').
  destruct H_sp => //.
  by rewrite in_set.
- move/negP/negP: Hs => Hs.
  move: Hf.
  rewrite in_set.
  move/negP.
  case.
  have H_sp := (insubP [subType of V] v').
  by destruct H_sp.
Qed.

Lemma freshV'P v' :
  reflect (forall v : V, val v != v') (v' \in freshV').
Proof.
apply: (iffP idP).
- rewrite in_set.
  move/negP => HP v.
  apply/negP.
  move/eqP => Hv.
  case: HP.
  rewrite -Hv.
  exact: valP.
- move => Hv.
  rewrite in_set.
  apply/negP => HP.
  have H_sp := (insubP [subType of V] v').
  destruct H_sp; last by move/negP: i; case.
  have Hvu := Hv u.
  move/negP/negP: Hvu.
  rewrite e.
  by move/eqP.
Qed.

Definition modifiedV := [set v | f v != f' (val v)].

Lemma not_modifiedP v :
  reflect (f v == f' (val v)) (v \notin modifiedV).
Proof.
apply: (iffP idP).
- move/negPf.
  rewrite in_set.
  by move/negP/negP.
- move => Hf.
  apply/negPf.
  rewrite in_set.
  by apply/negP/negP.
Qed.

Definition checkable_impactedV modified :=
  [set v in impacted g^-1 modified | checkable (val v)].

Definition checkable_impacted :=
  [seq (val v) | v <- enum (checkable_impactedV modifiedV)].

Lemma impactedVP (modified : {set V}) x :
  reflect
    (exists2 v, v \in modified & connect g^-1 v x)
    (x \in impacted g^-1 modified).
Proof. exact: impactedP. Qed.

Lemma impacted_closure : forall (modified : {set V}),
  [set x in closure g modified] = impacted g^-1 modified.
Proof.
move => modified.
apply/eqP.
rewrite eqEsubset.
apply/andP.
split.
- apply/subsetP.
  move => x.
  rewrite inE /=.
  move/closureP => [v Hv] Hc.
  apply/impactedVP.
  exists v => //.
  by apply/connect_rev.
apply/subsetP.
move => x.
move/impactedVP => [v Hv] Hc.
rewrite inE /=.
apply/closureP.
exists v => //.
by move/connect_rev: Hc.
Qed.

Lemma not_impactedP (modified : {set V}) x :
  reflect
  (forall v, connect g x v -> v \notin modified)
  (x \notin impacted g^-1 modified).
Proof.
apply: (iffP idP).
- move/impactedVP => Hex.
  move => v Hc.
  apply/negP => Hv.
  apply connect_rev in Hc.
  case: Hex.
  by exists v.
- move => Hc.
  apply/negP.
  move => Hx.
  move/impactedVP: Hx.
  move => [v Hv].
  move/connect_rev => /=.
  have ->: rel_of_simpl_rel [rel x' y' | g^-1 y' x'] = g by [].
  by move/Hc/negP.
Qed.

Definition impactedVV' modified := [set (val v) | v in impacted g^-1 modified].

Lemma impactedVV'_freshV' modified x :
  x \in impactedVV' modified -> x \notin freshV'.
Proof.
move => Hx.
rewrite in_set.
apply/negP.
move => HP.
move/negP: HP.
case.
move: Hx.
case/imsetP => v Hv Hx.
rewrite Hx.
exact: valP.
Qed.

Definition impactedV' : {set V'} := impactedVV' modifiedV :|: freshV'.

Definition impacted_fresh : seq V' := enum impactedV'.

Lemma impactedV'P x :
  reflect ((x \in impactedVV' modifiedV /\ x \notin freshV') \/ (x \in freshV' /\ x \notin impactedVV' modifiedV))
          (x \in impactedV').
Proof.
apply: (iffP idP).
- rewrite in_set.
  move/orP.
  case => Hx.
  * left; split => //.
    move: Hx.
    exact: impactedVV'_freshV'.
  * right; split => //.
    apply/negP.
    by move/impactedVV'_freshV'/negP.
- case.
  * move => [Hx Hf].
    rewrite in_set.
    apply/orP.
    by left.
  * move => [Hx Hf].
    rewrite in_set.
    apply/orP.
    by right.
Qed.

Definition checkable_impactedV' :=
 [set v in impactedV' | checkable v].

Definition checkable_impacted_fresh : seq V' :=
 enum checkable_impactedV'.

Definition check_impactedV'_cert :=
  [seq (v, check v) | v <- checkable_impacted_fresh].

Lemma check_impactedV'_cert_check v r :
  (v,r) \in check_impactedV'_cert ->
  checkable v /\ check v == r /\ v \in impactedV'.
Proof.
move/mapP => [v' Hv] Hc.
move: Hc Hv.
case =>->->.
rewrite mem_enum in_set.
move/andP => [Hc Hv].
by split.
Qed.

Lemma cert_check_impactedV'_check v r :
  checkable v ->
  check v == r ->
  v \in impactedV' ->
  (v,r) \in check_impactedV'_cert.
Proof.
move => Hc Hv Hi.
apply/mapP.
exists v; last by move/eqP: Hv=><-.
rewrite mem_enum in_set.
apply/andP.
by split.
Qed.

Lemma check_impactedV'_certP v r :
  reflect
    (checkable v /\ check v == r /\ v \in impactedV')
    ((v,r) \in check_impactedV'_cert).
Proof.
apply: (iffP idP).
- exact: check_impactedV'_cert_check.
- move => [Hc [Hv Hi]].
  exact: cert_check_impactedV'_check.
Qed.

Lemma check_impactedV'_cert_uniq :
  uniq [seq vr.1 | vr <- check_impactedV'_cert].
Proof.
rewrite map_inj_in_uniq.
- rewrite map_inj_uniq; first by rewrite enum_uniq.
  by move => x y; case.
- case => v1 r1.
  case => v2 r2.
  move => H1 H2 /= Heq.
  move: Heq H1 H2 =>-<-.
  move/mapP => [v1' Hv1' Hc1].
  rewrite mem_enum in Hv1'.
  case: Hc1 =><- Hr1.
  move/mapP => [v2' Hv2' Hc2].
  rewrite mem_enum in Hv2'.
  case: Hc2 =><- Hr2.
  by rewrite Hr1 Hr2.
Qed.

End Checked.

Section Other.

Variable A : eqType.
Variable V' : finType.
Variable f' : V' -> A.
Variable P : pred V'.
Local Notation V := (sig_finType P).
Variable f : V -> A.
Variables (g1 : rel V) (g2 : rel V).
Variable checkable : pred V'.
Variable R : eqType.
Variable check : V' -> R.

Hypothesis g1_g2_connect : connect g1 =2 connect g2.

Lemma connect_impactedV_eq modified :
  impacted g1^-1 modified = impacted g2^-1 modified.
Proof.
apply/eqP.
rewrite eqEsubset.
apply/andP.
split.
- apply/subsetP.
  move => x Hx.
  apply: rclosed_impacted; eauto.
  apply/impactedP.
  move/impactedP: Hx => [v Hv] Hc.
  exists v => //.
  apply connect_rev.
  rewrite -g1_g2_connect.
  by apply connect_rev.
- apply/subsetP.
  move => x Hx.
  apply: rclosed_impacted; eauto.
  apply/impactedP.
  move/impactedP: Hx => [v Hv] Hc.
  exists v => //.
  apply connect_rev.
  rewrite g1_g2_connect.
  by apply connect_rev.
Qed.

Lemma connect_impactedV'_eq :
  impactedV' f' f g1 = impactedV' f' f g2.
Proof.
apply/eqP.
rewrite eqEsubset.
apply/andP.
split.
- apply setSU.
  apply/subsetP.
  move => x.
  move/imsetP => [v Hi] Hv.
  apply/imsetP.
  exists v; last by [].
  by rewrite -connect_impactedV_eq.
- apply setSU.
  apply/subsetP.
  move => x.
  move/imsetP => [v Hi] Hv.
  apply/imsetP.
  exists v; last by [].
  by rewrite connect_impactedV_eq.
Qed.

Lemma connect_checkable_impactedV' :
  checkable_impactedV' f' f g1 checkable = checkable_impactedV' f' f g2 checkable.
Proof.
apply/eqP.
rewrite eqEsubset.
apply/andP.
split.
- apply/subsetP.
  move => x.
  rewrite in_set.
  move/andP => [Hi Hc].
  rewrite in_set.
  apply/andP.
  split => //.
  by rewrite -connect_impactedV'_eq.
- apply/subsetP.
  move => x.
  rewrite in_set.
  move/andP => [Hi Hc].
  rewrite in_set.
  apply/andP.
  split => //.
  by rewrite connect_impactedV'_eq.
Qed.

End Other.