Require Import Cases.
Require Import List.
Require Import Coq.Sets.Constructive_sets.
Require Import Coq.Arith.EqNat.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Program.Tactics.
Require Import Definitions.
Require Import Operational_Semantics.
Require Import Axioms.
Require Import Lemma5_Lemmas.
Require Import Contracts_Definition.
Require Import Contracts_Subst.
Require Import Contracts_Evaluation.
Require Import Lemma5.
Require Import Theorem7_Lemmas.
Require Import Coq.Arith.Minus.
Require Import Coq.Arith.Lt.

Definition Models (Ex:Exec)(cont:contract_Contract)(eff:Effect) : Prop :=
  contract_Eval cont Ex eff (contract_free_number cont).

Notation " A '|=' B " := (Models A B) (at level 30).

(**************************************************************************************************)
(*************************************** Theorem 7 of the Paper ***********************************)

Theorem theorem7 : forall  (Ex Ex':Exec)(Θ Θ':Store)(Σ: SessSoup)(τ: ConsCls)(ss:SessID)
                      (ii:SeqNo)(σσ:session)(η:Effect) (op: OperName)(Ing1 Ing2: Soup_Ing),
                     (WF Ex) -> (CausCons Θ Ex) ->
                     (Ing1 = (mkSoup_Ing ss ii ((mkop_cls op τ)::σσ))) ->
                     (Ing2 = (mkSoup_Ing ss (ii+1) σσ)) ->
                     (WF_union Σ Ing1) -> (WF_union Σ Ing2) ->
                     [[Ex,Θ,(Σ||| Ing1) --τ,η-->  Ex' ,Θ' , (Σ|||Ing2)]]
                     -> WF Ex'/\ (Ex'|=Store_Contr τ) η.

