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

Require Import misc.
Require Import regexp.

Set Implicit Arguments.

Module Automata.

  Import Misc.

  (** Finite automata. ***)
  Section FA.

    Variable char: finType.

    (** Type of input sequences ***)
    Definition word := word char.

    (** Deterministic finite automata. **)
    Section DFA.

      (** The type of deterministic finite automata. ***)
      Record dfa : Type :=
        {
          dfa_state :> finType;
          dfa_s: dfa_state;
          dfa_fin: pred dfa_state;
          dfa_step: dfa_state -> char -> dfa_state
        }.

      (** Acceptance on DFAs **)
      Section Acceptance.

        (** Assume some automaton **)
        Variable A: dfa.

        (** We define a run of w on the automaton A
   to be the list of states x_1 .. x_|w|
   traversed when following the edges labeled
   w_1 .. w_|w| starting in x. **)
        Fixpoint dfa_run' (x: A) (w: word) : seq A :=
          match w with
            | [::] => [::]
            | a::w => (dfa_step A x a) ::dfa_run' (dfa_step A x a) w
          end.

        (** A simplifying function for a "aux2" run
   (i.e. starting at s). **)
        Definition dfa_run := [fun w => dfa_run' (dfa_s A) w].

        (** Acceptance of w in x is defined as
   finality of the last state of a run of w on A
   starting in x. **)
        Fixpoint dfa_accept x w :=
          match w with
            | [::] => dfa_fin A x
            | a::w => dfa_accept (dfa_step A x a) w
          end.

        (** **)
        Fixpoint dfa_final x w :=
          match w with
            | [::] => x
            | a::w => dfa_final (dfa_step A x a) w
          end.

        Lemma dfa_final_accept x w:
          dfa_fin A (dfa_final x w) <-> dfa_accept x w.
        Proof.
          elim: w x => [| a w IH] x; split; intros; try done.
          simpl in *; apply IH; by done.
          simpl in *; apply IH; by done.
        Qed.

        Lemma dfa_accept_cons x a w:
          a::w \in dfa_accept x = (w \in dfa_accept (dfa_step A x a)).
        Proof. by rewrite -simpl_predE /=. Qed.

        (** We define the language of the deterministic
   automaton, i.e. acceptance in the starting state. **)
        Definition dfa_lang := [pred w | dfa_accept (dfa_s A) w].

        (** take lemma. **)
        Lemma dfa_run'_take x w n: take n (dfa_run' x w) = dfa_run' x (take n w).
        Proof. elim: w x n => [|a w IHw] x n //.
               case: n => [|n] //=. by rewrite IHw.
        Qed.

        (** rcons and cat lemmas. **)
        Lemma dfa_run'_cat x w1 w2 :
          dfa_run' x (w1 ++ w2) = dfa_run' x w1 ++ dfa_run' (last x (dfa_run' x w1)) w2.
        Proof. elim: w1 w2 x => [|a w1 IHw1] w2 x //.
               simpl. by rewrite IHw1.
        Qed.

        (* slightly altered acceptance statement. *)
        Lemma dfa_run_accept x w: last x (dfa_run' x w) \in dfa_fin A = (w \in dfa_accept x).
        Proof. elim: w x => [|a w IHw] x //. by rewrite /= IHw. Qed.

      End Acceptance.

    End DFA.

    Implicit Arguments Build_dfa [dfa_state].

    (** Non-deterministic automata. **)
    Section NFA.

      (** The type of non-deterministic finite automata. ***)
      Record nfa : Type :=
        {
          nfa_state :> finType;
          nfa_s: nfa_state;
          nfa_fin: pred nfa_state;
          nfa_step: nfa_state -> char -> pred nfa_state
        }.

      (** Acceptance on non-deterministic automata. **)
      Section Acceptance.

        Variable A: nfa.

        (** Non-deterministic acceptance. **)
        Fixpoint nfa_accept (x: A) w :=
          match w with
            | [::] => nfa_fin A x
            | a::w => [ exists y, (nfa_step A x a y) && nfa_accept y w ]
          end.

        (** We define the language of the non-deterministic
   automaton, i.e. acceptance in the starting state. **)
        Definition nfa_lang := [pred w | nfa_accept (nfa_s A) w].

        (** We define labeled paths over the non-deterministic step relation **)
        Fixpoint nfa_run x (xs : seq A) (w: word) {struct xs} :=
          match xs,w with
            | y :: xs', a::w' => nfa_step A x a y && nfa_run y xs' w'
            | [::]    , [::]  => true
            | _       , _     => false
          end.

        Lemma nfa_run_accept x w:
          reflect (exists2 xs, nfa_run x xs w & last x xs \in nfa_fin A)
                  (nfa_accept x w).
        Proof.
          elim: w x => [|a w IHw] x.
          case H: (nfa_accept x [::]); constructor.
            by exists [::].
                      move => [[|y xs]] //.
                      move: H => /= H _.
                        by rewrite -topredE /= H.
                        case H: nfa_accept => /=; constructor.
                        move/existsP: H => [] y /andP [] H1 /IHw [] xs H2 H3.
                        exists (y::xs) => //=.
                          by rewrite H1 H2 /=.
                          move => [[|y xs]] //= /andP [] H1 H2 H3.
                          move/existsP: H => H.
                          apply: H. exists y.
                          rewrite H1 /=.
                          apply/IHw.
                            by exists xs.
        Qed.

        (** Helpful facts **)
        Lemma nfa_accept_cat x w1 w2:
          nfa_accept x (w1 ++ w2) <->
          exists xs,
            nfa_run x xs w1
                    && nfa_accept (last x xs) w2.
        Proof. split.
               elim: w1 w2 x => [|a w1 IHw1] w2 x.
               simpl. exists [::]. simpl. exact: H.
               move/existsP => [] y /andP [] H0 /IHw1 [] ys /andP [] H1 H2.
               exists (y::ys) => /=. by rewrite H0 H1 H2.
               elim: w1 w2 x => [|a w1 IHw1] w2 x; move => [] [|y ys] /andP [] H0 H1 //.
               move: H0 => /= /andP [] H2 H3.
               apply/existsP. exists y. rewrite H2 /=.
               apply: IHw1.
               exists ys. by rewrite H3 H1.
        Qed.

      End Acceptance.

    End NFA.

    Implicit Arguments Build_nfa [nfa_state].

    (** We define the powerset construction to obtain
   a deterministic automaton from a non-deterministic one. **)
    Section PowersetConstruction.

      Variable A: nfa.

      Definition nfa_to_dfa :=
        {| dfa_s := set1 (nfa_s A);
           dfa_fin := [ pred X: {set A} | [ exists x: A, (x \in X) && nfa_fin A x] ];
           dfa_step := [ fun X a => \bigcup_(x | x \in X) finset (nfa_step A x a) ]
        |}.

      (** We prove that for every state x, the new automaton
   accepts at least the language of the given automaton
   when starting in a set containing x. **)
      Lemma nfa_to_dfa_aux2 (x: A) w (X: nfa_to_dfa):
        x \in X -> nfa_accept A x w -> dfa_accept nfa_to_dfa X w.
      Proof. move => H0.
             elim: w X x H0 => [|a w IHw] X x H0.
             (* [::] *)
             move => /= H1. apply/existsP. exists x.
               by rewrite H0 H1.
               (* a::w *)
               move => /= /existsP [] y /andP [] H1.
               apply (IHw).
               apply/bigcupP.
               exists x => //.
                 by rewrite in_set.
      Qed.

      (** Next we prove that in any set of states X, for every word w,
   if the powerset automaton accepts w in X, there exists one
   representative state of that set in which the given automaton
   accepts w. **)
      Lemma nfa_to_dfa_aux1 (X: nfa_to_dfa) w:
        dfa_accept nfa_to_dfa X w -> [ exists x, (x \in X) && nfa_accept A x w ].
      Proof. elim: w X => [|a w IHw] X => //.
             move/IHw => /existsP [] y /andP [].
             rewrite /dfa_step /nfa_to_dfa.
             move/bigcupP => [] x H0. rewrite in_set => H1 H2 /=.
             apply/existsP. exists x. rewrite H0 /=.
             apply/existsP. exists y.
               by rewrite H1 H2.
      Qed.

      (** Finally, we prove that the language of the powerset
   automaton is exactly the language of the given
   automaton. **)
      Lemma nfa_to_dfa_correct : nfa_lang A =i dfa_lang nfa_to_dfa.
      Proof. move => w. apply/idP/idP => /=.
             apply: nfa_to_dfa_aux2. by apply/set1P.
               by move/nfa_to_dfa_aux1 => /existsP [] x /andP [] /set1P ->.
      Qed.

    End PowersetConstruction.

    (** Embedding deterministic automata in non-deterministic automata. **)
    Section Embed.

      Variable A: dfa.

      Definition dfa_to_nfa : nfa :=
        {|
          nfa_s := dfa_s A;
          nfa_fin := dfa_fin A;
          nfa_step := fun x a y => y == dfa_step A x a
        |}.

      (** We prove that dfa_to_nfa accepts the same language as
   the given automaton in any state. **)
      Lemma dfa_to_nfa_correct' x w : dfa_accept A x w = nfa_accept dfa_to_nfa x w.
      Proof. elim: w x => [|b w IHw] x.
               by [].
               simpl. rewrite IHw.
               apply/idP/existsP.
               move => H0. exists (dfa_step A x b). by rewrite eq_refl H0.
                 by move => [] y /andP [] /eqP ->.
      Qed.

      (** We prove that dfa_to_nfa accepts the same language
   as the given automaton in the starting state, i.e. their
   languages are equal. **)
      Lemma dfa_to_nfa_correct : dfa_lang A =i nfa_lang dfa_to_nfa.
      Proof.
        exact: dfa_to_nfa_correct'.
      Qed.

    End Embed.

    (** Primitive automata **)
    Section Primitive.
      Definition dfa_void :=
        {|
          dfa_s := tt;
          dfa_fin := pred0;
          dfa_step := [fun x a => tt]
        |}.

      Lemma dfa_void_correct x w: ~~ dfa_accept dfa_void x w.
      Proof. by elim: w x => [|a w IHw] //= x. Qed.

      Definition dfa_eps :=
        {|
          dfa_s := true;
          dfa_fin := pred1 true;
          dfa_step := [fun x a => false]
        |}.

      Lemma dfa_eps_correct: dfa_lang dfa_eps =i pred1 [::].
      Proof.
        have H: (forall w, ~~ dfa_accept dfa_eps false w).
          by elim => [|a v IHv] //=.
          move => w.
          elim: w => [|a w IHw] //.
          apply/idP/idP.
          exact: H.
      Qed.

      Definition dfa_char a :=
        {|
          dfa_s := None;
          dfa_fin := pred1 (Some true);
          dfa_step := [fun x b => if x == None then if b == a then Some true else Some false else Some false ]
        |}.

      Lemma dfa_char_correct'' a w: ~~ dfa_accept (dfa_char a) (Some false) w.
      Proof. by elim: w => [|b v IHv] //=. Qed.
      Lemma dfa_char_correct' a w: dfa_accept (dfa_char a) (Some true) w = (w == [::]).
      Proof.
        elim: w a => [|b w IHw] a //=.
        apply/idP/idP.
        exact: dfa_char_correct''.
      Qed.
      Lemma dfa_char_correct a w: dfa_lang (dfa_char a) w = (w == [::a]).
      Proof.
        elim: w a => [|b w IHw] a //=.
        case H: (b == a).
        move/eqP: H => ->.
        rewrite dfa_char_correct'.
          by apply/eqP/eqP => [-> | []].
          apply/idP/eqP.
          move => H0. move: (dfa_char_correct'' a w). by rewrite H0.
          move => [] /eqP. by rewrite H.
      Qed.

      Definition dfa_dot :=
        {|
          dfa_s := None;
          dfa_fin := pred1 (Some true);
          dfa_step := [fun x b => if x == None then Some true else Some false ]
        |}.

      Lemma dfa_dot_correct'' w: ~~ dfa_accept dfa_dot (Some false) w.
      Proof. by elim: w => [|b v IHv] //=. Qed.
      Lemma dfa_dot_correct' w: dfa_accept dfa_dot (Some true) w = (w == [::]).
      Proof.
        elim: w => [|b w IHw] //=.
        apply/idP/idP.
        exact: dfa_dot_correct''.
      Qed.
      Lemma dfa_dot_correct w: dfa_lang dfa_dot w = (size w == 1).
      Proof.
        elim: w => [|b w IHw] //=.
        rewrite dfa_dot_correct'.
        apply/eqP/eqP => [-> | []] //=.
        exact: size0nil.
      Qed.

    End Primitive.

    (** Operations on non-deterministic automata. **)
    Section DFAOps.

      Variable A1: dfa.

      (** Complement automaton **)

      (** We construct the resulting automaton. **)
      Definition dfa_compl :=
        {|
          dfa_s := dfa_s A1;
          dfa_fin := [ fun x1 => ~~ dfa_fin A1 x1 ];
          dfa_step := (dfa_step A1)
        |}.

      (** We prove that the complement automaton accepts exactly
   the words not accepted by the original automaton. **)
      Lemma dfa_compl_correct' x:
        [ predC dfa_accept A1 x ] =i dfa_accept dfa_compl x.
      Proof. move => w. elim: w x => [|a w IHw] x.
               by apply/idP/idP.
               simpl. rewrite -topredE dfa_accept_cons /= -IHw.
               apply/negP/idP; rewrite dfa_accept_cons; by move/negP.
      Qed.

      (** Language correctness for dfa_compl **)
      Lemma dfa_compl_correct:
        [ predC dfa_lang A1 ] =i dfa_lang dfa_compl.
      Proof. exact: dfa_compl_correct'. Qed.

      (** Operations on two automata. **)
      Section BinaryOps.

        Variable A2: dfa.

        (** Disjunction automaton **)

        Definition dfa_disj :=
          {|
            dfa_s := (dfa_s A1, dfa_s A2);
            dfa_fin := (fun q => let (x1,x2) := q in dfa_fin A1 x1 || dfa_fin A2 x2);
            dfa_step := [fun x a => (dfa_step A1 x.1 a, dfa_step A2 x.2 a)]
          |}.

        (** Correctness w.r.t. any state. **)
        Lemma dfa_disj_correct' x:
          [ predU dfa_accept A1 x.1 & dfa_accept A2 x.2 ]
          =i dfa_accept dfa_disj x.
        Proof. move => w. elim: w x => [|a w IHw].
                 by move => [].
                 move => x /=. by rewrite dfa_accept_cons -IHw.
        Qed.

        (** Language correctness. **)
        Lemma dfa_disj_correct:
          [ predU  dfa_lang A1 & dfa_lang A2 ]
          =i dfa_lang dfa_disj.
        Proof. move => w /=. by rewrite -dfa_disj_correct'. Qed.

        (** Conjunction **)

        Definition dfa_conj :=
          {|
            dfa_s := (dfa_s A1, dfa_s A2);
            dfa_fin := (fun x => dfa_fin A1 x.1 && dfa_fin A2 x.2);
            dfa_step := [fun x a => (dfa_step A1 x.1 a, dfa_step A2 x.2 a)]
          |}.

        (** Correctness w.r.t. any state. **)
        Lemma dfa_conj_correct' x1 x2 :
          [ predI  dfa_accept A1 x1 & dfa_accept A2 x2 ]
          =i dfa_accept dfa_conj (x1, x2).
        Proof. move => w. elim: w x1 x2 => [|a w IHw].
                 by [].
                 move => x1 x2.
                 exact: IHw.
        Qed.

        (** Language correctness. **)
        Lemma dfa_conj_correct:
          [ predI dfa_lang A1 & dfa_lang A2 ]
          =i dfa_lang dfa_conj.
        Proof. move => w. by rewrite -dfa_conj_correct'  /=. Qed.

      End BinaryOps.

      (* Remove unreachable states *)
      Section Reachability.
        Definition reachable1 := [ fun x y => [ exists a, dfa_step A1 x a == y ] ].

        Definition reachable := enum (connect reachable1 (dfa_s A1)).

        Lemma reachable_step x a: x \in reachable ->  dfa_step A1 x a \in reachable.
        Proof.
          rewrite 2!mem_enum -2!topredE /= => Hx.
          eapply connect_trans.
          eassumption.
          apply/connectP.
          exists [::dfa_step A1 x a] => //=.
          rewrite andbT. apply/existsP. by exists a.
        Qed.

        Lemma reachable0 : dfa_s A1 \in reachable.
        Proof. rewrite mem_enum -topredE /=. by apply connect0. Qed.

        Definition dfa_connected :=
          {|
            dfa_s := SeqSub reachable0;
            dfa_fin := fun x => match x with SeqSub x _ => dfa_fin A1 x end;
            dfa_step := fun x a => match x with
                                     | SeqSub _ Hx => SeqSub (reachable_step _ a Hx)
                                   end
          |}.

        Lemma dfa_connected_correct' x (Hx: x \in reachable) :
          dfa_accept dfa_connected (SeqSub Hx) =i dfa_accept A1 x.
        Proof. move => w. elim: w x Hx => [|a w IHw] x Hx //=.
                 by rewrite 2!dfa_accept_cons IHw.
        Qed.

        Lemma dfa_connected_correct: dfa_lang dfa_connected =i dfa_lang A1.
        Proof.
          move => w. by rewrite /dfa_lang /= dfa_connected_correct'.
        Qed.

        Definition reachable1_connected := [ fun x y => [ exists a, dfa_step dfa_connected x a == y ] ].
        Lemma reachable1_connected_aux2 x y (Hx: x \in reachable) (Hy: y \in reachable) : connect reachable1 x y -> connect reachable1_connected (SeqSub Hx) (SeqSub Hy).
        Proof.
          move/connectP => [p].
          elim: p x Hx y Hy => [|z p IHp] x Hx y Hy //=.
          move => _ H.
          move: Hx Hy. rewrite H => Hx Hy.
          have: (Hx = Hy).
            by apply: bool_irrelevance.
            move => ->.
            apply: connect0.
            move/andP => [] /existsP [] a /eqP Ha Hpz H.
            have Hz: (z \in reachable).
            rewrite -Ha. by apply reachable_step.
            pose H0 := (IHp _ Hz _ Hy Hpz H).
            eapply connect_trans.
            apply connect1.
            instantiate (1 := SeqSub Hz).
            apply/existsP. exists a.
            simpl. move: Hz H0.
            rewrite -Ha => Hz H0.
            have: Hz = reachable_step x a Hx.
            apply bool_irrelevance.
              by move => ->.
              assumption.
        Qed.

        Lemma dfa_connected_repr' (x y: dfa_connected):
          connect reachable1_connected y x ->
          exists w, last y (dfa_run' dfa_connected y w) = x.
        Proof.
          move/connectP => [] p.
          elim: p x y => [|z p IHp] x y.
          move => _ -> /=. by exists [::].
                                     move => /= /andP [] /existsP [] a /eqP Ha Hp Hx.
                                     destruct (IHp x z) as [w Hw] => //.
                                     exists (a::w).
                                       by rewrite /= Ha.
        Qed.

        Lemma dfa_connected_repr x :
          exists w, last (dfa_s dfa_connected) (dfa_run dfa_connected w) = x.
        Proof.
          apply dfa_connected_repr'.
          destruct x as [x Hx].
          apply (reachable1_connected_aux2 (dfa_s A1) x reachable0).
            by rewrite mem_enum -topredE /= in Hx.
        Qed.

        Lemma dfa_connected_repr_pred x :
          exists w, last (dfa_s dfa_connected) (dfa_run dfa_connected w) == x.
        Proof.
          move: (dfa_connected_repr x) => [w /eqP].
            by eauto.
        Defined.

        Lemma dfa_connected_repr_fun (x: dfa_connected):
          word.
        Proof.
          move: (dfa_connected_repr_pred x).
          apply (xchoose).
        Defined.

        Lemma dfa_connected_repr_fun_correct x: last (dfa_s dfa_connected) (dfa_run dfa_connected (dfa_connected_repr_fun x)) = x.
        Proof.
          rewrite /dfa_connected_repr_fun.
            by move: (xchooseP (dfa_connected_repr_pred x)) => /eqP.
        Qed.

        Lemma dfa_connected_repr_fun_injective: injective dfa_connected_repr_fun.
        Proof.
          move => x y.
          rewrite /dfa_connected_repr_fun => H.
          move: (xchooseP (dfa_connected_repr_pred x)) => /eqP.
          move: (xchooseP (dfa_connected_repr_pred y)) => /eqP.
          rewrite H. by move => -> ->.
        Qed.

      End Reachability.

      Section Emptiness.

        Definition dfa_lang_empty := #|dfa_fin dfa_connected| == 0.

        Lemma dfa_lang_empty_aux2: dfa_lang dfa_connected =i pred0 -> dfa_lang_empty.
        Proof.
          rewrite /dfa_lang_empty.
          move => H.
          apply/eqP/eq_card0.
          move => x.
          apply/idP/idP.
          apply/negP.
          move: (dfa_connected_repr x) => [w Hw].
          move: (H w).
          rewrite /dfa_lang /= -dfa_run_accept.
          rewrite Hw.
            by move/negP.
        Qed.

        Lemma dfa_lang_empty_aux1: dfa_lang_empty -> dfa_lang dfa_connected =i pred0.
        Proof.
          rewrite /dfa_lang_empty.
          move => H w.
          apply/idP/idP.
          apply/negP.
          rewrite /dfa_lang /= -dfa_run_accept.
            by move/eqP/card0_eq: H => ->.
        Qed.

        Lemma dfa_lang_empty_correct:
          reflect (dfa_lang A1 =i pred0)
                  dfa_lang_empty.
        Proof.
          apply/iffP.
          eexact (@idP dfa_lang_empty ).
          move => H w. rewrite -dfa_connected_correct.
          exact: dfa_lang_empty_aux1.
          move => H.
          apply: dfa_lang_empty_aux2.
          move => w.
            by rewrite dfa_connected_correct.
        Qed.

      End Emptiness.

    End DFAOps.

    Section Equivalence.
      Definition dfa_sym_diff A1 A2 :=
        dfa_disj (dfa_conj A1 (dfa_compl A2)) (dfa_conj A2 (dfa_compl A1)).

      Definition dfa_equiv A1 A2 := dfa_lang_empty (dfa_sym_diff A1 A2).

      Lemma dfa_equiv_correct A1 A2:
        dfa_equiv A1 A2 <-> dfa_lang A1 =i dfa_lang A2.
      Proof.
        split; rewrite /dfa_sym_diff.
        move/dfa_lang_empty_correct => H w.
        move: (H w).
        rewrite -dfa_disj_correct -topredE /= -2!dfa_conj_correct -2!topredE /= -2!dfa_compl_correct.
        move/norP => [] /nandP [] /negP H1 /nandP [] /negP H2;
          apply/idP/idP; try by [];
          move/negP: H1; move/negP: H2;
            by auto using negbNE.
        move => H. apply/dfa_lang_empty_correct => w. move: (H w).
        rewrite -dfa_disj_correct -3!topredE /= -2!dfa_conj_correct -2!topredE /= -2!dfa_compl_correct.
        rewrite -H -4!topredE /= -2!topredE /= andbN => ->.
          by rewrite andbN.
      Qed.

    End Equivalence.

    (** Operations on non-deterministic automata. **)
    Section NFAOps.
      Variable A1: nfa.
      Variable A2: nfa.

      (** Concatenation of two non-deterministic automata. **)

      Definition nfa_conc : nfa :=
        {|
          nfa_s := inl _ (nfa_s A1);
          nfa_fin := [fun x =>
                        match x with
                          | inl x => nfa_fin A1 x && nfa_fin A2 (nfa_s A2)
                          | inr x => nfa_fin A2 x
                        end];
          nfa_step := fun x a y =>
                        match x,y with
                          | inl x, inl y => nfa_step A1 x a y
                          | inl x, inr y => nfa_fin A1 x && nfa_step A2 (nfa_s A2) a y
                          | inr x, inr y => nfa_step A2 x a y
                          | inr x, inl y => false
                        end
        |}.

      (** We prove that every path of A2 can be mapped to a path
   of nfa_conc. **)
      Lemma nfa_conc_cont x xs w:
        nfa_run A2 x xs w
        -> nfa_run nfa_conc (inr _ x) (map (@inr A1 A2) xs) w.
      Proof. elim: xs x w => [|y xs IHxs] x w; case: w => [|a w] => //.
             simpl. by move/andP => [] -> /IHxs ->.
      Qed.

      (** We prove that every word in the language of A2
   is also accepted by any final state of A1 in
   nfa_conc. **)
      Lemma nfa_conc_fin1 x1 w:
        nfa_fin A1 x1 ->
        nfa_lang A2 w ->
        nfa_accept nfa_conc (inl _ x1) w.
      Proof.
        move => H0 /nfa_run_accept [] ys.
        elim: ys w x1 H0 => [|y ys IHys] [|a w] x1 H0 //=.
        rewrite -topredE /=.
          by move: H0 => -> _ ->.
          move => /andP [] H1 H2 H3.
          apply/existsP. exists (inr _ y).
          rewrite H0 H1 /=.
          apply/nfa_run_accept.
          eexists _.
          apply nfa_conc_cont.
            by eassumption.
              by rewrite last_map /nfa_fin.
      Qed.

      (** We prove that for every word w1 accepted by A1 in
   some state x and for every word w2 in the language of A2
   w1 ++ w2 will be accepted by the corresponding state in
   nfa_conc. **)
      Lemma nfa_conc_aux2 x w1 w2:
        nfa_accept A1 x w1 ->
        nfa_lang A2 w2 ->
        nfa_accept nfa_conc (inl _ x) (w1 ++ w2).
      Proof. elim: w1 w2 x => [|a w1 IHw1] w2 x.
             move => H0 /nfa_run_accept [] xs [] H1 H2.
             move: (nfa_conc_cont _ _ _ H1) => H3.
             apply/nfa_accept_cat.
             exists [::] => /=.
             apply: nfa_conc_fin1 => //.
             apply/nfa_run_accept.
               by eauto.
               move => /existsP [] y /andP [] H1 H2 H3 /=.
               apply/existsP. exists (inl _ y).
               rewrite H1 /=.
               apply: IHw1.
               exact: H2.
               exact: H3.
      Qed.

      (** We prove that every word accepted by some state X in nfa_conc is
   - EITHER a concatenation of two words w1, w2 which are accpeted
   by A1, A2 (resp.) if X corresponds to one of A1's states
   - OR accepted by A2 in the state corresponding to X if X
   corresponds to one of A2's states. **)
      Lemma nfa_conc_aux1 X w :
        nfa_accept nfa_conc X w ->
        match X with
          | inl x => exists w1, exists w2, (w == w1 ++ w2) && (nfa_accept A1 x w1) && nfa_lang A2 w2
          | inr x => nfa_accept A2 x w
        end.
      Proof.
        elim: w X => [|a w IHw] [x|x] //=.
        move => /andP [] H0 H1. exists [::]. exists [::].
          by rewrite /= H0 H1.
          move/existsP => [] [y|y] /andP [] H0 /IHw.
          (* inl / inl *)
          move => [] w1 [] w2 /andP [] /andP [] /eqP H1 H2 /= H3.
          exists (a::w1). exists w2.
          rewrite H1 eq_refl H3 andTb andbT.
          apply/existsP. exists y.
          move: H0 => /= ->. rewrite andTb.
          exact H2.
          (* inl / inr *)
          move: H0 => /= /andP [] H0 H1 /= H2.
          exists [::]. exists (a::w) => /=.
          rewrite H0 eq_refl 2!andTb.
          apply/existsP. exists y.
            by rewrite H1 H2.
            (* inr / inl  *)
            move/existsP => [] [y|y] /andP [] H0 /IHw.
              by [].
              (* inr / inr *)
              move: H0 => /= H0 H1.
              apply/existsP. exists y.
                by rewrite H0 H1.
      Qed.

      Lemma nfa_conc_correct: nfa_lang nfa_conc =i conc (nfa_lang A1) (nfa_lang A2).
      Proof.
        move => w.
        apply/idP/concP.
        move/nfa_conc_aux1.
        rewrite /nfa_conc /nfa_s.
        move => [] w1 [] w2 /andP [] /andP [] /eqP H0 H1 H2.
          by eauto.
          move => [] w1 H0 [] w2 H2 ->.
            by apply/nfa_conc_aux2.
      Qed.

      (** Plus operator for non-deterministic automata. **)

      (** The step relation implements the following rule:
   - every edge to a final state will also be duplicated
   to point to s0.
       **)
      Definition step_plus x a y : bool :=
        nfa_step A1 x a y || (
                   (y == nfa_s A1)
                     && [ exists z, (nfa_fin A1 z) && (nfa_step A1 x a z) ]
                 ).

      (** **)
      Definition nfa_repeat : nfa :=
        {|
          nfa_s := nfa_s A1;
          nfa_fin := nfa_fin A1;
          nfa_step := fun x a y =>
                        nfa_step A1 x a y || (
                                   (y == nfa_s A1)
                                     && [ exists  z, (nfa_fin A1 z) && (nfa_step A1 x a z) ]
                                 )
        |}.

      (** We prove that every path of A1 can be mapped to a path
   of nfa_repeat. **)
      Lemma nfa_repeat_cont x xs w:
        nfa_run A1 x xs w
        -> nfa_run nfa_repeat x xs w.
      Proof. elim: xs x w => [|y xs IHxs] x w; case: w => [|a w] => //.
             move/andP => [] H0 /= /IHxs ->.
               by rewrite /step_plus H0 orTb.
      Qed.

      (** We prove that every accepting path labeled (a::w) in A1
   exists in nfa_repeat with only the last state changed to
   A1's starting state. This new path need not be accepting. **)
      Lemma nfa_repeat_lpath x y xs a w:
        nfa_fin nfa_repeat (last x (y::xs)) ->
        nfa_run nfa_repeat x (y::xs) (a::w) ->
        nfa_run nfa_repeat x (rcons (belast y xs) (nfa_s A1)) (a::w).
      Proof. elim: xs x y a w => [|z xs IHxs] x y a [|b w] //=.
             rewrite 2!andbT.
             move => H0 /orP [|/andP [] /eqP].
             move => H1. rewrite/step_plus.
             apply/orP. right. rewrite eq_refl.
             apply/existsP. exists y. by rewrite H0 H1.
             move => H1 /existsP [] z /andP [] H2 H3. move: H1 H0 => -> H4.
             apply/orP. right. rewrite eq_refl /=.
             apply/existsP. exists z. by rewrite H2 H3.
               by rewrite andbF.
                 by rewrite andbF.
                 rewrite -(last_cons y). move => H0 /andP [] H1 /andP [] H3 H4.
                 rewrite H1 /=. apply: IHxs.
                   by rewrite H0.
                   simpl. by rewrite H3 H4.
      Qed.

      (** We prove that every word accepted by A1 in
   some state x is also accepted by nfa_repeat in
   that state. **)
      Lemma nfa_repeat_correct0' x w1 :
        nfa_accept A1 x w1 ->
        nfa_accept nfa_repeat x w1.
      Proof.
        move/nfa_run_accept => [] xs [].
        move/nfa_repeat_cont => H0 H1.
        apply/nfa_run_accept.
          by exists xs.
      Qed.

      (** We prove that every word accepted by A1 is also
   accepted by nfa_repeat. **)
      Lemma nfa_repeat_correct0 w :
        nfa_lang A1 w ->
        nfa_lang nfa_repeat w.
      Proof. exact: nfa_repeat_correct0'. Qed.

      (** We prove that every prefix accpeted by A1 followed
   by a suffix accepted by nfa_repeat is again accepted
   by nfa_repeat. This is the first part of the proof of
   language correctness for nfa_repeat. **)
      Lemma nfa_repeat_aux2 w1 w2:
        nfa_lang A1 w1 ->
        nfa_lang nfa_repeat w2 ->
        nfa_lang nfa_repeat (w1 ++ w2).
      Proof.
        move => /nfa_run_accept [] [|x xs] []; case: w1 => [|a w1] => //.
        move => H0 H1 H2.
        apply/(nfa_accept_cat).
        exists (rcons (belast x xs) (nfa_s A1)).
        apply/andP. split.
        apply: nfa_repeat_lpath.
        exact: H1.
        apply: nfa_repeat_cont.
        exact: H0.
        rewrite last_rcons.
        exact H2.
      Qed.

      (** We prove that every word accepted by some state x in nfa_repeat
   is a concatenation of two words w1, w2 which are accpeted by
   A1 in x and nfa_repeat (resp.). **)
      Lemma nfa_repeat_aux1' x w :
        nfa_accept nfa_repeat x w ->
        ((exists w1, exists w2, (w == w1 ++ w2) && (w1 != [::]) && (nfa_accept A1 x w1) && nfa_lang nfa_repeat w2
         ) \/ nfa_accept A1 x w ).
      Proof. elim: w x => [|a w IHw] x.
             move => H0. right.
             exact: H0.
             case/existsP => y /andP [H0 H1].
             case: (IHw _ H1) => [[w1 [w2 /andP [/andP [/andP [/eqP H2 H9] H3] H4]]]|H2].
             move: H0 => /orP [H5|].
             left. exists (a::w1). exists w2.
             rewrite H2 eq_refl H4 andbT /=.
             apply/existsP. exists y.
               by rewrite H5 H3.
               move/andP => [] H5 /existsP [] z /andP [H6 H7].
               move: H5 H1 H3 => /eqP -> H1 H3.
               left. exists ([::a]). exists w.
               rewrite eq_refl /=. apply/andP. split.
               apply/existsP. exists z. by rewrite H6 H7.
               exact: H1.
               move: H0 => /orP [H5|].
               right => /=. apply/existsP. exists y.
                 by rewrite H5 H2.
                 move/andP => [/eqP H3 /existsP [z /andP [H4 H5]]].
                 move: H3 H1 H2 => -> H1 H2.
                 left. exists [::a]. exists w.
                 rewrite eq_refl /=. apply/andP. split.
                 apply/existsP. exists z. by rewrite H5 H4.
                 exact H1.
      Qed.

      (** We prove the second part of language correctness
   for nfa_repeat. **)
      Lemma nfa_repeat_aux1 w:
        nfa_lang nfa_repeat w ->
        ((exists w1, exists w2, (w == w1 ++ w2) && (w1 != [::]) && (nfa_lang A1 w1) && nfa_lang nfa_repeat w2
         ) \/ nfa_lang A1 w ).
      Proof. exact: nfa_repeat_aux1'. Qed.

      (* Star operator *)
      Definition nfa_star := (dfa_disj dfa_eps (nfa_to_dfa nfa_repeat)).

      Lemma nfa_star_aux1 w: w \in dfa_lang nfa_star -> w \in star (nfa_lang A1).
      Proof.
        rewrite /nfa_star -dfa_disj_correct -topredE /=.
        rewrite dfa_eps_correct => /orP [].
        move => /eqP ->.
        apply/starP. by exists [::].
                               rewrite -nfa_to_dfa_correct.
                               move: w.
                               apply: (size_induction size).
                               move => w IHw.
                               move/nfa_repeat_aux1' => [].
                               move => [] w1 [] w2 [/andP [/andP [/andP [/eqP H1 H2] H3] H4]].
                               have H5: (size w2 < size w).
                               rewrite H1 size_cat addnC -{1}(addn0 (size w2)).
                               rewrite ltn_add2l.
                                 by destruct w1.
                                 move: (IHw w2 H5 H4) => /starP [] vv H6 H7.
                                 apply/starP. exists (w1::vv).
                                   by rewrite /= H6 -topredE /= /eps /= H2 /nfa_lang /= -topredE /= H3.
                                     by rewrite H1 H7.
                                     rewrite /nfa_lang /=.

                                     case: w IHw => [|a w] IHw H.
                                     apply/starP. by exists [::].
                                                            apply/starP.
                                                            exists [::(a::w)] => //=.
                                                              by rewrite -topredE andbT.
                                                                by rewrite cats0.
      Qed.

      Lemma nfa_star_aux2 w: w \in star (nfa_lang A1) -> w \in dfa_lang nfa_star.
      Proof.
        rewrite /nfa_star -dfa_disj_correct -2!topredE /= -nfa_to_dfa_correct.
        move/starP => [] vv. elim: vv w => [|v vv IHvv] w.
        rewrite /= => _ ->. move: (dfa_eps_correct [::]).
          by rewrite /dfa_lang /=.
          rewrite [all _ _]/=.
          move/andP => [] /andP [] H0 H1 H2 H3.
          rewrite H3 [flatten _]/=.
          move/orP: (IHvv (flatten vv) H2 (Logic.eq_refl _)) => [].
          rewrite dfa_eps_correct => /eqP H4.
          move: H3. rewrite [flatten _]/= H4 cats0.
          move => H5. subst. apply/orP. right.
          rewrite H4 in IHvv.
            by apply nfa_repeat_correct0.
            move => H4.
            apply/orP. right.
              by apply: nfa_repeat_aux2.
      Qed.

      Lemma nfa_star_correct: dfa_lang nfa_star =i star (nfa_lang A1).
      Proof.
        move => w.
        apply/idP/idP.
          by move/nfa_star_aux1.
            by move/nfa_star_aux2.
      Qed.

    End NFAOps.

  End FA.

End Automata.


(** * Book I: Definitions and Axioms *)

Module Euclid.

(** ** Definitions *)

(* We close the nat scope as we will want to use the addition operator for magnitudes. *)
Close Scope nat_scope.

(**** Coq Note
We move the notition of a magnitude to the start of this note.

A magnitude appears in the form of length and angle. It should be thought of as a positive unit with equality , comparison and summation relations but no units of measurement.*)

(** General Axioms
-1. Things which are equal to the same thing are equal to one another.
-2. If equals be added to equals, the wholes are equal.
-3. If equals be taken from equals the remainders are equal.
-4. If equals be added to unequals, the whole are unequal, the greater sum being that which includes the greater of the unequals.
-5. If equals be taken from unequals, the remainders are unequal, the greater remainder being that which is left from the greater of the unequals.
-6. Things which are doubles of the same thing, or of equal things, are equal to each other.
-7. Things which are halves of the same thing, or of equal things, are equal to each other.
The eighth axiom is geometric in nature and has thus been placed later
-9. The whole is greater than it's parts.
*)

Class Magnitude {M : Type} (add : M -> M -> M) (greaterThan : M -> M -> Prop): Type := {
  general_axiom_1 : forall x y z : M, x=y -> x=z -> y=z;
  general_axiom_2 : forall x1 x2 y1 y2 : M, x1=x2 -> y1=y2 -> (add x1 y1)=(add x2 y2);
  general_axiom_3 : forall x1 x2 y1 y2 : M, x1=x2 -> (add x1 y1)=(add x2 y2) -> y1=y2;
  general_axiom_4 : forall x1 x2 y1 y2 : M, x1=x2 -> y1<>y2 -> (add x1 y1)<>(add x2 y2);
  general_axiom_4_1 : forall x1 x2 y1 y2 : M, x1=x2 -> greaterThan y1 y2 -> greaterThan (add x1 y1) (add x2 y2);
  general_axiom_4_2 : forall x1 x2 y1 y2 : M, x1=x2 -> greaterThan y2 y1 -> greaterThan (add x2 y2) (add x1 y1);
  general_axiom_5 : forall x1 x2 y1 y2 : M, x1=x2 -> (add x1 y1)<>(add x2 y2) -> y1<>y2;
  general_axiom_5_1 : forall x1 x2 y1 y2 : M, x1=x2 -> greaterThan (add x1 y1) (add x2 y2) -> greaterThan y1 y2;
  general_axiom_5_2 : forall x1 x2 y1 y2 : M, x1=x2 -> greaterThan (add x2 y2) (add x1 y1) -> greaterThan y2 y1;
  general_axiom_6 : forall x y : M, x = y -> (add x x)=(add y y);
  general_axiom_7 : forall x y : M, (add x x)=(add y y) -> x=y;
  general_axiom_9 : forall x y : M, greaterThan (add x y) x;
}.

(**
-1. A [Point] is that which has position, but no [Magnitude]
*)
Definition Point : Type. Admitted.
(**
-2. A [Line] is that which has length without breadth
*)
Definition Line : Type. Admitted.

Definition lineLength : Line -> Magnitude. Admitted.
(**
-3. The [extremities] of a [Line] are [Point]s, and the [intersection] of two [Line]s is a [Point].
*)

Definition extremals : Line -> Point * Point. Admitted.
(* Helper funtion to see if a point is one of the extremals of a line. *)
Definition isExtremal (l : Line) (p : Point) : Prop :=
  match (extremals l) with
    | (p1, p2) => p1 = p /\ p2 = p
  end.

Definition intersection : Line -> Line -> Point -> Prop. Admitted.

(**
-4. A [StraightLine] is that which evenly between its extreme points. Any portion cut off from a straight line is called a segment of it.
*)
Definition straightLine (l : Line) : Prop. Admitted.

(* Set of helper types for a pair of line and proof of straightness *)
Inductive StraightLine : Type :=
  straightLineCons (l : Line) : straightLine l -> StraightLine.
Definition line (s : StraightLine) : Line :=
  match s with
    | straightLineCons l _ => l
  end.

Definition straightLineDeterminedByExtremals (p1 p2 q1 q2 : Point)
                                 (l1 l2 : Line) :
    straightLine l1 -> straightLine l2 ->
    extremals l1 = (p1,p2) -> extremals l2 = (q1,q2) ->
                              (p1 = q1) -> (p2 = q2) -> l1 = l2.
Admitted.

Definition segmentOf : StraightLine -> StraightLine -> Prop. Admitted.
(**
-5. A [Surface] (or superficies) is that which has length and breadth, but no thickness.
*)
Definition Surface : Type. Admitted.

(**
-6. The boundaries of a [Surface] are [Line]s.
*)
Definition surfaceBoundary : Surface -> list Line. Admitted.

(**
-7. A plane surface is one in which any [DistinctPoints] being taken the [Line] between them lies wholly in that [Surface]. A plane surface is frequently referred to as a [Plane].
*)
Definition pointOnSurface : Point -> Surface -> Prop. Admitted.
Definition lineOnSurface : Line -> Surface -> Prop. Admitted.

Definition planeSurface (s : Surface) : Prop :=
  forall (p1 p2 : Point) (l : Line),
    pointOnSurface p1 s -> pointOnSurface p2 s ->
    (p1 , p2) = extremals l -> straightLine l ->
    lineOnSurface l s.

(* Helper type for a pair of a surface and a proof that it is a plane *)
Inductive PlaneSurface : Type :=
  plane (s : Surface) : planeSurface s -> PlaneSurface.

(**
-8. A plane angle is the inclination of two [Line]s to each other which meet together, but are not in the same direction.
(Definition 8. is not required in Euclid's geometry the only angles employed by him being those formed by [StraightLine]s.
*)

(**
-9. A plane rectilinear angle is the inclination of two [StraightLine]s to one another, which meet together, but are not in the same [StraightLine].
The [Point] at which the [StraightLine] meet is called the [vertex] of the angle, and the [StraightLine]s themselves the [arms] of the [Angle].
*)

Definition colinear (l1 l2 : StraightLine) : Prop :=
  exists (l : StraightLine), (segmentOf l1 l) /\ (segmentOf l2 l).

Inductive Angle : Type :=
  angle (l1 l2 : StraightLine) (p : Point) :
       not (colinear l1 l2) -> isExtremal (line l1) p -> isExtremal (line l2) p -> Angle.

Definition vertex (a : Angle) : Point :=
  match a with
    angle _ _ p _ _ _ => p
  end.

Definition arms (a : Angle) : StraightLine * StraightLine :=
  match a with
    angle l1 l2 _ _ _ _ => (l1, l2)
  end.

(**** Note.
When there are several [Angle]s at one [Point] each is expressed by three letters, of which the letter that refers to the vertex is put between the other two.
Thus the angle contained by the [StraightLine]s OA, OB is named the angle AOB or BOA; and the angle contained by OA, OC is named the angle AOC or COA.
But if there is only one [Angle] at a [Point], it may be expressed by a single letter, as the angle at O.

Of the two [StraightLine]s OB, OC shewn in the adjoining diagram, we recognize that OC is more inclined than OB to the [StraightLine] OA : this we express by saying that the [Angle] AOC is greater thn the angle AOB.
Thus the [Angle] must be regarded as having a [Magnitude].
*)
Definition angleMagnitude : Angle -> Magnitude. Admitted.

(**
It must be carefully observed that the size of an angle in no way depends on the length of its arms, but only on their inclination to one another.
The angle AOC is the sum of the angles AOB and BOC; and AOB is the difference of the angles AOC and BOC.
*)

(* Add comment as to the formation of this definition *)
Definition angleSum (a1 a2 asum : Angle) : Prop :=
  match (arms a1, arms a2,arms asum) with
    | ((l1,l2), (l3,l4), (l5,l6)) => vertex a1 = vertex a2
                                     /\ vertex a1 = vertex asum
                                     /\ colinear l2 l3
                                     /\ colinear l1 l4
                                     /\ colinear l2 l5
  end.

(* Implicit assertation that the sum of angles goes to the sum of magnitudes *)
Definition angleSumToMagSum (a1 a2 asum : Angle) :
  angleSum a1 a2 asum ->
       (angleMagnitude a1 + angleMagnitude a2) = angleMagnitude asum.
Admitted.

(* Helper defintions for when [Angle]s are equal in magnitude *)
Definition equalAngleMagnitude (a1 a2 : Angle) : Prop :=
  angleMagnitude a1 = angleMagnitude a2.

Definition angleGreaterEqual (a1 a2 : Angle) : Prop :=
  ex (fun adiff => angleSum a1 adiff a2).

(* Helper defintions for when [Angle]s are greater than or equal in magnitude *)
Definition greaterEqualAngleMagnitude (a1 a2 : Angle) : Prop :=
  angleMagnitude a1 <= angleMagnitude a2.

(** ( Another view of an [Angle] is recognized in many branches of mathematics; and though not employed by Euclid, it is here given because it furnishes more clearly than any other a conception of what is meant by the [Magnitude] of an [Angle].
Suppose that the [StraightLine] OP in the diagram is capable of revolution about the [Point] O like the hands of a watch, but in the opposite direction; and suppose that in this way it has passed successively from the positions OA to the positions occupied by OB and OC. Such a [Line] must have undergone more turning in passing from OA to OC than in passing from OA to OB; and consequently the [Angle] AOC is said to be greater than the [Angle] AOB. )  *)

(**
[Angle]s which lie on either side of a common arm are called [adjacent] angles.
For example, when one [StraightLine] OC is drawn from a [Point] in another [StraightLine] AB, the angles COA, COB are adjacent.
*)

Definition adjancent (a1 a2 : Angle) : Prop :=
  ex (fun asum => angleSum a1 a2 asum).

(**
When two [StraightLine]s, such as AB, CD, cross one another at E the two [Angle]s CEA, BED are said to be vertically opposite.
The two [Angle]s CEB, AED are also vertically opposite to one another.
*)

(* Define a helper method wherre we make explicit the lines we assue exist*)
Definition verticallyOppositeLines' (a1 a2 : Angle) (lA lB : StraightLine) : Prop :=
  match (arms a1, arms a2) with
    | ((l1,l2),(l3,l4)) => vertex a1 = vertex a2
                        /\ segmentOf l1 lA
                        /\ segmentOf l2 lB
                        /\ segmentOf l3 lA
                        /\ segmentOf l4 lB
  end.

Definition verticallyOpposite (a1 a2 : Angle) : Prop :=
  ex (fun lA => ex (fun lB => verticallyOppositeLines' a1 a2 lA lB)).

(**
-10. When a [StraightLine] standing on another makes the [adjancent] [Angle]s equal to one another, each of the [Angle]s is called a [rightAngle]; and the [StraightLine] which stands on the other is called [perpendicular] to it.
*)

(* Define helper method which add extra lines which are assumed to exist *)
Definition perpendicularDiagram (lBase lStanding : StraightLine) (pMeeting : Point) : Prop :=
  intersection lBase lStanding pMeeting
  /\ isExtremal lStanding pMeeting
  /\ not (isExtremal lBase pMeeting)
  /\ not (colinear lBase lStanding)

(* To pove we can form an angle need to prove that

Definition rightAngle (a : Angle) : Prop :=
  ex (


Require Import Nat Arith.

Inductive Lst : Type := cons : nat -> Lst -> Lst |  nil : Lst.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Theorem theorem0 : forall (x : Lst), eq x (append x nil).
Proof.
   intros.
   induction x.
   - simpl. rewrite <- IHx. reflexivity.
   - simpl. reflexivity.
Qed.


(** * 6.822 Formal Reasoning About Programs, Spring 2020 - Pset 2 *)

(*
Author: Samuel Gruetter <gruetter@mit.edu>

This PSet will introduce you to one of the major applications of formal reasoning
about programs: proving that an optimized program behaves the same as a simple program.

Imagine you're writing a program which needs a some function F. You know how to implement
F naively, but as you run your program, you notice that it spends a lot of time in
the function F. You find a library which claims to provide a very efficient implementation
of F, but looking at its source code, you don't really understand why this code should
calculate F, and you've seen some bug reports against previous versions of the library,
so you can't really know whether this library implements F correctly.
Since you care a lot about writing a correct program, you finally decide to keep using
your naive slow implementation.
Formal reasoning about programs to the rescue! If the authors of the library want to
increase the user's trust in their library, they can include the naive but simple-to-
understand version of F in their library as well, and write a proof that for all possible
inputs, the optimized version of F returns the same value as the simple version of F.
If that proof is in a machine-checkable format (e.g. in a Coq file), the library users do
not need to understand the implementation of the optimized F, nor the body of the proof,
but can still use the optimized F and be sure that it does the same as the simple
implementation, as long as they trust the proof checker.

In this PSet, we will put you in the role of the library author who writes a naive
version of F, an optimized implementation of F, and a proof that the two of them behave
the same.
*)

Require Import Coq.NArith.NArith. Open Scope N_scope.
Require Import Coq.Lists.List. Import ListNotations.
Require Import Coq.micromega.Lia.
Require Import Frap.Frap.
Require Import Pset2Sig.
Set Default Goal Selector "!".

(* Each of the exercises below is worth some number of points.
   If you just want to enjoy the proof hacking without getting distracted by points,
   feel free to ignore these points. On the other hand, if you want to know how
   many points each exercise earns you, you can find the points in Pset2Sig.v. *)

(* Recursive functions *)
(* ******************* *)

(* We will need some recursive functions in this PSet. Defining recursive functions in Coq can be
   a bit tricky, because Coq only accepts recursive functions for which it believes that they always
   terminate.
   For natural numbers represented as "nat", and for data structures like the abstract syntax trees
   we saw in class, recursive functions can usually be defined using "Fixpoint", because each
   recursive call is with an argument which is a subterm of the original argument, which is required
   for Coq to be convinced that the recursive function terminates.
   In this pset, however, we will use the binary representation of natural numbers, which is
   called "N" in Coq. If we wanted to use a Fixpoint and call it with, e.g. the binary number
   11001101, we could only make recursive calls with 1001101.
   What we want in this Pset, however, is to make recursive calls with the one less than the argument,
   i.e. with 11001100 in this example.
   For this kind of recursion, which does not follow the structure of the data, we use the
   following pattern: *)

Definition fact: N -> N :=
  recurse by cases
  | 0 => 1
  | n + 1 => (n + 1) * recurse
  end.

(* This pattern can only define functions recursing over a natural number with base case 0, and
   one recursive case where the recursive call is for one less than the argument.
   The above function implements factorial, i.e. "fact n = 1 * 2 * ... * n".
   In the recursive case, you can use the word "recurse" to refer to the result of the recursive
   call. *)

(* Let's compute the first few values of fact: *)
Compute fact 0.
Compute fact 1.
Compute fact 2.
Compute fact 3.
Compute fact 4.

(* Aside: If you don't like the above Notation and want to see the real definition, you can do this:
Close Scope N_recursion_scope.
Print fact.
*)

(* Instead of writing "(fact x)" all the time, it's more convenient to just write "x!",
   so we make a Notation for this: *)
Local Notation "x !" := (fact x) (at level 12, format "x !").

(* Exercise: Define a simple exponentiation function in the same style,
   so that "exp base n" equals "base^n". *)

Definition exp(base: N): N -> N. Admitted.

(* Once you define "exp", you can replace "Admitted." below by "Proof. equality. Qed." *)
Lemma test_exp_2_3: exp 2 3 = 8. Admitted.
Lemma test_exp_3_2: exp 3 2 = 9. Admitted.
Lemma test_exp_4_1: exp 4 1 = 4. Admitted.
Lemma test_exp_5_0: exp 5 0 = 1. Admitted.
Lemma test_exp_1_3: exp 1 3 = 1. Admitted.

(* Here's another recursive function defined in the same style to apply a function f to
   a range of values:
   "seq f len start" computes the list [f start; f (start+1); ... f (start+len-1)] *)
Definition seq(f: N -> N): N -> N -> list N :=
  recurse by cases
  | 0 => fun start => []
  | n + 1 => fun start => f start :: recurse (start + 1)
  end.

Compute (seq (fun x => x * x) 4 10).

(* "ith i l" returns the i-th element of the list l.
   To understand the recursion, note that "ith i" returns a function which takes a list and,
   depending on whether i was 0 or not, returns the head of the list or the (i-1)-th element
   of the tail.
   If the index is out of bounds, it returns the default value 0. *)
Definition ith: N -> list N -> N :=
  recurse by cases
  | 0 => fun (l: list N) => match l with
                            | h :: t => h
                            | nil => 0
                            end
  | i + 1 => fun (l: list N) => match l with
                                | h :: t => recurse t
                                | nil => 0
                                end
  end.

(* The standard library already contains a function called "length": *)
Check length.
(* However, it returns a "nat", i.e., the representation of natural numbers using O and S,
   which is very inefficient: To represent the number n, it needs roughly c*n bytes of RAM,
   where c is some constant, whereas "N", the binary representation of natural numbers,
   only used c*log(n) bytes of RAM.
   Therefore, we redefine our own length function which returns an N: *)
Fixpoint len(l: list N): N :=
  match l with
  | [] => 0
  | h :: t => 1 + len t
  end.
(* Note that since the recursion follows the structure of the data (the list) here,
   we use Fixpoint instead of "recurse by cases". *)

(* Here's a simple lemma: If we tell "seq" to return a list of length "count", it indeed does: *)
Lemma seq_len: forall f count start, len (seq f count start) = count.
Proof.
  induct count; simplify.
  - (* base case: count = 0 *)
    equality.
  - (* recursive case: assuming the statement holds for some "count", show that it
       also holds for "count + 1".
       This goal contains "seq f (count + 1) start", so we know that we're in the
       recursive case of "seq", so we'd like to replace "seq f (count + 1) start"
       by the recursive case we wrote in its definition.
       Unfortunately, neither "unfold seq" nor "simplify" can do this, but the
       tactic "unfold_recurse F k", where F is the function in question, and k
       its argument, does the job: *)
    unfold_recurse (seq f) count.
    (* And here's a hint you'll need later: Sometimes, your goal won't exactly contain
       (seq f (count + 1) start), but maybe (seq f someOtherExpression start), but you
       still know that someOtherExpression is strictly greater than 0.
       In such cases, if you want to use "unfold_recurse", you first have to run

       replace someOtherExpression with (someOtherExpression - 1 + 1) by linear_arithmetic.

       Note that if someOtherExpression could be 0, this won't work, because subtraction
       on natural numbers in Coq returns 0 if the result is negative, so "0 - 1 + 1"
       equals 1 in Coq's natural numbers, and linear_arithmetic can't prove "0 = 1"
       for you! *)

    simplify. rewrite IHcount. linear_arithmetic.
Qed.

(* An here's another general hint: You don't always need induction.
   Some lemmas in this pset can be solved using induction, but don't actually require it,
   and are simpler to solve if you don't use induction, so before doing induction,
   try to think where/if you would need an inductive hypothesis. *)

(* Exercise: Prove that the i-th element of seq has the value we'd expect. *)
Lemma seq_spec: forall f count i start, i < count -> ith i (seq f count start) = f (start + i).
Proof.
  induct count; simplify.
Admitted.

(* Exercise: Prove that if the index is out of bounds, "ith" returns 0. *)
Lemma ith_out_of_bounds_0: forall i l, len l <= i -> ith i l = 0.
Proof.
Admitted.

(* Binomial coefficients *)
(* ********************* *)

(* You might remember binomial coefficients from you math classes, which appear in many combinatorics
   problems, and form the coefficients of the expansion of the polynomial (x + y)^n.
   In math notation, they are defined as follows:

      / n \        n!
      |   |  = ---------
      \ k /    (n-k)! k!

   We can transcribe this to Coq as follows: *)

Definition C(n k: N): N := n! / ((n - k)! * k!).

(* If we want to know how many ways there are to pick 2 items out of 4 items, we can compute this in Coq: *)
Compute C 4 2.

(* And here are the coefficients of the expansion of (x + y)^3: *)
Compute [C 3 0; C 3 1; C 3 2; C 3 3].

(* For larger numbers, however, this way of computing C becomes quite slow: If I do

Compute C 1000 100.

   it takes about 2 seconds on my computer. You can measure the time by putting "Time" in front of any command:

Time Compute C 1000 100.

   In the fraction defining C, there are many factors which appear both in the numerator and in the
   denominator, so it seems that we should be able to cancel these out and write a more efficient
   implementation of C. Here is one candidate: *)

Definition bcoeff(n: N): N -> N :=
  recurse by cases
  | 0 => 1
  | k + 1 => recurse * (n - k) / (k + 1)
  end.

(* Now if we do

Time Compute bcoeff 1000 100.

   it only takes about 0.02 seconds on my computer, so we got a 100x speed improvement, yay!
   But how do we know whether it's correct?
   We could do some quick tests: *)

Compute [bcoeff 3 0; bcoeff 3 1; bcoeff 3 2; bcoeff 3 3].

(* This test produces the same values as for C, but we want to be sure that bcoeff will *always* produce
   the same values as C, so let's prove it, i.e. let's show that

   forall n k, k <= n -> bcoeff n k = C n k

   We will do so further below, but we first need a few helper lemmas and techniques:

   Many arithmetic goals in this Pset are linear, i.e. we there are only multiplications by
   constants, but no multiplications of two variables.
   For these linear arithmetic goals, the linear_arithmetic tactic works just fine, but for
   some non-linear goals which will appear in this Pset, you can try the tactic "nia"
   (which stands for "non-linear integer arithmetic"), but it does not always work, so
   sometimes you will have to search for appropriate lemmas to apply manually.
   For instance, to prove the following: *)
Goal forall n m, n <> 0 -> m <> 0 -> n * m <> 0.
Proof.
  simplify.
  (* you could use the "Search" command with a pattern: *)
  Search (_ * _ <> 0).
  (* which outputs the name of a handy lemma we can apply: *)
  apply N.neq_mul_0.
  split; assumption.
  (* (note that in this case "nia" would have worked as well, but in any case, it's good to know
     the "Search" command. *)
Qed.

(* Here's another example of how to use the "Search" command:
   Suppose you have the goal *)
Goal forall n, n <> 0 -> n / n = 1.
Proof.
  simplify.
  (* If we do "Search (_ / _)" we get a very long list, but if we do *)
  Search (?x / ?x).
  (* we force the two numbers on both sides of the / to be the same, and we only get the lemma we need: *)
  apply N.div_same.
  assumption.
Qed.

(* Now we're ready to prove a few simple facts: *)

Lemma fact_nonzero: forall n, n! <> 0.
Proof.
Admitted.

Lemma Cn0: forall n, C n 0 = 1.
Proof.
Admitted.

Lemma Cnn: forall n, C n n = 1.
Proof.
Admitted.

(* It's somewhat surprising that in the definition of C(n, k),

      n!
  -----------
  (n - k)! k!

  the denominator always divides the numerator.
  The following lemma proves it. Note that "(a | b)" means "a divides b".
  We provide the solution for you, so that you can step through it and use it as a
  source of useful strategies you can apply in the exercises below.
  Make sure to step through it and to understand each proof step! *)
Lemma C_is_integer: forall n k, k <= n ->
    (((n - k)! * k!) | n!).
Proof.
  induct n.
  - simplify.
    replace k with 0 by linear_arithmetic.
    simplify.
(* How can we prove that 1 divides 1? Probably it follows immediately from the definition of
   divisibility, so let's try to unfold it:

    unfold "|".

   Unfortunately that fails (reported at https://github.com/coq/coq/issues/11420), but we can do

    Locate "|".

   The output of this command shows us all notations involving "|", and the last one (N.divide) is the one
   we want. So we just unfold that one: *)
    unfold N.divide.
    exists 1. equality.
  - simplify. unfold N.divide in *.
    assert (k = 0 \/ k = n + 1 \/ 1 <= k <= n) as C by linear_arithmetic. cases C.
    + subst.
      replace (n + 1 - 0) with (n + 1) by linear_arithmetic.
      replace (0!) with 1 by equality.
      exists 1.
      linear_arithmetic.
    + subst.
      replace (n + 1 - (n + 1)) with 0 by linear_arithmetic.
      replace (0!) with 1 by equality.
      exists 1. linear_arithmetic.
    + pose proof (IHn k) as IH1.
      assert (k <= n) as A by linear_arithmetic. specialize (IH1 A). invert IH1.
      pose proof (IHn (k - 1)) as IH2.
      assert (k - 1 <= n) as B by linear_arithmetic. specialize (IH2 B). invert IH2.
      replace (n - (k - 1)) with (n - k + 1) in H1 by linear_arithmetic.
      unfold_recurse fact n.
      replace (k!) with ((k - 1 + 1)!) in *.
      2: { f_equal. linear_arithmetic. }
      unfold_recurse fact (k - 1).
      replace (k - 1 + 1) with k in * by linear_arithmetic.
      apply N.mul_cancel_r with (p := n - k + 1) in H0. 2: linear_arithmetic.
      apply N.mul_cancel_r with (p := k) in H1. 2: linear_arithmetic.
      assert (forall l1 r1 l2 r2, l1 = r1 -> l2 = r2 -> l1 + l2 = r1 + r2) as E. {
        simplify. linear_arithmetic.
      }
      specialize E with (1 := H0) (2 := H1).
      replace (n! * (n - k + 1) + n! * k) with ((n + 1) * n!) in E by nia.
      rewrite E.
      replace (n + 1 - k) with (n - k + 1) by linear_arithmetic.
      unfold_recurse fact (n - k).
      remember ((n - k)!) as F1.
      remember ((k - 1)!) as F2.
      remember (n - k + 1) as F3.
      remember k as F4.
      exists (x + x0).
      nia.
Qed.

(* Now we're ready to prove correctness of our optimized implementation bcoeff.
   Since this is not a class about math, we're providing a paper proof of each proof step
   of the inductive case:

  C(n, k + 1)

             n!
= -----------------------
  (n - (k + 1))! (k + 1)!

             n!
= -----------------------
  (n - k - 1)! k! (k + 1)

         n! (n - k)
= -------------------------------
  (n - k - 1)! (n - k) k! (k + 1)

               n! (n - k)
= ---------------------------------------
  (n - k - 1)! (n - k - 1 + 1) k! (k + 1)

          n! (n - k)
= ---------------------------
  (n - k - 1 + 1)! k! (k + 1)

      n! (n - k)
= -------------------
  (n - k)! k! (k + 1)

  n! (n - k)
= ----------- / (k + 1)
  (n - k)! k!

      n!
= ----------- * (n - k) / (k + 1)
  (n - k)! k!

= C(n, k) * (n - k) / (k + 1)

= bcoeff(n, k) * (n - k) / (k + 1)

= bcoeff(n, k + 1)

Your task is to translate this proof into Coq!

Potentially useful hint:
Note that multiplication and division have the same operator priority, and both are left-associative, so
   "a / b * c / d" is "((a / b) * c) / d", NOT "(a / b) * (c / d)"

Here we go: *)
Lemma bcoeff_correct: forall n k, k <= n -> bcoeff n k = C n k.
Proof.
  induct k.
Admitted.

(* All binomial coefficients for a given n *)
(* *************************************** *)

(* In some applications, we need to know all binomal coefficients C(n,k) for a fixed n.
   For instance, if we want to symbolically evaluate (x + y)^4, the result is

   C(4,0)*x^4 + C(4,1)*x^3*y + C(4,2)*x^2*y^2 + C(4,3)*x*y^3 + C(4,4)*y^4

   The simplest way to compute such lists would be to just use the C we defined above: *)

Definition all_coeffs_slow1(n: N): list N :=
  (recurse by cases
   | 0 => [1]
   | k + 1 => C n (k + 1) :: recurse
   end) n.

Compute all_coeffs_slow1 0.
Compute all_coeffs_slow1 1.
Compute all_coeffs_slow1 2.
Compute all_coeffs_slow1 3.
Compute all_coeffs_slow1 4.
Compute all_coeffs_slow1 5.
Compute all_coeffs_slow1 15.
(* However, this is not very efficient:

Time Compute all_coeffs_slow1 100.

takes 0.8s on my machine *)

(* We could use our more efficient bcoeff from above: *)
Definition all_coeffs_slow2(n: N): list N :=
  (recurse by cases
   | 0 => [1]
   | k + 1 => bcoeff n (k + 1) :: recurse
   end) n.

Compute all_coeffs_slow2 5.
Compute all_coeffs_slow2 15.
(* This is faster:

   Time Compute all_coeffs_slow2 100.

takes 0.2s on my machine and

  Time Compute all_coeffs_slow2 200.

takes 1.7 s on my machine.

But we can do even better by using Pascal's triangle:

      1
     1 1
    1 2 1
   1 3 3 1
  1 4 6 4 1

You can observe that the i-th row of this triangle is the result of "all_coeffs_slow1 i",
and that each value not at the boundary of the triangle is the sum of the values to
its upper left and its upper right. For instance, the 6 in the last row is the sum of the
two 3s above it.
More formally, we can state this as follows: *)
Definition Pascal's_rule: Prop := forall n k,
    1 <= k <= n ->
    C (n+1) k = C n (k - 1) + C n k.
(* Note that the above is only a definition which gives a name to this proposition,
   but not a lemma.
   We don't ask you to prove it, but it's a fun optional exercise, have a look at the
   end of this file if you're interested! *)

(* The following function takes in a line of Pascal's triangle and computes the line below it: *)
Definition nextLine(l: list N): list N :=
  1 :: seq (fun k => ith (k - 1) l + ith k l) (len l) 1.

Compute nextLine [1; 3; 3; 1].
Compute nextLine (nextLine [1; 3; 3; 1]).

(* This allows us to define a faster all_coeffs function: *)
Definition all_coeffs_fast: N -> list N :=
  recurse by cases
  | 0 => [1]
  | n + 1 => nextLine recurse
  end.

(* Time Compute all_coeffs_fast 200. takes 0.35s on my computer *)

(* Exercise: Let's prove that all_coeffs_fast is correct.
   Note that you can assume Pascal's rule to prove this. *)
Lemma all_coeffs_fast_correct:
  Pascal's_rule ->
  forall n k,
    k <= n ->
    ith k (all_coeffs_fast n) = C n k.
Proof.
Admitted.

(* ----- THIS IS THE END OF PSET2 ----- All exercises below this line are optional. *)

(* Optional exercise: Let's prove that Pascal's rule holds.
   On paper, this can be proved as follows, but feel free to ignore this if you want
   the full challenge!

   C(n, k-1) + C(n, k)

           n!                 n!
= --------------------- + -----------
  (n - k + 1)! (k - 1)!   (n - k)! k!

              n!                          n!
= ----------------------------- + -------------------
  (n - k)! (n - k + 1) (k - 1)!   (n - k)! k (k - 1)!

               n! k                          n! (n - k + 1)
= ------------------------------- + -------------------------------
  (n - k)! (n - k + 1) (k - 1)! k   (n - k)! k (k - 1)! (n - k + 1)

         n! (k + n - k + 1)
= -------------------------------
  (n - k)! (n - k + 1) (k - 1)! k

    (n + 1)!
= ---------------
  (n - k + 1)! k!

= C(n+1, k)
*)
Lemma Pascal's_rule_holds: Pascal's_rule.
Proof.
  unfold Pascal's_rule.

  (* Note: Proving
       a     b     a+b
      --- + --- =  ---
       c     c      c
     is a bit trickier than you might expect, because we're using integer division here.
     So, for instance,
      1     3                                                              1+3
     --- + ---   equals 0 + 1 in round-down integer division, which is not ---
      2     2                                                               2
     To make sure this rule holds, we must also require that c and b both divide a: *)
  assert (forall a b c, c <> 0 -> (c | a) -> (c | b) -> a / c + b / c = (a + b) / c)
    as add_fractions. {
    clear.
    simplify.
    unfold N.divide in *. invert H0. invert H1.
    rewrite N.div_mul by assumption.
    rewrite N.div_mul by assumption.
    replace (x * c + x0 * c) with ((x + x0) * c) by nia.
    rewrite N.div_mul by assumption.
    reflexivity.
  }

Admitted.

(* Optional exercise:
   all_coeffs_fast is still not as fast as it could be, because nextLine uses ith
   to access the elements of the previous line, and each invocation of ith takes
   linear time in i.
   It would be more efficient to implement nextLine as a recursive function
   which iterates through the previous line just once and computes the next line
   on the fly.
   Define such a nextLine' function, and then use it to define all_coeffs_faster,
   observe how it's even faster than all_coeffs_fast, and finally, prove that
   it's correct. *)

Definition nextLine'(l: list N): list N. Admitted.

Definition all_coeffs_faster: N -> list N. Admitted.

Lemma all_coeffs_faster_correct: forall n k,
    k <= n ->
    ith k (all_coeffs_faster n) = C n k.
Proof.
Admitted.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(**********************************************************************
    Proth.v

    Proth's Test

    Definition: ProthTest
 **********************************************************************)
Require Import ZArith.
Require Import ZCAux.
Require Import Pocklington.

Open Scope Z_scope.

Theorem ProthTest: forall h k a, let n := h * 2 ^ k + 1 in 1 < a -> 0 < h < 2 ^k -> (a ^ ((n - 1) / 2) + 1) mod n = 0 -> prime n.
intros h k a n; unfold n; intros H H1 H2.
assert (Hu: 0 < h * 2 ^ k).
apply Zmult_lt_O_compat; auto with zarith.
assert (Hu1: 0 < k).
case (Zle_or_lt k 0); intros Hv; auto.
generalize H1 Hv; case k; simpl.
intros (Hv1, Hv2); contradict Hv2; auto with zarith.
intros p1 _ Hv1; contradict Hv1; auto with zarith.
intros   p (Hv1, Hv2); contradict Hv2; auto with zarith.
apply PocklingtonCorollary1 with (F1 := 2 ^ k) (R1 := h). 1-2: auto with zarith.
ring.
apply Z.lt_le_trans with ((h + 1) * 2 ^ k). 2: auto with zarith.
rewrite Zmult_plus_distr_l; apply Zplus_lt_compat_l.
rewrite Zmult_1_l; apply Z.lt_le_trans with 2; auto with zarith.
intros p H3 H4.
generalize H2; replace (h * 2 ^ k + 1 - 1) with (h * 2 ^k) by auto with zarith; clear H2; intros H2.
exists a; split; auto; split.
pattern (h * 2 ^k) at 1; rewrite (Zdivide_Zdiv_eq  2 (h * 2 ^ k)). 2: auto with zarith.
rewrite (Zmult_comm 2); rewrite Zpower_mult. 3: auto with zarith.
rewrite Zpower_mod by auto with zarith.
assert (tmp: forall p, p = (p + 1) -1) by auto with zarith; rewrite (fun x => (tmp (a ^ x))).
rewrite Zminus_mod by auto with zarith.
rewrite H2.
rewrite (Zmod_small 1) by auto with zarith.
rewrite <- Zpower_mod by auto with zarith.
rewrite Zmod_small. auto with zarith.
simpl; unfold Zpower_pos; simpl; auto with zarith.
apply Z_div_pos; auto with zarith.
apply Z.divide_trans with (2 ^ k).
apply Zpower_divide; auto with zarith.
apply Zdivide_factor_l; auto with zarith.
apply Zis_gcd_gcd. auto with zarith.
apply Zis_gcd_intro. 1-2: auto with zarith.
intros x HD1 HD2.
assert (Hd1: p = 2).
apply prime_div_Zpower_prime with (4 := H4). 1-2: auto with zarith.
apply prime_2.
assert (Hd2: (x | 2)).
replace 2 with ((a ^ (h * 2 ^ k / 2) + 1) - (a ^ (h * 2 ^ k/ 2) - 1)) by auto with zarith.
apply Zdivide_minus_l; auto.
apply Z.divide_trans with (1 := HD2).
apply Zmod_divide; auto with zarith.
pattern 2 at 2; rewrite <- Hd1; auto.
replace 1 with ((h * 2 ^k + 1) - (h * 2 ^ k)) by auto with zarith.
apply Zdivide_minus_l; auto.
apply Z.divide_trans with (1 := Hd2); auto.
apply Z.divide_trans with (2 ^ k).
apply Zpower_divide; auto with zarith.
apply Zdivide_factor_l; auto with zarith.
Qed.

Definition proth_test h k a :=
  let n := h * 2 ^ k + 1 in
   if (Z_lt_dec 1  a) then
      if (Z_lt_dec 0 h) then
        if (Z_lt_dec h (2 ^k)) then
            if Z.eq_dec (Zpow_mod a  ((n - 1) / 2) n) (n - 1) then true
            else false else false else false else false.

Theorem ProthTestOp: forall h k a, proth_test h k a = true -> prime (h * 2 ^ k + 1).
intros h k a; unfold proth_test.
repeat match goal with |- context[if ?X then _ else _] => case X end; try (intros; discriminate).
intros H1 H2 H3 H4 _.
assert (Hu: 0 < h * 2 ^ k).
apply Zmult_lt_O_compat; auto with zarith.
apply ProthTest with (a := a); auto.
rewrite Zplus_mod; auto with zarith.
rewrite <- Zpow_mod_Zpower_correct; auto with zarith.
rewrite H1.
rewrite (Zmod_small 1); auto with zarith.
replace (h * 2 ^ k + 1 - 1 + 1) with (h * 2 ^ k + 1); auto with zarith.
apply Zdivide_mod; auto with zarith.
apply Z_div_pos; auto with zarith.
Qed.

Theorem prime5: prime 5.
exact (ProthTestOp 1 2 2 (refl_equal _)).
Qed.

Theorem prime17: prime 17.
exact (ProthTestOp 1 4 3 (refl_equal _)).
Qed.

Theorem prime257:  prime 257.
exact (ProthTestOp 1 8 3 (refl_equal _)).
Qed.

Theorem prime65537:  prime 65537.
exact (ProthTestOp 1 16 3 (refl_equal _)).
Qed.

(* Too tough !!
Theorem prime4294967297:  prime 4294967297.
exact (ProthTestOp 1 32 3 (refl_equal _)).
Qed.
*)


Require Import XR_R.
Require Import XR_Rsqr.
Require Import XR_Rminus.
Require Import XR_Rmult_comm.
Require Import XR_Rsqr_minus_plus.

Local Open Scope R_scope.

Lemma Rsqr_plus_minus : forall a b:R, (a + b) * (a - b) = Rsqr a - Rsqr b.
Proof.
  intros x y.
  rewrite Rmult_comm.
  apply Rsqr_minus_plus.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (lf2 : natural) (lf1 : natural) : natural :=
  plus lf1 Zero.


From mathcomp Require Import all_ssreflect all_algebra.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import intZmod.
Import intOrdered.
Import GRing.Theory.
Open Scope ring_scope.

Section Reversible.
  Definition enc1 (m n:int) := m - n.
  Definition enc2 (m n:int) := ((m + n) %/ 2)%Z.

  Definition dec1 (e1: int) (e2: int) := ((e1 + e2 * 2 + 1) %/2)%Z.
  Definition dec2 (e1: int) (e2: int) := dec1 e1 e2 - e1.

  Lemma addmn (m n:int) : (m + (- n) + m + n) = m * (2:int).
  Proof.
    rewrite addrC.
    rewrite [m + (-n) + m]addrC.
    rewrite [m + (m + (-n))]addrA.
    rewrite [m + m + (-n)]addrC addrA.
    rewrite addrN add0r.
    rewrite -{1}[m]mulr1.
    rewrite -{2}[m]mulr1.
    rewrite -mulrDr //=.
  Qed.

  Lemma divmn (d:int) : d - (d %% 2)%Z = (d %/ 2)%Z * 2.
  Proof.
    apply/subr0_eq.
    rewrite -opprB.
    rewrite [-(d - (d %% 2)%Z)]opprB addrA.
    rewrite -divz_eq //=.
    rewrite opprB.
    rewrite addrN //.
  Qed.

  Lemma lezrl (n m:int): lez n m = (n <= m).
  Proof.
    rewrite /lez //=.
  Qed.

  Lemma ltzrl (n m:int): ltz n m = (n < m).
  Proof.
    rewrite /ltz //=.
  Qed.

  Lemma lt_d_1 (d:int) : (d %% 2)%Z <= 1 .
  Proof.
    have lt_2 : (d %% 2)%Z < `|Posz 2| .
    - rewrite ltz_mod //.
    have eq_2 : `|Posz 2| = Posz 2.
    - by [].
    have eq_21 : (d %% 2)%Z < 2 .
    - rewrite -{2}eq_2 lt_2 //
    rewrite ltz_mod //.
    rewrite -ltz_add1r //.
  Qed.

  Lemma modDiv0 (d:int) : ((1 - (d %% 2)%Z) %/ 2)%Z = 0%Z.
  Proof.
    rewrite divz_small //.
    (* 0 <= 1 - (d %% 2)%Z < `|2|%N *)
    rewrite -lezrl subz_ge0 lezrl lt_d_1 /=.
    rewrite -lez_add1r addrA.
    rewrite -lezrl -subz_ge0 lezrl.
    have eq_2 : 1 + 1 = (2:int).
    - by [].
    have eq0_2 : (2:int) + (-(2:int)) = 0.
    - by [].
    rewrite addrC opprB /=.
    rewrite eq_2.
    rewrite [(d %% 2)%Z + (-(2:int))]addrC addrC addrA eq0_2.
    rewrite add0r.
    rewrite modz_ge0 //.
  Qed.

  Theorem dec1_correct (m n :int): dec1 (enc1 m n) (enc2 m n) = m.
  Proof.
    rewrite /dec1 /enc1 /enc2.
    rewrite -divmn.
    rewrite !addrA.
    rewrite [m - n + m + n]addmn.
    have divrMDl2 (m0: int): ((m * (Posz 2) + m0) %/ (Posz 2))%Z = m + (m0 %/ (Posz 2))%Z.
    - rewrite divzMDl //.
    rewrite {1}addrC !addrA.
    rewrite [1 + m * 2]addrC.
    set mn := - ((m + n) %% 2)%Z.
    rewrite -/mn.
    set mn1 := 1 + mn.
    rewrite addrC addrA.
    rewrite addrC addrA.
    rewrite -/mn1.
    rewrite addrC.
    rewrite divrMDl2.
    rewrite /mn1 /mn modDiv0.
    rewrite addr0 //.
  Qed.

  Theorem dec2_correct (m n :int): dec2 (enc1 m n) (enc2 m n) = n.
  Proof.
    rewrite /dec2.
    rewrite dec1_correct /enc1.
    rewrite [-(m - n)]opprB addrA.
    rewrite addrC addrA addNr add0r //.
  Qed.
End Reversible.