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

(** * DecimalPos

    Proofs that conversions between decimal numbers and [positive]
    are bijections. *)

Require Import Decimal DecimalFacts PArith NArith DecimalBin.

Module Unsigned.

Local Open Scope N.

(** A direct version of [of_little_uint] *)
Fixpoint of_lu (d:uint) : N :=
  match d with
  | Nil => 0
  | D0 d => 10 * of_lu d
  | D1 d => 1 + 10 * of_lu d
  | D2 d => 2 + 10 * of_lu d
  | D3 d => 3 + 10 * of_lu d
  | D4 d => 4 + 10 * of_lu d
  | D5 d => 5 + 10 * of_lu d
  | D6 d => 6 + 10 * of_lu d
  | D7 d => 7 + 10 * of_lu d
  | D8 d => 8 + 10 * of_lu d
  | D9 d => 9 + 10 * of_lu d
  end.

Definition hd d :=
match d with
 | Nil => 0
 | D0 _ => 0
 | D1 _ => 1
 | D2 _ => 2
 | D3 _ => 3
 | D4 _ => 4
 | D5 _ => 5
 | D6 _ => 6
 | D7 _ => 7
 | D8 _ => 8
 | D9 _ => 9
end.

Definition tl d :=
 match d with
 | Nil => d
 | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d => d
end.

Lemma of_lu_eqn d :
 of_lu d = hd d + 10 * (of_lu (tl d)).
Proof.
 induction d; simpl; trivial.
Qed.

Ltac simpl_of_lu :=
 match goal with
 | |- context [ of_lu (?f ?x) ] =>
   rewrite (of_lu_eqn (f x)); simpl hd; simpl tl
 end.

Fixpoint usize (d:uint) : N :=
  match d with
  | Nil => 0
  | D0 d => N.succ (usize d)
  | D1 d => N.succ (usize d)
  | D2 d => N.succ (usize d)
  | D3 d => N.succ (usize d)
  | D4 d => N.succ (usize d)
  | D5 d => N.succ (usize d)
  | D6 d => N.succ (usize d)
  | D7 d => N.succ (usize d)
  | D8 d => N.succ (usize d)
  | D9 d => N.succ (usize d)
  end.

Lemma of_lu_revapp d d' :
 of_lu (revapp d d') =
  of_lu (rev d) + of_lu d' * 10^usize d.
Proof.
 revert d'.
 induction d; simpl; intro d'; [ now rewrite N.mul_1_r | .. ];
 unfold rev; simpl revapp; rewrite 2 IHd;
 rewrite <- N.add_assoc; f_equal; simpl_of_lu; simpl of_lu;
 rewrite N.pow_succ_r'; ring.
Qed.

Definition Nadd n p :=
 match n with
 | N0 => p
 | Npos p0 => (p0+p)%positive
 end.

Lemma Nadd_simpl n p q : Npos (Nadd n (p * q)) = n + Npos p * Npos q.
Proof.
 now destruct n.
Qed.

Lemma of_uint_acc_eqn d acc : d<>Nil ->
 Pos.of_uint_acc d acc = Pos.of_uint_acc (tl d) (Nadd (hd d) (10*acc)).
Proof.
 destruct d; simpl; trivial. now destruct 1.
Qed.

Lemma of_uint_acc_rev d acc :
 Npos (Pos.of_uint_acc d acc) =
  of_lu (rev d) + (Npos acc) * 10^usize d.
Proof.
 revert acc.
 induction d; intros; simpl usize;
 [ simpl; now rewrite Pos.mul_1_r | .. ];
 rewrite N.pow_succ_r';
 unfold rev; simpl revapp; try rewrite of_lu_revapp; simpl of_lu;
 rewrite of_uint_acc_eqn by easy; simpl tl; simpl hd;
 rewrite IHd, Nadd_simpl; ring.
Qed.

Lemma of_uint_alt d : Pos.of_uint d = of_lu (rev d).
Proof.
 induction d; simpl; trivial; unfold rev; simpl revapp;
 rewrite of_lu_revapp; simpl of_lu; try apply of_uint_acc_rev.
 rewrite IHd. ring.
Qed.

Lemma of_lu_rev d : Pos.of_uint (rev d) = of_lu d.
Proof.
 rewrite of_uint_alt. now rewrite rev_rev.
Qed.

Lemma of_lu_double_gen d :
  of_lu (Little.double d) = N.double (of_lu d) /\
  of_lu (Little.succ_double d) = N.succ_double (of_lu d).
Proof.
 rewrite N.double_spec, N.succ_double_spec.
 induction d; try destruct IHd as (IH1,IH2);
 simpl Little.double; simpl Little.succ_double;
 repeat (simpl_of_lu; rewrite ?IH1, ?IH2); split; reflexivity || ring.
Qed.

Lemma of_lu_double d :
  of_lu (Little.double d) = N.double (of_lu d).
Proof.
 apply of_lu_double_gen.
Qed.

Lemma of_lu_succ_double d :
  of_lu (Little.succ_double d) = N.succ_double (of_lu d).
Proof.
 apply of_lu_double_gen.
Qed.

(** First bijection result *)

Lemma of_to (p:positive) : Pos.of_uint (Pos.to_uint p) = Npos p.
Proof.
 unfold Pos.to_uint.
 rewrite of_lu_rev.
 induction p; simpl; trivial.
 - now rewrite of_lu_succ_double, IHp.
 - now rewrite of_lu_double, IHp.
Qed.

(** The other direction *)

Definition to_lu n :=
  match n with
  | N0 => Decimal.zero
  | Npos p => Pos.to_little_uint p
  end.

Lemma succ_double_alt d :
  Little.succ_double d = Little.succ (Little.double d).
Proof.
 now induction d.
Qed.

Lemma double_succ d :
  Little.double (Little.succ d) =
  Little.succ (Little.succ_double d).
Proof.
 induction d; simpl; f_equal; auto using succ_double_alt.
Qed.

Lemma to_lu_succ n :
 to_lu (N.succ n) = Little.succ (to_lu n).
Proof.
 destruct n; simpl; trivial.
 induction p; simpl; rewrite ?IHp;
  auto using succ_double_alt, double_succ.
Qed.

Lemma nat_iter_S n {A} (f:A->A) i :
 Nat.iter (S n) f i = f (Nat.iter n f i).
Proof.
 reflexivity.
Qed.

Lemma nat_iter_0 {A} (f:A->A) i : Nat.iter 0 f i = i.
Proof.
 reflexivity.
Qed.

Lemma to_ldec_tenfold p :
 to_lu (10 * Npos p) = D0 (to_lu (Npos p)).
Proof.
 induction p using Pos.peano_rect.
 - trivial.
 - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)).
   rewrite N.mul_succ_r.
   change 10 at 2 with (Nat.iter 10%nat N.succ 0).
   rewrite ?nat_iter_S, nat_iter_0.
   rewrite !N.add_succ_r, N.add_0_r, !to_lu_succ, IHp.
   destruct (to_lu (N.pos p)); simpl; auto.
Qed.

Lemma of_lu_0 d : of_lu d = 0 <-> nztail d = Nil.
Proof.
 induction d; try simpl_of_lu; split; trivial; try discriminate;
 try (intros H; now apply N.eq_add_0 in H).
 - rewrite N.add_0_l. intros H.
   apply N.eq_mul_0_r in H; [|easy]. rewrite IHd in H.
   simpl. now rewrite H.
 - simpl. destruct (nztail d); try discriminate.
   now destruct IHd as [_ ->].
Qed.

Lemma to_of_lu_tenfold d :
 to_lu (of_lu d) = lnorm d ->
 to_lu (10 * of_lu d) = lnorm (D0 d).
Proof.
 intro IH.
 destruct (N.eq_dec (of_lu d) 0) as [H|H].
 - rewrite H. simpl. rewrite of_lu_0 in H.
   unfold lnorm. simpl. now rewrite H.
 - destruct (of_lu d) eqn:Eq; [easy| ].
   rewrite to_ldec_tenfold; auto. rewrite IH.
   rewrite <- Eq in H. rewrite of_lu_0 in H.
   unfold lnorm. simpl. now destruct (nztail d).
Qed.

Lemma Nadd_alt n m : n + m = Nat.iter (N.to_nat n) N.succ m.
Proof.
 destruct n. trivial.
 induction p using Pos.peano_rect.
 - now rewrite N.add_1_l.
 - change (N.pos (Pos.succ p)) with (N.succ (N.pos p)).
   now rewrite N.add_succ_l, IHp, N2Nat.inj_succ.
Qed.

