Require Import Arith Bool List.
From Utils Require Import Int Env Tactics IO.
From Src Require Import Tree.
Require Import FunInd Recdef.

Inductive value :=
| Lit (l: literal)
| Tuple (v1 v2: value)
| Left (v: value)
| Right (v: value)
| Fun (f: fnt) (e: env value).

#[global]
Hint Constructors value : evalₛ.

Section NF_v.
  Variable nf_v : value -> nat.

  Fixpoint nf_env env :=
    match env with
    | nil => 0
    | (n, v) :: env =>
        Nat.max (S n) (Nat.max (nf_v v) (nf_env env))
    end.
End NF_v.

Fixpoint next_freeᵥ (v : value) : nat :=
  match v with
  | Lit _ => 0
  | Tuple v1 v2 => Nat.max (next_freeᵥ v1) (next_freeᵥ v2)
  | Left v => next_freeᵥ v
  | Right v => next_freeᵥ v
  | Fun (Fnt fname farg fbody) env =>
      Nat.max (S fname) (Nat.max (S farg) (Nat.max (next_free fbody) (nf_env next_freeᵥ env)))
  end.

Definition next_free_env := nf_env next_freeᵥ.

Fixpoint value_eqb (v1 v2 : value) :=
  match v1, v2 with
  | Lit l1, Lit l2 => lit_eqb l1 l2
  | Tuple v1_1 v1_2, Tuple v2_1 v2_2 => value_eqb v1_1 v2_1 && value_eqb v1_2 v2_2
  | Left v1, Left v2 => value_eqb v1 v2
  | Right v1, Right v2 => value_eqb v1 v2
  | _, _ => false
  end.

Inductive result :=
| Rval (v: value) (* Intermediate result *)
| Rerr (* Type error *)
| Reoi (* End of Input *)
(* | Rhalt (n: int) (* End of program with Halt *) *)
| Rtimeout. (* Clock reached 0 *)

(* Definition is_timeout r :=
  match r with
  | Rtimeout => True
  | _ => False
  end.

Definition is_val r :=
  match r with
  | Rval _ => True
  | _ => False
  end.

Definition is_int_val r :=
  match r with
  | Rval (Lit (IntLit _)) => True
  | _ => False
  end.

Definition is_bool_val r :=
  match r with
  | Rval (Lit (BoolLit _)) => True
  | _ => False
  end.

Definition is_either_val r :=
  match r with
  | Rval (Left _) => True
  | Rval (Right _) => True
  | _ => False
  end.

Definition is_fun_val r :=
  match r with
  | Rval (Fun _ _) => True
  | _ => False
  end.

#[global]
Hint Unfold is_val is_int_val is_bool_val is_either_val is_fun_val is_timeout : eval. *)

(* Record state := mk_state {env: env value; input: list int; output: list int}.

Definition next_input (s: state) :=
  match input s with
  | h :: t => Some (h, mk_state (env s) t (output s))
  | Nil => None
  end.

Definition outputs (s: state) (o: int) :=
  mk_state (env s) (input s) (o :: output s).

Definition bind (s: state) (x: nat) (v: value) :=
  mk_state (Env.add (env s) x v) (input s) (output s). *)

Open Scope Z_scope.

Definition compute_binary_op op v1 v2 :=
  match op, v1, v2 with
  | Add, Lit (IntLit n1), Lit (IntLit n2) => Rval (Lit (IntLit (n1 + n2)))
  | Sub, Lit (IntLit n1), Lit (IntLit n2) => Rval (Lit (IntLit (n1 - n2)))
  | Mul, Lit (IntLit n1), Lit (IntLit n2) => Rval (Lit (IntLit (n1 * n2)))
  | Div, Lit (IntLit n1), Lit (IntLit 0) => Rerr
  | Div, Lit (IntLit n1), Lit (IntLit n2) => Rval (Lit (IntLit (n1 / n2)))
  | Mod, Lit (IntLit n1), Lit (IntLit 0) => Rerr
  | Mod, Lit (IntLit n1), Lit (IntLit n2) => Rval (Lit (IntLit (n1 mod n2)))
  | Lt, Lit (IntLit n1), Lit (IntLit n2) => Rval (Lit (BoolLit (n1 <? n2)))
  | Le, Lit (IntLit n1), Lit (IntLit n2) => Rval (Lit (BoolLit (n1 <=? n2)))
  | Eq, v1, v2 => Rval (Lit (BoolLit (value_eqb v1 v2)))
  | Or, Lit (BoolLit b1), Lit (BoolLit b2) => Rval (Lit (BoolLit (b1 || b2)))
  | And, Lit (BoolLit b1), Lit (BoolLit b2) => Rval (Lit (BoolLit (b1 && b2)))
  | Tup, v1, v2 => Rval (Tuple v1 v2)
  | _, _, _ => Rerr
  end.

Definition compute_unary_op op v :=
  match op, v with
  | Neg, Lit (IntLit n) => Rval (Lit (IntLit (-n)))
  | Not, Lit (BoolLit b) => Rval (Lit (BoolLit (negb b)))
  | Fst, Tuple v1 _ => Rval v1
  | Snd, Tuple _ v2 => Rval v2
  | Primitive.Left, v => Rval (Left v)
  | Primitive.Right, v => Rval (Right v)
  | Id, v => Rval v
  | _, _ => Rerr
  end.

Close Scope Z_scope.

Definition clock_term_r (a1 a2 : nat * term) :=
  match a1, a2 with
  | (c1, t1), (c2, t2) => c1 < c2 \/ size t1 < size t2
  end.

(* Fixpoint evalₛ' (clock : nat) (e : env value) (t : term) (io : IO) {struct clock} : result * IO :=
  let fix eval_aux (env : env value) (t : term) (io : IO) {struct t} : result * IO :=
    match t with
    | Var n =>
        match env ? n with
        | Some v => (Rval v, io)
        | None => (Rerr, io)
        end
    | Const l => (Rval (Lit l), io)
    | Let n t r =>
        match eval_aux env t io with
        | (Rval v, io) => eval_aux (env + (n, v)) t io
        | (r, io) => (r, io)
        end
    | LetRec (Fnt n a b) r =>
        eval_aux (env + (n, Fun (Fnt n a b) env)) r io
    | App f t =>
        match eval_aux env f io with
        | (Rval (Fun (Fnt n a b) Γ), io) =>
            match eval_aux env t io with
            | (Rval v, io) =>
                match clock with
                | 0 => (Rtimeout, io)
                | S clock =>
                    evalₛ' clock (Γ + (n, Fun (Fnt n a b) Γ) + (a, v)) b io
                end
            | (r, io) => (r, io)
            end
        | (Rval _, io) => (Rerr, io)
        | (r, io) => (r, io)
        end
    | In =>
        match get_input io with
        | Some (i, io) => (Rval (Lit (IntLit i)), io)
        | None => (Reoi, io)
        end
    | Out t =>
        match eval_aux env t io with
        | (Rval (Lit (IntLit o)), io) => (Rval (Lit UnitLit), outputs io o)
        | (Rval _ , io) => (Rerr, io)
        | (r, io) => (r, io)
        end
    | Ite c t e =>
        match eval_aux env c io with
        | (Rval (Lit (BoolLit true)), io) =>
            eval_aux env t io
        | (Rval (Lit (BoolLit false)), io) =>
            eval_aux env e io
        | (Rval _, io) => (Rerr, io)
        | (r, io) => (r, io)
        end
    | BinaryOp op t1 t2 =>
        match eval_aux env t1 io with
        | (Rval v1, io) =>
            match eval_aux env t2 io with
            | (Rval v2, io) => (compute_binary_op op v1 v2, io)
            | (r, io) => (r, io)
            end
        | (r, io) => (r, io)
        end
    | UnaryOp op t =>
        match eval_aux env t io with
        | (Rval v, io) => (compute_unary_op op v, io)
        | (r, io) => (r, io)
        end
    | Match s (ln, lt) (rn, rt) =>
        match eval_aux env s io with
        | (Rval (Left v), io) =>
            eval_aux (env + (ln, v)) lt io
        | (Rval (Right v), io) =>
            eval_aux (env + (rn, v)) rt io
        | (Rval _, io) => (Rerr, io)
        | (r, io) => (r, io)
        end
    end
  in eval_aux e t io. *)

