Require Import Program Arith.
Require Import Lists.List.
Require Import Recdef.

Inductive In {X:Type} : X -> list X -> Prop :=
  | in_head x xs: In x (x::xs)
  | in_tail x y xs: In x xs -> In x (y::xs)
.

(* Element x asub järjendis elemendist y eespool *)
Inductive First_Then {X:Type}: X -> X -> list X -> Prop :=
  | FT_delay x y z xs : First_Then x y xs ->  First_Then x y (z::xs)
  | FT_start x y xs : In y xs ->  First_Then x y (x::xs)
.

(*
   Abitaktika: kui on hüpotees H: bla = (x,y), ja eesmärk f x y
   siis rewrite_pair H teeb eesmärgiks f (fst bla) (snd bla)
*)
Ltac rewrite_pair_goal H :=
  match type of H with
  | ?x = (?y,?z) =>
    ( replace y with (fst x) by (rewrite H; reflexivity);
      replace z with (snd x) by (rewrite H; reflexivity) )
  | _ => fail "Taktika argument pole kujul: ?x = (?y,?z)."
  end.

(* Abitaktika: teeb sama mida rewrite_pair_goal abitaktika, kuid erinevus on, et seda ei rakendada mitte eesmärgile,
     vaid mõnele teisele eeldusele *)
Ltac rewrite_pair_in H Q :=
  match type of H with
  | ?x = (?y,?z) =>
    ( replace y with (fst x) in Q by (rewrite H; reflexivity);
      replace z with (snd x) in Q by (rewrite H; reflexivity) )
  | _ => fail "Taktika argument pole kujul: ?x = (?y,?z)."
  end.

(* Lihtsustab abitaktika rewrite_pair_goal kasutamist *)
Tactic Notation "rewrite_pair"  hyp(H) :=
  rewrite_pair_goal H.

(* Lihtsustab abitaktika rewrite_pair_in kasutamist *)
Tactic Notation "rewrite_pair"  hyp(H) "in" hyp(T) :=
  rewrite_pair_in H T.

Module Type Graph.
  Parameter node: Type.
  Parameter equalN: node -> node -> bool.
  Axiom EqN: forall x y:node, equalN x y = true <-> x = y.

  Lemma EqReflN: forall x, equalN x x = true.
  Proof.
  intros. apply EqN. reflexivity.
  Qed.

  Definition edge:= (node * node) %type.

  Definition nodes := list node.
  Definition edges := list edge.

  (* Tippu x pole graafis sisenevaid servi *)
  Fixpoint noIncoming (E:edges) (x: node) :=
    match E with
    | nil => true
    | cons (_,y) ys => if equalN x y then false else noIncoming ys x
    end.
End Graph.

Module Kahn (Import G : Graph).

