Add LoadPath "../../ml_proof".

Require Import ZArith.
Require Import List.
Require Import FMapPositive.

Require Import generic.
Require Import matchinglreduction.
Require Import matchinglproofsystem.
Require Import matchinglpartialcorrectness.

Require Import domains.
Require Import model.

Import ImpLang.
Module Import ImpReduction := MatchLReduction ImpLang.
Module Import ImpProof := MatchLProofSystem ImpLang.
Module Import ImpCorrectness := MatchLPartialCorrectness ImpLang.

Import Base BaseF BaseM BaseS.

Import TermAbbrevs.

Require Import kstyle.

Set Implicit Arguments.

Open Scope k_scope.

Import TermAbbrevs.

Open Scope kt_scope.

Inductive Krules : Rule -> Prop :=
  (* lookup *)
  | r_lookup : forall x rest env, Krules
   (Pattern (KCfg (kra (KExp (EVar x)) rest) env),
    Pattern (KCfg (kra (KExp (ECon (Lookup env x))) rest) env))
  (* assign *)
  | r_assign : forall x i rest env, Krules
  (Pattern (KCfg (kra (KStmt (SAssign x (ECon i))) rest) env),
   Pattern (KCfg (kra (KStmt Skip) rest) (Update env x i)))
  (* plus *)
  | r_plus : forall i j rest env, Krules
  (Pattern (KCfg (kra (KExp (EPlus (ECon i) (ECon j))) rest) env),
   Pattern (KCfg (kra (KExp (ECon (PlusZ i j))) rest) env))
  (* div *)
  | r_div : forall i j rest env, Krules
  (And
    (Pattern (KCfg (kra (KExp (EDiv (ECon i) (ECon j))) rest) env))
    (Equals (Bool true) (Nez j)),
   Pattern (KCfg (kra (KExp (ECon (DivZ i j))) rest) env))
  (* le *)
  | r_le : forall i j rest env, Krules
  (Pattern (KCfg (kra (KBExp (BLe (ECon i) (ECon j))) rest) env),
   Pattern (KCfg (kra (KBExp (BCon (Zleb i j))) rest) env))
  (* and true *)
  | r_and_t : forall b rest env, Krules
  (Pattern (KCfg (kra (KBExp (BAnd (BCon (Bool true)) b)) rest) env),
   Pattern (KCfg (kra (KBExp b) rest) env))
  (* and false *)
  | r_and_f : forall b rest env,  Krules
  (Pattern (KCfg (kra (KBExp (BAnd (BCon (Bool false)) b)) rest) env),
   Pattern (KCfg (kra (KBExp (BCon (Bool false))) rest) env))
  | r_skip : forall rest env, Krules
  (* skip *)
  (Pattern (KCfg (kra (KStmt Skip) rest) env),
   Pattern (KCfg rest env))
  (* if true *)
  | r_if_t : forall s1 s2 rest env, Krules
  (Pattern (KCfg (kra (KStmt (SIf (BCon (Bool true)) s1 s2)) rest) env),
   Pattern (KCfg (kra (KStmt s1) rest) env))
  (* if false *)
  | r_if_f : forall s1 s2 rest env, Krules
  (Pattern (KCfg (kra (KStmt (SIf (BCon (Bool false)) s1 s2)) rest) env),
   Pattern (KCfg (kra (KStmt s2) rest) env))
  | r_while : forall b s rest env, Krules
  (Pattern (KCfg (kra (KStmt (SWhile b s)) rest) env),
   Pattern (KCfg (kra (KStmt (SIf b (Seq s (SWhile b s)) Skip)) rest) env))
  (* heating and cooling *)
  (* plus *)
  | r_heat_plus_l : forall e e2 rest env, Krules
  (And
    (Pattern (KCfg (kra (KExp (EPlus e e2)) rest) env))
    (Equals (Bool true) (negb (isEVal e))),
   Pattern (KCfg (kra (KExp e) (kra (KFreezer (□ + e2)) rest)) env))  | r_heat_plus_r : forall e e2 rest env, Krules
  (And
    (Pattern (KCfg (kra (KExp (EPlus e e2)) rest) env))
    (Equals (Bool true) (negb (isEVal e2))),
   Pattern (KCfg (kra (KExp e2) (kra (KFreezer (e + □)) rest)) env))
  | r_cool_plus_l : forall i e rest env, Krules
  (Pattern (KCfg (kra (KExp (ECon i)) (kra (KFreezer (□ + e)) rest)) env),
   Pattern (KCfg (kra (KExp (EPlus (ECon i) e)) rest) env))
  | r_cool_plus_r : forall i e rest env, Krules
  (Pattern (KCfg (kra (KExp (ECon i)) (kra (KFreezer (e + □)) rest)) env),
   Pattern (KCfg (kra (KExp (EPlus e (ECon i))) rest) env))
  (* div *)
  | r_heat_div_l : forall e e2 rest env, Krules
  (And
    (Pattern (KCfg (kra (KExp (EDiv e e2)) rest) env))
    (Equals (Bool true)(negb (isEVal e))),
   Pattern (KCfg (kra (KExp e) (kra (KFreezer (□ / e2)) rest)) env))
  | r_heat_div_r : forall e e2 rest env, Krules
  (And
    (Pattern (KCfg (kra (KExp (EDiv e e2)) rest) env))
    (Equals (Bool true) (negb (isEVal e2))),
   Pattern (KCfg (kra (KExp e2) (kra (KFreezer (e / □)) rest)) env))
  | r_cool_div_l : forall i e rest env, Krules
  (Pattern (KCfg (kra (KExp (ECon i)) (kra (KFreezer (□ / e)) rest)) env),
   Pattern (KCfg (kra (KExp (EDiv (ECon i) e)) rest) env))
  | r_cool_div_r : forall i e rest env, Krules
  (Pattern (KCfg (kra (KExp (ECon i)) (kra (KFreezer (e / □)) rest)) env),
   Pattern (KCfg (kra (KExp (EDiv e (ECon i))) rest) env))
  (* le is seqstrict *)
  | r_heat_le_l : forall e e2 rest env, Krules
  (And
    (Pattern (KCfg (kra (KBExp (BLe e e2)) rest) env))
    (Equals (Bool true) (negb (isEVal e))),
   Pattern (KCfg (kra (KExp e) (kra (KFreezer (□ <= e2)) rest)) env))
  | r_heat_le_r : forall i e2 rest env, Krules
  (And
    (Pattern (KCfg (kra (KBExp (BLe (ECon i) e2)) rest) env))
    (Equals (Bool true) (negb (isEVal e2))),
   Pattern (KCfg (kra (KExp e2) (kra (KFreezer (i <= □)) rest)) env))
  | r_cool_le_l : forall i e rest env, Krules
  (Pattern (KCfg (kra (KExp (ECon i)) (kra (KFreezer (□ <= e)) rest)) env),
   Pattern (KCfg (kra (KBExp (BLe (ECon i) e)) rest) env))
  | r_cool_le_r : forall j i rest env, Krules
  (Pattern (KCfg (kra (KExp (ECon j)) (kra (KFreezer (i <= □)) rest)) env),
   Pattern (KCfg (kra (KBExp (BLe (ECon i) (ECon j))) rest) env))
  (* and only left-strict *)
  | r_heat_and : forall b1 b2 rest env, Krules
  (And
    (Pattern (KCfg (kra (KBExp (BAnd b1 b2)) rest) env))
    (Equals (Bool true) (negb (isBool b1))),
   Pattern (KCfg (kra (KBExp b1) (kra (KFreezer (□ && b2)) rest)) env))
  | r_cool_and : forall b b2 rest env, Krules
  (Pattern (KCfg (kra (KBExp (BCon b)) (kra (KFreezer (□ && b2)) rest)) env),
   Pattern (KCfg (kra (KBExp (BAnd (BCon b) b2)) rest) env))
  (* assign *)
  | r_heat_assign : forall x e rest env, Krules
  (And
    (Pattern (KCfg (kra (KStmt (SAssign x e)) rest) env))
    (Equals (Bool true) (negb (isEVal e))),
   Pattern (KCfg (kra (KExp e) (kra (KFreezer (x :=□)) rest)) env))
  | r_cool_assign : forall i x rest env, Krules
  (Pattern (KCfg (kra (KExp (ECon i)) (kra (KFreezer (x :=□)) rest)) env),
   Pattern (KCfg (kra (KStmt (SAssign x (ECon i))) rest) env))
  (* if *)
  | r_heat_if : forall b s1 s2 rest env, Krules
  (And
    (Pattern (KCfg (kra (KStmt (SIf b s1 s2)) rest) env))
    (Equals (Bool true) (negb (isBool b))),
   Pattern (KCfg (kra (KBExp b) (kra (KFreezer (if□then s1 else s2)) rest)) env))
  | r_cool_if : forall b s1 s2 rest env, Krules
  (Pattern (KCfg (kra (KBExp (BCon b)) (kra (KFreezer (if□then s1 else s2)) rest)) env),
   Pattern (KCfg (kra (KStmt (SIf (BCon b) s1 s2)) rest) env))
  (* seq *)
  | r_heat_seq : forall s1 s2 rest env, Krules
  (Pattern (KCfg (kra (KStmt (Seq s1 s2)) rest) env),
   Pattern (KCfg (kra (KStmt s1) (kra (KStmt s2) rest)) env))
  .

Local Open Scope positive_scope.
Definition Ev := 1.
Definition envv := 2.
Definition xv := 3.
Definition yv := 4.
Definition bv := 5.
Definition rv := 6.
Definition iv := 7.
Definition jv := 8.
Definition sv := 9.
Definition s1v := 10.
Definition s2v := 11.
Definition env'v := 12.

Definition E := TMVar Ev.
Definition env := TMVar envv.
Definition x := TMVar xv.
Definition y := TMVar yv.
Definition b := TMVar bv.
Definition r := TMVar rv.
Definition i := TMVar iv.
Definition j := TMVar jv.
Definition s := TMVar sv.
Definition s1 := TMVar s1v.
Definition s2 := TMVar s2v.
Definition env' := TMVar env'v.

Definition pvi : T := Id (domains.var 1).
Definition pvj : T := Id (domains.var 2).

(* Plan: add sort predicates like IsVar, etc,
  prove lemmas relating them to environment structure -
  and use the add x (find x m) m == m to put results in
  nice form. Then validity is nice and simple.
  *)

Definition hasSort s (result : option M) :=
  match result with
    | Some gamma => s = projT1 gamma
    | None => False
  end.

Fixpoint haveSorts ss rs {struct ss} :=
  match ss, rs with
    | nil, nil => True
    | s :: ss', res :: rs' => hasSort s res /\ haveSorts ss' rs'
    | _, _ => False
  end.

Lemma vinit' gamma s args vals op :
  Some gamma = opapply s args vals op ->
  hasSort s (opapply s args vals op).
Proof.
  revert vals; induction args; destruct vals; simpl;[congruence..|].
  destruct o as [[xs xv]|];
  [destruct (ImpLabels.sort_dec a xs);[destruct e|]|];
  [auto|congruence..].
Qed.

Lemma vinit gamma l args :
  Some gamma = lapply l args ->
    hasSort (projT1 (projT2 (label_sem l))) (lapply l args).
Proof.
  unfold lapply, ImpLabels.label_sem.
  destruct (label_sem l) as [arg [res op]].
  apply vinit'.
Qed.

Lemma vbreak s args vals op :
  hasSort s (opapply s args vals op) ->
  haveSorts args vals.
Proof.
  revert vals; induction args; destruct vals; simpl; trivial.
  destruct o as [[vs vv]|].
  destruct (ImpLabels.sort_dec a vs).
  destruct e.
  simpl. specialize (IHargs (op vv) vals). intuition.
  destruct 1.
  destruct 1.
Qed.

Lemma valid_refl : forall f,
  Valid (Implies f f).
Proof.
  unfold Valid, Satisfies. simpl. trivial.
Qed.

Lemma valid_add : forall f g,
  (Valid (Implies f g)) ->
  Valid (Implies f (And f g)).
Proof.
  unfold Valid, Satisfies. simpl. intuition.
Qed.

Lemma alf (Sys : System) pre cond post:
  Sys (And pre cond,post) ->
  forall psi, patternless psi ->
  Valid (Implies (And pre psi) cond) ->
  forall strict,
  PS strict Sys (And pre psi) (And post psi).
Proof.
  intros.
  apply ps_conseq
    with (phi1':=And (And pre cond) psi)(phi2':=(And post psi)).
  revert H1. unfold Valid, Satisfies. simpl. intuition.

  apply ps_lf. apply ps_axiom. auto.

  assumption.

  apply valid_refl.
Qed.
Implicit Arguments alf [Sys pre cond post psi strict].

