Require Import Relation_Operators.
Require Import Util.Subset.
Require Import Util.Postfix.
Require Import Util.FromList.
Require Import Lang.Syntax Lang.Bindings Lang.Operational.
Require Import Lang.BindingsFacts.
Require Import Lang.Sim.
Require Import Lang.SimFacts.
Require Import Relation_Operators.

Set Implicit Arguments.

Lemma step_n_to_step_refl_tran n cfg₁ cfg₂ :
step_n n cfg₁ cfg₂ → step_refl_tran cfg₁ cfg₂.
Proof.
induction 1 ; simpl.
+ constructor.
+ econstructor ; eauto.
Qed.

Lemma step_refl_tran_to_step_n cfg₁ cfg₂ :
step_refl_tran cfg₁ cfg₂ → ∃ n, step_n n cfg₁ cfg₂.
Proof.
induction 1 as [ | ? ? ? ? ? [n ?] ].
+ exists 0 ; constructor.
+ exists (S n) ; econstructor ; eauto.
Qed.

Section section_step_monotone.

Hint Constructors postfix.

Lemma step_monotone_config_aux :
∀ c₁ c₂, step c₁ c₂ →
∀ ξ₁ ξ₂ t₁ t₂, c₁ = ⟨ξ₁, t₁⟩ → c₂ = ⟨ξ₂, t₂⟩ →
postfix ξ₁ ξ₂.
Proof.
induction 1 ; intros ; crush ; eauto.
Qed.

Lemma step_monotone_config ξ₁ ξ₂ t₁ t₂ :
step ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
postfix ξ₁ ξ₂.
Proof.
intro ; eapply step_monotone_config_aux ; eauto.
Qed.

Hint Extern 0 => match goal with
| [H : step ⟨_, _⟩ ⟨_, _⟩ |- _] => eapply step_monotone_config in H
end.

Hint Resolve postfix_trans.

Lemma step_tran_monotone_config_aux :
∀ c₁ c₂, step_tran c₁ c₂ →
∀ ξ₁ ξ₂ t₁ t₂, c₁ = ⟨ξ₁, t₁⟩ → c₂ = ⟨ξ₂, t₂⟩ →
postfix ξ₁ ξ₂.
Proof.
induction 1 as [ | ? [ξ₁' t₁'] ? ? ? IH ] ; intros ; subst.
+ eauto.
+ eauto.
Qed.

Lemma step_tran_monotone_config ξ₁ ξ₂ t₁ t₂ :
step_tran ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
postfix ξ₁ ξ₂.
Proof.
intro ; eapply step_tran_monotone_config_aux ; eauto.
Qed.

Lemma step_refl_tran_monotone_config_aux :
∀ c₁ c₂, step_refl_tran c₁ c₂ →
∀ ξ₁ ξ₂ t₁ t₂, c₁ = ⟨ξ₁, t₁⟩ → c₂ = ⟨ξ₂, t₂⟩ →
postfix ξ₁ ξ₂.
Proof.
induction 1 as [ | ? [ξ₁' t₁'] ? ? ? IH ] ; intros ; subst.
+ crush.
+ eauto.
Qed.

Lemma step_refl_tran_monotone_config ξ₁ ξ₂ t₁ t₂ :
step_refl_tran ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
postfix ξ₁ ξ₂.
Proof.
intro ; eapply step_refl_tran_monotone_config_aux ; eauto.
Qed.

End section_step_monotone.

Section section_ktx_congruence.

Hint Constructors step.

Fixpoint ktx_congruence ξ₁ ξ₂ t₁ t₂ (K : ktx0) :
step ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ → step ⟨ξ₁, ktx_plug K t₁⟩ ⟨ξ₂, ktx_plug K t₂⟩.
Proof.
destruct K ; crush.
Qed.

Local Lemma ktx_tran_congruence_aux:
∀ c₁ c₂, step_tran c₁ c₂ →
∀ ξ₁ ξ₂ t₁ t₂, c₁ = ⟨ξ₁, t₁⟩ → c₂ = ⟨ξ₂, t₂⟩ →
∀ K, step_tran ⟨ξ₁, ktx_plug K t₁⟩ ⟨ξ₂, ktx_plug K t₂⟩.
Proof.
induction 1 as [ | ? [ξ' t'] ? ? ? IH ] ; intros ; subst.
+ apply t1n_step.
  apply ktx_congruence.
  assumption.
+ eapply t1n_trans.
  - apply ktx_congruence.
    eassumption.
  - apply IH ; crush.
Qed.

Lemma ktx_tran_congruence:
∀ ξ₁ ξ₂ t₁ t₂, step_tran ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
∀ K, step_tran ⟨ξ₁, ktx_plug K t₁⟩ ⟨ξ₂, ktx_plug K t₂⟩.
Proof.
intros ; eapply ktx_tran_congruence_aux ; eauto.
Qed.

Local Lemma ktx_refl_tran_congruence_aux:
∀ c₁ c₂, step_refl_tran c₁ c₂ →
∀ ξ₁ ξ₂ t₁ t₂, c₁ = ⟨ξ₁, t₁⟩ → c₂ = ⟨ξ₂, t₂⟩ →
∀ K, step_refl_tran ⟨ξ₁, ktx_plug K t₁⟩ ⟨ξ₂, ktx_plug K t₂⟩.
Proof.
induction 1 as [ | ? [ξ' t'] ? ? ? IH ] ; intros ; subst.
+ match goal with
  | [ H : ⟨_, _⟩ = ⟨_, _⟩ |- _ ] => inversion H ; clear H ; subst
  end.
  apply rt1n_refl.
+ eapply rt1n_trans.
  - apply ktx_congruence.
    eassumption.
  - apply IH ; crush.
Qed.

Lemma ktx_refl_tran_congruence:
∀ ξ₁ ξ₂ t₁ t₂, step_refl_tran ⟨ξ₁, t₁⟩ ⟨ξ₂, t₂⟩ →
∀ K, step_refl_tran ⟨ξ₁, ktx_plug K t₁⟩ ⟨ξ₂, ktx_plug K t₂⟩.
Proof.
intros ; eapply ktx_refl_tran_congruence_aux ; eauto.
Qed.

End section_ktx_congruence.

Section section_ktx_comp.
Context (EV HV V L : Set).

Lemma ktx_plug_comp
(K J : ktx EV HV V L) (t : tm EV HV V L) :
ktx_plug K (ktx_plug J t) = ktx_plug (ktx_comp K J) t.
Proof.
induction K ; simpl ; crush.
Qed.

Lemma tunnels_ktx_comp (X : var) (K J : ktx EV HV V L) :
tunnels X K →
tunnels X J →
tunnels X (ktx_comp K J).
Proof.
induction K ; crush.
Qed.

End section_ktx_comp.

Fixpoint L_map_ktx_plug
(EV HV V L L' : Set) (f : L → L')
(K : ktx EV HV V L) (t : tm EV HV V L) {struct K} :
L_map_tm f (ktx_plug K t) =
ktx_plug (L_map_ktx f K) (L_map_tm f t).
Proof.
destruct K ; simpl ; crush.
Qed.

Fixpoint HV_map_ktx_plug
(EV HV HV' V L : Set) (f : HV → lbl HV' L)
(K : ktx EV HV V L) (t : tm EV HV V L) {struct K} :
HV_map_tm f (ktx_plug K t) =
ktx_plug (HV_map_ktx f K) (HV_map_tm f t).
Proof.
destruct K ; simpl ; crush.
Qed.

Fixpoint EV_map_ktx_plug
(EV EV' HV V L : Set) (f : EV → eff EV' HV L)
(K : ktx EV HV V L) (t : tm EV HV V L) {struct K} :
EV_map_tm f (ktx_plug K t) =
ktx_plug (EV_map_ktx f K) (EV_map_tm f t).
Proof.
destruct K ; simpl ; crush.
Qed.

Fixpoint V_map_ktx_plug
(EV HV V V' L : Set) (f : V → val EV HV V' L)
(K : ktx EV HV V L) (t : tm EV HV V L) {struct K} :
V_map_tm f (ktx_plug K t) =
ktx_plug (V_map_ktx f K) (V_map_tm f t).
Proof.
destruct K ; simpl ; crush.
Qed.

Fixpoint L_bind_ktx_plug
(EV HV V L L' : Set) (f : L → lid L')
(K : ktx EV HV V L) (t : tm EV HV V L) {struct K} :
L_bind_tm f (ktx_plug K t) =
ktx_plug (L_bind_ktx f K) (L_bind_tm f t).
Proof.
destruct K ; simpl ; crush.
Qed.

Fixpoint HV_bind_ktx_plug
(EV HV HV' V L : Set) (f : HV → hd EV HV' V L)
(K : ktx EV HV V L) (t : tm EV HV V L) {struct K} :
HV_bind_tm f (ktx_plug K t) =
ktx_plug (HV_bind_ktx f K) (HV_bind_tm f t).
Proof.
destruct K ; simpl ; crush.
Qed.

Fixpoint EV_bind_ktx_plug
(EV EV' HV V L : Set) (f : EV → eff EV' HV L)
(K : ktx EV HV V L) (t : tm EV HV V L) {struct K} :
EV_bind_tm f (ktx_plug K t) =
ktx_plug (EV_bind_ktx f K) (EV_bind_tm f t).
Proof.
destruct K ; simpl ; crush.
Qed.

Fixpoint V_bind_ktx_plug
(EV HV V V' L : Set) (f : V → val EV HV V' L)
(K : ktx EV HV V L) (t : tm EV HV V L) {struct K} :
V_bind_tm f (ktx_plug K t) =
ktx_plug (V_bind_ktx f K) (V_bind_tm f t).
Proof.
destruct K ; simpl ; crush.
Qed.

Section sectoin_stuck_term_facts.

Local Ltac auto_stuck := repeat match goal with
| [ H : step ⟨_, tm_val _⟩ _ |- _ ] => inversion H ; subst ; clear H
| [ H : step ⟨_, tm_let _ _⟩ _ |- _ ] => inversion H ; subst ; clear H
| [ H : step ⟨_, tm_eapp _ _⟩ _ |- _ ] => inversion H ; subst ; clear H
| [ H : step ⟨_, tm_happ _ _⟩ _ |- _ ] => inversion H ; subst ; clear H
| [ H : step ⟨_, tm_app _ _⟩ _ |- _ ] => inversion H ; subst ; clear H
| [ H : step ⟨_, ⬇ _⟩ _ |- _ ] => inversion H ; subst ; clear H
| [ H : step ⟨_, ⇩ _ _⟩ _ |- _ ] => inversion H ; subst ; clear H
| [ H : step ⟨_, ⇧ _⟩ _ |- _ ] => inversion H ; subst ; clear H

| [ H : ktx_plug ?K _ = tm_val _ |- _ ] =>
  destruct K ; discriminate
| [ H : tm_val _ = ktx_plug ?K _ |- _ ] =>
  destruct K ; discriminate

| [ H : ⇧ _ = ⇧ _ |- _ ] => inversion H ; subst ; clear H
| [ H : ⇩ _ _ = ⇩ _ _ |- _ ] => inversion H ; subst ; clear H
| [ H : tm_let _ _ = tm_let _ _ |- _ ] => inversion H ; subst ; clear H
| [ H : tm_eapp _ _ = tm_eapp _ _ |- _ ] => inversion H ; subst ; clear H
| [ H : tm_happ _ _ = tm_happ _ _ |- _ ] => inversion H ; subst ; clear H
| [ H : tm_app _ _ = tm_app _ _ |- _ ] => inversion H ; subst ; clear H
end.

Lemma ktx_plug_up_val_unique EV HV V L 𝔽1 𝔽2
(K1 : ktx EV HV V L) t1 X1 (v1 : val EV HV V L) K2 t2 X2 (v2 : val EV HV V L) :
ktx_plug K1 (tm_app (⇧ (hd_def 𝔽1 (lid_f X1) t1)) v1) =
ktx_plug K2 (tm_app (⇧ (hd_def 𝔽2 (lid_f X2) t2)) v2) →
𝔽1 = 𝔽2 ∧ K1 = K2 ∧ t1 = t2 ∧ X1 = X2 ∧ v1 = v2.
Proof.
generalize K2 ; clear K2.
induction K1 ; simpl ; intros K2 H.
+ destruct K2 ; simpl in H ; try discriminate ; auto_stuck ; crush.
+ destruct K2 ; simpl in H ; try discriminate ; auto_stuck.
  match goal with
  | [ H : ktx_plug _ _ = ktx_plug _ _ |- _ ] => apply IHK1 in H
  end ; crush.
+ destruct K2 ; simpl in H ; try discriminate ; auto_stuck.
  match goal with
  | [ H : ktx_plug _ _ = ktx_plug _ _ |- _ ] => apply IHK1 in H
  end ; crush.
+ destruct K2 ; simpl in H ; try discriminate ; auto_stuck.
  match goal with
  | [ H : ktx_plug _ _ = ktx_plug _ _ |- _ ] => apply IHK1 in H
  end ; crush.
+ destruct K2 ; simpl in H ; try discriminate ; auto_stuck.
  match goal with
  | [ H : ktx_plug _ _ = ktx_plug _ _ |- _ ] => apply IHK1 in H
  end ; crush.
+ destruct K2 ; simpl in H ; try discriminate ; auto_stuck.
  match goal with
  | [ H : ktx_plug _ _ = ktx_plug _ _ |- _ ] => apply IHK1 in H
  end ; crush.
+ destruct K2 ; simpl in H ; try discriminate ; auto_stuck.
  match goal with
  | [ H : ktx_plug _ _ = ktx_plug _ _ |- _ ] => apply IHK1 in H
  end ; crush.
Qed.

Fixpoint ktx_plug_up_val_is_stuck ξ ξ' t' 𝔽 K r X (v : val0)
(Step : step ⟨ξ, ktx_plug K (tm_app (⇧ (hd_def 𝔽 (lid_f X) r)) v)⟩ ⟨ξ', t'⟩)
(Tunnel : tunnels X K) {struct K} :
False.
Proof.
destruct K ; simpl in Step, Tunnel.
+ inversion Step ; subst ; clear Step.
  - auto_stuck.
  - auto_stuck.
+ destruct Tunnel.
  inversion Step ; subst ; clear Step.
  - auto_stuck.
  - match goal with
    | [ H : ktx_plug _ (tm_app (tm_val (⇧ _)) _)  =
            ktx_plug _ (tm_app (tm_val (⇧ _)) _) |- _ ] =>
      eapply ktx_plug_up_val_unique in H
    end.
    crush.
  - eapply ktx_plug_up_val_is_stuck ; eauto.
+ inversion Step ; subst ; clear Step.
  - auto_stuck.
  - eapply ktx_plug_up_val_is_stuck ; eauto.
+ inversion Step ; subst ; clear Step.
  - auto_stuck.
  - eapply ktx_plug_up_val_is_stuck ; eauto.
+ inversion Step ; subst ; clear Step.
  - auto_stuck.
  - eapply ktx_plug_up_val_is_stuck ; eauto.
