(**
Rainbow, a termination proof certification tool

See the COPYRIGHTS and LICENSE files.

- Kim Quyen LY, 2013-04-18

* Matrix interpretation over domain arctic integer numbers - below zero

*)

Set Implicit Arguments.

Require Import ATrs ARedPair2 APolyInt_MA2 AMonAlg2 Equality
  AArcticBZInt2 ListForall ListUtil LogicUtil BoolUtil ZUtil
  AMatrixBasedInt2_ArcticBZ VecUtil VecArith2 Matrix2 cpf2color cpf
  OrdSemiRing2 VecOrd cpf_util AArcticBasedInt2.

(***********************************************************************)
(** ** Matrix interpretation over domain arctic integer numbers -
   below zero. *)

Section S.

  Variable arity: symbol -> nat.
  Variable dim : nat.

  Notation Sig := (Sig arity).
  Definition dim_pos := (dim_pos dim).
  Notation mint := (matrixInt_arcbz matrix_arcbz dim).

  (** Cast *)

  Definition matrix_cast_arcbz n m (Heq: n = m)(p: mint n) : mint m.
  rewrite <- Heq; auto.
  Defined.

  (** Default matrix interpretation over domain arctic integer numbers. *)

  Definition default_matrix_arcbz (n : nat) :=
    mkMatrixInt_arcbz (id_vec_arcbz dim_pos) (Vconst (id_matrix_arcbz dim) n).

  (** [fun_of_pairs_matrix_arcbz_list] is a representation for an interpretation
     associating to every function symbol of arity [n], an natural matrix
     with [n] variables. It is represented by a list of pairs [(g, mi)],
     where [g] is a function symbol and [mi] is its interpretation. *)

  Section fun_of_pairs_matrix_arcbz_list.

    Variable f : symbol.

    Fixpoint fun_of_matrix_arcbz_list (l : list {g: symbol & mint (arity g)})
      : mint (arity f) :=
      match l with
        | existT g m :: l' =>
          match @eq_symb_dec Sig g f with
            | left h => matrix_cast_arcbz (f_equal arity h) m
            | right _ => fun_of_matrix_arcbz_list l'
          end
        | nil => default_matrix_arcbz (arity f)
      end.

  End fun_of_pairs_matrix_arcbz_list.

(***********************************************************************)
(** ** Matrix interpretation in the setting of monotone algebras. *)

  Section MatrixMethodConf_Arcbz.

    Variable l : list {g : symbol & mint (arity g)}.

    Definition trsInt_arcbz (f : Sig) := fun_of_matrix_arcbz_list f l.

    Definition TMatrixInt_arcbz := mkMatrixMethodConf_arcbz Sig trsInt_arcbz.

    Definition MatrixArcbz_MonoAlgType := matAlg_arcbz TMatrixInt_arcbz.

    (** Weak reduction pair for matrix intepretration. *)

    Definition MatrixArcbz_WeakRedPair := bwrp MatrixArcbz_MonoAlgType.

    (** Reduction pair associcated to a monotone algebra. *)

    Definition matrix_arcbz_wrp := mkbWeakRedPair
      (wf_succ MatrixArcbz_WeakRedPair)
      (sc_succ MatrixArcbz_WeakRedPair)(bsucc_sub MatrixArcbz_WeakRedPair)
      (sc_succeq MatrixArcbz_WeakRedPair) (cc_succeq MatrixArcbz_WeakRedPair)
      (ARedPair2.refl_succeq MatrixArcbz_WeakRedPair)
      (ARedPair2.succ_succeq_compat MatrixArcbz_WeakRedPair)
      (bsucceq_sub MatrixArcbz_WeakRedPair)
      (ARedPair2.trans_succ MatrixArcbz_WeakRedPair)
      (ARedPair2.trans_succeq MatrixArcbz_WeakRedPair).

  End MatrixMethodConf_Arcbz.

  (****************************************************************************)
  (** ** Boolean function for matrix interpretation over domain arctic
     integer numbers *)

  Section BoolMint_arcbz.

    Local Open Scope Z_scope.

    (** Define boolean function for [gt] over domain arctic integer
       numbers/below-zero. *)

    Definition bgt_arc_bz m n :=
      match gt_decrbz m n with
        | left _ => true
        | right _ => false
      end.

    Notation "x >> y" := (gtrbz x y) (at level 70).

    (** Correcntess proof of [bgt] over domain arctic below-zero. *)

    Lemma bgt_arc_bz_ok : forall m n, bgt_arc_bz m n = true <-> (m >> n)%Z.

    Proof.
      intros. unfold bgt_arc_bz.
      case_eq (gt_decrbz m n); intuition.
    Qed.

    (** Define boolean function for [ge] over domain arctic integer
    numbers/below-zero. *)

    Definition bge_arc_bz m n := bgt_arc_bz m n || beq_ArcticBZDom m n.

    (** Correctness proof of [bge] in arctic below-zero. *)

    Lemma bge_arc_bz_ok : forall m n, bge_arc_bz m n = true <-> gerbz m n.

    Proof.
      intros m n. intuition.
      unfold gerbz. unfold bge_arc_bz in H. rewrite orb_eq in H.
      destruct H; try discr.
      apply bgt_arc_bz_ok in H. left. apply H.
      apply beq_ArcticBZDom_ok in H. right. apply H.
      (* -> *)
      unfold gerbz in H. destruct H.
      unfold bge_arc_bz. rewrite orb_eq.
      left. rewrite bgt_arc_bz_ok. apply H.
      unfold bge_arc_bz. rewrite orb_eq.
      right. rewrite beq_ArcticBZDom_ok. apply H.
    Qed.

    (** Define boolean function of [mat_ge] *)

    Definition bmat_ge_arcbz (m n : nat)(M N: matrix_arcbz m n) :=
      match mat_ge_dec_arcbz M N with
        | left _ => true (* M >=m N *)
        | right _ => false (* ~ M >=m N *)
      end.

    (** Correctness proof of mat_ge_arcbz and [bmat_ge]. *)

    Lemma bmat_ge_arcbz_ok : forall (m n: nat) (M N: matrix_arcbz m n),
                               bmat_ge_arcbz M N = true <-> mat_ge_arcbz M N.
    Proof.
      intros. unfold bmat_ge_arcbz.
      case_eq (mat_ge_dec_arcbz M N); intuition.
    Qed.

    (** Define boolean function of [mint_ge] over domain arctic
    integer numbers/below-zero. *)

    Definition bmint_arc_bz_ge n (l r : mint n) : bool :=
      bVforall2n (bmat_ge_arcbz (n:= dim)) (args_arcbz l) (args_arcbz r)
    && bVforall2n (fun m n => bge_arc_bz m n) (const_arcbz l) (const_arcbz r).

    (** Correctness proof of [bmint_ge] over domain arctic integer
      numbers/below-zero. *)

    Lemma bmint_arc_bz_ge_ok: forall n (l r: mint n),
      bmint_arc_bz_ge l r = true <-> mint_ge_arcbz l r.

    Proof.
      intros n l r. intuition.
      (* [1]. Proving the <- *)
      unfold bmint_arc_bz_ge in H.
      rewrite andb_eq in H. destruct H.
      rewrite bVforall2n_ok in H. unfold mint_ge_arcbz.
      split. apply H.
      rewrite bVforall2n_ok in H0. apply H0.
      (* Proving boolean function of [bge]. *)
      intros. split.
      (* -> *)
      intro H1. apply bge_arc_bz_ok in H1. hyp.
      (* <- *)
      intro H1. rewrite bge_arc_bz_ok. hyp.
      (* Proving boolean function of [bmat_ge]*)
      intros. split.
      (* -> *)
      intro H1. rewrite bmat_ge_arcbz_ok in H1.
      hyp.
      (* <- *)
      intro H1. apply bmat_ge_arcbz_ok. hyp.
      (* [2]. Proving the other -> *)
      unfold bmint_arc_bz_ge. rewrite andb_eq.
      split. rewrite bVforall2n_ok.
      unfold mint_ge_arcbz in H. destruct H.
      apply H. intros.
      (* -> *)
      split. intro H1. apply bmat_ge_arcbz_ok. hyp.
      (* <- *)
      intro H1. apply bmat_ge_arcbz_ok. hyp.
      (* Proving boolean function of [const_arcbz]. *)
      rewrite bVforall2n_ok. unfold mint_ge_arcbz in H.
      destruct H. apply H0.
      (* Proving boolean function of [bge_arc]. *)
      intros. split.
      (* -> *)
      intro H1. apply bge_arc_bz_ok. hyp.
      (* <- *)
      intro H1. rewrite bge_arc_bz_ok. hyp.
    Qed.

    (** Define boolean function for [gtx] in Arctic below-zero domain
       arctic addition is not strictly monotone in single
       arguments. It is, however, "haft strict" in the following sense:
       a strict increase in both arguments simultaneously gives a strict
       increase in the result. There is one exception: arctic addition
       is obviously strict if one argument is arctic zero, i.e.,
       [-oo]. This is the motivation for introducing the following
       relation [gtx]. *)

    Definition bgtxbz (x y: ArcticBZDom) : bool :=
      bgt_arc_bz x y || beq_ArcticBZDom x MinusInfBZ
        && beq_ArcticBZDom y MinusInfBZ.

    (** Correctness proof of [bgtxbz] *)

    Lemma bgtxbz_ok : forall x y, bgtxbz x y = true <-> gtx_bz x y.
    Proof.
      intros. intuition.
      unfold gtx_bz. unfold bgtxbz in H.
      rewrite orb_eq in H. rewrite andb_eq in H.
      destruct H; try discr.
      apply bgt_arc_bz_ok in H.
      (* Left part. *)
      left. hyp.
      destruct H. apply beq_ArcticBZDom_ok in H.
      apply beq_ArcticBZDom_ok in H0.
      (* Right part. *)
      right. auto.
      unfold gtx_bz in H. destruct H.
      unfold bgtxbz. rewrite orb_eq. rewrite andb_eq.
      (* Left part. *)
      left. rewrite bgt_arc_bz_ok. hyp.
      unfold bgtxbz. rewrite orb_eq. rewrite andb_eq.
      (* Right part. *)
      right. split. rewrite beq_ArcticBZDom_ok. destruct H.
      auto. rewrite beq_ArcticBZDom_ok. destruct H.
      auto.
    Qed.

    (** Define boolean function of [mat_gt]. *)

    Require Import AArcticBasedInt2.

    Definition bmat_gt_arcbz (M N:  matrix_arcbz dim dim)  :=
      match mat_gt_decbz M N with
        | left _ => true
        | right _ => false
      end.

    (** Correctness proof of [bmat_gt]. *)

    Lemma bmat_gt_arcbz_ok : forall (M N:  matrix_arcbz dim dim),
                               bmat_gt_arcbz M N = true <-> mat_gtbz M N.
    Proof.
      intros. unfold bmat_gt_arcbz.
      case_eq (mat_gt_decbz M N); intuition.
    Qed.

    (** Define boolean function for [mint_gt] over domain arctic
       integer numbers/below-zero. *)

    Definition bmint_arc_bz_gt n (l r : mint n) : bool :=
      bVforall2n bmat_gt_arcbz (args_arcbz l) (args_arcbz r) &&
      bVforall2n (fun m n => bgtxbz m n) (const_arcbz l) (const_arcbz r).

    (** Correctness proof of [bmint_gt] over domain arctic integer
       numbers/below-zero. *)

    Lemma bmint_arc_bz_gt_ok : forall n (l r : mint n),
      bmint_arc_bz_gt l r = true <-> Vforall2n (mat_gtbz (dim:=dim))
      (args_arcbz l) (args_arcbz r)
      /\ vec_gtbz (const_arcbz l) (const_arcbz r).

    Proof.
      intros n l r. intuition.
      (* Left part. *)
      unfold bmint_arc_bz_gt in H. rewrite andb_eq in H.
      destruct H. rewrite <- bVforall2n_ok. apply H.
      intros. split. intro H1. apply bmat_gt_arcbz_ok. hyp.
      intro H1. rewrite bmat_gt_arcbz_ok. hyp.
      (* Right part. *)
      unfold vec_gtbz.
      unfold bmint_arc_bz_gt in H.
      rewrite andb_eq in H. destruct H.
      rewrite bVforall2n_ok in H0. apply H0.
      (* Boolean function of [bgtx]. *)
      intros. split. intro H1.
      apply bgtxbz_ok. hyp.
      intro H1. rewrite bgtxbz_ok. hyp.
      (* Boolean function of [bmint_gt]. *)
      unfold bmint_arc_bz_gt. rewrite andb_eq. split.
      rewrite bVforall2n_ok. apply H0.
      intros. split. intro H2. apply bmat_gt_arcbz_ok. hyp.
      intro H2. rewrite bmat_gt_arcbz_ok. hyp.
      (* Second part. *)
      rewrite bVforall2n_ok. apply H1.
      intros. split. intro H2. apply bgtxbz_ok. hyp.
      intro H2. rewrite bgtxbz_ok. hyp.
    Qed.

  End BoolMint_arcbz.