Lemma conseq_l : forall phi1 phi1',
  Valid (Implies phi1 phi1') ->
  forall phi2 Sys strict,
  PS strict Sys phi1' phi2 -> PS strict Sys phi1 phi2.
Proof.
  intros. eauto using ps_conseq, valid_refl.
Qed.

(* Tactics for execution *)
Ltac valid_dec := subst;unfold Valid, Satisfies; intros; simpl; intuition.
Hint Unfold cons_System.
Hint Extern 5 (Valid _) => valid_dec.
Hint Extern 3 (patternless _) => (simpl;tauto).

Ltac unabbrev :=
  repeat match goal with
    [ T : Term positive , teq : ?T = _ |- _] =>
    rewrite teq
  end.
Ltac reabbrev :=
  repeat match goal with
    [ T : Term positive , teq : ?T = _ |- _] =>
    rewrite <- teq
  end.

Ltac step :=
eapply ps_trans;[solve[eauto 20 using ps_axiom,ps_lf,alf,Krules]|].

Ltac run := unabbrev;repeat step;instantiate;reabbrev.

(*
Lemma use_has
match PositiveMap.find envv rho with
       | Some gamma => sStore = projT1 gamma
       | None => False
       end
 *)

Lemma domain_reasoning_1
  (loopTest : Term positive)
  (HeqloopTest : loopTest = BLe (ECon (Val 1)) (EVar pvi))
  (loopBody : Term positive)
  (HeqloopBody : loopBody =
                Seq (SAssign pvi (EPlus (EVar pvi) (ECon (Val (-1)))))
                  (SAssign pvj (EPlus (EVar pvj) (ECon (Val 1))))) :
   Valid
     (Implies
(And
           (And
              (Pattern
                 (KCfg
                    (kra
                       (KStmt
                          (SIf
                             (BCon
                                (Zleb (Val 1)
                                   (Lookup (Update (Update env pvi x) pvj y)
                                      pvi)))
                             (Seq loopBody (SWhile loopTest loopBody)) Skip))
                       kdot) (Update (Update env pvi x) pvj y)))
              (And (And (HasSort sVal x) (HasSort sVal y))
                 (HasSort sStore env))) (Equals (Bool true) (Zleb (Val 0) x)))

        (Or
           (And
              (And
                 (Pattern
                    (KCfg
                       (kra
                          (KStmt
                             (SIf (BCon (Bool true))
                                (Seq loopBody (SWhile loopTest loopBody))
                                Skip)) kdot)
                       (Update (Update env pvi x) pvj y)))
                 (And (And (HasSort sVal x) (HasSort sVal y))
                    (HasSort sStore env)))
              (Equals (Bool true) (Zleb (Val 0) (PlusZ x (Val (-1))))))
           (Pattern
              (KCfg
                 (kra
                    (KStmt
                       (SIf (BCon (Bool false))
                          (Seq loopBody (SWhile loopTest loopBody)) Skip))
                    kdot) (Update (Update env pvi (Val 0)) pvj (PlusZ x y)))))).

Opaque PositiveMap.find.
Opaque PositiveMap.add.
subst;unfold Valid, Satisfies; intros; simpl; intuition.
repeat
(match goal with
  | [H : exists v, PositiveMap.find _ _ = Some (existT _ _ _)
    |- _] => let v := fresh v in let Hlookup := fresh Hlookup in
             destruct H as [v Hlookup];rewrite Hlookup in * |- *
  end).
cbv [lapply ImpLabels.label_sem label_sem label projT1 projT2 eq_rec eq_rect] in H.
simpl in * |- *.

rewrite PositiveMap.gso in H by discriminate.
rewrite PositiveMap.gss in H.
remember (Zle_bool 1 v0) as bresult in H.
pose proof (Zle_cases 1%Z v0) as Hle.
rewrite <- Heqbresult in Hle.
destruct bresult;[left|right].

(* need to continue, just show tidying *)
unfold lapply;simpl;intuition.
eauto.
eauto.
eauto.

clear -Hle.
repeat apply f_equal.
symmetry.
apply Zle_imp_le_bool.
omega.

(* preparing to stop *)
Lemma some_inj (A : Set) (x y : A) :
  Some x = Some y -> x = y.
Proof.
  injection 1; trivial.
Qed.
assert (v0 = 0%Z).
clear -H1 Hle.
unfold lapply in H1; simpl in H1.

Lemma M_inj (s : Sort) (x y : sort_sem s) :
  existT _ s x = existT _ s y -> x = y.
Proof.
  apply Eqdep_dec.inj_pair2_eq_dec; exact sort_dec.
Qed.
apply M_inj in H1.
symmetry in H1.
apply Zle_bool_imp_le in H1.
omega.
subst.
assumption.
(* adjustement done *)

Qed.

Lemma domain_reasoning_2 : forall
  (loopTest : Term positive)
  (HeqloopTest : loopTest = BLe (ECon (Val 1)) (EVar pvi))
  (loopBody : Term positive)
  (HeqloopBody : loopBody =
                Seq (SAssign pvi (EPlus (EVar pvi) (ECon (Val (-1)))))
                  (SAssign pvj (EPlus (EVar pvj) (ECon (Val 1))))),
   Valid
     (Implies
        (And
           (And
              (Pattern
                 (KCfg (kra (KStmt (SWhile loopTest loopBody)) kdot)
                    (Update
                       (Update (Update (Update env pvi x) pvj y) pvi
                          (PlusZ
                             (Lookup (Update (Update env pvi x) pvj y) pvi)
                             (Val (-1)))) pvj
                       (PlusZ
                          (Lookup
                             (Update (Update (Update env pvi x) pvj y) pvi
                                (PlusZ
                                   (Lookup (Update (Update env pvi x) pvj y)
                                      pvi) (Val (-1)))) pvj)
                          (Val 1)))))
              (And (And (HasSort sVal x) (HasSort sVal y))
                 (HasSort sStore env)))
           (Equals (Bool true) (Zleb (Val 0) (PlusZ x (Val (-1))))))
        (ApplyF
           (PositiveMap.add xv (PlusZ x (Val (-1)))
              (PositiveMap.add yv (PlusZ y (Val 1))
                 (PositiveMap.empty (Term positive))))
           (And
              (And
                 (Pattern
                    (KCfg (kra (KStmt (SWhile loopTest loopBody)) kdot)
                       (Update (Update env pvi x) pvj y)))
                 (And (And (HasSort sVal x) (HasSort sVal y))
                    (HasSort sStore env)))
              (Equals (Bool true) (Zleb (Val 0) x))))).
Proof.
intros; subst.
simpl.
valid_dec.
unfold ImpLang.app_var in * |- *.
repeat ((rewrite PositiveMap.gso in * |- * by discriminate)
  || rewrite PositiveMap.gss in * |- *
  || rewrite PositiveMap.gempty in * |- *).
simpl in * |- *.
repeat
(match goal with
  | [H : exists v, PositiveMap.find _ _ = Some (existT _ _ _)
    |- _] => let v := fresh v in let Hlookup := fresh Hlookup in
             destruct H as [v Hlookup];rewrite Hlookup in * |- *
  end).

unfold lapply in H;simpl in H.
apply some_inj in H.
subst gamma.
unfold lapply;simpl.
apply f_equal.
apply f_equal.
apply f_equal.
repeat ((rewrite PositiveMap.gso by discriminate) || rewrite PositiveMap.gss || rewrite PositiveMap.gempty).
Transparent PositiveMap.add.
destruct v1;[|destruct v1_1];reflexivity.
Opaque PositiveMap.add.

destruct H2. exists (x0 - 1)%Z.
unfold inTerm, value', Apply', ImpLang.app_var;simpl.
repeat ((rewrite PositiveMap.gso by discriminate) || rewrite PositiveMap.gss || rewrite PositiveMap.gempty).
simpl. rewrite H0. reflexivity.

destruct H4. exists (x0 + 1)%Z.
unfold inTerm, value', Apply', ImpLang.app_var;simpl.
repeat ((rewrite PositiveMap.gso by discriminate) || rewrite PositiveMap.gss || rewrite PositiveMap.gempty).
simpl. rewrite H0. reflexivity.
Qed.

Lemma domain_reasoning_3 : forall
  (loopTest : Term positive)
  (HeqloopTest : loopTest = BLe (ECon (Val 1)) (EVar pvi))
  (loopBody : Term positive)
  (HeqloopBody : loopBody =
                Seq (SAssign pvi (EPlus (EVar pvi) (ECon (Val (-1)))))
                  (SAssign pvj (EPlus (EVar pvj) (ECon (Val 1))))),
   Valid
     (Implies
        (ApplyF
           (PositiveMap.add xv (PlusZ x (Val (-1)))
              (PositiveMap.add yv (PlusZ y (Val 1))
                 (PositiveMap.empty (Term positive))))
           (Pattern
              (KCfg kdot (Update (Update env pvi (Val 0)) pvj (PlusZ x y)))))
        (Pattern
           (KCfg kdot (Update (Update env pvi (Val 0)) pvj (PlusZ x y))))).

intros.
simpl.
unfold Apply', ImpLang.app_var.
simpl.
repeat ((rewrite PositiveMap.gso by discriminate) || rewrite PositiveMap.gss || rewrite PositiveMap.gempty).
valid_dec.

destruct (PositiveMap.find envv rho) as [[[]]|];try discriminate H.
destruct (PositiveMap.find xv rho) as [[[]]|];try discriminate H.
destruct (PositiveMap.find yv rho) as [[[]]|];try discriminate H.

unfold lapply in * |- *; simpl in * |- *.
apply some_inj in H. subst.
replace (s3 + -1 + (s4 + 1))%Z with (s3 + s4)%Z.
reflexivity.
ring.
Qed.

Lemma sum : PS true Krules
  (And
    (Pattern (KCfg
      (kra
        (KStmt
          (SWhile (BLe (ECon (Val 1%Z)) (EVar pvi))
            (Seq
              (SAssign pvi (EPlus (EVar pvi) (ECon (Val (-1)%Z))))
              (SAssign pvj (EPlus (EVar pvj) (ECon (Val 1%Z)))))))
        kdot)
    (Update (Update env pvi x) pvj y)))
  (Equals (Bool true) (Zleb (Val 0%Z) x)))
  (Pattern (KCfg kdot
    (Update (Update env pvi (Val 0%Z))
      pvj (PlusZ x y)))).
Proof.

remember (BLe (ECon (Val 1)) (EVar pvi)) as loopTest.
remember (Seq (SAssign pvi (EPlus (EVar pvi) (ECon (Val (-1)))))
              (SAssign pvj (EPlus (EVar pvj) (ECon (Val 1)))))
  as loopBody.

apply conseq_l with
  (phi1' :=
    (And
      (And (Pattern
        (KCfg (kra (KStmt (SWhile loopTest loopBody)) kdot)
          (Update (Update env pvi x) pvj y)))
      (And (And (HasSort sVal x) (HasSort sVal y)) (HasSort sStore env)))
      (Equals (Bool true) (Zleb (Val 0) x)))).

subst; unfold Valid, Satisfies; intros.
Opaque PositiveMap.find.
Opaque PositiveMap.add.
simpl. intros.
cbv [lapply ImpLabels.label_sem label_sem label projT1 projT2 eq_rec eq_rect] in H.
destruct H.
destruct (PositiveMap.find xv rho) as [[[]]|];try (discriminate H0);
destruct (PositiveMap.find envv rho) as [[[]]|];try (discriminate H);
destruct (PositiveMap.find yv rho) as [[[]]|];try (discriminate H);
simpl in H.
intuition eauto.
(* That took a while, but now we have know sorts of variables *)

eapply ps_circ.

run; auto using ps_refl.

eapply conseq_l.
eauto using domain_reasoning_1.

apply ps_case.

let n := 19 in
unabbrev;do n step;instantiate;reabbrev.

(* ready to use the circular assumption, but will
   need to subst to expand x/y *)

eapply ps_conseq.
Focus 2.
eapply ps_subst.
apply ps_axiom; left; reflexivity.
instantiate (1:=
  PositiveMap.add xv (PlusZ x (Val (-1)%Z))
  (PositiveMap.add yv (PlusZ y (Val 1%Z))
    (PositiveMap.empty _))).

eauto using domain_reasoning_2.
eauto using domain_reasoning_3.

run; auto using ps_refl.
Qed.


Require Coq.Structures.Equalities.
Require Coq.FSets.FSetAVL.
Require Coq.FSets.FSetWeakList.
Require Coq.FSets.FMapFacts.
Require Coq.Lists.List.

Require Genevan.ProtoIdentifier.
Require Genevan.ProtoName.
Require Genevan.ListExts.
Require Genevan.ProtoPeer.Peer.
Require Genevan.ProtoPeer.CollectionT.

(** A concrete implementation of the _CollectionT_ interface. *)

Module Make (P : Peer.T) (S : Peer.SetsT P) : CollectionT.S P S.

  Module F := FSetFacts.WFacts S.

  Definition setsHaveName
    (s : S.t)
    (n : ProtoName.t)
  : Prop :=
    S.For_all (fun h => ProtoIdentifier.name (P.supports h) = n) s.

  Theorem setsHaveNameAdd : forall s n e,
    setsHaveName s n ->
      ProtoIdentifier.name (P.supports e) = n ->
        setsHaveName (S.add e s) n.
  Proof.
    intros s n e H_before H_nameEq.
    unfold setsHaveName in *.
    unfold S.For_all in *.
    intros f H_inF.
    rewrite F.add_iff in H_inF.
    destruct H_inF as [HL|HR]. {
      rewrite HL in *.
      exact H_nameEq.
    } {
      apply (H_before _ HR).
    }
  Qed.

  Theorem setsHaveNameSingleton : forall e,
    setsHaveName (S.singleton e) (ProtoIdentifier.name (P.supports e)).
  Proof.
    intros e.
    unfold setsHaveName in *.
    unfold S.For_all in *.
    intros f H_inF.
    rewrite F.singleton_iff in H_inF.
    rewrite H_inF in *.
    reflexivity.
  Qed.

  Definition setsNonEmpty (s : S.t) : Prop :=
    ~S.Empty s.

  Definition setsWF
    (s : S.t)
    (n : ProtoName.t)
  : Prop :=
    (setsHaveName s n) /\ setsNonEmpty s.

  Module ByName      := ProtoName.Maps.
  Module ByNameFacts := ProtoName.MapsFacts.

  Definition mapSetsNonEmpty (m : ByName.t S.t) : Prop :=
    forall s n, ByName.MapsTo n s m -> setsNonEmpty s.

  Definition mapSetsHaveNames (m : ByName.t S.t) : Prop :=
    forall s n, ByName.MapsTo n s m -> setsHaveName s n.

  Definition mapSetsWF (m : ByName.t S.t) : Prop :=
    mapSetsNonEmpty m /\ mapSetsHaveNames m.

  Definition mapIn (e : P.t) (m : ByName.t S.t) : Prop :=
    exists s, ByName.MapsTo (ProtoIdentifier.name (P.supports e)) s m /\ S.In e s.

  Definition addPeer
    (e : P.t)
    (m : ByName.t S.t)
  : ByName.t S.t :=
    let name := ProtoIdentifier.name (P.supports e) in
      match ByName.find name m with
      | Some existingEndpoints => ByName.add name (S.add e existingEndpoints) m
      | None                   => ByName.add name (S.singleton e) m
      end.

  Theorem addPeerSetsNonEmpty : forall m e,
    mapSetsNonEmpty m -> mapSetsNonEmpty (addPeer e m).
  Proof.
    intros m e.
    intros H_correctB.
    intros sAfter n H_mapsA.

    unfold mapSetsNonEmpty in *.
    unfold setsNonEmpty in *.
    unfold addPeer in H_mapsA.

    remember (ProtoIdentifier.name (P.supports e)) as e_name.

    destruct (ByName.find e_name m) as [sBefore|] eqn:H_find. {
      rewrite <- ByNameFacts.find_mapsto_iff in H_find.
      rewrite ByNameFacts.add_mapsto_iff in H_mapsA.
      destruct H_mapsA as [[H0L H0R]|[H1L H1R]]. {
        assert (S.In e (S.add e sBefore)) as H_in
          by (apply S.add_1; reflexivity).
        rewrite H0R in H_in.
        unfold S.Empty.
        unfold not; intro H_contra.
        apply (H_contra e H_in).
      } {
        apply (H_correctB _ _ H1R).
      }
    } {
      rewrite ByNameFacts.add_mapsto_iff in H_mapsA.
      destruct H_mapsA as [[H0L H0R]|[H1L H1R]]. {
        assert (S.In e (S.singleton e)) as H_in
          by (apply S.singleton_2; reflexivity).
        rewrite H0R in H_in.
        unfold S.Empty.
        unfold not; intro H_contra.
        apply (H_contra e H_in).
      } {
        apply (H_correctB _ _ H1R).
      }
    }
  Qed.

  Theorem addPeerSetsHaveName : forall m e,
    mapSetsHaveNames m -> mapSetsHaveNames (addPeer e m).
  Proof.
    intros m e.
    intros H_correctB.
    intros sAfter n H_mapsA.
    unfold addPeer in H_mapsA.

    remember (ProtoIdentifier.name (P.supports e)) as e_name.

    destruct (ByName.find e_name m) as [sBefore|] eqn:H_find. {
      rewrite <- ByNameFacts.find_mapsto_iff in H_find.
      rewrite ByNameFacts.add_mapsto_iff in H_mapsA.
      destruct H_mapsA as [[H0L H0R]|[H1L H1R]]. {
        unfold mapSetsHaveNames in H_correctB.
        pose proof (H_correctB _ _ H_find) as H_namesBefore.
        rewrite <- H0R.
        apply setsHaveNameAdd.
        rewrite <- H0L.
        exact H_namesBefore.
        rewrite <- Heqe_name.
        rewrite H0L.
        reflexivity.
      } {
        apply (H_correctB _ _ H1R).
      }
    } {
      rewrite ByNameFacts.add_mapsto_iff in H_mapsA.
      destruct H_mapsA as [[H0L H0R]|[H1L H1R]]. {
        rewrite <- H0R.
        rewrite <- H0L.
        rewrite Heqe_name.
        apply setsHaveNameSingleton.
      } {
        apply (H_correctB _ _ H1R).
      }
    }
  Qed.

  Theorem addPeerIn : forall m e,
    mapIn e (addPeer e m).
  Proof.
    intros m e.
    unfold mapIn.
    unfold addPeer.
    remember (ProtoIdentifier.name (P.supports e)) as e_name.

    destruct (ByName.find e_name m) as [sBefore|] eqn:H_find. {
      rewrite <- ByNameFacts.find_mapsto_iff in H_find.
      exists (S.add e sBefore).
      rewrite ByNameFacts.add_mapsto_iff.
      constructor. {
        left; constructor; reflexivity.
      } {
        apply S.add_1; reflexivity.
      }
    } {
      exists (S.singleton e).
      rewrite ByNameFacts.add_mapsto_iff.
      constructor. {
        left; constructor; reflexivity.
      } {
        apply S.singleton_2; reflexivity.
      }
    }
  Qed.

  Theorem addPeerInPreserve : forall m e f,
    mapIn f m -> mapIn f (addPeer e m).
  Proof.
    intros m e f H_fIn.
    remember (ProtoIdentifier.name (P.supports f)) as f_name.
    remember (ProtoIdentifier.name (P.supports e)) as e_name.

    destruct (P.eq_dec e f) as [H_efEq|H_efNeq]. {
      subst f.
      apply addPeerIn.
    } {
      destruct (String.string_dec e_name f_name) as [H_efnEq|H_efnNeq]. {
        unfold mapIn in *.
        unfold addPeer.
        rewrite <- Heqf_name in *.
        rewrite <- Heqe_name in *.
        rewrite <- H_efnEq in *.
        destruct (ByName.find e_name m) as [sBefore|] eqn:H_find. {
          rewrite <- ByNameFacts.find_mapsto_iff in H_find.
          destruct H_fIn as [sx [H_sx0 H_sx1]].
          pose proof (ProtoName.MapsFacts.MapsTo_fun H_find H_sx0) as H_same.
          subst sx.
          exists (S.add e sBefore).
          constructor. {
            rewrite ProtoName.MapsFacts.add_mapsto_iff.
            constructor. {
              constructor; reflexivity.
            }
          } {
            apply S.add_2.
            exact H_sx1.
          }
        } {
          destruct H_fIn as [sx [H_sx0 H_sx1]].
          pose proof (ProtoName.Maps.find_1 H_sx0) as H_contra.
          rewrite H_find in H_contra.
          inversion H_contra.
        }
      } {
        unfold mapIn in *.
        unfold addPeer.
        rewrite <- Heqf_name in *.
        rewrite <- Heqe_name in *.
        destruct H_fIn as [sx [H_sx0 H_sx1]].
        exists sx.

        constructor. {
          destruct (ByName.find e_name m) as [sBefore|] eqn:H_find. {
            apply ProtoName.Maps.add_2.
            exact H_efnNeq.
            exact H_sx0.
          } {
            apply ProtoName.Maps.add_2.
            exact H_efnNeq.
            exact H_sx0.
          }
        } {
          exact H_sx1.
        }
      }
    }
  Qed.

  Theorem addPeerSetsWF : forall m e,
    mapSetsWF m -> mapSetsWF (addPeer e m).
  Proof.
    intros m e H_correctB.
    destruct H_correctB as [Hc0 Hc1].

    constructor. {
      apply (addPeerSetsNonEmpty m e).
      exact Hc0.
    } {
      apply (addPeerSetsHaveName m e).
      exact Hc1.
    }
  Qed.

  Theorem addPeerSetsWFEmpty : mapSetsWF (ByName.empty S.t).
  Proof.
    constructor;
    (hnf; intros; rewrite ByNameFacts.empty_mapsto_iff in *; contradiction).
  Qed.

  Definition addPeers (peers : list P.t) : ByName.t S.t :=
    List.fold_right addPeer (ByName.empty S.t) peers.

  Theorem addPeersWF : forall es,
    mapSetsWF (addPeers es).
  Proof.
    induction es as [|e e_rest]. {
      apply addPeerSetsWFEmpty.
    } {
      apply (addPeerSetsWF _ e IHe_rest).
    }
  Qed.

  Theorem addPeersIn : forall es e,
    List.In e es -> mapIn e (addPeers es).
  Proof.
    induction es as [|f fs]. {
      intros e H_in.
      inversion H_in.
    } {
      intros x H_inx.
      simpl.
      destruct H_inx as [H_inL|H_inR]. {
        subst x.
        apply addPeerIn.
      } {
        pose proof (IHfs x H_inR) as H_mInX.
        apply addPeerInPreserve.
        exact H_mInX.
      }
    }
  Qed.

  Definition collect := addPeers.

End Make.


(* Test parsing/interpretation/pretyping on a large example *)
(* Expected time < 0.10s *)

(* Complexity of unification used to be exponential in the number of nested
   constants, as pointed out by Georges Gonthier and Nicolas Tabareau (a.o.)

   The problem is that unification of id^n+1(0) and id^n+1(1) proceeds as:
   - try not unfold the outermost id by trying to unify its arguments:
     1st rec. call on id^n(0) id^n(1), which fails
   - Coq then tries to unfold id^n+1(k) which produces id^n(k)
   - 2nd rec. call on id^n(0) id^n(1), which also fails
   Complexity is thus at least exponential.

   This is fixed (in the ground case), by the fact that when we try to
   unify two ground terms (ie. without unsolved evars), we call kernel
   conversion and if this fails, then the terms are not unifiable.
   Hopefully, kernel conversion is not exponential on cases like the one
   below thanks to sharing (as long as unfolding the fonction does not
   use its argument under a binder).

   There are probably still many cases where unification goes astray.
 *)

Definition id (n:nat) := n.
Goal
  (id (id (id (id
  (id (id (id (id
  (id (id (id (id
  (id (id (id (id
  (id (id (id (id
   0
   ))))
   ))))
   ))))
   ))))
   ))))
   =
  (id (id (id (id
  (id (id (id (id
  (id (id (id (id
  (id (id (id (id
  (id (id (id (id
   1
   ))))
   ))))
   ))))
   ))))
   ))))
.
Timeout 2 Time try refine (refl_equal _).


Load GradVer21Determ.
Import Semantics.

Require Import Coq.Logic.Classical_Pred_Type.

Definition PLIFTm1 (f : phi -> phi) : (pphi -> pphi) :=
  fun pp1 => fun p2 => exists p1, pp1 p1 /\ f p1 = p2.
Definition PLIFTp1 (f : phi -> phi -> Prop) : (pphi -> pphi) :=
  fun pp1 => fun p2 => exists p1, pp1 p1 /\ f p1 p2.
Definition PLIFTp3 (f : phi -> phi -> phi -> phi -> Prop) : (pphi -> pphi -> pphi -> pphi) :=
  fun pp1 pp2 pp3 => fun px => exists p1 p2 p3, pp1 p1 /\ pp2 p2 /\ pp3 p3 /\ f p1 p2 p3 px.
Definition GLIFTmp1 (f : phi -> phi) (gf : gphi -> gphi -> Prop) : Prop :=
  forall gp1 gp2 pp gp2',
  gGamma gp1 pp ->
  gAlpha (PLIFTm1 f pp) gp2 ->
  gf gp1 gp2' ->
  gphiEquals gp2' gp2.
Definition GLIFTm1 (f : phi -> phi) (gf : gphi -> gphi) : Prop :=
  forall gp1 gp2 pp,
  gGamma gp1 pp ->
  gAlpha (PLIFTm1 f pp) gp2 ->
  gphiEquals (gf gp1) gp2.
Definition GLIFTpp1 (f : phi -> phi -> Prop) (gf : gphi -> gphi -> Prop) : Prop :=
  forall gp1 gp2 pp gp2',
  gGamma gp1 pp ->
  gAlpha (PLIFTp1 f pp) gp2 ->
  gf gp1 gp2' ->
  gphiEquals gp2' gp2.
Definition GLIFTpp1x (f : phi -> phi -> Prop) (gf : gphi -> gphi -> Prop) : Prop :=
  forall gp1 gp2 pp,
  gGamma gp1 pp ->
  gf gp1 gp2 ->
  gAlpha (PLIFTp1 f pp) gp2.
Definition GLIFTpp3 (f : phi -> phi -> phi -> phi -> Prop) (gf : gphi -> gphi -> gphi -> gphi -> Prop) : Prop :=
  forall gp1 gp2 gp3 gpx pp1 pp2 pp3 gpx',
  gGamma gp1 pp1 ->
  gGamma gp2 pp2 ->
  gGamma gp3 pp3 ->
  gAlpha (PLIFTp3 f pp1 pp2 pp3) gpx ->
  gf gp1 gp2 gp3 gpx' ->
  gphiEquals gpx' gpx.

(* (* monotonic function with respect to phiImplies *)
Definition pmFun (f : phi -> phi -> Prop) : Prop :=
  forall x1 y1 x2 y2,
    f x1 y1 ->
    f x2 y2 ->
    phiImplies x1 x2 ->
    phiImplies y1 y2. *)

(* monotonic function with respect to phiImplies *)
Definition pmFun (f : phi -> phi -> Prop) : Prop :=
  forall x1 y1 x2 y2,
    f x1 y1 ->
    f x2 y2 ->
    phiImplies x1 x2 ->
    phiImplies y1 y2.

(* special condition *)
Definition gFun (f : phi -> phi -> Prop) : Prop :=
  forall pa pb pc, f pb pc ->
  forall p1, gGamma' (pa, pc) p1 ->
  exists p2
         p3, gGamma' (pa, pb) p2 /\
             f p2 p3 /\
             phiImplies p1 p3.

(* determinism, goodness transfer, sanity, ... *)
Definition goodFun (f : phi -> phi -> Prop) : Prop :=
  (forall x y,
    f x y ->
    good x ->
    good y)
  /\
  (forall x y1 y2,
    f x y1 ->
    f x y2 ->
    y1 = y2).

Definition liftable (f : phi -> phi -> Prop) : Prop :=
  goodFun f /\
  pmFun f /\
  gFun f.

Lemma liftableTrans : forall f1 f2,
  liftable f1 ->
  liftable f2 ->
  liftable (fun x1 x3 => exists x2, f1 x1 x2 /\ f2 x2 x3).
Proof.
  unfold liftable.
  intros. unf.
  split.
    unfold goodFun in *. unf.
    split.
      intros. unf.
      eapply H2 in H10; eauto.
    intros. unf.
    assert (x0 = x1). eapp H6.
    subst. eapp H7.
  split.
    unfold pmFun in *.
    intros. unf.
    eapply H0; eauto.
  unfold gFun in *.
  intros. unf.
  assert (H8' := H8).
  eapply H3 in H8; eauto. unf.
  assert (H4' := H4).
  eapply H5 in H4; eauto. unf.
  destruct pa.
  - inv H7. inv H9. inv H6. simpl in *.
    unfold gGamma'. simpl.
    exists pb.
    exists pc.
    splau.
    splau.
    admit.
  - inv H7. inv H9. inv H6. simpl in *.
    assert (pc = x1). eapp H1. subst.
    assert (x = x3). eapp H2. subst.
    exists pb.
    exists x1.
    cut.
Admitted.

Definition simpleLift (f : phi -> phi -> Prop) : (gphi -> gphi -> Prop) :=
  fun gp1 gp2 =>
    gGood gp1 /\
    gGood gp2 /\
    fst gp1 = fst gp2 /\
    f (snd gp1) (snd gp2).

(* liftable functions are in fact simply liftable *)
Lemma GLIFT_liftable : forall f,
  goodFun f ->
  pmFun f ->
  gFun f ->
  GLIFTpp1x f (simpleLift f).
Proof.
  unfold GLIFTpp1x, PLIFTp1,
    simpleLift, pmFun, goodFun, gFun.
  intros.

  destruct gp1, gp2. simpl in *.
  unf. subst.

  rename H4 into go0.
  rename H3 into go1.
  rename H2 into ga.
  rename H0 into mon.
  rename H1 into mag.
  rename H6 into goF.
  rename H8 into det.
  rename H7 into ff.
  inv ga.
  clear H.

  constructor.
  - constructor.
    * assert (exists x, gGamma' (b0, p1) x) as ee.
        unfold gGamma'. simpl.
        destruct b0.
          inv go1. apply hasWellFormedSubtype in H. unf.
          exists x. splau. eca.
        eex.
      invE ee xx.
      eapply (mag b0) in ff; eauto.
      unf.
      exists x0.
      exists x.
      tauto.
    * intros. unf.
      apply goF in H1; auto.
      unfold gGamma' in *.
      destruct b0; simpl in *; cut.
      subst.
      inv go0.
      split. apply H.
      inv H0; cut.
  - assumption.
  - repeat intro. unf.
    unfold gGamma' in *.
    destruct b0; simpl in *.
    * unf.
      eapply mon in H2; eauto.
    * subst.
      eapp det.
  - unfold pincl in *.
    intros.
    assert (ffx := ff).
    eapply mag in ff; eauto. unf.
    assert (gGamma' gp' x0).
      apply H0.
      eex.
    destruct gp'.
    unfold gGamma' in *. simpl in *.
    destruct b, b0; unf; subst.
    * splau.
      eapp (phiImpliesTrans p2 x0 p3).
    * assert (x0 = p1).
        eapp det. subst.
      splau.
    * admit. (*contradictory*)
    * eapp det.
Admitted.

Definition liftableImplies (p : phi) (p1 p2 : phi) : Prop :=
  p1 = p2 /\
  phiImplies p1 p.

Theorem liftableImplies_ : forall p, liftable (liftableImplies p).
Proof.
  split.
    split; intros.
      inv H. assumption.
    inv H. inv H0. congruence.
  split.
    unfold pmFun. intros.
    inv H. inv H0.
    assumption.
  unfold gFun. intros.
  inv H.
  exists p1.
  exists p1.
  splau.
  splau.
  splau.
  eapp (phiImpliesTrans p1 pc p0).
  unfold gGamma' in *. simpl in *.
  destruct pa; unf; cut.
Qed.

Definition liftableAppend (p : phi) (p1 p2 : phi) : Prop :=
  p2 = p1 ++ p /\
  (good p1 -> good (p1 ++ p)) /\
  (forall p'',(good p'' /\ phiImplies p'' (p1 ++ p)) ->
   exists p' , good p'  /\ phiImplies p'  (p1) /\ phiImplies p'' (p' ++ p) /\ good (p' ++ p)).

Theorem liftableAppend_ : forall p, liftable (liftableAppend p).
Proof.
  split.
    split; intros.
      inv H. apply H2. assumption.
    inv H. inv H0. congruence.
  split.
    unfold pmFun. intros.
    inv H. inv H0.
    repeat intro.
    apply evalphiSymm.
    apply evalphiSymm in H.
    apply evalphiApp in H. unf.
    apply evalphiAppRev; cut.
  unfold gFun. intros.
  inv H. unf.
  unfold gGamma' in *. simpl in *.
  destruct pa.
  - assert (H00 := H0).
    apply H1 in H0. unf.
    exists x. exists (x ++ p0).
    splau.
    splau.
    split. congruence.
    splau.
    intros. unf.
    exists x.
    cut.
  - subst.
    exists pb. exists (pb ++ p0).
    splau.
    splau.
    split. congruence.
    split. assumption.
    apply H1.
Qed.

Definition minWith {T:Type} (pred : T -> Prop) (lt : T -> T -> Prop) : T -> Prop :=
    fun x => pred x /\ (forall y, pred y -> lt x y).

Definition liftableWOvar (x : x) (p1 p2 : phi) : Prop :=
  (good p1 -> good p2) /\
  (minWith (fun p => phiImplies p1 p /\ ~ In x (FV p)) phiImplies p2).

Theorem liftableWOvar_ : forall x, liftable (liftableWOvar x).
Proof.
  split.
    split; intros.
      intros. apply H. assumption.
    intros. admit. (*the case when implemented*)
  split.
    unfold pmFun. intros.
    inv H. inv H0.
    unfold minWith in *.
    unf.
    apply H7.
    splau.
    eapp (phiImpliesTrans x1 x2 y2).
  unfold gFun. intros.
  unfold gGamma' in *. simpl in *.
  destruct pa.
  - unf.
    eexists. (* take minimum self-framed pb (if multiple choices, look at p1) *)
    eexists. (* follows from evaluation of WO *)
    admit.
  - subst.
    exists pb.
    exists pc.
    cut.
Admitted.

Definition liftableWOacc (a : A'_s) (p1 p2 : phi) : Prop :=
  (phiImplies p1 [phiAcc (fst a) (snd a)]) /\
  (good p1 -> good p2) /\
  (minWith (fun p => phiImplies p1 p /\ (forall px, phiImplies p px /\ ~ In a (staticFootprint px) /\ ~ In a (staticFootprintX px))) phiImplies p2).

Theorem liftableWOacc_ : forall x, liftable (liftableWOacc x).
Proof.
Admitted.

Fixpoint liftableWOaccs (a : A_s) (p1 p2 : phi) : Prop :=
  match a with
  | [] => p1 = p2
  | (a' :: a) => exists pp, liftableWOacc a' p1 pp /\
                            liftableWOaccs a pp p2
  end.

Theorem liftableWOaccs_ : forall x, liftable (liftableWOaccs x).
Proof.
  induction x.
  - simpl.
    split.
      split; cut.
    split.
      unfold pmFun. intros. subst. auto.
    unfold gFun. intros. subst. eex.
  - simpl.
    apply liftableTrans.
    * apply liftableWOacc_.
    * assumption.
Qed.

Definition liftableWOaccsX (p : phi) (p1 p2 : phi) : Prop :=
  phiImplies p1 p /\
  liftableWOaccs (staticFootprint p) p1 p2.

Theorem liftableWOaccsX_ : forall x, liftable (liftableWOaccsX x).
Proof.
  intros.
  assert (li := liftableWOaccs_ (staticFootprint x)).
  unfold liftableWOaccsX.
  inv li. inv H0.
  split.
    inv H.
    split; intros; unf.
      eapply H0; eauto.
    eapply H3; eauto.
  split.
  - unfold pmFun in *. intros. unf.
    eapply H1; eauto.
  - unfold gFun in *. intros. unf.
    eapply H2 in H5; eauto.
    unf.
    exists x0.
    exists x1.
    splau.
    splau.
    splau.
    unfold gGamma' in H0.
    simpl in *.
    destruct pa.
    * unf.
      eapp phiImpliesTrans.
    * subst.
      assumption.
Qed.

Definition liftablePS2
  (x1 : x) (y1 : x)
  (x2 : x) (y2 : x)
  (p1 p2 : phi) : Prop :=
  p2 = phiSubsts2 x1 y1 x2 y2 p1
  .

Theorem liftablePS2_ : forall x1 y1 x2 y2, liftable (liftablePS2 x1 y1 x2 y2).
Proof.
Admitted.

Definition liftablePS3
  (x1 : x) (y1 : x)
  (x2 : x) (y2 : x)
  (x3 : x) (y3 : x)
  (p1 p2 : phi) : Prop :=
  p2 = phiSubsts3 x1 y1 x2 y2 x3 y3 p1
  .

Theorem liftablePS3_ : forall x1 y1 x2 y2 x3 y3, liftable (liftablePS3 x1 y1 x2 y2 x3 y3).
Proof.
Admitted.


Require Import Relations.

Require Import AST.
Require Import Coqlib.
Require Import Integers.
Require Import Memory.
Require Import Registers.
Require Import RTL.
Require Import Values.

Require Import AliasAnalysis.
Require Import AliasHierarchy.
Require Import AliasLib.

Definition disjoint (x y: PTSet.t) :=
  forall a b, PTSet.In a x -> PTSet.In b y -> ~ AbsPO.overlap a b.

Theorem disjoint_implies: forall
  ge cs f sp pc rs m
  (AI: alias_interprets ge (State cs f sp pc rs m))
  rmap mmap (RES: (safe_funanalysis f)#pc = (rmap, mmap))
  r1 r2 (DISJ: disjoint (RegMap.get r1 rmap) (RegMap.get r2 rmap))
  b1 o1 (R1: rs # r1 = Vptr b1 o1)
  b2 o2 (R2: rs # r2 = Vptr b2 o2)
  ,
  Vptr b1 o1 <> Vptr b2 o2.
Proof.
  repeat intro. inv H. destruct AI as [abs SAT]. inv SAT. inv RES0. rewrite RPC in RES. inv RES.
  pose proof (RSAT r1) as Sr1. pose proof (RSAT r2) as Sr2.
  unfold regsat, valsat in Sr1, Sr2.
  rewrite R1 in Sr1. rewrite R2 in Sr2.
  destruct (abs b2).
  elim (DISJ (Loc a o2) (Loc a o2)); auto. apply reflexivity.
  elim (DISJ AbsPH.top AbsPH.top); auto using PTSet.In_top. apply reflexivity.
Qed.

Definition disjoint_dec_bool (a b: PTSet.t): bool :=
  PTSet.AbsPSet.for_all
  (fun x =>
    PTSet.AbsPSet.for_all
    (fun y =>
      negb (AbsPO.overlap_dec x y)
    )
    b
  )
  a.

Module Facts := OverlapFacts(AbsPO).

Theorem disjoint_dec_bool_spec: forall a b,
  disjoint_dec_bool a b = true -> disjoint a b.
Proof.
  intros a b DISJ x y INx INy OVER.
  apply PTSet.F.for_all_iff in DISJ.
  apply PTSet.In_spec in INx; destruct INx as [INx | [ax [Ax INax]]].
  Case "x is really in a".
  specialize (DISJ x INx). simpl in DISJ.
  apply PTSet.In_spec in INy; destruct INy as [INy | [ay [Ay INay]]].
  SCase "y is really in b".
  apply PTSet.F.for_all_iff in DISJ; auto.
  specialize (DISJ y INy). simpl in DISJ.
  destruct (AbsPO.overlap_dec x y). inv DISJ. contradiction.
  repeat intro. subst. reflexivity.
  SCase "y has an ancestor in b".
  apply PTSet.F.for_all_iff in DISJ; auto.
  specialize (DISJ ay INay). simpl in DISJ.
  destruct (AbsPO.overlap_dec x ay). inv DISJ. elim n.
  symmetry. eapply Facts.above_overlaps_too; eauto. now symmetry.
  repeat intro. subst. reflexivity.
  Case "x has an ancestor in a".
  specialize (DISJ ax INax). simpl in DISJ.
  apply PTSet.In_spec in INy; destruct INy as [INy | [ay [Ay INay]]].
  SCase "y is really in b".
  apply PTSet.F.for_all_iff in DISJ; auto.
  specialize (DISJ y INy). simpl in DISJ.
  destruct (AbsPO.overlap_dec ax y). inv DISJ.
  elim n. eapply Facts.above_overlaps_too; eauto.
  repeat intro. subst. reflexivity.
  SCase "y has an ancestor in b".
  apply PTSet.F.for_all_iff in DISJ; auto.
  specialize (DISJ ay INay). simpl in DISJ.
  destruct (AbsPO.overlap_dec ax ay). inv DISJ. elim n.
  eapply Facts.above_overlaps_too; eauto. symmetry.
  eapply Facts.above_overlaps_too; eauto. now symmetry.
  repeat intro. subst. reflexivity.
  repeat intro. subst. reflexivity.
Qed.

Definition disjoint_chunks (chunk1 chunk2: memory_chunk) (s1 s2: PTSet.t) :=
  forall (p1 p2: AbsPO.t),
    PTSet.In p1 s1 -> PTSet.In p2 s2 ->
    match p1, p2 with
    | Loc b1 o1, Loc b2 o2 =>
      (b1 <> b2 /\ ~ AbsPO.AbsBO.overlap b1 b2)
      \/ (Int.unsigned o1 + size_chunk chunk1 <= Int.unsigned o2)
      \/ (Int.unsigned o2 + size_chunk chunk2 <= Int.unsigned o1)
    | Loc b1 _, Blk b2 | Blk b1, Loc b2 _ | Blk b1, Blk b2 =>
      b1 <> b2
      \/ ~ AbsPO.AbsBO.overlap b1 b2
    end.

Theorem disjoint_chunks_implies: forall
  ge cs f sp pc rs m
  (AI: alias_interprets ge (State cs f sp pc rs m))
  rmap mmap (RES: (safe_funanalysis f)#pc = (rmap, mmap))
  chunk1 chunk2 r1 r2 (DISJ: disjoint_chunks chunk1 chunk2 (RegMap.get r1 rmap) (RegMap.get r2 rmap))
  b1 o1 (R1: rs # r1 = Vptr b1 o1)
  b2 o2 (R2: rs # r2 = Vptr b2 o2)
  ,
  b1 <> b2
  \/ (Int.unsigned o1 + size_chunk chunk1 <= Int.unsigned o2)
  \/ (Int.unsigned o2 + size_chunk chunk2 <= Int.unsigned o1).
Proof.
  intros. destruct AI as [abs SAT]. inv SAT. inv RES0. rewrite RPC in RES. inv RES.
  pose proof (RSAT r1) as Sr1. pose proof (RSAT r2) as Sr2.
  unfold regsat, valsat in Sr1, Sr2.
  rewrite R1 in Sr1. rewrite R2 in Sr2.
  destruct (abs b2) as [ab2|]_eqn, (abs b1) as [ab1|]_eqn.
  specialize (DISJ _ _ Sr1 Sr2). simpl in DISJ. intuition.
  left. intro. subst. rewrite Heqo in Heqo0. inv Heqo0. now apply H0.
  simpl in DISJ. left. intro. subst. rewrite Heqo in Heqo0. congruence.
  simpl in DISJ. left. intro. subst. rewrite Heqo in Heqo0. congruence.
  unfold disjoint_chunks in DISJ.
  specialize (DISJ (Loc AbsPO.AbsBO.top o1) (Loc AbsPO.AbsBO.top o2)). simpl in DISJ.
  feed_all DISJ.
  apply Sr1. apply PTSet.In_top.
  apply Sr2. apply PTSet.In_top.
  intuition.
Qed.

Theorem disjoint_chunks_implies2: forall
  ge cs f sp pc rs m
  abs (SAT: satisfy ge abs (State cs f sp pc rs m))
  rmap mmap (RES: (safe_funanalysis f)#pc = (rmap, mmap))
  chunk1 chunk2 set1 set2 (DISJ: disjoint_chunks chunk1 chunk2 set1 set2)
  b1 o1 b2 o2
  (In1:
    match abs b1 with
    | Some ab1 => PTSet.In (Loc ab1 o1) set1
    | None     => PTSet.ge set1 PTSet.top
    end
  )
  (In2:
    match abs b2 with
    | Some ab2 => PTSet.In (Loc ab2 o2) set2
    | None     => PTSet.ge set2 PTSet.top
    end
  )
  ,
  b1 <> b2
  \/ (Int.unsigned o2 + size_chunk chunk2 <= Int.unsigned o1)
  \/ (Int.unsigned o1 + size_chunk chunk1 <= Int.unsigned o2).
Proof.
  intros. inv SAT. inv RES0. rewrite RPC in RES. inv RES.
  (*
  pose proof (RSAT r1) as Sr1. pose proof (RSAT r2) as Sr2.
  unfold regsat, valsat in Sr1, Sr2.
  rewrite R1 in Sr1. rewrite R2 in Sr2.
  *)
  destruct (abs b2) as [ab2|]_eqn, (abs b1) as [ab1|]_eqn.
  specialize (DISJ _ _ In1 In2). simpl in DISJ. intuition.
  left. intro. subst. rewrite Heqo in Heqo0. inv Heqo0. now apply H0.
  simpl in DISJ. left. intro. subst. rewrite Heqo in Heqo0. congruence.
  simpl in DISJ. left. intro. subst. rewrite Heqo in Heqo0. congruence.
  unfold disjoint_chunks in DISJ.
  specialize (DISJ (Loc AbsPO.AbsBO.top o1) (Loc AbsPO.AbsBO.top o2)). simpl in DISJ.
  feed_all DISJ.
  apply In1. apply PTSet.In_top.
  apply In2. apply PTSet.In_top.
  intuition.
Qed.

Theorem disjoint_chunks_implies3: forall
  ge cs f sp pc rs m
  abs (SAT: satisfy ge abs (State cs f sp pc rs m))
  rmap mmap (RES: (safe_funanalysis f)#pc = (rmap, mmap))
  chunk1 chunk2 set1 set2 (DISJ: disjoint_chunks chunk1 chunk2 set1 set2)
  b o1 o2
  (In1:
    match abs b with
    | Some ab => PTSet.In (Loc ab o1) set1 /\ PTSet.In (Loc ab o2) set2
    | None    => PTSet.ge set1 PTSet.top /\ PTSet.ge set2 PTSet.top
    end
  )
  ,
  (Int.unsigned o2 + size_chunk chunk2 <= Int.unsigned o1)
  \/ (Int.unsigned o1 + size_chunk chunk1 <= Int.unsigned o2).
Proof.
  intros.
  pose proof (disjoint_chunks_implies2 _ _ _ _ _ _ _ _ SAT _ _ RES _ _ _ _ DISJ b o1 b o2).
  feed_all H; destruct (abs b); intuition.
Qed.

(* Should be moved in Integers.v *)
Theorem int_add_sub: forall a b,
  Int.add (Int.sub a b) b = a.
Proof.
  intros. rewrite Int.sub_add_opp. rewrite Int.add_assoc.
  setoid_rewrite Int.add_commut at 2. rewrite Int.add_neg_zero. now rewrite Int.add_zero.
Qed.

Theorem disjoint_chunks_shift_implies: forall
  ge cs f sp pc rs m
  (AI: alias_interprets ge (State cs f sp pc rs m))
  rmap mmap (RES: (safe_funanalysis f)#pc = (rmap, mmap))
  chunk1 chunk2 r1 r2 s1 s2
  (DISJ: disjoint_chunks chunk1 chunk2
    (shift_offset (RegMap.get r1 rmap) s1)
    (shift_offset (RegMap.get r2 rmap) s2)
  )
  b1 o1 (R1: rs # r1 = Vptr b1 o1)
  b2 o2 (R2: rs # r2 = Vptr b2 o2)
  ,
  (
    b1 <> b2
    \/ (Int.unsigned (Int.add o1 s1) + size_chunk chunk1 <= Int.unsigned (Int.add o2 s2))
    \/ (Int.unsigned (Int.add o2 s2) + size_chunk chunk2 <= Int.unsigned (Int.add o1 s1))
  )
  \/
  (
    b1 <> b2
    \/ (Int.unsigned o1 + size_chunk chunk1 <= Int.unsigned o2)
    \/ (Int.unsigned o2 + size_chunk chunk2 <= Int.unsigned o1)
  ).

Proof.
  intros. destruct AI as [abs SAT]. inv SAT. inv RES0. rewrite RPC in RES. inv RES.
  pose proof (RSAT r1) as Sr1. pose proof (RSAT r2) as Sr2.
  unfold regsat, valsat in Sr1, Sr2.
  rewrite R1 in Sr1. rewrite R2 in Sr2.
  destruct (abs b2) as [ab2|]_eqn, (abs b1) as [ab1|]_eqn.
  eapply In_shift_offset with (o' := Int.add o1 s1) in Sr1; [|reflexivity].
  eapply In_shift_offset with (o' := Int.add o2 s2) in Sr2; [|reflexivity].
  specialize (DISJ _ _ Sr1 Sr2). simpl in DISJ. intuition.
  left. left. intro. subst. rewrite Heqo in Heqo0. inv Heqo0. now apply H0.
  left. simpl in DISJ. left. intro. subst. rewrite Heqo in Heqo0. congruence.
  left. simpl in DISJ. left. intro. subst. rewrite Heqo in Heqo0. congruence.
  right. unfold disjoint_chunks in DISJ.
  specialize (DISJ (Loc AbsPO.AbsBO.top o1) (Loc AbsPO.AbsBO.top o2)). simpl in DISJ.
  feed_all DISJ.
  apply In_shift_offset with (o := Int.sub o1 s1). apply Sr1. apply PTSet.In_top.
  auto using int_add_sub.
  apply In_shift_offset with (o := Int.sub o2 s2). apply Sr2. apply PTSet.In_top.
  auto using int_add_sub.
  intuition.
Qed.

Definition disjoint_chunks_dec_bool chunk1 chunk2 (s1 s2: PTSet.t): bool :=
  PTSet.AbsPSet.for_all
  (fun p1 =>
    PTSet.AbsPSet.for_all
    (fun p2 =>
      match p1, p2 with
      | Loc b1 o1, Loc b2 o2 =>
        ((negb (AbsPO.AbsBO.eq_dec b1 b2)) && (negb (AbsPO.AbsBO.overlap_dec b1 b2)))
        || Int.no_overlap o1 (size_chunk chunk1) o2 (size_chunk chunk2)
      | Loc b1 _, Blk b2 | Blk b1, Loc b2 _ | Blk b1, Blk b2 =>
        ((negb (AbsPO.AbsBO.eq_dec b1 b2)) && (negb (AbsPO.AbsBO.overlap_dec b1 b2)))
      end
    )
    s2
  )
  s1.

Module AbsPHFacts := HierarchyFacts(AbsPH).

Lemma above_blk: forall x z,
  AbsPH.above (Blk x) (Blk z) ->
  AbsPO.AbsBO.above x z.
Proof.
  unfold AbsPH.above, AbsPO.AbsBO.above. intros x.
  setoid_rewrite clos_trans_tn1_iff.
  refine (AbsPO.AbsBO.above_ind _ _); intros z IND H.
  inv H.
  left.
  destruct x, z; try destruct a0; try destruct o; compute in *; congruence.
  destruct y.
  right with (y := t).
  destruct t, z; try destruct a0; try destruct o; compute in *; try congruence.
  apply IND; auto. apply AbsPO.AbsBO.parent_is_above.
  destruct t, z; try destruct a0; try destruct o; compute in *; try congruence.
  destruct t, z; try destruct a0; try destruct o; compute in *; try congruence.
Qed.

Lemma above_blk_loc: forall x z o,
  AbsPH.above (Blk x) (Loc z o) ->
  x = z \/ AbsPO.AbsBO.above x z.
Proof.
  unfold AbsPH.above, AbsPO.AbsBO.above. intros x.
  setoid_rewrite clos_trans_tn1_iff.
  refine (AbsPO.AbsBO.above_ind _ _); intros z o IND H.
  inv H.
  left.
  destruct x, z; try destruct a0; try destruct o; compute in *; congruence.
  destruct y.
  assert (t = z).
  destruct t, z; try destruct a0; try destruct o; compute in *; congruence.
  subst.
  assert (AbsPH.above (Blk x) (Blk z)).
  unfold AbsPH.above. now setoid_rewrite clos_trans_tn1_iff.
  apply above_blk in H. right.
  unfold AbsPO.AbsBO.above in H. now setoid_rewrite clos_trans_tn1_iff in H.
  exfalso.
  destruct t, z; try destruct a0; try destruct o; compute in *; try congruence.
Qed.

Module AbsBOFacts := OverlapFacts(AbsPO.AbsBO).

Ltac solver :=
  repeat (intuition (idtac;
    match goal with
    | |- _ \/ _ => left
    | |- _ \/ _ => right
    | |- _ <> _ => intro

    | H: AbsPH.above (Loc _ _) _ |- _ => apply not_loc_above in H
    | H: AbsPH.above (Blk ?b) (Blk ?c) |- _ => apply above_blk in H
    | H: AbsPH.above (Blk ?b) (Loc ?c ?o) |- _ => apply above_blk_loc in H

    | _: _ = _ |- _ => progress subst
    | _: _ = _ |- _ => discriminate
    | H: ?x = ?x |- _ => clear H
    | |- _ => AbsBOFacts.solver
    | |- _ => fail
    end
  )).

Theorem disjoint_chunks_dec_bool_spec: forall chunk1 chunk2 s1 s2,
  disjoint_chunks_dec_bool chunk1 chunk2 s1 s2 = true -> disjoint_chunks chunk1 chunk2 s1 s2.
Proof.
  intros ???? DISJ x y INx INy.
  apply PTSet.F.for_all_iff in DISJ; [|repeat intro; now subst].
  apply PTSet.In_spec in INx; destruct INx as [INx | [ax [Ax INax]]].
  Case "x is really in a".
  specialize (DISJ x INx). simpl in DISJ.
  apply PTSet.In_spec in INy; destruct INy as [INy | [ay [Ay INay]]].
  SCase "y is really in b".
  apply PTSet.F.for_all_iff in DISJ; [|repeat intro; now subst].
  specialize (DISJ y INy). simpl in DISJ.
  destruct x, y;
  destruct (AbsPO.AbsBO.eq_dec t t0), (AbsPO.AbsBO.overlap_dec t t0);
  simpl in DISJ; try solve [solver];
  right;
  apply Int.no_overlap_sound with (base := Int.zero) in DISJ; auto using size_chunk_pos;
  simpl in DISJ;
  setoid_rewrite Zmod_small in DISJ; auto using Int.unsigned_range.
  SCase "y has an ancestor in b".
  apply PTSet.F.for_all_iff in DISJ; [|repeat intro; now subst].
  specialize (DISJ ay INay). simpl in DISJ.
  destruct ay as [bay|? ?]; [|elim (not_loc_above _ _ _ Ay)].
  destruct x as [bx|bx ox], y as [byy|byy oy];
  destruct (AbsPO.AbsBO.eq_dec bx bay), (AbsPO.AbsBO.overlap_dec bx bay);
  simpl in DISJ; solve [solver].
  Case "x has an ancestor in a".
  specialize (DISJ ax INax). simpl in DISJ.
  apply PTSet.In_spec in INy; destruct INy as [INy | [ay [Ay INay]]].
  SCase "y is really in b".
  apply PTSet.F.for_all_iff in DISJ; [|repeat intro; now subst].
  specialize (DISJ y INy). simpl in DISJ.
  destruct ax as [bax|? ?]; [|elim (not_loc_above _ _ _ Ax)].
  destruct x as [bx|bx ox], y as [byy|byy oy];
  destruct (AbsPO.AbsBO.eq_dec bax byy), (AbsPO.AbsBO.overlap_dec bax byy);
  simpl in DISJ; solve [solver].
  SCase "y has an ancestor in b".
  apply PTSet.F.for_all_iff in DISJ; [|repeat intro; now subst].
  specialize (DISJ ay INay). simpl in DISJ.
  destruct ax as [bax|? ?]; [|elim (not_loc_above _ _ _ Ax)].
  destruct ay as [bay|bay oay];
  destruct (AbsPO.AbsBO.eq_dec bax bay), (AbsPO.AbsBO.overlap_dec bax bay);
  simpl in DISJ; try solve [solver];
  destruct x as [bx|bx ox], y as [byy|byy oy];
  solve [solver].
Qed.


From Undecidability.TM Require Import TM ProgrammingTools Code.
From Undecidability.TM Require Hoare.
From Complexity.TM Require Import Code.Decode.
Require Import FunInd Lia Ring Arith Program.Wf.

Lemma list_encode_prefixInjective sigX X (cX : codable sigX X):
  prefixInjective cX -> prefixInjective (Encode_list cX).
Proof.
  intros HcX. intros l. unfold Encode_list;cbn.
  induction l as [ | x l].
  {cbn. intros [];cbn. all:easy. }
  intros [ | x' l']. all:cbn. easy. intros ? ? [=H]. rewrite !app_assoc_reverse in H.
  specialize (map_retract_prefix_inj (H:=Retract_sigList_X (Retract_id sigX))) with (1:=H) as (t1'&t2'&H').
  apply HcX in H' as ->. apply app_inv_head in H. apply IHl in H. congruence.
Qed.

(*
Lemma TerminatesIn_Realises sig F n (M : pTM sig F n) Ter Rel:
  projT1 M ↓ Ter -> M ⊨ Rel
  -> forall tin, (exists k, Ter tin k) -> (exists ! y, Rel tin y ).
Proof.
  intros Terminates Realise. intros t (k&Tt).
  specialize (Terminates _ _ Tt) as (c&Hc).
  eexists. split. now eapply Realise;eassumption.
  intros c' Hc'. Realise
Qed. *)

From Complexity.TM Require Import Code.DecodeBool.

Module CheckEncodesBoolList.
  Section checkEncodesBoolList.

    (* Context (sigX:finType) X (cX : codable sigX X). *)
    Local Notation sigX := bool (only parsing).
    Local Notation cX := Encode_bool (only parsing).
    Local Notation X := bool.

    Context (tau:finType) `{I : Retract (sigList sigX) tau}.

    Let I__X : Retract sigX tau := ComposeRetract I _.
    Existing Instance I__X.
    Local Arguments ComposeRetract : simpl never.

    Local Remove Hints Retract_id : typeclass_instances.

    Let Rel' : pRel tau bool 1 := ContainsEncoding.Rel (Encode_list cX) Retr_f.
    Let Rel__X :=  ContainsEncoding.Rel (tau:=tau) cX Retr_f.

    Definition R'__step : pRel tau (option bool) 1 :=
      fun t '(y,t') =>
        match Option.bind Retr_g (current t[@Fin0]) with
          Some sigList_nil => t[@Fin0]=t'[@Fin0]
                             /\ y = Some true
        | Some sigList_cons =>
          exists t1 b1, Rel__X [|tape_move_right t[@Fin0]|] (b1,t1)
                   /\ t1[@Fin0] = tape_move_right t[@Fin0]
                   /\ t'[@Fin0] = (if b1 then tape_move_right t1[@Fin0] else t1[@Fin0])
                   /\ y = if b1 then None else Some false
        | _ => t[@Fin0]=t'[@Fin0] /\ y = Some false
        end.

    (*
    Context (M__X : pTM tau bool 1).
    Context (Realises__X : M__X ⊨ Rel__X).
     *)
    Local Notation M__X := (CheckEncodesBool.M (I:=I__X)) (only parsing).
    Local Notation Realises__X := (RealiseIn_Realise (@CheckEncodesBool.RealisesIn _ _)) (only parsing).

    Definition M'__step : pTM tau (option bool) 1 :=
      Switch (Relabel ReadChar (Option.bind Retr_g))
             (fun c =>
                match c with
                | Some sigList_nil => (Return Nop (Some true))
                | Some sigList_cons => (Move Rmove;; If M__X (Move Rmove;;Return Nop None) (Return Nop (Some false)))
                | _ => Return Nop (Some false)
                end).

    Lemma Realises'__step: M'__step ⊨ R'__step.
    Proof.
      unfold M'__step,R'__step.
      eapply Realise_monotone.
      { eapply Switch_Realise. now TM_Correct.
        introsSwitch c. destructBoth c as [ [] | ]. all:TM_Correct. apply Realises__X. }
      hnf. cbn. intros t (b,t') (?&?&(?&->&->&->)&H).
      destruct Option.bind as [ [] | ];cbn in H.
      1,2,4:now destruct H as (->&[? ->]).
      destruct H as (_&t1&Ht1&H). rewrite <- Ht1. destruct H as [H|H].
      2:{ destruct H as (?&(?&->)&->&[_ <-]). eexists [|t'[@Fin0]|],false. cbn. easy. }
      destruct H as (t2&(?&->)&?&_&Ht2&->&_&<-). eexists t2,true. hnf in t2. destruct_vector. cbn.  easy.
    Qed.

    Lemma Terminates'__step T__X (Ter__X : projT1 M__X ↓ T__X):
      projT1 M'__step ↓  (fun t k => exists k', T__X ([|tape_move_right t[@Fin0]|]) k' /\ k' + 7 <= k ).
    Proof.
      unfold M'__step.
      eapply TerminatesIn_monotone.
      { eapply Switch_TerminatesIn. 1,2:now TM_Correct.
        introsSwitch c. destructBoth c as [ [] | ]. all:TM_Correct. all:try eassumption. eapply RealiseIn_Realise, CheckEncodesBool.RealisesIn. }
      intros ? ? (k'&H1&H2). infTer 5.
      2:{ intros t ? (?&->&->&<-).
          destruct (Option.bind Retr_g (current t[@Fin0])) as [ [] | ].  1,2,4:now apply Nat.le_0_l.
          infTer 5. cbn -[plus]. intros t1 _ Ht1. infTer 2.
          1:{rewrite <- Ht1 in H1. hnf in t1. destruct_vector;eassumption. }
          infTer 2. intros t2 [] Ht2. 2:now apply Nat.le_0_l.
          infTer 4. intros. reflexivity.
      } ring_simplify. nia.
    Qed.

    Definition M' := While M'__step.

    Lemma Realise':
      (*prefixInjective cX -> *)
      (forall (x:X), encode x <> []) ->
      M' ⊨ Rel'.
    Proof.
      intros (*EpI_cX *) Hnnil. unfold Rel'.
      eapply Realise_monotone.
      { unfold M'. TM_Correct_step. eapply Realises'__step. }
      apply WhileInduction. all:unfold R'__step,Rel';cbn.
      -intros t y tout. destruct Option.bind as [[] | ]eqn:Heq.
       3: intros (t1&b&Ht1&H);destruct b;[easy | ]; revert H.
       2:{ intros [Ht [= ->]]. all:hnf.
           destruct t[@Fin0] as [ | | | t__L c t__R]. 1-3:easy. cbn in Heq. eapply retract_g_inv in Heq as ->.
           split. 2:now eexists 0.
           eexists []. rewrite <- Ht.  cbn. easy.
       }
       2:{ intros (Ht&Ht2&[= ->]). all:hnf. destruct Ht1 as [Ht1 [k Ht1']]. rewrite Ht2 in *. clear tout Ht2.
           hnf. split. 2:{ eexists (S k). rewrite nat_rect_succ_r. cbn in *. congruence. }
           intros [] ?; cbn.
           all:intros Ht'. all:erewrite tape_local_current_cons in Heq;[ |apply Ht']. all:cbn in Heq.
           all:rewrite retract_g_adjoint in Heq. now inv Heq.
           cbn in *. erewrite tape_local_move_right in Ht1. 2:eassumption.  autorewrite with list in Ht1.
           eapply Ht1 with (x:=b). f_equal.
       }
       all:intros [Ht [= ->]]. all:hnf.
       all:split;[ | now eexists 0 ].
       all:intros ? ? Ht'. all:destruct t[@Fin0]. all:cbn in Heq;inv Heq. cbn in *. all:destruct x;inv Ht'.
       all:retract_adjoint. all:easy.
      -intros tin tmid tout yout Hin. unfold ContainsEncoding.Rel.
       destruct tin[@Fin0] as [ | | | t__L c t__R ] eqn:Htin. all: cbn in Hin. 1-3:easy.
       destruct (Retr_g c) as [[] | ] eqn:Hc. 1,2,4:easy.
       apply retract_g_inv in Hc as ->. destruct Hin as (t1&[]&H__X&_&Hmid'&[=]).
       hnf in H__X. destruct H__X as [(x&Hx1&Hx2) [k__x Hk__x]]. (* cbn in Hx1.
       destruct t__R;revert Ht0;cbn. all:intros [= <- -> ->]. cbn in Hk__x.
       hnf in Hmid|-*. rewrite Hmid' in *. clear Hmid' tmid.
       (*)rewrite Hmid',Htin in *.  clear tin Htin tmid Hmid'. *) *)
       intros [hmid [k Hk]].
       split. 2:{ eexists _. clear hmid. cbn in *. rewrite nat_rect_succ_r. cbn. rewrite nat_rect_plus. rewrite <- Hk__x.
                  rewrite Hmid' in Hk.        rewrite <- nat_rect_succ_r in Hk. exact Hk.
       } clear k Hk.
       cbn in  *. rewrite tape_local_move_right' in Hx1. subst t__R.
       rewrite Hmid' in *. clear Hmid' tmid.
       destruct (cX x) eqn:HcX in Hx2,Hk__x;cbn in *. now edestruct Hnnil;eassumption.
       destruct t1[@Fin0] as [ | | | ? ? t__R];cbn in *. 1-3: now length_not_eq in Hx2.
       destruct yout.
       2:{ intros [ | x' l'] ?;cbn. now intros [= [=]%retract_f_injective <-].
           intros [= Hx'].
           (*rewrite map_app,map_map,app_assoc_reverse in Hx'. *)
           eapply retract_f_injective in Hx' as [= ->].
           (*set (f' := map _) in Hx'. change f' with (map (Retr_f (Retract:=I__X))) in Hx'. clear f'. *)
           (*specialize map_retract_prefix_inj with (1:= Hx') as (?&?&Hx1'). *)
           (*apply EpI_cX in Hx1' as <-. apply app_inv_head in Hx'.*)
           destruct t__R.  now destruct l'.
           eapply hmid. cbn.  eassumption.
       }
       edestruct hmid as (xs&Hxs&->). rewrite tape_local_move_right' in Hxs. subst t__R. rewrite tape_left_move_right',Hx2.
       exists (x::xs). cbn in *. autorewrite with list. now cbn.
       (* rewrite rev_app_distr,map_app,map_app,!map_rev,!map_app,!map_map,!app_assoc_reverse,!map_rev,map_map.
       set (f' := map _ (cX x)). change f' with (map (Retr_f (Retract:=I__X)) (cX x)). clear f'.
       split. easy. rewrite HcX. cbn. now autorewrite with list. *)
    Qed.

    Lemma Terminates' :
      projT1 M' ↓ (fun tin k => length (tape_local tin[@Fin0])*8 + 8 <= k).
    Proof.
      cbn.
      eapply TerminatesIn_monotone.
      { unfold M'. TM_Correct_step.
        2:eapply Terminates'__step, RealiseIn_TerminatesIn.
        1:eapply Realises'__step. now apply @CheckEncodesBool.RealisesIn. }
      eapply WhileCoInduction.
      intros tin k Hk.
      infTer 4.
      intros [] tmid. now intros; nia.
      cbn [R'__step].  destruct Option.bind as [ [] | ] eqn:Hc. 1,2,4:intuition congruence.
      intros (?&[]&Hbool&Ht'&H'&[=]). hnf in x. destruct_vector. cbn in Ht'. subst h. cbn - [plus] in *.
      destruct (tin[@Fin0]) as [ | | | ? ? t__R]. 1-3:easy. cbn - [plus] in *.
      destruct Hbool as [(x&Hx1&Hx2) _]. cbn in Hx1,Hx2.
      rewrite tape_local_move_right' in Hx1. rewrite tape_right_move_right' in Hx1. destruct t__R. easy.
      cbn -[plus]in *. inv Hx2. inv Hx1.
      eapply retract_g_inv in Hc as ->.
      rewrite H'. rewrite tape_local_move_right'.
      eexists. split. reflexivity. nia.
    Qed.
  End checkEncodesBoolList.

  Section checkEncodesBoolList2.
  Import Hoare.

    Context (Σ : finType) (retr__bools : Retract (sigList bool) Σ).
    Definition M : pTM (Σ^+) bool 1 := CheckTapeContains.M (M' (I:=_)).

    Lemma SpecT tape0:
     TripleT (≃≃([ ],[|Custom (eq tape0)|]))
        (12 * S(| right tape0 |) + 19) M
        (fun yout => ≃≃([inhabited (reflect (exists (bs:list bool), tape_contains _ tape0 bs) yout)]
                        ,[|Custom (if yout then eq tape0 else fun _ => True)|])).
    Proof.
      unfold M. eapply Realise_TripleT.
      - eapply CheckTapeContains.Realise. eapply Realise'. now intros []. now apply list_encode_prefixInjective,DecodeBool.bool_encode_prefixInjective.
      - eapply CheckTapeContains.Terminates. { eapply Realise'. now intros []. }
        eapply Terminates'.
      - intros tin b tout H HEnc. cbn in *.
        specialize (HEnc Fin0) as ->; simpl_vector in *; cbn in *.
        destruct H,b;tspec_solve. all:firstorder subst;eauto.
      - intros tin k HEnc Hk. cbn.
        specialize (HEnc Fin0) as ->;simpl_vector in *;cbn - ["+" "*"] in *.
        eexists;split. reflexivity.
        rewrite <- Hk. destruct (tin[@Fin0]) as [| | | ? ? []];cbn - ["+" "*"];try nia.
    Qed.
  End checkEncodesBoolList2.
End CheckEncodesBoolList.


(* -*- coq-prog-args: ("-top" "ModelStructure.CtxFibrancy.Overture") -*-  *)
Require Export ModelStructure.Overture.

Axiom FibrantF : forall {A: Type} (P: A -> Type), Type.
Existing Class FibrantF.

Notation "'Fibrant' A" := (FibrantF (λ _:unit, A)) (at level 10) : Fib_scope.
Notation "'FibrantF2' P" := (FibrantF (λ w, P w.1 w.2)) (at level 10) : Fib_scope.
Notation "'FibrantF3' P" := (FibrantF (λ w, P w.1 w.2.1 w.2.2)) (at level 10) : Fib_scope.
Open Scope Fib_scope.

Record TypeF := {
  TypeF_T : Type;
  TypeF_F : Fibrant TypeF_T
}.

Arguments Build_TypeF _ {_}.

Coercion TypeF_T : TypeF >-> Sortclass.
Global Existing Instance TypeF_F.

Axiom FibrantF_forall : ∀ {A: Type} {B: A -> Type} {C: ∀ x, B x -> Type},
    FibrantF B -> FibrantF2 C -> FibrantF (λ x, ∀ y, C x y).

Axiom FibrantF_sigma : ∀ {A: Type} {B: A -> Type} {C: ∀ x, B x -> Type},
    FibrantF B -> FibrantF2 C -> FibrantF (λ x, ∃ y, C x y).

Axiom Fibrant_Type : Fibrant Type.

Axiom FibrantF_compose
  : forall A (B: A -> Type) {FibB: FibrantF B} A' (f: A' -> A), FibrantF (B o f).

(* Axiom Fibrant_TypeF : Fibrant FType. *)

Instance Fibrant_FibrantF A (B: A -> Type) {FibP: FibrantF B}
  : ∀ x, Fibrant (B x)
  := λ x, FibrantF_compose A B unit (λ _, x).

Instance Fibrant_sigma A (B: A -> Type)
  : Fibrant A -> FibrantF B -> Fibrant (sigT B).
Proof.
  intros.
  ref (@FibrantF_sigma unit (λ _, A) (λ _ x, B x) _ _).
Defined.

Instance FibrantF_constant A B {FibB: Fibrant B}
  : FibrantF (λ _:A, B) | 50
  := FibrantF_compose unit (λ _, B) A (λ _, tt).

Instance FibrantF2_fibrant A (B: A -> Type) (C: forall x, B x -> Type) (H: FibrantF2 C)
  : forall x y, Fibrant (C x y).
intros x y; exact (@Fibrant_FibrantF _ _ H (x; y)).
Defined.

Instance FibrantF2_FibrantF A (B: A -> Type) (C: forall x, B x -> Type) (H: FibrantF2 C)
  : forall x, FibrantF (C x) | 50.
intros x. exact (FibrantF_compose (sigT B) _ _ (λ y : B x, (x; y))).
Defined.

Instance FibrantF2_FibrantF_constant A B (C: A -> B -> Type) (H: FibrantF2 C)
  : forall x, FibrantF (C x).
intros x. exact (FibrantF_compose (sigT (λ _, B)) _ _ (λ y, (x; y))).
Defined.

Instance FibrantF2_FibrantF'_constant A B (C: A -> B -> Type) (H: FibrantF2 C)
  : forall y, FibrantF (λ x, C x y) | 50.
intros y. exact (FibrantF_compose _ _ _ (λ x, (x; y))).
Defined.

Module Export Paths.
  Private Inductive paths {A : Type} (a : A) : A -> Type :=
    idpath : paths a a.

  Arguments idpath {A a} , [A] a.

  Definition paths_ind (A : Type) {FibA: Fibrant A} (a : A)
             (P : forall a0 : A, paths a a0 -> Type) {FibP: FibrantF2 P}
             (f: P a idpath) (y : A) (p : paths a y) : P y p
    := match p as p0 in (paths _ y0) return (P y0 p0) with
       | idpath => f
       end.
  Arguments paths_ind [A _] a P [_] f y p.

  Definition paths_rec (A : Type) {FibA: Fibrant A} (a : A) (P : A -> Type)
             {FibP: FibrantF P} (f : P a) (y : A) (p : paths a y)
    : P y :=
    match p in (paths _ y0) return (P y0) with
    | idpath => f
    end.

  Axiom FibrantF_paths : forall {Δ} (A : Δ -> Type) (t t' : forall x, A x),
      FibrantF A -> FibrantF (fun x => paths (t x) (t' x)).

  (** The inverse of a path. *)
  Definition inverse {A : Type} {FibA: Fibrant A} {x y : A} (p : paths x y) : paths y x
    := @paths_rec A FibA x (fun y => paths y x) _ idpath y p.

  Definition paths_rec' A {FibA: Fibrant A} a y P {FibP: FibrantF P} (X : P y)
             (H : @paths A a y) : P a
    := @paths_rec A FibA y P FibP X _ (inverse H).

  (* ****** myrewrite plugin ****** *)
  (* This plugin is to avoid a flaw in the mechanism of private inductive types. *)
  (* When we rewrite with a path equality, Coq uses the automatically generated terms internal_paths_rew and internal_paths_rew_r.*)
  (* However, those terms doesn't check the fibrancy condition.  *)
  (* Hence this plugin forces Coq to use paths_rec and paths_rec' instead. *)
  Declare ML Module "myrewrite2".
End Paths.

Arguments paths_rec [A _] a P [_] f y p.

Notation "x = y :> A" := (@paths A x y) : type_scope.
Notation "x = y" := (x = y :> _) : type_scope.

Notation "f == g" := (forall x, f x = g x) (at level 70, no associativity) : type_scope.

Tactic Notation "rew" open_constr(H)
  := rewrite H; auto with typeclass_instances.
Tactic Notation "rewi" open_constr(H)
  := rewrite <- H; auto with typeclass_instances.

(* This does not fail if you comment the "Declare ML Module..." line above. *)
Lemma  paths_rew_r_test_should_fail A {FibA: Fibrant A} a y P (X : P y) (H : a = y :> A) : P a.
Proof. Fail rewrite H; assumption. Abort.

Lemma paths_rew_test A {FibA: Fibrant A} a y P {FibP: FibrantF P} (X : P a) (H : a = y :> A) : P y.
Proof. rewi H. Defined.

Lemma paths_rew_r_test A {FibA: Fibrant A} a y P {FibP: FibrantF P} (X : P y) (H : a = y :> A) : P a.
Proof. rew H. Defined.

Definition Eq_to_paths {A : Type} {FibA: Fibrant A} {x y : A} (p : x ≡ y) : x = y :=
  match p with
    | refl => idpath
  end.

Definition concat {A : Type} {FibA: Fibrant A} {x y z : A} (p : x = y) (q : y = z) : x = z.
Proof.
  ref (@paths_rec A _ y (fun z => x = z) _
                  (@paths_rec A _ x (fun y => x = y)_ idpath y p) z q).
  all: ref (FibrantF2_FibrantF _ _ (@paths A _) _ _).
Defined.

Arguments concat {A FibA x y z} !p !q.

Delimit Scope path_scope with path.
Open Scope path_scope.

Notation "p @ q" := (concat p%path q%path) (at level 20) : path_scope.
Notation "p ^" := (inverse p%path) (at level 3, format "p '^'") : path_scope.
Notation "1" := idpath : path_scope.

Definition transport {A : Type} {FibA: Fibrant A} (P : A -> Type)
           {FibP: FibrantF P}  {x y : A} (p : x = y) (u : P x) : P y
  := paths_rec x P u y p.

Arguments transport {A}%type_scope {FibA} P {FibP} {x y} p%path_scope u : simpl nomatch.

Notation "p # x"
  := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope.

Record Contr (A: Type) {FibA: Fibrant A} :=
  { center : A;
    contr : ∀ x, center = x }.

(* ****** destruct_path tactic ****** *)

(* auxiliary tactics *)
Definition myid : forall A, A -> A := fun _ x => x.
Ltac mark H := let t := type of H in change (myid _ t) in H.
Ltac unmark H := let t := type of H in
                 match t with
                 | myid _ ?tt => change tt in H
                 end.
Hint Unfold myid : typeclass_instances.

(* If p : x = y  then destruct_path revert all hypothesis depending on x and y.  *)
(* Then, it applies paths_ind and then it reintroduce reverted hypothesis. *)
Ltac destruct_path p :=
  let t := type of p in
  match t with
    @paths _ ?x ?y =>
    mark p;
      repeat match goal with
             | [X: context[y] |- _] =>
               match type of X with
               | myid _ _ => fail 1
               | _ => revert X;
                   match goal with
                   | |- forall (X: ?T), ?G => change (forall (X: myid _ T), G)
                   end
               end
             end;
      unmark p;
      generalize y p; clear p y;
      match goal with
      | |- forall y p, @?P y p => let y := fresh y in
                                  let p := fresh p in
                                  intros y p; refine (paths_ind x P _ y p)
      end;
      repeat match goal with
             | |- forall (H: myid _ _), _ => let H := fresh H in
                                             intro H; unfold myid in H
             end
  end.


(** ** The functions of the over-towers defined by T and their iterations.

by Vladimir Voevodsky, started on Jan. 22, 2015 *)

Unset Automatic Introduction.

Require Export lBsystems.T_Tt .

(** *** The definition of an extended operation T and its elementary properties. *)

Definition T_ext_dom { BB : lBsystem_carrier } ( X1 X2 : BB ) :=
  dirprod ( ll X1 > 0 ) ( isover X2 ( ft X1 ) ) .

Definition T_ext_dom_constr { BB : lBsystem_carrier } { X1 X2 : BB }
           ( gt0 : ll X1 > 0 ) ( isov : isover X2 ( ft X1 ) ) : T_ext_dom X1 X2 :=
  dirprodpair gt0 isov .

Definition T_ext_dom_gt0 { BB : lBsystem_carrier } { X1 X2 : BB } ( inn : T_ext_dom X1 X2 ) :=
  pr1 inn .

Definition T_ext_dom_isov { BB : lBsystem_carrier } { X1 X2 : BB } ( inn : T_ext_dom X1 X2 ) :=
  pr2 inn .

Definition T_dom_to_T_ext_dom { BB : lBsystem_carrier } { X1 X2 : BB } ( inn : T_dom X1 X2 ) :
  T_ext_dom X1 X2 := T_ext_dom_constr ( T_dom_gt0 inn ) ( T_dom_isabove inn ) .
Coercion T_dom_to_T_ext_dom : T_dom >-> T_ext_dom .

Definition T_dom_to_T_ext_dom_ft { BB : lBsystem_carrier } { X1 X2 : BB } ( inn : T_dom X1 X2 ) :
  T_ext_dom X1 ( ft X2 ) := T_ext_dom_constr ( T_dom_gt0 inn ) ( isover_ft' ( T_dom_isabove inn ) ) .

Definition T_ext { BB : lBsystem_carrier } ( T : T_ops_type BB )
           { X1 X2 : BB } ( inn : T_ext_dom X1 X2 ) : BB .
Proof .
  intros. set ( gt0 := pr1 inn ) . set ( isov := pr2 inn ) .
  destruct ( ovab_choice isov ) as [ isab | eq ] .
  exact ( T _ _ ( dirprodpair gt0 isab ) ) .

  exact X1 .

Defined.

Lemma isover_T_ext { BB : lBsystem_carrier }
      ( T : T_ops_type BB ) ( ax1b : T_ax1b_type T )
      { X1 X2 : BB } ( inn : T_ext_dom X1 X2 ) :
  isover ( T_ext T inn ) X1 .
Proof .
  intros .
  unfold T_ext .
  destruct ( ovab_choice (pr2 inn) ) as [ isab | eq ] .
  exact ( ax1b _ _ _ ) .

  exact ( isover_XX _ ) .

Defined.

Lemma isover_T_ext_T_ext_2 { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 :  T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
      { X1 X2 X2' : BB } ( inn : T_ext_dom X1 X2 ) ( inn' : T_ext_dom X1 X2' )
      ( is : isover X2 X2' ) : isover ( T_ext T inn ) ( T_ext T inn' ) .
Proof .
  intros . unfold T_ext .
  destruct ( ovab_choice (pr2 inn) ) as [ isab | eq ] .
  destruct ( ovab_choice (pr2 inn') ) as [ isab' | eq' ] .
  apply ( isover_T_T_2 ax0 ax1a _ _ is ) .

  exact ( ax1b _ _ _ ) .

  destruct ( ovab_choice (pr2 inn') ) as [ isab' | eq' ] .
  assert ( absd : empty ) .
  rewrite eq in is .
  assert ( ge := isover_geh is ) .
  assert ( gt := isabove_gth isab' ) .
  exact ( ge gt ) .

  destruct absd .

  exact ( isover_XX _ ) .

Defined.

(** *** The function T_fun of the over-towers defined by the extended operation T *)

Definition T_fun_int { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax1b : T_ax1b_type T )
      { X1 : BB } ( gt0 : ll X1 > 0 ) ( X2' : ltower_over ( ft X1 ) ) : ltower_over X1 .
Proof .
  intros .
  set ( X2 := pr1 X2' ) . set ( isov := pr2 X2' : isover X2 ( ft X1 ) ) .
  split with ( T_ext T ( dirprodpair gt0 isov ) )  .

  apply ( isover_T_ext T ax1b ) .

Defined.

Lemma isovmonot_T_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
      { X1 : BB } ( gt0 : ll X1 > 0 )
      ( X3' X2' : ltower_over ( ft X1 ) ) ( isov : isover X3' X2' ) :
  isover ( T_fun_int ax1b gt0 X3' ) ( T_fun_int ax1b gt0 X2' ) .
Proof .
  intros .
  apply isinvovmonot_pocto .
  unfold T_fun_int. simpl .
  apply ( isover_T_ext_T_ext_2 ax0 ax1a ax1b ) .
  apply isovmonot_pocto .
  exact isov .

Defined.

Opaque isovmonot_T_fun .

Lemma ll_T_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
      { X1 : BB } ( gt0 : ll X1 > 0 ) ( X2' : ltower_over ( ft X1 ) ) :
  ll ( T_fun_int ax1b gt0 X2' ) = ll X2' .
Proof.
  intros.
  change _ with ( ll ( T_ext T ( dirprodpair gt0 ( pr2 X2' ) ) ) - ll X1 = ll X2' ) .
  change ( ll X2' ) with ( ll ( pr1 X2' ) - ll ( ft X1 ) ) .
  unfold T_ext .
  destruct (ovab_choice (pr2 (dirprodpair gt0 (pr2 X2')))) as [ isab | eq ] .
  rewrite ax0 .
  rewrite ll_ft .
  assert ( ge : ll (pr1 X2') >= ll X1 ) .
  apply natgthminus1togeh .
  rewrite <- ll_ft .
  apply ( isabove_gth isab ) .

  rewrite <- natassocmpeq .
  rewrite ( natpluscomm _ 1 ) .
  apply natassocpmeq .
  apply ge .

  apply ge .

  apply ( @natgthminus1togeh 1 _ gt0 ) .
  rewrite natminusnn .
  rewrite eq .
  rewrite natminusnn .
  apply idpath .

Defined.

Opaque ll_T_fun .

Lemma isllmonot_T_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
      { X1 : BB } ( gt0 : ll X1 > 0 ) : isllmonot ( T_fun_int ax1b gt0 ) .
Proof.
  intros. unfold isllmonot .
  intros X Y .
  repeat rewrite ( ll_T_fun ax0 ) .
  apply idpath .

Defined.

Opaque isllmonot_T_fun .

Lemma isbased_T_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
      { X1 : BB } ( gt0 : ll X1 > 0 ) : isbased ( T_fun_int ax1b gt0 ) .
Proof.
  intros. unfold isbased.  intros X eq0 .
  rewrite ll_T_fun .
  exact eq0.

  exact ax0.

Defined.

Opaque isbased_T_fun.

Definition T_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
      { X1 : BB } ( gt0 : ll X1 > 0 ) :
  ltower_fun ( ltower_over ( ft X1 ) ) ( ltower_over X1 ) :=
  ltower_fun_constr ( isovmonot_T_fun ax0 ax1a ax1b gt0 )
                    ( isllmonot_T_fun ax0 ax1b gt0 )
                    ( isbased_T_fun ax0 ax1b gt0 ) .

(** *** Definition of Tj_fun as iterations of the functions T_fun *)

(** **** Construction of Tj *)

(** The construction of a function requires only an operation of type T_ops_type satisfying a consition
of type T_ax1b_type but the proof that it is an ltower function requires other two properties of this
operation. *)

Definition Tj_fun { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
           { A X1 : BB } ( isov : isover X1 A ) :
  ltower_fun ( ltower_over A ) ( ltower_over X1 ) :=
  isover_ind ( fun ( X Y : BB ) => ltower_fun ( ltower_over Y ) ( ltower_over X ) )
             ( fun X => ltower_idfun _ )
             ( fun X gt0 => T_fun ax0 ax1a ax1b gt0 )
             ( fun X Y f g => ltower_funcomp g f ) _ _ isov .

Lemma Tj_fun_compt { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
      { X Y : BB } ( isab : isabove X Y ) :
  Tj_fun ax0 ax1a ax1b isab =
  ltower_funcomp ( Tj_fun ax0 ax1a ax1b ( isover_ft' isab ) )
                 ( T_fun ax0 ax1a ax1b ( isabove_gt0 isab ) ) .
Proof.
  intros.
  unfold Tj_fun .
  rewrite (@isover_ind_isab BB _ _ _ _ _ _ ).
  apply idpath .

Defined.

(*

Lemma Tj_fun_compt0 { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
      { X : BB } ( isov : isover X Y ) :
  Tj_fun ax0 ax1a ax1b isab =

Lemma Tj_fun_int_l0 { BB : lBsystem_carrier }
      { A X1 : BB } ( isov : isover X1 A )
      ( ell : ll X1 - ll A = 0 ) : X1 = A .
Proof .
  intros .
  destruct ( ovab_choice isov ) as [ isab | eq ] .
  assert ( absd : empty ) .
  assert ( gt := isabove_gth isab ) .
  assert ( gt0 := minusgth0 _ _ gt ) .
  rewrite ell in gt0 .
  exact ( negnatgthnn _ gt0 ) .

  destruct absd .

  exact eq .

Defined.

Lemma Tj_fun_int_l1 { BB : lBsystem_carrier }
      ( j : nat )
      { A X1 : BB } ( isov : isover X1 A )
      ( ell : ll X1 - ll A = S j ) :
  isover ( ft X1 ) A .
Proof .
  intros .
  assert ( gth : ll X1 > ll A ) .
  apply minusgth0inv .
  rewrite ell .
  exact ( natgthsn0 _ ) .

  exact ( isover_ft' ( isabove_constr gth isov ) ) .

Defined.

Opaque  Tj_fun_int_l1 .

Lemma Tj_fun_int_l2 { BB : lBsystem_carrier }
      ( j : nat )
      { A X1 : BB } ( isov : isover X1 A )
      ( ell : ll X1 - ll A = S j ) :
  ll ( ft X1 ) - ll A = j .
Proof .
  intros .
  rewrite ll_ft .
  rewrite natminuscomm .
  rewrite ell .
  simpl .
  exact ( natminuseqn _ ) .

Defined.

Opaque Tj_fun_int_l2 .

Lemma Tj_fun_int_l3 { BB : lBsystem_carrier }
      ( j : nat )
      { A X1 : BB }
      ( ell : ll X1 - ll A = S j ) : ll X1 > 0 .
Proof .
  intros .
  refine ( natgehgthtrans _ ( ll X1 - ll A ) _ ( natminuslehn _ _ ) _ ) .
  rewrite ell .
  exact ( natgthsn0 _ ) .

Defined.

Opaque Tj_fun_int_l3 .

Definition Tj_fun_int { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax1b : T_ax1b_type T )
           { A : BB }
           ( j : nat )
           { X1 : BB } ( isov : isover X1 A )
           ( ell : ll X1 - ll A = j )
           ( X2' : ltower_over A ) : ltower_over X1 .
Proof .
  intros until j . induction j as [ | j IHj ] .
  intros .
  assert ( eq := Tj_fun_int_l0 isov ell ) .
  split with ( pr1 X2' ) .
  rewrite eq .
  exact ( pr2 X2' ) .

  intros .
  assert ( Tprev := IHj ( ft X1 ) ( Tj_fun_int_l1 j isov ell ) (  Tj_fun_int_l2 j isov ell ) X2' ) .
  exact ( T_fun ax1b ( Tj_fun_int_l3 j ell ) Tprev ) .

Defined.

Definition Tj_fun { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax1b : T_ax1b_type T )
           { A X1 : BB } ( isov : isover X1 A ) : ltower_over A -> ltower_over X1 :=
  fun X2' => Tj_fun_int ax1b ( ll X1 - ll A ) isov ( idpath _ ) X2' .

(** **** Proof of monotonicity of Tj relative to the predicate isover *)

Lemma isovmonot_Tj_fun_int { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
      { A : BB }
      ( j : nat )
      { X1 : BB } ( isov : isover X1 A )
      ( ell : ll X1 - ll A = j )
      ( X2' X3' : ltower_over A ) ( isov' : isover X3' X2' ) :
  isover ( Tj_fun_int ax1b j isov ell X3' ) ( Tj_fun_int ax1b j isov ell X2' ) .
Proof .
  intros until j . induction j as [ | j IHj ] .
  intros .
  assert ( eq := Tj_fun_int_l0 isov ell ) .
  unfold Tj_fun_int .
  simpl .
  apply isinvovmonot_pocto .
  simpl .
  apply isovmonot_pocto .
  exact isov' .

  intros .
  simpl .
  unfold T_fun .
  apply isinvovmonot_pocto .
  simpl .
  apply ( isover_T_ext_T_ext_2 ax0 ax1a ax1b ) .
  apply isovmonot_pocto .
  apply IHj .
  exact isov' .

Defined.

Lemma isovmonot_Tj_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
      { X1 A : BB } ( isov : isover X1 A )
      ( X2' X3' : ltower_over A ) ( isov' : isover X2' X3' ) :
  isover ( Tj_fun ax1b isov X2' ) ( Tj_fun ax1b isov X3' ) .
Proof .
  intros .
  apply ( isovmonot_Tj_fun_int ax0 ax1a ax1b ) .
  exact isov' .

Defined.

(** **** Functions Tj and the length function ll *)

Lemma ll_Tj_fun_int { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
      { A : BB }
      ( j : nat )
      { X1 : BB } ( isov : isover X1 A )
      ( ell : ll X1 - ll A = j )
      ( X2' : ltower_over A ) :
  ll ( Tj_fun_int ax1b j isov ell X2' ) = ll X2' .
Proof .
  intros BB T ax0 ax1b A j .
  induction j as [ | j IHj ] . intros .
  simpl .
  change _ with ( ll ( pr1 X2' ) - ll X1 = ll ( pr1 X2' ) - ll A ) .
  assert ( eq : ll X1 = ll A ) . apply natminusmequalsn .
  apply ( isover_geh isov ) .

  apply ell .

  rewrite eq . apply idpath .

  simpl .

  intros .  rewrite ll_T_fun .
  apply IHj .

  apply ax0 .

Defined.

Lemma ll_Tj_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
      { A X1 : BB } ( isov : isover X1 A )
      ( X2' : ltower_over A ) :
  ll ( Tj_fun ax1b isov X2' ) = ll X2' .
Proof.
  intros.
  apply ll_Tj_fun_int .

  apply ax0 .

Defined.

Lemma isllmonot_Tj_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
      { A X1 : BB } ( isov : isover X1 A ) : isllmonot ( Tj_fun ax1b isov ) .
Proof.
  intros .
  unfold isllmonot .
  intros X Y .
  repeat rewrite ll_Tj_fun .
  apply idpath .

  apply ax0.

  apply ax0.

Defined.

Lemma isbased_Tj_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
      { A X1 : BB } ( isov : isover X1 A ) : isbased ( Tj_fun ax1b isov ) .
Proof.
  intros. unfold isbased. intros X eq0 .
  rewrite ll_Tj_fun .
  exact eq0.

  exact ax0.

Defined.

Definition ltower_Tj_fun { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
      { A X1 : BB } ( isov : isover X1 A ) :
  ltower_fun ( ltower_over A ) ( ltower_over X1 ) :=
  ltower_fun_constr ( isovmonot_Tj_fun ax0 ax1a ax1b isov )
                    ( isllmonot_Tj_fun ax0 ax1b isov )
                    ( isbased_Tj_fun ax0 ax1b isov ) .

(** *** Function Tt_fun *)

(* Definition Tt_fun { BB : lBsystem_carrier }
           ( T : T_ops_type BB ) ( Tt : Tt_ops_type BB )
           ( X : BB ) : *)

*)

(** *** Function Tprod for pointed l-Bsystems *)

Definition Tprod_fun { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
           ( X1 : BB ) :
  ltower_fun BB ( ltower_over X1 ) :=
  ltower_funcomp ( @ltower_fun_to_ltower_over BB )
                 ( Tj_fun ax0 ax1a ax1b ( isoverll0 ( ll_cntr BB ) X1 ) ) .

(* Definition Tprod { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
           ( X Y : BB ) : BB := pocto ( Tprod_fun ax0 ax1a ax1b X Y ) .

Definition isover_Tprod { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
           ( X Y : BB ) : isover ( Tprod ax0 ax1a ax1b X Y ) X :=
  pr2 ( Tprod_fun ax0 ax1a ax1b X Y ) .  *)

Lemma Tprod_compt { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
      ( X Y : BB ) ( gt0 : ll X > 0 ) :
  Tprod_fun ax0 ax1a ax1b X Y = T_fun ax0 ax1a ax1b gt0 ( Tprod_fun ax0 ax1a ax1b ( ft X ) Y ) .
Proof.
  intros.
  simpl .
  unfold funcomp .
  simpl .
  assert ( gt : ll X > ll ( cntr BB ) ) . rewrite (@ll_cntr BB). apply gt0 .

  set ( isab := dirprodpair gt (isoverll0 (ll_cntr BB) X) : isabove X ( cntr BB ) ) .
  change (isoverll0 (ll_cntr BB) X) with ( isabove_to_isover isab ) .
  rewrite Tj_fun_compt .
  simpl .
  assert ( int : (isover_ft' isab) = (isoverll0 (ll_cntr BB) (ft X)) ) . apply proofirrelevance .
  apply isaprop_isover .

  rewrite int .
  assert ( int' : gt0 = (isabove_gt0 isab) ) .
  apply proofirrelevance . apply ( pr2 ( _ > _ ) ) .

  rewrite int' . apply idpath .

Defined.

(*

Proof .
  intros .
  set ( X2' := @to_ltower_over BB X2 ) .
  exact ( Tj_fun ax0 ax1a ax1b ( isoverll0 ( ll_cntr BB ) X1 ) X2' ) .

Defined.

Lemma isovmonot_Tprod { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T )  ( ax1b : T_ax1b_type T )
           ( X1 : BB ) : isovmonot ( Tprod ax1b X1 ) .
Proof .
  intros .
  unfold isovmonot .
  intros X Y isov .
  set ( X' := @to_ltower_over BB X ) . set ( Y' := @to_ltower_over BB Y ) .
  set ( isov' := isovmonot_to_ltower_over isov ) .
  exact ( isovmonot_Tj_fun ax0 ax1a ax1b ( isoverll0 ( ll_cntr BB ) X1 ) X' Y' isov' ) .

Defined.

Definition Tprod_ovmonotfun { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T )  ( ax1b : T_ax1b_type T )
           ( X1 : BB ) : ovmonot_fun BB ( ltower_over X1 ) :=
  ovmonot_fun_constr ( Tprod ax1b X1 ) ( isovmonot_Tprod ax0 ax1a ax1b X1 ) .

Lemma ll_Tprod { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
           ( X1 : BB ) ( X2 : BB ) : ll ( Tprod ax1b X1 X2 ) = ll X2 .
Proof .
  intros .
  unfold Tprod .
  rewrite ll_Tj_fun .
  rewrite (@ll_to_ltower_over BB).
  apply idpath .

  apply ax0 .

Defined.

Lemma isllmonot_Tprod { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
           ( X1 : BB ) : isllmonot ( Tprod ax1b X1 ) .
Proof .
  intros . unfold isllmonot .  intros X Y .
  repeat rewrite ll_Tprod . apply idpath .

  apply ax0 .

  apply ax0 .

Defined.

Lemma isbased_Tprod { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
           ( X1 : BB ) : isbased ( Tprod ax1b X1 ) .
Proof.
  intros. unfold isbased . intros X eq0 .
  rewrite ll_Tprod .

  exact eq0.

  exact ax0.

Defined.

Definition ltower_fun_Tprod { BB : lBsystem_carrier }
           { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1a : T_ax1a_type T ) ( ax1b : T_ax1b_type T )
           ( X1 : BB ) :
  ltower_fun BB ( ltower_over X1 ) :=
  ltower_fun_constr ( isovmonot_Tprod ax0 ax1a ax1b X1 )
                    ( isllmonot_Tprod ax0 ax1b X1 )
                    ( isbased_Tprod ax0 ax1b X1 ) .

(*

Definition isabove_Tj { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
      { A X1 X2 : BB } ( isov : isover X1 A ) ( isab : isabove X2 A ) :
  isabove ( Tj ax0 ax1b isov isab ) X1 :=
  pr1 ( pr2 ( Tj_int_package ax0 ax1b ( ll X1 - ll A ) isov ( idpath _ ) isab ) ) .

Opaque isabove_Tj .

Definition ll_Tj { BB : lBsystem_carrier }
      { T : T_ops_type BB } ( ax0 : T_ax0_type T ) ( ax1b : T_ax1b_type T )
      { A X1 X2 : BB } ( isov : isover X1 A ) ( isab : isabove X2 A ) :
  ll ( Tj ax0 ax1b isov isab ) = ll X2 - ll A + ll X1 :=
  pr2 ( pr2 ( Tj_int_package ax0 ax1b ( ll X1 - ll A ) isov ( idpath _ ) isab ) ) .

*)

*)

(* End of the file lBsystems_T_fun_Tj_Ttj.v *)


(* 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                                                     *)

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	            Functor Free Monoid : SET -> MON                         *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export FreeMonoid.
Require Export Functor.
Require Export MON.

Set Implicit Arguments.
Unset Strict Implicit.

(* SET -> MON *)

Section funfreemon_map_def.

Variable A B : Setoid.

 Section funfreemon_mor_def.

 Variable f : Map A B.

 Fixpoint Dist_fun (l : Tlist A) : Tlist B :=
   match l with
   | Empty => Empty B
   | Concat1 a l1 => Concat1 (f a) (Dist_fun l1)
   end.

 Lemma Dist_map_law : Map_law Dist_fun.
 Proof.
 unfold Map_law in |- *; intros l1; elim l1.
 intro l2; elim l2.
 intros; apply Refl.
 intros c t H H1; elim H1.
 intros c t H l2; elim l2.
 intro H1; absurd (Equal_Tlist (Concat1 c t) (Empty A)).
 apply (Diff_Concat1_Empty (A:=A)).
 trivial.
 intros c0 t0 H1 H2.
 elim H2; intros H3 H4.
 simpl in |- *; split.
 apply Pres1; trivial.
 exact (H t0 H4).
 Qed.

 Canonical Structure Dist_map := Build_Map Dist_map_law.

 Lemma Dist_map_unit_law : MonUnit_law Dist_map.
 Proof.
 unfold MonUnit_law in |- *; simpl in |- *; trivial.
 Qed.

 Lemma Dist_map_op_law : MonOp_law Dist_map.
 Proof.
 unfold MonOp_law in |- *.
 intros l1 l2; elim l1.
 unfold ApMop in |- *; apply Refl.
 intros; split.
 apply Refl.
 trivial.
 Qed.

 Canonical Structure FunFreeMon_mor :=
   Build_MonMor Dist_map_unit_law Dist_map_op_law.

 End funfreemon_mor_def.

Lemma FunFreeMon_map_law : Map_law FunFreeMon_mor.
Proof.
unfold Map_law in |- *; simpl in |- *.
intros f g; unfold Equal_MonMor in |- *; simpl in |- *.
unfold Ext in |- *; simpl in |- *; intro H; intro l; elim l; simpl in |- *.
trivial.
intros c t H1; split.
apply H.
trivial.
Qed.

Canonical Structure FunFreeMon_map := Build_Map FunFreeMon_map_law.

End funfreemon_map_def.

Lemma FunFreeMon_fcomp_law : Fcomp_law FunFreeMon_map.
Proof.
unfold Fcomp_law in |- *; simpl in |- *.
intros A B C f g; unfold Equal_MonMor in |- *; simpl in |- *.
unfold Ext in |- *; simpl in |- *; intro l; elim l; simpl in |- *.
trivial.
intros c t H; split.
apply Refl.
trivial.
Qed.

Lemma FunFreeMon_fid_law : Fid_law FunFreeMon_map.
Proof.
unfold Fid_law in |- *; simpl in |- *.
intro A; unfold Equal_MonMor in |- *; simpl in |- *.
unfold Ext in |- *; simpl in |- *; intro l; elim l; simpl in |- *.
trivial.
intros c t H; split.
apply Refl.
trivial.
Qed.

Canonical Structure FunFreeMon :=
  Build_Functor FunFreeMon_fcomp_law FunFreeMon_fid_law.