Require Import VST.msl.msl_standard.
Require Import VST.msl.Coqlib2.

Module Type ADR_VAL.
Parameter address : Type.
Parameter some_address:address.

(* Validity of traces.  The "valid" predicate ensures that related addresses don't get
    split apart from each other.  *)
Parameter kind: Type.
Parameter valid : (address -> option (pshare * kind)) -> Prop.
Parameter valid_empty: valid (fun _ => None).
Parameter valid_join: forall f g h : address -> option (pshare * kind),
   @join _ (Join_fun address (option (pshare * kind))
                   (Join_lower (Join_prod pshare Join_pshare kind (Join_equiv kind))))
      f g h  ->
 valid f -> valid g -> valid h.
End ADR_VAL.

Module Type ADR_VAL0.
Parameter address : Type.
Parameter some_address:address.
Parameter kind: Type.
End ADR_VAL0.

Module SimpleAdrVal (AV0: ADR_VAL0) <:
   ADR_VAL with Definition address := AV0.address
                   with Definition kind := AV0.kind.
  Import AV0.
  Definition address := address.
  Definition some_address := some_address.
  Definition kind := kind.
  Definition valid (_: address -> option (pshare * kind)) := True.
  Lemma valid_empty: valid (fun _ => None).
  Proof. unfold valid; auto. Qed.
  Lemma valid_join: forall f g h : address -> option (pshare * kind),
   @join _ (Join_fun address (option (pshare * kind))
                   (Join_lower (Join_prod pshare Join_pshare kind (Join_equiv kind))))
      f g h  ->
    valid f -> valid g -> valid h.
  Proof.  intros; unfold valid; auto. Qed.
End SimpleAdrVal.

Fixpoint listprod (ts: list Type) : Type :=
 match ts with
  | nil => unit
  | t :: ts' => prod t (listprod ts')
 end.