(*
Sisend: Graaf (E,V)
Väljund: Järjestus L

Kahni algoritm:

1.      Leitakse iga tipu sisendaste
2.      Luuakse järjend Q, mis sisaldab graafi tippe, mille sisendaste on null
3. Tsükkel
      * Töö lõpetatakse, kui järjend Q on tühi
      * Kui järjend Q pole tühi:
          a. Valitakse järjendist suvaline tipp v
          b. Eemaldame graafist (E,V) tipu v ja kõik servad (v,u)
          c. Tipp v lisatakse topoloogilise järjestuse L lõppu
          d. Lõpptipud, mille sisendaste graafis (E,V) muutub nulliks, lisatakse järjendisse Q
4. Kui E on tühi, siis on väljastame L, muidu veateade *)

  (* Eemaldame graafist (E,V)  kõik tipust v väljuvad servad ja lisame  kõik tipud, kuhu sisenevad servad tipust v, järjendisse X *)
  Fixpoint remove_edges_from (E: edges) (v: node) (X: nodes) : edges*nodes :=
    match E with
    | nil => (nil,X)
    | (x,y)::E' =>
        if equalN v x then
          remove_edges_from E' v (y::X)
        else
          let '(E'', Q') := remove_edges_from E' v X in
          ((x,y) :: E'', Q')
    end.

  (* Kui järjendis X leidub tippe, mille sisendaste on null, siis vastavad tipud lisatakse järjendisse Q *)
  Fixpoint add_to_Q (E: edges) (X:nodes) (Q:nodes) : nodes :=
    match X with
    | nil => Q
    | y::X' =>
        if noIncoming E y then
          add_to_Q E X' (y::Q)
        else
          add_to_Q E X' Q
    end.

  Definition length_pair {X Y:Type} (p: list X * list Y): nat :=
    match p with (x,y) => length x + length y end.

  (* Esialgsete järjendite E ja X pikkute summa ei muutu, kui järjendist E eemaldatakse kõik tipust v väljuvad servad ja
       järjendisse X lisatakse kõik tipud, millesse sisenes serv tipust v *)
  Lemma remove_edges_len_sum E: forall X v,
      length_pair (remove_edges_from E v X) = length_pair (E, X).
  Proof.
  simpl. induction E.
  - reflexivity.
  - simpl. destruct a. intros. destruct equalN.
    + rewrite IHE. simpl. rewrite Nat.add_succ_r. reflexivity.
    + destruct remove_edges_from eqn: EQ. simpl. apply eq_S. rewrite <- (IHE X v). rewrite EQ. reflexivity.
  Qed.

  (* Esialgsete järjendite X ja Q pikkuste summa on võrdne või suurem järjendist, kuhu on lisatud ainult sisendastmega null tipud.
      Võrdne on juhul kui järjendis X on kõik sisendastmega null tipud *)
  Lemma add_to_Q_len X: forall E Q,
      length (add_to_Q E X Q) <= length X + length Q.
  Proof.
  induction X.
  - reflexivity.
  - simpl. intros. destruct noIncoming.
    + rewrite IHX. simpl. rewrite Nat.add_succ_r. reflexivity.
    + rewrite IHX. apply le_S. reflexivity.
  Qed.

  (* Tehakse kaks sammu korraga: remove_edges_from ja add_to_Q*)
  Definition remove_E_add_Q (E: edges) (v: node) (Q: nodes) : edges*nodes :=
    let '(E', X) := remove_edges_from E v nil in
    (E', add_to_Q E' X Q).

  (* Esialgsete järjendite E ja Q pikkuste summa on võrdne või suurem järjendite E' ja Q' pikkuste summast, kus E' on saadud
       järjendist E kõikide servade, mis väljuvad tipust v, eemaldamisel ja kus Q' on saadud järjendisse Q kõikide sisendastmega null
       tippude, mis tekkisid peale tipust v väljuvate servade eemaldamisel, lisamisel.
       Võrdne on siis, kui kõigi servade, millesse siseneb serv tipust v, sisendaste on null *)
  Lemma remove_E_add_Q_len_sum E: forall Q v,
    length_pair (remove_E_add_Q E v Q) <= length_pair (E, Q).
  Proof.
  intros. unfold remove_E_add_Q. destruct remove_edges_from eqn: EV. apply (f_equal length_pair) in EV.
  rewrite remove_edges_len_sum in EV. simpl in *. rewrite <- plus_n_O in EV. rewrite EV, plus_assoc_reverse.
  apply plus_le_compat_l, add_to_Q_len.
  Qed.

  (* Kahni algoritm eelneva kirjelduse põhjal *)
  Function kahn_loop (P:edges * nodes)  (L: nodes) {measure length_pair P}: option nodes :=
    match P with
    | (E, nil) =>
      match E with
        | nil           => Some L (* korras!  *)
        | cons _ _ => None   (* viga: tsükkel *)
      end
    | (E, v :: Q') =>
        kahn_loop (remove_E_add_Q E v Q')  (v::L)
    end.
  Proof.
  simpl. intros. rewrite <- plus_n_Sm. apply Peano.le_n_S, remove_E_add_Q_len_sum.
  Defined.

  (* Tagastab tagurpidi topoloogilise järjestuse. Vajalik, et leida kõige pealt sisendastmega null tipud *)
  Definition kahn (V:nodes) (E:edges): option nodes :=
    kahn_loop (E, (filter (noIncoming E) V)) [].

  (* Kui tippu n pole sisenevaid servi, siis see on samaväärne, et ei leidu tippu m nii, et tipust m väljuks kaar tippu n *)
  Lemma NoIncoming n E: noIncoming E n = true <-> ~(exists m, In (m,n) E).
  Proof.
  induction E.
  - split.
    + intros. unfold not. intros. inversion H0. inversion H1.
    + intros. simpl. reflexivity.
  - split.
    + simpl. destruct a. destruct equalN eqn: NN1.
      { discriminate. }
      { inversion IHE. unfold not. intros. apply H in H1. unfold not in H1. apply H1. inversion H2. inversion H3.
        - destruct H7. rewrite EqReflN in NN1. inversion NN1.
        - exists x. apply H6. }
    + inversion IHE. simpl. destruct a. destruct equalN eqn: NN1.
      { intros. apply EqN in NN1. destruct NN1. exfalso. destruct H1. exists n0. apply in_head. }
      { intros. apply H0. unfold not. intros. destruct H1. inversion H2. exists x. apply in_tail, H1. }
  Qed.

  (* Iga tippu n korral, mis asub Q-s, järeldub, et tippu n ei sisene ühtegi serva *)
  Definition PropQl (P:edges*nodes) :=
    forall n, In n (snd P) -> noIncoming (fst P) n = true.

  (* Iga tipu n korral, mis asub L-s, järeldub, et tippu n ei sisene ühtegi serva *)
  Definition PropLl (P:edges*nodes) (L: nodes) :=
    forall n, In n L -> noIncoming (fst P) n = true.

  (* Kui tipp n leidub esialgses graafis ja tippu n pole sisenevaid kaari, siis järeldub, et n asub Q-s või n asub L-s *)
  Definition PropQLr (SV:nodes) (P:edges*nodes) (L: nodes) :=
    forall n, In n SV -> noIncoming (fst P) n = true -> In n (snd P) \/ In n L.

  (* Iga tippude m,n korral, kui serv (m,n) leidub esialgses graafis, ja serv (m,n) ei leidu E-s, siis järjelikult tipp m asub L-s *)
  Definition PropL (SE:edges) (P:edges*nodes) (L: nodes) :=
    forall m n, In (m,n) SE -> ~(In (m,n) (fst P)) -> In m L.

  (* Iga tippude m,n korral, kui serv (m,n) leidub esialgses graafis, ja tippu n pole sisenevaid kaari, ja n ei asu Q-s, siis järeldub, et
       L-s asub tipp n eespool tippu n (topoloogiline järjestus tagurpidi) *)
  Definition PropLOrigin (SE:edges) (P:edges*nodes) (L: nodes) :=
    forall m n, In (m,n) SE -> noIncoming (fst P) n = true -> ~ In n (snd P) -> First_Then n m L.

  (* Kõik Propiga seotud eelnevad definitsioonid kehtivad samaaegselt *)
  Definition AProp (SV:nodes) (SE:edges) (P:edges*nodes) (L: nodes) :=
    PropQl P /\ PropLl P L /\ PropQLr SV P L /\ PropL SE P L /\ PropLOrigin SE P L.

  (* Järgnevad kaks taktikat lihtsustavad Propidega seotuid definitsioone lahti kirjutada tõestustes *)
  Tactic Notation "daprop" ident(q) :=
    (unfold AProp, PropQl, PropLl, PropQLr, PropL, PropLOrigin in q; destruct q as [pql [pll [pqlr [pl plo]]]]).

  Tactic Notation "splitprop" := (unfold AProp, PropQl, PropLl, PropQLr, PropL, PropLOrigin; split; [| split;[|split;[|split]]]).

  (* Kui kehtib tsükli-invariant ja E ning Q on saanud tühjaks ja serv (m, n) oli algselt graafis,
       siis peab nüüd olema L-is esmalt n ja siis m *)
  Lemma PropResultSound SV SE: forall L, AProp SV SE ([], []) L ->
    forall m n, In (m,n) SE -> First_Then n m L.
  Proof.
  intros. daprop H. apply plo.
  - apply H0.
  - reflexivity.
  - unfold not. intros. inversion H.
  Qed.

  Lemma DestructFilter {X:Type} (P:X -> Prop) (f: X -> bool) (S: list X): (forall x, In x S -> f x = true -> P x) ->
    forall x, In x (filter f S) -> P x.
  Proof.
  induction S.
  - intros. inversion H0.
  - intros. simpl in H0. destruct (f a) eqn: FA.
    + apply H in FA.
      { inversion H0.
        - apply FA.
        - apply IHS.
          + intros. apply H in H6.
            { apply H6. }
            { apply in_tail, H5. }
          + apply H3. }
      { apply in_head. }
    + apply IHS in H0.
      { apply H0. }
      { intros. apply H in H2.
        - apply H2.
        - apply in_tail, H1. }
  Qed.

  Lemma InFilter {X:Type} (f: X -> bool) (S: list X): forall x,  In x S -> f x = true -> In x (filter f S).
  Proof.
  induction S.
  - intros. inversion H.
  - intros. inversion H.
    + simpl. destruct (f a) eqn: FA.
      { apply in_head. }
      { destruct H3. rewrite FA in H0. inversion H0. }
    + simpl. destruct (f a) eqn: FA.
      { apply in_tail. apply IHS.
        - apply H3.
        - apply H0. }
      { apply IHS.
        - apply H3.
        - apply H0. }
  Qed.

  Lemma startQlProp SE V: PropQl (SE,(filter (noIncoming SE) V)).
  Proof.
  unfold PropQl. simpl. intros. apply DestructFilter with (P:= fun x => noIncoming SE x = true) in H.
  - apply H.
  - intros. apply H1.
  Qed.

  Lemma startQLrProp SE SV : PropQLr SV (SE,(filter (noIncoming SE) SV)) [].
  Proof.
  unfold PropQLr. intros. simpl in *. left. apply InFilter.
  - apply H.
  - apply H0.
  Qed.

  Lemma startLOriginProp SE SV: (forall n m, In (n,m) SE -> In n SV /\ In m SV) ->
    PropLOrigin SE (SE,(filter (noIncoming SE) SV)) [].
  Proof.
  unfold PropLOrigin. intros. unfold not in H2. destruct H2. simpl in *. apply InFilter.
  - apply H in H0. inversion H0. apply H3.
  - apply H1.
  Qed.

  Lemma startLProp SE SV: (forall n m, In (n,m) SE -> In n SV /\ In m SV) -> PropL SE (SE,(filter (noIncoming SE) SV)) [].
  Proof.
  unfold PropL. intros. destruct H1. simpl. apply H0.
  Qed.

  Lemma startProp SV SE: (forall n m, In (n,m) SE -> In n SV /\ In m SV) ->
      AProp SV SE (SE, (filter (noIncoming SE) SV)) [].
  Proof.
  intros. splitprop.
  - apply startQlProp.
  - intros. inversion H0.
  - apply startQLrProp.
  - apply startLProp, H.
  - apply startLOriginProp, H.
  Qed.

  (* Iga a, b, X ja v korral, kui serv (a,b) on servade järjendis E, siis serv (a,b) asub servade järjendis, millest on eemaldatud kõik
       servad, mis väljuvad tipust v või tipp a ongi tipp v *)
  Lemma InFstRemoveEdgesRa E: forall a b X v, In (a,b) E -> In (a,b) (fst (remove_edges_from E v X)) \/ a=v.
  Proof.
    induction E.
    - intros. inversion H.
    - simpl. destruct a eqn: A. intros a0 b X v. destruct equalN eqn: VN.
      + intros. inversion H.
        { right. apply EqN in VN. symmetry. apply VN. }
        { apply IHE. apply H2. }
      + destruct remove_edges_from eqn: EVX. simpl. intros. inversion H.
        { left. apply in_head. }
        { apply (IHE a0 b X v) in H2 as H4. inversion H4.
          - left. apply in_tail. rewrite_pair EVX. apply H5.
          - right. apply H5. }
  Qed.

  (* Erinevus eelmisega on see, et enne tõetasime, et see kehtib remove_edges_from funktsiooni korral ja nüüd kehtib
       remove_E_add_Q funktsiooni korral *)
  Lemma InFstRemoveEdgesRb E: forall a b Q v, In (a,b) E -> In (a,b) (fst (remove_E_add_Q E v Q)) \/ a=v.
  Proof.
  intros. unfold remove_E_add_Q. destruct remove_edges_from eqn: EV. simpl. rewrite_pair EV. apply InFstRemoveEdgesRa, H.
  Qed.

  (* Iga b, Q ja E korral, kui tipp b asub Q-s, siis asub tipp b Q-s ka siis, kui järjendile Q lisatakse elemente *)
  Lemma InSndRemoveEdgesRb X: forall b Q E,
    In b Q -> In b (add_to_Q E X Q).
  Proof.
  induction X.
  - intros. simpl. apply H.
  - intros. simpl. destruct noIncoming; try (apply IHX); try (apply in_tail); try (apply H).
  Qed.

  (* Iga b, v, Q ja E korral, kui tipp b asub töötlemata tippude Q järjendis, siis tipust v väljuvate servade eemaldamisel servade
       järjendist E, on tipp b ikkagi töötlemata tippude Q järjendis *)
  Lemma InSndRemoveEdgesRc: forall b v Q E,
    In b Q -> In b (snd (remove_E_add_Q E v Q)).
  Proof.
  unfold remove_E_add_Q. intros. destruct remove_edges_from. simpl. apply InSndRemoveEdgesRb, H.
  Qed.

  (* Kui tippu n on sisenevaid kaari, siis see on samaväärne, et leidub tipp m, et serv (m,n) kuulub servade järjendisse E *)
  Lemma YesIncoming n E: noIncoming E n = false <-> exists m, In (m,n) E.
  Proof.
    induction E.
    - split.
      + simpl. discriminate.
      + intros. inversion H. inversion H0.
    - split.
      + inversion IHE. simpl. destruct a. destruct equalN eqn: NN1.
        { intros. apply EqN in NN1. destruct NN1. exists n0. apply in_head. }
        { intros. apply H in H1. destruct H1. exists x. apply in_tail. apply H1. }
      + inversion IHE. simpl. destruct a. destruct equalN eqn: NN1.
        { reflexivity. }
        { intros. apply H0. inversion H1. inversion H2.
          - destruct H5, H6. rewrite EqReflN in NN1. inversion NN1.
          - exists x. apply H5. }
  Qed.

  (* Iga b, v, x ja X korral tipp b kuulub tippude järjendisse X sõltumata elementide järjekorrast järjendis X  *)
  Lemma InRemoveEdgePropa E: forall b v x X,
    In b (snd (remove_edges_from E v (x::X))) <->
    In b (x::snd (remove_edges_from E v X)).
  Proof.
  induction E.
  - simpl. reflexivity.
  - simpl. intros. destruct a. destruct equalN eqn: VN.
    + split.
      { intros. apply IHE in H. inversion H.
        - apply in_tail, IHE, in_head.
        - apply IHE in H2. inversion H2.
          + apply in_head.
          + apply in_tail, IHE, in_tail, H6. }
      { intros. inversion H.
        - apply IHE, in_tail, IHE, in_head.
        - apply IHE in H2. inversion H2.
          + apply IHE, in_head.
          + apply IHE, in_tail, IHE, in_tail, H6. }
    + destruct (remove_edges_from E v (x :: X)) eqn: EVX. destruct (remove_edges_from E v X) eqn: EVX2. simpl. split.
      { intros. rewrite_pair EVX in H.  rewrite_pair EVX2.  apply IHE, H. }
      { intros. rewrite_pair EVX. rewrite_pair EVX2 in H. apply IHE, H. }
  Qed.

  (* Iga a,b,X ja v korral, kui serv (a,b) kuulub E-sse ja tipust v väljuvate kaarte eemaldamisel tippu b pole sisenevaid servi, siis
       järeldub, et tipp b kuulub X-i *)
  Lemma RemoveEdgesPropa E: forall a b X v,
    In (a,b) E -> noIncoming (fst (remove_edges_from E v X)) b = true ->
    In b (snd (remove_edges_from E v X)).
  Proof.
    induction E.
    - intros. inversion H.
    - simpl. destruct a. intros a b Q v. destruct equalN.
      + destruct (noIncoming E n0) eqn: EN0.
        { intros. inversion H.
          - destruct H3, H4. apply InRemoveEdgePropa. apply in_head.
          - apply (IHE a b (n0 :: Q) v).
            + apply H3.
            + apply H0. }
        { apply YesIncoming in EN0. intros. inversion EN0. inversion H.
          - destruct H5. apply (IHE x b (b:: Q) v).
            + apply H1.
            + apply H0.
          - apply (IHE a b (n0:: Q) v).
            + apply H4.
            + apply H0. }
      + destruct remove_edges_from eqn: EQV. simpl. destruct (equalN b n0) eqn: BN0.
        { intros. inversion H0. }
        { simpl. intros. rewrite_pair EQV. inversion H.
          - destruct H4. apply (IHE a b Q v).
            + rewrite EqReflN in BN0. inversion H.
              { inversion BN0. }
              { apply H6. }
            + rewrite EqReflN in BN0. inversion BN0.
          - apply (IHE a b Q v).
            + apply H3.
            + rewrite_pair EQV in H0. apply H0. }
  Qed.

  (* Iga E, b ja Q korral, kui tippu b pole sisenevaid kaari ja b asub X-is, siis X-st kõikide sisendastmega null tippude tõstmist Q-sse
       kuulub b Q-sse *)
  Lemma RemoveEdgesPropb X: forall E b Q,
    noIncoming E b = true ->
    In b X ->
    In b (add_to_Q E X Q).
  Proof.
  induction X.
  - intros. inversion H0.
  - simpl. intros. destruct (noIncoming E a) eqn: EA.
    + inversion_clear H0.
      { apply InSndRemoveEdgesRb, in_head. }
      { apply IHX.
        - apply H.
        - apply H1. }
    + inversion H0.
      { destruct H3. rewrite EA in H. inversion H. }
      { apply IHX.
        - apply H.
        - apply H3. }
  Qed.

  (* Iga a,b,Q ja v korral, kui serv (a,b) asub servade järjendis E ning tipust v väljuvate kaarte eemaldamisel tippu b ei sisene ükski
       serv, siis järelikult on tipp b järjendis Q *)
  Lemma RemoveEdgesPropc E: forall a b Q v,
    In (a,b) E -> noIncoming (fst (remove_E_add_Q E v Q)) b = true ->
    In b (snd (remove_E_add_Q E v Q)).
  Proof.
  intros. unfold remove_E_add_Q. destruct remove_edges_from eqn: EV. simpl. apply (RemoveEdgesPropa E a b [] v) in H.
  - rewrite EV in H. apply (RemoveEdgesPropb n ((fst (remove_E_add_Q E v Q))) b Q) in H0.
    + destruct add_to_Q eqn: ENQ.
      { inversion H0. }
      { unfold remove_E_add_Q in ENQ. rewrite EV in ENQ. simpl in ENQ. rewrite <- ENQ in H0. apply H0. }
    + simpl in H. apply H.
  - unfold remove_E_add_Q in H0. rewrite EV in H0. simpl in H0. rewrite_pair EV in H0. apply H0.
  Qed.

  (* Iga b,v ja X korral, kui tippu b pole sisenevaid servi, siis pole tippu b sisenevaid servi ka siis kui E-st on eemaldatud kui tipust v
       väljuvad servad *)
  Lemma NoIncomingFstRa E: forall b v X,
    noIncoming E b = true ->
    noIncoming (fst (remove_edges_from E v X)) b = true.
  Proof.
  induction E.
    - simpl. reflexivity.
    - simpl. destruct a. intros b v. destruct equalN eqn: BN0.
      + discriminate.
      + destruct (equalN v n).
        { try (intros); try (apply IHE, H). }
        { intros. destruct remove_edges_from eqn: EQV. simpl. rewrite BN0. rewrite_pair EQV. apply IHE, H. }
  Qed.

  (* Erinevus eelmisega on see, et enne tõetasime, et see kehtib remove_edges_from funktsiooni korral ja nüüd kehtib
       remove_E_add_Q funktsiooni korral  *)
  Lemma NoIncomingFstRc E: forall b v Q,
    noIncoming E b = true ->
    noIncoming (fst (remove_E_add_Q E v Q)) b = true.
  Proof.
  unfold remove_E_add_Q. intros. destruct remove_edges_from eqn: EV. apply (NoIncomingFstRa E b v []) in H. rewrite_pair EV.
  simpl. apply H.
  Qed.

  (* Iga b,v ja X korral, kui tipust v väljuvate servade eemaldamisel tippu b ei ole sisenevaid kaari, siis järeldub, et tipust v ei
       sisenenud kaart tippu b või kuulub tipp b X-i *)
  Lemma NoIncomingRemovePropLefta E: forall b v X,
    noIncoming (fst (remove_edges_from E v X)) b = true ->
    noIncoming E b = true \/ In b (snd (remove_edges_from E v X)).
  Proof.
    induction E.
    - intros. left. reflexivity.
    - simpl. destruct a. intros b v Q. destruct equalN eqn: VN.
      + destruct (noIncoming E n0) eqn: EN0.
        { destruct (equalN b n0) eqn: BN0.
          - intros. right. apply IHE in H. inversion H.
            + apply InRemoveEdgePropa. apply EqN in BN0. destruct BN0. apply in_head.
            + apply H0.
          - intros. apply IHE. apply H. }
        { destruct (equalN b n0) eqn: BN0.
          - intros. right. simpl. apply YesIncoming in EN0. inversion EN0. apply (RemoveEdgesPropa E x) in H.
            + apply H.
            + apply EqN in BN0. destruct BN0. apply H0.
          - apply YesIncoming in EN0. inversion EN0. intros. apply IHE. apply H0. }
      + destruct (remove_edges_from E v Q) eqn: EQV. destruct (equalN b n0) eqn: BN0.
        { simpl. rewrite BN0. intros. inversion H. }
        { simpl. rewrite BN0. intros. rewrite_pair EQV in H. apply IHE in H. inversion H.
          - left. apply H0.
          - rewrite_pair EQV. right. apply H0. }
  Qed.

  (* Erinevus eelmisega on see, et enne tõetasime, et see kehtib remove_edges_from funktsiooni korral ja nüüd kehtib
       remove_E_add_Q funktsiooni korral *)
  Lemma NoIncomingRemovePropLeftc E: forall b v Q,
    noIncoming (fst (remove_E_add_Q E v Q)) b = true ->
    noIncoming E b = true \/ In b (snd (remove_E_add_Q E v Q)).
  Proof.
  intros. unfold remove_E_add_Q in *. destruct remove_edges_from eqn: EV. simpl in *. rewrite_pair EV in H.
  apply NoIncomingRemovePropLefta in H as T. inversion T.
  - left. apply H0.
  - apply (RemoveEdgesPropb (snd (remove_edges_from E v [])) (fst (remove_edges_from E v [])) b Q) in H0.
    + right. rewrite_pair EV. apply H0.
    + apply H.
  Qed.

  (* Iga b, E ja Q korral, iga a korral, kui a kuulub Q-sse ja tippu a pole sisenevaid servi, kui peale Q-sse kõikide sisendastmega
       null tippude lisamist kuulub tipp b Q-sse, järeldub, et tippu b polnud sisenevaid servi *)
  Lemma NoIncomingRemovePropb X: forall b E Q,
    (forall a, In a Q -> noIncoming E a = true) ->
    In b (add_to_Q E X Q) ->
    noIncoming E b = true.
  Proof.
  induction X.
  - simpl. intros. apply H, H0.
  - simpl. intros b E Q. destruct (noIncoming E a) eqn: EA.
    + intros. apply IHX in H0.
      { apply H0. }
      { intros. inversion H1.
        - apply EA.
        - apply H, H4. }
    + apply IHX.
  Qed.

  (* Iga b, v ja Q korral, iga a korral, kui a kuulub Q-sse ja tippu a pole sisenevaid servi, kui pärast Q-sse kõikide sisendastmega
       null tippude lisamist kuulub tipp b Q-sse, järeldub, et pärast tipust v kõikide väljuvate servade eemaldamist, polnud tippu b
       sisenevaid servi *)
  Lemma NoIncomingRemovePropNewc E: forall b v Q,
    (forall a, In a Q -> noIncoming E a = true) ->
    In b (snd (remove_E_add_Q E v Q)) ->
    noIncoming (fst (remove_E_add_Q E v Q)) b = true.
  Proof.
  intros. unfold remove_E_add_Q in *. destruct remove_edges_from eqn: EV. simpl in *. apply NoIncomingRemovePropb in H0.
  - apply H0.
  - intros. apply H,  (NoIncomingFstRa E a v []) in H1. rewrite EV in H1. simpl in H1. apply H1.
  Qed.

  (* AProp on tsükli-invariant — kui ta kehtib tsükkli algul, siis kehtib ka järgmisel iteratsioonil *)
  Lemma loopProp SV SE E (G:forall n m, In (n,m) SE -> In n SV /\ In m SV):
    forall v Q' L, AProp SV SE (E, v :: Q') L -> AProp SV SE (remove_E_add_Q E v Q') (v::L).
  Proof.
  intros. daprop H. simpl in *. splitprop.
  - intros. apply NoIncomingRemovePropNewc.
    + intros. apply pql, in_tail, H0.
    + apply H.
  - intros. apply NoIncomingFstRc. inversion H.
    + apply pql, in_head.
    + apply pll, H2.
  - intros. destruct (noIncoming E n) eqn: EN.
    + apply pqlr in H.
      { inversion H.
        - inversion H1.
          + right. apply in_head.
          + apply (InSndRemoveEdgesRc n v Q' E) in H4. left. apply H4.
        - right. apply in_tail. apply H1. }
      { apply EN. }
    + left. apply YesIncoming in EN. inversion EN. apply (RemoveEdgesPropc E x n Q' v).
      { apply H1. }
      { apply H0. }
  - intros. destruct (equalN m v) eqn: MV.
    + apply EqN in MV. destruct MV. apply in_head.
    + apply in_tail. apply (pl m n).
      { apply H. }
      { intros T. destruct H0. apply (InFstRemoveEdgesRb E m n Q' v) in T. inversion T.
        - apply H0.
        - apply EqN in H0. rewrite H0 in MV. inversion MV. }
  - intros. apply (NoIncomingRemovePropLeftc E n v Q') in H0. inversion H0.
    + apply (pqlr n) in H2 as T.
      { inversion T.
        - inversion H3.
          + apply FT_start. apply (pl m n).
            { apply H. }
            { intros K. apply NoIncoming in H2. destruct H2. exists m. apply K. }
          + apply FT_delay. apply plo.
            { apply H. }
            { apply H2. }
            { destruct H1. apply (InSndRemoveEdgesRc n v Q' E). apply H6. }
        - destruct (equalN n v) eqn: K.
          + apply EqN in K. destruct K. apply FT_start. apply (pl m n).
            { apply H. }
            { intros K. apply NoIncoming in H2. destruct H2. exists m. apply K. }
          + apply FT_delay. apply plo.
            { apply H. }
            { apply H2. }
            { intros P. inversion P.
              - apply EqN in H6. rewrite H6 in K. inversion K.
              - destruct H1. apply (InSndRemoveEdgesRc n v Q' E). apply H6. }}
      { apply G in H. destruct H. apply H3. }
    + contradiction.
  Qed.

  (* Iga x,y korral, kui serv (x,y) leidub E-s, siis topoloogilises järjestuses asub tipp x lõppjärjendis enne tippu y *)
  Definition TopoOrder (E:edges) (xs:nodes) := forall (x y: node), In (x,y) E -> First_Then y x xs.

  (* Kui tsükli-invariant kehtib ja tsükkel tagastab L’, siis see L’ on SE topolooginine järjestus *)
  Theorem main_loop: forall SV SE Q E L L' (G:forall n m, In (n,m) SE -> In n SV /\ In m SV),
    kahn_loop (E, Q) L = Some L'  -> AProp SV SE (E, Q) L -> TopoOrder SE L'.
  Proof.
  intros SV SE Q E L L' G H. unfold TopoOrder. functional induction (kahn_loop (E, Q) L).
  - inversion H. destruct H1. apply PropResultSound.
  - inversion H.
  - intros. eapply IHo in H.
    + apply H.
    + apply loopProp.
      { apply G. }
      { apply H0. }
    + apply H1.
  Qed.

  (* Tõestame, et kahni funktsioon tagastab topoloogilise järjestuse *)
  Theorem main: forall (V: nodes) (E: edges) (l: nodes),
    (forall n m, In (n,m) E -> In n V /\ In m V) -> 
    kahn V E = Some l -> TopoOrder E l.
  Proof.
  intros. apply (main_loop V E (filter (noIncoming E) V) E []).
  - apply H.
  - unfold kahn in H0. apply H0.
  - apply startProp, H.
  Qed.

End Kahn.

(* Ei leidnud kiiret varianti, et mitte teha koodi kordust*)
Module NatGraph <: Graph.
  Definition node := nat.
  Function equalN (n: nat) (m: nat) :=
    match n, m with
      | 0, 0 => true
      | S n, S m => equalN n m
      | _, _ => false
    end.

  Lemma EqN: forall x y:node, equalN x y = true <-> x = y.
  Proof.
  intros. split.
    - functional induction (equalN x y); intros.
      + reflexivity.
      + apply f_equal, IHb, H.
      + inversion H.
    - functional induction (equalN x y); intros.
      + reflexivity.
      + apply IHb. inversion_clear H. reflexivity.
      + destruct H. induction n; inversion y. 
  Qed.

  Lemma EqReflN: forall x, equalN x x = true.
  Proof. intros x. apply EqN. reflexivity. Qed.

  Definition edge:= (node * node) %type.

  Definition nodes := list node.
  Definition edges := list edge.

  Fixpoint noIncoming (E:edges) (x: node) :=
    match E with
    | nil => true
    | cons (_,y) ys => if equalN x y then false else noIncoming ys x
    end.
End NatGraph.

(* Mõningad näited, et algoritm tagastab õige topoloogilise järjestuse (näited teoorias toodud näite põhjal) *)
Module Examples.
  Module KNat := Kahn (NatGraph).
  Import NatGraph.
  Import KNat.

  Definition tipud : nodes := [1;2;3;4;5].

  Compute (kahn tipud [(1,2);(1,3);(2,3);(2,4);(3,4);(3,5)]).
  (* = Some [5; 4; 3; 2; 1] *)

  Compute (kahn tipud [(1,2);(1,3);(2,3);(2,4);(3,5);(3,4)]).
  (* = Some [4; 5; 3; 2; 1] *)

  Compute (kahn tipud [(1,2);(2,3);(3,1)]).
  (* = None *)
End Examples.