Proof. intros Ex Ex' θ θ' Σ τ s i σ η op. intros Ing1 Ing2.
       intros HWF HCausCons. intros HIng1 HIng2. intros WFl WFr. intro H.
       split.
       -Case"Proof of Well-Formedness of Ex'".
        destruct H.
                +exact HWF.
                +apply Lemma5 in H0. exact H0. exact HWF.
                +apply Lemma5 in H1. exact H1. exact HWF.
                +apply Lemma5 in H0. exact H0. exact HWF.

       -Case"Proof of E'|=Ψτ".
        inversion H.

        +SCase"EFFVIS".
         clear H2; clear H3. rename H4 into H2;  rename H5 into H3;
         rename H6 into H4; rename H7 into H5; rename H8 into H6; rename H9 into H7;
         rename H10 into H8; rename H11 into H9.
         subst. rename Ex' into Ex. inversion H0.
         remember (<< s, i, (op) __ (τ) :: σ >>) as Ing1.
         remember ( << s, i + 1, σ >>) as Ing2.
         assert ( forall (S S':SessSoup), S=S' -> forall (I:Soup_Ing), (In Soup_Ing S I -> In Soup_Ing S' I)) as Heq.
         apply Sess_Equal. specialize (Heq (Σ |||Ing1)  (Σ ||| Ing2 )).
         intuition. unfold In in H4.
         assert ((Σ ||| Ing1) Ing1). apply Union_intror. compute. intuition.
         specialize (H4 Ing1). apply H4 in H6.
         inversion H6. unfold WF_union in WFl. contradiction.
         inversion H7.
         subst.
         apply Seq_Uniq in H10. omega.
         (*---*)
        +SCase"[EC]". subst.
         intuition; subst; clear H H1; rename θ' into θ;rename H7 into H1.
         inversion H1; subst. compute.
          intros a Ha; intros b Hb. intros; intuition.
          (**)
          assert ((E A' vis' so' sameobj')-hbo a b) as HBO'; intuition.
          remember (E A vis so sameobj) as Ex.
          assert ((θ r) b). {
          specialize (H9 b η). rewrite H9 in H6. inversion H6. apply H10.
          destruct H10 as [Htemp Hvisbη]; clear Htemp. apply WF_Relation with (r:=vis)(a:=b)(b:=η) in Hvisbη.
          destruct Hvisbη as [Htemp Hdomη]; clear Htemp.
          replace vis with Ex-vis in Hdomη.
          apply Vis_Domain in Hdomη. apply CorrectFreshness in H1. contradiction. rewrite HeqEx. auto. }

          assert ( ~ ( b = η))as Hneqbη. { intro. apply Freshness with (r0:=r) in H1;auto. rewrite <- H13 in H1. contradiction. }
          assert (Ex-hbo a b) as HBOab.  { apply HBO'_HBO with (a:=a)(b:=b) in H1.  apply H1. apply HWF. apply Hneqbη. apply HBO'. }
          assert ((θ r) a)    as Hainθ.  { unfold CausCons in HCausCons. specialize (HCausCons r a b).
                                          apply HCausCons. intuition.
                                          assert (Ex-A a \/ ~Ex-A a) as Hcomp. apply Soup_comp.
                                          destruct Hcomp; auto.
                                          apply WF_Relation with (a:=a)(b:=b)(r:=Ex-hbo) in HBOab.
                                          destruct HBOab. apply Hbo_Domain in H16. apply H16. intuition.
                                          apply H10. apply HBOab.  }

          specialize (H9 a η). rewrite H9. left. split. apply Hainθ. reflexivity.

         (*---*)
        +SCase"[CC]". subst.
         clear H H1.
         rename θ' into θ. simpl in H5.
         unfold Models. inversion H8. subst. rename H10 into HVis'.
         simpl. intros ef HA' HBO'. rename ef into a.
         assert ((E A' vis' so' sameobj')-hbo a η). intuition.
         apply Inversion_HBO_Help with (vis:=vis')(so:=so')(sameobj:=sameobj')(A:=A') in H.
         Focus 2. reflexivity.

         destruct H.
         *SSCase"exists c s.t. hbo a c and so\/vis c η".
          destruct H as [c G]. unfold Rel_Union in G. inversion G.
          clear G; rename H into HBO'ac;rename H1 into Hstepcη.
          inversion Hstepcη; clear Hstepcη.
          (*1*)assert ((θ r) c).  specialize (HVis' c η). rewrite HVis' in H.
          inversion H. apply H1.
          apply CorrectFreshness in H8. simpl in H8. inversion H1.
          inversion H2. contradiction.

          (*2*)assert ((E A vis so sameobj)-hbo a c).
          apply HBO'_HBO with (a:=a)(b:=c) in H8.  apply H8.
          apply HWF. intro. apply Freshness with (r0:=r) in H8;auto. rewrite H2 in H1. contradiction.
          apply HBO'ac.
          unfold CausCons in HCausCons. specialize (HCausCons r a c).
          assert ((θ r) a).
          apply HCausCons; auto.
          apply WF_Relation with (a:=a)(b:=c)(r:= (E A vis so sameobj) -hbo) in H2.
          destruct H2. apply Hbo_Domain in H2. apply H2.
          specialize (HVis' a η). rewrite HVis'. auto.

          inversion H; clear H. rename H1 into H; clear H2.
          (*1*)assert ((θ r) c) as Hc.
          apply H5. compute. apply first. apply H.

          (*2*)assert ((E A vis so sameobj)-hbo a c) as Hbo.
          apply HBO'_HBO with (a:=a)(b:=c) in H8.  apply H8.
          apply HWF. intro. apply Freshness with (r0:=r) in H8;auto. rewrite H1 in Hc. contradiction.
          apply HBO'ac.

          specialize (HVis' a η). rewrite HVis'. left. split. Focus 2. reflexivity.
          unfold CausCons in HCausCons. specialize (HCausCons r a c). apply HCausCons; auto.
          apply WF_Relation with (a:=a)(b:=c)(r:= (E A vis so sameobj) -hbo) in Hbo.
          destruct Hbo. apply Hbo_Domain in H1. apply H1.

         *SSCase"One step hbo".
          inversion H; clear H; rename H1 into H.
          inversion H; clear H; clear H2; rename H1 into H.
          specialize (HVis' a η). rewrite HVis'. left. split. Focus 2. reflexivity.
          compute in H5. specialize (H5 a). apply H5. apply first. apply H.
          apply H.

         (*---*)
        +SCase "[SC]".
         subst.
         intuition; subst; clear H0 H1. rename H3 into Hreduct.
         inversion Hreduct; subst.
         unfold Models; compute. intros a HA' HSame' .
         specialize (H12 a). apply H12 in HA'.
         destruct HA'.
         *SSCase"a∈A".
          remember (E A' vis' so' sameobj')-hbo as hbo'.
          unfold Included in  H4. specialize (H4 a).
          simpl in H4. unfold In in H4. apply H4 in H0.
          assert (vis' a η). rewrite H13. left. auto.
          left. left. apply H1.

         *SSCase"a=η".
          rewrite H0. right. apply  Eff_Equi_refl.
Qed.


(******************************************************************************
Rainbow, a termination proof certification tool
See the COPYRIGHTS and LICENSE files.

- Kim Quyen LY, 2010-12-21

Define CPF type in Coq
******************************************************************************)

Set Implicit Arguments.

Require Import ZArith String.

Section definition.

(***********************************************************************)
(** string *)

Definition integer : Type := Z.
Definition nonNegativeInteger : Type := integer.
Definition positiveInteger : Type := integer.
Definition boolean : Type := bool.

(*Definition string := list Sig.*)

Inductive name := string

with label :=
  | Lab_numberLabel : list nonNegativeInteger -> label
  | Lab_symbolLabel : list symbol -> label

with symbol :=
  | Symbol_name : name -> symbol
  | Symbol_sharp : symbol -> symbol
  | Symbol_labeledSymbol : symbol -> label -> symbol
(*  | arity : symbol -> nat -> symbol*)

with var := T1 : string -> var (**)

with term :=
  | Term_var : var -> term
  | Term_funapp : symbol -> list term -> term

with cpf_rule := T2 : term -> term -> cpf_rule (**)

with rules := T3 : list cpf_rule -> rules (**)

with dps := T4 : rules -> dps (**)

with trs := T5 : rules -> trs (**)

with usableRules := T6 : rules -> usableRules (**)

with number :=
  | Number_integer : integer -> number
  | Number_rational : integer -> positiveInteger -> number

with coefficient :=
  | Coefficient_number : number -> coefficient
  | Coefficient_minusInfinity
  | Coefficient_plusInfinity
  | Coefficient_vector : vector -> coefficient
  | Coefficient_matrix : matrix -> coefficient

with vector := T7 : list coefficient -> vector (**)

with matrix := T8 : list vector -> matrix (**)

with polynomial :=
  | Polynomial_coefficient : coefficient -> polynomial
  | Polynomial_variable : positiveInteger -> polynomial
  | Polynomial_sum : list polynomial -> polynomial
  | Polynomial_product : list polynomial -> polynomial
  | Polynomial_max : list polynomial -> polynomial
  | Polynomial_min : list polynomial -> polynomial

with cpf_function :=
  | Function_polynomial : polynomial -> cpf_function

with arity := T9 : nonNegativeInteger -> arity (**)

with dimension := T10 : positiveInteger -> dimension (**)

with strictDimension := T11 : positiveInteger -> strictDimension (**)

with degree := T12 : nonNegativeInteger -> degree (**)

with position := T13 : positiveInteger -> position (**)

with argumentFilter := T14 : list symbol -> list arity -> list t3 -> argumentFilter (**)

with t3 :=
  | T3_collapsing : positiveInteger -> t3
  | T3_nonCollapsing : list position -> t3

with domain :=
  | Domain_naturals
  | Domain_integers
  | Domain_rationals : number -> domain
  | Domain_arctic : domain -> domain
  | Domain_tropical : domain -> domain
  | Domain_matrices : dimension -> strictDimension -> domain -> domain

with redPair :=
  | redpair_interpretation : cpf_type -> list symbol -> list arity -> list cpf_function -> redPair
  | redpair_pathOrder : list symbol -> list arity -> list nonNegativeInteger -> list t2 -> option argumentFilter -> redPair

with cpf_type :=
  | Cpf_type_polynomial : domain -> degree -> cpf_type
  | Cpf_type_matrixInterpretation : domain -> dimension -> strictDimension -> cpf_type

with t2 :=
  | T2_lex
  | T2_mul

with arithFunction :=
  | Arithfunction_natural : nonNegativeInteger -> arithFunction
  | Arithfunction_variable : positiveInteger -> arithFunction
  | Arithfunction_sum : list arithFunction -> arithFunction
  | Arithfunction_product : list arithFunction -> arithFunction
  | Arithfunction_min : list arithFunction -> arithFunction
  | Arithfunction_max : list arithFunction -> arithFunction

with model :=
  | Model_finiteModel : positiveInteger -> option tupleOrder -> list symbol -> list arity -> list arithFunction -> model
  | Model_rootLabeling

with tupleOrder :=
  | TupleOrder_pointWise

with dpProof :=
  | DpProof_pIsEmpty
  | DpProof_depGraphProc : list dps -> list boolean -> option (list positiveInteger) -> option (list dpProof) -> dpProof
  | DpProof_redPairProc : option orderingConstraints -> orderingConstraintProof -> dps -> dpProof -> dpProof
  | DpProof_redPairUrProc : option orderingConstraints -> orderingConstraintProof -> dps -> usableRules -> dpProof -> dpProof
  | DpProof_monoRedPairProc : option orderingConstraints -> orderingConstraintProof -> dps -> trs -> dpProof
  | DpProof_monoRedPairUrProc : option orderingConstraints -> orderingConstraintProof -> dps -> trs -> usableRules -> dpProof -> dpProof
  | DpProof_subtermProc : argumentFilter -> list cpf_rule -> list rewriteSequence -> dps -> dpProof -> dpProof
  | DpProof_semlabProc : model -> dps -> trs -> dpProof -> dpProof
  | DpProof_unlabProc : dps -> trs -> dpProof -> dpProof
  | DpProof_sizeChangeProc : t1 -> list cpf_rule -> list (list nonNegativeInteger -> list boolean -> list nonNegativeInteger) -> dpProof
  | DpProof_flatContextClosureProc : option symbol -> list context -> dps -> trs -> dpProof -> dpProof
  | DpProof_argumentFilterProc : argumentFilter -> dps -> trs -> dpProof -> dpProof
  | DpProof_finitenessAssumption : dpInput -> dpProof

with t1 :=
  | T1_subtermCriterion
  | T1_reductionPair : option orderingConstraints -> orderingConstraintProof -> option usableRules -> t1

with substitution := T15 : list var -> list term -> substitution (**)

with context :=
  | Context_box
  | Context_funContext : symbol -> list term -> context -> (list term) -> context

with rewriteSequence := T16 : (term) -> list (list position) -> list (list cpf_rule) -> list (list term) -> rewriteSequence (**)

with trsTerminationProof :=
  | TrsTerminationProof_rIsEmpty
  | TrsTerminationProof_ruleRemoval : option orderingConstraints -> orderingConstraintProof -> trs -> trsTerminationProof -> trsTerminationProof
  | TrsTerminationProof_dpTrans : dps -> boolean -> dpProof -> trsTerminationProof
  | TrsTerminationProof_semlab : model -> trs -> trsTerminationProof -> trsTerminationProof
  | TrsTerminationProof_unlab : trs -> trsTerminationProof -> trsTerminationProof
  | TrsTerminationProof_stringReversal : trs -> trsTerminationProof -> trsTerminationProof
  | TrsTerminationProof_flatContextClosure : (list context) -> trs -> trsTerminationProof -> trsTerminationProof
  | TrsTerminationProof_terminationAssumption : trsInput -> trsTerminationProof

with loop := T17: rewriteSequence -> substitution -> context -> loop  (**)

with trsNonterminationProof :=
  | TrsNonterminationProof_variableConditionViolated
  | TrsNonterminationProof_ruleRemoval : trs -> trsNonterminationProof -> trsNonterminationProof
  | TrsNonterminationProof_stringReversal : trs -> trsNonterminationProof -> trsNonterminationProof
  | TrsNonterminationProof_loop : loop -> trsNonterminationProof
  | TrsNonterminationProof_dpTrans : dps -> boolean -> dpNonterminationProof -> trsNonterminationProof
  | TrsNonterminationProof_nonterminationAssumption : trsInput -> trsNonterminationProof

with relativeTerminationProof :=
| RelativeTerminationProof_rIsEmpty
| RelativeTerminationProof_sIsEmpty : trsTerminationProof -> relativeTerminationProof
| RelativeTerminationProof_ruleRemoval : option orderingConstraints -> orderingConstraintProof -> trs -> trs -> relativeTerminationProof -> relativeTerminationProof
| RelativeTerminationProof_semlab : model -> trs -> trs -> relativeTerminationProof -> relativeTerminationProof
| RelativeTerminationProof_unlab : trs -> trs -> relativeTerminationProof -> relativeTerminationProof
| RelativeTerminationProof_stringReversal : trs -> trs -> relativeTerminationProof -> relativeTerminationProof
| RelativeTerminationProof_relativeTerminationAssumption : trsInput -> relativeTerminationProof

with dpNonterminationProof :=
| DpNonterminationProof_loop : loop -> dpNonterminationProof
| DpNonterminationProof_dpRuleRemoval : dps -> trs -> dpNonterminationProof -> dpNonterminationProof
| DpNonterminationProof_infinitenessAssumption : dpInput -> dpNonterminationProof

with relativeNonterminationProof :=
| RelativeNonterminationProof_loop : loop -> relativeNonterminationProof
| RelativeNonterminationProof_trsNonterminationProof : trsNonterminationProof -> relativeNonterminationProof
| RelativeNonterminationProof_variableConditionViolated
| RelativeNonterminationProof_ruleRemoval : trs -> trs -> relativeNonterminationProof -> relativeNonterminationProof
| RelativeNonterminationProof_nonterminationAssumption : trsInput -> relativeNonterminationProof

with orderingConstraints := T18 : list boolean -> list boolean -> list (option monotonePositions) -> list (option argumentFilter) -> list cpf_rule -> orderingConstraints (**)

with monotonePositions :=
| MonotonePositions_argumentFilter : argumentFilter -> monotonePositions
| MonotonePositions_everySymbolAndPosition

with orderingConstraintProof :=
| OrderingConstraintProof_redPair : redPair -> orderingConstraintProof
| OrderingConstraintProof_satisfiableAssumption : orderingConstraints -> orderingConstraintProof

with proof :=
| Proof_trsTerminationProof : trsTerminationProof -> proof
| Proof_trsNonterminationProof :  trsNonterminationProof -> proof
| Proof_relativeTerminationProof : relativeTerminationProof -> proof
| Proof_relativeNonterminationProof :  relativeNonterminationProof -> proof
| Proof_dpProof : dpProof -> proof
| Proof_dpNonterminationProof :  dpNonterminationProof -> proof
| Proof_orderingConstraintProof :  orderingConstraintProof -> proof

with url :=  T19 : string -> url (**)

with trsInput := T20 : trs -> option strategy -> option (rules) -> option (rules) -> trsInput (**)

with dpInput := T21 : trs -> dps -> option strategy ->  boolean -> dpInput (**)

with strategy :=
| Strategy_innermost

with certificationProblem := T22 : input -> string -> proof -> option (list string) -> option (list (option string)) -> option (list (option string)) -> option (list (option string)) -> option (list string) -> option (list string) -> option (list (option url)) -> option (option string) -> certificationProblem (**)

with input :=
| Input_trsInput : trsInput -> input
| Input_dpInput :  dpInput -> input
| Input_orderingConstraints : orderingConstraints -> input.

(***********************************************************************)
(** Cpf *)
(*
Inductive Record Cpf : Type := mkCpf {
  check : Cpf -> option bool;
  label : Label;
  symbol : Symbol;
  term : Term;
  rule : Rule;
  rules : list Rule;
  asignature : Cpf -> option Sig;
  aterm: forall f: Sig, Term -> option Sig
}.

(***********************************************************************)
(** list of symbols occurring in a term *)

Fixpoint symbs_list (t: Term) : list Symbol :=
  match t with
    | Var x => nil
    | Fun f l =>
      let fix symb_list_list n (l : list Term) {struct l} : list Symbol :=
        match l with
          | nil => nil
          | t :: lt => symbs_list t ++ symb_list_list n lt
        end
      in (f :: symb_list_list (arity f) l)
  end.

Function symb_list_list (l : list Term) {struct l} : list Symbol :=
  match l with
    | nil => nil
    | t :: lt => symbs_list t ++ symb_list_list lt
  end.
*)
End definition.


Require Import RamifyCoq.lib.Ensembles_ext.
Require Import Coq.Lists.List.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import VST.msl.Coqlib2.
Require Import RamifyCoq.lib.Coqlib.
Require Import RamifyCoq.lib.EquivDec_ext.
Require Import RamifyCoq.lib.relation_list.
Require Import RamifyCoq.msl_ext.log_normalize.
Require Import RamifyCoq.msl_ext.iter_sepcon.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.path_lemmas.
Require Import RamifyCoq.graph.reachable_computable.
Require Import RamifyCoq.graph.reachable_ind.
Require Import RamifyCoq.graph.subgraph2.
Require Import RamifyCoq.graph.graph_gen.
Require Import RamifyCoq.graph.dag.
Require Import RamifyCoq.graph.weak_mark_lemmas.
Require Import RamifyCoq.msl_application.Graph.
Require Import RamifyCoq.msl_application.Graph_Mark.
Require Import RamifyCoq.msl_application.GraphBi.
Require Export RamifyCoq.msl_application.GraphBi_Mark.
Require Import Coq.Logic.Classical.

Open Scope logic.

Section PointwiseGraph_Mark_Bi.

Context {pSGG_Bi: pPointwiseGraph_Graph_Bi}.
Context {sSGG_Bi: sPointwiseGraph_Graph_Bi bool unit}.

Local Coercion Graph_LGraph: Graph >-> LGraph.
Local Coercion LGraph_SGraph: LGraph >-> SGraph.
Local Identity Coercion Graph_GeneralGraph: Graph >-> GeneralGraph.
Local Identity Coercion LGraph_LabeledGraph: LGraph >-> LabeledGraph.
Local Identity Coercion SGraph_PointwiseGraph: SGraph >-> PointwiseGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.

Notation Graph := (@Graph pSGG_Bi bool unit unit).

Lemma root_unfold: forall (g: Graph) x d l r,
  vvalid g x ->
  vgamma g x = (d, l, r) ->
  reachable_dag_vertices_at x g = vertex_at x (d, l, r) * reachable_through_dag_vertices_at (l :: r :: nil) g.
Proof. apply va_reachable_dag_unfold. Qed.

Lemma root_update_unfold: forall (g: Graph) x d l r v,
  vvalid g x ->
  vgamma g x = (d, l, r) ->
  reachable_dag_vertices_at x (Graph_vgen g x v) = vertex_at x (v, l, r) * reachable_through_dag_vertices_at (l :: r :: nil) g.
Proof. intros. eapply va_reachable_dag_update_unfold; eauto. Qed.

(* TODO: More modularized way to prove these two RamificationPremise?
 For example, handling pure facts? *)
Lemma dag_ramify_left: forall (g g1: Graph) x l r,
  vvalid g x ->
  vgamma g x = (false, l, r) ->
  mark1 x g g1 ->
  @derives pred _
    (reachable_dag_vertices_at x g1)
    (reachable_dag_vertices_at l g1 *
     (ALL g': Graph,
       !! (mark l g1 g') -->
       (reachable_dag_vertices_at l g' -* reachable_dag_vertices_at x g'))).
Proof.
  intros.
  unfold reachable_dag_vertices_at.
  normalize.
  pose proof proj1 H1.
  rewrite <- H3 in H2.
  assert (localDag g1 l).
  1: {
    rewrite <- H3.
    eapply local_dag_step; eauto.
    eapply gamma_step; eauto.
  }
  rewrite prop_true_andp by auto.
  match goal with
  | |- _ |-- _ * ?A =>
    replace A with
   (ALL g' : Graph ,
      (!!mark l g1 g':pred) -->
      (vertices_at (reachable g' l) g' -*
       vertices_at (reachable g' x) g'))
  end.
  2: {
    apply allp_congr; intros g2.
    apply imp_prop_ext; [reflexivity |].
    intros [_ ?].
    rewrite prop_true_andp by (rewrite <- H5; auto).
    rewrite prop_true_andp by (rewrite <- H5, <- H3; auto).
    reflexivity.
  }
  eapply graph_ramify_left; eauto.
Qed.

Lemma dag_ramify_right: forall (g g1 g2: Graph) x l r,
  vvalid g x ->
  vgamma g x = (false, l, r) ->
  mark1 x g g1 ->
  mark l g1 g2 ->
  (reachable_dag_vertices_at x g2: pred) |-- reachable_dag_vertices_at r g2 *
   (ALL g':Graph,
     !! (mark r g2 g') -->
     (reachable_dag_vertices_at r g' -* reachable_dag_vertices_at x g')).
Proof.
  intros.
  pose proof @graph_ramify_right _ _ g g1 g2 x l r H H0 H1 H2.
  unfold reachable_dag_vertices_at.
  normalize.
  destruct H1 as [? _].
  destruct H2 as [_ ?].
  rewrite <- H2, <- H1 in H4.
  assert (localDag g2 r).
  1: {
    rewrite <- H2, <- H1.
    eapply local_dag_step; eauto.
    eapply gamma_step; eauto.
  }
  rewrite prop_true_andp by auto.

  match goal with
  | |- _ |-- _ * ?A =>
    replace A with
   (ALL  g' : Graph ,
      (!!mark r g2 g':pred) -->
      (vertices_at (reachable g' r) g' -*
       vertices_at (reachable g' x) g'))
  end.
  2: {
    apply allp_congr; intros g3.
    apply imp_prop_ext; [reflexivity |].
    intros [_ ?].
    rewrite prop_true_andp by (rewrite <- H6; auto).
    rewrite prop_true_andp by (rewrite <- H6, <- H2, <- H1; auto).
    reflexivity.
  }
  auto.
Qed.

End PointwiseGraph_Mark_Bi.


(** Coq coding by choukh, July 2021 **)

(* 基于斯科特[1] *)
(* 消除了哥德尔原始版本中公理不一致的问题 *)
(* 斯科特本人的版本[1]基于S5系统，但最近的研究[6]显示只需更弱的KB系统 *)

Require Import CM.Logic.Classical.
Require Import CM.Logic.Modal.
Require Import CM.Logic.Entity.

Parameter 积极 : 泛性质 性质.
Definition 消极 := λ Φ, ¬ 积极 Φ.

Axiom 积极性质的反面消极 : ⌈∀ Φ, 积极 Φ → 消极 (反 Φ)⌋.
Axiom 消极的否定积极 : ⌈∀ Φ, 消极 Φ → 积极 (反 Φ)⌋.

Axiom 积极的必然后果也积极 : ⌈∀ Φ Ψ : 性质, 积极 Φ → (Φ ⇒ Ψ) → 积极 Ψ⌋.

(* 基于[6]第5节的改进证法 *)
Theorem 积极性质可能存在实例 : ⌈∀ Φ, 积极 Φ → 一致 Φ⌋.
Proof.
  证明. intros Φ H. 反证.
  apply (爆炸原理 w Φ (反 Φ)) in 反设.
  apply (积极性质的反面消极 w Φ). apply H.
  now apply (积极的必然后果也积极 w Φ).
Qed.

(* x具有神性，当且仅当任意积极性质都被x所具有 *)
Definition 神性 : 性质 := λ x, ∀ Φ, 积极 Φ → Φ x.

Axiom 神性积极 : ⌈积极 神性⌋.

Theorem 可能存在神 : ⌈一致 神性⌋.
Proof. 证明. apply 积极性质可能存在实例. apply 神性积极. Qed.

Lemma 神的任意性质积极 : ⌈∀ x Φ, 神性 x → Φ x → 积极 Φ⌋.
Proof.
  证明. intros g Φ Hg HΦ. 反证.
  assert (积极 (反 Φ) w). firstorder using 消极的否定积极.
  now apply Hg in H.
Qed.

Module 一神论.

Theorem 神唯一 : ⌈∀ x y, 神性 x → 神性 y → x = y⌋.
Proof.
  证明. intros a b Ha Hb.
  set (λ x, x = a) as Φ.
  assert (积极 Φ w). now apply (神的任意性质积极 w a).
  now apply Hb in H.
Qed.

Theorem 必然神唯一 : ⌈□ ∀ x y, 神性 x → 神性 y → x = y⌋.
Proof. apply 𝗡. apply 神唯一. Qed.

End 一神论.

(* 对本性定义的修改消除了公理不一致的问题 *)
(* P是x的本性，当且仅当P是x的性质且x的任意性质都是P的必然后果 *)
Definition 本性 : 性质 → 实体 → 命题 :=
  λ Φ x, Φ x ∧ ∀ Ψ, Ψ x → Φ ⇒ Ψ.

Axiom 积极性质必然积极 : ⌈∀ Φ, 积极 Φ → □ 积极 Φ⌋.

Theorem 神性是神之本性 : ⌈∀ x, 神性 x → 本性 神性 x⌋.
Proof.
  证明. intros g Hg. split. apply Hg.
  intros Φ HΦ. apply 神的任意性质积极 in HΦ; auto.
  eapply 必然性三段论. apply 积极性质必然积极.
  apply HΦ. firstorder.
Qed.

(* 实体实在，当且仅当该实体的任意本性都必然存在实例 *)
Definition 实在性 : 性质 := λ x, ∀ Φ, 本性 Φ x → □ ∃ x, Φ x.

Axiom 实在性积极 : ⌈积极 实在性⌋.

Lemma 神具有实在性 : ⌈∀ x, 神性 x → 实在性 x⌋.
Proof. firstorder using 实在性积极. Qed.

Lemma 存在神则必然存在神 : ⌈(∃ x, 神性 x) → □ ∃ x, 神性 x⌋.
Proof.
  证明. intros [g Hg].
  apply (神具有实在性 w g Hg).
  now apply 神性是神之本性.
Qed.

Module 原始版. (* 基于[1] *)
Import Modal.S5.

Lemma 可能存在神则必然存在神 : ⌈一致 神性 → □ ∃ x, 神性 x⌋.
Proof.
  证明. intros H. apply 𝟰𝗕.
  eapply 可能性三段论1. apply H.
  apply 𝗡. apply 存在神则必然存在神.
Qed.

Theorem 必然存在神 : ⌈□ ∃ x, 神性 x⌋.
Proof. 证明. apply 可能存在神则必然存在神. apply 可能存在神. Qed.

Theorem 存在神 : ⌈∃ x, 神性 x⌋.
Proof. 证明. apply 𝗧. apply 必然存在神. Qed.

End 原始版.

Module Import 改进版. (* 基于[6]第5节 *)
Import Modal.KB.

Lemma 可能必然存在神 : ⌈◇ □ ∃ x, 神性 x⌋.
Proof.
  证明. eapply 可能性三段论1. apply 可能存在神.
  apply 𝗡. apply 存在神则必然存在神.
Qed.

Theorem 存在神 : ⌈∃ x, 神性 x⌋.
Proof. 证明. apply 𝗕归结. apply 可能必然存在神. Qed.

Theorem 必然存在神 : ⌈□ ∃ x, 神性 x⌋.
Proof. apply 𝗡. apply 存在神. Qed.

End 改进版.

Module 反驳1. (* 基于[6]第6节 *)

Lemma 神的任意性质都是神性的必然后果 : ⌈∀ x Φ, 神性 x → Φ x → 神性 ⇒ Φ⌋.
Proof. 证明. intros g Φ Hg. apply 神性是神之本性. apply Hg. Qed.

Lemma 神性的一切后果都存在实例 : ⌈∀ Φ, (∀ x, 神性 x → Φ x) → ∃ x : 实体, Φ x⌋.
Proof.
  证明. intros Φ H.
  destruct (存在神 w) as [g Hg].
  apply H in Hg. now exists g.
Qed.

Fact 模态坍塌 : ⌈∀ P, P → □ P⌋.
Proof.
  证明. intros P HP.
  set (λ _ : 实体, P) as Φ.
  cut ((□ ∃ x, Φ x) w). firstorder.
  destruct (存在神 w) as [g Hg].
  pose proof (神的任意性质都是神性的必然后果 w g Φ Hg HP).
  eapply 必然性三段论. apply H. apply 𝗡. 证明.
  apply 神性的一切后果都存在实例.
Qed.

End 反驳1.

Module 反驳2. (* 基于[1] *)

Fact 积极性质必然存在实例 : ⌈∀ Φ, 积极 Φ → □ ∃ x, Φ x⌋.
Proof.
  证明. intros Φ H. apply 积极性质必然积极 in H.
  eapply 必然性三段论. apply 必然存在神. firstorder.
Qed.

Fact 无本性的实体具有实在性 : ⌈∀ x, (∀ Φ, ¬ 本性 Φ x) → 实在性 x⌋.
Proof. firstorder. Qed.

Fact 任意实体具有实在性 : ⌈∀ x, 实在性 x⌋.
Proof.
  证明. intros x Φ H.
  set (λ _ : 实体, ∃ y, 本性 Φ y) as Ψ.
  cut ((□ ∃ y, Ψ y) w). firstorder.
  apply 积极性质必然存在实例.
  destruct (存在神 w) as [g Hg].
  apply (神的任意性质积极 w g); firstorder.
Qed.

End 反驳2.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O B A0 A1 C Cprime P Q R Aprime A Pprime Qprime Rprime Aprimeprime : Universe, ((wd_ O A0 /\ (wd_ B A0 /\ (wd_ A0 A1 /\ (wd_ O A1 /\ (wd_ O B /\ (wd_ A0 Aprime /\ (wd_ C Cprime /\ (wd_ A0 Cprime /\ (wd_ A Aprime /\ (wd_ A O /\ (wd_ P Q /\ (wd_ Aprime O /\ (wd_ R Q /\ (wd_ O Aprimeprime /\ (wd_ A0 Aprimeprime /\ (wd_ Aprime Aprimeprime /\ (wd_ Pprime Qprime /\ (wd_ Rprime Qprime /\ (col_ A0 Aprimeprime B /\ (col_ A0 A1 Aprimeprime /\ (col_ A0 A Aprime /\ (col_ A0 Aprime B /\ (col_ A0 A1 Aprime /\ (col_ A0 C Cprime /\ col_ A0 A1 B)))))))))))))))))))))))) -> col_ Aprime A0 Aprimeprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Formats.FixListOpt.
Require Export
        Coq.Lists.List.

(* Commenting out until useful again. *)
(*Section SteppingList.
  Context {A : Type}. (* data type *)
  Context {B : Type}. (* bin type *)
  Context {P : Type}. (* cache pointer type *)
  Context {cache : Cache}.
  Context {cache_inv : CacheDecode -> Prop}.
  Context {monoid : Monoid B}.

  Variable A_halt : A.
  Variable A_halt_dec : forall a, {a = A_halt} + {~ a = A_halt}.
  Variable A_predicate : A -> Prop.
  Variable A_predicate_rest : A -> B -> Prop.
  Variable A_predicate_halt : A_predicate A_halt.
  Variable format_A : A -> CacheFormat -> Comp (B * CacheFormat).
  Variable A_decode : B -> CacheDecode -> option (A * B * CacheDecode).
  Variable A_decode_pf : CorrectDecoder cache monoid A_predicate format_A A_decode cache_inv.
  Variable A_decode_lt
    : forall  (b : B)
              (cd : CacheDecode)
              (a : A)
              (b' : B)
              (cd' : CacheDecode),
      A_decode b cd = Some (a, b', cd')
      -> lt_B b' b.

  Variable P_predicate : P -> Prop.
  Variable P_predicate_dec : forall p, {P_predicate p} + {~ P_predicate p}.
  Variable P_format_Spec : P -> CacheFormat -> Comp (B * CacheFormat).
  Variable P_decode : B -> CacheDecode -> option (P * B * CacheDecode).
  Variable P_decode_pf : CorrectDecoder cache monoid P_predicate P_format_Spec P_decode cache_inv.
  Variable P_decode_le :
    forall (b1 : B)
           (cd1 : CacheDecode)
           (a : P)
           (b' : B)
           (cd' : CacheDecode),
      P_decode b1 cd1 = Some (a, b', cd') -> le_B b' b1.

  Variable X_format_Spec : bool -> CacheFormat -> Comp (B * CacheFormat).
  Variable X_decode : B -> CacheDecode -> option (bool * B * CacheDecode).
  Variable X_decode_pf : CorrectDecoder cache monoid (fun _ => True) X_format_Spec X_decode cache_inv.
  Variable X_decode_le :
    forall (b1 : B)
           (cd1 : CacheDecode)
           (a : bool)
           (b' : B)
           (cd' : CacheDecode),
      X_decode b1 cd1 = Some (a, b', cd') -> le_B b' b1.

  Variable cacheAdd : CacheAdd cache (list A * P).
  Variable cacheGet : CacheGet cache (list A) P.
  Variable cachePeek : CachePeek cache P.

  Variable cacheGet_OK :
    forall env p l,
      cache_inv env
      -> getD env p = Some l
      -> forall x,
          In x l
          -> A_predicate x /\ ~ x = A_halt.

  Variable cacheAdd_OK :
    forall env p l,
      cache_inv env
      -> (forall x,
             In x l
             -> A_predicate x /\ ~ x = A_halt)
        -> cache_inv (addD env (l, p)).

  Fixpoint format_list_step (l : list A ) (ce : CacheFormat)
    : Comp (B * CacheFormat) :=
    match l with
    | nil => `(b1, e1) <- X_format_Spec false ce;
             `(b2, e2) <- format_A A_halt e1;
             ret (mappend b1 b2, e2)
    | cons x l' =>
      match getE ce l with
      | Some position =>
        b <- {b : bool | True};
          If b Then (* Nondeterministically pick whether to use a cached value. *)
           If (P_predicate_dec position)
           Then (`(b1, e1) <- X_format_Spec true ce;
                `(b2, e2) <- P_format_Spec position e1;
                  ret (mappend b1 b2, e2))
           Else (`(b1, e1) <- X_format_Spec false ce;
             `(b2, e2) <- format_A x e1;
             `(b3, e3) <- format_list_step l' e2;
             ret (mappend (mappend b1 b2) b3, addE e3 (l, peekE ce)))
           Else
           (`(b1, e1) <- X_format_Spec false ce;
              `(b2, e2) <- format_A x e1;
              `(b3, e3) <- format_list_step l' e2;
              ret (mappend (mappend b1 b2) b3, addE e3 (l, peekE ce)))
      | None => `(b1, e1) <- X_format_Spec false ce;
                     `(b2, e2) <- format_A x e1;
                     `(b3, e3) <- format_list_step l' e2;
                     ret (mappend (mappend b1 b2) b3, addE e3 (l, peekE ce))
      end
    end%comp.

  (* Decode now uses a measure on the length of B *)

  Lemma lt_B_trans :
    forall b
           (b1 : {b' : B | le_B b' b})
           (b2 : {b' : B | lt_B b' (` b1)}),
      lt_B (` b2) b.
  Proof.
    intros; destruct b1; destruct b2; simpl in *.
    unfold le_B, lt_B in *; omega.
  Qed.

  Definition decode_list_step (b : B) (cd : CacheDecode):
    option (list A * B * CacheDecode) :=
    Fix well_founded_lt_b
           (fun _ => CacheDecode -> option (list A * B * CacheDecode))
      (fun b rec cd =>
         `(br, b1, e1) <- Decode_w_Measure_le X_decode b cd X_decode_le;
         If br Then
            (`(ps, b2, e2) <- Decode_w_Measure_le P_decode (proj1_sig b1) e1 P_decode_le;
             match getD cd ps  with
             | Some [] => None (* bogus *)
             | Some l => Some (l, proj1_sig b2, e2)
             | None => None (* bogus *)
             end)
            Else
            (`(a , b2, e2) <- Decode_w_Measure_lt A_decode (proj1_sig b1) e1 A_decode_lt;
             If A_halt_dec a Then
                Some (nil, proj1_sig b2, e2)
                Else
                (`(l, b3, e3) <- rec (proj1_sig b2) (lt_B_trans _ _ _) e2;
                 Some (a :: l, b3, addD e3 (a :: l, peekD cd))))) b cd.

  Theorem SteppingList_decode_correct :
    CorrectDecoder
      cache monoid
      (fun ls => (forall x, In x ls -> A_predicate x /\ ~ x = A_halt))
      format_list_step decode_list_step cache_inv.
  Proof.
    unfold CorrectDecoder; split.
    { intros env xenv xenv' l l' ext Eeq Ppredh Penc;
      subst.
      unfold decode_list_step in *; simpl in *.
      generalize dependent l';
        generalize dependent env;
        generalize dependent xenv;
        generalize ext; generalize dependent xenv';
          induction l; intros; simpl in *.
      { unfold Bind2 in *; computes_to_inv; subst.
        destruct v; destruct v0.
        injections.
        destruct (proj1 X_decode_pf _ _ _ _ _ (mappend b0 ext0) Eeq I Penc) as [? [? ?]]; subst.
        rewrite <- mappend_assoc.
        rewrite Coq.Init.Wf.Fix_eq; simpl.
        let H' := fresh in
        destruct (Decode_w_Measure_le_eq _ _ _ X_decode_le H) as [? H'];
          rewrite H'; simpl; clear H'.
          destruct (proj1 A_decode_pf _ _ _ _ _ ext0 H0 A_predicate_halt Penc') as [? [? ?]]; subst.
          let H' := fresh in
          destruct (Decode_w_Measure_lt_eq _ _ _ A_decode_lt H1) as [? H'];
            rewrite H'; simpl; clear H'.
          destruct (A_halt_dec A_halt); simpl; eexists; eauto.
          congruence.
          intros.
          apply functional_extensionality; intros.
          repeat (f_equal; repeat (apply functional_extensionality; intros)).
      }
      destruct (getE env (a :: l)) eqn: ?.
      rewrite Coq.Init.Wf.Fix_eq; simpl.
      computes_to_inv.
      destruct v; simpl in Penc'.
      { (* Case where the formatr decided to use compression. *)
        destruct (P_predicate_dec p); simpl in Penc';
        unfold Bind2 in Penc'; computes_to_inv; injections;
        subst; destruct v; destruct v0.
        - destruct (proj1 X_decode_pf _ _ _ _ _ (mappend b0 ext0) Eeq I Penc') as [? [? ?]]; subst.
          rewrite <- mappend_assoc; simpl;
            let H' := fresh in
            destruct (Decode_w_Measure_le_eq _ _ _ X_decode_le H) as [? H'];
              rewrite H'; simpl; clear H'.
          destruct (proj1 P_decode_pf _ _ _ _ _ ext0 H0 p0 Penc'') as [? [? ?]];
           let H' := fresh in
            destruct (Decode_w_Measure_le_eq _ _ _ P_decode_le H1) as [? H'];
              rewrite H'; simpl; clear H'.
          eapply get_correct in Heqo; eauto; rewrite Heqo.
          eauto.
        - destruct v1.
          destruct (proj1 X_decode_pf _ _ _ _ _ (mappend b0 (mappend b1 ext0))
                          Eeq I Penc') as [? [? ?]]; subst.
          rewrite <- !mappend_assoc; simpl.
          let H' := fresh in
          destruct (Decode_w_Measure_le_eq _ _ _ X_decode_le H) as [? H'];
            rewrite H'; simpl; clear H'.
          destruct (proj1 A_decode_pf _ _ _ _ _ (mappend b1 ext0) H0 (proj1 (Ppredh _ (or_introl _ eq_refl))) Penc'') as [? [? ?]]; subst.
          let H' := fresh in
          destruct (Decode_w_Measure_lt_eq _ _ _ A_decode_lt H1) as [? H'];
            rewrite H'; simpl; clear H'.
          destruct (A_halt_dec a); simpl.
          elimtype False; apply (proj2 (Ppredh _ (or_introl _ eq_refl)));
            eauto.
          eapply (fun H => IHl H _ ext0) in Penc'''; intros.
          destruct_ex; intuition.
          rewrite H4; simpl.
          eexists; intuition eauto.
          erewrite peek_correct.
          eapply add_correct.
          eauto.
          eauto.
          eapply Ppredh; eauto.
          eauto.
      }
      {
        unfold Bind2 in Penc'; computes_to_inv; injections;
        subst; destruct v; destruct v0; destruct v1.
        - destruct (proj1 X_decode_pf _ _ _ _ _ (mappend b0 (mappend b1 ext0)) Eeq I Penc') as [? [? ?]]; subst.
          rewrite <- !mappend_assoc; simpl.
          let H' := fresh in
          destruct (Decode_w_Measure_le_eq _ _ _ X_decode_le H) as [? H'];
            rewrite H'; simpl; clear H'.
          destruct (proj1 A_decode_pf _ _ _ _ _ (mappend b1 ext0) H0 (proj1 (Ppredh _ (or_introl _ eq_refl))) Penc'') as [? [? ?]]; subst.
          let H' := fresh in
          destruct (Decode_w_Measure_lt_eq _ _ _ A_decode_lt H1) as [? H'];
            rewrite H'; simpl; clear H'.
          destruct (A_halt_dec a); simpl.
          elimtype False; apply (proj2 (Ppredh _ (or_introl _ eq_refl)));
            eauto.
          eapply (fun H => IHl H _ ext0) in Penc'''; intros.
          destruct_ex; intuition.
          rewrite H4; simpl.
          eexists; intuition eauto.
          erewrite peek_correct.
          eapply add_correct.
          eauto.
          eauto.
          eauto.
          eauto.
      }
      intros.
      apply functional_extensionality; intros.
      repeat (f_equal; repeat (apply functional_extensionality; intros)).
      - rewrite Coq.Init.Wf.Fix_eq; simpl.
        unfold Bind2 in Penc; computes_to_inv; injections;
          subst; destruct v; destruct v0; destruct v1;
            simpl in *.
        destruct (proj1 X_decode_pf _ _ _ _ _ (mappend b0 (mappend b1 ext0))
                        Eeq I Penc) as [? [? ?]]; subst.
        rewrite <- !mappend_assoc; simpl.
        let H' := fresh in
        destruct (Decode_w_Measure_le_eq _ _ _ X_decode_le H) as [? H'];
          rewrite H'; simpl; clear H'.
        destruct (proj1 A_decode_pf _ _ _ _ _ (mappend b1 ext0) H0 (proj1 (Ppredh _ (or_introl _ eq_refl))) Penc') as [? [? ?]]; subst.
        let H' := fresh in
        destruct (Decode_w_Measure_lt_eq _ _ _ A_decode_lt H1) as [? H'];
          rewrite H'; simpl; clear H'.
        destruct (A_halt_dec a); simpl.
        elimtype False; apply (proj2 (Ppredh _ (or_introl _ eq_refl)));
          eauto.
        eapply (fun H => IHl H _ ext0) in Penc''; intros; eauto.
        destruct_ex; intuition.
        rewrite H4; simpl.
        eexists; intuition eauto.
        erewrite peek_correct.
        eapply add_correct.
        eauto.
        eauto.
        intros.
        apply functional_extensionality; intros.
        repeat (f_equal; repeat (apply functional_extensionality; intros)).
    }
    { unfold decode_list_step, format_list_step.
      intros env env' xenv' data bin;
        revert env env' xenv' data.
      eapply (@well_founded_induction _ _ well_founded_lt_b) with
      (a := bin); intros.
      rewrite Coq.Init.Wf.Fix_eq in H2; simpl.
      destruct (X_decode x env')
        as [ [ [ [ | ] ?] ?] | ] eqn: Heqo; simpl in *;
        first [eapply (Decode_w_Measure_le_eq' _ _ _ X_decode_le) in Heqo;
               rewrite Heqo in H2; simpl in H2; discriminate
              | let H' := fresh in
                destruct (Decode_w_Measure_le_eq _ _ _ X_decode_le Heqo) as [? H'];
                rewrite H' in H2; simpl in *; clear H'].
      - destruct (P_decode b c)
          as [ [ [ ? ?] ?] | ] eqn: Heqo'; simpl in *;
          first [eapply (Decode_w_Measure_le_eq' _ _ _ P_decode_le) in Heqo';
               rewrite Heqo' in H2; simpl in H2; discriminate
              | let H' := fresh in
                destruct (Decode_w_Measure_le_eq _ _ _ P_decode_le Heqo') as [? H'];
                rewrite H' in H2; simpl in *; clear H'].
        destruct (getD env' p) eqn: ?; simpl in *; try discriminate.
        injections.
        destruct l; try discriminate; injections.
        eapply (proj2 X_decode_pf) in Heqo; destruct Heqo;
          destruct_ex; intuition eauto; subst;
            eapply (proj2 P_decode_pf) in Heqo'; destruct Heqo';
              destruct_ex; intuition eauto; subst.
        rewrite (proj2 (get_correct _ _ _ _ H0) Heqo0).
        eexists; eexists; intuition eauto.
        computes_to_econstructor.
        apply (@PickComputes _ _ true); eauto.
        simpl.
        destruct (P_predicate_dec p).
        repeat computes_to_econstructor; eauto.
        intuition.
        simpl; rewrite mappend_assoc; reflexivity.
        pose proof (cacheGet_OK _ _ _ H1 Heqo0 _ H6); intuition.
        pose proof (cacheGet_OK _ _ _ H1 Heqo0 _ H6); intuition.
      - destruct (A_decode b c)
          as [ [ [ ? ?] ?] | ] eqn: Heqo'; simpl in *;
          first [eapply (Decode_w_Measure_lt_eq' _ _ _ A_decode_lt) in Heqo';
                 rewrite Heqo' in H2; simpl in H1; discriminate
                | let H' := fresh in
                  destruct (Decode_w_Measure_lt_eq _ _ _ A_decode_lt Heqo') as [? H'];
                  rewrite H' in H2; simpl in *; clear H'].
        eapply (proj2 X_decode_pf) in Heqo; eauto;
          destruct Heqo; destruct_ex;
            eauto; subst;
              eapply (proj2 A_decode_pf) in Heqo'; eauto;
                destruct Heqo'; destruct_ex;
                  eauto; subst; split_and; eauto.
        destruct (A_halt_dec a); simpl in *.
        + injections; simpl.
          intuition.
          eexists; eexists; intuition.
          computes_to_econstructor; eauto.
          computes_to_econstructor; eauto.
          unfold le_B in x0.
          simpl; rewrite mappend_assoc; reflexivity.
          eauto.
        + match type of H2 with
            context [Fix well_founded_lt_b ?P ?f ?b ?c] =>
            destruct (Fix well_founded_lt_b P f b c)
              as [ [ [ ? ?] ?] | ] eqn: ?; simpl in *; try discriminate
          end.
          simpl in H2; injections.
          split.
          * eapply cacheAdd_OK.
            eapply H12 in Heqo; eauto.
            unfold le_B, lt_B in *; omega.
            simpl; intros; intuition subst; eauto.
            eapply H14 in Heqo; eauto; destruct_ex; intuition.
            eapply H16; eauto.
            unfold le_B, lt_B in *; omega.
            eapply H14 in Heqo; eauto; destruct_ex; intuition.
            eapply H16; eauto.
            unfold le_B, lt_B in *; omega.
          * destruct (getE env (a :: l)) eqn : ? .
            eapply H14 in Heqo; eauto; destruct_ex; intuition.
            eexists; eexists; intuition eauto.
            computes_to_econstructor.
            apply (@PickComputes _ _ false); eauto.
            simpl.
            computes_to_econstructor; eauto.
            computes_to_econstructor; eauto.
            computes_to_econstructor; eauto.
            subst; rewrite !mappend_assoc; reflexivity.
            simpl in *; intuition subst; eauto.
            eapply H6; eauto.
            simpl in *; intuition subst; eauto.
            eapply H6; eauto.
            simpl.
            erewrite peek_correct; eauto.
            eapply add_correct; eauto.
            unfold le_B, lt_B in *; omega.
            eapply H14 in Heqo; eauto; destruct_ex; intuition.
            eexists; eexists; intuition eauto.
            computes_to_econstructor; eauto.
            computes_to_econstructor; eauto.
            computes_to_econstructor; eauto.
            subst; rewrite !mappend_assoc; reflexivity.
            simpl in *; intuition subst; eauto.
            eapply H6; eauto.
            simpl in *; intuition subst; eauto.
            eapply H6; eauto.
            simpl.
            erewrite peek_correct; eauto.
            eapply add_correct; eauto.
            unfold lt_B, le_B in *; rewrite !mappend_measure.
            rewrite mappend_measure in x1.
            omega.
      - intros; apply functional_extensionality; intros.
        repeat (f_equal; repeat (apply functional_extensionality; intros)).
        Grab Existential Variables.
        eauto.
    }
  Qed.
End SteppingList. *)


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export per_props_equality.

Lemma tequality_mkc_equality_sp_eq {p} :
  forall lib (a1 a2 b1 b2 A B : @CTerm p),
    equality lib a1 a2 A
    -> (tequality lib (mkc_equality a1 a2 A) (mkc_equality b1 b2 B)
        <=> (tequality lib A B # equality lib a1 b1 A # equality lib a2 b2 A)).
Proof.
  introv eqa.
  split; intro h; repnd; dands; auto.
  - rw @tequality_mkc_equality_sp in h; sp.
  - rw @tequality_mkc_equality_sp in h; repnd.
    repndors; spcast; eauto 3 with nequality.
  - rw @tequality_mkc_equality_sp in h; repnd.
    repndors; spcast; eauto 3 with nequality.
    + eapply equality_respects_cequivc_right;[exact h|].
      apply equality_sym in eqa; apply equality_refl in eqa; auto.
    + eapply equality_respects_cequivc_right;[exact h|].
      apply equality_sym in eqa; apply equality_refl in eqa; auto.
  - apply tequality_mkc_equality_sp; dands; auto.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


Require Import VST.concurrency.conclib.
Require Import VST.progs.bst_conc.
Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.

Require Export VST.floyd.Funspec_old_Notation.
#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition t_struct_tree := Tstruct _tree noattr.
Definition t_struct_tree_t := Tstruct _tree_t noattr.

Section TREES.
Variable V : Type.
Variable default: V.

Definition key := Z.

Inductive tree : Type :=
 | E : tree
 | T: tree -> key -> V -> tree -> tree.

Definition empty_tree : tree := E.

Fixpoint lookup (x: key) (t : tree) : V :=
  match t with
  | E => default
  | T tl k v tr => if x <? k then lookup x tl
                         else if k <? x then lookup x tr
                         else v
  end.

(*Fixpoint insert (x: key) (v: V) (s: node) : node :=
 match s with
 | En => EX locka : val, EX lockb : val,
          N tree_t (TR empty_node locka) x v (TR empty_node lockb)
 | N (TR a la) y v' (TR b lb) => if  x <? y
                        then N tree_t (TR (insert x v a) la) y v' (TR b lb)
                        else if y <? x
                        then N tree_t (TR a la) y v' (TR (insert x v b) lb)
                        else N tree_t (TR a la) x v (TR b lb)
 end.
*)

Fixpoint insert (x: key) (v: V) (s: tree) : tree :=
 match s with
 | E => T E x v E
 | T a y v' b => if  x <? y then T (insert x v a) y v' b
                        else if y <? x then T a y v' (insert x v b)
                        else T a x v b
 end.

Fixpoint pushdown_left (a: tree) (bc: tree) : tree :=
 match bc with
 | E => a
 | T b y vy c => T (pushdown_left a b) y vy c
 end.

Fixpoint delete (x: key) (s: tree) : tree :=
 match s with
 | E => E
 | T a y v' b => if  x <? y then T (delete x a) y v' b
                        else if y <? x then T a y v' (delete x b)
                        else pushdown_left a b
 end.

End TREES.
Arguments E {V}.
Arguments T {V} _ _ _ _.
Arguments insert {V} x v s.
Arguments lookup {V} default x t.
Arguments pushdown_left {V} a bc.
Arguments delete {V} x s.

Eval hnf in reptype (nested_field_type t_struct_tree_t [StructField _lock]).

(*Definition t_lock_pred' tl lsh p lock  := EX t : tree val, t_lock_pred tl lsh t p lock.

Definition t_lock_pred_uncurry (t: tree val) lsh (tl : (tree val -> (val * val) -> mpred)) := fun t '(p, lock) =>
  t_lock_pred tl t lsh p lock.

Definition t_lock_pred'' t lsh :=  HORec (t_lock_pred_uncurry t lsh).

Definition t_lock_pred''' t lsh p lock  := t_lock_pred'' t lsh (p,lock).

Definition ltree_final lsh p lock (t : tree val) :=
  !!(field_compatible t_struct_tree_t nil p) &&
  (field_at lsh t_struct_tree_t [StructField _lock] lock p *
   lock_inv lsh lock (t_lock_pred''' t lsh p lock)).
*)

Fixpoint tree_rep (t: tree val) (p: val) : mpred := (*tree strored in p correctly, see struct tree, representation in memory*)
 match t with
 | E => !!(p=nullval) && emp
 | T a x v b => !! (Int.min_signed <= x <= Int.max_signed /\ tc_val (tptr Tvoid) v) &&
    EX pa:val, EX pb:val,
    data_at Tsh t_struct_tree (Vint (Int.repr x),(v,(pa,pb))) p *
    tree_rep a pa * tree_rep b pb
 end.

Definition ltree tl lsh p lock :=
  !!(field_compatible t_struct_tree_t nil p) &&
  (field_at lsh t_struct_tree_t [StructField _lock] lock p *
   lock_inv lsh lock (tl (p, lock))).

Fixpoint node_rep tl lsh (t: tree val) (np: val) : mpred := (*tree strored in p correctly, see struct tree, representation in memory*)
 match t with
 | E => !!(np=nullval) && emp
 | T a x v b => !! (Int.min_signed <= x <= Int.max_signed /\ tc_val (tptr Tvoid) v) && EX pa : val, EX pb : val, EX locka : val, EX lockb : val,
    data_at Tsh t_struct_tree (Vint (Int.repr x),(v,(pa,pb))) np *
    ltree tl lsh pa locka * ltree tl lsh pb lockb
 end.

(*Definition t_lock_pred tl t lsh p lock :=

EX tp : val, (field_at Tsh (t_struct_tree_t) [StructField _t] tp p * node_rep tl lsh t tp *
  malloc_token Tsh (t_struct_tree_t) p *
 malloc_token Tsh (tlock) lock).
 *)

Definition t_lock_pred tl t lsh p (lock: val) :=
EX tp : val, (field_at Tsh (t_struct_tree_t) [StructField _t] tp p * node_rep tl lsh t tp). (* *
  malloc_token Tsh (t_struct_tree_t) p *
 malloc_token Tsh (tlock) lock).*)

Definition t_lock_pred' tl lsh p lock  :=
      EX t : tree val, t_lock_pred tl t lsh p lock.

Definition t_lock_pred_uncurry lsh (tl : ((val * val) -> mpred)) := fun '(p, lock) =>
  t_lock_pred' tl lsh p lock.

Definition t_lock_pred'' lsh :=  HORec (t_lock_pred_uncurry lsh).

Definition t_lock_pred''' lsh p lock := t_lock_pred'' lsh (p,lock).

Definition ltree_final lsh p lock :=
  !!(field_compatible t_struct_tree_t nil p) &&
  (field_at lsh t_struct_tree_t [StructField _lock] lock p *
   lock_inv lsh lock (t_lock_pred''' lsh p lock)).

Lemma ltree_subp : forall P Q a b c,
  ALL x : _, |> (P x <=> Q x) |-- |> ltree P a b c >=> |> ltree Q a b c.
Proof.
  intros; unfold ltree.
  rewrite !later_andp; apply subp_andp; [apply subp_refl|].
  rewrite !later_sepcon; apply subp_sepcon; [apply subp_refl|].
  rewrite <- subp_later.
  repeat intro.
  match goal with |- predicates_hered.app_pred (?A >=> ?B) a' =>
    change (predicates_hered.app_pred (subtypes.fash (predicates_hered.imp A B)) a') end.
  unfold lock_inv; repeat intro.
  destruct H3 as (b1 & ofs & ? & Hl & ?); exists b1, ofs; split; auto; split; auto.
  intro l; specialize (Hl l); simpl in *.
  if_tac; auto.
  destruct Hl as [rsh Hl]; exists rsh; rewrite Hl; repeat f_equal.
  extensionality.
  specialize (H (b, c) _ H0).
  apply ageable.necR_level in H2.
  apply predicates_hered.pred_ext; intros ? []; split; auto.
  - destruct (H a1) as [X _]; [lia|].
    specialize (X _ (ageable.necR_refl _)); auto.
  - destruct (H a1) as [_ X]; [lia|].
    specialize (X _ (ageable.necR_refl _)); auto.
Qed.

Theorem t_lock_pred_def : forall lsh p lock,
  t_lock_pred''' lsh p lock = t_lock_pred' (t_lock_pred'' lsh) lsh p lock.
Proof.
  intros.
  unfold t_lock_pred''', t_lock_pred''.
  etransitivity; [eapply equal_f, HORec_fold_unfold|].
  { apply prove_HOcontractive; intros ?? (?, ?).
    unfold t_lock_pred_uncurry.
    unfold t_lock_pred'.
    apply subp_exp; intros t.
    unfold t_lock_pred.
    apply subp_exp; intros. Admitted. (* change in t_lock_pred
    apply subp_sepcon, subp_refl.
    apply subp_sepcon, subp_refl.
    apply subp_sepcon; [apply subp_refl|].
    destruct t; simpl node_rep.
    { apply subp_refl. }
    rewrite !later_andp.
    apply subp_andp; [apply subp_refl|].
    repeat (rewrite 2later_exp' by auto; apply subp_exp; intros).
    rewrite !later_sepcon, !sepcon_assoc; apply subp_sepcon; [apply subp_refl|].
    apply subp_sepcon; eapply derives_trans, ltree_subp; apply allp_right; intros; eapply allp_left; rewrite eqp_later; apply derives_refl. }
  unfold t_lock_pred_uncurry; reflexivity.
Qed.*)

Definition treebox_rep (t: tree val) (b: val) :=
 EX p: val, data_at Tsh (tptr t_struct_tree_t) p b.

Definition nodebox_rep (sh : share) (lock : val) (nb: val) :=
 EX np: val, data_at Tsh (tptr (t_struct_tree_t)) np nb * ltree_final sh np lock.

Definition mallocN_spec :=
 DECLARE _mallocN
  WITH n: Z
  PRE [ 1%positive OF tint]
     PROP (4 <= n <= Int.max_unsigned)
     LOCAL (temp 1%positive (Vint (Int.repr n)))
     SEP ()
  POST [ tptr tvoid ]
     EX v: val,
     PROP (malloc_compatible n v)
     LOCAL (temp ret_temp v)
     SEP (memory_block Tsh n v).

Definition freeN_spec :=
 DECLARE _freeN
  WITH p : val , n : Z
  PRE [ 1%positive OF tptr tvoid , 2%positive OF tint]
     (* we should also require natural_align_compatible (eval_id 1) *)
      PROP() LOCAL (temp 1%positive p; temp 2%positive (Vint (Int.repr n)))
      SEP (memory_block Tsh n p)
  POST [ tvoid ]
    PROP () LOCAL () SEP ().

Definition treebox_new_spec :=
 DECLARE _treebox_new
  WITH u : unit
  PRE  [  ]
       PROP() LOCAL() SEP ()
  POST [ tptr (tptr t_struct_tree) ]
    EX v:val,
    PROP()
    LOCAL(temp ret_temp v)
    SEP (data_at Tsh (tptr t_struct_tree) nullval v).

(*Definition insert_spec :=
 DECLARE _insert
  WITH b: val, x: Z, v: val, t: tree val
  PRE  [ _t OF (tptr (tptr t_struct_tree)), _x OF tint,
        _value OF (tptr Tvoid)   ]
    PROP( Int.min_signed <= x <= Int.max_signed; is_pointer_or_null v)
    LOCAL(temp _t b; temp _x (Vint (Int.repr x)); temp _value v)
    SEP (treebox_rep t b)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (treebox_rep (insert x v t) b).
*)

(*maybe I should add the treebox_rep in the ltree definition *)
(*NEW*)
Definition insert_spec :=
  DECLARE _insert
  WITH sh : share, p : val, lock : val,
       b: val, x: Z, v: val, t: tree val
  PRE [  _t OF (tptr (tptr t_struct_tree_t)), _x OF tint,
        _value OF (tptr Tvoid)  ]
   PROP (readable_share sh; Int.min_signed <= x <= Int.max_signed; is_pointer_or_null v)
   LOCAL (temp _t b; temp _x (Vint (Int.repr x)); temp _value v)
   SEP (nodebox_rep sh lock b)
  POST [ Tvoid ]
   PROP ()
   LOCAL ()
   SEP (nodebox_rep sh lock b).
(*Definition insert_spec prog := DECLARE (ext_link_prog prog "insert") insert_spec'.*)

Definition lookup_spec :=
 DECLARE _lookup
  WITH b: val, x: Z, v: val, t: tree val
  PRE  [ _t OF (tptr (tptr t_struct_tree)), _x OF tint  ]
    PROP( Int.min_signed <= x <= Int.max_signed)
    LOCAL(temp _t b; temp _x (Vint (Int.repr x)))
    SEP (treebox_rep t b)
  POST [ tptr Tvoid ]
    PROP()
    LOCAL(temp ret_temp (lookup nullval x t))
    SEP (treebox_rep t b).

Definition turn_left_spec :=
 DECLARE _turn_left
  WITH ta: tree val, x: Z, vx: val, tb: tree val, y: Z, vy: val, tc: tree val, b: val, l: val, pa: val, r: val
  PRE  [ __l OF (tptr (tptr (Tstruct _tree noattr))),
        _l OF (tptr (Tstruct _tree noattr)),
        _r OF (tptr (Tstruct _tree noattr))]
    PROP(Int.min_signed <= x <= Int.max_signed; is_pointer_or_null vx)
    LOCAL(temp __l b; temp _l l; temp _r r)
    SEP (data_at Tsh (tptr t_struct_tree) l b;
         data_at Tsh t_struct_tree (Vint (Int.repr x), (vx, (pa, r))) l;
         tree_rep ta pa;
         tree_rep (T tb y vy tc) r)
  POST [ Tvoid ]
    EX pc: val,
    PROP(Int.min_signed <= y <= Int.max_signed; is_pointer_or_null vy)
    LOCAL()
    SEP (data_at Tsh (tptr t_struct_tree) r b;
         data_at Tsh t_struct_tree (Vint (Int.repr y), (vy, (l, pc))) r;
         tree_rep (T ta x vx tb) l;
         tree_rep tc pc).

Definition pushdown_left_spec :=
 DECLARE _pushdown_left
  WITH ta: tree val, x: Z, v: val, tb: tree val, b: val, p: val
  PRE  [ _t OF (tptr (tptr (Tstruct _tree noattr)))]
    PROP(Int.min_signed <= x <= Int.max_signed; tc_val (tptr Tvoid) v)
    LOCAL(temp _t b)
    SEP (data_at Tsh (tptr t_struct_tree) p b;
         field_at Tsh t_struct_tree [StructField _key] (Vint (Int.repr x)) p;
         field_at Tsh t_struct_tree [StructField _value] v p;
         treebox_rep ta (field_address t_struct_tree [StructField _left] p);
         treebox_rep tb (field_address t_struct_tree [StructField _right] p))
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (treebox_rep (pushdown_left ta tb) b).

Definition delete_spec :=
 DECLARE _delete
  WITH b: val, x: Z, t: tree val
  PRE  [ _t OF (tptr (tptr t_struct_tree)), _x OF tint]
    PROP( Int.min_signed <= x <= Int.max_signed)
    LOCAL(temp _t b; temp _x (Vint (Int.repr x)))
    SEP (treebox_rep t b)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (treebox_rep (delete x t) b).

Definition tree_free_spec :=
 DECLARE _tree_free
  WITH t: tree val, p: val
  PRE  [ _p OF (tptr t_struct_tree) ]
       PROP() LOCAL(temp _p p) SEP (tree_rep t p)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (emp).

Definition treebox_free_spec :=
 DECLARE _treebox_free
  WITH t: tree val, b: val
  PRE  [ _b OF (tptr (tptr t_struct_tree)) ]
       PROP() LOCAL(temp _b b) SEP (treebox_rep t b)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (emp).

Definition acquire_spec := DECLARE _acquire acquire_spec.
Definition release_spec := DECLARE _release release_spec.
Definition makelock_spec := DECLARE _makelock (makelock_spec _).
(*Definition freelock_spec := DECLARE _freelock (freelock_spec _).
Definition spawn_spec := DECLARE _spawn spawn_spec.
Definition freelock2_spec := DECLARE _freelock2 (freelock2_spec _).
Definition release2_spec := DECLARE _release2 release2_spec.*)

(*no freelock_spec, spawn_spec, freelock2_spec, release2_spec*)
Definition Gprog : funspecs :=
    ltac:(with_library prog [acquire_spec; release_spec; makelock_spec;
  (*
    acquire_spec; release_spec; makelock_spec; freelock_spec;
   makecond_spec; freecond_spec; wait_spec; signal_spec;*)
    mallocN_spec; freeN_spec; treebox_new_spec;
    tree_free_spec; treebox_free_spec;
    insert_spec; lookup_spec;
    turn_left_spec; pushdown_left_spec; delete_spec
  ]).

Lemma tree_rep_saturate_local:
   forall tl lsh t p, node_rep tl lsh t p |-- !! is_pointer_or_null p.
Proof.
destruct t; simpl; intros.
entailer!.
Intros pa pb locka lockb. entailer!.
Qed.

#[export] Hint Resolve tree_rep_saturate_local: saturate_local.

Lemma tree_rep_valid_pointer:
  forall tl lsh t p, node_rep tl lsh t p |-- valid_pointer p.
Proof.
intros.
destruct t; simpl; normalize; auto with valid_pointer.
Qed.
#[export] Hint Resolve tree_rep_valid_pointer: valid_pointer.

(*Lemma treebox_rep_saturate_local:
   forall t b, treebox_rep t b |-- !! field_compatible (tptr t_struct_tree_t) [] b.
Proof.
intros.
unfold treebox_rep.
Intros p.
entailer!.
Qed.

#[export] Hint Resolve treebox_rep_saturate_local: saturate_local.

Definition insert_inv (b0: val) (t0: tree val) (x: Z) (v: val): environ -> mpred :=
  EX b: val, EX t: tree val,
  PROP()
  LOCAL(temp _t b; temp _x (Vint (Int.repr x));   temp _value v)
  SEP(treebox_rep t b;  (treebox_rep (insert x v t) b -* treebox_rep (insert x v t0) b0)). (* b0 which points to t0 which is the entire tree *)
*)
Definition insert_inv' (b0: val) (t0: tree val) (x: Z) (v: val): environ -> mpred :=
  EX b: val, EX lock: val, EX lsh: share,
  PROP(readable_share lsh)
  LOCAL(temp _t b; temp _x (Vint (Int.repr x));   temp _value v)
  SEP(nodebox_rep lsh lock b).

Definition insert_inv (b0: val) (lsh0 : share) (lock0 : val) (t0: tree val) (x: Z) (v: val): environ -> mpred :=
  EX b: val, EX lock: val, EX lsh: share,
  PROP(readable_share lsh)
  LOCAL(temp _t b; temp _x (Vint (Int.repr x));   temp _value v)
  SEP(nodebox_rep lsh lock b; nodebox_rep lsh lock b -* nodebox_rep lsh0 lock0 b0).

Lemma ramify_PPQQ {A: Type} {NA: NatDed A} {SA: SepLog A} {CA: ClassicalSep A}: forall P Q,
  P |-- P * (Q -* Q).
Proof.
  intros. Check RAMIF_PLAIN.solve.
  apply RAMIF_PLAIN.solve with emp.
  + rewrite sepcon_emp. auto.
  + rewrite emp_sepcon. auto.
Qed.

Lemma tree_rep_nullval: forall tl t lsh,
  node_rep tl lsh t nullval |-- !! (t = E).
Proof.
  intros.
  destruct t; [entailer! |].
  simpl node_rep.
  Intros pa pb locka lockb. entailer!.
Qed.

#[export] Hint Resolve tree_rep_nullval: saturate_local.

(*Lemma treebox_rep_leaf: forall x p b (v: val),
  is_pointer_or_null v ->
  Int.min_signed <= x <= Int.max_signed ->
  data_at Tsh t_struct_tree (Vint (Int.repr x), (v, (nullval, nullval))) p * data_at Tsh (tptr t_struct_tree) p b |-- treebox_rep (T E x v E) b.
Proof.
  intros.
  unfold treebox_rep, tree_rep. Exists p nullval nullval. entailer!.
Qed.

Lemma bst_left_entail: forall (t1 t1' t2: tree val) k (v p1 p2 p b: val),
  Int.min_signed <= k <= Int.max_signed ->
  is_pointer_or_null v ->
  data_at Tsh (tptr t_struct_tree) p b *
  data_at Tsh t_struct_tree (Vint (Int.repr k), (v, (p1, p2))) p *
  node_rep t1 p1 * node_rep t2 p2
  |-- treebox_rep t1 (field_address t_struct_tree [StructField _left] p) *
       (treebox_rep t1'
         (field_address t_struct_tree [StructField _left] p) -*
        treebox_rep (T t1' k v t2) b).
        Print StructField.
Proof.
  intros.
  unfold_data_at (data_at _ _ _ p). Check field_at_data_at.
  rewrite (field_at_data_at _ t_struct_tree [StructField _left]).
  unfold treebox_rep at 1. Exists p1. cancel.
  Check wand_sepcon_adjoint.
  rewrite <- wand_sepcon_adjoint.
  clear p1.
  unfold treebox_rep.
  Exists p.
  simpl.
  Intros p1.
  Exists p1 p2.
  entailer!.
  unfold_data_at (data_at _ _ _ p).
  rewrite (field_at_data_at _ t_struct_tree [StructField _left]).
  cancel.
Qed.

Lemma bst_right_entail: forall (t1 t2 t2': tree val) k (v p1 p2 p b: val),
  Int.min_signed <= k <= Int.max_signed ->
  is_pointer_or_null v ->
  data_at Tsh (tptr t_struct_tree) p b *
  data_at Tsh t_struct_tree (Vint (Int.repr k), (v, (p1, p2))) p *
  node_rep t1 p1 * node_rep t2 p2
  |-- treebox_rep t2 (field_address t_struct_tree [StructField _right] p) *
       (treebox_rep t2'
         (field_address t_struct_tree [StructField _right] p) -*
        treebox_rep (T t1 k v t2') b).
Proof.
  intros.
  unfold_data_at (data_at _ _ _ p).
  rewrite (field_at_data_at _ t_struct_tree [StructField _right]).
  unfold treebox_rep at 1. Exists p2. cancel.

  rewrite <- wand_sepcon_adjoint.
  clear p2.
  unfold treebox_rep.
  Exists p.
  simpl.
  Intros p2.
  Exists p1 p2.
  entailer!.
  unfold_data_at (data_at _ _ _ p).
  rewrite (field_at_data_at _ t_struct_tree [StructField _right]).
  cancel.
Qed.
*)
Lemma modus_ponens_wand' {A}{ND: NatDed A}{SL: SepLog A}:
  forall P Q R: A, P |-- Q -> P * (Q -* R) |-- R.
Proof.
  intros.
  eapply derives_trans; [| apply modus_ponens_wand].
  apply sepcon_derives; [| apply derives_refl].
  auto.
Qed.

Lemma if_trueb: forall {A: Type} b (a1 a2: A), b = true -> (if b then a1 else a2) = a1.
Proof. intros; subst; auto. Qed.

Lemma if_falseb: forall {A: Type} b (a1 a2: A), b = false -> (if b then a1 else a2) = a2.
Proof. intros; subst; auto. Qed.

Ltac simpl_compb := first [ rewrite if_trueb by (apply Z.ltb_lt; lia)
                          | rewrite if_falseb by (apply Z.ltb_ge; lia)].

Lemma t_lock_exclusive : forall p l,
  exclusive_mpred (t_lock_pred''' Tsh p l).
Proof.
  intros. rewrite t_lock_pred_def. unfold t_lock_pred', t_lock_pred.
  eapply derives_exclusive, exclusive_sepcon1 with
  (P := EX tp : _, field_at Tsh t_struct_tree_t [StructField _t] tp p)
  (Q:=EX t0 : tree val, EX tp : val, node_rep (t_lock_pred'' Tsh) Tsh t0 tp   (* *malloc_token Tsh t_struct_tree_t p1' * malloc_token Tsh tlock l1*)).
  - Intros t0 tp. Exists tp. cancel. Exists t0 tp. apply derives_refl.
  - apply ex_field_at_exclusive.
    auto.
    simpl. lia.
Qed.
(*#[export] Hint Resolve t_lock_exclusive.*)

Lemma body_insert: semax_body Vprog Gprog f_insert insert_spec.
Proof.
  start_function.
  eapply semax_pre; [
    | apply (semax_loop _ (insert_inv b sh lock t x v) (insert_inv b sh lock t x v) )].
  * (* Precondition *)
    unfold insert_inv.
    Exists b lock sh. entailer!. apply wand_refl_cancel_right.
  * (* Loop body *)
    unfold insert_inv.
    Intros b1 lock1 sh1.
    forward. (* Sskip *)
    unfold nodebox_rep at 1. Intros p1.
    forward. (* tgt=*t; *)
      unfold ltree_final. entailer!.
    unfold ltree_final. Intros.
    (*assert_PROP
    (offset_val 4 p1 = field_address (tlock) [StructField _lock] p1).
      1: entailer!. rewrite field_address_offset.
         autorewrite with norm. unfold offset_val.*)
    forward. (* l=tgt->lock *)
      1: rewrite lock_inv_isptr. entailer!.
    forward_call(lock1, sh1, t_lock_pred''' sh1 p1 lock1).   (* acquire(l) *)
    rewrite t_lock_pred_def at 2.  unfold t_lock_pred', t_lock_pred.
    Intros t1 tp.
    forward. (*p=tgt->t*)
    forward_if.
    + (* then clause *)
      subst tp.
      Time forward_call (sizeof t_struct_tree_t).
        1: simpl. rep_lia.
      Intros p1'.
      rewrite memory_block_data_at_ by auto.
      Time forward_call (sizeof t_struct_tree_t).
        1: simpl. rep_lia.
      Intros p2'.
      rewrite memory_block_data_at_ by auto.
      forward. (* p1->t=NULL *)
      simpl.
      forward. (* p1->t=NULL *)
      simpl.
      forward_call (sizeof tlock).
        1: simpl. rep_lia.
      Intros l1.
      rewrite memory_block_data_at_ by auto.
      forward_call(l1, Tsh, t_lock_pred''' Tsh p1' l1).
      forward. (*p1->lock = l1*)
      forward_call(l1, Tsh, t_lock_pred''' Tsh p1' l1).
        { lock_props.
        - rewrite t_lock_pred_def. unfold t_lock_pred', t_lock_pred.
          eapply derives_exclusive, exclusive_sepcon1 with
          (P := EX tp : _, field_at Tsh t_struct_tree_t [StructField _t] tp
          p1')(Q:=EX t0 : tree val, EX tp : val, node_rep (t_lock_pred'' Tsh)
          Tsh t0 tp (* *malloc_token Tsh t_struct_tree_t p1' * malloc_token
          Tsh tlock l1*)).
          Intros t0 tp. Exists tp. cancel. Exists t0 tp. apply derives_refl.
          apply ex_field_at_exclusive. auto. simpl. lia.
        - setoid_rewrite t_lock_pred_def at 2. unfold t_lock_pred',
          t_lock_pred. Exists (E : tree val) (vint 0).
          unfold_data_at 2%nat. cancel. simpl. entailer!. }
      deadvars.
      forward_call (sizeof tlock).
        1: simpl. rep_lia.
      Intros l2.
      rewrite memory_block_data_at_ by auto.
      forward_call(l2, Tsh, t_lock_pred''' Tsh p2' l2).
      forward. (*p2->lock = l2*)
      forward_call(l2, Tsh, t_lock_pred''' Tsh p2' l2).
      { lock_props.
        - rewrite t_lock_pred_def. unfold t_lock_pred', t_lock_pred.
          eapply derives_exclusive, exclusive_sepcon1 with
          (P := EX tp : _, field_at Tsh t_struct_tree_t [StructField _t] tp
          p2')(Q:=EX t0 : tree val, EX tp : val, node_rep (t_lock_pred'' Tsh)
          Tsh t0 tp (* *malloc_token Tsh t_struct_tree_t p1' * malloc_token
          Tsh tlock l1*)).
          Intros t0 tp. Exists tp. cancel. Exists t0 tp. apply derives_refl.
          apply ex_field_at_exclusive. auto. simpl. lia.
        - setoid_rewrite t_lock_pred_def at 3. unfold t_lock_pred',
          t_lock_pred. Exists (E : tree val) (vint 0).
          unfold_data_at 1%nat. cancel. simpl. entailer!. }
      Time forward_call (sizeof t_struct_tree).
        1: simpl. rep_lia.
      Intros p'.
      rewrite memory_block_data_at_ by auto.
      forward. (* tgt->t=p; *)
      forward. (* p->key=x; *)
      forward. (* p->value=value; *)
      forward. (* p->left=NULL; *)
      forward. (* p->right=NULL; *)
      assert_PROP (t1= (@E _)).
        1: entailer!.
      subst t1. simpl node_rep.
      rewrite prop_true_andp by auto.
      forward. (* *t = tgt; *)
      forward_call(lock1, sh1, t_lock_pred''' sh1 p1 lock1).
      { lock_props.
        - rewrite t_lock_pred_def. unfold t_lock_pred', t_lock_pred.
          eapply derives_exclusive, exclusive_sepcon1 with
          (P := EX tp : _, field_at Tsh t_struct_tree_t [StructField _t] tp
          p1)(Q:=EX t0 : tree val, EX tp : val, node_rep (t_lock_pred'' sh1)
          sh1 t0 tp (* *malloc_token Tsh t_struct_tree_t p1' * malloc_token
          Tsh tlock l1*)).
          Intros t0 tp. Exists tp. cancel. Exists t0 tp. apply derives_refl.
          apply ex_field_at_exclusive. auto. simpl. lia.
        - setoid_rewrite t_lock_pred_def at 3. unfold t_lock_pred',
          t_lock_pred. Exists (T E x v E) p'. cancel. unfold node_rep. Exists p1' p2' l1 l2. entailer!. unfold ltree. entailer!. admit.
           }
      forward. (* return; *)
      unfold nodebox_rep. Exists p1. unfold ltree_final. entailer!. cancel. entailer!. admit. (*Stuck1*)
      (*apply treebox_rep_leaf. auto. auto.*)
    + (* else clause *)
      destruct t1.
        { simpl node_rep. normalize. }
      simpl node_rep.
      Intros pa pb locka lockb.
      forward. (* y=p->key; *)
      forward_if; [ | forward_if ].
      - (* Inner if, then clause: x<k *)
        forward. (* t=&p->left *)
        forward_call(lock1, sh1, t_lock_pred''' sh1 p1 lock1).
      { lock_props.
        - rewrite t_lock_pred_def. unfold t_lock_pred', t_lock_pred.
          eapply derives_exclusive, exclusive_sepcon1 with
          (P := EX tp0 : _, field_at Tsh t_struct_tree_t [StructField _t] tp0
          p1)(Q:=EX t0 : tree val, EX tp0 : val, node_rep (t_lock_pred'' sh1)
          sh1 t0 tp0 (* *malloc_token Tsh t_struct_tree_t p1' * malloc_token
          Tsh tlock l1*)).
          Intros t0 tp0. Exists tp0. cancel. Exists t0 tp0.
           apply derives_refl.
          apply ex_field_at_exclusive. auto. simpl. lia.
        - setoid_rewrite t_lock_pred_def. unfold t_lock_pred',
          t_lock_pred. Exists (T t1_1 k v0 t1_2) tp.
          cancel. simpl. entailer!. Exists pa pb locka lockb. cancel. }
          unfold insert_inv.
        Exists (field_address t_struct_tree [StructField _left] tp) locka sh1.
        entailer!. simpl. unfold field_address. simpl. admit. (*Stuck2*)
              rewrite if_true by auto with field_compatible. auto. rep_lia.
        simpl_compb.
        unfold insert_inv.
        Exists (offset_val 8 p1) t1_1. (*why offset 8*)
        entailer!. simpl. Print simpl_compb.
        simpl_compb.
        (* TODO: SIMPLY THIS LINE *)
        Print field_compatible. (*???*)
        replace (offset_val 8 p1)
          with (field_address t_struct_tree [StructField _left] p1)
          by (unfold field_address; simpl;
              rewrite if_true by auto with field_compatible; auto).
        Check RAMIF_PLAIN.trans'.
        apply RAMIF_PLAIN.trans'.
        apply bst_left_entail. auto. auto.
      - (* Inner if, second branch:  k<x *)
        forward. (* t=&p->right *)
        unfold insert_inv.
        Exists (offset_val 12 p1) t1_2.
        entailer!. simpl.
        simpl_compb. simpl_compb. (*boolean comparison*)
        (* TODO: SIMPLY THIS LINE *)
        replace (offset_val 12 p1)
          with (field_address t_struct_tree [StructField _right] p1)
          by (unfold field_address; simpl;
              rewrite if_true by auto with field_compatible; auto).
        apply RAMIF_PLAIN.trans'.
        apply bst_right_entail; auto.
      - (* Inner if, third branch: x=k *)
        assert (x=k) by lia.
        subst x.  clear H H1 H3.
        forward. (* p->value=value *)
        forward. (* return *) simpl.
        (* TODO: SIMPLY THIS LINE *)
        simpl_compb.
        simpl_compb.
        apply modus_ponens_wand'.
        unfold treebox_rep. Exists p1.
        simpl tree_rep. Exists pa pb. entailer!.
  * (* After the loop *)
    forward.
    unfold loop2_ret_assert. apply andp_left2. normalize.
Qed.