Module Type STRAT_MODEL.
  Declare Module AV : ADR_VAL.
  Import AV.

  Definition preds (PRED : Type) : Type :=
    { A: list Type & (listprod A -> PRED) }.

  Definition f_preds : functor preds :=
    f_sigma _ (fun _ => f_fun _ f_identity).
  Existing Instance f_preds.

  Inductive res (PRED : Type) : Type :=
    | NO'
    | YES': pshare -> kind -> preds PRED -> res PRED
    | PURE': kind -> preds PRED -> res PRED.

  Definition res_fmap (A B:Type) (f:A->B) (x:res A) : res B :=
    match x with
      | NO' => NO' B
      | YES' sh k pds => YES' B sh k (fmap f pds)
      | PURE' k pds => PURE' B k (fmap f pds)
    end.
  Axiom ff_res : functorFacts res res_fmap.
  Definition f_res : functor res := Functor ff_res.
  Existing Instance f_res.

  Inductive res_join (PRED : Type) : res PRED -> res PRED -> res PRED -> Prop :=
    | res_join_NO1 : res_join PRED (NO' PRED) (NO' PRED) (NO' PRED)
    | res_join_NO2 : forall sh k p, res_join PRED (NO' PRED) (YES' PRED sh k p) (YES' PRED sh k p)
    | res_join_NO3 : forall sh k p, res_join PRED (YES' PRED sh k p) (NO' PRED) (YES' PRED sh k p)
    | res_join_YES : forall (sh1 sh2 sh3:pshare) k p,
      join sh1 sh2 sh3 ->
      res_join PRED (YES' PRED sh1 k p) (YES' PRED sh2 k p) (YES' PRED sh3 k p)
    | res_join_PURE : forall k p, res_join PRED (PURE' PRED k p) (PURE' PRED k p) (PURE' PRED k p).
  Axiom pa_rj : forall PRED, @Perm_alg _ (res_join PRED).
  Axiom sa_rj : forall PRED, @Sep_alg _ (res_join PRED).
  Axiom ca_rj : forall PRED, @Canc_alg _ (res_join PRED).
  Axiom da_rj : forall PRED, @Disj_alg _ (res_join PRED).
  Axiom paf_res : @pafunctor res f_res res_join.

  Existing Instance paf_res.

  Definition res_option (PRED : Type) (r: res PRED) :=
    match r with
      | NO' => None
      | YES' sh k _ => Some (sh,k)
      | PURE' _ _ => None (* PUREs cannot be split in any interesting way, which is what valid is about. *)
    end.

  Definition valid' A (w: address -> res A) : Prop :=
    AV.valid (fun l => res_option A (w l)).

  Axiom valid'_res_map : forall A B f m, valid' A m -> valid' B (fmap f oo m).

  Definition pre_rmap (A:Type) := { m:address -> res A | valid' A m }.
  Definition f_pre_rmap : functor pre_rmap :=
    f_subset (f_fun _ f_res) _ valid'_res_map.
  Existing Instance f_pre_rmap.

  Axiom valid'_res_map2 : forall A B f m, valid' B (res_fmap A B f oo m) -> valid' A m.

  Instance Join_pre_rmap (A: Type) : Join (pre_rmap A) :=
            Join_prop _ (Join_fun address (res A) (res_join A)) (valid' A).

  Parameter Perm_pre_rmap: forall (A: Type), Perm_alg (pre_rmap A).
  Parameter Sep_pre_rmap: forall (A: Type), Sep_alg (pre_rmap A).
  Parameter Canc_pre_rmap: forall (A: Type), Canc_alg (pre_rmap A).
  Parameter Disj_pre_rmap: forall (A: Type), Disj_alg (pre_rmap A).
  Instance paf_pre_rmap : pafunctor f_pre_rmap :=
    saf_subset  (paf_fun address paf_res) valid' valid'_res_map valid'_res_map2.

End STRAT_MODEL.

Module StratModel (AV' : ADR_VAL) : STRAT_MODEL with Module AV:=AV'.
  Module AV := AV'.
  Import AV.

  Definition preds (PRED : Type) : Type :=
    { A: list Type & (listprod A -> PRED) }.

  Definition f_preds : functor preds :=
    f_sigma _ (fun _ => f_fun _ f_identity).
  Existing Instance f_preds.

  Instance Join_preds (A: Type) : Join (preds A) := Join_equiv _.

  Inductive res (PRED : Type) : Type :=
    | NO'
    | YES': pshare -> kind -> preds PRED -> res PRED
    | PURE': kind -> preds PRED -> res PRED.

  Definition res_fmap (A B:Type) (f:A->B) (x:res A) : res B :=
    match x with
      | NO' => NO' B
      | YES' sh k pds => YES' B sh k (fmap f pds)
      | PURE' k pds => PURE' B k (fmap f pds)
    end.

  Lemma ff_res : functorFacts res res_fmap.
  Proof with auto.
    constructor; intros; extensionality rs; icase rs; unfold res_fmap.
    rewrite fmap_id... rewrite fmap_id...
    rewrite <- fmap_comp... rewrite <- fmap_comp...
  Qed.

  Definition f_res : functor res := Functor ff_res.
  Existing Instance f_res.

  Inductive res_join (PRED : Type) : res PRED -> res PRED -> res PRED -> Prop :=
    | res_join_NO1 : res_join PRED (NO' PRED) (NO' PRED) (NO' PRED)
    | res_join_NO2 : forall sh k p, res_join PRED (NO' PRED) (YES' PRED sh k p) (YES' PRED sh k p)
    | res_join_NO3 : forall sh k p, res_join PRED (YES' PRED sh k p) (NO' PRED) (YES' PRED sh k p)
    | res_join_YES : forall (sh1 sh2 sh3:pshare) k p,
      join sh1 sh2 sh3 ->
      res_join PRED (YES' PRED sh1 k p) (YES' PRED sh2 k p) (YES' PRED sh3 k p)
    | res_join_PURE : forall k p, res_join PRED (PURE' PRED k p) (PURE' PRED k p) (PURE' PRED k p).

 Instance Join_res (PRED: Type) : Join (res PRED) := res_join PRED.

  Instance pa_rj : forall PRED, @Perm_alg _ (res_join PRED).
  Proof. intros. constructor.

      (* saf_eq *)
      intros x y z z' H1 H2; inv H1; inv H2; auto.
      f_equal. eapply join_eq; eauto.

      (* saf_assoc *)
      intros a b c d e H1 H2.
      icase d. exists c. inv H1. inv H2; split; constructor.
      icase c. 3: elimtype False; inv H2. exists b. inv H2. split; auto. icase b. constructor. constructor. inv H1.
      icase b. 3: elimtype False; inv H1. exists (YES' PRED p1 k0 p2). split. constructor. inv H1. apply H2.
      icase a. 3: elimtype False; inv H1. exists e. inv H1. split; auto. icase e. constructor. constructor. inv H2.
      icase e. 3: elimtype False; inv H2. elimtype False. inv H2.
      destruct (@join_assoc _ _ _ p5 p3 p1 p p7) as [sh' [? ?]]. inv H1; auto. inv H2; auto.
      exists (YES' PRED sh' k p0).
      inv H1. inv H2. split; constructor; auto.
      exists (PURE' PRED k p). inv H1. inv H2. split; constructor.

      (* saf_com *)
      intros a b c H; inv H; econstructor.
      apply join_comm; auto.

     intros; inv H; inv H0; auto. f_equal. eapply join_positivity; eauto.
 Qed.

  Instance sa_rj : forall PRED, @Sep_alg _ (res_join PRED).
  Proof. intros.
            apply mkSep with (fun x => match x with NO' => NO' _ | YES' _ _ _ => NO' _ | PURE' k pds => PURE' _ k pds end).
            intro. destruct t; constructor.
            intros. inversion H; auto.
  Defined.

  Instance ca_rj : forall PRED, @Canc_alg _ (res_join PRED).
  Proof. repeat intro. inv H; inv H0; auto.
    apply no_units in H2; contradiction.
    apply no_units in H1; contradiction.
    f_equal; auto. eapply join_canc; eauto.
  Qed.

  Instance da_rj : forall PRED, @Disj_alg _ (res_join PRED).
  Proof.  repeat intro.
    inv H; auto. apply join_self in H2. subst; auto.
  Qed.

  Instance paf_res : @pafunctor res f_res res_join.
  Proof. constructor; repeat intro.
  (* This is a little painful because of the way res_join is defined, but
      whatever... *)
    inv H; simpl; constructor; trivial.
    icase z. exists (NO' _). exists (NO' _). simpl in *. inv H. split. constructor. tauto.
    2: exists (PURE' _ k p); exists (PURE' _ k p); simpl in *; inv H; split; [constructor | tauto].
    icase x'. exists (NO' _). exists (YES' _ p k p0). split. constructor. split; auto. simpl in *; inv H. trivial.
    2: elimtype False; inv H.
    icase y. exists (YES' _ p k p0). exists (NO' _). split. constructor. split; auto. simpl in *. inv H. trivial.
    2: elimtype False; inv H.
    exists (YES' _ p1 k0 p0). exists (YES' _ p3 k1 p0). simpl in *. inv H. split. constructor. trivial. split; congruence.
    icase z'. exists (NO' _). exists (NO' _). simpl. icase x; inv H. split. constructor. tauto.
    destruct x; destruct y; try (elimtype False; inv H; fail).
    exists (YES' _ p1 k0 p2). exists (YES' _ p1 k0 p2). split. constructor. simpl in *. inv H. split; congruence.
    exists (NO' _). exists (YES' _ p1 k0 p2). split. constructor. simpl in *. inv H. split; congruence.
    exists (YES' _ p3 k1 p2). exists (YES' _ p k p2). simpl in *. inv H. split. constructor. trivial. split; congruence.
    destruct x; destruct y; try (elimtype False; inv H; fail). unfold fmap in H. unfold f_res in H. unfold res_fmap in H.
    exists (PURE' _ k0 p0). exists (PURE' _ k0 p0). split. constructor. inv H. simpl. split; congruence.
  Qed.

  Definition res_option (PRED : Type) (r: res PRED) :=
    match r with
      | NO' => None
      | YES' sh k _ => Some (sh,k)
      | PURE' _ _ => None
    end.

  Definition valid' A (w: address -> res A) : Prop :=
    AV.valid (fun l => res_option A (w l)).

  Lemma same_valid : forall f1 f2, (forall x, f1 x = f2 x) -> AV.valid f1 -> AV.valid f2.
  Proof.
    intros; replace f2 with f1; trivial.
    apply extensionality; auto.
  Qed.

  Lemma valid'_res_map : forall A B f m,
    valid' A m -> valid' B (fmap f oo m).
  Proof.
    unfold valid'; intros A B f m.
    apply same_valid; intro l.
    unfold compose.
    destruct (m l); simpl; auto.
  Qed.

  Lemma valid'_res_map2 : forall A B f m,
    valid' B (res_fmap A B f oo m) -> valid' A m.
  Proof.
    unfold valid'; intros A B f m.
    apply same_valid; intro l.
    unfold compose.
    destruct (m l); simpl; auto.
  Qed.

  Definition pre_rmap (A:Type) := { m:address -> res A | valid' A m }.
  Definition f_pre_rmap : functor pre_rmap :=
    f_subset (f_fun _ f_res) _ valid'_res_map.
  Existing Instance f_pre_rmap.

  Instance Join_pre_rmap (A: Type) : Join (pre_rmap A) :=
            Join_prop _ (Join_fun address (res A) (res_join A)) (valid' A).

  Instance paf_pre_rmap : pafunctor f_pre_rmap :=
    saf_subset  (paf_fun address paf_res) valid' valid'_res_map valid'_res_map2.

    Lemma identity_jres : forall PRED (r : res PRED),
      identity r <-> (r = NO' PRED) \/ (exists k, exists pds, r = PURE' _ k pds).
    Proof.
      split; intros.
      rewrite identity_unit_equiv in H.
      inv H; auto. elim (pjoin_unit H3).
      right. exists k. exists p. trivial.
      rewrite identity_unit_equiv.
      destruct H as [? | [k [pds ?]]]; subst r; constructor.
    Qed.

  Lemma pre_rmap_sa_valid_core (A: Type):
        forall x : address -> res A,
       valid' A x ->
       valid' A  (@core (address -> res A) (Join_fun address (res A) (res_join A))
                     (Sep_fun address (res A) (res_join A) (sa_rj A)) x).
  Proof.
    intros. red. red.
    replace (fun l => res_option A (core x l)) with (fun l : address => @None (pshare * kind)).
    apply AV.valid_empty.
    extensionality a. simpl. icase (x a).
  Qed.

  Lemma pre_rmap_sa_valid_join : forall A (x y z : address -> res A),
    @join _ (Join_fun address (res A) (res_join A)) x y z ->
    valid' A x -> valid' A y -> valid' A z.
  Proof.
     intros.
     simpl in H.
     unfold valid' in *.
     apply AV.valid_join with (fun l => res_option A (x l)) (fun l => res_option A (y l)); auto.
     intro l. spec H l. inv H; try constructor. split; simpl; auto.
  Qed.

  Definition Perm_pre_rmap (A: Type): Perm_alg (pre_rmap A) :=
    Perm_prop _ _ (Perm_fun address _ _ _) _ (pre_rmap_sa_valid_join _).

  Definition Sep_pre_rmap (A: Type): Sep_alg (pre_rmap A) :=
    Sep_prop _ _ (Perm_fun address _ _ _) _ (pre_rmap_sa_valid_join _)  _ (pre_rmap_sa_valid_core _).

  Definition Canc_pre_rmap (A: Type): Canc_alg (pre_rmap A) :=
    @Canc_prop _ _ _ (Canc_fun address _ _ _).

  Definition Disj_pre_rmap (A: Type): Disj_alg (pre_rmap A) :=
    @Disj_prop _ _ _ (Disj_fun address _ _ _).

End StratModel.

Open Local Scope nat_scope.

Module Type RMAPS.
  Declare Module AV:ADR_VAL.
  Import AV.

  Parameter rmap : Type.
  Axiom Join_rmap: Join rmap. Existing Instance Join_rmap.
  Axiom Perm_rmap: Perm_alg rmap. Existing Instance Perm_rmap.
  Axiom Sep_rmap: Sep_alg rmap. Existing Instance Sep_rmap.
  Axiom Canc_rmap: Canc_alg rmap.  Existing Instance Canc_rmap.
  Axiom Disj_rmap: Disj_alg rmap.  Existing Instance Disj_rmap.
  Axiom ag_rmap: ageable rmap.  Existing Instance ag_rmap.
  Axiom Age_rmap: Age_alg rmap.  Existing Instance Age_rmap.

  Inductive preds : Type :=
    SomeP : forall A : list Type, (listprod A -> pred rmap) -> preds.

  Definition NoneP := SomeP ((Void:Type)::nil) (fun _ => FF).
  Definition hair := preds.

  Inductive resource : Type :=
    | NO
    | YES: pshare -> kind -> preds -> resource
    | PURE: kind -> preds -> resource.

  Definition res_option (r:resource) :=
    match r with
      | NO => None
      | YES sh k _ => Some (sh,k)
      | PURE k _ => None
    end.

  Inductive res_join : resource -> resource -> resource -> Prop :=
   | res_join_NO1 : res_join NO NO NO
   | res_join_NO2 : forall sh k p, res_join (YES sh k p) NO (YES sh k p)
   | res_join_NO3 : forall sh k p, res_join NO (YES sh k p) (YES sh k p)
   | res_join_YES : forall (sh1 sh2 sh3:pshare) k p,
        join sh1 sh2 sh3 ->
        res_join (YES sh1 k p) (YES sh2 k p) (YES sh3 k p)
   | res_join_PURE : forall k p, res_join (PURE k p) (PURE k p) (PURE k p).

  Instance Join_resource: Join resource := res_join.
  Axiom Perm_resource: Perm_alg resource. Existing Instance Perm_resource.
  Axiom Sep_resource: Sep_alg resource. Existing Instance Sep_resource.
  Axiom Canc_resource: Canc_alg resource. Existing Instance Canc_resource.
  Axiom Disj_resource: Disj_alg resource. Existing Instance Disj_resource.

  Definition preds_fmap (f:pred rmap -> pred rmap) (x:preds) : preds :=
    match x with SomeP A Q => SomeP A (f oo Q)
    end.
  Axiom preds_fmap_id : preds_fmap (id _) = id preds.
  Axiom preds_fmap_comp : forall f g, preds_fmap g oo preds_fmap f = preds_fmap (g oo f).

  Definition resource_fmap (f:pred rmap -> pred rmap) (x:resource) : resource :=
    match x with
    | NO => NO
    | YES sh k p => YES sh k (preds_fmap f p)
    | PURE k p => PURE k (preds_fmap f p)
    end.
  Axiom resource_fmap_id : resource_fmap (id _) = id resource.
  Axiom resource_fmap_comp : forall f g, resource_fmap g oo resource_fmap f = resource_fmap (g oo f).

  Definition valid (m: address -> resource) : Prop :=
    AV.valid  (res_option oo m).

  Axiom valid_res_map : forall f m, valid m -> valid (resource_fmap f oo m).
  Axiom rmapj_valid_join : forall (x y z : address -> resource),
    join x y z -> valid x -> valid y -> valid z.
  Axiom rmapj_valid_core: forall x: address -> resource, valid x -> valid (core x).

  Definition rmap' := sig valid.

  Definition rmap_fmap (f: pred rmap -> pred rmap) (x:rmap') : rmap' :=
    match x with exist m H => exist (fun m => valid m) (resource_fmap f oo m) (valid_res_map f m H) end.
  Axiom rmap_fmap_id : rmap_fmap (id _) = id rmap'.
  Axiom rmap_fmap_comp : forall f g, rmap_fmap g oo rmap_fmap f = rmap_fmap (g oo f).

  Parameter squash : (nat * rmap') -> rmap.
  Parameter unsquash : rmap -> (nat * rmap').

  Axiom rmap_level_eq: @level rmap _ = fun x => fst (unsquash x).
  Axiom rmap_age1_eq: @age1 _ _ =
     fun k => match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.

  Definition resource_at (phi:rmap) : address -> resource := proj1_sig (snd (unsquash phi)).
  Infix "@" := resource_at (at level 50, no associativity).

  Instance Join_nat_rmap': Join (nat * rmap') := Join_prod _ (Join_equiv nat) _ _.

  Axiom join_unsquash : forall phi1 phi2 phi3,
    join phi1 phi2 phi3 <->
    join (unsquash phi1) (unsquash phi2) (unsquash phi3).

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

  Program Definition approx (n:nat) (p: pred rmap) : pred rmap :=
    fun w => level w < n /\ p w.
  Next Obligation.
  destruct H0.
  split.
  apply age_level in H. omega.
  apply pred_hereditary with a; auto.
  Qed.

  Axiom squash_unsquash : forall phi, squash (unsquash phi) = phi.
  Axiom unsquash_squash : forall n rm, unsquash (squash (n,rm)) = (n,rmap_fmap (approx n) rm).

End RMAPS.

Module Rmaps (AV':ADR_VAL) : RMAPS with Module AV:=AV'.
  Module AV:=AV'.
  Import AV.

  Module SM := StratModel(AV).
  Import SM.

  Module TyF. (* <: TY_FUNCTOR_PROP. *)
    Definition F := pre_rmap.
    Definition f_F := f_pre_rmap.

    Definition other := unit.

  End TyF.

  Module TyFSA. (* <: TY_FUNCTOR_SA_PROP with Module TF:=TyF. *)
    Module TF := TyF.
    Import TF.

  Instance Join_F: forall A, Join (F A) := _.
  Definition Perm_F : Perm_paf f_F Join_F := fun A _ _ => Perm_pre_rmap A.
  Definition Sep_F : Sep_paf f_F Join_F := fun (A : Type) (JA : Join A) _ _ => Sep_pre_rmap A.
  Definition Canc_F : Canc_paf f_F Join_F := fun (A : Type) (JA : Join A) _ _ => Canc_pre_rmap A.
  Definition Disj_F : Disj_paf f_F Join_F := fun (A : Type) (JA : Join A) _ _ => Disj_pre_rmap A.
  Definition paf_F := paf_pre_rmap.
 End TyFSA.

  Module K := KnotHered(TyF).
  Module KL := KnotHered_Lemmas(K).
  Module KSa := KnotHeredSa(TyFSA)(K).

  Definition rmap := K.knot.
  Instance Join_rmap: Join rmap := KSa.Join_knot.
  Instance Perm_rmap : Perm_alg rmap:= KSa.Perm_knot.
  Instance Sep_rmap : Sep_alg rmap:= KSa.Sep_knot Sep_pre_rmap.
  Instance Canc_rmap : Canc_alg rmap:= KSa.Canc_knot Canc_pre_rmap.
  Instance Disj_rmap : Disj_alg rmap:= KSa.Disj_knot Disj_pre_rmap.
  Instance ag_rmap : ageable rmap := KSa.K.ag_knot.
  Instance Age_rmap: Age_alg rmap := KSa.asa_knot.

  Inductive preds : Type :=
    SomeP : forall A : list Type, (listprod A -> pred rmap) -> preds.

  Definition NoneP := SomeP ((Void:Type)::nil) (fun _ => FF).

  Definition hair := preds.

  Inductive resource : Type :=
    | NO
    | YES: pshare -> kind -> preds -> resource
    | PURE : kind -> preds -> resource.

  Definition resource2res (r: resource): res (pred rmap) :=
    match r with
      | NO => NO' (pred rmap)
      | YES p k (SomeP A l) => YES' (pred rmap) p k (existT _ A l)
      | PURE k (SomeP A l) => PURE' (pred rmap) k (existT _ A l)
    end.

  Definition res2resource (r: res (pred rmap)) : resource :=
    match r with
      | NO' => NO
      | YES' p k (existT A l) => YES p k (SomeP A l)
      | PURE' k (existT A l) => PURE k (SomeP A l)
    end.

  Lemma res2resource2res: forall x, resource2res (res2resource x) = x.
  Proof. unfold resource2res, res2resource; destruct x; try destruct p0; try destruct p; auto. Qed.

  Lemma resource2res2resource: forall x, res2resource (resource2res x) = x.
  Proof. unfold resource2res, res2resource; destruct x; try destruct p0; try destruct p; auto. Qed.

  Definition res_option (r:resource) :=
    match r with
      | NO => None
      | YES sh k _ => Some (sh,k)
      | PURE _ _ => None
    end.

  Lemma res_option_rewrite: res_option = SM.res_option (pred rmap) oo resource2res.
  Proof. extensionality r; destruct r; auto. destruct p0; auto. destruct p; auto. Qed.

  Definition valid (m: address -> resource) : Prop :=
    AV.valid (res_option oo m).

  Inductive res_join : resource -> resource -> resource -> Prop :=
   | res_join_NO1 : res_join NO NO NO
   | res_join_NO2 : forall sh k p, res_join (YES sh k p) NO (YES sh k p)
   | res_join_NO3 : forall sh k p, res_join NO (YES sh k p) (YES sh k p)
   | res_join_YES : forall (sh1 sh2 sh3:pshare) k p,
        join sh1 sh2 sh3 ->
        res_join (YES sh1 k p) (YES sh2 k p) (YES sh3 k p)
   | res_join_PURE : forall k p, res_join (PURE k p) (PURE k p) (PURE k p).

  Instance Join_resource: Join resource := res_join.
  Instance Perm_resource: Perm_alg resource.
  Proof. constructor.

      (* saf_eq *)
      intros x y z z' H1 H2; inv H1; inv H2; auto.
      replace sh5 with sh3; auto.
      eapply join_eq; eauto.

      (* saf_assoc *)
      intros a b c d e H1 H2.
      destruct d. exists c. inv H1. inv H2; split; constructor.
      2: exists (PURE k p); inv H1; inv H2; split; constructor.
      destruct e; try (elimtype False; inv H2; fail).
      destruct c. exists b. inv H2. split; auto. destruct b; try constructor. inv H1.
      2: elimtype False; inv H2.
      destruct b. exists (YES p3 k1 p4). split. constructor. inv H1. trivial.
      2: elimtype False; inv H1.
      destruct a. exists (YES p1 k0 p2). inv H1. split; trivial. constructor.
      2: elimtype False; inv H1.
      destruct (@join_assoc _ _ _ p7 p5 p3 p p1) as [sh' [? ?]].
      inv H1; auto. inv H2; auto.
      exists (YES sh' k p0). inv H1. inv H2. split; constructor; trivial.

      (* saf_com *)
      intros a b c H; inv H; econstructor.
      apply join_comm; auto.

      (* positivity *)
      intros. inv H; inv H0; auto. f_equal. eapply join_positivity; eauto.
  Qed.

  Instance Sep_resource: Sep_alg resource.
  Proof.
    apply mkSep with (fun x => match x with NO => NO | YES _ _ _ => NO | PURE k pds => PURE k pds end).
    intros; destruct t; constructor.
    intros; inv H; auto.
  Defined.

  Instance Canc_resource: Canc_alg resource.
  Proof.
      intros a1 a2 b c H1 H2; inv H1; inv H2; auto.
      elim (pjoin_unit H1).
      elim (pjoin_unit H).
      f_equal.
      eapply join_canc; eauto.
  Qed.

  Instance Disj_resource: Disj_alg resource.
  Proof.
    repeat intro. inv H; auto. f_equal. apply join_self; auto.
  Qed.

  Lemma identity_resource : forall r,
    identity r <-> (r = NO) \/ (exists k, exists pds, r = PURE k pds).
  Proof.
    split; intros.
    rewrite identity_unit_equiv in H.
    inv H; auto.
    elim (pjoin_unit H3). right. exists k. exists p. trivial.
    rewrite identity_unit_equiv; destruct H as [? | [? [? ?]]]; subst r; constructor.
  Qed.

  Lemma same_valid : forall f1 f2, (forall x, f1 x = f2 x) -> AV.valid f1 -> AV.valid f2.
  Proof.
    intros; replace f2 with f1; trivial.
    apply extensionality; auto.
  Qed.

  Lemma rmapj_valid_core: forall x : address -> resource, valid x -> valid (core x).
  Proof.
     unfold valid, compose; intros. red. red.
     replace (fun x0 => res_option (core x x0)) with (fun _ : address => @None (pshare * kind)).
     apply AV.valid_empty.
     extensionality a. simpl. icase (x a).
  Qed.

  Lemma rmapj_valid_join : forall (x y z : address -> resource),
    join x y z ->
    valid x -> valid y -> valid z.
  Proof.
     intros.
     simpl in H.
     unfold valid, compose in *.
     apply AV.valid_join with (fun l => res_option (x l)) (fun l => res_option (y l)); auto.
     intro l. specialize (H l). inv  H; eauto. constructor. constructor. constructor.
     constructor. constructor. apply H5. split; auto.
     constructor.
  Qed.

  Definition rmap' := sig valid.
  Definition preds_fmap (f:(pred rmap)->(pred rmap)) (x:preds) : preds :=
    match x with SomeP A ls => SomeP A (f oo ls) end.

  Lemma preds_fmap_id : preds_fmap (id (pred rmap)) = id preds.
  Proof.
    intros; apply extensionality; intro x; destruct x; simpl; auto;
   (* the rest of this is for compatibility with Coq 8.3 *)
    replace (id (pred rmap) oo p) with p; auto;
    rewrite id_unit2; auto.
  Qed.

  Lemma preds_fmap_comp : forall f g, preds_fmap g oo preds_fmap f = preds_fmap (g oo f).
  Proof.
    intros; apply extensionality; intro x; destruct x; simpl; auto.
  Qed.

  Definition resource_fmap (f:(pred rmap)->(pred rmap)) (x:resource) : resource :=
    match x with
    | NO => NO
    | YES sh k p => YES sh k (preds_fmap f p)
    | PURE k p => PURE k (preds_fmap f p)
    end.

  Lemma valid_res_map : forall f m, valid m -> valid (resource_fmap f oo m).
  Proof.
    unfold valid, compose; intros.
    replace (fun l : address => res_option (resource_fmap f (m l)))
       with (fun l : address => res_option (m l)); auto.
    extensionality l.
    unfold res_option, resource_fmap.
    case (m l); auto.
  Qed.

  Lemma resource_fmap_id : resource_fmap (id (pred rmap)) = id resource.
  Proof.
    intros; apply extensionality; intro x.
    unfold resource_fmap.
    destruct x; simpl; auto.
    rewrite preds_fmap_id; auto.
    rewrite preds_fmap_id; auto.
  Qed.

  Lemma resource_fmap_comp : forall f g, resource_fmap g oo resource_fmap f = resource_fmap (g oo f).
  Proof.
    intros f g.
    apply extensionality; intro x; destruct x; simpl; auto.
    unfold compose at 1; simpl.
    rewrite <- preds_fmap_comp; auto.
    rewrite <- preds_fmap_comp; auto.
  Qed.

  Definition rmap_fmap (f:(pred rmap)->(pred rmap)) (x:rmap') : rmap' :=
    match x with exist m H => exist (fun m => valid m) (resource_fmap f oo m) (valid_res_map f m H) end.

  Lemma rmap_fmap_id : rmap_fmap (id (pred rmap)) = id rmap'.
  Proof.
    intros; apply extensionality; intro x.
    unfold rmap_fmap; destruct x.
    unfold id at 3.
    generalize (valid_res_map (id _) x v).
    rewrite (resource_fmap_id).
    simpl.
    rewrite (id_unit2 _ (resource) x).
    intro v0. f_equal; auto.
    apply proof_irr.
  Qed.

  Lemma rmap_fmap_comp : forall f g, rmap_fmap g oo rmap_fmap f = rmap_fmap (g oo f).
  Proof.
    intros f g.
    unfold rmap_fmap.
    apply extensionality; intro x.
    unfold compose at 1.
    destruct x.
    generalize (valid_res_map g (resource_fmap f oo x) (valid_res_map f x v)).
    generalize (valid_res_map (g oo f) x v).
    clear.
    assert (resource_fmap g oo resource_fmap f oo x = resource_fmap (g oo f) oo x).
    rewrite <- compose_assoc.
    rewrite resource_fmap_comp; auto.
    rewrite H.
    intros.
    intros; f_equal; proof_irr; auto.
  Qed.

  Definition rmap'2pre_rmap (r: rmap') : pre_rmap (pred rmap).
    destruct r as [f ?].
    unfold pre_rmap.
    assert (valid' _ (fun x: address => resource2res (f x))).
    unfold valid'. unfold valid, compose in v.
    eapply same_valid; try apply v.
    intros. simpl.
    destruct (f x); simpl; auto. destruct p0; simpl; auto. destruct p; simpl; auto.
    eauto.
  Defined.

  Definition pre_rmap2rmap' (r: pre_rmap (pred rmap)) : rmap'.
    destruct r as [f ?].
    unfold rmap', valid' in *.
    assert (valid (fun l: address => res2resource (f l))).
    unfold valid, compose.
    replace (fun l : address => res_option (res2resource (f l))) with (fun l : address => SM.res_option (pred rmap) (f l)); auto.
    extensionality l. rewrite res_option_rewrite.
    unfold compose; simpl. rewrite res2resource2res. auto.
    eauto.
  Defined.

  Lemma rmap'2pre_rmap2rmap' :
    forall x, rmap'2pre_rmap (pre_rmap2rmap' x) = x.
  Proof.
    intro. destruct x as [f V]. unfold rmap'2pre_rmap, pre_rmap2rmap'. simpl.
    match goal with |- exist _ _ ?p = _ => generalize p; intro p1 end.
    apply exist_ext.
    extensionality x; rewrite res2resource2res; auto.
  Qed.

  Lemma pre_rmap2rmap'2pre_rmap :
    forall x,  pre_rmap2rmap' (rmap'2pre_rmap x) = x.
  Proof.
    intro.
    destruct x as [f V].
    unfold rmap'2pre_rmap, pre_rmap2rmap'. simpl.
    match goal with |- exist _ _ ?p = _ => generalize p; intro p1 end.
    apply exist_ext.
    extensionality x; rewrite resource2res2resource; auto.
  Qed.

  Program Definition p2p (p:(pred rmap)) : K.predicate :=
    fun phi_e => p (fst phi_e).
  Next Obligation.
    destruct a as [a b]; destruct a' as [a' b'].
    unfold age, age1 in H. simpl in H. invSome. simpl in *.
    eapply pred_hereditary; eauto.
 Qed.

  Program Definition p2p' (p:K.predicate) : (pred rmap) :=
    fun (v:rmap) => p (v, tt).
  Next Obligation.
  unfold age in H; simpl in H.
  unfold rmap in *.
  eapply pred_hereditary; eauto.
  unfold age, age1; simpl.
  unfold ag_rmap in H. rewrite H. auto.
 Qed.

  Definition squash (n_rm:nat * rmap') : rmap :=
    match n_rm with (n,rm) => K.squash (n, fmap p2p (rmap'2pre_rmap rm)) end.

  Definition unsquash (phi:rmap) : (nat * rmap') :=
    match K.unsquash phi with (n,rm) => (n, pre_rmap2rmap' (fmap p2p' rm)) end.

  Definition rmap_level (phi:rmap) : nat := fst (unsquash phi).
  Definition resource_at (phi:rmap) : address -> resource := proj1_sig (snd (unsquash phi)).
  Infix "@" := resource_at (at level 50, no associativity).

  Lemma pred_ext': forall {A} `{agA: ageable A} P Q,
                (forall x, app_pred P x <-> app_pred Q x) -> P = Q.
  Proof. intros; apply pred_ext; intro; apply H; auto. Qed.

  Lemma squash_unsquash : forall phi, squash (unsquash phi) = phi.
  Proof.
    intros.
    unfold squash, unsquash; simpl.
    case_eq (K.unsquash phi); simpl; intros.
    rewrite rmap'2pre_rmap2rmap'.
    match goal with [ |- K.squash (n,?X) = _ ] =>
      change X with
        ((fmap p2p oo fmap p2p') f)
    end.
    rewrite fmap_comp.
    replace (p2p oo p2p') with (id K.predicate).
    rewrite fmap_id.
    unfold id.
    unfold TyF.F in *.
    rewrite <- H.
    rewrite K.squash_unsquash; auto.
    extensionality p.
    apply pred_ext'. intro x.
    destruct x as [k e].
    unfold compose, p2p, p2p'; simpl.
    unfold id.
    destruct e; intuition.
  Qed.

  Program Definition approx (n:nat) (p: (pred rmap)) : (pred rmap) :=
    fun w => level w < n /\ p w.
  Next Obligation.
  destruct H0.
  split.
  apply age_level in H.
  simpl in *. omega.
  apply pred_hereditary with a; auto.
  Qed.

  Lemma unsquash_squash : forall n rm, (unsquash (squash (n,rm))) = (n,rmap_fmap (approx n) rm).
  Proof.
    intros.
    unfold unsquash, squash.
    rewrite K.unsquash_squash; simpl.
    match goal with [|- (_,?X) = (_,?Y) ] =>
      replace Y with X; auto
    end.
    match goal with [|- pre_rmap2rmap' ?X = _ ] =>
      replace X with
        (fmap (p2p' oo K.approx n oo p2p) (rmap'2pre_rmap rm))
    end.
    2: repeat rewrite <- fmap_comp.
    2: unfold compose; auto.
    destruct rm; simpl.
    apply exist_ext.
    extensionality l.
    unfold compose.
    destruct (x l); simpl; auto.
    (* YES *)
    destruct p0; simpl.
    f_equal. f_equal.
    extensionality a.
    apply pred_ext'; intro w.
    unfold p2p', p2p, approx, compose; simpl.
    unfold app_pred at 1.
    rewrite K.approx_spec.
    unfold fidentity_fmap;
    unfold rmap_level, unsquash; simpl;
    repeat rewrite K.knot_level;
    repeat rewrite setset, setget;     intuition.
    (* PURE *)
    destruct p; simpl.
    f_equal. f_equal.
    extensionality a.
    apply pred_ext'; intro w.
    unfold p2p', p2p, approx, compose; simpl.
    unfold app_pred at 1.
    rewrite K.approx_spec.
    unfold fidentity_fmap;
    unfold rmap_level, unsquash; simpl;
    repeat rewrite K.knot_level;
    repeat rewrite setset, setget;     intuition.
  Qed.

  Instance Join_nat_rmap': Join (nat * rmap') := Join_prod _ (Join_equiv nat) _ _.

Lemma fmap_p2p'_inj:
  forall p q,
        @fmap SM.preds f_preds K.predicate (@pred rmap ag_rmap) p2p' p =
        @fmap SM.preds f_preds K.predicate (@pred rmap ag_rmap) p2p' q ->
        p=q.
Proof.
  intros.
  destruct p as [p Vp]. destruct q as [q Vq].
  unfold fmap in *. unfold f_preds in *. simpl in *.
  inv H.
  f_equal.
  apply inj_pair2 in H2. unfold ffun_fmap, f_identity in *.
  unfold fmap, compose in H2.
  extensionality w.
 apply equal_f with w in H2. unfold fidentity_fmap in *.
  unfold p2p' in *. inv H2.
  unfold K.predicate in *.
  apply pred_ext'. intros [k o]. destruct o.
  apply equal_f with k in H0. rewrite H0; intuition.
Qed.

  Lemma join_unsquash : forall phi1 phi2 phi3,
    join phi1 phi2 phi3 <->
    join (unsquash phi1) (unsquash phi2) (unsquash phi3).
  Proof.
    intros.
    unfold unsquash.
    rewrite KSa.join_unsquash.
    destruct (K.unsquash phi1).
    destruct (K.unsquash phi2).
    destruct (K.unsquash phi3).
    simpl; intuition.
    destruct H; simpl in *; split; simpl; auto.
    intro l; spec H0 l.
    destruct f as [f ?].
    destruct f0 as [f0 ?].
    destruct f1 as [f1 ?].
    simpl in *.
    unfold compose.
    inv H0; simpl.
    constructor. destruct p. simpl in *. constructor. destruct p. simpl in *. constructor.
    destruct p; simpl in *.
    constructor; auto.
    destruct p; simpl in *.
    constructor; auto.

    destruct H; simpl in *; split; simpl; auto.
    destruct f as [f ?].
    destruct f0 as [f0 ?].
    destruct f1 as [f1 ?].
    hnf in H0. simpl proj1_sig in H0.
    intro l; spec H0 l.
    simpl proj1_sig.
    clear - H0.
    forget (f l) as a; forget (f0 l) as b; forget (f1 l) as c.
    clear - H0.
    unfold res2resource in *. unfold res_fmap in *.
    destruct a as [|sha ka pa|ka pa]; try (remember (fmap p2p' pa) as fa; destruct fa);
    destruct b as [|shb kb pb|kb pb]; try (remember (fmap p2p' pb) as fb; destruct fb);
    destruct c as [|shc kc pc|kc pc]; try (remember (fmap p2p' pc) as fc; destruct fc);
    inv H0.
    constructor.
    apply inj_pair2 in H7. subst p0.
    replace pb with pc; [ constructor |].
    rewrite Heqfb in Heqfc. clear - Heqfc.
    apply fmap_p2p'_inj ; auto.
    apply inj_pair2 in H7. subst p0. rewrite Heqfa in Heqfc; clear - Heqfc.
    apply fmap_p2p'_inj in Heqfc. subst; constructor.
   subst x1. apply inj_pair2 in H11. subst p1. apply inj_pair2 in H7; subst p0.
   rewrite Heqfa in Heqfc, Heqfb; clear Heqfa.
    apply fmap_p2p'_inj in Heqfc.
     apply fmap_p2p'_inj in Heqfb. subst. subst. constructor. auto.
    subst x1. apply inj_pair2 in H8. subst p1. apply inj_pair2 in H5. subst p0.
   rewrite Heqfa in Heqfc, Heqfb; clear Heqfa.
    apply fmap_p2p'_inj in Heqfc.
     apply fmap_p2p'_inj in Heqfb. subst. subst. constructor.
Qed.

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

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

  Lemma rmap_age1_knot_age1 :
    rmap_age1 = @age1 _ K.ag_knot.
  Proof.
    extensionality x.
    unfold rmap_age1.
    rewrite  K.knot_age1.
    unfold unsquash, squash.
    case (K.unsquash x); simpl; intros.
    destruct n; auto.
    rewrite rmap'2pre_rmap2rmap'.
    f_equal. f_equal. f_equal.
    change ((fmap p2p oo fmap p2p') f = f).
    rewrite fmap_comp.
    replace (p2p oo p2p') with (id K.predicate).
    rewrite fmap_id; auto.

    extensionality p; apply pred_ext'; intro a; simpl.
    destruct a; unfold id; simpl.
    unfold compose.
    unfold p2p. unfold p2p'. simpl.
    unfold TyF.other in *. destruct o. intuition.
  Qed.

  Lemma rmap_age1_eq: @age1 _ ag_rmap = rmap_age1.
  Proof.
   unfold age1. unfold ag_rmap; simpl; auto.
   rewrite rmap_age1_knot_age1; reflexivity.
  Qed.

  Lemma rmap_level_eq: @level rmap ag_rmap = fun x => fst (unsquash x).
  Proof.
    intros.
   extensionality x.  unfold level.  unfold ag_rmap.
   unfold KSa.K.ag_knot. unfold unsquash.
   rewrite K.knot_level. destruct (K.unsquash x); simpl. auto.
  Qed.

  Lemma unevolve_identity_rmap :
   (* REMARK:  This may not be needed for anything, so for now it's removed
     from the Module Type *)
    forall w w':rmap, necR w w' -> identity w' -> identity w.
  Proof.
    intros.
    induction H; eauto.
    rewrite identity_unit_equiv in H0.
    rewrite identity_unit_equiv.
    red in H0. red.
    rewrite join_unsquash in H0.
    rewrite join_unsquash.
    hnf in H. unfold rmap, ag_rmap in H. rewrite <- rmap_age1_knot_age1 in H.
    unfold rmap_age1 in H.
   destruct (unsquash x).
   destruct n. inv H.
    assert (y = squash (n,r)).
    inv H; auto.
    subst y.
    rewrite unsquash_squash in H0.
    destruct H0; split;  simpl fst in *; simpl snd in *; try split; auto.
    intro l; spec H1 l.
    destruct r.
    simpl in *.
    unfold compose in *.
    destruct (x0 l); simpl in *.
    constructor.
    inv H1. constructor; auto.
    constructor.
  Qed.

End Rmaps.
Local Close Scope nat_scope.


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 A0 A1 B P Q R A C X : Universe, ((wd_ B A0 /\ (wd_ A0 A1 /\ (wd_ A0 O /\ (wd_ A1 O /\ (wd_ P Q /\ (wd_ R Q /\ (wd_ O B /\ (wd_ C O /\ (wd_ A1 A /\ (wd_ X A1 /\ (wd_ O A /\ (wd_ A0 A /\ (wd_ X O /\ (wd_ A0 C /\ (col_ A0 X A /\ (col_ A0 A B /\ (col_ A0 A1 B /\ (col_ O X A1 /\ col_ O A C)))))))))))))))))) -> col_ A0 O A)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Logic.Classical_Prop.
Require Import Logic.lib.Coqlib.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Model.OSAExamples.
Require Import Logic.SeparationLogic.Model.OSAGenerators.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.
Require Import Logic.HoareLogic.ImperativeLanguage.
Require Import Logic.HoareLogic.ProgramState.
Require Import Logic.HoareLogic.BigStepSemantics.
Require Import Logic.HoareLogic.TraceSemantics.
Require Import Logic.HoareLogic.HoareTriple_BigStepSemantics.
Require Import Logic.HoareLogic.GuardedHoareTriple_TraceSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelSingleNotation.
Import KripkeModelNotation_Intuitionistic.

Lemma start_by_Aacq_or_Arel {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res} {nAcr: NormalAction_resource Ac Res}: forall r tr, start_by_Aacq r tr -> start_by_Arel r tr -> False.
Proof.
  intros.
  induction tr.
  + inversion H0.
  + destruct (classic (is_resource_action r a)) as [[? | ?] | ?]; subst.
    - inversion H0; subst; solve_resource_action.
    - inversion H; subst; solve_resource_action.
    - inversion H; subst; solve_resource_action.
      inversion H0; subst; solve_resource_action.
      auto.
Qed.

Lemma start_by_Aacq_trace_acc_spec {state: Type} {Ac: Action} {Res: Resource} {J: Join state} {state_R: Relation state} {Acr: Action_resource Ac Res} {nAcr: NormalAction_resource Ac Res} {ac_sem: ActionInterpret (resources * state) Ac} {AIr: ActionInterpret_resource state Ac Res ac_sem}: forall (Inv: resource * (state -> Prop) -> Prop) (tr: trace) A1 A2 s1 s2,
  (forall r, start_by_Aacq r tr) ->
  @trace_access _ _ (ThreadLocal_ActionInterpret_resource _ Inv) tr (A1, s1) (Terminating (A2, s2)) ->
  A1 = A2.
Proof.
  intros.
  assert (join A2 (fun r => start_by_Arel r tr) A1).
  2: {
    extensionality r; apply prop_ext.
    specialize (H r); specialize (H1 r).
    pose proof start_by_Aacq_or_Arel r tr.
    destruct H1; tauto.
  }
  assert (forall r, start_by_Aacq r tr \/ start_by_Arel r tr).
  {
    intros r.
    specialize (H r).
    auto.
  }
  clear H.
  revert s1 A1 H0; induction tr; intros.
  + inversion H0; subst; clear H0.
    clear - nAcr.
    intros r.
    pose proof start_by_Aacq_or_Arel r nil.
    pose proof start_by_Aacq_nil r.
    split; tauto.
  + inversion H0; subst; clear H0.
    destruct s' as [A1' s1'].
    specialize (fun HH => IHtr HH s1' A1' H6); clear H6.
    simpl in H3.
    assert (HH: forall r : resource, start_by_Aacq r tr \/ start_by_Arel r tr).
    {
      clear - nAcr H1.
      intros r; specialize (H1 r).
      destruct (classic (is_resource_action r a)) as [[? | ?] | ?]; subst;
      destruct H1 as [HH | HH]; inversion HH; auto.
    }
    specialize (IHtr HH); clear HH.
    intros r; specialize (IHtr r); specialize (H1 r).
    destruct (classic (is_resources_action a)) as [[?r [? | ?]] | ?]; subst.
    - inversion H3; subst; clear H3; solve_resource_action.
      clear I f H7 H8 H9.
      specialize (H6 r).
      pose proof start_by_Aacq_or_Arel r (Aacquire_res r0 :: tr).
      pose proof start_by_Aacq_or_Arel r tr.
      destruct H1 as [H1 | H1]; inversion H1; subst; solve_resource_action;
      destruct IHtr, H6; split; try tauto.
    - inversion H3; subst; clear H3; solve_resource_action.
      clear I H7 H8.
      specialize (H6 r).
      pose proof start_by_Aacq_or_Arel r (Arelease_res r0 :: tr).
      pose proof start_by_Aacq_or_Arel r tr.
      destruct H1 as [H1 | H1]; inversion H1; subst; solve_resource_action;
      destruct IHtr, H6; split; try tauto.
    - rewrite <- thread_local_state_enable_non_resource_action in H3 by auto.
      apply state_enable_non_resource_action1 in H3; auto.
      subst A1.
      assert (~ is_resource_action r a) by (intro HH; apply H; exists r; auto).
      pose proof start_by_Aacq_or_Arel r (a :: tr).
      pose proof start_by_Aacq_or_Arel r tr.
      destruct H1 as [H1 | H1]; inversion H1; subst; solve_resource_action;
      destruct IHtr; split; try tauto.
Qed.

Section soundness.

Existing Instance unit_kMD.

Context {P: ProgrammingLanguage}
        {MD: Model}
        {J: Join model}
        {SA: SeparationAlgebra model}
        {R: Relation model}
        {po_R: PreOrder Krelation}
        {DCSA: DownwardsClosedSeparationAlgebra model}
        {UCSA: UpwardsClosedSeparationAlgebra model}
        {Res: Resource}
        {Ac: Action}
        {Acr: Action_resource Ac Res}
        {nAcr: NormalAction_resource Ac Res}
        {TS: TraceSemantics P (resources * model) Ac}
        {AIr: ActionInterpret_resource model Ac Res ac_sem}
        {SAAIr: @SAActionInterpret_resource (resources * model) Ac ac_sem (@prod_Join _ _ (Pred_Join resource) J) (fun a => ~ is_resources_action a)}
        {KAIr: @KActionInterpret_resource (resources * model) Ac ac_sem (RelProd (discPred_R resource) R)}.

Instance KSAAIr: @KSAActionInterpret_resource (resources * model) Ac ac_sem (@prod_Join _ _ (Pred_Join resource) J) (RelProd (discPred_R resource) R) (fun a => ~ is_resources_action a) :=
  ordered_and_frame_AIr _ _ _.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {sepconL: SepconLanguage L}
        {SM: Semantics L MD}
        {kiSM: KripkeIntuitionisticSemantics L MD tt SM}
        {fsepconSM: FlatSemantics.SepconSemantics L MD tt SM}.

Class LegalInvariants (Inv: resource * (model -> Prop) -> Prop): Prop := {
  at_most_one_invariant: forall r I1 I2, Inv (r, I1) -> Inv (r, I2) -> I1 = I2;
  invariant_mono: forall r I,  Inv (r, I) -> forall s1 s2, I s1 -> s1 <= s2 -> I s2;
  invariant_precise: forall r I, Inv (r, I) -> forall s,
    (exists s', (fun s' => exists f, I f /\ join s' f s) s') ->
    (exists s', greatest (fun s' => exists f, I f /\ join s' f s) s')
}.
(*
Definition ThreadLocal_KSA_AIr: forall (Inv: resource * (model -> Prop) -> Prop) {INV: LegalInvariants Inv}, @KSAActionInterpret_resource (resources * model) Ac (ThreadLocal_ActionInterpret_resource ac_sem Inv) (@prod_Join _ _ (Pred_Join resource) J) (RelProd (discPred_R resource) R).
  Check @lift_join.
 *)

Lemma ThreadLocal_ordered_frame_property (Inv: resource * (model -> Prop) -> Prop) {INV: LegalInvariants Inv}: forall (a: action) (m1 f n1' n1: resources * model) (n2: MetaState (resources * model)) fst_m2
    (ASSU: res_enable a (fst m1) fst_m2 (fst f) (*forall r, a = Arelease_res r -> ~ fst f r*)),
    @join _ (prod_Join _ _) m1 f n1' ->
    (RelProd (discPred_R _) R) n1' n1 ->
    thread_local_state_enable Inv a n1 n2  ->
    exists m2 n2', @lift_join _ (prod_Join _ _) m2 (Terminating f) n2' /\ @Partial.forward _ (RelProd (discPred_R _) R) n2' n2 /\ match m2 with Terminating m2 => fst m2 = fst_m2 | _ => True end /\ thread_local_state_enable Inv a m1 m2.
Proof.
  intros.
  destruct (classic (is_resources_action a)) as [[?r [? | ?]] | ?].
  + subst a.
    inversion H1; subst; solve_resource_action.
    rename m into n1, n into n2.
    destruct n1' as [A1' n1'], f as [Af f], m1 as [B1 m1].
    hnf in H; simpl in H; destruct H.
    hnf in H0; simpl in H0. destruct H0. hnf in H0, H7; simpl in H0, H7.
    pose proof join_Korder_down _ _ _ _ _ H6 H7 ltac:(reflexivity) as [n2' [? ?]].
    pose proof join_assoc _ _ _ _ _ (join_comm _ _ _ H2) H8 as [m2 [? ?]].
    assert (A1 = A1').
    {
      extensionality r0; apply prop_ext.
      apply iff_sym, H0.
    }
    subst A1'.
    pose proof join_assoc _ _ _ _ _ (join_comm _ _ _ H) H3 as [B2 [? ?]].
    exists (Terminating (B2, m2)), (Terminating (A2, n2')).
    split; [| split; [| split]].
    - constructor.
      split; apply join_comm; auto.
    - constructor; split; auto; simpl.
      hnf; intro; simpl; hnf; tauto.
    - apply res_enable_acq_inv in ASSU.
      simpl in ASSU; destruct ASSU as [? _].
      simpl; clear - H14 H12.
      extensionality r0; apply prop_ext.
      specialize (H12 r0); specialize (H14 r0); destruct H12, H14; tauto.
    - simpl.
      eapply thread_local_state_enable_acq; eauto.
  + subst a.
    destruct n1 as [A1 n1], n1' as [A1' n1'], f as [Af f], m1 as [B1 m1].
    hnf in H; simpl in H; destruct H.
    hnf in H0; unfold RelCompFun in H0; simpl in H0; destruct H0.
    assert (A1' = A1).
    {
      extensionality r0; apply prop_ext.
      apply H0.
    }
    subst A1'; clear H0.
    destruct (classic (forall I, Inv (r, I) -> exists m2, (fun m2 => exists f, I f /\ join m2 f m1) m2)).
    - inversion H1; subst; solve_resource_action.
      2: {
        exfalso.
        specialize (H0 _ H8).
        destruct H0 as [m2 [f0 [? ?]]].
        pose proof join_assoc _ _ _ _ _ (join_comm _ _ _ H4) H2 as [n2' [? ?]].
        pose proof join_Korder_up _ _ _ _ H6 H3 as [_f0 [n2 [? [? ?]]]].
        apply (H10 n2); clear H10.
        exists _f0; split; [eapply (invariant_mono _ _ H8); eauto | apply join_comm; auto].
      }
      specialize (H0 _ H8).
      apply (invariant_precise _ _ H8) in H0.
      destruct H0 as [m2 ?].
      destruct (proj1 H0) as [f0 [? ?]].
      pose proof join_assoc _ _ _ _ _ (join_comm _ _ _ H5) H2 as [n2' [? ?]].
      pose proof join_Korder_up _ _ _ _ H9 H3 as [_f0 [_n2 [? [? ?]]]].
      assert ((fun n : model => exists f : model, I f /\ join n f n1) _n2).
      { exists _f0; split; [eapply (invariant_mono _ _ H8); eauto | apply join_comm; auto]. }
      apply (proj2 H10) in H14.
      apply res_enable_rel_inv in ASSU; simpl in ASSU.
      rename fst_m2 into B2.
      exists (Terminating (B2, m2)), (Terminating (A2, n2')).
      split; [| split; [| split]].
      * constructor.
        split; auto.
        simpl.
        clear - ASSU H H7.
        intros r0; specialize (ASSU r0); specialize (H r0); specialize (H7 r0).
        destruct ASSU, H, H7; split; tauto.
      * constructor.
        split; [hnf; intros ?; hnf; tauto | change (n2' <= n); etransitivity; eauto].
      * auto.
      * simpl.
        eapply thread_local_state_enable_rel_succ; eauto.
    - exists Error, n2.
      split; [| split; [| split]].
      * constructor.
      * destruct n2; constructor.
        destruct p as [A2 n2].
        split; [hnf; intros ?; hnf; tauto | change (n2 <= n2); reflexivity].
      * auto.
      * apply Classical_Pred_Type.not_all_ex_not in H0; destruct H0 as [I ?].
        apply imply_to_and in H0; destruct H0.
        apply res_enable_rel_inv in ASSU; simpl in ASSU.
        eapply thread_local_state_enable_rel_fail; eauto.
  + rewrite <- (thread_local_state_enable_non_resource_action Inv) in H1 by auto.
    change ((fun a => ~ is_resources_action a) a) in H2.
    pose proof ordered_frame_property _ _ _ _ _ _ H2 H H0 H1 as [m2 [n2' [? [? ?]]]].
    exists m2, n2'.
    split; [| split; [| split]]; auto.
    - apply res_enable_not_res_inv in ASSU; auto.
      destruct m1 as [A1 m1], m2 as [| | [A2 m2]]; auto.
      simpl in H5.
      apply state_enable_non_resource_action1 in H5; auto.
      subst; auto.
    - simpl.
      rewrite <- (thread_local_state_enable_non_resource_action Inv) by auto.
      auto.
Qed.

Lemma hoare_parallel_partial_sound
      {CPP: ConcurrentProgrammingLanguage_Sparallel P}
      {AcP: Action_Parallel Ac}
      {nAcPr: NormalAction_Parallel_resource Ac Res}
      {c2tP: Command2Traces_Sparallel_resource P model Ac Res c2t}
      {AIPr: ActionInterpret_Parallel_resource model Ac Res ac_sem}:
  forall Inv c1 P1 Q1 c2 P2 Q2 (INV: LegalInvariants Inv),
  guarded_triple_partial_valid Inv P1 c1 Q1 ->
  guarded_triple_partial_valid Inv P2 c2 Q2 ->
  guarded_triple_partial_valid Inv (P1 * P2) (Sparallel c1 c2) (Q1 * Q2).
Proof.
  intros.
  rename H into LEFT_ASSU, H0 into RIGHT_ASSU.
  hnf in LEFT_ASSU, RIGHT_ASSU |- *; intros.
  unfold access, ThreadLocal_BSS in LEFT_ASSU, RIGHT_ASSU, H0; simpl in LEFT_ASSU, RIGHT_ASSU, H0.
  inversion H0; subst; clear H0.
  rewrite Sparallel_denote in H1.
  set (Tr1 := cmd_denote c1) in LEFT_ASSU, H1.
  set (Tr2 := cmd_denote c2) in RIGHT_ASSU, H1.
  clearbody Tr1 Tr2; clear c1 c2.
  inversion H1; subst; clear H1.
  set (A1 := fun _: resource => False) in LEFT_ASSU at 1, H4 at 1.
  set (A2 := fun _: resource => False) in RIGHT_ASSU at 1, H4 at 1.
  set (A := fun _: resource => False) in H2 at 1.
  rewrite sat_sepcon in H.
  destruct H as [s1 [s2 [? [? ?]]]].
  set (s0 := s_pre) in H.
  assert (STATE_JOIN: @join _ (prod_Join resources model) (A1, s1) (A2, s2) (A, s0)).
  {
    split; auto.
    hnf; intros r0.
    simpl; subst A1 A2 A; split; tauto.
  }
  assert (STATE_LE: @Krelation _ (RelProd (discPred_R resource) R) (A, s0) (A, s_pre)).
  {
    split; hnf; simpl.
    + intros; hnf; tauto.
    + change (s_pre <= s_pre).
      reflexivity.
  }
  clearbody A1 A2 A s0. clear H.
  specialize (fun ms_post HH => LEFT_ASSU s1 ms_post H1 (traces_access_intro tr1 _ _ _ H0 HH)).
  specialize (fun ms_post HH => RIGHT_ASSU s2 ms_post H5 (traces_access_intro tr2 _ _ _ H3 HH)).
  clear P1 P2 H1 H5 Tr1 Tr2 H0 H3.
  rename H2 into TRACE_ACC.
  revert s0 s1 s2 s_pre A LEFT_ASSU RIGHT_ASSU STATE_JOIN STATE_LE TRACE_ACC; induction H4; intros.
  + inversion TRACE_ACC; subst.
    destruct ms_post; subst; inversion H.
    subst m A.
    assert (A2 = fun _ => False).
    {
      extensionality r; apply prop_ext.
      destruct STATE_JOIN as [? _].
      hnf in H0. specialize (H0 r).
      simpl in H0; destruct H0.
      tauto.
    }
    assert (A1 = fun _ => False).
    {
      extensionality r; apply prop_ext.
      destruct STATE_JOIN as [? _].
      hnf in H1. specialize (H1 r).
      simpl in H1; destruct H1.
      tauto.
    }
    subst A1 A2.
    specialize (LEFT_ASSU (Terminating s1) (trace_access_nil _)); simpl in LEFT_ASSU.
    specialize (RIGHT_ASSU (Terminating s2) (trace_access_nil _)); simpl in RIGHT_ASSU.
    eapply sat_mono; [exact (proj2 STATE_LE) |].
    rewrite sat_sepcon.
    exists s1, s2.
    split; [| split]; auto.
    exact (proj2 STATE_JOIN).
  + exfalso.
    destruct (res_actions_no_race _ _ H).
    apply (state_enable_race_actions_spec a1 a2 A1 A2 s1 s2 s0); auto.
    - intro.
      rewrite (thread_local_state_enable_non_resource_action Inv) in H2 by auto.
      specialize (LEFT_ASSU Error (@trace_access_Error _ _ (ThreadLocal_ActionInterpret_resource _ Inv) _ _ _ H2)).
      inversion LEFT_ASSU.
    - intro.
      rewrite (thread_local_state_enable_non_resource_action Inv) in H2 by auto.
      specialize (RIGHT_ASSU Error (@trace_access_Error _ _ (ThreadLocal_ActionInterpret_resource _ Inv) _ _ _ H2)).
      inversion RIGHT_ASSU.
    - exact (proj2 STATE_JOIN).
  + change (res_enable a1 (fst (A1, s1)) A1' (fst (A2, s2))) in H.
    inversion TRACE_ACC; subst.
    - (* NonTerminating *)
      destruct ms_post; inversion H5; clear H5; auto.
    - (* Error *)
      pose proof ThreadLocal_ordered_frame_property Inv _ _ _ _ _ Error A1' H STATE_JOIN STATE_LE H3 as [Error' [Error'' [? [? [_ ?]]]]].
      inversion H1; subst; clear H1.
      inversion H0; subst; clear H0.
      simpl lift_function in H2.
      exfalso.
      apply (LEFT_ASSU Error).
      apply trace_access_Error; auto.
    - (* Terminating *)
      pose proof ThreadLocal_ordered_frame_property Inv _ _ _ _ _ (Terminating s') A1' H STATE_JOIN STATE_LE H2 as [m2 [n2' [? [? [? ?]]]]].
      destruct n2' as [| | n2']; inversion H1; subst.
      destruct m2 as [| | m2]; inversion H0; subst.
      * exfalso.
        apply (LEFT_ASSU Error).
        apply trace_access_Error; auto.
      * destruct s' as [A' s'], m2 as [A1' s1'], n2' as [A0' s0'].
        assert (A0' = A').
        {
          clear - H9. destruct H9 as [? _]; hnf in H; simpl in H.
          extensionality r0; apply prop_ext; apply H.
        }
        subst A0'.
        apply (IHtrace_interleave s0' s1' s2 s' A'); auto.
        intros.
        apply LEFT_ASSU.
        eapply trace_access_Terminating; eauto.
  + change (res_enable a2 (fst (A2, s2)) A2' (fst (A1, s1))) in H.
    inversion TRACE_ACC; subst.
    - (* NonTerminating *)
      destruct ms_post; inversion H5; clear H5; auto.
    - (* Error *)
      pose proof ThreadLocal_ordered_frame_property Inv _ _ _ _ _ Error A2' H (@join_comm _ _ (prod_SA _ _) _ _ _ STATE_JOIN) STATE_LE H3 as [Error' [Error'' [? [? [_ ?]]]]].
      inversion H1; subst; clear H1.
      inversion H0; subst; clear H0.
      simpl lift_function in H2.
      exfalso.
      apply (RIGHT_ASSU Error).
      apply trace_access_Error; auto.
    - (* Terminating *)
      pose proof ThreadLocal_ordered_frame_property Inv _ _ _ _ _ (Terminating s') A2' H (@join_comm _ _ (prod_SA _ _) _ _ _ STATE_JOIN) STATE_LE H2 as [m2 [n2' [? [? [? ?]]]]].
      destruct n2' as [| | n2']; inversion H1; subst.
      destruct m2 as [| | m2]; inversion H0; subst.
      * exfalso.
        apply (RIGHT_ASSU Error).
        apply trace_access_Error; auto.
      * destruct s' as [A' s'], m2 as [A2' s2'], n2' as [A0' s0'].
        assert (A0' = A').
        {
          clear - H9. destruct H9 as [? _]; hnf in H; simpl in H.
          extensionality r0; apply prop_ext; apply H.
        }
        subst A0'.
        apply (IHtrace_interleave s0' s1 s2' s' A'); auto.
        intros.
        apply RIGHT_ASSU.
        eapply trace_access_Terminating; eauto.
        apply (@join_comm _ _ (prod_SA _ _)); auto.
Qed.

Lemma SRA_triple_spec
      {c2tSRA: StructuralResourceAccess P Ac Res c2t}:
  forall (Inv: (resource * (model -> Prop)) -> Prop) (Pre: expr) (c: cmd) (Post: expr),
     guarded_triple_partial_valid Inv Pre c Post <->
     (forall s_pre A_post ms_post, KRIPKE: s_pre |= Pre -> @traces_access _ _ (ThreadLocal_ActionInterpret_resource _ Inv) (cmd_denote c) (fun _ => False, s_pre) (lift_function (pair A_post) ms_post) -> match ms_post with | Error => False | NonTerminating => True | Terminating s_post => KRIPKE: s_post |= Post end).
Proof.
  intros.
  split.
  + intros.
    hnf in H.
    inversion H1; subst.
    replace (lift_function (pair A_post) ms_post) with (lift_function (pair (fun _:resource => False)) ms_post) in H3.
    2: {
      destruct ms_post as [| | ms_post]; auto.
      simpl lift_function in H3.
      eapply start_by_Aacq_trace_acc_spec in H3; [subst; auto |].
      intros; eapply resource_sequential; eauto.
    }
    apply (H s_pre ms_post); auto.
    apply (traces_access_intro tr); auto.
  + intros.
    hnf; intros.
    apply (H s_pre (fun _ => False) ms_post); auto.
Qed.

Lemma hoare_resource_block_partial_sound
      {CPP: ConcurrentProgrammingLanguage_Sresource P Res}
      {c2tR: Command2Traces_Sresource P Ac Res c2t}
      {c2tSRA: StructuralResourceAccess P Ac Res c2t}:
  forall Inv0 Inv1 r P1 P2 c I dI (INV: LegalInvariants Inv1),
  @join _ (Pred_Join _) Inv0 (eq (r, dI)) Inv1 ->
  (dI = fun m => KRIPKE: m |= I) ->
  resource_no_occur r (cmd_denote c) ->
  guarded_triple_partial_valid Inv0 (P1 * I) c (P2 * I) ->
  guarded_triple_partial_valid Inv1 P1 (Sresource r c) P2.
Proof.
  intros.
  subst dI.
  rewrite SRA_triple_spec in H2 |- *.
  rename H into INV_CONS, H1 into NO_OCCUR.
  rename H2 into ASSU; intros.
  unfold access, ThreadLocal_BSS in ASSU, H0; simpl in ASSU, H0.
  inversion H0; subst; clear H0.
  rewrite Sresource_denote in H1.
  set (Tr := cmd_denote c) in ASSU, H1, NO_OCCUR.
  clearbody Tr; clear c.
  inversion H1; subst; clear H1.
  inversion H3; subst; clear H3.
  unfold singleton_traces, singleton_trace in H0, H4.
  subst tr1 tr3; rename tr0 into tr.
  specialize (fun s A_post ms_post _H HH => ASSU s A_post ms_post _H (traces_access_intro tr _ _ _ H1 HH)).
  specialize (NO_OCCUR _ H1).
  clear Tr H1.
  unfold trace_app in H2; simpl app in H2; inversion H2; subst; clear H2.
  { exfalso; inversion H4; subst; solve_resource_action. }
  { exfalso; inversion H4; subst; solve_resource_action. }
  inversion H3; subst; clear H3; solve_resource_action.
  assert (I0 = fun m => KRIPKE: m |= I).
  {
    clear - INV_CONS INV H7.
    apply (at_most_one_invariant r); auto.
    specialize (INV_CONS (r, fun m => m |= I)).
    destruct INV_CONS; simpl in *.
    tauto.
  }
  subst I0.
  assert (KRIPKE: n |= P1 * I).
  {
    rewrite sat_sepcon.
    exists s_pre, f; auto.
  }
  clear f s_pre H8 H9 H.
  rename n into s.
  specialize (fun A_post ms_post => ASSU s A_post ms_post H0); clear H0 P1.

  set (A1 := fun _ => False) in H5, ASSU at 1.
  clearbody A1.
  rename H5 into JOIN_RES, H6 into TRACE_ACC, H7 into Inv_r.

  revert A1 A2 s JOIN_RES TRACE_ACC ASSU; induction tr; intros.
  + simpl in TRACE_ACC.
    specialize (ASSU A1 (Terminating s) (trace_access_nil _)).
    change (KRIPKE: s |= P2 * I) in ASSU.
    rewrite sat_sepcon in ASSU.
    destruct ASSU as [s' [f [? [? ?]]]].
    assert ((fun n : model => exists f : model, KRIPKE: f |= I /\ join n f s) s') by (exists f; auto).
    inversion TRACE_ACC; subst.
    - inversion H6; subst; solve_resource_action.
    - inversion H6; subst; solve_resource_action.
      pose proof at_most_one_invariant _ _ _ H9 Inv_r; subst I0; clear H9.
      exfalso; apply (H10 s').
      exists f; auto.
    - inversion H5; subst; solve_resource_action.
      pose proof at_most_one_invariant _ _ _ H10 Inv_r; subst I0; clear H10.
      apply (proj2 H11) in H2.
      eapply sat_mono in H0; [| exact H2].
      inversion H8; subst.
      destruct ms_post; inversion H3; subst.
      auto.
  + simpl in TRACE_ACC.
    assert (forall ms, thread_local_state_enable Inv1 a (A2, s) ms ->
                       match ms with
                       | Error => thread_local_state_enable Inv0 a (A1, s) Error
                       | NonTerminating => thread_local_state_enable Inv0 a (A1, s) NonTerminating
                       | Terminating (A2', s') => exists A1', join A1' (eq r) A2' /\ thread_local_state_enable Inv0 a (A1, s) (Terminating (A1', s'))
                       end).
    {
      clear - INV_CONS INV NO_OCCUR JOIN_RES AIr.
      intros.
      assert (~ is_resource_action r a).
      {
        intros [? | ?].
        + subst; apply (proj1 NO_OCCUR).
          left; auto.
        + subst; apply (proj2 NO_OCCUR).
          left; auto.
      }
      clear NO_OCCUR; rename H0 into NO_OCCUR.
      inversion H; subst; solve_resource_action.
      + assert (Inv0 (r0, I0)).
        {
          specialize (INV_CONS (r0, I0)).
          assert ((r, fun m : model => KRIPKE: m |= I) <> (r0, I0)) by congruence.
          destruct INV_CONS; tauto.
        }
        rename A3 into A2'.
        pose proof join_assoc _ _ _ _ _ (join_comm _ _ _ JOIN_RES) H2 as [A1' [? ?]].
        apply join_comm in H4.
        exists A1'; split; auto.
        eapply (thread_local_state_enable_acq _ _ _ _ _ _ _ _ H1 H0 H5 H7).
      + assert (Inv0 (r0, I0)).
        {
          specialize (INV_CONS (r0, I0)).
          assert ((r, fun m : model => KRIPKE: m |= I) <> (r0, I0)) by congruence.
          destruct INV_CONS; tauto.
        }
        rename A3 into A2'.
        set (A1' := fun rr => A2' rr /\ r <> rr).
        assert (join A1' (eq r) A2').
        {
          subst A1'; intros rr; specialize (H2 rr); specialize (JOIN_RES rr).
          assert (r0 = rr -> r = rr -> False) by (intros; congruence).
          destruct H2, JOIN_RES; split; tauto.
        }
        assert (join A1' (eq r0) A1).
        {
          subst A1'; intros rr; specialize (H2 rr); specialize (JOIN_RES rr).
          assert (r0 = rr -> r = rr -> False) by (intros; congruence).
          destruct H2, JOIN_RES; split; tauto.
        }
        exists A1'; split; auto.
        eapply (thread_local_state_enable_rel_succ _ _ _ _ _ _ _ H3 H0 H6).
      + assert (Inv0 (r0, I0)).
        {
          specialize (INV_CONS (r0, I0)).
          assert ((r, fun m : model => KRIPKE: m |= I) <> (r0, I0)) by congruence.
          destruct INV_CONS; tauto.
        }
        rename A3 into A2'.
        set (A1' := fun rr => A2' rr /\ r <> rr).
        assert (join A1' (eq r) A2').
        {
          subst A1'; intros rr; specialize (H2 rr); specialize (JOIN_RES rr).
          assert (r0 = rr -> r = rr -> False) by (intros; congruence).
          destruct H2, JOIN_RES; split; tauto.
        }
        assert (join A1' (eq r0) A1).
        {
          subst A1'; intros rr; specialize (H2 rr); specialize (JOIN_RES rr).
          assert (r0 = rr -> r = rr -> False) by (intros; congruence).
          destruct H2, JOIN_RES; split; tauto.
        }
        eapply (thread_local_state_enable_rel_fail _ _ _ _ _ _ H3 H0 H6).
      + destruct ms as [| | [A2' s']].
        - eapply thread_local_state_enable_non_resource; auto.
          change Error with (lift_function (pair A1) (@Error model)).
          change Error with (lift_function (pair A2) (@Error model)) in H1.
          apply (state_enable_non_resource_action2 _ _ _ _ _ H0 H1).
        - eapply thread_local_state_enable_non_resource; auto.
          change NonTerminating with (lift_function (pair A1) (@NonTerminating model)).
          change NonTerminating with (lift_function (pair A2) (@NonTerminating model)) in H1.
          apply (state_enable_non_resource_action2 _ _ _ _ _ H0 H1).
        - pose proof state_enable_non_resource_action1 _ _ _ _ _ H0 H1; subst A2'.
          exists A1.
          split; auto.
          eapply thread_local_state_enable_non_resource; auto.
          change (Terminating (A2, s')) with (lift_function (pair A2) (Terminating s')) in H1.
          apply (state_enable_non_resource_action2 _ _ _ _ _ H0 H1).
    }
    inversion TRACE_ACC; subst.
    - destruct ms_post; inversion H4; auto.
    - simpl in H3.
      apply H in H3.
      specialize (ASSU A1 Error (@trace_access_Error _ _ (ThreadLocal_ActionInterpret_resource _ Inv0) _ _ _ H3)).
      inversion ASSU.
    - simpl in H2.
      apply H in H2.
      destruct s' as [A2' s'].
      destruct H2 as [A1' [? ?]].
      assert (~ In (Aacquire_res r) tr /\ ~ In (Arelease_res r) tr)
        by (simpl in NO_OCCUR; tauto).
      apply (IHtr H2 A1' A2' s'); auto; clear H2 ms_post IHtr TRACE_ACC H5 A_post.
      intros.
      apply (ASSU A_post ms_post).
      eapply trace_access_Terminating; eauto.
Qed.

End soundness.


(* Was an anomaly with ill-typed template polymorphism *)
Definition huh (b:bool) := if b then Set else Prop.
Definition lol b: huh b :=
  if b return huh b then nat else True.
Goal (lol true) * unit.
Fail generalize true. (* should fail with error, not anomaly *)
Abort.


(****************************************************************************)
(* Copyright 2021 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Cava.Cava.
Require Import Cava.IP.AdderSubtractor.

Definition bv_0   := N2Bv_sized 8  0.
Definition bv_5   := N2Bv_sized 8  5.
Definition bv_7   := N2Bv_sized 8  7.
Definition bv_15  := N2Bv_sized 8 15.
Definition bv_511 := N2Bv_sized 8 511.

Example ex1 :
  c_addsub_0 (bv_5, bv_7) = N2Bv_sized 9 12.
Proof. trivial. Qed.

Example ex2 :
  c_addsub_0 (bv_511, bv_511) = N2Bv_sized 9 1022.
Proof. trivial. Qed.

Definition adderInterface
  := combinationalInterface "c_addsub_0"
     [mkPort "B" (Vec Bit 8); mkPort "A" (Vec Bit 8)]
     [mkPort "S" (Vec Bit 9)].

Definition adderNetlist := makeNetlist adderInterface c_addsub_0.

Definition adder_tb_inputs : list (Bvector 8 * Bvector 8) :=
  [(bv_0, bv_5);
   (bv_7, bv_0);
   (bv_5, bv_7);
   (bv_511, bv_5);
   (bv_7, bv_511);
   (bv_511, bv_511)].

Definition adder_tb_expected_outputs
  := simulate (Comb c_addsub_0) adder_tb_inputs.

Definition adder_tb
  := testBench "c_addsub_0_tb" adderInterface
     adder_tb_inputs adder_tb_expected_outputs.


Require Import oeuf.Common.

Require Import oeuf.Utopia.
Require Import oeuf.Monads.
Require Import oeuf.ListLemmas.
Require Import oeuf.Metadata.
Require Import oeuf.HigherValue.
Require Import oeuf.AllValues.
Require Import oeuf.OpaqueOps.
Require oeuf.StepLib.

Definition function_name := nat.

(* List containing a flag for each argument, `true` if Elim should recurse on
   that argument, `false` if it shouldn't.  The length gives the number of
   arguments. *)
Definition rec_info := list bool.

Inductive expr :=
| Value (v : value)
| Arg
| UpVar (idx : nat)
| Call (f : expr) (a : expr)
| MkConstr (tag : nat) (args : list expr)
| Elim (cases : list (expr * rec_info)) (target : expr)
| MkClose (f : function_name) (free : list expr)
| OpaqueOp (o : opaque_oper_name) (args : list expr)
.

Inductive is_value : expr -> Prop :=
| IsValue : forall v, is_value (Value v).

Definition env := list expr.

Fixpoint unroll_elim (case : expr)
                     (args : list value)
                     (rec : rec_info)
                     (mk_rec : expr -> expr) : option expr :=
    match args, rec with
    | [], [] => Some case
    | arg :: args, r :: rec =>
            let case := Call case (Value arg) in
            let case := if r then Call case (mk_rec (Value arg)) else case in
            unroll_elim case args rec mk_rec
    | _, _ => None
    end.

Inductive state :=
| Run (e : expr) (l : list value) (k : value -> state)
| Stop (v : value).

Inductive sstep (E : env) : state -> state -> Prop :=
| SArg : forall l k v,
        nth_error l 0 = Some v ->
        sstep E (Run Arg l k) (k v)
| SUpVar : forall n l k v,
        nth_error l (S n) = Some v ->
        sstep E (Run (UpVar n) l k) (k v)

| SCloseStep : forall tag vs e es l k,
        Forall is_value vs ->
        ~ is_value e ->
        sstep E (Run (MkClose tag (vs ++ [e] ++ es)) l k)
                (Run e l (fun v => Run (MkClose tag (vs ++ [Value v] ++ es)) l k))
| SCloseDone : forall tag vs l k,
        let es := map Value vs in
        sstep E (Run (MkClose tag es) l k) (k (Close tag vs))

| SConstrStep : forall fname vs e es l k,
        Forall is_value vs ->
        ~ is_value e ->
        sstep E (Run (MkConstr fname (vs ++ [e] ++ es)) l k)
                (Run e l (fun v => Run (MkConstr fname (vs ++ [Value v] ++ es)) l k))
| SConstrDone : forall fname vs l k,
        let es := map Value vs in
        sstep E (Run (MkConstr fname es) l k) (k (Constr fname vs))

| SOpaqueOpStep : forall op vs e es l k,
        Forall is_value vs ->
        ~ is_value e ->
        sstep E (Run (OpaqueOp op (vs ++ [e] ++ es)) l k)
                (Run e l (fun v => Run (OpaqueOp op (vs ++ [Value v] ++ es)) l k))
| SOpaqueOpDone : forall op vs l k v,
        let es := map Value vs in
        opaque_oper_denote_higher op vs = Some v ->
        sstep E (Run (OpaqueOp op es) l k) (k v)

| SCallL : forall e1 e2 l k,
        ~ is_value e1 ->
        sstep E (Run (Call e1 e2) l k)
                (Run e1 l (fun v => Run (Call (Value v) e2) l k))
| SCallR : forall e1 e2 l k,
        is_value e1 ->
        ~ is_value e2 ->
        sstep E (Run (Call e1 e2) l k)
                (Run e2 l (fun v => Run (Call e1 (Value v)) l k))
| SMakeCall : forall fname free arg l k body,
        nth_error E fname = Some body ->
        sstep E (Run (Call (Value (Close fname free)) (Value arg)) l k)
                (Run body (arg :: free) k)

| SElimStep : forall cases target l k,
        ~ is_value target ->
        sstep E (Run (Elim cases target) l k)
                (Run target l (fun v => Run (Elim cases (Value v)) l k))
| SEliminate : forall cases tag args l k case rec e',
        nth_error cases tag = Some (case, rec) ->
        unroll_elim case args rec (fun x => Elim cases x) = Some e' ->
        sstep E (Run (Elim cases (Value (Constr tag args))) l k)
                (Run e' l k)
.

Definition sstar BE := StepLib.sstar (sstep BE).
Definition SStarNil := @StepLib.SStarNil state.
Definition SStarCons := @StepLib.SStarCons state.

Definition splus BE := StepLib.splus (sstep BE).
Definition SPlusOne := @StepLib.SPlusOne state.
Definition SPlusCons := @StepLib.SPlusCons state.

(* Proofs *)

(*
 * Mutual recursion/induction schemes for expr
 *)

Definition expr_rect_mut
        (P : expr -> Type)
        (Pl : list expr -> Type)
        (Pp : expr * rec_info -> Type)
        (Plp : list (expr * rec_info) -> Type)
    (HValue :   forall v, P (Value v))
    (HArg :     P Arg)
    (HUpVar :   forall n, P (UpVar n))
    (HCall :    forall f a, P f -> P a -> P (Call f a))
    (HConstr :  forall tag args, Pl args -> P (MkConstr tag args))
    (HElim :    forall cases target, Plp cases -> P target -> P (Elim cases target))
    (HClose :   forall f free, Pl free -> P (MkClose f free))
    (HOpaqueOp : forall o args, Pl args -> P (OpaqueOp o args))
    (Hnil :     Pl [])
    (Hcons :    forall e es, P e -> Pl es -> Pl (e :: es))
    (Hpair :    forall e r, P e -> Pp (e, r))
    (Hnil_p :   Plp [])
    (Hcons_p :  forall p ps, Pp p -> Plp ps -> Plp (p :: ps))
    (e : expr) : P e :=
    let fix go e :=
        let fix go_list es :=
            match es as es_ return Pl es_ with
            | [] => Hnil
            | e :: es => Hcons e es (go e) (go_list es)
            end in
        let go_pair p :=
            let '(e, r) := p in
            Hpair e r (go e) in
        let fix go_pair_list ps :=
            match ps as ps_ return Plp ps_ with
            | [] => Hnil_p
            | p :: ps => Hcons_p p ps (go_pair p) (go_pair_list ps)
            end in
        match e as e_ return P e_ with
        | Value v => HValue v
        | Arg => HArg
        | UpVar n => HUpVar n
        | Call f a => HCall f a (go f) (go a)
        | MkConstr tag args => HConstr tag args (go_list args)
        | Elim cases target => HElim cases target (go_pair_list cases) (go target)
        | MkClose f free => HClose f free (go_list free)
        | OpaqueOp o args => HOpaqueOp o args (go_list args)
        end in go e.

Definition expr_rect_mut'
        (P : expr -> Type)
        (Pl : list expr -> Type)
        (Pp : expr * rec_info -> Type)
        (Plp : list (expr * rec_info) -> Type)
    HValue HArg HUpVar HCall HConstr HElim HClose HOpaque Hnil Hcons Hpair Hnil_p Hcons_p
    : (forall e, P e) * (forall es, Pl es) * (forall p, Pp p) * (forall ps, Plp ps) :=
    let go := expr_rect_mut P Pl Pp Plp
        HValue HArg HUpVar HCall HConstr HElim HClose HOpaque Hnil Hcons Hpair Hnil_p Hcons_p
    in
    let fix go_list es :=
        match es as es_ return Pl es_ with
        | [] => Hnil
        | e :: es => Hcons e es (go e) (go_list es)
        end in
    let go_pair p :=
        let '(e, r) := p in
        Hpair e r (go e) in
    let fix go_pair_list ps :=
        match ps as ps_ return Plp ps_ with
        | [] => Hnil_p
        | p :: ps => Hcons_p p ps (go_pair p) (go_pair_list ps)
        end in
    (go, go_list, go_pair, go_pair_list).

(* Useful wrapper for `expr_rect_mut with (Pl := Forall P)` *)
Definition expr_ind' (P : expr -> Prop) (Pp : (expr * rec_info) -> Prop)
    (HValue :   forall v, P (Value v))
    (HArg :     P Arg)
    (HUpVar :   forall n, P (UpVar n))
    (HCall :    forall f a, P f -> P a -> P (Call f a))
    (HConstr :  forall c args, Forall P args -> P (MkConstr c args))
    (HElim :    forall cases target, Forall Pp cases -> P target -> P (Elim cases target))
    (HClose :   forall f free, Forall P free -> P (MkClose f free))
    (HOpaqueOp : forall o args, Forall P args -> P (OpaqueOp o args))
    (Hpair :    forall e r, P e -> Pp (e, r))
    (e : expr) : P e :=
    ltac:(refine (@expr_rect_mut P (Forall P) Pp (Forall Pp)
        HValue HArg HUpVar HCall HConstr HElim HClose HOpaqueOp _ _ Hpair _ _ e); eauto).

(* Useful wrapper for `expr_rect_mut with (Pl := Forall P)` *)
Definition expr_ind'' (P : expr -> Prop)
    (HValue :   forall v, P (Value v))
    (HArg :     P Arg)
    (HUpVar :   forall n, P (UpVar n))
    (HCall :    forall f a, P f -> P a -> P (Call f a))
    (HConstr :  forall c args, Forall P args -> P (MkConstr c args))
    (HElim :    forall cases target,
        Forall (fun c => P (fst c)) cases ->
        P target ->
        P (Elim cases target))
    (HClose :   forall f free, Forall P free -> P (MkClose f free))
    (HOpaqueOp : forall o args, Forall P args -> P (OpaqueOp o args))
    (e : expr) : P e :=
    ltac:(refine (@expr_rect_mut P (Forall P) (fun c => P (fst c)) (Forall (fun c => P (fst c)))
        HValue HArg HUpVar HCall HConstr HElim HClose HOpaqueOp _ _ _ _ _ e); eauto).

(*
 * Misc lemmas
 *)

Lemma unroll_elim_length : forall case args rec mk_rec,
    length args = length rec <-> unroll_elim case args rec mk_rec <> None.
first_induction args; destruct rec; intros; split; simpl;
  try solve [intro; congruence].

- intro Hlen. simpl. eapply IHargs. congruence.
- intro Hcall. f_equal. apply <- IHargs. eauto.
Qed.

Lemma length_unroll_elim : forall case args rec mk_rec,
    length args = length rec ->
    exists e, unroll_elim case args rec mk_rec = Some e.
first_induction args; destruct rec; intros0 Hlen; simpl in Hlen; try discriminate Hlen.
- eexists. reflexivity.
- inv Hlen.
  fwd eapply IHargs; try eassumption.
Qed.

Require oeuf.Semantics.

Definition prog_type : Type := list expr * list metadata.
Definition val_level := VlHigher.
Definition valtype := value_type val_level.

Definition initial_env (prog : prog_type) : env := fst prog.

Inductive is_callstate (prog : prog_type) : valtype -> valtype -> state -> Prop :=
| IsCallstate : forall fname free av body,
        nth_error (fst prog) fname = Some body ->
        let fv := Close fname free in
        HigherValue.public_value (snd prog) fv ->
        HigherValue.public_value (snd prog) av ->
        is_callstate prog fv av
            (Run body (av :: free) Stop).

Inductive final_state (prog : prog_type) : state -> valtype -> Prop :=
| FinalState : forall v,
        HigherValue.public_value (snd prog) v ->
        final_state prog (Stop v) v.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics.Semantics_gen state env val_level
                 (is_callstate prog)
                 (sstep)
                 (final_state prog)
                 (initial_env prog).

Definition nfree_ok_value nfrees : value -> Prop :=
    let fix go v :=
        let fix go_list vs :=
            match vs with
            | [] => True
            | v :: vs => go v /\ go_list vs
            end in
        match v with
        | Constr _ args => go_list args
        | Close fname free =>
                nth_error nfrees fname = Some (length free) /\
                go_list free
        | Opaque _ _ => True
        end in go.

Definition nfree_ok_value_list nfrees :=
    let go := nfree_ok_value nfrees in
    let fix go_list vs :=
        match vs with
        | [] => True
        | v :: vs => go v /\ go_list vs
        end in go_list.

Ltac refold_nfree_ok_value nfrees :=
    fold (nfree_ok_value_list nfrees) in *.

Definition nfree_ok nfrees : expr -> Prop :=
    let fix go e :=
        let fix go_list es :=
            match es with
            | [] => True
            | e :: es => go e /\ go_list es
            end in
        let fix go_pair p :=
            let '(e, _) := p in
            go e in
        let fix go_list_pair ps :=
            match ps with
            | [] => True
            | p :: ps => go_pair p /\ go_list_pair ps
            end in
        match e with
        | Value v => nfree_ok_value nfrees v
        | Arg => True
        | UpVar _ => True
        | Call f a => go f /\ go a
        | MkConstr _ args => go_list args
        | Elim cases target =>
                go_list_pair cases /\
                go target
        | MkClose fname free =>
                nth_error nfrees fname = Some (length free) /\
                go_list free
        | OpaqueOp op args => go_list args
        end in go.

Definition nfree_ok_list nfrees :=
    let go := nfree_ok nfrees in
    let fix go_list es :=
        match es with
        | [] => True
        | e :: es => go e /\ go_list es
        end in go_list.

Definition nfree_ok_pair nfrees : (expr * rec_info) -> Prop :=
    let go := nfree_ok nfrees in
    let fix go_pair p :=
        let '(e, r) := p in
        go e in go_pair.

Definition nfree_ok_list_pair nfrees :=
    let go_pair := nfree_ok_pair nfrees in
    let fix go_list_pair ps :=
        match ps with
        | [] => True
        | p :: ps => go_pair p /\ go_list_pair ps
        end in go_list_pair.

Ltac refold_nfree_ok nfrees :=
    fold (nfree_ok_list nfrees) in *;
    fold (nfree_ok_pair nfrees) in *;
    fold (nfree_ok_list_pair nfrees) in *.

Inductive nfree_ok_state nfrees : state -> Prop :=
| NfosRun : forall e l k,
        nfree_ok nfrees e ->
        Forall (nfree_ok_value nfrees) l ->
        (forall v,
            nfree_ok_value nfrees v ->
            nfree_ok_state nfrees (k v)) ->
        nfree_ok_state nfrees (Run e l k)
| NfosStop : forall v, nfree_ok_state nfrees (Stop v).

Definition check_nfree_ok_value : forall nfrees v,
    { nfree_ok_value nfrees v } + { ~ nfree_ok_value nfrees v }.
intros ? ?.
induction v using value_rect_mut with
    (Pl := fun vs =>
        { nfree_ok_value_list nfrees vs } +
        { ~ nfree_ok_value_list nfrees vs }).
all: try solve [left; constructor].

- (* Constr *) simpl. refold_nfree_ok_value nfrees. assumption.
- (* Close *)
  destruct (nth_error nfrees fname) as [nfree | ] eqn:?; cycle 1.
    { right. inversion 1.  congruence. }
  destruct (eq_nat_dec (length free) nfree), IHv;
    simpl; refold_nfree_ok_value nfrees; try subst nfree;
    try solve [left; eauto | right; inversion 1; eauto + congruence].

- (* cons *)
  destruct IHv, IHv0; simpl; refold_nfree_ok_value nfrees;
    solve [left; eauto | right; inversion 1; eauto].
Defined.

Definition check_nfree_ok : forall nfrees e,
    { nfree_ok nfrees e } + { ~ nfree_ok nfrees e }.
intros ? ?.
induction e using expr_rect_mut with
    (Pl := fun es =>
        { nfree_ok_list nfrees es } +
        { ~ nfree_ok_list nfrees es })
    (Pp := fun p =>
        { nfree_ok_pair nfrees p } +
        { ~ nfree_ok_pair nfrees p })
    (Plp := fun ps =>
        { nfree_ok_list_pair nfrees ps } +
        { ~ nfree_ok_list_pair nfrees ps }).
all: try solve [left; constructor].

- (* Value *) simpl. eapply check_nfree_ok_value.
- (* Call *)
  destruct IHe1, IHe2; simpl; solve [left; eauto | right; inversion 1; eauto].
- (* MkConstr *) destruct IHe; simpl; left + right; eassumption.
- (* ElimN *)
  destruct IHe, IHe0; simpl; refold_nfree_ok nfrees;
    solve [left; eauto | right; inversion 1; eauto].
- (* MkClose *)
  destruct (nth_error nfrees f) as [nfree | ] eqn:?; cycle 1.
    { right. inversion 1.  congruence. }
  destruct (eq_nat_dec (length free) nfree), IHe;
    simpl; refold_nfree_ok_value nfrees; try subst nfree;
    try solve [left; eauto | right; inversion 1; eauto + congruence].
- (* OpaqueOp *) destruct IHe; simpl; left + right; eassumption.

(* list, pair, etc *)
- destruct IHe, IHe0; simpl; refold_nfree_ok nfrees;
    solve [left; eauto | right; inversion 1; eauto].
- destruct IHe; simpl; left + right; eassumption.
- destruct IHe, IHe0; simpl; refold_nfree_ok nfrees;
    solve [left; eauto | right; inversion 1; eauto].
Defined.

Definition check_nfree_ok_list : forall nfrees exprs,
    { Forall (nfree_ok nfrees) exprs } +
    { ~ Forall (nfree_ok nfrees) exprs }.
induction exprs.
{ left. constructor. }

rename a into e.
destruct (check_nfree_ok nfrees e), IHexprs.
all: try solve [left; eauto | right; inversion 1; eauto].
Defined.

Lemma nfree_ok_value_list_Forall : forall nfrees es,
    nfree_ok_value_list nfrees es <->
    Forall (nfree_ok_value nfrees) es.
induction es; split; intro HH; simpl in *.
- constructor.
- constructor.
- break_and. constructor; tauto.
- on (Forall _ _), invc. constructor; tauto.
Qed.

Lemma nfree_ok_list_Forall : forall nfrees es,
    nfree_ok_list nfrees es <->
    Forall (nfree_ok nfrees) es.
induction es; split; intro HH; simpl in *.
- constructor.
- constructor.
- break_and. constructor; tauto.
- on (Forall _ _), invc. constructor; tauto.
Qed.

Lemma nfree_ok_list_pair_Forall : forall nfrees es,
    nfree_ok_list_pair nfrees es <->
    Forall (nfree_ok_pair nfrees) es.
induction es; split; intro HH; simpl in *.
- constructor.
- constructor.
- break_and. constructor; tauto.
- on (Forall _ _), invc. constructor; tauto.
Qed.

Lemma nfree_ok_list_map_value : forall nfrees vs,
    Forall (nfree_ok nfrees) (map Value vs) ->
    Forall (nfree_ok_value nfrees) vs.
induction vs; intros.
- constructor.
- on >Forall, invc. constructor; eauto.
Qed.

Ltac i_ctor := intros; econstructor; simpl; eauto.
Ltac i_lem H := intros; eapply H; simpl; eauto.

Lemma unroll_elim_nfree_ok : forall nfrees case args rec mk_rec e,
    nfree_ok nfrees case ->
    Forall (nfree_ok_value nfrees) args ->
    (forall e, nfree_ok nfrees e -> nfree_ok nfrees (mk_rec e)) ->
    unroll_elim case args rec mk_rec = Some e ->
    nfree_ok nfrees e.
first_induction args; destruct rec; intros0 Hcase Hargs Hmk_rec Hunroll; try discriminate;
simpl in *.
  { inject_some. auto. }

on >Forall, invc.
remember (if b then _ else _) as case'.
eapply IHargs with (case := case'); eauto.
subst case'. destruct b; simpl; eauto.
Qed.

Definition nfree_ok_value0 nfrees : value -> Prop :=
    fun v =>
        match v with
        | Close fname free => nth_error nfrees fname = Some (length free)
        | _ => True
        end.

Lemma nfree_ok_value_VForall : forall nfrees v,
    nfree_ok_value nfrees v <-> VForall (nfree_ok_value0 nfrees) v.
intro nfrees.
mut_induction v using value_rect_mut' with
    (Pl := fun vs =>
        nfree_ok_value_list nfrees vs <-> VForall_list (nfree_ok_value0 nfrees) vs);
[ simpl; refold_nfree_ok_value nfrees; refold_VForall (nfree_ok_value0 nfrees);
  tauto.. | ].
finish_mut_induction nfree_ok_value_VForall using list.
Qed exporting.

Lemma opaque_oper_denote_higher_nfree_ok_value : forall nfrees op vs v,
    opaque_oper_denote_higher op vs = Some v ->
    nfree_ok_value_list nfrees vs ->
    nfree_ok_value nfrees v.
intros.
rewrite nfree_ok_value_VForall, VForall_VIn.
rewrite nfree_ok_value_VForall_list, VForall_VIn_list in *.
intros.
rename vs into args, v into ret, v' into v.
destruct v; try solve [constructor].
fwd eapply opaque_oper_no_fab_clos_higher with (args := args) (ret := ret) as HH; eauto.
  { reflexivity. }
  destruct HH as (v0 & ? & ?).
assert (nfree_ok_value0 nfrees v0) by eauto.
destruct v0; try discriminate. simpl in *. inject_some.
auto.
Qed.

Lemma step_nfree_ok : forall E nfrees s s',
    Forall (nfree_ok nfrees) E ->
    nfree_ok_state nfrees s ->
    sstep E s s' ->
    nfree_ok_state nfrees s'.
intros0 Hnf II STEP.
invc STEP; invc II.

- (* SArg *)
  on _, eapply_. i_lem Forall_nth_error.

- (* SUpVar *)
  on _, eapply_. i_lem Forall_nth_error.

- (* SCloseStep *)
  simpl in *. refold_nfree_ok nfrees. break_and.
  on _, rewrite_fwd nfree_ok_list_Forall.  on _, invc_using Forall_3part_inv.
  i_ctor. i_ctor.
  simpl. refold_nfree_ok nfrees. split.
  + rewrite app_length in *. simpl in *. assumption.
  + rewrite nfree_ok_list_Forall. i_lem Forall_app.

- (* SCloseDone *)
  on _, eapply_.
  simpl in *. refold_nfree_ok nfrees. refold_nfree_ok_value nfrees. break_and.
  subst es.
  split.  { rewrite map_length in *. auto. }
  rewrite nfree_ok_value_list_Forall. eapply nfree_ok_list_map_value.
  rewrite <- nfree_ok_list_Forall. auto.

- (* SConstrStep *)
  simpl in *. refold_nfree_ok nfrees. break_and.
  on _, rewrite_fwd nfree_ok_list_Forall.  on _, invc_using Forall_3part_inv.
  i_ctor. i_ctor.
  simpl. refold_nfree_ok nfrees.
  rewrite nfree_ok_list_Forall. i_lem Forall_app.

- (* SConstrDone *)
  on _, eapply_.
  simpl in *. refold_nfree_ok nfrees. refold_nfree_ok_value nfrees. break_and.
  subst es.
  rewrite nfree_ok_value_list_Forall. eapply nfree_ok_list_map_value.
  rewrite <- nfree_ok_list_Forall. auto.

- (* SOpaqueOpStep *)
  simpl in *. refold_nfree_ok nfrees. break_and.
  on _, rewrite_fwd nfree_ok_list_Forall.  on _, invc_using Forall_3part_inv.
  i_ctor. i_ctor.
  simpl. refold_nfree_ok nfrees.
  rewrite nfree_ok_list_Forall. i_lem Forall_app.

- (* SOpaqueOpDone *)
  on _, eapply_.
  simpl in *. refold_nfree_ok nfrees. refold_nfree_ok_value nfrees. break_and.
  subst es.
  eapply opaque_oper_denote_higher_nfree_ok_value; eauto.
  rewrite nfree_ok_value_list_Forall. eapply nfree_ok_list_map_value.
  rewrite <- nfree_ok_list_Forall. auto.

- (* SCallL *)
  simpl in *. break_and.
  i_ctor. i_ctor.

- (* SCallR *)
  simpl in *. break_and.
  i_ctor. i_ctor.

- (* SMakeCall *)
  simpl in *. refold_nfree_ok_value nfrees. break_and.
  i_ctor.
  + i_lem Forall_nth_error.
  + i_ctor. rewrite <- nfree_ok_value_list_Forall. eauto.

- (* SElimStep *)
  simpl in *. refold_nfree_ok nfrees. break_and.
  i_ctor. i_ctor.

- (* SEliminate *)
  simpl in *. refold_nfree_ok nfrees. refold_nfree_ok_value nfrees. break_and.
  on _, rewrite_fwd nfree_ok_list_pair_Forall.
  fwd eapply Forall_nth_error with (xs := cases); eauto. simpl in *.
  i_ctor.
  eapply unroll_elim_nfree_ok; [ | | | eauto ]; eauto.
  + rewrite <- nfree_ok_value_list_Forall. eauto.
  + intros. simpl. refold_nfree_ok nfrees. split; eauto.
    rewrite nfree_ok_list_pair_Forall. eauto.

Qed.

Lemma public_value_nfree_ok : forall Ameta v,
    public_value Ameta v ->
    nfree_ok_value (map m_nfree Ameta) v.
induction v using value_ind'; intros0 Hpub; invc Hpub.
- simpl. refold_nfree_ok_value (map m_nfree Ameta).
  rewrite nfree_ok_value_list_Forall.
  list_magic_on (args, tt).
- simpl. refold_nfree_ok_value (map m_nfree Ameta).
  split.
  + erewrite map_nth_error; [ | eauto ]. congruence.
  + rewrite nfree_ok_value_list_Forall.
    list_magic_on (free, tt).
- constructor.
Qed.

Definition no_arg : expr -> Prop :=
    let fix go e :=
        let fix go_list es :=
            match es with
            | [] => True
            | e :: es => go e /\ go_list es
            end in
        let fix go_pair p :=
            let '(e, _) := p in
            go e in
        let fix go_list_pair ps :=
            match ps with
            | [] => True
            | p :: ps => go_pair p /\ go_list_pair ps
            end in
        match e with
        | Value v => True
        | Arg => False
        | UpVar _ => True
        | Call f a => go f /\ go a
        | MkConstr _ args => go_list args
        | Elim cases target =>
                go_list_pair cases /\
                go target
        | MkClose fname free =>
                go_list free
        | OpaqueOp op args => go_list args
        end in go.

Definition no_arg_list :=
    let go := no_arg in
    let fix go_list es :=
        match es with
        | [] => True
        | e :: es => go e /\ go_list es
        end in go_list.

Definition no_arg_pair : (expr * rec_info) -> Prop :=
    let go := no_arg in
    let fix go_pair p :=
        let '(e, r) := p in
        go e in go_pair.

Definition no_arg_list_pair :=
    let go_pair := no_arg_pair in
    let fix go_list_pair ps :=
        match ps with
        | [] => True
        | p :: ps => go_pair p /\ go_list_pair ps
        end in go_list_pair.

Ltac refold_no_arg :=
    fold (no_arg_list) in *;
    fold (no_arg_pair) in *;
    fold (no_arg_list_pair) in *.

Lemma no_arg_list_Forall : forall es,
    no_arg_list es ->
    Forall (no_arg) es.
induction es; intro HH; simpl in *.
- constructor.
- break_and. constructor; eauto.
Qed.

Lemma no_arg_list_Forall' : forall es,
    Forall (no_arg) es ->
    no_arg_list es.
induction es; intro HH; simpl in *.
- constructor.
- on (Forall _ _), invc. constructor; eauto.
Qed.

Lemma no_arg_list_pair_Forall : forall es,
    no_arg_list_pair es ->
    Forall (no_arg_pair) es.
induction es; intro HH; simpl in *.
- constructor.
- break_and. constructor; eauto.
Qed.

Lemma no_arg_list_pair_Forall' : forall es,
    Forall (no_arg_pair) es ->
    no_arg_list_pair es.
induction es; intro HH; simpl in *.
- constructor.
- on (Forall _ _), invc. constructor; eauto.
Qed.

Definition check_no_arg : forall e,
    { no_arg e } + { ~ no_arg e }.
intros ?.
induction e using expr_rect_mut with
    (Pl := fun es =>
        { no_arg_list es } +
        { ~ no_arg_list es })
    (Pp := fun p =>
        { no_arg_pair p } +
        { ~ no_arg_pair p })
    (Plp := fun ps =>
        { no_arg_list_pair ps } +
        { ~ no_arg_list_pair ps }).
all: try solve [eassumption | left; constructor].

- (* Arg *) right. inversion 1.
- (* Call *)
  destruct IHe1, IHe2; simpl; solve [left; eauto | right; inversion 1; eauto].
- (* Elim *)
  destruct IHe, IHe0; simpl; refold_no_arg;
    solve [left; eauto | right; inversion 1; eauto].

(* list, pair, etc *)
- destruct IHe, IHe0; simpl; refold_no_arg;
    solve [left; eauto | right; inversion 1; eauto].
- destruct IHe, IHe0; simpl; refold_no_arg;
    solve [left; eauto | right; inversion 1; eauto].
Defined.

Definition check_no_arg_list : forall exprs,
    { Forall (no_arg) exprs } +
    { ~ Forall (no_arg) exprs }.
induction exprs.
{ left. constructor. }

rename a into e.
destruct (check_no_arg e), IHexprs.
all: try solve [left; eauto | right; inversion 1; eauto].
Defined.

Definition check_no_arg_list_pair : forall ps,
    { no_arg_list_pair ps } +
    { ~ no_arg_list_pair ps }.
induction ps.
{ left. constructor. }

destruct a as [e r].
destruct (check_no_arg e), IHps.
all: try solve [right; inversion 1; eauto].
left. simpl. auto.
Defined.

Lemma unroll_elim_no_arg :
    forall case args rec mk_rec e',
    no_arg case ->
    (forall e, no_arg e -> no_arg (mk_rec e)) ->
    unroll_elim case args rec mk_rec = Some e' ->
    no_arg e'.
first_induction args; destruct rec; intros0 Hcase Hmk_rec Hunroll; try discriminate.
  { simpl in *. congruence. }
simpl in *.  remember (if b then _ else _) as case'.
i_lem (IHargs case').
subst case'. destruct b; simpl; eauto.
split; eauto. i_lem Hmk_rec.
Qed.

Definition elim_cases_no_arg : expr -> Prop :=
    let fix go e :=
        let fix go_list es :=
            match es with
            | [] => True
            | e :: es => go e /\ go_list es
            end in
        let fix go_pair p :=
            let '(e, _) := p in
            go e in
        let fix go_list_pair ps :=
            match ps with
            | [] => True
            | p :: ps => go_pair p /\ go_list_pair ps
            end in
        match e with
        | Value v => True
        | Arg => True
        | UpVar _ => True
        | Call f a => go f /\ go a
        | MkConstr _ args => go_list args
        | Elim cases target =>
                no_arg_list_pair cases /\
                go_list_pair cases /\
                go target
        | MkClose fname free =>
                go_list free
        | OpaqueOp _ args => go_list args
        end in go.

Definition elim_cases_no_arg_list :=
    let go := elim_cases_no_arg in
    let fix go_list es :=
        match es with
        | [] => True
        | e :: es => go e /\ go_list es
        end in go_list.

Definition elim_cases_no_arg_pair : (expr * rec_info) -> Prop :=
    let go := elim_cases_no_arg in
    let fix go_pair p :=
        let '(e, r) := p in
        go e in go_pair.

Definition elim_cases_no_arg_list_pair :=
    let go_pair := elim_cases_no_arg_pair in
    let fix go_list_pair ps :=
        match ps with
        | [] => True
        | p :: ps => go_pair p /\ go_list_pair ps
        end in go_list_pair.

Ltac refold_elim_cases_no_arg :=
    fold (elim_cases_no_arg_list) in *;
    fold (elim_cases_no_arg_pair) in *;
    fold (elim_cases_no_arg_list_pair) in *.

Inductive elim_cases_no_arg_state : state -> Prop :=
| EcnasRun : forall e l k,
        elim_cases_no_arg e ->
        (forall v, elim_cases_no_arg_state (k v)) ->
        elim_cases_no_arg_state (Run e l k)
| EcnasStop : forall v, elim_cases_no_arg_state (Stop v).

Definition check_elim_cases_no_arg : forall e,
    { elim_cases_no_arg e } + { ~ elim_cases_no_arg e }.
intros ?.
induction e using expr_rect_mut with
    (Pl := fun es =>
        { elim_cases_no_arg_list es } +
        { ~ elim_cases_no_arg_list es })
    (Pp := fun p =>
        { elim_cases_no_arg_pair p } +
        { ~ elim_cases_no_arg_pair p })
    (Plp := fun ps =>
        { elim_cases_no_arg_list_pair ps } +
        { ~ elim_cases_no_arg_list_pair ps }).
all: try solve [eassumption | left; constructor].

- (* Call *)
  destruct IHe1, IHe2; simpl; solve [left; eauto | right; inversion 1; eauto].
- (* Elim *)
  destruct (check_no_arg_list_pair cases); [ | right; inversion 1; auto].
  destruct IHe, IHe0; simpl; refold_elim_cases_no_arg;
    try solve [left; eauto | right; intro; break_and; auto].

(* list, pair, etc *)
- destruct IHe, IHe0; simpl; refold_elim_cases_no_arg;
    solve [left; eauto | right; inversion 1; eauto].
- destruct IHe, IHe0; simpl; refold_elim_cases_no_arg;
    solve [left; eauto | right; inversion 1; eauto].
Defined.

Definition check_elim_cases_no_arg_list : forall exprs,
    { Forall (elim_cases_no_arg) exprs } +
    { ~ Forall (elim_cases_no_arg) exprs }.
induction exprs.
{ left. constructor. }

rename a into e.
destruct (check_elim_cases_no_arg e), IHexprs.
all: try solve [left; eauto | right; inversion 1; eauto].
Defined.

Lemma elim_cases_no_arg_list_Forall : forall es,
    elim_cases_no_arg_list es <->
    Forall (elim_cases_no_arg) es.
induction es; split; intro HH.
- constructor.
- constructor.
- invc HH. constructor; tauto.
- invc HH. constructor; tauto.
Qed.

Lemma elim_cases_no_arg_list_pair_Forall : forall es,
    elim_cases_no_arg_list_pair es <->
    Forall (elim_cases_no_arg_pair) es.
induction es; split; intro HH.
- constructor.
- constructor.
- invc HH. constructor; tauto.
- invc HH. constructor; tauto.
Qed.

Lemma unroll_elim_cases_no_arg :
    forall case args rec mk_rec e',
    elim_cases_no_arg case ->
    (forall e, elim_cases_no_arg e -> elim_cases_no_arg (mk_rec e)) ->
    unroll_elim case args rec mk_rec = Some e' ->
    elim_cases_no_arg e'.
first_induction args; destruct rec; intros0 Hcase Hmk_rec Hunroll; try discriminate.
  { simpl in *. congruence. }
simpl in *.  remember (if b then _ else _) as case'.
i_lem (IHargs case').
subst case'. destruct b; simpl; eauto.
split; eauto. i_lem Hmk_rec.
Qed.

Lemma step_elim_cases_no_arg : forall E s s',
    Forall elim_cases_no_arg E ->
    elim_cases_no_arg_state s ->
    sstep E s s' ->
    elim_cases_no_arg_state s'.
intros0 Henv II STEP.
invc STEP; invc II;
eauto.

- (* SCloseStep *)
  simpl in *. refold_elim_cases_no_arg.
  on _, rewrite_fwd elim_cases_no_arg_list_Forall. on _, invc_using Forall_3part_inv.
  i_ctor. i_ctor. refold_elim_cases_no_arg.
  rewrite elim_cases_no_arg_list_Forall. i_lem Forall_app. i_ctor.

- (* SConstrStep *)
  simpl in *. refold_elim_cases_no_arg.
  on _, rewrite_fwd elim_cases_no_arg_list_Forall. on _, invc_using Forall_3part_inv.
  i_ctor. i_ctor. refold_elim_cases_no_arg.
  rewrite elim_cases_no_arg_list_Forall. i_lem Forall_app. i_ctor.

- (* SOpaqueOpStep *)
  simpl in *. refold_elim_cases_no_arg.
  on _, rewrite_fwd elim_cases_no_arg_list_Forall. on _, invc_using Forall_3part_inv.
  i_ctor. i_ctor. refold_elim_cases_no_arg.
  rewrite elim_cases_no_arg_list_Forall. i_lem Forall_app. i_ctor.

- (* SCallL *)
  simpl in *. refold_elim_cases_no_arg. break_and.
  i_ctor. i_ctor.

- (* SCallR *)
  simpl in *. refold_elim_cases_no_arg. break_and.
  i_ctor. i_ctor.

- (* SMakeCall *)
  i_ctor. i_lem Forall_nth_error.

- (* SElimStep *)
  simpl in *. refold_elim_cases_no_arg. break_and.
  i_ctor. i_ctor.

- (* SEliminate *)
  simpl in *. refold_elim_cases_no_arg. break_and.
  i_ctor. i_lem unroll_elim_cases_no_arg.
  + on _, rewrite_fwd elim_cases_no_arg_list_pair_Forall.
    fwd eapply Forall_nth_error with (xs := cases); eauto.
  + i_ctor.
Qed.