End S.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(* ---                           develop.v                              --- *)
(*                                                                          *)
(* Author: Pierre Casteran.                                                 *)
(*    LABRI, URA CNRS 1304,                                                 *)
(*    Departement d'Informatique, Universite Bordeaux I,                    *)
(*    33405 Talence CEDEX,                                                  *)
(*    e-mail:  casteran@labri.u-bordeaux.fr                                 *)

(*

  This file contains some important lemmas used in the "generation" module.
  It tells how to compose abstract machine code (with append) to build
  code for Call_M, Call_C and Call_K calls (see the module "spec")
*)

Require Import Constants.
Require Import monoid.
Require Import spec.
Require Import machine.
Require Import Wf_compl.
Require Import Plus.
Require Import Mult.
Require Import Lt.
Require Import Mult_compl.
Require Import euclid.
Require Import two_power.

(* A sequence for computing the cube of some m in M *)
Lemma M3 : gencode (Call_M three).
(******************************)
Proof.
 refine (gencode_intro _ (seq PUSH (seq SQR (seq MUL End))) _).
(*
 Realizer (seq PUSH (seq SQR (seq MUL End))).
 Program_all.
*)
 constructor 1.
 simpl in |- *; unfold power, three in |- *; intros.
 rewrite (u_neutral_r M MO).
 rewrite <- (point_assoc M MO); auto with arith.
 Qed.

(* A sequence for computing the (2^q)-th power of some m in M;
 this is a sequence of q SQRs  *)

Lemma M2q : forall q : nat, gencode (Call_M (two_power q)).
(**********************************************)
Proof.
 refine
  (let t := fun q : nat => gencode (Call_M (two_power q)) in
   (fix M2q (q : nat) : t q :=
      match q as x return (t x) with
      | O => gencode_intro _ End _
      | S p =>
          match M2q p with
          | gencode_intro c s => gencode_intro _ (seq SQR c) _
          end
      end)).
(*
 Realizer [q:nat]<Code>Match q with End
                                    ([_,c:?](seq SQR c))
                                    end.
 Program_all.
*)
 constructor 1.
 unfold power in |- *; simpl in |- *.
 intros; rewrite (u_neutral_r M MO); auto with arith.
 constructor 1; auto with arith.
 intros; simpl in |- *.
 inversion_clear s.
 rewrite H.
 apply Config_inv; auto with arith.
 rewrite <- plus_n_O.
 apply a2x; auto with arith.
Qed.

(* code generation  for (Call_M p) from the code for (Call_C p q)
   (it's the same!) *)

Lemma C2M : forall p q : nat, gencode (Call_C p q) -> gencode (Call_M p).
(****************************************)
Proof.
 refine
  (fun p q g => match g with
                | gencode_intro c s => gencode_intro _ c _
                end).
(*
 Realizer [p,q:nat][c:Code]c.
 Program_all.
*)
 constructor 1.
 inversion_clear s.
 auto with arith.
Qed.

(*  code generation for  (Call_C qp p) from the codes for (Call_M p) and (Call_M q)
    just append !                                                          *)
Lemma MMC :
 forall p q : nat,
 gencode (Call_M p) -> gencode (Call_M q) -> gencode (Call_C (q * p) p).
(***********************************************)
Proof.
 refine
  (fun p q g g' =>
   match g with
   | gencode_intro c s =>
       match g' with
       | gencode_intro c' s0 => gencode_intro _ (app c c') _
       end
   end).
(*
 Realizer [p,q:nat][c,c':Code](app c  c').
 Program_all.
*)
 constructor 2.
 intros; rewrite Exec_app.
 inversion_clear s.
 rewrite H.
 inversion_clear s0.
 rewrite (H0 M MO).
 rewrite power_mult; auto with arith.
Qed.

(* code generation for  (Call_C qp+r p) from cpr (code for (Call_K p r))
                                      and cq (code for (Call_M q))
 (it's cpr, followed by cq then a MUL statement                       *)

Lemma KMC :
 forall p q r : nat,
 gencode (Call_K p r) -> gencode (Call_M q) -> gencode (Call_C (q * p + r) p).
(***********************************************************)
Proof.
 refine
  (fun p q r g g' =>
   match g with
   | gencode_intro cpr s =>
       match g' with
       | gencode_intro cq s0 =>
           gencode_intro _ (app cpr (app cq (seq MUL End))) _
       end
   end).
(*
 Realizer [p,q,r:nat][cpr,cq:Code](app cpr (app  cq (seq MUL   End))).
 Program_all.
*)
 inversion_clear s; inversion_clear s0.
 constructor 2.
 intros; rewrite Exec_app.
 rewrite (H M MO a).
 rewrite (Exec_app M MO); simpl in |- *; rewrite H0.
 simpl in |- *.
 apply Config_inv.
 rewrite power_eucl; auto with arith.
 auto with arith.
Qed.

(* Code generation for (Call_K qp p) from cp (code for (Call_M p))
                                   and cq (code for (Call_M q))
   It's cp, followed by a PUSH, then cq                       *)

Lemma MMK :
 forall p q : nat,
 gencode (Call_M p) -> gencode (Call_M q) -> gencode (Call_K (q * p) p).
(**************************************************)
Proof.
 refine
  (fun p q g g' =>
   match g with
   | gencode_intro cp s =>
       match g' with
       | gencode_intro cq s0 => gencode_intro _ (app cp (seq PUSH cq)) _
       end
   end).
(*
 Realizer [p,q:nat][cp,cq:Code](app cp  (seq PUSH  cq)).
 Program_all.
*)
 inversion_clear s; inversion_clear s0.
 constructor 3.
 intros; rewrite Exec_app.
 rewrite H; simpl in |- *.
 rewrite H0; simpl in |- *.
 apply Config_inv; auto with arith.
 rewrite <- power_mult; auto with arith.
Qed.

(* Code generation for (Call_K qp+r p) from kpr (code for (Call_K p r))
                                     and mq (code for (Call_M q))
  it's kpr, followed by a sequence (PUSH;SWAP), then mq and a MUL statement *)

Lemma KMK :
 forall p q r : nat,
 gencode (Call_K p r) -> gencode (Call_M q) -> gencode (Call_K (q * p + r) p).
(***********************************************************)
Proof.
  refine
   (fun p q r g g' =>
    match g with
    | gencode_intro kpr s =>
        match g' with
        | gencode_intro mq s0 =>
            gencode_intro _
              (app kpr (seq PUSH (seq SWAP (app mq (seq MUL End))))) _
        end
    end).
(*
 Realizer [p,q,r:nat][kpr,mq:Code]
    (app kpr  (seq PUSH (seq  SWAP  ( app mq  (seq MUL  End))))).
 Program_all.
*)
 inversion_clear s; inversion_clear s0.
 constructor 3.
 intros; rewrite Exec_app.
 rewrite H; simpl in |- *.
 rewrite Exec_app.
 rewrite H0; simpl in |- *. auto with arith.
 rewrite power_eucl; auto with arith.
Qed.


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

Require Export Relations_1.
Require Export Relations_1_facts.
Require Export Relations_2.

Theorem Rstar_reflexive :
 forall (U:Type) (R:Relation U), Reflexive U (Rstar U R).
Proof.
auto with sets.
Qed.

Theorem Rplus_contains_R :
 forall (U:Type) (R:Relation U), contains U (Rplus U R) R.
Proof.
auto with sets.
Qed.

Theorem Rstar_contains_R :
 forall (U:Type) (R:Relation U), contains U (Rstar U R) R.
Proof.
intros U R; red in |- *; intros x y H'; apply Rstar_n with y; auto with sets.
Qed.

Theorem Rstar_contains_Rplus :
 forall (U:Type) (R:Relation U), contains U (Rstar U R) (Rplus U R).
Proof.
intros U R; red in |- *.
intros x y H'; elim H'.
generalize Rstar_contains_R; intro T; red in T; auto with sets.
intros x0 y0 z H'0 H'1 H'2; apply Rstar_n with y0; auto with sets.
Qed.

Theorem Rstar_transitive :
 forall (U:Type) (R:Relation U), Transitive U (Rstar U R).
Proof.
intros U R; red in |- *.
intros x y z H'; elim H'; auto with sets.
intros x0 y0 z0 H'0 H'1 H'2 H'3; apply Rstar_n with y0; auto with sets.
Qed.

Theorem Rstar_cases :
 forall (U:Type) (R:Relation U) (x y:U),
   Rstar U R x y -> x = y \/ (exists u : _, R x u /\ Rstar U R u y).
Proof.
intros U R x y H'; elim H'; auto with sets.
intros x0 y0 z H'0 H'1 H'2; right; exists y0; auto with sets.
Qed.

Theorem Rstar_equiv_Rstar1 :
 forall (U:Type) (R:Relation U), same_relation U (Rstar U R) (Rstar1 U R).
Proof.
generalize Rstar_contains_R; intro T; red in T.
intros U R; unfold same_relation, contains in |- *.
split; intros x y H'; elim H'; auto with sets.
generalize Rstar_transitive; intro T1; red in T1.
intros x0 y0 z H'0 H'1 H'2 H'3; apply T1 with y0; auto with sets.
intros x0 y0 z H'0 H'1 H'2; apply Rstar1_n with y0; auto with sets.
Qed.

Theorem Rsym_imp_Rstarsym :
 forall (U:Type) (R:Relation U), Symmetric U R -> Symmetric U (Rstar U R).
Proof.
intros U R H'; red in |- *.
intros x y H'0; elim H'0; auto with sets.
intros x0 y0 z H'1 H'2 H'3.
generalize Rstar_transitive; intro T1; red in T1.
apply T1 with y0; auto with sets.
apply Rstar_n with x0; auto with sets.
Qed.

Theorem Sstar_contains_Rstar :
 forall (U:Type) (R S:Relation U),
   contains U (Rstar U S) R -> contains U (Rstar U S) (Rstar U R).
Proof.
unfold contains in |- *.
intros U R S H' x y H'0; elim H'0; auto with sets.
generalize Rstar_transitive; intro T1; red in T1.
intros x0 y0 z H'1 H'2 H'3; apply T1 with y0; auto with sets.
Qed.

Theorem star_monotone :
 forall (U:Type) (R S:Relation U),
   contains U S R -> contains U (Rstar U S) (Rstar U R).
Proof.
intros U R S H'.
apply Sstar_contains_Rstar; auto with sets.
generalize (Rstar_contains_R U S); auto with sets.
Qed.

Theorem RstarRplus_RRstar :
 forall (U:Type) (R:Relation U) (x y z:U),
   Rstar U R x y -> Rplus U R y z ->  exists u : _, R x u /\ Rstar U R u z.
Proof.
generalize Rstar_contains_Rplus; intro T; red in T.
generalize Rstar_transitive; intro T1; red in T1.
intros U R x y z H'; elim H'.
intros x0 H'0; elim H'0.
intros x1 y0 H'1; exists y0; auto with sets.
intros x1 y0 z0 H'1 H'2 H'3; exists y0; auto with sets.
intros x0 y0 z0 H'0 H'1 H'2 H'3; exists y0.
split; [ try assumption | idtac ].
apply T1 with z0; auto with sets.
Qed.

Theorem Lemma1 :
 forall (U:Type) (R:Relation U),
   Strongly_confluent U R ->
   forall x b:U,
     Rstar U R x b ->
     forall a:U, R x a ->  exists z : _, Rstar U R a z /\ R b z.
Proof.
intros U R H' x b H'0; elim H'0.
intros x0 a H'1; exists a; auto with sets.
intros x0 y z H'1 H'2 H'3 a H'4.
red in H'.
specialize H' with (x := x0) (a := a) (b := y); lapply H';
 [ intro H'8; lapply H'8;
    [ intro H'9; try exact H'9; clear H'8 H' | clear H'8 H' ]
 | clear H' ]; auto with sets.
elim H'9.
intros t H'5; elim H'5; intros H'6 H'7; try exact H'6; clear H'5.
elim (H'3 t); auto with sets.
intros z1 H'5; elim H'5; intros H'8 H'10; try exact H'8; clear H'5.
exists z1; split; [ idtac | assumption ].
apply Rstar_n with t; auto with sets.
Qed.


(* * Combinators *)

(* * Export Modules for Combinators *)
From Undecidability.TM.Combinators Require Export Switch If SequentialComposition StateWhile While Mirror.

Set Default Goal Selector "!".

(* ** Simple Combinators *)

(* Simple operator to change the labelling function *)
Section Relabel.
  Variable (sig : finType) (n : nat).
  Variable F F' : finType.
  Variable pM : { M : TM sig n & state M -> F }.
  Variable p : F -> F'.

  Definition Relabel : pTM sig F' n :=
    (projT1 pM; fun q => p (projT2 pM q)).

  Lemma Relabel_Realise R :
    pM ⊨ R ->
    Relabel ⊨ ⋃_y (R |_ y) ||_(p y).
  Proof.
    intros HRel.
    intros tin k outc HLoop.
    hnf in HRel. specialize HRel with (1 := HLoop).
    hnf. now exists (projT2 pM (cstate outc)).
  Qed.

  Lemma Relabel_RealiseIn R k :
    pM ⊨c(k) R ->
    Relabel ⊨c(k) ⋃_y (R |_ y) ||_(p y).
  Proof. firstorder easy. Qed.

  Lemma Relabel_Terminates T :
    projT1 pM ↓ T ->
    projT1 Relabel ↓ T.
  Proof. firstorder easy. Qed.

End Relabel.

Arguments Relabel : simpl never.

(* Special case of the above operator, where we just fix a label *)
Section Return.

  Variable (sig : finType) (n : nat).
  Variable F : finType.
  Variable pM : { M : TM sig n & state M -> F }.
  Variable F' : finType.
  Variable p : F'.

  Definition Return := Relabel pM (fun _ => p).

  Lemma Return_Realise R :
    pM ⊨ R ->
    Return ⊨ (⋃_f (R |_ f)) ||_ p.
  Proof.
    intros. intros tin k outc HLoop. hnf.
    split; [easy|]. exists (projT2 pM (cstate outc)). hnf. eauto. Qed.

  Lemma Return_RealiseIn R k :
    pM ⊨c(k) R ->
    Return ⊨c(k) (⋃_f (R |_ f)) ||_ p.
  Proof. firstorder easy. Qed.

  Lemma Return_Terminates T :
    projT1 pM ↓ T ->
    projT1 Return ↓ T.
  Proof. firstorder easy. Qed.

End Return.

Arguments Return : simpl never.

#[export] Hint Extern 1 (Switch _ _ ⊨ _) => eapply Switch_Realise : TMdb.
#[export] Hint Extern 1 (Switch _ _ ⊨c(_) _) => eapply Switch_RealiseIn : TMdb.
#[export] Hint Extern 1 (projT1 (Switch _ _) ↓ _) => eapply Switch_TerminatesIn : TMdb.

#[export] Hint Extern 1 (If _ _ _ ⊨ _) => eapply If_Realise : TMdb.
#[export] Hint Extern 1 (If _ _ _ ⊨c(_) _) => eapply If_RealiseIn : TMdb.
#[export] Hint Extern 1 (projT1 (If _ _ _) ↓ _) => eapply If_TerminatesIn : TMdb.

#[export] Hint Extern 1 (Seq _ _ ⊨ _) => eapply Seq_Realise : TMdb.
#[export] Hint Extern 1 (Seq _ _ ⊨c(_) _) => eapply Seq_RealiseIn : TMdb.
#[export] Hint Extern 1 (projT1 (Seq _ _) ↓ _) => eapply Seq_TerminatesIn : TMdb.

#[export] Hint Extern 1 (While _ ⊨ _) => eapply While_Realise : TMdb.
#[export] Hint Extern 1 (projT1 (While _) ↓ _) => eapply While_TerminatesIn : TMdb.

#[export] Hint Extern 1 (StateWhile _ _ ⊨ _) => eapply StateWhile_Realise : TMdb.
#[export] Hint Extern 1 (projT1 (StateWhile _ _) ↓ _) => eapply StateWhile_TerminatesIn : TMdb.

#[export] Hint Extern 1 (Relabel _ _ ⊨ _) => eapply Relabel_Realise : TMdb.
#[export] Hint Extern 1 (Relabel _ _ ⊨c(_) _) => eapply Relabel_RealiseIn : TMdb.
#[export] Hint Extern 1 (projT1 (Relabel _ _) ↓ _) => eapply Relabel_Terminates : TMdb.

#[export] Hint Extern 1 (Return _ _ ⊨ _) => eapply Return_Realise : TMdb.
#[export] Hint Extern 1 (Return _ _ ⊨c(_) _) => eapply Return_RealiseIn : TMdb.
#[export] Hint Extern 1 (projT1 (Return _ _) ↓ _) => eapply Return_Terminates : TMdb.


Require Import VST.msl.simple_CCC.
Require Import VST.msl.seplog.
(* Require Import VST.msl.alg_seplog. *)
Require Import VST.msl.Extensionality.
Require Import Coq.Setoids.Setoid.

Local Open Scope logic.

Hint Extern 0 (_ |-- _) => match goal with |- ?A |-- ?B => constr_eq A B; simple apply derives_refl end.
(* Hint Resolve @derives_refl.    too expensive sometimes when it fails . . . *)

Ltac solve_andp' :=
  first [ apply derives_refl
        | apply andp_left1; solve_andp'
        | apply andp_left2; solve_andp'].

Ltac solve_andp := repeat apply andp_right; solve_andp'.

Lemma TT_right {A}{NA: NatDed A}: forall P:A, P |-- TT.
Proof. intros; apply prop_right; auto.
Qed.

Lemma FF_left {A}{NA: NatDed A}: forall P, FF |-- P.
Proof.
intros; apply prop_left. intuition.
Qed.

Hint Resolve @TT_right: norm.
Hint Resolve @FF_left : norm.

Ltac norm := auto with norm.

Lemma add_andp: forall {A: Type} `{NatDed A} (P Q: A), P |-- Q -> P = P && Q.
Proof.
  intros.
  apply pred_ext.
  + apply andp_right; auto.
  + apply andp_left1; apply derives_refl.
Qed.

Lemma andp_comm  {A}{NA: NatDed A}:
  forall P Q: A,  P && Q = Q && P.
Proof with norm.
 intros.
   apply pred_ext.
   apply andp_right. apply andp_left2... apply andp_left1...
    apply andp_right. apply andp_left2... apply andp_left1...
Qed.

Lemma andp_assoc {A} {NA: NatDed A} : forall P Q R : A,
  (P && Q) && R = P && (Q && R).
Proof.
  intros; apply pred_ext;   repeat apply andp_right.
  do 2 apply andp_left1; auto.
  apply andp_left1; apply andp_left2; auto.
  apply andp_left2; auto.
  apply andp_left1; auto.
  apply andp_left2; apply andp_left1; auto.
  do 2 apply andp_left2; auto.
Qed.

Lemma andp_derives {A} {NA: NatDed A}:
  forall P Q P' Q': A, P |-- P' -> Q |-- Q' -> P && Q |-- P' && Q'.
Proof.
intros.
apply andp_right.
apply andp_left1; apply H.
apply andp_left2; apply H0.
Qed.

Lemma orp_derives {A} {NA: NatDed A}:
  forall P Q P' Q': A, P |-- P' -> Q |-- Q' -> P || Q |-- P' || Q'.
Proof.
intros.
apply orp_left.
apply orp_right1; apply H.
apply orp_right2; apply H0.
Qed.

Class CCCviaNatDed (A: Type) (prod expo: A -> A -> A) {ND: NatDed A}: Prop :=
  isCCC: CartesianClosedCat.CCC A derives eq prod expo.

Lemma CCC_expo_derives: forall A prod expo {ND: NatDed A} {CCC: CCCviaNatDed A prod expo},
  forall P P' Q Q', P' |-- P -> Q |-- Q' -> expo P Q |-- expo P' Q'.
Proof.
  intros.
  pose proof isCCC.
  eapply CartesianClosedCat.expo_UMP; eauto.
  apply derives_trans.
Qed.

Lemma CCC_exp_prod1:
  forall A prod expo {ND : NatDed A} {CCC: CCCviaNatDed A prod expo} B (P: B -> A) Q,
  prod (exp P) Q = exp (fun x => prod (P x) Q).
Proof.
  intros.
  pose proof isCCC.
  apply pred_ext.
  + apply (proj2 (CartesianClosedCat.adjoint _ _ _ _ _ _)).
    apply exp_left; intro x.
    apply (proj1 (CartesianClosedCat.adjoint _ _ _ _ _ _)).
    apply (exp_right x).
    apply derives_refl.
  + apply exp_left; intro x.
    eapply CartesianClosedCat.prod_UMP; eauto.
    apply (exp_right x).
    apply derives_refl.
Qed.

Lemma CCC_exp_prod2:
  forall A prod expo {ND : NatDed A} {CCC: CCCviaNatDed A prod expo} B P (Q: B -> A),
  prod P (exp Q) = exp (fun x => prod P (Q x)).
Proof.
  intros.
  rewrite CartesianClosedCat.comm by eauto.
  erewrite CCC_exp_prod1 by eauto.
  f_equal. extensionality x.
  rewrite CartesianClosedCat.comm by eauto.
  reflexivity.
Qed.

Lemma CCC_distrib_orp_prod:
  forall A prod expo {ND : NatDed A} {CCC: CCCviaNatDed A prod expo} P Q R,
    prod (orp P Q) R = orp (prod P R) (prod Q R).
Proof.
  intros.
  pose proof isCCC.
  apply pred_ext.
  + apply (proj2 (CartesianClosedCat.adjoint _ _ _ _ _ _)).
    apply orp_left.
    - apply (proj1 (CartesianClosedCat.adjoint _ _ _ _ _ _)).
      apply orp_right1, derives_refl.
    - apply (proj1 (CartesianClosedCat.adjoint _ _ _ _ _ _)).
      apply orp_right2, derives_refl.
  + apply orp_left; eapply CartesianClosedCat.prod_UMP; eauto.
    - apply orp_right1, derives_refl.
    - apply orp_right2, derives_refl.
Qed.

Lemma CCC_FF_prod:
  forall A prod expo {ND : NatDed A} {CCC: CCCviaNatDed A prod expo} P,
    prod FF P = FF.
Proof.
  intros.
  pose proof isCCC.
  apply pred_ext.
  + apply (proj2 (CartesianClosedCat.adjoint _ _ _ _ _ _)).
    apply FF_left.
  + apply FF_left.
Qed.

Lemma CCC_prod_FF:
  forall A prod expo {ND : NatDed A} {CCC: CCCviaNatDed A prod expo} P,
    prod P FF = FF.
Proof.
  intros.
  pose proof isCCC.
  rewrite CartesianClosedCat.comm by eauto.
  eapply CCC_FF_prod; eauto.
Qed.

Instance andp_imp_CCC: forall A {ND : NatDed A}, CCCviaNatDed A andp imp.
Proof.
  intros.
  constructor.
  apply andp_comm.
  apply andp_assoc.
  apply imp_andp_adjoint.
  intros; apply andp_derives; auto.
Qed.

Instance sepcon_wand_CCC: forall A {ND : NatDed A} {SL: SepLog A}, CCCviaNatDed A sepcon wand.
Proof.
  intros.
  constructor.
  apply sepcon_comm.
  apply sepcon_assoc.
  apply wand_sepcon_adjoint.
  intros; apply sepcon_derives; auto.
Qed.

Lemma exp_unit: forall {A} `{NatDed A} (P: unit -> A),
  exp P = P tt.
Proof.
  intros.
  apply pred_ext.
  + apply exp_left; intro x.
    destruct x.
    auto.
  + apply (exp_right tt); auto.
Qed.

Lemma allp_unit: forall {A} `{NatDed A} (P: unit -> A),
  allp P = P tt.
Proof.
  intros.
  apply pred_ext.
  + apply (allp_left _ tt); auto.
  + apply allp_right; intro x.
    destruct x.
    auto.
Qed.

Lemma andp_is_allp {A}{ND: NatDed A}:
   forall P Q, andp P Q = allp (fun x : bool => if x then P else Q).
Proof.
 intros. apply pred_ext.
 apply allp_right. intro b; destruct b.
 apply andp_left1; apply derives_refl.
 apply andp_left2; apply derives_refl.
 apply andp_right.
 apply allp_left with true; apply derives_refl.
 apply allp_left with false; apply derives_refl.
Qed.

Lemma orp_is_exp {A}{ND: NatDed A}:
   forall P Q, orp P Q = exp (fun x : bool => if x then P else Q).
Proof.
 intros. apply pred_ext.
 apply orp_left.
 apply exp_right with true; apply derives_refl.
 apply exp_right with false; apply derives_refl.
 apply exp_left; intro b; destruct b.
 apply orp_right1; apply derives_refl.
 apply orp_right2; apply derives_refl.
Qed.

Lemma exp_prop: forall {B} {ND: NatDed B} A P, exp (fun x: A => prop (P x)) = prop (exists x: A, P x).
Proof.
  intros.
  apply pred_ext.
  + apply exp_left; intros x.
    apply prop_left; intros.
    apply prop_right; exists x; auto.
  + apply prop_left; intros.
    destruct H as [x ?].
    apply (exp_right x).
    apply prop_right; auto.
Qed.

Lemma modus_ponens {A}{ND: NatDed A}: forall P Q: A, derives (andp P (imp P Q)) Q.
Proof.
intros. apply derives_trans with (andp (imp P Q) P).
  apply andp_right; [apply andp_left2 | apply andp_left1]; apply derives_refl.
 apply imp_andp_adjoint. apply derives_refl.
Qed.

Lemma modus_ponens_wand {A}{ND: NatDed A}{SL: SepLog A}:
                      forall P Q: A, derives (sepcon P (wand P Q)) Q.
Proof.
intros.
  rewrite sepcon_comm.  apply wand_sepcon_adjoint. auto.
Qed.

Lemma wand_sepcon_wand: forall {A} {NA: NatDed A} {SA: SepLog A} (P1 P2 Q1 Q2: A),
  (P1 -* Q1) * (P2 -* Q2) |-- P1 * P2 -* Q1 * Q2.
Proof.
  intros.
  rewrite <- wand_sepcon_adjoint.
  rewrite (sepcon_comm P1), <- !sepcon_assoc, (sepcon_comm _ P1), (sepcon_assoc _ _ P2), <- (sepcon_assoc P1), (sepcon_comm _ P2).
  apply sepcon_derives; apply modus_ponens_wand.
Qed.

Lemma sepcon_FF {A}{ND: NatDed A}{SL: SepLog A} :
           forall P: A, sepcon P FF = FF.
Proof.
  intros.
  eapply CCC_prod_FF.
  apply sepcon_wand_CCC.
Qed.

Lemma FF_sepcon {A} {NA: NatDed A}{SA: SepLog A}: forall P: A, FF * P = FF.
Proof.
  intros.
  eapply CCC_FF_prod.
  apply sepcon_wand_CCC.
Qed.

Hint Rewrite @FF_sepcon @sepcon_FF : norm.

Lemma FF_andp {A}{NA: NatDed A}:  forall P: A, FF && P = FF.
Proof.
  intros.
  eapply CCC_FF_prod.
  apply andp_imp_CCC.
Qed.

Lemma andp_FF {A}{NA: NatDed A}:  forall P: A, P && FF = FF.
Proof.
  intros.
  eapply CCC_prod_FF.
  apply andp_imp_CCC.
Qed.
Hint Rewrite @FF_andp @andp_FF : norm.

Lemma FF_orp: forall {A: Type} `{NatDed A} (P: A), FF || P = P.
Proof.
  intros.
  apply pred_ext.
  + apply orp_left.
    apply FF_left.
    apply derives_refl.
  + apply orp_right2.
    apply derives_refl.
Qed.

Lemma orp_FF {A}{NA: NatDed A}:
  forall Q, Q || FF = Q.
Proof.
  intros.
  rewrite orp_comm.
  apply FF_orp.
Qed.

Lemma orp_TT {A}{NA: NatDed A}:
 forall Q, Q || TT = TT.
Proof.
  intros. apply pred_ext.
  + apply orp_left; apply TT_right.
  + apply orp_right2; auto.
Qed.

Lemma TT_orp {A}{NA: NatDed A}:
 forall Q, TT || Q = TT.
Proof.
  intros. apply pred_ext.
  + apply orp_left; apply TT_right.
  + apply orp_right1; auto.
Qed.

Lemma allp_forall: forall {A B: Type} `{NatDed A} P Q (x:B), (forall x:B, (P x = Q)) -> (allp P = Q).
Proof.
  intros.
  apply pred_ext.
  + apply (allp_left _ x).
    rewrite H0.
    apply derives_refl.
  + apply allp_right.
    intros.
    rewrite H0.
    apply derives_refl.
Qed.

Lemma allp_derives:
       forall {A: Type}  {NA: NatDed A} (B: Type) (P Q: B -> A),
               (forall x:B, P x |-- Q x) -> (allp P |-- allp Q).
Proof.
intros.
apply allp_right; intro x; apply allp_left with x; auto.
Qed.

Lemma allp_congr:
       forall {A: Type}  {NA: NatDed A} (B: Type) (P Q: B -> A),
               (forall x:B, P x = Q x) -> (allp P = allp Q).
Proof.
intros.
apply pred_ext; apply allp_derives; intros; rewrite H; auto.
Qed.

Lemma allp_uncurry: forall {A} `{NatDed A} (S T: Type) (P: S -> T -> A),
  allp (allp P) = allp (fun st => P (fst st) (snd st)).
Proof.
  intros.
  apply pred_ext.
  + apply allp_right; intros [s t].
    simpl.
    apply (allp_left _ t).
    apply (allp_left _ s).
    apply derives_refl.
  + apply allp_right; intro t.
    simpl.
    apply allp_right; intro s.
    apply (allp_left _ (s, t)).
    apply derives_refl.
Qed.

Lemma allp_depended_uncurry': forall {A} `{NatDed A} {S: Type} {T: S -> Type} (P: forall s: S, T s -> A),
  ALL s: S, (ALL t: T s, P s t) = ALL st: sigT T, P (projT1 st) (projT2 st).
Proof.
  intros.
  apply pred_ext.
  + apply allp_right; intros [s t].
    simpl.
    apply (allp_left _ s).
    apply (allp_left _ t).
    apply derives_refl.
  + apply allp_right; intro s.
    simpl.
    apply allp_right; intro t.
    apply (allp_left _ (existT T s t)).
    apply derives_refl.
Qed.

Lemma allp_uncurry': forall {A} `{NatDed A} (S T: Type) (P: S -> T -> A),
  ALL s: S, (ALL t: T, P s t) = ALL st: prod S T, P (fst st) (snd st).
Proof.
  intros.
  pose proof (@allp_depended_uncurry' A H S (fun _ => T) P).
  simpl in H0.
  rewrite H0.
  apply pred_ext; apply allp_right; intro st; destruct st as [s t].
  + apply (allp_left _ (existT (fun _ => T) s t)).
    apply derives_refl.
  + apply (allp_left _ (s, t)).
    apply derives_refl.
Qed.

Lemma allp_curry: forall {A} `{NatDed A} (S T: Type) (P: S * T -> A),
  allp P = allp (fun s => allp (fun t => P (s, t))).
Proof.
  intros.
  apply pred_ext.
  + apply allp_right; intro s.
    apply allp_right; intro t.
    apply (allp_left _ (s, t)).
    apply derives_refl.
  + apply allp_right; intros [s t].
    apply (allp_left _ s).
    apply (allp_left _ t).
    apply derives_refl.
Qed.

Lemma exp_derives {A}{NA: NatDed A}{B}:
   forall F G: B -> A, (forall x, F x |-- G x) -> exp F |-- exp G.
Proof.
intros.
apply exp_left; intro x. apply exp_right with x; auto.
Qed.

Lemma exp_congr:
 forall A NA T X Y,
    (forall v, X v = Y v) -> @exp A NA T X = @exp A NA T Y.
Proof.
intros. f_equal. extensionality v; auto.
Qed.

Lemma exp_uncurry:
  forall {T} {ND: NatDed T} A B F, (@exp T ND A (fun a => @exp T ND B (fun b => F a b)))
   = @exp T ND (A*B) (fun ab => F (fst ab) (snd ab)).
Proof.
intros.
apply pred_ext.
apply exp_left; intro a. apply exp_left; intro b. apply exp_right with (a,b).
apply derives_refl.
apply exp_left; intro ab. apply exp_right with (fst ab). apply exp_right with (snd ab).
apply derives_refl.
Qed.

Lemma exp_trivial {A}{NA: NatDed A}:
  forall {T: Type} (any: T) (P: A), exp (fun x:T => P) = P.
Proof.
 intros. apply pred_ext. apply exp_left; auto.
 apply exp_right with any; auto.
Qed.

Lemma allp_andp: forall {A B: Type} `{NatDed A} (P Q: B -> A), allp (P && Q) = allp P && allp Q.
Proof.
  intros.
  apply pred_ext.
  + apply andp_right; apply allp_derives; intros;
    simpl; [apply andp_left1|apply andp_left2]; apply derives_refl.
  + apply allp_right; intros.
    simpl; apply andp_right; [apply andp_left1|apply andp_left2];
    apply (allp_left _ v); apply derives_refl.
Qed.

Lemma distrib_andp_orp: forall {A : Type} {ND : NatDed A} (P Q R : A),
  (P && Q) || R = (P || R) && (Q || R).
Proof.
  intros.
  apply pred_ext.
  + apply orp_left.
    - apply andp_right; apply orp_right1; solve_andp.
    - apply andp_right; apply orp_right2, derives_refl.
  + rewrite imp_andp_adjoint.
    apply orp_left.
    - rewrite <- imp_andp_adjoint.
      rewrite andp_comm.
      rewrite imp_andp_adjoint.
      apply orp_left.
      * rewrite <- imp_andp_adjoint.
        rewrite andp_comm.
        apply orp_right1, derives_refl.
      * rewrite <- imp_andp_adjoint.
        apply orp_right2; solve_andp.
    - rewrite <- imp_andp_adjoint.
      apply orp_right2; solve_andp.
Qed.

Lemma prop_derives {A}{ND: NatDed A}:
 forall (P Q: Prop), (P -> Q) -> prop P |-- prop Q.
Proof.
intros; apply prop_left; intro; apply prop_right; auto.
Qed.

Lemma ND_prop_ext {A}{ND: NatDed A}: forall P Q, (P <-> Q) -> !! P = !! Q.
Proof.
  intros.
  apply pred_ext; apply prop_derives; tauto.
Qed.

Lemma prop_True_right {A}{NA: NatDed A}: forall P:A, P |-- !! True.
Proof. intros; apply prop_right; auto.
Qed.

Lemma derives_refl' {A}{NA: NatDed A}: forall P Q: A, P=Q -> P |-- Q.
Proof.  intros; subst; apply derives_refl. Qed.

Lemma derives_refl'' {A}{NA: NatDed A}: forall P Q: A, Q=P -> P |-- Q.
Proof.  intros; subst; apply derives_refl. Qed.

Lemma wand_derives {A}{ND: NatDed A}{SL: SepLog A}:
    forall P P' Q Q': A , P' |-- P -> Q |-- Q' ->  P -* Q |-- P' -* Q'.
Proof.
  eapply CCC_expo_derives.
  apply sepcon_wand_CCC.
Qed.

Lemma distrib_orp_andp {A}{ND: NatDed A}:
   forall (P Q R : A), andp (orp P Q) R = orp (andp P R) (andp Q R).
Proof.
  intros.
  eapply CCC_distrib_orp_prod.
  apply andp_imp_CCC.
Qed.

Lemma exp_andp1 {A}{ND: NatDed A}:  forall B (p: B -> A) q, andp (exp p) q = (exp (fun x => andp (p x) q)).
Proof.
  eapply CCC_exp_prod1.
  apply andp_imp_CCC.
Qed.

Lemma exp_sepcon1 {A}{ND: NatDed A} {SL: SepLog A}:
  forall T (P: T ->  A) Q, sepcon (exp P) Q = exp (fun x => sepcon (P x) Q).
Proof.
  eapply CCC_exp_prod1.
  apply sepcon_wand_CCC.
Qed.

Lemma distrib_orp_sepcon {A}{ND: NatDed A}{SL: SepLog A}:
      forall (P Q R : A), sepcon (P || Q) R = sepcon P R || sepcon Q R.
Proof.
  intros.
  eapply CCC_distrib_orp_prod.
  apply sepcon_wand_CCC.
Qed.

Lemma distrib_orp_sepcon2 {A}{ND: NatDed A}{SL: SepLog A}:
  forall P Q R: A,
     R * (P || Q) = R * P || R * Q.
Proof.
intros. rewrite !(sepcon_comm R). apply distrib_orp_sepcon.
Qed.

Lemma exp_sepcon2 {A}{NA: NatDed A}{SA: SepLog A}:
  forall T (P: A) (Q: T -> A),  P * exp Q = exp (fun x => P * Q x).
Proof.
  intros.
  eapply CCC_exp_prod2.
  apply sepcon_wand_CCC.
Qed.

Lemma allp_sepcon1 {A}{ND: NatDed A} {SL: SepLog A}:
  forall T (P: T ->  A) Q, sepcon (allp P) Q |-- allp (fun x => sepcon (P x) Q).
Proof.
intros.
apply allp_right; intro x.
apply sepcon_derives; auto.
apply allp_left with x. auto.
Qed.

Lemma allp_sepcon2 {A}{ND: NatDed A} {SL: SepLog A}:
  forall T P (Q: T ->  A), sepcon P (allp Q) |-- allp (fun x => sepcon P (Q x)).
Proof.
intros.
apply allp_right; intro x.
apply sepcon_derives; auto.
apply allp_left with x. auto.
Qed.

Lemma exp_andp2  {A}{NA: NatDed A}:
  forall B (p: A) (q: B -> A) , (p && exp q) = exp (fun x => p && q x).
Proof.
  intros.
  eapply CCC_exp_prod2.
  apply andp_imp_CCC.
Qed.

Lemma imp_derives {A} {NA: NatDed A}:
  forall P P' Q Q' : A,
    P' |-- P ->
    Q |-- Q' ->
    P --> Q |-- P' --> Q'.
Proof.
  intros.
  eapply CCC_expo_derives; auto.
  apply andp_imp_CCC.
Qed.

Lemma imp_right2: forall {A} {NA: NatDed A} (P Q : A), P |-- Q --> P.
Proof.
  intros.
  apply imp_andp_adjoint.
  apply andp_left1.
  auto.
Qed.

Lemma  distrib_sepcon_andp {A}{ND: NatDed A}{SL: SepLog A}:
     forall P Q R, sepcon P (andp Q R) |-- andp (sepcon P Q) (sepcon P R).
Proof.
  intros.
  apply andp_right.
  apply sepcon_derives; [ apply derives_refl | ].
  apply andp_left1; apply derives_refl.
  apply sepcon_derives; [ apply derives_refl | ].
  apply andp_left2; apply derives_refl.
Qed.

Lemma later_derives {A}{ND: NatDed A}{IA: Indir A}:
   forall P Q: A, P |-- Q -> later P |-- later Q.
Proof.
  intros.
  apply derives_trans with (TT && later P).
 apply andp_right. apply prop_right; auto. apply derives_refl.
  apply imp_andp_adjoint.
  eapply derives_trans; [ | apply later_K].
  eapply derives_trans; [ | apply now_later].
 apply imp_andp_adjoint.
 apply andp_left2; auto.
Qed.

Lemma later_andp  {A}{ND: NatDed A}{IA: Indir A}:
       forall P Q: A, later (P && Q) = later P && later Q.
Proof.
 intros. repeat rewrite andp_is_allp.
 rewrite later_allp.
 f_equal. extensionality x.
 destruct x; auto.
Qed.

Lemma later_orp  {A}{ND: NatDed A}{IA: Indir A}:
       forall P Q: A, later (P || Q) = later P || later Q.
Proof.
 intros. repeat rewrite orp_is_exp.
 repeat rewrite (later_exp' _ true).
 f_equal. extensionality x.
 destruct x; auto.
Qed.

Lemma later_left2 {T}{ND: NatDed T}{IT: Indir T}:
 forall A B C : T, A && B |-- C -> A && |> B |-- |>C.
Proof.
intros.
apply derives_trans with (|> (A && B)).
rewrite later_andp.
apply andp_derives; auto.
apply now_later.
apply later_derives; assumption.
Qed.

Lemma andp_dup {A}{ND: NatDed A}: forall P: A, P && P = P.
Proof. intros. apply pred_ext.
apply andp_left1; apply derives_refl.
apply andp_right; apply derives_refl.
Qed.

Lemma andp_TT {A}{NA: NatDed A}: forall (P: A), P && TT = P.
Proof with norm.
intros.
apply pred_ext.
apply andp_left1...
apply andp_right...
Qed.

Lemma TT_prop_right {A}{ND: NatDed A}: forall P: Prop,
   P -> @derives A ND TT (prop P).
Proof.
intros. apply prop_right; auto.
Qed.

Lemma sepcon_andp_prop'  {A}{NA: NatDed A}{SA: SepLog A}:
     forall (P:A)  (Q:Prop) (R: A), (!!Q && P)*R = !!Q&&(P*R).
Proof with norm.
intros.
rewrite sepcon_comm. rewrite sepcon_andp_prop.
rewrite sepcon_comm; auto.
Qed.

Lemma emp_sepcon  {A}{NA: NatDed A}{SA: SepLog A}{CA: ClassicalSep A} : forall (P:A),
   emp * P = P.
Proof with norm.
 intros; rewrite sepcon_comm. apply sepcon_emp.
Qed.

Lemma emp_wand {A}{NA: NatDed A}{SA: SepLog A}{CA: ClassicalSep A}:
   forall P: A, emp -* P = P.
Proof.
intros.
apply pred_ext.
rewrite <- (emp_sepcon (emp -* P)).
apply modus_ponens_wand.
apply wand_sepcon_adjoint.
rewrite sepcon_emp; auto.
Qed.

Lemma TT_andp {A}{NA: NatDed A}: forall P: A,  TT && P = P.
Proof with norm.
  intros. apply pred_ext. apply andp_left2... apply andp_right...
Qed.

Lemma prop_true_andp {A} {NA: NatDed A}:
  forall (P: Prop) (Q: A),  P -> (!! P && Q = Q).
Proof with norm.
intros.
apply pred_ext. apply andp_left2...
apply andp_right... apply prop_right...
Qed.

Lemma prop_true_andp' (P: Prop) {A} {NA: NatDed A}:
  forall (Q: A),  P -> (!! P && Q = Q).
Proof.
intros.
apply pred_ext. apply andp_left2, derives_refl.
apply andp_right. apply prop_right; auto. apply derives_refl.
Qed.

Lemma TT_andp_right {A}{NA: NatDed A}:
 forall P Q, TT |-- P -> TT |-- Q -> TT |-- P && Q.
Proof.
  intros. apply andp_right; auto.
Qed.

Ltac immediate := (assumption || reflexivity).

Hint Rewrite @prop_true_andp using (solve [immediate]) : norm.

Lemma true_eq {A} {NA: NatDed A}:  forall P: Prop, P -> (!! P) = (TT: A).
Proof with norm.
intros. apply pred_ext...
apply prop_right...
Qed.
Hint Rewrite @true_eq using (solve [immediate]) : norm.

Hint Rewrite @andp_dup : norm.

Lemma sepcon_TT {A} {NA: NatDed A}{SA: SepLog A}{CA: ClassicalSep A}:
   forall (P: A), P |-- (P * TT).
Proof with norm.
intros.
apply @derives_trans with (P * emp).
rewrite sepcon_emp...
apply sepcon_derives...
Qed.
Hint Resolve @sepcon_TT.

Lemma TT_sepcon {A} {NA: NatDed A}{SA: SepLog A}{CA: ClassicalSep A}:
   forall (P: A), P |-- (TT * P).
Proof. intros. rewrite sepcon_comm; apply sepcon_TT.
Qed.

Lemma imp_extract_exp_left {B A: Type} {NA: NatDed A}:
    forall    (p : B -> A) (q: A),
  (forall x, p x |-- q) ->
   exp p |-- q.
Proof.
intros.
apply exp_left. auto.
Qed.

Hint Rewrite @sepcon_emp @emp_sepcon @TT_andp @andp_TT
             @exp_sepcon1 @exp_sepcon2
               @exp_andp1 @exp_andp2
         @sepcon_andp_prop @sepcon_andp_prop'
     using (solve [auto with typeclass_instances])
        : norm.

Lemma forall_pred_ext  {A}  {NA: NatDed A}: forall B (P Q: B -> A),
 (ALL x : B, (P x <--> Q x)) |-- (ALL x : B, P x) <--> (ALL x: B, Q x) .
Proof.
intros.
apply andp_right.
 apply @derives_trans with (ALL x:B, P x --> Q x).
 apply allp_derives; intro x; apply andp_left1; auto.
 apply imp_andp_adjoint; apply allp_right; intro x.
 apply @derives_trans with ((P x --> Q x) && P x).
 apply andp_derives; apply allp_left with x; auto.
 rewrite andp_comm. apply modus_ponens.
 apply @derives_trans with (ALL x:B, Q x --> P x).
 apply allp_derives; intro x; apply andp_left2; auto.
 apply imp_andp_adjoint; apply allp_right; intro x.
 apply @derives_trans with ((Q x --> P x) && Q x).
 apply andp_derives; apply allp_left with x; auto.
 rewrite andp_comm. apply modus_ponens.
Qed.

Lemma exists_pred_ext  {A} {NA: NatDed A}: forall B (P Q: B -> A),
 (ALL x : B, (P x <--> Q x)) |-- (EX x : B, P x) <--> (EX x: B, Q x) .
Proof.
intros.
apply andp_right.
 apply imp_andp_adjoint.
autorewrite with norm.
apply exp_left; intro x. apply exp_right with x.
 apply imp_andp_adjoint.
apply allp_left with x. apply andp_left1; auto.
 apply imp_andp_adjoint.
autorewrite with norm.
apply exp_left; intro x. apply exp_right with x.
 apply imp_andp_adjoint.
apply allp_left with x. apply andp_left2; auto.
Qed.

Lemma imp_pred_ext  {A}  {NA: NatDed A}: forall B B' P Q,
       (B <--> B') && (B --> (P <--> Q))
 |-- (B --> P) <-->  (B' --> Q).
Proof.
intros.
apply andp_right.
apply -> imp_andp_adjoint.
apply -> imp_andp_adjoint.
rewrite andp_comm.
rewrite (andp_comm (B --> B')).
repeat rewrite <- andp_assoc.
do 2 rewrite andp_assoc.
eapply derives_trans; [eapply andp_derives; [apply modus_ponens | apply derives_refl] | ].
apply @derives_trans with ((B && (B --> (P --> Q))) && (B && (B --> P))).
repeat apply andp_right.
apply andp_left1; auto.
apply andp_left2. apply andp_left2. apply andp_left1. apply imp_derives; auto.
apply andp_left1; auto.
apply andp_left1; auto.
apply andp_left2. apply andp_left2. apply andp_left2. auto.
apply @derives_trans with ((P --> Q) && P).
apply andp_derives; apply modus_ponens.
rewrite andp_comm; apply modus_ponens.
apply -> imp_andp_adjoint.
apply -> imp_andp_adjoint.
rewrite andp_comm.
repeat rewrite <- andp_assoc.
do 2 rewrite andp_assoc.
eapply derives_trans; [eapply andp_derives; [apply modus_ponens | apply derives_refl] | ].
apply @derives_trans with ((B' && (B' --> (Q --> P))) && (B' && (B' --> Q))).
repeat apply andp_right.
apply andp_left1; auto.
repeat rewrite <- andp_assoc.
apply andp_left1.
apply -> imp_andp_adjoint.
apply andp_left1.
eapply derives_trans; [eapply andp_derives; [apply modus_ponens | apply derives_refl] | ].
eapply derives_trans; [apply modus_ponens | ].
apply andp_left2; auto.
apply andp_left1; auto.
repeat apply andp_left2. auto.
eapply derives_trans; [eapply andp_derives; apply modus_ponens | ].
rewrite andp_comm; apply modus_ponens.
Qed.

Lemma pull_right {A} {NA: NatDed A}{SA: SepLog A}:
 forall P Q R : A,
   (Q * P * R) = (Q * R * P).
Proof.
intros. repeat rewrite sepcon_assoc. rewrite (sepcon_comm P); auto.
Qed.

Lemma pull_right0 {A} {NA: NatDed A}{SA: SepLog A}:
  forall P Q : A,   (P * Q) = (Q * P).
Proof.
intros. rewrite (sepcon_comm P); auto.
Qed.

Ltac pull_left A := repeat (rewrite <- (pull_right A) || rewrite <- (pull_right0 A)).

Ltac pull_right A := repeat (rewrite (pull_right A) || rewrite (pull_right0 A)).

Lemma derives_extract_prop {A} {NA: NatDed A}:
  forall (P: Prop) (Q R: A), (P -> Q |-- R) ->  !!P && Q |-- R.
Proof.
 intros.
 apply imp_andp_adjoint.
 apply prop_left.
 intros. apply imp_andp_adjoint. rewrite TT_andp. apply H; auto.
Qed.

Lemma derives_extract_prop0 {A}{NA: NatDed A}:
    forall (P: Prop) (R: A), (P -> TT |-- R)  -> !!P |-- R.
Proof.
intros.
apply derives_trans with (!!P && TT).
rewrite andp_TT; auto.
apply derives_extract_prop; auto.
Qed.

Lemma derives_extract_prop' {A} {NA: NatDed A}:
  forall (P: Prop) (Q R: A), (P -> Q |-- R) ->  Q && !!P|-- R.
Proof.
intros. rewrite andp_comm. apply derives_extract_prop; auto.
Qed.

Lemma prop_imp {A} {ND: NatDed A}: forall (P: Prop) (Q: A), P -> !! P --> Q = Q.
Proof.
  intros.
  apply pred_ext.
  + eapply derives_trans; [| apply modus_ponens].
    apply andp_right; [| apply derives_refl].
    apply prop_right; auto.
  + apply imp_andp_adjoint.
    apply derives_extract_prop'.
    intros; auto.
Qed.

Lemma andp_assoc' {A}{NA: NatDed A}:
  forall P Q R : A, Q && (P && R) = P && (Q && R).
Proof. intros. rewrite andp_comm. rewrite andp_assoc. f_equal. apply andp_comm.
Qed.

Lemma corable_andp_sepcon2{A}{NA: NatDed A}{SA: SepLog A}{CA: CorableSepLog A}:
   forall P Q R : A, corable P ->  (Q && P) * R = P && (Q * R).
Proof.
intros. rewrite andp_comm. apply corable_andp_sepcon1. auto.
Qed.

Lemma corable_sepcon_andp1 {A}{NA: NatDed A}{SA: SepLog A}{CA: CorableSepLog A}:
   forall P Q R : A, corable P ->  Q  * (P && R) = P && (Q * R).
Proof.
intros. rewrite sepcon_comm. rewrite corable_andp_sepcon1; auto. rewrite sepcon_comm; auto.
Qed.

Lemma corable_sepcon_andp2 {A}{NA: NatDed A}{SA: SepLog A}{CA: CorableSepLog A}:
   forall P Q R : A, corable P ->  Q  * (R && P) = P && (Q * R).
Proof.
intros. rewrite sepcon_comm. rewrite andp_comm. rewrite corable_andp_sepcon1; auto. rewrite sepcon_comm; auto.
Qed.

Hint Resolve @corable_andp @corable_orp @corable_allp @corable_exp
                    @corable_imp @corable_prop @corable_sepcon @corable_wand @corable_later.
Hint Resolve @corable_prop : norm.

(* The followings are not in auto-rewrite lib. *)

Lemma sepcon_left_corable: forall {A}{NA: NatDed A}{SA: SepLog A}{CA: CorableSepLog A} (P Q: A), corable P -> (P * Q = (P && Q) * TT).
Proof.
  intros.
  pattern P at 1.
  rewrite <- (andp_TT P).
  rewrite !corable_andp_sepcon1 by auto.
  rewrite sepcon_comm.
  reflexivity.
Qed.

Lemma andp_left_corable: forall {A}{NA: NatDed A}{SA: SepLog A}{ClA: ClassicalSep A}{CA: CorableSepLog A} (P Q: A), corable P -> P && Q = (P && emp) * Q.
Proof.
  intros.
  pattern P at 1.
  rewrite corable_andp_sepcon1 by auto.
  rewrite sepcon_comm, sepcon_emp.
  reflexivity.
Qed.

Lemma TT_sepcon_TT: forall {A} `{ClassicalSep A}, TT * TT = TT.
Proof.
  intros.
  apply pred_ext.
  + apply prop_right; auto.
  + apply sepcon_TT.
Qed.

Lemma not_prop_right: forall {A} {NA: NatDed A} (P: A) (Q: Prop), (Q -> derives P FF) -> derives P (prop (not Q)).
Proof.
  intros.
  eapply derives_trans; [| apply prop_imp_prop_left].
  apply imp_andp_adjoint.
  apply derives_extract_prop'; auto.
Qed.

Lemma prop_and {A} {NA: NatDed A}:
    forall P Q: Prop, prop (P /\ Q) = (prop P && prop Q).
Proof.
  intros. apply pred_ext.
  + apply prop_left. intros [? ?].
    apply andp_right; apply prop_right; auto.
  + apply derives_extract_prop; intros.
    apply prop_left; intros.
    apply prop_right; auto.
Qed.

Lemma prop_impl {A} {NA: NatDed A}:
  forall P Q: Prop, prop (P -> Q) = (prop P --> prop Q).
Proof.
  intros.
  apply pred_ext.
  + apply imp_andp_adjoint.
    apply derives_extract_prop'; intros.
    apply prop_derives.
    auto.
  + apply prop_imp_prop_left.
Qed.

Lemma prop_forall {A B} {NA: NatDed A}:
  forall P: B -> Prop, prop (forall b, P b) = ALL b: B, !! P b.
Proof.
  intros.
  apply pred_ext.
  + apply allp_right; intros.
    apply prop_derives; auto.
  + apply allp_prop_left.
Qed.

Lemma sepcon_prop_prop:
  forall {A} `{ClassicalSep A} P Q, !! P * !! Q = !! (P /\ Q).
Proof.
  intros.
  rewrite <- (andp_TT (!! Q)) at 1.
  rewrite sepcon_andp_prop.
  rewrite <- (andp_TT (!! P)) at 1.
  rewrite sepcon_comm.
  rewrite sepcon_andp_prop.
  rewrite TT_sepcon_TT.
  rewrite andp_TT.
  rewrite andp_comm.
  rewrite prop_and.
  reflexivity.
Qed.

Lemma corable_sepcon_TT: forall {A}{NA: NatDed A}{SA: SepLog A}{ClA: ClassicalSep A}{CA: CorableSepLog A} (P : A), corable P -> P * TT = P.
Proof.
  intros.
  rewrite <- (andp_TT P).
  rewrite corable_andp_sepcon1 by auto.
  rewrite TT_sepcon_TT.
  reflexivity.
Qed.

Lemma derives_left_sepcon_right_corable: forall {A}{NA: NatDed A}{SA: SepLog A}{ClA: ClassicalSep A}{CA: CorableSepLog A} (P Q R: A), corable P -> (Q |-- P) -> Q * R |-- P.
Proof.
  intros.
  rewrite <- corable_sepcon_TT by auto.
  apply sepcon_derives; auto.
  apply TT_right.
Qed.

Lemma later_prop_andp_sepcon: forall {A: Type} {A}{NA: NatDed A}{SA: SepLog A}{ClA: ClassicalSep A}{IA: Indir A}{CSL: CorableSepLog A} {CI: CorableIndir A} (P: Prop) (Q R: A),
((|> !! P) && Q) * R = (|> !! P) && (Q * R).
Proof.
  intros.
  apply corable_andp_sepcon1.
  apply corable_later.
  apply corable_prop.
Qed.

Lemma sepcon_corable_corable:
  forall {A} `{CorableSepLog A} {ClS: ClassicalSep A} P Q, corable P -> corable Q -> P * Q = P && Q.
Proof.
  intros.
  apply pred_ext.
  + apply andp_right.
    - rewrite <- (andp_TT P) at 1.
      rewrite corable_andp_sepcon1 by auto.
      apply andp_left1; auto.
    - rewrite <- (andp_TT Q) at 1.
      rewrite corable_sepcon_andp1 by auto.
      apply andp_left1; auto.
  + rewrite andp_left_corable by auto.
    apply sepcon_derives; auto.
    apply andp_left1; auto.
Qed.

Lemma prop_false_andp {A}{NA :NatDed A}:
 forall P Q, ~P -> !! P && Q = FF.
Proof.
intros.
apply pred_ext.
+ apply derives_extract_prop; tauto.
+ apply FF_left.
Qed.

Lemma andp_prop_derives: forall {A} {NA: NatDed A} (P P': Prop) (Q Q': A),
  (P <-> P') ->
  (P -> Q |-- Q') ->
  !! P && Q |-- !! P' && Q'.
Proof.
  intros.
  apply derives_extract_prop.
  intros.
  apply andp_right; [apply prop_right; tauto | auto].
Qed.

Lemma andp_prop_ext:
 forall {A}{NA: NatDed A} (P P': Prop) (Q Q': A),
  (P<->P') ->
  (P -> (Q=Q')) ->
  !! P && Q = !! P' && Q'.
Proof.
  intros.
  apply pred_ext; apply andp_prop_derives.
  + auto.
  + intros.
    rewrite H0 by auto; auto.
  + tauto.
  + intros.
    rewrite H0 by tauto; auto.
Qed.

Lemma prop_and_same_derives {A}{NA: NatDed A}:
  forall P Q, Q |-- !! P   ->   Q |-- !!P && Q.
Proof.
intros. apply andp_right; auto.
Qed.

Ltac normalize1 :=
         match goal with
            | |- _ => contradiction
            | |- context [@andp ?A (@LiftNatDed ?T ?B ?C) ?D ?E ?F] =>
                      change (@andp A (@LiftNatDed T B C) D E F) with (D F && E F)
            | |- context [@later ?A  (@LiftNatDed ?T ?B ?C) (@LiftIndir ?X1 ?X2 ?X3 ?X4 ?X5) ?D ?F] =>
                   change (@later A  (@LiftNatDed T B C) (@LiftIndir X1 X2 X3 X4 X5) D F)
                     with (@later B C X5 (D F))
            | |- context [@sepcon ?A (@LiftNatDed ?B ?C ?D)
                                                         (@LiftSepLog ?E ?F ?G ?H) ?J ?K ?L] =>
                   change (@sepcon A (@LiftNatDed B C D) (@LiftSepLog E F G H) J K L)
                      with (@sepcon C D H (J L) (K L))
            | |- context [(?P && ?Q) * ?R] => rewrite (corable_andp_sepcon1 P Q R) by (auto with norm)
            | |- context [?Q * (?P && ?R)] => rewrite (corable_sepcon_andp1 P Q R) by (auto with norm)
            | |- context [(?Q && ?P) * ?R] => rewrite (corable_andp_sepcon2 P Q R) by (auto with norm)
            | |- context [?Q * (?R && ?P)] => rewrite (corable_sepcon_andp2 P Q R) by (auto with norm)
            (* In the next four rules, doing it this way (instead of leaving it to autorewrite)
                preserves the name of the "y" variable *)
            | |- context [andp (exp (fun y => _)) _] =>
                autorewrite with norm; apply imp_extract_exp_left; intro y
            | |- context [andp _ (exp (fun y => _))] =>
                autorewrite with norm; apply imp_extract_exp_left; intro y
            | |- context [sepcon (exp (fun y => _)) _] =>
               autorewrite with norm; apply imp_extract_exp_left; intro y
            | |- context [sepcon _ (exp (fun y => _))] =>
                autorewrite with norm; apply imp_extract_exp_left; intro y

           | |-  derives ?A   _ => match A with
                          | context [ ((!! ?P) && ?Q) && ?R ] => rewrite (andp_assoc (!!P) Q R)
                          | context [ ?Q && (!! ?P && ?R)] =>
                                         match Q with !! _ => fail 2 | _ => rewrite (andp_assoc' (!!P) Q R) end
                         end
            | |- _ => progress  (autorewrite with norm); auto with typeclass_instances
            | |- _ = ?x -> _ => intro; subst x
            | |- ?x = _ -> _ => intro; subst x
            |  |- ?ZZ -> _ => match type of ZZ with
                                               | Prop =>
                                                    let H := fresh in
                                                       ((assert (H:ZZ) by auto; clear H; intros _) || intro H)
                                               | _ => intros _
                                              end
            | |- forall _, _ => let x := fresh "x" in (intro x; normalize1; try generalize dependent x)
            | |- exp _ |-- _ => apply imp_extract_exp_left
            | |- !! _ |-- _ => apply derives_extract_prop0
            | |- !! _ && _ |-- _ => apply derives_extract_prop
            | |- _ && !! _ |-- _ => apply derives_extract_prop'
            | |- _ |-- !! (?x = ?y) && _ =>
                            (rewrite prop_true_andp with (P:= (x=y))
                                            by (unfold y; reflexivity); unfold y in *; clear y) ||
                            (rewrite prop_true_andp with (P:=(x=y))
                                            by (unfold x; reflexivity); unfold x in *; clear x)
            | |- TT |-- !! _ => apply TT_prop_right
            | |- _ => solve [auto with typeclass_instances]
            end.

Ltac normalize1_in Hx :=
             match type of Hx with
                 | context [@andp ?A (@LiftNatDed ?T ?B ?C) ?D ?E ?F] =>
                         change (@andp A (@LiftNatDed T B C) D E F) with (D F && E F)
                 | context [@later ?A  (@LiftNatDed ?T ?B ?C) (@LiftIndir ?X1 ?X2 ?X3 ?X4 ?X5) ?D ?F] =>
                    change (@later A  (@LiftNatDed T B C) (@LiftIndir X1 X2 X3 X4 X5) D F)
                     with (@later B C X5 (D F))
                 | context [@sepcon ?A (@LiftNatDed ?B ?C ?D)
                                                         (@LiftSepLog ?E ?F ?G ?H) ?J ?K ?L] =>
                   change (@sepcon A (@LiftNatDed B C D) (@LiftSepLog E F G H) J K L)
                      with (@sepcon C D H (J L) (K L))
                | context [ !! ?P ] =>
                                    rewrite (true_eq P) in Hx by auto with typeclass_instances
                | context [ !! ?P && ?Q ] =>
                                    rewrite (prop_true_andp P Q) in Hx by auto with typeclass_instances
                | context [(?P && ?Q) * ?R] => rewrite (corable_andp_sepcon1 P Q R) in Hx by (auto with norm)
                | context [?Q * (?P && ?R)] => rewrite (corable_sepcon_andp1 P Q R) in Hx by (auto with norm)
                | context [(?Q && ?P) * ?R] => rewrite (corable_andp_sepcon2 P Q R) in Hx by (auto with norm)
                | context [?Q * (?R && ?P)] => rewrite (corable_sepcon_andp2 P Q R) in Hx by (auto with norm)
                | _ => progress  (autorewrite with norm in Hx); auto with typeclass_instances
                end.

Ltac normalize := repeat (auto with norm; normalize1).

Tactic Notation "normalize" "in" hyp(H) := repeat (normalize1_in H).

Lemma guarded_sepcon_orp_distr {A}{ND: NatDed A}{SL: SepLog A}: forall (P1 P2: Prop) p1 p2 q1 q2,
  (P1 -> P2 -> False) ->
  (!! P1 && p1 || !! P2 && p2) * (!! P1 && q1 || !! P2 && q2) = !! P1 && (p1 * q1) || !! P2 && (p2 * q2).
Proof.
  intros.
  rewrite distrib_orp_sepcon.
  rewrite (sepcon_comm (!! P1 && p1)).
  rewrite (sepcon_comm (!! P2 && p2)).
  rewrite !distrib_orp_sepcon.
  apply pred_ext.
  + repeat apply orp_left; normalize.
    - apply orp_right1.
      rewrite sepcon_comm; auto.
    - tauto.
    - tauto.
    - apply orp_right2.
      rewrite sepcon_comm; auto.
  + apply orp_left.
    - apply orp_right1.
      apply orp_right1.
      normalize.
      rewrite sepcon_comm; auto.
    - apply orp_right2.
      apply orp_right2.
      normalize.
      rewrite sepcon_comm; auto.
Qed.

Definition mark {A: Type} (i: nat) (j: A) := j.

Lemma swap_mark1 {A} {NA: NatDed A}{SA: SepLog A}:
  forall i j (Pi Pj B : A), (i<j)%nat -> B * mark i Pi * mark j Pj = B * mark j Pj * mark i Pi.
Proof.
intros.
repeat rewrite sepcon_assoc.
f_equal.
apply sepcon_comm.
Qed.

Lemma swap_mark0 {A} {NA: NatDed A}{SA: SepLog A}:
  forall i j (Pi Pj: A),  (i<j)%nat -> mark i Pi * mark j Pj = mark j Pj * mark i Pi.
Proof.
intros.
apply sepcon_comm.
Qed.

Ltac select_left n :=
  repeat match goal with
 | |- context [(_ * mark ?i _ * mark n _)] =>
      rewrite (swap_mark1 i n); [ | solve [simpl; auto]]
 | |- context [(mark ?i _ * mark n _)] =>
      rewrite (swap_mark0 i n); [ | solve [simpl; auto]]
end.
Ltac select_all n := match n with
                                | O => idtac
                                | S ?n' => select_left n; select_all n'
                              end.
Ltac markem n P :=
   match P with
   | (?Y * ?Z) =>
        (match goal with H: mark _ Z = Z |- _ => idtac end
        || assert (mark n Z = Z) by auto); markem (S n) Y
   | ?Z =>  match goal with H: mark _ Z = Z |- _ => idtac end
                || assert (mark n Z = Z) by auto
  end.

Ltac prove_assoc_commut :=
 clear;
 try (match goal with |- ?F _ -> ?G _ => replace G with F; auto end);
  (repeat rewrite <- sepcon_assoc;
   match goal with |- ?P = _ => markem O P end;
   let LEFT := fresh "LEFT" in match goal with |- ?P = _ => set (LEFT := P) end;
  match goal with H: mark ?n _ = _ |- _ =>
     repeat  match goal with H: mark ?n _ = ?P |- _ => rewrite <- H; clear H end;
     select_all n;
     reflexivity
   end).

Lemma test_prove_assoc_commut {T}{NA: NatDed T}{SA: SepLog T} : forall A B C D E : T,
   D * E * A * C * B = A * B * C * D * E.
Proof.
intros.
prove_assoc_commut.
Qed.

(***** subtyping and contractiveness -- should split this into a separate file ******)
Require Import VST.msl.alg_seplog.

Lemma later_fash1 {A} {NA: NatDed A}{IA: Indir A}{RA: RecIndir A}:
   forall P : A, |> # P |-- # |> P.
Proof. intros. rewrite later_fash; auto.
Qed.

Lemma subp_later1 {A}  {NA: NatDed A}{IA: Indir A}{RA: RecIndir A} : forall P Q : A,
   |>(P >=> Q)  |--   |>P >=> |>Q.
Proof.
intros.
rewrite later_fash. rewrite later_imp. auto.
Qed.

Lemma subp_later {A}  {NA: NatDed A}{IA: Indir A}{RA: RecIndir A} : forall P Q : A,
   |>(P >=> Q) = |>P >=> |>Q.
Proof.
intros.
rewrite later_fash. rewrite later_imp. auto.
Qed.

Lemma eqp_later1 {A} {NA: NatDed A}{IA: Indir A}{RA: RecIndir A} : forall P Q : A,
   |>(P <=> Q)  |--   |>P <=> |>Q.
Proof.
intros.
rewrite later_fash.
rewrite later_andp; repeat rewrite later_imp; repeat  rewrite fash_andp. auto.
Qed.

Lemma eqp_later {A}  {NA: NatDed A}{IA: Indir A}{RA: RecIndir A}  : forall P Q: A,
    (|>(P <=> Q) = |>P <=> |>Q).
Proof.
intros.
rewrite later_fash.
rewrite later_andp; repeat rewrite later_imp; repeat  rewrite fash_andp. auto.
Qed.

Lemma subp_refl {A} {NA: NatDed A}{IA: Indir A}{RA: RecIndir A}  : forall G (P : A),
  G |-- P >=> P.
Proof.
intros.
rewrite <- (fash_triv G).
apply @derives_trans with (#TT).
apply fash_TT.
apply fash_derives.
apply imp_andp_adjoint.
apply andp_left2; auto.
Qed.

Lemma subp_trans {A} {NA: NatDed A}{IA: Indir A}{RA: RecIndir A}  : forall G (P Q R: A),
  G |-- P >=> Q ->
  G |-- Q >=> R ->
  G |-- P >=> R.
Proof.
intros.
  apply @derives_trans with ((P >=> Q) && (Q >=> R)).
 apply andp_right; auto.
  clear.
 rewrite <- fash_andp. apply fash_derives.
 apply -> imp_andp_adjoint.
 rewrite andp_comm. rewrite <- andp_assoc.
 eapply derives_trans; [ apply andp_derives | ].
 apply modus_ponens. apply derives_refl. apply modus_ponens.
Qed.

Lemma subp_top {A} {NA: NatDed A}{IA: Indir A}{RA: RecIndir A}  : forall G (P: A),
  G |-- P >=> TT.
Proof.
 intros. apply @derives_trans with (#TT).
 apply fash_TT.
 apply fash_derives. apply imp_andp_adjoint.
 apply andp_left1; auto.
Qed.

Lemma subp_bot {A} {NA: NatDed A}{IA: Indir A}{RA: RecIndir A}  : forall G (P: A),
  G |-- FF >=> P.
Proof.
 intros. apply @derives_trans with (#TT).
 apply fash_TT.
 apply fash_derives. apply imp_andp_adjoint.
 apply andp_left2; apply FF_left.
Qed.

Lemma subp_andp {A} {NA: NatDed A}{IA: Indir A}{RA: RecIndir A}  : forall G {P P' Q Q': A},
  G |-- P >=> P' ->
  G |-- Q >=> Q' ->
  G |-- P && Q >=> (P' && Q').
Proof.
 intros.
 apply @derives_trans with ((P >=> P') && (Q >=> Q')).
 apply andp_right; auto.
 clear.
 rewrite <- fash_andp. apply fash_derives.
 apply -> imp_andp_adjoint.
 apply @derives_trans with ((P && (P --> P')) && (Q && (Q --> Q'))).
 repeat apply andp_right.
 apply andp_left2. apply andp_left1; auto.
 do 2 apply andp_left1; auto.
 repeat apply andp_left2; auto.
 apply andp_left1; apply andp_left2; auto.
 apply andp_derives; apply modus_ponens.
Qed.

Lemma subp_imp {A} {NA: NatDed A}{IA: Indir A}{RA: RecIndir A}  : forall G (P P' Q Q' : A),
  G |-- P' >=> P ->
  G |-- Q >=> Q' ->
  G |-- (P --> Q) >=> (P' --> Q').
Proof.
 intros.
 apply @derives_trans with ((P' >=> P) && (Q >=> Q')).
 apply andp_right; auto.
 clear.
 rewrite <- fash_andp. apply fash_derives.
 apply -> imp_andp_adjoint.
 apply -> imp_andp_adjoint.
 apply @derives_trans with (((P' && (P' --> P)) && (P --> Q)) && (Q --> Q')).
 repeat apply andp_right.
 apply andp_left2.  auto.
 do 3 apply andp_left1; auto.
 apply andp_left1. repeat apply andp_left2; auto.
 apply andp_left1; apply andp_left1. apply andp_left2;  auto.
 eapply derives_trans ; [eapply andp_derives | ].
 eapply derives_trans ; [eapply andp_derives | ].
 apply modus_ponens. apply derives_refl.
 apply modus_ponens. apply derives_refl.
 apply modus_ponens.
Qed.

Lemma subp_orp {A} {NA: NatDed A}{IA: Indir A}{RA: RecIndir A}  : forall G (P P' Q Q' : A),
  G |-- P >=> P' ->
  G |-- Q >=> Q' ->
  G |-- (P || Q) >=> (P' || Q').
Proof.
 intros.
 eapply derives_trans; [ apply andp_right; [apply H | apply H0] | ].
 clear.
 rewrite <- fash_andp. apply fash_derives.
 apply -> imp_andp_adjoint.
rewrite andp_comm. apply imp_andp_adjoint.
apply orp_left; apply -> imp_andp_adjoint; [apply orp_right1 | apply orp_right2].
 rewrite <- andp_assoc. apply andp_left1. apply modus_ponens.
 rewrite (andp_comm (_ --> _)).
 rewrite <- andp_assoc. apply andp_left1. apply modus_ponens.
Qed.

Lemma subp_subp {A} {NA: NatDed A}{IA: Indir A}{RA: RecIndir A}:
  forall G (P Q R S: A),
   G |-- (R >=> P) ->
   G |-- (Q >=> S) ->
   G |-- (P >=> Q) >=> (R >=> S).
Proof.
 intros.
 intros.
 eapply derives_trans; [ apply andp_right; [apply H | apply H0] | ].
 clear.
 rewrite fash_triv.
 apply -> (@imp_andp_adjoint Triv).
 rewrite andp_assoc.
 apply @derives_trans with ((R >=> P) && (P >=> S)).
 apply andp_derives; auto.
 apply subp_trans with Q. apply andp_left2; auto. apply andp_left1; auto.
  apply subp_trans with P. apply andp_left1; auto. apply andp_left2; auto.
Qed.

Lemma allp_imp2_later_e2 {B}{A}{NA: NatDed A}{IA: Indir A}{RA: RecIndir A}:
   forall (P Q: B -> A) (y: B) ,
      (ALL x:B, |> P x <=> |> Q x) |-- |> Q y >=> |> P y.
Proof.
  intros. apply allp_left with y. repeat rewrite fash_andp. apply andp_left2; auto.
Qed.

Lemma allp_imp2_later_e1 {B}{A}{NA: NatDed A}{IA: Indir A}{RA: RecIndir A}:
   forall (P Q: B -> A) (y: B) ,
      (ALL x:B, |> P x <=> |> Q x) |-- |> P y >=> |> Q y.
Proof.
  intros. apply allp_left with y. repeat rewrite fash_andp. apply andp_left1; auto.
Qed.

Lemma prove_HOcontractive1 {A} {NA: NatDed A}{IA: Indir A}{RA: RecIndir A} : forall X F,
  (forall P Q: X -> A,
    (ALL x:X, |>(P x >=> Q x) |--
        ALL x:X, F P x >=> F Q x)) ->
   HOcontractive F.
Proof.
  unfold HOcontractive.
  intros.
  apply allp_right; intro v.
  rewrite fash_andp.
  apply andp_right.
  specialize (H P Q).
  eapply derives_trans; [ | eapply derives_trans ; [ apply H |] ].
  apply allp_derives; intro x.
  apply @later_derives. apply fash_derives. apply andp_left1. auto.
  apply allp_left with v; auto.
  specialize (H Q P).
  eapply derives_trans; [ | eapply derives_trans ; [ apply H |] ].
  apply allp_derives; intro x.
  apply later_derives. apply fash_derives. apply andp_left2. auto.
  apply allp_left with v; auto.
Qed.

Lemma prove_HOcontractive {A} {NA: NatDed A}{IA: Indir A}{RA: RecIndir A} : forall X F,
  (forall (P Q: X -> A) (x: X),
    (ALL x:X, (|> P x <=> |> Q x) |-- F P x >=> F Q x)) ->
   HOcontractive F.
Proof.
  intros.
  unfold HOcontractive.
  intros.
  apply allp_right; intro v.
  rewrite fash_andp.
  apply andp_right.
  eapply derives_trans; [ | apply H].
  apply allp_derives; intro x.
  rewrite eqp_later. auto.
  eapply derives_trans; [ | apply H].
  apply allp_derives; intro x.
  rewrite eqp_later. rewrite andp_comm. auto.
Qed.

Lemma sub_sepcon' {A}{NA: NatDed A}{SL: SepLog A}{IA: Indir A}{RA: RecIndir A}{SRA: SepRec A}:
  forall P P' Q Q': A, (P >=> P') && (Q >=> Q') |-- (P * Q) >=> (P' * Q').
Proof.
intros.
apply subp_i1.
rewrite unfash_sepcon_distrib.
apply sepcon_derives.
apply derives_trans with ((P --> P') && P).
apply andp_derives; auto.
eapply derives_trans; [ | apply unfash_fash ].
apply unfash_derives. apply andp_left1; auto.
rewrite andp_comm; apply modus_ponens.
apply derives_trans with ((Q --> Q') && Q).
apply andp_derives; auto.
eapply derives_trans; [ | apply unfash_fash ].
apply unfash_derives. apply andp_left2; auto.
rewrite andp_comm; apply modus_ponens.
Qed.

Lemma subp_sepcon {A} {NA: NatDed A}{IA: Indir A}{SA: SepLog A}{SI: SepIndir A}{RA: RecIndir A}{SRA: SepRec A} :
    forall G (P P' Q Q' : A),
  G |-- P >=> P' ->
  G |-- Q >=> Q' ->
  G |-- P * Q >=> P' * Q'.
Proof.
 intros.
 eapply derives_trans; [ | apply sub_sepcon'].
 apply andp_right; auto.
Qed.

Ltac sub_unfold :=
   match goal with
    | |- _ |-- ?A _ >=> ?A _ => unfold A
    | |- _ |-- ?A _ _ >=> ?A _ _ => unfold A
    | |- _ |-- ?A _ _ _ >=> ?A _ _ _ => unfold A
    | |- _ |-- ?A _ _ _ _ >=> ?A _ _ _ _ => unfold A
    | |- _ |-- ?A _ _ _ _ _ >=> ?A _ _ _ _ _ => unfold A
    | v: _ |- _ => destruct v
   end.

Hint Extern 2 (_ |-- _ >=> _) => sub_unfold : contractive.

Hint Resolve @prove_HOcontractive
  @subp_allp @subp_imp @subp_refl @subp_exp @subp_andp @subp_orp @subp_subp
  @subp_sepcon (* NOTE: This hint fails to work unless fully instantiated, for some reason;
                             so the client must re-do the subp_sepcon hint *)
  @allp_imp2_later_e1 @allp_imp2_later_e2 : contractive.

Lemma  goedel_loeb {A}  {NA: NatDed A}{IA: Indir A}:
    forall P Q : A ,   Q && later P |-- P ->  Q |-- P.
Proof.
intros.
assert (TT |-- Q --> P).
apply loeb.
rewrite later_imp.
apply imp_andp_adjoint.
eapply derives_trans; [ | apply H].
apply andp_right.
apply andp_left2; auto.
rewrite andp_comm.
apply derives_trans with (|> Q && (|> Q --> |> P)).
apply andp_derives; auto.
apply now_later.
apply modus_ponens.
apply derives_trans with (Q && (Q --> P)).
apply andp_right; auto.
apply derives_trans with TT; auto.
apply TT_right.
apply modus_ponens.
Qed.

(*Lemma Rec_sub {A} {NA: NatDed A}{IA: Indir A}{RA: RecIndir A} : forall G
  (F   : A -> A -> A)
  (HF1 : forall X, contractive (F X))
  (HF2 : forall R P Q, P >=> Q |-- F P R >=> F Q R)
  (HF3 : forall P Q X, |>(P >=> Q) |-- F X P >=> F X Q),
  forall P Q,
    G |-- P >=> Q ->
    G |-- Rec (F P) >=> Rec (F Q).
*)

Lemma HORec_sub {A}  {NA: NatDed A}{IA: Indir A}{RA: RecIndir A} : forall G B
  (F : A -> (B -> A) -> B -> A)
  (HF1 : forall X, HOcontractive (F X))
  (HF2 : forall R a (P Q: A), P >=> Q |-- F P R a >=> F Q R a)
  (HF3 : forall (P Q: B -> A) X, ALL b:B, |>(P b >=> Q b) |-- ALL b:B, F X P b >=> F X Q b),
  forall P Q : A,
    G |-- P >=> Q ->
    G |-- ALL b:B, HORec (F P) b >=> HORec (F Q) b.
Proof.
  intros.
  apply @derives_trans with (P>=>Q); auto.
  clear G H.
  apply goedel_loeb.
  apply allp_right; intro b.
  rewrite HORec_fold_unfold by auto.
  pose proof (HORec_fold_unfold _ _ (HF1 P)).
  pose proof (HORec_fold_unfold _ _ (HF1 Q)).
  set (P' := HORec (F P)) in *.
  set (Q' := HORec (F Q)) in *.
  rewrite <- H.
  specialize (HF3 P' Q' P).
  rewrite later_allp.
 eapply derives_trans; [apply andp_derives ; [apply derives_refl | apply HF3] | ].
  specialize (HF2 Q' b P Q). rewrite <- H0 in HF2.
 rewrite <- H in *.
  apply subp_trans with  (F P Q' b).
  apply andp_left2.  apply allp_left with b; auto.
  apply andp_left1; auto.
Qed.

(****** End contractiveness *****)

Require Import VST.msl.ghost_seplog.

Lemma bupd_andp2_corable: forall {A N D: Type} {ND : NatDed A} {SL : SepLog A} {CSL: ClassicalSep A} {BS : BupdSepLog A N D} {CoSL: CorableSepLog A},
  forall P Q, corable Q -> (|==> P) && Q |-- |==> (P && Q).
Proof.
  intros.
  rewrite (andp_comm P Q), (andp_left_corable Q), sepcon_comm by auto.
  eapply derives_trans; [| apply bupd_frame_r].
  rewrite (andp_comm _ Q), (andp_left_corable Q), sepcon_comm by auto.
  auto.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable t_phi_2_ : Prop.
Variable t_phi_1_ : Prop.
Variable t_or_2_ : Universe -> Prop.
Variable t_or_1_ : Universe -> Prop.
Variable t_ex_2_ : Prop.
Variable t_ex_1_ : Prop.
Variable t_and_2_ : Universe -> Prop.
Variable t_and_1_ : Universe -> Prop.
Variable p_2_ : Universe -> Prop.
Variable p_1_ : Universe -> Prop.
Variable notp_2_ : Universe -> Prop.
Variable notp_1_ : Universe -> Prop.
Variable goal_ : Prop.
Variable dom_ : Universe -> Prop.

Variable a_ : Universe.

Variable initial_model_1 : (dom_ a_ /\ t_phi_2_).
Variable pnnp_2_2 : (forall X : Universe, ((p_2_ X /\ notp_2_ X) -> goal_)).
Variable pnnp_1_3 : (forall X : Universe, ((p_1_ X /\ notp_1_ X) -> goal_)).
Variable ax_phi_2_4 : (forall X : Universe, ((dom_ X /\ t_phi_2_) -> t_or_2_ X)).
Variable ax_or_2_5 : (forall X : Universe, (t_or_2_ X -> (t_phi_1_ \/ t_and_2_ X))).
Variable ax_and_2_6 : (forall X : Universe, (t_and_2_ X -> (p_2_ X /\ t_ex_2_))).
Variable ax_ex_2_7 : (t_ex_2_ -> (exists Y : Universe, (dom_ Y /\ notp_2_ Y))).
Variable ax_phi_1_8 : (forall X : Universe, ((dom_ X /\ t_phi_1_) -> t_or_1_ X)).
Variable ax_or_1_9 : (forall X : Universe, (t_or_1_ X -> t_and_1_ X)).
Variable ax_and_1_10 : (forall X : Universe, (t_and_1_ X -> (p_1_ X /\ t_ex_1_))).
Variable ax_ex_1_11 : (t_ex_1_ -> (exists Y : Universe, (dom_ Y /\ notp_1_ Y))).

Theorem delta_12 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Modal.
Require Import SecOrder.
Require Import p_is_pos.
Require Import p_occurs_in.
Require Import P_occurs_in_alpha.
Require Import ST_setup.
Require Import Correctness_ST.
Require Import Coq.Arith.EqNat.
Require Import List_machinery_impl my_arith__my_leb_nat.

(* Uniform_Mod_Defns *)

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

Fixpoint SOQFree (alpha : SecOrder) : bool :=
  match alpha with
    predSO _ _ => true
  | relatSO _ _ =>  true
  | eqFO _ _ => true
  | allFO _ beta => SOQFree beta
  | exFO _ beta => SOQFree beta
  | negSO beta => SOQFree beta
  | conjSO beta1 beta2 => if SOQFree beta1 then SOQFree beta2 else false
  | disjSO beta1 beta2 => if SOQFree beta1 then SOQFree beta2 else false
  | implSO beta1 beta2 => if SOQFree beta1 then SOQFree beta2 else false
  | allSO _ _ => false
  | exSO _ _ => false
  end.

Fixpoint SOQFree_l (l : list SecOrder) : bool :=
  match l with
  | nil => true
  | cons alpha l' => if SOQFree alpha then SOQFree_l l' else false
  end.

Fixpoint is_unary_predless (alpha : SecOrder) : bool :=
  match alpha with
    predSO _ _ => false
  | relatSO _ _ =>  true
  | eqFO _ _ => true
  | allFO _ beta => is_unary_predless beta
  | exFO _ beta => is_unary_predless beta
  | negSO beta => is_unary_predless beta
  | conjSO beta1 beta2 => if is_unary_predless beta1 then is_unary_predless beta2 else false
  | disjSO beta1 beta2 => if is_unary_predless beta1 then is_unary_predless beta2 else false
  | implSO beta1 beta2 => if is_unary_predless beta1 then is_unary_predless beta2 else false
  | allSO _ beta => false
  | exSO _ beta => false
  end.

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

Lemma is_unary_predless_predSO : forall (P : predicate)
                                        (x : FOvariable),
  is_unary_predless (predSO P x) = false.
Proof.
  intros. reflexivity.
Qed.

Lemma is_unary_predless_conjSO_l: forall (alpha1 alpha2 : SecOrder),
  is_unary_predless (conjSO alpha1 alpha2) = true ->
    is_unary_predless alpha1 = true.
Proof.
  intros alpha1 alpha2.
  simpl.
  case (is_unary_predless alpha1);
    case (is_unary_predless alpha2);
      intros H; try reflexivity; try discriminate.
Qed.

Lemma is_unary_predless_conjSO_r: forall (alpha1 alpha2 : SecOrder),
  is_unary_predless (conjSO alpha1 alpha2) = true ->
    is_unary_predless alpha2 = true.
Proof.
  intros alpha1 alpha2.
  simpl.
  case (is_unary_predless alpha1);
    case (is_unary_predless alpha2);
      intros H; try reflexivity; try discriminate.
Qed.

Lemma un_predless_preds_in2 : forall alpha : SecOrder,
  length (preds_in alpha) = 0 <-> is_unary_predless alpha = true.
Proof.
  intros.
  induction alpha;
    try destruct p; try destruct f;
    try destruct f0;
    simpl;
    try (split; intros; discriminate);
    try (split; intros; reflexivity);
    try assumption;
    try (rewrite List.app_length;
    case_eq (is_unary_predless alpha1); intros H1;
      [apply IHalpha1 in H1; rewrite H1;
      simpl; assumption |
      case_eq (length (preds_in alpha1));
        [intros H;  apply IHalpha1 in H;
        rewrite H in *; discriminate |
        intros n H; simpl;
        split; intros; discriminate]]).
Qed.

Lemma un_predless_preds_in : forall (cond : SecOrder),
  is_unary_predless cond = true ->
    (preds_in cond = nil).
Proof.
  intros cond Hun.
  induction cond;
    try (destruct p; destruct f; simpl in *; discriminate);
    try (destruct f; destruct f0; simpl; reflexivity);
    try (destruct f; simpl in *; apply IHcond; assumption);
    try (simpl in *; apply IHcond; assumption);
    try (pose proof (is_unary_predless_conjSO_l _ _ Hun) as Hun1;
         pose proof (is_unary_predless_conjSO_r _ _ Hun) as Hun2);
    try (pose proof (is_unary_predless_disjSO_l _ _ Hun) as Hun1;
         pose proof (is_unary_predless_disjSO_r _ _ Hun) as Hun2);
    try (pose proof (is_unary_predless_implSO_l _ _ Hun) as Hun1;
         pose proof (is_unary_predless_implSO_r _ _ Hun) as Hun2);
    try (simpl in *; rewrite IHcond1; try rewrite IHcond2; try reflexivity;
        assumption);
    destruct p; simpl in *; discriminate.
Qed.

Lemma un_predless_preds_in_f : forall (alpha : SecOrder),
  is_unary_predless alpha = false -> ~ (length (preds_in alpha) = 0).
Proof.
  intros alpha H.
  unfold not; intros H2.
  induction alpha;
    try destruct p; try destruct f; try destruct f0; try destruct Q;
    simpl in *; try  discriminate;
    try (apply IHalpha; assumption);

    try (rewrite List.app_length in H2; destruct (beq_nat_0 _ _ H2);
    case_eq (is_unary_predless alpha1); intros Hun; rewrite Hun in *;
      [apply IHalpha2 | apply IHalpha1]; assumption).
Qed.

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

Lemma SOQFree_allFO : forall (alpha : SecOrder) (x : FOvariable),
  SOQFree (allFO x alpha) = true -> (SOQFree alpha = true).
Proof.
  intros alpha x H. assumption.
Qed.

Lemma SOQFree_allFO2 : forall (alpha : SecOrder) (x : FOvariable),
  (SOQFree alpha = true) -> SOQFree (allFO x alpha) = true.
Proof.
  intros alpha x H.
  simpl.
  destruct x as [xn].
  assumption.
Qed.

Lemma SOQFree_exFO : forall (alpha : SecOrder) (x : FOvariable),
  SOQFree (exFO x alpha) = true -> (SOQFree alpha = true).
Proof.
  intros alpha x H.
  simpl in H.
  destruct x as [xn].
  case_eq (SOQFree alpha); intros H2; rewrite H2 in *;
    [reflexivity | discriminate].
Qed.
(*
Lemma SOQFree_negSO : forall (alpha : SecOrder),
  SOQFree (negSO alpha) = true -> (SOQFree alpha = true).
Proof.
  intros alpha H.
  simpl in H.
  case_eq (SOQFree alpha); intros H2; rewrite H2 in *;
    [reflexivity | discriminate].
Qed.
*)
Lemma SOQFree_conjSO_l : forall (alpha1 alpha2 : SecOrder),
  SOQFree (conjSO alpha1 alpha2) = true -> (SOQFree alpha1 = true).
Proof.
  intros alpha1 alpha2 H.
  simpl in H.
  case_eq (SOQFree alpha1); intros H2; rewrite H2 in *;
    [reflexivity | discriminate].
Qed.

Lemma SOQFree_conjSO_r : forall (alpha1 alpha2 : SecOrder),
  SOQFree (conjSO alpha1 alpha2) = true -> (SOQFree alpha2 = true).
Proof.
  intros alpha1 alpha2 H.
  simpl in H.
  case_eq (SOQFree alpha1); intros H2; rewrite H2 in *;
    [case_eq (SOQFree alpha2); intros H3;
      [reflexivity | rewrite H3 in *];
      discriminate | discriminate].
Qed.

Lemma SOQFree_disjSO_l : forall (alpha1 alpha2 : SecOrder),
  SOQFree (disjSO alpha1 alpha2) = true -> (SOQFree alpha1 = true).
Proof.
  intros alpha1 alpha2 H.
  simpl in H.
  case_eq (SOQFree alpha1); intros H2; rewrite H2 in *;
    [reflexivity | discriminate].
Qed.

Lemma SOQFree_disjSO_r : forall (alpha1 alpha2 : SecOrder),
  SOQFree (disjSO alpha1 alpha2) = true -> (SOQFree alpha2 = true).
Proof.
  intros alpha1 alpha2 H.
  simpl in H.
  case_eq (SOQFree alpha1); intros H2; rewrite H2 in *;
    [case_eq (SOQFree alpha2); intros H3;
      [reflexivity | rewrite H3 in *];
      discriminate | discriminate].
Qed.

Lemma SOQFree_implSO_l : forall (alpha1 alpha2 : SecOrder),
  SOQFree (implSO alpha1 alpha2) = true -> (SOQFree alpha1 = true).
Proof.
  intros alpha1 alpha2 H.
  simpl in H.
  case_eq (SOQFree alpha1); intros H2; rewrite H2 in *;
    [reflexivity | discriminate].
Qed.

Lemma SOQFree_implSO_r : forall (alpha1 alpha2 : SecOrder),
  SOQFree (implSO alpha1 alpha2) = true -> (SOQFree alpha2 = true).
Proof.
  intros alpha1 alpha2 H.
  simpl in H.
  case_eq (SOQFree alpha1); intros H2; rewrite H2 in *;
    [case_eq (SOQFree alpha2); intros H3;
      [reflexivity | rewrite H3 in *];
      discriminate | discriminate].
Qed.

Lemma SOQFree_ST : forall (phi : Modal) (x : FOvariable),
  SOQFree (ST phi x) = true.
Proof.
  induction phi; intros x; simpl in *;
    try (destruct p; destruct x; reflexivity) ;
    try apply IHphi;
    try (rewrite IHphi1; rewrite IHphi2; reflexivity);
    try (destruct x; apply IHphi).
Qed.

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

Lemma un_predless_SOQFree : forall alpha,
  is_unary_predless alpha = true ->
  SOQFree alpha = true.
Proof.
  intros alpha Hun.
  induction alpha;
    try destruct p; try destruct f;
    try destruct f0;
    try reflexivity;
    try (simpl in *;
    apply IHalpha;
    assumption);
    try (simpl in *;
    case_eq (is_unary_predless alpha1); intros Hun1;
      rewrite Hun1 in *; try discriminate;
      rewrite IHalpha1;
        [apply IHalpha2;
        assumption |
        reflexivity]);
     simpl in *; discriminate.
Qed.

Lemma P_occ_in_alpha_un_predless : forall beta P,
  is_unary_predless beta = true ->
  P_occurs_in_alpha beta P = false.
Proof.
  intros beta P Hun.
  induction beta;
    try destruct p; try destruct f; destruct P; try destruct f0;
    try (simpl in *; discriminate);
    try (unfold P_occurs_in_alpha; reflexivity);
    try (    apply P_occurs_in_alpha_conjSO_f;
    pose proof (is_unary_predless_conjSO_l _ _ Hun) as H1;
    pose proof (is_unary_predless_conjSO_r _ _ Hun) as H2;
    apply conj; [apply IHbeta1 | apply IHbeta2];
    assumption).

    rewrite <- P_occurs_in_alpha_allFO.
    apply IHbeta.
    simpl in Hun.
    assumption.

    rewrite <- P_occurs_in_alpha_exFO.
    apply IHbeta.
    simpl in Hun.
    assumption.

    rewrite <- P_occurs_in_alpha_negSO.
    apply IHbeta.
    simpl in Hun.
    assumption.
Qed.


Require Import VST.msl.Extensionality.

Class NatDed (A: Type) := mkNatDed {
  andp: A -> A -> A;
  orp: A -> A -> A;
  exp: forall {T:Type}, (T -> A) -> A;
  allp: forall {T:Type}, (T -> A) -> A;
  imp: A -> A -> A;
  prop: Prop -> A;
  derives: A -> A -> Prop;
  pred_ext: forall P Q, derives P Q -> derives Q P -> P=Q;
  derives_refl: forall P, derives P P;
  derives_trans: forall P Q R, derives P Q -> derives Q R -> derives P R;
  TT := prop True;
  FF := prop False;
  andp_right:  forall X P Q:A, derives X P -> derives X Q -> derives X (andp P Q);
  andp_left1:  forall P Q R:A, derives P R -> derives (andp P Q) R;
  andp_left2:  forall P Q R:A, derives Q R -> derives (andp P Q) R;
  orp_left: forall P Q R, derives P R -> derives Q R -> derives (orp P Q) R;
  orp_right1: forall P Q R, derives P Q -> derives P (orp Q R);
  orp_right2: forall P Q R, derives P R -> derives P (orp Q R);
  exp_right: forall {B: Type} (x:B) (P: A) (Q: B -> A),
                        derives P (Q x) -> derives P (exp Q);
  exp_left: forall {B: Type} (P: B -> A) (Q: A),
                      (forall x, derives (P x) Q) -> derives (exp P) Q;
  allp_left: forall {B}(P: B -> A) x Q, derives (P x) Q -> derives (allp P) Q;
  allp_right: forall {B}(P: A) (Q: B -> A),  (forall v, derives P (Q v)) -> derives P (allp Q);
  imp_andp_adjoint: forall P Q R, derives (andp P Q) R <-> derives P (imp Q R);
  prop_left: forall (P: Prop) Q, (P -> derives TT Q) -> derives (prop P) Q;
  prop_right: forall (P: Prop) Q, P -> derives Q (prop P);
  prop_imp_prop_left: forall (P Q: Prop), derives (imp (prop P) (prop Q)) (prop (P -> Q));
  allp_prop_left: forall {B: Type} (P: B -> Prop), derives (allp (fun b => prop (P b))) (prop (forall b, P b))
(* not_prop_right: forall (P: A) (Q: Prop), (Q -> derives P FF) -> derives P (prop (not Q)) *)
}.

Program Instance LiftNatDed (A B: Type) {ND: NatDed B} : NatDed (A -> B) :=
 mkNatDed (A -> B)
    (*andp*) (fun P Q x => andp (P x) (Q x))
    (*orp*) (fun P Q x => orp (P x) (Q x))
    (*exp*) (fun T (F: T -> A -> B) (a: A) => exp (fun x => F x a))
    (*allp*) (fun T (F: T -> A -> B) (a: A) => allp (fun x => F x a))
    (*imp*) (fun P Q x => imp (P x) (Q x))
    (*prop*) (fun P x => prop P)
    (*derives*) (fun P Q => forall x, derives (P x) (Q x))
     _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _.
Next Obligation.
 intros; extensionality x; apply pred_ext; auto.
Defined.
Next Obligation.
 intros; apply derives_refl.
Defined.
Next Obligation.
 intros; eapply derives_trans; eauto.
Defined.
Next Obligation.
 intros; eapply andp_right; eauto.
Defined.
Next Obligation.
 intros; eapply andp_left1; eauto.
Defined.
Next Obligation.
 intros; eapply andp_left2; eauto.
Defined.
Next Obligation.
 intros; eapply orp_left; eauto.
Defined.
Next Obligation.
 intros; eapply orp_right1; eauto.
Defined.
Next Obligation.
 intros; eapply orp_right2; eauto.
Defined.
Next Obligation.
 intros; eapply exp_right; eauto.
Defined.
Next Obligation.
 intros; eapply exp_left; eauto.
Defined.
Next Obligation.
 intros; eapply allp_left; eauto.
Defined.
Next Obligation.
 intros; eapply allp_right; eauto.
Defined.
Next Obligation.
 intros; split; intros;  eapply imp_andp_adjoint; eauto.
Defined.
Next Obligation.
 intros; eapply prop_left; eauto.
Defined.
Next Obligation.
 intros; eapply prop_right; eauto.
Defined.
Next Obligation.
 intros; eapply prop_imp_prop_left; eauto.
Defined.
Next Obligation.
 intros; eapply allp_prop_left; eauto.
Defined.

Declare Scope logic.
Delimit Scope logic with logic.
Local Open Scope logic.
Declare Scope logic_derives.
Notation "P '|--' Q" := (derives P%logic Q%logic) (at level 80, no associativity) : logic_derives.
Open Scope logic_derives.
Notation "'EX' x .. y , P " :=
  (exp (fun x => .. (exp (fun y => P%logic)) ..)) (at level 65, x binder, y binder, right associativity) : logic.
Notation "'ALL' x .. y , P " :=
  (allp (fun x => .. (allp (fun y => P%logic)) ..)) (at level 65, x binder, y binder, right associativity) : logic.
Infix "||" := orp (at level 50, left associativity) : logic.
Infix "&&" := andp (at level 40, left associativity) : logic.
Notation "P '-->' Q" := (imp P Q) (at level 55, right associativity) : logic.
Notation "P '<-->' Q" := (andp (imp P Q) (imp Q P)) (at level 57, no associativity) : logic.
Notation "'!!' e" := (prop e) (at level 25) : logic.

Class SepLog (A: Type) {ND: NatDed A} := mkSepLog {
  emp: A;
  sepcon: A -> A -> A;
  wand: A -> A -> A;
  ewand: A -> A -> A;
  sepcon_assoc: forall P Q R, sepcon (sepcon P Q) R = sepcon P (sepcon Q R);
  sepcon_comm:  forall P Q, sepcon P Q = sepcon Q P;
  wand_sepcon_adjoint: forall (P Q R: A),  (sepcon P Q |-- R) <-> (P |-- wand Q R);
  sepcon_andp_prop: forall P Q R, sepcon P (!!Q && R) = !!Q && (sepcon P R);
  sepcon_derives: forall P P' Q Q' : A, P |-- P' -> Q |-- Q' -> sepcon P Q |-- sepcon P' Q';
  ewand_sepcon: forall (P Q R : A),  ewand (sepcon P Q) R = ewand P (ewand Q R);
  ewand_TT_sepcon: forall (P Q R: A),
                         andp (sepcon P Q) (ewand R TT) |--
                               sepcon (andp P (ewand R TT)) (andp Q (ewand R TT));
  exclude_elsewhere: forall P Q: A, sepcon P Q |-- sepcon (andp P (ewand Q TT)) Q;
  ewand_conflict: forall P Q R, sepcon P Q |-- FF -> andp P (ewand Q R) |-- FF
}.

Notation "P '*' Q" := (sepcon P Q) : logic.
Notation "P '-*' Q" := (wand P Q) (at level 60, right associativity) : logic.

Instance LiftSepLog (A B: Type) {NB: NatDed B}{SB: SepLog B} : SepLog (A -> B).
 apply (mkSepLog (A -> B) _ (fun rho => emp)
            (fun P Q rho => P rho * Q rho) (fun P Q rho => P rho -* Q rho)
            (fun P Q rho => ewand (P rho) (Q rho))).
 (* sepcon_assoc *) intros; extensionality rho; apply sepcon_assoc.
 (* sepcon_comm *) intros; extensionality rho; apply sepcon_comm.
 intros.  split. simpl. intuition.
    apply wand_sepcon_adjoint. auto.
    intro. intro rho.     apply <- wand_sepcon_adjoint; auto.
 simpl; intros. extensionality x. apply sepcon_andp_prop.
 simpl; intros; apply sepcon_derives; auto.
 simpl; intros; extensionality x; apply ewand_sepcon.
 simpl; intros; eapply ewand_TT_sepcon.
 simpl; intros; eapply exclude_elsewhere.
 simpl; intros; eapply ewand_conflict; eauto.
Defined.

Class ClassicalSep  (A: Type) {ND: NatDed A}{SL: SepLog A} := mkCS {
   sepcon_emp: forall P, P * emp = P
}.

Instance LiftClassicalSep (A B: Type)  {NB: NatDed B}{SB: SepLog B}{CB: ClassicalSep B} :
        ClassicalSep (A -> B).
 apply mkCS.
 intros. extensionality x. simpl. apply sepcon_emp.
Qed.

Definition  extensible {A}{ND: NatDed A}{SL: SepLog A}(P:A) := sepcon P TT |-- P.

Class IntuitionisticSep (A: Type) {ND: NatDed A}{SL: SepLog A} := mkIS {
   all_extensible: forall P, extensible P
}.

Instance LiftIntuitionisticSep (A B: Type)  {NB: NatDed B}{SB: SepLog B}{IB: IntuitionisticSep B} :
        IntuitionisticSep (A -> B).
 apply mkIS.
 intros. intro. simpl. apply all_extensible.
Qed.

Class Indir (A: Type) {ND: NatDed A} := mkIndir {
  later: A -> A;
  now_later: forall P: A, P |-- later P;
  later_K: forall P Q, later (P --> Q) |-- later P --> later Q;
  later_allp: forall T (F: T -> A),  later (allp F) = ALL x:T, later (F x);
  later_exp: forall T (F: T-> A), EX x:T, later (F x) |-- later (exp F);
  later_exp': forall T (any:T) F, later (exp F) = EX x:T, later (F x);
  later_exp'': forall T F, later (exp F) |-- (EX x:T, later (F x)) || later FF;
  later_imp: forall P Q,  later(P --> Q) = later P --> later Q;
  later_prop: forall PP: Prop, later (!! PP) |-- !! PP || later FF;
  loeb: forall P,   later P |-- P ->  TT |-- P
}.

Notation "'|>' e" := (later e) (at level 30, right associativity): logic.

Instance LiftIndir (A: Type) (B: Type)  {NB: NatDed B}{IXB: Indir B} :
         @Indir (A -> B) (LiftNatDed A B).
 apply (mkIndir _ _ (fun P rho => later (P rho))); intros; simpl in *; intros.
 apply now_later.
 apply later_K.
 simpl; intros. extensionality rho. apply later_allp.
 simpl; intros. apply later_exp.
 simpl; intros. extensionality rho. apply later_exp'; auto.
 simpl; intros. apply later_exp''.
 simpl; intros. extensionality rho. apply later_imp.
 simpl; intros. apply later_prop.
 simpl; intros. apply loeb; auto.
Defined.

Class SepIndir (A: Type) {NA: NatDed A}{SA: SepLog A}{IA: Indir A} := mkSepIndir {
  later_sepcon: forall P Q, |> (P * Q) = |>P * |>Q;
  later_wand: forall P Q, |> (P -* Q) = |>P -* |>Q;
  later_ewand: forall P Q, |> (ewand P Q) = ewand (|>P) (|>Q)
}.

Instance LiftSepIndir  (A: Type) (B: Type)  {NB: NatDed B} {SB: SepLog B}{IB: Indir B}{SIB: SepIndir B} :
     @SepIndir (A -> B) (LiftNatDed A B) (LiftSepLog A B) (LiftIndir A B).
 constructor.
 intros; simpl. extensionality rho.  apply later_sepcon.
 intros; simpl. extensionality rho.  apply later_wand.
 intros; simpl. extensionality rho.  apply later_ewand.
Defined.

Class CorableSepLog (A: Type) {ND: NatDed A}{SL: SepLog A}:= mkCorableSepLog {
  corable: A -> Prop;
  corable_prop: forall P, corable (!! P);
  corable_andp: forall P Q, corable P -> corable Q -> corable (P && Q);
  corable_orp: forall P Q, corable P -> corable Q -> corable (P || Q);
  corable_imp: forall P Q, corable P -> corable Q -> corable (P --> Q);
  corable_allp: forall {B: Type} (P:  B -> A), (forall b, corable (P b)) -> corable (allp P);
  corable_exp: forall {B: Type} (P:  B -> A), (forall b, corable (P b)) -> corable (exp P);
  corable_sepcon: forall P Q, corable P -> corable Q -> corable (P * Q);
  corable_wand: forall P Q, corable P -> corable Q -> corable (P -* Q);
  corable_andp_sepcon1: forall P Q R, corable P ->  (P && Q) * R = P && (Q * R)
}.

Instance LiftCorableSepLog (A: Type) (B: Type) {NB: NatDed B} {SB: SepLog B} {CSL: CorableSepLog B} : @CorableSepLog (A -> B) (LiftNatDed A B) (LiftSepLog A B).
  apply (@mkCorableSepLog _ _ _ (fun P => forall b, corable (P b))); intros; simpl in *; intros.
  + apply corable_prop.
  + apply corable_andp; auto.
  + apply corable_orp; auto.
  + apply corable_imp; auto.
  + apply corable_allp; auto.
  + apply corable_exp; auto.
  + apply corable_sepcon; auto.
  + apply corable_wand; auto.
  + extensionality b.
    apply corable_andp_sepcon1; auto.
Defined.

Class CorableIndir (A: Type) {ND: NatDed A}{SL: SepLog A}{CSL: CorableSepLog A}{ID: Indir A} :=
  corable_later: forall P, corable P -> corable (|> P).

Instance LiftCorableIndir (A: Type) (B: Type) {NB: NatDed B} {SB: SepLog B} {CSL: CorableSepLog B} {ID: Indir B} {CI: CorableIndir B}: @CorableIndir (A -> B) (LiftNatDed A B) (LiftSepLog A B) (LiftCorableSepLog A B) (LiftIndir A B).
  unfold CorableIndir; simpl; intros.
  apply corable_later; auto.
Defined.

Lemma orp_comm: forall {A: Type} `{NatDed A} (P Q: A), P || Q = Q || P.
Proof.
  intros.
  apply pred_ext.
  + apply orp_left; [apply orp_right2 | apply orp_right1]; apply derives_refl.
  + apply orp_left; [apply orp_right2 | apply orp_right1]; apply derives_refl.
Qed.