(* constructions for inductive proofs about derivations,
  part adapted from ~jeremy/isabelle/2005/seqms/gstep.{thy,ML}
  but can_trf_rules and friends are new *)

Set Implicit Arguments.

Require Import Wf.  (* wfp called Acc, note Acc_intro, Acc_rect,
  or AccT for Type version *)

Require Import Coq.Program.Equality. (* for dependent induction/destruction *)
Require Import PeanoNat. (* for Nat *)

(* Add LoadPath "../tense-lns". *)
Require Import gen genT.
Require Import ddT dd_fc.
Require Import rtcT.

(*
"gen_step ?P ?A ?sub ?derivs (?ps, ?concl) =
  ((ALL A'. (A', ?A) : ?sub --> Ball ?derivs (?P A')) -->
  (ALL p:set ?ps. p : ?derivs & ?P ?A p) -->
  ?concl : ?derivs --> ?P ?A ?concl)"
  *)

Definition gen_step (seq fml : Type) P A (sub : fml -> fml -> Type)
  derivs ps (concl : seq) :=
  (forall A', sub A' A -> (forall x, derivs x -> P A' x)) ->
  ForallT (fun p => prod (derivs p) (P A p)) ps -> derivs concl -> P A concl.

Lemma gen_step_sub_mono seq fml P A sub1 sub2 derivs ps c :
  rsub sub1 sub2 -> gen_step P A sub1 derivs ps c ->
  @gen_step seq fml P A sub2 derivs ps c.
Proof. unfold gen_step. intros rs gs saa. apply gs.
intros A' s1aa. exact (saa A' (rsubD rs _ _ s1aa)). Qed.

Lemma gen_step_def: forall (seq fml : Type) P A sub derivs ps (concl : seq),
  @gen_step seq fml P A sub derivs ps concl =
  ((forall A', sub A' A -> (forall x, derivs x -> P A' x)) ->
  ForallT (fun p => prod (derivs p) (P A p)) ps -> derivs concl -> P A concl).
Proof.  intros. unfold gen_step. reflexivity. Qed.

Inductive gen_step' (seq fml : Type) P A (sub : fml -> fml -> Type)
  derivs ps (concl : seq) :=
  | gsI : ((forall A', sub A' A -> (forall x, derivs x -> P A' x)) ->
  ForallT (fun p => prod (derivs p) (P A p)) ps -> derivs concl -> P A concl) ->
  gen_step' P A (sub : fml -> fml -> Type) derivs ps (concl : seq).

Lemma gs_gs': forall (seq fml : Type) P A (sub : fml -> fml -> Type)
  derivs ps (concl : seq),
  iffT (gen_step P A sub derivs ps concl) (gen_step' P A sub derivs ps concl).
Proof. intros. unfold gen_step. unfold iffT. split ; intros.
apply gsI. exact X.
destruct X. apply p ; assumption. Qed.

(*
"gen_step2 ?P ?A ?sub (?dls, ?drs) ((?psl, ?cl), ?psr, ?cr) =
  ((ALL A'.
       (A', ?A) : ?sub --> (ALL dl:?dls. ALL dr:?drs. ?P A' (dl, dr))) -->
   (ALL pl:set ?psl. pl : ?dls & ?P ?A (pl, ?cr)) -->
   (ALL pr:set ?psr. pr : ?drs & ?P ?A (?cl, pr)) -->
   ?cl : ?dls --> ?cr : ?drs --> ?P ?A (?cl, ?cr))"
*)

Definition gen_step2 (seql seqr fml : Type) (P : fml -> seql -> seqr -> Type)
  A (sub : fml -> fml -> Type) dls drs psl cl psr cr :=
  (forall A', sub A' A ->
    forall dl, dls dl -> forall dr, drs dr -> P A' dl dr) ->
  ForallT (fun pl => prod (dls pl) (P A pl cr)) psl ->
  ForallT (fun pr => prod (drs pr) (P A cl pr)) psr ->
  dls cl -> drs cr -> P A cl cr.

Lemma gen_step2_sub_mono seql seqr fml P A sub1 sub2 dls drs psl cl psr cr :
  rsub sub1 sub2 -> gen_step2 P A sub1 dls drs psl cl psr cr ->
  @gen_step2 seql seqr fml P A sub2 dls drs psl cl psr cr.
Proof. unfold gen_step2. intros rs gs saa. apply gs.
intros A' s1aa. exact (saa A' (rsubD rs _ _ s1aa)). Qed.

Definition gen_step2_empty seql seqr fml P A sub dls drs psl cl psr cr :=
  (@gen_step2_sub_mono seql seqr fml P A _ sub dls drs psl cl psr cr)
  (rsub_emptyT sub).

(* generalised version of inductive step proof *)
Lemma gen_step_lem_psT: forall (sty fty : Type) (P : fty -> sty -> Type)
  A sub rules prems, AccT sub A ->
    (forall A ps concl, rules ps concl ->
      gen_step P A sub (derrec rules prems) ps concl) ->
    (forall A prem, prems prem -> P A prem) ->
    (forall seq, derrec rules prems seq -> P A seq).
Proof. intros until 0. intros acc gs prs. induction acc.
intros.  eapply derrec_all_rect. apply prs.
intros. unfold gen_step in gs. eapply gs. exact X1. exact X.
apply ForallTI_forall. intros. split.
eapply dersrecD_forall in X2. exact X2. exact X4.
eapply ForallTD_forall in X3. exact X3. exact X4.
eapply derI ; eassumption. exact X0. Qed.

Lemma gen_step_lem_ps: forall (sty fty : Type) (P : fty -> sty -> Type)
  A sub rules prems, Acc sub A ->
    (forall A ps concl, rules ps concl ->
      gen_step P A sub (derrec rules prems) ps concl) ->
    (forall A prem, prems prem -> P A prem) ->
    (forall seq, derrec rules prems seq -> P A seq).
Proof. intros until 0. intros acc gs prs. induction acc.
intros.  eapply derrec_all_rect. apply prs.
intros. unfold gen_step in gs. eapply gs. exact X1. exact X.
apply ForallTI_forall. intros. split.
eapply dersrecD_forall in X2. exact X2. exact X4.
eapply ForallTD_forall in X3. exact X3. exact X4.
eapply derI ; eassumption. exact X0. Qed.

Check gen_step_lem_ps.

Definition gen_step_lem sty fty P A sub rules acc gs :=
  @gen_step_lem_ps sty fty P A sub rules (@emptyT sty) acc gs
  (fun A0 => @emptyT_any' sty (P A0)).

Definition gen_step_lemT sty fty P A sub rules acc gs :=
  @gen_step_lem_psT sty fty P A sub rules (@emptyT sty) acc gs
  (fun A0 => @emptyT_any' sty (P A0)).

Check gen_step_lem.

(* this one does allow for premises *)
Lemma gen_step2_lem_ps: forall (stya styb fty : Type) P (A : fty) sub
  rlsa rlsb (premsa : stya -> Type) (premsb : styb -> Type),
  Acc sub A -> (forall A psa psb ca cb, rlsa psa ca -> rlsb psb cb ->
  gen_step2 P A sub (derrec rlsa premsa)
    (derrec rlsb premsb) psa ca psb cb) ->
 (forall A pa, premsa pa -> forall cb, derrec rlsb premsb cb -> P A pa cb) ->
 (forall A pb, premsb pb -> forall ca, derrec rlsa premsa ca -> P A ca pb) ->
  forall seqa, derrec rlsa premsa seqa ->
  forall seqb, derrec rlsb premsb seqb -> P A seqa seqb.
Proof. intros until 0. intros acc gs prsa prsb. induction acc.
eapply derrec_all_rect2.
intros. eapply prsa in X0. exact X0. exact X1.
intros. eapply prsb in X0. exact X0. exact X1.
intros. unfold gen_step2 in gs. eapply gs. exact X0. exact X1. exact X.
apply ForallTI_forall. intros. split.
eapply dersrecD_forall in X2. exact X2. exact X6.
eapply ForallTD_forall in X4. exact X4. exact X6.
apply ForallTI_forall. intros. split.
eapply dersrecD_forall in X3. exact X3. exact X6.
eapply ForallTD_forall in X5. exact X5. exact X6.
eapply derI ; eassumption.  eapply derI ; eassumption. Qed.

Lemma gen_step2_lem_psT: forall (stya styb fty : Type) P (A : fty) sub
  rlsa rlsb (premsa : stya -> Type) (premsb : styb -> Type),
  AccT sub A -> (forall A psa psb ca cb, rlsa psa ca -> rlsb psb cb ->
  gen_step2 P A sub (derrec rlsa premsa)
    (derrec rlsb premsb) psa ca psb cb) ->
 (forall A pa, premsa pa -> forall cb, derrec rlsb premsb cb -> P A pa cb) ->
 (forall A pb, premsb pb -> forall ca, derrec rlsa premsa ca -> P A ca pb) ->
  forall seqa, derrec rlsa premsa seqa ->
  forall seqb, derrec rlsb premsb seqb -> P A seqa seqb.
Proof. intros until 0. intros acc gs prsa prsb. induction acc.
eapply derrec_all_rect2.
intros. eapply prsa in X0. exact X0. exact X1.
intros. eapply prsb in X0. exact X0. exact X1.
intros. unfold gen_step2 in gs. eapply gs. exact X0. exact X1. exact X.
apply ForallTI_forall. intros. split.
eapply dersrecD_forall in X2. exact X2. exact X6.
eapply ForallTD_forall in X4. exact X4. exact X6.
apply ForallTI_forall. intros. split.
eapply dersrecD_forall in X3. exact X3. exact X6.
eapply ForallTD_forall in X5. exact X5. exact X6.
eapply derI ; eassumption.  eapply derI ; eassumption. Qed.

Check gen_step2_lem_ps.

(* this one doesn't allow for premises *)
Definition gen_step2_lem stya styb fty P A sub rlsa rlsb acc gs :=
  @gen_step2_lem_ps stya styb fty P A sub rlsa rlsb
  (@emptyT stya) (@emptyT styb) acc gs
  (fun _ => @emptyT_any' stya _) (fun _ => @emptyT_any' styb _).

Definition gen_step2_lemT stya styb fty P A sub rlsa rlsb acc gs :=
  @gen_step2_lem_psT stya styb fty P A sub rlsa rlsb
  (@emptyT stya) (@emptyT styb) acc gs
  (fun _ => @emptyT_any' stya _) (fun _ => @emptyT_any' styb _).

Check gen_step2_lem.

(* simplified versions, forget A, then derive version with A *)
Definition gen_steps (seq : Type) P derivs ps (concl : seq) :=
  ForallT (fun p => prod (derivs p) (P p)) ps -> derivs concl -> P concl.

Definition gen_step2s (seql seqr : Type) (P : seql -> seqr -> Type)
  dls drs psl cl psr cr :=
  ForallT (fun pl => prod (dls pl) (P pl cr)) psl ->
  ForallT (fun pr => prod (drs pr) (P cl pr)) psr ->
  dls cl -> drs cr -> P cl cr.

(* generalised version of inductive step proof *)
Lemma gen_steps_lem_ps (sty : Type) (P : sty -> Type) rules prems:
    (forall ps concl, rules ps concl ->
      gen_steps P (derrec rules prems) ps concl) ->
    (forall prem, prems prem -> P prem) ->
    (forall seq, derrec rules prems seq -> P seq).
Proof. intros until 0. intros gs prs.
intros.  eapply derrec_all_rect. apply prs.
intros. unfold gen_steps in gs. eapply gs. exact X0.
apply ForallTI_forall. intros. split.
eapply dersrecD_forall in X1 ; eassumption.
eapply ForallTD_forall in X2 ; eassumption.
eapply derI ; eassumption. exact X. Qed.

Definition gen_steps_lem sty P rules gs :=
  @gen_steps_lem_ps sty P rules (@emptyT sty) gs (@emptyT_any' sty P).

Lemma gen_step2s_lem_ps: forall (stya styb : Type) P
  rlsa rlsb (premsa : stya -> Type) (premsb : styb -> Type),
  (forall psa psb ca cb, rlsa psa ca -> rlsb psb cb ->
  gen_step2s P (derrec rlsa premsa) (derrec rlsb premsb) psa ca psb cb) ->
 (forall pa, premsa pa -> forall cb, derrec rlsb premsb cb -> P pa cb) ->
 (forall pb, premsb pb -> forall ca, derrec rlsa premsa ca -> P ca pb) ->
  forall seqa, derrec rlsa premsa seqa ->
  forall seqb, derrec rlsb premsb seqb -> P seqa seqb.
Proof. intros until 0. intros gs prsa prsb.
eapply derrec_all_rect2.
- intros px ppx cy db. eapply prsa in db ; eassumption.
- intros py ppy cx da. eapply prsb in da ; eassumption.
- intros *. intros ra rb da db fx fy.
unfold gen_step2s in gs. eapply gs.
+ exact ra. + exact rb.
+ apply ForallTI_forall. intros x inx. split.
eapply dersrecD_forall in da ; eassumption.
eapply ForallTD_forall in fx ; eassumption.
+ apply ForallTI_forall. intros y iny. split.
eapply dersrecD_forall in db ; eassumption.
eapply ForallTD_forall in fy ; eassumption.
+ eapply derI ; eassumption.
+ eapply derI ; eassumption. Qed.

Definition gen_step2s_lem stya styb P rlsa rlsb gs :=
  @gen_step2s_lem_ps stya styb P rlsa rlsb
  (@emptyT stya) (@emptyT styb) gs
  (@emptyT_any' stya _) (@emptyT_any' styb _).

(* proof of version depending on formula A from versions not depending on A,
  showing this is possible, however, since this is difficult and
  proving (for example) gen_step2_lem_psT is not much harder
  than proving gen_step2s_lem_ps, might as welll use gen_step2_lem_psT *)
Lemma gen_step_lem' sty fty P (A : fty) sub rules:
  AccT sub A -> (forall A0 ps concl, rules ps concl ->
    gen_step P A0 sub (derrec rules (emptyT (X:=sty))) ps concl) ->
    forall seq : sty, derrec rules (emptyT (X:=sty)) seq -> P A seq.
Proof. intros acc gs. induction acc.
remember (fun s => (forall y, sub y x ->
  forall seq, derrec rules (emptyT (X:=sty)) seq -> P y seq) -> P x s) as Q.
pose (@gen_steps_lem sty Q).
rewrite HeqQ in q. intros seq ds. eapply q. 2: apply ds.
all: cycle 1. intros y syx. eapply X. exact syx.
clear q.  intros ps concl rpc.
eapply gs in rpc.  unfold gen_step in rpc.
unfold gen_steps.  intros ft drc sp.
apply rpc. exact sp. 2: exact drc.
apply ForallTI_forall.  intros x0 inxp.
eapply ForallTD_forall in ft. 2: apply inxp. cD.
split. exact ft. apply ft0. exact sp. Qed.

(* alternative approach to admissibility, useful for swap in Box rule of K4,
  where single swap in conclusion requires two swaps in premises,
  which requires the _rtc;
  very easily extended to derl rules in def of can_trf_rules
  (though this doesn't give height preservation),
  can we extend this to reflexive transitive closure of R ?? *)

(* note - although we can't seem to be able to extend this to derl
  and reflexive transitive closure of R together,
  we do need reflexive closure of R together with
  a sort of reflexive closure of the rules, eg
  where R is that a certain rule can be inverted,
  where the rule is that same rule, then we don't want a R step or
  a single rule application step;
  for the K4 rule which allows weakening, where the formula to be
  inverted is among what is added, then the changed version is
  derived from the original premise, not from a related premise *)

Unset Universe Polymorphism.

Definition can_trf_rules (sty : Type) R rules (ps : list sty) (c : sty) :=
  forall c' : sty, R c c' ->
  (sigT (fun ps' : list sty => prod (rules ps' c')
    (ForallT (fun p' => sigT (fun p => prod (InT p ps) (R p p'))) ps'))).

Definition can_trf_rules_rc (sty : Type) R rules (ps : list sty) (c : sty) :=
  forall c' : sty, R c c' ->
  (sigT (fun ps' : list sty => prod (rules ps' c') (ForallT
    (fun p' => sigT (fun p => prod (InT p ps) (clos_reflT R p p'))) ps'))).

(* can_trf_rules_rc would be a bit pointless if we specified that
  ps to c is a rule, because then can_trf_rules R would imply
  can_trf_rules (clos_reflT R) *)

Lemma can_trf_rules_imp_rc sty R rules ps c:
  @can_trf_rules sty R rules ps c -> @can_trf_rules_rc sty R rules ps c.
Proof. unfold can_trf_rules. unfold can_trf_rules_rc.
intros. apply X in X0. cD. exists X0. split. assumption.
apply ForallTI_forall. intros.
eapply ForallTD_forall in X2. 2: eassumption. cD.
exists X2. split. assumption.
apply rT_step. assumption. Qed.

Lemma can_trf_rules_mono' sty R rulesa rulesb:
  rsub rulesa rulesb -> forall ps (c : sty),
  can_trf_rules R rulesa ps c -> can_trf_rules R rulesb ps c.
Proof. unfold can_trf_rules.
intros. apply X0 in X1. clear X0. cD.
eexists.  split.  unfold rsub in X. apply X. apply X0. apply X2. Qed.

Lemma can_trf_rules_rc_mono' sty R rulesa rulesb:
  rsub rulesa rulesb -> forall ps (c : sty),
  can_trf_rules_rc R rulesa ps c -> can_trf_rules_rc R rulesb ps c.
Proof. unfold can_trf_rules_rc.
intros. apply X0 in X1. clear X0. cD.
eexists.  split.  unfold rsub in X. apply X. apply X0. apply X2. Qed.

Definition can_trf_rules_mono sty R rulesa rulesb r :=
  rsubI _ _ (@can_trf_rules_mono' sty R rulesa rulesb r).
Definition can_trf_rules_rc_mono sty R rulesa rulesb r :=
  rsubI _ _ (@can_trf_rules_rc_mono' sty R rulesa rulesb r).

(* union of two relations *)
Polymorphic Inductive runion U V ra rb (ps : U) (c : V) : Type :=
  | run_l : ra ps c -> @runion U V ra rb ps c
  | run_r : rb ps c -> @runion U V ra rb ps c.

(* union of set of rule sets *)
Polymorphic Inductive rUnion U V rr (ps : U) (c : V) : Type :=
  | rUnI : forall r, rr r -> r ps c -> @rUnion U V rr ps c.

(* union property for R in can_trf_rules... *)
Lemma can_trf_rules_un sty R R' rules ps (c : sty):
  can_trf_rules R rules ps c -> can_trf_rules R' rules ps c ->
    can_trf_rules (runion R R') rules ps c.
Proof. unfold can_trf_rules. intros. destruct X1.
apply X in r. cD.  exists r. split. assumption.
apply ForallTI_forall.  intros. eapply ForallTD_forall in r1. cD.
exists r1.  split. assumption. apply run_l. eassumption. assumption.
apply X0 in r. cD.  exists r. split. assumption.
apply ForallTI_forall.  intros. eapply ForallTD_forall in r1. cD.
exists r1.  split. assumption. apply run_r. eassumption. assumption.
Qed.

(* Union property for R in can_trf_rules... *)
Lemma can_trf_rules_Un sty rr rules ps (c : sty):
  (forall r, rr r -> can_trf_rules r rules ps c) ->
    can_trf_rules (rUnion rr) rules ps c.
Proof. unfold can_trf_rules. intros. destruct X0.
pose (X r r0 c' r1). cD. exists s. split. assumption.
apply ForallTI_forall.  intros. eapply ForallTD_forall in s1. cD.
exists s1. split. assumption.  eapply rUnI ; eassumption.  assumption. Qed.

Lemma can_trf_rules_req V R R' rules : req R R' -> forall ps c,
  @can_trf_rules V R rules ps c -> @can_trf_rules V R' rules ps c.
Proof. unfold can_trf_rules. unfold req. unfold rsub.
intros ss ps c fri c' rcc. cD.
apply ss0 in rcc. apply fri in rcc. cD.
exists rcc. split. assumption. apply ForallTI_forall. intros.
eapply ForallTD_forall in rcc1. cD.
exists rcc1. split. assumption. apply ss. eassumption.  assumption. Qed.

Lemma der_trf_rc_adm: forall (sty : Type) R rules,
  (forall ps c, rules ps c -> can_trf_rules_rc R (adm rules) ps c) ->
  forall concl, derrec rules (@emptyT sty) concl ->
    forall concl', R concl concl' -> derrec rules (@emptyT sty) concl'.
Proof. intros until 0. intro.
eapply (derrec_all_rect (Q := (fun concl => forall concl' : sty,
  R concl concl' -> derrec rules (emptyT (X:=sty)) concl'))).
intros. destruct H.
intros ps concl rpc dpss fall concl' Rcc.
apply X in rpc.  unfold can_trf_rules_rc in rpc.
apply rpc in Rcc. cD. clear rpc X.
(* here, weaker results by using derI or adm_derrec_trans
  instead of adm_derrec_trans *)
eapply adm_derrec_trans.  exact Rcc0.
apply dersrecI_forall. intros.
eapply ForallTD_forall in Rcc1. 2: eassumption.  cD.
inversion Rcc3. subst.
eapply ForallTD_forall in fall. 2: eassumption.
apply fall. assumption.
subst.  eapply dersrecD_forall in dpss. exact dpss. assumption. Qed.

Check der_trf_rc_adm.

Lemma der_trf_rc_derl: forall (sty : Type) R rules,
  (forall ps c, rules ps c -> can_trf_rules_rc R (derl rules) ps c) ->
  forall concl, derrec rules (@emptyT sty) concl ->
    forall concl', R concl concl' -> derrec rules (@emptyT sty) concl'.
Proof. intros sty R rules rtc. apply der_trf_rc_adm.
intros ps c rpc. apply rtc in rpc.
eapply can_trf_rules_rc_mono'.
apply rsub_derl_adm. apply rpc. Qed.

Check der_trf_rc_derl.

Lemma der_trf_rc: forall (sty : Type) R rules,
  (forall ps c, rules ps c -> can_trf_rules_rc R rules ps c) ->
  forall concl, derrec rules (@emptyT sty) concl ->
    forall concl', R concl concl' -> derrec rules (@emptyT sty) concl'.
Proof. intros sty R rules rtc. apply der_trf_rc_adm.
intros ps c rpc. apply rtc in rpc.
eapply can_trf_rules_rc_mono'.
apply rsub_adm. apply rpc. Qed.

Check der_trf_rc.

Lemma der_trf_derl: forall (sty : Type) R rules,
  (forall ps c, rules ps c -> can_trf_rules R (derl rules) ps c) ->
  forall concl, derrec rules (@emptyT sty) concl ->
    forall concl', R concl concl' -> derrec rules (@emptyT sty) concl'.
Proof. intros until 0. intro.
apply der_trf_rc_derl. intros. apply can_trf_rules_imp_rc.
exact (X ps c X0). Qed.

(* or can do the following *)
Definition der_trf_derl' sty R rules ct :=
  @der_trf_rc_derl sty R rules
    (fun ps c rpc => can_trf_rules_imp_rc (ct ps c rpc)).

Check der_trf_derl.

Lemma can_trf_derl X rules R ps (c : X): can_trf_rules R rules ps c ->
    can_trf_rules R (derl rules) ps c.
Proof. unfold can_trf_rules. intros.
apply X0 in X1. cD. exists X1. split. apply in_derl. assumption.
assumption. Qed.

Lemma der_trf: forall (sty : Type) R rules,
  (forall ps c, rules ps c -> can_trf_rules R rules ps c) ->
  forall concl, derrec rules (@emptyT sty) concl ->
    forall concl', R concl concl' -> derrec rules (@emptyT sty) concl'.
Proof. intros until 0. intro rct. apply der_trf_derl.
intros. apply can_trf_derl. apply rct. assumption. Qed.

Check der_trf.

Definition can_trf_rules_rtc (sty : Type) R rules (ps : list sty) (c : sty) :=
  forall c' : sty, R c c' ->
  (sigT (fun ps' : list sty => prod (rules ps' c')
    (ForallT (fun p' => sigT (fun p => prod (InT p ps)
      (clos_refl_transT_n1 R p p'))) ps'))).

Lemma can_trf_rules_imp_rtc sty R rules ps c:
  @can_trf_rules sty R rules ps c -> @can_trf_rules_rtc sty R rules ps c.
Proof. unfold can_trf_rules. unfold can_trf_rules_rtc.
intros. apply X in X0. cD. exists X0. split. assumption.
apply ForallTI_forall. intros.
eapply ForallTD_forall in X2. 2: eassumption. cD.
exists X2. split. assumption.
eapply rtn1T_trans. eassumption. apply rtn1T_refl. Qed.

Lemma can_trf_rules_rtc_mono' sty R rulesa rulesb ps c:
  rsub rulesa rulesb -> @can_trf_rules_rtc sty R rulesa ps c ->
  @can_trf_rules_rtc sty R rulesb ps c.
Proof. unfold rsub. unfold can_trf_rules_rtc. intros.
apply X0 in X1. clear X0. cD. exists X1. split. firstorder.
exact X2. Qed.

Definition can_trf_rules_rtc_mono sty R rulesa rulesb r :=
  rsubI _ _ (@can_trf_rules_rtc_mono' sty R rulesa rulesb r).

Lemma trf_rules_rtc: forall (sty : Type) R rules (c : sty),
  (forall ps' c', clos_refl_transT_n1 R c c' ->
    rules ps' c' -> can_trf_rules_rtc R rules ps' c') ->
  forall ps, rules ps c -> can_trf_rules (clos_refl_transT_n1 R) rules ps c.
Proof. intros. unfold can_trf_rules. intro. intro rtc.
induction rtc. exists ps. split. assumption.
apply ForallTI_forall. intros. exists x. split. assumption.
apply rtn1T_refl.
cD. eapply X in rtc.
unfold can_trf_rules_rtc in rtc. apply rtc in r. clear rtc. cD.
eexists. split. eassumption.
apply ForallTI_forall. intros.
eapply ForallTD_forall in r1. 2: eassumption. cD.
eapply ForallTD_forall in IHrtc1. 2: eassumption. cD.
eexists. split. eassumption.
(* now need transitivity of clos_refl_transT_n1 *)
apply clos_rtn1_rtT in r3.
apply clos_rtn1_rtT in IHrtc3.
apply clos_rt_rtn1T.
eapply rtT_trans ; eassumption. assumption. Qed.

Check trf_rules_rtc.

(* try to adapt proof of trf_rules_derl to also do _rtc
Lemma trf_rules_rtc_derl: forall (sty : Type) R (rules : rlsT sty),
  (forall ps c, rules ps c -> can_trf_rules_rtc R (derl rules) ps c) ->
  (forall ps c, derl rules ps c ->
    can_trf_rules (clos_refl_transT_n1 R) (derl rules) ps c).
NOT ACTUALLY SURE THIS IS VALID
Check trf_rules_rtc_derl.
*)

Lemma trf_rules_derl: forall (sty : Type) R (rules : rlsT sty),
  (forall ps c, rules ps c -> can_trf_rules R (derl rules) ps c) ->
  (forall ps c, derl rules ps c -> can_trf_rules R (derl rules) ps c).
Proof. intros until 0.  intro rctd.
eapply derl_all_rect.
{ intro. unfold can_trf_rules. intros. exists [c'].
split. apply asmI. apply ForallTI_forall. intros.
exists p. split. apply InT_eq. inversion X0 ; subst. assumption.
eapply InT_nilE in X1. eassumption. }

{ intros until 0. intros rpc drsl fcd qcp.
apply rctd in rpc.  subst. clear rctd.
unfold can_trf_rules. intros c' Rcc.
unfold can_trf_rules in rpc. apply rpc in Rcc. cD. clear rpc.

assert {cqss : list sty &
  (dersl rules cqss Rcc * ForallT (fun p' : sty =>
    {p : sty & InT p (concat pss) * R p p'}) cqss)%type}.

{ clear Rcc0. induction Rcc1.
exists []. simpl. split. apply dtNil. apply ForallT_nil.
cD.
eapply Forall2T_ex_r in fcd. 2: eassumption. destruct fcd.
unfold can_trf_rules in c. eapply c in p1. clear c.
destruct p1. cD.
eexists. split.  eapply dtCons ; eassumption.
apply ForallTI_forall. simpl. intros.
apply InT_appE in X. sD.
eapply ForallTD_forall in p2. 2: eassumption. cD.
eexists. split. 2: eassumption.
eapply InT_concat ; eassumption.
eapply ForallTD_forall in IHRcc2. 2: eassumption. assumption. }

{ cD. eexists. split. 2: eassumption.
eapply derl_trans ; eassumption.  } } Qed.

Check trf_rules_derl.

Lemma der_trf_rtc: forall (sty : Type) R rules,
  (forall ps c, rules ps c -> can_trf_rules_rtc R rules ps c) ->
  forall concl, derrec rules (@emptyT sty) concl ->
    forall concl', clos_refl_transT_n1 R concl concl' ->
    derrec rules (@emptyT sty) concl'.
Proof. intros until 1.  apply der_trf.
intros until 0. apply trf_rules_rtc.
intros until 1. apply X. Qed.

Check der_trf_rtc.

(* how to do this - maybe need to try _rtc variant of trf_rules_derl
Lemma der_trf_rtc_derl: forall (sty : Type) R rules,
  (forall ps c, rules ps c -> can_trf_rules_rtc R (derl rules) ps c) ->
  forall concl, derrec rules (@emptyT sty) concl ->
    forall concl', clos_refl_transT_n1 R concl concl' ->
      derrec rules (@emptyT sty) concl'.
*)

Lemma der_trf_ht: forall (sty : Type) R rules,
  (forall ps c, rules ps c -> can_trf_rules R rules ps c) ->
  forall concl (D : derrec rules (@emptyT sty) concl),
    forall concl', R concl concl' ->
    sigT (fun D' : derrec rules (@emptyT sty) concl' =>
      derrec_height D' <= derrec_height D).
Proof. intros until 0. intros ctr.
eapply (derrec_rect_mut_all (Q := (fun concl D => forall concl' : sty,
  R concl concl' -> {D' : derrec rules (emptyT (X:=sty)) concl' &
  derrec_height D' <= derrec_height D}))).
intros c p. destruct p.
intros ps concl rpc dpss apd concl' Rcc.
pose (ctr ps concl rpc) as ctrr.
unfold can_trf_rules in ctrr.
apply ctrr in Rcc. cD. clear ctrr ctr.

assert { Ds' : dersrec rules (emptyT (X:=sty)) Rcc &
  dersrec_height Ds' <= dersrec_height dpss }.
assert (forall p, InT p Rcc -> { D' : derrec rules (emptyT (X:=sty)) p &
  derrec_height D' <= dersrec_height dpss }).

{ intros.
eapply ForallTD_forall in Rcc1.  2: eassumption.  cD.
eapply allPderD_in in apd. 2: eassumption. destruct apd. (* cD doesn't work *)
apply s in Rcc3. cD. clear s.
eexists. (* shelves a goal *)
eapply le_dersrec_height. eassumption. eassumption. }

{ clear apd concl' Rcc0 Rcc1 R rpc.
(* this may be a useful lemma *)
induction Rcc. eexists. Unshelve. 3: apply dlNil. simpl. apply le_0_n.
require IHRcc. intros. apply X. apply InT_cons. assumption. cD.
pose (X a (InT_eq a Rcc)). cD.
exists (dlCons s IHRcc). simpl. apply Nat.max_lub ; assumption. }

cD.  exists (derI concl' Rcc0 X). simpl.  apply le_n_S. assumption. Qed.

Check der_trf_ht.

(* this proof gets quite unmanageable, need to use @dersrecI_forall' instead,
  which is a much simpler proof object
Goal forall X rules prems seq seqs f,
  @dersrecI_forall X rules prems (seq :: seqs) f =
  @dlCons X rules prems seq seqs (f seq (InT_eq seq seqs))
    (@dersrecI_forall X rules prems seqs (fun c i => f c (InT_cons seq i))).
Proof. intros.
unfold dersrecI_forall.  unfold dersrec_forall.
unfold iffT_D2.  unfold prod_rect.  unfold iffT_trans.
(etc, can do lots of unfolds)
*)

Lemma dlCons_inj: forall X rules prems seq seqs d ds d' ds',
  @dlCons X rules prems seq seqs d ds = dlCons d' ds' ->
  prod (d = d') (ds = ds').
(* shorter proof follows
Proof. intros.  injection H. intros. inversion_sigma.
unfold eq_rect in H3.  unfold eq_rect in H4.
dependent destruction H2.  dependent destruction H1.
split ; assumption. Defined.
*)
Proof. intros. dependent destruction H. tauto. Defined.

Check dlCons_inj.

(* formerly managed to prove these
Lemma dersrecI_forall_alt_cons: forall X rules prems seq seqs f,
  @dersrecI_forall X rules prems (seq :: seqs) f =
  @dlCons X rules prems seq seqs (f seq (InT_eq seq seqs))
    (@dersrecI_forall X rules prems seqs (fun c i => f c (InT_cons seq i))).

Lemma dersrecI_forall_alt_nil: forall X rules prems f,
  @dersrecI_forall X rules prems [] f = @dlNil X rules prems.

Lemma dlc_drsf: forall X rules prems seq seqs d ds f,
  @dlCons X rules prems seq seqs d ds =
    @dersrecI_forall X rules prems (seq :: seqs) f ->
  prod (d = f seq (InT_eq seq seqs))
  (ds = @dersrecI_forall X rules prems seqs (fun c i => f c (InT_cons seq i))).
*)

Lemma existT_inj: forall A P (x : A) px px',
  existT P x px = existT P x px' -> (px = px').
Proof. intros. dependent destruction H. tauto. Defined.

Lemma existT_inj': forall A P (x x' : A) px px',
  existT P x px = existT P x' px' -> (x = x').
Proof. intros. dependent destruction H. tauto. Defined.

(* Print Assumptions existT_inj.
Fetching opaque proofs from disk for Coq.Logic.EqdepFacts
Axioms:
Eqdep.Eq_rect_eq.eq_rect_eq : forall (U : Type) (p : U)
                                (Q : U -> Type) (x : Q p)
                                (h : p = p), x = eq_rect p Q x p h
JMeq_eq : forall (A : Type) (x y : A), x ~= y -> x = y
*)

(* soundness proofs *)

(* according to some semantics, if each rule preserves validity
  then a derivation preserves validity *)
(* note - proof doesn't work using derl instead of dercl *)
Lemma dercl_soundness W rules valid
  (rules_sound : forall ps c, rules ps c -> ForallT valid ps -> valid c) :
  forall ps (c : W), dercl rules ps c -> ForallT valid ps -> valid c.
Proof.
apply (@dercl_all_rect _ _ (fun ps c => ForallT valid ps -> valid c)).
- intros p fvps. exact (ForallT_singleD fvps).
- intros * rpsc dcsl fvv qseq fvqs. subst.
eapply rules_sound. exact rpsc.
clear rpsc dcsl. (* otherwise spoils induction *)
induction fvv. apply ForallT_nil.
simpl in fvqs.  apply ForallT_appendD in fvqs. destruct fvqs.
exact (ForallT_cons y (r f) (IHfvv f0)).
Qed.

Lemma derrec_soundness W rules prems valid
  (rules_sound : forall ps (c : W), rules ps c -> ForallT valid ps -> valid c) :
  (forall p, prems p -> valid p) -> forall c, derrec rules prems c -> valid c.
Proof. intro pv.  apply (derrec_all_rect pv).
intros * rps drs. exact (rules_sound ps concl rps). Qed.

Unset Universe Polymorphism.

(* useful predicates for proving admissibility *)
(* extend the idea of admissibility to relations *)
Inductive radm X rules p c : Type :=
  | radmI : (derrec rules (@emptyT X) p -> derrec rules (@emptyT X) c) ->
    radm X rules p c.

Definition radmD X rules p c (r : @radm X rules p c) :=
  match r with | radmI d => d end.

(* admissibility for a relation *)
Inductive rel_adm X rules R : Type :=
  | rel_admI : (forall p c, R p c -> @radm X rules p c) -> rel_adm X rules R.

Definition rel_admD X rules R (r : @rel_adm X rules R) :=
  match r with | rel_admI _ r0 => r0 end.

(* similar to rel_adm, but useful for gen_step_lemT *)
Definition can_rel sty fty rules (R : fty -> sty -> sty -> Type)
  (fml : fty) (seq : sty) :=
  forall seq', R fml seq seq' -> derrec rules emptyT seq'.

Lemma rel_adm_rtc X rules R :
  @rel_adm X rules R -> rel_adm rules (clos_refl_transT R).
Proof. repeat split.  destruct X0.
induction X1.  exact (radmD (r x y r0)).  tauto. tauto. Qed.

(* lemma relating rel_adm to can_rel *)
Lemma crd_ra sty fty rules (R : fty -> sty -> sty -> Type) fml:
  iffT (rel_adm rules (R fml))
  (forall seq, derrec rules emptyT seq -> can_rel rules R fml seq).
Proof. split.
- intros ra seq ds seq' rf.
inversion ra. specialize (X seq seq' rf).
destruct X. exact (d ds).
- intro dc. repeat split. intro dp.
exact (dc p dp c X). Qed.


(* $Id: Basics.v,v 1.12 2003/03/11 13:35:50 lcf Exp $ *)

Require Export Omega.
Require Export Even.
Require Export Max.
Require Export Min.

(* Tex_Prose
\chapter{Basics}
This is random stuff that should be in the Coq basic library.
*)

(* Begin_Tex_Verb *)
Lemma lt_le_dec:(n,m:nat){lt n m}+{le m n}.
(* End_Tex_Verb *)
Intros.
Case (le_lt_dec m n); Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma lt_z_two: (lt O (2)).
(* End_Tex_Verb *)
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma le_pred : (n,m:nat)(le n m)->(le (pred n)(pred m)).
(* End_Tex_Verb *)
Proof.
Induction n. Simpl. Auto with arith.
Intros n0 Hn0. Induction m. Simpl. Intro H. Inversion H.
Intros n1 H H0. Simpl. Auto with arith.
Qed.

(* Begin_Tex_Verb *)
Lemma lt_mult_right :
  (x,y,z:nat) (lt x y) -> (lt (0) z) -> (lt (mult x z) (mult y z)).
(* End_Tex_Verb *)
Intros x y z H H0.
Induction z.
Elim (lt_n_n ? H0).
Rewrite mult_sym.
Replace (mult y (S z)) with (mult (S z) y); Auto with arith.
Qed.

(* Begin_Tex_Verb *)
Lemma le_mult_right : (x,y,z:nat)(le x y)->(le (mult x z) (mult y z)).
(* End_Tex_Verb *)
Intros x y z H.
Rewrite mult_sym. Rewrite (mult_sym y).
Auto with arith.
Qed.

(* Tex_Prose
Factorial function. Does not exist in Arith.
Needed for special operations on polynomials.
*)
(* Begin_Tex_Verb *)
Fixpoint fac [n:nat] :nat :=
	Cases n of
	   O 		=> (S O)
	   | (S m)	=> (mult (S m)(fac m))
	end.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma nat_fac_gtzero:(n:nat)(lt O (fac n)).
(* End_Tex_Verb *)
Proof.
Induction n; Simpl; Auto with arith.
Qed.

(* needed for computational behavior of "Inversion" tactic *)
Transparent sym_eq.
Transparent f_equal.

Syntactic Definition Pair := (pair ??).
Syntactic Definition Proj1 := (proj1 ??).
Syntactic Definition Proj2 := (proj2 ??).

(* Following only needed in finite, but tha's now obsolete

* Begin_Tex_Verb *
Lemma deMorgan_or_and: (A,B,X:Prop)((A\/B)->X) -> (A->X)/\(B->X).
* End_Tex_Verb *
Tauto.
Qed.

* Begin_Tex_Verb *
Lemma deMorgan_and_or: (A,B,X:Prop)(A->X)/\(B->X) -> (A\/B->X).
* End_Tex_Verb *
Tauto.
Qed.

* Begin_Tex_Verb *
Lemma deMorgan_ex_all:
  (A:Set)(P:A->Prop)(X:Prop)((Ex P)->X) -> (a:A)(P a)->X.
* End_Tex_Verb *
Intros. Apply H; Exists a; Assumption.
Qed.

* Begin_Tex_Verb *
Lemma deMorgan_all_ex:
  (A:Set)(P:A->Prop)(X:Prop)((a:A)(P a)->X) -> (Ex P)->X.
* End_Tex_Verb *
Intros. Elim H0; Assumption.
Qed.

Implicit Arguments Off.

* Tex_Prose
Three lemmas for proving properties about definitions made with case
distinction to a sumbool, i.e. \verb!{A} + {B}!.
*
* Begin_Tex_Verb *
Lemma sumbool_rec_or : (A,B:Prop)(S:Set)(l,r:S)(s:{A}+{B})
                  (sumbool_rec A B [_:{A}+{B}]S [x:A]l [x:B]r s) = l \/
                  (sumbool_rec A B [_:{A}+{B}]S [x:A]l [x:B]r s) = r.
* End_Tex_Verb *
Intros. Elim s.
Intros. Left. Reflexivity.
Intros. Right. Reflexivity.
Qed.
*)
(* Begin_Tex_Verb *)
Lemma not_r_sumbool_rec : (A,B:Prop)(S:Set)(l,r:S)~B->(H:{A}+{B})
                  (sumbool_rec A B [_:{A}+{B}]S [x:A]l [x:B]r H) = l.
(* End_Tex_Verb *)
Intros. Elim H0.
Intros. Reflexivity.
Intro. Elim H. Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma not_l_sumbool_rec : (A,B:Prop)(S:Set)(l,r:S)~A->(H:{A}+{B})
                          (sumbool_rec A B [_:{A}+{B}]S [x:A]l [x:B]r H) = r.
(* End_Tex_Verb *)
Intros. Elim H0.
Intro. Elim H. Assumption.
Intros. Reflexivity.
Qed.

Implicit Arguments On.

(* Tex_Prose
\section{Some results about Z}
*)

(* Tex_Prose
We consider the injection \verb!inject_nat! from \verb!nat! to !Z! as a
coercion.
*)
Coercion inject_nat: nat>->Z.

(* Begin_Tex_Verb *)
Lemma POS_anti_convert :
  (n:nat)`(S n) = (POS (anti_convert n))`.
(* End_Tex_Verb *)
Induction n.
Simpl.
Reflexivity.
Intros n0 H.
Simpl.
Reflexivity.
Qed.

(* Begin_Tex_Verb *)
Lemma NEG_anti_convert :
  (n:nat)`-(S n) = (NEG (anti_convert n))`.
(* End_Tex_Verb *)
Induction n.
Simpl.
Reflexivity.
Intros n0 H.
Simpl.
Reflexivity.
Qed.

(* Begin_Tex_Verb *)
Lemma lt_O_positive_to_nat :
  (p:positive)(m:nat)(lt O m)->(lt O (positive_to_nat p m)).
(* End_Tex_Verb *)
Intro p.
Elim p.
Intros p0 H m H0.
Simpl.
Auto with arith.
Intros p0 H m H0.
Simpl.
Apply H.
Auto with arith.
Intros m H.
Simpl.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma anti_convert_pred_convert :
  (p:positive)(p = (anti_convert (pred (convert p)))).
(* End_Tex_Verb *)
Intro p.
Pattern 1 p.
Rewrite <- bij3.
Cut (EX n:nat | (convert p) = (S n)).

Intro H.
Elim H; Intros x H0.
Rewrite H0.
Elim x.

Simpl.
Reflexivity.

Intros n H1.
Simpl.
Rewrite sub_add_one.
Reflexivity.

Exists (pred (convert p)).
Apply S_pred with O.
Unfold convert.
Apply lt_O_positive_to_nat.
Auto with arith.
Qed.

(* Begin_Tex_Verb *)
Lemma p_is_some_anti_convert : (p:positive)(EX n:nat | p = (anti_convert n)).
(* End_Tex_Verb *)
Intro p.
Exists (pred (convert p)).
Apply anti_convert_pred_convert.
Qed.

(* Begin_Tex_Verb *)
Lemma convert_is_POS :
              (p:positive)`(convert p) = (POS p)`.
(* End_Tex_Verb *)
Intro p.
Elim (p_is_some_anti_convert p).
Intros x H.
Rewrite H.
Rewrite bij1.
Apply POS_anti_convert.
Qed.

(* Begin_Tex_Verb *)
Lemma min_convert_is_NEG :
              (p:positive)`-(convert p) = (NEG p)`.
(* End_Tex_Verb *)
Intro p.
Elim (p_is_some_anti_convert p).
Intros x H.
Rewrite H.
Rewrite bij1.
Apply NEG_anti_convert.
Qed.

(* Begin_Tex_Verb *)
Lemma Z_exh : (z:Z)(EX n:nat | z=n) \/ (EX n:nat | z=`-n`).
(* End_Tex_Verb *)
Intro z.
Elim z.

Left.
Exists O.
Auto.

Intro p.
Left.
Exists (convert p).
Rewrite convert_is_POS.
Reflexivity.

Intro p.
Right.
Exists (convert p).
Rewrite min_convert_is_NEG.
Reflexivity.
Qed.

(* Begin_Tex_Verb *)
Lemma nats_Z_ind :
                 (P:Z->Prop)((n:nat)(P n)) -> ((n:nat)(P `-n`)) -> (z:Z)(P z).
(* End_Tex_Verb *)
Intros P H H0 z.
Elim (Z_exh z); Intro H1.

Elim H1; Intros x H2.
Rewrite H2.
Apply H.

Elim H1; Intros x H2.
Rewrite H2.
Apply H0.
Qed.

(* Begin_Tex_Verb *)
Lemma pred_succ_Z_ind : (P:Z->Prop)(P `0`) ->
                                   ((n:Z)(P n)->(P `n+1`)) ->
                                   ((n:Z)(P n)->(P `n-1`)) ->
                                   (z:Z)(P z).
(* End_Tex_Verb *)
Intros P H H0 H1 z.
Apply nats_Z_ind.

Intro n.
Elim n.

Exact H.

Intros n0 H2.
Replace ((S n0)::Z) with `n0+1`.

Apply H0.
Assumption.

Rewrite inj_S.
Reflexivity.

Intro n.
Elim n.

Exact H.

Intros n0 H2.
Replace `-(S n0)` with `-n0-1`.

Apply H1.
Assumption.

Rewrite inj_S.
Unfold Zs.
Rewrite Zopp_Zplus.
Reflexivity.
Qed.

(* Begin_Tex_Verb *)
Lemma Zmult_minus_distr_r : (n,m,p:Z)`p*(n-m) = p*n-p*m`.
(* End_Tex_Verb *)
Intros n m p.
Rewrite Zmult_sym.
Rewrite Zmult_minus_distr.
Rewrite Zmult_sym.
Pattern `m*p`.
Rewrite Zmult_sym.
Reflexivity.
Qed.

(* Begin_Tex_Verb *)
Lemma Zodd_Zeven_min1 : (x:Z)(Zodd x) -> (Zeven `x-1`).
(* End_Tex_Verb *)
Intro x.
Elim x.

Simpl.
Auto.
Induction p.

Simpl.
Auto.

Intros p0 H H0.
Simpl in H0.
Tauto.

Simpl; Auto.

Induction p.

Simpl; Auto.

Simpl; Auto.

Auto.
Qed.

Implicit Arguments On.

(* Begin_Tex_Verb *)
Definition caseZ_diff := [A:Set][z:Z][f:nat->nat->A]
  Cases z of
    ZERO => (f O O)
  | (POS m) => (f (convert m) O)
  | (NEG m) => (f O (convert m))
  end.
(* End_Tex_Verb *)
Implicit Arguments Off.

(* Begin_Tex_Verb *)
Lemma caseZ_diff_O : (A:Set)(f:nat->nat->A)(caseZ_diff `0` f) = (f O O).
(* End_Tex_Verb *)
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma caseZ_diff_Pos : (A:Set)(f:nat->nat->A)(n:nat)
                       (caseZ_diff `n` f) = (f n O).
(* End_Tex_Verb *)
Intros A f n.
Elim n.

Reflexivity.

Intros n0 H.
Simpl.
Rewrite bij1.
Reflexivity.
Qed.

(* Begin_Tex_Verb *)
Lemma caseZ_diff_Neg : (A:Set)(f:nat->nat->A)(n:nat)
                       (caseZ_diff `-n` f) = (f O n).
(* End_Tex_Verb *)
Intros A f n.
Elim n.

Reflexivity.

Intros n0 H.
Simpl.
Rewrite bij1.
Reflexivity.
Qed.

(* Begin_Tex_Verb *)
Lemma proper_caseZ_diff : (A:Set)(f:nat->nat->A)
              ((m,n,p,q:nat)(plus m q) = (plus n p) -> (f m n) = (f p q)) ->
              (m,n:nat)(caseZ_diff `m-n` f) = (f m n).
(* End_Tex_Verb *)
Intros A F H m n.
Pattern m n.
Apply nat_double_ind.

Intro n0.
Replace `O-n0` with `-n0`.

Rewrite caseZ_diff_Neg.
Reflexivity.

Simpl.
Reflexivity.

Intro n0.
Replace `(S n0)-O` with (inject_nat `(S n0)`).

Rewrite caseZ_diff_Pos.
Reflexivity.

Simpl.
Reflexivity.

Intros n0 m0 H0.
Rewrite H with (S n0) (S m0) n0 m0.

Rewrite <- H0.
Replace `(S n0)-(S m0)` with `n0-m0`.

Reflexivity.

Repeat Rewrite inj_S.
Auto with zarith.

Auto with zarith.
Qed.

(* Begin_Tex_Verb *)
Lemma diff_Z_ind : (P:Z->Prop)((m,n:nat)(P `m-n`)) -> ((z:Z)(P z)).
(* End_Tex_Verb *)
Intros P H z.
Apply nats_Z_ind.

Intro n.
Replace (inject_nat `n`) with `n-O`.

Apply H.

Simpl.
Auto with zarith.

Intro n.
Replace `-n` with `O-n`.

Apply H.

Simpl.
Reflexivity.
Qed.

(* Begin_Tex_Verb *)
Lemma Zlt_reg_mult_l: (x,y,z:Z)`x>0`->`y<z`->`x*y < x*z`.
(* End_Tex_Verb *)
Proof.
 Intros x y z H H0.
 Case (SUPERIEUR_POS x `0`).

 Unfold Zgt in H.
 Assumption.

 Intros x0 H1.
 Cut (`x = (POS x0)`).

 Intro H2.
 Rewrite H2.
 Unfold Zlt in H0.
 Unfold Zlt.
 Cut ( (Zcompare `(POS x0)*y` `(POS x0)*z`) = (Zcompare y z)).

 Intro H3.
 Exact (trans_eq relation `(POS x0)*y ?= (POS x0)*z` `y ?= z`  INFERIEUR H3 H0).

 Apply Zcompare_Zmult_compatible.

 Cut (`x = x + (Zopp 0)`).
 Intro H2.
 Exact ( trans_eq Z x `x+(Zopp 0)` (POS x0) H2 H1).

 Simpl.
 Apply (sym_eq Z).
 Exact (Zero_right x).
Qed.

(* Begin_Tex_Verb *)
Lemma Zlt_opp: (x,y:Z)`x<y`->`(-x)>(-y)`.
(* End_Tex_Verb *)
Proof.
 Intros x y H.
 Red.
 Apply sym_eq.
 Cut(SUPERIEUR =(Zcompare y x)).

 Intro H0.
 Cut ((Zcompare y x)=(Zcompare (Zopp x) (Zopp y))).

 Intro H1.
 Exact (trans_eq relation SUPERIEUR (Zcompare y x) (Zcompare (Zopp x) (Zopp y)) H0 H1).

 Exact (Zcompare_Zopp y x).

 Apply sym_eq.
 Exact (Zlt_gt x y H).
Qed.

(* Begin_Tex_Verb *)
Lemma Zlt_conv_mult_l :(x,y,z:Z)`x<0`->`y<z`->`x*y>x*z`.
(* End_Tex_Verb *)
Proof.
 Intros x y z H H0.
 Cut (`(-x)>0`).

 Intro H1.
 Cut (`(-x)*y<(-x)*z`).

 Intro H2.
 Cut (`(-((-x)*y))>(-((-x)*z))`).

 Intro H3.
 Cut (`(-(-(x*y)))>(-(-(x*z)))`).

 Intro H4.
 Cut (`(-(-(x*y)))=x*y`).

 Intro H5.
 Rewrite H5 in H4.
 Cut (`(-(-(x*z)))=x*z`).

 Intro H6.
 Rewrite H6 in H4.
 Assumption.

 Exact (Zopp_Zopp (`x*z`)).

 Exact (Zopp_Zopp (`x*y`)).

 Cut (`(-((-x)*y))=(-(-(x*y)))`).
 Intro H4.
 Rewrite H4 in H3.
 Cut (`(-((-x)*z))=(-(-(x*z)))`).

 Intro H5.
 Rewrite H5 in H3.
 Assumption.

 Cut (`(-x)*z=(-(x*z))`).
 Intro H5.
 Exact (f_equal Z Z Zopp `(-x)*z` `(-(x*z))` H5).

 Exact (Zopp_Zmult x z).

 Cut (`(-x)*y=(-(x*y))`).
 Intro H4.

 Exact (f_equal Z Z Zopp `(-x)*y` `(-(x*y))` H4).

 Exact (Zopp_Zmult x y).

 Exact (Zlt_opp `(-x)*y` `(-x)*z` H2).

 Exact (Zlt_reg_mult_l `(-x)` y z H1 H0).

 Exact (Zlt_opp x `0` H).
Qed.

(* Begin_Tex_Verb *)
Lemma Zgt_not_eq :(x,y:Z)`x>y`->(~(x=y)).
(* End_Tex_Verb *)
Proof.
 Intros x y H.
 Cut (`y<x`).

 Intro H0.
 Cut (`y<>x`).

 Intro H1.
 Red.
 Intro H2.
 Cut (`y=x`).

 Intro H3.
 Apply H1.
 Assumption.

 Exact (sym_eq Z x y H2).

 Exact (Zlt_not_eq y x H0).

 Exact (Zgt_lt x y H).
Qed.

(* Begin_Tex_Verb *)
Lemma Zmult_absorb : (x,y,z: Z)~(x=ZERO)->(Zmult x y)=(Zmult x z)->y=z.
(* End_Tex_Verb *)
Proof.
 Intros x y z H H0.
 Case (dec_eq y z).

 Intro H1.
 Assumption.

 Intro H1.
 Case (not_Zeq y z).

 Assumption.

 Intro H2.
 Case (not_Zeq x `0`).

 Assumption.

 Intro H3.
 ElimType False.
 Cut (`x*y>x*z`).

 Intro H4.
 Cut (`x*y <> x*z`).

 Intro H5.
 Apply H5.
 Assumption.

 Exact (Zgt_not_eq `x*y` `x*z` H4 ).

 Exact (Zlt_conv_mult_l x y z H3 H2).

 Intro H3.
 ElimType False.
 Cut (`x*y<x*z`).

 Intro H4.
 Cut(`x*y<>x*z`).

 Intro H5.
 Apply H5.
 Assumption.

 Exact (Zlt_not_eq `x*y` `x*z` H4).

 Apply Zlt_reg_mult_l.

 Exact (Zlt_gt `0` x H3).

 Assumption.

 Intro H2.
 Apply False_ind.
 Cut(`x*z<x*y`).

 Intro H3.
 Cut(`x*z<>x*y`).

 Intro H4.
 Apply H4.
 Apply (sym_eq Z).
 Assumption.

 Exact (Zlt_not_eq `x*z` `x*y` H3).

 Apply False_ind.
 Case (not_Zeq x `0`).

 Assumption.

 Intro H3.
 Cut(`x*z>x*y`).

 Intro H4.
 Cut (`x*z<>x*y`).

 Intro H5.
 Apply H5.
 Apply (sym_eq Z).
 Assumption.

 Exact (Zgt_not_eq `x*z` `x*y` H4).

 Exact (Zlt_conv_mult_l x z y H3 H2).

 Intro H3.
 Cut(`x*z<x*y`).

 Intro H4.
 Cut (`x*z<>x*y`).

 Intro H5.
 Apply H5.
 Apply (sym_eq Z).
 Assumption.

 Exact (Zlt_not_eq `x*z` `x*y` H4).

 Apply Zlt_reg_mult_l.

 Exact (Zlt_gt `0` x H3).
 Auto.
Qed.


From Hammer Require Import Hammer.

Require Import Setoid Morphisms Wf_nat Omega.
From hahn Require Import HahnBase HahnList HahnSets HahnRelationsBasic HahnEquational HahnRewrite.

Set Implicit Arguments.

Definition fsupp A (r: relation A) :=
forall y, exists findom, forall x (REL: r x y), In x findom.

Hint Unfold fsupp ltof : unfolderDb.

Add Parametric Morphism A : (@fsupp A) with signature
inclusion --> Coq.Program.Basics.impl as fsupp_mori.
Proof. hammer_hook "HahnWf" "HahnWf.fsupp".
unfolder; ins; desf; specialize (H0 y0); desf; eauto.
Qed.

Add Parametric Morphism A : (@fsupp A) with signature
same_relation ==> iff as fsupp_more.
Proof.
unfold same_relation; split; ins; desf; eapply fsupp_mori; eauto.
Qed.

Section well_founded.

Variable A : Type.
Implicit Types r : relation A.

Lemma wf_impl_no_inf_seq r (WF: well_founded r) x :
~ exists a, a 0 = x /\ forall n, r (a (S n)) (a n).
Proof. hammer_hook "HahnWf" "HahnWf.wf_impl_no_inf_seq".
specialize (WF x); induction WF.
intro CONTRA; desf.
specialize (CONTRA0 0)  as C.
apply H0 in C; destruct C.
exists (fun n => a (S n)); ins.
Qed.

Lemma wf_impl_min_elt r (WF: well_founded r) B (NONEMPTY: ~ B ≡₁ ∅) :
exists b, B b /\ forall b', B b' -> ~ r b' b.
Proof. hammer_hook "HahnWf" "HahnWf.wf_impl_min_elt".
apply set_nonemptyE in NONEMPTY; desc.
apply NNPP; intro C.
induction x using (well_founded_ind WF).
destruct C; eexists; split; try edone; red; ins; eauto.
Qed.

Lemma wf_mon r1 r2 (INCL: r1 ⊆ r2) (WF: well_founded r2) : well_founded r1.
Proof. hammer_hook "HahnWf" "HahnWf.wf_mon".
unfold well_founded in *; ins;
induction (WF a); econstructor; eauto.
Qed.

Lemma wf_imm_succ r (WF: well_founded r) a b (REL: r a b) :
exists c, immediate r a c.
Proof. hammer_hook "HahnWf" "HahnWf.wf_imm_succ".
revert a REL; induction b using (well_founded_ind WF); ins.
tertium_non_datur (immediate r a b) as [?|NIM]; eauto.
Qed.

Lemma wf_restr r (WF: well_founded r) cond : well_founded (restr_rel cond r).
Proof. hammer_hook "HahnWf" "HahnWf.wf_restr".
red; ins; induction a using (well_founded_induction WF).
constructor; ins; unfolder in H0; desf; eauto.
Qed.

End well_founded.

Hint Resolve wf_restr : hahn.

Section finite_support.

Variable A : Type.
Implicit Types r : relation A.

Theorem fsupp_well_founded r (FS: fsupp r)
(IRR: irreflexive r) (TRANS: transitive r) :
well_founded r.
Proof. hammer_hook "HahnWf" "HahnWf.fsupp_well_founded".
intros a; specialize (FS a); desf; revert a FS.
induction findom
using (well_founded_induction (well_founded_ltof _ (@length _))).
unfold ltof in *.
constructor; intros y Rya.
assert (IN := FS _ Rya).
apply In_split in IN; desf.
eapply H with (y0 := l1 ++ l2); ins.
by rewrite !app_length; simpl; omega.
assert (Rxa: r x a) by eauto.
generalize (FS _ Rxa); rewrite !in_app_iff; ins; desf; eauto.
exfalso; eauto.
Qed.

Lemma fsupp_imm_t r (FS: fsupp r)
(IRR: irreflexive r) (TRANS: transitive r) :
r ≡ (immediate r)⁺.
Proof. hammer_hook "HahnWf" "HahnWf.fsupp_imm_t".
split; [|by eauto with hahn].
red; ins.
specialize (FS y); desf.
assert (M: forall n, r x n -> r n y -> In n findom) by eauto.
clear FS; revert x y H M.
induction findom
using (well_founded_induction (well_founded_ltof _ (@length _))).
unfold ltof in *.
ins.
tertium_non_datur (immediate r x y) as [|NIMM]; vauto.
assert (N := M _ NIMM NIMM0); apply In_split in N; desf.
apply t_trans with (y := n); eapply H with (y := l1 ++ l2); ins.
1,3: by rewrite !app_length; simpl; omega.
- apply M in H1; eauto; rewrite !in_app_iff in *; ins; desf; eauto.
exfalso; eauto.
- apply M in H2; eauto; rewrite !in_app_iff in *; ins; desf; eauto.
exfalso; eauto.
Qed.

Lemma fsupp_mon r r' (SUBS: r ⊆ r') (FS: fsupp r') : fsupp r.
Proof. hammer_hook "HahnWf" "HahnWf.fsupp_mon".
unfolder in *; ins; specialize (FS y); des; eauto.
Qed.

Lemma fsupp_empty : fsupp (A:=A) ∅₂.
Proof. hammer_hook "HahnWf" "HahnWf.fsupp_empty".
exists nil; ins.
Qed.

Lemma fsupp_eqv (d : A -> Prop) : fsupp ⦗d⦘.
Proof. hammer_hook "HahnWf" "HahnWf.fsupp_eqv".
unfolder; ins; exists (y :: nil); ins; desf; eauto.
Qed.

Lemma fsupp_cross (s s': A -> Prop) (F: set_finite s) : fsupp (s × s').
Proof. hammer_hook "HahnWf" "HahnWf.fsupp_cross".
unfolder in *; ins; desf; eexists; ins; desf; eauto.
Qed.

Lemma fsupp_union r1 r2 : fsupp (r1 ∪ r2) <-> fsupp r1 /\ fsupp r2.
Proof. hammer_hook "HahnWf" "HahnWf.fsupp_union".
unfolder in *; intuition;
repeat match goal with [ H : _, y : A |- _ ] => specialize (H y) end;
desf; first [exists (findom ++ findom0) | exists findom];
ins; desf; eauto using in_or_app.
Qed.

Lemma fsupp_unionI r1 r2 (FS1: fsupp r1) (FS2: fsupp r2) : fsupp (r1 ∪ r2).
Proof. hammer_hook "HahnWf" "HahnWf.fsupp_unionI".
by apply fsupp_union.
Qed.

Lemma fsupp_bunion B s (rr : B -> relation A)
(FIN: set_finite s) (FS: forall x (IN: s x), fsupp (rr x)) :
fsupp (bunion s rr).
Proof. hammer_hook "HahnWf" "HahnWf.fsupp_bunion".
unfolder in *; desf; ins.
revert s FIN FS; induction findom; ins.
by exists nil; ins; desf; eauto.
specialize (IHfindom (fun x => s x /\ x <> a)); ins.
specialize_full IHfindom; ins; desf; eauto.
by apply FIN in IN; desf; eauto.
tertium_non_datur (s a) as [X|X].
eapply FS in X; desf.
exists (findom1 ++ findom0); ins; desf.
tertium_non_datur (a = a0); desf; eauto 8 using in_or_app.
exists findom0; ins; desf; apply IHfindom; eexists; splits; eauto; congruence.
Qed.

Lemma fsupp_list r (FS: fsupp r) l :
exists findom, forall x y (REL: r x y) (IN: In y l), In x findom.
Proof. hammer_hook "HahnWf" "HahnWf.fsupp_list".
induction l; ins; desf.
by exists nil; ins.
specialize (FS a); desf.
exists (findom ++ findom0); ins; desf; eauto using in_or_app.
Qed.

Lemma fsupp_seqI r1 r2 (FS1: fsupp r1) (FS2: fsupp r2) : fsupp (r1 ⨾ r2).
Proof. hammer_hook "HahnWf" "HahnWf.fsupp_seqI".
unfold fsupp, seq; desf; ins; desf.
specialize (FS2 y); desf.
apply fsupp_list with (l:=findom) in FS1; desf.
exists findom0; ins; desf; eauto.
Qed.

Lemma fsupp_seq_eqv_l r d (FS: fsupp r) : fsupp (⦗d⦘ ⨾ r).
Proof. hammer_hook "HahnWf" "HahnWf.fsupp_seq_eqv_l".
unfold fsupp, seq, eqv_rel; desf; ins; desf.
specialize (FS y); desf; exists findom; ins; desf; eauto.
Qed.

Lemma fsupp_seq_eqv_r r d (FS: fsupp r) : fsupp (r ⨾ ⦗d⦘).
Proof. hammer_hook "HahnWf" "HahnWf.fsupp_seq_eqv_r".
unfold fsupp, seq, eqv_rel; desf; ins; desf.
specialize (FS y); desf; exists findom; ins; desf; eauto.
Qed.

Lemma fsupp_ct_rt r : fsupp r⁺ -> fsupp r＊.
Proof. hammer_hook "HahnWf" "HahnWf.fsupp_ct_rt".
rewrite rtE, fsupp_union; eauto using fsupp_eqv.
Qed.

Lemma fsupp_restr r (FS: fsupp r) cond : fsupp (restr_rel cond r).
Proof. hammer_hook "HahnWf" "HahnWf.fsupp_restr".
firstorder.
Qed.

Lemma functional_inv_fsupp r (F: functional r⁻¹) : fsupp r.
Proof. hammer_hook "HahnWf" "HahnWf.functional_inv_fsupp".
unfolder; ins.
tertium_non_datur (exists x, r x y); ins; desf.
- exists (x :: nil); ins; eauto.
- exists nil; ins; eauto.
Qed.

End finite_support.

Hint Resolve fsupp_empty fsupp_eqv fsupp_cross : hahn.
Hint Resolve fsupp_unionI fsupp_seqI fsupp_ct_rt fsupp_restr : hahn.


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

(** %\subsection*{ examples :  vecspace\_Fn.v }%*)
(** - In this file I define the vectorspaces $F^n$ (for arbitrary fields $F$);
 this is done without using the 'tool' alt_build_vecspace, just to
 show the tediousness of having to build all successive structures from the
 algebraic hierarchy by hand *)
Set Automatic Coercions Import.
Set Implicit Arguments.
Unset Strict Implicit.

Section Fn_vectors.

Require Export vecspaces_verybasic.
Require Export finite.

(**************************************)
(* In the beginning there was the set *)
(**************************************)

Definition Fn_set (F : Setoid) (n : Nat) : SET := seq n F.

(******************************************)
(* And Coq said, "let there be an sgroup" *)
(******************************************)

Let Fn_plus_fun :
  forall (F : sgroup) (n : Nat), Fn_set F n -> Fn_set F n -> Fn_set F n.
intros F n x y.
simpl in |- *.
apply (Build_Map (Ap:=fun i : fin n => x i +' y i)).
red in |- *.
elim x.
elim y.
intros.
red in Map_compatible_prf.
red in Map_compatible_prf0.
apply SGROUP_comp; auto with algebra.
Defined.

Definition Fn_plus :
  forall (F : sgroup) (n : Nat), law_of_composition (Fn_set F n).
intros F n.
apply (uncurry (f:=Fn_plus_fun (F:=F) (n:=n))).
red in |- *.
simpl in |- *.
intros.
red in |- *.
intro i.
simpl in |- *.
apply SGROUP_comp; auto with algebra.
Defined.

Lemma Fn_plus_associative :
 forall (F : sgroup) (n : Nat), associative (Fn_plus F n).
red in |- *.
intros.
simpl in |- *.
red in |- *.
intro i.
simpl in |- *.
apply SGROUP_assoc.
Qed.

Definition Fn_sgroup (F : sgroup) (n : Nat) : SGROUP :=
  Build_sgroup (Build_sgroup_on (Fn_plus_associative (F:=F) (n:=n))).

(*****************************************************)
(* And there was an sgroup, and Abel saw it was good *)
(*****************************************************)

Lemma Fn_plus_commutative :
 forall (F : abelian_sgroup) (n : Nat), commutative (Fn_plus F n).
red in |- *.
intros.
simpl in |- *.
red in |- *.
intro i.
simpl in |- *.
auto with algebra.
Qed.

Definition Fn_absgp (F : abelian_sgroup) (n : Nat) : ABELIAN_SGROUP :=
  Build_abelian_sgroup
    (Build_abelian_sgroup_on (A:=Fn_sgroup F n)
       (Fn_plus_commutative (F:=F) (n:=n))).

(******************************************************)
(* It is a monoid, Jim, but... exactly as we know it. *)
(******************************************************)

Definition Fn_zero : forall (F : monoid) (n : Nat), Fn_sgroup F n.
intros F n.
apply (Build_Map (Ap:=fun i : fin n => zero F)).
red in |- *.
intros.
apply Refl.
Defined.

Lemma Fn_zero_is_r_unit :
 forall (F : monoid) (n : Nat),
 unit_r (sgroup_law_map (Fn_sgroup F n)) (Fn_zero F n).
intros F n.
red in |- *.
intro.
simpl in |- *.
red in |- *.
intro i.
simpl in |- *.
apply MONOID_unit_r.
Qed.

Lemma Fn_zero_is_l_unit :
 forall (F : monoid) (n : Nat),
 unit_l (sgroup_law_map (Fn_sgroup F n)) (Fn_zero F n).
intros F n.
red in |- *.
intro.
simpl in |- *.
red in |- *.
intro i.
simpl in |- *.
apply MONOID_unit_l.
Qed.

Definition Fn_monoid (F : monoid) (n : Nat) : MONOID :=
  Build_monoid
    (Build_monoid_on (A:=Fn_sgroup F n) (monoid_unit:=
       Fn_zero F n) (Fn_zero_is_r_unit (F:=F) (n:=n))
       (Fn_zero_is_l_unit (F:=F) (n:=n))).

(*********************************)
(* And Abel saw that it was good *)
(*********************************)

Lemma Fn_monoid_is_abelian :
 forall (F : abelian_monoid) (n : Nat), abelian_monoid_on (Fn_monoid F n).
intros F n.
apply Build_abelian_monoid_on.
apply Build_abelian_sgroup_on.
exact (Fn_plus_commutative (F:=F) (n:=n)).
Qed.

Definition Fn_abmon (F : abelian_monoid) (n : Nat) : ABELIAN_MONOID :=
  Build_abelian_monoid (Fn_monoid_is_abelian F n).

(***********************************)
(* What's in a name? That which we *)
(* call a group by any other word  *)
(* would smell as sweet.           *)
(***********************************)

Let Fn_inv_fun : forall (F : group) (n : Nat), Fn_monoid F n -> Fn_monoid F n.
simpl in |- *.
intros F n v.
apply (Build_Map (Ap:=fun i : fin n => group_inverse F (v i))).
red in |- *.
intros i i' H.
apply GROUP_comp; auto with algebra.
Defined.

Definition Fn_inv :
  forall (F : group) (n : Nat), Map (Fn_monoid F n) (Fn_monoid F n).
intros F n.
apply (Build_Map (Ap:=Fn_inv_fun (F:=F) (n:=n))).
red in |- *.
intros.
simpl in |- *.
red in |- *.
intro i.
simpl in H.
red in H.
simpl in |- *.
apply GROUP_comp; auto with algebra.
Defined.

Lemma Fn_inv_is_r_inverse :
 forall (F : group) (n : Nat),
 inverse_r (Fn_plus F n) (Fn_zero F n) (Fn_inv F n).
intros F n.
red in |- *.
intro.
simpl in |- *.
red in |- *.
intro i.
simpl in |- *.
auto with algebra.
Qed.

Lemma Fn_inv_is_l_inverse :
 forall (F : group) (n : Nat),
 inverse_l (Fn_plus F n) (Fn_zero F n) (Fn_inv F n).
intros F n.
red in |- *.
intro.
simpl in |- *.
red in |- *.
intro i.
simpl in |- *.
auto with algebra.
Qed.

Definition Fn_group (F : group) (n : Nat) : GROUP :=
  Build_group
    (Build_group_on (group_inverse_map:=Fn_inv F n)
       (Fn_inv_is_r_inverse (F:=F) (n:=n))
       (Fn_inv_is_l_inverse (F:=F) (n:=n))).

(****************************)
(* Once more, Abel spoke... *)
(****************************)

Lemma Fn_group_is_abelian :
 forall (F : abelian_group) (n : Nat), abelian_group_on (Fn_group F n).
intros.
apply Build_abelian_group_on.
apply Build_abelian_monoid_on.
apply Build_abelian_sgroup_on.
exact (Fn_plus_commutative (F:=F) (n:=n)).
Qed.

Definition Fn_abgp (F : abelian_group) (n : Nat) : ABELIAN_GROUP :=
  Build_abelian_group (Fn_group_is_abelian F n).

(*******************************)
(* Alle modulen werden brueder *)
(*******************************)

Definition Fn_scmult_fun :
  forall (F : ring) (n : Nat), F -> Fn_set F n -> Fn_set F n.
simpl in |- *.
intros F n c v.
apply (Build_Map (Ap:=fun i : fin n => c rX v i)).
red in |- *.
auto with algebra.
Defined.

Lemma Fn_scmult_fun_comp :
 forall (F : ring) (n : Nat) (c c' : F) (v v' : Fn_set F n),
 c =' c' in _ ->
 v =' v' in _ -> Fn_scmult_fun c v =' Fn_scmult_fun c' v' in _.
simpl in |- *.
intros.
red in |- *.
intro i.
simpl in |- *.
apply RING_comp; auto with algebra.
Qed.

(********************************)
(* But that takes quite a while *)
(********************************)

Section necessary_module_stuff.

Let Fn_scmult_fun_map :
  forall (F : ring) (n : Nat), F -> MAP (Fn_set F n) (Fn_set F n).
intros F n c.
apply (Build_Map (Ap:=fun v : Fn_set F n => Fn_scmult_fun c v)).
red in |- *.
intros v v' H.
apply Fn_scmult_fun_comp; auto with algebra.
Defined.

Let Fn_scmult_F_to_EndoSet :
  forall (F : ring) (n : Nat),
  Map (Build_monoid (ring_monoid F)) (Endo_SET (Fn_set F n)).
intros F n.
simpl in |- *.
apply (Build_Map (Ap:=fun c : F => Fn_scmult_fun_map (F:=F) n c)).
red in |- *.
intros c c' H.
simpl in |- *.
red in |- *.
intro v.
generalize
 (Fn_scmult_fun_comp (F:=F) (n:=n) (c:=c) (c':=c') (v:=v) (v':=v) H).
simpl in |- *.
generalize (Refl v).
auto.
Defined.

Let Fn_scmult_sgroup_hom :
  forall (F : ring) (n : Nat),
  sgroup_hom (Build_monoid (ring_monoid F)) (Endo_SET (Fn_set F n)).
intros F n.
apply (Build_sgroup_hom (sgroup_map:=Fn_scmult_F_to_EndoSet F n)).
red in |- *.
simpl in |- *.
red in |- *.
intros c c' v.
simpl in |- *.
red in |- *.
intro i.
simpl in |- *.
apply Trans with ((c rX c') rX Ap v i); auto with algebra.
Defined.

Let Fn_scmult_monoid_hom :
  forall (F : ring) (n : Nat),
  monoid_hom (Build_monoid (ring_monoid F)) (Endo_SET (Fn_set F n)).
intros.
apply (Build_monoid_hom (monoid_sgroup_hom:=Fn_scmult_sgroup_hom F n)).
red in |- *.
simpl in |- *.
red in |- *.
intro v.
simpl in |- *.
red in |- *.
intro i.
simpl in |- *.
apply Trans with (one rX v i); auto with algebra.
Defined.

Definition Fn_scmult :
  forall (F : ring) (n : Nat),
  operation (Build_monoid (ring_monoid F)) (Fn_abgp F n).
intros.
simpl in |- *.
exact (Fn_scmult_monoid_hom F n).
Defined.

End necessary_module_stuff.

Lemma Fn_scmult_l_lin :
 forall (F : ring) (n : Nat), op_lin_left (Fn_scmult F n).
red in |- *.
intros F n c c' v.
simpl in |- *.
red in |- *.
intro i.
simpl in |- *.
apply RING_dist_r.
Qed.

Lemma Fn_scmult_r_lin :
 forall (F : ring) (n : Nat), op_lin_right (Fn_scmult F n).
intros F n.
red in |- *.
intros c c' v.
simpl in |- *.
red in |- *.
intro i.
simpl in |- *.
apply RING_dist_l.
Qed.

Definition Fn_mod (F : ring) (n : Nat) : MODULE F :=
  Build_module
    (Build_module_on (Fn_scmult_l_lin (F:=F) (n:=n))
       (Fn_scmult_r_lin (F:=F) (n:=n))).

Definition Fn (F : field) (n : Nat) : VECSP F := Fn_mod F n:vectorspace F.

End Fn_vectors.

(** - Defining the standard basis vectors needs a generalised Kronecker since
 0 and 1 from [nat] cannot be used in $F$ *)
Section Basis_vectors.

Fixpoint Kronecker (A : Setoid) (t f : A) (n m : Nat) {struct m} : A :=
  match n, m with
  | O, O => t
  | S n', O => f
  | O, S m' => f
  | S n', S m' => Kronecker t f n' m'
  end.

Lemma Kronecker_case_equal :
 forall (A : Setoid) (t f : A) (n m : Nat),
 n =' m in _ -> Kronecker t f n m =' t in _.
induction n; induction m; auto with algebra; intros.
inversion_clear H.
inversion_clear H.
simpl in |- *.
apply IHn; auto with algebra.
simpl in |- *; simpl in H; auto with arith.
Qed.

Lemma Kronecker_case_unequal :
 forall (A : Setoid) (t f : A) (n m : Nat),
 ~ n =' m in _ -> Kronecker t f n m =' f in _.
intros until n.
induction n.
induction m; auto with algebra.
intros; absurd (0 = 0); auto.
intros.
induction m; auto with algebra.
simpl in |- *.
apply IHn; auto with algebra.
intro p; red in H; apply H; simpl in p; simpl in |- *; auto with arith.
Qed.

Definition Basisvec_Fn :
  forall (F : field) (n i : Nat) (H : i < n), Fn F n:Type.
intros.
simpl in |- *.
apply
 (Build_Map
    (Ap:=fun j : fin n =>
         match j with
         | Build_finiteT j' _ => Kronecker one (zero F) i j'
         end)).
red in |- *.
intros x y.
elim x.
elim y.
simpl in |- *.
intros.
rewrite H0.
apply Refl.
Defined.
End Basis_vectors.


Require Import String.
Require Import List.
Require Import Multiset.
Require Import ListSet.

Require Import core.utils.Utils.

Require Import core.ConcreteSyntax.
Require Import core.Semantics.
Require Import core.Metamodel.
Require Import core.Expressions.

Require Import TT2BDD.TT.
Require Import TT2BDD.BDDv2.

Open Scope coqtl.

Definition TT2BDD (t: Table) :=
    transformation TTMetamodel bddMetamodel [
        (* The TruthTable transforms to a BDD, with the same name and Ports. *)

        (* Each InputPort transforms to an InputPort, with the same name. *)

        (* Each OutputPort transforms to an OutputPort, with the same name. *)

        (* Each Cell for the OutputPorts transform into Assignments. *)

        (* Each Row transforms to a Leaf. *)

        (* The TruthTable transforms into a subtree for each combination of input values, each subtree is owned by the subtree with iterator = i/2  *)

    ].

    (*

    example:
    a b c
    f - t
    t t f

              1
   a    2           3
   b  4   5       6   7

    leaf 1: c=t parent:4,5
    leaf 2: c=f parent:7

    (owner_i = i/2 rounded down)
             1
       2           3
     4   5       6   7
    8 9 10 11   12 13 14 15
   f=0 ...
    *)

(* We want to prove the following equivalence:
   given an assignment for *all* input ports 'ins', and given *an* output port 'out',
   (valueOf (evalTT TT ins) out) = (valueOf (evalBDD BDD ins) out)

    Theorem TT2BDD_correct:
     forall (inValues : list bool) (tt: TT) (bdd:BDD),
        bdd = execute TT2BDD tt ->
        evalTT tt inValues = evalBDD bdd inValues.
   *)

Close Scope coqtl.


(**
    TODO
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import TypeTheory.Auxiliary.CategoryTheoryImports.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.Auxiliary.SetsAndPresheaves.

Require Import TypeTheory.TypeCat.TypeCat.
Require Import TypeTheory.CwF_TypeCat.CwF_SplitTypeCat_Defs.
Require Import TypeTheory.CwF_TypeCat.TypeCat_Reassoc.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.

Section SplitTypeCat_Cat_Simple.

  Context (C : category).

  Definition TY'
    : split_typecat_structure C → preShv C.
  Proof.
    intros TC.
    use tpair.
    - use tpair.
      + intros Γ.
        exists (TC Γ).
        apply (pr1 (pr2 TC)).
      + intros Γ Γ' f A.
        apply (reind_typecat A f).
    - use make_dirprod.
      + intros Γ. simpl.
        use funextsec; intros A.
        apply (pr1 (pr1 (pr2 (pr2 TC)))).
      + intros Γ Γ' Γ'' f g. simpl.
        use funextsec; intros A.
        apply (pr1 (pr2 (pr2 (pr2 TC)))).
  Defined.

  Definition TY'_TY_eq
             (TC : split_typecat_structure C)
    : TY' TC = TY (weq_standalone_to_regrouped TC).
  Proof.
    use total2_paths_f.
    - apply idpath.
    - apply isaprop_is_functor. apply homset_property.
  Defined.

  Definition SplitTy_mor_data
             (X Y : split_typecat_structure C)
    : UU
    := ∑ (F_TY : ∏ (Γ : C), X Γ → Y Γ),
       (* ϕ : *) ∏ (Γ : C) (A : X Γ), Γ ◂ A --> Γ ◂ (F_TY _ A).

  Definition SplitTy_mor_axiom_F_TY
             {X Y : split_typecat_structure C}
             (mor : SplitTy_mor_data X Y)
    : UU
    := ∏ (Γ Γ' : C) (f : C ⟦ Γ', Γ ⟧) (A : X Γ),
       pr1 mor _ (reind_typecat A f) = reind_typecat (pr1 mor _ A) f.

  Definition SplitTy_mor_axiom_dpr
             {X Y : split_typecat_structure C}
             (mor : SplitTy_mor_data X Y)
    : UU
    := ∏ (Γ : C) (A : X Γ),
       pr2 mor Γ A ;; dpr_typecat _ = dpr_typecat _. (* ϕ ;; π (F_TY A) = π A *)

  Definition reind_ext_compare
             {X : split_typecat_structure C}
             {Γ : C} {A A' : TY' X $p Γ} (e : A = A')
    : z_iso (Γ ◂ A) (Γ ◂ A').
  Proof.
    apply idtoiso, maponpaths, e.
  Defined.

  Lemma reind_ext_compare_id {X : split_typecat_structure C}
        {Γ : C} (A : TY' X $p Γ)
    : reind_ext_compare (idpath A) = identity_z_iso (Γ ◂ A).
  Proof.
    apply idpath.
  Qed.

  Lemma reind_ext_compare_id_general {X : split_typecat_structure C}
        {Γ : C} {A : TY' X $p Γ}
        (e : A = A)
    : reind_ext_compare e = identity_z_iso (Γ ◂ A).
  Proof.
    apply @pathscomp0 with (reind_ext_compare (idpath _)).
    apply maponpaths, setproperty.
    apply idpath.
  Qed.

  Lemma reind_ext_compare_comp {X : split_typecat_structure C}
        {Γ : C} {A A' A'' : TY' X $p Γ} (e : A = A') (e' : A' = A'')
    : pr1 (reind_ext_compare (e @ e')) = reind_ext_compare e ;; reind_ext_compare e'.
  Proof.
    etrans. 2: { apply idtoiso_concat_pr. }
    unfold reind_ext_compare. apply maponpaths, maponpaths.
    apply maponpathscomp0.
  Qed.

  Lemma reind_ext_compare_comp_general {X : split_typecat_structure C}
        {Γ : C} {A A' A'' : TY' X $p Γ}
        (e : A = A') (e' : A' = A'') (e'' : A = A'')
    : pr1 (reind_ext_compare e'') = reind_ext_compare e ;; reind_ext_compare e'.
  Proof.
    refine (_ @ reind_ext_compare_comp _ _).
    apply maponpaths, maponpaths, setproperty.
  Qed.

  Definition F_TY_reind_ext_eq
             (X Y : split_typecat_structure C)
             (mor : SplitTy_mor_data X Y)
             (F_TY_ax : SplitTy_mor_axiom_F_TY mor)
    : ∏ (Γ : C) (A : X Γ) (Γ' : C) (f : Γ' --> Γ),
      pr1 mor _ (A {{f}})
      = (pr1 mor _ A) {{f}}.
  Proof.
    intros Γ Γ' f A.
    apply F_TY_ax.
  Defined.

  Definition F_TY_reind_ext_compare
             (X Y : split_typecat_structure C)
             (mor : SplitTy_mor_data X Y)
             (F_TY_ax : SplitTy_mor_axiom_F_TY mor)
    : ∏ (Γ : C) (A : X Γ) (Γ' : C) (f : Γ' --> Γ),
      z_iso (Γ' ◂ pr1 mor _ (A {{f}}))
          (Γ' ◂ (pr1 mor _ A) {{f}}).
  Proof.
    intros Γ Γ' f A.
    use reind_ext_compare.
    apply F_TY_reind_ext_eq.
    apply F_TY_ax.
  Defined.

  Local Definition Δ := F_TY_reind_ext_compare.

  Lemma Δ_φ {X Y : split_typecat_structure C} (mor : SplitTy_mor_data X Y)
        {Γ : C} {A A' : TY' X $p Γ} (e : A = A')
    : reind_ext_compare e ;; pr2 mor Γ A'
      = pr2 mor _ A ;; reind_ext_compare (maponpaths (pr1 mor _) e).
  Proof.
    destruct e; simpl. etrans. apply id_left. apply pathsinv0, id_right.
  Qed.

  Definition SplitTy_mor_axiom_q
             {X Y : split_typecat_structure C}
             (mor : SplitTy_mor_data X Y)
             (F_TY_ax : SplitTy_mor_axiom_F_TY mor)
    : UU
    := ∏ (Γ Γ' : C) (f : Γ' --> Γ) (A : X Γ),
       q_typecat A f ;; pr2 mor Γ A
       = pr2 mor Γ' (A {{f}}) ;; Δ _ _ _ F_TY_ax Γ A Γ' f ;; q_typecat _ f.

  Definition SplitTy_mor_axioms
             {X Y : split_typecat_structure C}
             (mor : SplitTy_mor_data X Y)
    : UU
    := ∑ (F_TY_ax : SplitTy_mor_axiom_F_TY mor)
         (dpr_ax : SplitTy_mor_axiom_dpr mor),
       SplitTy_mor_axiom_q mor F_TY_ax.

  Definition isaprop_SplitTy_mor_axioms
             {X Y : split_typecat_structure C}
             (mor : SplitTy_mor_data X Y)
    : isaprop (SplitTy_mor_axioms mor).
  Proof.
    apply Propositions.isaproptotal2.
    - intros ?. apply isapropdirprod.
      + repeat (apply impred_isaprop; intros ?). apply homset_property.
      + repeat (apply impred_isaprop; intros ?). apply homset_property.
    - intros.
      repeat (apply funextsec; intros ?).
      apply (pr1 (pr2 Y)).
  Defined.

  Definition SplitTy_mor
             (X Y : split_typecat_structure C)
    : UU
    := ∑ (mor_data : SplitTy_mor_data X Y),
       SplitTy_mor_axioms mor_data.

  Lemma SplitTy_mor_eq {X Y} (mor1 mor2 : SplitTy_mor X Y)
        (e_TY : ∏ Γ (A : TY' X $p Γ),
                pr1 (pr1 mor1) _ A =
                pr1 (pr1 mor2) _ A)
        (e_ϕ : ∏ Γ (A : TY' X $p Γ),
                  pr2 (pr1 mor1) _ A ;; reind_ext_compare (e_TY _ _)
                  = pr2 (pr1 mor2) _ A)
    : mor1 = mor2.
  Proof.
    use total2_paths_f. 2: apply isaprop_SplitTy_mor_axioms.
    use total2_paths_f.
    + repeat (apply funextsec; intros ?).
      apply e_TY.
    + etrans. use transportf_forall.
      apply funextsec; intros Γ.
      etrans. use transportf_forall.
      apply funextsec; intros A.
      refine (_ @ e_ϕ Γ A).
      etrans. apply (functtransportf
                       (λ x, x Γ A)
                       (λ y, C ⟦ Γ ◂ A, Γ ◂ y ⟧)).
      etrans. apply (functtransportf
                       (λ x, Γ ◂ x)
                       (λ y, C ⟦ Γ ◂ A, y ⟧)).
      etrans. apply pathsinv0, idtoiso_postcompose.
      apply maponpaths.
      unfold reind_ext_compare, ext_typecat.
      apply maponpaths.
      apply maponpaths.
      apply maponpaths.
      apply (pr1 (pr2 Y)).
  Qed.

  Definition SplitTy_mor_id
             (X : split_typecat_structure C)
    : SplitTy_mor X X.
  Proof.
    use tpair.
    - use tpair.
      + intros Γ. exact (idfun _).
      + intros Γ A. apply identity.
    - use tpair. 2: use make_dirprod.
      + intros Γ Γ' f A. apply idpath.
      + intros Γ A. apply id_left.
      + intros Γ Γ' f A. simpl.
        etrans. apply id_right.
        etrans. 2: apply assoc.
        etrans. 2: apply pathsinv0, id_left.
        apply pathsinv0.
        apply id_left.
  Defined.

  Definition SplitTy_mor_comp
             {X Y Z : split_typecat_structure C}
             (ff : SplitTy_mor X Y)
             (gg : SplitTy_mor Y Z)
    : SplitTy_mor X Z.
  Proof.
    use tpair.
    - use tpair.
      + intros Γ A. exact (pr1 (pr1 gg) _ (pr1 (pr1 ff) _ A)).
      + intros Γ A. exact (pr2 (pr1 ff) _ _ ;; pr2 (pr1 gg) _ _).
    - use tpair. 2: use make_dirprod.
      + intros Γ Γ' f A. simpl.
        etrans. apply maponpaths.
        apply (pr1 (pr2 ff)).
        apply (pr1 (pr2 gg)).
      + intros Γ A. simpl.
        etrans. apply assoc'.
        etrans. apply maponpaths.
        apply (pr1 (pr2 (pr2 gg))).
        apply (pr1 (pr2 (pr2 ff))).
      + intros Γ Γ' f A. simpl.
        set (ff_q := pr2 (pr2 (pr2 ff)) Γ Γ' f A).
        set (gg_q := pr2 (pr2 (pr2 gg))).
        etrans. apply assoc.
        etrans. apply maponpaths_2, ff_q.

        etrans. apply assoc'.
        etrans. apply assoc'.
        etrans. 2: apply assoc.
        etrans. 2: apply assoc.
        apply maponpaths.

        etrans. apply maponpaths, gg_q.

        etrans. apply assoc.
        etrans. apply maponpaths_2, assoc.
        etrans. apply maponpaths_2, maponpaths_2.
        apply Δ_φ.

        etrans. apply assoc'.
        etrans. apply assoc'.
        apply maponpaths.

        etrans. apply assoc.
        apply maponpaths_2.
        apply pathsinv0, reind_ext_compare_comp_general.
  Defined.

  Definition SplitTy_ob_mor
    : precategory_ob_mor
    := (split_typecat_structure C ,, SplitTy_mor).

  Definition SplitTy_id_comp
    : precategory_id_comp SplitTy_ob_mor.
  Proof.
    use make_dirprod.
    - apply SplitTy_mor_id.
    - intros X Y Z. apply SplitTy_mor_comp.
  Defined.

  Definition SplitTy_precat_data
    : precategory_data
    := (SplitTy_ob_mor ,, SplitTy_id_comp).

  Definition SplitTy_precat_axioms
    : is_precategory SplitTy_precat_data.
  Proof.
    repeat use make_dirprod.
    - intros X Y f. use SplitTy_mor_eq.
      + intros Γ A. apply idpath.
      + intros Γ A. cbn. etrans. apply maponpaths_2, id_left. apply id_right.
    - intros X Y f. use SplitTy_mor_eq.
      + intros Γ A. apply idpath.
      + intros Γ A. cbn. etrans. apply maponpaths_2, id_right. apply id_right.
    - intros X Y Z W f g h. use SplitTy_mor_eq.
      + intros Γ A. apply idpath.
      + intros Γ A. cbn. etrans. apply maponpaths_2, assoc. apply id_right.
    - intros X Y Z W f g h. use SplitTy_mor_eq.
      + intros Γ A. apply idpath.
      + intros Γ A. cbn. etrans. apply maponpaths_2, assoc'. apply id_right.
  Defined.

  Definition SplitTy_precat : precategory
    := (_ ,, SplitTy_precat_axioms).

  Definition SplitTy_precat_homsets : has_homsets SplitTy_precat.
  Proof.
    unfold has_homsets.
    intros X Y.
    apply isaset_total2. 2: intros ?; apply isasetaprop, isaprop_SplitTy_mor_axioms.
    - apply isaset_total2.
      + repeat (apply impred_isaset; intros ?).
        apply (pr1 (pr2 Y)).
      + intros ?.
        repeat (apply impred_isaset; intros ?).
        apply homset_property.
  Defined.

  Definition SplitTy_cat : category
    := (SplitTy_precat ,, SplitTy_precat_homsets).

End SplitTypeCat_Cat_Simple.


Set Automatic Coercions Import.
From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq.
Require Import pred prelude idynamic pcm unionmap heap domain.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Exceptions are an equality type *)
Inductive exn : Type := exn_from_nat : nat -> exn.

Definition exn_to_nat (e : exn) : nat :=
  let: exn_from_nat y := e in y.

Definition eqexn (e1 e2 : exn) : bool :=
  match e1, e2 with exn_from_nat m, exn_from_nat n => m == n end.

Lemma eqexnP : Equality.axiom eqexn.
Proof.
move=>[x][y]//=; case: eqP=>[->|*];constructor=>//.
by move=>[*].
Qed.

Canonical Structure exn_eqMixin := EqMixin eqexnP.
Canonical Structure exn_eqType := EqType exn exn_eqMixin.

(* Answer type *)
Inductive ans (A : Type) : Type := Val of A | Exn of exn.
Implicit Arguments Exn [A].

Notation pre := (Pred heap).
Notation post A := (ans A -> heap -> heap -> Prop).
Definition spec B := pre * post B : Type.

(********************************)
(* Definition of the Hoare type *)
(********************************)

Definition defed (P : Pred heap) : Pred heap :=
  fun i => i \In P /\ valid i.

Notation ideald P := (ideal (defed P)).

Section BasePrograms.
Variables (A : Type) (P : Pred heap).

Lemma singleP i : i \In defed P -> eq i <== defed P.
Proof. by case=>pf1 pf2 h <-. Qed.

Definition single i (pf : i \In defed P) := Ideal (singleP pf).

Lemma bound (p : ideald P) i : i \In id_val p -> i \In defed P.
Proof. by case: p=>p H; case/H. Qed.

(* we carve out the model out of the following base type *)
Definition prog := ideald P -> ans A -> Pred heap.

(* we take progs with only special properties *)
(* which we defined next *)

(* coherence is continuity stated with *)
(* directed sets instead of chains *)
Definition coherent (e : prog) :=
  forall p x m,
    m \In e p x <-> exists i (pf : i \In id_val p),
                    m \In e (single (bound pf)) x.

(* defined heaps map to defined heaps *)
Definition def_strict (e : prog) := forall p x, Heap.Undef \Notin e p x.

(* set of program runs *)
Definition runs_of (e : prog) : Pred (heap * ans A * heap) :=
  fun r => exists pf : r.1.1 \In defed P, r.2 \In e (single pf) r.1.2.

End BasePrograms.

Definition has_spec A (s : spec A) :=
  [Pred c : prog A s.1 |
     forall i y m, (i, y, m) \In runs_of c -> s.2 y i m].

Section STDef.
Variables (A : Type) (s : spec A).

Structure STspec := STprog {
  model : prog A s.1;
  _ : coherent model;
  _ : def_strict model;
  _ : model \In has_spec s}.

Lemma modelE (e1 e2 : STspec) : e1 = e2 <-> model e1 = model e2.
Proof.
move: e1 e2=>[e1 M1 S1 H1][e2 M2 S2 H2] /=; split=>[[//]|E].
rewrite E in M1 S1 H1 *.
by congr STprog; apply: proof_irrelevance.
Qed.

(* poset structure on ST *)

Definition st_leq e1 e2 := model e1 <== model e2.

Lemma st_refl e : st_leq e e.
Proof. by []. Qed.

Lemma st_asym e1 e2 : st_leq e1 e2 -> st_leq e2 e1 -> e1 = e2.
Proof.
move: e1 e2=>[e1 M1 S1 H1][e2 M2 S2 H2]; rewrite /st_leq /= => E1 E2.
rewrite (poset_asym E1 E2) in M1 M2 S1 S2 H1 H2 *; congr STprog;
by apply: proof_irrelevance.
Qed.

Lemma st_trans e1 e2 e3 : st_leq e1 e2 -> st_leq e2 e3 -> st_leq e1 e3.
Proof.
move: e1 e2 e3=>[e1 M1 S1 H1][e2 M2 S2 H2][e3 M3 S3 H3].
by apply: poset_trans.
Qed.

Definition st_bot' := bot : [poset of prog A s.1].

Lemma st_bot_coherent : coherent st_bot'.
Proof. by move=>r x m; split=>//; case=>i []. Qed.

Lemma st_bot_dstrict : def_strict st_bot'.
Proof. by move=>r x. Qed.

Lemma st_bot_has_spec : st_bot' \In has_spec s.
Proof. by move=>i y m [/= H][]. Qed.

Definition st_bot := STprog st_bot_coherent st_bot_dstrict st_bot_has_spec.

Lemma st_botP e : st_leq st_bot e.
Proof. by case: e=>*; apply: botP. Qed.

Definition stPosetMixin := PosetMixin st_botP st_refl st_asym st_trans.
Canonical stPoset := Eval hnf in Poset STspec stPosetMixin.

(* lattice structure on ST *)

Definition st_sup' (u : Pred STspec) :=
  sup [Pred p | exists e, p = model e /\ e \In u].

Lemma st_sup_coherent u : coherent (st_sup' u).
Proof.
move=>r x m; split.
- case=>_ [[_]][[_]][[_]][[]][p] M S H [->] P -> -> -> /=.
  case/M=>i [pf] H1.
  exists i, pf, (p (single (bound pf)) x m).
  split=>//; do 3![eexists _; split=>//].
  by exists (STprog M S H).
case=>i [pf][_][[_]][[_]][[_]][[]][p] M D H [->] P -> -> -> /= E.
have: exists i (pf : i \In id_val r), m \In p (single (bound pf)) x.
- by exists i, pf.
move/M=>H3; exists (p r x m); split=>//; do 3![eexists _; split=>//].
by exists (STprog M D H).
Qed.

Lemma st_sup_dstrict u : def_strict (st_sup' u).
Proof.
by move=>p x [_][[_]][[_]][[_]][[]][r] M D H [->] P -> -> -> /=; move/D.
Qed.

Lemma st_sup_has_spec u : st_sup' u \In has_spec s.
Proof.
move=>i y m [/= D].
case=>_ [[_]][[_]][[_]][[]][p] M S H [->] P -> -> -> /= R.
by apply: (H); exists D.
Qed.

Definition st_sup u :=
  STprog (@st_sup_coherent u) (@st_sup_dstrict u) (@st_sup_has_spec u).

Lemma st_supP (u : Pred STspec) e : e \In u -> st_leq e (st_sup u).
Proof. by case: e=>p M S H R; apply: supP; exists (STprog M S H). Qed.

Lemma st_supM (u : Pred STspec) e :
        (forall e1, e1 \In u -> st_leq e1 e) -> st_leq (st_sup u) e.
Proof. by case: e=>p M S H R; apply: supM=>y [q][->]; apply: R. Qed.

Definition stLatticeMixin := LatticeMixin st_supP st_supM.
Canonical stLattice := Lattice STspec stLatticeMixin.

(* In proofs, we keep goals in form (i, x, m) \In runs_of (model e). *)
(* We need a couple of lemmas about this form. *)

Lemma bot_runs : runs_of (model st_bot) =p Pred0.
Proof. by move=>r; split=>//; case. Qed.

Lemma model_runs p y m (e : STspec) :
        m \In model e p y <->
        exists i, i \In id_val p /\ (i, y, m) \In runs_of (model e).
Proof.
case: e=>mod M S H; rewrite M; split; case=>i [H1] H2.
- by exists i; split=>//; exists (bound H1).
exists i, H1; case: H2 =>/= H2.
by rewrite (proof_irrelevance H2 (bound H1)).
Qed.

Lemma def_runs i y m (e : STspec) :
        (i, y, m) \In runs_of (model e) -> [/\ valid i, i \In s.1 & valid m].
Proof.
case=>[[/= P D]] R; split=>//.
by case: e R=>p M S H; case: m=>//; move/S.
Qed.

Lemma spec_runs i y m (e : STspec) :
        (i, y, m) \In runs_of (model e) -> s.2 y i m.
Proof. by case: e=>p M S; apply. Qed.

End STDef.

Implicit Arguments spec_runs [A s i y m].
Prenex Implicits bot_runs model_runs def_runs spec_runs.

(************************************)
(* modeling the language primitives *)
(************************************)

Module Model.

(* recursion *)
Section Fix.
Variables (A : Type) (B : A -> Type) (s : forall x, spec (B x)).
Notation tp := (forall x, STspec (s x)).
Notation lat := (dfunLattice (fun x => [lattice of STspec (s x)])).
Variable (f : tp -> tp).

(* we take a fixpoint not of f, but of its monotone completion f' *)
(* should eventually prove that f' is monotone *)

Definition f' (e : lat) :=
  sup [Pred t : lat | exists e', e' <== e /\ t = f e'].

Definition ffix : tp := tarski_lfp f'.

End Fix.

Section Return.
Variables (A : Type) (x : A).

Definition ret_s : spec A :=
  (fun i => True, fun y i m => m = i /\ y = Val x).

Definition ret_sp (p : ideald ret_s.1) y m :=
  m \In id_val p /\ y = Val x.

Lemma ret_coherent : coherent ret_sp.
Proof.
move=>p y m; split; first by case=>H ->{y}; exists m, H.
by case=>i [H1][<-] ->.
Qed.

Lemma ret_dstrict : def_strict ret_sp.
Proof. by case=>p H y /= []; case/H. Qed.

Lemma ret_has_spec : ret_sp \In has_spec ret_s.
Proof. by move=>i y m; case=>/= T [-> ->]. Qed.

Definition ret := STprog ret_coherent ret_dstrict ret_has_spec.

End Return.

Section Throw.
Variables (A : Type) (e : exn).

Definition throw_s : spec A :=
  (fun i => True, fun y i m => m = i /\ y = Exn e).

Definition throw_sp (p : ideald throw_s.1) y m :=
  m \In id_val p /\ y = @Exn A e.

Lemma throw_coherent : coherent throw_sp.
Proof.
move=>p y m; split; first by case=>H ->{y}; exists m, H.
by case=>i [H1] [<-{m}] ->{y}.
Qed.

Lemma throw_dstrict : def_strict throw_sp.
Proof. by case=>p H y /= []; case/H. Qed.

Lemma throw_has_spec : throw_sp \In has_spec throw_s.
Proof. by move=>i y m; case=>/= T [-> ->]. Qed.

Definition throw := STprog throw_coherent throw_dstrict throw_has_spec.

End Throw.

Section Bind.
Variables (A B : Type).
Variables (s1 : spec A) (s2 : A -> spec B).
Variables (e1 : STspec s1) (e2 : forall x, STspec (s2 x)).

Definition bind_pre : pre :=
  fun i => s1.1 i /\ forall x m, s1.2 (Val x) i m -> (s2 x).1 m.
Definition bind_post : post B :=
  fun y i m => (exists x h, s1.2 (Val x) i h /\ (s2 x).2 y h m) \/
               (exists e, y = Exn e /\ s1.2 (Exn e) i m).
Definition bind_s := (bind_pre, bind_post).

Definition bind_sp (p : ideald bind_s.1) y m :=
   exists i, exists x h, i \In id_val p /\
     (i, x, h) \In runs_of (model e1) /\
     match x with
       Val x' => (h, y, m) \In runs_of (model (e2 x'))
     | Exn e => y = Exn e /\ m = h
     end.

Lemma bind_coherent : coherent bind_sp.
Proof.
case=>p H y m; split.
- case=>i [x][h][/= H1][H2] H3.
  by exists i, H1, i, x, h.
case=>i [/= H1][_][x][h][<-][T1 T2].
by exists i, x, h.
Qed.

Lemma bind_dstrict : def_strict bind_sp.
Proof.
move=>p y [i][x][h][H1][].
case: x=>[x'|e] H2; first by case/def_runs.
by case=>_ E; case/def_runs: H2; rewrite -E.
Qed.

Lemma bind_has_spec : bind_sp \In has_spec bind_s.
Proof.
move=>i y m.
case=>[[[/= S1 S2]]] D [h][x][j][<-][].
case: x=>[x|e] T1; last first.
- case=>->->; right; exists e; split=>//.
  by apply: spec_runs T1.
move=>T2; left; exists x, j.
by split; [apply: spec_runs T1 | apply: spec_runs T2].
Qed.

Definition bind := STprog bind_coherent bind_dstrict bind_has_spec.

End Bind.

Section Try.
Variables (A B : Type) (s : spec A) (s1 : A -> spec B) (s2 : exn -> spec B).
Variables (e : STspec s) (e1 : forall x, STspec (s1 x))
          (e2 : forall x, STspec (s2 x)).

Definition try_pre : pre :=
  fun i => s.1 i /\ (forall y m, s.2 (Val y) i m -> (s1 y).1 m) /\
                     forall e m, s.2 (Exn e) i m -> (s2 e).1 m.
Definition try_post : post B :=
  fun y i m => (exists x h, s.2 (Val x) i h /\ (s1 x).2 y h m) \/
               (exists e h, s.2 (Exn e) i h /\ (s2 e).2 y h m).
Definition try_s := (try_pre, try_post).

Definition try_sp (p : ideald try_s.1) y m :=
   exists i x h, i \In id_val p /\
     (i, x, h) \In runs_of (model e) /\
     match x with
       Val x' => (h, y, m) \In runs_of (model (e1 x'))
     | Exn e => (h, y, m) \In runs_of (model (e2 e))
     end.

Lemma try_coherent : coherent try_sp.
Proof.
case=>p H y m; split.
- case=>i [x][h][/= H1][H2] H3.
  by exists i, H1, i, x, h.
case=>i [/= H1][_][x][h][<-][T1 T2].
by exists i, x, h.
Qed.

Lemma try_dstrict : def_strict try_sp.
Proof.
move=>p y [i][x][h][H1][].
by case: x=>[x'|e'] H2; case/def_runs.
Qed.

Lemma try_has_spec : try_sp \In has_spec try_s.
Proof.
move=>i y m; case=>[[[/= S1 [S2 S3]]]] D [h][x][j][<-][].
case: x=>[x'|e'] T1 T2; [left; exists x' | right; exists e'];
exists j; by split; [apply: spec_runs T1 | apply: spec_runs T2].
Qed.

Definition try := STprog try_coherent try_dstrict try_has_spec.

End Try.

Definition conseq A (s1 s2 : spec A) :=
  forall i, s2.1 i -> valid i ->
    s1.1 i /\ forall y m, s1.2 y i m -> valid m -> s2.2 y i m.

Lemma conseq_refl (A : Type) (s : spec A) : conseq s s.
Proof. by []. Qed.

Hint Resolve conseq_refl.

Section Consequence.
Variables (A : Type) (s1 s2 : spec A) (e : STspec s1) (pf : conseq s1 s2).

Definition do_sp (p : ideald s2.1) y m :=
  exists i, i \In id_val p /\ (i, y, m) \In runs_of (model e).

Lemma do_coherent : coherent do_sp.
Proof.
case=>q H y m; split.
- by case=>i [/= H1 T1]; exists i, H1, i.
by case=>i [/= H1][_][<-] T1; exists i.
Qed.

Lemma do_dstrict : def_strict do_sp.
Proof. by move=>q y [h][/= H]; case/def_runs. Qed.

Lemma do_has_spec : do_sp \In has_spec s2.
Proof.
move=>i y m [[/= S1 D1]][_][<-] T; case/def_runs: (T)=>_ S2 D2.
by apply: (proj2 (pf S1 D1)) D2; apply: spec_runs T.
Qed.

Definition Do := STprog do_coherent do_dstrict do_has_spec.

End Consequence.

Section Read.
Variable (A : Type) (x : ptr).

Local Notation idyn v := (@idyn _ id _ v).

Definition read_s : spec A :=
  (fun i : heap => x \in dom i /\ exists v : A, find x i = Some (idyn v),
   fun y (i : heap) m => m = i /\
     forall v, find x i = Some (idyn v) -> y = Val v).

Definition read_sp (p : ideald read_s.1) (v : ans A) m :=
  m \In id_val p /\ exists w, v = Val w /\ find x m = Some (idyn w).

Lemma read_coherent : coherent read_sp.
Proof.
move=>p v m; split; last first.
- by case=>i [H1][<-][w][->]; split=>//; exists w.
case=>H1 [w][->] H2.
by exists m, H1; split=>//; exists w.
Qed.

Lemma read_dstrict : def_strict read_sp.
Proof. by case=>p H y []; case/H. Qed.

Lemma read_has_spec : read_sp \In has_spec read_s.
Proof.
move=>i y m [[[/= H1]]][v] H2 D [<-][w][->] H3.
by split=>// b1; rewrite H3; case; move/inj_pair2=>->.
Qed.

Definition read := STprog read_coherent read_dstrict read_has_spec.

End Read.

Section Write.
Variable (A : Type) (x : ptr) (v : A).

Local Notation idyn v := (@idyn _ id _ v).

Definition write_s : spec unit :=
  (fun i : heap => x \in dom i : Prop,
   fun y (i : heap) m => y = Val tt /\ upd x (idyn v) i = m).

Definition write_sp (p : ideald write_s.1) (y : ans unit) m :=
  exists i, i \In id_val p /\ x \in dom i /\
            y = Val tt /\ m = upd x (idyn v) i.

Lemma write_coherent : coherent write_sp.
Proof.
move=>p y m; split; case=>i [H1].
- by case=>H2 [->->]; exists i, H1,i.
by case=>_ [<-][H2][->] ->; exists i.
Qed.

Lemma write_dstrict : def_strict write_sp.
Proof.
case=>p H y [i] /= [H1][H2][H3].
suff L: valid (upd x (idyn v) i) by move=>H4; rewrite -H4 in L.
by rewrite validU (dom_cond H2) (dom_valid H2).
Qed.

Lemma write_has_spec : write_sp \In has_spec write_s.
Proof. by move=>i y m [[/= H1 D1]][_][<-][H2][->] ->. Qed.

Definition write := STprog write_coherent write_dstrict write_has_spec.

End Write.

Section Allocation.
Variables (A : Type) (v : A).

Local Notation idyn v := (@idyn _ id _ v).

Definition alloc_s : spec ptr :=
  (fun i => valid i : Prop,
   fun y (i : heap) m => exists x, x != null /\ y = Val x /\ x \notin dom i /\
                                   upd x (idyn v) i = m).

Definition alloc_sp (p : ideald alloc_s.1) y m :=
  exists i, i \In id_val p /\ exists l : ptr, y = Val l /\
    m = i \+ l :-> v /\ l != null /\ l \notin dom i.

Lemma alloc_coherent : coherent alloc_sp.
Proof.
move=>p x m; split.
- case=>i [H1][l][->][->][H2] H3.
  by exists i, H1, i; split=>//; exists l.
case=>i [H1][_][<-][l][->][->][H2 H3].
by exists i; split=>//; exists l.
Qed.

Lemma alloc_dstrict : def_strict alloc_sp.
Proof.
case=>p H y [m][/= H1][l][H2][H3][H4 H5]; case/H: H1=>_ D.
suff {H3}: valid (m \+ l :-> v) by rewrite -H3.
by rewrite joinC hvalidPtUn H4 D H5.
Qed.

Lemma alloc_has_spec : alloc_sp \In has_spec alloc_s.
Proof.
move=>i y m [[/= H D]][_][<-][l][->][->][H1] H2.
exists l; do !split=>//.
by rewrite -[i]unitR updUnL (negbTE H2) unitR.
Qed.

Definition alloc := STprog alloc_coherent alloc_dstrict alloc_has_spec.

End Allocation.

Section BlockAllocation.
Variables (A : Type) (v : A) (n : nat).

Definition allocb_s : spec ptr :=
  (fun i => valid i : Prop,
   fun y i m => exists r, y = Val r /\ m = i \+ updi r (nseq n v)).

Definition allocb_sp (p : ideald allocb_s.1) y m :=
  exists i, i \In id_val p /\ y = Val (fresh i) /\
            m = i \+ updi (fresh i) (nseq n v).

Lemma allocb_coherent : coherent allocb_sp.
Proof.
move=>p x m; split.
- by case=>i [H1][->] ->; exists i; exists H1; exists i.
by case=>i [H1][_][<-][->] ->; exists i.
Qed.

Lemma allocb_dstrict : def_strict allocb_sp.
Proof.
case=>p H y [m][/= H1][_] H2; case/H: H1=>_ D.
suff {H2}: valid (m \+ updi (fresh m) (nseq n v)) by rewrite -H2.
elim: n =>[|k IH]; first by rewrite /= unitR.
rewrite (_ : nseq k.+1 v = rcons (nseq k v) v); last first.
- by elim: {IH} k=>[|k IH] //=; rewrite -IH.
rewrite updi_last joinA joinC hvalidPtUn IH /=.
rewrite ptr_null negb_and fresh_null /=.
rewrite domUn !inE /= negb_and IH negb_or /=.
by rewrite dom_fresh updimV negb_and fresh_null ltnn.
Qed.

Lemma allocb_has_spec : allocb_sp \In has_spec allocb_s.
Proof. by move=>i y m [[/= H D]][_][<-][->] ->; exists (fresh i). Qed.

Definition allocb := STprog allocb_coherent allocb_dstrict allocb_has_spec.

End BlockAllocation.

Section Deallocation.
Variable x : ptr.

Definition dealloc_s : spec unit :=
  (fun i : heap => x \in dom i : Prop,
   fun y (i : heap) m => y = Val tt /\ free x i = m).

Definition dealloc_sp (p : ideald dealloc_s.1) (y : ans unit) m :=
  exists i, i \In id_val p /\ y = Val tt /\ x \in dom i /\ m = free x i.

Lemma dealloc_coherent : coherent dealloc_sp.
Proof.
move=>p y m; split.
- by case=>i [H1][->][H2] ->; exists i; exists H1; exists i.
by case=>i [H1][_][<-][->][H2] ->; exists i.
Qed.

Lemma dealloc_dstrict : def_strict dealloc_sp.
Proof.
case=>p H y [h][/=]; case/H=>_ H1 [H2][H3] H4.
suff: valid (free x h) by rewrite -H4.
by rewrite validF.
Qed.

Lemma dealloc_has_spec : dealloc_sp \In has_spec dealloc_s.
Proof. by move=>i y m [[/= H1 D1]][_][<-][->][H2] ->. Qed.

Definition dealloc :=
  STprog dealloc_coherent dealloc_dstrict dealloc_has_spec.

End Deallocation.

End Model.