(** Az earleyParser file változásai

*)

Require Import List.
Import ListNotations.
Require Import Psatz.

Require Import Earley.datastructures.
Require Import Earley.grammarDep.

Require Import Bool.Sumbool.
Require Import Arith.
Open Scope bool_scope.

Section Earleycontext.
Variable N T:Type.
Variable G:grammar N T.

(*TODO it should be visible from grammarDep*)
Instance grammarruleInOpClass: InOpClass (rule N T) (grammar N T):=
  fun r g => In r (grammarGetRules g).

Variable i:list T. (*The input string*)

(** A két összehasonlító függvény már nem bool adattipussal tér vissza hanem sumbool-al, ami tartalmassa a bizonyítékot is. A subool valójában vagy egy bizonyítékot ad vissza arra hogy igaz vagy egyet arra hogy hamis.

*)
Variable nEq: forall (n1 n2: N), {n1 = n2} + {n1 <> n2}.
Instance nEqEqDecOpClass: EqDecOpClass N:=nEq.
Variable tEq: forall (t1 t2: T), {t1 = t2} + {t1 <> t2}.
Instance tEqEqDecOpClass: EqDecOpClass T:=tEq.

(**
Ha nullázható a megadott nemterminális szimbólum, visszaad
egy ennek megfelelő szintaxisfát.
*)
Variable isNullable: forall (n:N), Maybe (forall i k, parseTreeDep N T G i k k n).

(** Az earley item jelentősen megváltozott. Az általa tartalmazott szabály szét lett bontva 3 részre. Külön áll a bal oldal, a jobb oldal pont előtti és a pont utáni részei. Ezen túl tartalmazza az általa lefedett netminálisok listáját. Továbbra is tartalmazza az általa generált parsetreeket, most már parseForest típusban, és a származási set számát, vagy mászoóval, hogy hányadik szimbólumnál kezdődik az elemzés amit lefed az item. Tartalmaz még kettő bizonylatot, egyet arra hogy az általa lefedett terminálisok listája megegyezik az elemzendő listában levőkkel, az item kezdő pozíciótól indulva. A másik pedig azt bizonyítja, hogy az item által lefedett szabály (a 3 részből összeillesztve) része a nyelvtannak.

*)
Inductive earlyItemD:=
  eiC (n:N) (*lhs symbol*)
  (rns: list (N+T)) (*Stuff before the dot*)
  (pnd: list (N+T)) (*Stuff after the dot*)
  (poss: list nat)
  (epos: nat)
  (pf: parseForestDep N T G i poss epos rns)
  (pM: (ruleConstr n (rns++pnd)) ∊ G).

Notation "n → rns • pnd ⟨ poss , epos ⟩ pf , pM" :=
  (eiC n rns pnd poss epos pf pM)  (at level 60).

(** Függvények az earley item különböző részeinek kiszedésére.

*)

Definition eitGetRule (it:earlyItemD):=
  let (n, rns, pnd, poss, epos, pf, pM):=it
  in ruleConstr  n (rns++pnd).

Definition eitGetRuleLhs (it:earlyItemD):=
  let (n, rns, pnd, poss, epos, pf, pM):=it in n.

(**The position of the dot.*)
Definition eitGetPOD (it:earlyItemD):=
  let (n, rns, pnd, poss, epos, pf, pM):=it in length rns.

Definition eitGetStartposition (it:earlyItemD):=
  let (n, rns, pnd, poss, epos, pf, pM):=it in hd epos poss.

(*?????*)
(*Definition eitExtrCH (it:earlyItemD): sigT (fun ris: (list (list T)) => sigT (fun rns=> parseForestWithInput N T G ris rns)):=
  let (_,ris,rns,pf,_,_,_,_):=it in existT _ ris (existT _ rns pf).
*)

Definition eitGetPending (it:earlyItemD):=
  let (n, rns, pnd, poss, epos, pf, pM):=it in pnd.

(*
Definition eitExtrRis (it:earlyItemD):=
  let (_,ris,_,_,_,_,_,_):=it in ris.*)

Definition eitGetEndPos (it:earlyItemD):=
  let (n, rns, pnd, poss, epos, pf, pM):=it in epos.

(** A befejezett earley set-ekhez hozzá került a set száma, és egy bizonyítás, hogy az általa lefedett terminálisok a kadik nál érnek véget.

*)

Definition completedEarleySets :=
  list {k:nat & list {it:earlyItemD | eitGetEndPos it = k}}.

(*
Instance ruleEqDecOpClass: EqDecOpClass (rule N T).
intros [n1 rh1] [n2 rh2].
destruct a.
Admitted.*)

Existing Instance ruleEqDecOpClass.

Definition eiEq (ei1 ei2:earlyItemD): bool.
refine(
  Nat.eqb (eitGetStartposition ei1) (eitGetStartposition ei2) &&
  Nat.eqb (eitGetPOD ei1) (eitGetPOD ei2) &&
  (if (eitGetRule ei1) =?= (eitGetRule ei2) then true else false)
).
(*Coq should be able to find it automatically!*)
eapply ruleEqDecOpClass; auto.
Defined.

(** Az éppen elemzett itemek listájához is hozzákerült ugyanaz mint a befejezettekhez.

*)

Inductive earleySetUnderConstruction: nat->Type:=
    sucC k (completed:(list {it:earlyItemD | eitGetEndPos it = k}))
         (pending:(list {it:earlyItemD | eitGetEndPos it = k})):
  earleySetUnderConstruction k.

Definition getNextUnprocessed k (s:earleySetUnderConstruction k):=
  match s with
    | sucC k c p =>
    match p with
      | nil => Nothing
      | cons h _ => Just h
    end
  end.

Definition markAsCompleted k (s:earleySetUnderConstruction k):
  earleySetUnderConstruction k:=
  match s in earleySetUnderConstruction k0 return earleySetUnderConstruction k0 with
    | sucC k c p =>
    match p with
      | nil => sucC k c p
      | cons h t => sucC k (cons h c) t
   end
  end.

Fixpoint isItemInList k
 (i:earlyItemD) (items:list {it:earlyItemD | eitGetEndPos it = k}):bool :=
  match items with
    |cons (exist _ hd _) tl =>
      if eiEq hd i
      then true
      else isItemInList k i tl
    | nil => false
    end.

(** Az insertIntoESC függvény az earley item mellé a szükséges bizonyítást is beleteszi a listába. Ezt bemenő paraméterként kapja meg.

*)

Fixpoint insertIntoESC
  k (e:earleySetUnderConstruction k) (ni:earlyItemD) (prf: eitGetEndPos ni = k):
      earleySetUnderConstruction k.
refine(
    match e in earleySetUnderConstruction k0 return k=k0 -> earleySetUnderConstruction k0 with
          | sucC k1 comp pend => fun heq =>
            match (isItemInList k1 ni comp) ,
                  (isItemInList k1 ni pend) with
              | false, false => sucC k1 comp (pend ++  [exist _ ni _])
              | _,_ => sucC k1 comp pend
            end
    end eq_refl
).
rewrite <- heq.
exact prf.
Defined.

(** Ez a függvény továbbra is a pont utáni első elemet olvassa ki, ami most a pont utáni szimbólumok listájának az első eleme. Hogyha nincs következő elem, bizonyítékot adunk vissza arra, hogy a szabálynak nincs több megvizsgálandü eleme.

*)
Definition getNextSymbolFromEarleyItem (it:earlyItemD): (N+T) + {eitGetPending it = nil}.
refine (
  (let (n, rns, pnd, poss, epos, pf, pM) as it0 return it = it0 -> _ := it in fun ieq =>
      match pnd as pnd0 return pnd = pnd0 -> _ with
        | nil => fun heq => inright _
        | cons hd _ => fun heq => inleft hd
      end eq_refl)
  eq_refl
).
try rewrite ieq. (*needed for version 8.6 coq*)
simpl.
exact heq.
Defined.

(** Ez a függvény a befejezett earley setek közül visszaadja a k-adikat.

*)

Fixpoint getKfromCes k (ces:completedEarleySets): list {it:earlyItemD | eitGetEndPos it = k}.
refine (
  match ces with
    | nil=> nil
    | cons (existT _ k0 hd) tl =>
    match Nat.eq_dec k k0  with
      | left _ => _
      | right _ => getKfromCes k tl
    end
  end
).
rewrite e.
exact hd.
Defined.

(** A lookup a megfelelő itemek mellé tesz két bizonyítékot is, arra hogy a következő szimbólum valóban a megfelelő nemterminális, ittelve a bizonyíték hogy az adott setnél van a feldolgozott terminálisok vége.
*)

Fixpoint lookupAux (pos:nat) (eil:list {it:earlyItemD | eitGetEndPos it = pos}) (B:N) {struct eil}:
(list ({it : earlyItemD | getNextSymbolFromEarleyItem it = inleft (inl B) /\ eitGetEndPos it = pos})).
refine(
  match eil with
    | cons (exist _ hd prf) tl =>
    match getNextSymbolFromEarleyItem hd as pr
    return getNextSymbolFromEarleyItem hd = pr -> _
    with
      | inleft (inl x) => fun heq => if nEq x B then

        cons (exist _ hd _) (lookupAux pos tl B)
   else lookupAux pos tl B
      | _ => fun heq => lookupAux pos tl B
    end eq_refl
    | nil => nil
  end
).
split.
rewrite <- e.
exact heq.
exact prf.
Defined.

Fixpoint lookup (ces:completedEarleySets) (B:N) (pos:nat):
(list ({it : earlyItemD | getNextSymbolFromEarleyItem it = inleft (inl B) /\ eitGetEndPos it = pos})).
refine (
  match ces with
    | nil => nil
    | cons (existT _ k hd) tl =>
    match Nat.eq_dec k pos with
      | left _ =>_
      | right _ => lookup tl B pos
    end
  end
).
rewrite <- e.
exact (lookupAux k hd B).
Defined.

(** A part of input függvény bool helyett sumbool típust ad vissza.

*)

Fixpoint AtPosDec (t:T) (ii:list T) (k:nat):
{AtPos T t ii k}+{~AtPos T t ii k}.
refine(
  match k as k0, ii as ii0
  return {AtPos T t ii0 k0}+{~AtPos T t ii0 k0}
  with
    | S n, cons hd tl =>
        if AtPosDec t tl n then left _ else right _
    | O, hd :: tl => if tEq hd t then left _ else right _
    | _,_ => right _
    end
).
intros H.
inversion H.
rewrite e.
apply atposHead.
intros H.
inversion H.
congruence.
intros H.
inversion H.
apply (atposTail _ _ _ _ _ a).
intros H.
inversion H.
congruence.
Defined.

(** A dotacvancer is jelentős változásokon ment keresztül, az earley item változtatása miatt. A pont mozgatásához hozzá kell adnunk a lefedett terminálisokhoz az újonnan lefedetteket, és szolgáltatni kell az earley itemhez tartozó kettő bizonyítékot, illetve a parseforesthez hozzá kell tenni a a megfelelő szintaxisfát. Ezen túl a pont mozgatása is megváltozott, hiszen nem egy szémot kell növelni, hanem áttenni a szabály még nem elemzett részének az első elemét a már elemzettek végére. Bejövő paraméterként kapjuk a lefedett terminálisok listáját, a nemterminálist amin túlmozgatjuk a pontot, a szintaxisfát ami ábrázolja a lefedett terminálisokat, az itemet amiben mozgatjuk a pontot. Illetve bizonyítékot hogy tényleg a megfelelő nemterminális áll a pont után, és hogy a lefedett terminálisok, a megfelelő pozícióban részei az elemzendő szövegnek.

*)
Definition dotAdvancerN
  (b1 e1: nat) (*The input, covered by the new part*)
  (n1:N)           (*Nonterminal symbol, were the dot is advanced*)
  (ch:parseTreeDep N T G i b1 e1 n1)
                  (*The parsetree that parses the input*)
  (it:earlyItemD) (*Earley item subject to dot advacement*)
  (nip : getNextSymbolFromEarleyItem it = inleft (inl n1))
             (*Proof that really there is a b after the dot in it*)
  (iinp : (eitGetEndPos it) = b1)
             (*Proof, thet input really is part of the whole
                 imput at the apropriate position*)
    : earlyItemD. (*Return it modified with the dot advanced
                    one position*)