Fixpoint evalₛ (fuel : nat) (env : env value) (t : term) (io : IO) {struct fuel} : result * IO * nat :=
  match fuel with
  | 0 => (Rtimeout, io, 0)
  | S fuel =>
    match t with
    | Var n =>
      match lookup env n with
      | None => (Rerr, io, fuel)
      | Some v => (Rval v, io, fuel)
      end
    | Const l => (Rval (Lit l), io, fuel)
    | Let x t rest =>
        let '(r, io, f1) := evalₛ fuel env t io in
        match r with
        | Rval v =>
            let '(r, io, f2) := evalₛ fuel (env + (x, v)) rest io in
              (r, io, Nat.min f1 f2)
        | _ => (r, io, f1)
        end
    | LetRec (Fnt fname farg fbody) rest =>
        let f := Fnt fname farg fbody in
        evalₛ fuel (env + (fname, Fun f env)) rest io
    | App f t =>
        let '(r, io, f1) := evalₛ fuel env f io in
        match r with
        | Rval (Fun (Fnt fname farg fbody) fenv) =>
            let '(r, io, f2) := evalₛ fuel env t io in
            match r with
            | Rval v =>
                let f := Fnt fname farg fbody in
                let '(r, io, f3) := evalₛ fuel (env + (fname, Fun f fenv) + (farg, v)) fbody io in
                  (r, io, Nat.min f1 (Nat.min f2 f3))
            | _ => (r, io, Nat.min f1 f2)
            end
        | Rval _ => (Rerr, io, f1)
        | _ => (r, io, f1)
        end
    | In =>
        match get_input io with
        | None => (Reoi, io, fuel)
        | Some (i, io) => (Rval (Lit (IntLit i)), io, fuel)
        end
    | Out t =>
        let '(r, io, f') := evalₛ fuel env t io in
        match r with
        | Rval (Lit (IntLit o)) => (Rval (Lit UnitLit), outputs io o, f')
        | Rval _ => (Rerr, io, f')
        | _ => (r, io, f')
        end
    | Ite c t e =>
        let '(r, io, f1) := evalₛ fuel env c io in
        match r with
        | Rval (Lit (BoolLit true)) =>
            let '(r, io, f2) := evalₛ fuel env t io in
              (r, io, Nat.min f1 f2)
        | Rval (Lit (BoolLit false)) =>
            let '(r, io, f2) := evalₛ fuel env e io in
              (r, io, Nat.min f1 f2)
        | Rval _ => (Rerr, io, f1)
        | _ => (r, io, f1)
        end
    | BinaryOp op t1 t2 =>
        let '(r, io, f1) := evalₛ fuel env t1 io in
        match r with
        | Rval v1 =>
            let '(r, io, f2) := evalₛ fuel env t2 io in
            match r with
            | Rval v2 => (compute_binary_op op v1 v2, io, Nat.min f1 f2)
            | _ => (r, io, Nat.min f1 f2)
            end
        | _ => (r, io, f1)
        end
    | UnaryOp op t =>
        let '(r, io, f') := evalₛ fuel env t io in
        match r with
        | Rval v => (compute_unary_op op v, io, f')
        | _ => (r, io, f')
        end
    | Match s (ln, lt) (rn, rt) =>
        let '(r, io, f1) := evalₛ fuel env s io in
        match r with
        | Rval (Left v) =>
            let '(r, io, f2) := evalₛ fuel (env + (ln, v)) lt io in
              (r, io, Nat.min f1 f2)
        | Rval (Right v) =>
            let '(r, io, f2) := evalₛ fuel (env + (rn, v)) rt io in
              (r, io, Nat.min f1 f2)
        | Rval _ => (Rerr, io, f1)
        | _ => (r, io, f1)
        end
    end
  end.

Fact S_sub : forall n, S n - n = 1.
  lia. Qed.

Fact sub_0 : forall n, n - 0 = n.
  lia. Qed.

Fact S_sub' : forall n m, m <= n -> S n - m = S (n - m).
  lia. Qed.

Opaque Nat.sub.

Lemma eval_fuel : forall f e t io r io' f',
  evalₛ f e t io = (r, io', f') -> f' <= f.
Proof.
  induction f; reduce.
  destruct t;
  repeat reduce || destruct_match
    || apply_anywhere IHf; lia.
Qed.

Ltac inst_IH :=
  match goal with
  | IH : forall _ _ _ _ _ _, evalₛ _ _ _ _ = (_, _, _) ->
          forall _, _ <= _ -> evalₛ _ _ _ _ = (_, _, _),
    H : evalₛ _ _ _ _ = (_, _, _),
    A : ?f3 <= _ |- _ =>
      unshelve epose proof (IH _ _ _ _ _ _ H f3 _); try lia;
      apply eval_fuel in H
  end.

Theorem eval_min_fuel : forall f1 e t io r io' f2,
    evalₛ f1 e t io = (r, io', f2) -> forall f3, f3 <= f2 ->
      evalₛ (f1 - f3) e t io = (r, io', f2 - f3).
Proof.
  induction f1; reduce.
  destruct t; reduce; try solve [
    repeat reduce || destruct_match || inst_IH;
    rewrite S_sub'; reduce;
    repeat rewrite_any; auto with lia
  ].
Qed.

(* Reserved Notation "'{' io1 '|' Γ '}' t '~>(' f ')' '{' r ',' io2 '}'" (at level 70, no associativity).
Inductive eval : env value -> term -> IO -> nat -> result -> IO -> Prop :=
| eval_var : forall env n v io,
    env ? n = Some v ->
      { io | env } Var n ~>(1) { Rval v, io }
| eval_var_err : forall env n io,
    env ? n = None ->
      { io | env } Var n ~>(1) { Rerr, io }
| eval_const : forall env l io,
      { io | env } Const l ~>(1) { Rval (Lit l), io }
| eval_let : forall env io n t v f io' t' f' r io'',
    { io | env } t ~>(f) { Rval v, io' } ->
    { io' | env + (n, v) } t' ~>(f') { r, io'' } ->
      { io | env } Let n t t' ~>(f + f' + 1) { r, io'' }
| eval_let_err : forall env io n t t' f r io',
    ~ (is_val r) ->
    { io | env } t ~>(f) { r, io' } ->
      { io | env } Let n t t' ~>(f + 1) { r, io' }
| eval_letrec : forall env io fname farg fbody f t io' r,
    let fnt := Fnt fname farg fbody in
    { io | env + (fname, Fun fnt env) } t ~>(f) { r, io' } ->
      { io | env } LetRec fnt t ~>(f + 1) { r, io' }
| eval_app : forall env e1 e2 f1 f2 f3 io0 io1 io2 io3 fname farg fbody fenv v r,
    let f := (Fun (Fnt fname farg fbody) fenv) in
    { io0 | env } e1 ~>(f1) { Rval f, io1 } ->
    { io1 | env } e2 ~>(f2) { Rval v, io2 } ->
    { io2 | fenv + (farg, v) + (fname, f) } fbody ~>(f3) { r, io3 } ->
      { io0 | env } App e1 e2 ~>(f1 + f2 + f3 + 1) { r, io3 }
| eval_app_err : forall env e1 e2 f io io' r,
    ~ (is_val r) ->
    { io | env } e1 ~>(f) { r, io' } ->
      { io | env } App e1 e2 ~>(f + 1) { r, io' }
| eval_app_err' : forall env e1 e2 f io io' r,
    is_val r -> ~ (is_fun_val r) ->
    { io | env } e1 ~>(f) { r, io' } ->
      { io | env } App e1 e2 ~>(f + 1) { Rerr, io' }
| eval_app_err'' : forall env e1 e2 f1 f2 fname farg fbody fenv io0 io1 io2 r,
    let f := (Fun (Fnt fname farg fbody) fenv) in
    ~ (is_val r) ->
    { io0 | env } e1 ~>(f1) { Rval f, io1 } ->
    { io1 | env } e2 ~>(f2) { r, io2} ->
      { io0 | env } App e1 e2 ~>(f1 + f2 + 1) { r, io2 }
| eval_in : forall env i is os,
      { {|input := i::is; output := os|} | env } In ~>(1) { Rval (Lit (IntLit i)), {|input := is; output := os|} }
| eval_in_err : forall env os,
      { {|input := nil; output := os|} | env } In ~>(1) { Reoi, {|input := nil; output := os|} }
| eval_out : forall env t f io is o os,
    { io | env } t ~>(f) { Rval (Lit (IntLit o)), {|input := is; output := os|} } ->
      { io | env } Out t ~>(f + 1) { Rval (Lit UnitLit), {|input := is; output := o::os|} }
| eval_out_err : forall env t f io r io',
    ~ (is_val r) ->
    { io | env } t ~>(f) { r, io' } ->
      { io | env } Out t ~>(f + 1) { r, io' }
| eval_out_err' : forall env t f io r io',
    is_val r -> ~ (is_int_val r) ->
    { io | env } t ~>(f) { r, io' } ->
      { io | env } Out t ~>(f + 1) { Rerr, io' }
| eval_ite_true : forall env cond thent elset f f' io io' r io'',
    { io | env } cond ~>(f) { Rval (Lit (BoolLit true)), io' } ->
    { io' | env } thent ~>(f') { r, io'' } ->
      { io | env } Ite cond thent elset ~>(f + f' + 1) { r, io'' }
| eval_ite_false : forall env cond thent elset f f' io io' r io'',
    { io | env } cond ~>(f) { Rval (Lit (BoolLit false)),  io' } ->
    { io' | env } elset ~>(f') { r, io'' } ->
      { io | env } Ite cond thent elset ~>(f + f' + 1) { r, io'' }
| eval_ite_err : forall env cond thent elset f io r io',
    ~ (is_val r) ->
    { io | env } cond ~>(f) { r, io' } ->
      { io | env } Ite cond thent elset ~>(f + 1) { r, io' }
| eval_ite_err' : forall env cond thent elset f io r io',
    is_val r -> ~ (is_bool_val r) ->
    { io | env } cond ~>(f) { r, io' } ->
      { io | env } Ite cond thent elset ~>(f + 1) { Rerr, io' }
| eval_match_left : forall env scrut n lt rcase v f io io' f' r io'',
    { io | env } scrut ~>(f) { Rval (Left v), io' } ->
    { io' | env + (n, v) } lt ~>(f') { r, io'' } ->
      { io | env } Match scrut (n, lt) rcase ~>(f + f' + 1) { r, io'' }
| eval_match_right : forall env scrut n lcase rt v f io io' f' r io'',
    { io | env } scrut ~>(f) { Rval (Right v), io' } ->
    { io' | env + (n, v) } rt ~>(f') { r, io'' } ->
      { io | env } Match scrut lcase (n, rt) ~>(f + f' + 1) { r, io'' }
| eval_match_err : forall env scrut lcase rcase f r io io',
    ~ (is_val r) ->
    { io | env } scrut ~>(f) { r, io' } ->
      { io | env } Match scrut lcase rcase ~>(f + 1) { r, io' }
| eval_match_err' : forall env scrut lcase rcase f r io io',
    is_val r -> ~ (is_either_val r) ->
    { io | env } scrut ~>(f) { r, io' } ->
      { io | env } Match scrut lcase rcase ~>(f + 1) { Rerr, io' }
| eval_binop : forall env op t1 t2 v1 v2 f1 f2 io io' io'',
    { io | env } t1 ~>(f1) { Rval v1, io' } ->
    { io' | env } t2 ~>(f2) { Rval v2, io'' } ->
      { io | env } BinaryOp op t1 t2 ~>(f1 + f2 + 1) { compute_binary_op op v1 v2, io'' }
| eval_binop_err : forall env op t1 t2 r1 f1 io io',
    ~ (is_val r1) ->
    { io | env } t1 ~>(f1) { r1, io' } ->
      { io | env } BinaryOp op t1 t2 ~>(f1 + 1) { r1, io' }
| eval_binop_err' : forall env op t1 t2 v1 r2 f1 f2 io io' io'',
    { io | env } t1 ~>(f1) { Rval v1, io' } ->
    ~ (is_val r2) ->
    { io' | env } t2 ~>(f2) { r2, io'' } ->
      { io | env } BinaryOp op t1 t2 ~>(f1 + f2 + 1) { r2, io'' }
| eval_unary : forall env op t v f io io',
    { io | env } t ~>(f) { Rval v, io' } ->
      { io | env } UnaryOp op t ~>(f + 1) { compute_unary_op op v, io' }
| eval_unary_err : forall env op t r f io io',
    ~ (is_val r) ->
    { io | env } t ~>(f) { r, io' } ->
      { io | env } UnaryOp op t ~>(f + 1) { r, io' }
| eval_timeout : forall env t io,
    { io | env } t ~>(0) { Rtimeout, io }
| eval_extra_fuel : forall env t f io io' r,
    ~ (is_timeout r) ->
    { io | env } t ~>(f) { r, io' } ->
      { io | env } t ~>(f + 1) { r, io' }
where "'{' io1 '|' Γ '}' t '~>(' f ')' '{' r ',' io2 '}'" := (eval Γ t io1 f r io2).

#[global]
Hint Constructors eval : eval.

Definition diverge t := forall env io f io',
  eval env t io f Rtimeout io'.

Ltac destruct_fuel :=
  match goal with
  | [|- context[eval _ _ _ ?f _ _]] =>
    let e := fresh "E" in
    destruct f; eauto with eval;
    assert (e: S f = f + 1) by lia;
    rewrite e in *; clear e
  end.

Ltac solve_eval_min_fuel :=
  match goal with
  | IH: forall _, _ < ?f -> exists _, eval _ _ _ _ _ _,
    l : _ < ?f |- _ =>
      specialize (IH _ l) as [? ?];
      eauto with eval
  | IH: forall _, _ < ?f1 -> exists _, eval _ _ _ _ _ _,
    _ :  ?f < ?f1 + ?f2 |- _ =>
      let l := fresh "l" in
      let r := fresh "r" in
      destruct (lt_dec f f1) as [l | r]; [
      specialize (IH _ l) as [? ?];
      eauto with eval | idtac ]
  | IH: forall _, _ < ?f1 -> exists _, eval _ _ _ _ _ _,
    _ :  ?f < ?f1 + ?f2 + ?f3 |- _ =>
      let l := fresh "l" in
      let r := fresh "r" in
      destruct (lt_dec f f1) as [l | r]; [
      specialize (IH _ l) as [? ?];
      eauto with eval | idtac ]
  end.

Ltac instantiate_eval_min_fuel_IH :=
  match goal with
  | IH: ~ is_timeout _ -> exists f_min, eval _ _ _ f_min _ _ /\ _ |- _ =>
      let f_min := fresh "f_min" in
      unshelve epose proof IH _ as [f_min [? ?]]; auto;
      clear IH
  end.

Ltac find_min_fuel :=
  match goal with
  | IH1: forall _, _ < ?f_min1 -> _,
    IH2: forall _, _ < ?f_min2 -> _,
    IH3: forall _, _ < ?f_min3 -> _ |- _ =>
      (
        exists (f_min1 + f_min2 + f_min3 + 1); split;
        [eauto with eval; fail | idtac]
      ) || (
        exists (f_min1 + f_min3 + f_min2 + 1); split;
        [eauto with eval; fail | idtac]
      ) || (
        exists (f_min2 + f_min1 + f_min3 + 1); split;
        [eauto with eval; fail | idtac]
      ) || (
        exists (f_min2 + f_min3 + f_min1 + 1); split;
        [eauto with eval; fail | idtac]
      ) || (
        exists (f_min3 + f_min1 + f_min2 + 1); split;
        [eauto with eval; fail | idtac]
      ) || (
        exists (f_min3 + f_min2 + f_min1 + 1); split;
        [eauto with eval; fail | idtac]
      )
  | IH1: forall _, _ < ?f_min1 -> _,
    IH2: forall _, _ < ?f_min2 -> _ |- _ =>
      (
        exists (f_min1 + f_min2 + 1); split;
        [eauto with eval; fail | idtac]
      ) || (
        exists (f_min2 + f_min1 + 1); split;
        [eauto with eval; fail | idtac]
      )
  | IH: forall _, _ < ?f_min -> _ |- _ =>
      exists (f_min + 1); split;
      eauto with eval
  | |- _ =>
      exists 1; split; eauto with eval
  end.

Lemma eval_min_fuel: forall t env io f r io',
  ~ (is_timeout r) ->
  eval env t io f r io' ->
  exists f_min, eval env t io f_min r io' /\
  (forall f', f' < f_min ->
    exists io'', eval env t io f' Rtimeout io'').
Proof.
  intros t env io f r io' HR;
  induction 1; subst_all;
  repeat instantiate_eval_min_fuel_IH;
  try solve [
    find_min_fuel; intros;
    destruct_fuel;
    repeat simpl_lia || solve_eval_min_fuel
  ]; try solve [
    destruct r; eauto with eval
  ].
  unfold is_timeout in HR; auto with exfalso.
Qed.

Ltac rewrite_S_fuel :=
  match goal with
  | |- eval _ _ _ (S ?n) _ _ =>
      rewrite_S n
  end.

Lemma eval_min_fuel': forall f f' env t io r io',
  ~ (is_timeout r) ->
  eval env t io f r io' ->
    f <= f' -> eval env t io f' r io'.
Proof.
  induction 3; try rewrite_S_fuel; auto with eval.
Qed.

Ltac instantiate_eval_min_fuel t :=
  match goal with
  | H: eval _ t _ ?f (Rval _) _ |- _ =>
      let f_min := fresh "f_min" in
      let H_eval := fresh "H_eval" in
      let H' := fresh "H" in
      unshelve epose proof eval_min_fuel _ _ _ _ _ _ _ H as [f_min [H_eval H']];
      auto with eval; clear H;
      let l := fresh "l" in
      let r := fresh "r" in
      destruct (lt_dec f f_min) as [l | r];
      [
        let io := fresh "io" in
        apply (H' _) in l as [io ?];
        exists Rtimeout, io; eauto with eval | repeat simpl_lia; clear H'
      ]
  end.

#[global]
Hint Resolve eval_min_fuel eval_min_fuel': eval.

Ltac solve_error_cases :=
  match goal with
  | H: eval _ _ _ _ ?r ?io' |- _ =>
      exists r, io'; eauto with eval
  end.

Ltac instantiate_eval_total_ind_IH env t io f :=
  match goal with
  | IH: forall f' t env io, f' < _ -> exists r io', eval env t io f' r io' |- _ =>
      let r := fresh "r" in
      let io' := fresh "io" in
      unshelve epose proof IH f t env io _ as [r [io' ?]]; subst;
      eauto with eval lia; destruct r; try solve [solve_error_cases]
  end.

Lemma eval_total_ind: forall f f' t env io, f' < f -> exists r io',
  eval env t io f' r io'.
Proof.
  induction f; try lia; try simpl_lia.
  destruct t0; intros;
  destruct_fuel; simpl_lia.
  - (* Var n *)
    destruct (lookup env n) eqn:E;
    [exists (Rval v) | exists Rerr];
    eauto with eval lia.
  - (* Const l *)
    exists (Rval (Lit l)); eauto with eval lia.
  - (* Let *)
    instantiate_eval_total_ind_IH env t0_1 io f'.
    instantiate_eval_min_fuel t0_1.
    instantiate_eval_total_ind_IH (Env.add env x v) t0_2 io0 f'0.
  - (* LetRec *)
    destruct f0 eqn:F.
    instantiate_eval_total_ind_IH (Env.add env fname (Fun f0 env)) t0 io f'.
  - (* App *)
    instantiate_eval_total_ind_IH env t0_1 io f'.
    destruct v;
    try solve [
      (* Solve not Fnttion cases *)
      exists Rerr, io0;
      eapply eval_app_err'; eauto with eval;
      autounfold with eval; auto
    ].
    destruct f0 eqn:F.
    instantiate_eval_min_fuel t0_1.
    instantiate_eval_total_ind_IH env t0_2 io0 f'0.
    instantiate_eval_min_fuel t0_2.
    instantiate_eval_total_ind_IH (Env.add (Env.add e arg v) fname (Fun (Fnt fname arg body) e)) body io1 f'1.
  - (* In *)
    destruct io eqn:E.
    destruct input;
    [exists Reoi | exists (Rval (Lit (IntLit z)))];
    eauto with eval lia.
  - (* Out *)
    instantiate_eval_total_ind_IH env t0 io f'.
    destruct v;
    try solve [
      (* Solve not literal cases *)
      exists Rerr, io0;
      eapply eval_out_err'; eauto with eval;
      autounfold with eval; auto
    ].
    destruct l;
    try solve [
      (* Solve not integer literal cases *)
      exists Rerr, io0;
      eapply eval_out_err'; eauto with eval;
      autounfold with eval; auto
    ].
    destruct io0.
    exists (Rval (Lit UnitLit));
    eauto with eval.
  - (* Ite *)
    instantiate_eval_total_ind_IH env t0_1 io f'.
    destruct v;
    try solve [
      (* Solve not literal cases *)
      exists Rerr, io0;
      eapply eval_ite_err'; eauto with eval;
      autounfold with eval; auto
    ].
    destruct l;
    try solve [
      (* Solve not boolean literal cases *)
      exists Rerr, io0;
      eapply eval_ite_err'; eauto with eval;
      autounfold with eval; auto
    ].
    instantiate_eval_min_fuel t0_1.
    destruct b.
    + instantiate_eval_total_ind_IH env t0_2 io0 f'0.
    + instantiate_eval_total_ind_IH env t0_3 io0 f'0.
  - (* Binary primitives *)
    instantiate_eval_total_ind_IH env t0_1 io f'.
    instantiate_eval_min_fuel t0_1.
    instantiate_eval_total_ind_IH env t0_2 io0 f'0.
    eauto with eval.
  - (* Unary primitives *)
    instantiate_eval_total_ind_IH env t0 io f'.
    eauto with eval.
  - (* Match *)
    instantiate_eval_total_ind_IH env t0 io f'.
    destruct v;
    try solve [
      (* Solve not either cases *)
      exists Rerr, io0;
      eapply eval_match_err'; eauto with eval;
      autounfold with eval; auto
    ];
    instantiate_eval_min_fuel t0.
    + (* Left *)
      destruct lcase eqn:L.
      instantiate_eval_total_ind_IH (Env.add env n v) t1 io0 f'0.
    + (* Right *)
      destruct rcase eqn:R.
      instantiate_eval_total_ind_IH (Env.add env n v) t1 io0 f'0.
Qed.

Theorem eval_total: forall t env io f,
  exists r io', eval env t io f r io'.
Proof.
  eauto using eval_total_ind.
Qed. *)


Load loadpath.
Require Import ZArith Coq.Lists.List Permutation.
Require Import VST.msl.Axioms msl.Coqlib2.
Require Import VST.msl.predicates_sa.
Require Import veristar.datatypes veristar.clauses
               veristar.list_denote veristar.heapresolve
               veristar.model_type veristar.model veristar.compare.
Require Import veristar.superpose.

(* clause lemmas
   -Interpretation of clauses under reordering, etc. *)

Module Type CL_SOUND.

Declare Module VSM : VERISTAR_MODEL. Import VSM VeriStarLogic.

Axiom order_eqv_sound : forall a,
  pure_atom_denote a = pure_atom_denote (order_eqv_pure_atom a).

Axiom order_eqv_clause_sound : forall c s,
  clause_denote (order_eqv_clause c) s <-> clause_denote c s.

Axiom clause_setd_listd : forall l b s,
  listd clause_denote inter b l s ->
  setd clause_denote inter b (clause_list2set l) s.

Axiom rev_cmp_eq : forall {A:Type} (f : A -> A -> comparison) (a1 a2 : A),
  Eq = rev_cmp f a1 a2 -> rev_cmp f a1 a2 = f a1 a2.

Axiom in_sort_uniq : forall c l,
  In c (rsort_uniq (rev_cmp compare_clause) l) -> In c l.

End CL_SOUND.

Module CL_Sound (VSM : VERISTAR_MODEL) : CL_SOUND with Module VSM := VSM.
Module VSM := VSM.
Import VSM VeriStarLogic.

Import sepalg.

Lemma order_eqv_sound a :
  pure_atom_denote a = pure_atom_denote (order_eqv_pure_atom a).
Proof.
intros; destruct a; unfold pure_atom_denote in *; simpl in *.
remember (expr_cmp e e0) as b; destruct b; auto; apply var_eq_sym'.
Qed.

Lemma list_denote_intersection_filter_nonreflex (B: spred) (l: list pure_atom) :
  listd pure_atom_denote inter B l =
  listd pure_atom_denote inter B (filter nonreflex_atom l).
Proof with simpl; auto.
intros; induction l... rewrite IHl; clear IHl.
remember (nonreflex_atom a) as b; destruct b...
destruct a; simpl in *.
assert (expr_cmp e e0 = Eq).
  remember (expr_cmp e e0) as b; destruct b; try reflexivity.
  inversion Heqb. inversion Heqb. clear Heqb.
symmetry in H; apply comp_eq in H; auto. rewrite H.
extensionality s; apply prop_ext; split; simpl; auto.
intros [H1 H2]; auto. split; auto. apply var_eq_refl.
Qed.

Lemma list_denote_normalize_pure_atoms :
  forall Q (B:spred) (l:list pure_atom)
     (Qassoc: forall x y z , Q x (Q y z) = Q (Q x y) z)
     (Qsymm: forall x y, Q x y = Q y x)
     (Hcmp: forall x y, Eq = pure_atom_cmp x y ->
       (forall P, Q (pure_atom_denote x) (Q (pure_atom_denote y) P) =
                  Q (pure_atom_denote y) P)),
  list_denote pure_atom_denote Q B l =
  list_denote pure_atom_denote Q B (normalize_atoms l).
Proof with simpl; auto.
intros; unfold normalize_atoms; rewrite listd_sort_uniq...
induction l... rewrite <-order_eqv_sound, <-IHl...
Qed.

Lemma list_denote_intersection_normalize_pure_atoms B l :
  list_denote pure_atom_denote inter B l =
  list_denote pure_atom_denote inter B (normalize_atoms l).
Proof.
intros; apply list_denote_normalize_pure_atoms.
intros. rewrite andp_assoc; trivial.
intros. rewrite andp_comm; trivial.
intros. rewrite <- pure_atom_cmp_eq in H. rewrite H.
rewrite interA. extensionality s; apply prop_ext.
split; intros H1. destruct H1 as [[H1 H2] H3]; split; auto.
destruct H1; split; auto. split; auto.
Qed.

Lemma list_denote_union_normalize_pure_atoms B l :
  list_denote pure_atom_denote un B l =
  list_denote pure_atom_denote un B (normalize_atoms l).
Proof.
intros.
apply list_denote_normalize_pure_atoms.
intros. rewrite union_assoc; trivial.
intros. rewrite union_com; trivial.
intros. rewrite <- pure_atom_cmp_eq in H. rewrite H.
rewrite <- union_assoc.
extensionality s; apply prop_ext; split; intros.
inversion H0. inversion H1; left; auto.
right; auto. inversion H0. left; left; auto. right; auto.
Qed.

Lemma list_denote_normalize_filter_nonreflex_atom B l :
  list_denote pure_atom_denote inter B
      (normalize_atoms (filter nonreflex_atom l)) =
  list_denote pure_atom_denote inter B l.
Proof.
intros; rewrite <- list_denote_intersection_normalize_pure_atoms.
rewrite <- list_denote_intersection_filter_nonreflex; auto.
Qed.

Lemma order_eqv_clause_sound c s :
  clause_denote (order_eqv_clause c) s <-> clause_denote c s.
Proof.
intros. destruct c; simpl;
  rewrite list_denote_normalize_filter_nonreflex_atom;
    rewrite <- list_denote_union_normalize_pure_atoms;
      apply iff_refl.
Qed.

(* todo: make the following lems more general *)

Lemma clause_setd_listd l b s :
  listd clause_denote inter b l s ->
  setd clause_denote inter b (clause_list2set l) s.
Proof with simpl; auto; try solve[congruence].
intro H1. apply setd_fold_left...
intros c cls s0 H2 H3. apply setd_add...
unfold setd; rewrite empty_set_elems...
rewrite (@listd_unfold_inter clause state) in H1.
destruct H1; auto.
Qed.

Lemma rev_cmp_eq {A:Type} (f : A -> A -> comparison) (a1 a2 : A) :
  Eq = rev_cmp f a1 a2 -> rev_cmp f a1 a2 = f a1 a2.
Proof with auto; try congruence.
unfold rev_cmp; destruct (f a1 a2)...
Qed.

Lemma in_insert_uniq c c' l :
  In c (insert_uniq (rev_cmp compare_clause) c' l) ->
  c' = c \/ In c l.
Proof with simpl; auto; try solve[congruence].
induction l...
remember (rev_cmp compare_clause c' a) as b; destruct b...
inversion 1; subst... cut (c' = c \/ In c l)... inversion 1...
Qed.

Lemma compare_clause_refl d : Eq = rev_cmp compare_clause d d.
Proof with simpl; auto.
unfold rev_cmp. rewrite comp_refl; auto.
Qed.

Lemma in_sort_uniq c l :
  In c (rsort_uniq (rev_cmp compare_clause) l) -> In c l.
Proof with simpl; auto; try solve[congruence].
induction l... intro H1.
generalize compare_clause_refl as H2; intros.
remember (rev_cmp compare_clause a c) as b; destruct b.
generalize Heqb; apply rev_cmp_eq in Heqb; rewrite Heqb.  intro Hx; apply comp_eq in Hx; auto.
right; apply IHl. generalize (in_insert_uniq _ _ _ H1) as H3.
inversion 1; subst...
right; apply IHl. generalize (in_insert_uniq _ _ _ H1) as H3.
inversion 1; subst...
Qed.

End CL_Sound.

(* some general lemmas about positives: not sure where to put these so they go
   here for now *)

Lemma positive_base_case: forall n, 0 = nat_of_P n - 1 -> n=1%positive.
Proof. intros. generalize (lt_O_nat_of_P n); intro.
 assert (nat_of_P n = 1) by omega.
 assert (nat_of_P 1%positive = 1) by reflexivity.
 rewrite <- H2 in H1.
 generalize (nat_of_P_inj n 1 H1); intro; subst n; auto.
Qed.


(*Krivine Abstract Machine - Third Part*)

(*Syntax*)

Inductive inst :=
| Access: nat -> inst
| Grab: inst
| Push: code -> inst
with code: Type :=
| cnil:   code
| cCons:  inst -> code -> code.

Inductive environment : Type :=
| nul: environment
| cons: code -> environment -> environment -> environment.

Definition state := prod (prod code environment) environment.

(*Semantics*)

Definition exec_inst (s: state): state:=
  match s with
    | (cCons (Access 0) c, cons c0 e0 e, stack) => (c0, e0, stack)
    | (cCons (Access n) c, cons c0 e0 e, stack) => (cCons (Access (n-1)) c, e, stack)
    | (cCons (Push c) c0, e, stack) => (c0, e, cons c e stack)
    | (cCons Grab c, e, cons  c0 e0 stack) => (c, cons c0 e0 e, stack)
    | s => s
  end.

(*Executing several times the code*)
Inductive mult_exec_inst : state -> state -> Prop :=
  | zero_step : forall s : state, mult_exec_inst s s
  | iPlus_step: forall s1 s2: state, mult_exec_inst (exec_inst s1) s2 -> mult_exec_inst s1 s2.


Require Import Reductions.MPCP_PCP.
From Undecidability.PCP Require Import SRH_SR.

Definition red := (fun '(R, x, a) => (P R x a, x, [a])).

Instance computable_Sigma : computable Sigma.
Proof.
  extract.
Defined.

Definition card1 (a0 : symbol) := (fun a => [a; a0] / [a0]).
Definition card2 (a0 : symbol) := (fun a => [a0; a] / [a0]).

Instance internalize_card1 : computable card1.
Proof.
  extract.
Defined.

Instance internalize_card2 : computable card2.
Proof.
  extract.
Defined.

Instance internalize_P : computable P.
Proof.
  change P with
      (fun (R : SRS) (x0 : Definitions.string) (a0 : symbol) =>
         R ++
           map (card1 a0) (a0 :: x0 ++ sym R) ++ map (card2 a0) (a0 :: x0 ++ sym R)).
  extract.
Defined.

Instance internalize_red : computable red.
Proof.
  extract.
Defined.


Set Implicit Arguments.

Require Import String.
Require Import ZArith.

Require Import domains.
Require Import kstyle.
Require Import coinduction.
Require Import evaluator.

Coercion EVar : string >-> Exp.
Coercion ECon : Z >-> Exp.

Function evals n kcfg :=
  match n with
    | 0 => kcfg
    | S n =>
      match eval kcfg with
      | Some kcfg' => evals n kcfg'
      | None => kcfg
     end
  end.

Lemma evals_sound :
  forall n c (P : kcfg -> Prop), P (evals n c) -> reaches c P.
Proof.
induction n; simpl; intros;
[|pose proof (eval_sound c); destruct (eval c)];
eauto using done,step.
Qed.

Lemma eval_happy' : forall env,
  steps (KCfg (kra (SAssign "x" (EPlus "x" "y")) nil)
            ("x" |-> 12%Z :* "y" |-> 13%Z :* env) mapEmpty mapEmpty)
        (KCfg nil ("x" |-> 25%Z :* "y" |-> 13%Z :* env) mapEmpty mapEmpty).
intros.
repeat (refine (step _ _);[match goal with [|- kstep ?l _] => eapply (eval_sound l) end|]);
instantiate;simpl Zplus;apply done;reflexivity.
Qed.

Definition gcdProg : Map string Stmt :=
  "gcd" |->
        SIf (BLe "a" "b")
          (SIf (BLe "b" "a")
               (Jump "done")
               (Seq (SAssign "b" (EMinus "b" "a"))
                    (Jump "gcd")))
          (Seq (SAssign "a" (EMinus "a" "b"))
               (Jump "gcd")).
Lemma label_eval : forall env,
  steps (KCfg (kra (Jump "gcd") kdot)
            ("a" |-> 12%Z :* "b" |-> 13%Z :* env) mapEmpty gcdProg)
        (KCfg (kra (Jump "done") kdot)
             ("a" |-> 1%Z :* "b" |-> 1%Z :* env) mapEmpty gcdProg).
intros. apply evals_sound with 307. simpl; repeat split; reflexivity.
Qed.

(* Some performance tests *)
Definition test_prop :=
  steps (KCfg (kra (SWhile (BLe 0%Z "x")
    (SAssign "x" (EPlus "x" (-1)%Z)))
  nil) ("x" |-> 25%Z) mapEmpty mapEmpty)
  (KCfg nil ("x" |-> (-1)%Z) mapEmpty mapEmpty).
Ltac kequiv_tac := repeat (apply conj);[reflexivity|simpl;equate_maps ..].
Ltac finish := apply done;kequiv_tac.

(* Using tactics alone *)
Lemma loop_test: test_prop.
Proof.
intros;
repeat (refine (step _ _);[econstructor (reflexivity || find_map_entry)|];instantiate;simpl Zplus);
finish.
Qed.

(* go step by step, but compute successor with eval rather than by tactics *)
Lemma loop_test': test_prop.
Proof.
Ltac step_eval :=refine (step _ _);[match goal with [|- kstep ?l _] => eapply (eval_sound l) end|].
intros;repeat step_eval;simpl;finish.
Qed.

(* use multi-step evaluator, reduce with simpl *)
Lemma loop_test_evals_simpl : test_prop.
Proof.
intros;apply (evals_sound 1000);simpl;kequiv_tac.
Qed.

(* reduce with lazy *)
Lemma loop_test_evals_lazy: test_prop.
Proof.
intros;apply (evals_sound 1000);lazy;kequiv_tac.
Qed.

(* reduce with cbv *)
Lemma loop_test_evals_cbv: test_prop.
Proof.
intros;apply (evals_sound 1000);cbv;kequiv_tac.
Qed.

(* reduce with compute *)
Lemma loop_test_evals_compute : test_prop.
Proof.
intros;apply (evals_sound 1000);compute;kequiv_tac.
Qed.

(* reduce with vm_compute *)
Lemma loop_test_evals_vm_compute : test_prop.
Proof.
intros;apply (evals_sound 1000);vm_compute;kequiv_tac.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

(*i $Id: NAddOrder.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Export NOrder.

Module NAddOrderPropFunct (Import N : NAxiomsSig').
Include NOrderPropFunct N.

(** Theorems true for natural numbers, not for integers *)

Theorem le_add_r : forall n m, n <= n + m.
Proof.
intro n; induct m.
rewrite add_0_r; now apply eq_le_incl.
intros m IH. rewrite add_succ_r; now apply le_le_succ_r.
Qed.

Theorem lt_lt_add_r : forall n m p, n < m -> n < m + p.
Proof.
intros n m p H; rewrite <- (add_0_r n).
apply add_lt_le_mono; [assumption | apply le_0_l].
Qed.

Theorem lt_lt_add_l : forall n m p, n < m -> n < p + m.
Proof.
intros n m p; rewrite add_comm; apply lt_lt_add_r.
Qed.

Theorem add_pos_l : forall n m, 0 < n -> 0 < n + m.
Proof.
intros; apply add_pos_nonneg. assumption. apply le_0_l.
Qed.

Theorem add_pos_r : forall n m, 0 < m -> 0 < n + m.
Proof.
intros; apply add_nonneg_pos. apply le_0_l. assumption.
Qed.

End NAddOrderPropFunct.


Require Import HoTT.

Require Import polynomial.

Axiom cheating : forall A : Type, A.
Ltac todo := apply cheating.
Axiom magic : forall A B, A -> B.

Section Endpoints.
(* The definition of a HIT signature and a HIT for the signature. *)

(* An endpoint is also called a "constructor term". It is used in
   the HIT signature to describe the endpoints of path constructors. *)

(*
   Endpoints are parameterized by a family of polynomials which will
   be specialized to the point constructors in the definition of HITS.
*)
Variable I : Type.
Variable C : I -> polynomial.

Inductive endpoint :
  polynomial -> polynomial -> Type :=
  | endpoint_var : forall {P}, endpoint P P
  | endpoint_const : forall {P} {T : Type}, T -> endpoint P (poly_const T)
  | endpoint_constr : forall {P} (i : I), endpoint P (C i) -> endpoint P poly_var
  | endpoint_fst : forall {P Q R}, endpoint P (poly_times Q R) -> endpoint P Q
  | endpoint_snd : forall {P Q R}, endpoint P (poly_times Q R) -> endpoint P R
  | endpoint_pair : forall {P Q R}, endpoint P Q -> endpoint P R -> endpoint P (poly_times Q R)
  | endpoint_inl : forall {P Q R}, endpoint P Q -> endpoint P (poly_plus Q R)
  | endpoint_inr : forall {P Q R}, endpoint P R -> endpoint P (poly_plus Q R)
.

Variable A : Type.
Variable F : A -> Type.
Variable c : forall i, poly_act (C i) A -> A.
Variable f : forall (i : I) (u : poly_act (C i) A), poly_fam (C i) F u -> F (c i u).

(* Endpoint acting on data for point constructors. *)
Fixpoint endpoint_act
  {P Q : polynomial}
  (e : endpoint P Q) (* the endpoint *)
  {struct e}
  : poly_act P A -> poly_act Q A.
Proof.
  destruct e.

  (* endpoint_var *)
  - exact (fun u => u).

  (* endpoint_const *)
  - exact (fun _ => t).

  (* endpoint_constr *)
  - exact (fun u => c i (endpoint_act _ _ e u)).

  (* endpoint_fst *)
  - exact (fun u => fst (endpoint_act _ _ e u)).

  (* endpoint_snd *)
  -  exact (fun u => snd (endpoint_act _ _ e u)).

  (* endpoint_pair *)
  - exact  (fun u => (endpoint_act _ _ e1 u, endpoint_act _ _ e2 u)).

  (* endpoint_inl *)
  -  exact (fun u => inl (endpoint_act _ _ e u)).

  (* endpoint_inr *)
  -  exact (fun u => inr (endpoint_act _ _ e u)).
Defined.

(* The dependent action of an endpoint, this is used for
   "lifting" the path constructors in the elimnation principle. *)
Fixpoint endpoint_dact
         {P Q : polynomial}
         (e : @endpoint P Q)
         {struct e} :
  forall (x : poly_act P A) (h : poly_fam P F x), poly_fam Q F (endpoint_act e x).
Proof.
  simple refine (
           match e as z in endpoint P Q
                 return (forall (x : poly_act P A) (h : poly_fam P F x), poly_fam Q F (endpoint_act z x))
           with
           | endpoint_var _ => _
           | endpoint_const _ _ t => _
           | endpoint_constr _ i u => _
           | endpoint_fst _ _ _ u => _
           | endpoint_snd _ _ _ u => _
           | endpoint_pair _ _ _ u v => _
           | endpoint_inl _ _ _ e => _
           | endpoint_inr _ _ _ e => _
           end).

  (* endpoint_var *)
  - exact (fun _ x => x).

  (* endpoint_const *)
  - exact (fun _ _ => t).

  (* endpoint_constr *)
  - { intros x h.
      apply f.
      apply endpoint_dact.
      - exact h.
    }

  (* endpoint_fst *)
  - { intros x h.
      apply (@fst _ (poly_fam p1 F (endpoint_act (endpoint_snd u) x))).
      apply @endpoint_dact with (Q := poly_times p0 p1).
      + exact h.
    }

  (* endpoint_snd *)
  - { intros x h.
      apply (@snd (poly_fam p0 F (endpoint_act (endpoint_fst u) x))).
      apply @endpoint_dact with (Q := poly_times p0 p1).
      + exact h.
    }

  (* endpoint_pair *)
  - { intros x h.
      split.
      - apply endpoint_dact.
        + exact h.
      - apply endpoint_dact.
        + exact h.
    }

  (* endpoint_inl *)
  - { intros x h.
      apply endpoint_dact with (e := e).
      + exact h.
    }

  (* endpoint_inr *)
  - { intros x h.
      apply endpoint_dact with (e := e).
      + exact h.
    }
Defined.

(* If [h] commutes with constructors, then it commutes with all endpoints. *)
Fixpoint endpoint_dact_compute
  (P Q : polynomial)
  (x : poly_act P A)
  (e : endpoint P Q)
  (h : forall x, F x)
  {struct e}
:
  (forall i u, h (c i u) = f i u (poly_dmap (C i) h u)) ->
  endpoint_dact e x (poly_dmap P h x) = poly_dmap Q h (endpoint_act e x).
Proof.
  intro H.
  destruct e.

  (* endpoint_var *)
  - { reflexivity. }

  (* endpoint_const *)
  - { reflexivity. }

  (* endpoint_constr *)
  - { simpl.
      transitivity (f i (endpoint_act e x) (poly_dmap (C i) h (endpoint_act e x))).
      - apply ap, endpoint_dact_compute, H.
      - symmetry ; apply H.
    }

  (* endpoint_fst *)
  - { simpl.
      rewrite (endpoint_dact_compute _ _ _ e).
      reflexivity.
      apply H.
    }

  (* endpoint_snd *)
  - { simpl.
      rewrite (endpoint_dact_compute _ _ _ e).
      reflexivity.
      apply H.
    }

  (* endpoint_pair *)
  - { apply path_prod ; apply endpoint_dact_compute, H. }

  (* endpoint_inl *)
  - { apply endpoint_dact_compute with (e := e), H. }

  (* endpoint_inr *)
  - { apply endpoint_dact_compute with (e := e), H. }
Defined.

(* A general HIT might have an arbitrary number of endpoints and therefore an arbitrarily
   nested point constructors. Our construction of a HIT presumes that there is a bound to
   the nesting. We define here what it means for an endpoint to have such a bound. *)
Inductive endpoint_rank : forall {P Q}, endpoint P Q -> nat -> Type :=
  | rank_var : forall {P} (n : nat), endpoint_rank (@endpoint_var P) n
  | rank_const : forall {P} {T : Type} (t : T) (n : nat), endpoint_rank (@endpoint_const P _ t) n
  | rank_constr : forall {P} (i : I) (n : nat) (e : endpoint P (C i)),
      endpoint_rank e n -> endpoint_rank (endpoint_constr i e) (S n)
  | rank_fst : forall {P Q R} (n : nat) (e : endpoint P (poly_times Q R)),
      endpoint_rank e n -> endpoint_rank (endpoint_fst e) n
  | rank_snd : forall {P Q R} (n : nat) (e : endpoint P (poly_times Q R)),
      endpoint_rank e n -> endpoint_rank (endpoint_snd e) n
  | rank_inl : forall {P Q R} (n : nat) (e : endpoint P Q),
      endpoint_rank e n -> endpoint_rank (@endpoint_inl _ _ R e) n
  | rank_inr : forall {P Q R} (n : nat) (e : endpoint P R),
      endpoint_rank e n -> endpoint_rank (@endpoint_inr _ Q _ e) n.

End Endpoints.

Arguments endpoint {_} _ _ _.
Arguments endpoint_var {_ _} {_}.
Arguments endpoint_const {_ _} {_} {_} _.
Arguments endpoint_constr {_ _} {_} _ _ .
Arguments endpoint_fst {_ _} {_ _ _} _.
Arguments endpoint_snd {_ _} {_ _ _} _.
Arguments endpoint_pair {_ _} {_ _ _} _ _.
Arguments endpoint_inl {_ _} {_ _ _} _.
Arguments endpoint_inr {_ _} {_ _ _} _.

Arguments endpoint_act {_ _ _} _ {P Q} _ _.
Arguments endpoint_dact {I C A F} c _ {P Q} _ _ _.
Arguments endpoint_dact_compute {_ _ _} _ _ _ {P Q} _ _ _ _.

Arguments endpoint_rank {_} _ {_ _} _ _.

(* A HIT signature is specified by point constructors and path constructors.

   Note: we are allowing an arbitrary family of poitn and path construcrors.
         We will restrict them later on in existence theorem.
*)
Structure hit_signature := {
  (* indexing for point constructors *)
  sig_point_index : Type ;

  (* the signatures for point constructors *)
  sig_point : sig_point_index -> polynomial ;

  (* indexing for path constructors *)
  sig_path_index : Type ;

  (* the parameters of each path constructor *)
  sig_path_param : sig_path_index -> polynomial ;

  (* the left and right endpoints of path constructors *)
  sig_path_lhs : forall i, endpoint sig_point (sig_path_param i) poly_var ;
  sig_path_rhs : forall i, endpoint sig_point (sig_path_param i) poly_var
}.

(* A HIT signature has rank [n] if all of its endpoints do. *)
Definition hit_rank Σ n :=
  (forall j, endpoint_rank (sig_point Σ) (sig_path_lhs Σ j) n) *
  (forall j, endpoint_rank (sig_point Σ) (sig_path_rhs Σ j) n).

(* Example: propositional truncation *)
Definition trunc_signature (A : Type) :=
  {|
    sig_point_index := Unit ;
    sig_point := (fun _ => poly_const A) ;
    sig_path_index := Unit ;
    sig_path_param := (fun _ => poly_times poly_var poly_var) ;
    sig_path_lhs := (fun _ => endpoint_fst endpoint_var) ;
    sig_path_rhs := (fun _ => endpoint_snd endpoint_var)
  |}.

(* Example: circle *)

Definition circle_signature :=
  {|
    sig_point_index := Unit ;
    sig_point := (fun _ => poly_const Unit) ;
    sig_path_index := Unit ;
    sig_path_param := (fun _ => poly_const Unit) ;
    sig_path_lhs := (fun _ => endpoint_constr tt endpoint_var) ;
    sig_path_rhs := (fun _ => endpoint_constr tt endpoint_var)
  |}.

(* Example: susupension *)

Definition suspension_signature (A : Type) :=
  {|
    sig_point_index := Bool ;
    sig_point := (fun _ => poly_const Unit) ;
    sig_path_index := Unit ;
    sig_path_param := (fun _ => poly_const A) ;
    sig_path_lhs := (fun _ => endpoint_constr false (endpoint_const tt)) ;
    sig_path_rhs := (fun _ => endpoint_constr true (endpoint_const tt))
  |}.

(* Example: natural numbers *)
Definition nat_signature :=
  {|
    sig_point_index := Bool ;
    sig_point := (fun b => if b then poly_const Unit else poly_var) ;
    sig_path_index := Empty ;
    sig_path_param := Empty_rect _ ;
    sig_path_lhs := Empty_rect _ ;
    sig_path_rhs := Empty_rect _
  |}.

Section HIT_Definition.

(* We define HIT for signature [Σ]. *)
Variable Σ : hit_signature.

(* The type of a lift of the point constructor [c] over a family [F]. *)
Definition point_over
  {H : Type} (* the carrier type *)
  (F : H -> Type)
  (c : forall i, poly_act (sig_point Σ i) H -> H) (* point constructors *)
  (p : forall j u, endpoint_act c (sig_path_lhs Σ j) u =
              endpoint_act c (sig_path_rhs Σ j) u) (* path constructors *)
  :=
  forall i (u : poly_act (sig_point Σ i) H), poly_fam (sig_point Σ i) F u -> F (c i u).

(* The type of a lift of the path constructor [p] over a family [F]. *)
Definition path_over
  {H : Type}
  {F : H -> Type}
  {c : forall i, poly_act (sig_point Σ i) H -> H} (* point constructors *)
  {p : forall j u, endpoint_act c (sig_path_lhs Σ j) u =
              endpoint_act c (sig_path_rhs Σ j) u} (* path constructors *)
  (c' : point_over F c p)
  :=
  forall j
    (x : poly_act (sig_path_param Σ j) H)
    (h : poly_fam (sig_path_param Σ j) F x),
    transport _ (p j x) (endpoint_dact c c' (sig_path_lhs Σ j) x h) =
    endpoint_dact c c' (sig_path_rhs Σ j) x h.

(* It is tricky to phrase the computation rule for paths, so we phrase an auxiliary lemma
   that lets us construct the type of the path computation rule interactively. *)
Definition hit_path_beta_eq
  (H : Type) (* the carrier type *)
  (c : forall i, poly_act (sig_point Σ i) H -> H) (* point constructors *)
  (p : forall j u, endpoint_act c (sig_path_lhs Σ j) u =
              endpoint_act c (sig_path_rhs Σ j) u) (* path constructors *)
  (E : (* the eliminator *)
       forall (F : H -> Type)
         (c' : point_over F c p)
         (p' : path_over c'),
         forall (x : H), F x)
  (point_beta : (* the point computation rule *)
    forall (F : H -> Type)
      (c' : point_over F c p)
      (p' : path_over c')
      i (t : poly_act (sig_point Σ i) H),
      E F c' p' (c i t) = c' i t (poly_dmap (sig_point Σ i) (E F c' p') t)) :
  Type.
Proof.
  simple refine (forall (F : H -> Type) (j : sig_path_index Σ)
                   (c' : point_over F c p)
                   (p' : path_over c')
                   (k : sig_path_index Σ)
                   (t : poly_act (sig_path_param Σ k) H), _).
  (* We want an equation between [α] and [β], but their types do not match, so a transport
     is required on each side of the equation. *)
  pose (α := apD (E F c' p') (p k t)).
  pose (β := p' k t (poly_dmap _ (E F c' p') t)).
  simpl in β.
  (* the path along which we will transport lhs *)
  assert (q_lhs : endpoint_dact c c' (sig_path_lhs Σ k) t (poly_dmap (sig_path_param Σ k) (E F c' p') t) =
              E F c' p' (endpoint_act c (sig_path_lhs Σ k) t)).
  { apply (endpoint_dact_compute F c c' t (sig_path_lhs Σ k)), point_beta. }
  (* the path along which we will transport rhs *)
  assert (q_rhs : endpoint_dact c c' (sig_path_rhs Σ k) t (poly_dmap (sig_path_param Σ k) (E F c' p') t) =
              E F c' p' (endpoint_act c (sig_path_rhs Σ k) t)).
  { apply (endpoint_dact_compute F c c' t (sig_path_rhs Σ k)), point_beta. }
  pose (β' := transport
              (fun z => transport F (p k t) z =
                     endpoint_dact c c' (sig_path_rhs Σ k) t (poly_dmap (sig_path_param Σ k) (E F c' p') t))

              q_lhs β).
  simpl in β'.
  pose (β'' := transport
                (fun z => transport F (p k t) (E F c' p' (endpoint_act c (sig_path_lhs Σ k) t)) = z)
                q_rhs β').
  exact (α = β'').
Defined.

Structure HIT :=
{
  (* the carrier of the HIT *)
  hit_carrier :> Type ;

  (* the point constructor *)
  hit_point : forall i, poly_act (sig_point Σ i) hit_carrier -> hit_carrier ;

  (* path constructors *)
  hit_path : forall j u, endpoint_act hit_point (sig_path_lhs Σ j) u =
                    endpoint_act hit_point (sig_path_rhs Σ j) u ;

  (* the eliminator *)
  hit_ind :
    forall (F : hit_carrier -> Type)
      (c : point_over F hit_point hit_path)
      (p : path_over c)
      (x : hit_carrier),
      F x ;

  (* computation rule for points *)
  hit_point_beta :
    forall (F : hit_carrier -> Type)
      (c : point_over F hit_point hit_path)
      (p : path_over c)
      (i : sig_point_index Σ)
      (t : poly_act (sig_point Σ i) hit_carrier),
        hit_ind F c p (hit_point i t) =
        c i t (poly_dmap (sig_point Σ i) (hit_ind F c p) t) ;

  (* computation rule for paths *)
  hit_path_beta :
    hit_path_beta_eq hit_carrier hit_point hit_path hit_ind hit_point_beta
}.
End HIT_Definition.

Arguments hit_point {_ _} _ _.
Arguments hit_path {_ _} _ _.
Arguments hit_ind {_ _} _ _ _ _.


(** Basic lemmas about [Z.modulo] for bootstrapping various tactics *)
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Crypto.Util.ZUtil.Hints.Core.
Local Open Scope Z_scope.

Module Z.
  Lemma mod_0_r_eq a b : b = 0 -> a mod b =
  ltac:(match eval hnf in (1 mod 0) with | 0 => exact 0 | _ => exact a end).
  Proof. intro; subst; auto with zarith. Qed.
  Hint Resolve mod_0_r_eq : zarith.
  Hint Rewrite mod_0_r_eq using assumption : zsimplify.

  Lemma div_mod_cases x y : ((x = y * (x / y) + x mod y /\ (y < x mod y <= 0 \/ 0 <= x mod y < y))
                             \/ (y = 0 /\ x / y = 0 /\ x mod y = ltac:(match eval hnf in (1 mod 0) with | 0 => exact 0 | _ => exact x end))).
  Proof.
    destruct (Z_zerop y); [ right; subst; auto with zarith | left ]; subst.
    split; [ apply Z.div_mod; assumption | ].
    destruct (Z_dec' y 0) as [ [H|H] | H]; [ left | right | congruence ].
    { apply Z.mod_neg_bound; assumption. }
    { apply Z.mod_pos_bound; assumption. }
  Qed.
End Z.


From Coq Require Import Arith Bool List.
From Giskard Require Import lib.

Import ListNotations.

Set Implicit Arguments.

(** * Definitions of Giskard datatypes *)

(** ** Blocks *)

(** Blocks are equipped with decidable equality, a genesis block inhabitant,
a height, a flag indicating its last block status. *)
Parameter block : Type.
Parameter GenesisBlock : block.
Parameter b_height : block -> nat.
Parameter b_index : block -> nat.

(** The genesis block has minimal height. *)
Axiom GenesisBlock_height : forall b, b_height GenesisBlock <= b_height b.

Definition b_last (b : block) : bool := (b_index b) =? 3.

Parameter block_eqb : block -> block -> bool.
Axiom block_eqb_correct : forall b1 b2, block_eqb b1 b2 = true <-> b1 = b2.

Definition block_eq_dec : forall b1 b2 : block, {b1 = b2} + {b1 <> b2}.
Proof.
intros.
case_eq (block_eqb b1 b2); intros.
- left; apply block_eqb_correct; assumption.
- right.
  intro.
  apply block_eqb_correct in H0.
  congruence.
Defined.

Parameter generate_new_block : block -> block.
Parameter generate_last_block : block -> block.
Axiom about_generate_last_block :
 forall b, b_height (generate_last_block b) = S (b_height b) /\ b_last (generate_last_block b) = true.
Axiom about_non_last_block : forall b, b_last (generate_new_block b) = false.

(** ** Parent relation *)

(** We assume a primitive parent relation on blocks. *)
Parameter parent_of : block -> block.
Parameter parent_ofb : block -> block -> bool.
Axiom parent_ofb_correct : forall b1 b2, parent_of b1 = b2 <-> parent_ofb b1 b2 = true.
Axiom generate_new_block_parent : forall b, parent_of (generate_new_block b) = b.
Axiom parent_block_height : forall b, S (b_height (parent_of b)) = b_height b.

Lemma about_generate_new_block : forall b, b_height (generate_new_block b) = S (b_height b).
Proof.
 intros.
 rewrite <- parent_block_height.
 rewrite generate_new_block_parent.
 reflexivity.
Qed.

(** ** Nodes *)

Parameter node : Type.
Parameter node_eqb : node -> node -> bool.
Axiom node_eqb_correct : forall n1 n2, node_eqb n1 n2 = true <-> n1 = n2.

Lemma node_eqb_refl : forall n, node_eqb n n = true.
Proof.
 intros. assert (n = n) by tauto.
 now apply node_eqb_correct in H.
Qed.

Lemma node_eqb_comm : forall n1 n2, node_eqb n1 n2 = node_eqb n2 n1.
Proof.
  intros; destruct (node_eqb n1 n2) eqn:?;
   destruct (node_eqb n2 n1) eqn:?; auto.
  - rewrite node_eqb_correct in Heqb.
    rewrite Heqb in Heqb0.
    rewrite node_eqb_refl in Heqb0; congruence.
  - rewrite node_eqb_correct in Heqb0.
    rewrite Heqb0 in Heqb.
    rewrite node_eqb_refl in Heqb; congruence.
Qed.

Lemma node_eqb_no : forall n1 n2, n1 <> n2 -> node_eqb n1 n2 = false.
Proof.
intros.
case_eq (node_eqb n1 n2); auto.
intros.
apply node_eqb_correct in H0; congruence.
Qed.

Definition node_eq_dec : forall n1 n2 : node, {n1 = n2}+{n1 <> n2}.
Proof.
intros.
case_eq (node_eqb n1 n2); intros.
- left; apply node_eqb_correct; assumption.
- right.
  intro.
  apply node_eqb_correct in H0.
  congruence.
Defined.

(** Honest node property. *)
Parameter honest_node : node -> Prop.
Parameter honest_nodeb : node -> bool.
Axiom honest_nodeb_correct : forall (n : node), honest_node n <-> honest_nodeb n = true.

(** ** Quorums *)

Parameter has_at_least_two_thirdsb : list node -> bool.
Definition has_at_least_two_thirds (l : list node) : Prop := has_at_least_two_thirdsb l = true.

Parameter has_at_least_one_thirdb : list node -> bool.
Definition has_at_least_one_third (l : list node) : Prop := has_at_least_one_thirdb l = true.

Axiom majority_growth : forall (l : list node),
    has_at_least_two_thirds l ->
    forall (n : node),
      has_at_least_two_thirds (n :: l).

Axiom empty_has_no_two_thirds' : forall (l : list node), has_at_least_two_thirds l -> exists n, In n l.
Theorem empty_has_no_two_thirds  : ~ has_at_least_two_thirds [].
Proof.
  intro H.
  destruct (empty_has_no_two_thirds' H).
  assumption.
Qed.
Axiom empty_has_no_one_third' : forall (l : list node), has_at_least_one_third  l -> exists n, In n l.
Theorem empty_has_no_one_third   : ~ has_at_least_one_third  [].
Proof.
  intro H.
  destruct (empty_has_no_one_third' H).
  assumption.
Qed.

Axiom minority_subset : forall (l : list node),
    has_at_least_one_third l ->
    forall (l_superset : list node),
      (forall n, In n l -> In n l_superset) ->
      has_at_least_one_third l_superset.

Lemma majority_shrink : forall (n : node) (l : list node),
 ~ has_at_least_two_thirds (n :: l) ->
 ~ has_at_least_two_thirds l.
Proof.
  intros n l H_not_in H_not_in_tl.
  apply H_not_in.
  apply majority_growth. assumption.
Qed.

Axiom intersection_property :
    forall (l1 l2 : list node),
      has_at_least_two_thirds l1 ->
      has_at_least_two_thirds l2 ->
      exists (l : list node),
        has_at_least_one_third l /\
        forall (n : node), In n l -> In n l1 /\ In n l2.

Definition is_member : node -> list node -> bool :=
 fun n ns => if in_dec node_eq_dec n ns then true else false.
Lemma is_member_correct : forall (n : node) (ln : list node), is_member n ln = true <-> In n ln.
Proof.
 intros; split; unfold is_member; intros;
  destruct (in_dec _ _); congruence.
Qed.

(** No more than one third malicious node assumption. *)
Parameter participants : list node.
Axiom evil_participants : ~ has_at_least_one_third (filter (fun n => negb (honest_nodeb n)) participants).

(** ** Messages *)

(** A message type is one of:
- <<PrepareBlock>>: implicitly carries highest block of previous view,
- <<PrepareVote>>: implicitly carries <<PrepareQC>> of parent,
- <<ViewChange>>: Implicitly carries <<PrepareQC>> of highest block in view,
- <<PrepareQC>>: Carries nothing, i.e., GenesisBlock, and
- <<ViewChangeQC>>: Carries nothing, i.e., GenesisBlock.
*)

Inductive message_type :=
| PrepareBlock
| PrepareVote
| ViewChange
| PrepareQC
| ViewChangeQC.

Definition message_type_eq_dec : forall (mt1 mt2 : message_type), {mt1 = mt2}+{mt1 <> mt2}.
Proof.
decide equality.
Defined.

Definition message_type_eqb : message_type -> message_type -> bool :=
fun mt1 mt2 => if message_type_eq_dec mt1 mt2 then true else false.

Lemma message_type_eqb_correct : forall (mt1 mt2 : message_type),
  message_type_eqb mt1 mt2 = true <-> mt1 = mt2.
Proof.
intros; split; unfold message_type_eqb;
  destruct (message_type_eq_dec _ _); congruence.
Qed.

(** A message contains:
- <<get_message_type>>: the message type,
- <<get_view>>: a timestamp of a view,
- <<get_sender>>: the sender node,
- <<get_block>>: the primary block, and
- <<get_piggyback_block>>: piggyback block.
*)

Record message := mkMessage {
 get_message_type : message_type;
 get_view : nat;
 get_sender : node;
 get_block : block;
 get_piggyback_block : block;
}.

Definition message_eq_dec : forall (m1 m2: message), {m1 = m2}+{m1 <> m2}.
Proof.
decide equality.
- apply block_eq_dec.
- apply block_eq_dec.
- apply node_eq_dec.
- apply Nat.eq_dec.
- apply message_type_eq_dec.
Defined.

Definition message_eqb : message -> message -> bool :=
fun m1 m2 => if message_eq_dec m1 m2 then true else false.

Lemma message_eqb_correct : forall (m1 m2 : message),
  message_eqb m1 m2 = true <-> m1 = m2.
Proof.
intros; split; unfold message_eqb;
  destruct (message_eq_dec _ _); congruence.
Qed.

(** ** Node state *)

(** Node state contains:
- <<node_view>>: view number,
- <<node_id>>: node identifier,
- <<in_messages>>: incoming message buffer,
- <<counting_messages>>: processed message buffer,
- <<out_messages>>: outgoing message buffer, and
- <<timeout>>: timeout flag.
*)

Record NState := mkNState {
 node_view : nat;
 node_id : node;
 in_messages : list message;
 counting_messages : list message;
 out_messages : list message;
 timeout : bool;
}.

Definition NState_init (n : node) : NState :=
  mkNState 0 n [] [] [] false.

Definition NState_eq_dec : forall (s1 s2 : NState), {s1 = s2} + {s1 <> s2}.
Proof.
decide equality.
- apply Bool.bool_dec.
- apply (list_eq_dec message_eq_dec).
- apply (list_eq_dec message_eq_dec).
- apply (list_eq_dec message_eq_dec).
- apply node_eq_dec.
- apply Nat.eq_dec.
Defined.

(** ** Supplementary definitions **)

(** Block proposer status is a function of the view number and node id. *)
Parameter is_block_proposer : node -> nat -> Prop.

(** We require that views have unique block proposers. *)
Axiom is_new_proposer_unique :
  forall (n1 n2 : node) (v1 v2 : nat),
    is_block_proposer n1 v1 ->
    is_block_proposer n2 v2 ->
    v1 = v2 ->
    n1 = n2.

Definition higher_block (b1 b2 : block) : block :=
 if (b_height b1) <? (b_height b2) then b2 else b1.

Definition message_with_higher_block (msg1 msg2 : message) : message :=
 if (b_height (get_block msg1)) <? (b_height (get_block msg2)) then msg2 else msg1.

Definition quorumb (lm : list message) : bool :=
  has_at_least_two_thirdsb (map get_sender lm).

Definition quorum (lm : list message) : Prop :=
  has_at_least_two_thirds (map get_sender lm).

Axiom quorum_subset :
  forall lm1 lm2,
    quorum lm1 ->
    (forall msg, In msg lm1 -> In msg lm2) ->
    quorum lm2.

Lemma quorum_growth :
 forall (lm : list message), quorum lm ->
   forall (msg : message), quorum (msg :: lm).
Proof.
 intros lm H msg.
 unfold quorum in *.
 now apply majority_growth.
Qed.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Require Import ClassicalExtras.
Require Import MyNotation.
Require Import Setoid.
Require Import FunctionalExtensionality.

Require Import Galois.
Require Import LanguageModel.
Require Import TraceModel.
Require Import Properties.
Require Import ChainModel.
Require Import RobustTraceProperty.

Require Import PropExtensionality.
Definition prop_extensionality := propositional_extensionality.

Section Robust2relHyperPreservation.

  Variable Source Target: Language.
  Variable compilation_chain : CompilationChain Source Target.

  (*CA: we don't need a particular structure of traces to define preservation
        e.g. traces = values or our defn of traces both make sense
   *)
  Variable trace__S trace__T : Type.

  Local Definition prop__S := prop trace__S.
  Local Definition prop__T := prop trace__T.

  Variable Source_Semantics : Semantics Source trace__S.
  Variable Target_Semantics : Semantics Target trace__T.

  Local Definition sem__S := sem Source_Semantics.
  Local Definition sem__T := sem Target_Semantics.
  Local Definition beh__S := beh Source_Semantics.
  Local Definition beh__T := beh Target_Semantics.
  Local Definition par__S := par Source.
  Local Definition par__T := par Target.
  Local Definition ctx__S := ctx Source.
  Local Definition ctx__T := ctx Target.
  Local Definition rsat__S := rhsat2 Source_Semantics.
  Local Definition rsat__T := rhsat2 Target_Semantics.

  Local Definition cmp := compile_par Source Target compilation_chain.

  Local Notation "P ↓" := (cmp P) (at level 50).
 (* CA: don't understand why this does not work

   Local Notation " C [ P ] " := (plug _  P C) (at level 50).
  *)
  Local Definition plug__S:= plug Source.
  Local Definition plug__T := plug Target.

  (* still mappings on trace properties *)
  Variable σ__π : (trace__T -> Prop) -> (trace__S -> Prop).
  Variable τ__π : (trace__S -> Prop) -> (trace__T -> Prop).

  Definition σ : (prop__T * prop__T -> Prop) -> (prop__S * prop__S -> Prop) :=
    fun T =>
      fun Π => exists π__T π__T', fst Π = σ__π π__T /\
                        snd Π = σ__π π__T' /\
                        T (π__T, π__T').

  Definition τ : (prop__S * prop__S -> Prop) -> (prop__T * prop__T -> Prop) :=
    fun S =>
      fun Π => exists π__S π__S', fst Π = τ__π π__S /\
                        snd Π = τ__π π__S' /\
                        S (π__S, π__S').

  Definition σR2hP (P1 P2 : par__S) (H__T : prop__T * prop__T -> Prop) :=
    rsat__S P1 P2 (σ H__T) -> rsat__T (P1 ↓) (P2 ↓) H__T.

  Definition σR2HP := forall P1 P2 H__T, σR2hP P1 P2 H__T.

  Lemma contra_σR2hP (P1 P2 : par__S) (H__T : prop__T * prop__T -> Prop) :
    (σR2hP P1 P2 H__T) <->  ((exists C__T, ~ H__T ((beh__T (plug__T (P1 ↓) C__T)), (beh__T (plug__T (P2 ↓) C__T)))) ->
                         (exists C__S, ~ (σ H__T) ((beh__S ( plug__S  P1 C__S)), (beh__S ( plug__S  P2 C__S))))).
  Proof.
    rewrite /σR2hP. by rewrite [_ -> _] contra !neg_rhsat2.
  Qed.

  Lemma contra_σR2HP :
    σR2HP <-> (forall P1 P2 H__T,   ((exists C__T, ~ H__T ((beh__T (plug__T (P1 ↓) C__T)), (beh__T (plug__T (P2 ↓) C__T)))) ->
                         (exists C__S, ~ (σ H__T) ((beh__S ( plug__S  P1 C__S)), (beh__S ( plug__S  P2 C__S)))))).
  Proof.
    rewrite /σR2HP.
    split => H P1 P2 H__T; by move/contra_σR2hP: (H P1 P2 H__T).
  Qed.

  Definition τR2hP (P1 P2 : par__S) (H__S : prop__S * prop__S -> Prop) :=
    rsat__S P1 P2 H__S -> rsat__T (P1 ↓) (P2 ↓) (τ H__S).

  Definition τR2HP := forall P1 P2 H__S, τR2hP P1 P2 H__S.

  Lemma contra_τR2hP (P1 P2 : par__S) (H__S : prop__S * prop__S -> Prop) :
    (τR2hP P1 P2 H__S) <-> ((exists C__T, ~ (τ H__S) ((beh__T (plug__T (P1 ↓) C__T)), (beh__T (plug__T (P2 ↓) C__T)))) ->
                        (exists C__S, ~  H__S ((beh__S (plug__S P1 C__S)), (beh__S (plug__S P2 C__S))))).
  Proof.
    rewrite /τR2hP. by rewrite [_ -> _] contra !neg_rhsat2.
  Qed.

  Lemma contra_τRHP :
    τR2HP <-> (forall P1 P2 H__S, ((exists C__T, ~ (τ H__S) ((beh__T (plug__T (P1 ↓) C__T)), (beh__T (plug__T (P2 ↓) C__T)))) ->
                          (exists C__S, ~  H__S ((beh__S (plug__S P1 C__S)), (beh__S (plug__S P2 C__S)))))).
  Proof.
    rewrite /τR2HP.
    split => H P1 P2 H__S; by move/contra_τR2hP: (H P1 P2 H__S).
  Qed.

End Robust2relHyperPreservation.


Require Import SM3.
(*
Definition Test1Input := hStobL "616263".
Definition Test1HashValue := hStobL
"66c7f0f4 62eeedd9 d1f2d46b dc10e4e2 4167c487 5cf2f7a2 297da02b 8f4ba8e0".
Example sm3_test1 : SM3_Hash Test1Input = Test1HashValue.
Proof. vm_compute. reflexivity. Qed.
Definition Test2Input := hStobL "61626364 61626364 61626364 61626364 61626364
 61626364 61626364 61626364 61626364 61626364 61626364 61626364 61626364
  61626364 61626364 61626364".
Definition Test2HashValue := hStobL
  "debe9ff9 2275b8a1 38604889 c18e5a4d 6fdb70e5 387e5765 293dcba3 9c0c5732".
Example sm3_test2 : SM3_Hash Test2Input = Test2HashValue.
Proof. vm_compute. reflexivity. Qed. *)


Require Export molecules_meta.

Import ListNotations.

(*
 * - règle r ::= reaction
 *             | ∀x. r | ∀X.r (quantification sur des valeurs | sur des molécules)
 *             | r ⊠ r | r ∧ r (conjonctions multiplicative et additive)
 * - réaction ::= g ? M1 -o M2, regle (implication linéaire avec une
 *                                     conjonction multiplicative à gauche)
 * - garde g : Prop
 * (règle := schéma de réaction)
 *)
CoInductive Regle{A : Type}
  : Type
  :=
  | neutreRegle : Regle
  | reaction :
      forall M1 M2 : (@Molecule A), forall r : Regle, forall g : Prop, Regle
  | quantificationValeur :
      forall V : Type,
      (V -> Regle)
      -> Regle
  | quantificationMolecule :
      ((@Molecule A) -> Regle)
      -> Regle
  | conjonctionMultiplicativeRegles : Regle -> Regle -> Regle
  | conjonctionAdditiveRegles : Regle -> Regle -> Regle
.

(* TODO vérifier les niveaux ! *)
Notation "g '?' x -o y" := (reaction x y neutreRegle g) (at level 10).
Notation "g '?' x --o y ',' r" := (reaction x y r g) (at level 10).
Notation "'∀2' r" := (quantificationMolecule r) (at level 5).
Notation "'∀1' r" := (quantificationValeur _ r) (at level 5).
Notation "'∀_m' X , r" := (∀2 (fun X => r)) (at level 5).
Notation "'∀_v' x , r" := (∀1 (fun x => r)) (at level 5).
Notation "r1 ⊠ r2" := (conjonctionMultiplicativeRegles r1 r2) (at level 18, right associativity).
Notation "r1 ∧ r2" := (conjonctionAdditiveRegles r1 r2) (at level 19, right associativity).

Definition exponentiel{A : Type}(r : @Regle A) : @Regle A.
  cofix E.
  exact (neutreRegle ∧ r ∧ (E ⊠ E)).
Defined.

Print exponentiel. (* ⊠ prioritaire / ∧ *)

Notation "'E!' r" := (exponentiel r) (at level 6).

Definition depliageRegle{A : Type}(r : @Regle A) : @Regle A.
  destruct r as [ | M1 M2 r g | V r | r | r1 r2 |r1 r2].
  {
    exact neutreRegle.
  }
  {
    exact (g ? M1 --o M2, r).
  }
  {
    exact (∀1 r).
  }
  {
    exact (∀2 r).
  }
  {
    exact (r1 ⊠ r2).
  }
  {
    exact (r1 ∧ r2).
  }
Defined.

(* Projections utiles pour simplifier la décomposition d'une égalité (dans le
 * cas quantificationValeur) *)

Print unit.

Definition projectionTypeQuantificationValeur{A : Type}(R : @Regle A) : Type.
  destruct R as [ | | V _ | _ | _ | _ ].
  {
    exact unit.
  }
  {
    exact unit.
  }
  {
    exact V.
  }
  {
    exact unit.
  }
  {
    exact unit.
  }
  {
    exact unit.
  }
Defined.

Definition projectionFonctionQuantificationValeur{A : Type}
           (R : @Regle A)
           (v : projectionTypeQuantificationValeur R) : @Regle A.
  destruct R as [ | M1 M2 r g | V r | r | r1 r2 | r1 r2].
  {
    exact neutreRegle.
  }
  {
    exact (g ? M1 --o M2, r).
  }
  {
    simpl in v.
    exact (r v).
  }
  {
    exact (∀2 r).
  }
  {
    exact (r1 ⊠ r2).
  }
  {
    exact (r1 ∧ r2).
  }
Defined.

(*
- Théorie de la démonstration -
  Séquent : liste de règles, molécule ⊢ molécule
- La molécule à droite indique le résultat du calcul.
  Il n'y a plus besoin de prédicat exprimant la terminaison.

        R1, R2, M1 ⊢ M2
[1-G] ---------------------
       R1, 1, R2, M1 ⊢ M2

            M1 ⊢ M2
[ID-G] ----------------
       [], M1 ⊢ M2

          ⊢ g   R1, MA ⊢ M1   r, R2, M2 ⊢ MB
[-o-G] ----------------------------------------
           R1, (g ? M1 --o M2, r), R2, MA ⊢ MB

         R1, r[x := v], R2, MA ⊢ MB
[∀1-G] --------------------------------
           R1, ∀x. r, R2, MA ⊢ MB

         R1, r[X := M], R2, MA ⊢ MB
[∀2-G] -------------------------------
          R1, ∀X. r, R2, MA ⊢ MB

            R1, MA ⊢ M   R2, M ⊢ MB
[Coupure-G] -----------------------
               R1, R2, MA ⊢ MB

         R1, r1, r2, R2, M1 ⊢ M2
[⊠-G]  ----------------------------
         R1, r1 ⊠ r2, R2, M1 ⊢ M2

         R1, r1 | r2, R2, M1 ⊢ M2
[∧-G]  ---------------------------
         R1, r1 ∧ r2, R2, M1 ⊢ M2

+ permutations pour les règles (déplacements en tête ou de la tête en
  chaînage arrière ou avant respectivement)

*)

Inductive Transformation{A : Type}
          (R : list (@Regle A)) (* règles *)
          (M1 : @Molecule A) (* molécule 1 *)
          (M2 : @Molecule A) (* molécule 2 *)
  : Prop
  :=
  | neutreTransformation :
      forall n,
        map depliageRegle (valeur n R) = [neutreRegle]
        -> Transformation ((prefixe n R) ++ (suffixe (S n) R)) M1 M2
        -> Transformation R M1 M2
  | identiteTransformation :
      R = []
      -> EquivalenceMoleculaire [M1] M2
      -> Transformation R M1 M2
  | reactionTransformation :
      forall n (g : Prop) N1 N2 r,
        map depliageRegle (valeur n R) = [g ? N1 --o N2, r]
        -> Transformation (prefixe n R) M1 N1
        -> g
        -> Transformation (r :: (suffixe (S n) R)) N2 M2
        -> Transformation R M1 M2
  | instanciationValeur :
      forall n T v (r : T -> (@Regle A)),
        map depliageRegle (valeur n R) = [∀1 r]
        -> Transformation (prefixe n R ++ [r v] ++ suffixe (S n) R) M1 M2
        -> Transformation R M1 M2
  | instanciationMolecule :
      forall n X r,
        map depliageRegle (valeur n R) = [∀2 r]
        -> Transformation (prefixe n R ++ [r X] ++ suffixe (S n) R) M1 M2
        -> Transformation R M1 M2
  | conjonctionMultiplicativeTransformation :
      forall n, forall r1 r2,
          map depliageRegle (valeur n R) = [r1 ⊠ r2]
          -> Transformation (prefixe n R ++ [r1] ++ [r2] ++ suffixe (S n) R) M1 M2
          -> Transformation R M1 M2
  | conjonctionAdditiviteGaucheTransformation :
      forall n, forall r1 r2,
          map depliageRegle (valeur n R) = [r1 ∧ r2]
          -> Transformation (prefixe n R ++ [r1] ++ suffixe (S n) R) M1 M2
          -> Transformation R M1 M2
  | conjonctionAdditiviteDroiteTransformation :
      forall n, forall r1 r2,
          map depliageRegle (valeur n R) = [r1 ∧ r2]
          -> Transformation (prefixe n R ++ [r2] ++ suffixe (S n) R) M1 M2
          -> Transformation R M1 M2
  | premiereRegle :
      forall n r,
        (map depliageRegle (valeur n R) = [r])
        -> Transformation (r :: ((prefixe n R) ++ (suffixe (S n) R))) M1 M2
        -> Transformation R M1 M2
  | coupureRegles :
      forall n N,
        Transformation (prefixe n R) M1 N
        -> Transformation (suffixe n R) N M2
        -> Transformation R M1 M2.

Arguments Transformation {_}.
Arguments neutreTransformation {_ _ _ _ }.
Arguments identiteTransformation {_ _ _ _ }.
Arguments reactionTransformation {_ _ _ _ }.
Arguments  instanciationValeur {_ _ _ _ } n {_}.
Arguments  instanciationMolecule {_ _ _ _ }.
Arguments  conjonctionMultiplicativeTransformation { _ _ _ _ }.
Arguments  conjonctionAdditiviteGaucheTransformation { _ _ _ _ }.
Arguments  conjonctionAdditiviteDroiteTransformation { _ _ _ _ }.
Arguments  premiereRegle {_ _ _ _ }.
Arguments  coupureRegles {_ _ _ _ }.

(* Blocage *)

Definition Blocage{A : Type}(R : list (@Regle A))(M1 : @Molecule A) : Prop :=
  forall M2, ~(Transformation R M1 M2).

Definition neutreRegleBlocage{A : Type}(r : @Regle A) : @Regle A.
exact (∀2 (fun Y => (Blocage [r] Y) ? Y -o Y)).
Defined.

Definition exponentielDeterministe{A : Type}(r : @Regle A) : @Regle A.
  cofix E.
  exact ((neutreRegleBlocage r) ∧ (r ⊠ E)).
Defined.


Require Export
  Base Coq.Strings.String.
Require Import
  Types.AbstractBool Types.Interval Types.Parity.

Declare Scope com_scope.

Definition cvalue : Type := nat+bool.

Inductive avalue_int : Type :=
  | VInt : (interval+⊤) → avalue_int
  | VAbool1 : (abstr_bool+⊤) → avalue_int.

Inductive avalue_par : Type :=
  | VPar : (parity+⊤) → avalue_par
  | VAbool2 : (abstr_bool+⊤) → avalue_par.

Inductive expr : Type :=
  | EVal : cvalue -> expr
  | EVar : string -> expr
  | EPlus : expr -> expr -> expr
  | EMult : expr -> expr -> expr
  | EEq : expr -> expr -> expr
  | ELe : expr -> expr -> expr
  | ENot : expr -> expr
  | EAnd : expr -> expr -> expr.

Inductive com : Type :=
  | CSkip : com
  | CSeq : com -> com -> com
  | CAss : string -> expr -> com
  | CIf  : expr -> com -> com -> com
  | CTryCatch : com -> com -> com
  | CThrow : com.

Bind Scope com_scope with com.
Notation "'SKIP'" :=
     CSkip : com_scope.
Notation "c1 ;c; c2" :=
    (CSeq c1 c2) (at level 80, right associativity) : com_scope.
Notation "x '::=' a" :=
    (CAss x a) (at level 60) : com_scope.
Notation "'TRY' c1 'CATCH' c2" :=
    (CTryCatch c1 c2) (at level 70) : com_scope.
Notation "'IF2' b 'THEN' c1 'ELSE' c2" :=
    (CIf b c1 c2) (at level 70) : com_scope.


From mathcomp Require Import all_ssreflect all_fingroup all_algebra.
From mathcomp Require Import all_solvable all_field.
From Abel Require Import various.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing.Theory Order.TTheory Num.Theory.

Local Open Scope ring_scope.

Local Notation "p ^^ f" := (map_poly f p)
  (at level 30, f at level 30, format "p  ^^  f").

Record algR := in_algR {algRval : algC; algRvalP : algRval \is Num.real}.

Canonical algR_subType := [subType for algRval].
Definition algR_eqMixin := [eqMixin of algR by <:].
Canonical algR_eqType := EqType algR algR_eqMixin.
Definition algR_choiceMixin := [choiceMixin of algR by <:].
Canonical algR_choiceType := ChoiceType algR algR_choiceMixin.
Definition algR_countMixin := [countMixin of algR by <:].
Canonical algR_countType := CountType algR algR_countMixin.
Definition algR_zmodMixin := [zmodMixin of algR by <:].
Canonical algR_zmodType := ZmodType algR algR_zmodMixin.
Definition algR_ringMixin := [ringMixin of algR by <:].
Canonical algR_ringType := RingType algR algR_ringMixin.
Definition algR_comRingMixin := [comRingMixin of algR by <:].
Canonical algR_comRingType := ComRingType algR algR_comRingMixin.
Definition algR_unitRingMixin := [unitRingMixin of algR by <:].
Canonical algR_unitRingType := UnitRingType algR algR_unitRingMixin.
Canonical algR_comUnitRingType := [comUnitRingType of algR].
Definition algR_idomainMixin := [idomainMixin of algR by <:].
Canonical algR_idomainType := IdomainType algR algR_idomainMixin.
Definition algR_fieldMixin := [fieldMixin of algR by <:].
Canonical algR_fieldType := FieldType algR algR_fieldMixin.
Definition algR_porderMixin := [porderMixin of algR by <:].
Canonical algR_porderType := POrderType ring_display algR algR_porderMixin.
Lemma total_algR : totalPOrderMixin [porderType of algR].
Proof. by move=> x y; apply/real_leVge/valP/valP. Qed.
Canonical algR_latticeType := LatticeType algR total_algR.
Canonical algR_distrLatticeType := DistrLatticeType algR total_algR.
Canonical algR_orderType := OrderType algR total_algR.

Lemma algRval_is_rmorphism : rmorphism algRval. Proof. by []. Qed.
Canonical algRval_additive := Additive algRval_is_rmorphism.
Canonical algRval_rmorphism := RMorphism algRval_is_rmorphism.

Definition algR_norm (x : algR) : algR := in_algR (normr_real (val x)).
Lemma algR_ler_norm_add x y : algR_norm (x + y) <= (algR_norm x + algR_norm y).
Proof. exact: ler_norm_add. Qed.
Lemma algR_normr0_eq0 x : algR_norm x = 0 -> x = 0.
Proof. by move=> /(congr1 val)/normr0_eq0 ?; apply/val_inj. Qed.
Lemma algR_normrMn x n : algR_norm (x *+ n) = algR_norm x *+ n.
Proof. by apply/val_inj; rewrite /= !rmorphMn/= normrMn. Qed.
Lemma algR_normrN x : algR_norm (- x) = algR_norm x.
Proof. by apply/val_inj; apply: normrN. Qed.

Section Num.
Definition algR_normedMixin :=
  Num.NormedMixin algR_ler_norm_add algR_normr0_eq0 algR_normrMn algR_normrN.

Section withz.
Let z : algR := 0.
Lemma algR_addr_gt0 (x y : algR) : z < x -> z < y -> z < x + y.
Proof. exact: addr_gt0. Qed.
Lemma algR_ger_leVge (x y : algR) : z <= x -> z <= y -> (x <= y) || (y <= x).
Proof. exact: ger_leVge. Qed.
Lemma algR_normrM : {morph algR_norm : x y / x * y}.
Proof. by move=> *; apply/val_inj; apply: normrM. Qed.
Lemma algR_ler_def (x y : algR) : (x <= y) = (algR_norm (y - x) == y - x).
Proof. by apply: ler_def. Qed.
End withz.

Let algR_ring := (GRing.Ring.Pack (GRing.ComRing.base
  (GRing.ComUnitRing.base (GRing.IntegralDomain.base
     (GRing.IntegralDomain.class [idomainType of algR]))))).
Definition algR_numMixin : @Num.mixin_of algR_ring _ _ :=
    @Num.Mixin _ _ algR_normedMixin
      algR_addr_gt0 algR_ger_leVge algR_normrM algR_ler_def.

Canonical algR_numDomainType  := NumDomainType algR algR_numMixin.
Canonical algR_normedZmodType := NormedZmodType algR algR algR_normedMixin.
Canonical algR_numFieldType := [numFieldType of algR].
Canonical algR_realDomainType := [realDomainType of algR].
Canonical algR_realFieldType := [realFieldType of algR].
End Num.

Definition algR_archiFieldMixin : Num.archimedean_axiom [numDomainType of algR].
Proof.
move=> /= x; have /andP[/= _] := floorC_itv (valP `|x|).
set n := floorC _; have [n_lt0|n_ge0] := ltP n 0.
  move=> /(@lt_le_trans _ _ _ _ 0); rewrite lerz0 lez_addr1.
  by move=> /(_ n_lt0); rewrite normr_lt0.
move=> x_lt; exists (`|(n + 1)%R|%N); apply: lt_le_trans x_lt _.
by rewrite /= rmorphMn/= pmulrn gez0_abs// addr_ge0.
Qed.
Canonical algR_archiFieldType := ArchiFieldType algR algR_archiFieldMixin.

Definition algRpfactor (x : algC) : {poly algR} :=
  if x \is Num.real =P true is ReflectT xR then 'X - (in_algR xR)%:P else
  'X^2 - (in_algR (Creal_Re x) *+ 2) *: 'X + ((in_algR (normr_real x))^+2)%:P.
Notation algCpfactor x := (algRpfactor x ^^ algRval).

Lemma algRpfactorRE (x : algC) (xR : x \is Num.real) :
  algRpfactor x = 'X - (in_algR xR)%:P.
Proof.
rewrite /algRpfactor; case: eqP xR => //= p1 p2.
by rewrite (bool_irrelevance p1 p2).
Qed.

Lemma algCpfactorRE (x : algC) : x \is Num.real ->
  algCpfactor x = 'X - x%:P.
Proof. by move=> xR; rewrite algRpfactorRE map_polyXsubC. Qed.

Lemma algRpfactorCE (x : algC) : x \isn't Num.real ->
  algRpfactor x =
  'X^2 - (in_algR (Creal_Re x) *+ 2) *: 'X + ((in_algR (normr_real x))^+2)%:P.
Proof. by rewrite /algRpfactor; case: eqP => // p; rewrite p. Qed.

Lemma algCpfactorCE (x : algC) : x \isn't Num.real ->
  algCpfactor x = ('X - x%:P) * ('X - x^*%:P).
Proof.
move=> xNR; rewrite algRpfactorCE//=.
rewrite rmorphD rmorphB/= !map_polyZ !map_polyXn/= map_polyX.
rewrite (map_polyC [rmorphism of algRval])/=.
rewrite mulrBl !mulrBr -!addrA; congr (_ + _).
rewrite opprD addrA opprK -opprD -rmorphM/= -normCK; congr (- _ + _).
rewrite mulrC !mul_polyC -scalerDl.
rewrite [x in RHS]algCrect conjC_rect ?Creal_Re ?Creal_Im//.
by rewrite addrACA addNr addr0.
Qed.

Lemma algCpfactorE x :
  algCpfactor x = ('X - x%:P) * ('X - x^*%:P) ^+ (x \isn't Num.real).
Proof.
by have [/algCpfactorRE|/algCpfactorCE] := boolP (_ \is _); rewrite ?mulr1.
Qed.

Lemma size_algCpfactor x : size (algCpfactor x) = (x \isn't Num.real).+2.
Proof.
have [xR|xNR] := boolP (_ \is _); first by rewrite algCpfactorRE// size_XsubC.
by rewrite algCpfactorCE// size_mul ?size_XsubC ?polyXsubC_eq0.
Qed.

Lemma size_algRpfactor x : size (algRpfactor x) = (x \isn't Num.real).+2.
Proof. by have := size_algCpfactor x; rewrite size_map_poly. Qed.

Lemma algCpfactor_eq0 x : (algCpfactor x == 0) = false.
Proof. by rewrite -size_poly_eq0 size_algCpfactor. Qed.

Lemma algRpfactor_eq0 x : (algRpfactor x == 0) = false.
Proof. by rewrite -size_poly_eq0 size_algRpfactor. Qed.

Lemma algCpfactorCgt0 x y : x \isn't Num.real -> y \is Num.real ->
  (algCpfactor x).[y] > 0.
Proof.
move=> xNR yR; rewrite algCpfactorCE// hornerM !hornerXsubC.
rewrite [x]algCrect conjC_rect ?Creal_Re ?Creal_Im// !opprD !addrA opprK.
rewrite -subr_sqr exprMn sqrCi mulN1r opprK ltr_paddl//.
- by rewrite real_exprn_even_ge0// ?rpredB// ?Creal_Re.
by rewrite real_exprn_even_gt0 ?Creal_Im ?orTb//=; apply/eqP/Creal_ImP.
Qed.

Lemma algRpfactorR_mul_gt0 (x a b : algC) :
    x \is Num.real -> a \is Num.real -> b \is Num.real ->
    a <= b ->
    ((algCpfactor x).[a] * (algCpfactor x).[b] <= 0) =
  (a <= x <= b).
Proof.
move=> xR aR bR ab; rewrite !algCpfactorRE// !hornerXsubC.
have [lt_xa|lt_ax|->]/= := real_ltgtP xR aR; last first.
- by rewrite subrr mul0r lexx ab.
- by rewrite nmulr_rle0 ?subr_lt0 ?subr_ge0.
rewrite pmulr_rle0 ?subr_gt0// subr_le0.
by apply: negbTE; rewrite -real_ltNge// (lt_le_trans lt_xa).
Qed.

Lemma monic_algCpfactor x : algCpfactor x \is monic.
Proof. by rewrite algCpfactorE rpredM ?rpredX ?monicXsubC. Qed.

Lemma monic_algRpfactor x : algRpfactor x \is monic.
Proof. by have := monic_algCpfactor x; rewrite map_monic. Qed.

Lemma poly_algR_pfactor (p : {poly algR}) :
  { r : seq algC |
    p ^^ algRval = val (lead_coef p) *: \prod_(z <- r) algCpfactor z }.
Proof.
wlog p_monic : p / p \is monic => [hwlog|].
  have [->|pN0] := eqVneq p 0.
    by exists [::]; rewrite lead_coef0/= rmorph0 scale0r.
  have [|r] := hwlog ((lead_coef p)^-1 *: p).
    by rewrite monicE lead_coefZ mulVf ?lead_coef_eq0//.
  rewrite !lead_coefZ mulVf ?lead_coef_eq0//= scale1r.
  rewrite map_polyZ/= => /(canRL (scalerKV _))->; first by exists r.
  by rewrite fmorph_eq0 lead_coef_eq0.
suff: {r : seq algC | p ^^ algRval = \prod_(z <- r) algCpfactor z}.
  by move=> [r rP]; exists r; rewrite rP (monicP _)// scale1r.
have [/= r pr] := closed_field_poly_normal (p ^^ algRval).
rewrite (monicP _) ?monic_map ?scale1r// {p_monic} in pr *.
have [n] := ubnP (size r).
elim: n r => // n IHn [|x r]/= in p pr *.
 by exists [::]; rewrite pr !big_nil.
rewrite ltnS => r_lt.
have xJxr : x^* \in x :: r.
  rewrite -root_prod_XsubC -pr.
  have /eq_map_poly-> : algRval =1 conjC \o algRval.
    by move=> a /=; rewrite (CrealP (algRvalP _)).
  by rewrite map_poly_comp mapf_root pr root_prod_XsubC mem_head.
have xJr : (x \isn't Num.real) ==> (x^* \in r) by rewrite implyNb CrealE.
have pxdvdC : algCpfactor x %| p ^^ algRval.
  rewrite pr algCpfactorE big_cons/= dvdp_mul2l ?polyXsubC_eq0//.
  by case: (_ \is _) xJr; rewrite ?dvd1p// dvdp_XsubCl root_prod_XsubC.
pose pr'x := p %/ algRpfactor x.
have [||r'] := IHn (if x \is Num.real then r else rem x^* r) pr'x; last 2 first.
- by case: (_ \is _) in xJr *; rewrite ?size_rem// (leq_ltn_trans (leq_pred _)).
- move=> /eqP; rewrite map_divp -dvdp_eq_mul ?algCpfactor_eq0//= => /eqP->.
  by exists (x :: r'); rewrite big_cons mulrC.
rewrite map_divp/= pr big_cons algCpfactorE/=.
rewrite divp_pmul2l ?expf_neq0 ?polyXsubC_eq0//.
case: (_ \is _) => /= in xJr *; first by rewrite divp1//.
by rewrite (big_rem _ xJr)/= mulKp ?polyXsubC_eq0.
Qed.

Definition algR_rcfMixin : Num.real_closed_axiom [numDomainType of algR].
Proof.
move=> p a b le_ab /andP[pa_le0 pb_ge0]/=.
case: ltgtP pa_le0 => //= pa0 _; last first.
  by exists a; rewrite ?lexx// rootE pa0.
case: ltgtP pb_ge0 => //= pb0 _; last first.
  by exists b; rewrite ?lexx ?andbT// rootE -pb0.
have p_neq0 : p != 0 by apply: contraTneq pa0 => ->; rewrite horner0 ltxx.
have {pa0 pb0} pab0 : p.[a] * p.[b] < 0 by rewrite pmulr_llt0.
wlog p_monic : p p_neq0 pab0 / p \is monic => [hwlog|].
  have [|||x axb] := hwlog ((lead_coef p)^-1 *: p).
  - by rewrite scaler_eq0 invr_eq0 lead_coef_eq0 (negPf p_neq0).
  - rewrite !hornerE/= -mulrA mulrACA -expr2 pmulr_rlt0//.
    by rewrite exprn_even_gt0//= invr_eq0 lead_coef_eq0.
  - by rewrite monicE lead_coefZ mulVf ?lead_coef_eq0 ?eqxx.
  by rewrite rootZ ?invr_eq0 ?lead_coef_eq0//; exists x.
have /= [rs prs] := poly_algR_pfactor p.
rewrite (monicP _) ?monic_map// scale1r {p_monic} in prs.
pose ab := [pred x | val a <= x <= val b].
have abR : {subset ab <= Num.real}.
  move=> x /andP[+ _].
  by rewrite -subr_ge0 => /ger0_real; rewrite rpredBr// algRvalP.
wlog : p pab0 {p_neq0 prs} /
    p ^^ algRval = \prod_(x <- rs | x \in ab) ('X - x%:P) => [hw|].
  move: prs; rewrite -!rmorph_prod => /map_poly_inj.
  rewrite (bigID ab)/=; set q := (X in X * _); set u := (X in _ * X) => pqu.
  have [||] := hw q; last first.
  - by move=> x; exists x => //; rewrite pqu rootM q0.
  - by rewrite rmorph_prod/=; under eq_bigr do rewrite algCpfactorRE ?abR//.
  have := pab0; rewrite pqu !hornerM mulrACA [_ * _ * _ < 0]pmulr_llt0//.
  rewrite !horner_prod -big_split/= prodr_gt0// => x.
  have [xR|xNR] := boolP (x \is Num.real); last first.
    by rewrite ?ltEsub/= -!horner_map/= mulr_gt0 ?algCpfactorCgt0 ?algRvalP.
  apply: contraNT; rewrite -leNgt ?leEsub/= -!horner_map/=.
  by rewrite algRpfactorR_mul_gt0 ?algRvalP.
rewrite -big_filter; have := filter_all ab rs.
set rsab := filter _ _.
have: all (mem Num.real) rsab.
  by apply/allP => x; rewrite mem_filter => /andP[/abR].
case: rsab => [_ _|x rsab]/=; rewrite (big_nil, big_cons).
  move=> pval1; move: pab0.
  have /map_poly_inj-> : p ^^ algRval = 1 ^^ algRval by rewrite rmorph1.
  by rewrite !hornerE ltr10.
move=> /andP[xR rsabR] /andP[axb arsb] prsab.
exists (in_algR xR) => //=.
by rewrite -(mapf_root [rmorphism of algRval])//= prsab rootM root_XsubC eqxx.
Qed.
Canonical algR_rcfType := RcfType algR algR_rcfMixin.