Require Export Basics_J.

Set Asymmetric Patterns.

Inductive
  boollist : Type :=
| bool_nil : boollist
| bool_cons : bool -> boollist -> boollist.

Inductive list (X : Type) : Type :=
| nil : list X
| cons : X -> list X -> list X.

Check nil.
Check nil nat.
Check cons.
Check (cons nat 2 (cons nat 1 (nil nat))).

Fixpoint length (X : Type) (l : list X) : nat :=
  match l with
  | nil => 0
  | cons h t => S (length X t)
  end.

Example test_length1 :
  length nat (cons nat 1 (cons nat 2 (nil nat))) = 2.
Proof. reflexivity.  Qed.

Example test_length2 :
  length bool (cons bool true (nil bool)) = 1.
Proof. reflexivity.  Qed.

Fixpoint app (X : Type) (l1 l2 : list X) : list X :=
  match l1 with
  | nil => l2
  | cons h t => cons X h (app X t l2)
  end.

Fixpoint snoc (X : Type) (l : list X) (v : X) : list X :=
  match l with
  | nil => cons X v (nil X)
  | cons h t => cons X h (snoc X t v)
  end.

Fixpoint rev (X : Type) (l : list X) : list X :=
  match l with
  | nil => nil X
  | cons h t => snoc X (rev X t) h
  end.

Example test_rev1 :
  rev nat (cons nat 1 (cons nat 2 (nil nat)))
  = (cons nat 2 (cons nat 1 (nil nat))).
Proof. reflexivity.  Qed.

Example test_rev2:
  rev bool (nil bool) = nil bool.
Proof. reflexivity.  Qed.