Ltac simpl_to_nat := simpl N.to_nat; unfold Pos.to_nat; simpl Pos.iter_op.

Lemma to_of_lu d : to_lu (of_lu d) = lnorm d.
Proof.
 induction d; [reflexivity|..];
 simpl_of_lu; rewrite Nadd_alt; simpl_to_nat;
 rewrite ?nat_iter_S, nat_iter_0, ?to_lu_succ, to_of_lu_tenfold by assumption;
 unfold lnorm; simpl; destruct nztail; auto.
Qed.

(** Second bijection result *)

Lemma to_of (d:uint) : N.to_uint (Pos.of_uint d) = unorm d.
Proof.
 rewrite of_uint_alt.
 unfold N.to_uint, Pos.to_uint.
 destruct (of_lu (rev d)) eqn:H.
 - rewrite of_lu_0 in H. rewrite <- rev_lnorm_rev.
   unfold lnorm. now rewrite H.
 - change (Pos.to_little_uint p) with (to_lu (N.pos p)).
   rewrite <- H. rewrite to_of_lu. apply rev_lnorm_rev.
Qed.

(** Some consequences *)

Lemma to_uint_nonzero p : Pos.to_uint p <> zero.
Proof.
 intro E. generalize (of_to p). now rewrite E.
Qed.

Lemma to_uint_nonnil p : Pos.to_uint p <> Nil.
Proof.
 intros E. generalize (of_to p). now rewrite E.
Qed.

