Section Ejercicio1.

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

Definition nilnat: list nat := nil nat.
Definition consnat: nat -> list nat -> list nat:= cons nat.

Check(list nat).
Check(consnat 0 nilnat).

Inductive arbol (X:Set): Set :=
  empty : arbol X
  | branch : X -> arbol X -> arbol X -> arbol X.

Inductive bintree (X:Set) :=
  Empty : bintree X
  | Branch : X -> bintree X -> bintree X -> bintree X.

Variable f : Set -> Set.

Inductive array (X:Set) : nat -> Set :=
  emptyarr : array X 0
  | consarr : forall n: nat,
    X -> array  X n ->  array X  (n + 1).

Inductive matrix (X:Set) : nat -> nat -> Set :=
  one_col : forall n: nat, array X n -> matrix X n 1
  | consm : forall n m: nat,
    matrix X n m -> array X n -> matrix X n (m+1).

Inductive leq : nat -> nat -> Prop :=
  le0 : forall n:nat, leq 0 n
  | leS : forall n m:nat, leq n m -> leq (S n) (S m).

(**
Fixpoint leq (n : nat) (m : nat) : bool := match n, m with
                                           | 0, _ => true
                                           | _, 0 => false
                                           | (S s), (S t) => leq s t
                                           end.

Eval compute in (leq 1 2).
**)

Inductive eq_list (X:Set) : list X -> list X -> Prop :=
  eq_list_nil : eq_list X (nil X) (nil X)
  | eq_list_cons : forall (l1 l2 : list X) (x1 x2 : X),
    x1 = x2 -> eq_list X (cons X x1 l1) (cons X x2 l2).

Inductive sorted (X:Set) (f:X->X->Prop) : list X -> Prop :=
  sorted_nil : sorted X f (nil X)
  | sorted_singleton : forall x:X, sorted X f (cons X x (nil X))
  | sorted_cons : forall (l : list X) (x1 x2 : X),
    f x1 x2 -> sorted X f (cons X x2 l) ->
      sorted X f (cons X x1 (cons X x2 l)).

Inductive mirror (X:Set) : bintree X -> bintree X -> Prop :=
  mirror_empty : mirror X (Empty X) (Empty X)
  | mirror_branch : forall (t11 t12 t21 t22 : bintree X) (x1 x2 : X),
    mirror X t11 t22 -> mirror X t12 t21 ->
      x1 = x2 -> mirror X (Branch X x1 t11 t12) (Branch X x2 t21 t22).

Inductive isomorfo (X:Set) : arbol X -> arbol X -> Prop :=
  isomorfo_empty : isomorfo X (empty X) (empty X)
  | isomorfo_branch : forall (t11 t12 t21 t22 : arbol X) (x1 x2 : X),
    isomorfo X t11 t21 -> isomorfo X t12 t22 ->
      isomorfo X (branch X x1 t11 t12) (branch X x2 t21 t22).

(**
data Tree a b = Empty | Leaf a | Branch b (Tree a b) (Tree a b)
**)

Inductive GenTree'' (A B : Set) : Set :=
  nodeGT'' : A -> GenForest'' A B -> GenTree'' A B
with
  GenForest'' (A B : Set) : Set :=
    leafGF'' : B -> GenForest'' A B
    | consGF'' : GenTree'' A B -> GenForest'' A B -> GenForest'' A B.

Inductive GenTree (A B : Set) : Set :=
  leafGT : B -> GenTree A B
  | nodeGT : A -> GenForest A B -> GenTree A B
with
  GenForest (A B : Set) : Set :=
    leafGF : GenTree A B -> GenForest A B
    | consGF : GenTree A B -> GenForest A B -> GenForest A B.

Definition tree_1 : GenTree nat bool :=
  nodeGT nat bool 1 (leafGF nat bool (leafGT nat bool true)).

Check (consGF nat bool tree_1 (leafGF nat bool (leafGT nat bool false))).
Check (leafGT nat bool true).

Definition tree'_1 := leafGT nat bool true.