Fixpoint app' X l1 l2 : list X :=
  match l1 with
  | nil => l2
  | cons h t => cons X h (app' X t l2)
  end.

Check app'.
Check app.

Fixpoint length' (X : Type) (l : list X) : nat :=
  match l with
  | nil => 0
  | cons h t => S (length' _ t)
  end.

Arguments nil [X].
Arguments cons [X].
Arguments length [X].
Arguments app [X].
Arguments rev [X].
Arguments snoc [X].

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).
Check (length list123'').

Fixpoint length'' {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons h t => S (length'' t)
  end.

Definition mynil : list nat := nil.
Check @nil.
Check nil.
Definition mynil' := @nil nat.

Notation "x :: y" := (cons x y)
                       (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                       (at level 60, right associativity).

Definition list123''' := [1, 2, 3].
Eval simpl in list123'''.
Check list123'''.

Fixpoint repeat (X : Type) (n : X) (count : nat) : list X :=
  match count with
  | 0 => nil
  | S count' => cons n (repeat X n count')
  end.

Example test_repeat1:
  repeat bool true 2 = cons true (cons true nil).
Proof. reflexivity. Qed.

Theorem nil_app : forall X : Type, forall l : list X,
      app [] l = l.
Proof. reflexivity. Qed.

Theorem rev_snoc : forall X : Type, forall v : X, forall s : list X,
        rev (snoc s v) = v :: (rev s).
Proof.
  intros. induction s as [| v' s'].
  Case "s = nil".
    reflexivity.
  Case "s = v' :: s'".
    simpl. rewrite -> IHs'. reflexivity. Qed.

Theorem snoc_with_append : forall X : Type, forall l1 l2 : list X, forall v : X,
        snoc (l1 ++ l2) v = l1 ++ (snoc l2 v).
Proof.
  intros. induction l1 as [| v' l1'].
  Case "l1 = nil".
    reflexivity.
  Case "l1 = v' :: l1'".
    simpl. rewrite -> IHl1'. reflexivity. Qed.

Inductive prod (X Y : Type) : Type :=
  pair : X -> Y -> prod X Y.

Arguments pair [X] [Y].

Notation "( x , y )" := (pair x y).

Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with (x, y) => x end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with (x, y) => y end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y) : list (X * Y) :=
  match (lx, ly) with
  | ([], _) => []
  | (_, []) => []
  | (x :: tx, y :: ty) => (x, y) :: (combine tx ty)
  end.

Fixpoint combine' {X Y : Type} (lx : list X) (ly : list Y) : list (X * Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

Fixpoint split {X Y : Type} (ps : list (X * Y)) : (list X * list Y) :=
  match ps with
  | [] => ([], [])
  | (x, y) :: ps' => match split ps' with
                   | (xs, ys) => (x :: xs, y :: ys)
                   end
  end.

Example test_split:
  split [(1,false),(2,false)] = ([1,2],[false,false]).
Proof. reflexivity.  Qed.

Inductive option (X : Type) : Type :=
| Some : X -> option X
| None : option X.

Arguments Some [X].
Arguments None [X].

Fixpoint index {X : Type} (n : nat) (l : list X) : option X :=
  match l with
  | [] => None
  | a :: l' => if beq_nat n O then Some a else index (pred n) l'
  end.

Example test_index1 :    index 0 [4,5,6,7]  = Some 4.
Proof. reflexivity.  Qed.
Example test_index2 :    index  1 [[1],[2]]  = Some [2].
Proof. reflexivity.  Qed.
Example test_index3 :    index  2 [true]  = None.
Proof. reflexivity.  Qed.

Definition hd_opt {X : Type} (l : list X) : option X := index 0 l.

Check @hd_opt.

Example test_hd_opt1 :  hd_opt [1,2] = Some 1.
Proof. reflexivity.  Qed.
Example test_hd_opt2 :   hd_opt  [[1],[2]]  = Some [1].
Proof. reflexivity.  Qed.

Definition doit3times {X : Type} (f : X -> X) (n : X) : X :=
  f (f (f n)).

Check @doit3times.

Example test_doit3times: doit3times minustwo 9 = 3.
Proof. reflexivity.  Qed.

Example test_doit3times': doit3times negb true = false.
Proof. reflexivity.  Qed.

Check plus.

Definition plus3 := plus 3.
Check plus3.

Example test_plus3 :    plus3 4 = 7.
Proof. reflexivity.  Qed.
Example test_plus3' :   doit3times plus3 0 = 9.
Proof. reflexivity.  Qed.
Example test_plus3'' :  doit3times (plus 3) 0 = 9.
Proof. reflexivity.  Qed.

Definition prod_curry {X Y Z : Type} (f : X * Y -> Z) (x : X) (y : Y) : Z :=
  f (x, y).

Definition prod_uncurry {X Y Z : Type}
           (f : X -> Y -> Z) (p : X * Y) : Z := f (fst p) (snd p).

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type) (f : X -> Y -> Z) x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
  intros. reflexivity. Qed.

Theorem curry_uncurry : forall (X Y Z : Type)
                               (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
  intros. destruct p. reflexivity. Qed.

Fixpoint filter {X : Type} (test : X -> bool) (l : list X) : list X :=
  match l with
  | [] => []
  | h :: t => if test h then h :: (filter test t)
              else filter test t
  end.

Example test_filter1: filter evenb [1,2,3,4] = [2,4].
Proof. reflexivity.  Qed.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  beq_nat (length l) 1.

Example test_filter2:
    filter length_is_1
           [ [1, 2], [3], [4], [5,6,7], [], [8] ]
  = [ [3], [4], [8] ].
Proof. reflexivity.  Qed.

Definition countoddmembers' (l : list nat) : nat :=
  length (filter oddb l).

Example test_countoddmembers'1:   countoddmembers' [1,0,3,1,4,5] = 4.
Proof. reflexivity.  Qed.
Example test_countoddmembers'2:   countoddmembers' [0,2,4] = 0.
Proof. reflexivity.  Qed.
Example test_countoddmembers'3:   countoddmembers' nil = 0.
Proof. reflexivity.  Qed.

Example test_anon_fun':
  doit3times (fun n => n * n) 2 = 256.
Proof. reflexivity.  Qed.

Example test_filter2':
    filter (fun l => beq_nat (length l) 1)
           [ [1, 2], [3], [4], [5,6,7], [], [8] ]
  = [ [3], [4], [8] ].
Proof. reflexivity.  Qed.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun n => andb (evenb n) (ble_nat 7 n)) l.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1,2,6,9,10,3,12,8] = [10,12,8].
Proof. reflexivity. Qed.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5,2,6,19,129] = [].
Proof. reflexivity. Qed.

Definition partition {X : Type} (test : X -> bool) (l : list X) : list X * list X :=
  (filter test l, filter (fun x => negb (test x)) l).

Example test_partition1: partition oddb [1,2,3,4,5] = ([1,3,5], [2,4]).
Proof. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5,9,0] = ([], [5,9,0]).
Proof. reflexivity. Qed.

Fixpoint map {X Y : Type} (f : X -> Y) (l : list X) : list Y :=
  match l with
  | [] => []
  | h :: t => f h :: (map f t)
  end.

Example test_map1: map (plus 3) [2,0,2] = [5,3,5].
Proof. reflexivity.  Qed.

Example test_map2: map oddb [2,1,2,5] = [false,true,false,true].
Proof. reflexivity.  Qed.

Example test_map3:
    map (fun n => [evenb n,oddb n]) [2,1,2,5]
  = [[true,false],[false,true],[true,false],[false,true]].
Proof. reflexivity.  Qed.

Theorem snoc_map : forall (X Y : Type) (f : X -> Y) (l : list X) (x : X),
    map f (snoc l x) = snoc (map f l) (f x).
Proof.
  intros. induction l as [| x' l'].
  Case "l = []".
    reflexivity.
  Case "l = x' :: l'".
    simpl. rewrite -> IHl'. reflexivity. Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
    map f (rev l) = rev (map f l).
Proof.
  intros. induction l as [| x l'].
  Case "n = []".
    reflexivity.
  Case "n = x :: l'".
    simpl. rewrite <- IHl'. apply snoc_map. Qed.

Fixpoint flat_map {X Y:Type} (f:X -> list Y) (l:list X)
                   : (list Y) :=
  match l with
  | [] => []
  | h :: ts => (f h) ++ (flat_map f ts)
  end.

Example test_flat_map1:
  flat_map (fun n => [n,n,n]) [1,5,4]
  = [1, 1, 1, 5, 5, 5, 4, 4, 4].
Proof. reflexivity.  Qed.

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X) : option Y :=
  match xo with
  | None => None
  | Some x => Some (f x)
  end.

Fixpoint fold {X Y : Type} (f : X -> Y -> Y) (l : list X) (b : Y) : Y :=
  match l with
  | [] => b
  | h :: t => f h (fold f t b)
  end.

Check (fold plus).
Eval simpl in (fold plus [1,2,3,4] 0).

Example fold_example1 : fold mult [1,2,3,4] 1 = 24.
Proof. reflexivity. Qed.

Example fold_example2 : fold andb [true,true,false,true] true = false.
Proof. reflexivity. Qed.

Example fold_example3 : fold (@app nat) [[1],[],[2,3],[4]] [] = [1,2,3,4].
Proof. reflexivity. Qed.

Definition constfun {X : Type} (x : X) : nat -> X :=
  fun (k : nat) => x.

Definition ftrue := constfun true.

Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.

Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

Definition override {X : Type} (f : nat -> X) (k : nat) (x : X) : nat -> X :=
  fun (k' : nat) => if beq_nat k k' then x else f k'.

Definition fmostlytrue := override (override ftrue 1 false) 3 false.

Example override_example1 : fmostlytrue 0 = true.
Proof. reflexivity. Qed.

Example override_example2 : fmostlytrue 1 = false.
Proof. reflexivity. Qed.

Example override_example3 : fmostlytrue 2 = true.
Proof. reflexivity. Qed.

Example override_example4 : fmostlytrue 3 = false.
Proof. reflexivity. Qed.

Theorem override_example : forall (b:bool),
  (override (constfun b) 3 true) 2 = b.
(* すべての真偽値 b について、 3 を受け取った場合に true を返し、 そうでなければ b を返す関数を 2 に適用した結果は b である  *)
Proof. reflexivity. Qed.

Theorem unfold_example_bad : forall m n,
  3 + n = m ->
  plus3 n + 1 = m + 1.
Proof.
  intros m n H.
  unfold plus3.
  rewrite -> H.
  reflexivity. Qed.

Theorem override_eq : forall {X:Type} x k (f:nat->X),
  (override f k x) k = x.
Proof.
  intros X x k f.
  unfold override.
  rewrite <- beq_nat_refl.
  reflexivity.  Qed.

Theorem override_neq : forall {X:Type} x1 x2 k1 k2 (f : nat->X),
  f k1 = x1 ->
  beq_nat k2 k1 = false ->
  (override f k2 x2) k1 = x1.
Proof.
  intros X x1 x2 k1 k2 f H H'.
  unfold override.
  rewrite -> H'.
  apply H. Qed.

Theorem eq_add_S : forall (n m : nat),
     S n = S m ->
     n = m.
Proof.
  intros n m eq. inversion eq. reflexivity. Qed.

Theorem silly5 : forall (n m o : nat),
    [n,m] = [o,o] ->
    [n] = [m].
Proof.
  intros n m o eq. inversion eq. reflexivity. Qed.

Example sillyex1 : forall (X : Type) (x y z : X) (l j : list X),
     x :: y :: l = z :: j ->
     y :: l = x :: j ->
     x = y.
Proof.
  intros X x y z l j eq0 eq1. inversion eq1. reflexivity. Qed.

Theorem silly6 : forall (n : nat),
    S n = O ->
    2 + 2 = 5.
Proof.
  intros n contra. inversion contra. Qed.

Theorem silly7 : forall (n m : nat),
    false = true ->
    [n] = [m].
Proof.
  intros n m contra. inversion contra. Qed.

Example sillyex2 : forall (X : Type) (x y z : X) (l j : list X),
    x :: y :: l = [] ->
    y :: l = z :: j ->
    x = z.
Proof.
  intros X x y z l j eq0 eq1. inversion eq0. Qed.

Lemma eq_remove_S : forall n m,
    n = m -> S n = S m.
Proof. intros n m eq. rewrite -> eq. reflexivity. Qed.

Theorem beq_nat_eq : forall n m,
    true = beq_nat n m -> n = m.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".
    intros m. destruct m as [| m'].
    SCase "m = 0". reflexivity.
    SCase "m = S m'". simpl. intros contra. inversion contra.
  Case "n = n'".
    intros m. destruct m as [| m'].
    SCase "m = 0". simpl. intros contra. inversion contra.
    SCase "m = S m'". simpl. intros H.
      apply eq_remove_S. apply IHn'. apply H. Qed.

Theorem beq_nat_eq' : forall m n,
  beq_nat n m = true -> n = m.
Proof.
  intros m. induction m as [| m'].
  Case "m = 0".
    intros n. induction n as [| n'].
    SCase "n = 0". reflexivity.
    SCase "n = S n'". simpl. intros contra. inversion contra.
  Case "m = S m'".
    intros n. induction n as [| n'].
    SCase "n = 0". simpl. intros contra. inversion contra.
    SCase "n = S n'". simpl. intros eq.
      apply eq_remove_S. apply IHm'. apply eq. Qed.

Theorem length_snoc' : forall (X : Type) (v : X)
                              (l : list X) (n : nat),
     length l = n ->
     length (snoc l v) = S n.
Proof.
  intros X v l. induction l as [| v' l'].
  Case "l = []".
    intros n eq. rewrite <- eq. reflexivity.
  Case "l = v' :: l'". intros n eq. simpl. destruct n as [| n'].
    SCase "n = 0". inversion eq.
    SCase "n = S n'".
      apply eq_remove_S. apply IHl'. inversion eq. reflexivity. Qed.

Theorem beq_nat_0_l : forall n,
  true = beq_nat 0 n -> 0 = n.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n'".
    intros contra. inversion contra. Qed.

Theorem beq_nat_0_r : forall n,
  true = beq_nat n 0 -> 0 = n.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n'".
    intros contra. inversion contra. Qed.

Theorem double_injective : forall n m,
    double n = double m ->
    n = m.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".
    intros m. induction m as [| m'].
    SCase "m = 0". reflexivity.
    SCase "m = S m'". intros contra. inversion contra.
  Case "n = S n'".
    intros m. induction m as [| m'].
    SCase "m = 0". intros contra. inversion contra.
    SCase "m = S m'".
    intros H. apply eq_remove_S. apply IHn'. inversion H. reflexivity. Qed.

Theorem S_inj : forall (n m : nat) (b : bool),
    beq_nat (S n) (S m) = b  ->
    beq_nat n m = b.
Proof.
  intros n m b H. simpl in H. apply H. Qed.

Theorem silly3' : forall (n : nat),
  (beq_nat n 5 = true -> beq_nat (S (S n)) 7 = true) ->
     true = beq_nat n 5  ->
     true = beq_nat (S (S n)) 7.
Proof.
  intros n eq H.
  symmetry in H. apply eq in H. symmetry in H.
  apply H. Qed.

Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".
    intros m. induction m as [| m'].
    SCase "m = 0". reflexivity.
    SCase "m = S m'". intros contra. inversion contra.
  Case "n = S n'".
    intros m H. induction m as [| m'].
    SCase "m = 0". inversion H.
    SCase "m = S m'".
      rewrite <- plus_n_Sm in H. rewrite <- plus_n_Sm in H.
      simpl in H. inversion H.
      apply IHn' in H1.
      apply eq_remove_S in H1.
      apply H1. Qed.

Definition sillyfun (n : nat) : bool :=
  if beq_nat n 3 then false
  else if beq_nat n 5 then false
  else false.

Theorem sillyfun_false : forall (n : nat),
    sillyfun n = false.
Proof.
  intros n. unfold sillyfun.
  destruct (beq_nat n 3).
    Case "beq_nat n 3 = true". reflexivity.
    Case "beq_nat n 3 = false". destruct (beq_nat n 5).
      SCase "beq_nat n 5 = true". reflexivity.
      SCase "beq_nat n 5 = false". reflexivity. Qed.

Theorem override_shadow : forall {X:Type} x1 x2 k1 k2 (f : nat->X),
  (override (override f k1 x2) k1 x1) k2 = (override f k1 x1) k2.
Proof.
  intros X x x2 k1 k2 f. unfold override.
  destruct (beq_nat k1 k2).
  Case "beq_nat k1 k2 = true". reflexivity.
  Case "beq_nat k1 k2 = false". reflexivity. Qed.

Theorem split_combine : forall (X Y : Type) (l : list (X * Y)) (l1 : list X) (l2 : list Y),
    split l = (l1, l2) -> combine l1 l2 = l.
Proof.
  intros X Y l. induction l as [| [x y] l'].
    Case "l = []".
      intros l1 l2 H. simpl in H. inversion H. reflexivity.
    Case "l = [x y] :: l'".
      intros l1 l2 H.
      simpl in H.
      destruct (split l') as [xs ys].
      inversion H.
      simpl.
      rewrite -> IHl'.
      reflexivity.
      reflexivity. Qed.

Definition sillyfun1 (n : nat) : bool :=
  if beq_nat n 3 then true
  else if beq_nat n 5 then true
  else false.

Theorem sillyfun1_odd_FAILED : forall (n : nat),
    sillyfun1 n = true ->
    oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  remember (beq_nat n 3) as e3.
  destruct e3.
    Case "e3 = true". apply beq_nat_eq in Heqe3.
      rewrite -> Heqe3. reflexivity.
    Case "e3 = false".
      remember (beq_nat n 5) as e5.
      destruct e5.
        SCase "beq_nat n 5 = true". apply beq_nat_eq in Heqe5.
          rewrite -> Heqe5. reflexivity.
        SCase "beq_nat n 5 = false". inversion eq. Qed.

Theorem override_same : forall {X:Type} x1 k1 k2 (f : nat->X),
  f k1 = x1 ->
  (override f k1 x1) k2 = f k2.
Proof.
  intros X x1 k1 k2 f H. unfold override.
  remember (beq_nat k1 k2) as eqk.
  destruct eqk.
    Case "beq_nat k1 k2 = true".
      apply beq_nat_eq in Heqeqk.
      rewrite <- Heqeqk. symmetry. apply H.
    Case "beq_nat k1 k2 = false". reflexivity. Qed.

Theorem filter_exercise : forall (X : Type) (test : X -> bool)
                             (x : X) (l lf : list X),
     filter test l = x :: lf ->
     test x = true.
Proof.
  intros X test x l. induction l as [| x' l'].
    Case "l = []".
      intros. inversion H.
    Case "l = x' :: l'".
      intros. unfold filter in H.
      remember (test x') as eqt. destruct eqt.
        SCase "test x' = true".
          inversion H. rewrite <- H1. symmetry. apply Heqeqt.
        SCase "test x' = false".
          apply IHl' in H. apply H. Qed.

Example trans_eq_example : forall (a b c d e f : nat),
     [a,b] = [c,d] ->
     [c,d] = [e,f] ->
     [a,b] = [e,f].
Proof.
  intros a b c d e f eq1 eq2.
  rewrite -> eq1. rewrite -> eq2. reflexivity.  Qed.

Theorem trans_eq : forall {X:Type} (n m o : X),
  n = m -> m = o -> n = o.
Proof.
  intros X n m o eq1 eq2. rewrite -> eq1. rewrite -> eq2.
  reflexivity.  Qed.

Example trans_eq_example' : forall (a b c d e f : nat),
     [a,b] = [c,d] ->
     [c,d] = [e,f] ->
     [a,b] = [e,f].
Proof.
  intros a b c d e f eq1 eq2.

  apply trans_eq with [c, d]. apply eq1. apply eq2. Qed.

Example trans_eq_exercise : forall (n m o p : nat),
    m = (minustwo o) ->
    (n + p) = m ->
    (n + p) = minustwo o.
Proof.
  intros n m o p eq1 eq2.
  apply trans_eq with m. apply eq2. apply eq1. Qed.

Theorem beq_nat_trans : forall n m p,
  true = beq_nat n m ->
  true = beq_nat m p ->
  true = beq_nat n p.
Proof.
  intros n m p eq1 eq2.
  apply beq_nat_eq in eq1. apply beq_nat_eq in eq2.
  rewrite -> (trans_eq n m p eq1 eq2).
  apply beq_nat_refl. Qed.

Theorem override_permute : forall {X : Type} x1 x2 k1 k2 k3 (f : nat -> X),
    false = beq_nat k2 k1 ->
    (override (override f k2 x2) k1 x1) k3 = (override (override f k1 x1) k2 x2) k3.
Proof.
  intros X x1 x2 k1 k2 k3 f eq1.
  unfold override. remember (beq_nat k1 k3) as eqk. destruct eqk.
    Case "beq_nat k1 k3 = true".
      apply beq_nat_eq in Heqeqk. rewrite -> Heqeqk in eq1. rewrite <- eq1. reflexivity.
    Case "beq_nat k1 k3 = false".
      reflexivity. Qed.

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.

Example test_fold_length1 : fold_length [4,7,0] = 3.
Proof. reflexivity. Qed.

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
  intros X l. induction l as [| x l'].
  Case "l = []". reflexivity.
  Case "l = x ::l'".
    simpl. rewrite <- IHl'. unfold fold_length. simpl. reflexivity. Qed.

Definition fold_map {X Y:Type} (f : X -> Y) (l : list X) : list Y :=
  fold (fun x l' => cons (f x) l') l [].

Theorem fold_map_correct : forall (X Y : Type) (f : X -> Y) (l : list X),
    fold_map f l = map f l.
Proof.
  intros X Y f l. induction l as [| x l'].
  Case "l = []". reflexivity.
  Case "l = x :: l'".
    simpl. rewrite <- IHl'. unfold fold_map. simpl. reflexivity. Qed.

Module MumbleBaz.
  Inductive mumble : Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.

  Inductive grumble (X : Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

  Inductive baz : Type :=
  | x : baz -> baz
  | y : baz -> bool -> baz.
End MumbleBaz.

Fixpoint forallb {X : Type} (test : X -> bool) (l : list X) : bool :=
  match l with
  | [] => true
  | h :: t => if test h then forallb test t else false
  end.

Fixpoint existsb {X : Type} (test : X -> bool) (l : list X) : bool :=
  match l with
  | [] => false
  | h :: t => if test h then true else existsb test t
  end.

Example test_forallb1 : forallb oddb [1,3,5,7,9] = true.
Proof. reflexivity. Qed.

Example test_forallb2 : forallb negb [false,false] = true.
Proof. reflexivity. Qed.

Example test_forall3 : forallb evenb [0,2,4,5] = false.
Proof. reflexivity. Qed.

Example test_forallb4 : forallb (beq_nat 5) [] = true.
Proof. reflexivity. Qed.

Example test_existsb1 : existsb (beq_nat 5) [0,2,3,6] = false.
Proof. reflexivity. Qed.

Example test_existsb2 : existsb (andb true) [true,true,false] = true.
Proof. reflexivity. Qed.

Example test_existsb3 : existsb oddb [1,0,0,0,0,3] = true.
Proof. reflexivity. Qed.

Example test_existsb4 : existsb evenb [] = false.
Proof. reflexivity. Qed.

Definition existsb' {X : Type} (test : X -> bool) (l : list X) : bool :=
  negb (forallb (fun x => (negb (test x))) l).

Theorem existsb_correct : forall {X : Type} (test : X -> bool) (l : list X),
    existsb' test l = existsb test l.
Proof.
  induction l as [|x l'].
  Case "l = []". reflexivity.
  Case "l = x :: l'".
    unfold existsb'. simpl.
    destruct (test x).
    SCase "test x = true". reflexivity.
    SCase "test x = false".
      rewrite <- IHl'. unfold existsb'.
      simpl. reflexivity.
Qed.


Require Import Raxiom Rconvenient.

Module IZR (Import T : CReals).

Module Rconvenient := Rconvenient T.
Import Rconvenient.

Open Scope R_scope.

Definition INR := fix f n := match n with O => R0 | S n' => R1 + f n' end.

Lemma INR_add : forall a b, INR (a + b) == INR a + INR b.
Proof.
  intros a b; induction a.
    simpl; symmetry; apply Radd_0_l.
    simpl; rewrite IHa; ring.
Qed.

Lemma INR_S : forall n, INR (S n) == R1 + INR n.
Proof.
  intros; reflexivity.
Qed.

Lemma INR_mul : forall a b, INR (a * b) == INR a * INR b.
Proof.
  intros a b; induction a.
    simpl; symmetry; apply Rmul_0_l.
    simpl; rewrite INR_add, IHa; ring.
Qed.

Lemma INR_IPR : forall p, INR (nat_of_P p) == IPR p.
Proof.
  intros p.
  induction p.
    rewrite nat_of_P_xI, INR_S, INR_mul, IHp; simpl; ring.
    rewrite nat_of_P_xO, INR_mul, IHp; simpl; ring.
    simpl; ring.
Qed.

Lemma IZR_Zopp : forall z, IZR (- z) == - IZR z.
Proof.
  intros z; induction z.
    simpl; symmetry; apply Ropp_0.
    reflexivity.
    symmetry; apply Ropp_involutive.
Qed.

Lemma IZR_INR : forall n, IZR (Z_of_nat n) == INR n.
Proof.
  intros n.
  destruct n.
  reflexivity.

  rewrite
    <- nat_of_P_o_P_of_succ_nat_eq_succ,
    <- Zpos_eq_Z_of_nat_o_nat_of_P,
    INR_IPR.
  reflexivity.
Qed.

Lemma INR_sub : forall a b, le b a -> INR (a - b) == INR a - INR b.
Proof.
  intros a b ab.
  rewrite (le_plus_minus b a ab) at 2.
  unfold Rsub.
  rewrite INR_add.
  rewrite Radd_comm, <- Radd_assoc, (Radd_comm (- INR b)), Radd_opp_r, Radd_0_l.
  reflexivity.
Qed.

Lemma Zopp_swap : forall a b, Z.opp a = b -> a = Z.opp b.
Proof.
  intros a b H; rewrite <- H; ring.
Qed.

Lemma Zuminus : forall a b, (a + - b = a - b)%Z.
Proof.
  intros; ring.
Qed.

Lemma Rpos_IPR : forall p, R0 < IPR p.
Proof.
intros p; induction p; simpl.
  apply Rlt_trans with (R0 + R1).
  apply Req_lt_compat_r with R1; [ symmetry; apply Radd_0_l | apply Rlt_0_1 ].

  apply Radd_lt_compat_r.
  eapply Req_lt_compat_l; [ apply Rmul_0_r | ].
  apply Rmul_lt_compat_l.
    apply Rlt_0_2.
    apply IHp.

  eapply Req_lt_compat_l; [ apply Rmul_0_r | ].
  apply Rmul_lt_compat_l.
    apply Rlt_0_2.
    apply IHp.

  apply Rlt_0_1.
Qed.

Lemma Rdiscr_IPR_0 : forall p, IPR p ## R0.
Proof.
intros p; right; apply Rpos_IPR.
Qed.

Lemma IZR_opp : forall a, IZR (- a) == - IZR a.
Proof.
  intros [ | p | p ]; simpl; symmetry.
    apply Ropp_0.
    reflexivity.
    apply Ropp_involutive.
Qed.

Lemma IPR_psucc : forall a, IPR (Pos.succ a) == IPR a + R1.
Proof.
  induction a.
   simpl. rewrite IHa. now ring.

   simpl. now ring.

   simpl. ring.
Qed.

Lemma IPR_add_carry : forall a b, IPR (a + b) == IPR a + IPR b
  /\ IPR (Pplus_carry a b) == IPR a + IPR b + R1.
Proof.
  induction a; simpl; intros.
   destruct b.
    simpl. destruct (IHa b) as [H1 H2]. rewrite H2. split.
     now ring.

     now ring.

    simpl. destruct (IHa b) as [H1 H2]. rewrite H1, H2. split.
     now ring.

     now ring.

   simpl. destruct (IHa 1%positive) as [H1 H2]. rewrite IPR_psucc. split.
    now ring.

    now ring.

   destruct b; simpl.
    destruct (IHa b) as [H1 H2]. split.
     rewrite H1. now ring.

     rewrite H2. now ring.

    destruct (IHa b) as [H1 H2]. split.
     rewrite H1. now ring.

     rewrite H1. now ring.

   destruct (IHa 1%positive) as [H1 H2 ]. split.
    now intuition.

    rewrite IPR_psucc. simpl. now ring.

  destruct b.
   simpl. split.
    rewrite IPR_psucc. now ring.

    rewrite IPR_psucc. now ring.

   split.
    simpl. now ring.

    simpl. rewrite IPR_psucc. now ring.

  simpl. split.
   now ring.

   ring.
Qed.

Lemma IPR_add : forall a b, IPR (a + b) == IPR a + IPR b.
Proof.
  apply IPR_add_carry.
Qed.

Lemma IPR_sub : forall a b, Pcompare a b Eq = Gt -> IPR (a - b) == IPR a - IPR b.
Proof.
  intros a b Cab.
  unfold Pminus.
  remember (Pminus_mask a b) as pmab.
  destruct (Pminus_mask_Gt _ _ Cab) as (z, (Hz, (eqz, Dz))).
  destruct pmab as [ | p | ]; try congruence.
  rewrite <- eqz.
  unfold Rsub (* TODO BUG : the following rewrite does not work under Rsub *) .
  rewrite IPR_add.
  cut (p = z).
    intro; subst; ring.
    congruence.
Qed.

Lemma IZR_add : forall a b, IZR (a + b) == IZR a + IZR b.
Proof.
  intros [ | a | a ] [ | b | b ]; simpl; try ring.
    apply IPR_add.

    rewrite Z.pos_sub_spec; remember (a ?= b)%positive as Cab.
    destruct Cab; simpl.
      erewrite (Pcompare_Eq_eq a b); [ ring | ]; auto.
      rewrite IPR_sub; [ ring | ]; apply ZC2; symmetry; assumption.
      rewrite IPR_sub; [ ring | ]; auto.

    rewrite Z.pos_sub_spec; remember (b ?= a)%positive as Cab.
    destruct Cab; simpl.
      erewrite (Pcompare_Eq_eq b a); [ ring | ]; auto.
      rewrite IPR_sub; [ ring | ]; apply ZC2; symmetry; assumption.
      rewrite IPR_sub; [ ring | ]; auto.

    rewrite IPR_add; ring.
Qed.

Lemma IZR_sub : forall x y, IZR (x - y) == IZR x - IZR y.
Proof.
  intros a b.
  unfold Zminus, Rsub.
  rewrite IZR_add, IZR_Zopp.
  reflexivity.
Qed.

Lemma IZR_lt : forall x y, (x < y)%Z -> IZR x < IZR y.
Proof.
  intros x y xy.
  apply Radd_lt_cancel_l with (-IZR x).
  eapply Req_lt_compat_l; [ apply Radd_comm | ].
  eapply Req_lt_compat_l; [ symmetry; apply Radd_opp_r | ].
  eapply Req_lt_compat_r; [ apply Radd_comm | ].
  eapply Req_lt_compat_r.
    rewrite <- IZR_Zopp, <- IZR_add; reflexivity.

    remember (y + - x)%Z as d.
    assert (dp : (0 < d)%Z) by omega.
    destruct d; try inversion dp.
    simpl.
    apply Rpos_IPR.
Qed.

Lemma IZR_le : forall x y, (x <= y)%Z -> IZR x <= IZR y.
Proof.
  intros x y xy.
  destruct (Z_le_lt_eq_dec _ _ xy).
  left; apply IZR_lt; auto.
  right; subst; apply Req_refl.
Qed.

Lemma IPR_mul : forall a b, IPR (a * b) == IPR a * IPR b.
Proof.
  induction a.
   simpl. intros. rewrite (IPR_add b ((a * b)~0)). simpl. rewrite IHa. now ring.

   intros. simpl. rewrite IHa. now ring.

   intros. simpl. ring.
Qed.

Lemma IZR_mul : forall a b, IZR (a * b) == IZR a * IZR b.
Proof.
  intros [ | p | p ] [ | q | q ]; simpl; try rewrite IPR_mul; ring.
Qed.

Lemma IZR_eq : forall a b, a = b -> IZR a == IZR b.
Proof.
  intros; subst; reflexivity.
Qed.

Ltac IZRify :=
  replace R1 with (IZR 1) by reflexivity;
  replace R0 with (IZR 0) by reflexivity;
  repeat
    (rewrite <- IZR_add ||
    rewrite <- IZR_sub ||
    rewrite <- IZR_mul ||
    rewrite <- IZR_opp);
  apply IZR_eq || apply IZR_lt || apply IZR_le || idtac.

Ltac eq_lt_compat_r_tac t := eapply Req_lt_compat_r; [ t; reflexivity | ].
Ltac eq_lt_compat_l_tac t := eapply Req_lt_compat_l; [ t; reflexivity | ].
Ltac eq_le_compat_r_tac t := eapply Req_le_compat_r; [ t; reflexivity | ].
Ltac eq_le_compat_l_tac t := eapply Req_le_compat_l; [ t; reflexivity | ].
Ltac eq_eq_compat_l_tac t := eapply Req_trans; [ symmetry; t; reflexivity | ].
Ltac eq_eq_compat_r_tac t := symmetry; eapply Req_trans; [ symmetry; t; reflexivity | ]; symmetry.

Ltac eq_compat_l_tac t := match goal with
  | |- _ == _ => eq_eq_compat_l_tac t
  | |- _ <  _ => eq_lt_compat_l_tac t
  | |- _ <= _ => eq_le_compat_l_tac t end.

Ltac eq_compat_r_tac t := match goal with
  | |- _ == _ => eq_eq_compat_r_tac t
  | |- _ <  _ => eq_lt_compat_r_tac t
  | |- _ <= _ => eq_le_compat_r_tac t end.

Ltac IZRrel :=
  eq_compat_r_tac IZRify;
  eq_compat_l_tac IZRify;
  match goal with
  | |- _ == _ => try apply IZR_eq
  | |- _ <= _ => try apply IZR_le
  | |- _ <  _ => try apply IZR_lt
  end; try omega.

End IZR.


From Hammer Require Import Hammer.

Require Import Rbase.
Require Import Rfunctions.
Require Import PartSum.
Local Open Scope R_scope.

Definition C (n p:nat) : R :=
INR (fact n) / (INR (fact p) * INR (fact (n - p))).

Lemma pascal_step1 : forall n i:nat, (i <= n)%nat -> C n i = C n (n - i).
Proof. hammer_hook "Binomial" "Binomial.pascal_step1".
intros; unfold C; replace (n - (n - i))%nat with i.
rewrite Rmult_comm.
reflexivity.
apply plus_minus; rewrite plus_comm; apply le_plus_minus; assumption.
Qed.

Lemma pascal_step2 :
forall n i:nat,
(i <= n)%nat -> C (S n) i = INR (S n) / INR (S n - i) * C n i.
Proof. hammer_hook "Binomial" "Binomial.pascal_step2".
intros; unfold C; replace (S n - i)%nat with (S (n - i)).
cut (forall n:nat, fact (S n) = (S n * fact n)%nat).
intro; repeat rewrite H0.
unfold Rdiv; repeat rewrite mult_INR; repeat rewrite Rinv_mult_distr.
ring.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply not_O_INR; discriminate.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply prod_neq_R0.
apply not_O_INR; discriminate.
apply INR_fact_neq_0.
intro; reflexivity.
apply minus_Sn_m; assumption.
Qed.

Lemma pascal_step3 :
forall n i:nat, (i < n)%nat -> C n (S i) = INR (n - i) / INR (S i) * C n i.
Proof. hammer_hook "Binomial" "Binomial.pascal_step3".
intros; unfold C.
cut (forall n:nat, fact (S n) = (S n * fact n)%nat).
intro.
cut ((n - i)%nat = S (n - S i)).
intro.
pattern (n - i)%nat at 2; rewrite H1.
repeat rewrite H0; unfold Rdiv; repeat rewrite mult_INR;
repeat rewrite Rinv_mult_distr.
rewrite <- H1; rewrite (Rmult_comm (/ INR (n - i)));
repeat rewrite Rmult_assoc; rewrite (Rmult_comm (INR (n - i)));
repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
ring.
apply not_O_INR; apply minus_neq_O; assumption.
apply not_O_INR; discriminate.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
apply not_O_INR; discriminate.
apply INR_fact_neq_0.
apply prod_neq_R0; [ apply not_O_INR; discriminate | apply INR_fact_neq_0 ].
apply INR_fact_neq_0.
rewrite minus_Sn_m.
simpl; reflexivity.
apply lt_le_S; assumption.
intro; reflexivity.
Qed.

Lemma pascal :
forall n i:nat, (i < n)%nat -> C n i + C n (S i) = C (S n) (S i).
Proof. hammer_hook "Binomial" "Binomial.pascal".
intros.
rewrite pascal_step3; [ idtac | assumption ].
replace (C n i + INR (n - i) / INR (S i) * C n i) with
(C n i * (1 + INR (n - i) / INR (S i))); [ idtac | ring ].
replace (1 + INR (n - i) / INR (S i)) with (INR (S n) / INR (S i)).
rewrite pascal_step1.
rewrite Rmult_comm; replace (S i) with (S n - (n - i))%nat.
rewrite <- pascal_step2.
apply pascal_step1.
apply le_trans with n.
apply le_minusni_n.
apply lt_le_weak; assumption.
apply le_n_Sn.
apply le_minusni_n.
apply lt_le_weak; assumption.
rewrite <- minus_Sn_m.
cut ((n - (n - i))%nat = i).
intro; rewrite H0; reflexivity.
symmetry ; apply plus_minus.
rewrite plus_comm; rewrite le_plus_minus_r.
reflexivity.
apply lt_le_weak; assumption.
apply le_minusni_n; apply lt_le_weak; assumption.
apply lt_le_weak; assumption.
unfold Rdiv.
repeat rewrite S_INR.
rewrite minus_INR.
cut (INR i + 1 <> 0).
intro.
apply Rmult_eq_reg_l with (INR i + 1); [ idtac | assumption ].
rewrite Rmult_plus_distr_l.
rewrite Rmult_1_r.
do 2 rewrite (Rmult_comm (INR i + 1)).
repeat rewrite Rmult_assoc.
rewrite <- Rinv_l_sym; [ idtac | assumption ].
ring.
rewrite <- S_INR.
apply not_O_INR; discriminate.
apply lt_le_weak; assumption.
Qed.


Require Import Bool.

(*Load Arith.*)
Require Import Arith.
Require Import Mult.
Require Import List.
Require Import Logic.

Set Implicit Arguments.
Definition Alphabet := nat.
Inductive Fin : nat -> Type :=
| f0 : forall n, Fin (S n)
| fs : forall n, Fin n -> Fin (S n).

Lemma fin_isnotzero : forall (n:nat), Fin n -> match n with
                                   | 0 => False
                                   | _ => True
                                       end.
intros.
induction H.
split.
split.
Qed.

Lemma fin0empty : Fin 0 -> False.
intro.
apply(fin_isnotzero H).
Qed.

(**  * Coproducts : *)
Definition addfin : forall (m n : nat) , Fin m + Fin n -> Fin (m+n).
intros.
destruct H.
induction f.
simpl.
apply (f0 (n0+ n)).
simpl.
apply (f0 (n0+n)).
simpl.
induction n.
apply fin0empty in f.
destruct f.
simpl.
assert(m+S n = S(m+n)).
auto.
rewrite H.
apply (f0 (m+n)).

Defined.

Definition addfin1 : forall (m n : nat), Fin (m+n) -> Fin m + Fin n.
induction n.
intros.
simpl.
assert(  m + 0 = m).
auto with arith.
rewrite H0 in H.
tauto.

(*
exact(inl H). *)
intros.
Check (f0 n).
simpl in *.
assert(m+S n = S(m+n)).
auto.

rewrite H0 in H.
assert (Fin (S n)).
apply (f0 n).
Check inr.
tauto.

(*

apply (inr (H1)). *)
Defined.

Definition isoadd1 : forall (m n :nat),
    (Fin m + Fin n -> Fin (m+n)) -> (Fin (m+n) -> Fin m+ Fin n) -> (Fin m+ Fin n -> Fin m + Fin n).

intros.
apply H0.
apply H.
assumption.
Qed.

Definition isoadd2: forall (m n:nat),
  (Fin (m+n) -> Fin m + Fin n) -> (Fin m+Fin n-> Fin (m+n)) -> (Fin (m+n) -> Fin (m+n)).
intros.
apply H0.
apply H.
exact H1.
Qed.

Definition finl : forall (m n : nat) , Fin m -> Fin (m+n).
intros.
induction n.
simpl.
rewrite<- plus_n_O.
exact H.
simpl.
rewrite<-plus_n_Sm.
exact (fs IHn).
Defined.
Definition finr : forall ( m n : nat), Fin n -> Fin (m+n).
intros.
induction m.
simpl.
exact H.
simpl.
apply (fs IHm).
Defined.

  Inductive FinPlus ( m n: nat) : Fin (m + n) -> Set:=
         | fsinl : forall i: Fin m , (FinPlus m n (finl n i))
         | fsinr : forall j: Fin n, FinPlus m n (finr m j) .

Print FinPlus.

(** * Products *)
Definition fst : forall (m n : nat) , Fin (m*n)-> Fin m.
intros.
induction m.
rewrite mult_0_l in H.
exact H.
simpl in H.
exact (f0 m).
Defined.

Definition snd: forall (m n : nat) , Fin (m*n) -> Fin n.
intros.
induction n.
rewrite  mult_0_r in H.
assumption.
exact (f0 n).
Defined.
Print fst.
Print snd.
Definition timesfin : forall (m n : nat) , Fin m * Fin n -> Fin (m*n) .

intros.
destruct H.

induction m.

rewrite mult_0_l .
exact f.
simpl.
apply finl.
exact f1.
Defined.

Definition timesfin1: forall (n m : nat) , Fin (m*n) -> Fin m * Fin n.
induction n.
simpl.
simpl.
intro.
assert(m*0 =0).
auto with arith.
rewrite H.
intro.
apply fin0empty in H0.
destruct H0.
intros.
assert(Fin m).
apply (fst  m (S n)).
exact H.
Show Proof.
intuition.
Show Proof.
apply (snd m (S n)).
exact H.
Defined.

Definition isomul1 : forall (m n: nat),
   (Fin m * Fin n -> Fin (m*n)) -> (Fin (m*n) -> Fin m * Fin n) -> (Fin m * Fin n -> Fin m * Fin n).

intros.
apply H0.
apply H.
exact H1.
Qed.

Definition isomul2 : forall (m n : nat),
   (Fin (m*n) ->Fin m * Fin n) -> (Fin m * Fin n -> Fin (m*n)) -> (Fin (m*n) -> Fin (m*n)).
intros.
apply H0.
apply H.
exact H1.
Qed.

Definition fincase : forall (m n p: nat) , (Fin m -> Fin p) -> (Fin n -> Fin p ) ->(Fin (m+n) -> Fin p).

intros.
apply addfin1 in H1.
destruct H1.
apply H.
exact f.
apply H0.
exact f.
Defined.

(** Function composition *)
Lemma comp : forall (m n p :nat) , (Fin m ->Fin m + Fin n) -> (Fin m+ Fin n -> Fin p) ->
         (Fin m -> Fin p).
intros m n p in1 fg f.
apply fg.
apply in1.
exact f.
Defined.

Lemma comp1 : forall (m n p:nat), (Fin n ->Fin m + Fin n) ->
    (Fin m+ Fin n-> Fin p) -> (Fin n -> Fin p).
intros m n p in2 fg g.
apply fg.
apply in2.
exact g.
Defined.

(** Distributivity law *)
Definition dist:
       forall (m n p :nat), Fin ( m * ( n+ p)) -> Fin ( m* n + m * p).
induction m.
intros.
simpl in *.
apply fin0empty in H.
destruct H.
intros.

apply addfin.
rewrite mult_plus_distr_l in H.
apply addfin1 in H.
assumption.
Defined.

Definition dist2 :
    forall (m n p : nat), Fin (m * n + m* p ) -> Fin (m * (n + p)).
induction m.
intros.
simpl in *.
apply fin0empty in H.
destruct H.
intros.
apply addfin1 in H.
rewrite mult_plus_distr_l.
apply addfin.
assumption.
Qed.

(*
 Lemma fin_inl_inject : forall (n m : nat) (i j : Fin n),
       finl m i = finl m j -> i = j.
induction i.
intros.

simpl in *.
assert( Fin (S n)).

apply (f0 n).

admit.
intros.
assert ( Fin ( m) -> Fin (m + ( n))).
apply (f0 n) .
induction H.

discriminate H.
Lemma finlinj : forall (m n : nat) (i j : Fin n),
       finl m i = finl n j -> i = j.

*)

Fixpoint exps  (x n :nat):nat :=

       match n with
       | 0  => 1
       | S n' =>   mult x (exps x n')
       end.
Eval compute in (exps 3 2).

Notation " x ^ y " := (exps x y).
Eval compute in (0 ^9).

Definition existsf1   (n:nat)(p:Fin n -> bool) : bool.
induction n .
exact false.
exact( p (f0 n) || IHn (fun m : Fin n => p (fs m))).
Defined.
Print existsf1.
Check In.

(** Here, we prove the correctness of the existsf1 predicate , by evaluating it to the value
of the exists quantifier in coq. we will also use proving by contradiction, as well as case analysis,
due to the disjunction [p(f0 n) || IHn (fun m : Fin n => p(fs m))] *)

Lemma exss : forall (n:nat)(p:Fin n -> bool), existsf1 p = true -> exists q:Fin n , p q =true.
intros.
induction n.
simpl.
simpl in H.
discriminate H.
simpl in  H.

case_eq ( p (f0 n)).
intro.
exists( f0 (n)).
exact H0.
intro.
rewrite H0 in H.
simpl in H.
apply IHn in H.
destruct H.
exists (fs x).
exact H.
Qed.

Lemma exs : forall (n:nat)(p:Fin n -> bool),(exists q :Fin n, p q = true) ->  existsf1 p = true.
intros.
destruct H.
simpl.
induction x.
simpl.
rewrite H.
simpl.
reflexivity.

case_eq (p (f0 n)).
intro.
simpl.
rewrite H0.
simpl.
reflexivity.
intro.
simpl.
rewrite H0.
simpl.
apply IHx.
exact H.
Qed.
(*

Definition isoex1 :forall (n:nat) (p:Fin n -> bool) *)
(*Definition isoex1 : forall (n : nat)(p : Fin n -> bool)(x: exists q:Fin n , p q = true) ,

   exss  p (exs p x) =x.
intros.
simpl in *.
set (exs p x ).
set (exss p e).

assert(existsf1 p =true -> exists q:Fin n , p q =true).
intros.
exact x.
assert((exists q :Fin n , p q =true) -> existsf1 p = true).
intros.
apply e.
set(exss p e).
intuition.
rewrite H0 in x.
rewrite e0 in x.

assert( exss p (exs p x) = exists q :Fin n , p q =true).
intros.
Definition isoex1 : forall (n:nat)(p:Fin n -> bool) ,

   (existsf1 p =true -> exists q:Fin n , p q =true) ->

  ((exists q:Fin n , p q = true) -> existsf1 p =true) -> (existsf1 p = true -> existsf1 p = true).
intros.

trivial.

apply H0.

intros.
simpl in *.

*)

(*We eill prove the isomorphism between tha fact that in our proof we can feed into 2 finite
sets [(Fin m -> Fin n)] and obtain a new finite set with cardinality [Fin (n^m)]

*)

Definition  allexp : forall(m n :nat) , (Fin m -> Fin n ) -> Fin ( n^m).
intros.
induction m.

simpl.
exact (f0 (pred 0)).
(*base case *)
simpl.
eapply timesfin.
(*use the definition of the product Fin m *FIn n -> Fin (m*n)*)
simpl.
induction n.
simpl.
apply timesfin1.
simpl.
apply H.
exact (f0 m).
apply timesfin1.
simpl.
apply finl.
apply IHm.
intro.
apply H.
exact (f0 m).
Defined.
Print allexp.

Definition es : forall (a b : nat) , Fin (b^a) -> (Fin a -> Fin b ).
intros.
simpl.
induction a.
apply fin0empty in H0.
destruct H0.
simpl in H.
apply timesfin1 in H.
destruct H.
exact f.
Defined.

(*Define an isomorphism between a predicate which contains n elements and the finite set with 2^n elements.
This is used when generating the power automaton. We will apply the lemmas that we have done before. *)

Definition allexp1 : forall (n : nat) , (Fin n -> bool) -> Fin (2^n).
intros.
apply allexp.
intro.
exact (f0 1).
Defined.

Definition allexp2 : forall (n : nat) , Fin (2^n) -> (Fin n -> bool).
intros.
apply (es  2) in H.
exact true.
apply allexp.
intro.
exact (f0 1).
Defined.

Fixpoint equalsf (n m:nat) (p :Fin n) (q: Fin m) : bool :=
    match p with
 | f0 _ => match q with
          | f0 _ => true
          | _ => false
          end
 | fs _ p' => match q with
           | f0 _ => false
           | fs _ q' =>  equalsf p' q'
         end
      end.
Print equalsf.

Definition eqf (n : nat) (p q : Fin n) : bool := equalsf p q.

Definition eqftoprop (n:nat)(p q :Fin n) : Prop :=
       match eqf p q with
     | true => True
     | false => False
     end.
(** Apply a finite set case analysis taking 2 functions and check whether is there the element for the [Fin m],

or the element from [Fin n] , that will be selected. From mapping two functions,
[Fin m -> Fin p] and [Fin n -> Fin p] is a way of "choosing" and therefore we need to use a set
that has cardinality m+n, and see if it will be mapped on Fin p.

*)

Definition finmn : forall (m n :nat), (Fin m + Fin n -> bool ) -> Fin (m+n) -> bool.
intros.
apply H.
apply addfin1 in H0.
assumption.
Defined.
Definition finsum : forall (m n :nat),  Fin m ->  Fin n -> Fin m + Fin n.
intros.
induction m.
apply fin0empty in H.
destruct H.
apply (inl H).
Defined.

Definition finbool :forall (m n :nat), (Fin m -> bool) -> (Fin n -> bool) ->
          Fin (m+n) -> bool.
intros.
induction m.
simpl in *.
exact true.
apply H.
exact (f0 m).
(*
apply IHm.
intro.
apply H.
exact (f0 m).
apply addfin1 in H1.
admit.*)
Defined.

Definition finmbool : forall (a:Alphabet) (m n: nat),
   (Fin m -> bool) -> (Fin (m+n) -> bool).
intros.
induction m.
exact false.
apply H.
exact (f0 m).

Qed.
Definition finpp : forall (a:Alphabet)(m n :nat),
  (Fin m -> Fin a -> Fin (2^m)) ->
      (Fin n -> Fin a -> Fin (2^n)) ->
      Fin (2^ (m+n)).
intros.
apply allexp1.
intro.
apply addfin1 in H1.
induction m.
simpl in H1.
exact false.
apply IHm.
intros.
apply allexp1.
intro.
exact true.
intuition.
apply addfin1.
admit.
Qed.

(*
Definition finpp : forall (a:Alphabet)(m n : nat),
   (Fin m-> Fin a -> Fin (2^m)) ->( Fin n -> Fin a -> Fin (2^n)) ->
   Fin (2 ^m + 2 ^n).
intros.

induction m.
simpl.
exact (f0 (2^n)).
induction n.
simpl .
simpl in *.
simpl.
simpl.
admit.

intros.
simpl.
induction n.
simpl.
assert (2^m+1 = S(2^m)).
admit.
rewrite H1.
exact (f0 (2^m)).
simpl.
induction m.
simpl.
exact (f0 (add (2^n) (add (2^n) 0))).
simpl.

*)


(* Exercise 25 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_025 : ~(forall x, P x /\ Q x) /\ (forall x, P x) -> ~(forall x, Q x).
Proof.
imp_i a1.
neg_i (forall x:D, P x /\ Q x) a2.
con_e1 (forall x:D, P x).
hyp a1.
all_i a.
con_i.
all_e (forall x:D, P x) a.
con_e2 (~(forall x:D, P x /\ Q x)).
hyp a1.
all_e (forall x:D, Q x) a.
hyp a2.
Qed.


From AlphaPearl Require Import Util.Nat Util.PlfTactics.
From Coq Require Import Bool List ssreflect.
Import ListNotations.
From mathcomp Require Import bigop eqtype seq ssrbool ssrnat.

Set Asymmetric Patterns.
Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.
Unset Printing Implicit Defensive.

#[local] Open Scope list_scope.

Notation "x '∈' y" := (x \in y) (at level 70).

Notation "x '∉' y" := (x \notin y) (at level 70).

(* Note that, at least for now, [maximum nil = 0]. *)
Definition maximum : list nat -> nat := foldr maxn 0.

Lemma maximum_correct : forall (l : list nat) (x : nat), x ∈ l -> x <= maximum l.
Proof.
  induction l; intros.
  { inverts H. }
  rewrite /= leq_max.
  rewrite in_cons in H. apply (rwP orP) in H as [].
  - apply (rwP eqP) in H. subst. rewrite leqnn //.
  - apply IHl in H. rewrite H orbT //.
Qed.

Lemma maxE r : maximum r = \max_(i <- r) i. Proof. exact: foldrE. Qed.

Lemma bigmax_subset :
  forall sub super : seq nat,
    {subset sub <= super} ->
    \max_(x <- sub) x <= \max_(x <- super) x.
Proof.
  intros.
  gen super. induction sub; intros; simpl in *.
  - rewrite big_nil //.
  - rewrite big_cons.
    assert (a ∈ a :: sub). { rewrite in_cons eq_refl //. }
    apply H in H0.
    rewrite geq_max -{1}maxE maximum_correct //.
    apply IHsub. intros_all.
    apply H. rewrite in_cons.
    destruct (x =P a); subst; auto.
Qed.

Lemma S_bigmax :
  forall s : seq nat,
    \max_(x <- s) S x <= S (\max_(x <- s) x).
Proof.
  intros.
  induction s.
  { rewrite !big_nil //. }
  rewrite !big_cons -!maxnSS geq_max leq_max leqnn leq_max IHs orbT //.
Qed.

Lemma maximum_in :
  forall l : seq nat,
    l = nil \/ maximum l ∈ l.
Proof.
  intros.
  induction l; auto.
  right.
  rewrite in_cons.
  destruct IHl as [IHl|IHl]; subst.
  - rewrite eq_refl //.
  - destruct (maxn_either a (maximum l)) as [Hmax|Hmax]; rewrite /= Hmax.
    + rewrite eq_refl //.
    + rewrite IHl orbT //.
Qed.

Lemma maximum_leq :
  forall l1 l2 : seq nat,
    (forall n, n ∈ l1 -> n <= maximum l2) ->
      maximum l1 <= maximum l2.
Proof.
  introv Hl12.
  induction l1; auto.
  rewrite /= geq_max -(rwP andP). split.
  - rewrite Hl12 // mem_head //.
  - apply IHl1. introv Hn.
    rewrite Hl12 // in_cons Hn orbT //.
Qed.


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

Require Import Orders Rbase Rbasic_fun ROrderedType GenericMinMax.

(** * Maximum and Minimum of two real numbers *)

Local Open Scope R_scope.

(** The functions [Rmax] and [Rmin] implement indeed
    a maximum and a minimum *)

Lemma Rmax_l : forall x y, y<=x -> Rmax x y = x.
Proof.
 unfold Rmax. intros.
 destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
  unfold Rle in *; intuition.
Qed.

Lemma Rmax_r : forall x y, x<=y -> Rmax x y = y.
Proof.
 unfold Rmax. intros.
 destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
  unfold Rle in *; intuition.
Qed.

Lemma Rmin_l : forall x y, x<=y -> Rmin x y = x.
Proof.
 unfold Rmin. intros.
 destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
  unfold Rle in *; intuition.
Qed.

Lemma Rmin_r : forall x y, y<=x -> Rmin x y = y.
Proof.
 unfold Rmin. intros.
 destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
  unfold Rle in *; intuition.
Qed.

Module RHasMinMax <: HasMinMax R_as_OT.
 Definition max := Rmax.
 Definition min := Rmin.
 Definition max_l := Rmax_l.
 Definition max_r := Rmax_r.
 Definition min_l := Rmin_l.
 Definition min_r := Rmin_r.
End RHasMinMax.

Module R.

(** We obtain hence all the generic properties of max and min. *)

Include UsualMinMaxProperties R_as_OT RHasMinMax.

(** * Properties specific to the [R] domain *)

(** Compatibilities (consequences of monotonicity) *)

Lemma plus_max_distr_l : forall n m p, Rmax (p + n) (p + m) = p + Rmax n m.
Proof.
 intros. apply max_monotone.
 intros x y. apply Rplus_le_compat_l.
Qed.

Lemma plus_max_distr_r : forall n m p, Rmax (n + p) (m + p) = Rmax n m + p.
Proof.
 intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p).
 apply plus_max_distr_l.
Qed.

Lemma plus_min_distr_l : forall n m p, Rmin (p + n) (p + m) = p + Rmin n m.
Proof.
 intros. apply min_monotone.
 intros x y. apply Rplus_le_compat_l.
Qed.

Lemma plus_min_distr_r : forall n m p, Rmin (n + p) (m + p) = Rmin n m + p.
Proof.
 intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p).
 apply plus_min_distr_l.
Qed.

(** Anti-monotonicity swaps the role of [min] and [max] *)

Lemma opp_max_distr : forall n m : R, -(Rmax n m) = Rmin (- n) (- m).
Proof.
 intros. symmetry. apply min_max_antimonotone.
 do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto.
Qed.

Lemma opp_min_distr : forall n m : R, - (Rmin n m) = Rmax (- n) (- m).
Proof.
 intros. symmetry. apply max_min_antimonotone.
 do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto.
Qed.

Lemma minus_max_distr_l : forall n m p, Rmax (p - n) (p - m) = p - Rmin n m.
Proof.
 unfold Rminus. intros. rewrite opp_min_distr. apply plus_max_distr_l.
Qed.

Lemma minus_max_distr_r : forall n m p, Rmax (n - p) (m - p) = Rmax n m - p.
Proof.
 unfold Rminus. intros. apply plus_max_distr_r.
Qed.

Lemma minus_min_distr_l : forall n m p, Rmin (p - n) (p - m) = p - Rmax n m.
Proof.
 unfold Rminus. intros. rewrite opp_max_distr. apply plus_min_distr_l.
Qed.

Lemma minus_min_distr_r : forall n m p, Rmin (n - p) (m - p) = Rmin n m - p.
Proof.
 unfold Rminus. intros. apply plus_min_distr_r.
Qed.

End R.


Notation add := ((fun m n x y => m x (n x y))).
Notation time := ((fun m n x y => m (n x) y)).
Notation two := (fun s n => s (s n)).
Notation thr := (fun s n => s (s (s n))).
Compute (add two thr S O) (*=> 5*).
Compute (time two thr S O) (*=> 6*).

Fixpoint fn_walk n (s: nat -> nat) z :=
  match n with
  | O => z
  | S n' => s (fn_walk n' s z)
  end.

Definition fun_nat n :=
  (fun s z => fn_walk n s z).

Lemma fun_nat_correct : forall n,
    fun_nat n S O = n.
Proof.
  induction n; simpl; auto.
Qed.

Notation adds n1 n2 := (add (fun_nat n1) (fun_nat n2)).
Notation times n1 n2 := (time (fun_nat n1) (fun_nat n2)).

Lemma add_correct : forall n m,
    adds n m = fun_nat (n + m).
Proof.
  unfold fun_nat; induction n; simpl; intros; auto.
  rewrite <- IHn. reflexivity.
Qed.

Theorem time_correct : forall n1 n2,
    times n1 n2 = fun_nat (n1 * n2).
Proof.
  induction n1; simpl; auto; intros.
  rewrite <- add_correct. rewrite <- IHn1.
  reflexivity.
Qed.

Fixpoint walk {A: Type} n (s: A -> A) z :=
  match n with
  | O => z
  | S n' => s (walk n' s z)
  end.

Definition fun_nat2 {A: Type} n :=
  (fun (s: A -> A) z => walk n s z).

Notation power := ((fun m n x y => n m x y)).
Notation powers n1 n2 := (power (fun_nat2 n1)(fun_nat2 n2)).
Compute (power two thr S O).

Fixpoint pow n1 n2 :=
  match n2 with
  | 0 => 1
  | S n => n1 * (pow n1 n)
  end.
Compute (pow 3 2).
Compute (pow 2 3).

Lemma pow_m_sn : forall n m,
    pow m (S n) = m * (pow m n).
Proof.
  induction n; simpl; intros; auto.
Qed.

Lemma walk__ : forall n,
    walk n = fn_walk n.
Proof.
  induction n; simpl; auto.
  rewrite IHn. reflexivity.
Qed.

Lemma fun_nat12 : forall n,
    fun_nat n = fun_nat2 n.
Proof.
  unfold fun_nat, fun_nat2.
  intros. rewrite walk__. reflexivity.
Qed.

Theorem power_correct: forall n2 n1,
    powers n1 n2 = fun_nat (pow n1 n2).
Proof.
  induction n2; simpl; intros; auto.
  rewrite IHn2. rewrite <- time_correct. rewrite <- fun_nat12. reflexivity.
Qed.

Theorem power2 : forall n2 n1,
    fun_nat2 (pow n1 n2) = ((fun_nat2 n2) (time (fun_nat n1)) (fun_nat 1)).
Proof.
  induction n2; intros; simpl; auto.
  rewrite <- IHn2. repeat rewrite <- fun_nat12. rewrite time_correct. reflexivity.
Qed.


Inductive listn : nat -> Set :=
  | niln : listn 0
  | consn : forall n : nat, nat -> listn n -> listn (S n).

Axiom
  ax :
    forall (n n' : nat) (l : listn (n + n')) (l' : listn (n' + n)),
    existS _ (n + n') l = existS _ (n' + n) l'.

Lemma lem :
 forall (n n' : nat) (l : listn (n + n')) (l' : listn (n' + n)),
 n + n' = n' + n /\ existT _ (n + n') l = existT _ (n' + n) l'.
Proof.
intros n n' l l'.

dependent rewrite (ax n n' l l').

split; reflexivity.
Qed.


From Coq Require Export ZArith List.
Import ListNotations.

#[global] Open Scope Z_scope.

Inductive cmd :=
| forward
| up
| down
.

Declare Custom Entry aoc02.

Notation "'input' x .. y" := (cons x .. (cons y nil) ..) (at level 200, x custom aoc02, y custom aoc02, only parsing).
Notation "x y" := (x, y) (in custom aoc02 at level 0, x constr at level 0, y constr at level 0).

Definition example := input
forward 5
down 5
forward 8
up 3
down 8
forward 2
.

(* Part One *)

Definition position : Type := Z * Z.

Definition eval1 (c : cmd) (n : Z) '((hpos, zpos) : position) : position :=
  match c with
  | forward => (hpos + n, zpos)
  | up   => (hpos, zpos - n)
  | down => (hpos, zpos + n)
  end.

Fixpoint eval (xs : list (cmd * Z)) (current : position) : position :=
  match xs with
  | [] => current
  | (c, n) :: xs => eval xs (eval1 c n current)
  end.

Definition solve (xs : list (cmd * Z)) : Z :=
  let '(hpos, zpos) := eval xs (0, 0) in
  hpos * zpos.

(* Compute solve example. *)

(* Part Two *)

Definition position_2 : Type := Z * Z * Z.

Definition eval1_2 (c : cmd) (n : Z) '((hpos, zpos, aim) : position_2) : position_2 :=
  match c with
  | forward => (hpos + n, zpos + n * aim, aim)
  | up => (hpos, zpos, aim - n)
  | down => (hpos, zpos, aim + n)
  end.

Fixpoint eval_2 (xs : list (cmd * Z)) (current : position_2) : position_2 :=
  match xs with
  | [] => current
  | (c, n) :: xs => eval_2 xs (eval1_2 c n current)
  end.

Definition solve2 (xs : list (cmd * Z)) : Z :=
  let '(hpos, zpos, _aim) := eval_2 xs (0, 0, 0) in
  hpos * zpos.

Definition solve12 (i : list (cmd * Z)) : Z * Z := (solve i, solve2 i).

(* Compute solve2 example. *)

(* The second part generalizes the first: the [aim] in Part Two plays the role of
   depth ([zpos]) in Part One. *)

(* We could prove this directly, but just to be fancy, let's make it explicit
   that it relies on a _simulation argument_:
   the single-step functions [eval1] and [eval1_2] preserve a relation [R] between [position]
   and [position_2], so the iterated-step functions [eval] and [eval_2] also preserve [R]. *)

Lemma eval_sim : forall (R : position -> position_2 -> Prop),
  (forall c n p p2, R p p2 -> R (eval1 c n p) (eval1_2 c n p2)) ->
  forall xs p p2,
  R p p2 -> R (eval xs p) (eval_2 xs p2).
Proof.
  intros R SIM; induction xs as [ | [c n] xs IH ]; cbn.
  - trivial.
  - intros * H; apply IH, SIM, H.
Qed.

Lemma eval1_fact : forall c n hpos zpos aim,
  eval1 c n (hpos, aim) = let '(hpos', _, aim') := eval1_2 c n (hpos, zpos, aim) in (hpos', aim').
Proof.
  destruct c; reflexivity.
Qed.

Theorem eval_fact : forall xs hpos zpos aim,
  eval xs (hpos, aim) = let '(hpos', _, aim') := eval_2 xs (hpos, zpos, aim) in (hpos', aim').
Proof.
  intros xs hpos zpos aim; apply eval_sim.
  - intros c n _ [[? ?] ?] ->. apply eval1_fact.
  - reflexivity.
Qed.


Require Export Lists.

Inductive list (X : Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

Check nil.
Check cons.

Check (cons nat 2 (cons nat 1 (nil nat))).

Fixpoint length (X : Type) (l : list X) : nat :=
  match l with
    | nil => O
    | cons h t => S (length X t)
  end.

Example test_length1: length nat (cons nat 1 (cons nat 2 (nil nat))) = 2.
Proof. reflexivity. Qed.
Example test_length2: length bool (cons bool true (nil bool)) = 1.
Proof. reflexivity. Qed.

Fixpoint app (X : Type) (l1 l2 : list X) : (list X) :=
  match l1 with
    | nil => l2
    | cons h t => cons X h (app X t l2)
  end.

Fixpoint snoc (X : Type) (l : list X) (v : X) : (list X) :=
  match l with
    | nil => cons X v (nil X)
    | cons h t => cons X h (snoc X t v)
  end.

Fixpoint rev (X : Type) (l : list X) : (list X) :=
  match l with
    | nil => nil X
    | cons h t => snoc X (rev X t) h
  end.

Example test_rev1: rev nat (cons nat 1 (cons nat 2 (nil nat))) =
                   (cons nat 2 (cons nat 1 (nil nat))).
Proof. reflexivity. Qed.
Example test_rev2: rev bool (nil bool) = nil bool.
Proof. reflexivity. Qed.

Module MumbleBaz.

  Inductive mumble : Type :=
    | a : mumble
    | b : mumble -> nat -> mumble
    | c : mumble.
  Inductive grumble (X : Type) :=
    | d : mumble -> grumble X
    | e : X -> grumble X.

  Inductive baz : Type :=
    | x : baz -> baz
    | y : baz -> bool -> baz.

End MumbleBaz.

Fixpoint app' X l1 l2 : list X :=
  match l1 with
    | nil => l2
    | cons h t => cons X h (app' X t l2)
  end.

Check app'.
Check app.

Fixpoint length' (X : Type) (l : list X) : nat :=
  match l with
    | nil => O
    | cons h t => S (length' _ t)
  end.

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments length {X} l.
Arguments app {X} l1 l2.
Arguments rev {X} l.
Arguments snoc {X} l v.

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).
Check (length list123'').

Fixpoint length'' {X : Type} (l : list X) : nat :=
  match l with
    | nil => O
    | cons h t => S (length'' t)
  end.

Notation "x :: y" := (cons x y) (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y) (at level 60, right associativity).

Definition list123''' := [1;2;3].
Check ([3 + 4] ++ nil).

Fixpoint repeat {X : Type} (n : X) (count : nat) : list X :=
  match count with
    | O => []
    | S n' => n :: repeat n n'
  end.

Example test_repeat1: repeat true 2 = cons true (cons true nil).
Proof. reflexivity. Qed.

Theorem rev_snoc:
  forall X : Type, forall v : X, forall s : list X,
    rev (snoc s v) = v :: (rev s).
Proof.
  intros X v s.
  induction s as [| n s'].
  Case "s = nil".
  simpl. reflexivity.
  Case "s = cons".
  simpl.
  rewrite -> IHs'.
  simpl.
  reflexivity.
Qed.

Theorem rev_involutive:
  forall X : Type, forall l : list X,
    rev (rev l) = l.
Proof.
  intros X l.
  induction l as [| n l'].
  Case "l = nil".
  simpl. reflexivity.
  Case "l = cons".
  simpl.
  rewrite -> rev_snoc.
  rewrite -> IHl'.
  reflexivity.
Qed.

Theorem snoc_with_append:
  forall X : Type, forall l1 l2 : list X, forall v : X,
    snoc (l1 ++ l2) v = l1 ++ (snoc l2 v).
Proof.
  intros X l1 l2 v.
  induction l1 as [| n l1'].
  Case "l1 = nil".
  simpl.  reflexivity.
  Case "l1 = cons".
  simpl.
  rewrite -> IHl1'.
  reflexivity.
Qed.

Inductive prod (X Y : Type) : Type :=
  pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with (x,y) => x end.
Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with (x,y) => y end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y) : list (X * Y) :=
  match (lx, ly) with
    | ([], _) => []
    | (_, []) => []
    | (x::tx, y::ty) => (x,y) :: (combine tx ty)
  end.

Check @combine.

Eval compute in (combine [1;2] [false;false;true;true]).

Fixpoint split {X Y : Type} (l : list (X * Y)) : list (X) * list (Y) :=
  match l with
    | [] => ([], [])
    | (x,y) :: t => (x :: fst (split t), y :: snd (split t))
  end.
Example test_split:
  split [(1, false);(2, false)] = ([1;2], [false;false]).
Proof. reflexivity. Qed.

Inductive option (X : Type) : Type :=
  | None : option X
  | Some : X -> option X.

Arguments Some {X} _.
Arguments None {X}.

Fixpoint index {X : Type} (n : nat) (l : list X) : option X :=
  match l with
    | [] => None
    | a :: l' => if beq_nat n O then Some a else index (pred n) l'
  end.

Example test_index1: index 0 [4;5;6;7] = Some 4.
Proof. reflexivity. Qed.
Example test_index2: index 1 [[1];[2]] = Some [2].
Proof. reflexivity. Qed.
Example test_index3: index 2 [true] = None.
Proof. reflexivity. Qed.

Definition hd_opt {X : Type} (l : list X) : option X :=
  match l with
    | nil => None
    | x :: t => Some x
  end.

Check hd_opt.
Check @hd_opt.

Example test_hd_opt1: hd_opt [1;2] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_opt2: hd_opt [[1];[2]] = Some [1].
Proof. reflexivity. Qed.

Definition doit3times {X : Type} (f: X -> X) (n : X) : X :=
  f (f (f n)).

Check @doit3times.

Example test_doit3times: doit3times minustwo 9 = 3.
Proof. reflexivity. Qed.

Example test_doit3times': doit3times negb true = false.
Proof. reflexivity. Qed.

Check plus.

Definition plus3 := plus 3.
Check plus3.

Example test_plus3: plus3 4 = 7.
Proof. reflexivity. Qed.
Example test_plus3': doit3times plus3 0 = 9.
Proof. reflexivity. Qed.
Example test_plus3'': doit3times (plus 3) 0 = 9.
Proof. reflexivity. Qed.

Definition prod_curry {X Y Z : Type}
           (f: X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

Definition prod_uncurry {X Y Z : Type}
           (f: X -> Y -> Z) (p : X * Y) : Z := f (fst p) (snd p).

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry:
  forall (X Y Z : Type) (f : X -> Y -> Z) x y,
    prod_curry (prod_uncurry f) x y = f x y.
Proof.
  intros X Y Z f x y.
  reflexivity.
Qed.

Theorem curry_uncurry:
  forall (X Y Z : Type) (f : (X * Y) -> Z) (p : X * Y),
    prod_uncurry (prod_curry f) p = f p.
Proof.
  intros X Y Z f p.
  destruct p.
  reflexivity.
Qed.

Fixpoint filter {X : Type} (test : X -> bool) (l : list X) : list X :=
  match l with
    | [] => []
    | cons h t => if test h then h :: (filter test t) else (filter test t)
  end.

Example test_filter1: filter evenb [1;2;3;4] = [2;4].
Proof. reflexivity. Qed.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  beq_nat (length l) 1.

Example test_filter2:
  filter length_is_1 [[1;2]; [3]; [4]; [5;6;7]; []; [8]] =
  [[3]; [4]; [8]].
Proof. reflexivity. Qed.

Definition countoddmembers' (l : list nat) : nat :=
  length (filter oddb l).
Example test_countoddmembers'1: countoddmembers' [1;0;3;1;4;5] = 4.
Proof. reflexivity. Qed.
Example test_countoddmembers'2: countoddmembers' [0;2;4] = 0.
Proof. reflexivity. Qed.
Example test_countoddmembers'3: countoddmembers' nil = 0.
Proof. reflexivity. Qed.

Example test_anon_fun':
  doit3times (fun n => n * n) 2 = 256.
Proof. reflexivity. Qed.

Example test_filter2':
  filter (fun l => beq_nat (length l) 1)
         [[1;2]; [3]; [4]; [5;6;7]; []; [8]]
         = [[3]; [4]; [8]].
Proof. reflexivity. Qed.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter evenb (filter (fun n => ble_nat 7 n) l).
Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
Proof. reflexivity. Qed.
Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
Proof. reflexivity. Qed.

Definition partition {X : Type} (test : X -> bool) (l : list X) : list X * list X :=
  ((filter test l), (filter (fun x => negb (test x)) l)).
Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. reflexivity. Qed.

Fixpoint map {X Y : Type} (f : X -> Y) (l : list X) : (list Y) :=
  match l with
    | [] => []
    | h :: t => (f h) :: (map f t)
  end.

Example test_map1: map (plus 3) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.

Example test_map2: map oddb [2;1;2;5] = [false;true;false;true].
Proof. reflexivity. Qed.

Example test_map3: map (fun n => [evenb n; oddb n]) [2;1;2;5] =
                   [[true;false];[false;true];[true;false];[false;true]].
Proof. reflexivity. Qed.

(* map f (snoc (rev l') n) = snoc (rev (map f l')) (f n) *)
(*Theorem map_snoc:
  forall (X Y : Type) (f : X -> Y) (l : list X),*)

Theorem map_cons:
  forall (X Y : Type) (f : X -> Y) (n : X) (l : list X),
    map f (n::l) = (f n) :: map f l.
Proof.
  intros X Y f n l.
  simpl. reflexivity.
Qed.

Theorem map_snoc:
  forall (X Y : Type) (f : X -> Y) (n : X) (l : list X),
   snoc (map f l) (f n) = map f (snoc l n).
Proof.
  intros X Y f n l.
  induction l as [| n' l'].
  Case "l = nil".
  simpl. reflexivity.
  Case "l = cons".
  simpl.
  rewrite -> IHl'.
  reflexivity.
Qed.

Theorem map_rev:
  forall (X Y : Type) (f : X -> Y) (l : list X),
    map f (rev l) = rev (map f l).
Proof.
  intros X Y f l.
  induction l as [| n l'].
  Case "l = nil".
  simpl. reflexivity.
  Case "l = cons".
  simpl.
  rewrite <- map_snoc.
  rewrite -> IHl'.
  reflexivity.
Qed.

Fixpoint flat_map {X Y : Type} (f : X -> list Y) (l : list X) : (list Y) :=
  match l with
    | [] => []
    | h :: t => (f h) ++ flat_map f t
  end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4] = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof. reflexivity. Qed.

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X) : (option Y) :=
  match xo with
    | None => None
    | Some x => Some (f x)
  end.

Fixpoint fold {X Y : Type} (f : X -> Y -> Y) (l : list X) (b : Y) : Y :=
  match l with
    | [] => b
    | h :: t => f h (fold f t b)
  end.

Check (fold andb).

Example fold_example1 : fold mult [1;2;3;4] 1 = 24.
Proof. reflexivity. Qed.

Example fold_example2 : fold andb [true;true;false;true] true = false.
Proof. reflexivity. Qed.

Example fold_example3 : fold app [[1];[];[2;3];[4]] [] = [1;2;3;4].
Proof. reflexivity. Qed.

Definition constfun {X : Type} (x : X) : nat -> X :=
  fun (k : nat) => x.
Definition ftrue := constfun true.

Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.
Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

Definition override {X : Type} (f : nat -> X) (k : nat) (x : X) : nat -> X :=
  fun (k' : nat) => if beq_nat k k' then x else f k'.

Definition fmostlytrue := override (override ftrue 1 false) 3 false.

Example override_example1 : fmostlytrue 0 = true.
Proof. reflexivity. Qed.

Example override_example2 : fmostlytrue 1 = false.
Proof. reflexivity. Qed.

Example override_example3 : fmostlytrue 2 = true.
Proof. reflexivity. Qed.

Example override_example4 : fmostlytrue 3 = false.
Proof. reflexivity. Qed.

Theorem override_example:
  forall b : bool,
    (override (constfun b) 3 true) 2 = b.
Proof.
  intros b.
  reflexivity.
Qed.

Theorem unfold_example_bad:
  forall m n,
    3 + n = m -> plus3 n + 1 = m + 1.
Proof.
  intros m n H.
Abort.

Theorem unfold_example:
  forall m n,
    3 + n = m -> plus3 n + 1 = m + 1.
Proof.
  intros m n H.
  unfold plus3.
  rewrite -> H.
  reflexivity.
Qed.

Theorem override_eq:
  forall {X : Type} x k (f : nat -> X),
    (override f k x) k = x.
Proof.
  intros X x k f.
  unfold override.
  rewrite <- beq_nat_refl.
  reflexivity.
Qed.

Theorem override_neq:
  forall (X : Type) x1 x2 k1 k2 (f : nat -> X),
    f k1 = x1 -> beq_nat k2 k1 = false -> (override f k2 x2) k1 = x1.
Proof.
  intros X x1 x2 k1 k2 f.
  intros H I.
  unfold override.
  rewrite -> I.
  rewrite -> H.
  reflexivity.
Qed.

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.

Example test_fold_length1 : fold_length [4;7;0] = 3.
Proof. reflexivity. Qed.

Theorem fold_length_correct:
  forall X (l : list X),
    fold_length l = length l.
Proof.
  intros X l.
  induction l as [| n l'].
  Case "l = nil".
  simpl. reflexivity.
  Case "l = cons".
  unfold fold_length.
  simpl.
  rewrite <- IHl'.
  unfold fold_length.
  reflexivity.
Qed.

Definition fold_map {X Y:Type} (f : X -> Y) (l : list X) : list Y :=
  fold (fun x => cons (f x)) l [].

Example test_fold_map: fold_map (plus 3) [1;2;3] = [4;5;6].
Proof. reflexivity. Qed.

Theorem eq_map_fold_map:
  forall (X Y : Type) (f : X -> Y) (l : list X),
    map f l = fold_map f l.
Proof.
  intros X Y f l.
  induction l as [| n l'].
  Case "l = nil".
  simpl. reflexivity.
  Case "l = cons".
  simpl.
  unfold fold_map.
  simpl.
  rewrite -> IHl'.
  unfold fold_map.
  reflexivity.
Qed.


Set Implicit Arguments.
Require Import FunctionalExtensionality.
Require Import DblibTactics.
Require Import DeBruijn.

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

(* Environments map variables to data. *)

(* Environments are homogeneous -- there is only one kind of variables --
   and non-dependent -- variables do not occur within data. *)

(* We represent environments as functions of type [nat -> option A], as
   opposed to lists of type [list A], because functions are slightly more
   pleasant to work with than lists. In particular, their domain need not
   be contiguous, and this makes the definition of insertion more natural. *)

Definition env A :=
  nat -> option A.

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

(* Operations on environments. *)

(* The empty environment is undefined everywhere. *)

Definition empty A : env A :=
  fun y => None.

(* Environment lookup is just function application. *)

Definition lookup A (x : nat) (e : env A) : option A :=
  e x.

(* [insert x a e] inserts a new variable [x], associated with data [a], in the
   environment [e]. The pre-existing environment entries at index [x] and
   above are shifted up. Thus, [insert x] is closely analogous to [shift x]
   for terms. *)

Definition insert A (x : nat) (a : A) (e : env A) : env A :=
  fun y =>
    match lt_eq_lt_dec x y with
    | inleft (left _)  (* x < y *) => e (y - 1)
    | inleft (right _) (* x = y *) => Some a
    | inright _        (* x > y *) => e y
    end.

(* [remove x] is the inverse of [insert x a]. That is, [remove x e] destroys
   the variable [x] in the environment [e]. The variables at index [x + 1]
   and above are shifted down. Thus, [remove x] is closely analogous to
   [subst v x] for terms. *)

(* Experience suggests that it is good style to always work with [insert]
   and avoid using [remove]. This leads to simpler goals and proofs. *)

Definition remove A (x : nat) (e : env A) : env A :=
  fun y =>
    match le_gt_dec x y with
    | left _  (* x <= y *) => e (1 + y)
    | right _ (* x > y *)  => e y
    end.

(* [map f e] is the environment obtained by applying [f] to every datum
   in the environment [e]. *)

Definition map A (f : A -> A) (e : env A) :=
  fun y =>
    match e y with
    | None   => None
    | Some a => Some (f a)
    end.

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

(* Basic arithmetic simplifications. *)

Lemma one_plus_x_minus_one_left:
  forall x,
  (1 + x) - 1 = x.
Proof.
  intros. omega.
Qed.

Lemma one_plus_x_minus_one_right:
  forall x,
  x > 0 ->
  1 + (x - 1) = x.
Proof.
  intros. omega.
Qed.

Ltac one_plus_x_minus_one :=
  repeat rewrite one_plus_x_minus_one_left;
  repeat rewrite one_plus_x_minus_one_right by omega.
  (* I tried [autorewrite with ... using omega]; it does not work. *)

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

(* Interaction between [lookup] and [empty]. *)

Lemma lookup_empty_None:
  forall A x,
  lookup x (@empty A) = None.
Proof.
  unfold lookup, empty. reflexivity.
Qed.

Lemma lookup_empty_Some:
  forall A x (a : A),
  lookup x (@empty _) = Some a ->
  False.
Proof.
  unfold lookup, empty. intros. congruence.
Qed.

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

(* Interaction between [lookup] and [insert]. *)

Lemma lookup_insert_bingo:
  forall A x y (a : A) e,
  x = y ->
  lookup x (insert y a e) = Some a.
Proof.
  intros. subst. unfold lookup, insert. dblib_by_cases. reflexivity.
Qed.

Lemma lookup_insert_recent:
  forall A x y (a : A) e,
  x < y ->
  lookup x (insert y a e) = lookup x e.
Proof.
  intros. unfold lookup, insert. dblib_by_cases. reflexivity.
Qed.

Lemma lookup_insert_old:
  forall A x y (a : A) e,
  x > y ->
  lookup x (insert y a e) = lookup (x - 1) e.
Proof.
  intros. unfold lookup, insert. dblib_by_cases. reflexivity.
Qed.

Lemma lookup_shift_insert:
  forall A x y (a : A) e,
  lookup (shift y x) (insert y a e) = lookup x e.
Proof.
  intros. destruct_lift_idx.
  rewrite lookup_insert_old by omega. f_equal. omega.
  rewrite lookup_insert_recent by omega. reflexivity.
Qed.

Ltac lookup_insert :=
  first [
    rewrite lookup_insert_bingo by omega
  | rewrite lookup_insert_old by omega; one_plus_x_minus_one
  | rewrite lookup_insert_recent by omega
  | rewrite lookup_shift_insert
  ].

Ltac lookup_insert_all :=
  first [
    rewrite lookup_insert_bingo in * by omega
  | rewrite lookup_insert_old in * by omega; one_plus_x_minus_one
  | rewrite lookup_insert_recent in * by omega
  | rewrite lookup_shift_insert in *
  ].

Hint Extern 1 (lookup _ (insert _ _ _) = _) =>
  lookup_insert
: lookup_insert.

Hint Extern 1 (lookup _ _ = _) =>
  lookup_insert_all
: lookup_insert.

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

(* Interaction between [lookup] and [map]. *)

Lemma lookup_map_some:
  forall A x (a : A) e f,
  lookup x e = Some a ->
  lookup x (map f e) = Some (f a).
Proof.
  unfold lookup, map. intros. case_eq (e x); intros; congruence.
Qed.

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

(* [insert] commutes itself, just like [lift] commutes with itself. *)

Lemma insert_insert:
  forall A k s (a b : A) e,
  k <= s ->
  insert k a (insert s b e) = insert (1 + s) b (insert k a e).
Proof.
  unfold insert. intros. extensionality y. dblib_by_cases; eauto with f_equal omega.
Qed.

(* Attempting to rewrite in both directions may seem redundant, because of the
   symmetry of the law [insert_insert]. It is not: because [omega] fails in
   the presence of meta-variables, rewriting in one direction may be possible
   while the other direction fails. *)

Ltac insert_insert :=
  first [
    rewrite insert_insert by omega; reflexivity
  | rewrite <- insert_insert by omega; reflexivity
  ].

Hint Extern 1 (insert _ _ (insert _ _ _) = _) =>
  insert_insert
: insert_insert.

Hint Extern 1 (_ = insert _ _ (insert _ _ _)) =>
  insert_insert
: insert_insert.

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

(* Interaction between [remove] and [insert]. *)

Lemma remove_insert:
  forall A x (a : A) e,
  remove x (insert x a e) = e.
Proof.
  intros. unfold remove, insert. extensionality y.
  dblib_by_cases; eauto with f_equal omega.
Qed.

Lemma insert_remove_bingo:
  forall A x y (a : A) e,
  lookup x e = Some a ->
  y = x ->
  insert y a (remove x e) = e.
Proof.
  unfold lookup, remove, insert. intros. extensionality z.
  dblib_by_cases; eauto with f_equal omega; congruence.
Qed.

Lemma insert_remove_recent:
  forall A x y (a : A) e,
  y <= x ->
  insert y a (remove x e) = remove (1 + x) (insert y a e).
Proof.
  intros. unfold insert, remove. extensionality z.
  dblib_by_cases; eauto with f_equal omega.
Qed.

Lemma insert_remove_old:
  forall A x y (a : A) e,
  y >= x ->
  insert y a (remove x e) = remove x (insert (1 + y) a e).
Proof.
  intros. unfold insert, remove. extensionality z.
  dblib_by_cases; eauto with f_equal omega.
Qed.

Ltac insert_remove :=
  first [
    rewrite insert_remove_recent by omega; reflexivity
  | rewrite insert_remove_old by omega; reflexivity
  | rewrite <- insert_remove_recent by omega; reflexivity
  | rewrite <- insert_remove_old by omega; reflexivity
  ].

Hint Extern 1 (remove _ (insert _ _ _) = insert _ _ (remove _ _)) =>
  insert_remove
: insert_remove.

Hint Extern 1 (insert _ _ (remove _ _)= remove _ (insert _ _ _) ) =>
  insert_remove
: insert_remove.

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

(* Interaction between [lookup] and [remove]. *)

Lemma lookup_remove:
  forall A x y (e : env A),
  lookup y (remove x e) = lookup (shift x y) e.
Proof.
  intros.  unfold lookup, remove. destruct_lift_idx; reflexivity.
Qed.

Lemma lookup_remove_old:
  forall A x y (e : env A),
  y >= x ->
  lookup y (remove x e) = lookup (1 + y) e.
Proof.
  intros. unfold lookup, remove. dblib_by_cases; eauto with f_equal omega.
Qed.

Lemma lookup_remove_recent:
  forall A x y (e : env A),
  y < x ->
  lookup y (remove x e) = lookup y e.
Proof.
  intros. unfold lookup, remove. dblib_by_cases; eauto with f_equal omega.
Qed.

Ltac lookup_remove :=
  first [
    rewrite lookup_remove_old by omega; one_plus_x_minus_one
  | rewrite lookup_remove_recent by omega
  ].

Hint Extern 1 (lookup _ (remove _ _) = _) =>
  lookup_remove
: lookup_remove.

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

(* Interaction between [map] and [insert]. *)

Lemma map_insert:
  forall A f x (a : A) e,
  map f (insert x a e) = insert x (f a) (map f e).
Proof.
  unfold map, insert. intros. extensionality y. dblib_by_cases; eauto with f_equal omega.
Qed.

Ltac map_insert :=
  first [
    rewrite map_insert; reflexivity
  | rewrite <- map_insert; reflexivity
  ].

Hint Extern 1 (map _ (insert _ _ _) = insert _ _ (map _ _)) =>
  map_insert
: map_insert.

Hint Extern 1 (insert _ _ (map _ _) = map _ (insert _ _ _)) =>
  map_insert
: map_insert.

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

(* [map] composes with itself. *)

Lemma map_map_fuse:
  forall A f g h e,
  (forall (d : A), f (g d) = h d) ->
  map f (map g e) = map h e.
Proof.
  intros. unfold map. extensionality y. case_eq (e y); congruence.
Qed.

Lemma map_map_exchange:
  forall A f1 f2 g1 g2 e,
  (forall (d : A), f1 (f2 d) = g1 (g2 d)) ->
  map f1 (map f2 e) = map g1 (map g2 e).
Proof.
  intros. unfold map. extensionality y. case_eq (e y); congruence.
Qed.

Lemma map_lift_map_lift:
  forall T k s wk ws (e : env T),
  forall `{Lift T},
  @LiftLift T _ ->
  k <= s ->
  map (lift wk k) (map (lift ws s) e) = map (lift ws (wk + s)) (map (lift wk k) e).
Proof.
  eauto using map_map_exchange, @lift_lift.
Qed.

Lemma map_map_vanish:
  forall A f g (e : env A),
  (forall x, f (g x) = x) ->
  map f (map g e) = e.
Proof.
  intros. unfold map. extensionality y. case_eq (e y); congruence.
Qed.

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

(* A definition of (an upper bound on) the length of an environment. *)

Definition length A (e : env A) (k : nat) :=
  forall x,
  k <= x ->
  lookup x e = None.

(* Every variable that is defined in the environment is less than the
   length of the environment. *)

Lemma defined_implies_below_length:
  forall A (e : env A) x k a,
  length e k ->
  lookup x e = Some a ->
  x < k.
Proof.
  intros.
  (* If [x < k] holds, the result is immediate. Consider the other case,
     [k <= x]. *)
  case (le_gt_dec k x); intro; try tauto.
  (* By definition of [length], [lookup x e] is [None]. *)
  assert (lookup x e = None). auto.
  (* We obtain a contradiction. *)
  congruence.
Qed.

Hint Resolve defined_implies_below_length : lift_idx_hints.

(* The empty environment has zero length. *)

Lemma length_empty:
  forall A k,
  length (@empty A) k.
Proof.
  repeat intro. apply lookup_empty_None.
Qed.

(* Extending an environment increments its length by one. *)

Lemma length_insert:
  forall A (e : env A) k a,
  length e k ->
  length (insert 0 a e) (1 + k).
Proof.
  unfold length; intros. lookup_insert. eauto with omega.
Qed.

Hint Resolve length_empty length_insert : length.

Hint Resolve length_insert : construction_closed.

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

(* A definition of when two environments agree up to length [k]. *)

Definition agree A (e1 e2 : env A) (k : nat) :=
  forall x,
  x < k ->
  lookup x e1 = lookup x e2.

(* A simple consequence of the definition. *)

Lemma agree_below:
  forall A (e1 e2 : env A) x a k,
  lookup x e1 = Some a ->
  length e1 k ->
  agree e1 e2 k ->
  lookup x e2 = Some a.
Proof.
  do 6 intro. intros hlookup ? ?.
  rewrite <- hlookup. symmetry.
  eauto using defined_implies_below_length.
Qed.

(* The empty environment agrees with every environment up to length [0]. *)

Lemma agree_empty:
  forall A (e : env A),
  agree (@empty _) e 0.
Proof.
  unfold agree. intros. elimtype False. omega.
Qed.

(* If two environments that agree up to [k] are extended with a new variable,
   then they agree up to [k+1]. *)

Lemma agree_insert:
  forall A (e1 e2 : env A) k,
  agree e1 e2 k ->
  forall x a,
  x <= k ->
  agree (insert x a e1) (insert x a e2) (1 + k).
Proof.
  unfold agree, lookup, insert. intros. dblib_by_cases; eauto with omega.
Qed.

Hint Resolve agree_below agree_empty agree_insert : agree.

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

(* Extending an environment with a list of bindings found in a pattern. *)

(* Note that we cannot define the concatenation of two environments, because
   we view environments as functions, so we do not have precise control over
   their domain. Only a list has finite domain. *)

(* Concatenation is just an iterated version of [insert 0]. *)

Fixpoint concat (A : Type) (e1 : env A) (e2 : list A) : env A :=
  match e2 with
  | nil =>
      e1
  | cons a e2 =>
      concat (insert 0 a e1) e2
  end.

(* Concatenation acts upon the length of the environment in an obvious
   manner. *)

Lemma length_concat:
  forall A (e2 : list A) (e1 : env A) n1 n,
  length e1 n1 ->
  n1 + List.length e2 = n ->
  length (concat e1 e2) n.
Proof.
  induction e2; simpl; intros.
  replace n with n1 by omega. assumption.
  eauto using length_insert with omega.
Qed.

Hint Resolve length_concat : length construction_closed.

(* If [e1] and [e2] agree up to depth [k], then, after extending them
   with a common suffix [e], they agree up to depth [k + length e]. *)

Lemma agree_concat:
  forall A (e : list A) (e1 e2 : env A) k n,
  agree e1 e2 k ->
  k + List.length e = n ->
  agree (concat e1 e) (concat e2 e) n.
Proof.
  induction e; simpl; intros.
  replace n with k by omega. assumption.
  eauto using agree_insert with omega.
Qed.

Hint Resolve agree_concat : agree.

(* Concatenation and insertion commute. *)

Lemma insert_concat:
  forall (A : Type) n x nx (a : A) e1 e2,
  List.length e2 = n ->
  n + x = nx ->
  insert nx a (concat e1 e2) = concat (insert x a e1) e2.
Proof.
  induction n; intros; subst; destruct e2; simpl in *; try discriminate; auto.
  rewrite insert_insert by omega.
  erewrite <- (IHn (1 + x)) by first [ congruence | eauto ].
  eauto with f_equal omega.
Qed.

(* [replicate n a] is a list of [n] elements, all of which are
   equal to [a]. *)

Fixpoint replicate (A : Type) (n : nat) (a : A) : list A :=
  match n with
  | 0 =>
      @nil _
  | S n =>
      cons a (replicate n a)
  end.

(* The list [replicate n a] has length [n]. *)

Lemma length_replicate:
  forall (A : Type) n (a : A),
  List.length (replicate n a) = n.
Proof.
  induction n; simpl; auto.
Qed.

(* A special case of [insert_concat]. *)

Lemma insert_concat_replicate:
  forall (A : Type) n x nx (a b : A) e1,
  n + x = nx ->
  insert nx a (concat e1 (replicate n b)) = concat (insert x a e1) (replicate n b).
Proof.
  eauto using insert_concat, length_replicate.
Qed.

(* [concat . (replicate . a)] is just an iterated version of [insert . a]. *)

Lemma concat_replicate_is_iterated_insert:
  forall (A : Type) n (a : A) e,
  insert n a (concat e (replicate n a)) =
  concat e (replicate (S n) a).
Proof.
  intros. simpl. eauto using insert_concat, length_replicate.
Qed.

Hint Resolve insert_concat length_replicate insert_concat_replicate
concat_replicate_is_iterated_insert : insert_concat.

(* A special case of [length_concat]. *)

Lemma length_concat_replicate:
  forall A (a : A) (e1 : env A) n1 n2 n,
  length e1 n1 ->
  n1 + n2 = n ->
  length (concat e1 (replicate n2 a)) n.
Proof.
  intros. eapply length_concat. eauto. rewrite length_replicate. eauto.
Qed.

Hint Resolve length_concat_replicate : length construction_closed.

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

(* Make some definitions opaque, so that Coq does not over-simplify in
   unexpected (and fragile) ways. *)

Global Opaque empty lookup insert remove map.


(**
プログラミング Coq 証明駆動開発入門(1)
http://www.iij-ii.co.jp/lab/techdoc/coqt/coqt8.html

をSSReflectに書き直した。
その上で、「Program Fixpoint」を使って定義をした。
*)

From mathcomp Require Import all_ssreflect.
Require Import Program.

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

(* ************ *)
(* 不等号の証明 *)
(* ************ *)
(*
(* lt なら le *)
(* ltnW でよかった。 *)
Lemma lt__le n n' : n > n' -> n' <= n.
Proof.
  move=> H.
  rewrite leq_eqVlt.
  by apply/orP; right.
Qed.

Lemma b_false__not_b b : b = false -> ~ b.
Proof.
  Search _ (_ = false).
  by apply/elimF/idP.
Qed.

(* le の否定が lt になる。 *)
Lemma not_le__lt n n' : ~ n <= n' <-> n' < n.
Proof.
  rewrite /not ltnNge /negb.
  split => H.
  - case: (n <= n') H => H.
    + exfalso.
        by apply H.
    + by [].
  - case: (n <= n') H => H H'.
    + by inversion H.
    + by inversion H'.
Qed.

(* 証明途中に出現するもの。 *)
Lemma test n n' : (n <= n') = false -> n' <= n.
Proof.
  move=> H.
  apply lt__le.
  apply not_le__lt.
  by apply b_false__not_b.
Qed.
 *)

Lemma le_false_lt n n' : (n <= n') = false -> n' < n.
Proof.
  move=> H.
  apply/ltP.
  apply PeanoNat.Nat.nle_gt.
  apply/leP.
  by apply negbT.
Qed.

(* Hint Resolve not_le__lt b_false__not_b : myleq. *)
Hint Resolve le_false_lt : myleq.

(* **** *)
(* 証明 *)
(* **** *)
Lemma perm_refl' : forall l : seq nat, perm_eq l l.
Proof.
  by [].
Qed.

Lemma perm_sym' : forall l l' : seq nat, perm_eq l l' -> perm_eq l' l.
Proof.
  move=> l l'.
  have H := @perm_eq_sym nat_eqType.
  rewrite /symmetric in H.
  by rewrite H.
Qed.

Lemma perm_trans' : forall l l' l'' : seq nat,
    perm_eq l l' -> perm_eq l' l'' -> perm_eq l l''.
Proof.
  move=> l l' l''.
  have H := @perm_eq_trans nat_eqType.
  rewrite /transitive in H.
    by eapply H.
Qed.

Lemma perm_cons' : forall (n : nat) (l l' : seq nat),
    perm_eq l l' -> perm_eq (n :: l) (n :: l').
Proof.
  move=> n l l'.
  have H := @perm_cons nat_eqType.
    by rewrite H.
Qed.

Lemma perm_iff : forall (m n : seq nat),
                   (forall l, perm_eq m l = perm_eq n l) <-> perm_eq m n.
Proof.
  move=> m n.
  split=> H.
  - by rewrite H.
  - by apply/perm_eqlP.
Qed.

Lemma perm_swap : forall (l l' : seq nat) (x a : nat),
                    perm_eq [:: x, a & l] l' = perm_eq [:: a, x & l] l'.
Proof.
  move=> l l' x a.
  apply perm_iff.
  Check cat1s.
  rewrite -[[:: x, a & l]]cat1s.
  rewrite -[[:: a & l]]cat1s.
  rewrite -[[:: a, x & l]]cat1s.
  rewrite -[[:: x & l]]cat1s.
  apply/perm_eqlP.
  by apply (perm_catCA [:: x] [:: a] l).
Qed.

Hint Resolve perm_cons' perm_refl' perm_swap perm_trans' : perm.

(* **** *)
(* 証明 *)
(* **** *)
Inductive LocallySorted (T : eqType) (R : rel T) : seq T -> Prop :=
| LSorted_nil : LocallySorted R nil
| LSorted_cons1 : forall a : T, LocallySorted R (a :: nil)
| LSorted_consn : forall (a b : T) (l : seq T),
                    LocallySorted R (b :: l) ->
                    R a b -> LocallySorted R (a :: b :: l).

Hint Resolve LSorted_nil LSorted_cons1 LSorted_consn : sort.

(* Permutation, seq.v *)
Check perm_eq (1::2::3::nil) (2::1::3::nil).
Eval compute in perm_eq (1::2::3::nil) (2::1::3::nil). (* true *)
Eval compute in perm_eq nil nil.                       (* true *)

(* ソート処理の定義 *)

(*
うまくいかなかった定義：
引数に事前条件を書くとうまくいかないようである。

Program Fixpoint insert' (a : nat) (l : {l : seq nat | LocallySorted leq l})
        {measure (size l)}
  : {s : seq nat | LocallySorted leq s /\ perm_eq (a :: l) s} :=
  match l with
  | nil => a :: nil
  | x :: xs => if a <= x then
                 a :: l
               else
                 x :: insert' a xs
  end.
 *)

Program Fixpoint insert n l {struct l} :
  {l' : seq nat | perm_eq (n ::l) l' /\
                  (LocallySorted leq l -> LocallySorted leq l') /\
                  (head n l' = n \/ head n l' = head n l)} :=
  match l with
  | nil => n :: nil
  | n' :: l' =>
    if n <= n' then
      n :: n' :: l'
    else
      n' :: insert n l'
  end.
Obligations.

Next Obligation.
    by auto with sort.
Defined.

Next Obligation.
  case Hnn' : (n <= n').
  - by auto with sort.
  - split.
    + erewrite perm_swap.
        by apply perm_cons'.
      (* by eauto with sort. *)
    + split.
      * move=> H0.
        assert (LocallySorted leq l') as H1 by (inversion H0; auto with sort).
        assert (LocallySorted leq x)  as H2 by auto.
        elim: x i l0 o H2.
        ** by auto with sort.
        ** inversion H0; subst.
           *** move=> a l _ _ _ Ho H2; rewrite /= in Ho.
               case: Ho => Ho; subst;
                             by auto with sort myleq.
               (*
               **** apply sorted2; by [apply ltnW, not_le__lt, b_false__not_b |].
               **** apply sorted2; by [apply ltnW, not_le__lt, b_false__not_b |].
               *)
           *** move=> a l' _ _ _ Ho H2; rewrite /= in Ho.
               case: Ho => Ho; subst;
                             by auto with sort myleq.
               (*
               **** apply sorted2; by [apply ltnW, not_le__lt, b_false__not_b |].
               **** apply sorted2; by [].
               *)
      * by auto.
Defined.

Program Fixpoint isort l {struct l} :
  {l' : seq nat | perm_eq l l' /\ LocallySorted leq l'} :=
match l with
| nil => nil
| a::l' => insert a (isort l')
end.

Next Obligation.
  by auto with sort.
Defined.

Next Obligation.
  remember (insert a x).
  case H : s => /= {Heqs}; subst.
    by intuition; eauto with perm.

    Undo 1.
  intuition.
  Check @perm_trans' (a :: l') (a :: x).
  - apply (@perm_trans' (a :: l') (a :: x)).
    + by apply perm_cons'.
    + by apply H.
  - apply (@perm_trans' (a :: l') (a :: x)).
    + by apply perm_cons'.
    + by apply H.
Defined.

Print sort.

Eval compute in proj1_sig (insert 1 nil).                (* [:: 1] *)
Eval compute in proj1_sig (insert 5 [:: 1; 4; 2; 9; 3]). (* [:: 1; 4; 2; 5; 9; 3] *)
Eval compute in proj1_sig (isort [:: 2; 4; 1; 5; 3]).    (* [:: 1; 2; 3; 4; 5] *)

Extraction insert.
Extraction isort.

(* ******************* *)
(* insert を使う merge *)
(* ******************* *)
Lemma sorted_ind_inv h ls : LocallySorted leq (h :: ls) -> LocallySorted leq ls.
Proof.
  move=> H.
  inversion H.
  - by auto with sort.
  - by [].
Qed.

Hint Resolve sorted_ind_inv : sort.

Program Fixpoint merge' (ls1 ls2 : seq nat) :
  {l' : seq nat | perm_eq (ls1 ++ ls2) l' /\
                  (LocallySorted leq ls1 /\ LocallySorted leq ls2 ->
                   LocallySorted leq l')} :=
  match ls1 with
  | nil => ls2
  | h :: ls' => insert h (merge' ls' ls2)
  end.
Obligations.
Next Obligation.
  split.
  - by [].
  - by case.
Defined.
Next Obligation.
  remember (insert h x) as s.
  case H : s => /= {Heqs}; subst.
  intuition.                          (* ゴールの /\ をsplit する。 *)
  - by debug eauto with sort perm.
  - by debug eauto with sort.
  - by debug eauto with sort perm.
  - by debug eauto with sort.
Defined.

Print merge'.

(* 未了 *)
(* 補題が足らないので、続きをする場合は *)
(* 新しくファイルを別にして、sortedなどの補題を充実させる。 *)
(* 未了 *)

(* *********************** *)
(* insert を使わない merge *)
(* *********************** *)
Program Fixpoint merge (ls1 ls2 : seq nat)
  {measure (size ls1 + size ls2)} :
  {l' : seq nat | perm_eq (ls1 ++ ls2) l' /\
                        (LocallySorted leq ls1 /\ LocallySorted leq ls2 ->
                         LocallySorted leq l')} :=
  (* match (ls1, ls2) とすると、ペアどうしの代入の前提が解けない。 *)
  (* 「'」をつけてもだめのよう。 *)
  match ls1 with
  | [::] => ls2
  | x :: ls1' => match ls2 with
                 | [::] => ls1
                 | y :: ls2' => if x <= y then
                                  x :: (merge ls1' ls2)
                                else
                                  y :: (merge ls1 ls2')
                 end
  end.
Obligations.
Next Obligation.
  split.
  - by [].
  - by case.
Defined.
Next Obligation.
  intuition.
  by rewrite cats0.
Defined.
Next Obligation.
  apply/ltP.
  by rewrite ltn_add2l.
Defined.
Next Obligation.
  remember (merge ls1' (y :: ls2') _) as s.
  case H : s => /= {Heqs}; subst.
  remember (merge (x :: ls1') ls2' _) as s.
  case H : s => /= {Heqs}; subst.
  case H : (x <= y); split.
Admitted.

Program Fixpoint splits (ls : seq nat) :
  { (ls1,ls2) : seq nat * seq nat |
    perm_eq ls (ls1 ++ ls2) /\
    (LocallySorted leq ls -> LocallySorted leq ls1) /\
    (LocallySorted leq ls -> LocallySorted leq ls2) } :=
  match ls with
  | [::] => ([::], [::])
  | [:: h] => ([:: h], [::])
  | [:: h1, h2 & ls'] =>
    let '(ls1, ls2) := splits ls' in (* let の左辺に"'"をつける。バニラCoq *)
    (h1 :: ls1, h2 :: ls2)
  end.
Obligations.
Next Obligation.
  Admitted.
Next Obligation.
  Admitted.

(* END *)


Section Z1.

Variables A B C : Prop.

Lemma z1l1: A -> (B -> A).
Proof.
  intros.
  assumption.
Qed.

Lemma z1l2: (A -> B -> C) -> (A -> B) -> A -> C.
Proof.
  intros.
  apply H.
  - assumption.
  - apply H0.
    assumption.
Qed.

Lemma z1l4: A -> ~~A.
Proof.
  intros.
  intro.
  absurd A.
  - assumption.
  - assumption.
Qed.

Lemma z1l6: ~~~A -> ~A.
Proof.
  intro.
  (* tauto. *)
  intro.
  absurd A.
  - intro.
    apply H.
    intro.
    absurd A; assumption.
  - assumption.
Qed.

(* Lemma z1l7: (~A -> B) -> A *)
(*              1  1 x  0 0 *)

Lemma z1l9: ((((A -> B) -> A) -> A) -> B) -> B.
Proof.
  intros.
  apply H.
  intros.
  apply H0.
  intros.
  apply H.
  intros.
  assumption.
Qed.

Lemma z1l10: (A -> B) -> (A -> ~B) -> A -> C.
Proof.
  intros.
  absurd B.
  - apply H0; assumption.
  - apply H; assumption.
Qed.

Require Import Classical.

Lemma z1l3: (~A -> A) -> A.
Proof.
  intros.
  destruct classic with A.
  - assumption.
  - apply H.
    assumption.
Qed.

Lemma z1l5: ~~A -> A.
Proof.
  apply NNPP.
Qed.

Lemma z1l8: ~(A -> B) -> A.
Proof.
  intros.
  apply NNPP.
  intro.
  apply H.
  intro.
  absurd A.
  - assumption.
  - assumption.
  (* tauto. *)
Qed.

End Z1.

Section Z2.

Require Import Classical.

Variable S T : Set.
Variable A : S -> T -> Prop.
Variable B : T -> Prop.
Variable C : Prop.

(* Lemma z2l1: (exists x, forall y, A x y) -> forall x, exists y, A x y. *)

Lemma z2l2: (~forall x, B x) -> exists x, ~(B x).
Proof.
  intro.
  apply NNPP.
  intro.
  apply H.
  intro.
  destruct classic with (B x).
  - assumption.
  - exfalso.
    apply H0.
    exists x.
    assumption.
Qed.

Lemma z2l3: (exists x, ~(B x)) -> (~forall x, B x).
Proof.
  intros.
  intro.
  destruct H.
  absurd (B x).
  - assumption.
  - apply H0.
Qed.

Lemma z2l4: (~exists x, B x) -> forall x, ~B x.
Proof.
  intros.
  intro.
  apply H.
  exists x.
  assumption.
Qed.

Lemma z2l5: (forall x, ~B x) -> ~exists x, B x.
Proof.
  intros.
  intro.
  destruct H0.
  absurd (B x).
  - apply H.
  - assumption.
Qed.

(* Lemma z2l6: (C -> exists x, B x) -> (exists x, C -> B x). *)

Lemma z2l7: (exists x, C -> B x) -> C -> exists x, B x.
Proof.
  intros.
  destruct H.
  exists x.
  apply H.
  assumption.
Qed.

(* Lemma z2l8: exists x, forall y, B x -> B y. *)

End Z2.

Section Z3.

Variable T : Set.
Variable C : T -> Prop.
Variable S : T -> Prop.
Variable G : T -> T -> Prop.

Axiom a3 :
forall x, C x /\ S x ->
forall y, S y -> (~ G y y -> G x y) /\ (G y y -> ~ G x y).

Lemma z3 :
~ exists x, C x /\ S x.
Proof.
  intro.
  destruct H.
  apply a3 with (y:=x) in H as H1.
  - apply H1; apply H1; intro; apply H1; assumption.
  - apply H.
Qed.

End Z3.

Section Z4.

Variables A B : Prop.

Lemma not_or: ~(A \/ B) -> ~A /\ ~B.
Proof.
  intro.
  split.
  - intro.
    apply H.
    left.
    assumption.
  - intro.
    apply H.
    right.
    assumption.
Qed.

Lemma and_not: ~A /\ ~B -> ~(A \/ B).
Proof.
  intro.
  intro.
  destruct H0 as [HA | HB].
  - absurd A.
    + apply H.
    + apply HA.
  - absurd B.
    + apply H.
    + apply HB.
Qed.

Lemma or_not: ~A \/ ~B -> ~(A /\ B).
Proof.
  intro.
  intro.
  destruct H.
  - absurd A.
    + assumption.
    + apply H0.
  - absurd B.
    + assumption.
    + apply H0.
Qed.

Require Import Classical.

Lemma not_and: ~(A /\ B) -> ~A \/ ~B.
Proof.
  intro.
  apply NNPP.
  intro.
  apply H.
  split.
  - apply NNPP.
    intro.
    apply H0.
    left.
    assumption.
  - apply NNPP.
    intro.
    apply H0.
    right.
    assumption.
Qed.

End Z4.

Section Z5.

(* Auto -
This tactic implements a Prolog-like resolution procedure to solve the current goal.
It first tries to solve the goal using the assumption tactic,
then it reduces the goal to an atomic one using intros
and introduces the newly generated hypotheses as hints.
Then it looks at the list of tactics associated to the head symbol of the goal
and tries to apply one of them (starting from the tactics with lower cost).
This process is recursively applied to the generated subgoals.

By default, auto only uses the hypotheses of the current goal and
the hints of the database named core. *)

Variables A B : Prop.

Lemma aux: A -> A /\ A /\ A /\ A /\ A.
Proof.
  (* auto 4. *)
  auto 5.
Qed.

End Z5.

Print nat.
Print bool.

Lemma t: nat <> bool.
Proof.
  intro.
Qed.


Require Export Poly_J.

Theorem double_injective_FAILED : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m. induction n as [| n'].
  Case "n = O". simpl. intros eq. destruct m as [| m'].
    SCase "m = O". reflexivity.
    SCase "m = S m'". inversion eq.
  Case "n = S n'". intros eq. destruct m as [| m'].
    SCase "m = O". inversion eq.
    SCase "m = S m'".
      assert (n' = m') as H.
      SSCase "Proof of assertion".
Admitted.

Theorem double_injective' : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
  Case "n = O". simpl. intros m eq. destruct m as [| m'].
    SCase "m = O". reflexivity.
    SCase "m = S m'". inversion eq.
  Case "n = S n'".
    intros m eq.
    destruct m as [| m'].
    SCase "m = O". inversion eq.     SCase "m = S m'".
      assert (n' = m') as H.
      SSCase "Proof of assertion". apply IHn'.
        inversion eq. reflexivity.
      rewrite -> H. reflexivity. Qed.

Theorem double_injective_take2 : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m.
  generalize dependent n.
  induction m as [| m'].
  Case "m = O". simpl. intros n eq. destruct n as [| n'].
    SCase "n = O". reflexivity.
    SCase "n = S n'". inversion eq.
  Case "m = S m'". intros n eq. destruct n as [| n'].
    SCase "n = O". inversion eq.
    SCase "n = S n'".
      assert (n' = m') as H.
      SSCase "Proof of assertion".
        apply IHm'. inversion eq. reflexivity.
      rewrite -> H. reflexivity. Qed.


Require Import Reals.

Open Scope R_scope.

Definition Real := R.

(* function parameter *)
Variable s : Real.

(* constant *)
Parameter Kt Bm Ke : Real.

(* variables *)
Parameter Rm Lm Jm : Real.

(* functions from s to real. *)
Variables Um Im Om Tm : Real -> Real.

Definition tm1 := (Um s) - Rm * (Im s) - Lm * s * (Im s) - Ke * (Om s).
Definition tm2 := Kt * (Im s) - Jm * s * (Om s) - Bm * (Om s) - (Tm s).
Definition tm3 := (Tm s) * (Lm *s + Rm).
Definition tm4 := (Um s) * Kt - Kt * Ke * (Om s) - (Lm * s + Rm) * (Jm * s + Bm) * (Om s).

(* assumptions of this deduction. *)
Axiom e1 : tm1 = 0.
Axiom e2 : tm2 = 0.

Definition tm5 :=  ((Um s) - Rm * (Im s) - (Lm * s) * (Im s)).

Lemma eq0_eq : forall y z, y-z = 0 -> y = z.
intros.
apply sym_eq.
apply Rminus_diag_uniq_sym.
assumption.
Qed.

(* move Ke * (Om s) in tm1 to the  right of  = *)
Lemma tm5_eq : tm5  = Ke * (Om s).
apply eq0_eq.
apply e1.
Qed.

Definition tm6 :=  ((Um s) - (Rm + Lm * s) * (Im s)).

Lemma  tm6_eq_tm5 : tm6 = tm5.
unfold tm5; unfold tm6.
ring.
Qed.

Lemma tm6_eq : tm6 = Ke * (Om s).
rewrite tm6_eq_tm5.
apply tm5_eq.
Qed.


Theorem Disjunctive_syllogism : forall P Q: Prop, (P \/ Q) -> ~P -> Q.
intros.
case H.
intros.
exfalso.
apply H0.
apply H1.
intros.
apply H1.
Qed.