refine (
  match it as k
  return it = k ->
         getNextSymbolFromEarleyItem k = inleft (inl n1)->
         earlyItemD
  with n → rns • pnd ⟨ poss , epos ⟩ pf, pM => fun ieq neq =>
    match pnd as pnd0
    return pnd = pnd0 ->
           forall pM2,
           getNextSymbolFromEarleyItem
             (n → rns • pnd0 ⟨ poss , epos ⟩ pf, pM2) =
           inleft (inl n1) ->
           earlyItemD
    with
      | nil => fun heq hpm neq2 => it
      | cons hd tl => fun heq hpm neq2 =>
        n → rns++[hd] • tl ⟨ poss++[epos] , e1 ⟩ _ , _
    end eq_refl pM neq
  end eq_refl nip

).
simpl in neq2.
assert (be : hd = inl n1).
injection neq2.
auto.
rewrite be.

rewrite ieq in iinp.
cbn in iinp.
rewrite <- iinp in ch.
exact (ptSnocN _ _ _ _ _ _ _ _ _ pf ch).

rewrite <- app_assoc.
apply hpm.
Defined.

Definition parseTreeFromCompletedEarlyItem bpos epos root
    (it:earlyItemD)
    (pendIsNull: eitGetPending it = nil)
    (bEq: bpos = eitGetStartposition it)
    (eEq: epos = eitGetEndPos it)
    (rootEq: root = eitGetRuleLhs it):
    parseTreeDep N T G i bpos epos root.
refine(
  match it as it0
  return it = it0 -> _
  with n → rns • pnd ⟨ poss , epos ⟩ pf, pM => fun Heq =>
     _
  end eq_refl
).
rewrite Heq in *.
cbn in eEq, bEq, rootEq, pendIsNull.
clear Heq.
rewrite pendIsNull in pM.
rewrite eEq,  rootEq.
rewrite app_nil_r in pM.

eapply (ptNode G i n rns bpos poss epos pf pM ?[pEqb]).
[pEqb]:{
  destruct poss; cbn in *; congruence.
}
Defined.

(** Egy bizonyatott tétel arra, hogy ha a a dotadvancert nullázható nemterminálisra használjuk, ahol a lefedett terminálisok listája az üres lista, akkor az eddig lefedett terminálisok listájának a vége nem változik.

*)

Theorem dotadvancerNul:
 forall bpos n x ei heq prf, eitGetEndPos (dotAdvancerN bpos bpos n x ei heq prf) = eitGetEndPos ei.
Proof.
  intros bpos n x ei heq prf.
  destruct ei.
  simpl.
  destruct pnd.
  simpl.
  reflexivity.
  simpl.
  simpl in prf.
  auto.
Qed.

(** Egy bebizonyított tétel, hogy a dotadvancer haszálata után, az utolsó lefedett terminális pozíciója megegyezik az item által utoljára lefedett szimbóluméval

*)
(*
eitGetEndPos
  (dotAdvancerN x k inn (ptNode G i x k inn irns istart irnp ipf ?Goal)
     hd ?Goal0 ?Goal1) = k
*)
Theorem dotadvancerXk: forall hd x k inn pt p0 p1
  (prx:eitGetEndPos hd = x)
  (pnn: eitGetPending hd <> nil),
eitGetEndPos (dotAdvancerN x k inn pt hd p0 p1) = k.
Proof.
  intros.
  destruct hd.
  simpl.
  destruct pnd.
  simpl in *.
  discriminate.
  simpl.
  simpl in prx.
  auto.
Qed.

(** A predictor továbbra is a megfelelő earley itemeket fogja létrehozni, de szolgáltatnia kell bizonyítékokat. A bizonyíték hogy az elemzett terminálisok vége a egfelelő helyen van egyszerű, hiszen a jelen setben kezdődik és a vége is itt ban mert még nem elemeztünk semmit. Az eddig lefedett terminálisok listéja az üreslista, mindenképpen része az eredeti listának. A bizonyítékot hogy a szabály része a nyelvtannak a gExtrRulD függvény szolgáltatja. Az üres szabályokat itt isfigyelembevesszük.

*)

Fixpoint predictorAux (k:nat) (n:N) (r:list({s: rule N T | s ∊ G} ))
    (s_curr:earleySetUnderConstruction k) : earleySetUnderConstruction k.
refine (
  match r with
    | (exist _ head headProof) :: tail =>
    match (lhs head) =?= n with
      | left prf => predictorAux k n tail
            (insertIntoESC k s_curr
              (*eiC n k nil nil (pfNil N T G i k) (rhs head) _ *)
              (n → nil • (rhs head) ⟨nil, k⟩ (pfNil N T G i k), _)
              eq_refl)
      | right prf => predictorAux k n tail s_curr
    end
    | nil => s_curr
  end
).
simpl.
rewrite <- prf.
rewrite ruleReassemble.
exact headProof.
Defined.

Fixpoint predictor (k:nat) (ei:earlyItemD)
    (s_curr:earleySetUnderConstruction k) (prf: eitGetEndPos ei = k):
      earleySetUnderConstruction k.
refine(
       match (getNextSymbolFromEarleyItem ei) as eii
       return getNextSymbolFromEarleyItem ei = eii -> _
       with
         | inleft (inl n) => fun heq =>
         let sNext := predictorAux k n
             (listToMembershipProofList (grammarGetRules G))
             s_curr in
         match isNullable n with
           | Just x => insertIntoESC k sNext
             (dotAdvancerN k k n
                 (x i k) ei heq prf) _
           | Nothing => sNext
         end
         | _ => fun heq => s_curr
       end eq_refl
).
rewrite <- prf.
apply dotadvancerNul.
Defined.

(** A scannernek is nyújtania kell bizonyos bizonyítékokat. Bizonyatani kell hogy amikor a scanner előremozgatja a pontot egy itemben, az item által lefedett terminálisok listája egyel hosszabb lesz, az új elemmel együtt is része az eredeti terminálisok listájának, és a szabály továbbra is része a nyelvtannak.

*)

Definition scanner (k:nat) (it:earlyItemD)
  (s_next:earleySetUnderConstruction (S k))
   (kOneAhead: (eitGetEndPos it) = k)
  : earleySetUnderConstruction (S k).
refine (
    match it as iit return it = iit -> _
    with n → rns • pnd ⟨poss, epos⟩ pf , pM => fun ieq =>
      match pnd as pnd0 return pnd = pnd0 -> _ with
        | cons (inr t) tl => fun heq =>
        match (AtPosDec t i k) with
          | left p =>
            (insertIntoESC (S k) s_next
              (n → (rns ++ [inr t]) • tl ⟨poss++[epos], epos+1⟩
                (ptSnocT _ _ _ i _  epos _ pf t _) , _)
            _)
       | _ => s_next
     end
    | _ => fun heq => s_next
    end eq_refl
    end eq_refl
).
Unshelve.
simpl.
rewrite ieq in kOneAhead.
simpl in kOneAhead.
lia.
rewrite ieq in kOneAhead.
simpl in kOneAhead.
rewrite kOneAhead.
exact p.
rewrite <- app_assoc.
simpl.
rewrite <- heq.
exact pM.
Defined.

(** A transferItems a lookup által visszaadott listának az elemeire meghívja a dotadvancert, és beírja őket a jelenlegi setbe. Ehez előállítjuk a bizonyítékot az insert függvény számára, hogy megfelelő helyen ér véget a lefedett terminálisok listája, ehez felhasználjuk a bemenetként megadott bizonyítékokat a befejezett szabály által lefedett szimbólumok kezdő és vég pontjára, illetve a dotadvancerXk tételt. A dotadvancernek szükséges bizonítékokat előállítjuk az itemben tárolt bizonyatékokból, és parsetreeeben térolt bizonyítékokat is, a befejezett earley itemben levő bizonyítékokkal, valamint inputként megkapjuk hogy a beffejezett szabály bal oldala megegyezik a B paraméterrel, és nincs több vizsgálatlan elem a szabályban.

*)

Fixpoint transferItems (x:nat) (k:nat) (B:N) (it:earlyItemD)
           (pendIsNull: eitGetPending it = nil)
           (beginIsX: eitGetStartposition it = x)
           (endIsK : eitGetEndPos it = k)
           (lhsIsB : (eitGetRuleLhs it) = B)
           (source: list {it : earlyItemD |
               getNextSymbolFromEarleyItem it = inleft (inl B)
               /\  eitGetEndPos it = x} )
           (target: earleySetUnderConstruction k):
           earleySetUnderConstruction k.
refine(
match it as iit
return it = iit -> earleySetUnderConstruction k
with
  eiC inn istart irns irnp ipf ipnd ipM =>
   fun ieq =>
  match source as ssource return source = ssource -> _ with
    | nil => fun _ =>target
    | cons (exist _ hd (conj prf1 prf2)) tl => fun seq =>
        transferItems  x k B it pendIsNull beginIsX endIsK lhsIsB tl
        (insertIntoESC k target
          (
             dotAdvancerN x k B
                (parseTreeFromCompletedEarlyItem _ _ _ it _ _ _ _)
                 hd _ _
          )
        _)
  end eq_refl
end eq_refl
).

eapply (dotadvancerXk _ x k).
exact prf2.
destruct hd.
destruct pnd;
cbn in prf1 |- *;
congruence.
Unshelve.
all:firstorder.
Defined.

(** A completernek nem sok feladata maradt, meghívja a lookup függvényt, majd az általa visszaadott értékkel, és további megfleleő paraméterekkel a transferItems függvényt. Ehhez a bizonyítékokat a kezdő pozícióra és a B paraméterre vonatkozókhoz elég egy egyszerű reflexivitási tétel, hiszen pont onnan olvastuk ki őket amivel meg kell egyeznie, a másik kettőt pedig beneő paraméterként fogja megkapni.

*)

Definition completer (k:nat) (it:earlyItemD)
   (s_completed: completedEarleySets)
   (s_curr:earleySetUnderConstruction k)
   (pendIsNull: eitGetPending it = nil)
   (endPosIsK: eitGetEndPos it = k):
      earleySetUnderConstruction k.
refine(
  let source := lookup s_completed ((eitGetRuleLhs it))
                       (eitGetStartposition it) in
  transferItems (eitGetStartposition it) k ((eitGetRuleLhs it))
  it pendIsNull eq_refl endPosIsK eq_refl source s_curr

).
Defined.

