Require Import Coq.Arith.Arith.
Require Import bedrock2.Map.SeparationLogic.
Require Import bedrock2.ptsto_bytes.
Require Import coqutil.Decidable.
Require Import coqutil.Word.Properties.
Require Import compiler.ExprImp.
Require Import compiler.NameGen.
Require Import coqutil.Tactics.Simp.
Require Import bedrock2.MetricLogging.
Require Import riscv.Platform.MinimalLogging.
Require Import riscv.Platform.MetricMinimal.
Require Import riscv.Platform.MetricLogging.
Require Import riscv.Utility.Utility.
Require Import riscv.Utility.Encode.
Require Import coqutil.Map.SortedList.
Require Import compiler.ZNameGen.
Require Import riscv.Utility.InstructionCoercions.
Require Import riscv.Platform.MetricRiscvMachine.
Require Import compiler.GoFlatToRiscv.
Require Import compiler.FlatToRiscvCommon.
Require Import compiler.SeparationLogic.
Require Import bedrock2Examples.Demos.
Import Utility.

Section FibCompiled.

  Definition fib_ExprImp nl ns: cmd := Eval cbv in
    snd (snd (Demos.fibonacciServer nl ns)).

  Notation RiscvMachine := MetricRiscvMachine.

  Fixpoint fib (n: nat): Z :=
    match n with
    | O => 0
    | S x =>
      match x with
      | O => 1
      | S y => (fib x + fib y)
      end
    end.

  Definition fib_bounded (n: nat): Z :=
    if (n <? 47)%nat then fib (n + 1) else -1.

  Lemma fib_invert: forall n,
      fib (S (S n)) = fib n + fib (S n).
  Proof.
    induction n.
    - reflexivity.
    - simpl. destruct n.
      + reflexivity.
      + blia.
  Qed.

  Lemma fib_pos: forall n,
      0 <= fib n.
  Proof.
    cut (forall N n, (n < N)%nat -> 0 <= fib n).
    - eauto.
    - induction N.
      + intros. exfalso. apply Nat.nlt_0_r in H. exact H.
      + intros.
        destruct n; [simpl; blia|].
        destruct n; [simpl; blia|].
        rewrite fib_invert.
        generalize (IHN n) (IHN (S n)).
        blia.
  Qed.

  Lemma fib_inc: forall n m,
      (n <= m)%nat ->
      fib n <= fib m.
  Proof.
   induction 1.
   - apply Z.le_refl.
   - apply Z.le_trans with (fib m); [assumption|].
     destruct m.
     + simpl. blia.
     + rewrite fib_invert.
       pose proof (fib_pos m).
       blia.
  Qed.

  Ltac fib_next :=
    match goal with
    | H0: fib ?n0 = ?r0, H1: fib ?n1 = ?r1 |- _ =>
      let Ht := fresh "Ht" in
      let H := fresh "H" in
      assert (n1 = n0 + 1)%nat as Ht by reflexivity; clear Ht;
      assert (fib (S n1) = fib n0 + fib n1) as H by (rewrite fib_invert; reflexivity);
      rewrite H0 in H; rewrite H1 in H;
      match goal with
      | H: fib _ = ?x |- _ =>
        let r := fresh "r" in
        remember x as r;
        match goal with
        | Heqr: ?l = _ + _ |- _ => cbv in Heqr; subst r
        end
      end;
      clear H0
    end.

  Lemma fib_width_limit: forall n,
      (n < 48)%nat ->
      fib n < 2 ^ 32.
  Proof.
    intros.
    assert (fib 0 = 0) by reflexivity.
    assert (fib 1 = 1) by reflexivity.
    do 46 fib_next.
    assert (fib 47 < 2 ^ 32) by (rewrite H2; reflexivity).
    intros.
    induction n.
    - simpl. reflexivity.
    - pose proof (fib_inc (S n) 47%nat) as Hinc.
      apply Nat.lt_le_pred in H.
      simpl in H.
      specialize (Hinc H).
      blia.
  Qed.

  Local Notation instructionsH := (bedrock2.MetricLogging.instructions).

  (*
  Lemma load_word_sep: forall k (m: mem) v R,
      ((ptsto_word k v) * R)%sep m ->
      load access_size.four m k = Some v.
  Proof.
    intros.
    pose proof load_bytes_of_sep as Hload.
    specialize Hload with (1 := H).
    cbv [load load_Z].
    match goal with
    | H: ?y = ?v |- context[?x] =>
      match y with
      | bedrock2.Memory.load_bytes _ _ _ =>
        match x with
        | bedrock2.Memory.load_bytes _ _ _ => change x with y; rewrite H
        end
      end
    end.
    simpl. f_equal.
    rewrite LittleEndian.combine_split.
    change (BinInt.Z.of_nat (Pos.to_nat 4) * 8) with width.
    change width with 32.
    rewrite (Naive._unsigned_in_range v).
    rewrite (Naive.of_Z_unsigned).
    reflexivity.
  Qed.

  Lemma word_add_of_Z: forall width a b c,
      c < 2 ^ width ->
      0 <= a ->
      0 <= b ->
      a + b = c ->
      @word.add width _ (word.of_Z a) (word.of_Z b) = word.of_Z (c).
  Proof.
    intros.
    simpl.
    f_equal.
    repeat (rewrite Z.mod_small; [|blia]).
    assumption.
  Qed.
*)

  Fixpoint get_if s :=
    match s with
    | cmd.seq s1 s2 =>
      match s1 with
      | cmd.cond _ _ _ => s1
      | _ => get_if s2
      end
    | _ => s
    end.

  Definition fib_if ns nl := get_if (fib_ExprImp ns nl).

  Definition fib_while ns nl := Eval cbv in
        match fib_if ns nl with
        | cmd.cond _ w _ => w
        | _ => fib_if ns nl
        end.

  Definition fib_while_body ns nl := Eval cbv in
        match fib_while ns nl with
        | cmd.while _ b => b
        | _ => fib_while ns nl
        end.

  Ltac destruct_hyp :=
    repeat match goal with
           | H : _ /\ _ |- _ => destruct H
           end.

