(***************************************************************************
* Equivalence of big-step and small-step in call-by-value - Equivalence    *
* Arthur Charguéraud, March 2009                                           *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN
  BigStep_Definitions BigStep_Infrastructure.

(* ********************************************************************** *)
(** * Basic lemmas used in the proofs *)

(** A simplified rule for reasoning on big-step reduction
    of a value applied to a value *)

Lemma reds_red_val : forall t1 v2 r,
  body t1 -> value v2 ->
  reds (t1 ^^ v2) r ->
  reds (trm_app (trm_abs t1) v2) r.
Proof. intros. applys~ reds_red. Qed.

(** Beta-star is a transitive relationship *)

Lemma beta_star_trans : forall t2 t1 t3,
  beta_star t1 t2 ->
  beta_star t2 t3 ->
  beta_star t1 t3.
Proof.
  introv R1. gen t3. induction R1; intros.
  auto.
  apply* beta_star_step.
Qed.

(** A term that reduces in big-step reaches a value *)

Lemma reds_to_value : forall t v,
  reds t v -> value v.
Proof. introv Rt. induction~ Rt. Qed.
Hint Extern 1 (value ?v) =>
  match goal with H: reds _ v |- _ =>
    apply (@reds_to_value _ _ H) end.

(* ********************************************************************** *)
(** From big-step to small-step *)

Lemma beta_star_app1 : forall t1 t1' t2,
  term t2 ->
  beta_star t1 t1' ->
  beta_star (trm_app t1 t2) (trm_app t1' t2).
Proof.
  introv T H. induction H.
  apply* beta_star_refl.
  apply* beta_star_step.
Qed.

Lemma beta_star_app2 : forall t1 t2 t2',
  value t1 ->
  beta_star t2 t2' ->
  beta_star (trm_app t1 t2) (trm_app t1 t2').
Proof.
  introv T H. induction H.
  apply* beta_star_refl.
  apply* beta_star_step.
Qed.

Lemma reds_to_beta_star : forall t v,
  reds t v -> beta_star t v /\ value v.
Proof.
  introv H. induction H.
  split~. apply* beta_star_refl.
  destruct IHreds1. destruct IHreds2. destruct IHreds3. split~.
   apply (@beta_star_trans (trm_app (trm_abs t3) t2)).
     apply~ beta_star_app1.
   apply (@beta_star_trans (trm_app (trm_abs t3) v2)).
     apply~ beta_star_app2.
   apply~ (@beta_star_step (t3 ^^ v2)).
Qed.

(* ********************************************************************** *)
(** * From small-step to big-step (the simpler proof) *)

Lemma beta_reds_to_reds : forall t t' v,
  beta t t' -> reds t' v -> value v -> reds t v.
Proof.
  introv Rt Rt' Vv. gen v.
  induction Rt; intros.
  apply~ reds_red_val.
  inversions Rt'. false_invert. apply* reds_red.
  inversions Rt'. false_invert. apply* reds_red. apply* IHRt.
Qed.

Lemma beta_star_to_reds : forall t v,
  beta_star t v -> value v -> reds t v.
Proof.
  introv Rt Vv. induction Rt.
  auto.
  apply* beta_reds_to_reds.
Qed.

(* ********************************************************************** *)
(** * Proof of equivalence *)

Lemma equivalence_result : equivalence.
Proof.
  split; intros.
  apply* reds_to_beta_star.
  apply* beta_star_to_reds.
Qed.

(* ********************************************************************** *)
(** * Another proof of small-step implies big-step *)

Require Import LibNat LibInt.
Import LibTacticsCompatibility.
Open Scope nat_scope.
(* TODO: should include LibNat LibOmega *)

(** [beta_starn n t1 t2] describes the fact that [t1] reduces
    to [t2] in exactly [n] steps. *)

Inductive beta_starn : nat -> trm -> trm -> Prop :=
  | beta_starn_refl : forall t,
     term t ->
     beta_starn 0 t t
  | beta_starn_step : forall t2 n t1 t3,
     beta t1 t2 ->
     beta_starn n t2 t3 ->
     beta_starn (S n) t1 t3.

(** [beta_starn] is regular. *)

Lemma beta_starn_regular : forall n e e',
  beta_starn n e e' -> term e /\ term e'.
Proof.
  induction 1.
  auto*.
  destruct* (beta_regular H).
Qed.

Hint Extern 1 (term ?t) =>
  match goal with
  | H: beta_starn _ t _ |- _ => apply (proj1 (beta_starn_regular H))
  | H: beta_starn _ _ t |- _ => apply (proj2 (beta_starn_regular H))
  end.

Hint Constructors beta_star beta_starn.

(** Equivalence between [beta_star] and [beta_starn]. *)

Lemma beta_starn_to_beta_star : forall n t1 t2,
  beta_starn n t1 t2 -> beta_star t1 t2.
Proof.
  introv H. induction* H.
Qed.

Lemma beta_star_to_beta_starn : forall t1 t2,
  beta_star t1 t2 -> exists n, beta_starn n t1 t2.
Proof.
  introv H. induction H.
  auto*.
  destruct* IHbeta_star.
Qed.

(** Some inversion results for [beta_starn]. *)

Lemma beta_starn_inv : forall n t v,
  beta_starn n t v -> value v -> ~ (value t) ->
  exists t', beta t t' /\ beta_starn (n-1) t' v.
Proof.
  introv Rn Vv Vt. inversions Rn.
    false~.
    exists t2. math_rewrite~ (S n0 - 1 = n0).
Qed.

Lemma beta_starn_inv_val : forall n t v,
  beta_starn n t v -> value t -> t = v.
Proof.
  introv Rn Vt. inversions Rn.
    auto.
    inversions Vt. false_invert.
Qed.

(** Main induction. *)

Ltac auto_star ::= intuition eauto with maths.

Lemma beta_starn_inv_app : forall n t1 t2 v,
  beta_starn n (trm_app t1 t2) v -> value v ->
  exists n1 v1 n2 v2 n3,
     beta_starn n1 t1 v1 /\ value v1
  /\ beta_starn n2 t2 v2 /\ value v2
  /\ beta_starn n3 (trm_app v1 v2) v
  /\ n1 < n /\ n2 < n /\ n3 <= n.
Proof.
  introv H. inductions H; introv Vv.
  inversions Vv. inversions H.
  exists* 0 (trm_abs t0) 0 t2 (S n).
  destruct~ (IHbeta_starn t1' t2)
   as (n1&v1&n2&v2&n3&S1&V1&S2&V2&S3&L1&L2&L3).
   exists* (S n1) v1 n2 v2 n3.
  destruct~ (IHbeta_starn t1 t2')
   as (n1&v1&n2&v2&n3&S1&V1&S2&V2&S3&L1&L2&L3).
   exists* n1 v1 (S n2) v2 n3.
Qed.

Lemma beta_starn_to_red : forall n t v,
  beta_starn n t v -> value v -> reds t v.
Proof.
  induction n using peano_induction.
  introv Rn Vv. destruct t.
  destruct (beta_starn_inv Rn Vv) as [t' [Rt Rp]].
   intros K; inversions K. inversion Rt.
  destruct (beta_starn_inv Rn Vv) as [t' [Rt Rp]].
   intros K; inversions K. inversion Rt.
  rewrite~ (beta_starn_inv_val Rn).
  destruct~ (beta_starn_inv_app Rn)
   as (n1&v1&n2&v2&n3&S1&V1&S2&V2&S3&L1&L2&L3).
   inversions V1. inversions S3; [ inversions Vv | ].
   inversions H1; [ | inversions H7 | inversions V2; inversions H7 ].
   eapply reds_red.
     apply* (H n1).
     apply* (H n2).
     apply* (H n0).
Qed.

Lemma beta_star_to_red : forall t v,
  beta_star t v -> value v -> reds t v.
Proof.
  introv Rt Vv. destruct (beta_star_to_beta_starn Rt).
  apply* beta_starn_to_red.
Qed.


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Matrix based on function, and with type safe design.
  author    : ZhengPu Shi
  date      : 2021.12

  remark    :
  1. Use inductive to fix the matrix type unsafe problem,
     that is, old phantom dimension parameters are replaced with
     dependent type.
*)

Require Export HierarchySetoid.
Require Export Sequence.
Require Export TuplesExt NatExt ListListExt.
Require Export Arith Lia Lra.
(* Require Import Setoid. (* R => R', Morphisms.respectful R R' *) *)

(** ** Definition of matrix *)
Section Def.

  (* 矩阵被定义为从自然数下标到值的映射，并用依赖类型来限定维度参数 *)
  Inductive mat {A:Type} (r c : nat) := mk_mat (f : nat -> nat -> A).

  (*     Bind Scope mat_scope with mat. *)

  (** 矩阵到函数 *)
  Definition m2f {A r c} (m : @mat A r c) : nat -> nat -> A :=
    let '(mk_mat _ _ f) := m in f.
  (** 函数到矩阵 *)
  Definition f2m {A r c} (f : nat -> nat -> A) : @mat A r c :=
    mk_mat _ _ f.

End Def.

(** ** Equality of matrix *)
Section meq.

  (** The equality relation of matrix element should be also a decidable
      relation *)
  Context `{EeqDecInst:EqDec}.

  (** The equality relation of matrix element should be an equivalence
      relation *)
  Context `{EqEquiv:Equivalence (A:=A) (R:=Aeq)}.

  Context {r c : nat}.

  Open Scope A_scope.

  Infix "==" := Aeq : A_scope.

  Check mat.
  (* 矩阵相等定义为：下标有效时对应元素相等 *)
  Definition meq (m1 m2 : @mat A r c) : Prop :=
    forall i j, i < r -> j < c -> m2f m1 i j == m2f m2 i j.

  Infix "==" := meq : mat_scope.
  Open Scope mat_scope.

  (** 容易证明，这是等价关系 *)
  Lemma meq_refl : forall (m : mat r c), m == m.
  Proof.
    unfold meq; intros; try reflexivity.
  Qed.

  Lemma meq_sym : forall (m1 m2 : mat r c), m1 == m2 -> m2 == m1.
  Proof.
    unfold meq; intros; auto. rewrite H; easy.
  Qed.

  Lemma meq_trans : forall (m1 m2 m3 : mat r c),
      m1 == m2 -> m2 == m3 -> m1 == m3.
  Proof.
    unfold meq; intros; auto. rewrite H,H0; auto; easy.
  Qed.

  (** Register meq equivalence relation to Coq to enable rewring support. *)
  Global Add Parametric Relation : (@mat A r c) meq
         reflexivity proved by meq_refl
         symmetry proved by meq_sym
         transitivity proved by meq_trans
         as meq_rel.

  (** 两矩阵等价，iff，对应元素相等。相当于加强了meq的另一个方向 *)
  Lemma meq_iff : forall (m1 m2 : @mat A r c),
      m1 == m2 <-> forall i j, i < r -> j < c -> (m2f m1 i j == m2f m2 i j)%A.
  Proof. intros. split; intros; auto. Qed.

  (** Meq is decidable *)
  Lemma meq_dec : forall (m1 m2 : mat r c), {m1 == m2} + {~(m1 == m2)}.
  Proof.
    intros [m1] [m2]. unfold meq. simpl.
    apply seq2eq_dec. Qed.

End meq.

(** 化简 meq *)
Ltac meq_simp :=
  (* 将 mat 转换为 mk_mat *)
  repeat match goal with
    | m : mat _ _ |- _ => destruct m as [m]
    end;
  (* 展开 meq,m2f *)
  unfold meq,m2f,f2m in *; simpl in *.

(** Note that, we cannot use notation to represent meq directly,
    because Aeq is unknown. *)
Infix "==" := meq : mat_scope.

Section meq_test.

  Context `{EqDecInst:EqDec}.
  Context `{EqEquiv:Equivalence (A:=A) (R:=Aeq)}.

  Infix "==" := (meq (Aeq:=Aeq)).

  Goal forall r c (m1 m2 m3 : @mat A r c), m1 == m2 -> m2 == m3 -> m1 == m3.
    intros. rewrite H,H0. reflexivity. Qed.

End meq_test.

(* ==================================== *)
(** ** Get element *)
Section mnth.

  Context {A:Type}.

  Definition mnth {r c} (m : mat r c) (ri ci : nat) : A := m2f m ri ci.

End mnth.

(* ==================================== *)
(** ** Get a row on a matrix *)
Section mrow.

  Context {A:Type}.

  (** 取出矩阵一行 *)
  Definition mrow {r c : nat} (ri : nat) (m : mat r c) : list A :=
    map (fun j => m2f m ri j) (seq 0 c).

  (** 取出矩阵一行，具有期望的长度 *)
  Lemma mrow_length : forall {r c} ri (m : mat r c), length (mrow ri m) = c.
  Proof. intros. unfold mrow. rewrite map_length. apply seq_length. Qed.

  (** 不越界时取出有效的数据 *)
  (** (mrow m i)[j] = m[i][j] *)
  Lemma mrow_nth : forall {r c} ri ci (m : mat r c) a,
      ri < r -> ci < c ->
      nth ci (mrow ri m) a = m2f m ri ci.
  Proof. intros. unfold mrow. rewrite nth_map_seq; auto. Qed.

End mrow.

(* ==================================== *)
(** ** Get a column of a matrix *)
Section mcol.

  Context {A:Type}.

  (** 取出矩阵一列 *)
  Definition mcol {r c : nat} (ci : nat) (m : mat r c) : list A :=
    map (fun i => m2f m i ci) (seq 0 r).

  (** 取出矩阵一列，具有期望的长度 *)
  Lemma mcol_length : forall {r c} ci (m : mat r c), length (mcol ci m) = r.
  Proof. intros. unfold mcol. rewrite map_length. apply seq_length. Qed.

  (** 不越界时取出有效的数据 *)
  (** (mcol m j)[i] = m[i][j] *)
  Lemma mcol_nth : forall {r c} ri ci (m : mat r c) a,
      ri < r -> ci < c ->
      nth ri (mcol ci m) a = m2f m ri ci.
  Proof. intros. unfold mcol. rewrite nth_map_seq; auto. Qed.

End mcol.

(* ==================================== *)
(** ** Convert between list of lists and matrix *)
Section l2m_m2l.

  Context `{EqDecInst:EqDec}.
  Context `{EqEquiv:Equivalence (A:=A) (R:=Aeq)}.
  Context {A0:A}.

  Infix "==" := (meq (Aeq:=Aeq)).

  (** Convert list of lists to matrix
      指定了行数和列数，不足补充自动填充为0，多余的数据会丢弃 *)
  Definition l2m {r c} (dl : list (list A)) : mat r c :=
    f2m (fun x y => nth y (nth x dl []) A0).

  (** Convert list of lists to matrix (auto calculate shape)
      矩阵行数等于输入列表的长度，
      矩阵列数等于输入列表的子列表中第一个列表的长度，
      该版本不常用 *)
  Definition l2m_autoshape (dl : list (list A))
    : mat (length dl) (length (hd [] dl)) :=
    mk_mat _ _ (fun x y => nth y (nth x dl []) A0).

  (** Convert matrix to list of lists *)
  Definition m2l {r c} (m : mat r c) : list (list A) :=
    map (fun ri => (map (fun ci => m2f m ri ci) (seq 0 c))) (seq 0 r).

  (** Convert matrix to list of lists (transposed) *)
  Definition m2l_transposed {r c} (m : mat r c) : list (list A) :=
    map (fun ci => (map (fun ri => m2f m ri ci) (seq 0 r))) (seq 0 c).

  (** 矩阵转列表 行数不变 *)
  Lemma m2l_length : forall {r c} (m : mat r c), length (m2l m) = r.
  Proof. intros. unfold m2l. rewrite map_length,seq_length;auto. Qed.

  (** 矩阵转列表 列数不变 *)
  Lemma m2l_width : forall {r c} (m : mat r c), width (m2l m) c.
  Proof.
    intros. unfold m2l.
    apply width_map. intros. rewrite map_length,seq_length;auto.
  Qed.

  Lemma l2m_m2l_id : forall {r c} (m : mat r c),
      l2m (m2l m) == m.
  Proof.
    intros. unfold l2m,m2l. meq_simp. intros.
    rewrite nth_map_seq; auto.
    rewrite nth_map_seq; auto.
    rewrite ?Nat.add_0_r. reflexivity.
  Qed.

  Lemma m2l_l2m_id : forall {r c} (dl : list (list A)),
      (length dl = r) -> (width dl c) -> m2l (@l2m r c dl) = dl.
  Proof.
    unfold m2l,l2m.
    induction r.
    - intros. apply length_zero_iff_nil in H. subst. simpl. auto.
    - intros. destruct dl.
      + simpl in *. lia.
      + simpl. destruct H0. inversion H.
        f_equal.
        * apply map_nth_seq. auto.
        * rewrite <- seq_shift. rewrite map_map.
          rewrite <- IHr with (c:=c); auto. f_equal. f_equal. auto.
  Qed.

  Lemma l2m_inj : forall {r c} (d1 d2 : list (list A)),
      length d1 = r -> width d1 c ->
      length d2 = r -> width d2 c ->
      d1 <> d2 -> ~(@l2m r c d1 == l2m d2).
  Proof.
    intros. intro. meq_simp.
    destruct H3.
    apply (@dlist_eq_iff_nth_nth _ A0 r c d1 d2 H H1 H0 H2).
    intros. auto.
  Qed.

  Lemma l2m_surj : forall {r c} (m : mat r c),
      (exists d, l2m d == m).
  Proof. Admitted.

  Lemma m2l_inj : forall {r c} (m1 m2 : mat r c),
      ~(m1 == m2) -> m2l m1 <> m2l m2.
  Proof.
    intros. intro. destruct H. meq_simp. intros.
    unfold m2l,m2f in H0.
    rewrite map_seq_eq in H0. apply H0 in H.
    rewrite map_seq_eq in H. apply H; auto.
  Qed.

  Lemma m2l_surj : forall {r c} (d : list (list A)),
      length d = r -> width d c ->
      (exists m, @m2l r c m = d).
  Proof. Admitted.

End l2m_m2l.

Section test.

  (* (* 先构造一个矩阵 *) *)
  (* Let dl1 := [[1;2;3];[4;5;6];[7;8;9]]. *)
  (* Let m1 := @l2m _ 0 3 3 dl1. *)

  (* Compute m2l (@l2m _ 0 0 3 dl1). *)

  (* (* 矩阵转列表 *) *)
  (* Compute m2l m1. *)

  (* (* 手动取出一些元素 *) *)
  (* Compute let m1 := m2f m1 in *)
  (*         (m1 0 0, m1 0 1, m1 0 2, m1 0 3). *)

  (* (* 取出第1行 *) *)
  (* Compute map (fun i => m2f m1 0 i) (seq 0 4). *)

  (* (* 取出所有元素 *) *)
  (* Compute (map (fun i => (map (fun j => m2f m1 i j) (seq 0 4))) (seq 0 4)). *)

End test.

Global Hint Resolve m2l_length : mat.
Global Hint Resolve m2l_width : mat.

(* ==================================== *)
(** ** Right shift columns *)
Section mshift.

  Context {A:Type}.
  Context {A0 A1:A}.
  Context {A1_neq_A0 : A1 <> A0}.

  (** Right shift columns *)
  Definition mshiftc {r c} (m : @mat A r c) (k : nat) : mat r c :=
    f2m (fun i j => m2f m i (j + k)).

  (** ∃ A A' k (X = A' /\ mshiftc A k <> mshiftc A' k *)
  Lemma mshiftc_neq : exists r c (m1 m2 : mat r c) (k : nat),
      m1 == m2 /\ ~(mshiftc m1 k == mshiftc m2 k).
  Proof.
    set (m1 := f2m (r:=2)(c:=2) (fun (i j:nat) => if (j <? 2) then A1 else A0)).
    set (m2 := f2m (r:=2)(c:=2) (fun (i j:nat) => if (j <? 3) then A1 else A0)).
    exists 2, 2, m1, m2, (1). split.
    - apply meq_iff. intros.
      (* unfold m1, m2. intros i j Hi Hj. simpl. *)
      destruct j as [|[|]]; destruct i as [|[|]]; trivial; lia.
    - intros F.
      assert (1 < 2) by lia.
      apply meq_iff in F. (* ToDo: 为何没有效果？ *)
      rewrite meq_iff in F.
      specialize (F _ _ H H).
      unfold m1, m2, mshiftc in F.
      simpl in F.
      apply A1_neq_A0; auto.
  Qed.

End mshift.

(* ==================================== *)
(** ** Matrix Automation *)

(** Useful tactic for solving A = B for concrete A, B *)

Ltac solve_end :=
  match goal with
  | H : lt _ O |- _ => apply Nat.nlt_0_r in H; contradict H
  end.

(** 由于 Coq 8.16 开始，提示“lt_S_n 弃用，文件 Arith.Lt 过时，
    请改用 Nat.succ_lt_mono_left 这个双向版本并不能完全代替单向的情形，
    这里需要严格的出现 S ?a < S ?b 时才使用该引理。
    因此，用 Arith_prebase.lt_S_n 来代替 *)
Ltac by_cell :=
  intros;
  let i := fresh "i" in
  let j := fresh "j" in
  let Hi := fresh "Hi" in
  let Hj := fresh "Hj" in
  intros i j Hi Hj; try solve_end;
  repeat (destruct i as [|i]; simpl;
          [|apply Arith_prebase.lt_S_n in Hi]; try solve_end); clear Hi;
  repeat (destruct j as [|j]; simpl;
          [|apply Arith_prebase.lt_S_n in Hj]; try solve_end); clear Hj.

Ltac lma := by_cell; compute; try ring; auto.

(* ==================================== *)
(** ** 指定维数的矩阵的创建函数 *)
Section SpecifyDims.

  Context {A:Type}.
  Context {A0:A}.

  Definition mk_mat_0_c c : @mat A 0 c.
  Proof. exact (l2m [] (A0:=A0)). Defined.

  Definition mk_mat_1_1 (a11 : A) : @mat A 1 1.
  Proof. exact (l2m [[a11]] (A0:=A0)). Defined.

  Definition mk_mat_1_2 (a11 a12 : A) : @mat A 1 2.
  Proof. exact (l2m [[a11;a12]] (A0:=A0)). Defined.

  Definition mk_mat_1_3 (a11 a12 a13 : A) : @mat A 1 3.
  Proof. exact (l2m [[a11;a12;a13]] (A0:=A0)). Defined.

  Definition mk_mat_1_4 (a11 a12 a13 a14 : A) : @mat A 1 4.
  Proof. exact (l2m [[a11;a12;a13;a14]] (A0:=A0)). Defined.

  Definition mk_mat_1_c c (l : list A) : @mat A 1 c.
  Proof. exact (l2m [l] (A0:=A0)). Defined.

  Definition mk_mat_r_0 r : @mat A r 0.
  Proof. exact (l2m [] (A0:=A0)). Defined.

  Definition mk_mat_2_1 (a11 a21 : A) : @mat A 2 1.
  Proof. exact (l2m [[a11];[a21]] (A0:=A0)). Defined.

  Definition mk_mat_2_2 (a11 a12 a21 a22 : A) : @mat A 2 2.
  Proof. exact (l2m [[a11;a12];[a21;a22]] (A0:=A0)). Defined.

  Definition mk_mat_3_1 (a11 a21 a31 : A) : @mat A 3 1.
  Proof. exact (l2m [[a11];[a21];[a31]] (A0:=A0)). Defined.

  Definition mk_mat_3_3 (a11 a12 a13 a21 a22 a23 a31 a32 a33 : A) : @mat A 3 3.
  Proof. exact (l2m [[a11;a12;a13]; [a21;a22;a23]; [a31;a32;a33]] (A0:=A0)).
  Defined.

  Definition mk_mat_4_1 (a11 a21 a31 a41 : A) : @mat A 4 1.
  Proof. exact (l2m [[a11];[a21];[a31];[a41]] (A0:=A0)). Defined.

  Definition mk_mat_4_4 (a11 a12 a13 a14 a21 a22 a23 a24
                           a31 a32 a33 a34 a41 a42 a43 a44 : A) : @mat A 4 4.
  Proof. exact (l2m [[a11;a12;a13;a14]; [a21;a22;a23;a24];
                      [a31;a32;a33;a34]; [a41;a42;a43;a44]] (A0:=A0)). Defined.

  Definition mk_mat_r_1 r (l : list A) : @mat A r 1.
  Proof. exact (f2m (fun ri ci : nat => if (ci =? 0) then (nth ri l A0) else A0)).
  Defined.

End SpecifyDims.

Section test.
  (* Compute mk_mat_2_1 1 2. *)
  (* Compute (m2l (mk_mat_2_1 1 2)). *)
  (* Compute (m2l (mk_mat_r_1 5 [1;2;3])). *)
End test.

(* ==================================== *)
(** ** 矩阵映射 *)
Section Map.

  Context {A:Type}.

  Definition mmap {r c} (f : A -> A) (m : mat r c) : mat r c :=
    f2m (fun i j => f (m2f m i j)).

  Definition mmap2 {r c} (f : A -> A -> A) (m1 m2 : mat r c) : mat r c :=
    f2m (fun i j => f (m2f m1 i j) (m2f m2 i j)).

  Lemma mmap2_comm : forall {r c} (f : A -> A -> A)
                       (f_comm : forall a b : A, f a b = f b a) (m1 m2 : mat r c),
      mmap2 f m1 m2 == mmap2 f m2 m1.
  Proof.
    intros. apply meq_iff. intros. cbv. auto.
  Qed.

  Lemma mmap2_assoc : forall {r c} (f : A -> A -> A)
                        (f_assoc : forall a b c, f a (f b c) = f (f a b) c)
                        (m1 m2 m3 : mat r c),
      mmap2 f (mmap2 f m1 m2) m3 == mmap2 f m1 (mmap2 f m2 m3).
  Proof.
    intros. apply meq_iff. intros. cbv. auto.
  Qed.

End Map.

(* ==================================== *)
(** ** 特殊矩阵：零矩阵、单位矩阵、对角矩阵等 *)
Section Special.

  Context {A:Type}.
  Context {A0 A1 : A}.

  (** Zero M *)
  Definition mat0 (r c : nat) : mat r c := f2m (fun _ _ => A0).

  (** Identity M *)
  Definition mat1 (n : nat) : mat n n :=
    f2m (fun i j => if (i =? j) then A1 else A0).

  (** Diagonal matrix *)
  Definition mdiag (n : nat) (l : list A) : mat n n :=
    f2m (fun i j => if (i =? j) then nth i l A0 else A0).

End Special.

(* ==================================== *)
(** ** 矩阵加法 *)
Section madd.

  Context `{AM:AMonoid}.

  (* Declare Scope A_scope. *)
  (* Delimit Scope A_scope with A. *)
  Open Scope A_scope.
  Infix "+" := op : A_scope.
  Notation "0" := e : A_scope.

  Definition madd {r c} (m1 m2 : mat r c) : mat r c :=
    f2m (fun i j => m2f m1 i j + m2f m2 i j).

  Infix "+" := madd.

  Lemma madd_comm : forall {r c} (m1 m2 : mat r c), m1 + m2 == (m2 + m1).
  Proof. lma. apply commutative. Qed.

  Lemma madd_assoc : forall {r c} (m1 m2 m3 : mat r c),
      (m1 + m2) + m3 == m1 + (m2 + m3).
  Proof. lma. rewrite associative;auto. Qed.

  Lemma madd_0_l : forall {r c} (m : mat r c), @mat0 A 0 r c + m == m.
  Proof. lma. apply identityLeft. Qed.

  Lemma madd_0_r : forall {r c} (m : mat r c), m + @mat0 A 0 r c == m.
  Proof. lma. apply identityRight. Qed.

  (** Get element of addition with two matrics equal to additon of
      corresponded elements. *)
  Lemma madd_nth : forall {r c} (m1 m2 : mat r c) ri ci,
      mnth (m1 + m2) ri ci = ((mnth m1 ri ci) + (mnth m2 ri ci))%A.
  Proof. intros. auto. Qed.

  (** 加法与 mrow 的关系 *)

  (* (m1 + m2)[0] = m1[0] + m2[0] *)
  Lemma mrow_aux_prop1 : forall {r c} (m1 m2 : mat r c) ri,
      ri < r ->
      mrow ri (m1 + m2) =
        map2 op (mrow ri m1) (mrow ri m2).
  Proof.
    intros. unfold mrow.
    rewrite map2_map_map with (g:=(fun j => m2f (m1 + m2) ri j)); auto.
  Qed.

End madd.

Global Infix "+" := madd : mat_scope.

(* ==================================== *)
(** ** Matrix subtraction *)
Section msub.

  Context `{G:AGroup}.

  (* Declare Scope A_scope. *)
  (* Delimit Scope A_scope with A. *)
  Open Scope A_scope.
  Infix "+" := op : A_scope.
  Notation "0" := e : A_scope.
  Notation "- x" := (inv x) : A_scope.
  Notation "a - b" := (a + (-b)) : A_scope.

  Definition mopp {r c} (m : mat r c) : mat r c :=
    f2m (fun i j => - (m2f m i j)).

  Definition msub {r c} (m1 m2 : mat r c) : mat r c :=
    f2m (fun i j => m2f m1 i j - m2f m2 i j).

  Notation "- a" := (mopp a) : mat_scope.
  Infix "-" := msub : mat_scope.
  Notation "m1 + m2" := (madd m1 m2 (op:=op)) : mat_scope.
  Open Scope mat_scope.

  Lemma mopp_opp : forall {r c} (m : mat r c), - (- m) == m.
  Proof. lma. apply group_inv_inv. Qed.

  Lemma msub_comm : forall {r c} (m1 m2 : mat r c), m1 - m2 == - (m2 - m1).
  Proof. lma. rewrite group_inv_distr. f_equal. rewrite group_inv_inv. auto.
  Qed.

  Lemma msub_assoc : forall {r c} (m1 m2 m3 : mat r c),
      (m1 - m2) - m3 == m1 - (m2 + m3).
  Proof.
    lma.
    rewrite <- associative. f_equal.
    rewrite group_inv_distr. rewrite commutative. auto.
  Qed.

  Lemma msub_0_l : forall {r c} (m : mat r c), (@mat0 _ 0 r c) - m == - m.
  Proof. lma. apply identityLeft. Qed.

  Lemma msub_0_r : forall {r c} (m : mat r c), m - (@mat0 _ 0 r c) == m.
  Proof.
    lma.
    rewrite (@group_inv_id A op 0 inv agroupGroup). apply identityRight.
  Qed.

  Lemma madd_opp : forall {r c} (m : mat r c), m + (-m) == @mat0 _ 0 r c.
  Proof. lma. apply inverseRight. Qed.

  Lemma msub_self : forall {r c} (m : mat r c), m - m == (@mat0 _ 0 r c).
  Proof. lma. apply inverseRight. Qed.

End msub.

Global Notation "- a" := (mopp a) : mat_scope.
Global Infix "-" := msub : mat_scope.

(* ==================================== *)
(** ** Constant multiplication of matrix *)
Section mcmul.

  Context `{RInst:Ring}.

  (* Declare Scope A_scope. *)
  (* Delimit Scope A_scope with A. *)
  Open Scope A_scope.
  Infix "+" := add0 : A_scope.
  Infix "*" := mul0 : A_scope.
  Notation "0" := zero0 : A_scope.
  Notation "1" := one0 : A_scope.
  Notation "- x" := (opp x) : A_scope.
  Notation "a - b" := (a + (-b)) : A_scope.

  (** 注册 Ring 结构，使能 ring 策略 *)
  Add Ring ring_inst : make_ring_theory.

  Definition mcmul {r c} (a : A) (m : mat r c) : mat r c :=
    f2m (fun i j => (a * m2f m i j)).

  Definition mmulc {r c} (m : mat r c) (a : A) : mat r c :=
    f2m (fun i j => (m2f m i j * a)).

  Notation "m1 + m2" := (madd m1 m2 (op:=add0)) : mat_scope.
  Infix "c*" := mcmul : mat_scope.
  Infix "*c" := mmulc : mat_scope.
  Open Scope mat_scope.

  Lemma mmulc_eq_mcmul : forall {r c} (a : A) (m : mat r c),
      m *c a == a c* m.
  Proof. lma. Qed.

  Lemma mcmul_0_l : forall {r c} (m : mat r c), 0 c* m == @mat0 _ 0 r c.
  Proof. lma. Qed.

  Lemma mcmul_0_r : forall {r c} a, a c* @mat0 _ 0 r c == @mat0 _ 0 r c.
  Proof. lma. Qed.

  Lemma mcmul_1_l : forall {r c} (m : mat r c), mcmul 1 m == m.
  Proof. lma. Qed.

  Lemma mcmul_1_r : forall {n} a,
      a c* @mat1 _ 0 1 n ==
        f2m (fun ri ci => if (ri =? ci) then a else 0).
  Proof.
    intros n a. apply meq_iff.
    intros. unfold mat1,mcmul. meq_simp.
    destruct (i =? j); ring.
  Qed.

  Lemma mcmul_assoc : forall {r c} (a b : A) (m : mat r c),
      a c* (b c* m) == (a * b) c* m.
  Proof. lma. Qed.

  Lemma mcmul_perm : forall {r c} (a b : A) (m : mat r c),
      a c* (b c* m) == b c* (a c* m).
  Proof. lma. Qed.

  Lemma mcmul_add_distr_l : forall {r c} (a : A) (m1 m2 : mat r c),
      a c* (m1 + m2) == ((a c* m1) + (a c* m2)).
  Proof. lma. Qed.

  Lemma mcmul_add_distr_r : forall {r c} (a b : A) (m : mat r c),
      (a + b)%A c* m == (a c* m) + (b c* m).
  Proof. lma. Qed.

  Global Add Parametric Morphism m n :
    (@mcmul m n) with signature eq ==> meq ==> meq as mcmul_mor.
  Proof.
    intros. unfold mcmul. meq_simp. intros. rewrite H; auto.
  Qed.

  Global Add Parametric Morphism m n :
    (@mmulc m n) with signature meq ==> eq ==> meq as mmulc_mor.
  Proof.
    intros. unfold mmulc. meq_simp. intros. rewrite H; auto.
  Qed.

End mcmul.

Global Infix "c*" := mcmul : mat_scope.
Global Infix "*c" := mmulc : mat_scope.

(* ==================================== *)
(** ** Matrix transposition *)
Section mtrans.

  Context `{R:Ring}.
  (* Declare Scope A_scope. *)
  (* Delimit Scope A_scope with A. *)
  Open Scope A_scope.
  (* Infix "+" := add0 : A_scope. *)
  (* Infix "*" := mul0 : A_scope. *)
  Notation "0" := zero0 : A_scope.
  Notation "1" := one0 : A_scope.
  (* Notation "- x" := (opp x) : A_scope. *)
  (* Notation "a - b" := (a + (-b)) : A_scope. *)

  Definition mtrans {r c} (m : @mat A r c): mat c r :=
    f2m (fun x y => m2f m y x).

  Notation "m 'ᵀ'" := (mtrans m) : mat_scope.

  (** Transpose twice keep unchanged. *)
  Lemma mtrans_trans : forall {r c} (m : mat r c), mtrans (mtrans m) == m.
  Proof. lma. Qed.

  (** Transpose identity matrix keep unchanged. *)
  Lemma mat1_trans_eq : forall {n : nat}, (@mat1 _ 0 1 n)ᵀ == (@mat1 _ 0 1 n).
  Proof.
    by_cell. unfold mtrans, mat1. meq_simp. rewrite Nat.eqb_sym. auto.
  Qed.

  (** Transpose zero matrix won't change the data. *)
  Lemma mat0_trans_eq : forall {r c : nat}, (@mat0 _ 0 r c)ᵀ == @mat0 _ 0 c r.
  Proof. lma. Qed.

End mtrans.

Global Notation "m 'ᵀ'" := (mtrans m) : mat_scope.

(* ==================================== *)
(** ** Matrix multiplication *)
Section mmul.

  Context `{R:Ring}.
  (* Declare Scope A_scope. *)
  (* Delimit Scope A_scope with A. *)
  Open Scope A_scope.
  Infix "+" := add0 : A_scope.
  Infix "*" := mul0 : A_scope.
  Notation "0" := zero0 : A_scope.
  Notation "1" := one0 : A_scope.
  Notation "- x" := (opp x) : A_scope.
  Notation "a - b" := (a + (-b)) : A_scope.

  (** 注册 Ring 结构，使能 ring 策略 *)
  Add Ring ring_inst : make_ring_theory.

  (** 定义矩阵乘法 *)
  Definition mmul {r c s : nat} (m1 : mat r c) (m2 : @mat A c s) : @mat A r s :=
    f2m (fun x z => seqsum (fun y => m2f m1 x y * m2f m2 y z) c
                    (add:=add0) (zero:=0)).

  Infix "*" := mmul : mat_scope.
  Open Scope mat_scope.
  Notation "m1 + m2" := (madd m1 m2 (op:=add0)) : mat_scope.
  Notation "a c* m" := (mcmul a m (mul0:=mul0)) : mat_scope.
  Notation "m *c a" := (mmulc m a (mul0:=mul0)): mat_scope.

  Lemma mmul_assoc : forall {r c s t : nat}
                       (m1 : mat r c) (m2 : @mat A c s) (m3: @mat A s t),
      (m1 * m2) * m3 == m1 * (m2 * m3).
  Proof.
    intros. apply meq_iff; intros.
    unfold mmul. meq_simp.
    induction c.
    - simpl. clear m2.
      induction s. reflexivity.
      simpl. rewrite IHs. ring.
    - simpl.
      rewrite <- IHc.
      rewrite seqsum_cmul_l.
      rewrite <- seqsum_plusSeq.
      apply seqsum_eq. intros. ring.
  Qed.

  Lemma mmul_add_distr_l : forall {r c s : nat}
                             (m1 : mat r c) (m2 m3 : @mat A c s),
      m1 * (m2 + m3) == m1 * m2 + m1 * m3.
  Proof.
    by_cell. unfold mmul, madd. meq_simp.
    rewrite <- seqsum_plusSeq.
    apply seqsum_eq; intros. ring.
  Qed.

  Lemma mmul_add_distr_r : forall {r c s : nat}
                             (m1 m2 : mat r c) (m3 : @mat A c s),
      (m1 + m2) * m3 == m1 * m3 + m2 * m3.
  Proof.
    by_cell. unfold mmul, madd. meq_simp.
    rewrite <- seqsum_plusSeq.
    apply seqsum_eq; intros. ring.
  Qed.

  Lemma mmul_0_l : forall {r c s} (m : @mat A c s),
      (@mat0 _ 0 r c) * m == @mat0 _ 0 r s.
  Proof.
    by_cell. unfold mmul,mat0. meq_simp.
    rewrite seqsum_seq0; auto. intros. ring.
  Qed.

  Lemma mmul_0_r : forall {r c s} (m : mat r c),
      m * (@mat0 _ 0 c s) == @mat0 _ 0 r s.
  Proof.
    by_cell. unfold mmul,mat0. meq_simp.
    rewrite seqsum_seq0; auto. intros. ring.
  Qed.

  Lemma mmul_1_l : forall {r c : nat} (m : mat r c),
      @mat1 _ 0 1 r * m == m.
  Proof.
    intros. apply meq_iff; intros.
    unfold mmul,mat1. meq_simp.
    eapply seqsum_unique. apply H.
    rewrite Nat.eqb_refl. ring.
    intros. apply Nat.eqb_neq in H1. rewrite H1. ring.
  Qed.

  Lemma mmul_1_r : forall {r c : nat} (m : mat r c),
      m * @mat1 _ 0 1 c == m.
  Proof.
    intros. apply meq_iff; intros.
    unfold mmul,mat1. meq_simp.
    eapply seqsum_unique. apply H0.
    rewrite Nat.eqb_refl. ring.
    intros. apply not_eq_sym in H1. apply Nat.eqb_neq in H1. rewrite H1. ring.
  Qed.

  Lemma mcmul_mul : forall {r c s} (a : A)
                              (m1 : mat r c) (m2 : @mat A c s),
      (a c* m1) * m2 == a c* (m1 * m2).
  Proof.
    by_cell. unfold mcmul,mmul. meq_simp.
    rewrite seqsum_cmul_l.
    apply seqsum_eq. intros. ring.
  Qed.

  Lemma mmul_mcmul : forall {r c s} (a : A)
                              (m1 : mat r c) (m2 : @mat A c s),
      m1 * (a c* m2) == a c* (m1 * m2).
  Proof.
    by_cell. unfold mcmul,mmul. meq_simp.
    rewrite seqsum_cmul_l.
    apply seqsum_eq. intros. ring.
  Qed.

End mmul.

Global Infix "*" := mmul : mat_scope.

(* ==================================== *)
(** ** Square matrix *)

Section square_matrix.

  Context {A:Type}.
  Context {add : A -> A -> A}.
  Context {zero : A}.
  Context `{M:@Monoid A add zero}.

  Definition Square n := @mat A n n.

  (** Trace *)
  Definition trace {n : nat} (m : Square n) :=
    seqsum (fun x => m2f m x x) n (add:=add) (zero:=zero).

End square_matrix.

 (* ==================================== *)
(** ** Other Operations and Properties *)

(** *** Convert between tuples and matrix *)
Section t2m_m2t.

  Context {A:Type}.
  Context {A0:A}.

  (** 一个元素 转换为 mat_1x1 *)
  Definition t2m_1x1 (a : A) : @mat A 1 1.
  Proof.
    exact (mk_mat_1_1 a (A0:=A0)).
  Defined.

  (** mat_1x1 转换为 一个元素 *)
  Definition m2t_1x1 (m : @mat A 1 1) : A := m2f m 0 0.

  (** 2x2元组 转换为 mat_2x2 *)
  Definition t2m_2x2 (t : @T_2x2 A) : @mat A 2 2.
  Proof.
    destruct t as (t1,t2).
    destruct t1 as (a11,a12).
    destruct t2 as (a21,a22).
    exact (mk_mat_2_2 a11 a12 a21 a22 (A0:=A0)).
  Defined.

  (** mat_2x2 转换为 2x2元组 *)
  Definition m2t_2x2 (m : @mat A 2 2) : @T_2x2 A :=
    let m := m2f m in
    (
      (m 0 0, m 0 1),
      (m 1 0, m 1 1)
    ).

  (** 3x3元组 转换为 mat_3x3 *)
  Definition t2m_3x3 (t : @T_3x3 A) : @mat A 3 3.
  Proof.
    destruct t as ((t1,t2),t3).
    destruct t1 as ((a11,a12),a13).
    destruct t2 as ((a21,a22),a23).
    destruct t3 as ((a31,a32),a33).
    exact (mk_mat_3_3 a11 a12 a13 a21 a22 a23 a31 a32 a33 (A0:=A0)).
  Defined.

  (** mat_3x3 转换为 3x3元组 *)
  Definition m2t_3x3 (m : @mat A 3 3) : @T_3x3 A :=
    let m := m2f m in
    (
      (m 0 0, m 0 1, m 0 2),
      (m 1 0, m 1 1, m 1 2),
      (m 2 0, m 2 1, m 2 2)
    ).

End t2m_m2t.

(* ==================================== *)
(** ** 测试 *)

(** 在 R 上的矩阵测试 *)
Module test_matrix_R.

  (** 单态化：为特定类型给定默认值 *)
  Open Scope R.
  Definition mat0 := mat0 (A0:=0).

  Definition m1 : mat 2 3 := f2m (fun i j => INR (i + j)).
  (* Compute mrow 0 m1. *)
  (* Compute mrow 1 m1. *)

  Definition m10 := mat0 3 4.
  (* Compute m10. *)
  Definition m11 := mmap (fun x => x + R1) m10.
  (* Compute m2l (m11). *)

End test_matrix_R.

(** 在 Q 上的矩阵测试 *)
Module test_matrix_Q.

  (** 单态化：为特定类型给定默认值 *)
  Open Scope Q.
  Definition mk_mat_3_3 := mk_mat_3_3 (A0:=0).
  Definition trace {n} (m : Square n) := trace m (add:=Qplus) (zero:=0).
  Definition madd {r c} (m1 m2:mat r c) := madd m1 m2 (op:=Qplus).
  Definition mmul {r c s} (m1:mat r c) (m2:mat c s) :=
    mmul m1 m2 (add0:=Qplus) (zero0:=0) (mul0:=Qmult).
  Infix "+" := madd.
  Infix "*" := mmul.

  (** 除了 Definition，还可以用 Notation 的方式来单态化 *)
  Notation l2m := (l2m (A0:=0)).

  Example m1 := mk_mat_3_3 1 2 3 4 5 6 7 8 9.
  (* Eval cbn in trace m1. *)
  (* Compute trace m1. *)
  (* Compute (m2l (m1 + m1)). *)
  (* Compute (m2l (m1 * m1)). *)

End test_matrix_Q.

(* (* ==================================== *) *)
(* (** ** Matrix Simplification *) *)

(* Ltac unify_matrix_dims tac :=  *)
(*   try reflexivity;  *)
(*   repeat (apply f_equal_gen; try reflexivity;  *)
(*           try (is_nat_equality; tac)). *)

(* Ltac restore_dims_rec A := *)
(*   match A with *)
(*   (* special cases *) *)
(*   | ?X * I _          => let A' := restore_dims_rec A in  *)
(*                         match type of A' with  *)
(*                         | @mat A ?m' ?n' =>  *)
(*                             constr:(@mmul m' n' n' A' (mat1 n')) *)
(*                         end *)
(*   | I _ * ?B          => let B' := restore_dims_rec B in  *)
(*                         match type of B' with  *)
(*                         | @mat A ?n' ?o' =>  *)
(*                             constr:(@mmul n' n' o' (mat1 n')  B') *)
(*                         end *)
(*   | ?X * @mat0 ?n ?n  => let A' := restore_dims_rec A in  *)
(*                         match type of A' with  *)
(*                         | @mat A ?m' ?n' =>  *)
(*                             constr:(@mmul m' n' n' A' (@mat0 n' n')) *)
(*                         end *)
(*   | @mat0 ?n ?n * ?B  => let B' := restore_dims_rec B in  *)
(*                         match type of B' with  *)
(*                         | @mat A ?n' ?o' =>  *)
(*                             constr:(@mmul n' n' o' (@mat0 n' n') B') *)
(*                         end *)
(*   | ?X * @mat0 ?n ?o  => let A' := restore_dims_rec A in  *)
(*                         match type of A' with  *)
(*                         | @mat A ?m' ?n' =>  *)
(*                             constr:(@mmul m' n' o A' (@mat0 n' o)) *)
(*                         end *)
(*   | @mat0 ?m ?n * ?B  => let B' := restore_dims_rec B in  *)
(*                         match type of B' with  *)
(*                         | @mat A ?n' ?o' =>  *)
(*                             constr:(@mmul n' n' o' (@mat0 m n') B') *)
(*                         end *)
(*   | ?X + @mat0 ?m ?n => let A' := restore_dims_rec A in  *)
(*                        match type of A' with  *)
(*                        | @mat A ?m' ?n' =>  *)
(*                            constr:(@madd m' n' A' (@mat0 m' n')) *)
(*                        end *)
(*   | @mat0 ?m ?n + ?B => let B' := restore_dims_rec B in  *)
(*                        match type of B' with  *)
(*                        | @mat A ?m' ?n' =>  *)
(*                            constr:(@madd m' n' (@mat0 m' n') B') *)
(*                        end *)
(*   (* general cases *) *)
(*   | ?X = ?B  => let A' := restore_dims_rec A in  *)
(*                let B' := restore_dims_rec B in  *)
(*                match type of A' with  *)
(*                | @mat A ?m' ?n' => constr:(@meq m' n' A' B') *)
(*                end *)
(*   | ?X * ?B   => let A' := restore_dims_rec A in  *)
(*                 let B' := restore_dims_rec B in  *)
(*                 match type of A' with  *)
(*                 | @mat A ?m' ?n' => *)
(*                     match type of B' with  *)
(*                     | @mat A ?n'' ?o' => constr:(@mmul m' n' o' A' B') *)
(*                     end *)
(*                 end  *)
(*   | ?X + ?B => let A' := restore_dims_rec A in  *)
(*               let B' := restore_dims_rec B in  *)
(*               match type of A' with  *)
(*               | @mat A ?m' ?n' => *)
(*                   match type of B' with  *)
(*                   | @mat A ?m'' ?n'' => constr:(@madd m' n' A' B') *)
(*                   end *)
(*               end *)
(*   | ?c * ?X => let A' := restore_dims_rec A in  *)
(*               match type of A' with *)
(*               | @mat A ?m' ?n' => constr:(@mcmul m' n' c A') *)
(*               end *)
(*   (* Handle functions applied to matrices *) *)
(*   | ?f ?X    => let f' := restore_dims_rec f in  *)
(*                let A' := restore_dims_rec A in  *)
(*                constr:(f' A') *)
(*   (* default *) *)
(*   | ?X       => A *)
(*   end. *)

(* Ltac restore_dims tac :=  *)
(*   match goal with *)
(*   | |- ?X      => let A' := restore_dims_rec A in  *)
(*                 replace A with A' by unify_matrix_dims tac *)
(*   end. *)

(* (* 终于合成了两个可带或可不带参数的策略 *) *)
(* Tactic Notation "restore_dims" tactic(tac) := restore_dims tac. *)

(* Tactic Notation "restore_dims" :=  *)
(*   restore_dims (try ring; unify_pows_two; simpl; lia). *)

(* (* 数据库名称可能的解释， U_db : User database *) *)
(* Global Hint Unfold madd mmul mcmul mat1 : U_db.  *)

(* Hint Rewrite @mmul_1_l @mmul_1_r @mcmul_1_l @mat1_trans_eq : M_db_light. *)
(* Hint Rewrite @mmul_0_l @mmul_0_r @madd_0_l @madd_0_r *)
(*   @mcmul_0_l @mcmul_0_r @mat0_trans_eq : M_db_light. *)

(* (* I don't like always doing restore_dims first, but otherwise sometimes leaves  *)
(*      unsolvable WF_Matrix goals. *) *)
(* Ltac Msimpl_light := restore_dims; autorewrite with M_db_light. *)

(* Ltac Msimpl := restore_dims; autorewrite with M_db_light. *)


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.List.ListFacts.
Require Import Fiat.Common.StringFacts.
Require Import Fiat.Common.Equality.
Require Import Fiat.Common.

Set Implicit Arguments.

Class Enumerable A
  := { enumerate : list A;
       enumerate_correct : forall x, List.In x enumerate }.

Global Arguments enumerate A {_}.

Section enum.
  Context {A B : Type} (beq : B -> B -> bool).

  Definition enumerate_fun_beq (enumerate : list A) (f g : A -> B)
  : bool
    := EqNat.beq_nat (List.length (List.filter (fun x => negb (beq (f x) (g x))) enumerate)) 0.

  Definition enumerate_fun_bl_in
             (bl : forall x y, beq x y = true -> x = y)
             (enumerate : list A) (f g : A -> B)
  : enumerate_fun_beq enumerate f g = true -> forall x, List.In x enumerate -> f x = g x.
  Proof.
    unfold enumerate_fun_beq.
    intros H x H'.
    apply EqNat.beq_nat_true in H.
    apply bl.
    destruct (beq (f x) (g x)) eqn:Heq; [ reflexivity | exfalso ].
    apply Bool.negb_true_iff in Heq.
    match type of H with
      | context[List.filter ?f ?ls]
        => pose proof (proj2 (@List.filter_In _ f x ls) (conj H' Heq)) as H'';
          destruct (List.filter f ls)
    end.
    { simpl in *.
      destruct H''. }
    { simpl in *; lia. }
  Qed.

  Definition enumerate_fun_bl
             (bl : forall x y, beq x y = true -> x = y)
             (enumerate : list A)
             (enumerate_bl : forall x, List.In x enumerate)
             (f g : A -> B)
  : enumerate_fun_beq enumerate f g = true -> forall x, f x = g x.
  Proof.
    intros; eapply enumerate_fun_bl_in; try eassumption; trivial.
  Qed.

  Definition enumerate_fun_false_lb_in
             (lb : forall x y, x = y -> beq x y = true)
             (enumerate : list A) (f g : A -> B)
  : enumerate_fun_beq enumerate f g = false -> { x | List.In x enumerate /\ f x <> g x }.
  Proof.
    induction enumerate as [|y ys IHys];
    unfold enumerate_fun_beq in *; simpl in *;
    intros H.
    { exfalso; clear -H; abstract discriminate. }
    { destruct (beq (f y) (g y)) eqn:Heq; simpl in *.
      { specialize (IHys H).
        exists (proj1_sig IHys); split; [ right | ];
        apply (proj2_sig IHys). }
      { exists y.
        split; [ left; reflexivity | ].
        intro H'.
        apply lb in H'.
        clear -H' Heq.
        generalize dependent (beq (f y) (g y)); clear; intros.
        abstract congruence. } }
  Defined.

  Definition enumerate_fun_false_lb
             (lb : forall x y, x = y -> beq x y = true)
             (enumerate : list A)
             (f g : A -> B)
  : enumerate_fun_beq enumerate f g = false -> { x | f x <> g x }.
  Proof.
    intro H.
    eexists (proj1_sig (enumerate_fun_false_lb_in lb enumerate f g H)).
    apply (proj2_sig (enumerate_fun_false_lb_in lb enumerate f g H)).
  Defined.

  Definition enumerate_fun_lb
             (lb : forall x y, x = y -> beq x y = true)
             (enumerate : list A)
             (f g : A -> B)
  : (forall x, f x = g x) -> enumerate_fun_beq enumerate f g = true.
  Proof.
    destruct (enumerate_fun_beq enumerate f g) eqn:Heq; [ reflexivity | ].
    intro H; exfalso.
    apply enumerate_fun_false_lb in Heq; [ | assumption.. ].
    destruct Heq; eauto with nocore.
  Qed.
End enum.

Section enumerable.
  Context {A} {H : Enumerable A} {B} (beq : B -> B -> bool).

  Definition enumerable_fun_beq : (A -> B) -> (A -> B) -> bool
    := enumerate_fun_beq beq (enumerate A).
  Definition enumerable_fun_bl
             (bl : forall x y, beq x y = true -> x = y)
             (f g : A -> B)
  : enumerable_fun_beq f g = true -> forall x, f x = g x
    := enumerate_fun_bl beq bl (enumerate A) enumerate_correct f g.
  Definition enumerable_fun_false_lb
             (lb : forall x y, x = y -> beq x y = true)
             (f g : A -> B)
  : enumerable_fun_beq f g = false -> { x | f x <> g x }
    := enumerate_fun_false_lb beq lb (enumerate A) f g.
  Definition enumerable_fun_lb
             (lb : forall x y, x = y -> beq x y = true)
             (f g : A -> B)
  : (forall x, f x = g x) -> enumerable_fun_beq f g = true
    := enumerate_fun_lb beq lb (enumerate A) f g.
End enumerable.

Scheme Equality for unit.
Definition unit_bl := internal_unit_dec_bl.
Definition unit_lb := internal_unit_dec_lb.

Local Ltac t bl :=
  abstract (
      let x := fresh in
      intro x; apply (list_in_bl bl); revert x;
      repeat intros []; simpl; try reflexivity
    ).

(* We do not want `Program` to perform simplifications *)
Local Obligation Tactic := idtac.

Global Program Instance enumerable_unit : Enumerable unit :=
  { enumerate := tt::nil }.
Next Obligation. t unit_bl. Defined.

Global Program Instance enumerable_Empty_set : Enumerable Empty_set
  := { enumerate := nil }.
Next Obligation. intros []. Defined.

Global Program Instance enumerable_True : Enumerable True
  := { enumerate := I::nil }.
Next Obligation. intros []; left; reflexivity. Defined.

Global Program Instance enumerable_False : Enumerable False
  := { enumerate := nil }.
Next Obligation. intros []. Defined.

Global Program Instance enumerable_bool : Enumerable bool
  := { enumerate := true::false::nil }.
Next Obligation. t (@bool_bl). Defined.

Global Program Instance enumerable_sum `{Enumerable A, Enumerable B} : Enumerable (A + B)
  := { enumerate := List.map inl (enumerate A) ++ List.map inr (enumerate B) }.
Next Obligation.
  intros ? ? ? ? [x|x]; apply in_or_app; [ left | right ];
  apply in_map;
  apply enumerate_correct.
Defined.

Global Program Instance enumerable_prod `{Enumerable A, Enumerable B} : Enumerable (A * B)
  := { enumerate := List.flat_map (fun a => List.map (pair a) (enumerate B)) (enumerate A) }.
Next Obligation.
  intros ? ? ? ? [a b].
  apply List.in_flat_map.
  exists a; split.
  { apply enumerate_correct. }
  { apply in_map;
    apply enumerate_correct. }
Defined.

Definition enumerate_ascii : list Ascii.ascii
  := Eval compute in List.map Ascii.ascii_of_nat (up_to 256).

Global Program Instance enumerable_ascii : Enumerable Ascii.ascii
  := { enumerate := enumerate_ascii }.
Next Obligation.
  intro x.
  abstract (
      rewrite <- (Ascii.ascii_nat_embedding x);
      change enumerate_ascii with (List.map Ascii.ascii_of_nat (up_to 256));
      apply List.in_map, in_up_to, nat_of_ascii_small
    ).
Defined.

Lemma filter_enumerate {A} {HE : Enumerable A} P a (H : List.filter P (enumerate A) = a::nil)
  : (forall a', is_true (P a') <-> a = a').
Proof.
  intro a'; split; intros;
  assert (H' : In a' (filter P (enumerate A)) <-> In a' (a::nil))
    by (rewrite H; reflexivity);
  clear H; subst; simpl in *;
  rewrite filter_In in H';
  split_iff; split_and;
  repeat match goal with
         | [ H : _ \/ False -> _ |- _ ] => specialize (fun k => H (or_introl k))
         | [ H : _ /\ _ -> _ |- _ ] => specialize (fun a b => H (conj a b))
         | _ => progress specialize_by (apply enumerate_correct)
         | _ => progress specialize_by assumption
         | _ => progress specialize_by (exact eq_refl)
         | _ => progress destruct_head or
         | _ => progress destruct_head False
         | _ => assumption
         end.
Qed.


(* https://sympa.inria.fr/sympa/arc/coq-club/2007-07/msg00013.html
   https://coq-club.inria.narkive.com/gO2dnKc4/well-founded-recursion-stuck-on-opaque-proofs
   https://sympa.inria.fr/sympa/arc/coq-club/2013-09/msg00034.html?ticket=ST-272822-JjlPeYflOHbYh07SIzDGXuXTxLk-cas.inria.fr
*)

From Coq Require Import Arith Utf8 Psatz
  Peano NArith Strings.Byte NArith.

  Local Open Scope N_scope.

  Fixpoint guard A (R : A -> A -> Prop) (n : nat) (wfR : well_founded R) : well_founded R :=
    match n with
    | 0%nat => wfR
    | S n' => fun x => Acc_intro x (fun y _ => guard A R n' (guard A R n' wfR) y)
    end.

  Definition np_total (np : N):  (np <? 256 = true) ->  byte.
  Proof.
    intros H.
    pose proof of_N_None_iff np as Hn.
    destruct (of_N np) as [b | ].
    + exact b.
    + exfalso; abstract (apply N.ltb_lt in H;
        intuition nia).
  Defined.

  Lemma nmod_256 : forall np, np mod 256 < 256.
  Proof.
    intros; eapply N.mod_lt; intro H;
    inversion H.
  Qed.

  Lemma N_eq_gt : forall up t : N, 256 <= up -> t = up / 256 -> 0 <=  t / 256 < t.
  Proof.
    intros up t Hup Ht.
    split.
    apply N.le_0_l.
    apply N.div_lt_upper_bound.
    nia.
    (* I know that 1 <= t *)
    assert (Hot: 1 <= t).
    rewrite Ht.
    apply N.div_le_lower_bound.
    nia.
    simpl. exact Hup. nia.
  Qed.

  Definition length_byte_list (np : N) : list byte.
  Proof.
    refine ((fix length_byte_list up (H: Acc (fun x y => 0 <= x < y) (N.div up 256)) {struct H}:=
      match (up <? 256) as upp return _ = upp -> _ with
      | true => fun Hnp => List.cons (np_total up _) List.nil
      | false => fun Hnp =>
        let r := N.modulo up 256 in
        let t := N.div up 256 in
        List.cons (np_total r _) (length_byte_list t _)
      end eq_refl
    ) np (guard _ (fun x y => 0 <= x < y) 100 (N.lt_wf 0) (N.div np 256))).
    + exact Hnp.
    + apply N.ltb_lt. apply (nmod_256 up).
    + eapply Acc_inv with (x := t). exact H.
      apply N.ltb_ge in Hnp.
      eapply N_eq_gt with (up := up); auto.
  Defined.

  Eval compute in length_byte_list 256.

  (* So it seems we can compute without guard condition as well *)

  Definition length_byte_list_without_guard : N -> list byte.
  Proof.
    intro np.
    cut (Acc lt (N.to_nat np));
    [revert np |].
    +
      refine(fix length_byte_list_without_guard np (acc : Acc lt (N.to_nat np))
        {struct acc} :=
      match acc with
      | Acc_intro _ f =>
        match (np <? 256) as npp
          return _ = npp -> _
        with
        | true => fun Ha => List.cons (np_total np Ha) List.nil
        | false => fun Ha =>
            let r := N.modulo np 256 in
            let t := N.div np 256 in
            List.cons (np_total r _) (length_byte_list_without_guard t _)
        end eq_refl
      end).
      ++
        apply N.ltb_lt, (nmod_256 np).
      ++
        apply N.ltb_ge in Ha.
        assert (Hc : (N.to_nat t < N.to_nat np)%nat).
        unfold t. rewrite N2Nat.inj_div.
        eapply Nat.div_lt; try abstract nia.
        exact (f (N.to_nat t) Hc).
    +
      apply lt_wf.
  Defined.

  Eval compute in length_byte_list_without_guard 3723.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List.

From Undecidability.MinskyMachines
  Require Import ndMM2.

Set Default Proof Using "Type".

Section ndMM2_monotonicity.

  Variables loc : Set.

  Notation "Σ // a ⊕ b ⊦ u" := (@ndmm2_accept loc Σ a b u) (at level 70, no associativity).

  Infix "⊆" := incl (at level 70).

  Tactic Notation "by" "constr" int(i) "with" hyp(H) := econstructor i; [ apply H | ]; eassumption.

  Fact ndmm2_accept_mono Σ Θ a b u : Σ ⊆ Θ -> Σ // a ⊕ b ⊦ u -> Θ // a ⊕ b ⊦ u.
  Proof.
    intros H.
    induction 1.
    + constructor; auto.
    + by constr 2 with H.
    + by constr 3 with H.
    + by constr 4 with H.
    + by constr 5 with H.
    + by constr 6 with H.
    + by constr 7 with H.
  Qed.

End ndMM2_monotonicity.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

Require Import NArith.
Require Import Relation_Definitions.
Require Import Setoid.
(*****)
Require Import Env.
Require Import EnvRing.
(*****)
Require Import List.
Require Import Bool.
Require Import OrderedRing.
Require Import Refl.
Require Coq.micromega.Tauto.

Set Implicit Arguments.

Import OrderedRingSyntax.

Section Micromega.

(* Assume we have a strict(ly?) ordered ring *)

Variable R : Type.
Variables rO rI : R.
Variables rplus rtimes rminus: R -> R -> R.
Variable ropp : R -> R.
Variables req rle rlt : R -> R -> Prop.

Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.

Notation "0" := rO.
Notation "1" := rI.
Notation "x + y" := (rplus x y).
Notation "x * y " := (rtimes x y).
Notation "x - y " := (rminus x y).
Notation "- x" := (ropp x).
Notation "x == y" := (req x y).
Notation "x ~= y" := (~ req x y).
Notation "x <= y" := (rle x y).
Notation "x < y" := (rlt x y).

(* Assume we have a type of coefficients C and a morphism from C to R *)

Variable C : Type.
Variables cO cI : C.
Variables cplus ctimes cminus: C -> C -> C.
Variable copp : C -> C.
Variables ceqb cleb : C -> C -> bool.
Variable phi : C -> R.

(* Power coefficients *)
Variable E : Type. (* the type of exponents *)
Variable pow_phi : N -> E.
Variable rpow : R -> E -> R.

Notation "[ x ]" := (phi x).
Notation "x [=] y" := (ceqb x y).
Notation "x [<=] y" := (cleb x y).

(* Let's collect all hypotheses in addition to the ordered ring axioms into
one structure *)

Record SORaddon := mk_SOR_addon {
  SORrm : ring_morph 0 1 rplus rtimes rminus ropp req cO cI cplus ctimes cminus copp ceqb phi;
  SORpower : power_theory rI rtimes req pow_phi rpow;
  SORcneqb_morph : forall x y : C, x [=] y = false -> [x] ~= [y];
  SORcleb_morph : forall x y : C, x [<=] y = true -> [x] <= [y]
}.

Variable addon : SORaddon.

Add Relation R req
  reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _)
  symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _)
  transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _)
as micomega_sor_setoid.

Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
Proof.
exact sor.(SORplus_wd).
Qed.
Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
Proof.
exact sor.(SORtimes_wd).
Qed.
Add Morphism ropp with signature req ==> req as ropp_morph.
Proof.
exact sor.(SORopp_wd).
Qed.
Add Morphism rle with signature req ==> req ==> iff as rle_morph.
Proof.
  exact sor.(SORle_wd).
Qed.
Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
Proof.
  exact sor.(SORlt_wd).
Qed.

Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
Proof.
  exact (rminus_morph sor). (* We already proved that minus is a morphism in OrderedRing.v *)
Qed.

Definition cneqb (x y : C) := negb (ceqb x y).
Definition cltb (x y : C) := (cleb x y) && (cneqb x y).

Notation "x [~=] y" := (cneqb x y).
Notation "x [<] y" := (cltb x y).

Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption.
Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption.
Ltac le_elim H := rewrite (Rle_lt_eq sor) in H; destruct H as [H | H].

Lemma cleb_sound : forall x y : C, x [<=] y = true -> [x] <= [y].
Proof.
  exact addon.(SORcleb_morph).
Qed.

Lemma cneqb_sound : forall x y : C, x [~=] y = true -> [x] ~= [y].
Proof.
intros x y H1. apply addon.(SORcneqb_morph). unfold cneqb, negb in H1.
destruct (ceqb x y); now try discriminate.
Qed.

Lemma cltb_sound : forall x y : C, x [<] y = true -> [x] < [y].
Proof.
intros x y H. unfold cltb in H. apply andb_prop in H. destruct H as [H1 H2].
apply cleb_sound in H1. apply cneqb_sound in H2. apply <- (Rlt_le_neq sor). now split.
Qed.

(* Begin Micromega *)

Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *)
Definition PolEnv := Env R. (* For interpreting PolC *)
Definition eval_pol : PolEnv -> PolC -> R :=
   Pphi rplus rtimes phi.

Inductive Op1 : Set := (* relations with 0 *)
| Equal (* == 0 *)
| NonEqual (* ~= 0 *)
| Strict (* > 0 *)
| NonStrict (* >= 0 *).

Definition NFormula := (PolC * Op1)%type. (* normalized formula *)

Definition eval_op1 (o : Op1) : R -> Prop :=
match o with
| Equal => fun x => x == 0
| NonEqual => fun x : R => x ~= 0
| Strict => fun x : R => 0 < x
| NonStrict => fun x : R => 0 <= x
end.

Definition eval_nformula (env : PolEnv) (f : NFormula) : Prop :=
let (p, op) := f in eval_op1 op (eval_pol env p).

(** Rule of "signs" for addition and multiplication.
   An arbitrary result is coded buy None. *)

Definition OpMult (o o' : Op1) : option Op1 :=
match o with
| Equal => Some Equal
| NonStrict =>
  match o' with
    | Equal => Some Equal
    | NonEqual  => None
    | Strict    => Some NonStrict
    | NonStrict => Some NonStrict
  end
| Strict => match o' with
              | NonEqual => None
              |  _       => Some o'
            end
| NonEqual => match o' with
                | Equal => Some Equal
                | NonEqual => Some NonEqual
                | _        => None
              end
end.

Definition OpAdd (o o': Op1) : option Op1 :=
  match o with
    | Equal => Some o'
    | NonStrict =>
      match o' with
        | Strict => Some Strict
        | NonEqual => None
        | _ => Some NonStrict
      end
    | Strict => match o' with
                  | NonEqual => None
                  |  _        => Some Strict
                end
    | NonEqual => match o' with
                    | Equal  => Some NonEqual
                    | _      => None
                  end
  end.

Lemma OpMult_sound :
  forall (o o' om: Op1) (x y : R),
    eval_op1 o x -> eval_op1 o' y -> OpMult o o' = Some om -> eval_op1 om (x * y).
Proof.
unfold eval_op1; destruct o; simpl; intros o' om x y H1 H2 H3.
(* x == 0 *)
inversion H3. rewrite H1. now rewrite (Rtimes_0_l sor).
(* x ~= 0 *)
destruct o' ; inversion H3.
 (* y == 0 *)
 rewrite H2. now rewrite (Rtimes_0_r sor).
 (* y ~= 0 *)
 apply (Rtimes_neq_0 sor) ; auto.
(* 0 < x *)
destruct o' ; inversion H3.
 (* y == 0 *)
 rewrite H2; now rewrite (Rtimes_0_r sor).
 (* 0 < y *)
 now apply (Rtimes_pos_pos sor).
 (* 0 <= y *)
  apply (Rtimes_nonneg_nonneg sor); [le_less | assumption].
(* 0 <= x *)
destruct o' ; inversion H3.
 (* y == 0 *)
 rewrite H2; now rewrite (Rtimes_0_r sor).
 (* 0 < y *)
 apply (Rtimes_nonneg_nonneg sor); [assumption | le_less ].
 (* 0 <= y *)
 now apply (Rtimes_nonneg_nonneg sor).
Qed.

Lemma OpAdd_sound :
  forall (o o' oa : Op1) (e e' : R),
    eval_op1 o e -> eval_op1 o' e' -> OpAdd o o' = Some oa -> eval_op1 oa (e + e').
Proof.
unfold eval_op1; destruct o; simpl; intros o' oa e e' H1 H2 Hoa.
(* e == 0 *)
inversion Hoa. rewrite <- H0.
destruct o' ; rewrite H1 ; now rewrite  (Rplus_0_l sor).
(* e ~= 0 *)
 destruct o'.
 (* e' == 0 *)
 inversion Hoa.
 rewrite H2. now rewrite (Rplus_0_r sor).
 (* e' ~= 0 *)
 discriminate.
 (* 0 < e' *)
 discriminate.
 (* 0 <= e' *)
 discriminate.
(* 0 < e *)
 destruct o'.
 (* e' == 0 *)
 inversion Hoa.
 rewrite H2.  now rewrite (Rplus_0_r sor).
 (* e' ~= 0 *)
 discriminate.
 (* 0 < e' *)
 inversion Hoa.
 now apply (Rplus_pos_pos sor).
 (* 0 <= e' *)
 inversion Hoa.
 now apply (Rplus_pos_nonneg sor).
(* 0 <= e *)
 destruct o'.
 (* e' == 0 *)
 inversion Hoa.
 now rewrite H2, (Rplus_0_r sor).
 (* e' ~= 0 *)
 discriminate.
 (* 0 < e' *)
 inversion Hoa.
 now apply (Rplus_nonneg_pos sor).
 (* 0 <= e' *)
 inversion Hoa.
 now apply (Rplus_nonneg_nonneg sor).
Qed.

Inductive Psatz : Type :=
| PsatzIn : nat -> Psatz
| PsatzSquare : PolC -> Psatz
| PsatzMulC : PolC -> Psatz -> Psatz
| PsatzMulE : Psatz -> Psatz -> Psatz
| PsatzAdd  : Psatz -> Psatz -> Psatz
| PsatzC    : C -> Psatz
| PsatzZ    : Psatz.

(** Given a list [l] of NFormula and an extended polynomial expression
   [e], if [eval_Psatz l e] succeeds (= Some f) then [f] is a
   logic consequence of the conjunction of the formulae in l.
   Moreover, the polynomial expression is obtained by replacing the (PsatzIn n)
   by the nth polynomial expression in [l] and the sign is computed by the "rule of sign" *)

(* Might be defined elsewhere *)
Definition map_option (A B:Type) (f : A -> option B) (o : option A) : option B :=
  match o with
    | None => None
    | Some x => f x
  end.

Arguments map_option [A B] f o.

Definition map_option2 (A B C : Type) (f : A -> B -> option C)
  (o: option A) (o': option B) : option C :=
  match o , o' with
    | None , _ => None
    | _ , None => None
    | Some x , Some x' => f x x'
  end.

Arguments map_option2 [A B C] f o o'.

Definition Rops_wd := mk_reqe (*rplus rtimes ropp req*)
                       sor.(SORplus_wd)
                       sor.(SORtimes_wd)
                       sor.(SORopp_wd).

Definition pexpr_times_nformula (e: PolC) (f : NFormula) : option NFormula :=
  let (ef,o) := f in
    match o with
      | Equal => Some (Pmul cO cI cplus ctimes ceqb e ef , Equal)
      |   _   => None
    end.

Definition nformula_times_nformula (f1 f2 : NFormula) : option NFormula :=
  let (e1,o1) := f1 in
    let (e2,o2) := f2 in
      map_option  (fun x => (Some (Pmul cO cI cplus ctimes ceqb e1 e2,x)))    (OpMult o1 o2).

 Definition nformula_plus_nformula (f1 f2 : NFormula) : option NFormula :=
  let (e1,o1) := f1 in
    let (e2,o2) := f2 in
      map_option  (fun x => (Some (Padd cO cplus ceqb e1 e2,x)))    (OpAdd o1 o2).

Fixpoint eval_Psatz (l : list NFormula) (e : Psatz) {struct e} : option NFormula :=
  match e with
    | PsatzIn n => Some (nth n l (Pc cO, Equal))
    | PsatzSquare e => Some (Psquare cO cI cplus ctimes ceqb e  , NonStrict)
    | PsatzMulC re e => map_option (pexpr_times_nformula re) (eval_Psatz l e)
    | PsatzMulE f1 f2 => map_option2 nformula_times_nformula  (eval_Psatz l f1) (eval_Psatz l f2)
    | PsatzAdd f1 f2  => map_option2 nformula_plus_nformula  (eval_Psatz l f1) (eval_Psatz l f2)
    | PsatzC  c  => if cltb cO c then Some (Pc c, Strict) else None
(* This could be 0, or <> 0 -- but these cases are useless *)
    | PsatzZ     => Some (Pc cO, Equal) (* Just to make life easier *)
  end.

Lemma pexpr_times_nformula_correct : forall (env: PolEnv) (e: PolC) (f f' : NFormula),
  eval_nformula env f -> pexpr_times_nformula e f = Some f' ->
   eval_nformula env f'.
Proof.
  unfold pexpr_times_nformula.
  destruct f.
  intros. destruct o ; inversion H0 ; try discriminate.
  simpl in *.    unfold eval_pol in *.
  rewrite (Pmul_ok sor.(SORsetoid) Rops_wd
    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))  addon.(SORrm)).
  rewrite H. apply (Rtimes_0_r sor).
Qed.

Lemma nformula_times_nformula_correct : forall (env:PolEnv)
  (f1 f2 f : NFormula),
  eval_nformula env f1 -> eval_nformula env f2 ->
  nformula_times_nformula f1 f2 = Some f  ->
   eval_nformula env f.
Proof.
  unfold nformula_times_nformula.
  destruct f1 ; destruct f2.
  case_eq (OpMult o o0) ; simpl ; try discriminate.
  intros. inversion H2 ; simpl.
  unfold eval_pol.
  destruct o1; simpl;
  rewrite (Pmul_ok sor.(SORsetoid) Rops_wd
    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))  addon.(SORrm));
  apply OpMult_sound with (3:= H);assumption.
Qed.

Lemma nformula_plus_nformula_correct : forall (env:PolEnv)
  (f1 f2 f : NFormula),
  eval_nformula env f1 -> eval_nformula env f2 ->
  nformula_plus_nformula f1 f2 = Some f  ->
   eval_nformula env f.
Proof.
  unfold nformula_plus_nformula.
  destruct f1 ; destruct f2.
  case_eq (OpAdd o o0) ; simpl ; try discriminate.
  intros. inversion H2 ; simpl.
  unfold eval_pol.
  destruct o1; simpl;
  rewrite (Padd_ok sor.(SORsetoid) Rops_wd
    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))  addon.(SORrm));
  apply OpAdd_sound with (3:= H);assumption.
Qed.

Lemma eval_Psatz_Sound :
  forall (l : list NFormula) (env : PolEnv),
    (forall (f : NFormula), In f l -> eval_nformula env f) ->
      forall (e : Psatz) (f : NFormula), eval_Psatz l e = Some f ->
        eval_nformula env f.
Proof.
  induction e.
  (* PsatzIn *)
  simpl ; intros.
  destruct (nth_in_or_default n l (Pc cO, Equal)) as [Hin|Heq].
  (* index is in bounds *)
  apply H. congruence.
  (* index is out-of-bounds *)
  inversion H0.
  rewrite Heq. simpl.
  now apply  addon.(SORrm).(morph0).
  (* PsatzSquare *)
  simpl. intros. inversion H0.
  simpl. unfold eval_pol.
  rewrite (Psquare_ok sor.(SORsetoid) Rops_wd
    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))  addon.(SORrm));
  now apply (Rtimes_square_nonneg sor).
  (* PsatzMulC *)
  simpl.
  intro.
  case_eq  (eval_Psatz l e) ; simpl ; intros.
  apply IHe in H0.
  apply pexpr_times_nformula_correct with (1:=H0) (2:= H1).
  discriminate.
  (* PsatzMulC *)
  simpl ; intro.
  case_eq (eval_Psatz l e1) ; simpl ; try discriminate.
  case_eq (eval_Psatz l e2) ; simpl ; try discriminate.
  intros.
  apply IHe1 in H1. apply IHe2 in H0.
  apply (nformula_times_nformula_correct env n0 n) ; assumption.
  (* PsatzAdd *)
  simpl ; intro.
  case_eq (eval_Psatz l e1) ; simpl ; try discriminate.
  case_eq (eval_Psatz l e2) ; simpl ; try discriminate.
  intros.
  apply IHe1 in H1. apply IHe2 in H0.
  apply (nformula_plus_nformula_correct env n0 n) ; assumption.
  (* PsatzC *)
  simpl.
  intro. case_eq (cO [<] c).
  intros.  inversion H1. simpl.
  rewrite <- addon.(SORrm).(morph0). now apply cltb_sound.
  discriminate.
  (* PsatzZ *)
  simpl. intros. inversion H0.
  simpl.   apply  addon.(SORrm).(morph0).
Qed.

Fixpoint ge_bool (n m  : nat) : bool :=
 match n with
   | O   => match m with
            |  O => true
            | S _ => false
          end
   | S n  => match m with
               | O => true
               | S m => ge_bool n m
             end
   end.

Lemma ge_bool_cases : forall n m,
 (if ge_bool n m then n >= m else n < m)%nat.
Proof.
  induction n; destruct m ; simpl; auto with arith.
  specialize (IHn m). destruct (ge_bool); auto with arith.
Qed.

Fixpoint xhyps_of_psatz (base:nat) (acc : list nat) (prf : Psatz)  : list nat :=
  match prf with
    | PsatzC _ | PsatzZ | PsatzSquare _ => acc
    | PsatzMulC _ prf => xhyps_of_psatz base acc prf
    | PsatzAdd e1 e2 | PsatzMulE e1 e2 => xhyps_of_psatz base (xhyps_of_psatz base acc e2) e1
    | PsatzIn n => if ge_bool n base then (n::acc) else acc
  end.

Fixpoint nhyps_of_psatz (prf : Psatz) : list nat :=
  match prf with
    | PsatzC _ | PsatzZ | PsatzSquare _ => nil
    | PsatzMulC _ prf => nhyps_of_psatz prf
    | PsatzAdd e1 e2 | PsatzMulE e1 e2 => nhyps_of_psatz e1 ++ nhyps_of_psatz e2
    | PsatzIn n => n :: nil
  end.

Fixpoint extract_hyps (l: list NFormula) (ln : list nat) : list NFormula  :=
  match ln with
    | nil => nil
    | n::ln => nth n l (Pc cO, Equal) :: extract_hyps l ln
  end.

Lemma extract_hyps_app : forall l ln1 ln2,
  extract_hyps l (ln1 ++ ln2) = (extract_hyps l ln1) ++ (extract_hyps l ln2).
Proof.
  induction ln1.
  reflexivity.
  simpl.
  intros.
  rewrite IHln1. reflexivity.
Qed.

Ltac inv H := inversion H ; try subst ; clear H.

Lemma nhyps_of_psatz_correct :  forall (env : PolEnv) (e:Psatz)  (l : list NFormula)  (f: NFormula),
  eval_Psatz l e = Some f ->
  ((forall f', In f' (extract_hyps l (nhyps_of_psatz e)) -> eval_nformula env f') ->  eval_nformula env f).
Proof.
  induction e ; intros.
  (*PsatzIn*)
  simpl in *.
  apply H0. intuition congruence.
  (* PsatzSquare *)
  simpl in *.
  inv H.
  simpl.
  unfold eval_pol.
  rewrite (Psquare_ok sor.(SORsetoid) Rops_wd
    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))  addon.(SORrm));
  now apply (Rtimes_square_nonneg sor).
  (* PsatzMulC *)
  simpl in *.
  case_eq (eval_Psatz l e).
  intros. rewrite H1 in H. simpl in H.
  apply pexpr_times_nformula_correct with (2:= H).
  apply IHe with (1:= H1); auto.
  intros. rewrite H1 in H. simpl in H ; discriminate.
  (* PsatzMulE *)
  simpl in *.
  revert H.
  case_eq (eval_Psatz l e1).
  case_eq (eval_Psatz l e2) ; simpl ; intros.
  apply nformula_times_nformula_correct with (3:= H2).
  apply IHe1 with (1:= H1) ; auto.
  intros. apply H0. rewrite extract_hyps_app.
  apply in_or_app. tauto.
  apply IHe2 with (1:= H) ; auto.
  intros. apply H0. rewrite extract_hyps_app.
  apply in_or_app. tauto.
  discriminate. simpl. discriminate.
  (* PsatzAdd *)
  simpl in *.
  revert H.
  case_eq (eval_Psatz l e1).
  case_eq (eval_Psatz l e2) ; simpl ; intros.
  apply nformula_plus_nformula_correct with (3:= H2).
  apply IHe1 with (1:= H1) ; auto.
  intros. apply H0. rewrite extract_hyps_app.
  apply in_or_app. tauto.
  apply IHe2 with (1:= H) ; auto.
  intros. apply H0. rewrite extract_hyps_app.
  apply in_or_app. tauto.
  discriminate. simpl. discriminate.
  (* PsatzC *)
  simpl in H.
  case_eq (cO [<] c).
  intros.  rewrite H1 in H. inv H.
  unfold eval_nformula. simpl.
  rewrite <- addon.(SORrm).(morph0). now apply cltb_sound.
  intros. rewrite H1 in H. discriminate.
  (* PsatzZ *)
  simpl in *. inv H.
  unfold eval_nformula. simpl.
  apply  addon.(SORrm).(morph0).
Qed.

(* roughly speaking, normalise_pexpr_correct is a proof of
  forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *)

(*****)
Definition paddC := PaddC cplus.
Definition psubC := PsubC cminus.

Definition PsubC_ok : forall c P env, eval_pol env (psubC  P c) == eval_pol env P - [c] :=
  let Rops_wd := mk_reqe (*rplus rtimes ropp req*)
                       sor.(SORplus_wd)
                       sor.(SORtimes_wd)
                       sor.(SORopp_wd) in
                       PsubC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))
                addon.(SORrm).

Definition PaddC_ok : forall c P env, eval_pol env (paddC  P c) == eval_pol env P + [c] :=
  let Rops_wd := mk_reqe (*rplus rtimes ropp req*)
                       sor.(SORplus_wd)
                       sor.(SORtimes_wd)
                       sor.(SORopp_wd) in
                       PaddC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))
                addon.(SORrm).

(* Check that a formula f is inconsistent by normalizing and comparing the
resulting constant with 0 *)

Definition check_inconsistent (f : NFormula) : bool :=
let (e, op) := f in
  match  e with
  | Pc c =>
    match op with
    | Equal => cneqb c cO
    | NonStrict => c [<] cO
    | Strict => c [<=] cO
    | NonEqual => c [=] cO
    end
  | _ => false (* not a constant *)
  end.

Lemma check_inconsistent_sound :
  forall (p : PolC) (op : Op1),
    check_inconsistent (p, op) = true -> forall env, ~ eval_op1 op (eval_pol env p).
Proof.
intros p op H1 env. unfold check_inconsistent in H1.
destruct op; simpl ;
(*****)
destruct p ; simpl; try discriminate H1;
try rewrite <- addon.(SORrm).(morph0); trivial.
now apply cneqb_sound.
apply addon.(SORrm).(morph_eq) in H1. congruence.
apply cleb_sound in H1. now apply -> (Rle_ngt sor).
apply cltb_sound in H1. now apply -> (Rlt_nge sor).
Qed.

Definition check_normalised_formulas : list NFormula -> Psatz -> bool :=
  fun l cm =>
    match eval_Psatz l cm with
      | None => false
      | Some f => check_inconsistent f
    end.

Lemma checker_nf_sound :
  forall (l : list NFormula) (cm : Psatz),
    check_normalised_formulas l cm = true ->
      forall env : PolEnv, make_impl (eval_nformula env) l False.
Proof.
intros l cm H env.
unfold check_normalised_formulas in H.
revert H.
case_eq (eval_Psatz l cm) ; [|discriminate].
intros nf. intros.
rewrite <- make_conj_impl. intro.
assert (H1' := make_conj_in _ _ H1).
assert (Hnf :=  @eval_Psatz_Sound  _ _  H1' _ _ H).
destruct nf.
apply (@check_inconsistent_sound _ _ H0 env Hnf).
Qed.

(** Normalisation of formulae **)

Inductive Op2 : Set := (* binary relations *)
| OpEq
| OpNEq
| OpLe
| OpGe
| OpLt
| OpGt.

Definition eval_op2 (o : Op2) : R -> R -> Prop :=
match o with
| OpEq => req
| OpNEq => fun x y : R => x ~= y
| OpLe => rle
| OpGe => fun x y : R => y <= x
| OpLt => fun x y : R => x < y
| OpGt => fun x y : R => y < x
end.

Definition  eval_pexpr : PolEnv -> PExpr C -> R :=
 PEeval rplus rtimes rminus ropp phi pow_phi rpow.

Record Formula (T:Type) : Type := {
  Flhs : PExpr T;
  Fop : Op2;
  Frhs : PExpr T
}.

Definition eval_formula (env : PolEnv) (f : Formula C) : Prop :=
  let (lhs, op, rhs) := f in
    (eval_op2 op) (eval_pexpr env lhs) (eval_pexpr env rhs).

(* We normalize Formulas by moving terms to one side *)

Definition norm := norm_aux cO cI cplus ctimes cminus copp ceqb.

Definition psub := Psub cO  cplus cminus copp ceqb.

Definition padd  := Padd cO  cplus ceqb.

Definition normalise (f : Formula C) : NFormula :=
let (lhs, op, rhs) := f in
  let lhs := norm lhs in
    let rhs := norm rhs in
  match op with
  | OpEq =>  (psub  lhs rhs, Equal)
  | OpNEq => (psub lhs rhs, NonEqual)
  | OpLe =>  (psub rhs lhs, NonStrict)
  | OpGe =>  (psub lhs rhs, NonStrict)
  | OpGt => (psub  lhs rhs, Strict)
  | OpLt => (psub  rhs lhs, Strict)
  end.

Definition negate (f : Formula C) : NFormula :=
let (lhs, op, rhs) := f in
  let lhs := norm lhs in
    let rhs := norm rhs in
      match op with
        | OpEq => (psub rhs lhs, NonEqual)
        | OpNEq => (psub rhs lhs, Equal)
        | OpLe => (psub lhs rhs, Strict) (* e <= e' == ~ e > e' *)
        | OpGe => (psub rhs lhs, Strict)
        | OpGt => (psub rhs lhs, NonStrict)
        | OpLt => (psub lhs rhs, NonStrict)
      end.

Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub  lhs rhs) == eval_pol env lhs - eval_pol env rhs.
Proof.
  intros.
  apply (Psub_ok  sor.(SORsetoid) Rops_wd
    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)).
Qed.

Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd  lhs rhs) == eval_pol env lhs + eval_pol env rhs.
Proof.
  intros.
  apply (Padd_ok  sor.(SORsetoid) Rops_wd
    (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)).
Qed.

Lemma eval_pol_norm : forall env lhs, eval_pexpr env lhs == eval_pol env  (norm lhs).
Proof.
  intros.
  apply  (norm_aux_spec sor.(SORsetoid) Rops_wd   (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm) addon.(SORpower) ).
Qed.

Theorem normalise_sound :
  forall (env : PolEnv) (f : Formula C),
    eval_formula env f -> eval_nformula env (normalise f).
Proof.
intros env f H; destruct f as [lhs op rhs]; simpl in *.
destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm.
now apply <- (Rminus_eq_0 sor).
intros H1. apply -> (Rminus_eq_0 sor) in H1. now apply H.
now apply -> (Rle_le_minus sor).
now apply -> (Rle_le_minus sor).
now apply -> (Rlt_lt_minus sor).
now apply -> (Rlt_lt_minus sor).
Qed.

Theorem negate_correct :
  forall (env : PolEnv) (f : Formula C),
    eval_formula env f <-> ~ (eval_nformula env (negate f)).
Proof.
intros env f; destruct f as [lhs op rhs]; simpl.
destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm.
symmetry. rewrite (Rminus_eq_0 sor).
split; intro H; [symmetry; now apply -> (Req_dne sor) | symmetry in H; now apply <- (Req_dne sor)].
rewrite (Rminus_eq_0 sor). split; intro; now apply (Rneq_symm sor).
rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor).
rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor).
rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor).
rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor).
Qed.

(** Another normalisation - this is used for cnf conversion **)

Definition xnormalise (t:Formula C) : list (NFormula)  :=
  let (lhs,o,rhs) := t in
  let lhs := norm lhs in
    let rhs := norm rhs in
    match o with
      | OpEq =>
        (psub lhs  rhs, Strict)::(psub rhs lhs , Strict)::nil
      | OpNEq => (psub lhs rhs,Equal) :: nil
      | OpGt   => (psub rhs lhs,NonStrict) :: nil
      | OpLt => (psub lhs rhs,NonStrict) :: nil
      | OpGe => (psub rhs lhs , Strict) :: nil
      | OpLe => (psub lhs rhs ,Strict) :: nil
    end.

Import Coq.micromega.Tauto.

Definition cnf_normalise (t:Formula C) : cnf (NFormula) :=
  List.map  (fun x => x::nil) (xnormalise t).

Add Ring SORRing : sor.(SORrt).

Lemma cnf_normalise_correct : forall env t, eval_cnf eval_nformula env (cnf_normalise t) -> eval_formula env t.
Proof.
  unfold cnf_normalise, xnormalise ; simpl ; intros env t.
  unfold eval_cnf, eval_clause.
  destruct t as [lhs o rhs]; case_eq o ; simpl;
    repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ;
    generalize (eval_pexpr  env lhs);
      generalize (eval_pexpr  env rhs) ; intros z1 z2 ; intros.
  (**)
  apply sor.(SORle_antisymm).
  rewrite  (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
  rewrite  (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
  now rewrite <- (Rminus_eq_0 sor).
  rewrite (Rle_ngt sor).  rewrite (Rlt_lt_minus sor). auto.
  rewrite (Rle_ngt sor).  rewrite (Rlt_lt_minus sor). auto.
  rewrite (Rlt_nge sor).  rewrite (Rle_le_minus sor). auto.
  rewrite (Rlt_nge sor).  rewrite (Rle_le_minus sor). auto.
Qed.

Definition xnegate (t:Formula C) : list (NFormula)  :=
  let (lhs,o,rhs) := t in
    let lhs := norm lhs in
      let rhs := norm rhs in
    match o with
      | OpEq  => (psub lhs rhs,Equal) :: nil
      | OpNEq => (psub lhs  rhs ,Strict)::(psub rhs lhs,Strict)::nil
      | OpGt  => (psub lhs  rhs,Strict) :: nil
      | OpLt  => (psub rhs lhs,Strict) :: nil
      | OpGe  => (psub lhs rhs,NonStrict) :: nil
      | OpLe  => (psub rhs lhs,NonStrict) :: nil
    end.

Definition cnf_negate (t:Formula C) : cnf (NFormula) :=
  List.map  (fun x => x::nil) (xnegate t).

Lemma cnf_negate_correct : forall env t, eval_cnf eval_nformula env (cnf_negate t) -> ~ eval_formula env t.
Proof.
  unfold cnf_negate, xnegate ; simpl ; intros env t.
  unfold eval_cnf, eval_clause.
  destruct t as [lhs o rhs]; case_eq o ; simpl;
    repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ;
    generalize (eval_pexpr  env lhs);
      generalize (eval_pexpr  env rhs) ; intros z1 z2 ; intros ; intuition.
  (**)
  apply H0.
  rewrite H1 ; ring.
  (**)
  apply H1.
  apply sor.(SORle_antisymm).
  rewrite  (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
  rewrite  (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
  (**)
  apply H0. now rewrite  (Rle_le_minus sor) in H1.
  apply H0. now rewrite (Rle_le_minus sor) in H1.
  apply H0. now rewrite (Rlt_lt_minus sor) in H1.
  apply H0. now rewrite (Rlt_lt_minus sor) in H1.
Qed.

Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d).
Proof.
  intros.
  destruct d ; simpl.
  generalize (eval_pol env p); intros.
  destruct o ; simpl.
  apply (Req_em sor r 0).
  destruct (Req_em sor r 0) ; tauto.
  rewrite <- (Rle_ngt sor r 0). generalize (Rle_gt_cases sor r 0). tauto.
  rewrite <- (Rlt_nge sor r 0). generalize (Rle_gt_cases sor 0 r). tauto.
Qed.

(** Reverse transformation *)

Fixpoint xdenorm (jmp : positive) (p: Pol C) : PExpr C :=
  match p with
    | Pc c => PEc c
    | Pinj j p => xdenorm  (Pos.add j jmp ) p
    | PX p j q   => PEadd
      (PEmul (xdenorm jmp p) (PEpow (PEX _  jmp) (Npos j)))
      (xdenorm (Pos.succ jmp) q)
  end.

Lemma xdenorm_correct : forall p i env,
  eval_pol (jump i env) p == eval_pexpr env (xdenorm (Pos.succ i) p).
Proof.
  unfold eval_pol.
  induction p.
  simpl. reflexivity.
  (* Pinj *)
  simpl.
  intros.
  rewrite Pos.add_succ_r.
  rewrite <- IHp.
  symmetry.
  rewrite Pos.add_comm.
  rewrite Pjump_add. reflexivity.
  (* PX *)
  simpl.
  intros.
  rewrite <- IHp1, <- IHp2.
  unfold Env.tail , Env.hd.
  rewrite <- Pjump_add.
  rewrite Pos.add_1_r.
  unfold Env.nth.
  unfold jump at 2.
  rewrite <- Pos.add_1_l.
  rewrite addon.(SORpower).(rpow_pow_N).
  unfold pow_N. ring.
Qed.

Definition denorm := xdenorm xH.

Lemma denorm_correct : forall p env, eval_pol env p == eval_pexpr env (denorm p).
Proof.
  unfold denorm.
  induction p.
  reflexivity.
  simpl.
  rewrite Pos.add_1_r.
  apply xdenorm_correct.
  simpl.
  intros.
  rewrite IHp1.
  unfold Env.tail.
  rewrite xdenorm_correct.
  change (Pos.succ xH) with 2%positive.
  rewrite addon.(SORpower).(rpow_pow_N).
  simpl. reflexivity.
Qed.

(** Sometimes it is convenient to make a distinction between "syntactic" coefficients and "real"
coefficients that are used to actually compute *)

Variable S : Type.

Variable C_of_S : S -> C.

Variable phiS : S -> R.

Variable phi_C_of_S :   forall c,  phiS c =  phi (C_of_S c).

Fixpoint map_PExpr (e : PExpr S) : PExpr C :=
  match e with
    | PEc c => PEc (C_of_S c)
    | PEX _ p => PEX _ p
    | PEadd e1 e2 => PEadd (map_PExpr e1) (map_PExpr e2)
    | PEsub e1 e2 => PEsub (map_PExpr e1) (map_PExpr e2)
    | PEmul e1 e2 => PEmul (map_PExpr e1) (map_PExpr e2)
    | PEopp e     => PEopp (map_PExpr e)
    | PEpow e n   => PEpow (map_PExpr e) n
  end.

Definition map_Formula (f : Formula S)  : Formula C :=
  let (l,o,r) := f in
    Build_Formula (map_PExpr l) o (map_PExpr r).

Definition eval_sexpr : PolEnv -> PExpr S -> R :=
  PEeval rplus rtimes rminus ropp phiS pow_phi rpow.

Definition eval_sformula (env : PolEnv) (f : Formula S) : Prop :=
  let (lhs, op, rhs) := f in
    (eval_op2 op) (eval_sexpr env lhs) (eval_sexpr env rhs).

Lemma eval_pexprSC : forall env s, eval_sexpr env s = eval_pexpr env (map_PExpr s).
Proof.
  unfold eval_pexpr, eval_sexpr.
  induction s ; simpl ; try (rewrite IHs1 ; rewrite IHs2) ; try reflexivity.
  apply phi_C_of_S.
  rewrite IHs. reflexivity.
  rewrite IHs. reflexivity.
Qed.

(** equality migth be (too) strong *)
Lemma eval_formulaSC : forall env f, eval_sformula env f = eval_formula env (map_Formula f).
Proof.
  destruct f.
  simpl.
  repeat rewrite eval_pexprSC.
  reflexivity.
Qed.

(** Some syntactic simplifications of expressions  *)

Definition simpl_cone (e:Psatz) : Psatz :=
  match e with
    | PsatzSquare t =>
                    match t with
                      | Pc c   => if ceqb cO c then PsatzZ else PsatzC (ctimes c c)
                      | _ => PsatzSquare t
                    end
    | PsatzMulE t1 t2 =>
      match t1 , t2 with
        | PsatzZ      , x        => PsatzZ
        |    x     , PsatzZ      => PsatzZ
        | PsatzC c ,  PsatzC c' => PsatzC (ctimes c c')
        | PsatzC p1 , PsatzMulE (PsatzC p2)  x => PsatzMulE (PsatzC (ctimes p1 p2)) x
        | PsatzC p1 , PsatzMulE x (PsatzC p2)  => PsatzMulE (PsatzC (ctimes p1 p2)) x
        | PsatzMulE (PsatzC p2)  x  , PsatzC p1   => PsatzMulE (PsatzC (ctimes p1 p2)) x
        | PsatzMulE x (PsatzC p2)   , PsatzC p1   => PsatzMulE (PsatzC (ctimes p1 p2)) x
        | PsatzC x   , PsatzAdd y z   => PsatzAdd (PsatzMulE (PsatzC x) y) (PsatzMulE (PsatzC x) z)
        | PsatzC c ,  _        => if ceqb cI c then t2 else PsatzMulE t1 t2
        | _ ,  PsatzC c        => if ceqb cI c then t1 else PsatzMulE t1 t2
        |     _     , _   => e
      end
    | PsatzAdd t1 t2 =>
      match t1 ,  t2 with
        | PsatzZ     , x => x
        |   x     , PsatzZ => x
        |   x     , y   => PsatzAdd x y
      end
    |   _     => e
  end.

End Micromega.

(* Local Variables: *)
(* coding: utf-8 *)
(* End: *)


Require Import List.

Require Import Logic.Class.Eq.

Require Import Logic.Func.Replace.
Require Import Logic.Func.Composition.

Require Import Logic.Fol.Free.
Require Import Logic.Fol.Valid.
Require Import Logic.Fol.Functor.

Require Import Logic.Set.Set.
Require Import Logic.Set.Equal.

Require Import Logic.Lang1.Syntax.
Require Import Logic.Lang1.Semantics.
Require Import Logic.Lang1.Relevance.
Require Import Logic.Lang1.Environment.
Require Import Logic.Lang1.Substitution.

(* A formula with a free variable could be viewed as a predicate which needs to *)
(* be 'evaluated' at some variable, where such evaluation corresponds to a      *)
(* variable substitution. In the following, we formalize this evaluation by     *)
(* substituting the variable '0' by the argument 'n'. This choice of variable   *)
(* '0' is arbitrary, but having this default choice leads to simpler syntax as  *)
(* there is no need to spell out which variable is being replaced. There is     *)
(* nothing deep here, as we are just creating a new formula from an old one.    *)
(* The ability to apply a formula viewed as predicate to variables is important *)
(* for two variables, and is needed to express the axiom schema of replacement. *)

Definition apply (p:Formula) (n:nat) : Formula := fmap (n // 0) p.

(* Same idea, but with two variables.                                           *)
Definition apply2 (p:Formula) (n m:nat) : Formula := fmap (replace2 0 1 n m) p.

(* The semantics of 'apply p n' in an environement where n is bound to set x    *)
(* is the same as the semantics of p in an environment where 0 is bound to x.   *)
(* However, we cannot hope to obtain this semantics equivalence without         *)
(* assuming that the replacement of variable 0 by n is a valid substitution     *)
(* for p. Also, n cannot already be a free variable of p.                       *)

Lemma evalApply1 : forall (e:Env) (p:Formula) (n:nat) (x:set),
    valid (n // 0) p ->
    ~In n (Fr p)        ->
    eval1 e (apply p n) n x <-> eval1 e p 0 x.
Proof.
    unfold eval1, apply. intros e p n x H1 H2. rewrite Substitution.
    - apply relevance. intros m H3. apply bindReplace. intros H4.
      subst. apply H2. assumption.
    - assumption.
Qed.

(* The semantics of 'apply2 p n m' in an environment where n is bound to x and  *)
(* m is bound to y, is the same as the semantics of p in an environment where 0 *)
(* is bound to x and 1 is bound to y, with the obvious caveat.                  *)
Lemma evalApply2 : forall (e:Env) (p:Formula) (n m:nat) (x y:set),
    valid (replace2 0 1 n m) p ->
    ~In n (Fr p)  ->
    ~In m (Fr p)  ->
    n <> m          ->
    eval2 e (apply2 p n m) n m x y <-> eval2 e p 0 1 x y.
Proof.
    unfold eval2, apply2. intros e p n m x y H1 H2 H3 H4. rewrite Substitution.
    - apply relevance. intros r H5. unfold comp. apply bindReplace2.
        + auto.
        + apply H4.                                     (* <- H4 *)
        + intros H6. apply H2. rewrite H6. assumption.  (* <- H2 *)
        + intros H6. apply H3. rewrite H6. assumption.  (* <- H3 *)
    - apply H1.                                         (* <- H1 *)
Qed.

Lemma evalApplyF1 : forall (e:Env) (p:Formula) (n m m':nat) (x y y':set),
    n <> m  ->
    n <> m' ->
    m <> m' ->
    valid (replace2 0 1 n m) p ->
    ~ In m' (Fr p) ->
    ~ In m  (Fr p) ->
    ~ In n  (Fr p) ->
    eval (bind (bind (bind e n x) m y) m' y') (apply2 p n m)
    <->
    eval (bind (bind e 0 x) 1 y) p.
Proof.
    intros e p n m m' x y y' H1 H2 H3 H4 H1' H2' H3'.
    unfold apply2. rewrite Substitution.
    remember (bind (bind (bind e n x) m y) m' y'; replace2 0 1 n m)
    as e1 eqn:E1. remember (bind (bind e 0 x) 1 y) as e2 eqn:E2.
    apply (relevance e1 e2).
    - intros k H5. rewrite E1, E2. unfold comp, bind, replace2.
      destruct (eqDec k 0) as [H6|H6] eqn:K0.
        + subst. destruct (eqDec m' n) as [H7|H7].
            { subst. exfalso. apply H2. reflexivity. }
            { destruct (eqDec m n) as [H8|H8].
                { subst. exfalso. apply H1. reflexivity. }
                { simpl. destruct (PeanoNat.Nat.eq_dec n n) as [H9|H9].
                    { apply equalRefl. }
                    { exfalso. apply H9. reflexivity. }}}
        + destruct (eqDec k 1) as [H7|H7] eqn:K1.
            { subst. destruct (eqDec m' m) as [H7|H7].
                { subst. exfalso. apply H3. reflexivity. }
                { simpl. destruct (PeanoNat.Nat.eq_dec m m) as [H8|H8].
                    { apply equalRefl. }
                    { exfalso. apply H8. reflexivity. }}}
            { destruct (eqDec m' k) as [H8|H8].
                { subst. exfalso. apply H1'. assumption. }
                { destruct (eqDec m k) as [H9|H9].
                    { subst. exfalso. apply H2'. assumption. }
                    { destruct (eqDec n k) as [H10|H10].
                        { subst. exfalso. apply H3'. assumption. }
                        { destruct (eqDec 0 k) as [H11|H11];
                          destruct (eqDec 1 k) as [H12|H12].
                            { subst. inversion H12. }
                            { exfalso. apply H6. symmetry. assumption. }
                            { exfalso. apply H7. symmetry. assumption. }
                            { apply equalRefl. }}}}}
    - assumption.
Qed.

Lemma evalApplyF2 : forall (e:Env) (p:Formula) (n m m':nat) (x y y':set),
    n <> m  ->
    n <> m' ->
    m <> m' ->
    valid (replace2 0 1 n m') p ->
    ~ In m' (Fr p) ->
    ~ In m  (Fr p) ->
    ~ In n  (Fr p) ->
    eval (bind (bind (bind e n x) m y) m' y') (apply2 p n m')
    <->
    eval (bind (bind e 0 x) 1 y') p.
Proof.
    intros e p n m m' x y y' H1 H2 H3 H4 H1' H2' H3'.
    remember (bind (bind (bind e n x) m y) m' y') as e1 eqn:E1.
    remember (bind (bind (bind e n x) m' y') m y) as e2 eqn:E2.
    remember (bind (bind e 0 x) 1 y') as e3 eqn:E3.
    assert (envEqual e1 e2) as H5.
        { rewrite E1, E2. apply bindPermute. apply not_eq_sym. assumption. }
    assert (eval e1 (apply2 p n m') <-> eval e2 (apply2 p n m')) as H6.
        { apply evalEnvEqual. assumption. }
    rewrite H6, E2, E3. apply evalApplyF1; try (assumption).
    apply not_eq_sym. assumption.
Qed.


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

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

Print Assumptions add.


Parameter A : Set.
Definition Eq : A -> A -> Prop :=
  fun x y => forall P : A -> Prop, P x <-> P y.
Lemma Eq_eq : forall x y, Eq x y <-> x = y.
Proof.
  unfold iff, Eq.
  split.
  intro.
  apply H.
  reflexivity.
  intros.
  rewrite H.
  apply iff_refl.
Qed.


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

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

Print Assumptions sub.


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.