Require Import Arith List Omega.
Require Import Max.

Set Implicit Arguments.

(** * Recursion on proofs *)

Print positive.

Fixpoint div2 (n : nat) : nat :=
  match n with
    | S (S n') => S (div2 n')
    | _ => O
  end.

Inductive ntb_pred : nat -> Prop :=
  | ntb_1 : ntb_pred 1
  | ntb_div2 : forall n,
    ntb_pred (div2 n)
    -> ntb_pred n.

Fixpoint bin_to_nat (b : positive) : nat :=
  match b with
    | xH => 1
    | xO b' => 2 * bin_to_nat b'
    | xI b' => 1 + 2 * bin_to_nat b'
  end.

Lemma ntb_pred_positive : forall n,
  ntb_pred n
  -> n = 0
  -> False.
  induction 1; intuition; subst; auto.
Qed.

Hint Resolve ntb_pred_positive.

Hint Extern 5 False => omega.

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

Definition nat_to_bin (n : nat) (pf : ntb_pred n) : positive.
  refine (fix nat_to_bin (n : nat) (pf : ntb_pred n) {struct pf} : positive :=
    match n as n' return (n = n' -> _) with
      | 0 => fun Heq => False_rec _ _
      | 1 => fun Heq => xH
      | S (S n') => fun Heq =>
	match nat_to_bin (div2 n)
	  (match pf in (ntb_pred n') return (n = n' -> ntb_pred (div2 n')) with
	     | ntb_1 => fun Heq => False_ind _ _
	     | ntb_div2 _ pf' => fun _ => pf'
	   end (refl_equal _)) with
	  | b =>
	    if isEven n
	      then xO b
	      else xI b
	end
    end (refl_equal _)); clear nat_to_bin; eauto.
Defined.

Eval compute in nat_to_bin ntb_1.
Eval compute in nat_to_bin (ntb_div2 2 ntb_1).
Eval compute in nat_to_bin (ntb_div2 3 ntb_1).
Eval compute in nat_to_bin (ntb_div2 4 (ntb_div2 2 ntb_1)).
Eval compute in nat_to_bin (ntb_div2 5 (ntb_div2 2 ntb_1)).

Extraction nat_to_bin.

(** * Well-founded recursion: merge sort example *)

Section mergeSort.
  Variable A : Set.
  Variable le : A -> A -> Prop.

  Variable le_dec : forall x y, {le x y} + {~le x y}.

  Fixpoint insert (x : A) (ls : list A) {struct ls} : list A :=
    match ls with
      | nil => x :: nil
      | h :: ls' =>
	if le_dec x h
	  then x :: ls
	  else h :: insert x ls'
    end.

  Fixpoint merge (ls1 ls2 : list A) {struct ls1} : list A :=
    match ls1 with
      | nil => ls2
      | h :: ls' => insert h (merge ls' ls2)
    end.

  Fixpoint split (ls : list A) : list A * list A :=
    match ls with
      | nil => (nil, nil)
      | h :: nil => (h :: nil, nil)
      | h1 :: h2 :: ls' =>
	let (ls1, ls2) := split ls' in
	  (h1 :: ls1, h2 :: ls2)
    end.

  Definition lengthOrder (ls1 ls2 : list A) :=
    length ls1 < length ls2.

  Theorem lengthOrder_wf : well_founded lengthOrder.
    red.

    cut (forall len : nat, forall a : list A, length a <= len -> Acc lengthOrder a); eauto.

    induction len; intuition.

    destruct a; simpl in H.

    constructor; intros.
    inversion H0.

    inversion H.

    constructor; intros.
    red in H0.
    apply IHlen.
    omega.
  Qed.

  Ltac arith_contra :=
    assert False; [omega | tauto].

  Lemma split_lengthOrder1' : forall len ls,
    2 <= length ls <= len
    -> lengthOrder (fst (split ls)) ls.
    induction len; simpl; intuition; try arith_contra.

    destruct ls; simpl in *; try arith_contra.
    destruct ls; simpl in *; try arith_contra.

    red; simpl.

    destruct (le_lt_dec 2 (length ls)).

    generalize (IHlen ls).
    destruct (split ls); simpl.
    unfold lengthOrder; simpl.
    omega.

    destruct ls; simpl in *; try omega.
    destruct ls; simpl in *; omega.
  Qed.

  Lemma split_lengthOrder2' : forall len ls,
    2 <= length ls <= len
    -> lengthOrder (snd (split ls)) ls.
    induction len; simpl; intuition; try arith_contra.

    destruct ls; simpl in *; try arith_contra.
    destruct ls; simpl in *; try arith_contra.

    red; simpl.

    destruct (le_lt_dec 2 (length ls)).

    generalize (IHlen ls).
    destruct (split ls); simpl.
    unfold lengthOrder; simpl.
    omega.

    destruct ls; simpl in *; try omega.
    destruct ls; simpl in *; omega.
  Qed.

  Theorem split_lengthOrder1 : forall ls,
    2 <= length ls
    -> forall ls1 ls2, split ls = (ls1, ls2)
      -> lengthOrder ls1 ls.
    intros.
    replace ls1 with (fst (split ls)).
    eapply split_lengthOrder1'; eauto.
    rewrite H0; trivial.
  Qed.

  Theorem split_lengthOrder2 : forall ls,
    2 <= length ls
    -> forall ls1 ls2, split ls = (ls1, ls2)
      -> lengthOrder ls2 ls.
    intros.
    replace ls2 with (snd (split ls)).
    eapply split_lengthOrder2'; eauto.
    rewrite H0; trivial.
  Qed.

  Hint Resolve split_lengthOrder1 split_lengthOrder2.

  Definition mergeSort (ls : list A) : list A.
    refine (Fix lengthOrder_wf (fun _ => list A)
      (fun (ls : list A)
	(mergeSort : forall ls' : list A, lengthOrder ls' ls -> list A) =>
	if le_lt_dec 2 (length ls)
	  then match split ls as lss return (split ls = lss -> _) with
		 | (ls1, ls2) => fun Heq => merge (mergeSort ls1 _) (mergeSort ls2 _)
	       end (refl_equal _)
	  else ls)); eauto.
  Defined.

  Theorem mergeSort_rec : forall x y ls,
    mergeSort (x :: y :: ls) =
    match split (x :: y :: ls) as lss return (split (x :: y :: ls) = lss -> _) with
      | (ls1, ls2) => fun Heq => merge (mergeSort ls1) (mergeSort ls2)
    end (refl_equal _).
    intros.
    unfold mergeSort at 1.
    rewrite Fix_eq; intuition.

    destruct (le_lt_dec 2 (length x0)); intuition.
    generalize (split_lengthOrder1 x0 l).
    generalize (split_lengthOrder2 x0 l).
    destruct (split x0); intuition.
    repeat rewrite H.
    reflexivity.
  Qed.
End mergeSort.

Recursive Extraction mergeSort.

(** * Domain theory approach to general recursive programs *)

(** ** Foundational definitions *)

Set Implicit Arguments.

Section computation.
  Variable A : Set.

  Definition computation :=
    {f : nat -> option A
      | forall (n : nat) (v : A),
	f n = Some v
	-> forall (n' : nat), n' >= n
	  -> f n' = Some v}.

  Definition runTo (m : computation) (n : nat) (v : A) :=
    proj1_sig m n = Some v.

  Definition run (m : computation) (v : A) :=
    exists n, runTo m n v.
End computation.

Hint Unfold runTo.

Section Bottom.
  Variable A : Set.

  Definition Bottom : computation A.
    exists (fun _ : nat => @None A); intuition.
  Defined.
End Bottom.

Section Return.
  Variable A : Set.
  Variable v : A.

  Definition Return : computation A.
    intros.
    exists (fun _ : nat => Some v); intuition.
  Defined.

  Theorem run_Return : run Return v.
    red.
    unfold runTo, Return.
    exists 0; auto.
  Qed.
End Return.

Hint Resolve run_Return.

Ltac caseEq e := generalize (refl_equal e); pattern e at -1; case e.

Section Bind.
  Variables A B : Set.
  Variable m1 : computation A.
  Variable m2 : A -> computation B.

  Definition Bind : computation B.
    destruct m1 as [f1 Hf1].
    exists (fun n =>
      match f1 n with
	| None => None
	| Some v =>
	  let (f2, Hf2) := m2 v in
	    f2 n
      end); intuition.
    generalize (Hf1 n).
    destruct (f1 n); intuition; try discriminate.
    rewrite (H1 a (refl_equal _) _ H0); trivial.
    destruct (m2 a); eauto.
  Defined.

  Theorem run_Bind : forall (v1 : A) (v2 : B),
    run m1 v1
    -> run (m2 v1) v2
    -> run Bind v2.
    unfold Bind, run, runTo; intros v1 v2 H1 H2.

    destruct m1 as [f1 Hf1]; simpl in *; idtac.
    caseEq (m2 v1); intros f2 Hf2 Heq.
    rewrite Heq in H2.
    destruct H1 as [n1 Hn1].
    destruct H2 as [n2 Hn2].

    exists (max n1 n2).
    rewrite (Hf1 _ _ Hn1); auto with arith.
    rewrite Heq.
    rewrite (Hf2 _ _ Hn2); auto with arith.
  Qed.

  Theorem run_Bind' : forall (v2 : B),
    run Bind v2
    -> exists v1 : A,
      run m1 v1
      /\ run (m2 v1) v2.
    unfold Bind, run, runTo; intros v2 H1.

    destruct m1 as [f1 Hf1]; simpl in *; idtac.
    destruct H1 as [n1 Hn1].
    caseEq (f1 n1);
    [intros v1 Heq
      | intros Heq]; rewrite Heq in Hn1; try discriminate.
    exists v1; intuition eauto.
    destruct (m2 v1); simpl; eauto.
  Qed.
End Bind.

Hint Resolve run_Bind.

Notation "x <- m1 ; m2" :=
  (Bind m1 (fun x => m2)) (right associativity, at level 70).

Section monotone_runTo.
  Variable A : Set.
  Variable c : computation A.
  Variable v : A.

  Theorem monotone_runTo : forall (n1 : nat),
    runTo c n1 v
    -> forall n2, n2 >= n1
      -> runTo c n2 v.
    unfold runTo; intuition.
    destruct c; simpl in *; intuition eauto.
  Qed.
End monotone_runTo.

Hint Resolve monotone_runTo.

Section rewrite.
  Variable A : Set.
  Variable c : computation A.
  Variable n : nat.
  Variable v : A.

  Theorem fold_runTo :
    (proj1_sig c n = Some v)
    = runTo c n v.
    trivial.
  Qed.
End rewrite.

Section lattice.
  Variable A : Set.

  Definition leq (x y : option A) :=
    forall v, x = Some v -> y = Some v.
End lattice.

Hint Unfold leq.

Section Fix.
  Variables A B : Set.
  Variable f : (A -> computation B) -> (A -> computation B).

  Hypothesis f_continuous : forall n v v1 x,
    runTo (f v1 x) n v
    -> forall (v2 : A -> computation B), (forall x, leq (proj1_sig (v1 x) n) (proj1_sig (v2 x) n))
      -> runTo (f v2 x) n v.

  Fixpoint Fix' (n : nat) (x : A) {struct n} : computation B :=
    match n with
      | O => Bottom _
      | S n' => f (Fix' n') x
    end.

  Definition Fix : A -> computation B.
    intro x.
    exists (fun n => proj1_sig (Fix' n x) n).

    cut (forall (steps : nat) (n : nat) (v : B),
      proj1_sig (Fix' n x) steps = Some v ->
      forall (n' : nat), n' >= n
	-> proj1_sig (Fix' n' x) steps = Some v).

    intuition.
    eapply H; eauto.
    rewrite fold_runTo; eauto.

    intros steps n.
    generalize dependent x.
    induction n; simpl; intuition.

    discriminate.

    destruct n'.
    inversion H0.

    simpl.
    apply f_continuous with (Fix' n); clear f_continuous; auto.

    red; intros.
    eauto with arith.
  Defined.

  Definition extensional (f : (A -> computation B) -> (A -> computation B)) :=
    forall g1 g2 n,
      (forall x, proj1_sig (g1 x) n = proj1_sig (g2 x) n)
      -> forall x, proj1_sig (f g1 x) n = proj1_sig (f g2 x) n.

  Hypothesis f_extensional : extensional f.

  Theorem run_Fix : forall x v,
    run (f Fix x) v
    -> run (Fix x) v.
    intros.

    red; unfold runTo; simpl.
    red in H; unfold runTo in H; simpl in H.

    destruct H as [n Hn].
    exists (S n).
    simpl.

    rewrite fold_runTo.
    apply monotone_runTo with n; auto.

    red.
    rewrite (f_extensional (Fix' n) Fix n); intuition.
  Qed.
End Fix.

Hint Resolve run_Fix.

Notation "'dfix' f [ x ::: dom ] ::: ran := e" :=
  (Fix (A := dom) (B := ran) (fun f x => e) _) (at level 80).
Notation "'dfix' f [ '__' ::: dom ] ::: ran := e" :=
  (Fix (A := dom) (B := ran) (fun f _ => e) _) (at level 80).
Notation "'dfix' '__' [ x ::: dom ] ::: ran := e" :=
  (Fix (A := dom) (B := ran) (fun _ x => e) _) (at level 80).
Notation "'dfix' '__' [ '__' ::: dom ] ::: ran := e" :=
  (Fix (A := dom) (B := ran) (fun _ _ => e) _) (at level 80).

(** ** Examples *)

(** *** The constant-0 function *)

Definition const : nat -> computation nat.
  refine (dfix const [ x ::: nat ] ::: nat := Return 0); intuition.
Defined.

Eval compute in proj1_sig (const 0) 0.
Eval compute in proj1_sig (const 0) 1.
Eval compute in proj1_sig (const 8) 2.

Hint Unfold extensional.

Theorem const_correct : forall n, run (const n) 0.
  intros.
  unfold const.
  apply run_Fix; auto.
Qed.

Recursive Extraction const.

(** *** Natural number addition *)

Definition add : nat * nat -> computation nat.
  refine (Fix (fun (add : nat * nat -> computation nat) (ns : nat * nat) =>
    let (n1, n2) := ns in
      match n1 with
	| O => Return (snd ns)
	| S n1' => res <- add (n1', n2); Return (S res)
      end) _); intuition.

  destruct x; simpl in *; idtac.
  destruct n0; intuition.

  unfold runTo, Bind; simpl.
  unfold runTo, Bind in H; simpl in H.
  caseEq (v1 (n0, n1)); intros f1 Hf1 Heq.
  rewrite Heq in H; simpl in H.

  caseEq (f1 n); [intros V1 Heq' | intros Heq']; rewrite Heq' in H; try discriminate.

  generalize (H0 (n0, n1)); intro Hleq.
  red in Hleq.
  rewrite Heq in Hleq; simpl in Hleq.
  destruct (v2 (n0, n1)) as [f2 Hf2]; simpl in *; idtac.
  rewrite (Hleq V1); intuition.
Defined.

Eval compute in proj1_sig (add (0, 0)) 0.
Eval compute in proj1_sig (add (0, 0)) 1.
Eval compute in proj1_sig (add (1, 0)) 1.

Eval compute in proj1_sig (add (8, 13)) 9.

Theorem add_extensional : extensional
  (fun add (ns : nat * nat) => let (n1, n2) := ns in
    match n1 with
      | O => Return (snd ns)
      | S n1' => res <- add (n1', n2); Return (S res)
    end).
  red; intuition.
  destruct a; intuition.
  unfold Bind.
  generalize (H (a, b)).
  destruct (g1 (a, b)); simpl.
  destruct (g2 (a, b)); simpl.
  intro Heq.
  rewrite Heq.
  trivial.
Qed.

Hint Immediate add_extensional.

Theorem add_correct : forall n1 n2, run (add (n1, n2)) (n1 + n2).
  induction n1; unfold add; eauto.
Qed.

Recursive Extraction add.

(** *** Guarded infinite loop *)

Definition looper : bool -> computation unit.
  refine (dfix looper [b ::: bool] ::: unit :=
    if b
      then Return tt
      else looper b); intuition.

  destruct x; intuition.
  unfold leq in H0.
  eauto.
Defined.

Eval compute in proj1_sig (looper true) 0.
Eval compute in proj1_sig (looper true) 1.

Eval compute in proj1_sig (looper false) 0.
Eval compute in proj1_sig (looper false) 1.
Eval compute in proj1_sig (looper false) 10.

Theorem looper_extensional : extensional (fun looper (b : bool) =>
  if b
    then Return tt
    else looper b).
  red; intuition.
  destruct x; intuition.
Qed.

Hint Immediate looper_extensional.

Theorem looper_correct : run (looper true) tt.
  unfold looper; auto.
Qed.

Recursive Extraction looper.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(* This contribution was updated for Coq V5.10 by the COQ workgroup.        *)
(* January 1995                                                             *)
(****************************************************************************)
(*                                                                          *)
(*      Coq V5.8                                                            *)
(*                                                                          *)
(*                                                                          *)
(*      First-order Unification                                             *)
(*                                                                          *)
(*      Joseph Rouyer                                                       *)
(*                                                                          *)
(*      November 1992                                                       *)
(*                                                                          *)
(*               New theorems and lemmas on naturals.                       *)
(*                                                                          *)
(****************************************************************************)
(*                            nat_complements.v                             *)
(****************************************************************************)

Require Import Arith.

(*********************************************************************)
(************* Lemmas on naturals proved in Nat.v and *****************)
(******************** used with the command "auto". *******************)
(*********************************************************************)
(*O_S      :(n:nat)(~O=(S n))*)
(*eq_S     :(n:nat)(m:nat)(n=m)->((S n)=(S m))*)
(*eq_add_S :(n:nat)(m:nat)((S n)=(S m))->(n=m)*)
(*le_pred_n:(n:nat)(le (pred n) n)*)
(*le_n_Sn  :(n:nat)(le n (S n))*)
(*le_S_n   :(n:nat)(m:nat)(le (S n) (S m))->(le n m)*)
(*le_Sn_O  :(n:nat)(~(le (S n) O))*)
(*le_n     :(n:nat)(le n n)*)
(*le_n_S   :(n:nat)(m:nat)(le n m)->(le (S n) (S m))*)
(*********************************************************************)

(*********************************************************************)
(********** Logic tools : To translate P:Prop into Q:Set : ****************)
(*********************************************************************)

Definition P_S (A : Set) (P : A -> Prop) (x : A) : Set :=
  {a : A | a = x &  P a}.

Lemma P_S_proof1 : forall (A : Set) (a : A) (P : A -> Prop), P a -> P_S A P a.
intros; unfold P_S in |- *; exists a; auto with arith.
Qed.

Lemma P_S_proof2 : forall (A : Set) (a : A) (P : A -> Prop), P_S A P a -> P a.
unfold P_S in |- *; intros A a P h; elim h; intros x h0; elim h0;
 auto with arith.
Qed.

(*********************************************************************)
(***************** Logic tools  To negate an equality : ******************)
(*********************************************************************)

Lemma Diff :
 forall (A : Set) (f : A -> Prop) (a b : A), f a -> ~ f b -> a <> b.
unfold not in |- *; intros A f a b H H0 H1; elim H0; elim H1; auto with arith.
Qed.

(*** Replace "apply h;auto with arith" by "auto" when the Type of h is False : ***)

Lemma n_False : ~ False.
auto with arith.
Qed.

(*********************************************************************)

(*********************************************************************)
(********************** Section complement_nat. *********************)
(*********************************************************************)

(*Section complement_nat.*)

(*********************************************************************)
(**************** Decidability of the equality in the Set nat : *************)
(*********************************************************************)

Lemma nat_eq_decS : forall x y : nat, {x = y} + {x <> y}.
simple induction x.
(*case x=O*)
simple induction y; auto with arith.
(*case x=(S y)*)
simple induction y.
(*... case y0=O*)
right; discriminate.
(*... case y0=(S y1)*)
intros y1 h; elim (H y1); intros.
(*... ... case y=y1*)
auto with arith. (*apply eq_S*)
(*case not y=y1*)
right; simplify_eq; auto with arith.
Qed.

Lemma nat_eq_decP : forall x y : nat, x = y \/ x <> y.
intros x y; elim (nat_eq_decS x y); auto with arith.
Qed.

(*********************************************************************)
(************** General induction (with le) : ****************************)
(*********************************************************************)

Lemma ind_leS :
 forall (n : nat) (P : nat -> Set),
 P 0 -> (forall p : nat, (forall q : nat, q <= p -> P q) -> P (S p)) -> P n.
intros n P; cut ((forall m : nat, m <= n -> P m) -> P n).
2: auto with arith. (*apply le_n*)
intros h h0 h1; apply h.
elim n.
(*case n=O*)
(*... case m=O*)
simple induction m.
intros; auto with arith.
(*... case m=(S y)*)
intros y Hyp1 Hyp2; absurd (S y <= 0); auto with arith. (*le_Sn_O*)
(*case n=(S y)*)
simple induction m.
(*... case m=O*)
auto with arith.
(*... case m=(S y0)*)
intros y0 hyp1 hyp2; apply (h1 y0).
eauto with arith.
Qed.

Lemma ind_leP :
 forall (n : nat) (P : nat -> Prop),
 P 0 -> (forall p : nat, (forall q : nat, q <= p -> P q) -> P (S p)) -> P n.
intros; apply (P_S_proof2 nat n P).
apply (ind_leS n (P_S nat P));
 [ apply P_S_proof1; assumption | intros; apply P_S_proof1 ].
apply H0; intros; elim (H1 q); [ intros x eg_x_q | auto with arith ].
rewrite eg_x_q; auto with arith.
Qed.

(*********************************************************************)
(********** Reasoning by cases with the natural constructors : ************)
(*********************************************************************)

Lemma pred_or : forall m : nat, 0 = m \/ m = S (pred m).
intro; elim m; auto with arith.
Qed.

Lemma nat_caseS :
 forall (x : nat) (P : nat -> Set), P 0 -> (forall n : nat, P (S n)) -> P x.
intros; elim x; auto with arith.
Qed.

(*********************************************************************)
(************** Decidability of le : ************************************)
(*********************************************************************)

Lemma le_decS : forall n p : nat, {n <= p} + {~ n <= p}.
simple induction n.
(*case n=O*)
auto with arith.
(*case n=(S y)*)
simple induction p.
auto with arith.           (*apply le_Sn_O*)
intros y0 le_or_not_le; elim (H y0).
auto with arith.             (*apply le_n_S*)
intro not_le_n0_y0; right; unfold not in |- *.
intros; elim not_le_n0_y0; auto with arith.        (*apply le_S_n*)
Qed.

Lemma le_decP : forall n p : nat, n <= p \/ ~ n <= p.
intros; elim (le_decS n p); auto with arith.
Qed.

Lemma le_S_eqS : forall n p : nat, n <= p -> {S n <= p} + {n = p :>nat}.
simple induction n.
simple induction p; auto with arith.
intros n0 H p; elim p.
intros; absurd (S n0 <= 0); auto with arith.
intros n1 H1 H2; elim (H n1); auto with arith. (*le_n_S*)
Qed.

Lemma le_S_eqP : forall n p : nat, n <= p -> S n <= p \/ n = p :>nat.
intros; elim (le_S_eqS n p); auto with arith.
Qed.


Require Import ssreflect Arith.
Require Import Arith.EqNat.
Require Import Arith.Compare_dec.
Require Import List.
Require Import Omega.

Inductive typ :=
  | Tnat : typ
  | Tarrow : typ -> typ -> typ.

Inductive term :=
  | Var : nat -> term
  | ConstNat : nat -> term
  | App : term -> term -> term
  | Lambda : typ -> term -> term.

Check nth.
Check (list).
Definition context (t: Set) := list (option t).

Lemma lambda_equivalence: forall (t u: term) (ty: typ), t = u <-> (Lambda ty t = Lambda ty u).
Proof.
  move => t u.
  split;(move => h0).
  rewrite h0.
  done.
  inversion h0.
  trivial.
Qed.

Lemma app_equivalence: forall t u v w: term, App t u = App v w <-> (t = v) /\ (u = w).
Proof.
  move => t u v w.
  split.
  move => h0.
  split.
  inversion h0.
  done.
  inversion h0.
  done.
  move => [h0 h1].
  rewrite h0.
  rewrite h1.
  done.
Qed.

Fixpoint omap (oty: option typ)  (ty: typ) : option typ:=
  match oty with
    | None => None
    | Some t => Some (Tarrow (ty) (t))
  end.

Fixpoint type (ctx: list typ) (t: term) : option typ :=
  match t with
    | Var n => nth_error ctx n
    | ConstNat _ => Some Tnat
    | App t1 t2 => if type ctx t1 is Some (Tarrow t1l t1r) then
                     if type ctx t2 is Some t1l then Some t1r
                     else None
                   else None
    | Lambda ty t => omap (type (ty :: ctx) t) ty
  end.

Fixpoint C (i: nat) (t: term): Prop :=
  match t with
    | Var v => (v < i)
    | ConstNat v => True
    | App t1 t2 => (C i t1) /\ (C i t2)
    | Lambda ty t1 => C (i+1) t1
  end.

(*Question 1.2*)
Lemma ind_C_pred: forall t: term, forall n: nat, C n t -> C (n+1) t.
Proof.
  induction t; simpl; intros.
  omega; trivial.
  trivial.
  split.
  apply IHt1.
  by destruct H.
  apply IHt2. by destruct H.
  by apply IHt.
Qed.

Fixpoint lifting (n: nat) (k: nat) (t: term): term :=
  match t with
    | Var i => if leb k i then Var (i+n) else Var i
    | ConstNat i => ConstNat i
    | App t1 t2 => App (lifting n k t1) (lifting n k t2)
    | Lambda ty t1 => Lambda ty (lifting n (k+1) t1)
  end.

Fixpoint substitution (i: nat) (t1: term) (t2: term): term :=
  match t1 with
    | Var v => if beq_nat i v then t2 else Var v
    | ConstNat i => ConstNat i
    | App t3 t4 => App (substitution i t3 t2) (substitution i t4 t2)
    | Lambda ty t3 => Lambda ty (substitution (i+1) t3 (lifting 1 0 t2))
  end.

(*Question 1.4.2*)
Theorem no_index_sub: forall (t u: term) (i: nat), (C i t) -> substitution i t u = t.
Proof.
  induction t; simpl; intros.
  have:(beq_nat i n = false).
  apply beq_nat_false_iff.
  omega.
  move => h0.
  by rewrite h0.
  trivial.
  rewrite app_equivalence; split.
  apply IHt1.
  apply H.
  apply IHt2.
  apply H.
  apply lambda_equivalence.
  by apply IHt.
Qed.

Definition has_type (ctx: list typ) (t: term) := exists ty: typ, type ctx t = Some ty.

Lemma nth_of_list: forall (A: Type) (l: list A) (n: nat), n < length l <-> exists a: A, nth_error l n = Some a.
Proof.
  intros A l.
  split.
  move: n.
  induction l; simpl.
  intros; omega.
  intro; case n; simpl.
  intros.
  exists a.
  done.
  intros.
  apply IHl.
  omega.
  intro h0.
  case:h0.
  move: n.
  induction l; simpl.
  intros.
  have:nth_error nil n = None.
  intros.
  induction n.
  by simpl.
  by simpl.
  intro.
  by rewrite x0 in p.
  intro.
  case:n; simpl.
  intros.
  omega.
  intros.
  have: n < (length l) -> S n < S (length l).
  omega.
  intro h0; apply h0.
  by apply (IHl _ x).
Qed.

Lemma app_is_typed: forall (t1 t2: term) (ctx: list typ), has_type ctx (App t1 t2) -> has_type ctx t1 /\ has_type ctx t2.
Proof.
  unfold has_type.
  intros.
  split.
  case H.
  intro.
  simpl.
  case (type ctx t1).
  intros.
    by exists t.
  intros.
  by exists x.
  case H.
  simpl.
  case (type ctx t2).
  case (type ctx t1).
  intro.
  case t.
  intros.
  done.
  intros.
  by exists t4.
  intros.
  done.
  case (type ctx t1).
  intro.
  case t.
  done.
  done.
  done.
Qed.

Lemma omap_eq: forall (oty: option typ) (ty: typ), (exists t0:typ, omap oty ty = Some t0) -> (exists t1:typ, oty = Some t1).
Proof.
  intros.
  case:H.
  intro.
  unfold omap.
  case oty.
  intros.
  by exists t.
  done.
Qed.

(*The converse is not true*)
Lemma typable_implies_closed: forall (t: term) (ctx: list typ), has_type ctx t -> C (length ctx) t.
Proof.
  induction t; simpl.
  unfold has_type.
  simpl.
  intros.
  case H.
  intros.
  induction ctx; simpl.
  have:nth_error nil n = None.
  intros.
  induction n.
  by simpl.  simpl.
  by simpl.
  intro h0.
  by rewrite h0 in H0.
  apply nth_of_list in H.
  done.
  intro.
  done.
  unfold has_type.
  intros.
  case H.
  intros.
  split.
  apply IHt1.
  apply (app_is_typed t1 t2 ctx).
  done.
  apply IHt2.
  by apply (app_is_typed t1 t2 ctx).
  intro.
  unfold has_type.
  simpl.
  intros.
  case:H.
  intros x H0.
  rewrite plus_comm.
  apply (IHt (t::ctx)).
  unfold has_type.
  apply (omap_eq _ t).
  by exists x.
Qed.


(******************************************************************************)
(* Dr Daniel Kirk (c) 2021                                                    *)
(******************************************************************************)
(* Let R : ringType and M : lmodType R                                        *)
(******************************************************************************)
(* lmodSetType M == a record consisting of a type 'sort' a function           *)
(*                'elem' : sort -> M, and proofs of (injective elem)          *)
(*                and (non_degenerate elem).                                  *)
(*                injective elem == forall x y : T, elem x = elem y -> x = y  *)
(*                non_degenerate elem == forall x : T, elem x != 0            *)
(*                S : lmodSetType M coerces to its type T and function elem   *)
(*                so b : S is shorthand for b : (sort S)                      *)
(*                and S b for (elem S) b.                                     *)
(******************************************************************************)
(* Let S : lmodSetType M                                                      *)
(******************************************************************************)
(* typeIsNonDegenerate S == the proof that S is non_degenerate                *)
(* typeIsInjective S == the proof that S  is injective                        *)
(******************************************************************************)
(*        li B     ==  forall C : lmodLCType B, lmodLC.li C.                  *)
(*      span B     ==  forall m : M, {C : lmodLCType B |lmodLC.sumsTo C m}    *)
(* lmodBasisType M == a record consisting of an lmodSetType sort and proofs   *)
(*                    of li sort and span sort                                *)
(******************************************************************************)
(* Let B : lmodBasisType M                                                    *)
(******************************************************************************)
(*    basisLI B    ==  given (C : lmodLC B) and a proof of (lmodLCSumsTo C 0) *)
(*                       returns proof of (C = nullFSType B)                  *)
(*  basisSpanLC B  ==  given m : M, returns (C : lmodLC B) such that          *)
(*                      (lmodLCSumsTo C m) is true                            *)
(*  basisSpanEq B  ==  given m : M returns a proof of                         *)
(*                          (lmodLCSumsTo (hasSpanLC B m) m)                  *)
(******************************************************************************)
(* lmodFinSetType M == a record consisting of a finType 'sort' and the        *)
(*                     mixin of an lmodSetType for type sort.                 *)
(*                     F : lmodBasisType M coerces to an lmodSetType          *)
(*                     so f : F and F f work as for lmodSetType               *)
(*                     However lmodFinSetType does not coerce to a finType    *)
(*                     There is an explicit function for this                 *)
(******************************************************************************)
(* Let F : lmodFinSetType M                                                   *)
(******************************************************************************)
(* typeIsNonDegenerate F == the proof that F is non_degenerate                *)
(* typeIsInjective F == the proof that F  is injective                        *)
(* to_FinType F == the underlying finType of F                                *)
(******************************************************************************)
(* Note that all F : lmodFinSetType M are bijective to some ordinal type,     *)
(* to establish the bijection we require:                                     *)
(*  1) n : nat                                                                *)
(*  2) and a proof K : n = size (enum (to_FinType F))                         *)
(*  finBasis_to_ord K f == ordinal of 'I_n corresponding to f : F             *)
(*  ord_to_finBasis K i == element of F corresponding to i : 'I_n             *)
(******************************************************************************)
(* lmodFinBasisType M == a record consisting of a lmodFinSetType sort and     *)
(*                       a mixin of lmodBasisType for sort (which coerces to  *)
(*                       lmodSetType M)                                       *)
(******************************************************************************)
(* Let B : lmodFinBasisType M                                                 *)
(******************************************************************************)
(* lmodFinBasis_to_lmodBasis B == the underlying lmodBasisType M              *)
(******************************************************************************)

Require Import Coq.Program.Tactics.
From Coq.Logic Require Import FunctionalExtensionality ProofIrrelevance.
From mathcomp Require Import ssreflect ssrfun eqtype fintype seq bigop.

Require Import Modules Linears FiniteSupport lmodLC.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
  From mathcomp Require Import ssrbool.
Set Warnings "parsing".

Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Open Scope ring_scope.
Set Implicit Arguments.
Unset Strict Implicit.

Reserved Notation "\basisProj_ b ^( B )"
  (at level 36, B at level 36, b at level 0,
    right associativity,
          format "'[' \basisProj_ b '^(' B ) ']'").

Module lmodBasis.
  Section Def.
    Variable (R : ringType) (M : lmodType R).

    Definition li (B : lmodSetType M)
    := forall (C : lmodLCType B), lmodLC.li C.

    Definition isnonzero (B : lmodSetType M) (T : seq (B*R)) := ~~has (eq_op^~0) (map snd T).
    Lemma nonzero_cons (B : lmodSetType M) (T : lmodLCType B) (a : B*R) c : isnonzero (a::c) -> isnonzero c.
    Proof. by rewrite/isnonzero/= negb_or -(rwP andP)=>U; rewrite (proj2 U). Qed.

    Definition span (B : lmodSetType M)
    := forall (m : M),
        {C : lmodLCType B | (lmodLC.sumsTo C m)}.

    Record mixin (B : lmodSetType M) := Mixin {
      is_li : li B;
      spans : span B;
    }.

    Record type := Pack { sort : _; class_of : mixin sort; }.

    Definition hasLI (B : type) (C : lmodLCType (sort B)) := @is_li _ (class_of B) C.
    Definition hasSpanLC (B : type) (m : M) := sval (@spans _ (class_of B) m).

    Lemma hasSpanEq (B : type) (m : M) : lmodLC.sumsTo (hasSpanLC B m) m.
    Proof. move: (proj2_sig (@spans _ (class_of B) m))=>P.
      destruct P as [s [S Eq]].
      refine(ex_intro _ s _); refine(ex_intro _ S _)=>//.
    Qed.

    Definition Build (T : eqType) (elem : T -> M)
      (I : injective elem) (ND : non_degenerate elem)
      (LI : li (lmodSet.Build I ND))
      (Sp : span (lmodSet.Build I ND))
    : type := Pack (Mixin LI Sp).

    Local Coercion sort : type >-> lmodSetType.
    Local Coercion class_of : type >-> mixin.
  End Def.

  Module Exports.
    Notation lmodBasisType := type.
    Notation basisLI := hasLI.
    Notation basisSpanLC := hasSpanLC.
    Notation basisSpanEq := hasSpanEq.
    Coercion sort : type >-> lmodSetType.
    Coercion class_of : type >-> mixin.
  End Exports.
  Export Exports.

  Section Results.
    Export lmodBasis.Exports GRing.
    Variable (R : ringType) (M : lmodType R) (B : type M).

    Lemma sumsToZero_null (C : lmodLCType B) : lmodLC.sumsTo C 0 -> C = nullFSType R B.
    Proof. move=>H; by apply (hasLI H). Qed.

    Definition is_add_ind_fn (xy x y : M) := (fun i : B => (sval (spans B xy)) i - (sval (spans B x) i + sval (spans B y) i)).

    Lemma is_additive (x y : M) : (hasSpanLC B x) <+> (hasSpanLC B y) = (hasSpanLC B (x + y)).
    Proof.
      move:(hasSpanEq B x) (hasSpanEq B y) (hasSpanEq B (x + y)).
      rewrite/hasSpanLC lmodLC.eqFSFun/=/lmodLCSumsTo/==>Ex Ey Exy.
      destruct Ex as [c [Uc [Fc Ex]]],  Ey as [d [Ud [Fd Ey]]], Exy as [cd [Ucd [Fcd Exy]]].

      move:(fsFun.hasSupport_catl d Fc)=>Fc'; move/fsFun.hasSupport_undup
        /(fsFun.hasSupport_catl cd)/fsFun.hasSupport_undup in Fc'.
      move:(fsFun.hasSupport_catr c Fd)=>Fd'; move /fsFun.hasSupport_undup
        /(fsFun.hasSupport_catl cd)/fsFun.hasSupport_undup in Fd'.

      move:(fsFun.hasSupport_undup (fsFun.hasSupport_catr (undup (c ++ d)) Fcd))=>Fcd'.
      rewrite (eqLCSumsTo Fc Fc' Uc (undup_uniq _)) in Ex; move/eqP in Ex.
      rewrite (eqLCSumsTo Fd Fd' Ud (undup_uniq _)) in Ey; move/eqP in Ey.
      rewrite (eqLCSumsTo Fcd Fcd' Ucd (undup_uniq _)) in Exy.
      move: Exy; rewrite -{3}Ex-{3}Ey -big_split/= -subr_eq0 -sumrB.
      under eq_bigr do rewrite -scalerDl -scalerBl; move=>Exy.

      have FS: fsFun.hasSupport (is_add_ind_fn (x + y) x y)
        (undup (undup (c ++ d) ++ cd)).
      rewrite/is_add_ind_fn=>b C.
      case(~~(sval (spans B x) b == 0)) as []eqn:Ec.
      by apply (Fc' b Ec).
      case(~~(sval (spans B y) b == 0)) as []eqn:Ed.
      by apply (Fd' b Ed).
      move/negbFE/eqP in Ec.
      move/negbFE/eqP in Ed.
      rewrite Ec Ed addr0 subr0 in C.
      by apply (Fcd' b C).

      have E: fsFun.finSuppE (is_add_ind_fn (x + y) x y).
      refine(ex_intro _ (undup (undup (c ++ d) ++ cd)) _); split=>//; apply (undup_uniq _).

      have S:lmodLCSumsTo (fsFun.Pack E) 0.
      refine(ex_intro _ (undup (undup (c ++ d) ++ cd)) (ex_intro _ (undup_uniq _) _)).
      apply(ex_intro _ FS Exy).

      clear FS; move:(@hasLI _ _ B (fsFun.Pack E) S)=>/=K.
      apply lmodLC.eqFSFun in K;simpl in K.
      apply functional_extensionality=>b.
      move:(equal_f K b)=>T.
      move/eqP in T.
      rewrite subr_eq0 eq_sym in T.
      by move/eqP in T.
    Qed.

    Definition is_sca_ind_fn r (x : M) := (fun i => (sval (spans B (r *: x)) i) - r * (sval (spans B (x)) i)).

    Lemma is_scalar (r : R) (x : M) : r <*:> (hasSpanLC B x) = (hasSpanLC B (r *: x)).
    Proof.
      move:(hasSpanEq B x) (hasSpanEq B (r *: x)).
      rewrite/hasSpanLC lmodLC.eqFSFun/=/lmodLCSumsTo/==>Ex Erx.
      destruct Ex as [c [Uc [Fc Ex]]], Erx as [d [Ud [Fd Erx]]].

      move:(fsFun.hasSupport_undup (fsFun.hasSupport_catl d Fc))=>Fc'.
      move:(fsFun.hasSupport_undup (fsFun.hasSupport_catr c Fd))=>Fd'.

      rewrite (eqLCSumsTo Fc Fc' Uc (undup_uniq _)) in Ex; move/eqP in Ex.
      rewrite (eqLCSumsTo Fd Fd' Ud (undup_uniq _)) in Erx.
      move: Erx; rewrite -{3}Ex -subr_eq0 scaler_sumr -sumrB.
      under eq_bigr do rewrite scalerA -scalerBl; move=>Erx.

      have FS: fsFun.hasSupport (is_sca_ind_fn r x)
        (undup (c ++ d)).
      rewrite /is_sca_ind_fn/fsFun.hasSupport=>b C.
      case(~~(sval (spans B x) b == 0)) as []eqn:Ec.
      by apply (Fc' b Ec).
      move/negbFE/eqP in Ec.
      rewrite Ec mulr0 subr0 in C.
      apply (Fd' b C).

      have E: finSuppE (is_sca_ind_fn r x).
      refine(ex_intro _ (undup (c ++ d)) _); split=>//; apply (undup_uniq _).

      have S:lmodLCSumsTo (fsFun.Pack E) 0.
      refine(ex_intro _ (undup (c ++ d)) _);
      apply (ex_intro _ (undup_uniq _) (ex_intro _ FS Erx)).

      clear FS; move:(@hasLI _ _ B (fsFun.Pack E) S)=>/=K.
      apply lmodLC.eqFSFun in K;simpl in K.
      apply functional_extensionality=>b.
      move:(equal_f K b)=>T.
      move/eqP in T.
      rewrite subr_eq0 eq_sym in T.
      by move/eqP in T.
    Qed.
  End Results.

  Section Coef.
    Variable (R : ringType) (M : lmodType R) (B : type M).

    Definition coef_raw (b : B) (m : M) : R
      := (hasSpanLC B m) b.

    Lemma coef_sca (b : B) : scalar (coef_raw b).
    Proof. rewrite/coef_raw=>r x y.
      by rewrite -is_additive -is_scalar/=.
    Qed.

    Definition coef b := Linear (coef_sca b).
  End Coef.

  Section Results.
    Export lmodBasis.Exports GRing.
    Variable (R : ringType) (M : lmodType R) (B : type M).

    Lemma BasisElem_hasSupport (b : B) : hasSupport (hasSpanLC B (B b)) [:: b].
    Proof.
      move:(hasLI (lmodLC.sumToElem_sumToZero (hasSpanEq B (B b)))).
      rewrite fsFun.eqFSFun/==>Z.
      move=>c X.
      move:(equal_f Z c)=>Y.
      case(c == b) as []eqn:E.
      by move/eqP in E; rewrite E in_cons eq_refl orTb.
      rewrite addr0 in Y.
      by rewrite Y eq_refl in X.
    Qed.

    Lemma orthonormP (b1 b2 : B) : coef b1 (B b2) = if b1 == b2 then 1 else 0.
    Proof. rewrite/= /coef_raw.
      move:(hasLI (lmodLC.sumToElem_sumToZero (hasSpanEq B (B b2)))).
      rewrite fsFun.eqFSFun/==>S.
      case(b1 == b2) as []eqn:E.
        move/eqP in E; rewrite -E.
        move:(equal_f S b1)=>Y.
        by move/eqP in Y; rewrite -E eq_refl subr_eq0 in Y; move/eqP in Y.

        move:(equal_f S b1)=>Y.
        by rewrite E addr0 in Y.
    Qed.

    Lemma sum_trivialises (S : seq B) (U : uniq S) (b1 : B) (x : M) : (hasSupport (lmodBasis.hasSpanLC B x) S) ->
      \sum_(b2 <- S) (coef b1 (lmodBasis.hasSpanLC B x b2 *: B b2)) *: B b1
      = (coef b1 x) *: B b1.
    Proof. move=>H.
      move:(lmodBasis.hasSpanEq B x)=>Z.
      destruct Z as [s [U' [H' Z]]]; move/eqP in Z.
      by rewrite -scaler_suml -linear_sum (eqLCSumsTo H H' U U')-{2}Z.
    Qed.
  End Results.

  Section Isomorphism.
    Export lmodBasis.Exports GRing.
    Variable (R : ringType) (M1 M2 : lmodType R) (f : linIsomType M1 M2)
    (B : type M1).
    Lemma inj_ : injective (f \o B).
    Proof. rewrite/comp=>x y H.
      move: (congr1 (inv(f)) H).
      rewrite !isomlK=>H2.
      apply (typeIsInjective H2).
    Qed.
    Lemma nondeg_ : non_degenerate (f \o B).
    Proof. move=>b.
      rewrite -(rwP negP) -(rwP eqP)=>H.
      move: (congr1 (inv(f)) H).
      rewrite !isomlK linear0 (rwP eqP)=>H2.
      move: (@typeIsNonDegenerate _ _ _ b).
      by rewrite H2.
    Qed.
    Definition bset := lmodSet.Build inj_ nondeg_.

    Lemma li_ : li bset.
    Proof. rewrite/bset=> C H.
      destruct C as [coef [c [U E]]].
      destruct H as [s [Us [H S]]].
      move:coef s Us E H S.
      rewrite /lmodSet.to_Type/=.
      move=>coef s Us E H S.
      rewrite fsFun.eqFSFun/=; clear c U E.

      move/eqP/(congr1 (isom_linmapI f)) in S; move:S.
      rewrite /comp linear_sum linear0.
      under eq_bigr do rewrite linearZ_LR/=(linIsom.isomfK f).
      rewrite(rwP eqP)=>/=S.

      have J : finSuppE coef.
      refine (ex_intro _ s _); split=>//.

      have K : lmodLCSumsTo (fsFun.Pack J) 0 by
      apply (ex_intro _ s (ex_intro _ Us (ex_intro _ H S))).

      move:(hasLI K); by rewrite eqFSFun.
    Qed.

    Lemma span_ : lmodBasis.span bset.
    Proof. move=>m; move: (hasSpanEq B (inv(f) m))=>X.
      destruct (hasSpanLC B (inv(f) m)) as [coef E].
      have FS: fsFun.finSuppE (B:=bset) coef by
      destruct E as [e [U F]];
      refine(ex_intro _ e _); split=>//.
      refine (exist _ (fsFun.Pack FS) _).
      destruct X as [c [U [D S]]].
      refine (ex_intro _ c (ex_intro _ U (ex_intro _ D _))).
      move/eqP/(congr1 f)/eqP in S; move:S.
      rewrite isomKl linear_sum.
      by under eq_bigr do rewrite linearZ.
    Qed.

    Definition isomorphicBasis : type M2
      := Build li_ span_.
  End Isomorphism.
End lmodBasis.
Export lmodBasis.Exports.

Notation "\basisProj_ b ^( B )" := (@lmodBasis.coef _ _ B b) : lmod_scope.

Module lmodFinSet.
  Section Def.
    Variable (R : ringType) (M : lmodType R).
    Record class (T : finType) := Class {
      base : lmodSet.mixin M T;
    }.

    Record type := Pack { sort : _; class_of : class sort; }.

    Definition Build {T : finType} (elem : T -> M) (I : injective elem) (ND : non_degenerate elem)
    := Pack (Class (lmodSet.Build I ND)).

    Section Seq.
      Variable (s : seq M) (H : all (fun m => m != 0) s).
      Definition elem_seq (t : seq_sub s) : M := ssval t.
      Lemma inj_seq : injective elem_seq.
        rewrite /elem_seq/==>x y W.
        by rewrite (rwP eqP)/eq_op/= W.
      Qed.
      Lemma nondeg_seq : non_degenerate elem_seq.
      Proof. rewrite/elem_seq/==>x.
        move:H=>H2; move/allP in H2.
        by move:(H2 (ssval x) (ssvalP x)).
      Qed.
      Definition seq := Build inj_seq nondeg_seq.
    End Seq.

    Section Lemmas.
      Variable (T : type).
      Definition to_set
      := lmodSet.Pack (base (class_of T)).

      Variable (n : nat) (K : n = size (enum (sort T))).
      Definition to_ord : sort T -> 'I_n :=
      eq_rect_r (fun n : nat => sort T -> 'I_n)
        (eq_rect #|sort T| (fun n : nat => sort T -> 'I_n)
          enum_rank (size (enum (sort T))) (cardT (sort T))) K.

      Definition from_ord : 'I_n -> sort T :=
      eq_rect_r (fun n : nat => 'I_n -> sort T)
        (eq_rect #|sort T| (fun n : nat => 'I_n -> sort T)
          enum_val (size (enum (sort T))) (cardT (sort T))) K.

      Lemma from_ordK : cancel to_ord from_ord.
      Proof. rewrite/to_ord/from_ord/eq_rect_r/eq_rect.
        destruct (cardT (sort T)), (Logic.eq_sym K)=>x.
        by rewrite enum_rankK.
      Qed.

      Lemma to_ordK : cancel from_ord to_ord.
      Proof. rewrite/to_ord/from_ord/eq_rect_r/eq_rect.
        destruct (cardT (sort T)), (Logic.eq_sym K)=>x.
        by rewrite enum_valK.
      Qed.
    End Lemmas.
  End Def.

  Module Exports.
    Notation lmodFinSetType := type.
    Notation to_FinType := sort.
    Coercion to_set : type >-> lmodSetType.
    Notation finBasis_to_ord := to_ord.
    Notation ord_to_finBasis := from_ord.
    Notation finBasis_to_ordK := to_ordK.
    Notation ord_to_finBasisK := from_ordK.
  End Exports.
End lmodFinSet.
Export lmodFinSet.Exports.

Module lmodFinBasis.
  Section Def.
    Variable (R : ringType) (M : lmodType R).
    Record mixin (T : lmodFinSetType M) := Mixin {
      base : lmodBasis.mixin T;
    }.

    Record type := Pack { sort : _; class_of : mixin sort; }.

    Definition Build (T : finType) (elem : T -> M)
    (I : injective elem) (ND : non_degenerate elem)
    (LI : lmodBasis.li (lmodFinSet.Build I ND))
    (Sp : lmodBasis.span (lmodFinSet.Build I ND))
    : type := Pack (Mixin (lmodBasis.Mixin LI Sp)).

    Definition basis_number (B : type) := #|(to_FinType (sort B))|.

    Lemma typeSpanning (T : type) : lmodBasis.span (sort T).
    Proof. destruct T as [t B], B as [B], B; apply spans. Qed.

    Lemma typeLI (T : type) : lmodBasis.li (sort T).
    Proof. destruct T as [t B], B as [B], B; apply is_li. Qed.
  End Def.

  Section To.
    Variable (R : ringType) (M : lmodType R).
    Definition to_lmodBasis (B : type M)
    := lmodBasis.Pack (base (class_of B)).
  End To.
  Section From.
    Variable (R : ringType) (M : lmodType R) (T : lmodBasisType M) (finClass : Finite.class_of T).

    Definition bset := @lmodFinSet.Build _ M (Finite.Pack finClass) T (@typeIsInjective _ _ T) (@typeIsNonDegenerate _ _ T).
    Lemma hasFinSuppP coef s : fsFun.hasSupport (B:=T) coef s <-> fsFun.hasSupport (R:=R) (B:=bset) coef s.
    Proof. split=>H b W; move:(H b W);
        [rewrite -(mem_map (f:=fun b : T => b : bset))| rewrite -(mem_map (f:=fun b : bset => b : T))];
        by [rewrite map_id | |rewrite map_id |].
    Qed.
    Lemma finSupp_uniqP s : @uniq (lmodSet.sort T) s <-> @uniq (lmodSet.sort bset) s.
    Proof. split=>U.
      by rewrite -(map_inj_in_uniq (f:=fun b : T => b : bset)) in U; [rewrite map_id in U|].
      by rewrite -(map_inj_in_uniq (f:=fun b : bset => b : T)) in U; [rewrite map_id in U|].
    Qed.

    Lemma finSuppP coef : fsFun.finSuppE (B:=T) coef <-> fsFun.finSuppE (R:=R) (B:=bset) coef.
    Proof. split=>H; destruct H as [s [U F]]; refine(ex_intro _ s _).
      move/finSupp_uniqP in U; split=>//.
      by move/hasFinSuppP in F.

      move/finSupp_uniqP in U; split=>//.
      by move/hasFinSuppP in F.
    Qed.

    Lemma lmodLCSumsToP (C : lmodLCType bset) (E : fsFun.finSuppE (B:=T) C) m
    : lmodLCSumsTo (B:=bset) C m <-> lmodLCSumsTo (fsFun.Pack E) m.
    rewrite/bset/=/lmodFinSet.to_set/=/lmodLCSumsTo/=.
    split=>H; destruct H as [s [U [H S]]];
    move/finSupp_uniqP in U;
    move/hasFinSuppP in H;
    apply (ex_intro _ s (ex_intro _ U (ex_intro _ H S))).
    Qed.

    Lemma li_ : lmodBasis.li bset.
    Proof.
      move=>/=C S.
      have E: fsFun.finSuppE (B := T) C.
      rewrite finSuppP.
      destruct C as [coef C].
      by apply C.
      move/(lmodLCSumsToP E) in S.
      move:(lmodBasis.hasLI S).
      by rewrite !lmodLC.eqFSFun.
    Qed.

    Lemma span_ : lmodBasis.span bset.
    Proof. move=>m.
      move: (lmodBasis.hasSpanEq T m)=>X.

      have E: fsFun.finSuppE (B := bset) (lmodBasis.hasSpanLC T m) by
      clear X;destruct (lmodBasis.hasSpanLC T m) as [coef C]=>/=;
      move/finSuppP in C.

      refine (exist _ (fsFun.Pack E) _).
      destruct X as [s [U [H S]]].
      move/finSupp_uniqP in U;
      move/hasFinSuppP in H;
      apply(ex_intro _ s (ex_intro _ U (ex_intro _ H S))).
    Qed.

    Definition from_lmodBasis : type M
    := Build li_ span_.
  End From.

  Module Exports.
    Notation basis_number := basis_number.
    Notation lmodFinBasisType := type.
    Coercion class_of : type >-> mixin.
    Coercion sort : type >-> lmodFinSetType.
    Coercion to_lmodBasis : type >-> lmodBasisType.
    Notation lmodBasis_to_finLmodBasis := from_lmodBasis.
    Notation lmodFinBasis_to_lmodBasis := to_lmodBasis.
  End Exports.

  Section Results.
    Export Exports GRing.
    Variable (R : ringType) (M : lmodType R) (B : type M) (x : M).
    Lemma hasSupport_enum: hasSupport (lmodBasis.hasSpanLC B x) (enum B).
    Proof. move=>b B'; by rewrite mem_enum. Qed.

    End Results.
End lmodFinBasis.
Export lmodFinBasis.Exports.

Close Scope ring_scope.


(* ---------------------------------------------------------------------
   This file contains definitions and proof scripts related to
   (i) closure operations for context-free grammars,
   (ii) context-free grammars simplification
   (iii) context-free grammar Chomsky normalization and
   (iv) pumping lemma for context-free languages.

   More information can be found in the paper "Formalization of the
   Pumping Lemma for Context-Free Languages", submitted to JFR.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - UNIT RULES                                           *)
(* --------------------------------------------------------------------- *)

Require Import List.
Require Import Ring.
Require Import Omega.

Require Import misc_arith.
Require Import misc_list.
Require Import cfg.
Require Import useless.

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

Import ListNotations.
Open Scope list_scope.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - UNIT RULES - DEFINITIONS                             *)
(* --------------------------------------------------------------------- *)

Section UnitRules.

Variables terminal non_terminal: Type.
Notation sf := (list (non_terminal + terminal)).
Notation sentence := (list terminal).
Notation term_lift:= ((terminal_lift non_terminal) terminal).
Notation nlist:= (list non_terminal).
Notation tlist:= (list terminal).

Inductive unit (g: cfg non_terminal terminal) (a: non_terminal): non_terminal -> Prop:=
| unit_rule: forall (b: non_terminal),
             rules g a [inl b] -> unit g a b
| unit_trans: forall b c: non_terminal,
              unit g a b ->
              unit g b c ->
              unit g a c.

Inductive g_unit_rules (g: cfg _ _): non_terminal -> sf -> Prop :=
| Lift_direct' :
       forall left: non_terminal,
       forall right: sf,
       (forall r: non_terminal,
       right <> [inl r]) -> rules g left right ->
       g_unit_rules g left right
| Lift_indirect':
       forall a b: non_terminal,
       unit g a b ->
       forall right: sf,
       rules g b right ->
       (forall c: non_terminal,
       right <> [inl c]) ->
       g_unit_rules g a right.

Lemma unit_exists_right:
forall g: cfg _ _,
forall a b: non_terminal,
unit g a b ->
exists c : sf, rules g a c.
Proof.
intros g a b H.
induction H.
- exists [inl b].
  exact H.
- exact IHunit1.
Qed.

Lemma unit_exists_left:
forall g: cfg _ _,
forall a c: non_terminal,
unit g a c ->
exists b : non_terminal, rules g a [inl b].
Proof.
intros g a c H.
induction H.
- exists b.
  exact H.
- exact IHunit1.
Qed.

Lemma g_unit_finite:
forall g: cfg _ _,
exists n: nat,
exists ntl: nlist,
exists tl: tlist,
In (start_symbol g) ntl /\
forall left: non_terminal,
forall right: sf,
g_unit_rules g left right ->
(length right <= n) /\
(In left ntl) /\
(forall s: non_terminal, In (inl s) right -> In s ntl) /\
(forall s: terminal, In (inr s) right -> In s tl).
Proof.
intros g.
destruct (rules_finite g) as [n [ntl [tl H1]]].
exists n, ntl, tl.
split.
- destruct H1 as [H1 _].
  exact H1.
- destruct H1 as [_ H1].
  intros left right H2.
  inversion H2.
  + subst.
    specialize (H1 left right H0).
    destruct H1 as [H4 [H5 H6]].
    split.
    * exact H4.
    * {
      split.
      - exact H5.
      - exact H6.
      }
  + subst.
    apply unit_exists_right in H.
    destruct H as [c H4].
    split.
    * specialize (H1 b right H0).
      destruct H1 as [H1 _].
      exact H1.
    * {
      split.
      - specialize (H1 left c H4).
        destruct H1 as [_ [H1 _]].
        exact H1.
      - specialize (H1 b right H0).
        destruct H1 as [_ [_ H1]].
        exact H1.
      }
Qed.

Definition g_unit (g: cfg _ _): cfg _ _ := {|
start_symbol:= start_symbol g;
rules:= g_unit_rules g;
t_eqdec:= t_eqdec g;
nt_eqdec:= nt_eqdec g;
rules_finite:= g_unit_finite g
|}.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - UNIT RULES - LEMMAS AND THEOREMS                     *)
(* --------------------------------------------------------------------- *)

Lemma unit_not_unit:
forall g: cfg _ _,
forall a b: non_terminal,
~ unit (g_unit g) a b.
Proof.
intros g a0 b0 H.
induction H.
- inversion H.
  + specialize (H0 b).
    destruct H0.
    reflexivity.
  + specialize (H2 b).
    destruct H2.
    reflexivity.
- exact IHunit1.
Qed.

Lemma unit_derives:
forall g: cfg _ _,
forall a b: non_terminal,
unit g a b ->
derives g [inl a] [inl b].
Proof.
intros g a b H.
induction H.
- apply derives_start.
  exact H.
- apply derives_trans with (s2:=[inl b]).
  + exact IHunit1.
  + exact IHunit2.
Qed.

Lemma rules_g_unit_g:
forall g: cfg _ _,
forall left: non_terminal,
forall right: sf,
rules (g_unit g) left right ->
rules g left right \/ derives g [inl left] right.
Proof.
intros g left right H.
simpl in H.
inversion H.
- left.
  exact H1.
- right.
  subst.
  replace right with ([] ++ right ++ []).
  + apply derives_step with (left:=b).
    * apply unit_derives in H0.
      exact H0.
    * exact H1.
  + rewrite app_nil_l.
    rewrite app_nil_r.
    reflexivity.
Qed.

Lemma rules_g_unit_g':
forall g: cfg _ _,
forall left: non_terminal,
forall right: sf,
rules (g_unit g) left right ->
rules g left right \/
exists left': non_terminal, unit g left left' /\ rules g left' right.
Proof.
intros g left right H.
inversion H.
- left.
  exact H1.
- right.
  exists b.
  split.
  + exact H0.
  + exact H1.
Qed.

Lemma rules_g_unit_not_unit:
forall g: cfg _ _,
forall left: non_terminal,
forall right: sf,
(rules (g_unit g) left right) ->
(~ exists n: non_terminal, right = [inl n]).
Proof.
intros g left right H1 H2.
inversion H1.
- subst.
  destruct H2 as [n H2].
  specialize (H n).
  contradiction.
- subst.
  destruct H2 as [n H2].
  specialize (H3 n).
  contradiction.
Qed.

Lemma generates_g_unit_g:
forall g: cfg _ _,
forall s: sf,
generates (g_unit g) s -> generates g s.
Proof.
unfold generates.
intros g s H.
simpl in H.
remember [inl (start_symbol g)] as w1.
induction H.
- apply derives_refl.
- apply rules_g_unit_g in H0.
  destruct H0 as [H0 | H0].
  + apply derives_step with (left:=left).
    * apply IHderives.
      exact Heqw1.
    * exact H0.
  + apply derives_subs with (s3:=[inl left]).
    * apply IHderives.
      exact Heqw1.
    * exact H0.
Qed.

Lemma rules_g_g_unit:
forall g: cfg _ _,
forall left: non_terminal,
forall right: sf,
rules g left right ->
(forall n: non_terminal, right <> [inl n]) ->
rules (g_unit g) left right.
Proof.
intros g left right H1 H2.
simpl.
apply Lift_direct'.
- exact H2.
- exact H1.
Qed.

Lemma derives3_g_g_unit:
forall g: cfg _ _,
forall n: non_terminal,
forall s: sentence,
derives3 g n s -> derives3 (g_unit g) n s.
Proof.
intros g.
intros n s H.
apply derives3_ind_2 with (g:=g) (P:=derives3 (g_unit g)) (P0:=derives3_aux (g_unit g)).
- intros n0 lt H1.
  apply derives3_rule.
  apply rules_g_g_unit in H1.
  + exact H1.
  + destruct lt; discriminate.
- intros n0 ltnt lt H1 H2 H3.
  destruct ltnt.
  + apply rules_g_g_unit in H1.
    * inversion H2.
      subst.
      apply derives3_rule.
      exact H1.
    * discriminate.
  + destruct ltnt.
    * {
      destruct s0.
      - apply exists_rule_derives3_aux in H2.
        destruct H2 as [H2 | H2].
        + assert (H10: rules (g_unit g) n0 (map term_lift lt)).
            {
            apply Lift_indirect' with (b:=n1).
            * apply unit_rule.
              exact H1.
            * exact H2.
            * destruct lt; discriminate.
            }
          apply derives3_rule.
          exact H10.
        + destruct H2 as [right [H4 H5]].
          apply exists_rule_derives3_aux in H3.
          destruct H3 as [H3 | H3].
          * apply rules_g_unit_g' in H3.
            {
            destruct H3 as [H3 | H3].
            - assert (H10: rules (g_unit g) n0 (map term_lift lt)).
                {
                apply Lift_indirect' with (b:=n1).
                - apply unit_rule.
                  exact H1.
                - exact H3.
                - intros c0.
                  destruct lt.
                  + discriminate.
                  + discriminate.
                }
              apply derives3_rule.
              exact H10.
            - destruct H3 as [left' [H6 H7]].
              assert (H10: rules (g_unit g) n0 (map term_lift lt)).
                {
                apply Lift_indirect' with (b:=left').
                - apply unit_trans with (b:=n1).
                  + apply unit_rule.
                    exact H1.
                  + exact H6.
                - exact H7.
                - intros c0.
                  destruct lt; discriminate.
                }
              apply derives3_rule.
              exact H10.
            }
          * destruct H3 as [right0 [H6 H7]].
            assert (H6':=H6).
            apply rules_g_unit_not_unit in H6'.
            apply rules_g_unit_g' in H6.
            {
            destruct H6 as [H6 | H6].
            - apply derives3_step with (ltnt:=right0).
              + apply Lift_indirect' with (b:=n1).
                * apply unit_rule.
                  exact H1.
                * exact H6.
                * apply not_exists_forall_not.
                  exact H6'.
              + exact H7.
            - apply derives3_step with (ltnt:=right0).
              + destruct H6 as [left' [H8 H9]].
                apply Lift_indirect' with (b:=left').
                * {
                  apply unit_trans with (b:=n1).
                  - apply unit_rule.
                    exact H1.
                  - exact H8.
                  }
                * exact H9.
                * apply not_exists_forall_not.
                  exact H6'.
              + exact H7.
            }
      - apply rules_g_g_unit in H1.
        + apply derives3_step with (ltnt:=[inr t]).
          * exact H1.
          * exact H3.
        + discriminate.
      }
    * {
      apply rules_g_g_unit in H1.
      - apply derives3_step with (ltnt:=(s0 :: s1 :: ltnt)).
        + exact H1.
        + exact H3.
      - discriminate.
      }
- apply derives3_aux_empty.
- intros t ltnt lt H1 H2.
  apply derives3_aux_t.
  exact H2.
- intros n0 lt lt' ltnt H1 H2 H3 H4.
  apply derives3_aux_nt.
  + exact H2.
  + exact H4.
- exact H.
Qed.

Lemma derives_g_g_unit:
forall g: cfg _ _,
forall s: sentence,
forall n: non_terminal,
derives g [inl n] (map term_lift s) -> derives (g_unit g) [inl n] (map term_lift s).
Proof.
intros g s n.
repeat rewrite derives_equiv_derives3.
apply derives3_g_g_unit.
Qed.

Theorem g_equiv_unit:
forall g: cfg _ _,
g_equiv (g_unit g) g.
Proof.
unfold g_equiv.
unfold produces.
intros g s.
split.
- apply generates_g_unit_g.
- apply derives_g_g_unit.
Qed.

Definition has_no_unit_rules (g: cfg _ _): Prop:=
forall left n: non_terminal,
forall right: sf,
rules g left right -> right <> [inl n].

Lemma g_unit_has_no_unit_rules:
forall g: cfg _ _,
has_no_unit_rules (g_unit g).
Proof.
unfold has_no_unit_rules.
intros g left n right H.
destruct right.
- apply nil_cons.
- inversion_clear H.
  + specialize (H0 n).
    exact H0.
  + specialize (H2 n).
    exact H2.
Qed.

Theorem g_unit_correct:
forall g: cfg _ _,
g_equiv (g_unit g) g /\
has_no_unit_rules (g_unit g).
Proof.
intros g.
split.
- apply g_equiv_unit.
- apply g_unit_has_no_unit_rules.
Qed.

End UnitRules.


Require Import Sets.

Definition Monotonic {L:Set} (rel:L->L->Prop) (f:L->L) := forall x y, rel x y -> rel (f x) (f y).

Definition Compatible {L:Set} (f:L->L) (S: Pow L) := forall x, x ∈ S -> (f x) ∈ S.


Require Export ifTf.

(** This library defines a theorem [IFIDEMP] and its proof. Notice that we use [#] (resp. [##]) for [message] (resp. [Bool]) in lieu of [=].

 [if b then (if b then x1 else y1) else (if b then x2 else y2) # if b then x1 else y2] *)

Theorem IFIDEMP_B : forall (n: nat)(b1 b2 b3 b4 : Bool), (IF (Bvar n) then (IF (Bvar n) then b1 else b2) else (IF (Bvar n) then b3 else b4)) ## (IF (Bvar n) then b1 else b4).
Proof.
intros n b1 b2 b3 b4.
rewrite IFEVAL_B with (b1:= IF (Bvar n) then b1 else b2)(b2 := (IF (Bvar n) then b3 else b4)) .
simpl.
rewrite <-beq_nat_refl.
rewrite IFTRUE_B.
rewrite IFFALSE_B.
rewrite IFEVAL_B with(b2:=b4).
reflexivity.
Qed.

Theorem IFIDEMP_M : forall (n: nat)(x1 x2 y1 y2 : message),  (If (Bvar n) then (If (Bvar n) then x1 else y1) else (If (Bvar n) then x2 else y2)) # (If (Bvar n) then x1 else y2).
Proof.
intros n x1 x2 y1 y2 .
rewrite IFEVAL_M with (t1:= If (Bvar n) then x1 else y1)(t2 := (If (Bvar n) then x2 else y2)) .
simpl.
rewrite <-beq_nat_refl.
rewrite IFTRUE_M.
rewrite IFFALSE_M.
rewrite IFEVAL_M with (t2:=y2).
reflexivity.
Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.
Require int.ComputerDivision.
Require number.Parity.

(* Hack so that Why3 does not override the notation below.

(* Why3 assumption *)
Definition divides (d:Z) (n:Z): Prop := exists q:Z, (n = (q * d)%Z).

*)

Require Import Znumtheory.
Notation divides := Zdivide (only parsing).

(* Why3 goal *)
Lemma divides_refl : forall (n:Z), (divides n n).
Proof.
exact Zdivide_refl.
Qed.

(* Why3 goal *)
Lemma divides_1_n : forall (n:Z), (divides 1%Z n).
Proof.
exact Zone_divide.
Qed.

(* Why3 goal *)
Lemma divides_0 : forall (n:Z), (divides n 0%Z).
Proof.
exact Zdivide_0.
Qed.

(* Why3 goal *)
Lemma divides_left : forall (a:Z) (b:Z) (c:Z), (divides a b) -> (divides
  (c * a)%Z (c * b)%Z).
Proof.
exact Zmult_divide_compat_l.
Qed.

(* Why3 goal *)
Lemma divides_right : forall (a:Z) (b:Z) (c:Z), (divides a b) -> (divides
  (a * c)%Z (b * c)%Z).
Proof.
exact Zmult_divide_compat_r.
Qed.

(* Why3 goal *)
Lemma divides_oppr : forall (a:Z) (b:Z), (divides a b) -> (divides a (-b)%Z).
Proof.
exact Zdivide_opp_r.
Qed.

(* Why3 goal *)
Lemma divides_oppl : forall (a:Z) (b:Z), (divides a b) -> (divides (-a)%Z b).
Proof.
exact Zdivide_opp_l.
Qed.

(* Why3 goal *)
Lemma divides_oppr_rev : forall (a:Z) (b:Z), (divides (-a)%Z b) -> (divides a
  b).
Proof.
exact Zdivide_opp_l_rev.
Qed.

(* Why3 goal *)
Lemma divides_oppl_rev : forall (a:Z) (b:Z), (divides a (-b)%Z) -> (divides a
  b).
Proof.
exact Zdivide_opp_r_rev.
Qed.

(* Why3 goal *)
Lemma divides_plusr : forall (a:Z) (b:Z) (c:Z), (divides a b) -> ((divides a
  c) -> (divides a (b + c)%Z)).
Proof.
exact Zdivide_plus_r.
Qed.

(* Why3 goal *)
Lemma divides_minusr : forall (a:Z) (b:Z) (c:Z), (divides a b) -> ((divides a
  c) -> (divides a (b - c)%Z)).
Proof.
exact Zdivide_minus_l.
Qed.

(* Why3 goal *)
Lemma divides_multl : forall (a:Z) (b:Z) (c:Z), (divides a b) -> (divides a
  (c * b)%Z).
Proof.
intros a b c.
apply Zdivide_mult_r.
Qed.

(* Why3 goal *)
Lemma divides_multr : forall (a:Z) (b:Z) (c:Z), (divides a b) -> (divides a
  (b * c)%Z).
Proof.
exact Zdivide_mult_l.
Qed.

(* Why3 goal *)
Lemma divides_factorl : forall (a:Z) (b:Z), (divides a (b * a)%Z).
Proof.
exact Zdivide_factor_l.
Qed.

(* Why3 goal *)
Lemma divides_factorr : forall (a:Z) (b:Z), (divides a (a * b)%Z).
Proof.
exact Zdivide_factor_r.
Qed.

(* Why3 goal *)
Lemma divides_n_1 : forall (n:Z), (divides n 1%Z) -> ((n = 1%Z) \/
  (n = (-1%Z)%Z)).
Proof.
exact Zdivide_1.
Qed.

(* Why3 goal *)
Lemma divides_antisym : forall (a:Z) (b:Z), (divides a b) -> ((divides b
  a) -> ((a = b) \/ (a = (-b)%Z))).
Proof.
exact Zdivide_antisym.
Qed.

(* Why3 goal *)
Lemma divides_trans : forall (a:Z) (b:Z) (c:Z), (divides a b) -> ((divides b
  c) -> (divides a c)).
Proof.
exact Zdivide_trans.
Qed.

(* Why3 goal *)
Lemma divides_bounds : forall (a:Z) (b:Z), (divides a b) -> ((~ (b = 0%Z)) ->
  ((ZArith.BinInt.Z.abs a) <= (ZArith.BinInt.Z.abs b))%Z).
Proof.
exact Zdivide_bounds.
Qed.

Import EuclideanDivision.

(* Why3 goal *)
Lemma mod_divides_euclidean : forall (a:Z) (b:Z), (~ (b = 0%Z)) ->
  (((int.EuclideanDivision.mod1 a b) = 0%Z) -> (divides b a)).
Proof.
intros a b Zb H.
exists (div a b).
rewrite (Div_mod a b Zb) at 1.
rewrite H.
ring.
Qed.

(* Why3 goal *)
Lemma divides_mod_euclidean : forall (a:Z) (b:Z), (~ (b = 0%Z)) -> ((divides
  b a) -> ((int.EuclideanDivision.mod1 a b) = 0%Z)).
Proof.
intros a b Zb H.
assert (Zmod a b = Z0).
now apply Zdivide_mod.
unfold mod1, div.
rewrite H0.
case Z_le_dec ; intros H1.
rewrite (Z_div_exact_full_2 a b Zb H0) at 1.
apply Zminus_diag.
now elim H1.
Qed.

(* Why3 goal *)
Lemma mod_divides_computer : forall (a:Z) (b:Z), (~ (b = 0%Z)) ->
  (((ZArith.BinInt.Z.rem a b) = 0%Z) -> (divides b a)).
Proof.
intros a b Zb H.
exists (Z.quot a b).
rewrite Zmult_comm.
now apply Zquot.Z_quot_exact_full.
Qed.

(* Why3 goal *)
Lemma divides_mod_computer : forall (a:Z) (b:Z), (~ (b = 0%Z)) -> ((divides b
  a) -> ((ZArith.BinInt.Z.rem a b) = 0%Z)).
Proof.
intros a b Zb (q,H).
rewrite H.
apply Zquot.Z_rem_mult.
Qed.

(* Why3 goal *)
Lemma even_divides : forall (a:Z), (number.Parity.even a) <-> (divides 2%Z
  a).
Proof.
split ;
  intros (q,H) ; exists q ; now rewrite Zmult_comm.
Qed.

(* Why3 goal *)
Lemma odd_divides : forall (a:Z), (number.Parity.odd a) <-> ~ (divides 2%Z
  a).
Proof.
split.
intros H.
contradict H.
apply Parity.even_not_odd.
now apply <- even_divides.
intros H.
destruct (Parity.even_or_odd a).
elim H.
now apply -> even_divides.
exact H0.
Qed.


Require Export Eqdep.

Section update_def.
Variables (A : Type) (A_eq_dec : forall (x y : A),  { x = y } + { x <> y }).
Variables (B : A ->  Type) (a : A) (v : B a) (f : forall (x : A),  B x).

Definition update (x : A) : B x :=
   match A_eq_dec a x with
    | left h => eq_rect a B v x h
    | right h' => f x
   end.

End update_def.

Theorem update_eq:
 forall (A : Type) (eq_dec : forall (x y : A),  { x = y } + { x <> y })
        (B : A ->  Type) (a : A) (v : B a) (f : forall (x : A),  B x),
  update A eq_dec B a v f a = v.
Proof.
intros A eq_dec B a v f.
unfold update;case (eq_dec a a).
- intros e; rewrite <- eq_rect_eq;auto.
- intros Hneq; elim Hneq; trivial.
Qed.


(* Every Isabelle constant has prefix I *)
(* just from IFOL.thy *)
(* Q : What's class "term"? *)

(* Should A be set or type or sth else? *)
Notation tip := Set.

(* TODO: Define "Pointed set" type...
Inductive PSet :=
| C (S:Set) (s:S) : PSet *)

Inductive o :=
(* Equality *)
| Ieq (A:tip) : A -> A -> o
(* Propositional logic *)
| IFalse : o
| Iconj : o -> o -> o
| Iimp : o -> o -> o
(*| IAll (A:tip) : A -> A -> o*)
.

Inductive prop :=
| ITrueprop : o -> prop
| Iimpl : prop -> prop -> prop
| Iall (A:tip) : (A->prop) -> prop
.

(* Isabelle's judgement == Coq's Coercion? *)
Coercion tp := ITrueprop.

(* TODO: add context! *)
Inductive Prf : prop -> Type :=
(* Metalogic *)
| A1 A B :  Prf (Iimpl A (Iimpl B A))
| A2 A B C :  Prf (
Iimpl (Iimpl A (Iimpl B C)) (Iimpl (Iimpl A B) (Iimpl A C))
)
| MP A B : Prf (Iimpl A B) -> Prf A -> Prf B
(* |  assu P : Prf (Iimpl P P) *)
(* Object logic *)
(* Equality *)
| Irefl : forall (A:tip) (a:A),
   Prf (Ieq A a a)
| Isubst : forall (A:tip) (a b:A) (P:A -> o),
   Prf (Ieq A a b) -> Prf (P a) -> Prf (P b)
(* Propositional logic *)
| IimpI : forall (P Q : o),
   Prf (Iimpl P Q) -> Prf (Iimp P Q)
| Imp : forall (P Q : o),
   Prf (Iimp P Q) -> Prf P -> Prf Q
.

Inductive PrfCtx (G : prop -> Type): prop -> Type :=
| ctx p : PrfCtx G p
| ax p : Prf p -> PrfCtx G p
.

(*
Inductive WithMP (G : prop -> Type): prop -> Type :=
| Imp : forall (P Q : o),
   WithMP (Iimp P Q) -> WithMP P -> WithMP Q
*)

Theorem Deduction (P Q:prop) (H : Prf P -> Prf Q)
:  Prf (Iimpl P Q).
Proof.
Abort.
(*
Context (P:prop).
Check A2 P P P.*)

(* The following is useful when one does not use context:
(as it possibly done in Isabelle) *)
Theorem assu P : Prf (Iimpl P P).
Proof.
refine (MP _ _ _ _).
refine (MP _ _ _ _).
refine (A2 P (Iimpl P P) P).
refine (A1 _ _).
refine (A1 _ _).
Defined.

Theorem dropL P Q : Prf Q -> Prf (Iimpl P Q).
Proof.
intro H.
refine (MP _ _ _ _).
refine (A1 _ _).
assumption.
Defined.

Theorem dropR P Q R : Prf (Iimpl P R)
 -> Prf (Iimpl P (Iimpl Q R)).
Proof.
refine (MP _ _ _).
refine (MP _ _ _ _).
refine (A2 _ _ _).
refine (dropL _ _ _).
refine (A1 _ _).
Defined.

(* Simple theorems: *)
Definition ITrue : o := Iimp IFalse IFalse.
Theorem TrueI: Prf ITrue.
Proof.
unfold ITrue.
apply IimpI.
apply assu.
Defined.
(*--------------------------*)
(* What if "inductive extension"? *)
(*
Axiom elems : forall A:Type, A -> Type.
*)

Inductive bigunion {A} (f:A -> Type) : Type :=
| c : forall n : A, f n -> bigunion f
. (* exists *)

(*| z : f 0 -> bigunion
| s : forall n : nat,  *)

Fixpoint q (n:nat) :=


Require Import BenB.

Variable X: R -> Prop.
Variable Y: R -> Prop.

Theorem getallen_003 :
  (Y 0)
->
    (forall t:R, Y t -> (forall u:R, u>=t+2 -> X u))
  ->
    (forall t:R, t>=3 -> X t).
Proof.
imp_i a1.
imp_i a2.
all_i a.
imp_i a3.
imp_e (a >= 0+2).
all_e (forall u:R, u >= 0 + 2 -> X u) a.
imp_e (Y 0).
all_e (forall t : R, Y t -> forall u : R, u >= t + 2 -> X u) 0.
hyp a2.
hyp a1.
lin_solve.
Qed.


(* Rule Evaluator Helper Functions *)

Require Import Nat.
Require Import QArith.

(* Q type less than -> bool *)

Definition Qlt (a b : Q) : bool := (Qle_bool a b) &&  negb (Qeq_bool a b).

(* Q type greater than -> bool *)

Definition Qgt (a b : Q) : bool := negb (Qle_bool a b) &&  negb (Qeq_bool a b).

(* nat type greater than -> bool *)

Definition gtr_nat (a b : nat) : bool := negb (Nat.leb a b) && negb (beq_nat a b).