(** A findRules tovébbra is azokat a szabályokat keresi, aminek a kezdőszimbólum áll a bal oldalán. A gExtrRul függvény által visszaadott listának minden eleméhez tartozik egy bbizonyítás, hogy beletartozik a nyelvtanba. Mindig abba a felébe kell belenézni amiben a szabály van, de az eredmény listába a teljes elemeket kell beletenni.

*)
Definition findRules (n:N) : list {a : rule N T | In a (grammarGetRules G)}:=
  let lp := (listToMembershipProofList (grammarGetRules G)) in
  filter  (fun '(exist _ r _) => if nEq n (lhs r) then true else false ) lp.

(** A oneSet függvény nem sokat változott, az alapvető működése ugyanaz, de a meghívott fügvényekhez bizonyítékokat kell adn. A predictornak és a csannernek csak egy bizonyíték kell, a vizsgált earley item által lefedett terminálisok végéről, ezt ki tudjuk olvasni az itemből. A completernek ugyanez mellé kell mégegy bizonyíték, ami azt igazolja, hogy nincs több elem a vizsgálatra váró részében, ez a match-ből ered, abban az ágában hívjuk meg, amikor nem tudtunk beolvasni több elemet a listából.

*)

Fixpoint oneSet (k:nat)
  (s_completed: completedEarleySets)
  (s_curr:earleySetUnderConstruction k)
  (s_next:earleySetUnderConstruction (S k))
  (num:nat):
  completedEarleySets * earleySetUnderConstruction (S k).
refine(
  match num , getNextUnprocessed k s_curr with
    | S x, Just (exist _ it prf) =>
    match getNextSymbolFromEarleyItem it with
      | inleft nt =>
      match nt with
        | inl n => oneSet k
           s_completed
          (markAsCompleted k (predictor k it s_curr prf))
          s_next x
        | inr t =>

          oneSet k s_completed
          (markAsCompleted k s_curr)
          (scanner k it s_next prf)
          x
      end
      | inright heq =>
          oneSet k s_completed
          (markAsCompleted k (completer k it s_completed s_curr heq prf))
          s_next x
    end
    | _,_ => (s_completed++[(let (k0,A,_):= s_curr in existT _ k0 A)],s_next)
  end
).
Defined.

Fixpoint ParserAux
  (k:nat)
  (s_completed: completedEarleySets)
  (s_curr:earleySetUnderConstruction k)
  (s_next:earleySetUnderConstruction (S k))
  (lng fuel:nat):
  completedEarleySets:=
    match lng with
      | S x =>
          match (oneSet k s_completed
          s_curr s_next fuel) with
            | (a,b) => ParserAux (S k) a b
                              (sucC (S (S k)) nil nil) x fuel
          end
      |_ => s_completed
  end.

(**Az isNil megállapítja, hogy a megadott lista üres-e. A visszatérési érték sumbool.

*)

Definition isNil {A:Type} (a:list A): {a = nil}+{a <> nil}.
refine(
  match a as aa return {aa = nil}+{aa <> nil} with
    | nil => left eq_refl
    | _ => right _
  end
).
discriminate.
Defined.

(** A proofFilter a filterhez hasonlóan működik, szüksége van bemeneti paraméterként egy listára és egy függvényre amit a lista elemeire meghívva egy sumbool értéket ad vissza. Amire az érték igaz, azt beletesszük a visszatérési listába, a sumboolban levő bizonyítékkal együtt.

*)

Fixpoint proofFilter {A:Type} {P Q : A -> Prop} (f: forall a:A , {P a} + {Q a}) (l: list A): list {a:A | P a}:=
  match l with
    | nil => nil
    | cons hd tl =>
      match (f hd) with
         | left p => exist _ hd p :: (proofFilter f tl)
         | _ => (proofFilter f tl)
      end
    end.

(** A makeces függvény egy új függvény, ez fogha a parserAuxot meghívni, ez állítja elő a teljes befejezett earley seteket. A makeces állítja itt elő a szükséges üres setek listáját, meghívja a findrulest, és a visszaadott szabályokhoz earley itemeket csinál, üres parseforestekkel, és bizonyításokkal. A bizonyítások egyszerüek, minden feldolgozott terminális lista üres, tehét az eleje és a vége is 0, a szabály nyelvtanbatartozását pedig bizonyítja a findRules függvény.

*)

Definition makeCes (fuel:nat): completedEarleySets.
refine (

  ParserAux 0 nil
    (sucC O nil
        (map (fun '(exist _ r p) => exist _
    ((lhs r) → nil • (rhs r) ⟨nil, 0⟩ (pfNil N T G i 0) , _)
            _)
        (findRules (grammarGetStart G)))
    )
    (sucC 1 nil nil) (length i+1) fuel
).
simpl.
reflexivity.
Unshelve.
simpl.
cbn in p.
rewrite ruleReassemble.
exact p.
Defined.

(** A parser függvény meghívja a makeCes függvényt, majd az utolsó setből kiválasztja az early itemet ami megfelel a hátom kritériumnak, a proofFilterrel. A szabály végén van a pont, erre használjuk az isNil függvényt, a kezdőszimbólum a baloldala, és az nulladik setben kezdődött. Ha nem találunk ilyen semmti adunk vissza, ha találunk ilyeneket, akkor az elsőt, kiválasztjuk és visszaadjuk parseTreeDepWithInput-ot.

*)

Definition Parser
  (fuel:nat): Maybe (parseTreeDep N T G i 0 (length i) (grammarGetStart G)).
refine(
  let ces := makeCes fuel
    in let finalItemE := getKfromCes (length i) ces in

    let ptree := proofFilter (fun it =>
      sumbool_and _ _ _ _ (sumbool_and _ _ _ _ (nEq (lhs (eitGetRule (proj1_sig it))) (grammarGetStart G) )

      (isNil (eitGetPending (proj1_sig it))))
      (Nat.eq_dec (eitGetStartposition (proj1_sig it)) O)) finalItemE
    in match ptree with
         | nil => Nothing
         | cons (exist _ hd hdprf) _ =>
         match hd as hhd return hd = hhd -> _ with
           | exist _ e prf => fun hdeq =>
           match e as ee return e = ee -> _ with
             | (*eiC n bpos rns rnp pf pnd pM =>*)
               n → rns • pnd ⟨poss, epos⟩ pf , pM =>

 fun heq => Just _
           end eq_refl
         end eq_refl
       end

).
clear ptree.

rewrite hdeq in hdprf.
simpl in hdprf.
clear hdeq.
rewrite heq in prf.
simpl in prf.
rewrite heq in hdprf.
simpl in hdprf.
destruct hdprf as [[hdprf1 hdprf2] hdprf3].
clear heq.
rewrite <- prf.
(*rewrite hdprf3 in pf |- *.*)
eapply ptNode.
apply pf.
rewrite hdprf2 in pM.
rewrite <- app_nil_end in pM.
rewrite <- hdprf1.
apply pM.
destruct poss; cbn in *; congruence.
Defined.

End Earleycontext.

Print Assumptions Parser.
(*Arguments eitGetRule [N T] _.
Arguments eitGetPOD [N T] _.
Arguments eitExtrSP [N T] _.
Arguments getNextUnprocessed [N T] _.
Arguments insertIntoESC [N T] _ _ _ _.
Arguments getNextSymbolFromEarleyItem [N T] _.
Arguments predictor [N T] _ _ _ _ _ _.
Arguments scanner [N T] _ _ _ _ _ _.
*)


Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import
        syntax_ott
        Infrastructure
        Target_Adequacy
        Logical_Relation_Def
        Logical_Relation_Infrastructure
        Target_Safety
        Normalize.

Lemma disjoint_rel_v : forall A1 A2 v1 v2,
    disjoint A1 A2 ->
    nil |= v1 ~: (|A1|) ->
    nil |= v2 ~: (|A2|) ->
    value v1 ->
    value v2 ->
    rel_v (|A1|) (|A2|) v1 v2.
Proof.
  introv Dis. gen v1 v2.
  induction Dis; introv Ty1 Ty2 Val1 Val2; try solve [simpls*].

  apply~ rel_v_unit.
  apply~ rel_v_unit2.

  simpls.
  splits*.
  introv Rel.
  lets [? ?] : rel_v_well_type Rel.
  assert (HH1 : nil |= (trm_app v1 a1) ~: | A2 |) by autos*.
  assert (HH2 : nil |= (trm_app v2 a2) ~: | B2 |) by autos*.
  lets (v3 & ? & Red1): normalization HH1.
  lets (v3' & ? & Red2): normalization HH2.
  lets* : preservation_multi_step Red1.
  lets* : preservation_multi_step Red2.
  exists* v3 v3'.

  lets* (v1' & v2' & ? & ? & ?) : prod_canonical Ty1.
  substs.
  inverts Ty1.
  apply rel_v_proj1. splits*.

  lets* (v1' & v2' & ? & ? & ?) : prod_canonical Ty2.
  substs.
  inverts Ty2.
  apply rel_v_proj2. splits*.

  (* recrds *)
  simpls.
  splits*.
  lets* (v1' & ?): rcd_canonical Val1 Ty1.
  lets* (v2' & ?): rcd_canonical Val2 Ty2.
  substs.
  case_if*.
  inverts Val1.
  inverts Val2.
  inverts Ty1.
  inverts Ty2.
  exists~ v1' v2'.
  splits*.
  simpls.
  splits*.
  case_if*.
Qed.

Lemma disjoint_rel_e_open : forall G1 G2 t1 t2 T1 T2,
    G1 |= t1 ~: | T1 | ->
    G2 |= t2 ~: | T2 | ->
    disjoint T1 T2 ->
    rel_e_open G1 G2 t1 t2 (| T1 |)  (| T2 |).
Proof.
  introv Ty1 Ty2 Dis.
  splits*.
  introv GG.
  lets (HH1 & HH2): bind_close  Ty1 Ty2 GG.
  lets (v1 & ? & ?): normalization HH1.
  lets (v2 & ? & ?): normalization HH2.
  lets* : preservation_multi_step H0.
  lets* : preservation_multi_step H2.
  splits*.
  exists~ v1 v2.
  splits*.
  apply~ disjoint_rel_v.
Qed.

Lemma compat_var : forall G1 G2 x A1 A2,
    uniq G1 -> uniq G2 -> binds x A1 G1 -> binds x A2 G2 ->
    rel_e_open G1 G2 (trm_var_f x) (trm_var_f x) A1 A2.
Proof.
  intros.
  unfolds.
  splits*.
  introv GG.
  (* gen A1 A2. *)
  induction GG.
  invert H1.

  simpls.
  lets [[? [? ?]]|[? ?]] : binds_cons_uniq_1 H H1; substs;
    lets [[? [? ?]]|[? ?]] : binds_cons_uniq_1 H0 H2; substs; tryfalse; case_if*.

  lets* [? ?]: rel_v_well_type H5.
  repeat rewrite* bind_value; try (sapply* value_no_fv).
  apply~ rel_v_in_rel_e.
Qed.

Lemma compat_unit1 : forall G1 G2 t T,
    G2 |= t ~: T -> uniq G1 -> rel_e_open G1 G2 trm_unit t a_unit T.
Proof.
  introv H ?.
  unfolds.
  splits*.
  introv GG.
  assert (HH : G1 |= trm_unit ~: a_unit) by auto.
  lets (? & HH1): bind_close HH H GG.
  lets (v & ? & H3): normalization HH1.
  lets : preservation_multi_step HH1 H3.
  rewrite* bind_value; try solve [simpl; fsetdec].
  splits*.
  exists trm_unit v.
  splits*.
  apply~ rel_v_unit.
Qed.

Lemma compat_unit2 : forall G1 G2 t T,
    G2 |= t ~: T -> uniq G1 -> rel_e_open G2 G1 t trm_unit T a_unit.
Proof.
  introv H ?.
  unfolds.
  splits*.
  introv GG.
  assert (HH : G1 |= trm_unit ~: a_unit) by auto.
  lets (HH1 & ?): bind_close H HH GG.
  lets (v & ? & H3): normalization HH1.
  lets : preservation_multi_step HH1 H3.
  (* rewrite* bind_value; try solve [simpl; fsetdec]. *)
  splits*.
  exists v trm_unit.
  splits*.
  rewrite* bind_value; try solve [simpl; fsetdec].
  apply~ rel_v_unit2.
Qed.

Lemma compat_int : forall G i,
    uniq G -> rel_e_open G G (trm_lit i) (trm_lit i) a_nat a_nat.
Proof.
  intros.
  unfolds.
  splits*.
  introv GG.
  repeat rewrite* bind_value; try solve [simpl; fsetdec].
  apply~ rel_v_in_rel_e.
  splits*.
Qed.

Lemma compat_app : forall G1 G2 t1 t2 t3 t4 T1 T2 T1' T2',
    rel_e_open G1 G2 t1 t2 (a_arrow T1 T1') (a_arrow T2 T2') ->
    rel_e_open G1 G2 t3 t4 T1 T2 ->
    rel_e_open G1 G2 (trm_app t1 t3) (trm_app t2 t4) T1' T2'.
Proof.
  introv Rel1 Rel2.
  destruct Rel1 as (HH1 & HH2 & Rel1).
  destruct Rel2 as (HH3 & HH4 & Rel2).
  splits*.
  introv GG.
  lets Rel1' : Rel1 GG.
  lets Rel2' : Rel2 GG.
  repeat rewrite bind_app.
  destruct Rel1' as (Rel1' & ? & ?).
  destruct Rel1' as (v1 & v1' & ? & ? & Red1 & Red1' & Rel1').
  destruct Rel2' as (Rel2' & ? & ?).
  destruct Rel2' as (v2 & v2' & ? & ? & Red2 & Red2' & Rel2').
  lets [? ?]: bind_close HH1 HH2 GG.
  lets [? ?]: bind_close HH3 HH4 GG.
  apply rel_e_convr with (t' := trm_app v1' v2'); auto_star.
  apply rel_e_convl with (t := trm_app v1 v2); auto_star.
  destruct Rel1' as (? & ? & ? & ? & Rel1').
  lets [? ?]: bind_close HH3 HH4 GG.
  lets* : preservation_multi_step Red2.
  lets* : preservation_multi_step Red2'.
  forwards * : Rel1' Rel2'.

  splits*.
  apply star_trans with (b := trm_app v1 (bind g1 t3)).
  apply~ multi_red_app2.
  apply~ multi_red_app.
  apply star_trans with (b := trm_app v1' (bind g2 t4)).
  apply~ multi_red_app2.
  apply~ multi_red_app.
Qed.

Lemma compat_pair1 : forall G1 G2 T1 T2 T3 t1 t2 t3,
    rel_e_open G1 G2  (trm_pair t1 t2) t3 (a_prod T1 T2) T3 <->
    rel_e_open G1 G2 t1 t3 T1 T3 /\
    rel_e_open G1 G2 t2 t3 T2 T3.
Proof.
  intros.
  splits.
  introv H.

  - Case "->".
    destruct H as (H & ? & ?).
    splits.

    inverts H.
    splits*.
    introv GG.
    lets : H1 GG.
    rewrite bind_pair in H.
    destruct H as (HH & Ty1 & Ty2).
    inverts Ty1.
    lets* (v1 & ? & ?): normalization H5.
    lets* (vv & ? & ?): normalization Ty2.
    lets* (v2 & ? & ?): normalization H9.
    destruct HH as (vv1 & ? & ? & ? & ? & ? & Imp).
    lets (? & ?) : rel_v_well_type Imp.
    lets* (v1' & v2' & ? & ? & ?) : prod_canonical H15.
    substs.
    assert (trm_pair (bind g1 t1) (bind g1 t2) ->* trm_pair v1 v2).
    sapply* multi_red_pair.
    lets* : value_unique H13 H19.
    inverts H20.
    apply rel_v_proj1 in Imp.
    destruct Imp.
    my_simplfier.
    splits*.
    exists v1 vv.
    splits*.

    inverts H.
    splits*.
    introv GG.
    lets : H1 GG.
    rewrite bind_pair in H.
    destruct H as (HH & Ty1 & Ty2).
    inverts Ty1.
    lets* (v1 & ? & ?): normalization H5.
    lets* (vv & ? & ?): normalization Ty2.
    lets* (v2 & ? & ?): normalization H9.
    destruct HH as (vv1 & ? & ? & ? & ? & ? & Imp).
    lets (? & ?) : rel_v_well_type Imp.
    lets* (v1' & v2' & ? & ? & ?) : prod_canonical H15.
    substs.
    assert (trm_pair (bind g1 t1) (bind g1 t2) ->* trm_pair v1 v2).
    sapply* multi_red_pair.
    lets* : value_unique H13 H19.
    inverts H20.
    apply rel_v_proj1 in Imp.
    destruct Imp.
    my_simplfier.
    splits*.
    exists v2 vv.
    splits*.

  - Case "<-".
    introv H.
    destruct H as (H1 & H2).
    destruct H1 as (? & ? & Imp1).
    destruct H2 as (? & ? & Imp2).
    splits*.
    introv GG.
    lets Imp1' : Imp1 GG.
    lets Imp2' : Imp2 GG.
    clear Imp1 Imp2.
    destruct Imp1' as (Imp1' & ? & ?).
    destruct Imp1' as (v1 & ? & ? & ? & ? & ? & Imp1').
    destruct Imp2' as (Imp2' & ? & ?).
    destruct Imp2' as (v2 & ? & ? & ? & ? & ? & Imp2').
    my_simplfier.

    rewrite bind_pair.
    splits*.
    exists (trm_pair v1 v2) x0.
    splits*.
    sapply* multi_red_pair.
    apply rel_v_proj1.
    splits~.