Lemma to_uint_inj p p' : Pos.to_uint p = Pos.to_uint p' -> p = p'.
Proof.
 intro E.
 assert (E' : N.pos p = N.pos p').
 { now rewrite <- (of_to p), <- (of_to p'), E. }
 now injection E'.
Qed.

Lemma to_uint_pos_surj d :
 unorm d<>zero -> exists p, Pos.to_uint p = unorm d.
Proof.
 intros.
 destruct (Pos.of_uint d) eqn:E.
 - destruct H. generalize (to_of d). now rewrite E.
 - exists p. generalize (to_of d). now rewrite E.
Qed.

Lemma of_uint_norm d : Pos.of_uint (unorm d) = Pos.of_uint d.
Proof.
 now induction d.
Qed.

Lemma of_inj d d' :
 Pos.of_uint d = Pos.of_uint d' -> unorm d = unorm d'.
Proof.
 intros. rewrite <- !to_of. now f_equal.
Qed.

Lemma of_iff d d' : Pos.of_uint d = Pos.of_uint d' <-> unorm d = unorm d'.
Proof.
 split. apply of_inj. intros E. rewrite <- of_uint_norm, E.
 apply of_uint_norm.
Qed.

End Unsigned.

(** Conversion from/to signed decimal numbers *)

Module Signed.

Lemma of_to (p:positive) : Pos.of_int (Pos.to_int p) = Some p.
Proof.
 unfold Pos.to_int, Pos.of_int, norm.
 now rewrite Unsigned.of_to.
Qed.

Lemma to_of (d:int)(p:positive) :
 Pos.of_int d = Some p -> Pos.to_int p = norm d.
Proof.
 unfold Pos.of_int.
 destruct d; [ | intros [=]].
 simpl norm. rewrite <- Unsigned.to_of.
 destruct (Pos.of_uint d); now intros [= <-].
Qed.

Lemma to_int_inj p p' : Pos.to_int p = Pos.to_int p' -> p = p'.
Proof.
 intro E.
 assert (E' : Some p = Some p').
 { now rewrite <- (of_to p), <- (of_to p'), E. }
 now injection E'.
Qed.

Lemma to_int_pos_surj d :
 unorm d <> zero -> exists p, Pos.to_int p = norm (Pos d).
Proof.
 simpl. unfold Pos.to_int. intros H.
 destruct (Unsigned.to_uint_pos_surj d H) as (p,Hp).
 exists p. now f_equal.
Qed.

Lemma of_int_norm d : Pos.of_int (norm d) = Pos.of_int d.
Proof.
 unfold Pos.of_int.
 destruct d.
 - simpl. now rewrite Unsigned.of_uint_norm.
 - simpl. now destruct (nzhead d) eqn:H.
Qed.

Lemma of_inj_pos d d' :
 Pos.of_int (Pos d) = Pos.of_int (Pos d') -> unorm d = unorm d'.
Proof.
 unfold Pos.of_int.
 destruct (Pos.of_uint d) eqn:Hd, (Pos.of_uint d') eqn:Hd';
  intros [=].
 - apply Unsigned.of_inj; now rewrite Hd, Hd'.
 - apply Unsigned.of_inj; rewrite Hd, Hd'; now f_equal.
Qed.

End Signed.


Require Import ssreflect.
Require Import seq.
Require Import eqtype.
Require Import ssrnat.
Require Import ssrfun.
Require Import ssrbool.
Require Import fintype.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Section Def.

Variables (n : nat) (T : Type).

Record tuple_of : Type := Tuple {tval :> seq T; _ : size tval == n}.

Canonical Structure tuple_subType := SubType tval tuple_of_rect vrefl.

Lemma size_tuple : forall t : tuple_of, size t = n.
Proof. move=> f; exact: (eqP (valP f)). Qed.

Lemma tsub_default : forall (t : tuple_of) (i : 'I_n), T.
Proof. by case=> [[|//]]; move/eqP <-; case. Qed.

Definition tsub t i := sub (tsub_default t i) t i.

Lemma tsub_sub : forall x t i, tsub t i = sub x t i.
Proof. by move=> x t i; apply: set_sub_default; rewrite size_tuple. Qed.

Lemma maps_tsub_enum : forall t, maps (tsub t) (enum 'I_n) = t.
Proof.
move=> t; case def_t: {-}(val t) => [|x0 t'].
  by rewrite [enum _]size_eq0 // -cardE card_ord -(size_tuple t) def_t.
apply: (@eq_from_sub _ x0) => [|i]; rewrite size_maps.
  by rewrite -cardE size_tuple card_ord.
move=> lt_i_e; have lt_i_n: i < n by rewrite -cardE card_ord in lt_i_e.
by rewrite (sub_maps (Ordinal lt_i_n)) // (tsub_sub x0) sub_enum_ord.
Qed.

Lemma eq_from_tsub : forall t1 t2, tsub t1 =1 tsub t2 -> t1 = t2.
Proof.
by move=> *; apply: val_inj; rewrite /= -!maps_tsub_enum; exact: eq_maps.
Qed.

Definition tuple t s & phantom (seq T) (tval t) -> phantom (seq T) s := t.

Definition tsize of tuple_of := n.

End Def.

Notation "n .-tuple" := (tuple_of n)
  (at level 2, format "n .-tuple") : type_scope.

Notation "{ 'tuple' n 'of' T }" := (n.-tuple T : predArgType)
  (at level 0, only parsing) : form_scope.

Notation "[ 'tuple' 'of' s ]" := (@tuple _ _ _ s id)
  (at level 0, format "[ 'tuple'  'of'  s ]") : form_scope.

Notation "[ 'tsub' t i ]" := (tsub t (@Ordinal (tsize t) i (erefl true)))
  (at level 0, t, i at level 8, format "[ 'tsub'  t  i ]") : form_scope.

Canonical Structure seq0_tuple T :=
   Tuple (erefl _ : @size T [::] == 0).
Canonical Structure adds_tuple n T x (t : n.-tuple T) :=
   Tuple (valP t : size (x :: t) == n.+1).

Notation "[ 'tuple' x1 ; .. ; xn ]" := [tuple of x1 :: .. [:: xn] ..]
  (at level 0, format "[ 'tuple' '['  x1 ; '/'  .. ; '/'  xn ']' ]")
  : form_scope.

Notation "[ 'tuple' ]" := [tuple of [::]]
  (at level 0, format "[ 'tuple' ]") : form_scope.

Section SeqTuple.

Variables (n : nat) (T rT : Type).
Notation tT := (n.-tuple T).

Lemma seqn_tupleP : forall x : T, size (seqn n x) == n.
Proof. by move=> x; rewrite size_seqn. Qed.
Canonical Structure seqn_tuple x := Tuple (seqn_tupleP x).

Lemma iota_tupleP : forall m, size (iota m n) == n.
Proof. by move=> m; rewrite size_iota. Qed.
Canonical Structure iota_tuple m := Tuple (iota_tupleP m).

Lemma behead_tupleP : forall t : tT, size (behead t) == n.-1.
Proof. by move=> t; rewrite size_behead size_tuple. Qed.
Canonical Structure behead_tuple t := Tuple (behead_tupleP t).

Lemma belast_tupleP : forall x (t : tT), size (belast x t) == n.
Proof. by move=> x t; rewrite size_belast size_tuple. Qed.
Canonical Structure belast_tuple x t := Tuple (belast_tupleP x t).

Lemma cat_tupleP : forall n1 n2 (t1 : n1.-tuple T) (t2 : n2.-tuple T),
  size (t1 ++ t2) == n1 + n2.
Proof. by move=> n1 n2 t1 t2; rewrite size_cat !size_tuple. Qed.
Canonical Structure cat_tuple n1 n2 t1 t2 := Tuple (@cat_tupleP n1 n2 t1 t2).

Lemma take_tupleP : forall m (t : tT), size (take m t) == minn m n.
Proof. by move=> m t; rewrite size_take size_tuple eqxx. Qed.
Canonical Structure take_tuple m t := Tuple (take_tupleP m t).

Lemma drop_tupleP : forall m (t : tT), size (drop m t) == n - m.
Proof. by move=> m t; rewrite size_drop size_tuple. Qed.
Canonical Structure drop_tuple m t := Tuple (drop_tupleP m t).

Lemma rev_tupleP : forall t : tT, size (rev t) == n.
Proof. by move=> t; rewrite size_rev size_tuple. Qed.
Canonical Structure rev_tuple t := Tuple (rev_tupleP t).

Lemma rot_tupleP : forall m (t : tT), size (rot m t) == n.
Proof. by move=> m t; rewrite size_rot size_tuple. Qed.
Canonical Structure rot_tuple m t := Tuple (rot_tupleP m t).

Lemma rotr_tupleP : forall m (t : tT), size (rotr m t) == n.
Proof. by move=> m t; rewrite size_rotr size_tuple. Qed.
Canonical Structure rotr_tuple m t := Tuple (rotr_tupleP m t).

Lemma maps_tupleP : forall f (t : tT), @size rT (maps f t) == n.
Proof. by move=> f t; rewrite size_maps size_tuple. Qed.
Canonical Structure maps_tuple f t := Tuple (maps_tupleP f t).

Lemma scanl_tupleP : forall f x (t : tT), @size rT (scanl f x t) == n.
Proof. by move=> f x t; rewrite size_scanl size_tuple. Qed.
Canonical Structure scanl_tuple f x t := Tuple (scanl_tupleP f x t).

Lemma pairmap_tupleP : forall f x (t : tT), @size rT (pairmap f x t) == n.
Proof. by move=> f x t; rewrite size_pairmap size_tuple. Qed.
Canonical Structure pairmap_tuple f x t := Tuple (pairmap_tupleP f x t).

Lemma zip_tupleP : forall t1 t2 : tT, size (zip t1 t2) == n.
Proof. by move=> *; rewrite size1_zip !size_tuple. Qed.
Canonical Structure zip_tuple t1 t2 := Tuple (zip_tupleP t1 t2).

Definition thead (n : pos_nat) (t : n.-tuple T) := tsub t ord0.

Lemma tsub0 : forall x n (t : n.-tuple T), tsub [tuple of x :: t] ord0 = x.
Proof. by []. Qed.

Lemma theadE : forall x n (t : n.-tuple T), thead [tuple of x :: t] = x.
Proof. by []. Qed.

Lemma tuple0 : forall t : 0.-tuple T, t = [tuple].
Proof. by move=> t; apply: val_inj; case: t => [[]]. Qed.

CoInductive tuple1_spec : n.+1.-tuple T -> Type :=
  Tuple1spec x (t : tT) : tuple1_spec [tuple of x :: t].

Lemma tupleP : forall t, tuple1_spec t.
Proof.
move=> [[|x t] //= sz_t]; pose t' := Tuple (sz_t : size t == n).
rewrite (_ : Tuple _ = [tuple of x :: t']) //; exact: val_inj.
Qed.

Lemma tsub_maps : forall f (t : tT) i,
  tsub [tuple of maps f t] i = f (tsub t i) :> rT.
Proof. by move=> f t i; apply: sub_maps; rewrite size_tuple. Qed.

End SeqTuple.

Lemma tsub_behead : forall (n : pos_nat) T (t : n.+1.-tuple T) i,
  tsub [tuple of behead t] i = tsub t (inord i.+1).
Proof.
by move=> n T; case/tupleP=> x t i; rewrite !(tsub_sub x) inordK ?ltnS.
Qed.

Lemma tuple_eta : forall n T (t : n.+1.-tuple T),
  t = [tuple of thead t :: behead t].
Proof. move=> n T; case/tupleP=> x t; exact: val_inj. Qed.

Section EqTuple.

Variables (n : nat) (T : eqType).

Canonical Structure tuple_eqType := Eval hnf in [subEqType for @tval n T].

Canonical Structure tuple_predType :=
  Eval hnf in mkPredType (fun t : n.-tuple T => mem_seq t).

Lemma memtE : forall t : n.-tuple T, mem t = mem (tval t).
Proof. by []. Qed.

End EqTuple.

Section FinTuple.

Variables (n : nat) (T : finType).
Notation tT := (n.-tuple T).

Lemma tuple_enum : {enumMixin tT}.
Proof.
elim: n => [|m [et cnt_et]].
  by exists [:: ([tuple] : 0.-tuple T)] => t; rewrite /= [t]tuple0.
exists (foldr (fun x => cat (maps (adds_tuple x) et)) [::] (enum T)).
case/tupleP=> x t; rewrite -[1]/(x \in T : nat) -(mem_enum T).
elim: (enum T) (uniq_enum T) => //= y e IHe; case/andP=> ney.
rewrite count_cat count_maps in_adds; move/IHe->.
rewrite -[preim _ _]/[fun t' => (y == x) && (t' == t)] /= eq_sym.
by move/negPf: ney; case: eqP => [-> -> | _ _]; rewrite (cnt_et, count_pred0).
Qed.

Definition tuple_finMixin := @FinMixin tT _ tuple_enum.
Canonical Structure tuple_finType := FinClass tuple_finMixin.
Canonical Structure tuple_subFinType := SubFinType tuple_finMixin.

Lemma enum_tupleP : forall a : pred T, size (enum a) == #|a|.
Proof. by move=> a; rewrite -cardE. Qed.
Canonical Structure enum_tuple a := Tuple (enum_tupleP a).

Definition ord_tuple : n.-tuple 'I_n := Tuple (introT eqP (size_enum_ord n)).
Lemma val_ord_tuple : val ord_tuple = enum 'I_n. Proof. by []. Qed.

Lemma tuple_maps_ord : forall T' (t : n.-tuple T'),
  t = [tuple of maps (tsub t) ord_tuple].
Proof. by move=> T' t; apply: val_inj => /=; rewrite maps_tsub_enum. Qed.

End FinTuple.


(*
  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   : Inversion of square matrix
  author    : ZhengPu Shi
  date      : 2022.08

  remark    :
  1. 行列式(determinant)的三种方法，参考：https://zhuanlan.zhihu.com/p/435900775
  a. 按行/列展开，用代数余子式的定义来计算。
    每展开一次，相当于降了一阶。
    注意：按行/列展开，是拉普拉斯展开定理的特例。
  b. 利用初等变换。
  c. 逆序数法求行列式，也就是按定义。

  2. 利用行列式计算逆矩阵的算法，从Coq到OCaml，测试结果
  n=8, 1.1s;  n=9, 12s;  n=10, 120s
  主要问题：
  a. 看到CPU占用过高，但内存并不高。
  b. 可能是 nat 结构不合理，最好是 int 类型的下标。可以考虑OCaml直接写一个版本。
  c. 可能是 det 函数不断的递归导致。
  所以，用OCaml仿照同样的思路，可以写多个版本来测试，以便排除是否为算法问题导致。
  a. 版本1，仍然使用 NatFun 风格，但是是 int 下标
  b. 版本2，使用 array 结构
  c. 版本3，使用 matrix (bigarray) 结构

  版本1的测试结果
  n=8, 0.25s;  n=9, 2.4s;  n=10, 32s
  这一版还是很慢，可能是函数式风格的原因？？

  版本2的测试结果
  n=8, 1s;  n=9,7s; n=10,未测试
  这一版反而更慢了，array的开销为什么这么大，也许是for循环太多导致

*)

Require Import StrExt.
Require Export Matrix.
Require RAST.

(* ==================================== *)
(** ** 一些通用的策略，以后要整理到一个合适的位置 *)

(** 列表相等转换为元素相等 *)
(* Ltac tac_listeq := *)
(*   repeat match goal with *)
(*   | |- cons ?x1 ?l1 = cons ?x2 ?l2 => f_equal *)
(*   end. *)

(* ==================================== *)
(** ** 全排列（简称排列），用于验证行列式的定义 *)
Section permutation.

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

  (** 取出列表中的 第 k 个元素 与 其余元素构成的列表 *)
  Fixpoint pick (l : list A) (k : nat) : A * list A :=
    match k with
    | 0 => (hd A0 l, tl l)
    | S k' => match l with
             | [] => (A0, [])
             | x :: l' =>
                 let (a,l0) := pick l' k' in
                 (a, [x] ++ l0)
             end
    end.

  (** 列表全排列的辅助函数 *)
  Fixpoint perm_aux (n : nat) (l : list A) : list (list A) :=
    match n with
    | 0 => [[]]
    | S n' =>
        let d1 := map (fun i => pick l i) (seq 0 n) in
        let d2 := map
                    (fun k : A * list A => let (x, lx) := k in
                                         let d3 := perm_aux n' lx in
                                         map (fun l1 => [x] ++ l1) d3) d1 in
        concat d2
    end.

  (** 列表全排列的辅助函数 *)
  Definition perm (l : list A) : list (list A) :=
    perm_aux (length l) l.

  (** 全排列的种数 *)
  Definition Pn (l : list A) := length (perm l).

  (** 全排列种数等于阶乘 *)
  Lemma Pn_eq : forall l, Pn l = fact (length l).
  Proof.
    intros l.
    induction l; simpl; auto.
  Abort.

End permutation.

Section test.
  (* Compute perm []. *)
  (* Compute perm [1]. *)
  (* Compute perm [1;2]. *)
  (* Compute perm [1;2;3]. *)
  (* Compute perm [1;2;3;4]. *)
End test.

(* ==================================== *)
(** ** 基于伴随矩阵的逆矩阵算法 *)
Section inversion.

  (** 矩阵元素要求是域结构 *)
  Context `{F:Field}.
  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.
  Notation "/ x" := (inv x) : A_scope.
  Notation "a / b" := (a * (/b)) : A_scope.

  (* Add Ring ring_inst : make_ring_theory. *)
  Add Field field_inst : make_field_theory.

  (* ------------------------------------------- *)
  (** *** Determinant. *)

  (** Get the sub square matrix which remove r-th row and c-th column
    from a square matrix. *)
  Definition submat {n} (m : Square (S n)) (r c : nat) : @Square A n :=
    f2m (fun i j =>
      let i' := (if i <? r then i else S i) in
      let j' := (if j <? c then j else S j) in
      m2f m i' j').

  (** Calculate determinant
      方法：按照第0行展开 *)
  Fixpoint det {n} : Square n -> A :=
    match n with
    | 0 => fun _ => 1
    | S n' =>
        fun m =>
          fold_left
            add0
            (map (fun i =>
                    let a := if Nat.even i
                             then (m2f m 0 i)%nat
                             else (-(m2f m 0 i)%nat)%A
                    in
                    let d := det (submat m 0 i) in
                    (a * d))
               (seq 0 n))
            0
    end.

  (** Verify formula for determinant of specify matrix *)
  Section det_specify_matrix.

    (** 任给一些方阵 *)
    Variable m11 : @Square A 1.
    Variable m22 : @Square A 2.
    Variable m33 : @Square A 3.

    (** 给出其行列式公式 *)
    Definition det_m11 : A :=
      let a11 := m2t_1x1 m11 in
      a11.
    Definition det_m22 : A :=
      let '((a11,a12),(a21,a22)) := m2t_2x2 m22 in
      a11 * a22 - a12 * a21.
    Definition det_m33 : A :=
      let '((a11,a12,a13),(a21,a22,a23),(a31,a32,a33)) := m2t_3x3 m33 in
      a11*a22*a33 - a11*a23*a32 -
        a12*a21*a33 + a12*a23*a31 +
        a13*a21*a32 - a13*a22*a31.

    (** 验证这些公式正确 *)
    Lemma det_m11_ok : det m11 = det_m11. cbv. ring. Qed.
    Lemma det_m22_ok : det m22 = det_m22. cbv. ring. Qed.
    Lemma det_m33_ok : det m33 = det_m33. cbv. ring. Qed.

  End det_specify_matrix.

  (* ------------------------------------------- *)
  (** *** 克拉默法则 *)

  (** 对于 A X = b 的方程组，
      当方程可数和未知数个数相等时，即A构成方阵时，
      记 D = |A|, Di = |[b/i] A|，其中，[b/i] A 表示把 A 中第 i 列换成 b，
      若 |A| 不为零，则方程有解，并可以给出求解公式  *)

  (** 替换方阵某一列的内容 *)
  Definition mchgcol {n} (m : Square n) (k : nat) (v : mat n 1) : @Square A n :=
    f2m (fun i j => if j =? k then m2f v i 0%nat else m2f m i j).

  (** 克拉默法则 *)
  Definition cramerRule {n} (A : Square n) (b : mat n 1) : mat n 1 :=
    let D := det A in
    f2m (fun i j =>
      let Di := det (mchgcol A i b) in
        (Di / D)%A).

  (* ------------------------------------------- *)
  (** *** 伴随矩阵，简称伴随阵. *)

  (** 由各个元素的代数余子式以转置的样式构成的新矩阵，称为原矩阵的伴随矩阵
      adjoint matrix, adjugate matrix,
      adj(A), A* *)

  Definition madj {n} : Square n -> Square n :=
    match n with
    | O => fun m => m
    | S n' => fun m =>
      f2m (fun i j =>
        let s := if Nat.even (i + j) then 1 else -(1) in
        let d := det (submat m j i) in
        s * d)
    end.

  (* ------------------------------------------- *)
  (** *** 逆矩阵 *)
  Definition minv {n} (m : Square n) :=
    mcmul (1 / det m) (madj m)
      (mul0:=mul0) (r:=n) (c:=n).

  (** Inversion matrix of of specify matrix *)
  Section inversion_for_specify_matrix.

    (** 任给一些方阵 *)
    Variable m11 : @Square A 1.
    Variable m22 : @Square A 2.
    Variable m33 : @Square A 3.

    (** 给出其逆矩阵公式 *)
    Definition inv_m11 : Square 1 :=
      let a11 := m2t_1x1 m11 in
      let d := det_m11 m11 in
      mk_mat_1_1 (A0:=0) (1/a11).
    Definition inv_m22 : Square 2 :=
      let '((a11,a12),(a21,a22)) := m2t_2x2 m22 in
      let d := det_m22 m22 in
      mk_mat_2_2 (A0:=0) (a22/d) (-a12/d) (-a21/d) (a11/d).

    (* 注意，以下公式可由matlab来提供，避免手写 *)
    Definition inv_m33 : Square 3 :=
      let '((a11,a12,a13),(a21,a22,a23),(a31,a32,a33)) := m2t_3x3 m33 in
      let d := det_m33 m33 in
      mk_mat_3_3 (A0:=0)
        ((a22*a33 - a23*a32)/d) (-(a12*a33 - a13*a32)/d) ((a12*a23 - a13*a22)/d)
        (-(a21*a33 - a23*a31)/d) ((a11*a33 - a13*a31)/d) (-(a11*a23 - a13*a21)/d)
        ((a21*a32 - a22*a31)/d) (-(a11*a32 - a12*a31)/d) ((a11*a22 - a12*a21)/d).

    (** 验证这些公式正确。
        注意，这里只验证了表达式与minv函数输出一致，还未验证逆矩阵性质 *)
    Lemma inv_m11_ok : det m11 <> 0 -> minv m11 == inv_m11.
    Proof. lma. field. cbv in H. intro. destruct H. ring_simplify. auto. Qed.

    Lemma inv_m22_ok : det m22 <> 0 -> minv m22 == inv_m22.
    Proof. lma; field; cbv in H; intro; destruct H; ring_simplify; auto. Qed.

    Lemma inv_m33_ok : det m33 <> 0 -> minv m33 == inv_m33.
    Proof.
      lma; field; cbv in H; intro; destruct H; ring_simplify; auto;
        rewrite <- H0; ring.
    Qed.

  End inversion_for_specify_matrix.

  (** 直接计算出1/2/3阶符号矩阵的逆矩阵 *)
  Section FindFormula.
    Variable a11 a12 a13 a21 a22 a23 a31 a32 a33 : A.
    Let m1 := mk_mat_1_1 (A0:=0) a11.
    Let m2 := mk_mat_2_2 (A0:=0) a11 a12 a21 a22.
    Let m3 := mk_mat_3_3 (A0:=0) a11 a12 a13 a21 a22 a23 a31 a32 a33.

    (* 虽然结果正确，但是太过冗长，以后使用 RAST 来化简 *)
    (* Compute (m2l (minv m1)). *)
    (* Compute (m2l (minv m2)). *)
    (* Compute (m2l (minv m3)). *)

  End FindFormula.

End inversion.

(* ==================================== *)
(** ** Q上的矩阵求逆 *)
Module MatrixInvQ.

  Export QArith.
  Open Scope Q.

  Definition mk_mat_3_1 := mk_mat_3_1 (A0:=0).
  Definition mk_mat_3_3 := mk_mat_3_3 (A0:=0).
  Definition mk_mat_4_1 := mk_mat_4_1 (A0:=0).
  Definition mk_mat_4_4 := mk_mat_4_4 (A0:=0).
  Definition det {n} :=
    det (n:=n) (add0:=Qplus) (zero0:=0) (mul0:=Qmult) (one0:=1) (opp:=Qopp).
  Definition cramerRule {n} :=
    cramerRule (n:=n) (add0:=Qplus) (zero0:=0)
      (mul0:=Qmult) (one0:=1) (opp:=Qopp) (inv:=Qinv).
  Definition madj {n} :=
    madj (n:=n) (add0:=Qplus) (zero0:=0) (mul0:=Qmult) (one0:=1) (opp:=Qopp).

  (** 由于Q的表示不唯一，使用 reduce 来转换为唯一形式 *)
  Definition m2l_red {r c} (m : mat r c) := map (fun l => map Qred l) (m2l m).

End MatrixInvQ.

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

(** 数值矩阵部分，使用特定的域会便于计算，但涉及到符号时，会展开为复杂的表达式，
不便于符号矩阵的证明 *)
Module Exercise_Number.

  Import MatrixInvQ.

  (** 同济大学，线性代数（第五版），page22, 例14 *)
  Section example14.
    Let A := mk_mat_4_4
      2 1 (-5) 1
      1 (-3) 0 (-6)
      0 2 (-1) 2
      1 4 (-7) 6.
    Let b := mk_mat_4_1 8 9 (-5) 0.

    Goal det A == 27. cbv. auto. Qed.

    (* Compute (m2l (cramerRule A b)). *)
    Goal (m2l_red (cramerRule A b) = [[3];[-4];[-1];[1]]). cbv. auto. Qed.

  End example14.

  Section example15.
    Let A := mk_mat_4_4
      1 1 1 1
      1 2 4 8
      1 3 9 27
      1 4 16 64.
    Let b := mk_mat_4_1 3 4 3 (-3).

    Goal (m2l_red (cramerRule A b) = [[3];[-3#2];[2];[-1#2]]). cbv. auto. Qed.
  End example15.

End Exercise_Number.

(** 符号矩阵部分，在符号这一级方便证明 *)
(** 同济大学《线性代数（第五版）》，page25, 习题一 *)
Module Exercise_Symbol.

  (** 矩阵元素 *)
  Context `{F:Field}.
  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.
  Notation "/ x" := (inv x) : A_scope.
  Notation "a / b" := (a * (/b)) : A_scope.
  Notation "2" := (1+1) : A_scope.
  Notation "3" := (1+2) : A_scope.

  Add Field field_inst : make_field_theory.

  Definition mk_mat_3_3 := mk_mat_3_3 (A0:=0).
  Definition mk_mat_4_4 := mk_mat_4_4 (A0:=0).
  Definition det {n} :=
    det (n:=n) (add0:=add0) (zero0:=zero0) (mul0:=mul0) (one0:=one0) (opp:=opp).

  (* A上的幂函数 *)
  Fixpoint Apow (a : A) (n : nat) :=
    match n with
    | 0 => 1
    | S n' => (a * (Apow a n'))%A
    end.
  Infix "^" := (Apow).

  Example ex6_1 : forall a b : A,
    let m := (mk_mat_3_3 (a*a) (a*b) (b*b) (2*a) (a+b) (2*b) 1 1 1)%A in
      det m = (a - b)^3.
  Proof. intros. cbv. ring. Qed.

  Example ex6_2 : forall a b x y z : A,
    let m1 := (mk_mat_3_3
      (a*x+b*y) (a*y+b*z) (a*z+b*x)
      (a*y+b*z) (a*z+b*x) (a*x+b*y)
      (a*z+b*x) (a*x+b*y) (a*y+b*z))%A in
    let m2 := mk_mat_3_3 x y z y z x z x y in
      det m1 = ((a^3 + b^3) * det m2)%A.
  Proof. intros. cbv. ring. Qed.

  Example ex6_3 : forall a b e d : A,
    let m := (mk_mat_4_4
      (a*a) ((a+1)^2) ((a+2)^2) ((a+3)^2)
      (b*b) ((b+1)^2) ((b+2)^2) ((b+3)^2)
      (e*e) ((e+1)^2) ((e+2)^2) ((e+3)^2)
      (d*d) ((d+1)^2) ((d+2)^2) ((d+3)^2))%A in
        det m = 0.
  Proof. intros. cbv. ring. Qed.

  Example ex6_4 : forall a b e d : A,
    let m := (mk_mat_4_4
      1 1 1 1
      a b e d
      (a^2) (b^2) (e^2) (d^2)
      (a^4) (b^4) (e^4) (d^4))%A in
      det m = ((a-b)*(a-e)*(a-d)*(b-e)*(b-d)*(e-d)*(a+b+e+d))%A.
  Proof. intros. cbv. ring. Qed.

  (** 6.(5) 是无穷的，需要更多构造和证明，待以后补充 *)

End Exercise_Symbol.

(* ==================================== *)
(** ** 计算符号矩阵逆矩阵的 更简洁形式 *)
(** 在Coq中对符号矩阵直接计算行列式或逆矩阵等，含有大量冗余数据（比如zero,one）,
    尽管不影响证明，但是我们并不轻轻松的得到对用户友好的表示。
    换言之，例如 0 + 1 * a + b * 1 + 0 要能够自动化简为 a + b。
    当初开发基于伴随矩阵求逆矩阵的一个目的就是要能对符号矩阵求解，
    不但要能求解，最好还能得到友好的表达形式。

    本节的目的是使用一种AST，设法简化矩阵表达式。
    原理：
        由于矩阵运算包括这里的逆矩阵运算是建立在多态上的，
        所以我们定制一种矩阵元素类型，并将该类型上的运算用归纳的方式
        统一在AST下，然后利用AST来化简表示。

    另一种思路：
        可以借助 ring_simplify 来化简。比如：
        Goal forall aaa:A, aaa = det matxx.  (* 先构造一个证明环境 *)
        (* 然后在证明中可以化简表达式 *)

 *)
Module Simplify_by_RAST.

  (** 带有AST的R类型，用于简化表达式 *)
  Import RAST.

  (** 矩阵元素类型 *)
  Notation "0" := A0.
  Notation "1" := A1.
  Notation "2" := (1 + 1)%A.
  Notation "3" := (1 + 2)%A.
  Infix "+" := Aadd.
  Infix "-" := Asub.
  Infix "*" := Amul.

  Definition mk_mat_1_1 := mk_mat_1_1 (A0:=0).
  Definition mk_mat_2_2 := mk_mat_2_2 (A0:=0).
  Definition mk_mat_3_3 := mk_mat_3_3 (A0:=0).
  Definition minv {n} :=
    minv (n:=n)(add0:=Aadd)(zero0:=0)(opp:=Aopp)
      (mul0:=Amul)(one0:=1)(inv:=Ainv).

  (* simp 函数可以化简A类型上的项，我们需要对 list (list A) 进行化简 *)

  (** list (list A) 的化简 *)
  Definition dl_nsimp (dl : list (list A)) (n : nat) :=
    map (map (fun t => nsimp t n)) dl.

  (** list (list A) 上的 A -> R 的转换 *)
  Definition dl_A2R (dl : list (list A)) : list (list R) :=
    map (map A2R) dl.

  (* 以计算 1/2/3阶符号矩阵的逆矩阵为例，测试 RAST 的化简效果 *)

  Section Test.

    (* 定义多个变量 *)
    Variable r11 r12 r13 r21 r22 r23 r31 r32 r33 : R.
    Let a11 := ALit r11. Let a12 := ALit r12. Let a13 := ALit r13.
    Let a21 := ALit r21. Let a22 := ALit r22. Let a23 := ALit r23.
    Let a31 := ALit r31. Let a32 := ALit r32. Let a33 := ALit r33.

    (* 构造1/2/3阶矩阵 *)
    Let m1 := mk_mat_1_1 a11.
    Let m2 := mk_mat_2_2 a11 a12 a21 a22.
    Let m3 := mk_mat_3_3 a11 a12 a13 a21 a22 a23 a31 a32 a33.

    (* 计算逆矩阵 *)
    Let l1 := Eval cbv in m2l (minv m1).
    Let l2 := Eval cbv in m2l (minv m2).
    Let l3 := Eval cbv in m2l (minv m3).

    (* 可以看到，结果确实有冗余 *)
    (* Print l1.   (* [[(1 * (/ (0 + (a11 * 1)))) * (1 * 1)]] *) *)
    (* Print l2. *)
    (* Print l3. *)

    (* simp化简 *)
    (* Compute dl_nsimp l1 0. *)
    (* Compute dl_nsimp l1 1. *)
    (* Compute dl_nsimp l1 2. *)
    (* Compute dl_nsimp l1 3. *)
    (* Compute dl_nsimp l1 4. *)
    (* Compute dl_nsimp l1 5. *)
    (* Compute dl_nsimp l1 6. *)
    (* Compute dl_nsimp l1 7. *)
    (* Compute dl_nsimp l1 8. (* 已经最简 *) *)
    (* Compute dl_nsimp l1 9. *)
    (* 得到 R 类型上的结果 *)
    (* Compute dl_A2R (dl_nsimp l1 8). (** [[/r11]] *) *)

    (* Compute dl_A2R (dl_nsimp l2 5). *)
    (* Compute dl_A2R (dl_nsimp l2 10). *)
    (* Compute dl_A2R (dl_nsimp l2 15). *)
    (* Compute dl_A2R (dl_nsimp l2 20). (* 已经最简 *) *)
    (*
      = [[/ (r11 * r22 + - r12 * r21) * r22; - / (r11 * r22 + - r12 * r21) * r12];
      [- / (r11 * r22 + - r12 * r21) * r21; / (r11 * r22 + - r12 * r21) * r11]]
     *)

    (* Compute dl_A2R (dl_nsimp l3 5). *)
    (* Compute dl_A2R (dl_nsimp l3 20). *)
    (* Compute dl_A2R (dl_nsimp l3 30). *)
    (* Compute dl_A2R (dl_nsimp l3 40). *)
    (* Compute dl_A2R (dl_nsimp l3 42). (* 已经最简 *) *)
  (*
    = [[/ (r11 * r22 * r33 + r11 * - r23 * r32 + - r12 * r21 * r33 + - r12 * - r23 * r31 + r13 * r21 * r32 + r13 * - r22 * r31) * r22 * r33 +
    / (r11 * r22 * r33 + r11 * - r23 * r32 + - r12 * r21 * r33 + - r12 * - r23 * r31 + r13 * r21 * r32 + r13 * - r22 * r31) * - r23 * r32;
    - / (r11 * r22 * r33 + r11 * - r23 * r32 + - r12 * r21 * r33 + - r12 * - r23 * r31 + r13 * r21 * r32 + r13 * - r22 * r31) * r12 * r33 +
    - / (r11 * r22 * r33 + r11 * - r23 * r32 + - r12 * r21 * r33 + - r12 * - r23 * r31 + r13 * r21 * r32 + r13 * - r22 * r31) * - r13 * r32;
    / (r11 * r22 * r33 + r11 * - r23 * r32 + - r12 * r21 * r33 + - r12 * - r23 * r31 + r13 * r21 * r32 + r13 * - r22 * r31) * r12 * r23 +
    / (r11 * r22 * r33 + r11 * - r23 * r32 + - r12 * r21 * r33 + - r12 * - r23 * r31 + r13 * r21 * r32 + r13 * - r22 * r31) * - r13 * r22];
    [- / (r11 * r22 * r33 + r11 * - r23 * r32 + - r12 * r21 * r33 + - r12 * - r23 * r31 + r13 * r21 * r32 + r13 * - r22 * r31) * r21 * r33 +
    - / (r11 * r22 * r33 + r11 * - r23 * r32 + - r12 * r21 * r33 + - r12 * - r23 * r31 + r13 * r21 * r32 + r13 * - r22 * r31) * - r23 * r31;
    / (r11 * r22 * r33 + r11 * - r23 * r32 + - r12 * r21 * r33 + - r12 * - r23 * r31 + r13 * r21 * r32 + r13 * - r22 * r31) * r11 * r33 +
    / (r11 * r22 * r33 + r11 * - r23 * r32 + - r12 * r21 * r33 + - r12 * - r23 * r31 + r13 * r21 * r32 + r13 * - r22 * r31) * - r13 * r31;
    - / (r11 * r22 * r33 + r11 * - r23 * r32 + - r12 * r21 * r33 + - r12 * - r23 * r31 + r13 * r21 * r32 + r13 * - r22 * r31) * r11 * r23 +
    - / (r11 * r22 * r33 + r11 * - r23 * r32 + - r12 * r21 * r33 + - r12 * - r23 * r31 + r13 * r21 * r32 + r13 * - r22 * r31) * - r13 * r21];
    [/ (r11 * r22 * r33 + r11 * - r23 * r32 + - r12 * r21 * r33 + - r12 * - r23 * r31 + r13 * r21 * r32 + r13 * - r22 * r31) * r21 * r32 +
    / (r11 * r22 * r33 + r11 * - r23 * r32 + - r12 * r21 * r33 + - r12 * - r23 * r31 + r13 * r21 * r32 + r13 * - r22 * r31) * - r22 * r31;
    - / (r11 * r22 * r33 + r11 * - r23 * r32 + - r12 * r21 * r33 + - r12 * - r23 * r31 + r13 * r21 * r32 + r13 * - r22 * r31) * r11 * r32 +
    - / (r11 * r22 * r33 + r11 * - r23 * r32 + - r12 * r21 * r33 + - r12 * - r23 * r31 + r13 * r21 * r32 + r13 * - r22 * r31) * - r12 * r31;
    / (r11 * r22 * r33 + r11 * - r23 * r32 + - r12 * r21 * r33 + - r12 * - r23 * r31 + r13 * r21 * r32 + r13 * - r22 * r31) * r11 * r22 +
    / (r11 * r22 * r33 + r11 * - r23 * r32 + - r12 * r21 * r33 + - r12 * - r23 * r31 + r13 * r21 * r32 + r13 * - r22 * r31) * - r12 * r21]]
     : list (list R)
   *)

    (* 相比而言，matlab的输出结果更加友好
       注意：看起来是在显示时做了处理，如果拷贝出文本，看到的还是冗长的式子。

       这里是Matlab的输出，并拷贝出的结果（手动做了换行处理）：
[(r22*r33 - r23*r32)/(r11*r22*r33 - r11*r23*r32 - r12*r21*r33 + r12*r23*r31 + r13*r21*r32 - r13*r22*r31),
-(r12*r33 - r13*r32)/(r11*r22*r33 - r11*r23*r32 - r12*r21*r33 + r12*r23*r31 + r13*r21*r32 - r13*r22*r31),
(r12*r23 - r13*r22)/(r11*r22*r33 - r11*r23*r32 - r12*r21*r33 + r12*r23*r31 + r13*r21*r32 - r13*r22*r31);

 -(r21*r33 - r23*r31)/(r11*r22*r33 - r11*r23*r32 - r12*r21*r33 + r12*r23*r31 + r13*r21*r32 - r13*r22*r31),
(r11*r33 - r13*r31)/(r11*r22*r33 - r11*r23*r32 - r12*r21*r33 + r12*r23*r31 + r13*r21*r32 - r13*r22*r31),
-(r11*r23 - r13*r21)/(r11*r22*r33 - r11*r23*r32 - r12*r21*r33 + r12*r23*r31 + r13*r21*r32 - r13*r22*r31);

(r21*r32 - r22*r31)/(r11*r22*r33 - r11*r23*r32 - r12*r21*r33 + r12*r23*r31 + r13*r21*r32 - r13*r22*r31),
-(r11*r32 - r12*r31)/(r11*r22*r33 - r11*r23*r32 - r12*r21*r33 + r12*r23*r31 + r13*r21*r32 - r13*r22*r31),
(r11*r22 - r12*r21)/(r11*r22*r33 - r11*r23*r32 - r12*r21*r33 + r12*r23*r31 + r13*r21*r32 - r13*r22*r31)]

         这里是显示出来的效果（提取了公因式，并写成了分式的样子）：
[(r22*r33 - r23*r32)/s1, -(r12*r33 - r13*r32)/s1, (r12*r23 - r13*r22)/s1;
 -(r21*r33 - r23*r31)/s1, (r11*r33 - r13*r31)/s1, -(r11*r23 - r13*r21)/s1;
 (r21*r32 - r22*r31)/s1, -(r11*r32 - r12*r31)/s1, (r11*r22 - r12*r21)/s1]
 其中，s1 = r11*r22*r33 - r11*r23*r32 - r12*r21*r33 + r12*r23*r31 + r13*r21*r32 - r13*r22*r31
     *)

    (** 另一种思路，借用Coq的 ring_simplify *)
    Section Simplify_by_ring_simplify.
      (** 以3x3矩阵之逆矩阵的第(0,0)项为例 *)
      Let x := Eval cbv in  hd 0 (hd [] l3).
      (* Print x. *)

      (** 进入证明环境，命题本身不重要，只是为了借用化简能力 *)
      Goal forall a, a = A2R x.
      Proof.
        clear. unfold x. intros. simpl.
        ring_simplify. (* ring简化效果不佳 *)
        field_simplify. (* field简化很好 *)
        (* 手动记录这个结果：
           a = (r22 * r33 - r23 * r32) /
           (r11 * r22 * r33 - r11 * r23 * r32 - r22 * r31 * r13 -
           r33 * r12 * r21 + r23 * r12 * r31 + r32 * r21 * r13)
         *)
      Abort.

    End Simplify_by_ring_simplify.

    (** 无论何种方式，我们能够获取到简化的表达式，
        其正确性已经在前文完成 *)

  End Test.

  (** *** 构造用于矩阵元素的字符串名称 *)
  Section mat_element_string.

    (** 从 "a" 2 3 到 "a23" *)
    Definition nn2s (prefix:string) (i j:nat) : string :=
      (prefix ++ (nat2str (S i)) ++ (nat2str (S j)))%string.

    (** 构造矩阵需要的所有字符串变量 *)
    Definition mat_vars_s (r c:nat) : list (list string) :=
      map (fun i => map (nn2s "a" i) (seq 0 c)) (seq 0 r).

    (* 计算所有矩阵元素的字符串名称 *)
    (* Compute mat_vars_s 3 4. *)

    (* 当 100x100 规模时，约 2.5 s *)
    (* Time Eval cbv in (mat_vars_s 100 100). *)

    (* 取出单独的矩阵元素的字符串名称 *)
    (* Check nth 0 (mat_vars_s 3 4). *)
    (* Check nth 0 (nth 0 (mat_vars_s 3 4) []) "". *)
    (* Compute nth 0 (nth 0 (mat_vars_s 3 4) []) "". *)

  End mat_element_string.

  (** *** 任意维度的测试，自动构造变量 *)
  Module Test_any_dim.

    Open Scope nat.

    (** 虚拟的环境，可以将 string 映射到 A *)
    Variable env_s2A : string -> A.
    Coercion env_s2A : string >-> A.

    (** 矩阵的生成函数 *)
    Definition g_test r c := fun i j =>
      env_s2A (nth j (nth i (mat_vars_s r c) []) "").

    (* 当 200x200 规模时，计算一个元素，约 0.5 s。时间太长了 *)
    (* Time Compute g_test 200 200 5 6. *)

    (* 事先算好字符串，节省时间 *)
    Definition ORDERS := 6.  (* 设定阶数，行数、列数都等于它 *)
    Definition ROWS := ORDERS.
    Definition COLS := ORDERS.
    Definition mat_vars_given := Eval cbv in (mat_vars_s ROWS COLS).
    (* Print mat_vars_given. *)

    Definition g := fun i j =>
      env_s2A (nth j (nth i mat_vars_given []) "").

    (* 此时，取出元素速度较快 *)
    (* Compute g 1 2. *)

    Definition m : mat ROWS COLS := f2m g.

    (** 以下测试不要经常运行，太久 *)
    (* Time Compute minv m. *)
    (* Time Compute (m2l (minv m)). *)
    (* Time Definition m' := Eval cbv in (minv m). *)
    (* Time Definition dl := Eval cbv in (m2l m' (r:=ROWS) (c:=COLS)). *)

    (* Time Definition dl1 := Eval cbv in (dl_nsimp dl 2). (* 10 s *) *)
    (* Time Definition dl2 := Eval cbv in (dl_nsimp dl1 2). *) (* 20 s *)
    (* Time Definition dl3 := Eval cbv in (dl_nsimp dl2 2). *) (* 40 s *)

    (* Check dl1. *)
    (* Check (hd [] dl1). *)
    (* Check (hd A0 (hd [] dl1)). *)
    (* Compute (hd A0 (hd [] dl1)). *)
    (* Time Compute (hd A0 (hd [] (dl_nsimp dl 3))). *)
    (* Time Compute (hd A0 (hd [] (dl_nsimp dl 6))). (* 发现越来越复杂了 *) *)
    (* 注意，这里继续优化反而有问题，因为 nsimp 为是 ALit 而写的，
       这里的类型可能不适合 *)
    (* 重新写一版，针对 ALit 的*)

  End Test_any_dim.

  (* 几乎与 Test_any_dim 一样，只不过使用 ALit。
     即，定义在 R 上，并 ALit 到  A 类型，而不是直接定义在 A 上。*)
  Module Test_any_dim_ALit.

    Open Scope nat.

    (** 虚拟的环境，可以将 string 映射到 R。相比A，好处是R不会被展开 *)
    Variable env_s2R : string -> R.
    Coercion env_s2R : string >-> R.
    Coercion ALit : R >-> A.

    (** 矩阵的生成函数 *)
    Definition g_test r c := fun i j =>
      (ALit (env_s2R (nth j (nth i (mat_vars_s r c) []) ""))).

    (* 事先算好字符串，节省时间 *)
    Definition ORDERS := 4.  (* 设定阶数，行数、列数都等于它 *)
    Definition ROWS := ORDERS.
    Definition COLS := ORDERS.
    Definition mat_vars_given := Eval cbv in (mat_vars_s ROWS COLS).
    (* Print mat_vars_given. *)

    Definition g := fun i j =>
      (ALit (env_s2R (nth j (nth i mat_vars_given []) ""))).

    (* 此时，取出元素速度较快 *)
    (* Compute g 1 2. *)

    Definition m : mat ROWS COLS := f2m g.

    (* Time Compute minv m. *)
    (* Time Compute (m2l (minv m)). *)
    (* Time Definition m' := Eval cbv in (minv m). *)
    (* Time Definition dl := Eval cbv in (m2l m' (r:=ROWS) (c:=COLS)). *)

    (* Time Definition dl1 := Eval cbv in (dl_nsimp dl 2). *)
    (* Time Definition dl2 := Eval cbv in (dl_nsimp dl1 2). *)
    (* Time Definition dl3 := Eval cbv in (dl_nsimp dl2 10). *)
    (* Time Definition dl4 := Eval cbv in (dl_nsimp dl3 10). *)

    (* Eval cbv in (dl_nsimp dl2 20). *)
    (* Eval cbv in (dl_nsimp dl2 30). *)
    (* Eval cbv in (dl_nsimp dl2 40). *)
    (* Eval cbv in (dl_nsimp dl2 100). *)
    (* Eval cbv in (dl_nsimp dl2 150). *)

    (** 总结：
        1. matlab提供的符号矩阵确实很好。
        2. 这里的优化也许只要对单个表示（比如行列式）优化即可。
        3. 逆矩阵输出可能需要像matlab那样，用分式，并分离行列式这种公共表示更好
        4. 高于5、6阶，可能就没有什么意义了，人们并不会直接使用这么复杂的公式。
     *)

  End Test_any_dim_ALit.

End Simplify_by_RAST.


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

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

Print Assumptions opp.


(** This example demonstrates and approach to handling delimited information release in SeLoC.

It is based on the example from  "A Separation Logic for Enforcing DeclarativeInformation Flow Control Policies" by David Costanzo and Zhong Shao.
*)
From iris.base_logic Require Import invariants.
From iris_ni.logrel Require Import types.
From iris_ni.program_logic Require Import dwp heap_lang_lifting.
From iris.proofmode Require Import proofmode.
From iris.heap_lang Require Import lang proofmode.
From iris_ni.proofmode Require Import dwp_tactics.
From iris_ni.logrel Require Import interp.
From iris_ni.examples Require Import lock.

(** The idea behind this example, is that a person A. has a calendar,
(which we model as a linked list), and each day is marked eiter with 0
(meaining that the day is free, and there are no meetings) or with a
positive integer t (meatning that there is a meeting at time t).

If someone wants to set up their appointment with A., they have to see
which days are they available. In order to do so, A. must be able to
disclose the days on which they are free, without disclosing any other
information (e.g. times of other meetings).

The program that discloses the avilablility of A. is the
`available_dates` below.

We show non-interference with a form of delimited control.
Specifically, we show that if an attacker already knows the days on
which A. is available, then the attacker cannot learn any further
information.
 *)

(* Iterate a function `f` over the linked list `hd`
   `f` is called with `f i x` where `x` is `i`-th element in the list.
 *)
Definition iter_loop : val :=
  rec: "loop" "i" "hd" "f" :=
    match: "hd" with
      NONE => #()
    | SOME "l" =>
      let: "tmp1" := Fst !"l" in
      let: "tmp2" := Snd !"l" in
      "f" "i" "tmp1";;
      "loop" ("i"+#1) "tmp2" "f"
    end.
Definition iter : val := λ: "hd" "f", iter_loop #0 "hd" "f".

Definition available_dates (out : loc) : val := λ: "cal",
  iter "cal" (λ: "i" "x", if: "x" = #0 then #out <- "i" else Skip).

(* Meta-function (macro) : create a HeapLang linked list out of a Coq list *)
Fixpoint make_llist (xs : list val) : expr :=
  match xs with
  | [] => NONE
  | (x::xs) =>
    SOME (ref (x, make_llist xs))
  end.

Section calendar.
  Context `{!heapDG Σ}.

  (* Predicate describing that `hd1` and `hd2` point to lists `xs1` and `xs2`, respectively *)
  Fixpoint is_list (hd1 : val) (hd2 : val) (xs1 xs2 : list val) : iProp Σ :=
    match xs1,xs2 with
    | [],[] => ⌜hd1 = NONEV⌝ ∗ ⌜hd2 = NONEV⌝
    | x1 :: xs1, x2 :: xs2 => ∃ (l1:loc) (l2 :loc) hd1' hd2',
         ⌜hd1 = SOMEV #l1⌝ ∗ ⌜hd2 = SOMEV #l2⌝ ∗ l1 ↦ₗ (x1,hd1') ∗ l2 ↦ᵣ (x2,hd2')
         ∗ is_list hd1' hd2' xs1 xs2
    | _, _ => False
    end%I.

  Lemma make_llist_spec (xs1 xs2 : list val) :
    length xs1 = length xs2 →
    ⊢ DWP make_llist xs1 & make_llist xs2 : λ hd1 hd2, is_list hd1 hd2 xs1 xs2.
  Proof using Type.
    revert xs2. induction xs1 as [|x1 xs1]=>xs2; simpl.
    - intros Hxs2. symmetry in Hxs2. eapply nil_length_inv in Hxs2.
      simplify_eq/=. dwp_pures.
      iApply dwp_value. eauto.
    - destruct xs2 as [|x2 xs2]; simpl.
      { inversion 1. }
      intros Hlen. simplify_eq/=.
      dwp_bind (make_llist xs1) (make_llist xs2).
      iApply (dwp_wand with "[]").
      { by iApply IHxs1. }
      iIntros (t1 t2) "Ht". dwp_pures.
      dwp_bind (ref _)%E (ref _)%E.
      iApply dwp_alloc. iIntros (hd1 hd2) "Hhd1 Hhd2". iNext.
      dwp_pures. iApply dwp_value. iModIntro.
      iExists _,_,_,_. eauto with iFrame.
  Qed.

  (* Specifications for the iter function *)
  Lemma iter_loop_spec P (i : Z) (f1 f2 :val) hd1 hd2 xs1 xs2 ξ :
    Forall2 P xs1 xs2 →
    is_list hd1 hd2 xs1 xs2 -∗
    □(∀ x1 x2 (i : Z), ⌜P x1 x2⌝ → DWP (App f1 #i x1) & (App f2 #i x2) : ⟦ tunit ⟧ ξ) -∗
    DWP iter_loop #i hd1 f1
      & iter_loop #i hd2 f2 : ⟦ tunit ⟧ ξ.
  Proof using Type.
    iIntros (Hxs) "Hlst #Hf". iRevert (Hxs).
    iLöb as "IH" forall (i hd1 hd2 xs1 xs2). iIntros (Hxs).
    dwp_rec. dwp_pures.
    destruct xs1 as [|x1 xs1], xs2 as [|x2 xs2]; iSimpl in "Hlst"; try by iExFalso.
    - iDestruct "Hlst" as "[-> ->]". dwp_pures. iApply logrel_unit.
    - iDestruct "Hlst" as (l1 l2 hd1' hd2' -> ->) "(Hl1 & Hl2 & Hlst)".
      apply Forall2_cons_1 in Hxs. destruct Hxs.
      dwp_pures. dwp_bind (! _)%E (! _)%E. iApply (dwp_load with "Hl1 Hl2"). iIntros "Hl1 Hl2". iNext.
      dwp_pures. dwp_bind (! _)%E (! _)%E. iApply (dwp_load with "Hl1 Hl2"). iIntros "Hl1 Hl2". iNext.
      dwp_pures. dwp_bind (f1 #i x1) (f2 #i x2). iApply (dwp_wand with "[Hf]").
      { iApply "Hf". iPureIntro. naive_solver. }
      iIntros (??) "_". dwp_pures.
      iApply ("IH" $! (i+1)%Z with "Hlst [%//]").
  Qed.

  Lemma iter_spec P (f1 f2 :val) hd1 hd2 xs1 xs2 ξ :
    Forall2 P xs1 xs2 →
    is_list hd1 hd2 xs1 xs2 -∗
    □(∀ x1 x2 (i : Z), ⌜P x1 x2⌝ → DWP (App f1 #i x1) & (App f2 #i x2) : ⟦ tunit ⟧ ξ) -∗
    DWP iter hd1 f1 & iter hd2 f2 : ⟦ tunit ⟧ ξ.  (* TODO: return is_list *)
  Proof using Type.
    iIntros (Hxs) "Hlst #Hf". dwp_rec. dwp_pures.
    iApply (iter_loop_spec with "Hlst Hf"); eauto.
  Qed.

  Lemma available_dates_spec (out : loc) hd1 hd2 xs1 xs2 :
    Forall2 (λ x1 x2, x1 = #0 ↔ x2 = #0) xs1 xs2 →
    ⟦ tref (tint Low) ⟧ Low #out #out -∗
    is_list hd1 hd2 xs1 xs2 -∗
    DWP available_dates out hd1 & available_dates out hd2 : ⟦ tunit ⟧ Low.
  Proof using Type.
    iIntros (HP) "#Hout Hlst". dwp_rec. dwp_pures.
    iApply (iter_spec with "Hlst [-]"); eauto.
    iModIntro. iIntros (x1 x2 i Hxs).
    dwp_pures.
    case_bool_decide; case_bool_decide; try by (exfalso; naive_solver).
    - dwp_pures.
      iApply logrel_store ; eauto; iApply dwp_value; eauto.
      iModIntro. iExists _,_. eauto.
    - dwp_pures. iApply logrel_unit.
  Qed.

End calendar.

From iris_ni Require Import program_logic.dwp_adequacy.

(* Adequacy statement *)
(* xs1 xs2 are calendars *)
Lemma available_dates_secure (out : loc) (xs1 xs2 : list val) σ1 σ2 (n : Z):
    Forall2 (λ x1 x2, x1 = #0 ↔ x2 = #0) xs1 xs2 →
    σ1.(heap) !! out = Some (Some #n) →
    σ2.(heap) !! out = Some (Some #n) →
    dwp_adequacy.R heapDΣ {[out]}
                   ([let: "hd1" := make_llist xs1 in available_dates out "hd1"]%E,σ1)
                   ([let: "hd2" := make_llist xs2 in available_dates out "hd2"]%E,σ2).
Proof using Type.
  intros Hxs Hσ1 Hσ2.
  apply tc_once. simpl.
  eapply dwp_lift_bisim_singleton; eauto.
  iIntros (HG) "Ho".
  dwp_bind (make_llist xs1) (make_llist xs2).
  iApply (dwp_wand with "[]").
  { iApply make_llist_spec. by eapply Forall2_length. }
  iIntros (hd1 hd2) "Hhd". dwp_pures.
  iApply (dwp_wand with "[-]").
  { by iApply (available_dates_spec with "Ho Hhd"). }
  iIntros (v1 v2). iDestruct 1 as "[-> ->]".
  eauto.
Qed.