Require Import List.
Require Import Bool.
Require Import ZArith.
Require Import pomozne.
Require Import Recdef.

Fixpoint ostanek (l : list Z) : list Z :=
  match l with
    | nil => nil
    | a :: l' => if (a =? najmanjsi a l')%Z then l' else a :: (ostanek l')
  end.

Eval compute in (ostanek (4 :: 2 :: 6 :: 3 :: 1 :: 10 :: nil)%Z).

Lemma dolzina_nic (l : list Z) :
  length l <= 0 -> l = nil.
Proof.
  intro.
  induction l; auto.
  simpl in H.
  omega.
Qed.

Lemma najmanjsi_spust (x y : Z) (l : list Z) :
  x = najmanjsi x (y :: l) -> x = najmanjsi x l.
Proof.
  intro.
  assert (x <= y)%Z as G.
  rewrite H.
  apply najmanjsi_tail.
  firstorder.
  unfold najmanjsi in H.
  apply Zle_is_le_bool in G.
  now rewrite G in H.
Qed.

Lemma najmanjsi_dod (x y : Z) (l : list Z) :
  y = najmanjsi y l -> (y < x)%Z -> y = najmanjsi y (x :: l).
Proof.
  intros H G.
  simpl.
  apply Z.lt_le_incl in G.
  apply Zle_is_le_bool in G.
  now rewrite G.
Qed.

Lemma se_manjsi (x y : Z) (l : list Z) :
  x = (najmanjsi x l) -> (y < x)%Z -> y = (najmanjsi y l).
Proof.
  intros H G.
  induction l; auto.
  assert (x <= a)%Z as F.
  rewrite H.
  apply najmanjsi_tail.
  firstorder.
  apply najmanjsi_spust in H.
  apply IHl in H.
  apply najmanjsi_dod.
  assumption.
  firstorder.
Qed.

Lemma dolzina_ostanka (x : Z) (l : list Z) :
  length (ostanek (x :: l) )= length  l.
Proof.
  induction l.
  - simpl.
    now rewrite Z.eqb_refl.
  - simpl.
    simpl in IHl.
    case_eq (Z.leb x a);
    case_eq (Z.eqb a (najmanjsi a l));
    case_eq (Z.eqb x (najmanjsi x l));
    intros H G F; auto.
    + rewrite H in IHl.
      simpl.
      simpl in IHl.
      now rewrite IHl.
    + apply Z.eqb_eq in G.
      rewrite G in F.
      apply Z.leb_gt in F.
      apply Z.lt_neq in F.
      apply Z.neq_sym in F.
      apply Z.eqb_neq in F.
      now rewrite F.
    + apply Z.eqb_eq in G.
      rewrite <- G.
      apply Z.leb_gt in F.
      apply Z.lt_neq in F.
      apply Z.neq_sym in F.
      apply Z.eqb_neq in F.
      now rewrite F.
    + apply Z.eqb_eq in H.
      apply Z.eqb_neq in G.
      apply Z.leb_gt in F.
      assert (a = najmanjsi a l) as E.
      apply (se_manjsi x a);assumption.
      firstorder.
    + rewrite H in IHl.
      simpl in IHl.
      apply Z.leb_gt in F.
      assert (najmanjsi a l < x)%Z as E.
      apply (trans (najmanjsi a l) a x).
      apply najmanjsi_head.
      assumption.
      apply Z.lt_neq in E.
      apply Z.neq_sym in E.
      apply Z.eqb_neq in E.
      rewrite E.
      simpl.
      now apply eq_S.
Qed.