(*
  Ltac eval_fib_var_names :=
    cbv [FibonacciServer.a
           FibonacciServer.b
           Demos.FibonacciServer.c
           Demos.FibonacciServer.i
           Demos.FibonacciServer.n
           Demos.FibonacciServer.ZNames.Inst] in *.

  Ltac known_var :=
    match goal with
    | H: map.get ?l ?a = ?x |- context [?y] =>
      match x with
      | Some ?v =>
        match y with
        | map.get l a =>
          let Hp := fresh "Hp" in
          assert (y = x) as Hp by assumption;
          rewrite Hp; clear Hp
        end
      end
    end.

  Ltac fib_step_precondition :=
    match goal with
    | |- map.get (map.put _ _ _) _ = Some _ =>
      rewrite map.get_put_diff; [assumption|discriminate] || apply map.get_put_same
    | |- _ => assumption || simpl; blia
    end.

  Ltac eval_var_solve :=
    unfold eval_expr;
    eval_fib_var_names;
    repeat known_var;
    reflexivity.

  Ltac exec_set_solve :=
    intros; destruct_hyp;
    eapply @exec.set;
    [
      eval_var_solve |
      try (repeat split; fib_step_precondition)
    ].

  Ltac propogate_eq :=
    repeat match goal with
           | H0: ?x = ?y, H1: ?y = ?z |- _ => rewrite H1 in H0
           end; assumption.

  Lemma fib_correct_body: forall t m (l : locals) mc a b i n (R: mem -> Prop) ns nl,
      R m ->
      map.get l FibonacciServer.a = Some a ->
      map.get l FibonacciServer.b = Some b ->
      map.get l FibonacciServer.i = Some i ->
      map.get l FibonacciServer.n = Some n ->
      exec map.empty (fib_while_body ns nl) t m l mc (fun t' m' l' mc' =>
        t' = t /\
        R m' /\
        map.get l' FibonacciServer.a = Some b /\
        map.get l' FibonacciServer.b = Some (word.add a b) /\
        map.get l' FibonacciServer.i = Some (word.add i (word.of_Z 1)) /\
        map.get l' FibonacciServer.n = Some n /\
        instructionsH mc' - instructionsH mc = 21).
  Proof.
    intros.
    cbv [fib_while_body].
    eapply @exec.seq with (mid := (fun t' m' l' mc' =>
      t' = t /\
      R m' /\
      map.get l' FibonacciServer.a = Some a /\
      map.get l' FibonacciServer.b = Some b /\
      map.get l' FibonacciServer.c = Some (word.add a b) /\
      map.get l' FibonacciServer.i = Some i /\
      map.get l' FibonacciServer.n = Some n /\
      instructionsH mc' = instructionsH mc + 5));
      [exec_set_solve|].
    intros.

    eapply @exec.seq with (mid := (fun t' m' (l': locals) mc' =>
      t' = t /\
      R m' /\
      map.get l' (@FibonacciServer.a Basic32Syntax _) = Some b /\
      map.get l' (@FibonacciServer.b Basic32Syntax _)  = Some b /\
      map.get l' (@FibonacciServer.c Basic32Syntax _)  = Some (word.add a b) /\
      map.get l' (@FibonacciServer.i Basic32Syntax _)  = Some i /\
      map.get l' (@FibonacciServer.n Basic32Syntax _)  = Some n /\
      instructionsH mc' = instructionsH mc + 7));
      [exec_set_solve|].
    intros.
    eapply @exec.seq with (mid := (fun t' m' l' mc' =>
      t' = t /\
      R m' /\
      map.get l' FibonacciServer.a = Some b /\
      map.get l' FibonacciServer.b = Some (word.add a b) /\
      map.get l' FibonacciServer.c = Some (word.add a b) /\
      map.get l' FibonacciServer.i = Some i /\
      map.get l' FibonacciServer.n = Some n /\
      instructionsH mc' = instructionsH mc + 9));
      exec_set_solve.
  Qed.

  Lemma fib_correct_while: forall n (iter : nat) t m (l : locals) mc i (R: mem -> Prop) nl ns,
      Z.of_nat n < 47 ->
      (iter <= n)%nat ->
      (i = n - iter)%nat ->
      R m ->
      map.get l FibonacciServer.a = Some (word.of_Z (fib i)) ->
      map.get l FibonacciServer.b = Some (word.of_Z (fib (S i))) ->
      map.get l FibonacciServer.n = Some (word.of_Z (Z.of_nat n)) ->
      map.get l FibonacciServer.i = Some (word.of_Z (Z.of_nat i) : word) ->
      exec map.empty (fib_while nl ns) t m l mc (fun t' m' l' mc' =>
        t' = t /\
        R m' /\
        instructionsH mc' <= instructionsH mc + (Z.of_nat iter) * 34 + 12 /\
        map.get l' FibonacciServer.b = Some (word.of_Z (fib (n + 1)))).
  Proof.
    induction iter.
    - intros.
      eapply @exec.while_false.
      + eval_var_solve.
      + simpl. destruct_one_match.
        * rewrite H1 in E. rewrite Nat.sub_0_r in E.
          apply Z.lt_irrefl in E.
          exfalso. assumption.
        * reflexivity.
      + repeat split.
        * assumption.
        * simpl. blia.
        * replace n with i by blia.
          rewrite Nat.add_1_r.
          etransitivity; [ eassumption | reflexivity ].
    - intros.
      eapply @exec.while_true.
      + eval_var_solve.
      + simpl. destruct_one_match.
        * simpl. rewrite Zdiv.Zmod_1_l; [discriminate | cbv; reflexivity].
        * repeat match goal with
                 | H: context[_ mod _] |- _ => rewrite Z.mod_small in H; [|blia]
                 end.
          blia.
      + eapply fib_correct_body with (nl := nl) (ns := ns); eauto.
      + intros.
        eval_fib_var_names.
        destruct_hyp.
        eapply weaken_exec.
        * eapply IHiter with (nl := nl) (ns := ns); try (reflexivity || eassumption).
          -- blia.
          -- etransitivity; [eassumption|].
             f_equal. f_equal. f_equal. blia.
          -- etransitivity; [eassumption|].
             f_equal. replace (S i) with (n - iter)%nat by blia. rewrite H1.
             assert (n - iter > 0)%nat by blia.
             pose proof fib_invert as Hfib.
             specialize Hfib with (n := (n - S iter)%nat).
             apply word_add_of_Z; try apply fib_pos.
             ++ change Semantics.width with 32.
                apply fib_width_limit.
                blia.
             ++ replace (S (n - S iter))%nat with (n - iter)%nat in Hfib; [|blia].
                symmetry. apply Hfib.
          -- etransitivity; [eassumption|].
             f_equal. rewrite H1.
             simpl. f_equal.
             rewrite Z.mod_small; [|blia].
             rewrite Z.mod_small; [|blia].
             blia.
        * cbv beta. intros. destruct_hyp.
          repeat split.
          -- propogate_eq.
          -- assumption.
          -- unfold_MetricLog. simpl in *. blia.
          -- assumption.
  Qed.

  Lemma fib_if_true_correct: forall (n: nat) t m (l: locals) mc (R: mem -> Prop) nl ns,
      (n < 47)%nat ->
      R m ->
      map.get l FibonacciServer.a = Some (word.of_Z 0) ->
      map.get l FibonacciServer.b = Some (word.of_Z 1) ->
      map.get l FibonacciServer.n = Some (word.of_Z (Z.of_nat n)) ->
      map.get l FibonacciServer.i = Some (word.of_Z 0)  ->
      exec map.empty (fib_if nl ns) t m l mc (fun t' m' l' mc' =>
        R m' /\
        t' = t /\
        instructionsH mc' <= instructionsH mc + (Z.of_nat n) * 34 + 25 /\
        map.get l' FibonacciServer.b = Some (word.of_Z (fib (n + 1)))).
  Proof.
    intros.
    eapply @exec.if_true.
    - eval_var_solve.
    - simpl.
      destruct_one_match; [discriminate|].
      repeat rewrite Z.mod_small in * by blia.
      exfalso. blia.
    - eapply weaken_exec.
      + destruct_hyp.
        eapply fib_correct_while with (iter := n) (i := 0%nat) (nl := nl) (ns := ns); try eassumption.
        * blia.
        * apply le_n.
        * rewrite Nat.sub_diag. reflexivity.
      + intros. cbv beta in *. destruct_hyp.
        repeat split; try assumption.
        unfold_MetricLog. simpl in *. blia.
  Qed.

  Lemma fib_if_false_correct: forall (n: nat) t m (l: locals) mc (R: mem -> Prop) nl ns,
      Z.of_nat n < 2 ^ 32 ->
      (n >= 47)%nat ->
      R m ->
      map.get l FibonacciServer.a = Some (word.of_Z 0) ->
      map.get l FibonacciServer.b = Some (word.of_Z 1) ->
      map.get l FibonacciServer.n = Some (word.of_Z (Z.of_nat n)) ->
      map.get l FibonacciServer.i = Some (word.of_Z 0)  ->
      exec map.empty (fib_if nl ns) t m l mc (fun t' m' l' mc' =>
        t' = t /\
        R m' /\
        instructionsH mc' <= instructionsH mc + 22 /\
        map.get l' FibonacciServer.b = Some (word.of_Z (-1))).
  Proof.
    intros.
    eapply @exec.if_false.
    + eval_var_solve.
    + simpl.
      destruct_one_match; [|reflexivity].
      repeat rewrite Z.mod_small in * by blia.
      exfalso. blia.
    + exec_set_solve.
  Qed.

  Lemma fib_correct: forall (n: nat) t (m: mem) (l : locals) mc v nl ns,
      (ptsto_word (word.of_Z nl) (word.of_Z (Z.of_nat n)) *
       ptsto_word (word.of_Z ns) (word.of_Z v))%sep m ->
      Z.of_nat n < 2 ^ 32 ->
      exec map.empty (fib_ExprImp nl ns) t m l mc (fun t' m' l' mc' =>
        instructionsH mc' <= instructionsH mc + (Z.of_nat n) * 34 + 72 /\
        (ptsto_word (word.of_Z nl) (word.of_Z (Z.of_nat n)) *
         ptsto_word (word.of_Z ns) (word.of_Z (fib_bounded n)))%sep m').
  Proof.
    intros *. intro Hsep. intros.
    unfold fib_ExprImp.
    eapply @exec.seq with (mid := (fun t' m' l' mc' =>
      t' = t /\
      (ptsto_word (word.of_Z nl) (word.of_Z (Z.of_nat n)) *
       ptsto_word (word.of_Z ns) (word.of_Z v))%sep m' /\
      map.get l' FibonacciServer.n = Some (word.of_Z (Z.of_nat n)) /\
      instructionsH mc' = instructionsH mc + 10)).
    1: { eapply @exec.set.
         + simpl in *.
           pose proof load_word_sep as Hload.
           specialize Hload with (1 := Hsep).
           match goal with
           | H: ?x = ?r |- context[?y] =>
             match x with
             | load ?a ?m ?v =>
               match y with
               | load a m v => change y with x; rewrite H
               end
             end
           end.
           reflexivity.
         + repeat split; fib_step_precondition. }
    intros. destruct_hyp.
    eapply @exec.seq with (mid := (fun t' m' l' mc' =>
      t' = t /\
      (ptsto_word (word.of_Z nl) (word.of_Z (Z.of_nat n)) *
       ptsto_word (word.of_Z ns) (word.of_Z v))%sep m' /\
      map.get l' FibonacciServer.a = Some (word.of_Z 0) /\
      map.get l' FibonacciServer.n = Some (word.of_Z (Z.of_nat n)) /\
      instructionsH mc' = instructionsH mc + 19));
      [exec_set_solve|].
    intros. destruct_hyp.
    eapply @exec.seq with (mid := (fun t' m' l' mc' =>
      t' = t /\
      (ptsto_word (word.of_Z nl) (word.of_Z (Z.of_nat n)) *
       ptsto_word (word.of_Z ns) (word.of_Z v))%sep m' /\
      map.get l' FibonacciServer.a = Some (word.of_Z 0) /\
      map.get l' FibonacciServer.b = Some (word.of_Z 1) /\
      map.get l' FibonacciServer.n = Some (word.of_Z (Z.of_nat n)) /\
      instructionsH mc' = instructionsH mc + 28));
      [exec_set_solve|].
    intros. destruct_hyp.
    eapply @exec.seq with (mid := (fun t' m' l' mc' =>
      t' = t /\
      (ptsto_word (word.of_Z nl) (word.of_Z (Z.of_nat n)) *
       ptsto_word (word.of_Z ns) (word.of_Z v))%sep m' /\
      map.get l' FibonacciServer.a = Some (word.of_Z 0) /\
      map.get l' FibonacciServer.b = Some (word.of_Z 1) /\
      map.get l' FibonacciServer.i = Some (word.of_Z 0) /\
      map.get l' FibonacciServer.n = Some (word.of_Z (Z.of_nat n)) /\
      instructionsH mc' = instructionsH mc + 37));
      [exec_set_solve|].
    intros.
    destruct_hyp.
    unfold fib_bounded.
    destruct (n <? 47)%nat eqn:Hlt.
    - rewrite Nat.ltb_lt in *.
      eapply @exec.seq with (mid := (fun t' m' l' mc' =>
        t' = t /\
        (ptsto_word (word.of_Z nl) (word.of_Z (Z.of_nat n)) *
         ptsto_word (word.of_Z ns) (word.of_Z v))%sep m' /\
        instructionsH mc' <= instructionsH mc + (Z.of_nat n) * 34 + 62 /\
        map.get l' FibonacciServer.b = Some (word.of_Z (fib (n + 1))))).
        * eapply weaken_exec; [eapply fib_if_true_correct with (nl := nl) (ns := ns); eassumption|].
          cbv beta. intros. destruct_hyp.
          repeat split; try assumption.
          -- propogate_eq.
          -- blia.
        * intros. destruct_hyp.
          eapply @exec.store.
          -- reflexivity.
          -- eval_var_solve.
          -- pose proof load_word_sep as Hsepload.
             apply sep_comm in H23.
             specialize Hsepload with (1 := H23).
             cbv [store store_Z bedrock2.Memory.store_bytes].
             cbv [load load_Z] in Hsepload.
             destruct_one_match; [reflexivity|].
             match goal with
             | H0: ?x = ?v, H1: context[?y] |- _ =>
               match x with
               | bedrock2.Memory.load_bytes _ _ _ =>
                 match y with
                 | bedrock2.Memory.load_bytes _ _ _ => change y with x in H1; rewrite H0 in H1
                 end
               end
             end.
             discriminate.
          -- repeat split.
             ++ unfold_MetricLog. simpl in *. blia.
             ++ apply sep_comm in H23.
                pose proof unchecked_store_bytes_of_sep as HStore.
                specialize HStore with (1 := H23).
                match goal with
                | |- context[?x] =>
                  match x with
                  | LittleEndian.split _ _ => specialize HStore with (bs := x)
                  end
                end.
                wcancel_assumption.
    - rewrite Nat.ltb_ge in *.
      eapply @exec.seq with (mid := (fun t' m' l' mc' =>
        t' = t /\
        (ptsto_word (word.of_Z nl) (word.of_Z (Z.of_nat n)) *
         ptsto_word (word.of_Z ns) (word.of_Z v))%sep m' /\
        instructionsH mc' <= instructionsH mc + (Z.of_nat n) * 34 + 62 /\
        map.get l' FibonacciServer.b = Some (word.of_Z (-1)))).
      * eapply weaken_exec; [eapply fib_if_false_correct with (nl := nl) (ns := ns); eassumption|].
          cbv beta. intros. destruct_hyp.
          repeat split; try assumption.
          -- propogate_eq.
          -- blia.
        * intros. destruct_hyp.
          eapply @exec.store.
          -- reflexivity.
          -- eval_var_solve.
          -- pose proof load_word_sep as Hsepload.
             apply sep_comm in H23.
             specialize Hsepload with (1 := H23).
             cbv [store store_Z bedrock2.Memory.store_bytes].
             cbv [load load_Z] in Hsepload.
             destruct_one_match; [reflexivity|].
             match goal with
             | H0: ?x = ?v, H1: context[?y] |- _ =>
               match x with
               | bedrock2.Memory.load_bytes _ _ _ =>
                 match y with
                 | bedrock2.Memory.load_bytes _ _ _ => change y with x in H1; rewrite H0 in H1
                 end
               end
             end.
             discriminate.
          -- repeat split.
             ++ unfold_MetricLog. simpl in *. blia.
             ++ apply sep_comm in H23.
                pose proof unchecked_store_bytes_of_sep as HStore.
                specialize HStore with (1 := H23).
                match goal with
                | |- context[?x] =>
                  match x with
                  | LittleEndian.split _ _ => specialize HStore with (bs := x)
                  end
                end.
                wcancel_assumption.
  Qed.

  Definition run1 : Pipeline.M unit := @run1 _ _ _ _ Pipeline.RVM _ iset.
  Definition mcomp_sat := GoFlatToRiscv.mcomp_sat.

  Lemma fib_compiled: forall n (initialMachine: RiscvMachine) insts v nl ns R,
      0 <= n < 2 ^ 32 ->
      word.unsigned (getPc initialMachine) mod 4 = 0 ->
      getNextPc initialMachine = word.add (getPc initialMachine) (word.of_Z 4) ->
      insts = (ExprImp2Riscv (fib_ExprImp nl ns)) ->
      subset (footpr (program (getPc initialMachine) insts))
             (of_list initialMachine.(getXAddrs)) ->
      (program (getPc initialMachine) insts * R *
       (ptsto_word (word.of_Z ns) (word.of_Z v) *
        ptsto_word (word.of_Z nl) (word.of_Z n)))%sep initialMachine.(getMem) ->
      runsToNonDet.runsTo (mcomp_sat run1) initialMachine
        (fun (finalL: RiscvMachine) =>
           (program (getPc initialMachine) insts * R *
            (ptsto_word (word.of_Z ns) (word.of_Z (fib_bounded (Z.to_nat n))) *
             ptsto_word (word.of_Z nl) (word.of_Z n)))%sep finalL.(getMem) /\
           getPc finalL = add (getPc initialMachine) (mul (ZToReg 4) (ZToReg (Zlength insts))) /\
           getNextPc finalL = add (getPc finalL) (ZToReg 4) /\
           finalL.(getMetrics).(instructions) - initialMachine.(getMetrics).(instructions) <= n * 34 + 72).
  Proof.
    intros. subst.
    destruct H.

    rewrite <- sep_inline_eq in H4.
    destruct H4 as [initialMem Hsep]. destruct Hsep.

    eapply runsToNonDet.runsTo_weaken.
    - pose proof Pipeline.exprImp2Riscv_correct as Hp.
      specialize Hp with (sH := fib_ExprImp nl ns)
                         (mcH := bedrock2.MetricLogging.EmptyMetricLog).
      eapply Hp.
      + clear. intros. exact H.
      + simpl. blia.
      + cbv. intuition congruence.
      + reflexivity.
      + assumption.
      + assumption.
      + reflexivity.
      + assumption.
      + instantiate (2 := initialMem). instantiate (1 := R). seplog.
      + constructor.
      + eapply ExprImp.weaken_exec.
        * eapply fib_correct with (n := Z.to_nat n).
          -- rewrite Z2Nat.id; [|assumption]. instantiate (1 := v). wcancel_assumption.
          -- rewrite Z2Nat.id; assumption.
        * intros. eassumption.
    - intros.
      do 3 destruct H6.
      destruct_hyp.
      rewrite Z2Nat.id in *; try assumption.
      repeat split.
      + apply sep_inline_eq.
        eexists.
        split.
        * seplog.
        * wcancel_assumption.
      + assumption.
      + assumption.
      + repeat unfold_MetricLog. repeat simpl_MetricLog. simpl in *.
        destruct_hyp.
        eapply Z.le_trans.
        * eassumption.
        * blia.
  Qed.
  (*
  Print Assumptions fib_compiled.
  *)
*)

End FibCompiled.


From Coq Require Import
     ssreflect
     String
.

From ExtensibleCompiler.Passes Require Import
     RemoveUnaryIfs
.

From ExtensibleCompiler.Semantics.All Require Import
     Bool
     If1
     If2
     Lambda
     Unit
.

From ExtensibleCompiler.Syntax.Terms Require Import
     Bool
     If1
     If2
     Stuck
     Unit
.

From ExtensibleCompiler.Syntax.Types Require Import
     BoolType
     UnitType
.

From ExtensibleCompiler.Theory Require Import
     Algebra
     Environment
     Eval
     Functor
     IndexedAlgebra
     IndexedFunctor
     IndexedSum1
     ProgramAlgebra
     ProofAlgebra
     SubFunctor
     Sum1
     Types
     TypeSoundness
     UniversalProperty
.

Local Open Scope Sum1.
Local Open Scope SubFunctor.

(* Create a type language [T] *)
Definition T := (BoolType + UnitType).

(* Create an expression language [E] *)
Definition E := (Bool + If2 + Unit).

(* Create a value language [V] *)
Definition V := (Bool + Stuck + Unit).

(*
Create a concrete representation for the result of type-checking, so that it is
easy to inspect manually
 *)
Inductive Result :=
| BoolValue (b : bool)
| UnitValue
| EvalFailed
.

Variant ForComputeResult := .

(* Algebra to turn the extensible results into concrete results *)
Global Instance computeResult
  : forall R, ProgramAlgebra ForComputeResult V R Result
  := fun _ =>
       {|
         programAlgebra :=
           fun rec =>
             (fun   '(MkBool b) => BoolValue b)
             || (fun 'Stuck      => EvalFailed)
             || (fun 'Unit       => UnitValue)
         ;
       |}.

Definition eval'
           (e : WellFormedValue E)
  : Result
  := foldProgramAlgebra
       (Alg := computeResult)
       (proj1_sig (eval (L := E) (V := V) (proj1_sig e) (empty _))).

Theorem regression__unit : eval' unit = UnitValue.
Proof. reflexivity. Qed.

Theorem regression__true : eval' (boolean true) = BoolValue true.
Proof. reflexivity. Qed.

Theorem regression__false : eval' (boolean false) = BoolValue false.
Proof. reflexivity. Qed.

Theorem regression__if2True
  : eval' (if2 (boolean true) (boolean true) (boolean false)) = BoolValue true.
Proof. reflexivity. Qed.

Theorem regression__if2False
  : eval' (if2 (boolean false) (boolean true) (boolean false)) = BoolValue false.
Proof. reflexivity. Qed.

Theorem regression__if2IllTypedCondition
  : eval' (if2 unit (boolean true) (boolean false)) = EvalFailed.
Proof. reflexivity. Qed.

Theorem regression__if2IllTypedBranchStillWorksLeft
  : eval' (if2 (boolean true) (boolean true) unit) = BoolValue true.
Proof. reflexivity. Qed.

Theorem regression__if2IllTypedBranchStillWorksRight
  : eval' (if2 (boolean false) unit (boolean false)) = BoolValue false.
Proof. reflexivity. Qed.

(*
Let's make sure that we can instantiate the statement of type soundness through
evaluation.
 *)

Definition WellTyped__E
  : (TypedExpr T V)-indexedPropFunctor
  := (WellTypedValue__Bool).

(* Definition SourceExpr := Bool + If1 + Unit. *)
(* Definition TargetExpr := Bool + If2 + Unit. *)
(* Definition Value := Bool + Stuck + Unit. *)

(* Definition EvalRelation__Source *)
(*   : (WellFormedValue SourceExpr * WellFormedValue Value)-indexedPropFunctor *)
(*   := (EvalRelation__Bool + EvalRelation__If1 + EvalRelation__Unit)%IndexedSum1. *)

(* Definition EvalRelation__Target *)
(*   : (WellFormedValue TargetExpr * WellFormedValue Value)-indexedPropFunctor *)
(*   := (EvalRelation__Bool + EvalRelation__If2 + EvalRelation__Unit)%IndexedSum1. *)

(* Definition removeUnaryIfs' *)
(*            (e : WellFormedValue SourceExpr) *)
(*   : WellFormedValue TargetExpr *)
(*   := removeUnaryIfs (L := SourceExpr) (V := TargetExpr) (proj1_sig e). *)

(* Theorem test *)
(*   : removeUnaryIfs' (if1 (boolean true) unit) = if2 (boolean true) unit unit. *)
(* Proof. *)
(*   reflexivity. *)
(* Qed. *)

Variant ForRemoveUnaryIfsCorrectness := .

Declare Scope Prod1.
Delimit Scope Prod1 with Prod1.
Open Scope Prod1.

Variant Prod1 (F G : Set -> Set) (A : Set) : Set :=
| prod1 : F A -> G A -> (F * G)%Sum1 A
where
"F * G" := (Prod1 F G) : Prod1.

Arguments prod1 {F G A}.

Global Instance Functor__Prod1
       {F G} `{Functor F} `{Functor G}
  : Functor (F * G).
Proof.
  refine
    {|
      fmap := fun A B f '(prod1 fa ga) => prod1 (fmap f fa) (fmap f ga);
    |}.
  {
    move => A [] f g /=.
    do 2 rewrite fmapId //.
  }
  {
    move => A B C f g [] fa ga /=.
    do 2 rewrite fmapFusion //.
  }
Defined.

(*
NOTE:

I was trying to do a [WellFormedProofAlgebra2], that took a (Source * Value)
pair and rebuilt it, but you end up wanting a product functor, and then you'd
end up with [A <= A * B] constraints, which might not be true or not be worth it.

It seems like it might be better to do a [WellFormedProofAlgebra] where you only
change one of the two elements ofthe pair at the time, kind of like if you do
induction one variable at a time rather than induction on the pair.

Probably want to do induction on the source term, with the value universally
quantified in the output.
 *)

Section Correctness.

  Context
    {S T V}
    `{Functor S} `{Functor T} `{Functor V}
    (EvalRelation__Source : (Fix S * Fix V)-indexedPropFunctor)
    (EvalRelation__Target : (Fix T * Fix V)-indexedPropFunctor)
  .

  Definition AbstractCorrectnessStatement
             `{removeUnaryIfs__S : forall {R}, MixinAlgebra S R (WellFormedValue T)}
             (recRemoveUnaryIfs : WellFormedValue S -> WellFormedValue T)
             (s : Fix S)
             (UP'__s : FoldUP' s)
    : Prop
    := forall (v : Fix V),
      IndexedFix EvalRelation__Source (s, v) ->
      IndexedFix EvalRelation__Target
                 ( proj1_sig (removeUnaryIfs__S recRemoveUnaryIfs (unwrapUP' s)),
                   v
                 ).

  Definition Correctness__ProofAlgebra
             `{RemoveUnaryIfs__S : forall {R}, ProgramAlgebra ForRemoveUnaryIfs S R (WellFormedValue T)}
    := forall recRemoveUnaryIfs,
      ProofAlgebra ForRemoveUnaryIfsCorrectness
                   S
                   (sig (UniversalPropertyP
                           (AbstractCorrectnessStatement
                              (removeUnaryIfs__S := fun _ => programAlgebra)
                              recRemoveUnaryIfs
                           )
                   )).

  Lemma Correctness
        `{RemoveUnaryIfs__S : forall R, ProgramAlgebra ForRemoveUnaryIfs S R (WellFormedValue T)}
        `{! WellFormedMendlerProgramAlgebra RemoveUnaryIfs__S}
        (PA : Correctness__ProofAlgebra)
        `{! forall rec, WellFormedProofAlgebra (PA rec)}
    : forall (s : Fix S)
        (v : Fix V),
      FoldUP' s ->
      IndexedFix EvalRelation__Source (s, v) ->
      IndexedFix EvalRelation__Target (proj1_sig (removeUnaryIfs s), v).
  Proof.
    move => s v UP'__s E__S.
    rewrite <- (wrapUP'_unwrapUP' s) => //.
    rewrite /= / removeUnaryIfs / mendlerFold / wrapF.
    rewrite wellFormedMendlerProgramAlgebra.
    case (Induction
            (PA := PA (fun s => removeUnaryIfs (proj1_sig s))) s _
         ) => [? C].
    apply C => //.
  Qed.

End Correctness.

(* Let's instantiate it *)

Definition SourceExpr := Bool + If1   + Unit.
Definition TargetExpr := Bool + If2   + Unit.
Definition Value      := Bool + Stuck + Unit.

Definition EvalRelation__Source
  : (Fix SourceExpr * Fix Value)-indexedPropFunctor
  := (EvalRelation__Bool + EvalRelation__If1 + EvalRelation__Unit)%IndexedSum1.

Definition EvalRelation__Target
  : (Fix TargetExpr * Fix Value)-indexedPropFunctor
  := (EvalRelation__Bool + EvalRelation__If2 + EvalRelation__Unit)%IndexedSum1.

Definition S' := If1.
Definition T' := BoolType.
Definition V' := If2.

(* Definition CorrectnessInstantiation *)
(*   := Correctness *)


Require Import Coq.Classes.RelationClasses.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.Peano_dec.

Require Import HJ.Tid.
Require Import HJ.Vars.
Require Import HJ.Phasers.Regmode.
Require Import HJ.Phasers.Taskview.
Require Import HJ.Phasers.Phaser.
Require Import HJ.Phasers.WellFormed.
Require Import HJ.Phasers.PhaseOrdering.Taskview.
Import WellFormed.Taskview.
Import WellFormed.Phaser.
Import PhaseOrdering.Taskview.

Set Implicit Arguments.

Section Defs.
  Inductive Forall (R: taskview -> taskview -> Prop) (ph1 ph2:phaser) : Prop :=
    ph_rel_def:
      (forall t1 t2 v1 v2,
        Map_TID.MapsTo t1 v1 ph1 ->
        Map_TID.MapsTo t2 v2 ph2 ->
        R v1 v2) ->
      Forall R ph1 ph2.

  Definition Facilitates := Forall Taskview.Facilitates.

  Inductive HappensBefore (ph1 ph2:phaser) : Prop :=
    ph_happens_before_def:
      forall t1 t2 v1 v2,
      Map_TID.MapsTo t1 v1 ph1 ->
      Map_TID.MapsTo t2 v2 ph2 ->
      Taskview.HappensBefore v1 v2 ->
      HappensBefore ph1 ph2.

  Definition BlockedBy x y := HappensBefore x y.

  Inductive WellOrdered x : Prop :=
    well_ordered_def:
      Facilitates x x ->
      WellOrdered x.

  Inductive Par x y: Prop :=
    par_def:
      Facilitates x y ->
      Facilitates y x ->
      Par x y.

End Defs.

Module Notations.
  Infix "<" := HappensBefore : phaser_scope.
  Infix ">" := BlockedBy : phaser_scope.
  Infix "<=" := (fun x y => Facilitates y x) : phaser_scope.
  Infix ">=" := Facilitates : phaser_scope.
  Infix "||" := Par : phaser_scope.
End Notations.

Section Facts.

  Lemma ph_rel_inv:
    forall R ph1 ph2 t1 t2 v1 v2,
    Map_TID.MapsTo t1 v1 ph1 ->
    Map_TID.MapsTo t2 v2 ph2 ->
    Forall R ph1 ph2 ->
    R v1 v2.
  Proof.
    intros.
    inversion H1.
    eauto.
  Qed.

  Lemma well_ordered_to_facilitates:
    forall v1 v2 t1 t2 ph,
    WellOrdered ph ->
    Map_TID.MapsTo t1 v1 ph ->
    Map_TID.MapsTo t2 v2 ph ->
    Taskview.Facilitates v1 v2.
  Proof.
    intros.
    destruct H as (Hx).
    inversion Hx.
    eauto.
  Qed.

  Lemma ph_hb_to_not_chb:
    forall ph1 ph2,
    HappensBefore ph1 ph2 ->
    ~ Facilitates ph1 ph2.
  Proof.
    intros.
    intuition.
    inversion H.
    inversion H0.
    assert (Taskview.Facilitates v1 v2) by eauto.
    assert (~ Taskview.Facilitates v1 v2) by auto using tv_hb_to_not_ge.
    contradiction H6.
  Qed.

  Lemma ph_chb_to_not_hb:
    forall ph1 ph2,
    Facilitates ph1 ph2 ->
    ~ HappensBefore ph1 ph2.
  Proof.
    intros.
    intuition.
    inversion H.
    inversion H0.
    assert (Taskview.Facilitates v1 v2) by eauto.
    assert (~ Taskview.Facilitates v1 v2) by auto using tv_hb_to_not_ge.
    contradiction H6.
  Qed.

  Lemma ph_hb_trans:
    forall ph1 ph2 ph3,
    HappensBefore ph1 ph2 ->
    HappensBefore ph2 ph3 ->
    WellOrdered ph2 ->
    HappensBefore ph1 ph3.
  Proof.
    intros.
    destruct H1.
    inversion H.
    inversion H0.
    clear H H0.
    assert (Taskview.Facilitates v0 v2) by (inversion H1; eauto).
    eauto using lt_trans_ex, ph_happens_before_def.
  Qed.

  Lemma ph_hb_irreflexive:
    forall ph,
    WellOrdered ph ->
    ~ (HappensBefore ph ph).
  Proof.
    intros.
    inversion H.
    auto using ph_chb_to_not_hb.
  Qed.

  Section Antisym.
  Variable x y:phaser.

  Variable wx: WellFormed x.
  Variable wy: WellFormed y.
  Variable gx: WellOrdered x.
  Variable gy: WellOrdered y.

  Lemma ph_hb_antisym:
    HappensBefore x y ->
    ~ (HappensBefore y x).
  Proof.
    intros.
    apply ph_chb_to_not_hb.
    apply ph_rel_def.
    intros.
    destruct (tv_hb_ge_dec v1 v2); auto.
    inversion H.
    assert (Taskview.HappensBefore v1 v3). {
      inversion gx as (gx').
      inversion gx'.
      assert (Taskview.Facilitates v0 v2) by eauto.
      eauto using lt_trans_ex.
    }
    assert (~ Taskview.Facilitates v1 v3) by eauto using tv_hb_to_not_ge.
    assert (Taskview.Facilitates v1 v3) by (inversion gy as (gy'); inversion gy'; eauto).
    contradiction.
  Qed.
  End Antisym.

  Let ph_ge_refl_preserves_reduces_some:
    forall ph ph' t o o',
    WellFormed ph ->
    WellOrdered ph ->
    Reduces ph (t, o) ph' ->
    as_tv_op o = Some o' ->
    Facilitates ph' ph'.
  Proof.
    intros.
    assert (Hin : Map_TID.In t ph) by eauto using register_inv_in.
    apply Map_TID_Extra.in_to_mapsto in Hin.
    destruct Hin as (v, Hmt).
    assert (Taskview.Reduces v o' (Taskview.reduces o' v)) by
        eauto using ph_reduces_to_tv_reduce.
      assert (ph' = Map_TID.add t (Taskview.reduces o' v) ph) by
        eauto using ph_to_tv_correct.
      subst.
      apply ph_rel_def.
      intros.
      apply Map_TID_Facts.add_mapsto_iff in H4.
      destruct H4 as [(?,?)|(?,?)].
      + subst.
        apply Map_TID_Facts.add_mapsto_iff in H5.
        destruct H5 as [(?,?)|(?,?)].
        * subst.
          eauto using
            tv_reduces_preserves_well_formed,
            ph_well_formed_to_tv_well_formed,
            tv_well_formed_to_ge_refl.
        * apply tv_lhs_eval_ge with (v2:=v2) in H3;
          eauto using ph_well_formed_to_tv_well_formed, well_ordered_to_facilitates.
      + apply Map_TID_Facts.add_mapsto_iff in H5.
        destruct H5 as [(?,?)|(?,?)].
        * subst.
          assert (R : Taskview.Facilitates v1 v) by
          eauto using well_ordered_to_facilitates.
          inversion R; clear R.
          - destruct o'; simpl in *.
            {
              rewrite <- signal_preserves_wait_phase in *.
              auto using tv_nhb_ge.
            }
            apply as_tv_op_inv_wait in H2.
            subst.
            inversion H1; simpl in *; subst; clear H1.
            inversion H3; simpl in *; subst; clear H3.
            inversion H7; subst; clear H7.
            inversion H8; subst; clear H8.
            simpl_red.
            rename v0 into v2.
            destruct (Regmode.can_signal_wo (mode v1)). {
              apply tv_nhb_ge.
              rewrite wait_wait_phase.
              eauto.
            }
            auto using tv_nhb_wo.
          - apply tv_nhb_so.
            rewrite reduces_preserves_mode.
            assumption.
          - auto using tv_nhb_wo.
        * eauto using well_ordered_to_facilitates.
  Qed.

  Let ph_ge_refl_preserves_reduces_drop:
    forall ph ph' t,
    WellOrdered ph ->
    Reduces ph (t, DROP) ph' ->
    WellOrdered ph'.
  Proof.
    intros.
    inversion H0; subst; clear H0.
    inversion H4; subst; clear H4; simpl in *.
    unfold drop in *.
    apply well_ordered_def.
    apply ph_rel_def.
    intros; simpl in *.
    apply Map_TID.remove_3 in H1.
    apply Map_TID.remove_3 in H2.
    eauto using well_ordered_to_facilitates.
  Qed.

  Definition wo_phaser := { ph: phaser | WellOrdered ph }.

  Instance HappensBefore_StrictOrder : StrictOrder
    (fun (x y:wo_phaser) => HappensBefore (proj1_sig x) (proj1_sig y)).
  Proof.
    apply Build_StrictOrder.
    - unfold Irreflexive, Reflexive, complement.
      intros.
      destruct x; simpl in *.
      apply ph_hb_irreflexive in H; auto.
    - unfold Transitive.
      intros.
      destruct x as (x, ?), y as (y, ?), z as (z, ?);
      simpl in *.
      eauto using ph_hb_trans.
  Qed.

  Let exists_dec := Map_TID_Extra.exists_dec (elt:=taskview) tid_eq_rw.

  Let tv_hb x y := if tv_hb_dec x y then true else false.

  Let hb x y :=
  exists_dec
  (fun _ v1 =>
    match exists_dec (fun _ v2 => tv_hb v1 v2) y with
    | inl _ => true
    | inr _ => false
    end
  )
  x.

  Lemma hb_dec x y:
    { HappensBefore x y}
    +
    { Facilitates x y }.
  Proof.
    destruct (hb x y). {
      left.
      destruct s as ((?,v1), (?,?)); simpl in *.
      destruct (exists_dec _ y). {
        destruct s as ((?,v2),(?,?)); simpl in *.
        unfold tv_hb in H2.
        destruct (tv_hb_dec v1 v2). {
          eauto using ph_happens_before_def.
        }
        inversion H2.
      }
      inversion H0.
    }
    right.
    destruct s.
    apply ph_rel_def.
    intros.
    apply e in H.
    destruct (exists_dec _ y). {
      inversion H.
    }
    destruct s.
    apply e0 in H0.
    unfold tv_hb in *.
    destruct (tv_hb_dec v1 v2). {
      inversion H0.
    }
    auto using tv_not_lt_to_ge.
  Defined.

  Lemma par_dec x y:
    { Par x y } + { ~ Par x y }.
  Proof.
    destruct (hb_dec x y). {
      right.
      unfold not; intros.
      destruct H, h.
      destruct H.
      apply tv_hb_to_not_ge in H3.
      contradiction H3; eauto.
    }
    destruct (hb_dec y x). {
      right.
      unfold not; intros.
      destruct H, h.
      destruct H0.
      apply tv_hb_to_not_ge in H3.
      contradiction H3; eauto.
    }
    auto using par_def.
  Defined.

  Lemma well_ordered_dec x:
    { WellOrdered x } + { ~ WellOrdered x }.
  Proof.
    destruct (hb_dec x x). {
      right.
      unfold not; intros.
      destruct H.
      apply ph_hb_to_not_chb in h.
      contradiction.
    }
    auto using well_ordered_def.
  Defined.

  Lemma hb_to_not_mhp:
    forall x y,
    HappensBefore x y ->
    ~ Facilitates x y.
  Proof.
    intros.
    inversion H.
    unfold not; intros N.
    inversion N.
    assert (Taskview.Facilitates v1 v2) by eauto.
    apply tv_hb_to_not_ge in H2.
    contradiction.
  Qed.

  Lemma not_mhp_to_hb:
    forall x y,
    ~ Facilitates x y ->
    HappensBefore x y.
  Proof.
    intros.
    destruct (hb_dec x y); auto.
    contradiction.
  Qed.

  Lemma mhp_to_not_hb:
    forall x y,
    Facilitates y x ->
    ~ HappensBefore y x.
  Proof.
    unfold not; intros.
    destruct H0, H.
    assert (Taskview.Facilitates v1 v2) by eauto.
    apply tv_hb_to_not_ge in H2.
    contradiction.
  Qed.

  Lemma not_hb_to_mhp:
    forall x y,
    ~ HappensBefore x y ->
    Facilitates x y.
  Proof.
    intros.
    apply ph_rel_def; intros.
    destruct (Taskview.tv_hb_ge_dec v1 v2). {
      contradiction H.
      eauto using ph_happens_before_def.
    }
    assumption.
  Qed.

  Let tv_nhb_register_left:
    forall r v1 v2,
    r_le (get_mode r) (mode v1) ->
    Taskview.Facilitates v1 v2 ->
    Taskview.Facilitates (set_mode v1 (get_mode r)) v2.
  Proof.
    intros ? ? ? Hle Hge.
    inversion Hge.
    * apply tv_nhb_ge.
      rewrite set_mode_preserves_signal_phase.
      assumption.
    * auto using tv_nhb_so.
    * rewrite H in Hle.
      inversion Hle.
      rewrite <- H.
      rewrite set_mode_ident.
      assumption.
  Qed.

  Let tv_nhb_register_both:
    forall r v,
    r_le (get_mode r) (mode v) ->
    Taskview.Facilitates v v ->
    Taskview.Facilitates (set_mode v (get_mode r)) (set_mode v (get_mode r)).
  Proof.
    intros.
    destruct (get_mode r); auto using tv_nhb_so, tv_nhb_wo.
    inversion H.
    subst.
    rewrite H3.
    rewrite set_mode_ident.
    assumption.
  Qed.

  Let tv_nhb_register_right:
    forall v1 v2 r,
    r_le (get_mode r) (mode v2) ->
    Taskview.Facilitates v1 v2 ->
    Taskview.Facilitates v1 (set_mode v2 (get_mode r)).
  Proof.
    intros ? ? r Hle Hge.
    inversion Hge.
    * apply tv_nhb_ge.
      rewrite set_mode_preserves_wait_phase.
      assumption.
    * rewrite H in Hle.
      inversion Hle.
      rewrite H1 in *.
      rewrite <- H.
      rewrite set_mode_ident.
      assumption.
    * auto using tv_nhb_wo.
  Qed.

  Let ph_ge_refl_preserves_reduces_register:
    forall t r ph ph',
    WellOrdered ph ->
    Reduces ph (t, (REGISTER r)) ph' ->
    WellOrdered ph'.
  Proof.
    intros ? ? ? ? Hge R.
    inversion R; subst; simpl in *; clear R.
    inversion H2; subst; clear H2.
    assert (R:=H0).
    apply register_rw with (r:=r) in R; auto.
    rewrite R; clear R.
    apply well_ordered_def.
    apply ph_rel_def.
    intros ? ? ? ? Hmt1 Hmt2.
    apply Map_TID_Facts.add_mapsto_iff in Hmt1;
    destruct Hmt1 as [(?,?)|(?,?)].
    - subst.
      apply Map_TID_Facts.add_mapsto_iff in Hmt2;
      destruct Hmt2 as [(?,?)|(?,?)].
      + subst.
        eauto using well_ordered_to_facilitates, tv_nhb_register_both.
      + eauto using well_ordered_to_facilitates, tv_nhb_register_left.
    - apply Map_TID_Facts.add_mapsto_iff in Hmt2;
      destruct Hmt2 as [(?,?)|(?,?)].
      + subst.
        eauto using well_ordered_to_facilitates, tv_nhb_register_right.
      + eauto using well_ordered_to_facilitates.
  Qed.

  Theorem ph_ge_refl_preserves_reduce:
    forall ph t o ph',
    WellFormed ph ->
    WellOrdered ph ->
    Phaser.Reduces ph (t, o) ph' ->
    WellOrdered ph'.
  Proof.
    intros.
    remember (as_tv_op o) as o'.
    symmetry in Heqo'.
    destruct o' as [o'|].
    - apply well_ordered_def; inversion H0; eauto using ph_ge_refl_preserves_reduces_some.
    - destruct o; try (simpl in Heqo'; inversion Heqo'); clear Heqo'.
      + eauto using ph_ge_refl_preserves_reduces_drop.
      + eauto using ph_ge_refl_preserves_reduces_register.
  Qed.

  Let ph_ge_reduces_some:
    forall ph t o o' ph',
    WellFormed ph ->
    WellOrdered ph ->
    Reduces ph (t, o) ph' ->
    as_tv_op o = Some o' ->
    Facilitates ph' ph.
  Proof.
    intros.
    assert (Hin : Map_TID.In t ph) by eauto using register_inv_in.
    apply Map_TID_Extra.in_to_mapsto in Hin.
    destruct Hin as (v, Hmt).
    assert (Taskview.Reduces v o' (Taskview.reduces o' v)) by
    eauto using ph_reduces_to_tv_reduce.
    assert (ph' = Map_TID.add t (Taskview.reduces o' v) ph) by
    eauto using ph_to_tv_correct.
    subst.
    apply ph_rel_def.
    intros.
    apply Map_TID_Facts.add_mapsto_iff in H4;
    destruct H4 as [(?,?)|(?,?)].
    - subst.
      assert (Taskview.WellFormed v) by (inversion H; eauto).
      assert (Taskview.Facilitates v v2) by eauto using well_ordered_to_facilitates.
      eauto using tv_lhs_eval_ge.
    - eauto using well_ordered_to_facilitates.
  Qed.

  Lemma ph_ge_reduce:
    forall ph t o ph',
    WellFormed ph ->
    WellOrdered ph ->
    Reduces ph (t, o) ph' ->
    Facilitates ph' ph.
  Proof.
    intros ? ? ? ? WF Hge R.
    remember(as_tv_op o) as o'.
    symmetry in Heqo'.
    destruct o' as [o'|]; eauto using ph_ge_reduces_some.
    (destruct o; simpl in Heqo'; inversion Heqo'); clear Heqo';
    inversion R; subst;  simpl in *; clear R;
    inversion H2; subst; clear H2.
    - unfold drop in *.
      apply ph_rel_def.
      intros.
      apply Map_TID.remove_3 in H0.
      eauto using well_ordered_to_facilitates.
    - assert (R:= H0).
      apply register_rw with (r:=r) in H0; auto.
      rewrite H0 in *; clear H0.
      apply ph_rel_def; intros.
      apply Map_TID_Facts.add_mapsto_iff in H0;
      destruct H0 as [(?,?)|(?,?)].
      + subst.
        eauto using well_ordered_to_facilitates, tv_nhb_register_left.
      + eauto using well_ordered_to_facilitates.
  Qed.

  Section Trans.
    Inductive Update : op -> Prop :=
      | update_signal:
        Update SIGNAL
      | update_wait:
        Update WAIT
      | update_register:
        forall r,
        Update (REGISTER r).

    Hint Constructors Update.

    (** Reduces for update-operations *)

    Inductive ReducesUpdates p1 : event -> phaser -> Prop :=
      reduces_updates_def:
        forall t o p2,
        Update o ->
        Reduces p1 (t, o) p2 ->
        ReducesUpdates p1 (t, o) p2.

    Hint Constructors ReducesUpdates.

    Inductive ReducesDestructs p1 : event -> phaser -> Prop :=
      reduces_destructs_def:
        forall p2 t,
        Reduces p1 (t, DROP) p2 ->
        ReducesDestructs p1 (t, DROP) p2.

    Hint Constructors ReducesDestructs.

    Lemma case_reduces:
      forall ph1 e ph2,
      Reduces ph1 e ph2 ->
      { ReducesUpdates ph1 e ph2 } + { ReducesDestructs ph1 e ph2 }.
    Proof.
      intros.
      destruct e as (?,[]); try (solve [left; auto | right; auto]).
    Qed.

    Lemma reduces_mapsto_neq:
      forall t v ph1 t' o ph2,
      Map_TID.MapsTo t v ph1 ->
      t' <> t ->
      Reduces ph1 (t', o) ph2 ->
      Map_TID.MapsTo t v ph2.
    Proof.
      intros.
      assert (Hin : Map_TID.In t' ph1) by eauto using register_inv_in.
      apply Map_TID_Extra.in_to_mapsto in Hin.
      destruct Hin as (v', Hmt').
      assert (R:=Hmt').
      inversion H1; subst; clear H1.
      destruct o; simpl in *;
      inversion H5; subst; clear H5.
      - apply signal_rw in R. rewrite R.
        auto using Map_TID.add_2.
      - apply wait_rw in R; rewrite R.
        auto using Map_TID.add_2.
      - unfold drop in *.
        auto using Map_TID.remove_2.
      - apply register_rw with (r:=r) in R. rewrite R.
        apply Map_TID.add_2; auto.
        intuition.
        subst.
        contradiction H1.
        eauto using Map_TID_Extra.mapsto_to_in.
    Qed.

    Lemma reduces_mapsto_neq_rtl:
      forall t v ph1 t' o ph2,
      Map_TID.MapsTo t v ph2 ->
      t' <> t ->
      Reduces ph1 (t', o) ph2 ->
      Map_TID.MapsTo t v ph1 \/ exists r, o = REGISTER r /\ t = (get_task r).
    Proof.
      intros.
      assert (Hin : Map_TID.In t' ph1) by eauto using register_inv_in.
      apply Map_TID_Extra.in_to_mapsto in Hin.
      destruct Hin as (v', Hmt').
      inversion H1; subst; clear H1.
      assert (R:=Hmt').
      destruct o; simpl in *;
      inversion H5; subst; simpl in *; clear H5.
      - left.
        apply signal_rw in R.
        rewrite R in H.
        eauto using Map_TID.add_3.
      - apply wait_rw in R; rewrite R in H.
        left; eauto using Map_TID.add_3.
      - unfold drop in *.
        left; eauto using Map_TID.remove_3.
      - destruct (TID.eq_dec t (get_task r)).
        + eauto.
        + left.
          apply register_rw with (r:=r) in R; auto; rewrite R in *.
          rewrite Map_TID_Facts.add_mapsto_iff in H.
          destruct H.
          * destruct H.
            symmetry in H.
            contradiction.
          * destruct H; assumption.
    Qed.

    Lemma reduces_update_inv:
      forall t v ph1 t' o ph2,
      Map_TID.MapsTo t v ph1 ->
      ReducesUpdates ph1 (t', o) ph2 ->
      { Map_TID.MapsTo t v ph2 } + { exists o', (as_tv_op o = Some o' /\ t' = t /\ Map_TID.MapsTo t (Taskview.reduces o' v) ph2) }.
    Proof.
      intros.
      destruct (TID.eq_dec t' t). {
        rewrite tid_eq_rw in *; subst.
        assert (rw:=H).
        destruct o; simpl in *; try destruct H1.
        - right.
          exists Taskview.SIGNAL.
          intuition.
          inversion H0; subst; clear H0.
          simpl_red.
          auto using signal_1.
        - right; exists Taskview.WAIT; intuition.
          inversion H0; subst; clear H0.
          simpl_red.
          auto using wait_1.
        - left.
          inversion H0; inversion H3.
        - left.
          inversion H0; subst; clear H0.
          simpl_red.
          auto using register_1.
      }
      left.
      inversion H0; subst; clear H0.
      eauto using reduces_mapsto_neq.
    Qed.
  End Trans.

  Lemma ph_reduces_updates_preserves_ge_left:
    forall x y z t o,
    WellFormed y ->
    Facilitates y x ->
    ReducesUpdates y (t, o) z ->
    Facilitates z x.
  Proof.
    intros.
    apply ph_rel_def.
    intros tz tx vz vx; intros.
    destruct (TID.eq_dec t tz). {
      rewrite tid_eq_rw in *; subst.
      rename H1 into r.
      assert (i: Map_TID.In tz y) by (inversion r; eauto using register_inv_in).
      apply Map_TID_Extra.in_to_mapsto in i.
      destruct i as (v, mt).
      assert (R:=r).
      apply reduces_update_inv with (t:=tz) (v:=v) in r; auto.
      destruct r. {
        assert (v = vz) by eauto using Map_TID_Facts.MapsTo_fun.
        subst.
        inversion H0; eauto.
      }
      destruct e as (o', (Hv, (_, Hmt))).
      assert (vz = Taskview.reduces o' v) by eauto using Map_TID_Facts.MapsTo_fun.
      subst.
      assert (Taskview.Reduces v o' (Taskview.reduces o' v))
      by (inversion R; eauto using ph_reduces_to_tv_reduce).
      assert (Taskview.Facilitates v vx) by (inversion H0; eauto).
      assert (Taskview.WellFormed v) by (inversion H; eauto).
      eauto using tv_nhb_eval_lhs.
    }
    inversion H1; subst; clear H1.
    assert (R := H8).
    apply reduces_mapsto_neq_rtl with (t:=tz) (v:=vz) in R; auto.
    destruct R as [?|R]. { inversion H0; eauto. }
    destruct R as (r, (?, ?)).
    subst.
    simpl_red.
    assert (R: vz = set_mode v (get_mode r)). {
      eapply register_inv_1; eauto.
    }
    rewrite R in *; clear R.
    assert (Taskview.Facilitates v vx)
    by (inversion H0; eauto).
    eauto using tv_nhb_register_left.
  Qed.

  Lemma ph_reduces_drop_preserves_ge_left:
    forall x y z t,
    Facilitates y x ->
    Reduces y (t, DROP) z ->
    Facilitates z x.
  Proof.
    intros.
    apply ph_rel_def; intros tz tx vz vx; intros.
    simpl_red.
    apply drop_mapsto_inv in H1.
    destruct H1.
    inversion H; eauto.
  Qed.

  Require Import Coq.Relations.Relation_Operators.
  Require Import Coq.Relations.Operators_Properties.

  Lemma ph_s_reduces_preserves_ge_left:
    forall x y z,
    WellFormed y ->
    Facilitates y x ->
    SReduces y z ->
    Facilitates z x.
  Proof.
    intros.
    destruct H1.
    apply case_reduces in H1.
    destruct H1.
    - eauto using ph_reduces_updates_preserves_ge_left.
    - destruct r; eauto using ph_reduces_drop_preserves_ge_left.
  Qed.

  Lemma ph_s_reduces_trans_refl_well_formed:
    forall x y,
    WellFormed x ->
    clos_refl_trans phaser SReduces x y ->
    WellFormed y.
  Proof.
    intros.
    induction H0; auto.
    destruct H0.
    eauto using ph_reduces_preserves_well_formed.
  Qed.

  Lemma ph_s_reduces_trans_refl_ge_refl:
    forall x y,
    WellFormed x ->
    WellOrdered x ->
    clos_refl_trans phaser SReduces x y ->
    WellOrdered y.
  Proof.
    intros.
    induction H1; auto.
    - destruct H1.
      eauto using ph_ge_refl_preserves_reduce.
    - assert (WellFormed y) by eauto using ph_s_reduces_trans_refl_well_formed.
      eauto.
  Qed.

  Lemma ph_s_reduces_trans_refl_ge:
    forall x y,
    WellFormed x ->
    WellOrdered x ->
    clos_refl_trans phaser SReduces x y ->
    Facilitates y x.
  Proof.
    intros.
    rewrite clos_rt_rtn1_iff in H1.
    induction H1.
    - inversion H0; auto.
    - assert (WellFormed y). {
        rewrite <- clos_rt_rtn1_iff in H2.
        eauto using ph_s_reduces_trans_refl_well_formed.
      }
      eauto using ph_s_reduces_preserves_ge_left.
  Qed.

  Import Notations.
  Open Scope phaser_scope.

  Lemma ph_signal_lhs_ge_rhs:
    forall x t,
    WellOrdered x ->
    SignalPre t x ->
    x >= signal t x.
  Proof.
    intros.
    inversion H0.
    apply ph_rel_def.
    intros.
    apply signal_mapsto_inv in H4.
    destruct H4 as [(?,(v',(?,?)))|(?,?)].
    - subst.
      assert (v' = v) by eauto using Map_TID_Facts.MapsTo_fun; subst; clear H6.
      eauto using well_ordered_to_facilitates, signal_preserves_rhs.
    - eauto using well_ordered_to_facilitates.
  Qed.

  Lemma ph_wait_lhs_ge_rhs:
    forall x t,
    WellOrdered x ->
    WaitPre t x ->
    x >= wait t x.
  Proof.
    intros.
    inversion H0; clear H0.
    apply ph_rel_def.
    intros.
    apply wait_mapsto_inv in H4.
    destruct H4 as [(?,(v',(?,?)))|(?,?)].
    - subst.
      assert (v' = v) by eauto using Map_TID_Facts.MapsTo_fun; subst; clear H6.
      assert (Taskview.Facilitates v1 v) by eauto using well_ordered_to_facilitates.
      rename v into v2.
      destruct H3.
      apply wait_preserves_rhs; eauto.
    - eauto using well_ordered_to_facilitates.
  Qed.

  Lemma ph_register_lhs_ge_rhs:
    forall x r t,
    WellOrdered x ->
    RegisterPre r t x ->
    x >= register r t x.
  Proof.
    intros.
    inversion H0; clear H0.
    apply ph_rel_def.
    intros.
    apply register_inv_mapsto in H4 as [?|(?,(v',(?,?)))]. {
      eauto using well_ordered_to_facilitates.
    }
    subst.
    assert (v' = v) by eauto using Map_TID_Facts.MapsTo_fun; subst; clear H5.
    apply tv_nhb_register_right; auto.
    eauto using well_ordered_to_facilitates.
  Qed.

  Lemma ph_drop_lhs_ge_rhs:
    forall x t,
    WellOrdered x ->
    DropPre t x ->
    x >= drop t x.
  Proof.
    intros.
    inversion H0.
    apply ph_rel_def.
    intros.
    apply drop_mapsto_inv in H3.
    destruct H3 as (?,?).
    eauto using well_ordered_to_facilitates.
  Qed.

  Lemma reduces_ne:
    forall x y,
    WellOrdered x ->
    SReduces x y ->
    x >= y.
  Proof.
    intros.
    inversion H0; clear H0.
    inversion H1.
    destruct o; simpl in *; subst; clear H1.
    - auto using ph_signal_lhs_ge_rhs.
    - auto using ph_wait_lhs_ge_rhs.
    - auto using ph_drop_lhs_ge_rhs.
    - auto using ph_register_lhs_ge_rhs.
  Qed.

  Lemma reduces_par:
    forall x y,
    WellFormed x ->
    WellOrdered x ->
    SReduces x y ->
    x || y.
  Proof.
    intros.
    inversion H1.
    apply par_def.
    - eauto using reduces_ne.
    - eauto using ph_ge_reduce.
  Qed.

  Lemma ph_par_symm:
    forall x y,
    x || y <-> y || x.
  Proof.
    split; intros;
    inversion H; eauto using par_def.
  Qed.
End Facts.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e216m2e108m1_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


(*
This file consists of several sections:
- nonnegative lists, polynomials with nonnegative coefs, proof of Proposition 2.39 of [bpr], monic_roots_changes_eq0
- complements for scaleX_poly
- complements for transformations in R and roots
- complements for transformations and equality
- complements for transformations in C and roots
- proof of 3 circles i)
- proof of 3 circles ii)
*)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype prime.
Require Import div bigop ssralg poly polydiv polyorder ssrnum zmodp.
Require Import polyrcf qe_rcf_th complex poly_normal pol.

Set Implicit Arguments.
Unset Strict Implicit.

Import GRing.Theory Num.Theory Num.Def.
Import Pdiv.Idomain.

Section about_nonneg.

Variable R : rcfType.

Local Notation C := (complex R).

Definition nonneg := fun (s : seq R) => all (fun x => 0 <= x) s.

Lemma nonnegP (s : seq R) : reflect
  (forall k, (k < size s)%N -> 0 <= s`_k) (nonneg s).
Proof. by apply/all_nthP. Qed.

Lemma nonneg_poly_deg1 (a : R) :
   nonneg ('X - a%:P) = (a <= 0).
Proof.
by rewrite polyseqXsubC /= ler01 oppr_ge0 !andbT.
Qed.

Lemma nonneg_poly_deg2 (z : C) :
   nonneg ('X^2 + (1 *- 2 * Re z) *: 'X + (Re z ^+ 2 + Im z ^+ 2)%:P)
    = ((Re z) <= 0).
Proof.
rewrite -(mul1r 'X^2) mul_polyC polyseq_deg2 /= ?oner_neq0 // ler01 !andbT.
rewrite nmulr_rge0 ?oppr_lt0 ?ltr0n //.
by rewrite addr_ge0 // sqr_ge0.
Qed.

Lemma nonneg_mulr (p q : {poly R}) :
   (nonneg p) -> (nonneg q) -> (nonneg (p * q)).
Proof.
case Hpsize : (p == 0).
  by rewrite (eqP Hpsize) mul0r => Hp Hq.
move/eqP/eqP : Hpsize => Hpsize.
case Hqsize : (q == 0).
  by rewrite (eqP Hqsize) mulr0.
move/eqP/eqP : Hqsize=> Hqsize Hp Hq.
apply/nonnegP => k Hk.
rewrite coef_mul_poly /= sumr_ge0 //.
case=> i Hi _ /=.
apply: mulr_ge0.
  case Hi2 : (i < size p)%N.
    by apply/nonnegP; rewrite ?Hi2.
  by rewrite -(coefK p) coef_poly Hi2.
case Hi2 : (k - i < size q)%N.
   by apply/nonnegP.
by rewrite -(coefK q) coef_poly Hi2.
Qed.

Local Notation toC := (fun (p : {poly R}) =>
   @map_poly R _ (real_complex R) p).

Lemma nonneg_root_nonpos : forall (p : {poly R}),
   (p \is monic) ->
   (forall z : C, root (toC p) z -> ((Re z) <= 0)) -> nonneg p.
Proof.
move=> p Hpmonic.
move: {2}(size p) (leqnn (size p)) => n.
elim: n p Hpmonic=> [p Hpmonic Hpsize Hproot | n IH p Hpmonic Hpsize Hproots].
(* size p <= 0 *)
  rewrite size_poly_leq0 in Hpsize.
  by rewrite (eqP Hpsize) monicE lead_coef0 eq_sym oner_eq0 in Hpmonic.
(* size p <= n.+1 *)
case: (altP (size (toC p) =P 1%N)) => Hpsize2.
(* size p = 1 *)
  rewrite size_map_poly_id0 in Hpsize2;
    last by rewrite eq_sym negbT // ltr_eqF // ltcR (eqP Hpmonic) ltr01.
  have Hp := (size1_polyC (eq_leq Hpsize2)).
  rewrite Hp in Hpsize2.
  rewrite Hp monicE lead_coefE Hpsize2 -pred_Sn polyseqC in Hpmonic.
  rewrite size_polyC in Hpsize2.
  rewrite Hpsize2 /= in Hpmonic.
  by rewrite Hp /= (eqP Hpmonic) polyseqC oner_neq0 /= ler01.
(* size p != 1 *)
move/closed_rootP : Hpsize2.
case=> x Hrootx.
case: (altP (Im x =P 0)) => Himx.
(* real root *)
  have H := monicXsubC (Re x).
  have Hp := real_root_div_poly_deg1 Himx Hrootx.
  rewrite Pdiv.IdomainMonic.dvdp_eq // in Hp.
  rewrite (eqP Hp) nonneg_mulr //.
    apply: IH=> [ | | z Hz].
    + by rewrite monicE -(@lead_coef_Mmonic _ (p %/ ('X - (Re x)%:P))
          ('X - (Re x)%:P)) // -(eqP Hp) -monicE.
    - rewrite size_divp; last by apply: monic_neq0.
      by rewrite size_XsubC leq_subLR addnC addn1.
    + rewrite Hproots // (eqP Hp) rmorphM rootM.
      apply/orP; by left.
  by rewrite nonneg_poly_deg1 (Hproots x Hrootx).
(* pair of complex roots *)
have H : 'X^2 + (1 *- 2 * Re x) *: 'X + (Re x ^+ 2 + Im x ^+ 2)%:P \is monic.
  by rewrite -(mul1r 'X^2) mul_polyC monicE lead_coefE polyseq_deg2 // oner_neq0.
have H2 : size ('X^2 + (1 *- 2 * Re x) *: 'X + (Re x ^+ 2 + Im x ^+ 2)%:P) = 3.
  by rewrite -(mul1r 'X^2) mul_polyC polyseq_deg2 // oner_neq0.
have Hp := complex_root_div_poly_deg2 Himx Hrootx.
rewrite Pdiv.IdomainMonic.dvdp_eq // in Hp.
rewrite (eqP Hp) nonneg_mulr //.
  apply: IH=> [ | | z Hz].
 + by rewrite monicE -(@lead_coef_Mmonic _ _ ('X^2 + (1 *- 2 * Re x) *: 'X +
    (Re x ^+ 2 + Im x ^+ 2)%:P)) // -(eqP Hp) -monicE.
  - rewrite size_divp; last by apply: monic_neq0.
    by rewrite H2 leq_subLR addnC addn2 (@leq_trans n.+1).
  + rewrite Hproots // (eqP Hp) rmorphM rootM.
    apply/orP; by left.
by rewrite nonneg_poly_deg2 (Hproots _ Hrootx).
Qed.

Lemma nonneg_changes0 : forall (s : seq R),
   (nonneg s) -> (changes s = 0%N).
Proof.
elim=> [ |a ] //.
case=> [_ _ |b l IHbl /andP [] Ha Hblnonneg].
  by rewrite /= mulr0 addn0 ltrr.
have/andP [Hb Hlnonneg] := Hblnonneg.
apply/eqP; rewrite addn_eq0 eqb0 -lerNgt mulr_ge0 //=.
apply/eqP; by apply: IHbl.
Qed.

(* Proposition 2.39 *)
Lemma monic_roots_changes_eq0 (p : {poly R}) :
   p \is monic ->
   (forall (z : C), (root (toC p) z) -> (Re z <= 0)) ->
   changes p = 0%N.
Proof.
move=> Hpmonic H.
by rewrite nonneg_changes0 // nonneg_root_nonpos.
Qed.

End about_nonneg.

Section about_scaleX_poly. (* move this section to pol.v*)

Variable (R : comRingType).

Lemma scaleX_poly_is_linear (c : R) : linear (scaleX_poly c).
Proof. by move=> a u v; rewrite /scaleX_poly comp_polyD comp_polyZ. Qed.

Lemma scaleX_poly_multiplicative (c : R) : multiplicative (scaleX_poly c).
Proof.
split. move=> x y; exact: comp_polyM. by rewrite /scaleX_poly comp_polyC.
Qed.

Canonical scaleX_poly_additive (c : R) := Additive (scaleX_poly_is_linear c).
Canonical scaleX_poly_linear c := Linear (scaleX_poly_is_linear c).
Canonical scaleX_poly_rmorphism c := AddRMorphism (scaleX_poly_multiplicative c).

Lemma scaleX_polyC (c a : R) : a%:P \scale c = a%:P.
Proof. by rewrite /scaleX_poly comp_polyC. Qed.

End about_scaleX_poly.

Section about_transformations.

Variable (R : fieldType).
(*
Lemma root_shift_1 (p : {poly R}) (a x : R) :
   (root p x) = root (p \shift a) (x-a).
Proof. by rewrite !rootE -horner_shift_poly1. Qed.
*)
Lemma root_shift_2 (p : {poly R}) (a x : R) :
   root p (x + a) = root (p \shift a) x.
Proof.
by rewrite !rootE -{2}(@addrK _ a x) -horner_shift_poly1.
Qed.
(*
Lemma root_scale_1 (p : {poly R}) (a x : R) : (a != 0) ->
   root p x = root (p \scale a) (x / a).
Proof.
move=> Ha.
by rewrite !rootE horner_scaleX_poly mulrC (@mulrVK _ a _ x) // unitfE.
Qed.
*)
Lemma root_scale_2 (p : {poly R}) (a x : R) :
   root p (a * x) = root (p \scale a) x.
Proof.
by rewrite !rootE horner_scaleX_poly.
Qed.
(*
Lemma root_reciprocal_1 (p : {poly R}) (x : R) : (x != 0) ->
   root p x = root (reciprocal_pol p) (x^-1).
Proof.
move=> Hx.
rewrite !rootE horner_reciprocal1; last by rewrite unitfE.
rewrite GRing.mulrI_eq0 //; apply: GRing.lregX.
by apply/lregP.
Qed.
*)
Lemma root_reciprocal_2 (p : {poly R}) (x : R) : (x != 0) ->
   root p (x^-1) = root (reciprocal_pol p) x.
Proof.
move=> Hx.
rewrite !rootE horner_reciprocal; last by rewrite unitfE.
rewrite GRing.mulrI_eq0 //; apply: GRing.lregX.
by apply/lregP.
Qed.
(*
Lemma root_Mobius_1 (p : {poly R}) (x : R) (l r : R) :
   (l != r) -> (x != l) -> (x != r) ->
   root p x = root (Mobius p l r) ((r - x) / (x - l)).
Proof.
move=> Hlr Hxl Hxr.
rewrite /Mobius.
rewrite -root_shift_2 -(@mulrK _ (x - l) _ 1); last by rewrite unitfE subr_eq0.
rewrite mul1r -mulrDl addrA -(@addrA _ _ (-x) x) (@addrC _ (-x) x) addrA addrK.
rewrite -root_reciprocal_2.
  rewrite invrM; last by rewrite unitfE invr_eq0 subr_eq0.
    rewrite invrK -root_scale_2 mulrC divrK;
      last by rewrite unitfE subr_eq0 eq_sym.
    by rewrite -root_shift_2 -addrA (@addrC _ _ l) addrA addrK.
  by rewrite unitfE subr_eq0 eq_sym.
apply: GRing.mulf_neq0.
  by rewrite subr_eq0 eq_sym.
by rewrite invr_eq0 subr_eq0.
Qed.
*)
Lemma root_Mobius_2 (p : {poly R}) (x : R) (l r : R) :
   (x + 1 != 0) ->
   root p ((r + l * x) / (x + 1)) = root (Mobius p l r) x.
Proof.
move=> Hx.
rewrite /Mobius -root_shift_2 -root_reciprocal_2 //.
rewrite -root_scale_2 -root_shift_2 -{3}(@mulrK _ (x + 1) _ l).
  by rewrite -mulrDl {2}(@addrC _ x 1) mulrDr mulr1 addrA
       -(addrA r (- l) l) (addrC (-l) l) addrA addrK.
by rewrite unitfE.
Qed.

Lemma MobiusM (p q : {poly R}) (l r : R) :
   Mobius (p * q) l r = (Mobius p l r) * (Mobius q l r).
Proof.
by rewrite /Mobius !rmorphM /= reciprocalM rmorphM.
Qed.

Lemma Mobius_Xsubc (c l r : R) : (l != r) ->
   Mobius ('X - c%:P) l r = (l - c) *: 'X + (r - c)%:P.
Proof.
move=> Hlr.
rewrite /Mobius rmorphB /= shift_polyC rmorphB /= scaleX_polyC
   /shift_poly comp_polyX rmorphD /= scaleX_polyC /scaleX_poly
   comp_polyX -addrA -(rmorphB _ l c) /= reciprocal_monom.
  by rewrite rmorphD rmorphM /= comp_polyX !comp_polyC
    mulrDl polyC1 mul1r mulrC mul_polyC -addrA (addrC (l - c)%:P _)
    -rmorphD /= addrA addrNK.
by rewrite subr_eq0 eq_sym.
Qed.

Lemma Mobius_Xsubc_monic (c l r : R) :
   (l != r) -> (l != c) ->
   (lead_coef (Mobius ('X - c%:P) l r))^-1 *: (Mobius ('X - c%:P) l r)
         = 'X + ((r - c) / (l - c))%:P.
Proof.
move=> Hlr Hlc.
rewrite Mobius_Xsubc //  lead_coefE.
have Hlc2 : ((l - c) != 0).
  by rewrite subr_eq0.
have HlcP : ((l - c)%:P == 0) = false.
  apply/eqP/eqP.
  by rewrite polyC_eq0 subr_eq0.
have Hsize : size ((l - c) *: 'X + (r - c)%:P) = 2.
  by rewrite -(mul_polyC (l - c) 'X) size_MXaddC HlcP /= size_polyC Hlc2.
have Hcoef1 : ((l - c) *: 'X + (r - c)%:P)`_1 = (l - c).
  by rewrite coefD coefC addr0 -mul_polyC coefMX coefC /=.
by rewrite Hsize -mul_polyC Hcoef1 mulrDr mul_polyC -rmorphM
   mulrC -!mul_polyC mulrA (mulrC _ 'X) -rmorphM (mulrC _ (l - c))
   mulfV //= polyC1 mulr1.
Qed.

End about_transformations.

Section about_transformations_and_equality.

Variable (R : idomainType).

Lemma shift_poly_eq (p q : {poly R}) (a : R) :
   (p == q) = (p \shift a == q \shift a).
Proof.
by rewrite /shift_poly -(subr_eq0 p q) -(@comp_poly2_eq0 _ (p-q) ('X + a%:P))
  ?size_XaddC // rmorphB subr_eq add0r.
Qed.

Lemma scale_poly_eq (p q : {poly R}) (a : R) : (a != 0) ->
   (p == q) = (p \scale a == q \scale a).
Proof.
move=> Ha.
by rewrite /scaleX_poly -(subr_eq0 p q) -(@comp_poly2_eq0 _ (p-q) ('X * a%:P))
  ?size_XmulC // rmorphB subr_eq add0r.
Qed.

Lemma reciprocal_Xn n :
   reciprocal_pol ('X^n) = (GRing.one R)%:P.
Proof.
rewrite /reciprocal_pol size_polyXn poly_def big_ord_recl.
rewrite subSS subn0 coefXn expr0 eqxx scale1r big1 ?addr0 // => i _.
rewrite lift0 subSS coefXn /=.
have H : (((n - i.+1)%N == n) = false).
  apply: negbTE.
  rewrite neq_ltn.
  apply/orP; left.
  rewrite -(ltn_add2r i.+1) subnK; last by case: i.
  by rewrite -addSnnS ltn_addr.
by rewrite H /= -mul_polyC mul0r.
Qed.

Lemma reciprocal_Xn_root0 (p : {poly R}) :
   reciprocal_pol p = reciprocal_pol (p %/ 'X^(\mu_0 p)).
Proof.
rewrite -(addr0 'X) -oppr0.
have Hmu0 := (root_mu p 0).
rewrite Pdiv.IdomainMonic.dvdp_eq in Hmu0.
  by rewrite {1}(eqP Hmu0) reciprocalM {2}oppr0 addr0 reciprocal_Xn
    polyC1 mulr1 polyC0.
by rewrite polyC0 oppr0 addr0 monicXn.
Qed.

Lemma pdivmu0_0th_neq0 : forall p : {poly R}, (p != 0) ->
   (p %/ 'X^(\mu_0 p))`_0 != 0.
Proof.
move=> p Hp.
have H0noroot : ~~(root (p %/ 'X^(\mu_0 p)) 0).
  rewrite -mu_gt0.
    rewrite -eqn0Ngt -(addr0 'X) -(@oppr0 (poly_zmodType R)) -polyC0 mu_div
      ?subn_eq0; by rewrite leqnn.
  rewrite Pdiv.CommonIdomain.divp_eq0 negb_or Hp /= negb_or.
  rewrite -size_poly_gt0 {1}size_polyXn /= -leqNgt dvdp_leq //.
  by rewrite -(addr0 'X) -oppr0 -polyC0 root_mu.
rewrite -horner_coef0. apply: negbT.
by move/rootPf : H0noroot.
Qed.

Lemma reciprocal_reciprocal (p : {poly R}) :
   reciprocal_pol (reciprocal_pol p) = p %/ ('X^(\mu_0 p)).
Proof.
case Hp0 : (p == 0).
  move/eqP : Hp0 => ->.
  by rewrite !reciprocalC div0p polyC0.
rewrite (@reciprocal_Xn_root0 p) reciprocal_idempotent //.
apply: pdivmu0_0th_neq0.
by apply: negbT.
Qed.

Lemma reciprocal0 (p : {poly R}) :
   (reciprocal_pol p == 0) = (p == 0).
Proof.
apply/idP/idP => Hp.
  have H : (p %/ ('X^(\mu_0 p)) == 0).
    by rewrite -reciprocal_reciprocal -polyC0 -reciprocalC (eqP Hp).
  rewrite Pdiv.CommonIdomain.divp_eq0 in H.
  move/orP : H; case => [| /orP [] H] //.
    by rewrite -size_poly_eq0 size_polyXn -(Bool.negb_involutive (_.+1 == 0%N))
      -lt0n /= in H.
  have H2 := (root_mu p 0).
  case Hp0 : (p == 0) => //.
  rewrite gtNdvdp // in H2.
    by apply: negbT.
  by rewrite oppr0 addr0.
by rewrite (eqP Hp) -polyC0 reciprocalC.
Qed.

(*
Lemma reciprocal_nth : forall (p : {poly R}) k, (k < size p)%N ->
   (reciprocal_pol p)`_k = p`_((size p) - k.+1).
Proof.
move=> p k Hk.
by rewrite /reciprocal_pol coef_poly Hk.
Qed.
*)
Lemma reciprocal_nth_2 : forall (p : {poly R}) k, (k < size p)%N ->
   (reciprocal_pol p)`_(size p - k.+1) = p`_k.
Proof.
move=> p k Hk.
rewrite /reciprocal_pol coef_poly.
have Hk2 : (size p - k.+1 < size p)%N.
  by rewrite -(ltn_add2r k.+1) subnK // -addSnnS ltn_addr.
rewrite Hk2 !subnS -!subn1 !subnBA; last by rewrite subn_gt0.
  by rewrite addn1 -subnDA addn1 addnC addnK.
by apply: ltnW.
Qed.

Lemma reciprocal_eq (p q : {poly R}) : (p`_0 != 0) -> (q`_0 != 0) ->
   (p == q) = (reciprocal_pol p == reciprocal_pol q).
Proof.
move=> Hp0 Hq0.
apply/idP/idP => Hpq.
  by move/eqP : Hpq => ->.
apply/eqP.
apply: poly_inj.
have Hsize : (size p = size q).
  by rewrite -reciprocal_size // -(@reciprocal_size _ q) // (eqP Hpq).
apply: eq_from_nth => // i Hi.
rewrite -reciprocal_nth_2 // -(@reciprocal_nth_2 q) //.
  by rewrite (eqP Hpq) Hsize.
by rewrite -Hsize.
Grab Existential Variables.
exact: 0.
Qed.

Lemma Mobius0 : forall (p : {poly R}) (a b : R),
   (a != b) ->
   (p == 0) = ((Mobius p a b) == 0).
Proof.
move=> p a b Hab.
apply/idP/idP => Hp; move/eqP : Hp => Hp.
  by rewrite /Mobius Hp /shift_poly /scaleX_poly !comp_polyC
     reciprocalC comp_polyC.
rewrite /Mobius in Hp.
rewrite (shift_poly_eq p 0 a) shift_polyC (@scale_poly_eq _ _  (b - a)).
  by rewrite /scaleX_poly comp_polyC -reciprocal0 (shift_poly_eq _ _ 1)
     shift_polyC Hp.
by rewrite subr_eq0 eq_sym.
Qed.

End about_transformations_and_equality.

Section transformations_in_C.

Variable (R : rcfType).
Local Notation C:= (complex R).

Local Notation toC := (fun (p : {poly R}) =>
   @map_poly R _ (real_complex R) p).

Lemma shift_toC (p : {poly R}) (a : R) :
   toC (p \shift a) = (toC p) \shift a%:C.
Proof.
by rewrite /shift_poly (map_comp_poly _ p ('X + a%:P)) rmorphD /=
   map_polyX map_polyC.
Qed.

Lemma scale_toC (p : {poly R}) (a : R) :
   toC (p \scale a) = (toC p) \scale a%:C.
Proof.
by rewrite /scaleX_poly (map_comp_poly _ p ('X * a%:P)) rmorphM /=
   map_polyX map_polyC.
Qed.

Lemma reciprocal_toC (p : {poly R}) :
   toC (@reciprocal_pol _ p) = reciprocal_pol (toC p).
Proof.
rewrite /reciprocal_pol poly_def rmorph_sum /= poly_def size_map_inj_poly.
    apply: eq_bigr => i _.
    rewrite -mul_polyC rmorphM /= map_polyXn /=.
    by rewrite !coef_map /= map_polyC /= mul_polyC.
  by apply: complexI.
by rewrite -complexr0.
Qed.

Lemma Mobius_toC (p : {poly R}) (l r : R) :
   toC (Mobius p l r) = Mobius (toC p) l%:C r%:C.
Proof.
by rewrite {2}/Mobius -shift_toC /= -rmorphB -scale_toC
   -reciprocal_toC -shift_toC /Mobius.
Qed.

(*
Lemma root_Mobius_C_1 :  forall (p : {poly R}) (z : C) (l r : R),
   (l != r) -> (z != l%:C) -> (z != r%:C) ->
      root (toC p) z =
      root (toC (Mobius p l r)) ((r%:C - z) / (z - l%:C)).
Proof.
move=> p z l r Hlr Hzl Hzr.
have HlrC : (l%:C != r%:C).
  by rewrite -!complexr0 eq_complex /= negb_and eq_refl orbF.
rewrite !rootE Mobius_toC /Mobius -!rootE -@root_shift_2
   -(@mulrK _ (z - l%:C) _ 1).
  rewrite mul1r -mulrDl addrA -(@addrA _ _ (-z) z) (@addrC _ (-z) z) addrA
     addrK -root_reciprocal_2.
    rewrite invrM.
        rewrite invrK -root_scale_2 mulrC divrK.
          by rewrite -root_shift_2 -addrA (@addrC _ _ l%:C) addrA addrK.
        by rewrite unitfE subr_eq0 eq_sym.
      by rewrite unitfE subr_eq0 eq_sym.
    by rewrite unitfE invr_eq0 subr_eq0.
  apply: GRing.mulf_neq0.
    by rewrite subr_eq0 eq_sym.
  by rewrite invr_eq0 subr_eq0.
by rewrite unitfE subr_eq0.
Qed.
*)

Lemma root_Mobius_C_2 : forall (p : {poly R}) (z : C) (l r : R),
   (z + 1 != 0) ->
      root (toC p) ((r%:C + l%:C * z) / (z + 1)) =
      root (toC (Mobius p l r)) z.
Proof.
move=> p z l r Hz.
rewrite !rootE Mobius_toC /Mobius -!rootE -root_shift_2 -root_reciprocal_2 //.
rewrite -root_scale_2 -root_shift_2 -{3}(@mulrK _ (z + 1) _ l%:C).
  by rewrite -mulrDl {2}(@addrC _ z 1) mulrDr mulr1 addrA
   -(addrA r%:C (- l%:C) l%:C) (addrC (-l%:C) l%:C) addrA addrK.
by rewrite unitfE.
Qed.

End transformations_in_C.

Lemma mul_polyC_seqmul : forall (R : rcfType) (p : {poly R}) (a : R),
   (a != 0) ->
   polyseq (a *: p) = seqmul (nseq (size p) a) p.
Proof.
move=> R p a Ha.
elim/poly_ind : p => [ | p c IHp].
  by rewrite size_poly0 /= seqmul0 -mul_polyC mulr0 -polyC0 polyseq0.
rewrite -{2}(cons_poly_def) -mul_polyC mulrDr mulrA mul_polyC -polyC_mul.
rewrite -!cons_poly_def !polyseq_cons.
case Hp : (~~ (nilp p)).
  have Hp2 : (~~ (nilp (a *: p))).
    rewrite nil_poly in Hp.
    by rewrite nil_poly -mul_polyC mulf_neq0 // ?Hp // polyC_eq0.
  rewrite Hp2.
  by rewrite seqmul_cons IHp.
have Hp2 : (nilp (a *: p)).
  rewrite nil_poly in Hp.
  rewrite nil_poly -mul_polyC mulf_eq0.
  apply/orP; right.
  by apply: negbFE.
rewrite Hp2 /= size_polyC.
case/altP : (c =P 0) => Hc /=.
  by rewrite Hc mulr0 seqmul0 polyseqC eq_refl.
have Hac : (a * c != 0).
  by apply: mulf_neq0.
by rewrite !polyseqC Hac Hc /= seqmul_cons.
Qed.

Lemma changes_mulC : forall (R : rcfType) (p : {poly R}) (a : R), (a != 0) ->
   changes p = changes (a *: p).
Proof.
move=> R p a Ha.
rewrite mul_polyC_seqmul //=.
case: p => s Hs.
elim: s Hs => [Hs |b l IHl Hs] //=.
case: l IHl Hs => [_ _ |c l IHcl Hs] //=.
  by rewrite !addn0 !mulr0.
rewrite /= in IHcl.
rewrite IHcl //= /seqmul.
apply/eqP.
rewrite eqn_add2r !mulrA (mulrC a) -(mulrA b) -expr2 (mulrC _ (a^+2)) -mulrA
   eq_sym.
apply/eqP.
rewrite (@pmulr_rlt0 _ (a ^+2) (b * c)) //.
by rewrite ltr_def // ?sqrf_eq0 // sqr_ge0 Ha.
Qed.

Section thm_3_cercles_partie1.

Variables (R : rcfType) (l r : R) (Hlr_le : l < r).

Local Notation C := (complex R).

Local Notation toC := (fun (p : {poly R}) =>
   @map_poly R _ (real_complex R) p).

Lemma Hlr : l != r.
Proof.
rewrite eq_sym.
apply: (@proj1 (r != l) (l <= r)).
apply/andP.
by rewrite -ltr_def.
Qed.

Lemma HlrC : (l%:C != r%:C).
Proof.
by rewrite -!complexr0 eq_complex /= negb_and Hlr eq_refl.
Qed.

Definition notinC (z : C) :=
   0 <= (Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 + r * l.

Lemma notinC_Re_lt0_1 : forall (z : C), (z != l%:C) ->
   (notinC z) = (Re ((r%:C - z) / (z - l%:C)) <= 0).
Proof.
case => a b Hab.
rewrite /notinC /=.
simpc.
rewrite !mulrA -(mulNr (b * b) _) -mulrDl
  -expr2 (mulrDl r (-a) _) (mulrC r (a - l)) (mulrC (-a) _) (mulrDl _ _ r)
  (mulrDl _ _ (-a)) mulrNN mulrN -expr2 !addrA (addrC (a * r) _)
  -(addrA _ (a * r) _ ) (addrC (a * r) _ ) (mulrC a r) addrA
  (addrC (- l * r) _ ) -(addrA _ (r * a) (l * a)) -(mulrDl _ _ a)
  -(addrA (- a ^+2) _ _) (addrC (- l * r)) -!addrA (addrC _ (- b^+2))
  !addrA mulNr (mulrC l r) (addrC r l) -oppr_ge0 -[X in (_ = (0 <= X))]mulNr
  !opprD !opprK pmulr_lge0 //.
rewrite invr_gt0 ltr_def addr_ge0 ?sqr_ge0 // andbT paddr_eq0 ?sqr_ge0 //
   negb_and !sqrf_eq0 subr_eq0.
by rewrite -complexr0 eq_complex negb_and /= in Hab.
Qed.

Lemma notinC_Re_lt0_2 : forall (z : C), (z + 1 != 0) ->
   (notinC ((r%:C + l%:C * z) / (z + 1))) = (Re z <= 0).
Proof.
move=> z Hz.
rewrite (@notinC_Re_lt0_1 ((r%:C + l%:C * z) / (z + 1))) /=.
  rewrite -{1}(@mulrK _ (z+1) _ r%:C); last by rewrite unitfE.
  rewrite -(mulNr (r%:C + l%:C * z) _ ) -(mulrDl _ _ (z+1)^-1) mulrDr mulr1
     opprD !addrA addrK -{3}(@mulrK _ (z+1) _ l%:C); last by rewrite unitfE.
  rewrite -(mulNr (l%:C * (z+1)) _ ) -(mulrDl _ _ (z+1)^-1) mulrDr mulr1
     opprD !addrA addrK invrM.
      rewrite invrK !mulrA -(mulrA _ _ (z+1)) (mulrC _ (z+1)) !mulrA mulrK;
          last by rewrite unitfE.
      rewrite -mulNr -mulrDl (mulrC _ z) mulrK //.
      by rewrite unitfE subr_eq0 eq_sym HlrC.
    by rewrite unitfE subr_eq0 eq_sym HlrC.
  by rewrite -unitrV invrK unitfE.
rewrite -subr_eq0 -{2}(@mulrK _ (z + 1) _ l%:C); last by rewrite unitfE.
rewrite -mulNr -mulrDl mulrDr mulr1 opprD addrA addrK mulf_neq0 //.
  by rewrite subr_eq add0r eq_sym HlrC.
by rewrite invr_eq0.
Qed.

(* Theorem 10.47 i. *)
Theorem three_circles_1 : forall (p : {poly R}),
   (forall (z : C), root (toC p) z -> (notinC z)) ->
   changes (Mobius p l r) = 0%N.
Proof.
move=> p H.
have Hlr := Hlr.
case Hp0 : (p == 0).
  rewrite (Mobius0 p Hlr) in Hp0.
  move/eqP : Hp0 => ->.
  by rewrite polyseq0.
rewrite (@changes_mulC R (Mobius p l r) (lead_coef (Mobius p l r))^-1).
  apply: monic_roots_changes_eq0 => [ | z Hz].
    by rewrite monicE lead_coefZ mulrC -unitrE unitfE lead_coef_eq0
       -Mobius0 // Hp0.
  case/altP : (z+1 =P 0) => [/eqP Hz2 | Hz2].
    rewrite addr_eq0 eq_complex in Hz2.
    move/andP : Hz2; case => /eqP Hrez _.
    by rewrite Hrez raddfN lerN10.
  rewrite map_polyZ rootZ /= -?root_Mobius_C_2 // in Hz.
    rewrite -notinC_Re_lt0_2 //.
    apply: H => //.
  rewrite -complexr0 eq_complex /= negb_and eq_refl orbF.
  by rewrite invr_eq0 lead_coef_eq0 -Mobius0 // negbT.
by rewrite invr_eq0 lead_coef_eq0 -Mobius0 // negbT.
Qed.

End thm_3_cercles_partie1.

Section thm_3_cercles_partie2.

Variable (R : rcfType).

Local Notation C := (complex R).

Definition inC1 := fun (l r : R) (z : C) =>
   (Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 -
   (r - l) * (Im z) / (Num.sqrt 3%:R) + l * r < 0.

Definition inC2 := fun (l r : R) (z : C) =>
   (Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 +
   (r - l) * (Im z) / (Num.sqrt 3%:R) + l * r < 0.

Definition inC12 := fun (l r : R) (z : C) =>
   ((Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 -
   (r - l) * (Im z) / (Num.sqrt 3%:R) + l * r < 0) ||
   ((Re z) ^+2 - (l + r) * (Re z) + (Im z) ^+2 +
   (r - l) * (Im z) / (Num.sqrt 3%:R) + l * r < 0).

Lemma inC1_or_inC2 : forall (l r : R) (z : C),
   (inC1 l r z) || (inC2 l r z) = (inC12 l r z).
Proof. by done. Qed.

Definition inB1 := fun (z : C) =>
   ((Re z) - 1 <= 0) && ((Im z)^+2 <= 3%:R * ((Re z) - 1) ^+2).

Lemma inB_inB1 : forall (z : C), (inB z) = (inB1 (z + 1)).
Proof.
case => a b.
by rewrite /inB1 /= addrK addr0 /inB.
Qed.

Lemma inB1_help : forall (z : C), (inB1 z) =
   (((Num.sqrt 3%:R) * ((Re z) - 1) - Im(z) <= 0) &&
     (0 <= - (Num.sqrt 3%:R * ((Re z) - 1)) - Im(z))).
Proof.
case=> a b.
rewrite /inB1 /=.
case/altP : (a - 1 =P 0) => Ha.
  rewrite Ha /= mulr0 oppr0 add0r lerr Bool.andb_true_l (expr2 0) !mulr0.
  by rewrite -eqr_le oppr_eq0 -sqrf_eq0 eqr_le sqr_ge0 andbT.
rewrite -{1}(sqr_sqrtr (a:=3%:R)); last by apply: ler0n.
rewrite -(ComplexField.exprM _ (a-1)) -(ler_sqrt (b^+2)).
  rewrite !sqrtr_sqr normrM (ger0_norm (x := Num.sqrt 3%:R));
    last by apply: sqrtr_ge0.
  apply/idP/idP => /andP [] => H1 H2.
    rewrite -(normrN (a-1)) (gtr0_norm (x:= - (a - 1))) in H2.
      by rewrite ler_norml mulrN opprK -subr_le0
         -[X in (_ && X)]subr_ge0 in H2.
    by rewrite oppr_gt0 ltr_def H1 eq_sym Ha.
  have Hb : `|b| <= Num.sqrt 3%:R * -(a - 1).
    by rewrite ler_norml mulrN opprK -subr_le0 -[X in (_ && X)]subr_ge0 H1 H2.
  have Ha2 : (0 <= - (a - 1)).
    rewrite -(pmulr_lge0 (x:=Num.sqrt 3%:R)); last by rewrite sqrtr_gt0 ltr0n.
    by rewrite mulrC (ler_trans (y:=`|b|)).
  by rewrite -oppr_ge0 Ha2 /= -(normrN (a-1)) (ger0_norm (x:= -(a-1))).
rewrite ComplexField.exprM mulr_gt0 // ltr_def sqr_ge0.
  by rewrite sqrf_eq0 sqrtr_eq0 -ltrNge ltr0n.
by rewrite sqrf_eq0 Ha.
Qed.

Lemma Re_invc : forall (z : C), Re z^-1 = Re z / ((Re z) ^+ 2 + (Im z) ^+2).
Proof. by case. Qed.

Lemma Im_invc : forall (z : C), Im z^-1 = (- Im z) / ((Re z) ^+ 2 + (Im z) ^+2).
Proof. case => a b. by rewrite mulNr. Qed.

Lemma inB1_notinC1201 : forall (z : C), (z != 0) ->
   (inB1 z) = ~~(inC12 0 1 (z ^-1)).
Proof.
case=> a b Hz.
rewrite -inC1_or_inC2 negb_or inB1_help /=.
have H : a ^+ 2 + b ^+ 2 \is a GRing.unit.
  rewrite eq_complex /= negb_and in Hz.
  case/orP: Hz=> H;
    by rewrite unitfE paddr_eq0 ?sqr_ge0 // negb_and !sqrf_eq0 H ?orbT.
have H3 : (Num.ExtraDef.sqrtr (GRing.natmul (V:=R) (GRing.one R) (3)))
          \is a GRing.unit.
  by rewrite unitfE sqrtr_eq0 -ltrNge ltr0n.
rewrite /inC1 /= -lerNgt add0r oppr0 mul0r !addr0 !mul1r.
rewrite [x in (0 <= ((x + _) + _))]addrC -[x in (0 <= (x + _))]addrA
   ComplexField.exprM -(mulNr b) ComplexField.exprM sqrrN -mulrDl
   (expr2 ((a^+2 + b^+2)^-1)) -{2}(mulr1 (a^+2 + b^+2)) -invrM //
   -mulf_div [x in (0 <= _ + x + _)]mulrC !mulrA (mulrK (x:=(a^+2 + b^+2))) //
   -[in x in _ = x]mulNr -mulrDl -{5}(opprK 1) -(opprD a (- 1)) -mulrA -invrM //.
rewrite -[in x in _ = x]mulNr -(mul1r ( - (a - 1) / (a ^+ 2 + b ^+ 2)))
   -{5}(@mulrK _ (Num.sqrt 3%:R) _ 1) //.
rewrite mul1r mulf_div -mulrDl mulrN -[in x in (_ = x)]opprD.
rewrite /inC2 /= -lerNgt add0r oppr0 mul0r !addr0 !mul1r.
rewrite [x in (0 <= ((x + _) + _))]addrC -[x in (0 <= (x + _))]addrA
   ComplexField.exprM -(mulNr b) ComplexField.exprM sqrrN -mulrDl
   (expr2 ((a^+2 + b^+2)^-1)) -{3}(mulr1 (a^+2 + b^+2)) -invrM //
   -mulf_div [x in (0 <= _ + x + _)]mulrC !mulrA (mulrK (x:=(a^+2 + b^+2))) //
   -[in x in (_ = _ && x)]mulNr -mulrDl -{8}(opprK 1) -(opprD a (- 1)) -mulrA
   -invrM //.
rewrite -(mul1r ( - (a - 1) / (a ^+ 2 + b ^+ 2)))
    -{8}(@mulrK _ (Num.sqrt 3%:R) _ 1) //.
rewrite mul1r mulf_div -mulrDl mulNr oppr_ge0 pmulr_lge0.
  rewrite pmulr_lle0 ?mulrN //.
  by rewrite invr_gt0 ltr_def -unitfE unitrM H H3 /= mulr_ge0 // ?sqrtr_ge0 //
     addr_ge0 // sqr_ge0.
by rewrite invr_gt0 ltr_def -unitfE unitrM H H3 /= mulr_ge0 // ?sqrtr_ge0 //
     addr_ge0 // sqr_ge0.
Qed.

Lemma notinC1201_lr_scale (l r : R) : forall (z : C), (l != r) ->
   ~~(inC12 0 1 z) = ~~(inC12 0 (r - l) ((r - l)%:C * z)).
Proof.
case=> a b Hlr.
rewrite !/inC12. simpc. rewrite /=.
rewrite !ComplexField.exprM !(mulrA (r - l) _ a) !(mulrA (r - l) _ b)
   -expr2 -(mulrN _ a) -mulrA -(mulrN _ (b / Num.sqrt 3%:R))
    -!(mulrDr ((r - l)^+2)) !negb_or -!lerNgt.
by rewrite !pmulr_rge0 // ltr_def sqr_ge0 sqrf_eq0 subr_eq0 eq_sym Hlr.
Qed.

Lemma notinC12lr_shift (l r : R) : forall (z : C), (l != r) ->
   ~~(inC12 0 (r - l) z) = ~~(inC12 l r (z + l%:C)).
Proof.
case=> a b Hlr.
rewrite !/inC12. simpc. rewrite /= !negb_or -!lerNgt.
by rewrite (expr2 (a+l)) (mulrDl a l) !mulrDr (mulrDl l r)
   (mulrDl l  r) -!expr2 !opprD
   [l * a + _]addrC !addrA addrK -(addrA _ (- (r * a)) _)
   (addrC (- (r * a)) _) !addrA addrK -(addrA _ (a * l) _)
   (addrC (a * l)) (mulrC a l) -{5 9}(opprK l) mulNr -opprD
   -mulrDl [X in (_ = (0 <= X) && _)]addrC [X in (_ = _ && (0 <= X))]addrC
   !addrA (addrC (l * r)) -(addrA _ (l * r) _)
   (addrC (l * r)) (mulrC l r) !addrA addrK.
Qed.

Lemma inB_notinC12 : forall (l r : R) (z : C), (l != r) -> (z + 1 != 0) ->
   (inB z) = ~~(inC12 l r ((r%:C + l%:C * z) / (z + 1))).
Proof.
move=> l r z Hlr Hz.
have H : ((r%:C + l%:C * z) / (z + 1) = ((r - l)%:C / (z + 1) + l%:C)).
  rewrite -{2}[l%:C](@mulrK _ (z + 1)); last by rewrite unitfE.
  by rewrite -mulrDl {2}[z+1]addrC mulrDr mulr1 rmorphB /= !addrA addrNK.
by rewrite H -notinC12lr_shift // -notinC1201_lr_scale //
   -inB1_notinC1201 // -inB_inB1.
Qed.

Lemma changes_nseq : forall (s : seq R) (a : R), (a != 0) ->
   changes (seqmul (nseq (size s) a) s) = changes s.
elim => [ | c l IHl a Ha] //.
case : l IHl => [IH |b l IHbl ] //.
  by rewrite /= !mulr0 addn0.
have Helpme : ((changes [::c, b & l]) = ((c * b < 0)%R + changes [:: b & l])%N).
  by done.
rewrite Helpme -(IHbl a) //.
have Helpme2 : (((a * c) * (a * b) < 0) == (c * b < 0)).
  rewrite (mulrC a b) -mulrA (mulrC a) -!mulrA -expr2 mulrA.
  by rewrite pmulr_llt0 // ltr_def sqrf_eq0 Ha sqr_ge0.
by move/eqP : Helpme2 => <-.
Qed.

Lemma seqn0_nseq : forall (s : seq R) (a : R), (a != 0) ->
   seqmul (nseq (size (seqn0 s)) a) (seqn0 s) =
   seqn0 (seqmul (nseq (size s) a) s).
Proof.
elim => [ | c l IHl a Ha] //.
case Hc : (c != 0).
  have Hac : (a * c != 0).
    by apply: mulf_neq0.
  by rewrite seqmul_cons /= Hac /= Hc /= seqmul_cons /= -IHl.
have Hac : ((a * c != 0) = false).
  by rewrite mulf_eq0 negb_or Ha Hc.
by rewrite seqmul_cons /= Hc /= Hac /= IHl.
Qed.

Lemma inBneg1 : (@inB R (-1)).
Proof.
by rewrite /inB !raddfN lerN10 /= oppr0 sqrrN !expr2 mulr0 !mulr1 ler0n.
Qed.

Local Notation toC := (fun (p : {poly R}) =>
   @map_poly R _ (real_complex R) p).

(* (~~ root p r) because of (~~ root (Mobius p l r) 0) *)
Theorem three_circles_2 : forall  (l r : R) (p : {poly R})
   (a : R), (~~ root p r) -> (l < a < r) -> (~~ root p a) ->
   (forall z : C, root (toC p) z -> ~~ (inC12 l r z) ) ->
   (changes (seqn0 (Mobius (p * ('X - a%:P)) l r)) = 1%N).
Proof.
move=> l r p a Hpnorootr /andP [] Hal Har Hpnoroota H.
have Hlr : l != r.
  by rewrite negbT // ltr_eqF // (@ltr_trans _ a)//;
  move/andP : Hlar; case.
have Hal2 : l != a.
  by rewrite negbT // ltr_eqF.
case Hp : (p == 0).
  have : false => //.
    by rewrite -(andbN (root p a)) Hpnoroota (eqP Hp) root0.
move/eqP/eqP : Hp => Hp.
have Hlc1 : (lead_coef (Mobius (R:=R) (p * ('X - a%:P)) l r))^-1 != 0.
  rewrite invr_neq0 // MobiusM lead_coefM mulf_neq0 //;
  rewrite lead_coef_eq0 -Mobius0 // negbT //.
  by apply: polyXsubC_eq0.
have Hlc2 : (lead_coef (Mobius p l r) != 0).
  by rewrite lead_coef_eq0 -Mobius0.
rewrite -(@changes_nseq _
   (lead_coef (Mobius (p * ('X - a%:P)) l r)) ^-1) //
    seqn0_nseq // -mul_polyC_seqmul //.
rewrite MobiusM lead_coefM -mul_polyC invrM ?unitfE; [ | done |].
  rewrite rmorphM /= mulrA mulrC !mulrA
       (mulrC (Mobius ('X - a%:P) _ _) _)
       mul_polyC -mulrA mul_polyC mulrC
       [in X in (changes (R:=R) (seqn0 (polyseq (_ * X))))]
       (@Mobius_Xsubc_monic R a l r Hlr Hal2)
       -(opprK ((r - a) / (l - a))%:P) -polyC_opp.
    apply: normal_changes.
      by rewrite oppr_gt0 pmulr_rlt0 ?invr_lt0 ?subr_lt0 // subr_gt0.
    apply: normal_root_inB => [ | z Hz].
      rewrite monicE lead_coef_lreg.
        by rewrite mulrC -unitrE unitfE.
      apply/lregP; by apply: invr_neq0.
    case/altP : (z+1 =P 0) => [/eqP Hz2 | Hz2].
      rewrite addr_eq0 in Hz2.
      by rewrite (eqP Hz2) inBneg1.
    rewrite (inB_notinC12 Hlr) //.
    rewrite -mul_polyC rmorphM /= map_polyC mul_polyC rootZ in Hz.
    apply: H.
      by rewrite root_Mobius_C_2.
    rewrite /= eq_complex negb_and.
    apply/orP; left. by apply: invr_neq0.
  rewrite rootZ.
    rewrite -root_Mobius_2; last by rewrite add0r oner_neq0.
    by rewrite mulr0 addr0 add0r invr1 mulr1.
  by apply: invr_neq0.
by rewrite lead_coef_eq0 -Mobius0 // negbT // polyXsubC_eq0.
Qed.

End thm_3_cercles_partie2.


Require
  MathClasses.categories.varieties.
Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.universal_algebra MathClasses.theory.ua_homomorphisms.

Definition op := False.

Definition sig: Signature := Build_Signature unit op (False_rect _).

Definition Laws: EqEntailment sig → Prop := λ _, False.

Definition theory: EquationalTheory := Build_EquationalTheory sig Laws.

(* Constructing an object in the variety from an instance of the class: *)

Section from_instance.
  Context A `{Setoid A}.

  Notation carriers := (λ _, A).

  Instance: AlgebraOps sig carriers := λ o, False_rect _ o.

  Instance: Algebra sig carriers.
  Proof. constructor; intuition. Qed.

  Instance: InVariety theory carriers.
  Proof. constructor; intuition. Qed.

  Definition object: varieties.Object theory := varieties.object theory (λ _, A).

End from_instance.

(* Constructing an instance of the class from an object in the variety: *)

Section from_variety.

  Context `{InVariety theory A}.

  Instance: Setoid (A tt) := {}.

End from_variety.

Lemma mor_from_sr_to_alg `{InVariety theory A} `{InVariety theory B}
  (f: ∀ u, A u → B u) `{!Setoid_Morphism (f tt)}: HomoMorphism sig A B f.
Proof with try apply _.
 constructor.
    intros []...
   intros [].
  change (Algebra theory A)...
 change (Algebra theory B)...
Qed.

#[global]
Instance decode_variety_and_ops `{InVariety theory A}: Setoid (A tt) := {}.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e255m19_11limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.omega.Omega.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.PropositionalLogic.Syntax.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.

Class PropositionalVariables: Type := {
  Var: Type
}.

Inductive expr {Sigma: PropositionalVariables}: Type :=
  | andp : expr -> expr -> expr
  | orp : expr -> expr -> expr
  | impp : expr -> expr -> expr
  | falsep : expr
  | varp : Var -> expr.

Arguments expr Sigma: clear implicits.

Instance L {Sigma: PropositionalVariables}: Language :=
  Build_Language (expr Sigma).

Instance minL {Sigma: PropositionalVariables}: MinimumLanguage L :=
  Build_MinimumLanguage L impp.

Instance pL {Sigma: PropositionalVariables}: PropositionalLanguage L :=
  Build_PropositionalLanguage L andp orp falsep.

Definition rank {Sigma: PropositionalVariables}: expr Sigma -> nat :=
  fix rank (x: expr Sigma): nat :=
    match x with
    | andp y z => 1 + rank y + rank z
    | orp y z => 1 + rank y + rank z
    | impp y z => 1 + rank y + rank z
    | falsep => 0
    | varp p => 0
    end.

Definition formula_countable: forall {Sigma}, Countable Var -> Countable (expr Sigma).
  intros.
  assert (forall n, Countable (sig (fun x: expr Sigma => rank x <= n))).
  + induction n.
    - apply (@bijection_Countable _ (Var + unit)%type); [| solve_Countable].
      apply bijection_sym.
      apply (FBuild_bijection _ _ (fun x =>
               match x with
               | inl p => exist (fun x: expr Sigma => rank x <= 0) (varp p) (le_n 0)
               | inr _ => exist (fun x: expr Sigma => rank x <= 0) falsep (le_n 0)
               end)).
      * hnf; intros.
        destruct a1 as [? | []], a2 as [? | []]; inversion H; auto.
      * hnf; intros.
        destruct b as [[] HH]; try solve [inversion HH].
        1: exists (inr tt); eauto; f_equal; apply proof_irrelevance.
        1: exists (inl v); eauto; f_equal; apply proof_irrelevance.
    - set (s := sig (fun x: expr Sigma => rank x <= n)).
      apply (@injection_Countable _ (s * s + s * s + s * s + unit + Var)%type); [| solve_Countable].

      apply (Build_injection _ _ (fun x y =>
        match y with
        | inl (inl (inl (inl (exist _ y _, exist _ z _)))) => proj1_sig x = andp y z
        | inl (inl (inl (inr (exist _ y _, exist _ z _)))) => proj1_sig x = orp y z
        | inl (inl (inr (exist _ y _, exist _ z _))) => proj1_sig x = impp y z
        | inl (inr _) => proj1_sig x = falsep
        | inr p => proj1_sig x = varp p
        end)).
      * hnf; intros.
        destruct a as [[y z | y z | y z | | p] ?H].
        (* 1 *) simpl in H. assert (rank y <= n) by omega. assert (rank z <= n) by omega.
                exists (inl (inl (inl (inl (exist _ y H0, exist _ z H1))))); auto.
        (* 2 *) simpl in H. assert (rank y <= n) by omega. assert (rank z <= n) by omega.
                exists (inl (inl (inl (inr (exist _ y H0, exist _ z H1))))); auto.
        (* 3 *) simpl in H. assert (rank y <= n) by omega. assert (rank z <= n) by omega.
                exists (inl (inl (inr (exist _ y H0, exist _ z H1)))); auto.
        (* 4 *) exists (inl (inr tt)); auto.
        (* 5 *) exists (inr p); auto.
      * hnf; intros.
        destruct a as [[y z | y z | y z | | p] ?H];
        destruct b1 as [[[[[[y1 ?H] [z1 ?H]] | [[y1 ?H] [z1 ?H]]] | [[y1 ?H] [z1 ?H]]] |] | p1]; try solve [inversion H];
        destruct b2 as [[[[[[y2 ?H] [z2 ?H]] | [[y2 ?H] [z2 ?H]]] | [[y2 ?H] [z2 ?H]]] |] | p2]; try solve [inversion H0].
        (* 1 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 2 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 3 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 4 *) destruct u, u0; auto.
        (* 5 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
      * hnf; intros.
        destruct b as [[[[[[y ?H] [z ?H]] | [[y ?H] [z ?H]]] | [[y ?H] [z ?H]]] |] | p];
        destruct a1 as [[y1 z1 | y1 z1 | y1 z1 | | p1] ?H]; try solve [inversion H];
        destruct a2 as [[y2 z2 | y2 z2 | y2 z2 | | p2] ?H]; try solve [inversion H0].
        (* 1 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 2 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 3 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 4 *) f_equal; apply proof_irrelevance.
        (* 5 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
  + apply (@injection_Countable _ (sigT (fun n => sig (fun x: expr Sigma => rank x <= n)))); [| solve_Countable; auto].
    apply (FBuild_injection _ _ (fun x0 => existT (fun n => sig (fun x => rank x <= n)) (rank x0) (exist (fun x => rank x <= rank x0) x0 (le_n (rank x0))))).
    hnf; intros.
    simpl in H.
    inversion H; auto.
Qed. (* 20 seconds *)