Check (nodeGT nat bool 1 (leafGF nat bool tree'_1)).

Inductive GenTree' (A B : Set) : Set :=
  leafGT' : GenForest' A B -> GenTree' A B
  | nodeGT' : B -> GenForest' A B -> GenTree' A B
with
  GenForest' (A B : Set) : Set :=
    leafGF' : A -> GenForest' A B
    | consGF' : GenTree' A B -> GenForest' A B -> GenForest' A B.

Check (leafGT' nat bool
  (leafGF' nat bool 1)).

End Ejercicio1.

Section Ejercicio2.

(* Apartado 1 *)

Definition Or : bool -> bool -> bool :=
  fun b1 b2 =>
    match b1, b2 with
      true, _ => true
      | _, true => true
      | _, _ => false
    end.

Eval compute in (Or true false).

Definition And : bool -> bool -> bool :=
  fun b1 b2 =>
    match b1, b2 with
      true, _ => b2
      | false, _ => false
    end.

Eval compute in (And true false).
Eval compute in (And false true).

Definition Not : bool -> bool :=
  fun b =>
    match b with
      true => false
      | _ => true
    end.

Eval compute in (Not true).

Definition Xor : bool -> bool -> bool :=
  fun b1 b2 =>
    match b1, b2 with
      true, true => false
      | false, false => false
      | _, _ => true
    end.

(* Apartado 2 *)

Definition is_nil (A : Set) : list A -> bool :=
  fun xs =>
    match xs with
      nil => true
      | _ => false
    end.

Eval simpl in (is_nil nat (nil nat)).
Eval simpl in (is_nil nat (cons nat 1 (nil nat))).

End Ejercicio2.

Section Ejercicio3.

(* Apartado 1 *)
Fixpoint sum (n m : nat) : nat :=
    match n with
      0 => m
      | (S k) => S (sum k m)
    end.

(* Apartado 2 *)
Fixpoint prod (n m : nat) : nat :=
    match n with
      0 => 0
      | (S k) => sum (prod k m) m
    end.

Eval simpl in (prod 1000 0).
Eval simpl in (forall n: nat, prod n 0 = 0).

(* Apartado 3 *)
Fixpoint pot (n m : nat) {struct m} : nat :=
  match m with
    0 => 1
    | S k => prod n (pot n k)
  end.

Eval simpl in (pot 9 3).

(* Apartado 4 *)
Fixpoint leBool (n m : nat) : bool :=
  match n, m with
    0, _ => true
    | S k, 0 => false
    | S k1, S k2 => leBool k1 k2
  end.

Eval simpl in (leBool 44 331).

End Ejercicio3.

Section Ejercicio4.

Check nil.

(* Apartado 1 *)
Fixpoint length (A:Set) (xs:list A): nat :=
  match xs with
    nil => 0
    | cons y ys => sum 1 (length A ys)
  end.

Eval simpl in (length bool (cons bool true (nil bool))).

(* Apartado 2 *)
Fixpoint append (A:Set) (xs:list A) (ys:list A): list A :=
  match xs, ys with
    nil, _ => ys
    | cons z zs, _ => cons A z (append A zs ys)
  end.

Eval simpl in (append nat (cons nat 3 (cons nat 1 (nil nat)))
  (cons nat 2 (nil nat))).

Definition singleton (A:Set) (a:A) : list A := cons A a (nil A).

(* Apartado 3 *)
Fixpoint reverse (A:Set) (xs:list A) : list A :=
  match xs with
    nil => nil A
    | cons z zs => append A (reverse A zs) (cons A z (nil A))
  end.

Eval compute in (reverse nat (cons nat 1 (cons nat 2 (nil nat)))).

(* Apartado 4 *)
Fixpoint filter (A:Set) (f:A->bool) (xs:list A) : list A :=
  match xs with
    nil => nil A
    | cons y ys => if f y then cons A y (filter A f ys) else filter A f ys
  end.

Eval compute in
(
filter nat
  (fun x => leBool 2 x)
  (cons nat 0 (cons nat 12 (cons nat 33 (nil nat))))
).

(* Apartado 5 *)
Fixpoint map (A B:Set) (f:A -> B) (xs:list A) : list B :=
  match xs with
    nil => nil B
    | cons y ys => cons B (f y) (map A B f ys)
  end.

Eval compute in (map nat nat (fun x => x + 1) (cons nat 1 (nil nat))).

(* Apartado 6 *)
Fixpoint exists_ (A:Set) (p:A -> bool) (xs:list A) : bool :=
  match xs with
    nil => false
    | cons y ys => if p y then true else exists_ A p ys
  end.

Eval compute in
(
exists_ nat
  (fun x => leBool 4 x)
  (cons nat 0 (cons nat 5 (cons nat 1 (cons nat 12 (nil nat)))))
).

End Ejercicio4.

Section Ejercicio5.

(* Apartado 1 *)
Fixpoint inverse (X : Set) (b : bintree X) : bintree X :=
  match b with
    Empty => Empty X
    | (Branch e l r) => Branch X e (inverse X r) (inverse X l)
  end.

Eval compute in (inverse nat (Branch nat 1 (Empty nat)
  (Branch nat 2 (Empty nat) (Empty nat)))).
Eval compute in
(
  mirror nat
    (inverse nat (Branch nat 1 (Empty nat)
      (Branch nat 2 (Empty nat) (Empty nat))))
    (Branch nat 1 (Empty nat) (Branch nat 2 (Empty nat) (Empty nat)))
).

(* Apartado 2 *)

(*
Inductive GenTree (A B : Set) : Set :=
  leafGT : B -> GenTree A B
  | nodeGT : A -> GenForest A B -> GenTree A B
with
  GenForest (A B : Set) : Set :=
    leafGF : GenTree A B -> GenForest A B
    | consGF : GenTree A B -> GenForest A B -> GenForest A B.
*)

(*Fixpoint nodes (X Y : Set) (gt : GenTree X Y) : bool :=
*)

End Ejercicio5.

Section Ejercicio6.

Definition listN := list nat.

Fixpoint nat_eq (n:nat) (m:nat) : bool :=
  match n, m with
    0, 0 => true
    | S k1, S k2 => nat_eq k1 k2
    | _, _ => false
  end.

(* 6.1 *)
Fixpoint member (n:nat) (xs:listN) : bool :=
  match xs with
    nil => false
    | cons m ys => Or (nat_eq m n) (member n ys)
  end.

Eval compute in (member 2 (cons nat 2 (cons nat 2 (nil nat)))).

(* 6.2 *)
Fixpoint delete (xs:listN) (n:nat) : listN :=
  match xs with
    nil => nil nat
    | cons m ys => if nat_eq m n then
  delete ys n else cons nat m (delete ys n)
  end.

Eval compute in (delete
  (cons nat 2 (cons nat 2 (cons nat 80 (nil nat)))) 8).

(* 6.3 *)
Fixpoint insert (x:nat) (xs:listN) {struct xs} : listN :=
  match xs with
    nil => cons nat x (nil nat)
    | cons y ys =>
    match leBool x y with
      true => cons nat x (cons nat y ys)
      | _  => cons nat y (insert x ys)
    end
  end.

Fixpoint insert_sort (xs:listN) : listN :=
  match xs with
    nil => nil nat
    | cons y ys => insert y (insert_sort ys)
  end.

Eval compute in
(
  insert_sort
    (
      (cons nat 45
      (cons nat 0
      (cons nat 93
      (cons nat 12
      (nil nat)
      ))))
    )
).

(* Generalizaciones *)

End Ejercicio6.

Section Ejercicio7.

(* 7.1 *)
Inductive Exp (A:Set) : Set :=
  atom : A -> Exp A
  | Sum : Exp A -> Exp A -> Exp A
  | Mul : Exp A -> Exp A -> Exp A
  | Minus : Exp A -> Exp A.

(* 7.2 *)
Fixpoint InterpretNat (ne : Exp nat) : nat :=
  match ne with
    atom n => n
    | Sum n1 n2 => (InterpretNat n1) + (InterpretNat n2)
    | Mul n1 n2 => (InterpretNat n1) * (InterpretNat n2)
    | Minus n => InterpretNat n
  end.

(* 7.3 *)
Fixpoint InterpretBool (be : Exp bool) : bool :=
  match be with
    atom b => b
    | Sum b1 b2 => Or (InterpretBool b1) (InterpretBool b2)
    | Mul b1 b2 => And (InterpretBool b1) (InterpretBool b2)
    | Minus b => Not (InterpretBool b)
  end.

End Ejercicio7.

Section Ejercicio8.

(* 8.1 *)
Theorem andAsoc : forall p q r: bool,
  And (And p q) r = And p (And q r).
Proof.
  destruct p; reflexivity.
Qed.

Theorem orAsoc : forall p q r: bool,
  Or (Or p q) r = Or p (Or q r).
Proof.
  destruct p;
  destruct q;
  destruct r;
  reflexivity.
Qed.

Theorem andConmut : forall p q : bool, And p q = And q p.
Proof.
  destruct p;
  destruct q;
  reflexivity.
Qed.

Theorem orConmut : forall p q : bool, Or p q = Or q p.
Proof.
  destruct p;
  destruct q;
  reflexivity.
Qed.

(* 8.2 *)
Lemma LAnd : forall a b : bool, (And a b = true) <->
  (a = true /\ b = true).
Proof.
  destruct a;
  destruct b;
  compute;
  split;
  intro;
  [split | | split |destruct H as [_ H] |split
  |destruct H as [H _] |split |destruct H as [H _] ];
  trivial.
Qed.

(* 8.3 *)
Lemma LOr1 : forall a b : bool, Or a b = false <->
  a = false /\ b = false.
Proof.
  destruct a;
  destruct b;
  compute;
  split;
  intro;
  [split |destruct H as [_ H] | split |destruct H as [H _]
  |split |destruct H as [_ H] | split |split ];
  trivial.
Qed.

(* 8.4 *)
Lemma LOr2 : forall a b : bool, Or a b = true
  <-> a = true \/ b = true.
Proof.
  destruct a;
  destruct b;
  compute;
  split;
  intro;
  [right | | left |
  |right | | right | elim H; intros];
  trivial.
Qed.

(* 8.5 *)
Lemma LXor : forall a b : bool, Xor a b = true <-> a <> b.
Proof.
  intuition.
  destruct a; rewrite <- H0 in H; discriminate.
  destruct a; destruct b; compute;
    [elim H | | | elim H]; trivial.
Qed.

(* 8.6 *)
Lemma LNot : forall b : bool, Not (Not b) = b.
Proof.
  destruct b; trivial.
Qed.

End Ejercicio8.

Section Ejercicio9.

Lemma SumO : forall n : nat, sum n 0 = n.
Proof.
  apply nat_ind; [ | intros; simpl; rewrite H ]; trivial.
Qed.

Lemma SumS : forall n m : nat, sum n (S m) = sum (S n) m.
Proof.
  intro.
  elim n; simpl; [ | intros; rewrite -> H]; trivial.
Qed.

Lemma SumConm : forall n m : nat, sum n m = sum m n.
Proof.
  intro.
  elim n; simpl; [ | intros; rewrite -> H]; trivial.
Qed.

Lemma SumAsoc : forall n m p : nat, sum n (sum m p) = sum (sum n m) p.
Proof.
  intro.
  elim n; simpl; [ | intros; rewrite -> H ]; trivial.
Qed.

Check prod.

Lemma Prod0 : forall m : nat, prod m 0 = 0.
Proof.
  induction m;
  [ | simpl; rewrite IHm ]; trivial.
Qed.

Lemma ProdS : forall n m : nat,
  prod n (S m) = sum (prod n m) n.
Proof.
  intros.
  induction n.
    trivial.

    simpl.
    rewrite IHn.
    rewrite SumConm.
    rewrite SumAsoc.
    simpl.
    rewrite SumConm.
    rewrite SumAsoc.
    rewrite SumConm.
    rewrite (SumConm n m).
    rewrite SumAsoc.
    trivial.
Qed.

Lemma ProdConm : forall n m : nat, prod n m = prod m n.
Proof.
  intros.
  induction n;
  [ symmetry; apply Prod0
  |
    rewrite ProdS;
    simpl;
    rewrite IHn;
    trivial ].
Qed.

Lemma ProdDistr : forall n m p : nat,
  prod n (sum m p) = sum (prod n m) (prod n p).
Proof.
  intros.
  induction n;
  [ |
    simpl;
    rewrite IHn;
    rewrite SumAsoc;
    rewrite SumAsoc;
    rewrite <- (SumAsoc (prod n m) m (prod n p));
    rewrite (SumConm m (prod n p));
    rewrite <- (SumAsoc (prod n m) (prod n p) m)
  ]; trivial.
Qed.

Lemma ProdAsoc : forall n m p : nat, prod n (prod m p) =
prod (prod n m) p.
Proof.
  intros.
  induction n;
  [ |
    simpl;
    rewrite IHn;
    rewrite (ProdConm (sum (prod n m) m) p);
    rewrite ProdDistr;
    rewrite ProdConm;
    rewrite (ProdConm m p)
  ]; trivial.
Qed.

End Ejercicio9.

Section Ejercicio10.

Lemma L1 : forall (A : Set) (l : list A), append A l (nil
 A) = l.
Proof.
  intros.
  induction l;
  [ | simpl; rewrite IHl ]; trivial.
Qed.

Lemma L2 : forall (A : Set) (l : list A) (a : A), ~(cons
A a l) = nil A.
Proof.
  unfold not.
  intros.
  discriminate H.
Qed.

Lemma L3 : forall (A : Set) (l m : list A) (a : A),
cons A a (append A l m) = append A (cons A a l) m.
Proof.
  intros.
  induction l; [ | simpl ]; trivial.
Qed.

Lemma L4 : forall (A : Set) (l m : list A),
length A (append A l m) = sum (length A l) (length
A m).
Proof.
  intros.
  induction l;
  [ | simpl; rewrite IHl]; trivial.
Qed.

Lemma L5 : forall (A : Set) (l : list A),
  length A (reverse A l) = length A l.
Proof.
  intros.
  induction l;
  [ trivial
  | simpl;
    rewrite <- IHl;
    rewrite L4;
    simpl;
    apply SumConm
  ].
Qed.

(* Lema auxiliar, asociatividad del append *)
Lemma AppendAsoc : forall (A : Set) (l m n : list A),
  append A (append A l m) n = append A l (append A m n).
Proof.
  intros.
  induction l;
  [ | simpl; rewrite IHl ]; trivial.
Qed.

Lemma L6 : forall (A : Set) (l m : list A),
 reverse A (append A l m) = append A (reverse A m) (reverse A l).
Proof.
  intros.
  induction l; simpl;
  [ rewrite L1
    |
    rewrite IHl;
    rewrite AppendAsoc
  ]; trivial.
Qed.

End Ejercicio10.

Section Ejercicio11.

Lemma  L7 : forall (A B : Set) (l m : list A) (f : A -> B),
  map A B f (append A l m) = append B (map A B f l) (map A B f m).
Proof.
  intros.
  induction l;
  [ | simpl; rewrite IHl ]; trivial.
Qed.

Lemma L8 : forall (A : Set) (l m : list A) (P : A -> bool),
  filter A P (append A l m) = append A (filter A P l) (filter A P m).
Proof.
  intros.
  induction l;
  [ |
    simpl;
    rewrite IHl;
    case (P x)
  ]; trivial.
Qed.

Lemma L9 : forall (A : Set) (l m n : list A),
  append A l (append A m n) = append A (append A l m) n.
Proof.
  intros.
  induction l;
  [ |
    simpl;
    rewrite IHl
  ]; trivial.
Qed.

Lemma L10 : forall (A : Set) (l : list A),
reverse A (reverse A l) = l.
Proof.
  intros.
  induction l;
  [ | simpl; rewrite L6; rewrite IHl ]; trivial.
Qed.

End Ejercicio11.

Section Ejercicio12.

Fixpoint filterMap (A B : Set) (P : B -> bool) (f : A -> B)
  (l : list A) {struct l} : list B :=
    match l with
    | nil => nil B
    | cons a l1 =>
      match P (f a) with
      | true => cons B (f a) (filterMap A B P f l1)
      | false => filterMap A B P f l1
      end
    end.

Lemma FusionFilterMap :
  forall (A B : Set) (P : B -> bool) (f : A -> B) (l : list A),
    filter B P (map A B f l) = filterMap A B P f l.
Proof.
  intros.
  induction l;
  [ | simpl; case (P (f x)); rewrite IHl ]; trivial.
Qed.

End Ejercicio12.

Section Ejercicio18.

Variable A : Set.
Inductive Tree_ : Set :=
  | nullT : Tree_
  | consT : A -> Tree_ -> Tree_ -> Tree_.

(* 18.1 *)
Inductive isSubTree: Tree_ -> Tree_ -> Prop :=
  | isSubTree0 : forall t: Tree_, isSubTree t t
  | isSubTree1 : forall (t1 t2 t3: Tree_) (x: A),
    isSubTree t1 t2 -> isSubTree t1 (consT x t2 t3)
  | isSubTree2 : forall (t1 t2 t3: Tree_) (x: A),
    isSubTree t1 t3 -> isSubTree t1 (consT x t2 t3).

(* 18.2 *)
Lemma isSubTreeReflex : forall t: Tree_,
  isSubTree t t.
Proof.
  apply isSubTree0.
Qed.

(* 18.3 *)
Lemma isSubTreeTrans : forall t1 t2 t3: Tree_,
  isSubTree t1 t2 /\ isSubTree t2 t3 -> isSubTree t1 t3.
Proof.
  intros.
  destruct H.
  induction H0;
  [ |
    apply isSubTree1;
    apply IHisSubTree
    |
    apply isSubTree2;
    apply IHisSubTree
  ]; trivial.
Qed.

End Ejercicio18.

Section Ejercicio19.

(* 19.1 *)
Variable A: Set.

Inductive ACom: nat -> Set :=
  | leafACom: A -> ACom 0
  | consACom: forall n: nat, A -> ACom n -> ACom n -> ACom (S n).

Variable a: A.

Check (leafACom a).

(* 19.2 *)
Fixpoint h (n: nat) (t: ACom n): nat :=
    match t with
      leafACom _ => 1
      | consACom n0 x t1 t2 => h n0 t1 + h n0 t2
    end.

Eval simpl in (h 0 (leafACom a)).

(* 19.3 *)

Parameter poten: nat -> nat -> nat.

Axiom potO : forall n : nat, poten (S n) 0 = 1.
(*  n0 = 1 ∀ n>0  *)
Axiom potS : forall m: nat, poten 2 (S m) = sum (poten 2 m) (poten 2 m).
(*  2m+1 = 2m + 2m  *)

Lemma e193: forall (n: nat) (t: ACom n),
  h n t = poten 2 n.
Proof.
  intros.
  induction t;
  [ rewrite potO
    |
    simpl;
    rewrite (potS n)
  ]; auto.
Qed.

End Ejercicio19.

Section Ejercicio20.

Definition max: nat -> nat -> nat :=
  fun n m =>
    if leBool m n then n else m.

(* 20.1 *)
Inductive AB (A: Set): nat -> Set :=
  | emptyAB: AB A 0
  | branchAB: forall n k: nat,
  A -> AB A n -> AB A k -> AB A (S (max n k)).

(* 20.2 *)
Fixpoint camino (A: Set) (n: nat) (t: AB A n): list A :=
  match t with
    emptyAB => nil A
    | branchAB n1 n2 x t1 t2 =>
      if leBool n2 n1
      then cons A x (camino A n1 t1)
      else cons A x (camino A n2 t2)
  end.

(* Prueba de ejemplo *)
Definition e := emptyAB nat.
Definition t1 := branchAB nat 0 0 1 e e.
Definition t2 := branchAB nat 1 1 2 t1 t1.
Definition t3 := branchAB nat 1 2 3 t1 t2.
Definition t4 := branchAB nat 1 0 4 t1 e.
Definition t5 := branchAB nat 1 2 5 t1 t4.
Definition t6 := branchAB nat 3 3 6 t3 t5.

Eval simpl in (camino nat 0 e).
Eval simpl in (camino nat 3 t5).
Eval simpl in (camino nat 4 t6).

(* 20.3 *)
Lemma e203 (A: Set): forall (n: nat) (t: AB A n),
  length A (camino A n t) = n.
Proof.
  intros.
  induction t; simpl;
  [ |
    unfold max;
    case (leBool k n);
    simpl;
      [ rewrite IHt1 | rewrite IHt2 ]
   ]; trivial.
Qed.

End Ejercicio20.

Section Ejercicio16.

Inductive posfijo (A: Set): list A -> list A -> Prop :=
  posfijoE : forall l: list A, posfijo A l l
  | posfijoL : forall (l1 l2: list A) (x: A),
    posfijo A l1 l2 -> posfijo A l1 (cons A x l2).

(* 16.2 *)
Lemma e162a (A : Set) : forall l1 l2 l3 : list A,
  l2 = append A l3 l1 -> posfijo A l1 l2.
Proof.
  intros.
  rewrite H.
  clear H.
  induction l3;
  simpl;
  [ apply posfijoE
    |
    apply posfijoL;
    trivial
  ].
Qed.

(* 16.3 *)
Fixpoint ultimo (A: Set) (xs: list A) {struct xs}: list A :=
  match xs with
    nil => nil A
    | cons y nil => xs
    | cons y ys => ultimo A ys
  end.

Eval simpl in (ultimo nat (cons nat 1 (cons nat 2 (cons nat 3 (nil nat))))).

(* 16.4 *)
Lemma e164 (A: Set):
  forall l: list A, posfijo A (ultimo A l) l.
Proof.
  intro.
  induction l;
  simpl;
  [ apply posfijoE
    |
    destruct l;
      [ apply posfijoE
        |
        apply posfijoL
      ];
      trivial
   ].
Qed.

Lemma e162b (A: Set): forall l1 l2: list A,
  posfijo A l1 l2 -> (exists l3: list A, l2 = append A l3 l1).
Proof.
  intros.
  induction H;
  [ exists (nil A)
    |
    elim IHposfijo;
    intros;
    exists (cons A x x0);
    rewrite H0
   ]; simpl; trivial.
Qed.

End Ejercicio16.

Section Ejercicio15.

Inductive Tree (A: Set): Set :=
  leafTree: A -> Tree A
  | branchTree: Tree A -> Tree A -> Tree A.

(* 15.1 *)
Fixpoint mapTree (A B: Set) (t: Tree A) (f: A -> B): Tree B :=
  match t with
    leafTree x => leafTree B (f x)
    | branchTree t1 t2 =>
      branchTree B (mapTree A B t1 f) (mapTree A B t2 f)
  end.

(* 15.2 *)
Fixpoint numLeaves (A: Set) (t: Tree A): nat :=
  match t with
    leafTree x => 1
    | branchTree t1 t2 =>
      (numLeaves A t1) + (numLeaves A t2)
  end.

(* 15.3 *)
Lemma e153 (A B: Set):
  forall (t: Tree A) (f: A -> B),
    numLeaves B (mapTree A B t f) = numLeaves A t.
Proof.
  intros.
  induction t;
  simpl;
  [ |
    rewrite IHt1;
    rewrite IHt2
  ]; trivial.
Qed.

(* 15.4 *)
Fixpoint hojas (A: Set) (t: Tree A): list A :=
  match t with
    leafTree x => cons A x (nil A)
    | branchTree t1 t2 =>
      append A (hojas A t1) (hojas A t2)
  end.

Lemma e154 (A: Set):
  forall (t: Tree A), length A (hojas A t) = numLeaves A t.
Proof.
  intro.
  induction t;
  simpl;
  [ trivial
    |
    rewrite L4;
    rewrite IHt1;
    rewrite IHt2
  ]; trivial.
Qed.

End Ejercicio15.


Require Import Modal.
Require Import occ_in_phi.
Require Import Bool.
Require Import my_arith__my_leb_nat.

Fixpoint is_pos (phi : Modal) (i : nat) : bool :=
  if occ_in_phi phi i then
  match phi with
  | atom p => EqNat.beq_nat 1 i
  | mneg psi => eqb false (is_pos psi i)
  | mconj psi1 psi2 => if Nat.leb i (length (pv_in psi1)) then is_pos psi1 i
                          else is_pos psi2 (i-(length (pv_in psi1)))
  | mdisj psi1 psi2 => if Nat.leb i (length (pv_in psi1)) then is_pos psi1 i
                          else is_pos psi2 (i-(length (pv_in psi1)))
  | mimpl psi1 psi2 => if Nat.leb i (length (pv_in psi1)) then eqb false (is_pos psi1 i)
                          else is_pos psi2 (i-(length (pv_in psi1)))
  | box psi => is_pos psi i
  | diam psi => is_pos psi i
  end
  else false.

Lemma is_pos_defn_mconj : forall (phi1 phi2 : Modal) (i : nat),
  is_pos (mconj phi1 phi2) i =
  if occ_in_phi (mconj phi1 phi2) i
     then if Nat.leb i (length (pv_in phi1))
             then is_pos phi1 i
             else is_pos phi2 (i-(length (pv_in phi1)))
     else false.
Proof.
  intros; simpl; reflexivity.
Qed.

Lemma is_pos_defn_mdisj : forall (phi1 phi2 : Modal) (i : nat),
  is_pos (mdisj phi1 phi2) i =
  if occ_in_phi (mdisj phi1 phi2) i
     then if Nat.leb i (length (pv_in phi1))
             then is_pos phi1 i
             else is_pos phi2 (i-(length (pv_in phi1)))
     else false.
Proof.
  intros; simpl; reflexivity.
Qed.

Lemma is_pos_defn_mimpl : forall (phi1 phi2 : Modal) (i : nat),
  is_pos (mimpl phi1 phi2) i =
  if occ_in_phi (mimpl phi1 phi2) i
     then if Nat.leb i (length (pv_in phi1))
             then eqb false (is_pos phi1 i)
             else is_pos phi2 (i-(length (pv_in phi1)))
     else false.
Proof.
  intros; simpl; reflexivity.
Qed.

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

Fixpoint is_neg (phi : Modal) (i : nat) : bool :=
  if occ_in_phi phi i then
  match phi with
  | atom p => false
  | mneg psi => eqb false (is_neg psi i)
  | mconj psi1 psi2 => if Nat.leb i (length (pv_in psi1)) then is_neg psi1 i
                          else is_neg psi2 (i-(length (pv_in psi1)))
  | mdisj psi1 psi2 => if Nat.leb i (length (pv_in psi1)) then is_neg psi1 i
                          else is_neg psi2 (i-(length (pv_in psi1)))
  | mimpl psi1 psi2 => if Nat.leb i (length (pv_in psi1)) then eqb false (is_neg psi1 i)
                          else is_neg psi2 (i-(length (pv_in psi1)))
  | box psi => is_neg psi i
  | diam psi => is_neg psi i
  end
  else false.


Require Import Arith List Permutation Extraction.
Require Import SortSpec.

Require Import Tactics.Crush.
Require Import Tactics.Tactics.

Module InsertSort <: Sorting.

(** Body of insert sort. Sort the rest list, and insert the head
    element into the sorted rest list. *)
Fixpoint insert (x : nat) (l : list nat) : list nat :=
  match l with
  | nil => x :: nil
  | y :: l' => if x <=? y
                 then x :: y :: l'
                 else y :: insert x l'
  end.

Fixpoint insertsort (l : list nat) : list nat :=
  match l with
  | nil => nil
  | x :: l' => insert x (insertsort l')
  end.

Definition sort := insertsort.

Example insertsort_pi :
  sort [3; 1; 4; 1; 5; 9; 2; 6; 5; 3; 5] = [1; 1; 2; 3; 3; 4; 5; 5; 5; 6; 9].
Proof.
  simpl; reflexivity.
Qed.

(** [insert] keeps a sorted list still sorted. *)
Lemma insert_keeps_sorted :
  forall l x, Sorted l -> Sorted (insert x l).
Proof.
  intros l.
  induction l; crush.
  bdestruct (x <=? a); crush.
  pose proof (IHl x).
  inversion H; destruct l; crush.
  bdestruct (x <=? n); crush.
Qed.

(** [insert] keeps a permutation still a permutation. *)
Lemma insert_keeps_permutation :
  forall l l' x, Permutation l l' -> Permutation (x :: l) (insert x l').
Proof.
  intros l l'.
  generalize dependent l.
  induction l'; crush.
  bdestruct (x <=? a); crush.
  pose proof (IHl' l' x (Permutation_refl l')).
  apply perm_trans with (l' := (a :: x :: l')); auto.
  apply perm_swap.
Qed.

Theorem sort_algorithm : forall (l : list nat),
  Sorted (sort l) /\ Permutation l (sort l).
Proof.
  unfold sort.
  intros; induction l; split; crush.
  - apply insert_keeps_sorted; auto.
  - apply insert_keeps_permutation; auto.
Qed.

End InsertSort.

Extraction InsertSort.insert.
Extraction InsertSort.insertsort.


Require Export Coq.Strings.String.
Require Export Coq.Bool.Bool.
Require Export Coq.Arith.EqNat.
Require Export List.
Notation "x :: l" := (cons x l) (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

(* Here I have formalized the basic definitions of model theory in Coq and proved some basic theorems
I have followed this text: http://www.math.toronto.edu/weiss/model_theory.pdf. *)

(******************************************************************************************)
(* Args *)
(******************************************************************************************)

(* Argument tuples are lists parameterized by length. These types are passed to functions
and relations. Specifically an n-place function will take an n-tuple args as its parameter
and an m-place relation will take an m-typle args as its parameter.*)

(* Inductive type idea and notation taken from
 http://www.cs.cornell.edu/courses/cs6115/2017fa/notes/lecture8.html *)
Inductive args (T : Type) : nat -> Type :=
| nilA : args T 0
| consA : forall n, T -> args T n -> args T (S n).
Local Notation "[| |]" := (@nilA _).
Local Notation "[| x |]" := (@consA _ 1 x nilA).
Local Notation "[| x ; .. ; y |]" := (@consA _ _ x (.. (@consA _ _ y (@nilA _)) ..)).

(******************************************************************************************)
(* Symbols *)
(******************************************************************************************)

(* In model theory there are symbols for variables, functions, constants, and relations, along with
all the usual logic connectives and quantifiers, which we will see later in the formula section. *)

Inductive var : Type :=
(* The nat is the variable identifier. *)
| Var : nat -> var.
Inductive func : Type :=
(* The first nat is the function identifier and the second nat is the function arity. *)
| Func : nat -> nat -> func.
Inductive const : Type :=
(* The first nat is the constant identifier. *)
| Const : nat -> const.
Inductive rel : Type :=
(* The first nat is the relation identifier and the second nat is the relation arity. *)
| Rel : nat -> nat -> rel.

(******************************************************************************************)
(* Terms *)
(******************************************************************************************)

(* Terms in model theory are variables, constants, or n-place functions which take n arguments,
all of which are also terms. *)

(* Does the arity of the function f match arity? *)
Definition arity_match_func (f : func) (arity : nat) := match f with
| Func _ ar => arity = ar
end.

Inductive term : Type :=
(* Wraps a variable symbol. *)
| VarT   : var -> term
(* Wraps a constant symbol. *)
| ConstT : const -> term
(* Function terms consist of a symbol, an arity, a term argument tuple of that arity,
and a proof that the symbol arity matches the specified arity. *)
| FuncT  : forall (f : func) (arity : nat) (arg : args term arity),
            (arity_match_func f arity) -> term.

Module func_inst_example.
Definition v0 := VarT (Var 0).
Definition myArgs := [| v0; v0 |].
Definition myFuncSym := Func 0 2.
Definition myProof : (arity_match_func myFuncSym 2). Proof. reflexivity. Qed.
Definition myFunc := FuncT myFuncSym 2 myArgs myProof.
End func_inst_example.

(******************************************************************************************)
(* Formulas *)
(******************************************************************************************)

(* Formulas in model theory are relations (including the special equals relation, which is a
part of any language), as well as the usual logical connectives applied to formulas. Note that
Equals and Relates formulas are known as atomic formulas. *)

Definition arity_match_rel (r : rel) (arity : nat) := match r with
| Rel _ ar => arity = ar
end.

Inductive formula : Type :=
(* Equals formulas takes in two formulas and always as the usual interpretation of equality. *)
| Equals  : term -> term -> formula
(* Relates formulas consist of a symbol, an arity, a term argument tuple of that arity
and a proof that the symbol arity matches the specified arity. *)
| Relates : forall (r : rel) (arity : nat) (arg : args term arity),
            (arity_match_rel r arity) -> formula
(* Usual logical Not. *)
| Not     : formula -> formula
(* Usual logical Or. *)
| Or      : formula -> formula -> formula
(* Usual predicate calculus quantification. *)
| Forall  : var -> formula -> formula.

(* Derived formulas *)
Definition And (phi psi : formula) := Not (Or (Not phi) (Not psi)).
Definition Impl (phi psi : formula) := Or (Not phi) psi.
Definition Iff (phi psi : formula) := And (Impl phi psi) (Impl psi phi).
Definition Exists (v : var) (phi : formula) := Not (Forall v (Not phi)).

(******************************************************************************************)
(* Subformulas *)
(******************************************************************************************)

(* Here we define the notion of a subformula of a formula. *)
Inductive subformula : formula -> formula -> Prop :=
| SubIden   (psi phi : formula) : psi = phi -> subformula psi phi
(* If psi is the same as phi, psi is a subformula of phi. *)
| SubNot    (psi phi : formula) : subformula (Not psi) phi -> subformula psi phi
(* If Not psi is a subformula of phi, psi is a subformula of phi. *)
| SubOrL    (theta psi phi : formula) : subformula (Or theta psi) phi -> subformula theta phi
(* If Or theta psi is a subformula of phi, theta is a subformula of phi. *)
| SubOrR    (theta psi phi : formula) : subformula (Or theta psi) phi -> subformula psi phi
(* If Or theta psi is a subformula of phi, psi is a subformula of phi. *)
| SubForall (v : var) (psi phi : formula) : subformula (Forall v psi) phi -> subformula psi phi.
(* If Forall v psi is a subformula of phi, psi is a subformula of phi. *)

(* Below are proofs about subformulas for derived formulas. *)

(* If And theta psi is a subformula of phi, theta is a subformula of phi. *)
Theorem SubAndL : forall (theta psi phi : formula),
  subformula (And theta psi) phi -> subformula theta phi.
Proof.
  intros.
  unfold And in H.
  apply SubNot in H.
  apply SubOrL in H.
  apply SubNot in H.
  assumption.
Qed.

(* If And theta psi is a subformula of phi, psi is a subformula of phi. *)
Theorem SubAndR : forall (theta psi phi : formula),
  subformula (And theta psi) phi -> subformula psi phi.
Proof.
  intros.
  unfold And in H.
  apply SubNot in H.
  apply SubOrR in H.
  apply SubNot in H.
  assumption.
Qed.

(* If Impl theta psi is a subformula of phi, theta is a subformula of phi. *)
Theorem SubImplL : forall (theta psi phi : formula),
  subformula (Impl theta psi) phi -> subformula theta phi.
Proof.
  intros.
  unfold Impl in H.
  apply SubOrL in H.
  apply SubNot in H.
  assumption.
Qed.

(* If Impl theta psi is a subformula of phi, psi is a subformula of phi. *)
Theorem SubImplR : forall (theta psi phi : formula),
  subformula (Impl theta psi) phi -> subformula psi phi.
Proof.
  intros.
  unfold Impl in H.
  apply SubOrR in H.
  assumption.
Qed.

(* If Iff theta psi is a subformula of phi, theta is a subformula of phi. *)
Theorem SubIffL : forall (theta psi phi : formula),
  subformula (Iff theta psi) phi -> subformula theta phi.
Proof.
  intros.
  unfold Iff in H.
  apply SubAndL in H.
  apply SubImplL in H.
  assumption.
Qed.

(* If Iff theta psi is a subformula of phi, psi is a subformula of phi. *)
Theorem SubIffR : forall (theta psi phi : formula),
  subformula (Iff theta psi) phi -> subformula psi phi.
Proof.
  intros.
  unfold Iff in H.
  apply SubAndL in H.
  apply SubImplR in H.
  assumption.
Qed.

(* If Exists v psi is a subformula of phi, psi is a subformula of phi. *)
Theorem SubExists : forall (v : var) (psi phi : formula),
  subformula (Exists v psi) phi -> subformula psi phi.
Proof.
  intros.
  unfold Exists in H.
  apply SubNot in H.
  apply SubForall in H.
  apply SubNot in H.
  assumption.
Qed.

(******************************************************************************************)
(* Util functions for var/const/func/rel lists *)
(******************************************************************************************)

Definition eq_var (v1 : var) (v2 : var) := match v1, v2 with
| Var v1', Var v2' => beq_nat v1' v2'
end.

Fixpoint contains_var (l : list var) (v : var) := match l with
| [] => false
| h::t => eq_var v h || contains_var t v
end.

Fixpoint remove_var (l : list var) (v : var) := match l with
| [] => []
| h::t => if eq_var v h then remove_var t v else h::(remove_var t v)
end.

Definition eq_const (c1 : const) (c2 : const) := match c1, c2 with
| Const c1', Const c2' => beq_nat c1' c2'
end.

Fixpoint contains_const (l : list const) (c : const) := match l with
| [] => false
| h::t => eq_const c h || contains_const t c
end.

Definition eq_func (f1 : func) (f2 : func) := match f1, f2 with
| Func f1' _, Func f2' _ => beq_nat f1' f2'
end.

Fixpoint contains_func (l : list func) (f : func) := match l with
| [] => false
| h::t => eq_func f h || contains_func t f
end.

Definition eq_rel (r1 : rel) (r2 : rel) := match r1, r2 with
| Rel r1' _, Rel r2' _ => beq_nat r1' r2'
end.

Fixpoint contains_rel (l : list rel) (r : rel) := match l with
| [] => false
| h::t => eq_rel r h || contains_rel t r
end.

(******************************************************************************************)
(* Free variables *)
(******************************************************************************************)

(* Given a formula, a variable is in the set of that formula's free variables if and only if
it appears outside the syntatic scope of a quantifier at least once in that formula. *)

(* Helper type that represents function arguments as a list rather than an args.
This is so we can use the useful list functions rather than deal with cumbersome arg terms. *)
Inductive termList : Type :=
| VarTList   : var -> termList
| ConstTList : const -> termList
| FuncTList  : func -> (list termList ) -> termList.

(* Converts a term to a termList. *)
Fixpoint term_to_termlist (t : term) :=

let _args_to_list := (fix _args_to_list (n : nat) (a : args term n) := match a with
| nilA _ => []
| consA _ n' h t  => (term_to_termlist h)::(_args_to_list n' t)
end) in

match t with
| VarT v        => VarTList v
| ConstT c      => ConstTList c
| FuncT f n a _ => FuncTList f (_args_to_list n a)
end.

(* Returns a list of all the variables mentioned in the termList. *)
Fixpoint term_vars_helper (t : termList) := match t with
| VarTList v    => v::[]
| ConstTList c  => []
| FuncTList f l => fold_left (fun acc x => acc++(term_vars_helper x)) l []
end.

(* Returns a list of all the variables mentioned in the term. *)
Definition term_vars (t : term) := term_vars_helper (term_to_termlist t).

(* Converts an args term n into a list term. *)
Fixpoint args_to_list (n : nat) (a : args term n) := match a with
| nilA _ => []
| consA _ n' h t' => (term_to_termlist h)::(args_to_list n' t')
end.

Module term_vars_example.
Theorem am : arity_match_func (Func 1 2) 2. Proof. reflexivity. Qed.
Definition t  := FuncT (Func 1 2) 2 [|VarT (Var 1); VarT (Var 1)|] am.
Definition tv := term_vars t.
Theorem thm : contains_var tv (Var 1) = true. Proof. reflexivity. Qed.
End term_vars_example.

(* Returns the free variables of phi. *)
Fixpoint free_vars (phi : formula) := match phi with
| Equals t1 t2      => (term_vars t1)++(term_vars t2)
| Relates r n a _   => fold_left (fun a x => a++(term_vars_helper x)) (args_to_list n a) []
| Not psi           => free_vars psi
| Or theta psi      => (free_vars theta)++(free_vars psi)
| Forall v psi      => remove_var (free_vars psi) v
end.

Module free_vars_example.
Definition v1   := VarT (Var 1).
Definition v2   := VarT (Var 2).
Theorem am : arity_match_func (Func 1 1) 1. Proof. reflexivity. Qed.
Definition t    := FuncT (Func 1 1) 1 [|v1|] am.
Definition phi  := Or (Equals v2 v2) (Forall (Var 1) (Equals t t)).
Definition fv   := free_vars phi.
Theorem thm1 : contains_var fv (Var 1) = false. Proof. reflexivity. Qed.
Theorem thm2 : contains_var fv (Var 2) = true. Proof. reflexivity. Qed.
End free_vars_example.

(******************************************************************************************)
(* Substitution *)
(******************************************************************************************)

(* Given a formula phi, a variable v, and a term t, define substitution to be syntactic replacement
of all free occurrences of v with t in phi. *)

(* Term substitution. Substitutes all occurrences of v with t in t_orig. *)
Fixpoint subst_term (t_orig : term) (v : var) (t : term) :=
let subst_term_args := (fix subst_term_args (n : nat) (a : args term n) := match a with
| nilA _ => nilA _
| consA _ n' h t' => consA _ n' (subst_term h v t) (subst_term_args n' t')
end) in

match t_orig with
| VarT v    => t
| ConstT c  => ConstT c
| FuncT f n a p => FuncT f n (subst_term_args n a) p
end.

Fixpoint subst_helper (phi: formula) (v : var) (t : term) (free : list var) :=
let subst_term_args := (fix subst_term_args (n : nat) (a : args term n) := match a with
| nilA _ => nilA _
| consA _ n' h t' => consA  _ n' (subst_term h v t) (subst_term_args n' t')
end) in

match phi with
| Equals t1 t2    =>  if (contains_var free v) then
                        Equals (subst_term t1 v t) (subst_term t2 v t)
                      else
                        Equals t1 t2
| Relates r n a p =>  if (contains_var free v) then
                        Relates r n (subst_term_args n a) p
                      else
                        Relates r n a p
| Not psi         =>  Not (subst_helper psi v t free)
| Or theta psi    =>  Or (subst_helper theta v t free) (subst_helper psi v t free)
| Forall v' psi   => Forall v' (subst_helper psi v t (remove_var free v'))
end.

(* Formula substitution. Substitutes all free occurrences of v with t in phi. *)
Definition subst (phi: formula) (v : var) (t : term) := subst_helper phi v t (free_vars phi).

Module subst_example.
Definition v1       := Var 1.
Definition v1T      := VarT v1.
Definition v2T      := VarT (Var 2).
Definition cT       := ConstT (Const 1).
Theorem am : arity_match_rel (Rel 1 2) 2. Proof. reflexivity. Qed.
Definition phi      := Or (Equals v1T v1T) (Forall v1 (Relates (Rel 1 2) 2 [|v1T; v2T|] am)).
Definition phi_sub  := subst phi v1 cT.
Definition expected := Or (Equals cT cT) (Forall v1 (Relates (Rel 1 2) 2 [|v1T; v2T|] am)).
Theorem thm1 : phi_sub = expected. Proof. reflexivity. Qed.
End subst_example.

(******************************************************************************************)
(* Languages *)
(******************************************************************************************)

(* A language in model theory is defined as a set of constant, relation, and function symbols.*)
Inductive lang : Type :=
| Lang : list const -> list rel -> list func -> lang.
Definition lang_const (l : lang) := match l with
| Lang c r f => c
end.
Definition lang_rel (l : lang) := match l with
| Lang c r f => r
end.
Definition lang_func (l : lang) := match l with
| Lang c r f => f
end.

(* A term is valid with respect to a language if it only mentions symbols from that language. *)
Fixpoint valid_term (language : lang) (t : term) :=
let valid_term_args := (fix valid_term_args (n : nat) (a : args term n) := match a with
| nilA _ => true
| consA _ n' h t => (valid_term language h) && (valid_term_args n' t)
end) in

match t with
| VarT _        => true
| ConstT c      => contains_const (lang_const language) c
| FuncT f n a _ => contains_func (lang_func language) f && (valid_term_args n a)
end.

(* A formula is valid with respect to a language if it only mentions symbols from that language. *)
Fixpoint valid_formula (language : lang) (phi : formula) :=
let valid_term_args := (fix valid_term_args (n : nat) (a : args term n) := match a with
| nilA _ => true
| consA _ n' h t => (valid_term language h) && (valid_term_args n' t)
end) in

match phi with
| Equals t1 t2  => (valid_term language t1) && (valid_term language t2)
| Relates r n a _ => contains_rel (lang_rel language) r && (valid_term_args n a)
| Not psi       => valid_formula language psi
| Or psi theta  => (valid_formula language psi) && (valid_formula language theta)
| Forall _ psi  => valid_formula language psi
end.

Module valid_formula_example.
Definition c1 := ConstT (Const 1).
Definition c2 := ConstT (Const 2).
Definition c3 := ConstT (Const 3).
Definition v1 := Var 1.
Definition r1 := (Rel 1 2).
Theorem am : arity_match_rel r1 2. Proof. reflexivity. Qed.
Definition phi := Or (Equals c1 c2) (Forall v1 (Relates r1 2 [|VarT v1; c3|] am)).
Definition l := Lang [Const 1; Const 2; Const 3]  [Rel 1 2] [].
Theorem thm1 : (valid_formula l phi) = true. Proof. reflexivity. Qed.
Definition l' := Lang [Const 1; Const 2] [Rel 1 2] [].
Theorem thm2: (valid_formula l' phi) = false. Proof. reflexivity. Qed.
End valid_formula_example.

(******************************************************************************************)
(* Models *)
(******************************************************************************************)

(* Given a language L, a model is a tuple (A, I) where A is a set (called the universe of the model)
and I is an interpretation function for the constant, function, and relation symbols for L.
If a symbol F is an n-place function symbol, then I(F) is an n-place function
symbol on A. If a symbol R is an m-place relation symbol, then I(R) is an m-place relation
symbol on A. If a symbol C is a constant symbol, then I(C) is an element of A. Note that constants
can be viewed as a degenerate case of functions, namely a function that takes 0 arguments.*)

(* Note that it isn't strictly necesary to tie interpretation functions to a language, since
interpretation functions for constants/functions/relations can simply map all symbols
not in a given language to a single value. For example, if a language has constants
{Const 1, Const 2}, an interpretation function can map Const 1 to v1, Const 2 to v2,
and all other constants to v1. Similar reasoning applies to functions and relations. *)

(* The constant portion of the symbol interpretation function maps each constant symbol to an element of A. *)
Inductive constInterp (A : Type) : Type :=
| ConstInterp : (const -> A) -> constInterp A.

(* The function portion of the symbol interpretation function maps each n-place function symbol
to a n-place function on A. *)
Inductive funcInterp (A : Type) : Type :=
| FuncInterp : (func -> (list A) -> A) -> funcInterp A.

(* The relation portion of the symbol interpretation function maps each m-place relation symbol
to an m-place relation on A. *)
Inductive relInterp (A : Type) : Type :=
| RelInterp : (rel -> (list A) -> Prop) -> relInterp A.

(* The symbol interpretation function is a composite of the constant, function, and relation
symbol interpretation functions. *)
Inductive interpretation (A : Type) : Type :=
| Interpretation : (constInterp A) -> (funcInterp A) -> (relInterp A) -> interpretation A.

(* A model is a composite of a language and an interpretation function. *)
Inductive model (A : Type) : Type :=
| Model : lang -> (interpretation A) -> model A.

Module model_example.
Definition zero := Const 0.
Definition plus := Func 0 2.
Definition times := Func 1 2.
Definition simpleLang := Lang [zero] [] [plus].
Definition cInterp (c : const) := if eq_const c zero then 0 else 0.
Fixpoint fInterp (f : func) (args : list nat) :=
  if (eq_func f plus) then
    match args with
    | [] => 0
    | h::t => h + (fInterp f t)
    end
  else
    match args with
    | [] => 0
    | h::t => h * (fInterp f t)
    end
.
Definition rInterp (r : rel) (args : list nat) := True.
Definition interp :=
  Interpretation nat (ConstInterp nat cInterp) (FuncInterp nat fInterp) (RelInterp nat rInterp).
Definition myModel := Model nat simpleLang interp.
End model_example.


From mathcomp Require Import all_ssreflect all_algebra.
Require Import Poly_complements.

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

Import GRing.Theory.
Local Open Scope ring_scope.

Section Poly_exec.
Variable R : ringType.
Implicit Type p : {poly R}.

Lemma Poly_cons (a: R) K:
	Poly (a :: K) = cons_poly a (Poly K).
Proof. done. Qed.

Definition lopp_poly : seq R -> seq R := map -%R.

Lemma lopp_poly_spec l : Poly (lopp_poly l) = - Poly l.
Proof.
elim: l => [|a l IH]; rewrite /= ?rm0 //.
by rewrite !cons_poly_def IH opprD polyCN mulNr.
Qed.

Definition lscal_poly (a : R) := map (fun i => a * i).

Lemma lscal_poly_spec a l : Poly (lscal_poly a l) = a *: Poly l.
Proof.
elim: l => [|b l IH]; rewrite /= ?rm0 //.
by rewrite !cons_poly_def IH scalerDr scalerAl polyCM mul_polyC.
Qed.

(* l1 + l2 *)
Fixpoint ladd_poly (l1 l2 : seq R) :=
 if l1 is a :: l3 then
   if l2 is b :: l5 then a + b :: ladd_poly l3 l5
   else l1
 else l2.

Lemma ladd_poly_spec l1 l2 : Poly (ladd_poly l1 l2) = Poly l1 + Poly l2.
Proof.
elim: l1 l2 => [l2| a l1 IH [|b l2]]; rewrite /= ?rm0 //.
rewrite !cons_poly_def IH  polyCD mulrDl.
by rewrite -addrA [Poly l2 * _ + _]addrCA addrA.
Qed.

(* l1 - l2 *)
Fixpoint lsub_poly (l1 l2 : seq R) :=
 if l1 is a :: l3 then
   if l2 is b :: l5 then a - b :: lsub_poly l3 l5
   else l1
 else lopp_poly l2.

Lemma lsub_poly_spec l1 l2 : Poly (lsub_poly l1 l2) = Poly l1 - Poly l2.
Proof.
elim: l1 l2 => [l2| a l1 IH [|b l2]]; rewrite /= ?rm0 //.
  by rewrite lopp_poly_spec.
rewrite !cons_poly_def IH  polyCB mulrBl.
by rewrite -addrA [-_ + _]addrCA opprD !addrA.
Qed.
End Poly_exec.


Require Import ZArith.
Require Import QArith.
Load funs.

Open Scope Q_scope.

Definition same_cardinality (A B : Type) :=
  exists f : A -> B, exists g : B -> A,
    (forall b : B, f (g b) = b) /\ (forall a : A, g (f a) = a).

Definition is_denumerable A := same_cardinality A nat.

Lemma same_card_is_two_injectives : forall A B : Type,
 (exists f : A -> B, injective f) ->
 (exists g : B -> A, injective g) -> same_cardinality A B.

Theorem Q_is_at_most_denumerable: exists f : Q -> nat, injective f.
Proof.
Qed.

Theorem Q_is_denumbrable: is_denumbrable Q.
Proof.
	destruct Q_is_at_most_denumerable as [f injf].
Qed.


(*

   Benedikt Ahrens and Régis Spadotti

   Terminal semantics for codata types in intensional Martin-Löf type theory

   http://arxiv.org/abs/1401.1053

*)

(*

  Content of this file:

  definition of category

*)

Require Export Misc.Unicode.
Require Export Theory.Notations.
Require Export Theory.SetoidType.

Generalizable All Variables.

(*------------------------------------------------------------------------------
  -- ＣＡＴＥＧＯＲＹ  ＤＥＦＩＮＩＴＩＯＮ
  ----------------------------------------------------------------------------*)
(** ** Category definition **)

Structure Category : Type := mkCategory
{ Obj            :>  Type
; Hom            :   Obj → Obj → Setoid where "A ⇒ B" := (Hom A B)
; id             :   ∀ {A}, A ⇒ A
; compose        :   ∀ {A B C}, [ B ⇒ C ⟶ A ⇒ B ⟶ A ⇒ C ] where "g ∘ f" := (compose g f)
; left_id        :   ∀ {A B} {f : A ⇒ B}, id ∘ f ≈ f
; right_id       :   ∀ {A B} {f : A ⇒ B}, f ∘ id ≈ f
; compose_assoc  :   ∀ {A B C D} {f : A ⇒ B} {g : B ⇒ C} {h : C ⇒ D}, h ∘ g ∘ f ≈ h ∘ (g ∘ f) }.

Arguments mkCategory  {_ _ _ _} _ _ _.
Arguments Hom         {_} _ _.
Arguments id          {_} {_}.
Arguments compose     {_} {_ _ _}.

Notation "_⇒_"  := Hom (only parsing).
Infix "⇒"       := Hom.

Notation "_∘_"  := compose (only parsing).
Infix "∘"       := compose.

Notation "'id[' X ]"     := (id (A := X)) (only parsing).
Notation "T '-id'"       := (id (c := T)) (at level 0, only parsing).
Notation "T '-id[' X ]"  := (id (c := T) (A := X)) (at level 0, only parsing).

Notation "'Category.make' ⦃ 'Hom' ≔ Hom ; 'id' ≔ id ; 'compose' ≔ compose ⦄" :=
  (@mkCategory _ Hom id compose _ _ _) (only parsing).

(** ** Opposite category **)

Program Definition op_cat (𝒞 : Category) : Category :=
  Category.make ⦃ Hom ≔ λ (A B : 𝒞) ∙ B ⇒ A
                ; id  ≔ λ _ ∙ id
                ; compose ≔ λ _ _ _ ∙ λ g f ↦₂ f ∘ g ⦄.
Next Obligation. solve_proper. Qed.
Next Obligation. now rewrite right_id. Qed.
Next Obligation. now rewrite left_id. Qed.
Next Obligation. now rewrite compose_assoc. Qed.

Notation "𝒞 '^op'" := (op_cat 𝒞) (at level 3, no associativity, format "𝒞 '^op'").

(** ** Product of categories **)

Local Notation π₁ := fst.
Local Notation π₂ := snd.

Program Definition prod_cat (𝒞 𝒟 : Category) : Category :=
  Category.make ⦃ Hom ≔ λ (A B : 𝒞 ⟨×⟩ 𝒟) ∙ Setoid.make ⦃ Carrier ≔ (π₁ A ⇒ π₁ B) ⟨×⟩ (π₂ A ⇒ π₂ B)
                                                        ; Equiv ≔ λ f g ∙ π₁ f ≈ π₁ g ∧ π₂ f ≈ π₂ g ⦄
                ; id  ≔ λ A ∙ (𝒞-id , 𝒟-id)
                ; compose ≔ λ A B C ∙ λ g f ↦₂ (π₁ g ∘ π₁ f , π₂ g ∘ π₂ f) ⦄.
Next Obligation.
  constructor.
  - intros [f₁ f₂]; split; reflexivity.
  - intros [f₁ f₂] [g₁ g₂] [eq_f₁g₁ eq_f₂g₂]; split; now symmetry.
  - intros [f₁ f₂] [g₁ g₂] [h₁ h₂] [? ?] [? ?]; split; etransitivity; eauto.
Qed.
Next Obligation.
  intros [? ?] [? ?] [? ?] [? ?] [? ?] [? ?]; split; now apply cong.
Qed.
Next Obligation.
  split; now rewrite left_id.
Qed.
Next Obligation.
  split; now rewrite right_id.
Qed.
Next Obligation.
  split; now rewrite compose_assoc.
Qed.

Notation "A '𝘅' B" := (prod_cat A B) (at level 20, left associativity).
Notation "'_𝘅_'" := prod_cat (only parsing).


Require Export Arith.
Require Export ArithRing.

Fixpoint div2 (n:nat):nat:=
  match n with 0 => 0 | 1 => 0 | S (S p) => S (div2 p) end.

Fixpoint div3 (n:nat):nat:=
  match n with
    0 => 0
  | 1 => 0
  | 2 => 0
  | S (S (S p)) => S (div3 p) end.

Fixpoint rem2 (n:nat):nat:=
  match n with 0 => 0 | 1 => 1 | S (S p) => rem2 p end.

Theorem div2_ind :
  forall P: nat -> Prop,
    P 0 -> P 1 ->
    (forall n, P n -> P (S (S n))) ->
    forall n, P n.
Proof.
 intros P H0 H1 Hstep n.
 assert (P n/\P(S n)).
 elim n; intuition.
 intuition.
Qed.

Theorem div3_ind :
  forall P : nat -> Prop,
    P 0 -> P 1 -> P 2 ->
    (forall n, P n -> P (S (S (S n)))) ->
    forall n, P n.
Proof.
 intros P H0 H1 H2 Hstep n.
 assert (P n/\P(S n)/\P(S (S n))).
 elim n; intuition.
 intuition.
Qed.

Fixpoint fib (n:nat) : nat :=
  match n with
    0 => 1
  | 1 => 1
  | S ((S p) as q) => fib p + fib q
  end.

Fixpoint fib2 (n:nat) : nat*nat :=
  match n with
    0 => (1, 1)
  | S p =>
    let (v1, v2) := fib2 p in (v2, v1 + v2)
  end.

Theorem fib_ind :
  forall P : nat -> Prop,
    P 0 -> P 1 ->
    (forall n, P n -> P (S n) -> P (S (S n)))->
    forall n, P n.
Proof.
 intros P H0 H1 Hstep n.
 assert (P n/\P(S n)).
 elim n; intuition.
 intuition.
Qed.

Theorem div3_le : forall n, div3 n <= n.
Proof.
 intro n; elim n using div3_ind; simpl; auto with arith.
Qed.

Theorem div2_rem2_eq : forall n, 2 * div2 n + rem2 n = n.
Proof.
 intros n; elim n using div2_ind; try (simpl; auto with arith; fail).
 intros p IHp; pattern p at 3; rewrite <- IHp.
 simpl;ring.
Qed.

Theorem fib_fib2_equiv : forall n, fib n = (fst (fib2 n)).
Proof.
 intros n; elim n using fib_ind; try(simpl;auto with arith;fail).
 intros p IHp IHSp.
 replace (fib (S (S p))) with (fib p + fib (S p)).
 rewrite IHp; rewrite IHSp.
 simpl.
 case (fib2 p); auto.
 auto.
Qed.


Require Import Nat Arith List.
Import ListNotations.

(*****************************************************************************************)
(******************************** { Définitions de base } ********************************)
(*****************************************************************************************)

(** une case du plateau *)
Record coord := mkCoord { x : nat; y : nat }.

(** liste de cases *)
Definition plateau := list coord.

(** une case est soit blanche soit noire *)
Inductive couleur := Blanc | Noir.

(** négatif *)
Definition neg_couleur c :=
  match c with
  | Blanc => Noir
  | Noir => Blanc
  end.

(**
  un domino se pose peut être identifié par :
  - une case
  - le sens dans lequel il est posé
  exemple : Hauteur {0;0} occupe les cases {0;0} et {0;1}
 *)
Inductive domino :=
  | Hauteur : coord -> domino
  | Largeur : coord -> domino.

(** case a droite de [c] *)
Definition droite  (c : coord) := {| x := c.(x) + 1; y := c.(y) |}.

(** case en dessous de [c] *)
Definition dessous (c : coord) := {| x := c.(x)    ; y := c.(y) + 1 |}.

(** pair des cases occupées par un domino *)
Definition case_prise (d:domino) : coord * coord :=
  match d with
  | Hauteur c => (c, dessous c)
  | Largeur c => (c, droite c)
  end.

(** une case est blanche si la somme de ses coordonnées est paire *)
Definition case_blanche (c : coord) : Prop := Nat.Even (c.(x) + c.(y)).

(** une case est noire si la somme de ses coordonnées est paire *)
Definition case_noire (c : coord) : Prop := Nat.Odd (c.(x) + c.(y)).

(** condiction pour que la case [c] soit de couleur [cc] *)
Definition couleur_case (cc : couleur) (c : coord) : Prop :=
  match cc with
  | Blanc => Nat.Even (c.(x) + c.(y))
  | Noir  => Nat.Odd  (c.(x) + c.(y))
  end.

(** calcul le nombre de case de couleur [Blanc] sur un plateau [p] *)
Fixpoint card_bl (p : plateau) :=
  match p with
  | [] => 0
  | c :: t =>
      if even (c.(x) + c.(y))
      then 1 + card_bl t
      else card_bl t
  end.

(** calcul le nombre de case de couleur [Noir] sur un plateau [p] *)
Fixpoint card_no (p : plateau) :=
  match p with
  | [] => 0
  | c :: t =>
      if odd (c.(x) + c.(y))
      then 1 + card_no t
      else card_no t
  end.

(** calcul le nombre de case de couleur [c] sur un plateau [p] *)
Definition card (c : couleur) (p : plateau) :=
  match c with
  | Blanc => card_bl p
  | Noir  => card_no p
  end.

(** Fabrique une ligne d'un plateau
    exemple : mk_line n m = [ { 1; m } .. { n; m } ] *)
Fixpoint mk_line (n m:nat) : list coord :=
  match n with
  | 0 => []
  | S n => {| x := n; y := m |} :: (mk_line n m)
  end.

(** construction d'un plateau « classique »
    forme de carré [n] * [n]
    exemple :
     mk_plateau n := { {1; 1} ; ... ; {1; n} ; ... ; {n; 1} ; { n; n } } *)
Fixpoint mk_plateau (n:nat) :=
  match n with
  | 0 => []
  | S n =>
      (mk_line 8 n) ++ (mk_plateau n)
  end.

(** Plateau du problème original est un plateau d'échecs donc : 8x8 *)
Definition plateau_base : plateau := mk_plateau 8.

(* Eval compute in mk_plateau 8. *)

(** l'égalité entre coordonnées est décidable *)
Lemma eq_coord : forall a b : coord, {a = b} + {a <> b}.
Proof.
  decide equality; decide equality.
Defined.

Lemma eq_rw {P}:
  forall a (x y : P), (if eq_coord a a then x else y) = x.
Proof.
  intros a y0 x0.
  case (eq_coord a a).
  intro eq.
  - trivial.
  - contradiction.
Qed.

Lemma eq_rw2 {P}:
  forall a b (x y : P), a <> b -> (if eq_coord a b then x else y) = y.
Proof.
  intros a b x0 y0 H.
  case (eq_coord a b).
  - contradiction.
  - trivial.
Qed.

(** l'égalité entre dominos est décidable *)
Lemma eq_domino : forall a b : domino, {a = b} + {a <> b}.
Proof.
  intros a b.
  destruct a, b.
  - case (eq_coord c c0); intro e.
    + rewrite e. left. trivial.
    + decide equality; apply eq_coord.
  - right. discriminate.
  - right. discriminate.
  - case (eq_coord c c0); intro e.
    + rewrite e. left. trivial.
    + decide equality; apply eq_coord.
Defined.

(** notation à la \setminus *)
Infix "\" := (fun a b => List.remove eq_coord b a) (at level 31, left associativity).

(** Plateau du problème : échiquier classique sans 1 pair de coins opposés *)
Definition plateau_coupe := plateau_base \ {| x := 7; y := 7|} \ {| x := 0; y := 0|}.

(* Eval compute in plateau_coupe. *)

(** poser un domino [d] :
      retirer les deux cases prisent par [d] dans la liste des cases du plateau *)
Definition pose_domino (d : domino) (p : plateau) : plateau :=
  p \ fst (case_prise d) \ snd (case_prise d).

Infix "//" := pose_domino (at level 29, right associativity).

(** itérations consécutives de la fonction précédante *)
Definition pose_dominos (dl : list domino) (p_init : plateau) : plateau :=
  fold_left (fun (p : plateau) (d : domino) => d // p) dl p_init.

(** hyp : si l'on a un [p'] tq [p' = pose_domino d p]
          alors c'est que les cases prisent par le domino
          étaient présentes dans [p] *)

Hypothesis rm_iff_mem : forall p p' d, p' = d // p ->
  (In (fst (case_prise d)) p /\ In (snd (case_prise d)) p).

Definition mk_domino_H (x y : nat) := Hauteur {| x := x ; y := y |}.
Definition mk_domino_L (x y : nat) := Largeur {| x := x ; y := y |}.

(* Eval compute in pose_domino (mk_domino_H 4 4) plateau_coupe. *)


Require Export Relations Classes.EquivDec.
From FloatCohorts Require Import Arith Tactics.

Open Scope Z.

(* simple binary float: no zero, no special values *)
Record float_pair : Set := FPair { FPnum : positive; FPexp : Z}.

Definition fp_equiv_def : relation float_pair :=
  fun fp1 fp2 =>
    let '(m1, e1) := (FPnum fp1, FPexp fp1) in
    let '(m2, e2) := (FPnum fp2, FPexp fp2) in
    or
      ((e2 <= e1) /\ (Z.pos m2 = (Z.pos m1) * 2 ^ (e1 - e2)))
      ((e1 <= e2) /\ (Z.pos m1 = (Z.pos m2) * 2 ^ (e2 - e1))).

Instance fp_equiv : Equivalence fp_equiv_def.
Proof.
  unfold fp_equiv_def.
  constructor.
  -
    constructor.
    split.
    reflexivity.
    rewrite Z.sub_diag, Z.pow_0_r, Z.mul_1_r.
    reflexivity.
  -
    unfold Symmetric; intros.
    destruct H; auto.
  -
    intros fp1 fp2 fp3 EQ12 EQ23.
    destruct fp1 as [mp1 e1], fp2 as [mp2 e2], fp3 as [mp3 e3].
    unfold FPnum, FPexp in *.
    remember (Z.pos mp1) as m1; clear Heqm1 mp1.
    remember (Z.pos mp2) as m2; clear Heqm2 mp2.
    remember (Z.pos mp3) as m3; clear Heqm3 mp3.
    destruct EQ12 as [EQ12 | EQ12], EQ23 as [EQ23 | EQ23].
    all: destruct EQ12 as [E12 M12], EQ23 as [E23 M23]; subst.
    + left; split; [lia |].
      rewrite <-Z.mul_assoc.
      rewrite <-Z.pow_add_r; try lia.
      replace (e1 - e2 + (e2 - e3)) with (e1 - e3) by lia.
      reflexivity.
    + destruct (Z.eq_dec e1 e3); subst.
      * (* e1 = e3 *)
        apply Z.mul_reg_r in M23.
        subst; left; split; [lia |].
        rewrite Z.sub_diag; lia.
        pose proof (Z.pow_pos_nonneg 2 (e3 - e2)).
        lia.
      * destruct (Z_lt_le_dec e1 e3).
        -- (* e1 < e3 *)
          assert (E123 : e2 <= e1 < e3) by lia; clear E12 E23 n l.
          right; split; [lia |].
          apply f_equal with (f := fun x => Z.div x (2 ^ (e1 - e2))) in M23.

          rewrite Z_div_mult in M23;
            [| generalize (Z.pow_pos_nonneg 2 (e1 - e2)); lia].
          subst.
          rewrite Z.divide_div_mul_exact;
            [| apply Z.pow_nonzero; lia | apply Zpow_divide; lia].
          replace (e3 - e2) with ((e3 - e1) + (e1 - e2)) by lia.
          rewrite Z.pow_add_r by lia.
          rewrite Z.div_mul by (apply Z.pow_nonzero; lia).
          reflexivity.
        -- (* e3 < e1 *)
          assert (E123: e2 <= e3 < e1) by lia; clear E12 E23 n l.
          left; split; [lia |].
          apply f_equal with (f := fun x => Z.div x (2 ^ (e3 - e2))) in M23.
          rewrite Z_div_mult in M23;
            [| generalize (Z.pow_pos_nonneg 2 (e3 - e2)); lia].
          subst.
          rewrite Z.divide_div_mul_exact;
            [| apply Z.pow_nonzero; lia | apply Zpow_divide; lia].
          replace (e1 - e2) with ((e1 - e3) + (e3 - e2)) by lia.
          rewrite Z.pow_add_r by lia.
          rewrite Z.div_mul by (apply Z.pow_nonzero; lia).
          reflexivity.
    + destruct (Z.eq_dec e1 e3); subst.
      * (* e1 = e3 *)
        left; split; [lia |].
        rewrite Z.sub_diag; lia.
      * destruct (Z_lt_le_dec e1 e3).
        -- (* e1 < e3 *)
          assert (E123 : e1 < e3 <= e2) by lia; clear E12 E23 n l.
          right; split; [lia |].
          rewrite <-Z.mul_assoc.
          rewrite <-Z.pow_add_r by lia.
          replace (e2 - e3 + (e3 - e1)) with (e2 - e1) by lia.
          reflexivity.
        -- (* e3 < e1 *)
          assert (H: e3 < e1 <= e2) by lia; clear E12 E23 n l.
          left; split; [lia |].
          rewrite <-Z.mul_assoc.
          rewrite <-Z.pow_add_r by lia.
          replace (e2 - e1 + (e1 - e3)) with (e2 - e3) by lia.
          reflexivity.
    + right; split; [lia |].
      rewrite <-Z.mul_assoc.
      rewrite <-Z.pow_add_r; try lia.
      replace (e3 - e2 + (e2 - e1)) with (e3 - e1) by lia.
      reflexivity.
Qed.

Instance fp_equiv_dec : DecidableEquivalence fp_equiv.
Proof.
  unfold DecidableEquivalence, Decidable.decidable.
  intros fp1 fp2.
  unfold equiv, fp_equiv_def.
  destruct fp1 as [mp1 e1], fp2 as [mp2 e2].
  unfold FPnum, FPexp in *.
  destruct (Z_le_dec e1 e2),
           (Z_le_dec e2 e1),
           (Z.eq_dec (Z.pos mp2) (Z.pos mp1 * 2 ^ (e1 - e2))),
           (Z.eq_dec (Z.pos mp1) (Z.pos mp2 * 2 ^ (e2 - e1))).
  all: auto.
  all: right.
  all: intros C.
  all: destruct C; destruct H.
  all: auto.
Qed.

Definition digits_m (fp : float_pair) : positive :=
  Pos.size (FPnum fp).

Lemma exponent_unique (fp1 fp2 : float_pair) :
  FPexp fp1 = FPexp fp2 ->
  fp1 === fp2 ->
  fp1 = fp2.
Proof.
  destruct fp1 as [m1 e1], fp2 as [m2 e2].
  cbn.
  intros H E.
  subst.
  rewrite Z.sub_diag in *.
  cbn in *.
  repeat rewrite Pos.mul_1_r in *.
  destruct E as [[H1 H2] | [H1 H2]].
  all: inversion H2; subst; reflexivity.
Qed.

Lemma digits_m_unique (fp1 fp2 : float_pair) :
  digits_m fp1 = digits_m fp2 ->
  fp1 === fp2 ->
  fp1 = fp2.
Proof.
  intros.
  destruct (Z.eq_dec (FPexp fp1) (FPexp fp2)) as [| NE];
    [apply exponent_unique; assumption |].
  destruct fp1 as [m1 e1], fp2 as [m2 e2].
  cbn in *.
  destruct H0 as [[E M] | [E M]].
  -
    remember (e1 - e2) as ed.
    destruct ed; try lia.
    replace e1 with (e2 + Z.pos p) in * by lia.
    clear Heqed E NE.

    break_match; inversion M; clear M.
    rewrite <-Pos2Z.inj_pow in Heqz.
    inversion Heqz; clear Heqz.
    rewrite <-H2 in H1.
    rewrite H1 in H.
    rewrite pos_size_mul_pow_two in H.
    lia.
  -
    remember (e2 - e1) as ed.
    destruct ed; try lia.
    replace e2 with (e1 + Z.pos p) in * by lia.
    clear Heqed E NE.

    break_match; inversion M; clear M.
    rewrite <-Pos2Z.inj_pow in Heqz.
    inversion Heqz; clear Heqz.
    rewrite <-H2 in H1.
    rewrite H1 in H.
    rewrite pos_size_mul_pow_two in H.
    lia.
Qed.

Lemma equiv_neq_m (fp1 fp2 : float_pair) :
  fp1 === fp2 ->
  (FPnum fp1 < FPnum fp2)%positive ->
  FPexp fp1 > FPexp fp2.
Proof.
  intros.
  destruct fp1 as (m1, e1), fp2 as (m2, e2).
  cbn in *.
  destruct H as [[E M] | [E M]].
  -
    break_match; inversion M.
    destruct (e1 - e2) eqn:A; lia.
  -
    exfalso.
    break_match; try lia.
    inversion M.
    rewrite H1 in H0.
    clear - H0.
    induction p; lia.
Qed.

Lemma equiv_neq_e (fp1 fp2 : float_pair) :
  fp1 === fp2 ->
  FPexp fp1 < FPexp fp2 ->
  (FPnum fp1 > FPnum fp2)%positive.
Proof.
  intros.
  destruct fp1 as (m1, e1), fp2 as (m2, e2).
  cbn in *.
  destruct H as [[E M] | [E M]].
  -
    break_match; inversion M.
    destruct (e1 - e2) eqn:A; lia.
  -
    break_match; inversion M.
    enough (1 < 2 ^ (e2 - e1)) by nia.
    destruct (e2 - e1) eqn:A; try lia.
    clear.
    rename p0 into p.
    rewrite <-(Z.pow_1_l (Z.pos p)) by lia.
    apply Z.pow_lt_mono_l; lia.
Qed.

Lemma equiv_neq_m_digits (fp1 fp2 : float_pair) :
  fp1 === fp2 ->
  (digits_m fp1 < digits_m fp2)%positive ->
  FPexp fp1 > FPexp fp2.
Proof.
  intros.
  apply pos_size_monotone_inv in H0.
  apply equiv_neq_m; assumption.
Qed.

Lemma equiv_neq_e_digits (fp1 fp2 : float_pair) :
  fp1 === fp2 ->
  FPexp fp1 < FPexp fp2 ->
  (digits_m fp1 > digits_m fp2)%positive.
Proof.
  intros.
  destruct (Pos.eq_dec (digits_m fp1) (digits_m fp2))
    as [EQ | NEQ].
  -
    exfalso.
    apply digits_m_unique in EQ; [| assumption].
    subst.
    lia.
  -
    apply equiv_neq_e in H0; [| assumption].
    apply Pos.gt_lt, Pos.lt_le_incl in H0.
    apply pos_size_monotone in H0.
    unfold digits_m in *.
    lia.
Qed.


Require Import Arith.
Require Import Lia.
From recross Require Import util regexp.

Fixpoint pumping_constant (re : regexp) : nat :=
  match re with
  | Void | Nil | Class [] => 1
  | Char _ | Class _ => 2
  | Star re => pumping_constant re
  | Cat re1 re2 | Alt re1 re2 | And re1 re2 =>
      pumping_constant re1 + pumping_constant re2
  end.

Lemma pumping_constant_ge_1 : forall re,
  pumping_constant re >= 1.
Proof.
  induction re; cbn; try destruct cs; intuition. Qed.

Lemma pumping_constant_ne_0 : forall re,
  pumping_constant re <> 0.
Proof.
  intros.
  assert (pumping_constant re >= 1) by apply pumping_constant_ge_1.
  lia. Qed.

Fixpoint napp {T} (l : list T) (n : nat) : list T :=
  match n with
  | S n' => l ++ napp l n'
  | 0 => []
  end.

Lemma napp_plus : forall T (l : list T) n m,
  napp l (n + m) = napp l n ++ napp l m.
Proof.
  induction n; cbn; intros.
  - reflexivity.
  - now rewrite IHn, app_assoc. Qed.

Lemma Star_napp : forall re n s1 s2,
  s1 =~ re ->
  s2 =~ Star re ->
  napp s1 n ++ s2 =~ Star re.
Proof.
  induction n; cbn; intros.
  - assumption.
  - rewrite <- app_assoc. now apply MStarApp, IHn. Qed.

Lemma add_le : forall n m p,
  n + m <= p -> n <= p /\ m <= p.
Proof. lia. Qed.

Lemma pumping : forall re s,
  s =~ re ->
  pumping_constant re <= length s ->
  exists s1 s2 s3,
    s = s1 ++ s2 ++ s3 /\
    s2 <> [] /\
    length s1 + length s2 <= pumping_constant re /\
    forall n, s1 ++ napp s2 n ++ s3 =~ re.
Proof.
  intros re s H Hlen. induction H; cbn in *.
  - invert Hlen.
  - invert Hlen. invert H0.
  - destruct cs.
    + invert H.
    + invert Hlen. invert H1.
  - invert Hlen. apply pumping_constant_ne_0 in H0 as [].
  - rewrite app_length in Hlen.
    destruct (le_lt_dec (pumping_constant re) (length s1)) as [Hlen1 | Hlen1].
    + apply IHre_match1 in Hlen1 as [s11 [s12 [s13 [? [? []]]]]]. subst.
      exists s11, s12, (s13 ++ s2). repeat split.
      * now rewrite <- (app_assoc s11 _ _), <- app_assoc.
      * assumption.
      * assumption.
      * intros. rewrite (app_assoc _ _ s2), app_assoc. now apply MStarApp.
    + destruct (Nat.eq_dec (length s1) 0) as [Heq | Heq].
      * apply length_zero_iff_nil in Heq. subst. apply IHre_match2, Hlen.
      * exists [], s1, s2. repeat split.
        -- intro. destruct s1. now apply Heq. discriminate.
        -- cbn. lia.
        -- intros. now apply Star_napp.
  - rewrite app_length in Hlen.
    apply Nat.add_le_cases in Hlen as [Hlen1 | Hlen2].
    + apply IHre_match1 in Hlen1 as [s11 [s12 [s13 [? [? []]]]]]. subst.
      exists s11, s12, (s13 ++ s2). repeat split.
      * now rewrite <- app_assoc, <- app_assoc.
      * assumption.
      * lia.
      * intros. rewrite (app_assoc _ _ s2), app_assoc. now apply MCat.
    + destruct (le_lt_dec (pumping_constant re1) (length s1)) as [Hlen1 | Hlen1].
      * apply IHre_match1 in Hlen1 as [s11 [s12 [s13 [? [? []]]]]]. subst.
        exists s11, s12, (s13 ++ s2). repeat split.
        -- now repeat rewrite <- app_assoc.
        -- assumption.
        -- lia.
        -- intros. rewrite (app_assoc _ _ s2), app_assoc. apply MCat.
          ++ apply H4.
          ++ assumption.
      * apply IHre_match2 in Hlen2 as [s21 [s22 [s23 [? [? []]]]]]. subst.
        exists (s1 ++ s21), s22, s23. repeat split.
        -- now rewrite app_assoc.
        -- assumption.
        -- rewrite app_length. lia.
        -- intros. rewrite <- app_assoc. now apply MCat.
  - apply add_le in Hlen as [Hlen1 _].
    apply IHre_match in Hlen1 as [s11 [s12 [s13 [? [? []]]]]]. subst.
    exists s11, s12, s13. repeat split.
    + assumption.
    + lia.
    + intros. now apply MAltL.
  - apply add_le in Hlen as [_ Hlen2].
    apply IHre_match in Hlen2 as [s21 [s22 [s23 [? [? []]]]]]. subst.
    exists s21, s22, s23. repeat split.
    + assumption.
    + lia.
    + intros. now apply MAltR.
  - apply add_le in Hlen as [Hlen1 Hlen2].
    apply IHre_match1 in Hlen1 as [s11 [s12 [s13 [? [? []]]]]].
    apply IHre_match2 in Hlen2 as [s21 [s22 [s23 [? [? []]]]]].
    exists s11, s12, s13. repeat split.
    + assumption.
    + assumption.
    + lia.
    + intros. apply MAnd. apply H4. admit.
Admitted.


(* This File contains the proof of Dilworth's Thm. We just combine the
   Thms DilworthA and DilworthB from the File Finitedilworth_AB.v to prove
   the statement of Dilworth's theorem.
   Dilworth's decomposition theorem is the central result in our formalization.
   It states that in any poset, the maximum size of an antichain is equal to
   the minimum number of chains in any chain cover. In other words, if c(P)
   represents the size of a smallest chain cover of P, then width(P)=c(P).

   We prove the following formal statement,

  Theorem Dilworth: forall (P: FPO U), Dilworth_statement P.

  where Dilworth_statement is defined as,

  Definition Dilworth_statement:= fun (P: FPO U)=> forall (m n: nat),
      (Is_width P m) -> (exists cover: Ensemble (Ensemble U),
      (Is_a_smallest_chain_cover P cover) /\ (cardinal _ cover n)) -> m=n.

 *)

Require Export PigeonHole.
Require Export BasicFacts.
Require Import FiniteDilworth_AB.

Section Dilworth.

  Variable U: Type.

Inductive Is_width (P: FPO U) (n: nat) :Prop :=
     W_cond: (exists la: Ensemble U, Is_largest_antichain_in P la /\ cardinal _ la n) -> (Is_width P n).

 Definition Dilworth_statement:=  fun (P: FPO U)=>
     forall (m n: nat), (Is_width P m) ->
    (exists cover: Ensemble (Ensemble U), (Is_a_smallest_chain_cover P cover)/\ (cardinal _ cover n)) ->
    m=n.

   Theorem Dilworth: forall (P: FPO U), Dilworth_statement P.

   Proof. { intro P. unfold Dilworth_statement. intros m n. intros.
            destruct H. destruct H as [la H]. destruct H0 as [cover H0].

            (* We prove that there is a chain cover of size m using DilworthB *)
            assert (H1:  (exists (cv: Ensemble (Ensemble U)), Is_a_chain_cover P cv /\
                                                      cardinal _ cv m)).
            { apply (DilworthB _ P ).  exists la.  auto. }
            (* Hence n<= m, since n is the size of smallest chain cover *)
            assert (H2: n<= m ).
            { destruct H1 as [cv H1].
             destruct H0 as [H_cover H0].
             destruct H_cover .
             apply H3 with ( cover0:= cv) ( sn:= n) (n:= m). tauto.
            }
            (* We prove n>=m or ~ (n<m) using DilworthA *)
             assert (H3: n>= m).
              { apply nat_P1. apply ( DilworthA _ P) with (cv:= cover) (a:= la).
                apply H0.  apply H. tauto.  tauto. }
           (* Hemce combining H2 and H3 we have m=n  *)
           auto with arith.  }
  Qed.

End Dilworth.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.

Local Open Scope morphism_scope.

Section Equalizer.
  Context {C : Category} {a b : Obj} (f g : a –≻ b).

  (** given two parallel arrows f,g : a -> b, their equalizer is an object e
      together with an arrow eq : e -> a such that f ∘ eq = g ∘ eq such that
      for any other object z and eqz : z -> a that we have f ∘ eqz = g ∘ eqz,
      there is a unique arrow h : z -> e that makes the following diagram
      commute:

#
<pre>

          eqz
/—————————————————\     f
|                 ↓  ———————>
z ———–> e ——————> a          b
   ∃!h      eq       ———–——–>
                        g
</pre>
#
 *)

  Local Open Scope morphism_scope.

  Record Equalizer : Type :=
    {
      equalizer : C;

      equalizer_morph : equalizer –≻ a;

      equalizer_morph_com : f ∘ equalizer_morph = g ∘ equalizer_morph;

      equalizer_morph_ex (e' : Obj) (eqm : e' –≻ a) :
        f ∘ eqm = g ∘ eqm → e' –≻ equalizer;

      equalizer_morph_ex_com (e' : Obj) (eqm : e' –≻ a)
                             (eqmc : f ∘ eqm = g ∘ eqm)
      : equalizer_morph ∘ (equalizer_morph_ex e' eqm eqmc) = eqm;

      equalizer_morph_unique (e' : Obj) (eqm : e' –≻ a)
                             (com : f ∘ eqm = g ∘ eqm) (u u' : e' –≻ equalizer)
      : equalizer_morph ∘ u = eqm → equalizer_morph ∘ u' = eqm → u = u'
    }.

  Coercion equalizer : Equalizer >-> Obj.

  (** Equalizers are unique up to isomorphism. *)
  Theorem Equalizer_iso (e1 e2 : Equalizer) : (e1 ≃ e2)%isomorphism.
  Proof.
    apply (Build_Isomorphism _ _ _ (equalizer_morph_ex e2 _ (equalizer_morph e1)
                                                       (equalizer_morph_com e1))
                             ((equalizer_morph_ex e1 _ (equalizer_morph e2)
                                                  (equalizer_morph_com e2))));
    eapply equalizer_morph_unique; [| | simpl_ids; trivial| | |simpl_ids;
                                      trivial]; try apply equalizer_morph_com;
    rewrite <- assoc; repeat rewrite equalizer_morph_ex_com; auto.
  Qed.

End Equalizer.

Arguments equalizer_morph {_ _ _ _ _} _.
Arguments equalizer_morph_com {_ _ _ _ _} _.
Arguments equalizer_morph_ex {_ _ _ _ _} _ {_ _} _.
Arguments equalizer_morph_ex_com {_ _ _ _ _} _ {_ _} _.
Arguments equalizer_morph_unique {_ _ _ _ _} _ {_ _ _} _ _ _ _.

Arguments Equalizer _ {_ _} _ _, {_ _ _} _ _.

Definition Has_Equalizers (C : Category) : Type :=
  ∀ (a b : C) (f g : a –≻ b), Equalizer f g.

Existing Class Has_Equalizers.

(** CoEqualizer is the dual of equalzier *)
Definition CoEqualizer {C : Category} := @Equalizer (C^op).

Arguments CoEqualizer _ {_ _} _ _, {_ _ _} _ _.

Definition Has_CoEqualizers (C : Category) : Type := Has_Equalizers (C^op).

Existing Class Has_CoEqualizers.


Require Export GeoCoq.Elements.OriginalProofs.lemma_8_2.

Section Euclid.

Context `{Ax1:euclidean_neutral_ruler_compass}.

Lemma lemma_squareflip :
   forall A B C D,
   SQ A B C D ->
   SQ B A D C.
Proof.
intros.
assert ((Cong A B C D /\ Cong A B B C /\ Cong A B D A /\ Per D A B /\ Per A B C /\ Per B C D /\ Per C D A)) by (conclude_def SQ ).
assert (Cong B A D C) by (forward_using lemma_congruenceflip).
assert (Cong B A A D) by (forward_using lemma_congruenceflip).
assert (Cong B A C B) by (forward_using lemma_congruenceflip).
assert (Per C B A) by (conclude lemma_8_2).
assert (Per B A D) by (conclude lemma_8_2).
assert (Per A D C) by (conclude lemma_8_2).
assert (Per D C B) by (conclude lemma_8_2).
assert (SQ B A D C) by (conclude_def SQ ).
close.
Qed.

End Euclid.


Lemma Identity :
  forall A : Prop,
    A -> A.
Proof.
  intro A.
  intro H_A.
  apply H_A.
Qed.

(* ASSUMPTIONS
   ==========
     GOAL
*)

Lemma Identity' :
  forall B : Prop,
    B -> B.
Proof.
  intro B.
  intro H_B.
  apply H_B.
Qed.

Lemma Identity'' :
  forall C : Prop,
    C -> C.
Proof.
  intro C.
  intro H_C.
  apply H_C.
Qed.

(* Freedom to choose names *)
Lemma Identity''' :
  forall Z : Prop,
    Z -> Z.
Proof.
  intro Simon.
  intro Hypothesis_about_Simon.
  apply Hypothesis_about_Simon.
Qed.

Theorem foobar :
  forall A B : Prop,
    A -> (B -> A).
Proof.
  intro A.
  intro B.
  intro H_A.
  intro H_B.
  apply H_A.
Qed.

Require Import Arith.

Lemma comm_a :
  forall a b c : nat,
    (a + b) + c = c + (b + a).
Proof.
  intros a b c.
  rewrite -> (plus_comm a b). (* From the left *)
  rewrite -> (plus_comm (b + a) c).
  reflexivity.

  Restart.

  intros a b c.
  rewrite -> (plus_comm (a + b) c).
  rewrite -> (plus_comm a b).
  reflexivity.

  (* It can obviously be done in any way and from any direction *)

Qed.


Inductive day : Type :=
  | lundi : day
  | mardi : day
  | mercredi : day
  | jeudi : day
  | vendredi : day
  | samedi : day
  | dimanche : day.

Definition next_day (d : day) : day :=
  match d with
  | lundi => mardi
  | mardi => mercredi
  | mercredi => jeudi
  | jeudi => vendredi
  | vendredi => samedi
  | samedi => dimanche
  | dimanche => lundi
  end.

Eval compute in (next_day vendredi).
Eval compute in (next_day (next_day samedi)).

Example test_next_day:
  next_day (next_day dimanche) = mardi.

Proof.
  simpl. (* optional 'cause reflexivity seems to perform simpl automatically*)
  reflexivity.
Qed.

Inductive bool : Type :=
  | true : bool
  | false : bool.

Definition negb (b : bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Example test_negb1 : negb true = false.
Proof.
  reflexivity.
Qed.

Example test_negb2 : negb false = true.
Proof.
  reflexivity.
Qed.

Definition andb (a : bool) (b : bool) : bool :=
  match a with
  | true => b
  | false => false
  end.

Example test_andb1 : andb false false = false.
Proof.
  reflexivity.
Qed.

Example test_andb2 : andb true false = false.
Proof.
  reflexivity.
Qed.

Example test_andb3 : andb false true = false.
Proof.
  reflexivity.
Qed.

Example test_andb4 : andb true true = true.
Proof.
  reflexivity.
Qed.

Definition orb (a : bool) (b : bool) : bool :=
  match a with
  | true => true
  | false => b
  end.

Example test_orb1 : orb false false = false.
Proof.
  reflexivity.
Qed.

Example test_orb2 : orb true false = true.
Proof.
  reflexivity.
Qed.

Example test_orb3 : orb true false = true.
Proof.
  reflexivity.
Qed.

Example test_ordb4 : orb true true = true.
Proof.
  reflexivity.
Qed.

(* Exercises *)

(* nandb *)
Definition nandb (a : bool) (b : bool) : bool :=
  negb (andb a b).

Example test_nandb1: nandb true false = true.
Proof.
  reflexivity.
Qed.

Example test_nandb2: nandb false false = true.
Proof.
  reflexivity.
Qed.

Example test_nandb3: nandb false true = true.
Proof.
  reflexivity.
Qed.

Example test_nandb4: nandb true true = false.
Proof.
  reflexivity.
Qed.

(* andb3 *)

Definition andb3 (a : bool) (b : bool) (c : bool) : bool :=
  andb (andb a b) c.

Example test_andb31: andb3 true true true = true.
Proof.
  reflexivity.
Qed.

Example test_andb32: andb3 false true true = false.
Proof.
  reflexivity.
Qed.

Example test_andb33: andb3 true false true = false.
Proof.
  reflexivity.
Qed.

Example test_andb34: andb3 true true false = false.
Proof.
  reflexivity.
Qed.

(* Numbers *)

Module MyNat.

  Inductive nat : Type :=
    | O : nat
    | S : nat -> nat.

  Definition pred (n : nat) : nat :=
    match n with
    | O => O
    | S n' => n'
    end.

End MyNat.

Definition minustwo (n : nat) : nat :=
  match n with
  | O => O
  | S O => O
  | S (S n') => n'
  end.

Check (S (S (S (S O)))).
Eval compute in (minustwo 4).

Fixpoint evenb (n : nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => evenb n'
  end.

Definition oddb (n : nat) : bool := negb (evenb n).

Module Playground1.

  Fixpoint my_plus (a b : nat) : nat :=
    match b with
    | O => a
    | S n => plus (S a) n
    end.

  (* from sf *)
  Fixpoint plus (n : nat) (m : nat) : nat :=
  match n with
    | O => m
    | S n' => S (plus n' m)
  end.

  Example test_plus510: plus 5 10 = 15.
  Proof.
    reflexivity.
  Qed.

  Eval compute in (plus 3 2).

  Fixpoint mult (n m : nat) : nat :=
    match n with
      | O => O
      | S n' => plus m (mult n' m)
    end.

  Example test_mult1: (mult 3 3) = 9.
  Proof. reflexivity. Qed.

  (* Exercises *)

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

  Example test_fact0 : factorial O = S O.
  Proof.
    reflexivity.
  Qed.

  Example test_fact3 : factorial 3 = 6.
  Proof.
    reflexivity.
  Qed.

  Example test_fact4 : factorial 4 = 4 * factorial 3.
  Proof.
    reflexivity.
  Qed.

  Example test_fact5 : factorial 5 = mult 10 12.
  Proof.
    reflexivity.
  Qed.

End Playground1.

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

Example test_ble_nat1: (ble_nat 2 2) = true.
Proof. reflexivity. Qed.
Example test_ble_nat2: (ble_nat 2 4) = true.
Proof. reflexivity. Qed.
Example test_ble_nat3: (ble_nat 4 2) = false.
Proof. reflexivity. Qed.

Definition blt_nat (n m : nat) : bool :=
  ble_nat n (m - 1).

Example test_blt_nat1: (blt_nat 2 2) = false.
Proof. reflexivity. Qed.

Example test_blt_nat2: (blt_nat 2 4) = true.
Proof. reflexivity. Qed.

Example test_blt_nat3: (blt_nat 4 2) = false.
Proof. reflexivity. Qed.

Theorem plus_O_n : forall n : nat, 0 + n = n.
Proof.
  intros n.
  reflexivity.
Qed.

Theorem plus_1_l : forall n : nat, 1 + n = S n.
Proof.
  intros n.
  reflexivity.
Qed.

Theorem mult_0_l : forall n : nat, 0 * n = 0.
Proof.
  intros n.
  reflexivity.
Qed.

Theorem plus_id_example : forall n m : nat,
  n = m -> n + n = m + m.
Proof.
  intros n m.
  intros H.
  rewrite -> H.
  reflexivity.
Qed.

(* Exercises *)
Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o.
  intros H1 H2.
  rewrite -> H1.
  rewrite <- H2.
  reflexivity.
Qed.

Theorem mult_S_1 : forall n m : nat,
  m = S n -> m * (1 + n) = m * m.
Proof.
  intros n m.
  intros H.
  rewrite -> plus_1_l.
  rewrite <- H.
  reflexivity.
Qed.

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

Theorem plus_1_neq_0 : forall n : nat,
  beq_nat (n + 1) 0 = false.
Proof.
  intros n.
  destruct n as [| n' ].
  reflexivity.
  reflexivity.
Qed.

Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros b. destruct b.
    reflexivity.
    reflexivity.
Qed.

Theorem zero_nbeq_plus_1 : forall n : nat,
  beq_nat 0 (n + 1) = false.
Proof.
  intros n.
  destruct n as [| n' ].
  reflexivity.
  reflexivity.
Qed.

Theorem identify_fn_applied_twice :
  forall (f : bool -> bool),
  (forall x : bool,
  f x = x) ->
  forall b : bool, f (f b) = b.
Proof.
  intros f.
  intros H.
  intros b.
  rewrite -> H.
  rewrite -> H.
  reflexivity.
Qed.

Theorem neg_fn_applied_twice :
  forall (f : bool -> bool),
  (forall x : bool,
  f x = negb x) ->
  forall b : bool, f (f b) = b.
Proof.
  intros f.
  intros H.
  intros b.
  rewrite -> H.
  rewrite -> H.
  rewrite -> negb_involutive.
  reflexivity.
Qed.

(* mmh works but seems bad *)
Theorem andb_eq_orb :
  forall b c : bool,
  andb b c = orb b c -> b = c.
Proof.
  intros b.
  intros c.
  destruct b.
  simpl.
  intros H.
  rewrite -> H.
  reflexivity.
  simpl.
  intros H.
  rewrite -> H.
  reflexivity.
Qed.


(**
<<
  This file contains parition function of quicksort as an exampl
  that tries to use [fold_left_right_tup] from [FoldLib].

  [1] Bird, Richard. Introduction to Functional Programming using
                 Haskell (2nd ed.). Prentice Hall. Harlow, England.
                 1998.
>>
*)

  Require Import Recdef.
  Require Import homo.MyLib.

  (** ** Partitioning

   *)

  (** *** [partition_lt]

      We use [partition] from the List library of Coq to
      defined [partition_lt].
   *)

  Functional Scheme partition_ind := Induction for partition Sort Prop.
  Definition f_part (p: nat) := fun x => Nat.ltb x p.

  Definition partition_lt (p: nat) (l: list nat) := partition (f_part p) l.
  Functional Scheme partition_lt_ind := Induction for partition_lt Sort Prop.

  (** *** [partition_wont_expand]
  *)

  Lemma partition_wont_expand:
    forall l p m_lt m_ge,
      (m_lt, m_ge) = partition_lt p l ->
      length m_lt <= length l /\ length m_ge <= length l.
  Proof.
    intros l p.
    functional induction (partition (f_part p) l); intros * P.
    - injection P; intros; subst; auto.
    - unfold partition_lt in P.
      simpl in P.
      rewrite e0 in P.
      rewrite e1 in P.
      injection P; intros; subst.
      simpl.
      symmetry in e0.
      apply IHp0 in e0.
      intuition.
    - unfold partition_lt in P.
      simpl in P.
      rewrite e0 in P.
      rewrite e1 in P.
      injection P; intros; subst.
      simpl.
      symmetry in e0.
      apply IHp0 in e0.
      intuition.
  Qed.

  (** *** [partition_lt_idempotent]
   *)

  Lemma partition_lt_idempotent:
    forall l p m_lt m_ge,
      (m_lt, m_ge) = partition_lt p l ->
      (m_lt, []) = partition_lt p m_lt.
  Proof.
    intros l p.
    functional induction (partition (f_part p) l); intros * P.
    - injection P; intros;
      now subst m_lt m_ge.
    - unfold partition_lt in P.
      simpl in P.
      rewrite e0 in P.
      rewrite e1 in P.
      symmetry in e0.
      apply IHp0 in e0.
      injection P; intros;
      subst m_lt m_ge.
      simpl.
      rewrite <- e0.
      rewrite e1.
      reflexivity.
    -
      simpl in P.
      unfold partition_lt in P.
      rewrite e0 in P.
      rewrite e1 in P.
      injection P; intros;
      subst m_lt m_ge.
      symmetry in e0.
      apply IHp0 in e0.
      apply e0.
  Qed.

  (** *** [partition__lt]
   *)

  Lemma partition__lt:
    forall l p m_lt m_ge k,
      (m_lt, m_ge) = partition_lt p l ->
      In k m_lt ->
      k < p.
  Proof.
    induction l as [| y ys] ; intros * P IN.
    - inversion P; subst.
      apply in_nil in IN; inversion IN.
    - unfold partition_lt in P.
      simpl in P.
      name_term tpl (partition (f_part p) ys) Py.
      destruct tpl as [lo hi].
      rewrite <- Py in P.
      unfold f_part in P.
      remember (Nat.ltb y p) as r.
      destruct r.
      +
        injection P; intros T1 T2.
        inversion T1; clear T1.
        subst.
        symmetry in Heqr.
        apply Nat.ltb_lt in Heqr.
        destruct IN.
        * now subst k.
        * apply IHys with (m_lt:=lo) (m_ge:=hi); auto.
      + injection P; intros;
        subst lo.
        apply IHys with (m_lt:=m_lt) (m_ge:=hi); auto.
  Qed.

  Lemma partition__le:
    forall l p m_lt m_ge k,
      (m_lt, m_ge) = partition_lt p l ->
      In k m_ge ->
      p <= k.
  Proof.
    induction l as [| y ys] ; intros * P IN.
    - inversion P; subst.
      apply in_nil in IN; inversion IN.
    - unfold partition_lt in P.
      simpl in P.
      name_term tpl (partition (f_part p) ys) Py.
      destruct tpl as [lo hi].
      rewrite <- Py in P.
      unfold f_part in P.
      remember (Nat.ltb y p) as r.
      destruct r.
      + injection P; intros T1 T2.
        subst hi; apply IHys with (k:=k) in Py; auto.
      + symmetry in Heqr.
        apply Nat.ltb_ge in Heqr.
        injection P; intros T1 T2.
        subst.
        destruct IN.
        * now subst k.
        * apply IHys with (m_lt:=lo) (m_ge:=hi); auto.
  Qed.

  Require Import Sorting.Sorted Sorting.Permutation.
  Definition join_parted (p:nat) (m_lt m_ge: list nat) :=
    m_lt ++ [p] ++ m_ge.

  Lemma partition_join_parted_permute:
    forall m p m_lt m_ge,
      (m_lt, m_ge) = partition_lt p m ->
      Permutation (p::m) (m_lt++[p]++m_ge).
  Proof.
    intros * P.
    apply Permutation_cons_app.
    revert P.
    revert m_ge m_lt p.
    induction m as [| x xs]; intros * P.
    - simpl in P.
      injection P; intros;
      subst.
      apply perm_nil.
    - simpl in P.
      unfold partition_lt in P.
      name_term tpl (partition (f_part p) xs) Tpl.
      rewrite <- Tpl in P.
      unfold f_part in P.
      destruct tpl as [lo hi].
      remember (Nat.ltb x p) as r.
      destruct r; injection P; intros;
        subst m_lt m_ge.
      + apply IHxs in Tpl.
        simpl.
        apply perm_skip.
        apply Tpl.
      + apply Permutation_cons_app.
        apply IHxs in Tpl; auto.
  Qed.

  Definition partition_one (l: list nat) (p: nat) :=
    (fix f (l: list nat) (z: list nat * list nat) :=
       match l with
         | [] => z
         | x::xs => match z with
                      | (lo, hi) => if Nat.ltb x p
                                    then f xs (lo ++ [x], hi)
                                    else f xs (lo, hi ++ [x])
                    end
       end)
      l ([],[]).

  Lemma f_fact_7:
    forall {S1 S2 A B C D E F: Type}
           (f: S1 -> S2 -> A -> B -> C -> D -> E -> F)
           (bb:bool) s1 s2 f1 f2 f4 f5 pp1 pp2,
      f s1 s2 f1 f2
        (if bb then pp1 else pp2)
        f4 f5
      =
      if bb then
        f s1 s2 f1 f2 pp1 f4 f5
      else
        f s1 s2 f1 f2 pp2 f4 f5
  .
  Proof.
    intros.
    now destruct bb.
  Qed.

  (** ** Quicksort

   *)

  (** *** [qsort]

  *)

 Function qsort (m: list nat) {measure length m}:=
    match m with
      | [] => []
      | x::xs => let (m_lt, m_ge) := partition_lt x xs in
                 (qsort m_lt) ++ [x] ++ (qsort m_ge)
    end.
  Proof.
    -
      intros * M * P.
      symmetry in P.
      apply partition_wont_expand in P.
      simpl.
      intuition.
    - intros * M * P.
      symmetry in P.
      apply partition_wont_expand in P.
      simpl.
      intuition.
   Qed.