Function bsort (l : list Z) {measure length l} :=
  match l with
    |nil => nil
    | x :: l' => (najmanjsi x l') :: (bsort (ostanek (x :: l')))
  end.
Proof.
  intros l x l' H.
  rewrite (dolzina_ostanka x l').
  firstorder.
Defined.

Lemma ostanek_pod (x : Z) (l : list Z) :
  In x (ostanek l) -> In x l.
Proof.
  intro.
  induction l.
  - simpl in H.
    contradiction.
  - simpl in H.
    case_eq (a =? najmanjsi a l)%Z; intro G.
    + rewrite G in H.
      simpl.
      now right.
    + rewrite G in H.
      simpl in H.
      destruct H.
      * firstorder.
      * apply IHl in H.
        firstorder.
Qed.

Lemma urejen_najmanjsi (x : Z) (l : list Z) :
  urejen l -> (forall y, In y l -> (x <= y)%Z) -> urejen (x :: l).
Proof.
  intros H G.
  destruct l.
  now simpl.
  simpl.
  split.
  - apply G.
    firstorder.
  - destruct l; auto.
Qed.

Lemma ohranjanje_el (n : nat) (x : Z) (l : list Z) :
  length l <= n -> In x (bsort l) -> In x l.
Proof.
  generalize l.
  induction n; intros l' H G.
  - destruct l'.
    + now simpl in G.
    + simpl in H.
      omega.
  - apply le_lt_or_eq in H.
    destruct H.
    + apply IHn.
      now apply lt_n_Sm_le in H.
      assumption.
    + destruct l'.
      simpl in H.
      omega.
      rewrite bsort_equation in G.
      apply in_inv in G.
      destruct G as [F|F].
      * rewrite <- F.
        apply najmanjsi_In.
      * apply IHn in F.
        now apply ostanek_pod.
        rewrite dolzina_ostanka.
        simpl in H.
        omega.
Qed.

Lemma bsort_ureja_n (n : nat) (l : list Z) :
  (length l <= n)%nat -> urejen (bsort l).
Proof.
  generalize l.
  induction n; intros l' H.
  - destruct l'.
    + now simpl.
    + simpl in H.
      assert (S (length l') > 0) as G.
      apply gt_Sn_O.
      apply le_not_gt in H.
      contradiction.
  - apply le_lt_or_eq in H.
    destruct H.
    + apply lt_n_Sm_le in H.
      apply IHn in H.
      assumption.
    + destruct l'.
      * now simpl.
      * simpl in H.
        apply eq_add_S in H.
        rewrite bsort_equation.
        assert (length (ostanek (z :: l')) = n) as G.
        now rewrite dolzina_ostanka.
        apply urejen_najmanjsi.
        apply IHn.
        omega.
        intros y F.
        apply (ohranjanje_el n) in F.
        simpl in F.
        { case_eq (z =? najmanjsi z l')%Z; intro D.
        - rewrite D in F.
          now apply najmanjsi_tail.
        - rewrite D in F.
          simpl in F.
          destruct F.
          + rewrite H0.
            apply najmanjsi_head.
          + apply ostanek_pod in H0.
            now apply najmanjsi_tail.
        }
        omega.
Qed.

Theorem bsort_ureja : forall l : list Z, urejen (bsort l).
Proof.
  intro.
  apply (bsort_ureja_n (length l)).
  omega.
Qed.

Lemma pojavi_notIn (x : Z) (l : list Z) :
  ~In x l -> pojavi x l = pojavi x (ostanek l).
Proof.
  intro.
  induction l; auto.
  simpl in H.
  apply Decidable.not_or in H.
  destruct H as [H G].
  apply IHl in G.
  simpl.
  apply Z.neq_sym in H.
  apply Z.eqb_neq in H.
  rewrite H.
  case_eq (Z.eqb a (najmanjsi a l)); intro F; auto.
  simpl.
  now rewrite H.
Qed.

Lemma najmanjsi_ostanek (x : Z) (l : list Z) :
  (x = najmanjsi x l)%Z -> In x l -> S (pojavi x (ostanek l)) = pojavi x l.
Proof.
  intros H G.
  induction l.
  now simpl in G.
  case_eq (Z.eqb a (najmanjsi a l)); intro F.
  + simpl.
    rewrite F.
    simpl in G.
    destruct G as [E|E].
    * rewrite E.
      now rewrite Z.eqb_refl.
    * apply Z.eqb_eq in F.
      assert ((a <= x)%Z /\ (x <= a)%Z) as D.
      split.
      rewrite F.
      now apply najmanjsi_tail.
      rewrite H.
      apply najmanjsi_tail.
      firstorder.
      assert (x = a) as C.
      omega.
      apply Z.eqb_eq in C.
      now rewrite C.
  + simpl.
    rewrite F.
    case_eq (Z.eqb x a); intro E.
    * apply Z.eqb_neq in F.
      apply Z.eqb_eq in E.
      rewrite E in H.
      simpl in H.
      rewrite Z.leb_refl in H.
      firstorder.
    * simpl.
      rewrite E.
      {destruct G as [D|D].
      - apply Z.eqb_neq in E.
        firstorder.
      - apply IHl.
        apply Z.eqb_eq.
        case_eq (Z.leb x a); intro C.
        + simpl in H.
          rewrite C in H.
          now apply Z.eqb_eq.
        + apply Z.leb_gt in C.
          assert (x <= a)%Z as B.
          rewrite H.
          apply najmanjsi_tail.
          firstorder.
          firstorder.
        + assumption. }
Qed.

Lemma nenajmanjsi_ostanek (x : Z) (l : list Z) :
  (x <> najmanjsi x l)%Z -> pojavi x (ostanek l) = pojavi x l.
Proof.
  intro.
  induction l; auto.
  simpl.
  case_eq (Z.eqb a (najmanjsi a l)); case_eq (Z.eqb x a); intros F E.
  + apply Z.eqb_eq in F.
    rewrite F in H.
    apply Z.eqb_eq in E.
    simpl in H.
    rewrite Z.leb_refl in H.
    firstorder.
  + reflexivity.
  + simpl.
    rewrite F.
    apply eq_S.
    apply IHl.
    apply Z.eqb_eq in F.
    apply Z.eqb_neq in E.
    now rewrite F.
  + simpl.
    rewrite F.
    apply IHl.
    apply Z.eqb_neq.
    simpl in H.
    case_eq (Z.leb x a); intro G.
    rewrite G in H.
    now apply Z.eqb_neq.
    rewrite G in H.
    case_eq (Z.eqb x (najmanjsi x l)); intro D; auto.
    apply Z.eqb_eq in D.
    apply Z.eqb_neq in F.
    apply Z.eqb_neq in E.
    apply Z.leb_gt in G.
    assert (a = najmanjsi a l \/ In (najmanjsi a l) l) as C.
    apply najmanjsi_inv.
    destruct C as [C|C];firstorder.
    apply (najmanjsi_tail x (najmanjsi a l) l) in C.
    rewrite <- D in C.
    assert (x <= a)%Z as B.
    transitivity (najmanjsi a l);auto.
    apply najmanjsi_head.
    omega.
Qed.

Lemma pomo_In (x : Z) (l : list Z) :
  In x l -> length l > 0.
Proof.
  intro.
  destruct l.
  now simpl in H.
  simpl.
  omega.
Qed.

Lemma pomo_ostanek (x : Z) (l : list Z) :
  length l > 0 -> length (x :: ostanek l) = length l.
Proof.
  generalize x.
  induction l.
  intros.
  now simpl in H.
  intros.
  simpl.
  case_eq (Z.eqb a (najmanjsi a l)).
   + now intro.
   + intro.
     apply Z.eqb_neq in H0.
     assert (a = najmanjsi a l \/ In (najmanjsi a l) l). apply najmanjsi_inv.
     destruct H1 as [F | F].
      - contradiction.
      - assert (length l > 0).
         * now apply pomo_In in F.
         * apply eq_S.
           now apply (IHl a) in H1.
Qed.

Lemma pojavi_bsort_n (x : Z) (n : nat) (l : list Z) :
  length l <= n -> pojavi x l = pojavi x (bsort l).
Proof.
  generalize x l.
  induction n; intros y l' H.
  - apply dolzina_nic in H.
    now rewrite H.
  - apply le_lt_or_eq in H.
    destruct H as [H|H].
    + apply lt_n_Sm_le in H.
      now apply (IHn y l') in H.
    + destruct l';auto.
      simpl in H.
      apply eq_add_S in H.
      rewrite bsort_equation.
      simpl.
      case_eq (Z.eqb y z);
      case_eq (Z.eqb z (najmanjsi z l'));
      case_eq (Z.eqb y (najmanjsi z l'));
      intros G F E.
      * apply eq_S.
        apply (IHn y l').
        omega.
      * apply Z.eqb_eq in E.
        apply Z.eqb_eq in F.
        apply Z.eqb_neq in G.
        rewrite E in G.
        firstorder.
      * apply Z.eqb_eq in E.
        apply Z.eqb_neq in F.
        apply Z.eqb_eq in G.
        rewrite E in G.
        firstorder.
      * apply Z.eqb_eq in E.
        rewrite E.
        assert (pojavi z (z :: ostanek l') = S(pojavi z l')) as D.
        simpl.
        rewrite Z.eqb_refl.
        apply eq_S.
        apply (nenajmanjsi_ostanek ).
        now apply Z.eqb_neq in F.
        rewrite  <- D.
        apply IHn.
        simpl.
        destruct l'.
        simpl in F.
        apply Z.eqb_neq in F.
        omega.
        rewrite dolzina_ostanka.
        simpl in H.
        omega.
      * apply Z.eqb_eq in G; apply Z.eqb_eq in F; apply Z.eqb_neq in E.
        firstorder.
      * apply IHn.
        omega.
      * {
        assert (S (pojavi y (z :: ostanek l')) = pojavi y l') as D.
        simpl.
        rewrite E.
        apply najmanjsi_ostanek.
         - apply Z.eqb_eq in G.
           apply Z.eqb_neq in F.
           now apply najmanjsi_manjsi in G.
         - apply Z.eqb_eq in G.
           apply Z.eqb_neq in E.
           now apply (najmanjsi_neq y z l') in E.
         - simpl in D.
           rewrite E in D.
           apply Z.eqb_eq in G.
           assert (y = najmanjsi z l') as GG. assumption.
           apply najmanjsi_inv1 in G.
           destruct G as [G|G].
           apply Z.eqb_neq in E; contradiction.
           assert (y = najmanjsi z l') as GGG. assumption.
           apply najmanjsi_manjsi in GG.
           rewrite <- D.
           apply eq_S.
           assert (length (z :: ostanek (l')) <= n).
            + rewrite <- (pomo_ostanek z l') in H.
              firstorder.
              now apply pomo_In in G.
            + apply (IHn y) in H0.
              rewrite <- H0.
              simpl.
              now rewrite E.
        }
      * {
        assert (pojavi y (z :: ostanek l') = pojavi y l') as D.
        - simpl.
          rewrite E.
          apply Z.eqb_neq in G; apply Z.eqb_neq in F; apply Z.eqb_neq in E.
          case_eq (Z.eqb y (najmanjsi y l'));intro C.
          + apply Z.eqb_eq in C.
            assert (~ In y l') as B.
            apply (nenajmanjse_fore y z l'); assumption.
            rewrite <- pojavi_notIn; auto.
          + apply Z.eqb_neq in C.
            now apply nenajmanjsi_ostanek.
        - rewrite <- D.
          apply IHn.
          simpl.
          destruct l'.
          simpl in F.
          apply Z.eqb_neq in F.
          omega.
          rewrite dolzina_ostanka.
          simpl in H.
          omega.
        }
Qed.

Theorem bsort_permutira : forall l : list Z, permutiran l (bsort l).
Proof.
  intro l.
  unfold permutiran.
  intro x.
  now apply (pojavi_bsort_n x (length l) l).
Qed.


Set Implicit Arguments.
Require Import Omega.
Require Import Coq.Numbers.Natural.Peano.NPeano. (* [mod] *)
Require Import Coq.Arith.Wf_nat.                 (* [lt_wf] *)
Require Import Coq.Wellfounded.Inclusion.        (* [wf_incl] *)
Require Import Coq.Wellfounded.Inverse_Image.    (* [wf_inverse_image] *)
Require Import Coq.Arith.Peano_dec.              (* [eq_nat_dec] *)
Require Import Loop.

(* This file contains a few demos of the use of [Loop]. *)

(* ---------------------------------------------------------------------------- *)

(* Use OCaml integers at extraction time. *)

Require Import ExtrOcamlNatInt.
Extract Inlined Constant modulo => "(mod)".
Extract Inlined Constant plus => "(+)".

(* ---------------------------------------------------------------------------- *)

(* Demo 1. Euclid's GCD algorithm. *)

(* The body of Euclid's loop. *)

Definition gcd_body (ab : nat * nat) :=
  let (a, b) := ab in
  if eq_nat_dec b 0 then
    MsgFinished a
  else
    MsgContinue (b, a mod b).

(* The algorithm terminates because [b], the second component of the
   state, decreases at every iteration. *)

Definition gcd_evolution (s' s : nat * nat) :=
  snd s' < snd s.

Lemma gcd_wf:
  well_founded gcd_evolution.
Proof.
  unfold gcd_evolution. eapply wf_inverse_image. eapply lt_wf.
Qed.

Lemma gcd_body_evolution:
  forall s s',
  gcd_body s = MsgContinue s' ->
  gcd_evolution s' s.
Proof.
  unfold gcd_body. intros [ a b ] [ a' b' ].
  destruct (eq_nat_dec b 0).
  { congruence. }
  { intros h. injection h. clear h. intros. subst. unfold gcd_evolution.
    eauto using Nat.mod_upper_bound. }
Qed.

(* Thus, we are allowed to construct the loop. *)

Definition gcd : nat * nat -> nat :=
  loop gcd_body
    gcd_wf gcd_body_evolution.

(* This code has the desired property. *)

Lemma gcd_eq:
  forall a b,
  gcd (a, b) =
    if eq_nat_dec b 0 then
      a
    else
      gcd (b, a mod b).
Proof.
  intros. unfold gcd, gcd_body. rewrite loop_eq.
  (* The match/match optimisation must be justified by a case analysis. *)
  destruct (eq_nat_dec b 0); eauto.
Qed.

(* The code can be extracted as follows. Inlining [loop] and [gcd_body]
   triggers a match/match optimisation in Coq's extraction engine, and allows
   us to obtain the clean code that we would have written by hand in OCaml.
   Although this code apparently constructs a pair at every iteration, a
   recent OCaml compiler is able to produce machine code that keeps the
   parameters [a] and [b] in two registers. *)

Extraction Inline gcd_body.

Extraction gcd.
(* This should yield the following OCaml code:

let rec gcd = function
| (a, b) -> if (=) b 0 then a else let s' = (b, ((mod) a b)) in gcd s'

so we have, in OCaml:

# gcd (25, 185);;
- : int = 5
# gcd (42, 735);;
- : int = 21
# gcd (8, 13);;
- : int = 1

*)

(* ---------------------------------------------------------------------------- *)

(* Demo 2. Counting up to 100, two by two, accumulating a list of indices.
   This is a loop whose termination argument relies on an invariant, namely
   the property of being even and less than (or equal to) 100. *)

Require Import List.

(* The type of the current state. *)

Notation state := (nat * list nat)%type.

(* The loop body. *)

Definition MAX := 100.
Definition TWO := 2.

Definition count_body (s : state) :=
  let (n, ns) := s in
  if eq_nat_dec n MAX then
    MsgFinished ns
  else
    MsgContinue (n + TWO, n :: ns).

(* The evolution relation. *)

Definition count_evolution (s' s : state) :=
  let (n , _) := s  in
  let (n', _) := s' in
  n' = n + 2.

(* The invariant. *)

Definition count_invariant (s : state) :=
  let (n , _) := s in
  n = 2 * (n/2) /\ n <= MAX.

(* A technical arithmetic lemma. *)

Lemma plus2_div2:
  forall n,
  (n + 2) / 2 = n/2 + 1.
Proof.
Admitted.

(* We must prove the following facts. *)

Lemma wf_count_evolution:
  well_founded (fun s' s =>
    count_evolution s' s /\ count_invariant s /\ count_invariant s'
  ).
Proof.
  eapply wf_incl; [ |
    eapply wf_inverse_image
      with (f := fun s : state => let (n, _) := s in 50 - n/2);
    eapply lt_wf
  ].
  unfold count_evolution, count_invariant. intros [ n' _ ] [ n _ ] ?.
  repeat match goal with h: _ /\ _ |- _ => destruct h end.
  generalize (plus2_div2 n); intro.
  unfold MAX in *. omega.
Qed.

Lemma count_body_evolution:
  forall s s', count_invariant s -> count_body s = MsgContinue s' -> count_evolution s' s.
Proof.
  unfold count_body, count_evolution, count_invariant.
  intros [ n ? ] [ n' ? ] [ ? ? ].
  destruct (eq_nat_dec n MAX); [ congruence | ].
  intro h. injection h. clear h. intro h.
  unfold TWO in *. omega.
Qed.

(* We isolate the following auxiliary lemma because it is used in the
   statement of [count_eq_simplified] below. *)

Lemma count_invariant_preserved_aux:
  forall n ns, count_invariant (n, ns) -> n <> MAX -> count_invariant (n + 2, n :: ns).
Proof.
  unfold count_invariant. intros ? ? [ ? ? ] ?.
  split.
  { generalize (plus2_div2 n); intro. omega. }
  { unfold MAX in *. omega. }
Qed.

Lemma count_invariant_preserved:
  forall s,
  count_invariant s ->
  forall s',
  count_body s = MsgContinue s' ->
  count_invariant s'.
Proof.
  unfold count_body, count_evolution. intros [ n ns ]. intros.
  destruct (eq_nat_dec n MAX); [ congruence | msg_injection ].
  eauto using count_invariant_preserved_aux.
  (* We use [Defined] as opposed to [Qed] because we need to unfold
     this definition in the proof of [count_eq_simplified]. *)
Defined.

(* Thus, we are allowed to construct the loop. *)

Definition count :=
  loop_with_invariant count_body
    wf_count_evolution count_body_evolution count_invariant_preserved.

(* This code has the desired property. *)

Lemma count_eq:
  forall s,
  forall hs : count_invariant s,
  count (exist _ s hs) =
    match count_body s as m return (count_body s = m -> list nat) with
    | MsgContinue s' => fun eq =>
        count (exist _ s' (count_invariant_preserved _ hs eq))
    | MsgFinished t  => fun _  =>
        t
    end eq_refl.
Proof.
  intros. unfold count. rewrite loop_eq_with_invariant. fold count. reflexivity.
Qed.

(* By inlining [count_body] in the statement of [count_eq] and
   exchanging the two [match] constructs, we obtain the following
   somewhat simplified statement of the fixed point equation. *)

Lemma count_eq_simplified:
  forall n ns,
  forall hs : count_invariant (n, ns),
  count (exist _ (n, ns) hs) =
    match eq_nat_dec n MAX with
    | right hneq =>
        count (exist _ (n + 2, n :: ns) (count_invariant_preserved_aux hs hneq))
    | left  heq  =>
        ns
    end.
Proof.
  intros. rewrite count_eq. unfold count_body.
  (* It is definitely not nice to have to rely on a transparent proof!
     So far, I haven't found a better way. Suggestions are welcome! *)
  unfold count_invariant_preserved.
  generalize (count_invariant_preserved_aux hs). intro cxhs.
  destruct (eq_nat_dec n MAX).
  { reflexivity. }
  { reflexivity. }
Qed.

(* Extraction. *)

(* Unfortunately, there seems to be no generic way of translating
   integer constants to integer constants during extraction. *)
Extract Inlined Constant MAX => "100".
Extract Inlined Constant TWO => "2".

Extraction Inline count_body.

Extraction count.
(* This should yield the following OCaml code:

let rec count = function
| (n, ns) ->
  if (=) n 100 then ns else let s' = (((+) n 2), (n :: ns)) in count s'

so we have, in OCaml:

# count (90, []);;
- : int list = [98; 96; 94; 92; 90]

*)

(* As an example of reasoning a posteriori with an extra invariant,
   we prove that if the loop starts at [MIN], then every element in
   the final list is greater than or equal to [MIN]. (We could also
   prove that all of them are even and less than [MAX].) *)

Definition goal MIN (ms : list nat) :=
  forall m, In m ms -> MIN <= m.

Definition extra_invariant MIN (s : state) :=
  let (n, ns) := s in
  MIN <= n /\ goal MIN ns.

Lemma above_min:
  forall MIN,
  forall s,
  proj1_sig s = (MIN, nil) ->
  goal MIN (count s).
Proof.
  intros ? ? heq. unfold count.
  eapply loop_with_invariant_invariant_alt with (X := extra_invariant MIN);
    unfold count_invariant, extra_invariant, count_body.
  (* The extra invariant is preserved. *)
  { intros [ n ns ] [ n' ns' ] [ ? ? ] [ ? ? ] ?.
    destruct (eq_nat_dec n MAX); [ congruence | msg_injection ].
    intros. subst n' ns'.
    split.
    { omega. }
    { unfold goal in *. simpl. intros ? [ | ].
      intros. subst n. assumption.
      eauto. }
  }
  (* The extra invariant implies the goal. *)
  { intros [ n ns ] ns' [ ? ? ] [ ? ? ] ?.
    destruct (eq_nat_dec n MAX); [ msg_injection | congruence ].
    assumption. }
  (* The extra invariant holds initially. *)
  { destruct s as [ [ n ns ] hs ]. simpl in *.
    injection heq. clear heq. intros. subst.
    split.
      { eauto. }
      { unfold goal. simpl. tauto. }
  }
Qed.


(* -------------------------------------------------------------------- *)
Require Import Arith List.
From Autosubst Require Import Autosubst.
(* These are already required by Autosubst. However, having them
   available is useful to prove equality lemmas about the translation
  to Coq formulas. *)
Require Import Coq.Logic.FunctionalExtensionality.

(* -------------------------------------------------------------------- *)
Inductive expr : Type :=
| Var (_ : var)
| Zero
| Succ (_ : expr)
| Plus (_ : expr) (_ : expr)
| Mult (_ : expr) (_ : expr).

Inductive formula : Type :=
| Bottom
(* Autosubst complains if this line is not present.
   See https://github.com/uds-psl/autosubst/issues/4 *)
| DummyVar (_ : var)
| Implies (_ : formula) (_ : formula)
| And (_ : formula) (_ : formula)
| Or (_ : formula) (_ : formula)
| Eq (_ : expr) (_ : expr)
| Forall (_ : {bind expr in formula})
| Exists (_ : {bind expr in formula}).

Infix "@+" := Plus (at level 50, left associativity).
Infix "@*" := Mult (at level 40, left associativity).
Notation "x @-> y" := (Implies x y) (at level 99, right associativity, y at level 200).
Infix "@/\" := And (at level 80, right associativity).
Infix "@\/" := Or (at level 85, right associativity).
Infix "@=" := Eq (at level 70).
Notation Not := (fun P => P @-> Bottom).
Notation "@~ x" := (Not x) (at level 75, right associativity).

(* -------------------------------------------------------------------- *)
(* Magic commands to bind Autosubst to our formulas and expressions. *)
Instance Ids_expr : Ids expr. derive. Defined.
Instance Rename_expr : Rename expr. derive. Defined.
Instance Subst_expr : Subst expr. derive. Defined.
Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.
Instance HSubst_formula : HSubst expr formula. derive. Defined.
Instance Ids_formula : Ids formula. derive. Defined.
Instance Rename_formula : Rename formula. derive. Defined.
Instance Subst_formula : Subst formula. derive. Defined.
Instance HSubstLemmas_formula : HSubstLemmas expr formula. derive. Qed.
Instance SubstHSubstComp_expr_formula : SubstHSubstComp expr formula. derive. Qed.
Instance SubstLemmas_formula : SubstLemmas formula. derive. Qed.

(* -------------------------------------------------------------------- *)
(* Some useful lemmas that seem to be missing from Autosubst. *)
Lemma subst_cons :
  forall A Gamma sigma, (A :: Gamma)..|[sigma] = A.|[sigma] :: Gamma..|[sigma].
Proof.
  auto.
Qed.

Lemma subst_app :
  forall Gamma Delta sigma, (Gamma ++ Delta)..|[sigma] = Gamma..|[sigma] ++ Delta..|[sigma].
Proof.
  intros Gamma Delta sigma; induction Gamma.
  - simpl; auto.
  - simpl. f_equal. auto.
Qed.

(* -------------------------------------------------------------------- *)
(* Definition of the rules of natural deduction, given a way to know
   whether a formula is an axiom. Note that this is a Type, in order to
   allow computation on proofs. *)
Definition env := list formula.
Inductive nd (ax : formula -> Type) : env -> formula -> Type :=
| Nd_axiom : forall A Gamma, ax A -> nd ax Gamma A
| Nd_assume : forall A Gamma, nd ax (A :: Gamma) A
| Nd_weak : forall A B Gamma, nd ax Gamma A -> nd ax (B :: Gamma) A
| Nd_impI : forall A B Gamma, nd ax (A :: Gamma) B -> nd ax Gamma (Implies A B)
| Nd_impE : forall A B Gamma, nd ax Gamma (Implies A B) -> nd ax Gamma A -> nd ax Gamma B
| Nd_andI : forall A B Gamma, nd ax Gamma A -> nd ax Gamma B -> nd ax Gamma (And A B)
| Nd_andEL : forall A B Gamma, nd ax Gamma (And A B) -> nd ax Gamma A
| Nd_andER : forall A B Gamma, nd ax Gamma (And A B) -> nd ax Gamma B
| Nd_orIL : forall A B Gamma, nd ax Gamma A -> nd ax Gamma (Or A B)
| Nd_orIR : forall A B Gamma, nd ax Gamma B -> nd ax Gamma (Or A B)
| Nd_orE : forall A B C Gamma, nd ax Gamma (Or A B) -> nd ax (A :: Gamma) C -> nd ax (B :: Gamma) C -> nd ax Gamma C
| Nd_botE : forall A Gamma, nd ax Gamma Bottom -> nd ax Gamma A
| Nd_forallI : forall A Gamma, nd ax Gamma..|[ren (+1)] A -> nd ax Gamma (Forall A)
| Nd_forallE : forall A Gamma t, nd ax Gamma (Forall A) -> nd ax Gamma A.|[t/]
| Nd_existI : forall A Gamma t, nd ax Gamma A.|[t/] -> nd ax Gamma (Exists A)
| Nd_existE : forall A B Gamma, nd ax Gamma (Exists A) -> nd ax (A :: Gamma..|[ren (+1)]) B.|[ren (+1)] -> nd ax Gamma B
| Nd_eq_refl : forall Gamma t, nd ax Gamma (t @= t)
| Nd_eq_elim : forall Gamma A t1 t2, nd ax Gamma (t1 @= t2) -> nd ax Gamma A.|[t1/] -> nd ax Gamma A.|[t2/].

(* -------------------------------------------------------------------- *)
(* Some useful tactics to reason about natural deduction. *)

(* Clear the [n] first hypotheses of the sequent. *)
Ltac nd_clear n :=
  match n with
  | 0 => idtac
  | S ?n => apply Nd_weak; nd_clear n
  end.

(* Try to prove the sequent by applying any assumption. *)
Ltac nd_assumption_rec :=
  solve [apply Nd_assume | apply Nd_weak; nd_assumption_rec].
Tactic Notation "nd_assumption" := nd_assumption_rec.

(* Try to prove the sequent by applying the [n]th,
   0-indexed, assumption. *)
Tactic Notation "nd_assumption" constr(n) := nd_clear n; apply Nd_assume.

(* -------------------------------------------------------------------- *)
(* Definition of the axioms of Heyting and Peano arithmetic. *)

Inductive PeanoAxioms : formula -> Type :=
| Peano_0_ne_Sn : PeanoAxioms (Forall (@~ (Succ (Var 0) @= Zero)))
| Peano_ne_0_Sn : PeanoAxioms (Forall (Exists ((@~ (Var 1 @= Zero)) @-> (Succ (Var 0) @= Var 1))))
| Peano_S_inj : PeanoAxioms (Forall (Forall ((Succ (Var 1) @= Succ (Var 0)) @-> (Var 1 @= Var 0))))
| Peano_plus_0 : PeanoAxioms (Forall (Zero @+ Var 0 @= Var 0))
| Peano_plus_S : PeanoAxioms (Forall (Forall (Succ (Var 1) @+ Var 0 @= Succ (Var 1 @+ Var 0))))
| Peano_mult_0 : PeanoAxioms (Forall (Zero @* Var 0 @= Zero))
| Peano_mult_S : PeanoAxioms (Forall (Forall (Succ (Var 1) @* Var 0 @= Var 1 @* Var 0 @+ Var 0)))
| Peano_rec : forall P, PeanoAxioms (P.|[Zero/] @-> ((Forall (Implies P P.|[Succ (Var 0) .: ren (+1)])) @-> (Forall P))).

Inductive ClassicalPeano : formula -> Type :=
| PeanoAxiom : forall A, PeanoAxioms A -> ClassicalPeano A
| DoubleNegation : forall A, ClassicalPeano (@~ @~ A @-> A).

Notation Heyting := (nd PeanoAxioms).
Notation Peano := (nd ClassicalPeano).

(* -------------------------------------------------------------------- *)
(* Definition of the translation of formulas into Coq [Type]s. This
   allows to prove the theorems in a constructive setting. *)

Fixpoint tr_expr sigma e :=
  match e with
  | Var n => sigma n
  | Zero => 0
  | Succ e => S (tr_expr sigma e)
  | e1 @+ e2 => (tr_expr sigma e1) + (tr_expr sigma e2)
  | e1 @* e2 => (tr_expr sigma e1) * (tr_expr sigma e2)
  end.

Fixpoint tr_formula sigma A : Type :=
  match A with
  | Bottom => False
  | DummyVar _ => True
  | A @-> B => (tr_formula sigma A) -> (tr_formula sigma B)
  | A @/\ B => (tr_formula sigma A) * (tr_formula sigma B)
  | A @\/ B => (tr_formula sigma A) + (tr_formula sigma B)
  | e1 @= e2 => (tr_expr sigma e1) = (tr_expr sigma e2)
  | Forall A => forall x, tr_formula (x .: sigma) A
  | Exists A => {x : nat & tr_formula (x .: sigma) A}
  end.

Definition tr_env sigma Gamma := fold_right prod True (map (tr_formula sigma) Gamma).
Hint Unfold tr_env.

Lemma tr_env_cons : forall sigma A Gamma,
    tr_env sigma (A :: Gamma) = (tr_formula sigma A * tr_env sigma Gamma)%type.
Proof.
  intros; unfold tr_env; auto.
Qed.

Lemma tr_expr_subst : forall e sigma xi,
    tr_expr xi e.[sigma] = tr_expr (fun x => tr_expr xi (sigma x)) e.
Proof.
  intros e; induction e; intros; simpl; auto.
Qed.

Lemma tr_expr_extensionality : forall e sigma1 sigma2,
    (forall x, sigma1 x = sigma2 x) -> tr_expr sigma1 e = tr_expr sigma2 e.
Proof.
  intros e; induction e; intros; simpl; auto.
Qed.

(* Helpful tactic to prove equality of sigT types. *)
Ltac sigT_extensionality x :=
  f_equal; [intros H1 H2; rewrite H2; reflexivity | extensionality x].

Lemma tr_formula_extensionality : forall A sigma1 sigma2,
    (forall x, sigma1 x = sigma2 x) -> tr_formula sigma1 A = tr_formula sigma2 A.
Proof.
  intros A; induction A; intros; simpl; try auto.
  - rewrite (IHA1 sigma1 sigma2 H); rewrite (IHA2 sigma1 sigma2 H); auto.
  - rewrite (IHA1 sigma1 sigma2 H); rewrite (IHA2 sigma1 sigma2 H); auto.
  - rewrite (IHA1 sigma1 sigma2 H); rewrite (IHA2 sigma1 sigma2 H); auto.
  - repeat (rewrite (tr_expr_extensionality _ sigma1 sigma2); auto).
  - extensionality x. apply IHA. intros [|n]; autosubst.
  - sigT_extensionality x. apply IHA. intros [|n]; autosubst.
Qed.

Lemma tr_env_extensionality : forall Gamma sigma1 sigma2,
    (forall x, sigma1 x = sigma2 x) -> tr_env sigma1 Gamma = tr_env sigma2 Gamma.
Proof.
  intros Gamma; induction Gamma.
  - intros; simpl; auto.
  - intros; do 2 (rewrite tr_env_cons); simpl.
    erewrite tr_formula_extensionality; auto.
    f_equal. apply IHGamma; auto.
Qed.

Lemma tr_formula_subst : forall A sigma xi,
    tr_formula xi A.|[sigma] = tr_formula (fun x => tr_expr xi (sigma x)) A.
Proof.
  intros A; induction A; intros; simpl; auto.
  - rewrite IHA1; rewrite IHA2; auto.
  - rewrite IHA1; rewrite IHA2; auto.
  - rewrite IHA1; rewrite IHA2; auto.
  - do 2 (rewrite tr_expr_subst); auto.
  - extensionality x. rewrite IHA. apply tr_formula_extensionality.
    intros [|n]; simpl; asimpl; auto.
    rewrite tr_expr_subst. apply tr_expr_extensionality. intros; simpl; auto.
  - sigT_extensionality x. rewrite IHA. apply tr_formula_extensionality.
    intros [|n]; simpl; asimpl; auto.
    rewrite tr_expr_subst. apply tr_expr_extensionality. intros; simpl; auto.
Qed.

Lemma tr_formula_subst1 : forall A sigma e,
    tr_formula sigma A.|[e/] = tr_formula ((tr_expr sigma e) .: sigma) A.
Proof.
  intros A sigma e; rewrite tr_formula_subst; apply tr_formula_extensionality.
  intros [|n]; simpl; auto.
Qed.

Lemma tr_env_subst : forall Gamma sigma xi,
    tr_env xi Gamma..|[sigma] = tr_env (fun x => tr_expr xi (sigma x)) Gamma.
Proof.
  intros Gamma; induction Gamma.
  - intros; unfold tr_env; simpl; auto.
  - intros sigma xi; unfold tr_env; simpl; asimpl.
    rewrite tr_formula_subst. f_equal.
    unfold tr_env in IHGamma. rewrite <- IHGamma. auto.
Qed.

(* A formula that can be proved in Heyting arithmetic can also be
   proved in Coq *)
Theorem reflect : forall Gamma A, Heyting Gamma A -> forall sigma, tr_env sigma Gamma -> tr_formula sigma A.
Proof.
  intros Gamma A dn; elim dn.
  - intros A0 Gamma0 H sigma Henv.
    destruct H; simpl; try (intros; auto; congruence).
    + intros [|n].
      * exists 0; intros; exfalso; auto.
      * exists n; auto.
    + intros; apply plus_comm.
    + intros H0 HI x; induction x as [|x IHx]; simpl in *.
      * rewrite tr_formula_subst1 in H0. auto.
      * specialize (HI x IHx). rewrite tr_formula_subst in HI.
        erewrite tr_formula_extensionality; [apply HI|].
        intros [|n]; simpl; auto.
  - simpl. intros A0 Gamma0 sigma [H1 H2]; auto.
  - simpl. intros A0 B0 Gamma0 H1 H2 sigma [H3 H4]. auto.
  - simpl. intros A0 B0 Gamma0 H1 H2 sigma H3 H4.
    apply H2. unfold tr_env; simpl. auto.
  - simpl. intros A0 B0 Gamma0 H1 H2 H3 H4 sigma H5.
    apply H2; auto.
  - simpl. intros A0 B0 Gamma0 H1 H2 H3 H4 sigma H5. auto.
  - simpl. intros A0 B0 Gamma0 H1 H2 sigma H3. apply H2; auto.
  - simpl. intros A0 B0 Gamma0 H1 H2 sigma H3. apply H2; auto.
  - simpl. intros A0 B0 Gamma0 H1 H2 sigma H3. auto.
  - simpl. intros A0 B0 Gamma0 H1 H2 sigma H3. auto.
  - simpl. intros A0 B0 C0 Gamma0 H1 H2 H3 H4 H5 H6 sigma H7.
    destruct (H2 sigma H7); [apply H4 | apply H6]; unfold tr_env; simpl; auto.
  - simpl. intros A0 Gamma0 H1 H2 sigma H3. exfalso; eapply H2; eauto.
  - simpl. intros A0 Gamma0 H1 H2 sigma H3 x. apply H2.
    rewrite tr_env_subst.
    erewrite tr_env_extensionality; eauto.
  - simpl. intros A0 Gamma0 t H1 H2 sigma H3.
    rewrite tr_formula_subst1. apply H2; auto.
  - simpl. intros A0 Gamma0 t H1 H2 sigma H3.
    specialize (H2 sigma H3). rewrite tr_formula_subst1 in H2.
    eauto.
  - simpl. intros A0 B0 Gamma0 H1 H2 H3 H4 sigma H5.
    destruct (H2 sigma H5) as [x H6].
    specialize (H4 (x .: sigma)). rewrite tr_env_cons in H4.
    rewrite tr_formula_subst in H4.
    apply H4. rewrite tr_env_subst; auto.
  - simpl. intros Gamma0 t sigma H. reflexivity.
  - simpl. intros Gamma0 A0 t1 t2 H1 H2 H3 H4 sigma H5.
    specialize (H2 sigma H5).
    specialize (H4 sigma H5).
    rewrite tr_formula_subst1 in *. congruence.
Defined.

(* As a trivial corollary, Heyting arithmetic is consistent. *)
Corollary Heyting_consistent : Heyting nil Bottom -> False.
Proof.
  intros H. apply reflect with (sigma := fun _ => 0) in H; auto.
  unfold tr_env; simpl; auto.
Defined.

(* -------------------------------------------------------------------- *)
(* Definition of the combined double-negation and Friedman translation
   of Peano arithmetic to Friedman arithmetic. *)
Definition dnegA A B := (B @-> A) @-> A.

Fixpoint friedman A B :=
  match B with
  | Bottom | DummyVar _ | _ @= _ => B @\/ A
  | B @/\ C => (dnegA A (friedman A B)) @/\ (dnegA A (friedman A C))
  | B @\/ C => (dnegA A (friedman A B)) @\/ (dnegA A (friedman A C))
  | B @-> C => (dnegA A (friedman A B)) @-> (dnegA A (friedman A C))
  | Forall B => (Forall (dnegA A.|[ren (+1)] (friedman (A.|[ren (+1)]) B)))
  | Exists B => (dnegA A (Exists (friedman (A.|[ren (+1)]) B)))
  end.

Lemma nd_cut : forall ax Gamma A B, nd ax Gamma A -> nd ax (A :: Gamma) B -> nd ax Gamma B.
Proof.
  intros ax Gamma A B H0 H1.
  apply Nd_impE with (A := A).
  - apply Nd_impI; auto.
  - auto.
Defined.

Lemma nd_weak_r : forall ax Gamma A, nd ax Gamma A -> forall Delta Pi B, Gamma = Delta ++ Pi -> nd ax (Delta ++ (B :: Pi)) A.
Proof.
  intros ax Gamma A dn; elim dn.
  - intros; apply Nd_axiom; auto.
  - intros A0 Gamma0 [|A1 Delta] Pi B H.
    + simpl in *. apply Nd_weak. rewrite <- H. apply Nd_assume.
    + simpl in *. replace A1 with A0 by congruence. apply Nd_assume.
  - intros A0 B Gamma0 H1 H2 [|B1 Delta] Pi B0 H3.
    + simpl in *. rewrite <- H3. apply Nd_weak. apply Nd_weak. auto.
    + simpl in *. apply Nd_weak. apply H2. congruence.
  - intros A0 B Gamma0 H1 H2 Delta Pi B0 H3. apply Nd_impI.
    apply H2 with (Delta := A0 :: Delta). simpl; congruence.
  - intros A0 B Gamma0 H1 H2 H3 H4 Delta Pi B0 H5. apply Nd_impE with (A := A0).
    + apply H2; auto.
    + apply H4; auto.
  - intros A0 B Gamma0 H1 H2 H3 H4 Delta Pi B0 H5. apply Nd_andI.
    + apply H2; auto.
    + apply H4; auto.
  - intros A0 B Gamma0 H1 H2 Delta Pi B0 H3. eapply Nd_andEL. apply H2; auto.
  - intros A0 B Gamma0 H1 H2 Delta Pi B0 H3. eapply Nd_andER. apply H2; auto.
  - intros A0 B Gamma0 H1 H2 Delta Pi B0 H3. eapply Nd_orIL. apply H2; auto.
  - intros A0 B Gamma0 H1 H2 Delta Pi B0 H3. eapply Nd_orIR. apply H2; auto.
  - intros A0 B0 C Gamma0 H1 H2 H3 H4 H5 H6 Delta Pi B1 H7. eapply Nd_orE.
    + apply H2; auto.
    + apply H4 with (Delta := A0 :: Delta). simpl; congruence.
    + apply H6 with (Delta := B0 :: Delta). simpl; congruence.
  - intros A0 Gamma0 H1 H2 Delta Pi B H3. apply Nd_botE. auto.
  - intros A0 Gamma0 H1 H2 Delta Pi B H3. apply Nd_forallI.
    rewrite H3 in *. rewrite subst_app in *. rewrite subst_cons.
    apply H2; auto.
  - intros A0 Gamma0 t H1 H2 Delta Pi B H3. apply Nd_forallE. apply H2; auto.
  - intros A0 Gamma0 t H1 H2 Delta Pi B H3. apply Nd_existI with (t := t).
    apply H2; auto.
  - intros A0 B Gamma0 H1 H2 H3 H4 Delta Pi B0 H5. eapply Nd_existE.
    + apply H2; auto.
    + rewrite H5 in *. rewrite subst_app in *. rewrite subst_cons.
      apply H4 with (Delta0 := (A0 :: Delta..|[ren (+1)])); auto.
  - intros Gamma0 t Delta Pi B H. apply Nd_eq_refl.
  - intros Gamma0 A0 t1 t2 H1 H2 H3 H4 Delta Pi B H5.
    eapply Nd_eq_elim; [apply H2 | apply H4]; auto.
Defined.

Lemma nd_weak : forall ax Gamma Delta A B, nd ax (Gamma ++ Delta) A -> nd ax (Gamma ++ (B :: Delta)) A.
Proof.
  intros ax Gamma Delta A B H.
  apply nd_weak_r with (Gamma := Gamma ++ Delta) (Delta := Gamma) (Pi := Delta); auto.
Defined.

(* Helpful tactics to handle natural deduction sequents. *)

Ltac nd_weak n :=
  match n with
  | 0 => apply Nd_weak
  | 1 => apply (nd_weak _ (_ :: nil)); simpl
  | 2 => apply (nd_weak _ (_ :: _ :: nil)); simpl
  | 3 => apply (nd_weak _ (_ :: _ :: _ :: nil)); simpl
  | 4 => apply (nd_weak _ (_ :: _ :: _ :: _ :: nil)); simpl
  | 5 => apply (nd_weak _ (_ :: _ :: _ :: _ :: _ :: nil)); simpl
  | 6 => apply (nd_weak _ (_ :: _ :: _ :: _ :: _ :: _ :: nil)); simpl
  end.

Ltac nd_apply n :=
  eapply Nd_impE; [nd_assumption n|].

Ltac nd_intro := apply Nd_impI.

Ltac nd_destruct_or n :=
  eapply Nd_orE; [nd_assumption n|nd_weak (S n)|nd_weak (S n)].
Ltac nd_left := apply Nd_orIL.
Ltac nd_right := apply Nd_orIR.

Ltac nd_assert H :=
  apply Nd_impE with (A := H); [nd_intro|].

Ltac nd_destruct_and n :=
  eapply Nd_impE;
  [
    nd_intro; eapply Nd_impE;
    [nd_intro; nd_weak (S (S n))
    |eapply Nd_andEL; nd_assumption (S n)
    ]
   |eapply Nd_andER; nd_assumption n
  ].
Ltac nd_split := apply Nd_andI.

Ltac nd_exfalso := apply Nd_botE.

Ltac nd_unapply n := eapply Nd_impE; [|nd_assumption n].
Ltac nd_revert n := nd_unapply n; nd_weak n.

(* Some lemmas concerning double-negation translation *)

Lemma double_neg_simpl :
  forall ax Gamma A B, nd ax Gamma A -> nd ax Gamma (dnegA B A).
Proof.
  intros ax Gamma A B H.
  nd_intro. nd_apply 0. nd_weak 0; auto.
Defined.

Lemma double_neg_imp :
  forall ax Gamma A B C, nd ax (B :: Gamma) C -> nd ax (dnegA A B :: Gamma) (dnegA A C).
Proof.
  intros ax Gamma A B C H.
  nd_intro. nd_apply 1. nd_intro. nd_apply 1.
  nd_weak 1; nd_weak 1; auto.
Defined.

Lemma or_imp :
  forall Gamma A B C, Heyting (B :: Gamma) C -> Heyting ((A @\/ B) :: Gamma) (A @\/ C).
Proof.
  intros Gamma A B C H.
  nd_destruct_or 0.
  - nd_left; nd_assumption.
  - nd_right; auto.
Defined.

Lemma or_double_neg :
  forall ax Gamma A B, nd ax Gamma (A @\/ B) -> nd ax Gamma (dnegA A B).
Proof.
  intros ax Gamma A B H.
  nd_intro.
  eapply Nd_orE; [nd_weak 0; eauto| |].
  - nd_assumption.
  - nd_apply 1; nd_assumption.
Defined.

Lemma double_neg_or :
  forall ax Gamma A B, nd ax Gamma (dnegA A B) -> nd ax Gamma (dnegA A (B @\/ A)).
Proof.
  intros ax Gamma A B H.
  nd_intro. eapply Nd_impE; [nd_weak 0; apply H|].
  nd_intro. nd_apply 1. nd_left; nd_assumption.
Defined.

Lemma or_double_neg_rev :
  forall ax Gamma A B, nd ax Gamma (B @\/ A) -> nd ax Gamma (dnegA A B).
Proof.
  intros ax Gamma A B H.
  nd_intro.
  eapply Nd_orE; [nd_weak 0; eauto| |].
  - nd_apply 1; nd_assumption.
  - nd_assumption.
Defined.

Lemma double_neg_4 : forall ax Gamma A B, nd ax Gamma (dnegA B (dnegA B A)) -> nd ax Gamma (dnegA B A).
Proof.
  intros ax Gamma A B H.
  nd_intro.
  eapply Nd_impE; [nd_weak 0; eauto|].
  nd_intro; nd_apply 0; nd_assumption.
Defined.

Lemma double_neg_weak :
  forall ax Gamma A B C, nd ax (B :: Gamma) (dnegA A C) -> nd ax (dnegA A B :: Gamma) (dnegA A C).
Proof.
  intros ax Gamma A B C H.
  apply double_neg_4. apply double_neg_imp; auto.
Defined.

Lemma double_neg_weakH :
  forall ax Gamma A B C, nd ax (B :: Gamma) (dnegA A C) -> nd ax Gamma (dnegA A B) -> nd ax Gamma (dnegA A C).
Proof.
  intros ax Gamma A B C H1 H2.
  eapply Nd_impE; [|apply H2].
  nd_intro; apply double_neg_weak; auto.
Defined.

(* Compatibility between Friedman translation and substitution *)

Lemma friedman_subst :
  forall B A sigma, (friedman A B).|[sigma] = friedman A.|[sigma] B.|[sigma].
Proof.
  intros B. induction B; intros; simpl; auto.
  - rewrite IHB1; rewrite IHB2; auto.
  - rewrite IHB1; rewrite IHB2; auto.
  - rewrite IHB1; rewrite IHB2; auto.
  - rewrite IHB. asimpl. auto.
  - rewrite IHB. asimpl. auto.
Defined.

Lemma friedman_subst_map :
  forall Gamma A sigma, (map (friedman A) Gamma)..|[sigma] = map (friedman A.|[sigma]) Gamma..|[sigma].
Proof.
  intros. induction Gamma.
  - simpl; auto.
  - rewrite subst_cons. unfold map in *. rewrite subst_cons.
    rewrite IHGamma. rewrite friedman_subst. auto.
Defined.

Lemma double_neg_bottom :
  forall Gamma A, Heyting Gamma (dnegA A (Bottom @\/ A)) -> Heyting Gamma A.
Proof.
  intros Gamma A H.
  eapply Nd_impE; [apply H|].
  nd_intro. nd_destruct_or 0.
  - nd_exfalso; nd_assumption.
  - nd_assumption.
Defined.

Fixpoint QF P : Type :=
  match P with
  | Bottom | _ @= _ => True
  | (A @-> B) | A @\/ B | A @/\ B => QF A * QF B
  | Forall _ | Exists _ | DummyVar _ => False
  end.

Definition equiv (A B : Type) : Type := (A -> B) * (B -> A).

Lemma equiv_refl :
  forall A, equiv A A.
Proof.
  split; auto.
Defined.

Lemma nd_eq_sym : forall ax Gamma t1 t2, nd ax Gamma (t1 @= t2) -> nd ax Gamma (t2 @= t1).
Proof.
  intros ax Gamma t1 t2 H.
  apply Nd_eq_elim with (A := Var 0 @= t1.[ren (+1)]) in H; asimpl in *; auto.
  apply Nd_eq_refl.
Defined.

(* Instantiations of Peano axioms *)

Lemma Peano_0_ne_Sn_i : forall Gamma t,
    Heyting Gamma (@~ (Succ t @= Zero)).
Proof.
  intros Gamma t.
  evar (Delta : env).
  set (H := Nd_axiom PeanoAxioms _ ?Delta Peano_0_ne_Sn).
  apply Nd_forallE with (t := t) in H.
  asimpl in H.
  apply H.
Defined.

Lemma Peano_ne_0_Sn_i : forall Gamma t,
    Heyting Gamma (Exists ((@~ (t.[ren (+1)] @= Zero)) @-> (Succ (Var 0) @= t.[ren (+1)]))).
Proof.
  intros Gamma t.
  evar (Delta : env).
  set (H := Nd_axiom PeanoAxioms _ ?Delta Peano_ne_0_Sn).
  apply Nd_forallE with (t := t) in H.
  asimpl in H. apply H.
Defined.

Lemma Peano_S_inj_i : forall Gamma t1 t2,
    Heyting ((Succ t1 @= Succ t2) :: Gamma) (t1 @= t2).
Proof.
  intros Gamma t1 t2.
  evar (Delta : env).
  set (H := Nd_axiom PeanoAxioms _ ?Delta Peano_S_inj).
  apply Nd_forallE with (t := t1) in H.
  apply Nd_forallE with (t := t2) in H.
  asimpl in H.
  eapply Nd_impE; [apply H|apply Nd_assume].
Defined.

Lemma Peano_plus_0_i : forall Gamma t,
    Heyting Gamma ((Zero @+ t) @= t).
Proof.
  intros Gamma t.
  evar (Delta : env).
  set (H := Nd_axiom PeanoAxioms _ ?Delta Peano_plus_0).
  apply Nd_forallE with (t := t) in H.
  asimpl in H.
  apply H.
Defined.

Lemma Peano_plus_S_i : forall Gamma t1 t2,
    Heyting Gamma ((Succ t1 @+ t2) @= Succ (t1 @+ t2)).
Proof.
  intros Gamma t1 t2.
  evar (Delta : env).
  set (H := Nd_axiom PeanoAxioms _ ?Delta Peano_plus_S).
  apply Nd_forallE with (t := t1) in H.
  apply Nd_forallE with (t := t2) in H.
  asimpl in H.
  apply H.
Defined.

Lemma Peano_mult_0_i : forall Gamma t,
    Heyting Gamma ((Zero @* t) @= Zero).
Proof.
  intros Gamma t.
  evar (Delta : env).
  set (H := Nd_axiom PeanoAxioms _ ?Delta Peano_mult_0).
  apply Nd_forallE with (t := t) in H.
  asimpl in H.
  apply H.
Defined.

Lemma Peano_mult_S_i : forall Gamma t1 t2,
    Heyting Gamma ((Succ t1 @* t2) @= t1 @* t2 @+ t2).
Proof.
  intros Gamma t1 t2.
  evar (Delta : env).
  set (H := Nd_axiom PeanoAxioms _ ?Delta Peano_mult_S).
  apply Nd_forallE with (t := t1) in H.
  apply Nd_forallE with (t := t2) in H.
  asimpl in H.
  apply H.
Defined.

Ltac HA_rec :=
  eapply Nd_impE; [
    eapply Nd_impE; [
      apply Nd_axiom; apply Peano_rec
     |asimpl]
   |asimpl; apply Nd_forallI; asimpl; nd_intro].

(* Equality is decidable in Heyting arithmetic *)

Lemma eq_decidable_forall : forall Gamma,
    Heyting Gamma (Forall (Forall ((Var 1 @= Var 0) @\/ @~ (Var 1 @= Var 0)))).
Proof.
  intros Gamma.
  HA_rec.
  - HA_rec.
    + nd_left; apply Nd_eq_refl.
    + nd_weak 0; nd_right.
      nd_intro.
      eapply Nd_impE; [|apply nd_eq_sym; nd_assumption].
      apply Peano_0_ne_Sn_i.
  - HA_rec.
    + nd_right.
      apply Peano_0_ne_Sn_i.
    + nd_weak 0.
      eapply Nd_impE; [|apply Nd_forallE with (t := Var 0); apply Nd_assume].
      asimpl. nd_intro.
      nd_destruct_or 0.
      * nd_left.
        evar (Delta : env).
        set (H := (Nd_eq_elim PeanoAxioms ?Delta (Succ (Var 2) @= Succ (Var 0)) (Var 1) (Var 0))).
        asimpl in H. apply H; [nd_assumption|apply Nd_eq_refl].
      * nd_right; nd_intro; nd_apply 1.
        apply Peano_S_inj_i.
Defined.

Lemma eq_decidable : forall Gamma e1 e2,
    Heyting Gamma ((e1 @= e2) @\/ @~ (e1 @= e2)).
Proof.
  intros Gamma e1 e2.
  set (H := eq_decidable_forall Gamma).
  apply Nd_forallE with (t := e1) in H.
  apply Nd_forallE with (t := e2) in H.
  asimpl in H; auto.
Defined.

(* Quantifier-free formulas are decidable *)

Lemma qf_decidable : forall Gamma A, QF A -> Heyting Gamma (A @\/ (@~ A)).
Proof.
  intros Gamma A. induction A; intros H; simpl in H; try (exfalso; assumption).
  - nd_right; nd_intro; nd_assumption.
  - destruct H as [H1 H2].
    eapply Nd_orE; [apply IHA2; auto| |].
    + apply Nd_orIL; nd_intro; nd_assumption.
    + eapply Nd_orE; [nd_weak 0; apply IHA1; auto| |].
      * nd_right; nd_intro.
        nd_apply 2. nd_apply 0. nd_assumption.
      * nd_left; nd_intro; nd_exfalso.
        nd_apply 1; nd_assumption.
  - destruct H as [H1 H2].
    eapply Nd_orE; [apply IHA1; auto| |].
    + eapply Nd_orE; [nd_weak 0; apply IHA2; auto| |].
      * nd_left; nd_split; nd_assumption.
      * nd_right; nd_intro.
        nd_destruct_and 0; nd_apply 2; nd_assumption.
    + nd_right; nd_intro.
      nd_apply 1; nd_destruct_and 0; nd_assumption.
  - destruct H as [H1 H2].
    eapply Nd_orE; [apply IHA1; auto| |].
    + nd_left; nd_left; nd_assumption.
    + eapply Nd_orE; [apply Nd_weak; apply IHA2; auto| |].
      * nd_left; nd_right; nd_assumption.
      * nd_right; nd_intro; nd_destruct_or 0; [nd_apply 2 | nd_apply 1]; nd_assumption.
  - apply eq_decidable.
Defined.

(* The Friedman translation of a formula that can be proved in Peano arithmetic
   can be proved in Heyting arithmetic *)

Lemma friedman_Peano_Heyting :
  forall Gamma A, Peano Gamma A -> forall P, Heyting (map (friedman P) Gamma) (dnegA P (friedman P A)).
Proof.
  intros Gamma A dn; elim dn; clear Gamma A dn.
  - intros A Gamma H P. destruct H as [A HA | A].
    (* Axioms *)
    + apply double_neg_simpl.
      destruct HA; simpl.
      * apply Nd_forallI. apply double_neg_simpl.
        nd_intro; apply double_neg_imp.
        nd_destruct_or 0; [|nd_right; nd_assumption].
        nd_left; nd_revert 0.
        apply Peano_0_ne_Sn_i.
      * apply Nd_forallI. apply double_neg_simpl; apply double_neg_simpl.
        eapply Nd_impE; [|apply Nd_forallE with (t := Var 0); apply Nd_axiom; apply Peano_ne_0_Sn].
        asimpl. nd_intro.
        eapply Nd_existE; [nd_assumption|].
        rewrite subst_cons; nd_weak 1. asimpl.
        apply Nd_existI with (t := Var 0). asimpl.
        nd_intro. apply double_neg_weak. apply double_neg_or.
        apply Nd_impE with (A := dnegA P.|[ren (+2)] (Var 1 @= Zero @-> Bottom)).
        -- nd_intro. apply double_neg_imp. nd_apply 2. nd_assumption.
        -- nd_weak 1. nd_intro. eapply Nd_impE; [nd_apply 1|].
           ++ nd_weak 1. nd_intro.
              eapply Nd_impE; [|apply eq_decidable].
              nd_intro; nd_destruct_or 0.
              ** nd_apply 1; nd_left; nd_assumption.
              ** nd_apply 2; nd_assumption.
           ++ nd_intro. nd_destruct_or 0; [nd_exfalso|]; nd_assumption.
      * apply Nd_forallI. apply double_neg_simpl.
        apply Nd_forallI. apply double_neg_simpl.
        nd_intro. apply double_neg_imp.
        nd_destruct_or 0; [|nd_right; nd_assumption].
        nd_left. apply Peano_S_inj_i.
      * apply Nd_forallI. apply double_neg_simpl.
        nd_left. apply Peano_plus_0_i.
      * apply Nd_forallI. apply double_neg_simpl.
        apply Nd_forallI. apply double_neg_simpl.
        nd_left. apply Peano_plus_S_i.
      * apply Nd_forallI. apply double_neg_simpl.
        nd_left. apply Peano_mult_0_i.
      * apply Nd_forallI. apply double_neg_simpl.
        apply Nd_forallI. apply double_neg_simpl.
        nd_left. apply Peano_mult_S_i.
      * eapply Nd_impE; [|apply Nd_axiom; apply Peano_rec with
          (P := dnegA P.|[ren (+1)] (friedman P.|[ren (+1)] P0))].
        nd_intro. nd_intro. apply double_neg_simpl.
        nd_intro. apply double_neg_imp.
        eapply Nd_impE; [nd_apply 2|]; asimpl.
        -- rewrite friedman_subst. asimpl. nd_assumption.
        -- nd_weak 1. nd_weak 1. apply Nd_forallI.
           eapply Nd_impE; [|apply Nd_forallE with (t := Var 0); nd_assumption].
           rewrite subst_cons. nd_weak 0. asimpl.
           nd_intro. nd_intro. rewrite friedman_subst.
           eapply Nd_impE; [|nd_assumption 1]; nd_intro.
           apply double_neg_weak.
           asimpl. nd_apply 0. nd_assumption.
    + simpl. remember (friedman P A) as C.
      apply double_neg_simpl.
      nd_intro. apply double_neg_weak.
      nd_intro. apply double_neg_bottom.
      nd_apply 1. apply double_neg_simpl.
      nd_intro. apply double_neg_weak.
      nd_intro; nd_apply 2; nd_assumption.
  - intros A Gamma P; simpl; apply double_neg_simpl; nd_assumption.
  - intros A B Gamma H1 H2 P; simpl; nd_weak 0; apply H2.
  - intros A B Gamma H1 H2 P; simpl in *; apply double_neg_simpl.
    nd_intro. apply double_neg_weak; auto.
  - intros A B Gamma H1 H2 H3 H4 P. simpl in *.
    nd_intro. eapply Nd_impE; [nd_weak 0; apply H2|].
    nd_intro. nd_revert 1. nd_apply 0. nd_weak 0; apply H4.
  - intros A B Gamma H1 H2 H3 H4 P. simpl in *.
    apply double_neg_simpl. nd_split; auto.
  - intros A B Gamma H1 H2 P. simpl in *.
    eapply double_neg_weakH; [|apply H2].
    nd_destruct_and 0; nd_assumption.
  - intros A B Gamma H1 H2 P. simpl in *.
    eapply double_neg_weakH; [|apply H2].
    nd_destruct_and 0; nd_assumption.
  - intros A B Gamma H1 H2 P. simpl in *.
    apply double_neg_simpl; nd_left; auto.
  - intros A B Gamma H1 H2 P. simpl in *.
    apply double_neg_simpl; nd_right; auto.
  - intros A B C Gamma H1 H2 H3 H4 H5 H6 P. simpl in *.
    eapply double_neg_weakH; [|apply H2].
    nd_destruct_or 0; apply double_neg_weak; [apply H4 | apply H6].
  - intros A Gamma H1 H2 P; simpl in *.
    nd_intro. nd_weak 0.
    eapply Nd_impE; [apply H2|].
    nd_intro. nd_destruct_or 0; [nd_exfalso|]; nd_assumption.
  - intros A Gamma H1 H2 P; simpl in *.
    apply double_neg_simpl.
    specialize (H2 P.|[ren (+1)]).
    apply Nd_forallI. rewrite friedman_subst_map. auto.
  - intros A Gamma t H1 H2 P; simpl in *.
    specialize (H2 P).
    eapply double_neg_weakH; [|apply H2].
    replace (dnegA P (friedman P A.|[t/]))
      with (dnegA P.|[ren (+1)] (friedman P.|[ren (+1)] A)).|[t/]
      by (asimpl; rewrite friedman_subst; autosubst).
    apply Nd_forallE; nd_assumption.
  - intros A Gamma t H1 H2 P; simpl in *.
    apply double_neg_simpl.
    specialize (H2 P).
    nd_intro. eapply Nd_impE; [nd_weak 0; apply H2|].
    nd_intro. nd_apply 1.
    eapply Nd_existI. asimpl; rewrite friedman_subst; asimpl; nd_assumption.
  - intros A B Gamma H1 H2 H3 H4 P; simpl in *.
    specialize (H4 P.|[ren (+1)]); specialize (H2 P).
    apply double_neg_4 in H2.
    eapply double_neg_weakH; [|apply H2].
    eapply Nd_existE; [nd_assumption|].
    rewrite subst_cons.
    nd_weak 1.
    rewrite friedman_subst_map; simpl. rewrite friedman_subst. auto.
  - intros Gamma t P; simpl in *.
    apply double_neg_simpl. nd_left. apply Nd_eq_refl.
  - intros Gamma A t1 t2 H1 H2 H3 H4 P.
    nd_assert (dnegA P ((t1 @= t2) @\/ P)); [|apply H2].
    apply double_neg_weak. nd_destruct_or 0.
    + replace (dnegA P (friedman P A.|[t2/]))
        with (dnegA P.|[ren (+1)] (friedman P.|[ren (+1)] A)).|[t2/]
        by (asimpl; rewrite friedman_subst; autosubst).
      eapply Nd_eq_elim; [nd_assumption|].
      asimpl; rewrite friedman_subst; asimpl. nd_weak 0; apply H4.
    + nd_intro; nd_assumption.
Defined.

(* For a quantifier-free formula, friedman A P and P \/ A are equivalent
   in Heyting arithmetic *)

Lemma friedman_or_equiv :
  forall P Gamma A, QF P -> (Heyting Gamma ((friedman A P) @-> (P @\/ A)) *
                 Heyting Gamma ((P @\/ A) @-> (friedman A P))).
Proof.
  intros P. induction P.
  - intros Gamma A H. simpl in *.
    split; nd_intro; nd_assumption.
  - intros Gamma A H. simpl in *.
    split; nd_intro; nd_assumption.
  - intros Gamma A [HQF1 HQF2]. simpl in *.
    split.
    + nd_intro.
      eapply Nd_impE; [|apply (qf_decidable _ P1 HQF1)]; nd_intro.
      nd_destruct_or 0.
      * eapply Nd_impE; [|apply (qf_decidable _ P2 HQF2)]; nd_intro.
        nd_destruct_or 0.
        -- nd_left; nd_intro; nd_assumption.
        -- nd_right.
           apply Nd_impE with (A := friedman A P2 @-> A).
           ++ nd_apply 2. apply double_neg_simpl.
              eapply Nd_impE; [apply IHP1; auto|].
              nd_left. nd_assumption.
           ++ nd_intro.
              eapply Nd_orE; [|nd_exfalso; nd_apply 2; nd_assumption|nd_assumption].
              nd_revert 0; apply IHP2; auto.
      * nd_left; nd_intro; nd_exfalso.
        nd_apply 1; nd_assumption.
    + nd_intro; nd_intro; nd_intro.
      nd_destruct_or 2; [|nd_assumption].
      nd_assert (P1 @-> A).
      * nd_apply 3. nd_intro.
        eapply Nd_orE; [eapply Nd_impE; [apply IHP1; auto|nd_assumption]| |nd_assumption].
        nd_apply 2; nd_assumption.
      * nd_intro. nd_apply 2.
        eapply Nd_impE; [apply IHP2; auto|].
        nd_left; nd_apply 1; nd_assumption.
  - intros Gamma A [HQF1 HQF2]. simpl in *.
    split.
    + nd_intro.
      eapply Nd_impE; [|apply (qf_decidable _ P1 HQF1)]; nd_intro.
      nd_destruct_or 0.
      * eapply Nd_impE; [|apply (qf_decidable _ P2 HQF2)]; nd_intro.
        nd_destruct_or 0.
        -- nd_left. nd_split; nd_assumption.
        -- nd_right. nd_destruct_and 2.
           nd_apply 1; nd_intro.
           nd_assert (P2 @\/ A); [|nd_revert 0; apply IHP2; auto].
           nd_destruct_or 0; [nd_exfalso; nd_apply 4|]; nd_assumption.
      * nd_right. nd_destruct_and 1.
        nd_apply 0; nd_intro.
        nd_assert (P1 @\/ A); [|nd_revert 0; apply IHP1; auto].
        nd_destruct_or 0; [nd_exfalso; nd_apply 4|]; nd_assumption.
    + nd_intro.
      nd_destruct_or 0.
      * nd_destruct_and 0. nd_split; apply double_neg_simpl.
        -- eapply Nd_impE; [apply IHP1; auto|]. nd_left; nd_assumption.
        -- eapply Nd_impE; [apply IHP2; auto|]. nd_left; nd_assumption.
      * nd_split; nd_intro; nd_assumption.
  - intros Gamma A [HQF1 HQF2]. simpl in *.
    split.
    + nd_intro.
      eapply Nd_impE; [|apply (qf_decidable _ P1 HQF1)]; nd_intro.
      nd_destruct_or 0.
      * nd_left; nd_left; nd_assumption.
      * eapply Nd_impE; [|apply (qf_decidable _ P2 HQF2)]; nd_intro.
        nd_destruct_or 0.
        -- nd_left; nd_right; nd_assumption.
        -- nd_right. nd_destruct_or 2; nd_apply 0; nd_intro.
           ++ nd_assert (P1 @\/ A); [|nd_revert 0; apply IHP1; auto].
              nd_destruct_or 0; [nd_exfalso; nd_apply 4|]; nd_assumption.
           ++ nd_assert (P2 @\/ A); [|nd_revert 0; apply IHP2; auto].
              nd_destruct_or 0; [nd_exfalso; nd_apply 3|]; nd_assumption.
    + nd_intro. nd_destruct_or 0.
      * nd_destruct_or 0; [nd_left | nd_right]; apply double_neg_simpl.
        -- eapply Nd_impE; [apply IHP1; auto|]. nd_left; nd_assumption.
        -- eapply Nd_impE; [apply IHP2; auto|]. nd_left; nd_assumption.
      * nd_left; nd_intro; nd_assumption.
  - intros Gamma A H. simpl in *.
    split; nd_intro; nd_assumption.
  - intros; simpl in *; exfalso; auto.
  - intros; simpl in *; exfalso; auto.
Defined.

Lemma friedman_or_equiv_l :
  forall P Gamma A, QF P -> Heyting Gamma ((friedman A P) @-> (P @\/ A)).
Proof.
  intros. apply friedman_or_equiv; auto.
Defined.

Lemma friedman_or_equiv_r :
  forall P Gamma A, QF P -> Heyting Gamma ((P @\/ A) @-> (friedman A P)).
Proof.
  intros. apply friedman_or_equiv; auto.
Defined.

Lemma tr_friedman_equiv :
  forall P A sigma, QF P ->
    equiv (tr_formula sigma (friedman A P)) (tr_formula sigma (P @\/ A)).
Proof.
  intros P A sigma H.
  destruct (friedman_or_equiv P nil A) as [E1 E2]; auto.
  split.
  - apply reflect with (sigma := sigma) in E1; simpl in *; auto.
    unfold tr_env; simpl; auto.
  - apply reflect with (sigma := sigma) in E2; simpl in *; auto.
    unfold tr_env; simpl; auto.
Defined.

(* Definition of Sigma_0 and Pi_0 formulas *)

Inductive Sigma_0 : nat -> formula -> Type :=
| QF_Sigma : forall n A, QF A -> Sigma_0 n A
| Exists_Sigma : forall n A, Sigma_0 (S n) A -> Sigma_0 (S n) (Exists A)
| Pi_Sigma : forall n A, Pi_0 n A -> Sigma_0 (S n) A

with Pi_0 : nat -> formula -> Type :=
| QF_Pi : forall n A, QF A -> Pi_0 n A
| Sigma_Pi : forall n A, Sigma_0 n A -> Pi_0 (S n) A
| Forall_Pi : forall n A, Pi_0 (S n) A -> Pi_0 (S n) (Forall A).

Fixpoint leading_exists A :=
  match A with
  | Exists A => S (leading_exists A)
  | _ => 0
  end.

Fixpoint after_exists A :=
  match A with
  | Exists A => after_exists A
  | _ => A
  end.

Fixpoint add_n_exists n A :=
  match n with
  | 0 => A
  | S n => Exists (add_n_exists n A)
  end.

Theorem add_n_exists_inverse :
  forall A, add_n_exists (leading_exists A) (after_exists A) = A.
Proof.
  intros A. induction A; simpl; congruence.
Defined.

Lemma double_neg_exists :
  forall Gamma P A, Heyting (A :: Gamma..|[ren (+1)]) P.|[ren (+1)] -> Heyting ((dnegA P (Exists A)) :: Gamma) P.
Proof.
  intros Gamma P A H.
  nd_apply 0. nd_intro. eapply Nd_existE; [nd_assumption|].
  rewrite subst_cons; rewrite subst_cons. nd_weak 1; nd_weak 1. apply H.
Defined.

Lemma exists_imply :
  forall n Gamma A, Heyting Gamma (A @-> (add_n_exists n A).|[ren (+n)]).
Proof.
  intros n. induction n as [|n IHn].
  - intros Gamma A. asimpl. nd_intro; nd_assumption.
  - intros Gamma A. simpl; nd_intro.
    apply Nd_existI with (t := Var n). asimpl.
    nd_revert 0. apply IHn.
Defined.

Lemma friedman_n_exists :
  forall n Gamma P A, Heyting ((friedman P.|[ren (+n)] A) :: Gamma..|[ren (+n)]) P.|[ren (+n)] -> Heyting (friedman P (add_n_exists n A) :: Gamma) P.
Proof.
  intros n. induction n as [|n IHn].
  - intros Gamma P A H. asimpl in *. apply H.
  - intros Gamma P A H. asimpl in *.
    apply double_neg_exists. apply IHn. asimpl. apply H.
Defined.

Lemma n_exists_friedman_imply :
  forall n Gamma A, QF A -> Heyting Gamma (dnegA (add_n_exists n A) (friedman (add_n_exists n A) (add_n_exists n A))) -> Heyting Gamma (add_n_exists n A).
Proof.
  intros n Gamma A H1 H2.
  eapply Nd_impE; [apply H2|].
  nd_intro. apply friedman_n_exists.
  eapply Nd_impE; [|apply friedman_or_equiv_l; apply H1].
  nd_intro. eapply Nd_impE; [|nd_apply 0; nd_assumption].
  nd_intro. nd_destruct_or 0; [|nd_assumption].
  nd_revert 0; nd_clear 2. apply exists_imply.
Defined.

Lemma after_exists_QF :
  forall A, QF A -> QF (after_exists A).
Proof.
  intros A H; destruct A; simpl in *; auto.
  exfalso; auto.
Defined.

Lemma Sigma_0_1_after_exists_QF :
  forall A, Sigma_0 1 A -> QF (after_exists A).
Proof.
  intros A H. remember 1 as n. induction H.
  - apply after_exists_QF; auto.
  - simpl; auto.
  - injection Heqn; intro; subst. inversion p. apply after_exists_QF; auto.
Defined.

Lemma Sigma_0_1_equiv :
  forall Gamma A, Sigma_0 1 A -> Heyting Gamma (dnegA A (friedman A A)) -> Heyting Gamma A.
Proof.
  intros Gamma A H1 H2.
  rewrite <- add_n_exists_inverse.
  apply n_exists_friedman_imply.
  - apply Sigma_0_1_after_exists_QF; auto.
  - rewrite add_n_exists_inverse; apply H2.
Defined.

(* Peano arithmetic is Sigma_0^1 conservative over Heyting arithmetic *)

Lemma Peano_Sigma_0_1_conservative :
  forall A, Sigma_0 1 A -> Peano nil A -> Heyting nil A.
Proof.
  intros A H1 H2.
  apply Sigma_0_1_equiv; auto.
  apply friedman_Peano_Heyting with (Gamma := nil); auto.
Defined.

Fixpoint leading_foralls A :=
  match A with
  | Forall A => S (leading_foralls A)
  | _ => 0
  end.

Fixpoint after_foralls A :=
  match A with
  | Forall A => after_foralls A
  | _ => A
  end.

Fixpoint add_n_foralls n A :=
  match n with
  | 0 => A
  | S n => Forall (add_n_foralls n A)
  end.

Theorem add_n_foralls_inverse :
  forall A, add_n_foralls (leading_foralls A) (after_foralls A) = A.
Proof.
  intros A. induction A; simpl; congruence.
Defined.

Lemma after_foralls_QF :
  forall A, QF A -> QF (after_foralls A).
Proof.
  intros A H; destruct A; simpl in *; auto.
  exfalso; auto.
Defined.

Lemma Sigma_0_n_Pi_0_n_after_foralls :
  forall n A, (Pi_0 n A -> Pi_0 n (after_foralls A)) * (Sigma_0 n A -> Sigma_0 n (after_foralls A)).
Proof.
  intros n. induction n as [|n IHn].
  - intros A. split; intros H; inversion H; constructor; apply after_foralls_QF; auto.
  - intros A. remember (S n) as m. split.
    + intros H. induction H.
      * apply QF_Pi; apply after_foralls_QF; auto.
      * injection Heqm; intros; subst. apply Sigma_Pi; apply IHn; auto.
      * simpl; auto.
    + intros H. induction H.
      * apply QF_Sigma; apply after_foralls_QF; auto.
      * simpl; apply Exists_Sigma; auto.
      * injection Heqm; intros; subst. apply Pi_Sigma; apply IHn; auto.
Defined.

Lemma Pi_0_Sn_after_foralls_Sigma_0_n :
  forall n A, Pi_0 (S n) A -> Sigma_0 n (after_foralls A).
Proof.
  intros n A H. remember (S n) as m. induction H.
  - apply QF_Sigma; apply after_foralls_QF; auto.
  - apply Sigma_0_n_Pi_0_n_after_foralls; congruence.
  - simpl; auto.
Defined.

Lemma add_foralls :
  forall ax n A Gamma, nd ax Gamma..|[ren (+n)] A -> nd ax Gamma (add_n_foralls n A).
Proof.
  intros ax n. induction n as [|n IHn].
  - intros. simpl. asimpl in *. auto.
  - intros A Gamma H. simpl in *. apply Nd_forallI. apply IHn.
    asimpl; auto.
Defined.

Lemma fold_env :
  forall ax Gamma A, nd ax Gamma A -> nd ax nil (fold_left (fun B C => C @-> B) Gamma A).
Proof.
  intros ax Gamma. induction Gamma as [|B Gamma IH].
  - simpl. auto.
  - intros A H. simpl. apply IH.
    nd_intro; auto.
Defined.

Lemma unfold_env :
  forall ax Gamma A, nd ax nil (fold_left (fun B C => C @-> B) Gamma A) -> nd ax Gamma A.
Proof.
  intros ax Gamma. induction Gamma as [|B Gamma IH].
  - simpl. auto.
  - intros A H. simpl. nd_revert 0. apply IH. simpl in H. auto.
Defined.

Definition closed_formula A := forall sigma, A.|[sigma] = A.

Lemma add_n_foralls_r :
  forall A n, add_n_foralls n (Forall A) = add_n_foralls (S n) A.
Proof.
  intros A n; induction n; simpl in *; congruence.
Defined.

Lemma add_n_foralls_closed :
  forall n A, closed_formula A -> closed_formula (add_n_foralls n A).
Proof.
  intros n. induction n as [|n IHn].
  - intros A H; simpl in *; auto.
  - intros A H sigma. simpl in *.
    rewrite IHn; auto.
Defined.

Lemma add_n_foralls_compose :
  forall n m A, add_n_foralls n (add_n_foralls m A) = add_n_foralls (n + m) A.
Proof.
  intros n m A. induction n; simpl in *; congruence.
Defined.

Lemma add_more_foralls_closed :
  forall n m A, m >= n -> closed_formula (add_n_foralls n A) -> closed_formula (add_n_foralls m A).
Proof.
  intros n m A H1 H2.
  replace m with ((m - n) + n) by (auto using Nat.sub_add).
  rewrite <- add_n_foralls_compose. apply add_n_foralls_closed; auto.
Defined.

Lemma iterate_sum :
  forall (X : Type) (f : X -> X) x n1 n2, iterate f n1 (iterate f n2 x) = iterate f (n1 + n2) x.
Proof.
  intros; induction n1 as [|n1 IH].
  - asimpl; auto.
  - simpl. unfold iterate in *. congruence.
Defined.
Hint Rewrite iterate_sum : autosubst.

Lemma upn_max :
  forall (P1 P2 : ((var -> expr) -> Prop)),
    {n | forall sigma, P1 (upn n sigma)} -> {n | forall sigma, P2 (upn n sigma)} ->
           {n | forall sigma, P1 (upn n sigma) /\ P2 (upn n sigma)}.
Proof.
  intros P1 P2 [n1 H1] [n2 H2].
  set (m := max n1 n2). exists m. intros sigma. asimpl.
  specialize (H1 (upn (m - n1) sigma)). specialize (H2 (upn (m - n2) sigma)).
  asimpl in *.
  rewrite Nat.add_comm in H1; rewrite Nat.sub_add in H1 by apply Nat.le_max_l.
  rewrite Nat.add_comm in H2; rewrite Nat.sub_add in H2 by apply Nat.le_max_r.
  auto.
Defined.

Lemma upn_succ :
  forall n sigma, upn (S n) sigma n = Var n.
Proof.
  intros n. induction n as [|n IH].
  - intros sigma. asimpl. auto.
  - intros sigma. asimpl. rewrite IH. auto.
Defined.
Hint Rewrite upn_succ : autosubst.

Lemma can_close_expr :
  forall (t : expr), {n | forall sigma, t.[upn n sigma] = t}.
Proof.
  intros t. induction t.
  - exists (S v). intros sigma. asimpl. rewrite upn_succ; auto.
  - exists 0. intros sigma. simpl. auto.
  - destruct IHt as [n H]. exists n. intros sigma. specialize (H sigma). simpl. congruence.
  - destruct (upn_max (fun sigma => t1.[sigma] = t1) (fun sigma => t2.[sigma] = t2) IHt1 IHt2)
      as [m H].
    exists m. intros sigma. specialize (H sigma). asimpl. destruct H; f_equal; auto.
  - destruct (upn_max (fun sigma => t1.[sigma] = t1) (fun sigma => t2.[sigma] = t2) IHt1 IHt2)
      as [m H].
    exists m. intros sigma. specialize (H sigma). asimpl. destruct H; f_equal; auto.
Defined.

(* Every formula can be closed *)

Lemma can_close_formula :
  forall A, {n | forall sigma, A.|[upn n sigma] = A}.
Proof.
  intros A. induction A; try (exists 0; intro sigma; simpl in *; autosubst).
  - destruct (upn_max (fun sigma => A1.|[sigma] = A1) (fun sigma => A2.|[sigma] = A2) IHA1 IHA2)
      as [m H].
    exists m. asimpl. intros sigma; specialize (H sigma). destruct H.
    f_equal; auto.
  - destruct (upn_max (fun sigma => A1.|[sigma] = A1) (fun sigma => A2.|[sigma] = A2) IHA1 IHA2)
      as [m H].
    exists m. asimpl. intros sigma; specialize (H sigma). destruct H.
    f_equal; auto.
  - destruct (upn_max (fun sigma => A1.|[sigma] = A1) (fun sigma => A2.|[sigma] = A2) IHA1 IHA2)
      as [m H].
    exists m. asimpl. intros sigma; specialize (H sigma). destruct H.
    f_equal; auto.
  - asimpl.
    destruct (upn_max (fun sigma => e.[sigma] = e) (fun sigma => e0.[sigma] = e0) (can_close_expr e) (can_close_expr e0))
      as [m H].
    exists m. intros sigma; specialize (H sigma). destruct H.
    f_equal; auto.
  - destruct IHA as [n IHA].
    exists n. intros sigma. asimpl. specialize (IHA (up sigma)).
    asimpl in *. congruence.
  - destruct IHA as [n IHA].
    exists n. intros sigma. asimpl. specialize (IHA (up sigma)).
    asimpl in *. congruence.
Defined.

Lemma n_foralls_closed :
  forall n A, (forall sigma, A.|[upn n sigma] = A) -> closed_formula (add_n_foralls n A).
Proof.
  intros n. induction n as [|n IHn].
  - intros. simpl. auto.
  - intros. rewrite <- add_n_foralls_r.
    apply IHn. intros sigma. asimpl. rewrite H; auto.
Defined.

Lemma elim_foralls_closed :
  forall ax n A, closed_formula (add_n_foralls n A) -> nd ax nil (add_n_foralls n A) -> forall sigma, nd ax nil A.|[sigma].
Proof.
  intros ax n. induction n as [|n IHn].
  - intros A H1 H2 sigma. simpl in *. rewrite H1. auto.
  - intros A H1 H2 sigma. simpl in *.
    replace A.|[sigma] with A.|[Var 0 .: ((ren (+1)) >> sigma >> ren (+1))].|[sigma 0/] by autosubst.
    apply Nd_forallE.
    replace (Forall A.|[Var 0 .: ren (+1) >> sigma >> ren (+1)])
      with (Forall A).|[ren (+1) >> sigma] by autosubst.
    apply IHn; rewrite add_n_foralls_r; auto.
Defined.

Lemma fold_env_subst :
  forall Gamma A sigma,
    (fold_left (fun B C : formula => C @-> B) Gamma A).|[sigma] =
    fold_left (fun B C : formula => C @-> B) Gamma..|[sigma] A.|[sigma].
Proof.
  intros Gamma. induction Gamma as [|B Gamma IH].
  - intros. simpl. auto.
  - intros. rewrite subst_cons. simpl. rewrite IH. auto.
Defined.

Lemma prove_subst :
  forall ax Gamma A sigma, nd ax Gamma A -> nd ax Gamma..|[sigma] A.|[sigma].
Proof.
  intros ax Gamma A sigma H.
  apply unfold_env.
  replace (fold_left (fun B C : formula => C @-> B) Gamma..|[sigma] A.|[sigma])
    with (fold_left (fun B C : formula => C @-> B) Gamma A).|[sigma] by apply fold_env_subst.
  set (B := fold_left (fun B C : formula => C @-> B) Gamma A).
  destruct (can_close_formula B) as [n H1].
  eapply elim_foralls_closed.
  - apply n_foralls_closed. apply H1.
  - apply add_foralls. simpl. apply fold_env; auto.
Defined.

(*

(* Another way to prove the above lemma -- simpler, but requires to prove the
   compatibility with substitution of all axioms. *)

Lemma prove_subst2 :
  forall ax Gamma A, nd ax Gamma A -> forall sigma, nd ax Gamma..|[sigma] A.|[sigma].
Proof.
  intros ax Gamma A H.
  induction H; intros sigma; simpl; asimpl in *; try (constructor; auto; fail).
  - admit.
  - apply Nd_weak. specialize (IHnd sigma). auto.
  - specialize (IHnd sigma). apply Nd_impI. auto.
  - specialize (IHnd1 sigma); specialize (IHnd2 sigma). eapply Nd_impE; simpl; eauto.
  - specialize (IHnd sigma); eapply Nd_andEL; eauto.
  - specialize (IHnd sigma); eapply Nd_andER; eauto.
  - specialize (IHnd1 sigma); specialize (IHnd2 sigma); specialize (IHnd3 sigma); eapply Nd_orE; eauto.
  - eapply Nd_forallI. asimpl in *. specialize (IHnd (up sigma)).
    asimpl in *. auto.
  - replace A.|[t.[sigma] .: sigma] with A.|[up sigma].|[t.[sigma]/] by autosubst.
    apply Nd_forallE. auto.
  - eapply Nd_existI. asimpl. specialize (IHnd sigma). asimpl in *. eauto.
  - eapply Nd_existE. apply IHnd1. specialize (IHnd2 (up sigma)). asimpl in *. auto.
  - specialize (IHnd2 sigma). specialize (IHnd1 sigma).
    replace A.|[t2.[sigma] .: sigma] with A.|[up sigma].|[t2.[sigma]/] by autosubst.
    eapply Nd_eq_elim. apply IHnd1. asimpl in *. auto.

 *)

Lemma elim_foralls :
  forall ax n Gamma A, nd ax Gamma (add_n_foralls n A) -> forall sigma, nd ax Gamma..|[ren (+n) >> sigma] A.|[sigma].
Proof.
  intros ax n. induction n as [|n IHn].
  - intros Gamma A H sigma. simpl in *. asimpl. apply prove_subst. auto.
  - intros Gamma A H sigma. rewrite <- add_n_foralls_r in H.
    specialize (IHn Gamma (Forall A) H (ren (+1) >> sigma)).
    apply Nd_forallE with (t := sigma 0) in IHn.
    asimpl in *. auto.
Defined.

(* Peano arithmetic is Pi_0^2 conservative over Heyting arithmetic *)

Lemma Peano_Pi_0_2_conservative :
  forall A, Pi_0 2 A -> Peano nil A -> Heyting nil A.
Proof.
  intros A H1 H2.
  rewrite <- add_n_foralls_inverse in H2.
  apply elim_foralls with (sigma := ids) in H2. asimpl in H2.
  apply Peano_Sigma_0_1_conservative in H2; [|apply Pi_0_Sn_after_foralls_Sigma_0_n; auto].
  rewrite <- add_n_foralls_inverse.
  apply add_foralls. asimpl. auto.
Defined.


(*
  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 implemented with Function (Safe version) (Fixed Shape)
  author    : ZhengPu Shi
  date      : 2021.12

  remark    :
  1. This is safe version of NatFun, which corrected the shape problem

  2. About determinant and inversion matrix:
  (1). There are three methods to compute the determinant,
     ref: https://zhuanlan.zhihu.com/p/435900775
     a. expand by row or column, then compute it with the algebraic remainder (代数
        余子式) 。Each expansion corresponds to a drop of one order.
        Note: expanding by rows/columns is a special case of Laplace's expansion
        theorem.
     b. using primitive transformations (初等变换).
     c. with the help of inverse ordinal (逆序数) and permutation, i.e., by the
        definition.
  (2). Test the performance of inversion algorithm here which is an OCaml program
     extracted from Coq.

     Test result:
          n=8, 1.1s;  n=9, 12s;  n=10, 120s

     Main issue:
     a. observed that, the CPU usage is too high, but memory usage is low.
     b. maybe caused by the index of nat type, and I think that int type should
        better. So, maybe we need to write an implementation in OCaml directly.
     c. another reason is that the recursion of det function is too much.

     So, we should write several version in OCaml, to check which one resulting the
     bad performane.
     a. version1, still use NatFun, but with index of int type.
     b. version2, use array
     c. version3, use matrix (bigarray)

     New test result:
     a. version1,
        n=8, 0.25s;  n=9, 2.4s;  n=10, 32s
        I think it is still slow, maybe causing by functional style
     b. version2,
        n=8, 1s;  n=9,7s; n=10, not tested yet
        This version is slower than original one, although we have used
        array structure, why? maybe too much foo loop? I'm not sure.
 *)

Require Export MatrixTheory.
Require Sequence SafeNatFun.Matrix.
Require PermutationExt.

(* ######################################################################### *)
(** * Basic matrix theory implemented with SafeNatFun *)

Module BasicMatrixTheorySF (E : ElementType) <: BasicMatrixTheory E.

  (** Basic library *)
  Export BasicConfig TupleExt SetoidListListExt HierarchySetoid.

  Export Sequence SafeNatFun.Matrix.

  (* ==================================== *)
  (** ** Matrix element type *)
  Export E.

  Global Infix "==" := Aeq : A_scope.
  Global Infix "==" := (eqlistA (eqlistA Aeq)) : dlist_scope.

  Open Scope nat_scope.
  Open Scope A_scope.
  Open Scope mat_scope.

  (* ==================================== *)
  (** ** Matrix type and basic operations *)

  (** We define a _matrix_ as record which contains only one field has type of
      nat -> nat -> A.
      Meanwhile, thare are two parameters respresenting rows and columns of
      the matrix as parts of type of mat. *)
  Definition mat (r c : nat) := @mat A r c.

  (** Square matrix *)
  Definition smat (n : nat) := mat n n.

  (* (** matrix equality *) *)
  Definition meq {r c : nat} (m1 m2 : mat r c) : Prop := @meq A Aeq r c m1 m2.
  Global Infix "==" := meq : mat_scope.

  Lemma meq_equiv : forall {r c}, Equivalence (meq (r:=r) (c:=c)).
  Proof.
    intros. apply meq_equiv.
  Qed.

  Global Existing Instance meq_equiv.

  (** Get n-th element of a matrix *)
  Definition mnth {r c} (m : mat r c) (ri ci : nat) := mnth (A0:=A0) m ri ci.
  Global Notation "m ! r ! c" := (mnth m r c) : mat_scope.

  (** meq and mnth should satisfy this constraint *)
  Lemma meq_iff_mnth : forall {r c : nat} (m1 m2 : mat r c),
      m1 == m2 <-> (forall ri ci, ri < r -> ci < c -> (m1 ! ri ! ci == m2 ! ri ! ci)%A).
  Proof.
    intros. apply meq_iff_mnth.
  Qed.

  (* ==================================== *)
  (** ** Convert between list list and matrix *)

  (** *** list list to mat *)

  Definition l2m {r c} (dl : list (list A)) : mat r c := @l2m A A0 r c dl.

  (** l2m is a proper morphism *)
  Lemma l2m_aeq_mor : forall r c, Proper (eqlistA (eqlistA Aeq) ==> meq) (@l2m r c).
  Proof.
  Admitted.

  Global Existing Instance l2m_aeq_mor.

  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)%dlist -> ~(@l2m r c d1 == l2m d2).
  Proof.
    intros. apply l2m_inj; auto.
  Qed.

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

  (** *** mat to list list *)
  Definition m2l {r c} (m : mat r c) : list (list A) := @m2l A r c m.

  (** m2l is a proper morphism *)
  Lemma m2l_aeq_mor : forall r c, Proper (meq ==> eqlistA (eqlistA Aeq)) (@m2l r c).
  Proof.
  Admitted.

  Global Existing Instance m2l_aeq_mor.

  Lemma m2l_length : forall {r c} (m : mat r c), length (m2l m) = r.
  Proof.
    intros. apply m2l_length.
  Qed.

  Global Hint Resolve m2l_length : mat.

  Lemma m2l_width : forall {r c} (m : mat r c), width (m2l m) c.
  Proof.
    intros. apply m2l_width.
  Qed.

  Global Hint Resolve m2l_width : mat.

  Lemma m2l_l2m_id : forall {r c} (dl : list (list A)) (H1 : length dl = r)
                            (H2 : width dl c), (@m2l r c (l2m dl) == dl)%dlist.
  Proof.
    intros. apply m2l_l2m_id; auto.
  Qed.

  Lemma l2m_m2l_id : forall {r c} (m : mat r c), l2m (m2l m) == m.
  Proof.
    intros. apply l2m_m2l_id; auto.
  Qed.

  Lemma m2l_inj : forall {r c} (m1 m2 : mat r c),
      ~(m1 == m2) -> ~(m2l m1 == m2l m2)%dlist.
  Proof.
    intros. apply (m2l_inj (A0:=A0)). easy.
  Qed.

  Lemma m2l_surj : forall {r c} (d : list (list A)),
      length d = r -> width d c ->
      (exists m, @m2l r c m == d)%dlist.
  Proof.
    intros. apply (m2l_surj (A0:=A0)); auto.
  Qed.

  (* ==================================== *)
  (** ** Specific matrix *)

  Definition mk_mat_1_1 (a00 : A) : mat 1 1 := mk_mat_1_1 (A0:=A0) a00.

  Definition mk_mat_3_1 (a00 a10 a20 : A) : mat 3 1 := mk_mat_3_1 (A0:=A0) a00 a10 a20.

  Definition mk_mat_4_1 (a00 a10 a20 a30 : A) : mat 4 1 :=
    mk_mat_4_1 (A0:=A0) a00 a10 a20 a30.

  Definition mk_mat_2_2 (a00 a01 a10 a11 : A) : mat 2 2
    := mk_mat_2_2 (A0:=A0) a00 a01 a10 a11.

  Definition mk_mat_3_3 (a00 a01 a02 a10 a11 a12 a20 a21 a22 : A) : mat 3 3
    := mk_mat_3_3 (A0:=A0) a00 a01 a02 a10 a11 a12 a20 a21 a22.

  Definition mk_mat_4_4 (a00 a01 a02 a03 a10 a11 a12 a13
                           a20 a21 a22 a23 a30 a31 a32 a33 : A) : mat 4 4
    := mk_mat_4_4 (A0:=A0) a00 a01 a02 a03 a10 a11 a12 a13
         a20 a21 a22 a23 a30 a31 a32 a33.

  (* ==================================== *)
  (** ** Convert between tuples and matrix *)

  (** tuple_3x3 -> mat_3x3 *)
  Definition t2m_3x3 (t : @T_3x3 A) : mat 3 3 := t2m_3x3 (A0:=A0) t.

  (** mat_3x3 -> tuple_3x3 *)
  Definition m2t_3x3 (m : mat 3 3) : @T_3x3 A := m2t_3x3 m.

  (** m[0,0] : mat_1x1 -> A *)
  Definition scalar_of_mat (m : mat 1 1) := m ! 0 ! 0.

  (* ==================================== *)
  (** ** Matrix transposition *)

  Definition mtrans {r c} (m : mat r c): mat c r :=
    @mtrans A r c m.

  Global Notation "m \T" := (mtrans m) : mat_scope.

  Lemma mtrans_trans : forall {r c} (m : mat r c), mtrans (mtrans m) == m.
  Proof.
    intros. apply mtrans_trans.
  Qed.

  (* ==================================== *)
  (** ** Mapping of matrix *)

  (** Mapping of a matrix *)
  Definition mmap {r c} (f : A -> A) (m : mat r c) : mat r c := @mmap A r c f m.

  Definition mmap2 {r c} (f: A -> A -> A) (m1 m2: mat r c) : mat r c :=
    @mmap2 A r c f m1 m2.

  Lemma mmap2_comm : forall {r c} (f : A -> A -> A)
                            (f_comm : forall a b : A, (f a b == f b a)%A)
                            (m1 m2 : mat r c),
      mmap2 f m1 m2 == mmap2 f m2 m1.
  Proof.
    (* lma. (* this tactic is enough too. *) *)
    intros. apply mmap2_comm. auto.
  Qed.

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

  (** Auto unfold these definitions *)
  Global Hint Unfold meq mmap mmap2 : mat.

  (** linear matrix arithmetic tactic for equation: split goal to every element *)
  Global Ltac lma :=
    autounfold with mat;
    Matrix.lma.

End BasicMatrixTheorySF.

(* ######################################################################### *)
(** * Decidable matrix theory implemented with SafeNatFun *)

Module DecidableMatrixTheorySF (E : DecidableElementType) <: DecidableMatrixTheory E.

  (* Export E. *)
  Include BasicMatrixTheorySF E.

  (** linear matrix arithmetic tactic for equation: split goal to every element *)

  (** meq is decidable *)
  Lemma meq_dec : forall {r c}, Decidable (meq (r:=r)(c:=c)).
  Proof.
    intros. apply @meq_dec. apply Dec_Aeq.
  Qed.

End DecidableMatrixTheorySF.

(* ######################################################################### *)
(** * Ring matrix theory implemented with SafeNatFun *)

Module RingMatrixTheorySF (E : RingElementType) <: RingMatrixTheory E.

  (* Export E. *)
  Include BasicMatrixTheorySF E.

  Add Ring ring_thy_inst : Ring_thy.

  (** Zero matrix *)
  Definition mat0 r c : mat r c := @mat0 A A0 r c.

  (** Unit matrix *)
  Definition mat1 n : mat n n := @mat1 A A0 A1 n.

  (** *** Addition of matrix *)

  Definition madd {r c} (m1 m2 : mat r c) : mat r c := madd (Aadd:=Aadd) m1 m2.
  Infix "+" := madd : mat_scope.

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

  (** (m1 + m2) + m3 = m1 + (m2 + m3) *)
  Lemma madd_assoc : forall {r c} (m1 m2 m3 : mat r c), (m1 + m2) + m3 == m1 + (m2 + m3).
  Proof.
    intros. apply madd_assoc.
  Qed.

  (** 0 + m = m *)
  Lemma madd_0_l : forall {r c} (m : mat r c), (mat0 r c) + m == m.
  Proof.
    intros. apply madd_0_l.
  Qed.

  (** m + 0 = m *)
  Lemma madd_0_r : forall {r c} (m : mat r c), m + (mat0 r c) == m.
  Proof.
    intros. apply madd_0_r.
  Qed.

  (** *** Opposite of matrix *)

  Definition mopp {r c} (m : mat r c) : mat r c := @mopp A Aopp r c m.
  Global Notation "- m" := (mopp m) : mat_scope.

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

  (** m + (-m) = 0 *)
  Lemma madd_opp : forall {r c} (m : mat r c), m + (-m) == mat0 r c.
  Proof.
    intros. apply madd_opp.
  Qed.

  (** *** Subtraction of matrix *)

  Definition msub {r c} (m1 m2 : mat r c) : mat r c := @msub A Aadd Aopp r c m1 m2.
  Infix "-" := msub : mat_scope.

  (** m1 - m2 = - (m2 - m1) *)
  Lemma msub_comm : forall {r c} (m1 m2 : mat r c), m1 - m2 == - (m2 - m1).
  Proof.
    intros. apply msub_comm.
  Qed.
  (** (m1 - m2) - m3 = m1 - (m2 + m3) *)
  Lemma msub_assoc : forall {r c} (m1 m2 m3 : mat r c), (m1 - m2) - m3 == m1 - (m2 + m3).
  Proof.
    intros. apply msub_assoc.
  Qed.

  (** 0 - m = - m *)
  Lemma msub_0_l : forall {r c} (m : mat r c), (mat0 r c) - m == - m.
  Proof.
    intros. apply msub_0_l.
  Qed.

  (** m - 0 = m *)
  Lemma msub_0_r : forall {r c} (m : mat r c), m - (mat0 r c) == m.
  Proof.
    intros. apply msub_0_r.
  Qed.

  (** m - m = 0 *)
  Lemma msub_self : forall {r c} (m : mat r c), m - m == (mat0 r c).
  Proof.
    intros. apply msub_self.
  Qed.

  (** *** Scalar multiplication of matrix *)

  (** Left scalar multiplication of matrix *)
  Definition mcmul {r c} (a : A) (m : mat r c) : mat r c :=
    @mcmul A Amul r c a m.
  Notation "a c* m" := (mcmul a m) : mat_scope.

  (** Right scalar multiplication of matrix *)
  Definition mmulc {r c} (m : mat r c) (a : A) : mat r c :=
    @mmulc A Amul r c m a.
  Notation "m *c a" := (mmulc m a) : mat_scope.

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

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

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

  (** a * (m1 + m2) = (a * m1) + (a * m2) *)
  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.
    intros. apply mcmul_add_distr_l.
  Qed.

  (** (a + b) * m = (a * m) + (b * m) *)
  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.
    intros. apply mcmul_add_distr_r.
  Qed.

  (** 0 * m = 0 *)
  Lemma mcmul_0_l : forall {r c} (m : mat r c), A0 c* m == mat0 r c.
  Proof.
    intros. apply mcmul_0_l.
  Qed.

  (** 1 * m = m *)
  Lemma mcmul_1_l : forall {r c} (m : mat r c), A1 c* m == m.
  Proof.
    intros. apply mcmul_1_l.
  Qed.

  (** *** Multiplication of matrix *)

  Definition mmul {r c s} (m1 : mat r c) (m2 : mat c s) : mat r s :=
    @mmul A Aadd A0 Amul r c s m1 m2.

  Global Infix "*" := mmul : mat_scope.

  (** m1 * (m2 + m3) = (m1 * m2) + (m1 * m3) *)
  Lemma mmul_add_distr_l : forall {r c s} (m1 : mat r c) (m2 m3 : mat c s),
      m1 * (@madd c s m2 m3) == @madd r s (m1 * m2) (m1 * m3).
  Proof.
    intros. apply mmul_add_distr_l.
  Qed.

  (** (m1 + m2) * m3 = (m1 * m3) + (m2 * m3) *)
  Lemma mmul_add_distr_r : forall {r c s} (m1 m2 : mat r c) (m3 : mat c s),
      (@madd r c m1 m2) * m3 == @madd r s (m1 * m3) (m2 * m3).
  Proof.
    intros. apply mmul_add_distr_r.
  Qed.

  (** (m1 * m2) * m3 = m1 * (m2 * m3) *)
  Lemma mmul_assoc : forall {r c s t} (m1 : mat r c) (m2 : mat c s) (m3 : mat s t),
      (m1 * m2) * m3 == m1 * (m2 * m3).
  Proof.
    intros. apply mmul_assoc.
  Qed.

  (** mat0 * m = mat0 *)
  Lemma mmul_0_l : forall {r c s} (m : mat c s), (mat0 r c) * m == mat0 r s.
  Proof.
    intros. apply mmul_0_l.
  Qed.

  (** m * mat0 = mat0 *)
  Lemma mmul_0_r : forall {r c s} (m : mat r c), m * (mat0 c s) == mat0 r s.
  Proof.
    intros. apply mmul_0_r.
  Qed.

  (** mat1 * m = m *)
  Lemma mmul_1_l : forall {r c} (m : mat r c), (mat1 r) * m == m.
  Proof.
    intros. apply mmul_1_l.
  Qed.

  (** m * mat1 = m *)
  Lemma mmul_1_r : forall {r c} (m : mat r c), m * (mat1 c) == m.
  Proof.
    intros. apply mmul_1_r.
  Qed.

  (** a c* (m1 * m2) = (a c* m1) * m2. *)
  Lemma mcmul_mul_assoc : forall {r c s} (a : A) (m1 : mat r c) (m2 : mat c s),
      a c* (m1 * m2) == (a c* m1) * m2.
  Proof.
    intros. apply mcmul_mul_assoc.
  Qed.

  (** m1 * (a c* m2) = a c* (m1 * m2). *)
  Lemma mcmul_mul_perm : forall {r c s} (a : A) (m1 : mat r c) (m2 : mat c s),
      a c* (m1 * m2) == m1 * (a c* m2).
  Proof.
    intros. apply mcmul_mul_perm.
  Qed.

  (** Auto unfold these definitions *)
  Global Hint Unfold madd mopp msub mcmul mmul : mat.

  (** ** Extended matrix theory *)

  (** Trace of a square matrix *)
  Definition trace {n : nat} (m : smat n) :=
    seqsum (A0:=A0) (Aadd:=Aadd) (fun i => m!i!i) n.

  (** Determinant of 3x3 matrix *)
  Definition det3 (m : mat 3 3) : A :=
    (let '((a11,a12,a13),(a21,a22,a23),(a31,a32,a33)) := m2t_3x3 m in
     let b1 := (a11 * a22 * a33) in
     let b2 := (a12 * a23 * a31) in
     let b3 := (a13 * a21 * a32) in
     let c1 := (a11 * a23 * a32) in
     let c2 := (a12 * a21 * a33) in
     let c3 := (a13 * a22 * a31) in
     let b := (b1 + b2 + b3) in
     let c := (c1 + c2 + c3) in
     (b - c))%A.

End RingMatrixTheorySF.

(* ######################################################################### *)
(** * Decidable Field matrix theory implemented with SafeNatFun *)

Module DecidableFieldMatrixTheorySF (E : DecidableFieldElementType)
<: DecidableFieldMatrixTheory E.

  (* Export E. *)
  Include RingMatrixTheorySF E.

  Add Field field_inst : make_field_theory.

  Import PermutationExt.

  (** meq is decidable *)
  Lemma meq_dec : forall (r c : nat), Decidable (meq (r:=r) (c:=c)).
  Proof.
    intros. apply meq_dec.
  Qed.

  (** ** matrix theory *)

  (** *** matrix inversion *)
  Section Inversion.

    (** Determinant of a square matrix.  *)
    Definition det {n} (m : smat n) : A := @det A Aadd A0 Aopp Amul A1 n m.

    (** Determinant of a matrix of 1D *)
    Definition det_1_1 (m : smat 1) := @det_1_1 A m.

    (** Determinant of a matrix of 2D *)
    Definition det_2_2 (m : smat 2) := @det_2_2 A Aadd Aopp Amul m.

    (** Determinant of a matrix of dimension-3 *)
    Definition det_3_3 (m : smat 3) := @det_3_3 A Aadd Aopp Amul m.

    (** Cramer rule, which can slving the equation with form of M*x=b.
      Note, the result is valid only when D is not zero *)
    Definition cramerRule {n} (M : smat n) (b : mat n 1) : mat n 1 :=
      @cramerRule A Aadd A0 Aopp Amul A1 Ainv n M b.

    (** Inverse matrix of a matrix *)
    Definition minv {n} (m : smat n) := @minv A Aadd A0 Aopp Amul A1 Ainv n m.

    (** Simplified formula of inverse matrix of 1D *)
    Definition inv_1_1 (m : smat 1) : smat 1 := @inv_1_1 A A0 Amul A1 Ainv m.

    (** Simplified formula of inverse matrix of 2D *)
    Definition inv_2_2 (m : smat 2) : smat 2 := @inv_2_2 A Aadd A0 Aopp Amul Ainv m.

    (** Simplified formula of inverse matrix of 2D *)
    Definition inv_3_3 (m : smat 3) : smat 3 := @inv_3_3 A Aadd A0 Aopp Amul Ainv m.

  End Inversion.

End DecidableFieldMatrixTheorySF.

(** Test *)
Module Test.
  Module Export MatrixQ := DecidableFieldMatrixTheorySF DecidableFieldElementTypeQ.
  Open Scope Q.
  Open Scope mat_scope.

  Example m3 := mk_mat_3_3 1 2 3 4 5 6 7 8 9.
  (* Compute m2l (m3 + m3). *)
  (* Compute m2l (m3 * m3). *)

  (** inverse matrix with concrete number *)
  (* Compute m2l (minv m3). *)
  Example m4 := mk_mat_3_3 1 2 3 4 5 7 6 8 9.
  (* Compute m2l (minv m4). *)
  (* Compute (m2l (m4 * (minv m4))). *)

  Module Export MatrixR := DecidableFieldMatrixTheorySF DecidableFieldElementTypeR.
  Open Scope R.
  Open Scope mat_scope.

  Variable a b c d : R.

  (** inverse matrix with symbol *)

  (** direct result has many redundant items *)
  (* Eval cbv in m2l (minv (mk_mat_2_2 a b c d)). *)

  (** simplified result is better *)
  (* Eval cbv in m2l (inv_2_2 (mk_mat_2_2 a b c d)). *)

End Test.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Arith.
Require Export Nk_ind.
Require Export Ndiv.
Open Scope nat_scope.

(** * Definition of a finite sum on [nat] with an index starting from 0 *)

Fixpoint Nfinite_sum_0_n (n : nat) (f : nat -> nat) {struct n} : nat :=
match n with
| 0 => f 0
| S n' => (f n) + Nfinite_sum_0_n n' f
end.

(** * Properties of finite sum *)

(** Compatibility with sum *)
Lemma Nfinite_sum_plus_compat : forall n f g,
  Nfinite_sum_0_n n f + Nfinite_sum_0_n n g = Nfinite_sum_0_n n (fun k => f k + g k).
Proof.
induction n.
compute. reflexivity.
intros.
unfold Nfinite_sum_0_n. fold Nfinite_sum_0_n.
rewrite plus_assoc_reverse.
rewrite plus_assoc_reverse.
assert (g (S n) + Nfinite_sum_0_n n g = Nfinite_sum_0_n n g + g (S n)).
auto with arith.
rewrite H.
clear H.
assert (Nfinite_sum_0_n n f + (Nfinite_sum_0_n n g + g (S n)) =
  Nfinite_sum_0_n n f + Nfinite_sum_0_n n g + g (S n)).
auto with arith.
rewrite H.
clear H.
rewrite IHn.
auto with arith.
Qed.

(** Distributivity of multiplication *)
Lemma Nfinite_sum_mult_distrib : forall a n f,
  a * Nfinite_sum_0_n n f = Nfinite_sum_0_n n (fun k => a * f k).
Proof.
induction n.
compute. reflexivity.
intros.
unfold Nfinite_sum_0_n. fold Nfinite_sum_0_n.
rewrite <- IHn.
ring.
Qed.

(** Compatibility with equality (limited equality) *)
Lemma Nfinite_sum_subtle_eq_compat :
  forall n f g, (forall k, k <= n -> f k = g k) -> Nfinite_sum_0_n n f = Nfinite_sum_0_n n g.
Proof.
induction n.
compute. intros.
apply H. trivial.
intros.
unfold Nfinite_sum_0_n. fold Nfinite_sum_0_n.
rewrite (IHn f g).
rewrite (H (S n)).
reflexivity.
trivial.
intros.
apply H.
auto with arith.
Qed.

(** compatibility with equality (unlimited equality) *)
Lemma Nfinite_sum_eq_compat : forall n f g,
  (forall k, f k = g k) -> Nfinite_sum_0_n n f = Nfinite_sum_0_n n g.
Proof.
intros.
apply Nfinite_sum_subtle_eq_compat.
intros.
apply H.
Qed.

(** One term, lower splitting of finite sum *)
Lemma Nfinite_sum_split_lower : forall n f,
  Nfinite_sum_0_n (S n) f = f 0 + Nfinite_sum_0_n n (fun k => f (S k)).
Proof.
induction n.
compute. auto with arith.
intros.
unfold Nfinite_sum_0_n. fold Nfinite_sum_0_n.
unfold Nfinite_sum_0_n in IHn. fold Nfinite_sum_0_n in IHn.
rewrite IHn.
rewrite plus_assoc.
rewrite plus_assoc.
auto with arith.
Qed.

(** One term, upper splitting of finite sum *)
Lemma Nfinite_sum_split_upper : forall n f,
  Nfinite_sum_0_n (S n) f = Nfinite_sum_0_n n f + f (S n).
Proof.
intros.
unfold Nfinite_sum_0_n. fold Nfinite_sum_0_n.
auto with arith.
Qed.

(** General splitting of finite sum *)
Lemma Nfinite_sum_split : forall n p q f,
  p + q = n -> Nfinite_sum_0_n (S n) f = Nfinite_sum_0_n p f + Nfinite_sum_0_n q (fun k => f (kth_S p k)).
Proof.
induction n.
induction p.
intros.
simpl in H.
rewrite H.
unfold Nfinite_sum_0_n.
unfold kth_S.
auto with arith.

intros.
discriminate H.

destruct p.
intros.
simpl in H.
rewrite H. clear H.
assert (Nfinite_sum_0_n 0 f=f 0).
compute. reflexivity.
rewrite H. clear H.
rewrite Nfinite_sum_split_lower.
unfold kth_S.
reflexivity.
intros.
assert (p+q=n).
auto with arith.
clear H.
assert (Nfinite_sum_0_n (S (S n)) f=f(S(S n))+Nfinite_sum_0_n (S n) f).
rewrite plus_comm.
apply Nfinite_sum_split_upper.
rewrite H. clear H.
rewrite (IHn p q).
rewrite Nfinite_sum_split_upper.
assert (f (S p) + Nfinite_sum_0_n q (fun k : nat => f (kth_S (S p) k))
  = Nfinite_sum_0_n (S q) (fun k=>f(kth_S p k))).
rewrite Nfinite_sum_split_lower.
rewrite kth_S_special.
unfold kth_S. fold kth_S.
assert (forall k:nat, kth_S p (S k)=S(kth_S p k)).
intro.
rewrite kth_S_sym.
unfold kth_S. fold kth_S.
rewrite kth_S_sym.
reflexivity.
assert (Nfinite_sum_0_n q (fun k : nat => f (S (kth_S p k)))=
  Nfinite_sum_0_n q (fun k : nat => f (kth_S p (S k)))).
apply Nfinite_sum_eq_compat.
intro.
rewrite (H k).
reflexivity.
rewrite H1.
reflexivity.
assert (Nfinite_sum_0_n p f + f (S p) +
  Nfinite_sum_0_n q (fun k : nat => f (kth_S (S p) k))
  =
  Nfinite_sum_0_n p f + (f (S p) +
  Nfinite_sum_0_n q (fun k : nat => f (kth_S (S p) k)))).
auto with arith.
rewrite H1. clear H1.
rewrite H. clear H.
assert (f (S (S n)) +
  (Nfinite_sum_0_n p f + Nfinite_sum_0_n q (fun k : nat => f (kth_S p k)))
  =
  Nfinite_sum_0_n p f + (Nfinite_sum_0_n q (fun k : nat => f (kth_S p k))+f (S (S n)))).
rewrite plus_comm.
auto with arith.
rewrite H. clear H.
assert (Nfinite_sum_0_n (S q) (fun k : nat => f (kth_S p k)) =
  Nfinite_sum_0_n q (fun k : nat => f (kth_S p k)) + f (S (S n))).
rewrite Nfinite_sum_split_upper.
assert (kth_S p (S q)=S(S n)).
rewrite kth_S_sym.
unfold kth_S. fold kth_S.
rewrite kth_S_sym.
rewrite kth_S_plus.
assert (q+p+1=(p+q)+1).
auto with arith.
rewrite H. rewrite H0. clear H.
rewrite plus_1_r.
reflexivity.
rewrite <- H.
reflexivity.
rewrite H.
auto with arith.
exact H0.
Qed.

(** Compatibility with division *)
Lemma Nfinite_sum_div_compat : forall n f p,
  (forall k, k <= n -> (p | f k)) -> (p | Nfinite_sum_0_n n f).
Proof.
induction n.
intros.
simpl. apply H. auto.
intros.
rewrite Nfinite_sum_split_upper.
apply Ndiv_plus_compat.
apply IHn.
intros.
apply H. auto with arith.
apply H.
auto.
Qed.


Require Arith.

(*
Inductive le (n : nat) : nat -> Prop :=
 | le_n : n <= n
 | le_S : forall m : nat, n <= m -> n <= S m
*)

Fixpoint leb (n m : nat) : bool :=
  match n with
    | 0 => true
    | S n' => match m with
                | 0 => false
                | S m' => leb n' m'
              end
  end.

Eval compute in (leb 5 2).
Eval compute in (leb 50 2).
Eval compute in (leb 52 52).
Eval compute in (leb 100 424).

(*
Lemma le_0_any : forall m, 0 <= m.
Proof.
  induction m.
  constructor. (*  apply le_n. *)
  constructor.
  trivial.
Defined.
*)

Fixpoint le_0_any (m:nat) : 0 <= m :=
  match m return 0 <= m with
    | 0 => le_n 0
    | S m' => le_S _ _ (le_0_any m')
  end.

Definition le_n_S      : forall n m : nat, n <= m -> S n <= S m :=
fun (n m : nat) (H : n <= m) =>
le_ind n (fun m0 : nat => S n <= S m0) (le_n (S n))
  (fun (m0 : nat) (_ : n <= m0) (IHle : S n <= S m0) =>
   le_S (S n) (S m0) IHle) m H
.

Lemma leb_le : forall n m, leb n m = true -> n <= m.
Proof.
  induction n; try rename n into n'.
  intros m H.
  apply le_0_any.

  simpl.
  intros m.
  case m; clear m.
  intros Habs.
  discriminate.
  intros m'.
  intros H.
  generalize (IHn _ H); intros H1.
  apply le_n_S.
  trivial.
Defined.

Eval compute in (leb_le 4 9 (refl_equal _)).

Lemma le_leb : forall n m, n <= m -> leb n m = true.
Proof.
  induction n.
  intros m H.
  simpl.
  trivial.
  intros m.
  intros H.
  generalize (IHn _ H); intros H1.
  simpl.
  case m.
  intros Habs.

Qed.

(*
; A nat is
;  - 0  or
;  - S n

; le : nat nat -> boolean
(define (le n m)
  (cond [(n = 0) ...]
        [(n = S n')   .. (le n' ..)... ]))

..)

*)


From Coq Require Import Lia.
From Coq Require Import List.
From Coq Require Import Logic.Eqdep_dec.
From Coq Require Import ZArith.

Class IsMonoid (M : Type) (op : M -> M -> M) (e : M) : Prop :=
  { munit_left  : forall m, (op e m) = m;
    munit_right : forall m, (op m e) = m;
    massoc      : forall m1 m2 m3, op m1 (op m2 m3) = op (op m1 m2) m3
  }.

#[refine]
Instance nat_sum_monoid : IsMonoid nat (fun x y => x + y) 0 :=
  {| munit_left  := _;
     munit_right := _;
     massoc      := _
  |}.
all: lia.
Qed.

#[refine]
Instance nat_mul_monoid : IsMonoid nat (fun x y => x * y) 1 :=
  {| munit_left  := _;
     munit_right := _;
     massoc      := _
  |}.
all: lia.
Qed.

Open Scope Z.

#[refine]
Instance Z_sum_monoid : IsMonoid Z (fun x y => x + y) 0 :=
  {| munit_left  := _;
     munit_right := _;
     massoc      := _
  |}.
all: lia.
Qed.

Close Scope Z.

Class Dec (A : Type) : Prop :=
  { dec : forall x y : A, x = y \/ x <> y }.

#[refine]
Instance Z_dec : Dec Z := { dec := _ }.
repeat decide equality. Qed.

#[refine]
Instance from_dec {A : Type} (d : forall x y : A, {x = y} + {x <> y}) : Dec A :=
  { dec := _ }.
intros x y; specialize (d x y) as []; [left | right]; assumption. Qed.

Instance bool_dec : Dec bool := from_dec Bool.bool_dec.
Instance nat_dec  : Dec nat := from_dec Nat.eq_dec.

#[refine]
Instance list_dec {A : Type} `{Dec A} : Dec (list A) :=
  { dec := _ }.
decide equality; apply dec. Qed.

#[refine]
Instance Tuple_dec {A B : Type} `{Dec A} `{Dec B} : Dec (A * B) :=
  { dec := _ }.
decide equality; apply dec. Qed.

Class SigEq {A : Type} (P : A -> Prop) : Prop :=
  { subset_eq : forall x y : sig P, proj1_sig x = proj1_sig y -> x = y }.

#[refine]
Instance SigEq_dec {A B : Type} `{Dec B} {f g : A -> B} : SigEq (fun x => f x = g x) :=
  { subset_eq := _ }.
intros [x px] [y py]; simpl; intros; subst; f_equal; apply (eq_proofs_unicity dec).
Qed.

#[refine]
Instance sig_dec {A : Type} {P : A -> Prop} `{Dec A} `{SigEq A P} : Dec (sig P) :=
  { dec := _ }.
intros [x px] [y py];
  specialize (dec x y) as [];
  subst.
* left; apply subset_eq; simpl; reflexivity.
* right; unfold not; inversion 1; auto.
Qed.

(** A result that helps in dealing with situations where heterogeneous equality
    might seem needed. Instead of assuming [JMeq_eq] we can prove that, after a
    function application, elements of equal "dependent subset types" are equal *)
Lemma heterog_subset_eq_f {D X Y : Type} {P : D -> X -> Prop}:
    forall (sigeq : forall (d : D), SigEq (P d))
      (f : forall {d : D}, sig (P d) -> Y)
      (d1 d2 : D)
      (x1 : sig (P d1))
      (x2 : sig (P d2)),
    d1 = d2 -> proj1_sig x1 = proj1_sig x2 -> f x1 = f x2.
Proof.
  intros pi * H1 H2; subst; apply subset_eq in H2; subst; reflexivity.
Qed.