Qed.

Lemma compat_pair2 : forall G1 G2 T1 T2 T3 t1 t2 t3,
    rel_e_open G1 G2 t3 (trm_pair t1 t2) T3 (a_prod T1 T2) <->
    rel_e_open G1 G2 t3 t1 T3 T1 /\
    rel_e_open G1 G2 t3 t2 T3 T2.
Proof.
  intros.
  splits.
  introv H.

  - Case "->".
    destruct H as (? & HH & ?).
    splits.

    inverts HH.
    splits*.
    introv GG.
    lets : H0 GG.
    rewrite bind_pair in H1.
    destruct H1 as (HH & Ty1 & Ty2).
    inverts Ty2.
    lets* (v1 & ? & ?): normalization H6.
    lets* (vv & ? & ?): normalization Ty1.
    lets* (v2 & ? & ?): normalization H9.
    destruct HH as (? & vv1 & ? & ? & ? & ? & Imp).
    lets (? & ?) : rel_v_well_type Imp.
    lets* (v1' & v2' & ? & ? & ?) : prod_canonical H16.
    substs.
    assert (trm_pair (bind g2 t1) (bind g2 t2) ->* trm_pair v1 v2).
    sapply* multi_red_pair.
    lets* : value_unique H14 H19.
    inverts H20.
    apply rel_v_proj2 in Imp.
    destruct Imp.
    my_simplfier.
    splits*.
    exists vv v1.
    splits*.

    inverts HH.
    splits*.
    introv GG.
    lets : H0 GG.
    rewrite bind_pair in H1.
    destruct H1 as (HH & Ty1 & Ty2).
    inverts Ty2.
    lets* (v1 & ? & ?): normalization H6.
    lets* (vv & ? & ?): normalization Ty1.
    lets* (v2 & ? & ?): normalization H9.
    destruct HH as (? & vv1 & ? & ? & ? & ? & Imp).
    lets (? & ?) : rel_v_well_type Imp.
    lets* (v1' & v2' & ? & ? & ?) : prod_canonical H16.
    substs.
    assert (trm_pair (bind g2 t1) (bind g2 t2) ->* trm_pair v1 v2).
    sapply* multi_red_pair.
    lets* : value_unique H14 H19.
    inverts H20.
    apply rel_v_proj2 in Imp.
    destruct Imp.
    my_simplfier.
    splits*.
    exists vv v2.
    splits*.

  - Case "<-".
    introv H.
    destruct H as (H1 & H2).
    destruct H1 as (? & ? & Imp1).
    destruct H2 as (? & ? & Imp2).
    splits*.
    introv GG.
    lets Imp1' : Imp1 GG.
    lets Imp2' : Imp2 GG.
    clear Imp1 Imp2.
    destruct Imp1' as (Imp1' & ? & ?).
    destruct Imp1' as (? & v1 & ? & ? & ? & ? & Imp1').
    destruct Imp2' as (Imp2' & ? & ?).
    destruct Imp2' as (? & v2 & ? & ? & ? & ? & Imp2').
    my_simplfier.

    rewrite bind_pair.
    splits*.
    exists x0 (trm_pair v1 v2).
    splits*.
    sapply* multi_red_pair.
    apply rel_v_proj2.
    splits~.
Qed.

Lemma compat_pair : forall G1 G2 t1 t2 t3 t4 A1 A2 A1' A2',
    rel_e_open G1 G2 t1 t2 (|A1|) (|A2|) ->
    rel_e_open G1 G2 t3 t4 (|A1'|) (|A2'|) ->
    disjoint A1 A2' ->
    disjoint A1' A2 ->
    rel_e_open G1 G2 (trm_pair t1 t3) (trm_pair t2 t4) (a_prod (|A1|) (|A1'|)) (a_prod (|A2|) (|A2'|)).
