Inductive day : Type :=
  | monday : day
  | tuesday : day
  | wednesday : day
  | thursday : day
  | friday : day
  | saturday : day
  | sunday : day.

Definition next_weekday (d : day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Eval compute in (next_weekday friday).
   (* ==> monday : day *)
Eval compute in (next_weekday (next_weekday saturday)).
   (* ==> tuesday : day *)

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

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

Definition andb (b1 : bool) (b2 : bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition orb (b1 : bool) (b2 : bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

Example test_orb1: (orb true false) = true.
Proof. reflexivity. Qed.
Example test_orb2: (orb false false) = false.
Proof. reflexivity. Qed.
Example test_orb3: (orb false true) = true.
Proof. reflexivity. Qed.
Example test_orb4: (orb true true) = true.
Proof. reflexivity. Qed.\u00e5


Require Import Nat Arith.

Inductive Lst : Type :=  nil : Lst | cons : nat -> Lst -> Lst.

Scheme Equality for Lst.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Fixpoint len (len_arg0 : Lst) : nat
           := match len_arg0 with
              | nil => 0
              | cons x y => plus 1 (len y)
              end.

Fixpoint butlast (butlast_arg0 : Lst) : Lst
           := match butlast_arg0 with
              | nil => nil
              | cons n x => if Lst_beq x nil then nil else cons n (butlast x)
              end.

Theorem theorem0 : forall (x : Lst) (n : nat), eq (Lst_beq (cons n x) nil) false.
Proof.
  reflexivity.
Qed.

Theorem theorem1 : forall (x : Lst) (n : nat), eq (plus 1 (len (butlast (cons n x)))) (len (cons n x)).
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. destruct (Lst_beq x nil) eqn:?.
    + destruct x.
      * reflexivity.
      * discriminate.
    + simpl. simpl in IHx. rewrite Heqb in IHx. simpl in IHx. rewrite IHx. reflexivity.
Qed.


Require Import rt.util.tactics.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

(* Induction lemmas for natural numbers. *)
Section NatInduction.

  Lemma strong_ind :
    forall (P: nat -> Prop),
      (forall n, (forall k, k < n -> P k) -> P n) ->
      forall n, P n.
  Proof.
    intros P ALL n; apply ALL.
    induction n; first by ins; apply ALL.
    intros k LTkSn; apply ALL.
    by intros k0 LTk0k; apply IHn, leq_trans with (n := k).
  Qed.

  Lemma leq_as_delta :
    forall x1 (P: nat -> Prop),
      (forall x2, x1 <= x2 -> P x2) <->
      (forall delta, P (x1 + delta)).
  Proof.
    ins; split; last by intros ALL x2 LE; rewrite -(subnK LE) addnC; apply ALL.
    {
      intros ALL; induction delta.
        by rewrite addn0; apply ALL, leqnn.
        by apply ALL; rewrite -{1}[x1]addn0; apply leq_add; [by apply leqnn | by ins].
    }
  Qed.

End NatInduction.


(* SumOfNatを解いてもらったもの *)

Require Import Arith.

Fixpoint sum (n: nat) {struct n}: nat :=
  match n with
  | O   => O
  | S p => S p + sum p
  end.

Lemma sum_Sn: forall n, sum (S n) = S n + sum n.
Proof.
  simpl; reflexivity.
Qed.

Lemma succ_add: forall n, S n = n + 1.
Proof.
Admitted.

Lemma add_diag: forall n, n + n = 2 * n.
Proof.
Admitted.

Goal forall n m: nat, m = 2 * sum n -> m = n * (n + 1).
Proof.
  induction n.
  - intros; apply H.
  - rewrite sum_Sn.
    intros.
    (* ここまでは分かった *)
    rewrite Nat.mul_add_distr_l.
    rewrite Nat.mul_succ_l.
    rewrite Nat.mul_1_r.
    rewrite <- Nat.add_assoc.
    rewrite add_diag.
    rewrite Nat.add_comm.
    rewrite Nat.mul_add_distr_l in H.
    rewrite (IHn (2 * sum n)) in H.
    rewrite <- succ_add in H.
    apply H.
    reflexivity.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Omega.

Theorem l_le_max : ∀ n m, n ≤ max n m.
Proof.
  induction n; cbn; intros; try omega.
  destruct m; trivial.
  cut (n ≤ max n m); trivial; omega.
Qed.

Theorem r_le_max : ∀ n m, m ≤ max n m.
Proof.
  induction n; cbn; intros; try omega.
  destruct m;  try omega.
  cut (m ≤ max n m); trivial; omega.
Qed.

Theorem le_S_n_eq_or_le_n : ∀ n m, n ≤ S m → {n = S m} + {n ≤ m}.
Proof.
  intros n m H.
  destruct (eq_nat_dec n (S m)); [left; trivial|].
  right.
  omega.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (y : natural) (x : natural) : natural :=
  plus (mult y x) lf2.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (y : natural) (x : natural) : natural :=
  plus (mult y x) x.


(** * Sorted types. *)
(** Gianluca Amato,  Marco Maggesi, Cosimo Perini Brogi 2019-2021 *)
(*
This file contains a formalization of _sorted types_, i.e. types indexed by elements of another
type, called _index type_. Notation and terminologies are inspired by Wolfgang Wechler,
_Universal Algebra for Computer Scientist_, Springer.
*)

Require Import UniMath.Foundations.All.
Require Export UniMath.Combinatorics.MoreLists.

Require Export UniMath.Algebra.Universal.HVectors.

Declare Scope sorted_scope.

Delimit Scope sorted_scope with sorted.

Local Open Scope sorted_scope.

(** An element of [sUU S] is an [S]-sorted type, i.e., an [S]-indexed family of types. *)

Definition sUU (S: UU): UU := S → UU.

(** If [X] and [Y] are [S]-sorted types, then [sfun X Y] is an [S]-sorted mapping, i.e.,
a [S]-indexed family of functions [X s → Y s]. *)

Definition sfun {S: UU} (X Y: sUU S): UU := ∏ s: S, X s → Y s.

Notation "x s→ y" := (sfun x y) (at level 99, y at level 200, right associativity): type_scope.

Bind Scope sorted_scope with sUU.

Bind Scope sorted_scope with sfun.

Definition idsfun {S: UU} (X: sUU S): X s→ X := λ s: S, idfun (X s).

Definition scomp {S: UU} {X Y Z: sUU S} (f: Y s→ Z) (g: X s→ Y): sfun X Z
  := λ s: S, (f s) ∘ (g s).

Infix "s∘" := scomp (at level 40, left associativity): sorted_scope.

Definition sunit (S: UU): sUU S := λ σ: S, unit.

Definition tosunit {S: UU} {X: sUU S}: X s→ sunit S := λ σ: S, tounit.

Lemma iscontr_sfuntosunit {S: UU} {X: sUU S}: iscontr (X s→ sunit S).
Proof.
  apply impred_iscontr.
  intros.
  apply iscontrfuntounit.
Defined.

(** An element of [shSet S] is an [S]-sorted set, i.e., an [S]-indexed family of sets. It can be
immediately coerced to an [S]-sorted type. *)

Definition shSet (S: UU): UU := S → hSet.

Definition sunitset (S: UU): shSet S := λ _, unitset.

Lemma isaset_set_sfun_space {S: UU} {X: sUU S} {Y: shSet S}: isaset (X s→ Y).
Proof.
  change (isaset (X s→ Y)).
  apply impred_isaset.
  intros.
  apply isaset_forall_hSet.
Defined.

(** If [X: sUU S], then [star X] is the lifting of [X] to the index type [list S], given
by [star X] [s1; s2; ...; sn] = [X s1 ; X s2 ; ... ; X sn]. *)

Definition star {S: UU} (X: sUU S): sUU (list S) := λ l: list S, hvec (vec_map X (pr2 l)).

Bind Scope hvec_scope with star.

Notation "A ⋆" := (star A) (at level 3, format "'[ ' A '⋆' ']'"): sorted_scope.

(** If [f] is an indexed mapping between [S]-indexed types [X] and [Y], then [starfun X] is the lifting of
[f] to a [list S]-indexed mapping between [list S]-indexed sets [star X] and [star Y].
*)

Definition starfun {S: UU} {X Y: sUU S} (f: sfun X Y) : sfun X⋆ Y⋆ := λ s: list S, h1map f.

Notation "f ⋆⋆" := (starfun f) (at level 3, format "'[ ' f '⋆⋆' ']'"): sorted_scope.

(** Here follows the proof that [starfun] is functorial. Compositionality w.r.t. [s∘] is presented as
[(f s∘ g)⋆⋆ _ x = f⋆⋆ _ (g⋆⋆ _ x)] instead of [(f s∘ g)⋆⋆ = (f⋆⋆) s∘ (g⋆⋆ )] since the former
does not require function extensionality. *)

Lemma staridfun {S: UU} {X: sUU S} (l: list S) (x: X⋆ l): (idsfun X)⋆⋆ _ x = idsfun X⋆ _ x.
Proof.
  apply h1map_idfun.
Defined.

Lemma starcomp {S: UU} {X Y Z: sUU S} (f: Y s→ Z) (g: X s→ Y) (l: list S) (x: X⋆ l)
  : (f s∘ g)⋆⋆ _ x = f⋆⋆ _ (g⋆⋆ _ x).
Proof.
  unfold starfun.
  apply pathsinv0.
  apply h1map_compose.
Defined.


Require Import Znumtheory.
Require Import QArith.

(** Proof that Sqrt(2) cannot be rational *)

Ltac mysimpl := simplify_eq; repeat rewrite Pmult_xO_permute_r.

Theorem main_thm : forall p q: positive, (p*p <> 2*(q*q))%positive.
Proof.
induction p; simpl; intro; mysimpl.
destruct q; mysimpl; firstorder.
Qed.

Coercion inject_Z : Z >-> Q.

Theorem sqrt2_not_rational : forall q:Q, ~ q^2 == 2.
Proof.
intros (a,b).
unfold Qeq, Qpower, Qmult; simpl.
repeat rewrite Zmult_1_r; rewrite Pmult_1_r.
destruct a as [|a|a]; simpl; simplify_eq; exact (main_thm a b).
Qed.

(** Ok, I admit, the proof above is a hack, since we exploit the binary
  nature of positive numbers in Coq. For comparison, let's do the same for
  an arbitrary prime number. *)

Open Scope Z_scope.

Theorem main_thm_gen : forall p:Z, prime p ->
 forall a b:Z, 0<a -> 0<b -> a*a <> p*b*b.
Proof.
intros p Hp a b Ha.
generalize Ha; revert b; pattern a.
apply Zlt_0_rec; auto with zarith.
clear a Ha; intros a Hrec _ b Ha Hb Hneg.
assert (Hdiv: (p|a)).
 destruct (prime_mult p Hp a a); auto.
 exists (b*b); rewrite Hneg; ring.
destruct Hdiv as (c,Hc).
assert (Hneg': b*b = p*c*c).
 rewrite Hc in Hneg.
 replace (c*p*(c*p)) with (p*(p*c*c)) in Hneg by ring.
 symmetry.
 destruct Hp.
 apply Zmult_reg_l with p; auto with zarith.
 rewrite Hneg; ring.
revert Hneg'.
apply Hrec; auto.
(* justification of the recursive call: *)
split; auto with zarith.
destruct (Z_lt_ge_dec b a); auto.
destruct Hp as (Hp,_).
assert (a*a < p*b*b); [|omega].
 apply Zle_lt_trans with (b*b).
 apply Zmult_le_compat; auto with zarith.
 replace (b*b) with (1*(b*b)) by (auto with zarith).
 rewrite <- Zmult_assoc.
 apply Zmult_lt_compat_r; auto with zarith.
 apply Zmult_lt_0_compat; auto with zarith.
destruct Hp as (Hp,_).
destruct p; destruct a; destruct c; auto; simpl in Hc; try discriminate.
Qed.

Theorem sqrtprime_not_rational : forall p:Z, prime p ->
 forall q:Q, ~ q*q == p.
Proof.
intros p Hp (a,b).
unfold Qmult, Qeq; simpl.
rewrite Zmult_1_r; rewrite Zpos_mult_morphism.
rewrite Zmult_assoc.
destruct a as [|a|a].
destruct Hp; destruct p; simpl in *; try discriminate.
apply main_thm_gen; auto with zarith; compute; auto.
simpl; rewrite Zpos_mult_morphism.
apply main_thm_gen; auto with zarith; compute; auto.
Qed.


From MyCoq.Lib Require Export Nat.
From MyCoq.Lib Require Export Poly.

(* apply *)
Theorem silly2: forall (n m o p : nat),
  n = m -> (n = m -> [n; o] = [m; p]) -> [n; o] = [m; p].
Proof.
  intros n m o p eq1 eq2.
  apply eq2.
  apply eq1.
Qed.

Theorem silly2a: forall (n m : nat),
  (n, n) = (m, m) -> (forall (q r : nat), (q, q) = (r, r) -> [q] = [r]) -> [n] = [m].
Proof.
  intros n m eq1 eq2.
  apply eq2.
  apply eq1.
Qed.

Theorem silly_ex: (forall n, evenb n = true -> oddb (S n) = true) -> evenb (N 4) = true -> oddb (N 3) = true.
Proof.
  intros H.
  apply H.
Qed.

Theorem silly3_firsttry: forall (n : nat),
  true = (n =? (N 5)) -> (S (S n)) =? (N 7) = true.
Proof.
  intros n H.
  symmetry.
  apply H.
Qed.

Search rev.
Theorem rev_exercise1: forall (l l' : list nat),
  l = rev l' -> l' = rev l.
Proof.
  intros l l'.
  intros H.
  rewrite H.
  rewrite rev_involutive .
  reflexivity.
Qed.

(* apply with *)
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.
  (* 根据引理结论对证明目标进行匹配的过程中并没有为 m 确定实例 *)
  apply trans_eq with (m := [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.
  intros eq1 eq2.
  apply trans_eq with (m := m).
  - apply eq2.
  - apply eq1.
Qed.

(* The injection and discriminate Tactics *)
Theorem S_injective: forall (n m : nat),
  S n = S m -> n = m.
Proof.
  intros n m H1.
  assert (H2: n = pred (S n)).
  {
    reflexivity.
  }
  rewrite H2.
  rewrite H1.
  reflexivity.
Qed.

Theorem S_injective': forall (n m : nat),
  S n = S m -> n = m.
Proof.
  intros n m H.
  injection H as Hnm.
  apply Hnm.
Qed.

Theorem injection_ex1: forall (n m o : nat),
  [n; m] = [o; o] -> [n] = [m].
Proof.
  intros n m o H.
  injection H as H1 H2.
  rewrite H1.
  rewrite H2.
  reflexivity.
Qed.

Theorem injection_ex2: forall (n m o : nat),
  [n; m] = [o; o] -> [n] = [m].
Proof.
  intros n m o H.
  injection H.
  intros H1 H2.
  rewrite H1.
  rewrite H2.
  reflexivity.
Qed.

Example injection_ex3: forall (X : Type) (x y z : X) (l j : list X),
  x :: y :: l = z :: j ->
  j = z :: l ->
  x = y.
Proof.
  intros X x y z l j.
  intros H1 H2.
  injection H1 as H11 H12.
  rewrite H2 in H12.
  injection H12 as H3.
  rewrite H11.
  rewrite H3.
  reflexivity.
Qed.

Theorem eqb_0_l: forall n,
   O =? n = true -> n = O.
Proof.
  intros [| n'].
  - reflexivity.
  - intros H.
    discriminate.
Qed.

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

Example discriminate_ex3: forall (X : Type) (x y z : X) (l j : list X),
  x :: y :: l = [] -> x = z.
Proof.
  intros x y z l j.
  intros contra.
  discriminate.
Qed.

Theorem f_equal: forall (A B : Type) (f : A -> B) (x y : A),
  x = y -> f x = f y.
Proof.
  intros  A B f x y.
  intros H.
  rewrite H.
  reflexivity.
Qed.

Theorem eq_implies_succ_equal': forall (n m : nat),
  n = m -> S n = S m.
Proof.
  intros n m H.
  apply f_equal.
  apply H.
Qed.

(* 对假设使用策略 *)
Theorem S_inj: forall (n m : nat) (b : bool),
  (S n) =? (S m) = b -> n =? m = b.
Proof.
  intros n m b.
  intros H.
  simpl in H.
  apply H.
Qed.

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

(* 变换归纳假设 *)
Theorem double_injective: forall (n m : nat),
  double n = double m -> n = m.
Proof.
  induction n as [| n' IHn'] .
  - simpl.
    intros [| m'] H.
    + reflexivity.
    + discriminate H.
  - simpl.
    intros [| m'] H.
    + discriminate.
    + apply f_equal.
      apply IHn'.
      injection H as goal.
      apply goal.
Qed.

Theorem eqb_true: forall n m,
  n =? m = true -> n = m.
Proof.
  induction n as [| n' IHn'].
  - intros [| m'] H.
    + reflexivity.
    + discriminate.
  - intros [| m'] H.
    + discriminate.
    + apply f_equal.
      apply IHn'.
      simpl in H.
      apply H.
Qed.

Theorem plus_n_n_injective: forall n m,
  n + n = m + m -> n = m.
Proof.
  induction n as [| n'].
  - intros [| m'] H.
    + reflexivity.
    + discriminate.
  - intros [| m'] H.
    + discriminate.
    + apply f_equal.
      apply IHn'.
      simpl in H.
      rewrite plus_n_Sm in H.
      rewrite plus_n_Sm in H.
      injection H as H'.
      apply H'.
Qed.

Theorem double_injective_take2: forall (n m : nat),
  double n = double m -> n = m.
Proof.
  intros n m.
  generalize dependent n.
  induction m as [| m' IHm'] .
  - simpl.
    intros [| n'] H.
    + reflexivity.
    + discriminate H.
  - simpl.
    intros [| n'] H.
    + discriminate.
    + apply f_equal.
      apply IHm'.
      injection H as goal.
      apply goal.
Qed.

Theorem nth_error_after_last: forall (n : nat) (X : Type) (l : list X),
  length l = n ->
  nth_error l n = None.
Proof.
  intros n X.
  induction n as [| n'].
  - destruct l as [| n l'].
    + reflexivity.
    + intros H.
      discriminate H.
  - intros [| n l'] H.
    + reflexivity.
    + apply IHn'.
      injection H as H'.
      apply H'.
Qed.

(* 展开定义 *)
Definition square n := n * n.

Lemma square_mult: forall n m, square (n * m) = square n * square m.
Proof.
  intros n m.
  unfold square.
  rewrite mult_assoc.
  rewrite mult_assoc.
  assert (H: n * m * n = n * n * m).
  {
    rewrite mult_comm.
    rewrite mult_assoc.
    reflexivity.
  }
  rewrite H.
  reflexivity.
Qed.

Definition bar x :=
  match x with
  | O => N 5
  | S _ => N 5
  end.

Fact silly_fact: forall m, bar m + N 1 = bar (m + N 1) + N 1.
Proof.
  intros m.
  unfold bar.
  destruct m as [| m'].
  - reflexivity.
  - reflexivity.
Qed.

(* 对复合表达式使用 destruct *)
Definition sillyfun (n : nat) : bool :=
  if n =? N 3 then false
  else if n =? N 5 then false
  else false.

Theorem sillyfun_false: forall (n : nat),
  sillyfun n = false.
Proof.
  intros n.
  unfold sillyfun.
  destruct (n =? N 3) eqn : E1.
  - reflexivity.
  - destruct (n =? N 5) eqn : E2.
    + reflexivity.
    + reflexivity.
Qed.

Theorem combine_split: forall X Y (l : list (X * Y)) l1 l2,
  split l = (l1, l2) -> combine l1 l2 = l.
Proof.
  intros X Y.
  intros l.
  (* induction 后加 eqn : E 会产生矛盾的假设 *)
  induction l as [| n l' IHl'].
  - intros l1 l2 H.
    injection H as H1 H2.
    rewrite <- H1.
    rewrite <- H2.
    reflexivity.
  - destruct n as [n1 n2].
    simpl.
    destruct (split l') as [l1' l2'].
    intros l1 l2 H.
    injection H as H1 H2.
    rewrite <- H1.
    rewrite <- H2.
    simpl.
    assert (Hc: combine l1' l2' = l').
    {
      apply IHl'.
      - reflexivity.
    }
    rewrite Hc.
    reflexivity.
Qed.

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

Theorem sillyfun1_odd_FAILED: forall (n : nat),
  sillyfun1 n = true -> oddb n = true.
Proof.
  intros n.
  intros H.
  unfold sillyfun1 in H.
  destruct (n =? N 3) eqn : Heq3.
  - apply eqb_true in Heq3.
    rewrite Heq3.
    reflexivity.
  - destruct (n =? N 5) eqn : Heq5.
    + apply eqb_true in Heq5.
      rewrite Heq5.
      reflexivity.
    + discriminate.
Qed.

Theorem bool_fn_applied_thrice: forall (f : bool -> bool) (b : bool),
  f (f (f b)) = f b.
Proof.
  intros f.
  intros b.
  destruct b eqn : Eb.
  - destruct (f true) eqn : Et.
    + rewrite Et, Et.
      reflexivity.
    + destruct (f false) eqn : Ef.
      * apply Et.
      * apply Ef.
  - destruct (f true) eqn : Et.
    + destruct (f false) eqn : Ef.
      * rewrite Et, Et.
        reflexivity.
      * rewrite Ef, Ef.
        reflexivity.
    + destruct (f false) eqn : Ef.
      * rewrite Et, Ef.
        reflexivity.
      * rewrite Ef, Ef.
        reflexivity.
Qed.

(* exercises *)
Theorem eqb_sym: forall (n m : nat),
  (n =? m) = (m =? n).
Proof.
  induction n as [| n'].
  - intros [| m'].
    + reflexivity.
    + simpl.
      reflexivity.
  - intros [| m'].
    + simpl.
      reflexivity.
    + simpl.
      apply IHn'.
Qed.

Theorem eqb_trans: forall n m p,
  n =? m = true ->
  m =? p = true ->
  n =? p = true.
Proof.
  intros n m p.
  intros H1 H2.
  apply eqb_true in H1.
  apply eqb_true in H2.
  rewrite -> H1.
  rewrite <- H2.
  apply self_eq.
Qed.

Definition split_combine_statement : Prop :=
  forall (X Y : Type) (l1 : list X) (l2 : list Y) (l : list (X * Y)),
  length l1 = length l2 -> combine l1 l2 = l -> split l = (l1, l2).

Theorem split_combine: split_combine_statement.
Proof.
  unfold split_combine_statement.
  intros X Y.
  induction l1 as [| n1 l1' IHl1'].
  - intros l2 l.
    intros H1 H2.
    destruct l2 as [| n2 l2'].
    + rewrite <- H2.
      simpl.
      reflexivity.
    + discriminate H1.
  - intros l2 l.
    intros H1 H2.
    destruct l2 as [| n2 l2'].
    + discriminate H1.
    + simpl in H2.
      rewrite <- H2.
      simpl.
      assert (Hsc: split (combine l1' l2') = (l1', l2')).
      {
        apply IHl1'.
        - simpl in H1.
          injection H1 as H1'.
          apply H1'.
        - reflexivity.
      }
      rewrite Hsc.
      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.
  intros test.
  intros x.
  induction l as [| n l'].
  - intros lf.
    intros H.
    simpl in H.
    discriminate H.
  - intros lf.
    intros H.
    simpl in H.
    destruct (test n) eqn : E.
    + injection H as H' H''.
      rewrite <- H'.
      apply E.
    + apply IHl' with (lf := lf).
      apply H.
Qed.

Fixpoint forallb {X : Type} (test : X -> bool) (l : list X) : bool :=
  match l with
  | [] => true
  | x :: y => (test x) && forallb test y
  end.

Example test_forallb1: forallb oddb [N 1; N 3; N 5; N 7; N 9] = true.
Proof. simpl. reflexivity. Qed.
Example test_forallb2: forallb (eqb (N 5)) [] = true.
Proof. simpl. reflexivity. Qed.

Fixpoint existsb {X : Type} (test : X -> bool) (l : list X) : bool :=
  match l with
  | [] => false
  | x :: y => (test x) || existsb test y
  end.

Example test_existsb1: existsb (andb true) [true; true; false] = true.
Proof. simpl. reflexivity. Qed.
Example test_existsb2: existsb (eqb (N 5)) [] = false.
Proof. simpl. reflexivity. Qed.

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

Example test_existsb'1: existsb (andb true) [true; true; false] = true.
Proof. simpl. reflexivity. Qed.
Example test_existsb'2: existsb (eqb (N 5)) [] = false.
Proof. simpl. reflexivity. Qed.

Theorem existsb_existsb': forall (X : Type) (test : X -> bool) (l : list X),
  existsb test l = existsb' test l.
Proof.
  intros X.
  intros test.
  unfold existsb'.
  induction l as [| n l'].
  - simpl.
    reflexivity.
  - simpl.
    destruct (test n) eqn : E.
    + simpl.
      reflexivity.
    + simpl.
      apply IHl'.
Qed.

Definition excluded_middle : Prop :=
  forall (P : Prop), P \/ ~ P.

Definition contrapositive : Prop :=
  forall (P Q : Prop), (P -> Q) <-> (~ Q -> ~ P).

Definition double_negation : Prop :=
  forall (P : Prop), ~ (~ P) <-> P.

Theorem de_morgan: forall (P Q : Prop), ~ (P \/ Q) <-> (~ P) /\ (~ Q).
Proof.
  intros P Q.
  split.
  - unfold not.
    intro H1.
    split.
    + intro H2.
      apply H1.
      left.
      apply H2.
    + intro H2.
      apply H1.
      right.
      apply H2.
  - unfold not.
    intros H1 H2.
    destruct H1 as [H11 H12].
    destruct H2 as [H21 | H22].
    + apply H11.
      apply H21.
    + apply H12.
      apply H22.
Qed.

Theorem equivalent: excluded_middle <-> contrapositive.
Proof.
  unfold excluded_middle.
  unfold contrapositive.
  split.
  - intros H1 P Q.
    split.
    + intros H2 H3.
      intro H4.
      apply H3.
      apply H2.
      apply H4.
    + intros H2 H3.
      specialize (H1 Q) as H4.
      destruct H4 as [H41 | H42].
      * apply H41.
      * apply H2 in H42.
        apply H42 in H3.
        destruct H3.
  - intros H1 P.
    assert double_negation as H2.
    {
      intro Q.
      specialize (H1 True Q).
      split.
      - intro H3.
        apply H1.
        + intro H4.
          apply H3 in H4.
          destruct H4.
        + reflexivity.
      - intro H3.
        unfold not.
        intro H4.
        apply H4.
        apply H3.
    }
    apply H2.
    intro H3.
    apply de_morgan in H3.
    destruct H3 as [H31 H32].
    apply H32 in H31.
    destruct H31.
Qed.

Theorem not_equivalent_with_neg: forall (P : Prop), ~ (P <-> ~ P).
Proof.
  intros P H1.
  unfold not in H1.
  destruct H1 as [H11 H12].
  assert (H2: P -> False).
  {
    intro H3.
    apply H11.
    apply H3.
    apply H3.
  }
  apply H11.
  - apply H12.
    apply H2.
  - apply H12.
    apply H2.
Qed.


(*Robert Hughes
Comp 293 Hw 2
This is the document for the second homework for the software reliability class*)

From LF Require Export Poly.
From LF Require Export Lists.
From LF Require Export Basics.
From LF Require Export Induction.

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

(*Question #1*)
Theorem question_1: forall X (l : list X),
  fold_length l = length l.
Proof.
  intros.
  induction l as [| h t IH].
  - reflexivity.
  - simpl.
    rewrite <- IH.
    unfold fold_length.
    simpl. reflexivity.
Qed.

(*Question #2*)
Definition fold_map {X Y:Type} (f : X -> Y) (l : list X) : list Y :=
fold (fun x => fun xs => f x :: xs) l [].

Theorem question_2: forall X Y (l : list X) (f: X -> Y),
  fold_map f l = map f l.
Proof.
  intros.
  induction l as [| h t IH].
  - reflexivity.
  - simpl.
    rewrite <- IH.
    unfold fold_map.
    simpl. reflexivity.
Qed.

(*Question 3a*)

Definition Nat := forall X : Type, (X -> X) -> X -> X.

(*Question 3b*)

Definition zero : Nat :=
  fun (X : Type) (f : X -> X) (x : X) => x.

Definition one : Nat :=
  fun (X : Type) (f : X -> X) (x : X) => f x.

Definition two : Nat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f x).

Definition three : Nat :=
  fun (X : Type) (f : X -> X) (x : X) => f( f (f x) ).

(*Question 3c*)

Definition succ (a : Nat) : Nat :=
  fun (X : Type) (f : X -> X) (x: X) => f (a X f x).

(*Question 3d*)

Example succ_1 : succ zero = one.
Proof.
intros. simpl. reflexivity. Qed.

Example succ_2 : succ one = two.
Proof.
intros. reflexivity. Qed.

Example succ_3 : succ two = three.
Proof.
intros. reflexivity. Qed.

(*Question 3e*)
Definition plus (a b : Nat) : Nat :=
  fun (X : Type) (f : X -> X) (x: X) => b X f (a X f x).

(*Question 3f*)

Example plus_1 : plus zero one = one.
  Proof. reflexivity. Qed.

Example plus_2 : plus two three = plus three two.
  Proof. reflexivity. Qed.

Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
  Proof. reflexivity. Qed.

(*Question 3g*)

Definition mult (a b : Nat) : Nat :=
  fun (X : Type) (f : X -> X) => b X (a X f).

(*Question 3h*)

Example mult_1 : mult one one = one.
  Proof. reflexivity. Qed.

Example mult_2 : mult zero (plus three three) = zero.
  Proof. reflexivity. Qed.

Example mult_3 : mult two three = plus three three.
  Proof. reflexivity. Qed.

(*Question 3i*)

Definition exp (a b : Nat) : Nat :=
fun (X : Type) (f : X -> X) (x : X) =>  (b (X -> X) (a X) f) x.

(*Question 3j*)

Example exp_1 : exp two two = plus two two.
Proof. reflexivity. Qed.

Example exp_2 : exp three two = plus (mult two (mult two two)) one.
Proof. reflexivity. Qed.

Example exp_3 : exp three zero = one.
Proof. reflexivity. Qed.

(*Question 3k*)
Theorem question_3k: forall n : Nat,
plus n one = succ n.
Proof.
  intro n.  reflexivity. Qed.

(*Question 3l*)
Theorem question_3l: forall (n m: Nat),
mult n (succ m) = plus (mult n m) n.
Proof.

  intro n. reflexivity. Qed.

(*Question 4*)
Definition func_comp {A B C : Type} (g : B -> C) (f : A -> B) :=
  fun x => g (f x).

(*
Theorem question_4: forall(),
*)
Theorem composition_associative : forall A B C D (f : A -> B) (g : B -> C) (h : C -> D),
  func_comp (func_comp h g) f = func_comp h (func_comp g f).
Proof.
  intros. reflexivity. Qed.

(*Question 5*)
(*Question 5a*)
Inductive tree (X:Type) : Type :=
  | empty : tree X
  | branch : X -> list (tree X) -> tree X.

Arguments tree {X}.
Arguments empty {X}.
Arguments branch {X}.

(*Question 5b*)
Definition mytree :=
  branch 1 [ branch 5 [ branch 2 [empty] ] ;  branch 8 [empty] ;
          branch 7 [ branch 3 [empty];branch 4 [empty] ] ].

(*Question 5c*)
Definition isleaf {X: Type} (node: @tree X) : bool :=
  match node with
    | empty => true
    | _ => false
  end.

(*Question 5d*)
Example test_isleaf:
  isleaf mytree = false.
Proof.
  simpl. reflexivity.
Qed.

(* Test tree for the height
Definition mytree_test :=
  branch 1[ branch 3 [ branch 5 [ empty]; branch 2 [branch 2 [branch 2 [branch 2 [empty]]]] ]].

*)

(*Question 5e*)

Fixpoint height {X: Type} (tr: @tree X) : nat :=
  let fix subtree_height (l: list tree) : nat :=
        match l with
          |nil => 0
          |h::t => max ( height h ) ( subtree_height t )
        end
  in
  match tr with
  | empty => 0
  | branch _ l => S (subtree_height l)
  end.

(*Compute height mytree_test .*)

(*Question 5f*)

Example test_height:
  height mytree = 3.
Proof.
  simpl. reflexivity.
Qed.

(*Question 5g*)
Fixpoint sum_nodes (tr: @tree nat) : nat :=
  let fix subtree_node (l: list tree) : nat :=
        match l with
          |nil => 0
          |h::t =>  ( sum_nodes h ) + ( subtree_node t )
        end
  in
  match tr with
  | empty => 0
  | branch r l => r + (subtree_node l)
  end.

Compute sum_nodes mytree.

(*Question 5h*)
Example test_sum_nodes:
  sum_nodes mytree = 30.
Proof.
  simpl. reflexivity.
Qed.

(*Question 6*)
(*Question 6a*)

Inductive b_tree (X: Type) : Type :=
  | emp_tree : b_tree X
  | node: X ->b_tree X -> b_tree X-> b_tree X.

Arguments b_tree {X}.
Arguments emp_tree {X}.
Arguments node {X}.

Definition mytree2 :=
node 1
    (node 2
        (node 4 emp_tree emp_tree)
        (node 5 emp_tree emp_tree))
    (node 3 emp_tree emp_tree).

(*Question 6b*)
Fixpoint preorder {X: Type} (btr: b_tree) : list X:=
  match btr with
  | emp_tree => []
  | node p q r =>   [p] ++ preorder q ++ preorder r
  end.

(*Question 6c*)
Compute preorder mytree2.

(*Question 6d*)
Fixpoint inorder {X: Type} (btr: b_tree) : list X:=
  match btr with
  | emp_tree => []
  | node p q r => inorder q ++ [p] ++ inorder r
  end.

(*Question 6e*)
Compute inorder mytree2.

(*Question 6f*)
Fixpoint postorder {X: Type} (btr: b_tree) : list X:=
  match btr with
  | emp_tree => []
  | node p q r =>  postorder q ++ postorder r ++  [p]
  end.

(*Question 6g*)
Compute postorder mytree2.

(*Question 6h*)
Theorem question_6h : forall (X : Type) ( tree : @b_tree X ),

  length (preorder tree) = length (postorder tree).
Proof.
  intros X tree. induction tree.
  - reflexivity.
  - simpl. rewrite app_length. rewrite app_length. rewrite app_length. simpl. rewrite IHtree1.
 rewrite IHtree2.  rewrite <- plus_n_Sm. rewrite <- plus_n_O. rewrite plus_n_Sm. reflexivity.
Qed.

(*Question 6i*)
Fixpoint count_nodes {X: Type} (btr : @b_tree X) : nat :=
  match btr with
  |emp_tree => 0
  |node x y z => S( count_nodes y) + (count_nodes z)
end.

Theorem question_6i: forall (X:Type) (tr : @b_tree X),
count_nodes tr = length(preorder tr).
Proof.
  intros. induction tr.
  - reflexivity.
  - simpl. rewrite app_length. rewrite IHtr2. rewrite IHtr1. reflexivity.
Qed.

(*Question 6j*)
Fixpoint height_btr {X: Type} (btr : @b_tree X) : nat :=
  match btr with
  | emp_tree => 0
  | node _ t1 t2 => 1 + max (height_btr t1) (height_btr t2)
  end.

Lemma max_comm :
  forall n m : nat, max n m = max m n.
Proof.
intro n; induction n as [| n' IHn'];
  intro m; destruct m as [| m'];
    simpl; try (rewrite IHn'); trivial.
Qed.

Lemma plus_par : forall n m, n + m = (n + m).
Proof.
  intros n m. reflexivity.
Qed.

Lemma leb_refl : forall n:nat,
  leb n n = true.
Proof.
  intros n. induction n as [|n'].
  - reflexivity.
  - simpl. rewrite IHn'. reflexivity.
Qed.

Lemma leb_max : forall n m,
  leb n (max n m) = true.
Proof.
  intros.
  generalize dependent m.
  induction n.
  -simpl. reflexivity.
  - destruct m.
    + simpl. apply leb_refl.
    + simpl. destruct n.
      * simpl. reflexivity.
      * rewrite IHn. reflexivity.
Qed.

Lemma leb_plus_max : forall n m,
  leb (max n m) (n + m) = true.
Proof.
  intros.
  generalize dependent m.
  intros. induction n.
  - simpl. rewrite leb_refl. reflexivity.
Admitted.

Theorem question_6j : forall {X: Type}(t : @b_tree X),
      leb (height_btr t) (count_nodes t)=true.
Proof.
  intros.
  simpl.
  - induction t.
    apply leb_refl.
  simpl. destruct t1. simpl.
  + rewrite IHt2. reflexivity.
  Admitted.

Theorem question_6j_other: forall (X:Type) (tr : @b_tree X),
  leb (height_btr tr) (count_nodes tr) = true.
Proof.
  intros. induction tr.
  - reflexivity.
  - simpl.
Admitted.


(** A library of relation operators defining sequences of transitions
  and useful properties about them. *)

Set Implicit Arguments.

Section SEQUENCES.

Variable A: Type.                 (**r the type of states *)
Variable R: A -> A -> Prop.       (**r the transition relation, from one state to the next *)

(** ** Finite sequences of transitions *)

(** Zero, one or several transitions: reflexive, transitive closure of [R]. *)

Inductive star: A -> A -> Prop :=
  | star_refl: forall a,
      star a a
  | star_step: forall a b c,
      R a b -> star b c -> star a c.

Lemma star_one:
  forall (a b: A), R a b -> star a b.
Proof.
  eauto using star.
Qed.

Lemma star_trans:
  forall (a b: A), star a b -> forall c, star b c -> star a c.
Proof.
  induction 1; eauto using star.
Qed.

(** One or several transitions: transitive closure of [R]. *)

Inductive plus: A -> A -> Prop :=
  | plus_left: forall a b c,
      R a b -> star b c -> plus a c.

Lemma plus_one:
  forall a b, R a b -> plus a b.
Proof.
  eauto using star, plus.
Qed.

Lemma plus_star:
  forall a b,
  plus a b -> star a b.
Proof.
  intros. inversion H. eauto using star.
Qed.

Lemma plus_star_trans:
  forall a b c, plus a b -> star b c -> plus a c.
Proof.
  intros. inversion H. eauto using plus, star_trans.
Qed.

Lemma star_plus_trans:
  forall a b c, star a b -> plus b c -> plus a c.
Proof.
  intros. inversion H0. inversion H; eauto using plus, star, star_trans.
Qed.

Lemma plus_right:
  forall a b c, star a b -> R b c -> plus a c.
Proof.
  eauto using star_plus_trans, plus_one.
Qed.

(** ** Infinite sequences of transitions *)

(** It is easy to characterize the fact that all transition sequences starting
  from a state [a] are infinite: it suffices to say that any finite sequence
  starting from [a] can always be extended by one more transition. *)

Definition all_seq_inf (a: A) : Prop :=
  forall b, star a b -> exists c, R b c.

(** However, this is not the notion we are trying to characterize: that, starting
  from [a], there exists one infinite sequence of transitions
  [a --> a1 --> a2 --> ... -> aN -> ...].

  Indeed, consider [A = nat] and [R] such that [R 0 0] and [R 0 1].
  [all_seq_inf 0] does not hold, because a sequence [0 -->* 1] cannot be extended.
  Yet, [R] admits an infinite sequence, namely [0 --> 0 --> ...].

  Another attempt would be to represent the sequence of states
  [a0 --> a1 --> a2 --> ... -> aN -> ...] explicitly, as a function
  [f: nat -> A] such that [f i] is the [i]-th state [ai] of the sequence. *)

Definition infseq_with_function (a: A) : Prop :=
  exists f: nat -> A, f 0 = a /\ forall i, R (f i) (f (1 + i)).

(** This is a correct characterization of the existence of an infinite sequence
  of reductions.  However, it is very inconvenient to work with this definition
  in Coq's constructive logic: in most use cases, the function [f] is not
  computable and therefore cannot be defined in Coq.  *)

(** To obtain a practical definition of infinite sequences, we use the following
  coinductive definition of the predicate [infseq a]. *)

CoInductive infseq: A -> Prop :=
  | infseq_step: forall a b,
      R a b -> infseq b -> infseq a.

(** An inductive predicate such as [star a b] holds iff there exists a finite
  derivation of the conclusion [star a b] that uses the constructors
  [star_refl] and [star_step] a finite number of times.

  A coinductive predicate is similar, but holds iff there exists a finite
  OR INFINITE derivation of the conclusion that uses the constructors
  of the predicate a finite OR INFINITE number of times.

  In other words, an inductive predicate is a smallest fixpoint: the smallest predicate
  that satisfies its constructors; a coinductive predicate is a greatest fixpoint:
  the largest predicate that satisfies its constructors.

  The [infseq] predicate above must be defined coinductively.  Indeed, if
  we define it inductively, the predicate would be empty (always false),
  since there are no base cases!

  Coq provides some primitive support for constructing infinite derivations
  of facts such as [infseq a].  Such constructions are proofs by coinduction.
  For example, we can prove the following: *)

Remark cycle_infseq:
  forall a, R a a -> infseq a.
Proof.
  intros. cofix COINDHYP. apply infseq_step with a. auto. apply COINDHYP.
Qed.

(** This style of proof by coinduction, using the [cofix] tactic, is effective
  but can run into limitations of Coq's proof engine (the so-called
  "guard condition").  However, we can derive more conventional
  coinduction principles that are often easier to use. *)

(** Consider a set [X] of states [A], that is, a predicate [X: A -> Prop].
  Assume that for every [a] in [X], we can make one [R] transition to a [b]
  that is still in [X].  Then, starting from [a] in [X], we can transition
  to some [a1] in [X], then to some [a2] still in [X], then... It is clear
  that we are just building an infinite sequence of transitions starting from
  [a]. Therefore [infseq a] should hold.  Let's prove this! *)

Lemma infseq_coinduction_principle:
  forall (X: A -> Prop),
  (forall a, X a -> exists b, R a b /\ X b) ->
  forall a, X a -> infseq a.
Proof.
  intros X P. cofix COINDHYP; intros.
  destruct (P a H) as [b [U V]]. apply infseq_step with b; auto.
Qed.

(** An even more useful variant of this coinduction principle considers a
  set [X] where for every [a] in [X], we can make one *or several* transitions
  to reach a [b] in [X].  *)

Lemma infseq_coinduction_principle_2:
  forall (X: A -> Prop),
  (forall a, X a -> exists b, plus a b /\ X b) ->
  forall a, X a -> infseq a.
Proof.
  intros.
  apply infseq_coinduction_principle with
    (X := fun a => exists b, star a b /\ X b).
- intros.
  destruct H1 as [b [STAR Xb]]. inversion STAR; subst.
+ destruct (H b Xb) as [c [PLUS Xc]]. inversion PLUS; subst.
  exists b0; split. auto. exists c; auto.
+ exists b0; split. auto. exists b; auto.
- exists a; split. apply star_refl. auto.
Qed.

(** Here is an example of use of [infseq_coinduction_principle]:
  if all finite transition sequences starting at [a] can be extended,
  [infseq a] holds. *)

Lemma infseq_if_all_seq_inf:
  forall a, all_seq_inf a -> infseq a.
Proof.
  apply infseq_coinduction_principle.
  intros. destruct (H a) as [b Rb]. constructor.
  exists b; split; auto.
  unfold all_seq_inf; intros. apply H. apply star_step with b; auto.
Qed.

(** Likewise, the function-based characterization [infseq_with_function]
  implies [infseq]. *)

Lemma infseq_from_function:
  forall a, infseq_with_function a -> infseq a.
Proof.
  apply infseq_coinduction_principle.
  intros. destruct H as [f [P Q]].
  exists (f 1); split.
  subst a. apply Q.
  exists (fun n => f (1 + n)); split. auto. intros. apply Q.
Qed.

(** Consider the transition sequences starting at state [a].
  They can be infinite, or they can be finite: after a number of transitions,
  we reach a state from with no transition is possible.  It is intuitively
  obvious that at least one of the two cases must hold.

  It is however impossible to prove this fact in Coq's constructive logic.
  Indeed, a constructive proof would be isomorphic (by the Curry-Howard isomorphism)
  to a terminating function that solves Turing's halting problem!

  To prove this fact, we must enrich Coq with axioms from classical logic,
  namely the axiom of excluded middle: for all propositions [P],
  either [P] or [~P] hold.  The Coq standard library provides such axioms
  in the module named [Classical], which we now import. *)

Require Import Classical.

Definition irred (a: A) : Prop := forall b, ~(R a b).

Lemma infseq_or_finseq:
  forall a, infseq a \/ exists b, star a b /\ irred b.
Proof.
  intros.
  destruct (classic (forall b, star a b -> exists c, R b c)).
- left. apply infseq_if_all_seq_inf; auto.
- right.
  apply not_all_ex_not in H. destruct H as [b P].
  apply imply_to_and in P. destruct P as [U V].
  exists b; split. auto.
  red; intros; red; intros. elim V. exists b0; auto.
Qed.

(** ** Determinism properties for functional transition relations. *)

(** A transition relation is functional if every state can transition to at most
  one other state. *)

Hypothesis R_functional:
  forall a b c, R a b -> R a c -> b = c.

(** Uniqueness of finite transition sequences. *)

Lemma star_star_inv:
  forall a b, star a b -> forall c, star a c -> star b c \/ star c b.
Proof.
  induction 1; intros.
- auto.
- inversion H1; subst.
+ right. eauto using star.
+ assert (b = b0) by (eapply R_functional; eauto). subst b0.
  apply IHstar; auto.
Qed.

Lemma finseq_unique:
  forall a b b',
  star a b -> irred b ->
  star a b' -> irred b' ->
  b = b'.
Proof.
  intros. destruct (star_star_inv H H1).
- inversion H3; subst. auto. elim (H0 _ H4).
- inversion H3; subst. auto. elim (H2 _ H4).
Qed.

(** A state cannot both diverge and terminate on an irreducible state. *)

Lemma infseq_star_inv:
  forall a b, star a b -> infseq a -> infseq b.
Proof.
  induction 1; intros.
- auto.
- inversion H1; subst.
  assert (b = b0) by (eapply R_functional; eauto). subst b0.
  apply IHstar; auto.
Qed.

Lemma infseq_finseq_excl:
  forall a b,
  star a b -> irred b -> infseq a -> False.
Proof.
  intros.
  assert (infseq b) by (eapply infseq_star_inv; eauto).
  inversion H2. elim (H0 b0); auto.
Qed.

(** If there exists an infinite sequence of transitions from [a],
  all sequences of transitions arising from [a] are infinite. *)

Lemma infseq_all_seq_inf:
  forall a, infseq a -> all_seq_inf a.
Proof.
  intros. unfold all_seq_inf. intros.
  assert (infseq b) by (eapply infseq_star_inv; eauto).
  inversion H1. subst. exists b0; auto.
Qed.

End SEQUENCES.


Require Import mathcomp.ssreflect.ssreflect.
Require Import mathcomp.ssreflect.ssrbool.
Require Import mathcomp.ssreflect.eqtype.
Require Import mathcomp.ssreflect.ssrnat.

Section Smullyan_drinker.
  Variables (D : Type)(P : D -> Prop).
  Hypothesis (d : D) (EM : forall A, A \/ ~A).

  Lemma drinker : exists x, P x -> forall y, P y.
  Proof.
    (* case: (EM (exists y, ~P y)) is equivalent to move: (EM (exists y, ~P y)); case. *)
    case: (EM (exists y, ~P y)) => [[y notPy]| nonotPy]; first by exists y.
    (*
      exists d => _ y.
      case : (EM (P y)).
        done.
        move => notPy.
    *)
    exists d => _ y; case: (EM (P y)) => // notPy.
    by case: nonotPy; exists y.
  Qed.
End Smullyan_drinker.


Require Import Coq.Lists.List.
Require Import Coq.Sorting.Permutation.
Require Import TLC.LibTactics.
Require Import LibNatExtra.
Require Import LibRewrite.
Require Import ZArith.

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

(* Type classes for two central properties of a binary operation: associativity,
   and the existence of a unit. *)

Class Unit {A : Type} (op : A -> A -> A) := {
  unit:
    A;
  left_unit:
    forall a,
    op unit a = a;
  right_unit:
    forall a,
    op a unit = a
}.

Class Commutative {A : Type} (op : A -> A -> A) := {
  commutativity:
    forall a1 a2,
    op a1 a2 = op a2 a1
}.

Class Associative {A : Type} (op : A -> A -> A) := {
  associativity:
    forall a1 a2 a3,
    op (op a1 a2) a3 = op a1 (op a2 a3)
}.

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

(* Instances for addition, multiplication, maximum. *)

Obligation Tactic := try solve [ intros; ring_simplify; omega ].
Program Instance unit_plus : Unit plus := { unit := 0 }.
Program Instance commutative_plus : Commutative plus.
Program Instance associative_plus : Associative plus.
Program Instance unit_mult : Unit mult := { unit := 1 }.
Program Instance commutative_mult : Commutative mult.
Program Instance associative_mult : Associative mult.
Program Instance unit_Zplus : Unit Z.add := { unit := 0%Z }.
Program Instance commutative_Zplus : Commutative Z.add.
Program Instance associative_Zplus : Associative Z.add.
Program Instance unit_Zmult : Unit Z.mul := { unit := 1%Z }.
Program Instance commutative_Zmult : Commutative Z.mul.
Program Instance associative_Zmult : Associative Z.mul.
Obligation Tactic := try solve [ intros; repeat max_case; omega ].
Program Instance unit_max  : Unit max  := { unit := 0 }.
Program Instance commutative_max  : Commutative max.
Program Instance associative_max  : Associative max.

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

(* [big op xs] is the iterated application of [op] to the elements of
   the list [xs]. *)

Definition big {A : Type} (op : A -> A -> A) `{Unit A op} xs :=
  fold_right op unit xs.

(* This notation is inspired by Bertot et al.'s paper. *)

Notation "\big [ op ]_ ( r <- range ) f" :=
  (big op (map (fun r => f) range)) (at level 36).

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

(* [big] is covariant. *)

(* TEMPORARY (unused)

Obligation Tactic := unfold Proper, respectful.

Program Instance proper_big A op `{Unit A op} (R : relation A) `{Reflexive A R} :
  Proper (R ++> R ++> R) op -> Proper (Forall2 R ++> R) (big op).
Next Obligation.
  induction 3; simpl; eauto.
Qed.

(* [map] is covariant. *)

Program Instance proper_map A B (R : relation A) (S : relation B) :
  Proper ((R ++> S) ++> Forall2 R ++> Forall2 S) (@map A B).
Next Obligation.
  induction 2; simpl; eauto.
Qed.

*)

Lemma big_covariant:
  forall B op `{Unit B op} (R : relation B) `{Reflexive B R},
  Proper (R ++> R ++> R) op ->
  forall A (f g : A -> B) (xs : list A),
  (forall x, In x xs -> R (f x) (g x)) ->
  R (big op (map f xs)) (big op (map g xs)).
Proof using.
  introv ? hop. induction xs; simpl; intros.
  eauto.
  eapply hop. eauto. eauto.
Qed.

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

(* [big op] plays well with lists. *)

Lemma big_nil:
  forall A op `{Unit A op},
  big op nil = unit.
Proof using.
  reflexivity.
Qed.

Lemma big_app:
  forall A op `{Unit A op} `{Associative A op} xs ys,
  big op (xs ++ ys) = op (big op xs) (big op ys).
Proof using.
  induction xs; simpl; intros.
  rewrite left_unit. reflexivity.
  rewrite IHxs. rewrite associativity. reflexivity.
Qed.

Lemma big_permutation:
  forall A op `{Unit A op, Commutative A op, Associative A op} xs ys,
  Permutation xs ys ->
  big op xs = big op ys.
Proof using.
  induction 3; simpl; try congruence.
  rewrite <- associativity. rewrite (@commutativity _ _ _ y x). rewrite associativity. congruence.
Qed.

Obligation Tactic := try (repeat intro; eauto using big_permutation).
Program Instance big_permutation_ A op `{Unit A op, Commutative A op, Associative A op} :
  Proper (@Permutation A ++> @eq A) (big op).

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

(* Distributivity of a product onto a big sum. *)

Class Distributive {A : Type} (mult plus : A -> A -> A) `{Unit A plus} := {
  distributivity:
    forall a b c,
    mult c (plus a b) = plus (mult c a) (mult c b);
  absorption:
    (* The unit of addition must be absorbant for multiplication. *)
    forall c, mult c unit = unit
}.

Obligation Tactic := try (intros; simpl; ring_simplify; omega).
Program Instance distributive_mult_plus : Distributive mult plus.
(* Program Instance distributive_plus_max  : Distributive plus max. (* fails, due to absorption *) *)
Program Instance distributive_Zmult_Zplus : Distributive Z.mul Z.add.

Lemma big_distributive:
  forall A mult plus `{Unit A plus, Associative A plus, Distributive A mult plus},
  forall c xs,
  mult c (big plus xs) = big plus (map (mult c) xs).
Proof using.
  induction xs; simpl; intros.
  (* Nil. *)
  rewrite absorption. reflexivity.
  (* Cons. *)
  rewrite distributivity. rewrite IHxs. reflexivity.
Qed.

Lemma big_map_distributive:
  forall A mult plus `{Unit A plus, Associative A plus, Distributive A mult plus},
  forall c B (f : B -> A) xs,
  mult c (big plus (map f xs)) = big plus (map (fun x => mult c (f x)) xs).
Proof using.
  intros. rewrite big_distributive by eauto with typeclass_instances.
  rewrite map_map. reflexivity.
Qed.

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

(* Intervals. *)

(* [interval_ i len] is the semi-open interval [i, i + len). *)

Fixpoint interval_ i len :=
  match len with
  | 0 =>
      nil
  | S len =>
      i :: interval_ (i + 1) len
  end.

(* [interval i j] is the semi-open interval [i, j). *)

Definition interval i j :=
  interval_ i (j - i).

(* The length of [interval i j] is [j - i]. *)

Lemma length_interval_:
  forall len i,
  length (interval_ i len) = len.
Proof using.
  induction len; simpl; congruence.
Qed.

Lemma length_interval:
  forall i j,
  length (interval i j) = j - i.
Proof using.
  unfold interval. eauto using length_interval_.
Qed.

(* Basic properties. *)

Lemma interval_is_empty:
  forall i j,
  j <= i ->
  interval i j = nil.
Proof using.
  unfold interval. intros.
  replace (j - i) with 0 by omega.
  reflexivity.
Qed.

Lemma interval_is_nonempty:
  forall i j,
  i < j ->
  interval i j = i :: interval (i + 1) j.
Proof using.
  unfold interval. intros.
  replace (j - i) with (S (j - (i + 1))) by omega.
  reflexivity.
Qed.

Lemma in_interval_lo:
  forall x lo hi,
  In x (interval lo hi) ->
  lo <= x.
Proof using.
  assert (forall x len lo, In x (interval_ lo len) -> lo <= x).
    induction len; simpl; intros.
    false.
    match goal with h: _ \/ _ |- _ => destruct h end.
      omega.
      forwards: IHlen. eauto. omega.
  eauto.
Qed.

Lemma in_interval_hi:
  forall x lo hi,
  In x (interval lo hi) ->
  x < hi.
Proof using.
  assert (aux: forall x len lo, In x (interval_ lo len) -> x < lo + len /\ len > 0).
    induction len; simpl; intros.
    false.
    match goal with h: _ \/ _ |- _ => destruct h end.
      omega.
      forwards: IHlen. eauto. omega.
  intros. forwards: aux. eauto. omega.
Qed.

Lemma interval_app:
  forall i j k,
  i <= j ->
  j <= k ->
  interval i j ++ interval j k = interval i k.
Proof using.
  assert (reformulation:
    forall len1 i len2,
    interval_ i len1 ++ interval_ (i + len1) len2 = interval_ i (len1 + len2)
  ).
  induction len1; simpl; intros.
  (* Nil. *)
  f_equal. omega.
  (* Cons. *)
  rewrite <- IHlen1. do 3 f_equal. omega.
  (* Back to the original goal. *)
  unfold interval. intros. replace (k - i) with ((j - i) + (k - j)) by omega.
  rewrite <- reformulation. do 2 f_equal. omega.
Qed.

(* Test. *)

Goal \big[plus]_(i <- interval 0 10) i = 45.
Proof using.
  reflexivity.
Qed.

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

(* The Cartesian product of two lists. *)

Fixpoint cartesian {A B : Type} (xs : list A) (ys : list B) : list (A * B) :=
  match xs with
  | nil =>
      nil
  | x :: xs =>
      map (fun y => (x, y)) ys ++ cartesian xs ys
  end.

(* Looking at [cartesian] from the other side. *)

Lemma cartesian_nil:
  forall {A B : Type} (xs : list A),
  cartesian xs (nil : list B) = nil.
Proof using.
  induction xs; simpl; eauto.
Qed.

Lemma cartesian_cons:
  forall {A B : Type} (xs : list A) y (ys : list B),
  Permutation
    (cartesian xs (y :: ys))
    (map (fun x => (x, y)) xs ++ cartesian xs ys).
Proof using.
  induction xs; simpl; intros.
  (* Nil. *)
  econstructor.
  (* Cons. *)
  econstructor.
  rewrite IHxs.
  do 2 rewrite app_assoc.
  eauto using Permutation_app, Permutation_app_comm.
Qed.

(* Up to a permutation of the list and up to swapping the pair components,
   [cartesian] is commutative. *)

Lemma cartesian_commutative:
  forall {A B C : Type} (f : A * B -> C) (g : B * A -> C),
  (forall x y, f (x, y) = g (y, x)) ->
  forall (xs : list A) (ys : list B),
  Permutation
    (map f (cartesian xs ys))
    (map g (cartesian ys xs)).
Proof using.
  introv h. induction xs as [| x xs ]; simpl; intros.
  (* Nil. *)
  rewrite cartesian_nil. econstructor.
  (* Cons. *)
  rewrite map_app.
  rewrite IHxs.
  rewrite map_map.
  erewrite map_ext by eapply h.
  rewrite <- map_map.
  rewrite <- map_app.
  rewrite <- cartesian_cons.
  eapply Permutation_refl.
Qed.

(* A sum of sums is equal to a single sum over the Cartesian product. *)

Lemma bigop_cartesian:
  forall A B C : Type,
  forall op `{Unit C op, Commutative C op, Associative C op},
  forall f : A * B -> C,
  forall xs ys,
  big op (map f (cartesian xs ys)) =
  big op (map (fun x => big op (map (fun y => f (x, y)) ys)) xs).
Proof using.
  induction xs; simpl; intros.
  (* Nil. *)
  reflexivity.
  (* Cons. *)
  rewrite map_app.
  rewrite map_map.
  rewrite big_app by assumption.
  rewrite IHxs.
  reflexivity.
Qed.

Goal
  forall A B C : Type,
  forall op `{Unit C op, Commutative C op, Associative C op},
  forall f : A * B -> C,
  forall xs ys,
  \big[op]_(xy <- cartesian xs ys) (f xy) =
  \big[op]_(x <- xs) \big[op]_(y <- ys) (f (x, y)).
Proof using.
  intros. eapply bigop_cartesian; eauto with typeclass_instances.
Qed.


Require Import ZArith.
Require Import Psatz.
Open Scope Z_scope.

Lemma two_x_eq_1 : forall x, 2 * x = 1 -> False.
Proof.
  intros.
  lia.
Qed.

Lemma two_x_y_eq_1 : forall x y, 2 * x + 2 * y = 1 -> False.
Proof.
  intros.
  lia.
Qed.

Lemma two_x_y_z_eq_1 : forall x y z, 2 * x + 2 * y + 2 * z= 1 -> False.
Proof.
  intros.
  lia.
Qed.

Lemma omega_nightmare : forall x y, 27 <= 11 * x + 13 * y <= 45 ->  -10 <= 7 * x - 9 * y <= 4 -> False.
Proof.
  intros ; intuition auto.
  lia.
Qed.

Lemma compact_proof : forall z,
 (z < 0) ->
 (z >= 0) ->
  (0 >= z \/ 0 < z) -> False.
Proof.
 intros.
 lia.
Qed.


Lemma and_comm: forall P Q, P/\Q -> Q /\ P.
Proof.
intros.
destruct H.
split.
 * assumption.
 * assumption.
Qed.

Print and_comm.

Lemma or_comm: forall P Q, P \/ Q -> Q \/ P.
Proof.
intros.
destruct H.
 * right.
   assumption.
 * left;assumption.
Qed.

Print or_comm.

Print iff.

Lemma Iff_or_comm: forall P Q, P \/ Q <-> Q \/ P.
Proof.
intros.
split; apply or_comm.
Qed.

Print False.

Lemma FalseImpliesAny: False -> 2+2=5.
Proof.
intro.
destruct H.
Qed.

Lemma negations: forall P Q :Prop, ~P -> ~ ~ P -> Q.
Proof.
intros.
(*contradiction.*)
destruct H0.
assumption.
Qed.

Print ex.

(*Lemma is: @ex nat (fun x:nat => x+1 = 2).*)

Lemma istnieje1: exists x, x+1=2.
Proof.
exists 1.
simpl.
trivial.
Qed.

Lemma istnieje2: forall m n, (exists x, x+n = m) -> (n=m) \/ (exists k, m = S k).
Proof.
intros.
destruct H.
destruct x.
(*destruct x eqn:?.*)
* left.
  simpl in H.
  assumption.
* right.
  simpl in H.
  exists (x+n).
  symmetry.
  assumption.
Qed.

Definition Double_neg : Prop := forall P:Prop, ~~P -> P.

Definition Exm : Prop := forall P : Prop, P \/ ~P.

Definition Classical_impl : Prop := forall P Q:Prop, (P -> Q) -> ~P \/ Q.

Definition Peirce : Prop := forall P Q : Prop, ((P -> Q) -> P) -> P.

Definition Not_forall_not_exists : Prop :=
           forall (A:Type)(P:A->Prop), ~(forall x:A, ~P x) -> ex P.

Lemma  Exm_Double_neg : Exm -> Double_neg.
Proof.
 unfold Double_neg.
 intros H P.
 destruct (H P) as [p | p'].
 - intro;assumption.
 - (* generalize p'. *)
 apply negations.
 assumption.
(* intro H1.
 apply (negations P); assumption.*)
Qed.


Require Import Bool.
Require Import Arith.

Inductive lst : Type :=
| Cons : nat -> lst -> lst
| Nil : lst.

Inductive heap : Type :=
| Hleaf : heap
| Heap : nat -> nat -> heap -> heap -> heap.

Fixpoint right_height (h : heap) : nat :=
  match h with
  | Hleaf => 0
  | Heap k v l r => right_height r + 1
  end.

Definition rank (h : heap) : nat :=
  match h with
  | Hleaf => 0
  | Heap k v l r => k
  end.

Fixpoint has_leftist_property (h : heap) : bool :=
  match h with
  | Hleaf => true
  | Heap k v l r =>
    has_leftist_property l
    && has_leftist_property r
    && (right_height r <=? right_height l)
    && (k =? right_height r + 1)
  end.

Fixpoint hsize (h : heap) : nat :=
  match h with
  | Hleaf => 0
  | Heap k v l r => hsize l + hsize r + 1
  end.

Definition mergea (v : nat) (l r : heap) : heap :=
  if rank r <=? rank l
    then Heap (rank r + 1) v l r
    else Heap (rank l + 1) v r l.

Fixpoint merge (h1 : heap) : heap -> heap :=
  fix merge_aux (h2 : heap) : heap :=
  match h1, h2 with
  | h, Hleaf => h
  | Hleaf, h => h
  | Heap k1 v1 l1 r1, Heap k2 v2 l2 r2 =>
    if v2 <? v1
      then mergea v1 l1 (merge r1 (Heap k2 v2 l2 r2))
      else mergea v2 l2 (merge_aux r2)
  end.

Definition hinsert (h : heap) (n : nat) : heap :=
  merge (Heap 1 n Hleaf Hleaf) h.

(* Require Coq.extraction.Extraction.

Recursive Extraction hinsert. *)

Lemma hsize_nonneg : forall h : heap, hsize h >= 0.
Proof.
  (* This lemma is trivial since we use nat instead of Int. *)
  intros.
  induction (hsize h).
  - auto.
  - auto.
Qed.

Lemma rank_right_height : forall h : heap,
  has_leftist_property h = true -> rank h = right_height h.
Proof.
  intros.
  induction h.
  - auto.
  - simpl. simpl in H. apply andb_true_iff in H. destruct H. apply Nat.eqb_eq in H0. assumption.
Qed.

Lemma leftist_mergea : forall (v : nat) (l r : heap),
  has_leftist_property l && has_leftist_property r = true
    -> has_leftist_property (mergea v l r) = true.
Proof.
  intros.
  unfold mergea.
  apply andb_true_iff in H. destruct H.
  destruct (Nat.leb_spec (rank r) (rank l)).
  - rewrite (rank_right_height r H0) in H1.
    rewrite (rank_right_height l H) in H1.
    simpl. rewrite (rank_right_height r H0).
    apply andb_true_iff. split.
    + apply andb_true_iff. split.
      * rewrite H. rewrite H0. reflexivity.
      * apply Nat.leb_le. assumption.
    + apply Nat.eqb_eq. reflexivity.
  - rewrite (rank_right_height r H0) in H1.
    rewrite (rank_right_height l H) in H1.
    simpl. rewrite (rank_right_height l H).
    apply le_Sn_le in H1.
    apply andb_true_iff. split.
    + apply andb_true_iff. split.
      * rewrite H. rewrite H0. reflexivity.
      * apply Nat.leb_le. assumption.
    + apply Nat.eqb_eq. reflexivity.
Qed.

Lemma leftist_merge : forall h1 h2 : heap,
  has_leftist_property h1 && has_leftist_property h2 = true
    -> has_leftist_property (merge h1 h2) = true.
Proof.
  intro h1.
  induction h1.
  - intros. destruct h2.
    + reflexivity.
    + simpl. simpl in H. assumption.
  - intros. induction h2.
    + simpl. apply andb_true_iff in H. destruct H. simpl in H. assumption.
    + apply andb_true_iff in H. destruct H. simpl in H. apply andb_true_iff in H. destruct H. apply andb_true_iff in H. destruct H. apply andb_true_iff in H. destruct H. simpl. destruct (n2 <? n0).
      * apply leftist_mergea. apply andb_true_iff. split.
        -- assumption.
        -- apply IHh1_2. rewrite H3. rewrite H0. reflexivity.
      * simpl in H0. apply andb_true_iff in H0. destruct H0. apply andb_true_iff in H0. destruct H0. apply andb_true_iff in H0. destruct H0. simpl in IHh2_2. apply leftist_mergea. apply andb_true_iff. split.
        -- assumption.
        -- apply IHh2_2. rewrite H. rewrite H3. rewrite H2. rewrite H1. rewrite H6. reflexivity.
Qed.

Theorem leftist_hinsert : forall (x : heap) (n : nat),
  has_leftist_property x = true -> has_leftist_property (hinsert x n) = true.
Proof.
  intros. unfold hinsert. apply leftist_merge. apply andb_true_iff. split.
  - unfold has_leftist_property. reflexivity.
  - assumption.
Qed.


(**Modal definitions based on Benzmuller and Paleo 2015**)
Parameter W: Type. (* Type for worlds *)
Parameter e: Type. (* Typefor individuals *)
Definition MProp := W  -> Prop. (* Type of modal propositions *)
Parameter R: W -> W -> Prop. (* Accessibility relation for worlds *)

(**Defining the modal connectives**)
Definition mnot (p: MProp)(w: W) := ~ (p w).
Notation "m~ p" := (mnot p) (at level 74, right associativity).

Definition mand (p q:MProp)(w: W) := (p w) /\ (q w).
Notation "p m/\ q" := (mand p q) (at level 79, right associativity).
Definition mor (p q:MProp)(w: W) := (p w) \/ (q w).
Notation "p m\/ q" := (mor p q) (at level 79, right associativity).
Definition mimplies (p q:MProp)(w:W) := (p w) -> (q w).
Notation "p m-> q" := (mimplies p q) (at level 99, right associativity).
Definition mequiv (p q:MProp)(w:W) := (p w) <-> (q w).
Notation "p m<-> q" := (mequiv p q) (at level 99, right associativity).
Definition mequal (x y: MProp)(w: W) := x = y.
Notation "x m= y" := (mequal x y) (at level 99, right associativity).

Definition A {t: Type}(p: t -> MProp)(w: W) := forall x, p x w.
Notation "’mforall’ x , p" := (A (fun x => p))
(at level 200, x ident, right associativity) : type_scope.

Definition E {t: Type}(p: t -> MProp)(w: W) := exists x, p x w.
Notation "’mexists’ x , p" := (E (fun x => p))(at level 200, x ident, right associativity) : type_scope.

Definition box (p: MProp) := fun w:W => forall w1, (R w w1) -> (p w1).
Definition dia (p: MProp) := fun w:W => exists w1, (R w w1) /\ (p w1).

Definition V (p: MProp) := forall w, p w.

Notation "[ p ]" := (V p).

(** A bit of Montague**)
Parameter Man Human Walk : (e->MProp).

Definition man:=  fun x:e=> Man  x.
Definition human:= fun x:e=> Human  x.
Definition walk:= fun x:e=> Walk  x.

Parameter w_c:W.
Check E.
Definition a:= fun CN: (e->MProp)=>  fun VP:(e->MProp)=> fun w:W=> exists x,
                                                                           (VP x w).
Check a.
Check a.
Check (a man)  walk.
Check box.
Definition neccessarily:= fun P:MProp=>   box (P).
Definition possibly:= fun P:MProp=>  dia(P).
Theorem NEC: neccessarily ((a man) walk) w_c-> exists w: W, R w_c w->  ((a man) walk w).
  cbv. intros. exists w_c. intro. elim H with w_c. intros. exists x. apply H1. assumption. Qed.

Theorem NEC2: neccessarily ((a man) walk) w_c-> forall w: W, R w_c w->  ((a man) walk w). cbv. intros.  apply H. assumption. Qed.

Section POSS.
  Variable refl: forall w: W,  R w w.
  Variable trans: forall w w1 w2, R w w1 /\ R w1 w2 -> R w w2.
  Variable x:e.
  (**Axiom M, needs refl**)
Theorem NECW:  neccessarily ((a man) walk) w_c->   ((a man) walk) w_c. cbv.
                                                                       firstorder.            Qed.
(**Axiom D, needs refl**)
Theorem NECPOSS:  neccessarily ((a man) walk) w_c->  possibly  ((a man) walk) w_c. cbv. firstorder. Qed.

(**dia dia -> dia,  needs transitivity**)
Theorem POSSPOSS:  possibly (possibly ((a man) walk)) w_c->  possibly  ((a man) walk) w_c. cbv. firstorder. Qed.

(**Other theorems can be proven depending on the properties defined on the accessibility relation**)
End POSS.


(*Require Import stdpp.base stdpp.numbers.
*)
Require Import QArith.
Record V2 (a : Type) := {
                         x2 : a;
                         y2 : a
                       }.

Arguments x2 {a}.
Arguments y2 {a}.

Record M2 := {
              c1 : V2 Q;
              c2 : V2 Q
              }.

Open Scope Q_scope.
Definition vadd v w : V2 Q := {| x2 := v.(x2) + w.(x2) ; y2 := v.(y2) + w.(y2)  |}.

Definition smul s v : V2 Q := {| x2 := s * v.(x2) ; y2 := s * v.(y2)   |}.

Definition dot v w : Q := v.(x2) * w.(x2) + v.(y2) * w.(y2).

Definition mapply m v := vadd (smul v.(x2) m.(c1)) (smul v.(y2) m.(c2)).

Require Import Ring.
Require Import Psatz.
Require Import Lqa.

Goal forall x y , x + y == x + y. intros. lra. Qed.

Definition VEq v w := v.(x2) == w.(x2)  /\ v.(y2) == w.(y2).
Notation "x == y" := (VEq x y).
Notation " x + y " := (vadd x  y).
Notation " s * y " := (smul s y).

Definition vzero := {| x2 := 0 ; y2 := 0 |}.

Definition xhat := {| x2 := 1 ; y2 := 0 |}.

Definition yhat := {| x2 := 0 ; y2 := 1 |}.
Check vzero.
Check vzero == vzero.
Theorem vadd_comm : forall v w, v + w == w + v. Proof. intros. split; simpl; lra. Qed.

(* This is a setoid equality. :/   Does lra not work on Qc? *)

Theorem linop : forall v w m, mapply m (vadd v w) == (vadd (mapply m v)  (mapply m w)).
  intros. unfold mapply. unfold vadd. simpl. split; simpl; lra. Qed.

Theorem linop2 : forall s v m, mapply m (smul s v) == smul s (mapply m v).
  intros. unfold mapply. unfold smul. simpl. split; simpl; lra. Qed.

Definition mcompose m n :=  {|
                            c1 := mapply m n.(c1);
                            c2 := mapply m n.(c2)

                            |}.

Notation " m @@ n " := (mcompose m n) (at level 50) .
Notation " m @ v " := (mapply m v) (at level 50) .

Theorem matrixgood : forall m n v, mapply m (mapply n v) == mapply ( mcompose m n ) v.
   intros. unfold mapply. unfold mcompose. simpl. split; simpl; lra. Qed.

Definition madd m n := {|
                        c1 := vadd m.(c1) n.(c1);
                        c2 := vadd m.(c2) n.(c2)
                      |}.

Notation "<< a b >>" := {| x2 := a ; y2 := b |}.
Notation "<< a b , c d >>" := {| c1 := {| x2 := a ; y2 := c|} ; c2 := {| x2 := b ; y2 := d |} |}.

Check << 1 0 >> .

(*

https://www.labri.fr/perso/casteran/CoqArt/TypeClassesTut/typeclassestut.pdf
He does a 2x2 matrix type
*)

Require Import Extraction.
Require Import Coq.extraction.ExtrOcamlNatInt  Coq.extraction.ExtrOcamlZInt.
Recursive Extraction vadd.
Recursive Extraction smul.

Goal dot vzero vzero <= 1. cbn. unfold dot. simpl. lra. Qed.

Theorem vadd_comm : forall v w, vadd v w = vadd w v. Proof.
                                                  intros v w. destruct v. destruct w. unfold vadd. cbn.  assert (x3 + x4 = x4 + x3). ring.  assert (y3 + y4 = y4 + y3). ring.  rewrite H. rewrite H0. auto. Qed.

Theorem smul_assoc : forall a b v, smul a (smul b v)  = smul (a * b) v. Proof.
     intros. destruct v.  unfold smul. cbn.  assert (a * (b * x3) = a * b * x3). ring.  assert (a * (b * y3) = a * b * y3). ring.  rewrite H. rewrite H0. auto. Qed.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.Combinatorics.FiniteSets.
Require Import UniMath.CategoryTheory.Core.Categories.

Require Import prelude.
Require Import syntax.containers.
Require Import syntax.hit_signature.
Require Import syntax.W_types.
Require Import algebra.set_algebra.

Local Open Scope container_scope.

(**
Monoids

Inductive monoid : Type :=
| 1 : monoid
| m : monoid -> monoid -> monoid
| nl : ∏ (x : monoid), m(x, 1) = x
| nr : ∏ (x : monoid), m(1, x) = x
| assoc : ∏ (x y z : monoid), m(x, m(y, z)) = m(m(x, y), z)
 *)
Definition monoid_operations
  : hSet
  := setcoprod unitset unitset.

Definition monoid_unit
  : monoid_operations
  := inl tt.

Definition monoid_mult
  : monoid_operations
  := inr tt.

Definition monoid_arities
  : monoid_operations → hSet.
Proof.
  intro x.
  induction x as [ | ].
  - exact emptyset.
  - exact boolset.
Defined.

Definition monoid_sig_point_constr
  : container.
Proof.
  use make_container.
  - exact monoid_operations.
  - exact monoid_arities.
Defined.

Definition monoid_eqs
  : hSet
  := setcoprod
       unitset
       (setcoprod
          unitset
          unitset).

Definition monoid_neutral_left
  : monoid_eqs
  := inl tt.

Definition monoid_neutral_right
  : monoid_eqs
  := inr (inl tt).

Definition monoid_assoc
  : monoid_eqs
  := inr (inr tt).

Definition monoid_eqs_args
  : monoid_eqs → hSet.
Proof.
  intros x.
  induction x as [ | [ | ]].
  - exact unitset.
  - exact unitset.
  - exact (setcoprod unitset (setcoprod unitset unitset)).
Defined.

Definition monoid_sig_path_arg
  : container.
Proof.
  use make_container.
  - exact monoid_eqs.
  - exact monoid_eqs_args.
Defined.

Definition W_unit
           (A : hSet)
  : W monoid_sig_point_constr A.
Proof.
  use sup.
  - exact monoid_unit.
  - exact fromempty.
Defined.

Definition W_mult
           {A : hSet}
           (x y : W monoid_sig_point_constr A)
  : W monoid_sig_point_constr A.
Proof.
  use sup.
  - exact monoid_mult.
  - intro b.
    induction b.
    + exact x.
    + exact y.
Defined.

Definition monoid_sig_lhs
           (s : shapes monoid_sig_path_arg)
  : W monoid_sig_point_constr (positions monoid_sig_path_arg s).
Proof.
  induction s as [ | [ | ]].
  - (* neutral left *)
    use W_mult.
    + refine (var _).
      exact tt.
    + apply W_unit.
  - (* neutral right *)
    use W_mult.
    + apply W_unit.
    + refine (var _).
      exact tt.
  - (* associativity *)
    use W_mult.
    + refine (var _).
      exact (inl tt).
    + use W_mult.
      * refine (var _).
        exact (inr (inl tt)).
      * refine (var _).
        exact (inr (inr tt)).
Defined.

Definition monoid_sig_rhs
           (s : shapes monoid_sig_path_arg)
  : W monoid_sig_point_constr (positions monoid_sig_path_arg s).
Proof.
  induction s as [ | [ | ]].
  - (* neutral left *)
    refine (var _).
    exact tt.
  - (* neutral right *)
    refine (var _).
    exact tt.
  - (* associativity *)
    use W_mult.
    + use W_mult.
      * refine (var _).
        exact (inl tt).
      * refine (var _).
        exact (inr (inl tt)).
    + refine (var _).
      exact (inr (inr tt)).
Defined.

Definition monoid_sig : hit_signature.
Proof.
  use make_hit_signature.
  - exact monoid_sig_point_constr.
  - exact monoid_sig_path_arg.
  - exact monoid_sig_lhs.
  - exact monoid_sig_rhs.
Defined.

Definition is_finitary_monoid_sig
  : is_finitary_hit monoid_sig.
Proof.
  split.
  - intro x.
    induction x as [ | ] ; cbn -[isfinite].
    + apply isfiniteempty.
    + apply isfinitebool.
  - intro x.
    induction x as [ | [ | ]] ; cbn -[isfinite].
    + apply isfiniteunit.
    + apply isfiniteunit.
    + use isfinitecoprod.
      * apply isfiniteunit.
      * use isfinitecoprod.
        ** apply isfiniteunit.
        ** apply isfiniteunit.
Qed.

Section MonoidAlgebra.
  Variable (X : hit_algebra monoid_sig).

  Definition monoid_carrier
    : hSet
    := pr11 X.

  Definition monoid_alg_unit
    : monoid_carrier
    := pr21 X (monoid_unit ,, fromempty).

  Definition monoid_alg_mult
             (x y : monoid_carrier)
    : monoid_carrier.
  Proof.
    refine (pr21 X (monoid_mult ,, _)).
    intro b.
    induction b.
    - exact x.
    - exact y.
  Defined.

  Local Notation e := monoid_alg_unit.
  Local Notation "x · y" := (monoid_alg_mult x y).

  Definition monoid_alg_neutral_left
             (x : monoid_carrier)
    : x · e = x.
  Proof.
    pose (p := pr2 X monoid_neutral_left (λ _, x)).
    cbn in p.
    refine (_ @ p) ; clear p.
    unfold monoid_alg_mult ; cbn.
    do 2 apply maponpaths.
    use funextsec.
    intro b.
    induction b.
    - apply idpath.
    - unfold monoid_alg_unit ; cbn.
      do 2 apply maponpaths.
      use funextsec.
      intro q ; induction q.
  Qed.

  Definition monoid_alg_neutral_right
             (x : monoid_carrier)
    : e · x = x.
  Proof.
    pose (p := pr2 X monoid_neutral_right (λ _, x)).
    cbn in p.
    refine (_ @ p) ; clear p.
    unfold monoid_alg_mult ; cbn.
    do 2 apply maponpaths.
    use funextsec.
    intro b.
    induction b.
    - unfold monoid_alg_unit ; cbn.
      do 2 apply maponpaths.
      use funextsec.
      intro q ; induction q.
    - apply idpath.
  Qed.

  Definition monoid_alg_assoc_help
             (x y z : monoid_carrier)
    : path_arg monoid_sig monoid_assoc → alg_carrier (pr1 X).
  Proof.
    intro b.
    induction b as [ | [ | ]].
    - exact x.
    - exact y.
    - exact z.
  Defined.

  Definition monoid_alg_assoc
             (x y z : monoid_carrier)
    : x · (y · z) = (x · y) · z.
  Proof.
    pose (p := pr2 X monoid_assoc (monoid_alg_assoc_help x y z)).
    refine (_ @ p @ _) ; clear p.
    - unfold monoid_alg_mult ; cbn.
      do 2 apply maponpaths.
      use funextsec.
      intro b ; induction b ; cbn.
      + apply idpath.
      + do 2 apply maponpaths.
        use funextsec.
        intro b ; induction b ; cbn.
        * apply idpath.
        * apply idpath.
    - unfold monoid_alg_mult ; cbn.
      do 2 apply maponpaths.
      use funextsec.
      intro b ; induction b ; cbn.
      + do 2 apply maponpaths.
        use funextsec.
        intro b ; induction b ; cbn.
        * apply idpath.
        * apply idpath.
      + apply idpath.
  Defined.
End MonoidAlgebra.

Definition make_monoid_algebra
           (G : hSet)
           (e : G)
           (i : G → G)
           (m : G → G → G)
           (nl : ∏ (g : G), m g e = g)
           (nr : ∏ (g : G), m e g = g)
           (a : ∏ (g₁ g₂ g₃ : G),
                m g₁ (m g₂ g₃)
                =
                m (m g₁ g₂) g₃)
  : hit_algebra monoid_sig.
Proof.
  simple refine ((G ,, _) ,, _) ; cbn.
  - intro x.
    induction x as [s p].
    induction s as [ | ] ; cbn in p.
    + exact e.
    + exact (m (p true) (p false)).
  - intros j p.
    induction j as [ | [ | ]] ; cbn in p ; cbn.
    + apply nl.
    + apply nr.
    + apply a.
Defined.


Require Import MathUtils.

Module Export RSA.

Definition rsa_keygen_public (p q : nat) : nat * nat
  :=
  let euler_totient := (p - 1) * (q - 1) in
  let n := (p * q) in
    ((coprime euler_totient) , n).

Definition rsa_keygen_private (p q : nat) : nat * nat
  :=
  let e := (fst (rsa_keygen_public p q)) in
  let n := p * q in
  let euler_totient := (p - 1) * (q - 1) in
    ((mod_inv e euler_totient) , (p * q)).

Definition rsa_encrypt' (plain_text : nat) (public_key : nat * nat) : nat
  := match public_key with
     | (e , n) => modl (exp plain_text e) n
     end.

Definition rsa_encrypt'' (p q : nat) (plain_text : nat) : nat
  :=
  let public_key := (rsa_keygen_public p q) in
    (rsa_encrypt' plain_text public_key).

Definition rsa_encrypt (p q : nat) (plain_text : list nat) : list nat
  := loop (rsa_encrypt'' p q) plain_text.

Definition rsa_decrypt' (cipher_text : nat) (private_key : nat * nat) : nat
  := match private_key with
     | (d , n) => modl (exp cipher_text d) n
     end.

Definition rsa_decrypt'' (p q : nat) (cipher_text : nat) : nat
  :=
  let private_key := (rsa_keygen_private p q) in
    rsa_decrypt' cipher_text private_key.

Definition rsa_decrypt (p q : nat) (cipher_text : list nat) : list nat
  := loop (rsa_decrypt'' p q) cipher_text.

End RSA.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Require Import Arith.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint less (less_arg0 : natural) (less_arg1 : natural) : bool
           := match less_arg0, less_arg1 with
              | x, Zero => false
              | Zero, Succ x => true
              | Succ x, Succ y => less x y
              end.
Fixpoint eqb (n m: natural) : bool :=
match n, m with
   | Zero, Zero => true
   | Zero, Succ _ => false
   | Succ _, Zero => false
   | Succ n', Succ m' => eqb n' m'
end.
Definition leq (x : natural) (y : natural) : bool :=
eqb x y || less x y.
(*
Fixpoint leq (n m : natural) : bool :=
match n, m with
| Zero  , x   => true
| x , Zero   => false
| Succ x, Succ y => leq x y
end. *)

Fixpoint insort (insort_arg0 : natural) (insort_arg1 : lst) : lst
           := match insort_arg0, insort_arg1 with
              | i, Nil => Cons i Nil
              | i, Cons x y => if less i x then Cons i (Cons x y) else Cons x (insort i y)
              end.

Fixpoint sorted (sorted_arg0 : lst) : bool
:= match sorted_arg0 with
   | Nil => true
   | Cons x l => match l with
      | Nil => true
      | Cons z y => andb (sorted l) (leq x z)
      end
   end.

Fixpoint sort (sort_arg0 : lst) : lst
           := match sort_arg0 with
              | Nil => Nil
              | Cons x y => insort x (sort y)
              end.
Lemma not_less : forall (x y : natural), less x y = false -> leq y x = true.
Proof.
   intros.
   generalize dependent y.
   induction x.
   - intros. unfold leq. destruct y.
   + simpl in H. apply IHx in H. unfold leq in H. simpl. assumption.
   + reflexivity.
   - intros. unfold leq. destruct y.
   + discriminate.
   + reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : natural), eq (sorted x) true -> eq (sorted (insort y x)) true.
Proof.
   (* intros.
  induction x.
  - destruct x.
    + simpl. destruct (less y n) eqn:?.
      * simpl. unfold leq. rewrite Heqb. admit.
      * simpl. lfind.  assumption.
Admitted.


Require Export induction.
Module NatList.

  Inductive natprod : Type :=
  | pair : nat -> nat -> natprod.

  Definition fst (p :natprod) : nat :=
    match p with
    | pair x y => x
    end.

  Definition snd (p : natprod) : nat :=
    match p with
    | pair x y => y
    end.

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

  Definition fst' ( p :natprod) : nat :=
    match p with
    | (x,y) =>x
    end.

  Definition snd' (p : natprod) : nat :=
    match p with
    | (x,y) => y
    end.

  Definition swap_pair (p : natprod) : natprod :=
    match p with
    | (x,y)=>(y,x)
    end.

  Theorem surjective_pairing' : forall (n m : nat),
      (n,m) = (fst (n,m), snd (n,m)).
  Proof.
    reflexivity.
  Qed.

  Theorem snd_fst_is_swap : forall (p : natprod),
      (snd p, fst p) = swap_pair p.
  Proof.
    intros [n m].
    reflexivity.
  Qed.

  Theorem fst_swap_is_snd : forall (p: natprod),
      fst (swap_pair p) = snd p.
  Proof.
    intros [n m].
    reflexivity.
  Qed.

  Inductive natlist : Type :=
  | nil : natlist
  | cons : nat -> natlist -> natlist.

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

  Definition mylist3 := [1;2;3].
  Definition mylist2 := 1 :: 2 :: 3 :: nil.
  Definition mylist1 :=  1 :: (2 :: (3 :: nil)).

  Fixpoint repeat (n count : nat) : natlist :=
    match count with
    | 0 => nil
    | S count' =>  n :: (repeat n count')
    end.

  Fixpoint length (l:natlist) : nat :=
    match l with
    | nil => 0
    |  h :: t => S (length t)
    end.

  Fixpoint app (l1 l2 : natlist) : natlist :=
    match l1 with
    | nil => l2
    | h :: t => h :: (app t l2)
    end.

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

  Definition hd (default:nat) (l:natlist) :nat  :=
    match l with
    | nil => default
    | h :: t => h
    end.

  Definition tl (l:natlist) : natlist :=
    match l with
    | nil => nil
    | h :: t => t
    end.

  Fixpoint nonzeros (l : natlist) : natlist :=
    match l with
    | nil => nil
    | h :: t =>
      match h with
      | 0 => nonzeros t
      | _ => [h] ++  (nonzeros t)
      end
    end.

  Fixpoint oddmembers (l : natlist) : natlist :=
    match l with
    | nil => nil
    | h :: t =>
      match (oddb h) with
      | true => h :: (oddmembers t)
      | false => oddmembers t
      end
    end.

  Fixpoint countoddmembers (l : natlist) : nat :=
    match l with
    | nil => 0
    | h :: t =>
      match (oddb h) with
      | true => S (countoddmembers t)
      | false => countoddmembers t
      end
    end.

  Fixpoint alternate ( l1 l2 : natlist)  : natlist :=
    match l1 with
    | nil => l2
    | h :: t =>
      match l2 with
      | nil => l1
      | h' :: t' => h :: h' :: ( alternate t t')
      end
    end.

  Definition bag := natlist.

  Fixpoint count (v:nat) (s:bag) : nat :=
    match s with
    | nil => 0
    | h :: t =>
      match (beq_nat v h) with
      | true => S (count v t)
      | false => (count v t)
      end
    end.

  Definition sum : bag -> bag -> bag := alternate.

  Definition  add ( v:nat)(s:bag) : bag := v :: s .

  Definition member (v:nat) (s:bag) : bool := negb ( beq_nat 0 (count v s)).

  Fixpoint remove_one (v:nat) (s:bag) : bag :=
    match s with
    | nil => nil
    | h :: t =>
      match (beq_nat v h) with
      | true => t
      | false => remove_one v t
      end
    end.

  Fixpoint remove_all (v:nat) (s:bag) : bag :=
    match s with
    | nil => nil
    | h :: t =>
      match (beq_nat h v) with
      | true => remove_all v t
      | false => h :: (remove_all v t)
      end
    end.

  Theorem beqT : forall n : nat, beq_nat n n = true.
  Proof.
    intros n.
    induction  n as  [| n' H'].
    - reflexivity.
    - simpl.
      congruence.
  Qed.

  Theorem bag_theorem : forall  n: natlist, forall m:nat,
        S (count m n) =  (count m (add m n)).
  Proof.
    intros m n.
    simpl.
    rewrite  beqT.
    reflexivity.
  Qed.

  Theorem app_assoc : forall l1 l2 l3 : natlist,
      (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
  Proof.
    intros l1 l2 l3.
    induction l1 as [| n l1' IHl1'].
    - reflexivity.
    - simpl.
      rewrite <- IHl1'.
      reflexivity.
  Qed.

  Fixpoint rev (l:natlist) :natlist :=
    match l with
    | nil => []
    | h :: t =>  rev t ++ [h]
    end.

  Theorem app_length : forall l1 l2 : natlist,
      length (l1 ++ l2) = (length l1) + (length l2).
  Proof.
    intros l1 l2.
    induction l1 as [| n l1' IHl1'].
    - reflexivity.
    - simpl.
      rewrite IHl1'.
      reflexivity.
  Qed.

  Theorem rev_length: forall l : natlist,
      length (rev l) = length l.
  Proof.
    intros l.
    induction l as [| n l' IHn'].
    - reflexivity.
    - simpl.
      rewrite -> app_length,plus_comm.
      rewrite IHn'.
      reflexivity.
  Qed.

  Theorem app_nil_r : forall l : natlist,
      l ++ [] = l.
  Proof.
    intros l.
    induction l as [| n l' IHl'].
    - reflexivity.
    - simpl.
      rewrite IHl'.
      reflexivity.
  Qed.

  Theorem rev_app_distr : forall l1 l2: natlist,
      rev (l1 ++ l2) = rev l2 ++ rev l1.
  Proof.
    intros l1 l2.
    induction l1 as [| n l' IHl'].
    - simpl.
      rewrite -> app_nil_r.
      reflexivity.
    - simpl.
      rewrite IHl'.
      rewrite -> app_assoc.
      reflexivity.
  Qed.

  Theorem rev_involutive : forall l : natlist,
      rev (rev l) = l.
  Proof.
    intros l.
    induction l as [| n l' IHl'].
    - reflexivity.
    - simpl.
      rewrite rev_app_distr.
      rewrite IHl'.
      reflexivity.
  Qed.

  Theorem app_assoc4  : forall l1 l2 l3 l4 : natlist,
      l1 ++ ( l2 ++ ( l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
  Proof.
    intros l1 l2 l3 l4.
    rewrite <- app_assoc.
    rewrite <- app_assoc.
    reflexivity.
  Qed.

  Theorem nonzerosT: forall l1 : natlist,forall n : nat,
        nonzeros(n :: l1) = (nonzeros [n]) ++ (nonzeros l1).
  Proof.
    intros l1 n.
    destruct n as [ | n'].
    - simpl.
      reflexivity.
    - simpl.
      reflexivity.
  Qed.

  Lemma nonzeros_app : forall l1 l2 :natlist,
      nonzeros ( l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
  Proof.
    intros l1 l2.
    induction l1 as [| n l IHl'].
    - reflexivity.
    - rewrite -> nonzerosT.
      rewrite -> app_assoc.
      rewrite <- IHl'.
      rewrite <- nonzerosT.
      reflexivity.
  Qed.

  Fixpoint beq_natlist (l1 l2 : natlist) : bool :=
    match l1 with
    | nil =>
      match l2 with
        | nil => true
        | _ => false
      end
    | h :: t =>
      match l2 with
      | nil => false
      | h2 :: t2 =>
        match beq_nat h h2 with
        | true => beq_natlist t t2
        | false => false
        end
      end
    end.

  Theorem beq_natlist_refl : forall l : natlist,
      true = beq_natlist l l.
  Proof.
    intros l.
    induction l as [| n l' IHl'].
    - reflexivity.
    - simpl.
      assert (H: forall k: nat, beq_nat k k =true).
      { intros k.
        induction k as [| k'].
        - reflexivity.
        - simpl.
          congruence.
      }
      rewrite -> H.
      congruence.
  Qed.

  Theorem count_member_nonzero : forall ( s : bag),
      leb 1 (count 1 (1 :: s)) =true.
  Proof.
    intros s.
    induction s as [| n l' IHl'].
    - reflexivity.
    - reflexivity.
  Qed.

  Theorem ble_n_Sn : forall n,
      leb n (S n) =true.
  Proof.
    intros n.
    induction n as [| n' IHn'].
    - reflexivity.
    - simpl.
      rewrite IHn'.
      reflexivity.
  Qed.

  Theorem remove_decreases_count: forall (s : bag),
      leb (count 0 (remove_one 0 s)) (count 0 s) = true.
  Proof.
    intros s.
    induction s as [| n l' IH'].
    - reflexivity.
    - destruct n as [| n'].
      + simpl.
        rewrite ble_n_Sn.
        reflexivity.
      + simpl.
        congruence.
  Qed.

  Theorem beq_nn: forall n,
      beq_nat n n =true.
  Proof.
    intros n.
    induction n as [| n'].
    - reflexivity.
    - simpl.
      congruence.
  Qed.

  Theorem bag_count_sum: forall n: nat, forall l : natlist,
        S(count n l) = count n (sum [n] l).
  Proof.
    intros n l.
    induction l as [| n' l' IH'].
    - simpl.
      rewrite beq_nn.
      reflexivity.
    - simpl.
      rewrite beq_nn.
      reflexivity.
  Qed.

  Theorem rev_app : forall (l1 l2:natlist),
      rev l1 = rev l2 -> rev (rev l1) = rev (rev l2).
  Proof.
    intros l1 l2 H.
    rewrite H.
    reflexivity.
  Qed.

  Theorem rev_injective:  forall ( l1 l2 :natlist),
      rev l1 = rev l2 -> l1 = l2.
  Proof.
    intros l1 l2 H.
    apply rev_app in H.
    rewrite rev_involutive in H.
    rewrite rev_involutive in H.
    congruence.
  Qed.

  Inductive natoption : Type :=
  | Some : nat -> natoption
  | None : natoption.

  Fixpoint nth_error (l:natlist) (n:nat) :natoption :=
    match l with
    | nil => None
    | a:: l' => match beq_nat n 0 with
                | true => Some a
                | false => nth_error l' (pred n)
                end
    end.

  Fixpoint nth_error' (l:natlist) (n:nat) : natoption :=
    match l with
    | nil => None
    | a :: l' => if beq_nat n 0 then Some a
                 else nth_error' l' (pred n)
    end.

  Definition option_elim ( d : nat) (o : natoption) : nat :=
    match o with
    | Some n' => n'
    | None  => d
    end.

  Definition hd_error (l : natlist) : natoption :=
    match l with
    | nil => None
    | h :: t => Some h
    end.

  Theorem option_elim_hd : forall (l:natlist) (default:nat) ,
      hd default l = option_elim default (hd_error l).
  Proof.
    intros l default.
    destruct l as [| h  t].
    - reflexivity.
    - reflexivity.
  Qed.

  End NatList.

  Inductive id : Type :=
  | Id : nat -> id.

  Definition beq_id (x1 x2 : id) :=
    match x1, x2 with
    | Id n1, Id n2 => beq_nat n1 n2
    end.

  Theorem beq_nn : forall n:nat, beq_nat n n=true.
  Proof.
    intros n.
    induction n as [| n'].
    - reflexivity.
    - simpl.
      congruence.
  Qed.

  Theorem beq_id_refl : forall x, true = beq_id x x.
  Proof.
    intros x.
    destruct x as [n'].
    simpl.
    rewrite beq_nn.
    reflexivity.
  Qed.

  Module PartialMap.
    Export NatList.
    Inductive partial_map : Type :=
    | empty : partial_map
    | record : id -> nat -> partial_map -> partial_map.

    Definition update (d : partial_map) (x : id) (value : nat) : partial_map :=
      record x value d.

    Fixpoint find (x :id) (d : partial_map) : natoption :=
      match d with
      | empty => None
      | record y v d' => if beq_id x y
                         then Some v
                         else find x d'
      end.

    Theorem update_eq :
      forall (d : partial_map) (x: id) (v: nat),
        find x (update d x v) = Some v.
    Proof.
      intros d x v.
      simpl.
      rewrite <- beq_id_refl.
      reflexivity.
    Qed.

    Theorem update_neq:
      forall (d : partial_map) ( x y :id) (o : nat),
        beq_id x y = false -> find x (update d y o) = find x d.
    Proof.
      intros d x y o H.
      simpl.
      rewrite H.
      reflexivity.
    Qed.


(** * 6.822 Formal Reasoning About Programs, Spring 2018 - Pset 2 *)

Require Import Frap Pset2Sig.

(* If we [either] an [option] value with [None]
 * on the right, it leaves that value unchanged,
 * (just as if we put the [None] on the left).
 * This is analogous to how appending [nil]
 * on either side of a list leaves it unchanged.
 *)
Theorem either_None_right : forall {A} (xo : option A),
    either xo None = xo.
Proof.
Admitted.

(* [either] is associative, just like [++].
 *)
Theorem either_assoc : forall {A} (xo yo zo : option A),
    either (either xo yo) zo = either xo (either yo zo).
Proof.
Admitted.

(* [head] should compute the head of a list, that is,
 * it should return [Some] with the first element of
 * the list if the list is nonempty, and [None]
 * if the list is empty.
 *)
Fixpoint head {A} (xs : list A) : option A.
Admitted.

Example head_example : head [1; 2; 3] = Some 1.
Proof.
Admitted.

(* The following theorem makes a formal connection
 * between [either] and [++].
 *)
Theorem either_app_head : forall {A} (xs ys : list A),
    head (xs ++ ys) = either (head xs) (head ys).
Proof.
Admitted.

(* [leftmost_Node] should compute the leftmost node of
 * a tree.
 *
 * Please implement [leftmost_Node] directly using
 * recursion (i.e., pattern matching) on the [tree] argument,
 * without using the [flatten] operation.
 *)
Fixpoint leftmost_Node {A} (t : tree A) : option A.
Admitted.

Example leftmost_Node_example :
    leftmost_Node (Node (Node Leaf 2 (Node Leaf 3 Leaf)) 1 Leaf)
    = Some 2.
Proof.
Admitted.

(* Prove that the leftmost node of the tree is the same
 * as the head of the list produced by flattening the tree
 * with an in-order traversal.
 *)
Theorem leftmost_Node_head : forall {A} (t : tree A),
      leftmost_Node t = head (flatten t).
Proof.
Admitted.

(* Now let's work with the binary tries we defined earlier!
 *
 * Define [lookup] such that [lookup k t] looks up the
 * map entry corresponding to the key [k : list bool] in the
 * binary trie [t : binary_trie A], interpreting [t] such that
 * the value at the root of [t] corresponds to the
 * entry for the key [nil], the left subtree contains entries
 * for those keys that begin with [true], and the right subtree
 * contains entries for those keys that begin with [false].
 *)
Fixpoint lookup {A} (k : list bool) (t : binary_trie A) : option A.
Admitted.

Example lookup_example1 : lookup [] (Node Leaf (None : option nat) Leaf) = None.
Proof.
Admitted.

Example lookup_example2 : lookup [false; true]
    (Node (Node Leaf (Some 2) Leaf) None (Node (Node Leaf (Some 1) Leaf) (Some 3) Leaf))
                          = Some 1.
Proof.
Admitted.

(* [Leaf] represents an empty binary trie, so a lookup for
 * any key should return [None].
 *)
Theorem lookup_empty {A} (k : list bool)
  : lookup k (Leaf : binary_trie A) = None.
Proof.
Admitted.

(* Define an operation to "insert" a key and optional value
 * into a binary trie. The [insert] definition should satisfy two
 * properties: one is [lookup_insert] below, which says that if we
 * look up a key [k] in a trie where [(k, v)] has just been inserted,
 * the result should be [v]. The other is that lookups on keys different
 * from the one just inserted should be the same as on the original map.
 *
 * If an entry for that key already exists, [insert] should replace
 * that entry with the new one being inserted. Note that [insert] can
 * be used to remove an entry from the trie, too, by inserting [None]
 * as the value.
 *
 * Hint: it may be helpful to define an auxiliary function that inserts
 * a key and optional value into the empty trie.
 *)
Fixpoint insert {A} (k : list bool) (v : option A) (t : binary_trie A)
  : binary_trie A.
Admitted.

Example insert_example1 : lookup [] (insert [] None (Node Leaf (Some 0) Leaf)) = None.
Proof.
Admitted.

Example insert_example2 : lookup [] (insert [true] (Some 2) (Node Leaf (Some 0) Leaf)) = Some 0.
Proof.
Admitted.

Theorem lookup_insert {A} (k : list bool) (v : option A) (t : binary_trie A)
  : lookup k (insert k v t) = v.
Proof.
Admitted.

(* You've reached the end of the problem set. Congrats!
 *
 * If you're up for a completely optional additional challenge,
 * try defining a left-biased merge function below that merges two
 * binary tries, preferring map entries from the first binary trie
 * when an entry exists for both binary tries. Then prove
 * [lookup_left_biased_merge], which formally states that lookups
 * on the merged binary trie operate in exactly this manner.
 *
 * If you don't want to complete this additional challenge, you
 * can just leave everything below unmodified.
 *)

Fixpoint left_biased_merge {A} (t t' : binary_trie A) : binary_trie A.
Admitted.

Theorem lookup_left_biased_merge {A} (k : list bool) (t t' : binary_trie A)
  : lookup k (left_biased_merge t t') = either (lookup k t) (lookup k t').
Proof.
Admitted.