+ inversion Step ; subst ; clear Step.
  - auto_stuck.
  - eapply ktx_plug_up_val_is_stuck ; eauto.
  - auto_stuck.
+ inversion Step ; subst ; clear Step.
  - auto_stuck.
  - auto_stuck.
  - eapply ktx_plug_up_val_is_stuck ; eauto.
Qed.

End sectoin_stuck_term_facts.

Section section_sim_operational.

Import TLC.LibList.

Lemma sim_tunnels ξ ξ' EV LV V L (K K' : ktx EV LV V L) X X' :
ktx_sim ξ ξ' K K' →
var_sim ξ ξ' X X' →
tunnels X K →
noduplicates ξ' →
tunnels X' K'.
Proof.
induction 1 as [ | K K' Y Y' ? ? HY | | | | | ] ; simpl ;
intros HX Tunnel NoDup.
+ crush.
+ split ; [ crush | ].
  intro ; subst.
  destruct Tunnel as [ _ H' ] ; apply H'.
  clear - HX HY NoDup.
  destruct HX as [nX [NX NX']].
  destruct HY as [nY [NY NX'2]].
  assert (nX = nY) ; [ eauto using noduplicates_Nth_same_inv | subst nY ].
  eauto using Nth_functional.
+ crush.
+ crush.
+ crush.
+ crush.
+ crush.
Qed.

Hint Constructors lid_sim lbl_sim ef_sim eff_sim ty_sim.
Hint Constructors hd_sim ktx_sim val_sim tm_sim.

Lemma ktx_plug_sim ξ ξ' EV LV V L (K K' : ktx EV LV V L) t t' :
ktx_sim ξ ξ' K K' → tm_sim ξ ξ' t t' → tm_sim ξ ξ' (ktx_plug K t) (ktx_plug K' t').
Proof.
induction 1 ; crush.
Qed.

Lemma ktx_plug_sim_l_inv EV LV V L : ∀ K (s : tm EV LV V L) t' ξ ξ',
tm_sim ξ ξ' (ktx_plug K s) t' →
∃ K' s', t' = ktx_plug K' s' ∧ ktx_sim ξ ξ' K K' ∧ tm_sim ξ ξ' s s'.
Proof.
induction K ; simpl ; intros ? ? ? ? H ; inversion H ; subst ; clear H.
+ repeat exists ; crush.
+ repeat exists ; crush.
+ repeat exists ; crush.
+ repeat exists ; crush.
+ repeat exists ; crush.
+ repeat exists ; crush.
+ repeat exists ; crush.
+ match goal with
  | [ H : tm_sim _ _ (ktx_plug K _) _ |- _ ] =>
    eapply IHK in H ; destruct H as [? [? [? [? ?]]]] ; subst
  end.
  eexists (ktx_down _ _) ; eexists ; crush.
+ match goal with
  | [ H : tm_sim _ _ (ktx_plug K _) _ |- _ ] =>
    eapply IHK in H ; destruct H as [? [? [? [? ?]]]] ; subst
  end.
  eexists (ktx_let _ _) ; eexists ; crush.
+ match goal with
  | [ H : tm_sim _ _ (ktx_plug K _) _ |- _ ] =>
    eapply IHK in H ; destruct H as [? [? [? [? ?]]]] ; subst
  end.
  eexists (ktx_eapp _ _) ; eexists ; crush.
+ match goal with
  | [ H : tm_sim _ _ (ktx_plug K _) _ |- _ ] =>
    eapply IHK in H ; destruct H as [? [? [? [? ?]]]] ; subst
  end.
  eexists (ktx_happ _ _) ; eexists ; crush.
+ match goal with
  | [ H : tm_sim _ _ (ktx_plug K _) _ |- _ ] =>
    eapply IHK in H ; destruct H as [? [? [? [? ?]]]] ; subst
  end.
  eexists (ktx_app1 _ _) ; eexists ; crush.
+ repeat match goal with
  | [ H : tm_sim _ _ (tm_val _) _ |- _ ] =>
    inversion H ; subst ; clear H
  | [ H : tm_sim _ _ (ktx_plug K _) _ |- _ ] =>
    eapply IHK in H ; destruct H as [? [? [? [? ?]]]] ; subst
  end.
  eexists (ktx_app2 _ _) ; eexists ; crush.
Qed.

Ltac solve_sim := repeat match goal with
| [ H : tm_sim _ _ (tm_val _ ) _ |- _ ] => inversion H ; subst ; clear H
| [ H : tm_sim _ _ (tm_let _ _) _ |- _ ] => inversion H ; subst ; clear H
| [ H : tm_sim _ _ (tm_eapp _ _) _ |- _ ] => inversion H ; subst ; clear H
| [ H : tm_sim _ _ (tm_happ _ _) _ |- _ ] => inversion H ; subst ; clear H
| [ H : tm_sim _ _ (tm_app _ _) _ |- _ ] => inversion H ; subst ; clear H
| [ H : tm_sim _ _ (⬇ _) _ |- _ ] => inversion H ; subst ; clear H
| [ H : tm_sim _ _ (⇩ _ _) _ |- _ ] => inversion H ; subst ; clear H
| [ H : tm_sim _ _ (⇧ _) _ |- _ ] => inversion H ; subst ; clear H
| [ H : tm_sim _ _ _ (tm_val _ ) |- _ ] => inversion H ; subst ; clear H
| [ H : tm_sim _ _ (ktx_plug _ _) _ |- _ ] =>
  apply ktx_plug_sim_l_inv in H ; destruct H as [? [? [? [? ?]]]] ; subst

| [ H : val_sim _ _ (val_fun _) _ |- _ ] => inversion H ; subst ; clear H
| [ H : val_sim _ _ (val_efun _) _ |- _ ] => inversion H ; subst ; clear H
| [ H : val_sim _ _ (val_hfun _) _ |- _ ] => inversion H ; subst ; clear H
| [ H : val_sim _ _ (val_up _) _ |- _ ] => inversion H ; subst ; clear H
| [ H : hd_sim _ _ (hd_def _ _ _) _ |- _ ] => inversion H ; subst ; clear H
| [ H : lid_sim _ _ (lid_f _) _ |- _ ] => inversion H ; subst ; clear H

| [ H : step ⟨_, tm_val _⟩ _ |- _ ] => inversion H ; subst ; clear H
| [ H : step ⟨_, tm_let _ _⟩ _ |- _ ] => inversion H ; subst ; clear H
| [ H : step ⟨_, tm_eapp _ _⟩ _ |- _ ] => inversion H ; subst ; clear H
| [ H : step ⟨_, tm_happ _ _⟩ _ |- _ ] => inversion H ; subst ; clear H
| [ H : step ⟨_, tm_app _ _⟩ _ |- _ ] => inversion H ; subst ; clear H
| [ H : step ⟨_, ⬇ _⟩ _ |- _ ] => inversion H ; subst ; clear H
| [ H : step ⟨_, ⇩ _ _⟩ _ |- _ ] => inversion H ; subst ; clear H
| [ H : step ⟨_, ⇧ _⟩ _ |- _ ] => inversion H ; subst ; clear H

| [ H : ktx_plug ?K _ = tm_val _ |- _ ] => destruct K ; discriminate
| [ H : tm_val _ = ktx_plug ?K _ |- _ ] => destruct K ; discriminate

| [ H : ktx_plug _ (tm_app (tm_val (⇧ (hd_def _ _ _))) _) =
        ktx_plug _ (tm_app (tm_val (⇧ (hd_def _ _ _))) _) |- _ ] =>
  apply ktx_plug_up_val_unique in H ; destruct H as [? [? ?]]
end.

Hint Resolve var_sim_future lid_sim_future lbl_sim_future eff_sim_future ty_sim_future.
Hint Resolve hd_sim_future ktx_sim_future val_sim_future tm_sim_future.

Hint Resolve EV_bind_tm_sim HV_bind_tm_sim V_bind_tm_sim L_bind_tm_sim V_map_ktx_sim.

Hint Resolve ktx_plug_sim.

Hint Constructors step.

Lemma step_preserves_sim
cfg₁ cfg₂ (H₁ : step cfg₁ cfg₂) :
∀ ξ₁ t₁ ξ₂ t₂ (Hcfg₁ : cfg₁ = ⟨ξ₁, t₁⟩) (Hcfg₂ : cfg₂ = ⟨ξ₂, t₂⟩)
ξ₁' t₁'
(NoDup_ξ₁ : noduplicates ξ₁)
(NoDup_ξ₁' : noduplicates ξ₁')
(Hsim : tm_sim ξ₁ ξ₁' t₁ t₁')
ξ₂' t₂'
(H₂ : step ⟨ξ₁', t₁'⟩ ⟨ξ₂', t₂'⟩),
tm_sim ξ₂ ξ₂' t₂ t₂' ∧
((ξ₂ = ξ₁ ∧ ξ₂' = ξ₁') ∨ (∃ X X', ξ₂ = X :: ξ₁ ∧ ξ₂' = X' :: ξ₁')).
Proof.
induction H₁ ; intros ; inversion Hcfg₁ ; inversion Hcfg₂ ; clear Hcfg₁ Hcfg₂ ; subst.
+ solve_sim ; crush.
+ solve_sim ; crush.
+ solve_sim ; crush.
+ solve_sim ; crush.
+ solve_sim ; split.
  - constructor ; [ exists 0 ; crush | ].
    apply L_bind_tm_sim ; [ | eauto 6 ].
    intro x ; destruct x ; simpl ; [ | crush ].
    constructor ; exists 0 ; crush.
  - right ; eauto.
+ solve_sim ; crush.
+ solve_sim.
  - crush.
  - exfalso.
    eauto using ktx_plug_up_val_is_stuck, sim_tunnels.
+ solve_sim.
  - exfalso.
    match goal with
    | [ H : tm_sim _ _ _ (ktx_plug K (tm_app (tm_val (⇧ _)) _)) |- _ ] =>
      apply tm_sim_sym in H ; apply ktx_plug_sim_l_inv in H ;
      destruct H as [?[?[?[??]]]] ; subst
    end.
    solve_sim.
    eauto using ktx_plug_up_val_is_stuck, sim_tunnels.
  - match goal with
    | [ H : tm_sim _ _ t₁ _ |- _ ] =>
      eapply IHH₁ in H ; try reflexivity ; try eassumption ; destruct H as [? ?]
    end.
    eauto.
+ solve_sim.
  match goal with
  | [ H : tm_sim _ _ t₁ _ |- _ ] =>
    eapply IHH₁ in H ; try reflexivity ; try eassumption ; destruct H as [? ?]
  end.
  eauto.
+ solve_sim.
  match goal with
  | [ H : tm_sim _ _ t₁ _ |- _ ] =>
    eapply IHH₁ in H ; try reflexivity ; try eassumption ; destruct H as [? ?]
  end.
  eauto.
+ solve_sim.
  match goal with
  | [ H : tm_sim _ _ t₁ _ |- _ ] =>
    eapply IHH₁ in H ; try reflexivity ; try eassumption ; destruct H as [? ?]
  end.
  eauto.
+ solve_sim.
  match goal with
  | [ H : tm_sim _ _ t₁ _ |- _ ] =>
    eapply IHH₁ in H ; try reflexivity ; try eassumption ; destruct H as [? ?]
  end.
  eauto.
+ solve_sim.
  match goal with
  | [ H : tm_sim _ _ t₁ _ |- _ ] =>
    eapply IHH₁ in H ; try reflexivity ; try eassumption ; destruct H as [? ?]
  end.
  eauto.
Qed.

Lemma sim_preserves_step
cfg₁ cfg₂ (H₁ : step cfg₁ cfg₂) :
∀ ξ₁ t₁ ξ₂ t₂ (Hcfg₁ : cfg₁ = ⟨ξ₁, t₁⟩) (Hcfg₂ : cfg₂ = ⟨ξ₂, t₂⟩)
ξ₁' t₁'
(NoDup_ξ₁ : noduplicates ξ₁)
(NoDup_ξ₁' : noduplicates ξ₁')
(Hsim : tm_sim ξ₁ ξ₁' t₁ t₁'),
∃ ξ₂' t₂', step ⟨ξ₁', t₁'⟩ ⟨ξ₂', t₂'⟩.
Proof.
induction H₁ ; intros ; inversion Hcfg₁ ; inversion Hcfg₂ ; clear Hcfg₁ Hcfg₂ ; subst.
+ solve_sim ; eauto.
+ solve_sim ; eauto.
+ solve_sim ; eauto.
+ solve_sim ; eauto.
+ pick_fresh_gen (from_list ξ₁') X'.
  solve_sim ; eauto.
+ solve_sim ; eauto.
+ solve_sim.
  eexists ; eexists.
  match goal with
  | [ H1 : var_sim ?ξ ?ξ' ?X ?X'1,
      H2 : var_sim ?ξ ?ξ' ?X ?X'2,
      NoDup : noduplicates ?ξ' |- _ ] =>
    specialize H1 as H1' ; specialize H2 as H2' ;
    destruct H1 as [n1 [? ?]] ; destruct H2 as [n2 [? ?]] ;
    assert (n1 = n2) ; [ eauto using noduplicates_Nth_same_inv | ] ;
    assert (X'1 = X'2) ; [ subst ; eauto using Nth_functional | ]
  end.
  subst ; constructor.
  eauto using sim_tunnels.
+ solve_sim.
  match goal with
  | [ H : tm_sim _ _ t₁ _ |- _ ] =>
    eapply IHH₁ in H ; try reflexivity ; try assumption ;
    destruct H as [? [? ?]]
  end.
  eauto.
+ solve_sim.
  match goal with
  | [ H : tm_sim _ _ t₁ _ |- _ ] =>
    eapply IHH₁ in H ; try reflexivity ; try assumption ;
    destruct H as [? [? ?]]
  end.
  eauto.
+ solve_sim.
  match goal with
  | [ H : tm_sim _ _ t₁ _ |- _ ] =>
    eapply IHH₁ in H ; try reflexivity ; try assumption ;
    destruct H as [? [? ?]]
  end.
  eauto.
+ solve_sim.
  match goal with
  | [ H : tm_sim _ _ t₁ _ |- _ ] =>
    eapply IHH₁ in H ; try reflexivity ; try assumption ;
    destruct H as [? [? ?]]
  end.
  eauto.
+ solve_sim.
  match goal with
  | [ H : tm_sim _ _ t₁ _ |- _ ] =>
    eapply IHH₁ in H ; try reflexivity ; try assumption ;
    destruct H as [? [? ?]]
  end.
  eauto.
+ solve_sim.
  match goal with
  | [ H : tm_sim _ _ t₁ _ |- _ ] =>
    eapply IHH₁ in H ; try reflexivity ; try assumption ;
    destruct H as [? [? ?]]
  end.
  eauto.
Qed.

End section_sim_operational.

Section section_step_vars.

Import TLC.LibList.

Hint Rewrite <- from_list_spec.

Lemma step_preserves_noduplicates :
∀ c₁ c₂, step c₁ c₂ → ∀ ξ₁ ξ₂ t₁ t₂, c₁ = ⟨ξ₁, t₁⟩ → c₂ = ⟨ξ₂, t₂⟩ →
noduplicates ξ₁ → noduplicates ξ₂.
Proof.
induction 1 ; intros ? ? ? ? Cfg₁ Cfg₂ NoDup ;
inversion Cfg₁ ; inversion Cfg₂ ; subst ; clear Cfg₁ Cfg₂ ; eauto.
constructors ; crush.
Qed.

Hint Extern 1 => match goal with
| [ H : _ \u _ \c _ |- _ ] => apply union_subset_inv in H ; destruct H
| [ H : step ⟨ ?ξ, _ ⟩ ⟨ ?ξ', _ ⟩ |- _ \c from_list ?ξ' ] =>
  assert (from_list ξ \c from_list ξ') ; [
    apply postfix_is_subset ; apply (step_monotone_config H) |
  ]
end.

Hint Resolve subset_refl subset_union_l subset_union_r.

Lemma step_preserves_closedness :
∀ c₁ c₂, step c₁ c₂ → ∀ ξ₁ ξ₂ t₁ t₂, c₁ = ⟨ξ₁, t₁⟩ → c₂ = ⟨ξ₂, t₂⟩ →
Xs_tm t₁ \c from_list ξ₁ → Xs_tm t₂ \c from_list ξ₂.
Proof.
induction 1 ; intros ? ? ? ? Cfg₁ Cfg₂ Closed ;
inversion Cfg₁ ; inversion Cfg₂ ; subst ; clear Cfg₁ Cfg₂ ; simpl in Closed |- *.
+ eapply subset_trans ; [ | exact Closed ].
  eapply subset_trans ; [ apply V_bind_tm_Xs with (B := Xs_val v) ; auto | ].
  rewrite union_comm ; auto.
+ eapply subset_trans ; [ | exact Closed ].
  eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := Xs_eff 𝓔) ; auto | ].
  auto using union_subset.
+ eapply subset_trans ; [ | exact Closed ].
  eapply subset_trans ; [ apply HV_bind_tm_Xs with (B := Xs_hd h) ; auto | ].
  auto using union_subset.
+ eapply subset_trans ; [ | exact Closed ].
  eapply subset_trans ; [ apply V_bind_tm_Xs with (B := Xs_val v) ; auto | ].
  auto using union_subset.
+ rewrite from_list_cons.
  apply union_subset ; [ | auto ].
  eapply subset_trans with (F := \{X} \u Xs_tm t).
  - eapply subset_trans ; [ apply L_bind_tm_Xs with (B := \{X}) ; auto | ].
    apply union_subset ; auto.
  - apply union_subset ; auto.
+ auto.
+ rewrite Xs_ktx_plug in Closed ; simpl in Closed.
  eapply subset_trans ; [ | exact Closed ].
  eapply subset_trans ; [ apply V_bind_tm_Xs with (B := Xs_ktx K \u \{X} \u Xs_val v) | ].
  - destruct x as [|[|x]] ; simpl ; [|auto|auto].
    rewrite Xs_ktx_plug, V_map_ktx_Xs ; simpl.
    repeat apply union_subset ; auto using subset_empty_l.
  - repeat apply union_subset ; auto.
+ simpl ; apply union_subset ; eauto using subset_trans.
+ simpl ; apply union_subset ; eauto using subset_trans.
+ simpl ; apply union_subset ; eauto using subset_trans.
+ simpl ; apply union_subset ; eauto using subset_trans.
+ simpl ; apply union_subset ; eauto using subset_trans.
+ simpl ; apply union_subset ; eauto using subset_trans.
Qed.

End section_step_vars.


(************************************************************************************)
(**                                                                                *)
(**                             The DatalogCert Library                             *)
(**                                                                                *)
(**             CNRS & Université Paris-Sud, Université Paris-Saclay                *)
(**                                                                                *)
(**                        Copyright 2016-2019 : FormalData                         *)
(**                                                                                *)
(**         Authors: Véronique Benzaken                                             *)
(**                  Évelyne Contejean                                              *)
(**                  Stefania Dumbrava                                              *)
(**                                                                                *)
(************************************************************************************)

From mathcomp
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype.
From mathcomp
Require Import tuple finfun bigop finset.

Require Import FL.bigop_aux.

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

(** * Standard Datalog in Coq

We define the *syntax* and *model-theoretic semantics*, as well as a bottom-up fixpoint evaluation
engine, for standard Datalog. The syntactic primitives of the language are terms (constants or variables),
atoms, clauses and programs. Semantically, *interpretations* (ground atom sets) are the main building blocks.
The bottom-up engine iteratively extends an initial seed substitution into one that matches all clause body atoms to an
existing interpretations (candidate model) and provably grounds the corresponding clause head, i.e, instantiates all of
its variables. To ease the proof-engineering effort, we distinguish between ground and non-ground constructs.
As such, we define corresponding separate types, both for the language primitives and for substitutions (we call
grounding substitutions "groundings"). *)

Section Datalog.

(** maximal number of program variables *)
Variable n        : nat.

(** program signature: constants and symbols as finite types and arities as finitely-supported functions *)
Variable constype : finType.
Variable symtype  : finType.
Variable arity    : {ffun symtype -> nat}.

Inductive constant := C of constype.
Definition of_constant c := let: C c := c in c.

(** instances for the type of constants *)
Canonical cons_subType      := Eval hnf in [newType for of_constant].
Canonical cons_eqType       := Eval hnf in EqType _     [eqMixin of constant by <: ].
Canonical cons_choiceType   := Eval hnf in ChoiceType _ [choiceMixin of constant by <:].
Canonical cons_countType    := Eval hnf in CountType  _ [countMixin  of constant by <:].
Canonical cons_subCountType := Eval hnf in [subCountType of constant].
Canonical cons_finType      := Eval hnf in FinType    _ [finMixin    of constant by <:].
Canonical cons_subFinType   := Eval hnf in [subFinType of constant].

(** "raw" ground atoms pack a symbol and an argument list of constants *)
Inductive raw_gatom := RawGAtom of symtype & seq constant.

(** extractors for the corresponding symbols and arguments of a "raw" ground atom *)
Definition sym_gatom ga := let: RawGAtom s_ga _   := ga in s_ga.
Definition arg_gatom ga := let: RawGAtom _ arg_ga := ga in arg_ga.

Lemma gatom_eta ga : ga = RawGAtom (sym_gatom ga) (arg_gatom ga).
Proof. by case: ga. Qed.

(** *** Ground Atom Instances *)

Section RawGAtomInstances.

(** packing and unpacking of a "raw" ground atom; needed for the canonical inference of its instances *)
Definition raw_gatom_rep l := let: RawGAtom s a := l in (s, a).
Definition raw_gatom_pre l := let: (s, a) := l in RawGAtom s a.

(** cancelation lemma for "raw" ground atoms *)
Lemma raw_gatom_repK : cancel raw_gatom_rep raw_gatom_pre.
Proof. by case. Qed.

(** "raw" ground atom instances *)
Canonical raw_gatom_eqType :=
  Eval hnf in EqType raw_gatom (CanEqMixin raw_gatom_repK).

Canonical raw_gatom_choiceType :=
  Eval hnf in ChoiceType raw_gatom (CanChoiceMixin raw_gatom_repK).

Canonical raw_gatom_countType :=
  Eval hnf in CountType  raw_gatom (CanCountMixin  raw_gatom_repK).

End RawGAtomInstances.

(** ** Ground Atoms:
A ground atom [gatom] packs a "raw" ground atom and a boolean well-formedness condition *)

(** ground atom well-formedness condition: argument size and symbol arity have to match *)
Definition wf_gatom ga := size (arg_gatom ga) == arity (sym_gatom ga).

(** ground atom record *)
Structure gatom : Type := GAtom {uga :> raw_gatom; _ : wf_gatom uga}.

(** ground atom instances *)
Canonical gatom_subType      := Eval hnf in [subType for uga].
Canonical gatom_eqType       := Eval hnf in EqType _     [eqMixin     of gatom by <:].
Canonical gatom_choiceType   := Eval hnf in ChoiceType _ [choiceMixin of gatom by <:].
Canonical gatom_countType    := Eval hnf in CountType  _ [countMixin  of gatom by <:].
Canonical gatom_subCountType := Eval hnf in [subCountType of gatom].

Section GatomFinType.

(** maximal symbol arity *)
Notation max_ar := (\max_(s in symtype) arity s).

Lemma max_ar_bound y : arity y < max_ar.+1.
Proof. exact/leq_bigmax_cond. Qed.

(** corresponding finite type for ground atoms, packing a symbol type and a tuple of constants
    of length bounded by the maximal symbol arity *)
Notation gatom_enc := ({x : 'I_(max_ar.+1) & (symtype * x.-tuple constant)%type}).

(** injecting a ground atom [ga] into its corresponding finite type encoding [gatom_enc] *)
Definition gatom_fenc (ga : gatom) : gatom_enc :=
  let: GAtom ga proof := ga in

  existT _ (Ordinal (max_ar_bound (sym_gatom ga))) (sym_gatom ga, Tuple proof).

(** conversely converting a ground atom finite type encoding [gatom_enc] into a ground atom [gatom] *)
Definition fenc_gatom (e : gatom_enc): option gatom.
case: e => x [s]; case: (val x == arity s) / eqP => [-> | _] [tup proof];
[exact: (Some (@GAtom (RawGAtom s tup) proof)) | exact/None].
Defined.

(** partial cancelation lemma for ground atoms *)
Lemma fenc_gatomK : pcancel gatom_fenc fenc_gatom.
Proof. by case=> [[s args] proof] /=; case: eqP => // ?; rewrite !eq_axiomK. Qed.

End GatomFinType.

(** canonical instances for ground atoms *)
Canonical gatom_finType     := Eval hnf in FinType gatom (PcanFinMixin fenc_gatomK).
Canonical gatom_subFinType  := [subFinType of gatom].

(** ** Ground Clauses:
A ground clause [gclause] packs a ground atom head and a body list of ground atoms *)
Inductive  gclause      := GClause of gatom & seq gatom.

(** head and body extractors for ground clauses *)
Definition head_gcl gcl := let: GClause h b := gcl in h.
Definition body_gcl gcl := let: GClause h b := gcl in b.

(** interpretations are finite sets of ground atoms *)
Notation interp := {set gatom}.

Implicit Types (i m : interp) (gcl : gclause).

(** set of all symbols of a given interpretation *)
Definition sym_i i := [set sym_gatom (val ga) | ga in i].

(** satisfiability of a ground clause [gcl] w.r.t a given interpretation [i]:
    if all body atoms belong to [i], the head should also belong to [i] *)
Definition gcl_true gcl i :=
  all (mem i) (body_gcl gcl) ==> (head_gcl gcl \in i).

(** Terms are either
    - variables, i.e, integers bound by a maximal (computable) index [n]
      - to which we assign the _finite_ ordinal type ['I_n]
    - constants to which we assign the _finite_ [constype]
*)

Inductive term : Type :=
  | Var of 'I_n
  | Val of constant.

(** corresponding sigma type encoding for terms; needed for canonical instance inference *)
Notation termRep := ('I_n + constant)%type.

(** injecting a term [t] into its [termRep] encoding *)
Definition term_rep (t : term) : termRep :=
  match t with
  | Var i => inl i
  | Val c => inr c
  end.

(** converting a [termRep] encoding into the corresponding term type  *)
Definition term_con (r : termRep) : term :=
  match r with
  | inl i => Var i
  | inr c => Val c
  end.

(** cancelation lemma for terms *)
Lemma term_repK : cancel term_rep term_con.
Proof. by case. Qed.

(** canonical instances for terms *)
Canonical term_eqType := Eval hnf in EqType term (CanEqMixin term_repK).
Canonical term_choiceType := Eval hnf in ChoiceType term (CanChoiceMixin term_repK).

(** Atoms are represented as records packing:
   - a base type [raw_atom]
     - which pairs a symbol with its term list argument
   - a _boolean_ well-formedness condition [wf_atom]
     - which ensures symbol arity and argument size agree *)

Inductive raw_atom : Type := RawAtom of symtype & seq term.

Section RawAtomInstances.

(** packing and unpacking of raw atoms *)
Definition raw_atom_rep l := let: RawAtom s a := l in (s, a).
Definition raw_atom_pre l := let: (s, a)      := l in RawAtom s a.

(** cancelation lemma for raw atoms *)
Lemma raw_atom_repK : cancel raw_atom_rep raw_atom_pre.
Proof. by case. Qed.

(** canonical instances for raw atoms *)
Canonical raw_atom_eqType     := Eval hnf in EqType     raw_atom (CanEqMixin     raw_atom_repK).
Canonical raw_atom_choiceType := Eval hnf in ChoiceType raw_atom (CanChoiceMixin raw_atom_repK).

End RawAtomInstances.

(** extractors for the corresponding symbols and arguments of an atom *)
Definition sym_atom a := let: RawAtom s_a _     := a in s_a.
Definition arg_atom a := let: RawAtom _   arg_a := a in arg_a.

(** atom well-formedness condition: argument size and symbol arity must match *)
Definition wf_atom a := size (arg_atom a) == arity (sym_atom a).

(** ** Atoms are records packing a "raw" atom and a corresponding boolean well-formedness condition *)
Structure atom : Type := Atom {ua :> raw_atom; _ : wf_atom ua}.

(** atom instances *)
Canonical atom_subType    := Eval hnf in [subType for ua].
Canonical atom_eqType     := Eval hnf in EqType     _ [eqMixin of atom by <: ].
Canonical atom_choiceType := Eval hnf in ChoiceType _ [choiceMixin of atom by <:].

(** Clauses pack an atom head and an atom list body. *)
Inductive clause : Type := Clause of atom & seq atom.

Section ClauseInstances.

(** packing and unpacking of clauses *)
Definition clause_rep cl := let: Clause hd bd := cl in (hd, bd).
Definition clause_pre cl := let: (hd, bd)     := cl in Clause hd bd.

(** cancelation lemma for clauses *)
Lemma clause_repK : cancel clause_rep clause_pre.
Proof. by case. Qed.

(** clause instances *)
Canonical clause_eqType     := Eval hnf in EqType     clause (CanEqMixin     clause_repK).
Canonical clause_choiceType := Eval hnf in ChoiceType clause (CanChoiceMixin clause_repK).

End ClauseInstances.

(** ** Programs are clause lists. *)
Definition program := seq clause.

(** extractors for the corresponding head, body and atoms of a clause *)
Definition head_cl  cl := let: Clause h b := cl in h.
Definition body_cl  cl := let: Clause h b := cl in b.
Definition atoms_cl cl := [:: head_cl cl & body_cl cl].

(** clause head symbols *)
Definition hsym_cl cl := sym_atom (head_cl cl).

(** all clause symbols *)
Definition sym_cl  cl := [seq sym_atom (val a) | a <- atoms_cl cl].

(** all head symbols of a program *)
Definition hsym_prog  p := [seq hsym_cl cl | cl <- p].

(** all program symbols *)
Definition sym_prog   p := flatten [seq sym_cl cl   | cl <- p].

(** all program atoms *)
Definition atoms_prog p := flatten [seq atoms_cl cl | cl <- p].

Section Grounding.

(** *** Ground valuations and their application  *)

(** type of groundings: finitely-supported functions mapping variables to constants *)
Definition gr := {ffun 'I_n -> constant}.

Implicit Types (g : gr) (t : term) (ra : raw_atom) (a : atom)
               (cl : clause) (hd : atom) (tl : seq atom).

(** term grounding *)
Definition gr_term g t :=
  match t with
  | Var v => g v
  | Val c => c
  end.

(** raw atom grounding *)
Definition gr_raw_atom g ra :=
  RawGAtom (sym_atom ra) [seq gr_term g x | x <- arg_atom ra].

(** the grounding of a well-formed ground atom is well-formed *)
Definition gr_atom_proof g a : wf_gatom (gr_raw_atom g a).
Proof. by case: a => s arg; rewrite /wf_gatom size_map. Qed.

(** atom grounding *)
Definition gr_atom g a := GAtom (gr_atom_proof g a).

(** clause grounding *)
Definition gr_cl g cl :=
  GClause (gr_atom g (head_cl cl)) [seq gr_atom g a | a <- body_cl cl].

End Grounding.

Section Theory.

(** *** Collecting Constants *)

Section Constants.

Definition const_term t : seq constant :=
  if t is Val e then [:: e] else [::].

(** atom constants *)
Definition const_atom a : seq constant :=
  flatten [seq const_term x | x <- arg_atom a].

(** atom list constants *)
Definition const_tail (tl : seq atom) : seq constant :=
  flatten [seq const_atom (val x) | x <- tl].

(** clause constants *)
Definition const_cl cl : seq constant :=
  const_tail [:: head_cl cl & body_cl cl].

End Constants.

Section Variables.

(** *** Collecting Variables *)

(** term variables *)
Definition term_vars t : {set 'I_n} := if t is Var v then [set v] else set0.

(** "raw" atom variables *)
Definition raw_atom_vars (ra : raw_atom) : {set 'I_n} :=
  \bigcup_(t <- arg_atom ra) term_vars t.

(** atom variables *)
Definition atom_vars (a : atom) : {set 'I_n} := raw_atom_vars a.

(** atom list variables *)
Definition tail_vars tl : {set 'I_n} := \bigcup_(t <- tl) atom_vars t.

(** **** Program Safety Condition *)

(** clause safety: all head variables should appear among the body variables *)
Definition safe_cl cl :=
  atom_vars (head_cl cl) \subset tail_vars (body_cl cl).

(** program safety: all clauses should be safe *)
Definition prog_safe p := all safe_cl p.

End Variables.

(** ** Program Satisfiability *)

(** a clause [c] is satisfied by an interpretation [i], if for all groundings [g]
its corresponding instantiation is satisfied by [i] *)
Definition cl_true cl i := forall g : gr, gcl_true (gr_cl g cl) i.

Definition prog_true p i :=
  forall g : gr, all (fun cl => gcl_true (gr_cl g cl) i) p.

End Theory.

Section Substitutions.

(** *** Substitutions as finitely supported partial functions *)
Definition sub := {ffun 'I_n -> option constant}.

Implicit Types (s : sub) (t : term) (a : atom) (v : 'I_n)
         (b : 'I_n * constant).

(** empty substitution *)
Definition emptysub : sub := [ffun _ => None].

(** Variable is mapped/free by the substitution s *)
Definition mem_bound s v : bool := s v.
Definition mem_free  s v : bool := s v == None.

(** Binding b belongs to s *)
Definition mem_binding s b : bool := s b.1 == Some b.2.

(** mem_binding = \in to be used as generic predicate *)
Definition eqbind_class := sub.

(** Implementing the collective predicate interface for sub *)
Identity Coercion sub_of_eqbind : eqbind_class >-> sub.

Coercion pred_of_eq_bind (s : eqbind_class) : pred_class := [eta mem_binding s].

Canonical mem_bind_symtype := mkPredType mem_binding.

Lemma mem_bindE s b : b \in s = (s b.1 == Some b.2). Proof. by []. Qed.

Definition inE := (mem_bindE, inE).

(** substitution [s2] extends [s1] *)
Definition sub_st s1 s2 :=
  [forall v : 'I_n, if s1 v is Some b1 then (v, b1) \in s2 else true].

Notation "A \sub B" := (sub_st A B)
  (at level 70, no associativity) : bool_scope.

(** reflection lemma for substitution ordering *)
Lemma substP s1 s2 : reflect {subset s1 <= s2} (s1 \sub s2).
Proof.
apply/(iffP forallP)=> [H t|H v].
  by move/eqP=> t_s1; have:= H t.1; rewrite t_s1.
by case E: (s1 _) => [d|//]; apply/H; rewrite inE E.
Qed.

Implicit Arguments substP [s1 s2].
Prenex Implicits substP.

(** **** Substitution Extensionality Lemma *)
Lemma substE s1 s2 :
  reflect (forall d v, s1 v = Some d -> s2 v = Some d) (s1 \sub s2).
Proof.
apply/(iffP substP)=> [H d v| H [v d]].
  by move/(_ (v,d)): H; rewrite !inE => H /eqP H1; exact/eqP/H.
by rewrite !inE => /eqP H1; rewrite (H d).
Qed.

(** reflexivity of substitution ordering *)
Lemma substss s : s \sub s.
Proof. exact/substP. Qed.

(** transitivity of substitution ordering *)
Lemma subst_trans s1 s2 s3 : s2 \sub s3 -> s1 \sub s2 -> s1 \sub s3.
Proof. by move=> /substP H1 /substP H2; apply/substP=> b /H2; auto. Qed.

(** any substitution extends the empty substitution *)
Lemma subst0s s : emptysub \sub s.
Proof. by apply/substP=> ?; rewrite inE ffunE. Qed.

(** Extending a substitution [s] with a binding [(v,d)] *)
Definition add s v d :=
  [ffun u => if u == v then Some d else s u].

(** If [v] was free in [s], substitution extension respects ordering. *)
Lemma sub_add s v d : mem_free s v -> s \sub (add s v d).
Proof.
move/eqP=> H; apply/substP=> -[u e].
by rewrite !inE !ffunE; case: ifP H => // /eqP -> ->.
Qed.

Lemma addE (s : sub) (v : 'I_n) d : (add s v d) v = Some d.
Proof. by rewrite ffunE eqxx. Qed.

Lemma add_add (s : sub) v d e : (add (add s v e) v d) = add s v d.
Proof. by apply/ffunP=> u; rewrite !ffunE; case: eqP. Qed.

(** Term substitution *)
Definition sterm s t : term :=
  match t with
  | Val d => Val d
  | Var v => if s v is Some d
             then Val d
             else Var v
  end.

(** Term grounding *)
Definition term_gr s t := { gt : constant | Val gt = sterm s t }.

(** Empty term substitution application *)
Lemma emptysubE t : sterm emptysub t = t.
Proof. by case: t => //= v; rewrite ffunE. Qed.

(** Substitution extension for terms *)
Lemma sterm_sub t s1 s2 d :
  s1 \sub s2 -> sterm s1 t = Val d -> sterm s2 t = Val d.
Proof.
case: t => //= v /substE H.
by case E: (s1 v) => [a1|//]; move/H: E ->.
Qed.

(** Atom substitution: applying a substiution [s] to a "raw" atom [ra] *)
Definition sraw_atom ra s := RawAtom (sym_atom ra) [seq sterm s x | x <- arg_atom ra].

(** Given an atom [a] and a substitution [s], the atom resulting by instantiating
[a] with [s] is well-formed *)
Lemma satom_proof a s : wf_atom (sraw_atom a s).
Proof. by case: a => ra pf; rewrite /wf_atom /= size_map. Qed.

(** Instantiation function that, for a given atom [a], takes a substitution [s]
and returns the corresponding substituted atom *)
Definition satom a : sub -> atom := fun s => Atom (satom_proof a s).

(** Atom symbols are preserved by substitution instantiation *)
Lemma sym_satom a nu : sym_atom (satom a nu) = sym_atom a.
Proof. by []. Qed.

(** Lifting ground raw atoms to raw atoms *)
Definition to_raw_atom gra :=
  RawAtom (sym_gatom gra) [seq Val x | x <- arg_gatom gra].

(** The atom obtain from the lifting of a ground atom is well-formed *)
Lemma to_atom_proof (ga : gatom) : wf_atom (to_raw_atom ga).
Proof. by case: ga => ra pf; rewrite /wf_atom /= size_map. Qed.

(** Lifting of ground atoms to atoms *)
Definition to_atom ga := Atom (to_atom_proof ga).

(** Atom grounding *)
Definition atom_gr a s := { gtl : gatom | to_atom gtl = satom a s }.

(** **** Atom Substitution Extensions Lemma:
Let [s1], [s2] be two substitutions. If [s2] extends [s1] and [s1] instantiates
an atom [a] to a ground atom [ga], then [s2] also instantitates [a] to [ga]. *)
Lemma satom_sub a s1 s2 ga :
  s1 \sub s2 -> satom a s1 = to_atom ga -> satom a s2 = to_atom ga.
Proof.
case: a ga => // [[sy1 a1] pf1] [[sy2 a2] pf2] ss /= [hs harg].
apply/val_inj; congr RawAtom; rewrite //=.
elim: a1 a2 harg {pf1 pf2} => //= a1 l1 iha [|a2 l2] //= [].
by move/(sterm_sub ss)=> ->/iha<-.
Qed.

(** Tail substitution *)
Definition stail tl s : list atom := [seq satom a s | a <- tl].

(** Lifting of a ground tail to tail *)
Definition to_tail gtl : list atom := [seq to_atom ga | ga <- gtl].

(** Grounding of atom list *)
Definition tail_gr tl s := { gtl : list gatom | to_tail gtl = stail tl s}.

End Substitutions.

(** Export the notation *)
Notation "A \sub B" := (sub_st A B)
  (at level 70, no associativity) : bool_scope.

Hint Resolve substss subst0s.

Section NoDepGrounding.

(** Non-dependent grounding using default element *)
Implicit Types (s : sub) (t : term) (a : atom) (v : 'I_n)
               (b : 'I_n * constant).

(** default element *)
Variable def : constant.

(** grounding a term [t] with a substitution [s] and the default element [def] *)
Definition gr_term_def s t : constant :=
  match t with
  | Val c => c
  | Var i => odflt def (s i)
  end.

(** If, when instantiating a term [t] with a substitution [s], we obtain a constant [c],
then we obtain [c] also when grounding [t] with [s] using the default element [def]. *)
Lemma gr_term_defP c t s :
  sterm s t = Val c -> gr_term_def s t = c.
Proof. by case: t => /= [v|e [//]]; case: (s _) => // e []. Qed.

Lemma gr_term_sub t1 t2 s d (t_sub : term_vars t1 \subset term_vars t2) :
  sterm s t2 = Val d -> exists e, sterm s t1 = Val e.
Proof.
case: t2 t1 t_sub => [v2|d2] [v1|d1] /subsetP /=.
+ move/(_ v1)=> /implyP; rewrite !inE eqxx /= => /eqP->.
  by case E: (s v2) => [a|] //= _; exists a.
+ by move=> _ _; exists d1.
+ by move/(_ v1)=> /implyP; rewrite !inE eqxx.
+ by move=> _ _; exists d1.
Qed.

(** grounding a raw atom [ra] with a substitution [s] and the default element [def] *)
Definition gr_raw_atom_def s ra : raw_gatom :=
  RawGAtom (sym_atom ra) (map (gr_term_def s) (arg_atom ra)).

(** well-formedness is preserved by non-dependent grounding *)
Lemma gr_atom_def_proof s a : wf_gatom (gr_raw_atom_def s a).
Proof. by case: a => ra pf; rewrite /wf_gatom size_map. Qed.

(** grounding an atom [a] with a substitution [s] *)
Definition gr_atom_def s a : gatom := GAtom (gr_atom_def_proof s a).

(** Let [a] be an atom and [s] a substitution. If, when instantiating [a] with [s], we obtain
the ground atom [ga], then, when grounding [a] with [s] and the default element [def], we also
obtain [ga]. *)
Lemma gr_atom_defP a s ga :
  satom a s = to_atom ga -> gr_atom_def s a = ga.
Proof.
case: a ga => [[sym1 t1] pf1] [[sym2 t2] pf2] /= [hs harg].
apply/val_inj; congr RawGAtom; rewrite //=.
by elim: t1 t2 harg {pf1 pf2} => [|x1 t1 iht1] [|x2 t2] //= [] /gr_term_defP <- /iht1<-.
Qed.

(** Let [ga] be a ground atom. If we lift it to an atom and ground it with a substitution
[s] and a default element [def], [ga] is preserved. *)
Lemma gr_atom_defK ga s : gr_atom_def s (to_atom ga) = ga.
Proof.
case: ga => //= [[sym t] pf]; apply/val_inj => /=; congr RawGAtom.
by elim: t {pf} => //= a ga ->.
Qed.

(** Using default value to lift a subst to a grounding *)
Definition to_gr s : gr := [ffun v => if s v is Some c then c else def].

Definition to_sub (g : gr) : sub := [ffun v => Some (g v)].

Lemma to_subE t g : sterm (to_sub g) t = Val (gr_term g t).
Proof. by case: t => [i|d] //=; rewrite ffunE. Qed.

Lemma to_grP t s c : sterm s t = Val c -> gr_term (to_gr s) t = c.
Proof.
move/gr_term_defP; case: t => [v|e] //=.
by case E: (s v) => [a|] <-; rewrite ffunE E.
Qed.

End NoDepGrounding.

Section Match.
(** Matching functions *)

Implicit Types (s : sub) (t : term) (a : atom) (v : 'I_n)
         (b : 'I_n * constant).

(** matching a term [t] against a constant [d], starting from an initial substitution [s]. *)
Definition match_term d t s : option sub :=
  match t with
  | Val e => if d == e then Some s else None
  | Var v => if s v is Some e then
             (if d == e then Some s else None)
             else Some (add s v d)
  end.

(** Let [s1], [s2] be two substitutions. If [s2] is the result of matching a term [t]
against a constant [d], starting from an initial substitution [s1], then [s2] extends [s1]. *)
Lemma match_term_sub s1 s2 t d : match_term d t s1 = Some s2 -> sub_st s1 s2.
Proof.
case: t => //= [v|e]; last first.
  by case: eqP => _ // [->].
case E: (s1 _) => /= [a|].
  by case: eqP => _ // [->].
by case=> <-; have/eqP/sub_add := E.
Qed.

(** matching a raw atom [ra] against a ground raw atom [rga], starting from an initial substitution [s]. *)
Definition match_raw_atom s ra rga : option sub :=
  match ra, rga with
    | RawAtom s1 arg1, RawGAtom s2 arg2 =>
      if (s1 == s2) && (size arg1 == size arg2)
      then foldl (fun acc p => obind (match_term p.1 p.2) acc)
                 (Some s) (zip arg2 arg1)
      else None
  end.

(** matching an [a] against a ground atom [ga], starting from an initial substitution [s]. *)
Definition match_atom s a (ga : gatom) := match_raw_atom s a ga.

(** matching an atom [a] against all the ground atoms of an interpretation [i], starting from an
initial substitution [s] *)
Definition match_atom_all i a s :=
  [set x | Some x \in [set match_atom s a ga | ga in i]].

(** reflection lemma for atom matching *)
Lemma match_atomsP a i r s :
  reflect (exists2 ga, ga \in i & Some r = match_atom s a ga)
          (r \in match_atom_all i a s).
Proof. by rewrite inE; exact: (iffP imsetP). Qed.

(** join for the set monad *)
Definition bindS {A B : finType} (i : {set A}) (f : A -> {set B}) : {set B} :=
  cover [set f x | x in i].

(** reflection lemma for binding *)
Lemma bindP (A B : finType) (i : {set A}) (f : A -> {set B}) (r : B) :
  reflect (exists2 s, s \in i & r \in f s) (r \in bindS i f).
Proof.
by rewrite /bindS cover_imset; exact: (iffP bigcupP); case=> s xin rin; exists s.
Qed.

(** monadic fold for the set monad: iteratively composing the result of applying a function [f],
seeded with an initial value [s0], to all elements of a list [l] *)
Fixpoint foldS {A : Type} {B : finType}
         (f : A -> B -> {set B}) (s0 : {set B}) (l : seq A) :=
  if l is [:: x & l] then bindS s0 (fun y => foldS f (f x y) l)
  else s0.

(** If functions [f] and [g] are extensionally equal, then we get the same output when binding
a set [s] with them. *)
Lemma eq_bindS (A B : finType) (f g : A -> {set B}) (s : {set A}) :
  f =1 g -> bindS s f = bindS s g.
Proof.
move=> h_f; apply/setP=> x; rewrite /bindS !cover_imset.
by apply/bigcupP/bigcupP; case=> y y_in x_in; exists y; rewrite // ?h_f // -h_f.
Qed.

(** The result of binding the union of two sets [s1] and [s2] with a function [f]
equals the result of taking the union between the binding of [s1] with [f] and
the binding of [s2] with [f] *)
Lemma bindSU (A B : finType) (f : A -> {set B}) (s1 s2 : {set A})  :
  bindS (s1 :|: s2) f = bindS s1 f :|: bindS s2 f.
Proof. by rewrite /bindS !cover_imset bigcup_setU. Qed.

(** Let [s] be a set and [f], [g] two functions. The result of taking the union
between the binding of [s] with [f] and the binding of [s] with [g] equals the
binding of [s] with the function that returns the point-wise union of [f] and [g] application *)
Lemma bindUS (A B : finType) (f g : A -> {set B}) (s : {set A})  :
  bindS s f :|: bindS s g = bindS s (fun x => f x :|: g x ).
Proof.
rewrite /bindS !cover_imset; apply/setP=> x; rewrite !inE; apply/orP/bigcupP.
  by case=> /bigcupP[y hy hfy]; exists y; rewrite // inE hfy ?orbT.
by case=> [y hy]; rewrite inE; case/orP=> hf; [left | right]; apply/bigcupP; exists y.
Qed.

(** If [f] and [g] are extensionally equal, then the results of taking their fold over a list [l],
seeded with an initial set [s], are equal *)
Lemma eq_foldS (A : eqType) (T : finType) f g (s : {set T}) (l : seq A) :
  {in l, f =2 g} -> foldS f s l = foldS g s l.
Proof.
move=> h_f; elim: l s h_f => //= x l ihl s h_f.
have heq: (fun y : T => foldS f (f x y) l) =1
          (fun y : T => foldS g (g x y) l).
  move=> y; rewrite h_f ?inE ?eqxx ?ihl //.
  by move=> u hu k; rewrite h_f // inE hu orbT.
by rewrite (eq_bindS _ heq).
Qed.

(** The result of folding a function [f] over a list [l], starting from the union
of sets [s1] and [s2] equals the union of folding [f] over [l] starting from [s1]
and of folding [f] over [l] starting from [s2] *)
Lemma foldSU A (T : finType) f (s1 s2 : {set T}) (l : seq A) :
  foldS f (s1 :|: s2) l = foldS f s1 l :|: foldS f s2 l.
Proof. by elim: l => //= x l ihl; rewrite bindSU. Qed.

(** matching a list of atoms [tl] agains ground atoms of an interpretation [i] *)
Definition match_body i tl : {set sub} :=
  foldS (match_atom_all i) [set emptysub] tl.

(** one iteration of fwd_chain for a one-clause program *)
Definition cons_clause (def : constant) (cl : clause) i : {set gatom} :=
  [set gr_atom_def def s (head_cl cl) | s in match_body i (body_cl cl)].

(** one iteration of fwd_chain for a program *)
Definition fwd_chain def p i : {set gatom} :=
  i :|: \bigcup_(cl <- p) cons_clause def cl i.

End Match.

(** Monotonicity lemmas for fwd_chain functions *)
Section Monotonicity.

Lemma bindS_mon {A B : finType} (i1 i2 : {set A}) (f1 f2 : A -> {set B}) :
  i1 \subset i2 -> (forall x, f1 x \subset f2 x) ->
  bindS i1 f1 \subset bindS i2 f2.
Proof.
move=> H1 H2; apply/subsetP => r; case/bindP=> u ui1 ri1.
apply/bindP; exists u; move/subsetP: H1. by apply.
by move/subsetP: (H2 u) => H _; apply: H.
Qed.

Lemma foldS_mon {A : eqType} {B : finType} (f1 f2 : A -> B -> {set B}) (l : seq A)
  (f_mon : forall x y, f1 x y \subset f2 x y) :
  (forall (s1 s2 : {set B}), (s1 \subset s2) -> foldS f1 s1 l \subset foldS f2 s2 l).
Proof. by elim: l => //= x l ihl s1 s2 hs12; apply/bindS_mon=> // y; exact/ihl. Qed.

Lemma match_atom_all_mon i1 i2 s a :
 i1 \subset i2 -> match_atom_all i1 a s \subset match_atom_all i2 a s.
Proof. by move=> s12; apply/preimsetS/imsetS. Qed.

Lemma match_body_mon i1 i2 cl :
  i1 \subset i2 -> match_body i1 (body_cl cl) \subset match_body i2 (body_cl cl).
Proof.
by move=> H; apply/foldS_mon => //; move=> u s'; apply: match_atom_all_mon.
Qed.

Lemma cons_cl_mon i1 i2 cl def :
  i1 \subset i2 -> cons_clause def cl i1 \subset cons_clause def cl i2.
Proof. by move=> Hs; rewrite //; apply/imsetS/match_body_mon. Qed.

Lemma fwd_chain_mon i1 i2 p def :
  i1 \subset i2 ->
  fwd_chain def p i1 \subset fwd_chain def p i2.
Proof.
move=> Hs; apply/setUSS/subsetP; move=> // ga /bigcup_seqP[cl cl_in /andP[ga_in _]].
apply/bigcup_seqP; exists cl => //; apply/andP; split; auto.
by move/subsetP: (cons_cl_mon cl def Hs); apply.
Qed.

End Monotonicity.

Section Increasing.

(** Forward Chain is increasing. *)
Lemma fwd_chain_inc i p def : i \subset fwd_chain def p i.
Proof. exact: subsetUl. Qed.

End Increasing.

Section Soundness.

Implicit Types (s r : sub) (d def : constant) (t : term) (a : atom)
               (ga : gatom) (tl : list atom) (cl : clause).

(** **** Term Matching Soundness:
Let [t] be a term, [d] a constant and [s] an arbitrary substitution.
If term matching outputs a substitution [r], extending [s] with the matching of [t] against [d], then
[r] is indeed a solution, i.e, the instantiation of [t] with [r] equals [d].*)
Lemma match_term_sound d t s r : match_term d t s = Some r -> sterm r t = Val d.
Proof.
case: t => /= [v|c]; last by case: eqP => [->|].
case E: (s _) => [e|]; last by case => <-; rewrite ffunE eqxx.
by case: eqP => //->[<-]; rewrite E.
Qed.

(** List Fold Soundness *)
Lemma foldl_0_gen {A} u l r
     (f : A -> sub -> option sub)
     (f_pmon : forall x s r, f x s = Some r -> s \sub r)
 : foldl (fun acc p => obind (f p) acc) u l = Some r ->
   exists2 s, u = Some s & s \sub r.
Proof.
elim: l u => [|hd tl IHl] //= => [Hu | u Hfold].
  by exists r; [done | apply/substss].
case: (IHl (obind (f hd) u) Hfold) => [s Hbind Hsub].
case E : u => [s'|]; rewrite E //= in Hbind.
by exists s'; [done | apply/(subst_trans Hsub (@f_pmon hd s' s Hbind))].
Qed.

Lemma foldl_0 gar ar u r :
 foldl (fun acc p => obind [eta match_term p.1 p.2] acc) u (zip gar ar) = Some r ->
 exists2 s, u = Some s & s \sub r.
Proof. by apply: foldl_0_gen => x s r0; apply: match_term_sub. Qed.

(** **** Atom Matching Soundness:
Let [a] be an atom, [ga] a ground atom and [s], an arbitrary substitution.
If atom matching outputs a substitution [r], extending [s] with the matching of [a] against [ga], then
[r] is indeed a solution, i.e, the instantiation of [a] with [r] equals [ga]. *)
Lemma match_atom_sound a ga s r :
  match_atom s a ga = Some r -> satom a r = to_atom ga.
Proof.
case: a ga => /= [[s_a arg_a] pf_a] [[s_g arg_g] pf_g] // hma.
apply/val_inj; move: hma; rewrite /match_atom /= {pf_a pf_g}.
case: eqP => Hs //; rewrite Hs; case: eqP => Harg //=.
elim: arg_a arg_g s Harg => [| a ar iha] [| g gar] //= s [Hsize] Hf.
congr RawAtom => /=.
have [s' Hs' Hsub] := foldl_0 Hf; rewrite Hs' in Hf.
have [->] := iha _ _ Hsize Hf.
by have/sterm_sub-> := (match_term_sound Hs').
Qed.

(** **** Atom Matching Substitution Lemma:
If [s2] is the result of matching an atom [a] against
a ground atom [ga], starting from an initial substitution [s1], then [s2] is the extension of [s1]. *)
Lemma match_atom_sub s1 s2 a ga :
  match_atom s1 a ga  = Some s2 -> sub_st s1 s2.
Proof.
rewrite/match_atom.
case: a ga => [[s_a arg_a] pf_a] [[s_g arg_g] pf_g].
rewrite /match_raw_atom /=.
case: eqP => // Hs //=.
case: eqP => // Harg //=.
move/foldl_0=> [s' Hs' Hsub].
by injection Hs' => H; rewrite H; apply/Hsub.
Qed.

(** substitution domain: set of all variables it binds *)
Definition dom s := [set v : 'I_n | s v].

Lemma to_sub_grt def t nu :
  gr_term_def def (to_sub nu) t = gr_term nu t.
Proof. by case: t=> [var | val] //=; rewrite ffunE. Qed.

Lemma to_sub_gra def a nu :
  gr_atom_def def (to_sub nu) a = gr_atom nu a.
Proof.
case: a=> [[sym args] pf_a]; apply/val_inj; congr RawGAtom.
by apply/eq_map=> x; apply/to_sub_grt.
Qed.

Lemma sub_dom_grt t s :
  term_vars t \subset dom s <-> exists c, sterm s t = Val c.
Proof.
case: t=> [var|val]; split; rewrite ?(sub0set, sub1set, inE) //=.
+ by case: (s var) => [c|]=> c'//=; exists c.
+ by case: (s var) => [c|] //; case=> //.
+ by exists val.
Qed.

Lemma sub_dom_gra (ra : raw_atom) s :
  reflect (exists gra, sraw_atom ra s = to_raw_atom gra)
          (raw_atom_vars ra \subset dom s).
Proof.
case: ra => [sym args]; apply: (iffP idP).
  elim: args => [|t arg iha]; first by exists (RawGAtom sym [::]).
  rewrite /raw_atom_vars big_cons subUset => /andP[/sub_dom_grt [c Hc] /iha] [[sy l] [->]] H.
  by exists (RawGAtom sy (c :: l)); congr RawAtom; rewrite /= Hc H.
elim: args => [| a arg iha]; first by rewrite /raw_atom_vars big_nil sub0set.
case=> [[sga [|ga gal]] // [hs hga hgal]].
rewrite /raw_atom_vars big_cons subUset iha ?andbT; first by apply/sub_dom_grt; exists ga.
by exists (RawGAtom sym gal); congr RawAtom; rewrite /= hgal.
Qed.

Lemma sub_dom_raw a s :
  (exists gra : raw_gatom, sraw_atom a s = to_raw_atom gra) ->
   exists ga : gatom, satom a s = to_atom ga.
Proof.
case=> ga sha.
have pf_ga: wf_gatom ga.
  case: ga a sha => [s' arg'] [[sa aa] pfa] [h1 h2].
  rewrite /wf_gatom /= -h1.
  have -> // : size arg' = size aa.
  by move/(congr1 size): h2; rewrite !size_map.
by exists (GAtom pf_ga); apply/val_inj.
Qed.

Lemma sub_dom_ga (a : atom) s :
  reflect (exists ga, satom a s = to_atom ga)
          (atom_vars a \subset dom s).
Proof.
have [h|h]:= (sub_dom_gra a s).
  by left; apply: sub_dom_raw.
right; case=> [ga hga]; apply: h.
by exists ga; case: a hga => a /= pf /(congr1 val).
Qed.

Implicit Types (ss : {set sub}).

Definition match_pbody tl i ss0 := foldS (match_atom_all i) ss0 tl.

Lemma match_pbody_cons a l i r ss0 :
  reflect (exists2 s, s \in ss0 & r \in match_pbody l i (match_atom_all i a s))
          (r \in match_pbody (a :: l) i ss0).
Proof. exact: bindP. Qed.

Lemma match_body_pbody tl i r :
  match_body i tl = match_pbody tl i [set emptysub].
Proof. by rewrite /match_pbody /match_body. Qed.

Lemma sub_st_add v d s' s :
  s' \sub s -> s v = Some d -> s' v = None -> add s' v d \sub s.
Proof.
move=> Hsub Hs Hs'; apply/forallP=> v'; rewrite /add ffunE.
case: eqP => [->| Hv]; first exact/eqP.
by move/forallP in Hsub; apply/Hsub.
Qed.

(** **** Term Matching Completeness:
Given a solution [s] to term-matching [t] w.r.t [d],
for any sub-substitution [s'], there exists an [r] that is a solution
 and also better/minimal w.r.t [s] *)
Lemma match_term_complete d t s s' :
 sub_st s' s -> sterm s t = Val d ->
 exists r, match_term d t s' = Some r /\ sub_st r s.
Proof.
case: t=> /= [v|c] // => Hsub //; last first.
  by case=> [->] //; exists s'; split; [case: eqP | done].
case Hs : (s _)  => [e|] //; case=> He //; rewrite -He {d He}.
case Hs': (s' _) => [e'|] //.
     by exists s'; case: eqP=> He //; last first;
     move/substE in Hsub;
     have Hsub' := (Hsub e' v Hs');
     rewrite Hs in Hsub'; injection Hsub';
     rewrite //= Hsub.
by exists (add s' v e); split; [done | apply/sub_st_add].
Qed.

(** **** Atom Matching Completeness:
Let [a] be an atom, [ga] a ground atom and [s] a substitution
that instantiates [a] to [ga]. Then, seeding the atom matching algorithm with [s'], an arbitrary restriction
of [s], outputs a better matching solution than [s], i.e, a substitution [r] that is smaller or equal to [s]. *)
Lemma match_atom_complete ga a s s' :
 sub_st s' s -> satom a s = to_atom ga ->
 exists2 r, match_atom s' a ga = Some r & sub_st r s.
Proof.
case: a ga => [[s_a arg_a] pfa] [[s_g arg_g] pfs] //= Hsub [hsym Harg].
rewrite /match_atom /= hsym eqxx /=.
have ->: size arg_a = size arg_g.
  by move/(congr1 size): Harg; rewrite !size_map.
rewrite eqxx {s_a s_g hsym pfa pfs}.
elim: arg_a arg_g s' Hsub Harg => [| h l IHl] [| gh gl] //= s' Hsub.
  by exists s'.
case; move=> Ht Hl.
have [r' [Hs'r Hr]] := match_term_complete Hsub Ht.
have [r'' H Hr_sub] := IHl _ _ Hr Hl.
by exists r''; rewrite // Hs'r.
Qed.

(** Let [a] be an atom, [ga] a ground atom and [v] a grounding. Instantiating [a] with the coercion of
[v] equals the lifting of [ga] iff the grounding of [a] with [v] equals [ga] *)
Lemma to_gr_atomP a v ga :
  satom a (to_sub v) = to_atom ga <-> gr_atom v a = ga.
Proof.
case: a ga => [[s_a arg_a] pfa] [[s_g arg_g] pfg];
split; case => hs harg; apply/val_inj => /= {pfa pfg}.
  congr RawGAtom => //=.
  elim: arg_g arg_a harg => [|ag arg_g ihag] [|aa arg_a] //.
  by rewrite /= to_subE => -[->] ha; rewrite ihag.
congr RawAtom => //=.
elim: arg_g arg_a harg => [|ag arg_g ihag] [|aa arg_a] //.
by rewrite /= to_subE => -[->] ha; rewrite ihag.
Qed.

Lemma match_ptl_complete s' ss0 i cl v :
 s' \in ss0 -> sub_st s' (to_sub v) ->
 all (mem i) (body_gcl (gr_cl v cl)) ->
 exists2 r, r \in match_pbody (body_cl cl) i ss0 &
            sub_st r (to_sub v).
Proof.
case: cl => head body //=.
elim: body s' ss0 => [| hd tl] => //= [ | IHl ] s' ss0  Hs' H_sub H_mem //.
  exists s'; [exact: Hs' | exact: H_sub].
case/andP: H_mem => [H_in H_mem].
have HH : exists2 ga, ga \in i & gr_atom v hd = ga.
  by exists (gr_atom v hd).
case: HH=> [ga Hga_in Hga].
move/to_gr_atomP in Hga.
have [r' Hr' Hr'_sub] := (@match_atom_complete ga hd (to_sub v) s' H_sub Hga).
have Hr'_all : r' \in match_atom_all i hd s'.
  by apply/match_atomsP; exists ga.
have [s Hs Hs_sub] := IHl r' (match_atom_all i hd s') Hr'_all Hr'_sub H_mem.
by exists s; [apply/match_pbody_cons; exists s' | done].
Qed.

Lemma match_tl_complete i cl v :
 all (mem i) (body_gcl (gr_cl v cl)) ->
 exists2 r, r \in match_pbody (body_cl cl) i [set emptysub] &
                  sub_st r (to_sub v).
Proof.
by apply/(@match_ptl_complete emptysub); [rewrite inE| exact/subst0s].
Qed.

(** Let [ss0] be a substitution set. If [r] is in the result of extending substitutions in [ss0]
with bindings matching the [tl] atom list against the ground atoms of an interpretation [i], then
there exists a substitution [s] in [ss0] that [r] extends. *)
Lemma match_atom_all_sub tl i r ss0 :
 r \in match_pbody tl i ss0 ->
  exists2 s, s \in ss0 & sub_st s r.
Proof.
elim: tl ss0 => [| a l IHl] //=.
by rewrite /match_pbody /foldS; exists r.
rewrite /match_pbody //=.
move=> ss0. move/bindP => Hr.
case: Hr => [s Hs Hr] //.
have [s' H_in Hs'] := (IHl (match_atom_all i a s) Hr).
exists s. exact: Hs.
move/match_atomsP in H_in.
case: H_in=> [ga Hga HH].
move/esym in HH.
apply: subst_trans (match_atom_sub HH).
exact: Hs'.
Qed.

(** Let [r] in the result of extending substitutions in [ss0]
with bindings matching the [tl] atom list against the ground atoms of an interpretation [i].
Then, there exists a ground atom list [gtl], such that [gtl] is the instantiation of [t] with [r]
and all the atoms in [gtl] are in [i]. *)
Lemma match_pbody_sound tl i r ss0 :
  r \in match_pbody tl i ss0 ->
      exists2 gtl, stail tl r = [seq to_atom ga | ga <- gtl]
                   & all (mem i) gtl.
Proof.
elim: tl ss0 => [|a l IHl] /=.
  by exists [::].
move=> ss0.
case/match_pbody_cons => /= [s0 Hs0 Hrs].
have /= [gtl [H_tl H_mem]] := (IHl (match_atom_all i a s0) Hrs) => {IHl}.
have [s Hs Hsub] := match_atom_all_sub Hrs.
have/match_atomsP [ga Hga] := Hs.
exists (ga :: gtl).
rewrite H_tl //=.
move/esym in q.
move: (match_atom_sound q) => H.
have H_r := satom_sub Hsub H.
by rewrite H_r.
by rewrite /= H_mem Hga.
Qed.

Lemma r_dom_term d t r : sterm r t = Val d -> term_vars t \subset dom r.
Proof.
case: t => [v|c] //=; last by rewrite sub0set.
by rewrite sub1set inE; case: (r v).
Qed.

Lemma r_dom_atom a ga r : satom a r = to_atom ga -> atom_vars a \subset dom r.
Proof.
case: a ga => [[sym args] pfa] [[gsym gargs] pfg] [hs harg].
rewrite /atom_vars /= hs {pfa pfg hs}.
elim: args gargs harg => [ | a args IHa] [ | ga gargs] //=.
  by rewrite /raw_atom_vars big_nil sub0set.
by rewrite /raw_atom_vars big_cons subUset; case=> /r_dom_term -> /IHa.
Qed.

Lemma seq_inj T (x y : T) (xs ys : seq T) :
  [:: x & xs] = [:: y & ys] -> x = y /\ xs = ys.
Proof. by case. Qed.

Lemma r_dom_body tl gtl r : stail tl r = [seq to_atom ga | ga <- gtl] ->
                            tail_vars tl \subset dom r.
Proof.
elim: tl gtl => [ | a arg IHa] [ | ga gargs] //=.
  by rewrite /tail_vars big_nil sub0set.
move=> hl; have [/r_dom_atom hs /IHa hha] := seq_inj hl.
by rewrite /tail_vars big_cons subUset hs hha.
Qed.

Lemma match_tl_sound tl i r :
  r \in match_body i tl ->
        exists2 gtl, stail tl r = [seq to_atom ga | ga <- gtl]
                     & all (mem i) gtl.
Proof. exact/match_pbody_sound. Qed.

(** **** Clause Consequence Soundness:
Let [cl] be a safe clause and [i] an interpretation.
If the clause consequence operator derives no new facts from [cl], then [i] is a model for [cl].*)
Lemma cons_cl_sound def cl i :
  safe_cl cl -> cons_clause def cl i \subset i -> cl_true cl i .
Proof.
move=> h_safe; rewrite /cons_clause => /subsetP h_fp v.
apply/implyP=> h_tl; apply/h_fp/imsetP=> {h_fp}.
have [r r_in_match r_sub_v] := match_tl_complete h_tl.
exists r; first by [].
case: cl h_safe h_tl r_in_match => /= hd tl h_safe h_tl r_in_match.
have [gtl Hgtl _] := match_tl_sound r_in_match.
have h_g : exists ga, satom hd r = to_atom ga.
  exact/sub_dom_ga/(subset_trans h_safe)/r_dom_body/Hgtl.
rewrite -(to_sub_gra def hd v); case: h_g => ga hga.
have h1 := (gr_atom_defP def hga).
have h_sub := satom_sub r_sub_v hga.
have h2 := (gr_atom_defP def h_sub).
by rewrite h1 h2.
Qed.

(** **** Forward Chain Soundness:
Let [p] be a safe program and [i] an interpretation.
If [i] is the fixpoint of one iteration of forward chain, then [i] is a model for [p]. *)
Lemma fwd_chain_sound def p i :
  prog_safe p -> fwd_chain def p i = i -> prog_true p i .
Proof.
move/allP=> h_safe /setUidPl /bigcups_seqP => h_cls ?.
  by apply/allP=> ? h; apply: (cons_cl_sound (h_safe _ h)); apply: h_cls.
Qed.

Lemma to_gr_sub def t s : gr_term_def def s t = gr_term (to_gr def s) t.
Proof. by case: t=> [var | val] //=; rewrite ffunE //=. Qed.

Lemma gr_atom_defE def s a : gr_atom (to_gr def s) a = gr_atom_def def s a.
Proof.
case: a => [[s_a arg_a] pfa] //=; apply/val_inj => /=; congr RawGAtom.
elim: arg_a {pfa} => [ |t arg_a IHl] //=.
by rewrite IHl; congr cons; rewrite to_gr_sub.
Qed.

Lemma tail_mem def s tl gtl i :
 stail tl s = [seq to_atom ga | ga <- gtl] ->
 all (mem i) gtl ->
 all (mem i) [seq gr_atom (to_gr def s) x | x <- tl].
Proof.
elim: tl gtl => [ | h l] Hl gtl //= H_mem //=.
move: H_mem; case: gtl=> [ | gh gl] //.
rewrite map_cons => hss /andP[hin hmem]; have [hhd htl]:= seq_inj hss.
apply/andP; split.
  by rewrite gr_atom_defE (gr_atom_defP def hhd).
by apply/(Hl gl htl hmem).
Qed.

(** **** Clause Consequence Stability:
Let [cl] be a clause and [i] an interpretation satisfying [c].
Then, the clause consequence operator derives no new facts from [cl]. *)
Lemma cons_cl_stable def cl i : cl_true cl i -> cons_clause def cl i \subset i.
Proof.
rewrite/cl_true/cons_clause/gcl_true //= => Hclause.
rewrite sub_imset_pre.
apply/subsetP=> s /match_tl_sound [gtl Htl Hmem].
have Hcl := Hclause (to_gr def s); move/implyP in Hcl.
by rewrite inE -gr_atom_defE; apply/Hcl/tail_mem; last exact: Hmem.
Qed.

(** Let [p] be a program. Any interpretation [i] that is a model of [p] is a fixpoint of one iteration of forward chain *)
Lemma fwd_chain_stable def p i : prog_true p i -> fwd_chain def p i = i.
Proof.
move=> p_true; apply/setUidPl/bigcups_seqP=> cl h_in _.
by apply/cons_cl_stable=> v; have/allP := p_true v; exact.
Qed.

(** Forward Chain reflection lemma: Given a safe program [p], an interpretation [i]
is a model of [p] iff it is a fixpoint of one iteration of forward chain. *)
Lemma fwd_chainP def p i (p_safe : prog_safe p) :
  reflect (prog_true p i) (fwd_chain def p i == i).
Proof. apply/(iffP eqP); [exact: fwd_chain_sound | exact: fwd_chain_stable]. Qed.

(** Given a program [p] and an interpretation [i]. The symbols in the strict result (without [i]) of applying forward
chain on [p] given [i] are among the head symbols of [p]. *)
Lemma sym_pengine_subset_hsymp def p i :
  {subset sym_i ((fwd_chain def p i) :\: i) <= hsym_prog p}.
Proof.
move=> s; case/imsetP=> ga; rewrite !inE => /andP [/negbTE h].
rewrite h; case/bigcup_seqP=> cl cl_in. rewrite andbT.
by case/imsetP=> nu nu_in -> ->; apply/mapP; exists cl.
Qed.

(** **** Forward Chain Extensionality:
If two programs [p1] and [p2] are extensionally equal, then
the output of forward chain on [p1] equals that on [p2]. *)
Lemma eq_fwd_chain def p1 p2 i :
  p1 =i p2 -> fwd_chain def p1 i = fwd_chain def p2 i.
Proof.
by move=> h; apply/setP=> ga; rewrite !inE (eq_big_idem _ _ (@setUid _) h).
Qed.

(** **** Forward Chain Decomposition:
The result of applying forward chain on the concatenation of
programs [p1] and [p2], given an interpretation [i] equals the union of forward chain on [p1] given [i]
with forward chain on [p2] given [i]. *)
Lemma fwd_chain_cat def p1 p2 i :
  fwd_chain def (p1 ++ p2) i = fwd_chain def p1 i :|: fwd_chain def p2 i.
Proof. by apply/setP=> ga; rewrite ?(big_cat, inE) orbACA orbb. Qed.

(** Let [ga] be a ground atom in the output of applying forward chain on [p], given [i].
Then, either [ga] is in [i] or its symbol among the head symbols in [p]. *)
Lemma fwd_chain_sym def p i ga :
  (ga \in fwd_chain def p i) ->
  (ga \in i) || (sym_gatom ga \in hsym_prog p).
Proof.
case: (ga \in i) / boolP => [|/negbTE h] /=.
  by rewrite /fwd_chain !inE => ->.
rewrite inE h => /bigcup_seqP[cl ?].
rewrite andbT; case/imsetP=> ? ? ->.
by apply/mapP; exists cl.
Qed.

(** Let [ga] be a ground atom in the output of iterating the application of forward chain on [p],
given [i], [k] times. Then, either [ga] is in [i] or its symbol is among the head symbols in [p]. *)
Lemma iter_fwd_chain_sym def p i ga k :
  (ga \in iter k (fwd_chain def p) i) ->
  (ga \in i) || (sym_gatom ga \in hsym_prog p).
Proof.
by elim: k=> [-> //|k h] /fwd_chain_sym /orP [/h|->]; rewrite ?orbT.
Qed.

(** Atom Matching Decomposition:
Let [i1], [i2] be two interpretations,
The substitution set extending a substitution [s] with bindings matching [a]
against the union of [i1] and [i2] equals the union of the substitution set
extending [s] with bindings matching [a] against [i1] with that extending [s]
with bindings matching [a] against [i2]. *)
Lemma match_atom_allU s a i1 i2 :
  match_atom_all (i1 :|: i2) a s =
  match_atom_all i1 a s :|:
  match_atom_all i2 a s.
Proof.
apply/setP=> nu; rewrite !inE; apply/imsetP/orP.
  by case=> ga; rewrite !inE; case/orP=> /mem_imset ha ->; auto.
by case=> /imsetP[ga] hga hnu; exists ga; rewrite ?inE ?hga ?orbT.
Qed.

Definition sym_tl tl := [seq sym_atom (val x) | x <- tl].

(** Atom Matching Modularity:
Let [i1], [i2] be two interpretations.
If the symbol of an atom [a] does not appear among those in [i2], then
extending a substitution [nu] with bindings matching [a] against the union of [i1] and [i2]
equals that of extending [nu] with bindings matching [a] against [i1]. *)
Lemma match_atom_all_strata nu a i1 i2 :
  sym_atom a \notin sym_i i2 ->
  match_atom_all (i1 :|: i2) a nu =
  match_atom_all i1 a nu.
Proof.
move=> h_dis; apply/setP=> nnu; rewrite !inE imsetU !inE.
suff -> : Some nnu \in [set match_atom nu a ga | ga in i2] = false.
  by rewrite orbF.
apply/imsetP=> -[ga gain /esym] /match_atom_sound /(congr1 (sym_atom \o val)) h.
by case/negP: h_dis; apply/imsetP; exists ga.
Qed.

(** Body Matching Modularity:
Let [tl] be an atom list and [i1], [i2] interpretations.
If the symbols in [tl] do not appear in [i2], then the result of matching [tl] against
the union of [i1] with [i2] equals the result of matching [tl] against [i1]. *)
Lemma match_body_strata tl i1 i2 :
  [disjoint sym_tl tl & sym_i i2] ->
  match_body (i1 :|: i2) tl = match_body i1 tl.
Proof.
move=> h_dis; apply: eq_foldS => a a_in nu.
apply: match_atom_all_strata => {nu}.
rewrite disjoint_has in h_dis.
apply: contra h_dis; case/imsetP=> ga hga /= hs.
apply/hasP; exists (sym_atom a).
  by apply/mapP; exists a.
by apply/imsetP; exists ga.
Qed.

Open Scope SET.

(** **** Forward Chain Modularity:
Let [p] be a program and [i], [ip] interpretations.
If [i] is a model for [p] and the symbols in [p] do not appear in [ip], then the
result of applying forward chain on [p], starting from the union of [i] with [ip]
adds no new facts. *)
Lemma fwd_chain_mod def p i ip
      (h_tr   : prog_true p i)
      (h_strata : [disjoint sym_prog p & sym_i ip]) :
  fwd_chain def p (i :|: ip) = i :|: ip.
Proof.
have U := (fwd_chain_stable def h_tr).
rewrite /fwd_chain /cons_clause in U *.
suff E: \bigcup_(cl <- p) ([set gr_atom_def def s (head_cl cl)
                        | s in match_body (i :|: ip) (body_cl cl)]) =
        \bigcup_(cl <- p) ([set gr_atom_def def s (head_cl cl)
                        | s in match_body i (body_cl cl)]).
  by rewrite E -{3}U [i :|: bigop _ _ _]setUC setUAC [_ :|: i]setUC.
set f1 := bigop _ _ _.
set f2 := bigop _ _ _.
rewrite [f1]big_seq_cond [f2]big_seq_cond {f1 f2 U}.
apply: eq_bigr => cl; rewrite andbT => cl_in.
suff -> : match_body (i :|: ip) (body_cl cl)  =
          match_body i (body_cl cl) by [].
apply: match_body_strata.
rewrite !disjoint_has in h_strata *.
apply: contra h_strata; case/hasP=> s hst hs.
apply/hasP; exists s; last by [].
by apply/flatten_mapP; exists cl; rewrite // inE hst orbT.
Qed.

(** Lemmas about forward chain iteration. *)
Lemma iter_fwd_chain_stable def pp i k
  (h_tr : prog_true pp i) :
  iter k (fwd_chain def pp) i = i.
Proof.
elim: k i h_tr => [|ns ihns] ci hstb //=.
by rewrite ihns // fwd_chain_stable.
Qed.

Lemma iter_fwd_chain_subset def pp i k :
  i \subset iter k (fwd_chain def pp) i.
Proof.
elim: k => //= k ihk; rewrite (subset_trans (fwd_chain_inc i pp def)) //.
exact: fwd_chain_mon.
Qed.

End Soundness.
End Datalog.

Lemma fix_iter T (f : T -> T) n s (s_fix : s = f s) : s = iter n f s.
Proof. by elim: n => //= n {1}<-. Qed.

Lemma iter_leq_fix T (f : T -> T) x n m (i_eq: iter n f x = iter n.+1 f x) :
  n <= m -> iter m f x = iter m.+1 f x.
Proof. by move=>/subnK<-; elim: {m}(m-n) => //= m {2}<-. Qed.

(* note: minsetP lemma subsumes all this *)
Section iter_mon.

Variables (T : finType).
Implicit Types (s : {set T}) (f : {set T} -> {set T}).

Definition monotone   f := forall s1 s2, s1 \subset s2 -> f s1 \subset f s2.

Definition increasing f := forall s, s \subset f s.

Variables (f : {set T} -> {set T}) (f_mon : monotone f).

Lemma iter_mon n : monotone (iter n f).
Proof. by elim: n => // n ihn s1 s2 /= s_in; exact/f_mon/ihn. Qed.

Variable (lb : {set T}) (f_lb : forall s, lb \subset s -> lb \subset f s).

Definition iterf n := iter n f lb.

Lemma subset_iterf m n : m <= n -> iterf m \subset iterf n.
Proof.
move/subnK<-; rewrite /iterf addnC iter_add; apply/iter_mon.
by elim: {n m} (n-m); [rewrite ?fsubset_refl | move=> n ihn; apply/f_lb].
Qed.

End iter_mon.

Section Fixpoints.

Variables (T : finType) (s0 ub : {set T}).

Hypothesis (s0_bound : s0 \subset ub).

Implicit Types (s : {set T}) (f : {set T} -> {set T}).

Variables (f : {set T} -> {set T}).

Definition ubound := forall s, s  \subset ub -> f s \subset ub.

Hypothesis (f_mono : monotone f) (f_inc : increasing f) (f_ubound: ubound).

Notation iterf_incr n := (iterf f s0 n).
Notation lfp_incr     := (iterf f s0 #|ub|).

Lemma iterf_incr_bound n : (iterf_incr n) \subset ub.
Proof. by elim: n => /= [|n ihn]; rewrite ?lb_bound ?f_ubound //=. Qed.

(** Adapted from the lfpE lemma in http://www.ps.uni-saarland.de/extras/jaritp14/
   (C) Christian Doczkal and Gert Smolka *)
Lemma lfpE : lfp_incr = f lfp_incr.
Proof.
suff/exists_eqP: [exists k : 'I_#|ub|.+1 , iterf_incr k == iterf_incr k.+1].
   case=> k E; exact/(iter_leq_fix E)/leq_ord.
apply/contraT; rewrite negb_exists => /forallP /= H.
have/(_ #|ub|.+1 (leqnn _)): forall k , k <= #|ub|.+1 -> k <= #|iterf_incr k|.
  elim=> // n IHn Hn.
  rewrite (leq_ltn_trans (IHn (ltnW Hn))) ?proper_card //.
  rewrite properEneq subset_iterf // ?andbT.
  exact: H (Ordinal Hn).
  move=> s hs; have := f_mono hs; have := f_inc s0.
  apply: subset_trans.
rewrite leqNgt ltnS subset_leq_card ?f_ubound //.
exact/iterf_incr_bound.
Qed.

Lemma min_lfp_all s (hs : s0 \subset s) (sfp : s = f s) : lfp_incr \subset s.
Proof. by rewrite (fix_iter #|ub| sfp); apply/iter_mon. Qed.

Lemma has_lfp :
  { lfp : {set T} | lfp = f lfp
                  /\ lfp = iter #|ub| f s0
                  /\ forall s', s0 \subset s' -> s' = f s' -> lfp \subset s'}.
Proof.
by exists lfp_incr; rewrite -lfpE /lfp_incr; repeat split; apply/min_lfp_all.
Qed.

End Fixpoints.

Section Completeness.

Variable n   : nat.
Variable st  : finType.
Variable ct  : finType.
Variable def : constant ct.
Variable ar  : {ffun st -> nat}.
Variable p   : program n ct ar.

Hypothesis p_safe : prog_safe p.

Notation gatom := (gatom ct ar).
Definition bp : {set gatom} := setT.

(** Proof that B(P) is a model of the safe program [p]. *)
Lemma bpM : prog_true p bp.
Proof. by move=> gr; apply/allP=> cl cl_in; apply/implyP; rewrite inE. Qed.

Lemma fwd_chain_complete :
{ m : {set gatom} &
{ n : nat | [/\ prog_true p m
              , m = iter n (fwd_chain def p) set0
              & forall m', prog_true p m' -> m \subset m']}}.
Proof.
have h_inc : increasing (fwd_chain def p).
  by move=> i; apply: fwd_chain_inc.
have h_mon := fwd_chain_mon p def.
have h_fp  := fwd_chain_stable def bpM.
have h_ub  :  ubound bp (fwd_chain def p).
  by move=> ss H; rewrite subsetT.
have h_lb  : set0 \subset bp by rewrite /bp.
have [m [m_fix [m_def m_min]]] := has_lfp h_lb h_mon h_inc h_ub.
exists m, #|bp|; do ! split; auto.
  exact/(fwd_chain_sound p_safe)/esym/m_fix.
by move=> m' /(fwd_chain_stable def)/esym/m_min; apply; rewrite sub0set.
Qed.

Print Assumptions fwd_chain_complete.

(** **** Forward Chain Completeness:
Let [p] be a safe program. The iterative forward chain
inference engine terminates (after iterating as many times as there are elements in B(P))
and outputs a minimal model for [p]. *)
Lemma incr_fwd_chain_complete (s0 : {set gatom}) :
{ m : {set gatom} &
{ n : nat | [/\ prog_true p m
              , n = #|bp|
              , m = iter n (fwd_chain def p) s0
              & forall (m' : {set gatom}), s0 \subset m' -> prog_true p m' -> m \subset m']}}.
Proof.
have h_inc : increasing (fwd_chain def p).
  by move=> i; apply: fwd_chain_inc.
have h_mon := fwd_chain_mon p def.
have h_fp  := fwd_chain_stable def bpM.
have h_ub  :  ubound bp (fwd_chain def p).
  by move=> ss H; rewrite subsetT.
have h_lb  : s0 \subset bp by rewrite /bp.
have [m [m_fix [m_def m_min]]] := has_lfp h_lb h_mon h_inc h_ub.
exists m, #|bp|; do ! split; auto.
  exact/(fwd_chain_sound p_safe)/esym/m_fix.
by move=> m' hs /(fwd_chain_stable def)/esym/m_min; apply.
Qed.

End Completeness.

Module Exports.

Canonical cons_subType.
Canonical cons_eqType.
Canonical cons_choiceType.
Canonical cons_countType.
Canonical cons_subCountType.
Canonical cons_finType.
Canonical cons_subFinType.
Canonical raw_gatom_eqType.
Canonical raw_gatom_choiceType.
Canonical raw_gatom_countType.
Canonical gatom_subType.
Canonical gatom_eqType.
Canonical gatom_choiceType.
Canonical gatom_countType.
Canonical gatom_subCountType.
Canonical gatom_finType.
Canonical gatom_subFinType.
Canonical term_eqType.
Canonical term_choiceType.
Canonical raw_atom_eqType.
Canonical raw_atom_choiceType.
Canonical atom_subType.
Canonical atom_eqType.
Canonical atom_choiceType.
Canonical clause_eqType.
Canonical clause_choiceType.
End Exports.


(*

  Copyright 2016 University of Luxembourg

  This file is part of our formalization of Platzer's
    "A Complete Uniform Substitution Calculus for Differential Dynamic Logic"
  available here: http://arxiv.org/pdf/1601.06183.pdf (July 27, 2016).
  We refer to this formalization as DdlCoq here.

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

  DdlCoq is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with DdlCoq.  If not, see <http://www.gnu.org/licenses/>.

  authors:
    Vincent Rahli
    Marcus Völp
    Ivana Vukotic

 *)

Require Export list_util.
Require Export vec_util.
Require Export reals_util.
Require Export symbol_lemmas.
Require Export Derive.
Require Export deriv_util.
Require Export state.

(**

  This file contains some lemmas about smooth functions with multiple arguments.
  Beside that, this file introduces definitions for semantics of Terms, Formulas and
  Programs, as well as definition of interpretation.
  This file works with functions with multiple arguments

*)

(** definition of symbols which works with functions with multiple arguments *)
Inductive Symbol :=
(* terms *)
| SymbolFunction (f : FunctionSymbol) (n : nat) : Symbol
| SymbolDotTerm (n : nat) : Symbol

(* formulas *)
| SymbolPredicate (f : PredicateSymbol) (n : nat) : Symbol
| SymbolQuantifier (f : QuantifierSymbol) : Symbol
| SymbolDotForm : Symbol

(* ODEs *)
(* provides the bound variables & dynamic semantics of ODE constants *)
| SymbolODE (c : ODEConst) : Symbol

(* programs *)
| SymbolProgramConst (a : ProgramConstName) : Symbol.

(*
Record listn (T : Type) (n : nat) :=
  mk_listn
  {
    listn_l : list T;
    listn_cond : Datatypes.length listn_l = n
  }.
*)

(** function is n derivable if it's n derivable in every point *)
Definition ex_derive_all_n (f : R -> R) :=
  forall n pt, ex_derive_n f n pt.

(** partial derivative of variables in state (st stands for state here) *)
Fixpoint partial_derive
         (f : state -> R)
         (l : list Assign)
  : state -> R
  :=
    match l with
    | [] => f
    | v :: l =>
      fun (st : state) =>
        Derive
          (fun X : R =>
             partial_derive
               f
               l
               (upd_state st v X))
          (st v)
    end.

Require Export FunctionalExtensionality.

Lemma upd_state_var_ext :
  forall s v,
    upd_state_var s v (s (KAssignVar v)) = s.
Proof.
  introv.
  apply functional_extensionality; introv.
  unfold upd_state_var, upd_state; dest_cases w.
Qed.

Lemma upd_state_ext :
  forall s v,
    upd_state s v (s v) = s.
Proof.
  introv.
  apply functional_extensionality; introv.
  unfold upd_state_var, upd_state; dest_cases w.
Qed.

Lemma upd_state_var_twice :
  forall s v z w,
    upd_state_var (upd_state_var s v z) v w
    = upd_state_var s v w.
Proof.
  introv.
  apply functional_extensionality; introv.
  unfold upd_state_var, upd_state.
  dest_cases w.
Qed.
Hint Rewrite upd_state_var_twice.

Lemma upd_state_twice :
  forall s v z w,
    upd_state (upd_state s v z) v w
    = upd_state s v w.
Proof.
  introv.
  apply functional_extensionality; introv.
  unfold upd_state.
  dest_cases w.
Qed.
Hint Rewrite upd_state_twice.

Lemma partial_derive_st_as_Derive_n :
  forall (l : list Assign) f v s,
    (forall x, List.In x l -> x = v)
    -> partial_derive f l s
       = Derive_n
           (fun r => f (upd_state s v r))
           (List.length l)
           (s v).
Proof.
  induction l; introv imp; simpl in *.
  { rewrite upd_state_ext; auto. }
  { dLin_hyp h; subst.
    apply Derive_ext; introv.
    rewrite (IHl f v); auto.
    autorewrite with core.
    apply Derive_n_ext; introv.
    autorewrite with core; auto. }
Qed.

Definition ex_partial_derive_st_l
           (f  : state -> R)
           (st : state)
           (l  : list Assign)
           (v  : Assign) :=
  ex_derive_R
    (fun X => partial_derive f l (upd_state st v X))
    (st v).

(** This says that the (n+1)th partial derivative of f exists *)
Definition ex_nth_partial_derive_st (n : nat) (f : state -> R) :=
  forall (st : state) (l : list Assign) (v : Assign),
    List.length l = n
    -> ex_partial_derive_st_l f st l v.

Definition ex_all_partial_derive_st (f : state -> R) :=
  forall n, ex_nth_partial_derive_st n f.

Lemma partial_derive_st_ext :
  forall f g l st,
    (forall s, f s = g s)
    -> partial_derive f l st
       = partial_derive g l st.
Proof.
  induction l; introv imp; simpl; auto.
  apply Derive_ext; introv.
  apply IHl; auto.
Qed.

Lemma ex_all_partial_derive_st_ext :
  forall F G,
    (forall s, F s = G s)
    -> ex_all_partial_derive_st F
    -> ex_all_partial_derive_st G.
Proof.
  introv imp d len; simpl.
  eapply ex_derive_ext;[|apply (d n);exact len].
  simpl; introv.
  apply partial_derive_st_ext; auto.
Qed.

(*
Definition partial_derive_st_upd :
  forall f l s s',
    partial_derive f l s
    = partial_derive (fun s' => f (upd_state_st s s' l)) l s'.
Proof.
  induction l; introv; simpl; autorewrite with core; auto.
Abort.*)

Definition ex_partial_derive
           (f : state -> R)
           (v : Assign)
           (l : list Assign) : Prop :=
  forall pt s,
    ex_derive_R
      (fun X =>
         partial_derive
           f
           l
           (upd_state s v X))
      pt.

(** This is a variant of [ex_all_partial_derive_st] where the point can be anything.
    We prove below in [ex_partial_derive_st_pt_eq_all] that both
    definitions are equivalent.
 *)
Definition ex_partial_derive_st_pt (f : state -> R) : Prop :=
  forall v l, ex_partial_derive f v l.

Lemma ex_partial_derive_st_pt_eq_all :
  forall (f : state -> R),
    ex_partial_derive_st_pt f <-> ex_all_partial_derive_st f.
Proof.
  introv; split; intro h.

  { introv len; subst.
    unfold ex_partial_derive_st_l; simpl; apply h. }

  { repeat introv; simpl in *.
    pose proof (h (List.length l) (upd_state s v pt) l v eq_refl) as h.
    unfold ex_partial_derive_st_l in h; simpl in h.
    autorewrite with core in h.
    eapply ex_derive_ext;[|exact h]; clear h; simpl; introv.
    autorewrite with core; auto. }
Qed.

Definition Vector := Vector.t.

(*

   This is essentially stating that [f] is smooth.
   It derives [f]'s arguments through the interpretation function [G].

   Does that even make sense?

   Try to prove [ex_derive_func 2 plus_vector],
   where plus_vector is defined from Rplus.
   (see below)

   T is really Term, but what do we really care what the type is?

 *)
Definition ex_partial_derive_st_func {m : nat} (f : Vector R m -> R) :=
  forall (T  : Type)
         (d  : T) (* forall non-empty T *)
         (ts : Vector T m)
         (G  : state -> T -> R),
    (forall t, Vector.In t ts -> ex_all_partial_derive_st (fun s => G s t))
    -> ex_all_partial_derive_st (fun s => f (Vector.map (G s) ts)).

(*

  Here's a slightly stronger version where the arguments have to only be
  derivable on sublists.

  We show below in [smooth_fun_T_eq] that it is equivalent
  to the vectorial version [smooth_fun]

 *)
Definition smooth_fun_T {m : nat} (f : Vector R m -> R) :=
  forall (T  : Type)
         (d  : T) (* forall non-empty T *)
         (ts : Vector T m)
         (G  : state -> T -> R)
         (v  : Assign)
         (l  : list Assign),
    (forall t w l',
        Vector.In t ts
        -> sublist (w :: l') (v :: l)
        -> ex_partial_derive (fun s => G s t) w l')
    -> ex_partial_derive (fun s => f (Vector.map (G s) ts)) v l.

(*
   A stronger variant of ex_partial_derive_st_func.
   Here we ask for the arguments to be derivable on the same
   states and variables.
   Is that enough?  Probably not because I can't prove it for plus in
   dynamic_semantics_prop.v! (Lemma ex_partial_derive_st_func_l_plus_vector)
 *)
Definition ex_partial_derive_st_func_l {m : nat} (f : Vector R m -> R) :=
  forall (T  : Type)
         (d  : T) (* forall non-empty T *)
         (ts : Vector T m)
         (G  : state -> T -> R)
         (st : state)
         (l  : list Assign)
         (v  : Assign),
    (forall t, Vector.In t ts -> ex_partial_derive_st_l (fun s => G s t) st l v)
    -> ex_partial_derive_st_l (fun s => f (Vector.map (G s) ts)) st l v.

Definition revApp {A B} (s : A) (f : A -> B) : B := f s.

(*

  This is an alternative definition of ex_partial_derive_st_func
  that is not parametrized over a non-empty type and an interpretation-like
  function (the G in ex_partial_derive_st_func)
  but instead directly provides a vector of interpretations.
  We show below in ex_partial_derive_vec_st_func_eq that the two definitions
  are equivalent (obviously! :P).

 *)
Definition ex_partial_derive_vec_st_func {m : nat} (f : Vector R m -> R) :=
  forall (Is : Vector (state -> R) m),
    (forall i, Vector.In i Is -> ex_all_partial_derive_st i)
    -> ex_all_partial_derive_st (fun s => f (Vector.map (revApp s) Is)).

Definition smooth_fun {m : nat} (f : Vector.t R m -> R) :=
  forall (Is : Vector.t (state -> R) m) (v : Assign) (l : list Assign),
    (forall i w l',
        Vector.In i Is
        -> sublist (w :: l') (v :: l)
        -> ex_partial_derive i w l')
    -> ex_partial_derive (fun s => f (Vector.map (revApp s) Is)) v l.

Lemma ex_partial_derive_vec_st_func_eq :
  forall {m} (f : Vector.t R m -> R),
    ex_partial_derive_vec_st_func f <-> ex_partial_derive_st_func f.
Proof.
  introv; split; introv exd.

  { introv d cond.
    unfold ex_partial_derive_vec_st_func in exd.

    pose proof (exd (Vector.map (fun a s => G s a) ts)) as q; clear exd.
    autodimp q hyp.
    { introv j; apply in_vec_map in j; exrepnd; subst; auto. }
    eapply ex_all_partial_derive_st_ext in q;
      [|introv;rewrite vec_map_map; unfold compose; reflexivity].
    auto.
  }

  { introv cond.
    unfold ex_partial_derive_st_func in exd.
    apply (exd (state -> R) (fun _ => 0) Is (fun s i => i s)); auto.
  }
Qed.

Lemma ex_partial_derive_ext :
  forall f g v l,
    (forall s, f s = g s)
    -> ex_partial_derive f v l
    -> ex_partial_derive g v l.
Proof.
  introv e pd; introv; simpl in *.
  eapply ex_derive_ext;[|apply pd]; simpl; introv.
  apply partial_derive_st_ext; auto.
Qed.

Lemma smooth_fun_T_eq :
  forall {m} (f : Vector.t R m -> R),
    smooth_fun f <-> smooth_fun_T f.
Proof.
  introv; split; introv exd.

  { introv d cond; introv; simpl in *.

    pose proof (exd (Vector.map (fun a s => G s a) ts) v l) as q; clear exd.
    autodimp q hyp.
    { introv j; apply in_vec_map in j; exrepnd; subst; auto. }
    eapply ex_derive_ext;[|apply (q pt s)]; simpl; introv; clear q.
    apply partial_derive_st_ext; introv.
    rewrite vec_map_map; unfold compose; auto.
  }

  { introv cond; introv; simpl in *.
    apply (exd (state -> R) (fun _ => 0) Is (fun s i => i s)); auto.
  }
Qed.

Definition plus_vector : Vector.t R 2%nat -> R :=
  fun v : Vector.t R 2%nat =>
    match v with
    | Vector.cons x 1 (Vector.cons y 0 Vector.nil) => Rplus x y
    | _ => R0
    end.

(* see ex_partial_derive_st_func_test_plus in dynamic_semantics_props, which is proved *)
Lemma ex_partial_derive_st_func_test : ex_partial_derive_st_func plus_vector.
Proof.
  introv d; introv.
  unfold plus_vector; simpl.
  apply (Vector.caseS' ts).
  introv; simpl.
  apply (Vector.caseS' t).
  introv; simpl.

  clear ts t.
  apply (@Vector.case0
                T
                (fun t0 =>
                   (forall t : T,
                       Vector.In t (Vector.cons T h 1 (Vector.cons T h0 0 t0)) ->
                       ex_all_partial_derive_st (fun s : state => G s t)) ->
                   ex_all_partial_derive_st
                     (fun s : state =>
                        match Vector.map (G s) t0 return R with
                        | @Vector.nil _ => G s h + G s h0
                        | @Vector.cons _ _ _ _ => 0
                        end))).
  simpl.
  clear t0.
  introv ih.
  rename h into x.
  rename h0 into y.

  pose proof (ih x) as h1.
  pose proof (ih y) as h2.
  clear ih.
  autodimp h1 hyp;[constructor|].
  autodimp h2 hyp;[repeat constructor|].

(*
  unfold ex_partial_derive_st in *.
  unfold ex_nth_partial_derive_st in *.
  introv H1.
  unfold ex_derive_R in *.
  unfold ex_derive in *.
  (* I need instance of type T (I can not rewrite, apply of pose proof)*)
 *)
Abort.

(** interpretation of function with multiple arguments *)
Record interpretation_function (n : nat) :=
  MkInterpFun
    {
      interp_fun_f : Vector.t R n -> R;
      interp_fun_cond : smooth_fun_T interp_fun_f
    }.

(** definition of semantics for Terms *)
Definition TermSem := state -> R.

(** definition of semantics for Formulas *)
Definition FormulaSem := state -> Prop.

(** definition of semantics for Formulas which return False and True, respectively *)
Definition FalseFormulaSem : FormulaSem := fun _ => False.
Definition TrueFormulaSem  : FormulaSem := fun _ => True.

(** definition of semantics for Programs **)
Definition ProgramSem := state -> state -> Prop.

(** definition of semantics for Programs which return False and True, respectively *)
Definition FalseProgramSem : ProgramSem := fun _ _ => False.
Definition TrueProgramSem  : ProgramSem := fun _ _ => True.

(** definition of semantics for Differential Programs *)
Definition ODESem := state -> state.
(*Definition ODESem := R -> (R -> state) -> Prop.*)
(*Definition ODEConstSem := state -> state.*)
(*Definition ODEConstSem := (R -> state) -> R -> state.*)
(* Could we do that instead:

Definition ODESem := forall r : R, (preal_upto r -> state) -> Prop.
Definition ODEConstSem := forall (r : R), (preal_upto r -> state) -> preal_upto r -> state.*)

(*
  [R -> state] is a stateflow.
  Do we have to limit the stateflow in time?  Right now we do with the argument [R].
 *)

Definition interpQuantExt (F : FormulaSem -> FormulaSem) :=
  forall f g v w,
    (forall a, v a = w a)
    -> (forall s, f s <-> g s)
    -> (F f v <-> F g w).

(** interpretation of quantifier *)
Record interpretation_quantifier :=
  MkInterpQuant
    {
      interp_quant_f : FormulaSem -> FormulaSem;
      interp_quant_ext : interpQuantExt interp_quant_f
    }.

Definition interpOdeExt (l : list Assign) (F : ODESem) :=
  forall (v w : state) a,
    (forall a, v a = w a)
    -> F v a = F w a.

Record interpretation_ode :=
  MkInterpODE
    {
      interp_ode_bv   : list Assign;
      interp_ode_dm   : ODESem;
      interp_ode_cond : interpOdeExt interp_ode_bv interp_ode_dm
    }.

(** definition of interpretation *)
Definition interpretation :=
  forall f : Symbol,
    match f return Type with
    | SymbolFunction _ n => interpretation_function n
    | SymbolDotTerm n => R

    | SymbolPredicate _  n => Vector.t R n -> Prop
    | SymbolQuantifier _ => interpretation_quantifier
    | SymbolDotForm => FormulaSem

    | SymbolODE _ => interpretation_ode

    | SymbolProgramConst _ => ProgramSem
    end.

Ltac constant_derivable :=
  let eps := fresh "eps" in
  let h   := fresh "h" in
  let d   := fresh "d" in
  let q   := fresh "q" in
  let z   := fresh "z" in
  try (unfold derivable_pt, derivable_pt_abs, derivable_pt_lim);
    autorewrite with core;
    exists R0;
    intros eps h;
    exists R1pos;
    intros d q z;
    autorewrite with core;
    rewrite zero_div_is_zero; auto;
    rewrite Rabs_R0; auto.

Lemma deriv_constant :
  forall c, derivable (fun X => c).
Proof.
  intros c; intros x.
  reg.
Qed.

Lemma ex_all_partial_derive_st_implies_l_pt :
  forall (f : state -> R) v l,
    ex_all_partial_derive_st f
    -> ex_partial_derive f v l.
Proof.
  introv h; introv; simpl in *.
  apply ex_partial_derive_st_pt_eq_all in h.
  apply h.
Qed.