Proof.
  introv Rel1 Rel2 Dis1 Dis2.
  destruct Rel1 as (HH1 & HH2 & Rel1).
  destruct Rel2 as (HH3 & HH4 & Rel2).
  splits*.
  introv GG.
  lets Rel1' : Rel1 GG.
  lets Rel2' : Rel2 GG.
  repeat rewrite bind_pair.
  destruct Rel1' as (Rel1' & ? & ?).
  destruct Rel1' as (v1 & v1' & ? & ? & Red1 & Red1' & Rel1').
  destruct Rel2' as (Rel2' & ? & ?).
  destruct Rel2' as (v2 & v2' & ? & ? & Red2 & Red2' & Rel2').
  lets [TT1 TT2]: bind_close HH1 HH2 GG.
  lets [TT3 TT4]: bind_close HH3 HH4 GG.

  apply rel_e_convr with (t' := trm_pair v1' v2'); auto_star.
  apply rel_e_convl with (t := trm_pair v1 v2); auto_star.
  lets : preservation_multi_step TT1 Red1.
  lets : preservation_multi_step TT2 Red1'.
  lets : preservation_multi_step TT3 Red2.
  lets : preservation_multi_step TT4 Red2'.
  apply rel_v_in_rel_e.
  apply rel_v_proj1; splits; apply rel_v_proj2; splits~.
  apply~ disjoint_rel_v.
  apply~ disjoint_rel_v.
  apply~ multi_red_pair.
  apply~ multi_red_pair.
Qed.

Lemma compat_co_proj1 : forall G1 G2 t1 t1' t2 T1 T2,
    rel_e_open G1 G2 (trm_capp co_proj1 (trm_pair t1 t1')) t2 T1 T2 ->
    rel_e_open G1 G2 t1 t2 T1 T2.
Proof with auto.
  introv H.
  destruct H as (Ty1 & Ty2 & Imp).
  inverts Ty1.
  inverts H4.
  inverts H2.

  splits*.
  introv GG.
  lets : Imp GG.
  repeat rewrite bind_capp in *.
  repeat rewrite bind_pair in *.

  lets (? & ?): bind_close H4 Ty2 GG.
  lets (? & ?): bind_close H6 Ty2 GG.
  lets (v1 & ? & ?): normalization H0.
  lets (v2 & ? & ?): normalization H1.
  lets (v3 & ? & ?): normalization H2.

  apply rel_e_redl with (t := v1) in H.
  apply rel_e_redr with (t' := v2) in H...
  apply rel_e_convl with (t := v1)...
  apply rel_e_convr with (t' := v2)...

  apply star_trans with (b := (trm_capp co_proj1 (trm_pair v1 v3)))...
  apply multi_red_capp.
  apply multi_red_pair...
Qed.

Lemma compat_co_proj2 : forall G1 G2 t1 t1' t2 T1 T2,
    rel_e_open G1 G2 (trm_capp co_proj2 (trm_pair t1' t1)) t2 T1 T2 ->
    rel_e_open G1 G2 t1 t2 T1 T2.
Proof with auto.
  introv H.
  destruct H as (Ty1 & Ty2 & Imp).
  inverts Ty1.
  inverts H4.
  inverts H2.

  splits*.
  introv GG.
  lets : Imp GG.
  repeat rewrite bind_capp in *.
  repeat rewrite bind_pair in *.

  lets (? & ?): bind_close H4 Ty2 GG.
  lets (? & ?): bind_close H6 Ty2 GG.
  lets (v1 & ? & ?): normalization H0.
  lets (v2 & ? & ?): normalization H1.
  lets (v3 & ? & ?): normalization H2.

  apply rel_e_redl with (t := v3) in H.
  apply rel_e_redr with (t' := v2) in H...
  apply rel_e_convl with (t := v3)...
  apply rel_e_convr with (t' := v2)...

  apply star_trans with (b := (trm_capp co_proj2 (trm_pair v1 v3)))...
  apply multi_red_capp.
  apply multi_red_pair...
Qed.

Lemma compat_abs : forall G1 G2 t1 t2 x T1 T2 T1' T2',
    x \notin dom G1 \u dom G2 \u fv_exp t1 \u fv_exp t2 ->
    rel_e_open ([(x, T1)] ++ G1) ([(x, T2)] ++ G2) (t1 ^ x) (t2 ^ x) T1' T2' ->
    rel_e_open G1 G2 (trm_abs t1) (trm_abs t2) (a_arrow T1 T1') (a_arrow T2 T2').
Proof.
  introv ? Rel.
  destruct Rel as (Ty1 & Ty2 & Rel).
  splits*.
  pick fresh y and apply typ_abs.
  sapply* typing_rename.
  pick fresh y and apply typ_abs.
  sapply* typing_rename.
  introv GG.
  lets Ty1': typing_to_etyping Ty1.
  lets Ty2': typing_to_etyping Ty2.
  apply etyping_abs in Ty1'; autos.
  apply etyping_abs in Ty2'; autos.
  apply etyping_to_typing in Ty1'; autos.
  apply etyping_to_typing in Ty2'; autos.
  lets* [? ?]: bind_close Ty1' Ty2' GG.
  repeat rewrite bind_abs in *.
  apply rel_v_in_rel_e.
  splits*.
  intros.

  assert (rel_g ([(x, T1)] ++ G1) ([(x, T2)] ++ G2) ([(x, a1)] ++ g1) ([(x, a2)] ++ g2)) by autos.
  lets [? ?]: rel_g_well_type_value H3.

  forwards* Imp : Rel.
  inverts H3 as. intros ? ? ? Typ.
  lets [? ?]: rel_v_well_type Typ.

  apply rel_e_convr with (t':= (bind g2 t2) ^^ a2); auto_star.
  apply rel_e_convl with (t := (bind g1 t1) ^^ a1); auto_star.
  rewrite* <- (@bind_subst g1 x).
  rewrite* <- (@bind_subst g2 x).
Qed.

Lemma compat_rcd : forall G1 G2 t1 t2 T1 T2 l,
    rel_e_open G1 G2 t1 t2 T1 T2 ->
    rel_e_open G1 G2 (trm_rcd l t1) (trm_rcd l t2) (a_rcd l T1) (a_rcd l T2).
Proof.
  introv H.
  destruct H as (? & ? & Imp).
  splits*.
  introv HH.
  apply Imp in HH.
  repeat rewrite bind_rcd.

  destruct HH as (HH & ? & ?).
  destruct HH as (v1 & v2 & ? & ? & ? & ? & ?).

  splits*.
  exists (trm_rcd l v1) (trm_rcd l v2).
  splits~; try apply~ multi_red_rcd.
  apply~ rel_v_rcd.
Qed.

Lemma compat_proj : forall G1 G2 t1 t2 T1 T2 l,
    rel_e_open G1 G2 t1 t2 (a_rcd l T1) (a_rcd l T2) ->
    rel_e_open G1 G2 (trm_proj t1 l) (trm_proj t2 l) T1 T2.
Proof.
  introv H.
  destruct H as (? & ? & Imp).
  splits*.
  introv HH.
  apply Imp in HH.
  repeat rewrite bind_proj.

  destruct HH as (HH & ? & ?).
  destruct HH as (v1 & v2 & ? & ? & ? & ? & HH).
  lets (HH1 & HH2) : rel_v_well_type HH.
  lets* (v1' & ?): rcd_canonical HH1.
  lets* (v2' & ?): rcd_canonical HH2.
  substs.
  inverts H3.
  inverts H4.
  inverts HH1.
  inverts HH2.

  splits*.
  exists v1' v2'.
  splits~.

  apply star_trans with (b := trm_proj (trm_rcd l v1') l); auto.
  apply~ multi_red_proj.

  apply star_trans with (b := trm_proj (trm_rcd l v2') l); auto.
  apply~ multi_red_proj.

  sapply rel_v_rcd; eauto.
Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import funs.
Require Import dataset.
Require Import ssrnat.
Require Import seq.
Require Import finset.
Require Import paths.
Require Import connect.
Require Import hypermap.
Require Import color.
Require Import geometry.
Require Import patch.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Section Sew.

Variables (gd gr : hypermap) (bgd : seq gd) (bgr : seq gr).

Hypothesis Hbgd : sfcycle edge bgd.
Hypothesis Hbgr : ufcycle node bgr.
Hypothesis Hrs : size bgd = size bgr.

Lemma HbgdE : forall xd, bgd xd -> cedge xd =1 bgd.
Proof. by move=> *; apply fconnect_cycle; case (andP Hbgd). Qed.

Lemma HbgdE1 : forall xd, bgd (edge xd) -> bgd xd.
Proof. by move=> xd Hxd; rewrite -(HbgdE Hxd) Sedge fconnect1. Qed.

Lemma HbgrN : forall xr, bgr xr -> cnode xr =1 bgr.
Proof. by move=> *; apply fconnect_cycle; case (andP Hbgr). Qed.

Lemma HbgrN1 : forall xr, bgr (node xr) -> bgr xr.
Proof. by move=> xr Hxr; rewrite -(HbgrN Hxr) Snode fconnect1. Qed.

Remark in_bgd : forall xd, {xr0 : gr | bgd xd} + {setC bgd xd}.
Proof.
move=> xd; rewrite /setC; case Hxd: (bgd xd); [ left | by right ].
by case: bgr Hxd Hrs => [|xr0 pr]; [ case bgd | exists xr0 ].
Qed.

Remark in_bgr : forall xr, {xd0 : gd | bgr xr} + {setC bgr xr}.
Proof.
move=> xr; rewrite /setC; case Hxr: (bgr xr); [ left | by right ].
by case: bgd Hxr Hrs => [|xd0 pd]; [ case bgr | exists xd0 ].
Qed.

Let hdr xr0 xd := sub xr0 (rev bgr) (index xd bgd).

Let hrd xd0 xr := sub xd0 bgd (index xr (rev bgr)).

Remark bgr_hdr : forall xd,  bgd xd -> forall xr0, bgr (hdr xr0 xd).
Proof.
by move=> *; rewrite /hdr -mem_rev mem_sub // size_rev -Hrs index_mem.
Qed.

Remark bgd_hrd : forall xr, bgr xr -> forall xd0, bgd (hrd xd0 xr).
Proof.
by move=> *; rewrite /hrd mem_sub // Hrs -size_rev index_mem mem_rev.
Qed.

Remark hrd_hdr : forall xd, bgd xd -> forall xd0 xr0, hrd xd0 (hdr xr0 xd) = xd.
Proof.
move=> xd Hxd xd0 xr0; rewrite /hrd /hdr index_uniq ?sub_index //.
  by rewrite size_rev -Hrs index_mem.
by rewrite uniq_rev; case: (andP Hbgr).
Qed.

Remark hdr_hrd : forall xr, bgr xr -> forall xd0 xr0, hdr xr0 (hrd xd0 xr) = xr.
Proof.
move=> xr Hxr xd0 xr0; rewrite /hrd /hdr index_uniq ?sub_index ?mem_rev //.
  by rewrite Hrs -size_rev index_mem mem_rev.
by apply simple_uniq; case: (andP Hbgd).
Qed.

Remark node_hdr : forall xd, bgd xd ->
  forall xr0, node (hdr xr0 xd) = hdr xr0 (node (face xd)).
Proof.
case: (andP Hbgd) (andP Hbgr) => [HdE Ud] [HrN Ur] xd Hxd xr0.
move/simple_uniq: Ud => Ud; set xr := hdr xr0 xd.
have Hxr: bgr xr by rewrite /xr bgr_hdr.
rewrite -(eqP (prev_cycle HdE Hxd)) Eedge (eqP (next_cycle HrN Hxr)).
rewrite -(rev_rev bgr) next_rev ?uniq_rev // !prev_sub Hxd mem_rev Hxr.
case Dbgr: {1}(rev bgr) => [|xr1 bgr']; first by rewrite -mem_rev Dbgr in Hxr.
rewrite /xr {1}/hdr.
case Dbgd: {1 2}bgd => [|xd1 bgd'] /=; first by rewrite Dbgd in Hxd.
set i := index xd bgd'.
have Hi: i < size bgd by rewrite Dbgd /= ltnS /i index_size.
rewrite /hdr index_uniq //; rewrite Hrs -size_rev in Hi.
apply: (etrans (congr1 (sub _ _) _) (set_sub_default Hi _ _)).
rewrite -uniq_rev Dbgr /= in Ur; case/andP: Ur => [Hxr1' Ur'].
rewrite Dbgd /= in Ud; case/andP: Ud => [Hxd1' _].
have Hrs' := Hrs; rewrite Dbgd -(size_rev bgr) Dbgr /= in Hrs'.
move: Hrs' => [Hrs'].
rewrite Dbgd /= /setU1 eqd_sym in Hxd; case Hxd1: (xd =d xd1) Hxd.
  rewrite Dbgr /= /i -(cats0 bgr') -(cats0 bgd') !index_cat /= !addn0.
  by clear; rewrite (eqP Hxd1) (negbE Hxr1') (negbE Hxd1').
by rewrite Dbgr /= -index_mem; move=> *; rewrite index_uniq // -Hrs'.
Qed.

Remark edge_hrd : forall xr, bgr xr -> forall xd0,
  edge (hrd xd0 xr) = hrd xd0 (face (edge xr)).
Proof.
move=> xr Hxr xd0; set yr := face (edge xr).
have Hyr: bgr yr by apply HbgrN1; rewrite /yr Eedge.
rewrite -{1}[xr]Eedge -/yr -{1}(hdr_hrd Hyr xd0 xr).
set yd := hrd xd0 yr; have Hyd: bgd yd by rewrite /yd bgd_hrd.
by rewrite node_hdr // hrd_hdr ?Eface // HbgdE1 ?Eface.
Qed.

Inductive sew_tag : Set :=
  | SewDisk : sew_tag
  | SewRest : sew_tag.

Definition sew_tag_eq pt1 pt2 : bool :=
  match pt1, pt2 with
  | SewDisk, SewDisk => true
  | SewRest, SewRest => true
  | _, _ => false
  end.

Definition sew_tag_data : dataSet.
apply (@DataSet _ sew_tag_eq); abstract by do 2 case; constructor.
Defined.
Canonical Structure sew_tag_data.

Definition sew_tag_set : finSet.
apply (@FinSet _ (Seq SewDisk SewRest)); abstract by case.
Defined.
Canonical Structure sew_tag_set.
Notation ptag := sew_tag_set (only parsing).

Let sew_sub_map (i : sew_tag_set) : finSet :=
  match i with
  | SewDisk => gd
  | SewRest => subFin (setC bgr)
  end.

Definition sew_dart := sumFin sew_sub_map.

Definition sewd xd : sew_dart := @sumdI _ sew_sub_map SewDisk xd.

Definition sewr_r xr Hxr : sew_dart :=
  @sumdI _ sew_sub_map SewRest (@subdI _ _ xr Hxr).

Definition sewr xr :=
  match in_bgr xr with
  | inleft u => let (xd0, _) := u in sewd (hrd xd0 xr)
  | inright Hxr => sewr_r Hxr
  end.

Lemma inj_sewd : injective sewd.
Proof.
move=> xd yd; move/(introT eqP); rewrite /sewd /= sumd_eqdr; exact (xd =P yd).
Qed.

Lemma inj_sewr : injective sewr.
Proof.
move=> xr yr; move/(introT eqP); rewrite /sewr.
case: (in_bgr xr) (in_bgr yr) => [[xd0 Hxr]|Hxr] [[xd1 Hyr]|Hyr] //=.
  by move=> Hxy; rewrite -(hdr_hrd Hxr xd0 xr) (inj_sewd (eqP Hxy)) hdr_hrd.
rewrite /sewr_r sumd_eqdr /eqd /=; exact (xr =P yr).
Qed.

Remark sewr_bgr : forall xd0 xr, bgr xr -> sewr xr = sewd (hrd xd0 xr).
Proof.
move=> xd0 xr Hxr; rewrite /sewr; case: (in_bgr xr) => [[xd1 _]|Hxr'].
  by rewrite -{1}(hdr_hrd Hxr xd0 xr) hrd_hdr ?bgd_hrd.
by case/idP: Hxr'.
Qed.

Remark sewr_gr : forall xr Hxr, sewr xr = @sewr_r xr Hxr.
Proof.
move=> xr Hxr; rewrite /sewr.
case: (in_bgr xr) => [[xd0 Hxr']|Hxr']; first by rewrite (negbE Hxr) in Hxr'.
by rewrite (bool_eqT Hxr Hxr').
Qed.

Remark sewr_hdr : forall xd, bgd xd -> forall xr0, sewr (hdr xr0 xd) = sewd xd.
Proof. by move=> xd Hxd xr0; rewrite (sewr_bgr xd) ?hrd_hdr ?bgr_hdr. Qed.

Definition sew_edge (w : sew_dart) : sew_dart :=
  match w with
  | sumdI SewDisk xd =>
    if in_bgd xd is inleft (exist xr _) then sewr (edge (hdr xr xd)) else
    sewd (edge xd)
  | sumdI SewRest ur =>
    let (xr, _) := ur in sewr (edge xr)
  end.

Definition sew_face_r (xr : gr) : sew_dart :=
  match sewr (face xr) with
  | sumdI SewDisk xd => sewd (face xd)
  | ufr => ufr
  end.

Definition sew_face (w : sew_dart) : sew_dart :=
  match w with
  | sumdI SewDisk xd =>
    if in_bgd xd is inleft (exist xr _) then sew_face_r (hdr xr xd) else
    sewd (face xd)
  | sumdI SewRest ur =>
    let (xr, _) := ur in sew_face_r xr
  end.

Definition sew_node (w : sew_dart) : sew_dart :=
  match w with
  | sumdI SewDisk xd => sewd (node xd)
  | sumdI SewRest ur => let (xr, _) := ur in sewr (node xr)
  end.

Lemma Esew_map : monic3 sew_edge sew_node sew_face.
Proof.
move=> [[|] xd]; [ simpl | case: xd => [xr Hxr] /= ].
  case: (in_bgd xd) => [[xr0 Hxd]|Hxd] /=.
    set exr := edge (hdr xr0 xd); transitivity (sew_node (sew_face_r exr)).
    rewrite /sewr; case: (in_bgr exr) => [[xd0 Hexr]|Hexr] //=.
    case: (in_bgd (hrd xd0 exr)); last by rewrite /setC bgd_hrd.
      by move=> [xr1 _]; rewrite /= hdr_hrd.
    rewrite /= /sew_face_r (sewr_bgr xd) /=.
      by rewrite /exr -edge_hrd ?bgr_hdr // Eedge (hrd_hdr Hxd).
    by apply HbgrN1; rewrite /exr Eedge bgr_hdr.
    case: (in_bgd (edge xd)) => [[xr0 Hexd]|Hexd]; rewrite /= ?Eedge //.
  by case (negP Hxd); apply HbgdE1.
transitivity (sew_node (sew_face_r (edge xr))).
rewrite /sewr; case: (in_bgr (edge xr)) => [[xd0 Hexr]|Hexr] //=.
  case: (in_bgd _) => [[xr0 Hexd]|Hexd] /=; first by rewrite hdr_hrd.
  by rewrite /setC bgd_hrd in Hexd.
have Hfexr: setC bgr (face (edge xr)).
  apply/idP => [Hfexr]; case/idP: Hxr.
  by rewrite -{1}[xr]Eedge -(HbgrN Hfexr) fconnect1.
by rewrite /sew_face_r (sewr_gr Hfexr) /= Eedge (sewr_gr Hxr).
Qed.

Definition sew_map := Hypermap Esew_map.

Lemma sewr_rev_sewd : maps sewr bgr = rev (maps sewd bgd).
Proof.
apply: (etrans (esym (rev_rev _)) (congr1 rev _)); rewrite -maps_rev.
move: (andP Hbgd) sewr_hdr Hrs => [_ Ud]; rewrite /hdr -(size_rev bgr).
elim: bgd (rev bgr) {Ud}(simple_uniq Ud) => [|xd pd Hrec] [|xr pr] //=.
move/andP=> [Hpxd Upd] Edr; rewrite -(Edr _ (setU11 _ _) xr) set11 /=.
move=> [Hsz]; congr Adds; apply: Hrec => // yd Hyd yr0.
rewrite -(Edr _ (setU1r _ Hyd) yr0).
by case: (yd =P xd) Hpxd => [<-|_]; rewrite ?Hyd.
Qed.

Lemma sew_map_patch : @patch sew_map _ _ sewd sewr bgd bgr.
Proof.
split=> //.
- exact inj_sewd.
- exact inj_sewr.
- exact sewr_rev_sewd.
- move=> x; case Dx: {0}x => [[|] xd]; move: Dx; last move: xd => [xr Hxr].
    rewrite -[sumdI _]/(sewd xd) => Dx.
    rewrite /setU /setC Dx codom_f (mem_maps inj_sewd) /=.
    case: (in_bgd xd) => [[xr0 Hxd]|Hxd].
      rewrite Hxd; apply/set0Pn; exists (hdr xr0 xd).
      by rewrite /preimage (sewr_hdr Hxd) set11.
    rewrite (negbE Hxd); apply/set0Pn => [] [xr H]; case/idP: Hxd; move: H.
    rewrite /preimage /sewr; case: (in_bgr xr) => [[xd0 Hxr]|Hxr]; last done.
    by rewrite (inj_eqd inj_sewd); move/eqP=> Dxd; rewrite Dxd bgd_hrd.
  rewrite -[sumdI _]/(sewr_r Hxr); move=> Dx.
  rewrite Dx /setU /setC {2}/codom /set0b eq_card0 //=.
  by apply/set0Pn; exists xr; rewrite /preimage (sewr_gr Hxr) set11.
- by move=> xd Hxd /=; case: (in_bgd xd) => // [[xr0 Hxd']]; case/idP: Hxd.
- move=> xr; rewrite {2}/sewr; case: (in_bgr xr) => [[xd0 Hxr]|Hxr] //=.
  case: (in_bgd (hrd xd0 xr)) => [[xr0 _]|Hxd']; first by rewrite hdr_hrd.
  by case (negP Hxd'); rewrite bgd_hrd.
by move=> xr Hxr; rewrite (sewr_gr Hxr).
Qed.

End Sew.

Unset Implicit Arguments.


From hahn Require Import Hahn.
From PromisingLib Require Import Loc.
From Promising2 Require Import View Time Event.
From imm Require Import AuxRel2.

Set Implicit Arguments.
Remove Hints plus_n_O.

Section MaxValue.
  Variable A : Type.

  Definition max_value f (INR : A -> Prop) val :=
    ⟪ UB: forall a (INa: INR a), Time.le (f a) val ⟫ /\
    ⟪ MAX: ((forall a, ~ INR a) /\ val = Time.bot) \/
       (exists a_max, ⟪ INam: INR a_max ⟫ /\
                      ⟪LB': Time.le val (f a_max)⟫) ⟫.

  Lemma max_value_singleton f b t (T: t = f b) : max_value f (eq b) t.
  Proof using.
    red; splits; ins; desc; subst.
      by apply Time.le_lteq; eauto.
      right; exists b; splits; try apply Time.le_lteq; eauto.
  Qed.

  Lemma max_value_new_f f f' P t
        (MAX: max_value f P t) (F: forall x, P x -> f' x = f x): max_value f' P t.
  Proof using.
    unfold max_value in *; ins; desf; splits; ins.
    all: try rewrite F; auto.
    right; exists a_max; rewrite F; auto.
  Qed.

  Lemma max_value_same_set f P P' t
        (MAX: max_value f P t) (SAME: P' ≡₁ P): max_value f P' t.
  Proof using.
    unfolder in *; desc.
    unfold max_value in *; ins; desf; splits; ins.
    all: try specialize (SAME a); desf; eauto.
    left; split; eauto; ins; intro;  eapply MAX0; apply SAME; edone.
  Qed.

  Lemma max_value_join f P P' P'' t t'
        (MAX: max_value f P t) (MAX':  max_value f P' t')
        (SAME_: P'' ≡₁ P ∪₁ P'):
    max_value f P'' (Time.join t t').
  Proof using.
    assert (SAME: forall x, P'' x <-> P x \/ P' x).
      by unfolder in *; basic_solver 12.
    unfold max_value in *; ins; desf; splits; ins.
    all: try apply SAME in INa; desf.
    all: try apply SAME0 in INa; desf.
    all: try by etransitivity; eauto; eauto using Time.join_l, Time.join_r.
    - left; split; eauto. ins; intro.
      specialize (MAX1 a). specialize (MAX0 a).
      apply SAME in H; desf.
    - right; exists a_max; splits.
      rewrite SAME; eauto.
      apply Time.join_spec; eauto; etransitivity; eauto; rewrite Time.le_lteq; eauto.
      apply Time.le_lteq. apply Time.bot_spec.
    - right; exists a_max; splits.
      apply SAME; eauto.
      apply Time.join_spec; eauto; etransitivity; eauto; rewrite Time.le_lteq; eauto.
      apply Time.le_lteq. apply Time.bot_spec.
    - right;
        destruct (Time.le_lt_dec (f a_max) (f a_max0)); [exists a_max0|exists a_max]; splits.
      all: try rewrite SAME; eauto.
      all: try (apply Time.join_spec; eauto;
                etransitivity; eauto; rewrite Time.le_lteq; eauto).
  Qed.

  Lemma max_value_loc f f' P P' t b
        (MAX: max_value f P t)
        (SAME_: P' ≡₁ P ∪₁ eq b)
        (F: forall x, P x -> f' x = f x):
    max_value f' P'  (Time.join t (f' b)).
  Proof using.
    assert (SAME: forall x, P' x <-> P x \/ eq b x).
      by unfolder in *; basic_solver 12.
    eapply max_value_join with (P':= eq b); eauto.
    eapply max_value_new_f with (f:=f); eauto.
    eapply max_value_singleton; done.
  Qed.

  Lemma max_value_empty f P (SAME: forall x, ~ P x): max_value f P Time.bot.
  Proof using.
    red; splits.
    ins; exfalso; eapply SAME; edone.
    left; splits; eauto.
  Qed.

  Lemma max_value_le f b c tm l P
        (LE: Time.le (tm l) (f b))
        (MAX: max_value f P (LocFun.find l tm))
        (LT: Time.lt (f b) (f c))
        (IN: P c) : False.
  Proof using.
    unfold LocFun.find in *.
    red in MAX; desf.
    eby eapply MAX0.
    apply UB in IN.
    eapply Time.lt_strorder; eauto using TimeFacts.le_lt_lt.
  Qed.

  Lemma max_value_lt f b tm l P t
        (LT1: Time.lt t (f b))
        (MAX: max_value f P (LocFun.find l tm))
        (LT2: Time.lt (tm l) t)
        (IN: P b) : False.
  Proof using.
    unfold LocFun.find in *.
    red in MAX; desf.
    eby eapply MAX0.
    apply UB in IN.
    assert (Time.lt (tm l) (f b)).
    eapply Time.lt_strorder; eauto.
    eapply Time.lt_strorder; eauto using TimeFacts.le_lt_lt.
  Qed.

Lemma max_value_le_join f (P P' : A -> Prop) t
      (LT: forall x, P' x -> Time.lt (f x) t) :
  max_value f (P ∪₁ P') t -> max_value f P t.
Proof using.
  intros MAX; red in MAX; desf; red; split; unnw; ins.
  1,3: by apply UB; left.
  { destruct (classic (exists a, P a)) as [[a PP]|NN]; [right|left].
    { exists a; split; auto. apply Time.bot_spec. }
    split; auto. intros a PP. apply NN. eexists; eauto. }
  destruct INam as [H|H].
  { right; eexists; eauto. }
  exfalso. eapply Time.lt_strorder.
  eapply TimeFacts.le_lt_lt; eauto.
Qed.

Lemma max_value_same_value f S a b
      (H : max_value f S a) (B : max_value f S b) :
  a = b.
Proof using.
  red in H; red in B; desf.
  { exfalso. eapply MAX; eauto. }
  { exfalso. eapply MAX0; eauto. }
  specialize (UB0 a_max INam).
  specialize (UB a_max0 INam0).
  apply TimeFacts.antisym.
  all: etransitivity; eauto.
Qed.

Lemma timemap_same_max_value_implies_eq f S (a b : TimeMap.t)
      (H : forall l, max_value f (S l) (a l)) (B : forall l, max_value f (S l) (b l)):
  a = b.
Proof using.
  apply LocFun.ext.
  intros l. specialize (H l). specialize (B l).
  eapply max_value_same_value; eauto.
Qed.

Lemma view_same_max_value_implies_eq f S a b
      (A_PLN_RLX : TimeMap.eq (View.pln a) (View.rlx a))
      (B_PLN_RLX : TimeMap.eq (View.pln b) (View.rlx b))
      (H : forall l, max_value f (S l) (View.rlx a l))
      (B : forall l, max_value f (S l) (View.rlx b l)) :
  a = b.
Proof using.
  apply View.ext.
  rewrite A_PLN_RLX. rewrite B_PLN_RLX.
  all: eapply timemap_same_max_value_implies_eq; eauto.
Qed.

Lemma max_value_bot_f S :
  max_value (fun _ => Time.bot) S Time.bot.
Proof using.
  red. splits.
  { ins. apply Time.bot_spec. }
  destruct (classic (exists e, S e)) as [[e SE]|SE]; [right|left].
  { exists e. split; auto. apply Time.bot_spec. }
  split; auto. by apply not_ex_all_not.
Qed.

End MaxValue.


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

Section constants.

Require Import Reals.
Require Import trajectory_const.
Require Import rrho.
Require Import trajectory_def.

Variable intr : Trajectory.
Variable evad : EvaderTrajectory.

Lemma Rle_201_250 : (MinSpeed <= 250)%R.
unfold MinSpeed in |- *; left; prove_sup.
Qed.

Lemma Rle_250_880 : (250 <= MaxSpeed)%R.
unfold MaxSpeed in |- *; left; prove_sup.
Qed.

(**********)
Definition V : TypeSpeed := mkTypeSpeed 250 Rle_201_250 Rle_250_880.
Definition r_V : R := r V.
Definition rho_V : R := rho V.
Definition AlertTime : R := 19%R.
Definition AlertRange : R := 1400%R.
Definition tstep : R := (/ 2)%R.
Definition MaxStep : R := 1%R.
Definition MaxT : R := 10%R.
Definition MinT : R := (MaxT - tstep)%R.
Definition m (t : R) : R :=
  let z := IZR 2 in (z * r_V * sin (rho_V * (t / z)))%R.
Definition m_rho_ub (t : R) : R :=
  let z := IZR 2 in (z * r_lb V * sin_lb (rho_lb V * (t / z)))%R.

(**********)
Record TimeT : Type := mkTimeT
  {val :> R; cond_1 : (MinT <= val)%R; cond_2 : (val <= MaxT)%R}.

(**********)
Lemma MinT_is_pos : (0 < MinT)%R.
Proof with trivial.
unfold MinT in |- *; unfold MaxT, tstep in |- *;
 apply Rmult_lt_reg_l with 2%R...
prove_sup...
rewrite Rmult_0_r; rewrite Rmult_minus_distr_l; rewrite <- Rinv_r_sym...
apply Rlt_trans with 1%R; prove_sup...
Qed.

(**********)
Theorem rho_ub_t_PI2 :
 forall (h : TypeSpeed) (t : TimeT), (rho_ub h * t < PI / 2)%R.
Proof with trivial.
intros; assert (H := cond_2 t)...
unfold MaxT in H; apply Rlt_trans with (PI_lb / 2)%R...
unfold rho_ub in |- *; cut (g < 33)%R...
cut (tan_ub_MaxBank < 4 / 5)%R...
cut (/ h < / 200)%R...
intros; generalize g_pos; intro H3; generalize tan_ub_MaxBank_pos; intro H4;
 generalize (Rinv_0_lt_compat h (TypeSpeed_pos h));
 intro H5...
generalize
 (Rmult_le_0_lt_compat g 33 tan_ub_MaxBank (4 / 5)
    (Rlt_le 0 g H3) (Rlt_le 0 tan_ub_MaxBank H4) H2 H1)...
intro H6; generalize (Rmult_lt_0_compat g tan_ub_MaxBank H3 H4); intro H7...
assert
 (H8 :=
  Rmult_le_0_lt_compat (g * tan_ub_MaxBank) (33 * (4 / 5))
    (/ h) (/ 200) (Rlt_le 0 (g * tan_ub_MaxBank) H7)
    (Rlt_le 0 (/ h) H5) H6 H0)...
apply Rlt_trans with (33 * / 200 * (4 / 5) * t)%R...
apply Rmult_lt_compat_r...
apply Rlt_le_trans with MinT...
apply MinT_is_pos...
apply (cond_1 t)...
rewrite Rmult_assoc; rewrite (Rmult_comm (/ 200)); unfold Rdiv in |- *;
 do 2 rewrite <- Rmult_assoc...
apply Rle_lt_trans with (33 * / 200 * (4 / 5) * 10)%R...
apply Rmult_le_compat_l...
left; apply Rmult_lt_0_compat...
apply Rmult_lt_0_compat; [ prove_sup | apply Rinv_0_lt_compat; prove_sup ]...
unfold Rdiv in |- *; apply Rmult_lt_0_compat;
 [ prove_sup | apply Rinv_0_lt_compat; prove_sup ]...
apply Rmult_lt_reg_l with 2%R...
prove_sup...
apply Rmult_lt_reg_l with 200%R...
prove_sup...
apply Rmult_lt_reg_l with 5%R...
prove_sup...
set (x := 200%R); set (y := 33%R); set (z := 10%R); set (u := 5%R);
 set (v := 4%R); set (w := 2%R)...
unfold Rdiv in |- *;
 replace (u * (x * (w * (PI_lb * / w))))%R with (x * PI_lb * u * (w * / w))%R;
 [ idtac | ring ]...
replace (u * (x * (w * (y * / x * (v * / u) * z))))%R with
 (w * y * v * z * (u * / u) * (x * / x))%R; [ idtac | ring ]...
repeat rewrite <- Rinv_r_sym; unfold x, y, z, u, v, w in |- *; try discrR...
unfold PI_lb in |- *; prove_sup...
apply Rinv_lt_contravar...
apply Rmult_lt_0_compat...
prove_sup...
apply Rlt_le_trans with MinSpeed...
unfold MinSpeed in |- *; prove_sup...
apply (v_cond1 h)...
apply Rlt_le_trans with MinSpeed...
unfold MinSpeed in |- *; prove_sup...
apply (v_cond1 h)...
unfold tan_ub_MaxBank in |- *; unfold Rdiv in |- *...
apply Rmult_lt_reg_l with 10%R...
prove_sup...
rewrite (Rmult_comm 10); rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
rewrite Rmult_1_r; apply Rmult_lt_reg_l with 5%R...
prove_sup...
pattern 5%R at 1 in |- *; rewrite (Rmult_comm 5); do 2 rewrite Rmult_assoc;
 rewrite <- Rinv_l_sym...
prove_sup...
discrR...
discrR...
unfold g in |- *; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 10%R...
prove_sup...
rewrite <- Rmult_comm; rewrite Rmult_assoc; rewrite <- Rinv_l_sym...
rewrite Rmult_1_r; prove_sup...
discrR...
unfold Rdiv in |- *; repeat rewrite <- (Rmult_comm (/ 2));
 apply Rmult_lt_compat_l...
apply Rinv_0_lt_compat; prove_sup...
assert (H0 := PI_approx); elim H0...
Qed.

(**********)
Theorem rho_t_PI2 : forall t : TimeT, (rho_V * t < PI / 2)%R.
Proof with trivial.
intro; generalize (rho_ub_t_PI2 V t); intro; unfold rho_V in |- *...
apply Rlt_trans with (rho_ub V * t)%R...
apply Rmult_lt_compat_r...
apply Rlt_le_trans with MinT; [ apply MinT_is_pos | apply (cond_1 t) ]...
apply rho_ub_0...
Qed.

(**********)
Lemma rho_t_2 : forall t : TimeT, (rho_V * t < 2)%R.
Proof with trivial.
intro t; apply Rlt_trans with (PI / 2)%R...
apply rho_t_PI2...
apply Rlt_le_trans with (PI_ub / 2)%R...
unfold Rdiv in |- *; repeat rewrite <- (Rmult_comm (/ 2))...
apply Rmult_lt_compat_l...
apply Rinv_0_lt_compat; prove_sup...
assert (H := PI_approx); elim H...
right; unfold PI_ub in |- *; unfold Rdiv in |- *.
change 4%R with (IZR (2 * 2)).
rewrite (mult_IZR 2 2).
 rewrite Rmult_assoc;
 rewrite <- Rinv_r_sym; [ apply Rmult_1_r | discrR ]...
Qed.

(**********)
Lemma r_V_is_pos : (0 < r_V)%R.
unfold r_V in |- *; unfold r in |- *; unfold Rdiv in |- *;
 apply Rmult_lt_0_compat;
 [ apply (TypeSpeed_pos V) | apply Rinv_0_lt_compat; apply rho_pos ].
Qed.

(**********)
Lemma rho_V_is_pos : (0 < rho_V)%R.
unfold rho_V in |- *; apply rho_pos.
Qed.

(**********)
Lemma m_le : forall t1 t2 : TimeT, (t1 <= t2)%R -> (m t1 <= m t2)%R.
Proof with trivial.
intros; unfold m in |- *; repeat rewrite Rmult_assoc...
repeat apply Rmult_le_compat_l...
left; simpl in |- *; prove_sup...
left; apply r_V_is_pos...
generalize (rho_t_PI2 t1); intro H1...
generalize (rho_t_PI2 t2); intro H2...
assert (Hyp : (0 < 2)%R)...
prove_sup0...
generalize
 (Rmult_lt_compat_l (/ 2) (rho_V * t1) (PI / 2) (Rinv_0_lt_compat 2 Hyp) H1)...
generalize
 (Rmult_lt_compat_l (/ 2) (rho_V * t2) (PI / 2) (Rinv_0_lt_compat 2 Hyp) H2)...
replace (/ 2 * (PI / 2))%R with (PI / 4)%R...
clear H1 H2; intros H1 H2...
rewrite Rmult_comm in H1...
rewrite Rmult_comm in H2...
unfold Rdiv in |- *...
generalize (cond_1 t1)...
generalize (cond_1 t2)...
generalize MinT_is_pos; intro H7...
intros H3 H4...
generalize (Rlt_le_trans 0 MinT t1 H7 H4); clear H4; intro H4...
generalize (Rlt_le_trans 0 MinT t2 H7 H3); clear H3; intro H3...
apply sin_incr_1...
left; apply Rlt_trans with 0%R...
apply _PI2_RLT_0...
repeat simple apply Rmult_lt_0_compat...
apply rho_V_is_pos...
apply Rinv_0_lt_compat; simpl in |- *; prove_sup0...
left; apply Rlt_trans with (PI / 4)%R...
rewrite <- Rmult_assoc...
apply PI4_RLT_PI2...
left; apply Rlt_trans with 0%R...
apply _PI2_RLT_0...
repeat simple apply Rmult_lt_0_compat...
apply rho_V_is_pos...
apply Rinv_0_lt_compat; simpl in |- *; prove_sup0...
left; apply Rlt_trans with (PI / 4)%R...
rewrite <- Rmult_assoc...
apply PI4_RLT_PI2...
apply Rmult_le_compat_l...
left; apply rho_V_is_pos...
apply Rmult_le_compat_r...
left; apply Rinv_0_lt_compat; simpl in |- *; prove_sup0...
unfold Rdiv in |- *; rewrite (Rmult_comm (/ 2)); rewrite Rmult_assoc;
 rewrite <- Rinv_mult_distr...
Qed.

(**********)
Lemma m_rho_ub_0 : forall t : TimeT, (m_rho_ub t <= m t)%R.
Proof with trivial.
intro; unfold m_rho_ub, m in |- *; repeat rewrite Rmult_assoc;
 apply Rmult_le_compat_l...
left; simpl in |- *; prove_sup0...
cut (0 <= r_lb V <= r_V)%R...
cut (0 <= sin_lb (rho_lb V * (t / 2)) <= sin (rho_V * (t / 2)))%R...
intros; elim H; intros H1 H2; elim H0; intros H3 H4...
apply Rmult_le_compat...
cut (0 < rho_lb V * (t / 2) <= rho_V * (t / 2))%R...
cut (rho_V * (t / 2) <= PI / 2)%R...
intros; elim H0; intros H1 H2; split...
left; apply sin_lb_gt_0...
apply Rle_trans with (rho_V * (t / 2))%R...
apply Rle_trans with (sin (rho_lb V * (t / 2)))...
generalize
 (SIN (rho_lb V * (t / 2)) (Rlt_le 0 (rho_lb V * (t / 2)) H1)
    (Rle_trans (rho_lb V * (t / 2)) (PI / 2) PI
       (Rle_trans (rho_lb V * (t / 2)) (rho_V * (t / 2)) (PI / 2) H2 H)
       (Rlt_le (PI / 2) PI PI2_Rlt_PI)))...
intro H3; elim H3; intros H4 H5...
apply sin_incr_1...
left; apply (Rlt_trans (- (PI / 2)) 0 (rho_lb V * (t / 2)) _PI2_RLT_0 H1)...
apply Rle_trans with (rho_V * (t / 2))%R...
left;
 apply
  (Rlt_trans (- (PI / 2)) 0 (rho_V * (t / 2)) _PI2_RLT_0
     (Rlt_le_trans 0 (rho_lb V * (t / 2)) (rho_V * (t / 2)) H1 H2))...
left; apply Rlt_trans with (PI / 4)%R...
generalize (rho_t_PI2 t); intro H; unfold Rdiv in |- *;
 replace (/ 4)%R with (/ 2 * / 2)%R...
repeat rewrite <- Rmult_assoc; apply Rmult_lt_compat_r...
apply Rinv_0_lt_compat; prove_sup0...
rewrite <- Rinv_mult_distr...
discrR...
discrR...
apply PI4_RLT_PI2...
split...
unfold Rdiv in |- *; repeat simple apply Rmult_lt_0_compat...
apply rho_lb_pos...
apply Rlt_le_trans with MinT...
apply MinT_is_pos...
apply (cond_1 t)...
apply Rinv_0_lt_compat; prove_sup0...
apply Rmult_le_compat_r...
left; unfold Rdiv in |- *; apply Rmult_lt_0_compat...
apply Rlt_le_trans with MinT...
apply MinT_is_pos...
apply (cond_1 t)...
apply Rinv_0_lt_compat; prove_sup0...
unfold rho_V in |- *...
left; apply rho_lb_0...
split...
unfold r_lb in |- *...
unfold Rdiv in |- *; left; apply Rmult_lt_0_compat...
apply (TypeSpeed_pos V)...
apply Rinv_0_lt_compat; apply rho_ub_pos...
unfold r_V in |- *; left; apply r_lb_0...
Qed.

(**********)
Lemma m_rho_T_pos : forall t : TimeT, (0 < m t)%R.
Proof with trivial.
intro t; unfold m in |- *; repeat simple apply Rmult_lt_0_compat...
simpl in |- *; prove_sup0...
apply r_V_is_pos...
generalize (cond_1 t); generalize MinT_is_pos; intros H H0;
 generalize (Rlt_le_trans 0 MinT t H H0); clear H;
 intro H; apply sin_gt_0...
repeat simple apply Rmult_lt_0_compat...
apply rho_V_is_pos...
unfold Rdiv in |- *; apply Rmult_lt_0_compat;
 try (apply Rinv_0_lt_compat; simpl in |- *; prove_sup0)...
generalize (rho_t_PI2 t); intro H1; assert (Hyp : (0 < 2)%R)...
prove_sup0...
generalize
 (Rmult_lt_compat_r (/ 2) (rho_V * t) (PI / 2) (Rinv_0_lt_compat 2 Hyp) H1);
 rewrite Rmult_assoc; replace (PI / 2 * / 2)%R with (PI / 4)%R...
intro H2; apply Rlt_trans with (PI / 4)%R...
apply (Rlt_trans (PI / 4) (PI / 2) PI PI4_RLT_PI2 PI2_Rlt_PI)...
unfold Rdiv in |- *; rewrite Rmult_assoc; rewrite <- Rinv_mult_distr...
Qed.

Variable T : TimeT.

Definition MaxDistance : R := (V * T + ConflictRange)%R.
Definition MinDistance : R := (m T - ConflictRange)%R.
Definition MaxDistance_ub : R := (V * MaxT + ConflictRange)%R.
Definition MinDistance_lb : R := (m_rho_ub MinT - ConflictRange)%R.

(**********)
Lemma MaxDistance_ub_0 : (MaxDistance <= MaxDistance_ub)%R.
unfold MaxDistance, MaxDistance_ub in |- *.
rewrite (Rplus_comm (V * T)).
rewrite (Rplus_comm (V * MaxT)).
apply Rplus_le_compat_l.
apply Rmult_le_compat_l.
left; apply (TypeSpeed_pos V).
apply (cond_2 T).
Qed.

(**********)
Lemma MinT_MaxT : (MinT <= MaxT)%R.
unfold MinT in |- *; pattern MaxT at 2 in |- *; rewrite <- (Rplus_0_r MaxT).
unfold Rminus in |- *; apply Rplus_le_compat_l.
unfold tstep in |- *; rewrite <- Ropp_0; left; apply Ropp_lt_gt_contravar;
 apply Rinv_0_lt_compat; prove_sup.
Qed.

(**********)
Lemma MinDistance_lb_0 : (MinDistance_lb <= MinDistance)%R.
Proof with trivial.
unfold MinDistance_lb, MinDistance in |- *; unfold Rminus in |- *;
 rewrite (Rplus_comm (m_rho_ub MinT)); rewrite (Rplus_comm (m T));
 apply Rplus_le_compat_l...
cut (MinT <= MinT)%R...
intro H; apply Rle_trans with (m MinT)...
apply (m_rho_ub_0 (mkTimeT MinT H MinT_MaxT))...
apply (m_le (mkTimeT MinT H MinT_MaxT) T)...
simpl in |- *; apply (cond_1 T)...
right...
Qed.

(*** Easy to prove with constructive reals ***)
(*** Verified with Mapple                  ***)
Axiom MinDistance_lb_majoration : (V + ConflictRange < MinDistance_lb)%R.

(**********)
Lemma MinDistance_lb_pos : (0 < MinDistance_lb)%R.
Proof with trivial.
apply Rlt_trans with (V + ConflictRange)%R...
unfold V, ConflictRange in |- *; simpl in |- *; prove_sup...
apply MinDistance_lb_majoration...
Qed.

(**********)
Lemma MinDistance_pos : (0 < MinDistance)%R.
apply Rlt_le_trans with MinDistance_lb.
apply MinDistance_lb_pos.
apply MinDistance_lb_0.
Qed.

Definition MinBeta : R := (539 / 1000)%R.

End constants.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

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

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

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

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

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

*)

Require Export sequents.

Definition wf_bseq {o} (s : @baresequent o) :=
  vswf_hypotheses [] (hyps s)
  # wf_term (ctype (concl s))
  # closed_type_baresequent s.

(* This is a variant of [rule_true2] (which is equivalent to [rule_true])
   that only needs [wf_bseq] and not [pwf_sequent].
 *)
Definition rule_true3 {o} lib (R : @rule o) : Type :=
  forall wf    : wf_bseq (goal R),
  forall cargs : args_constraints (sargs R) (hyps (goal R)),
  forall hyps  : (forall s, LIn s (subgoals R) -> sequent_true2 lib s),
    sequent_true2 lib (goal R).

Lemma pwf_sequent_implies_wf_bseq {o} :
  forall (seq : @baresequent o),
    pwf_sequent seq -> wf_bseq seq.
Proof.
  introv wf.
  unfold pwf_sequent, wf_sequent, wf_concl in wf; unfold wf_bseq; repnd; dands; auto.
Qed.
Hint Resolve pwf_sequent_implies_wf_bseq : slow.

(* The other direction is not true because [rule_true] and [rule_true2] assume
   that the extract is well-formed. *)
Lemma rule_true3_implies_rule_true2 {o} :
  forall lib (R : @rule o), rule_true3 lib R -> rule_true2 lib R.
Proof.
  introv rt wf args imp.
  unfold rule_true3 in rt.
  repeat (autodimp rt hyp); eauto 3 with slow.
Qed.
Hint Resolve rule_true3_implies_rule_true2 : slow.

Lemma rule_true3_implies_rule_true {o} :
  forall lib (R : @rule o), rule_true3 lib R -> rule_true lib R.
Proof.
  introv rt.
  rw @rule_true_iff_rule_true2; eauto 3 with slow.
Qed.
Hint Resolve rule_true3_implies_rule_true : slow.

Definition wf_subgoals2 {o} (R : @rule o) :=
  forall s, LIn s (subgoals R) -> wf_bseq s.

Lemma fold_wf_subgoals2 {o} :
  forall R : @rule o,
    (forall s, LIn s (subgoals R) -> wf_bseq s) = wf_subgoals2 R.
Proof. sp. Qed.

(* This is a variant of [wf_rule] that uses [wf_bseq] instead of [pwf_sequent] *)
Definition wf_rule2 {o} (R : @rule o) :=
  wf_bseq (goal R) -> wf_subgoals2 R.

(*
*** Local Variables:
*** coq-load-path: ("." "../util/" "../terms/" "../computation/" "../cequiv/" "../close/")
*** End:
*)


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
Require Import securite.

Lemma POinv1rel7 :
 forall (l l0 : list C) (k k0 k1 k2 : K) (c c0 c1 c2 : C)
   (d d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 d11 d12 d13 d14 d15 d16 d17 d18 d19
    d20 : D),
 inv0
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 inv1
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l) ->
 rel7
   (ABSI (MBNaKab d7 d8 d9 k0) (MANbKabCaCb d4 d5 d6 k c c0)
      (MABNaNbKeyK d d0 d1 d2 d3) l)
   (ABSI (MBNaKab d18 d19 d20 k2) (MANbKabCaCb d15 d16 d17 k1 c1 c2)
      (MABNaNbKeyK d10 d11 d12 d13 d14) l0) ->
 inv1
   (ABSI (MBNaKab d18 d19 d20 k2) (MANbKabCaCb d15 d16 d17 k1 c1 c2)
      (MABNaNbKeyK d10 d11 d12 d13 d14) l0).

Proof.
do 32 intro.
unfold inv0, inv1, rel7 in |- *; intros know_c_c0_l know_Kas_Kbs and1.
elim know_c_c0_l; intros know_c_l know_c0_l.
elim know_Kas_Kbs; intros know_Kas know_Kbs.
elim and1; intros eq_l0 t1.
clear know_c_c0_l know_Kas_Kbs and1 t1.
rewrite eq_l0.
split.

(* first part *)
apply D2.
simpl in |- *.
repeat apply C2 || apply C3 || apply C4.
apply equivncomp with (l ++ rngDDKKeyAB).
apply equivS3.
apply AlreadyInb; apply EP0; assumption.
apply D1; assumption.
discriminate.
discriminate.

(* second part *)
apply D2.
simpl in |- *.
repeat apply C2 || apply C3 || apply C4.
apply equivncomp with (l ++ rngDDKKeyAB).
apply equivS3.
apply AlreadyInb; apply EP0; assumption.
apply D1; assumption.
discriminate.
discriminate.
Qed.