Definition rInv {T1 T2:Set}  (R: T1 -> T2 -> Prop) :=
  fun a b => R b a.

Definition TotalHalf {T1 T2 : Set} (R: T1 -> T2 -> Prop) : Type :=
(forall (t1:T1), @sigT T2 (R t1)).

Definition OneToOneHalf  {A B : Set} (R : A -> B -> Prop) : Prop :=
forall a b1 b2,
  R a b1
  -> R a b2
  ->  b1=b2.

Definition Total {T1 T2 : Set} (R: T1 -> T2 -> Prop) : Type :=
(TotalHalf R) *
(TotalHalf (rInv R)).

Definition OneToOne  {A B : Set} (R : A -> B -> Prop) : Prop :=
OneToOneHalf R /\ (OneToOneHalf (rInv R)).

Require Import SquiggleEq.tactics.

Definition left_identity {S T : Type} (f: S -> T) (g: T-> S): Prop :=
  forall s: S , (g (f s)) = s.

Definition isomorphic (A B : Set)  :=
  sigT (fun f: A->B => sig (fun g: B->A =>  left_identity f g /\ left_identity g f)).

Definition isomorphic2 (A B : Set) : Type :=
  sigT (fun R: A -> B -> Prop => (Total R * OneToOne R)%type).

Section iff.
  Variables (A B: Set).
  Lemma same12: isomorphic A B -> isomorphic2 A B.
  Proof.
    intros Hiso.
    destruct Hiso as [f Hiso].
    destruct Hiso as [g Hiso].
    hnf in Hiso. unfold left_identity in Hiso.
    repnd.
    exists (fun a b => f a = b).
    split; split.
    - intros a. exists (f a). reflexivity.
    - intros b. exists (g b). hnf. auto.
    - intros ? ? ? H1eq H2eq. congruence.
    - intros ? ? ? H1eq H2eq. congruence.
  Qed.

  Lemma same21: isomorphic2 A B -> isomorphic A B.
  Proof.
    intros Hiso.
    destruct Hiso as [R Hiso].
    destruct Hiso as [Tot One].
    unfold Total, OneToOne, TotalHalf, OneToOneHalf in *.
    repnd.
    exists (fun a => projT1 (Tot0 a)).
    exists (fun b => projT1 (Tot b)).
    split; unfold rInv in *.
    - intros a.
      destruct (Tot0 a) as [b ab].
      simpl. destruct (Tot b) as [a' ab'].
      simpl. hnf in ab'. unfold rInv in *. eauto.
    - intros b.
      destruct (Tot b) as [a ab].
      simpl. destruct (Tot0 a) as [b' ab'].
      simpl. hnf in ab'. unfold rInv in *. eauto.
  Qed.

End iff.

Print sigT.

Inductive sigTS (A : Set) (P : A -> Prop) : Prop :=  existT : forall x : A, P x -> sigTS A P.
Inductive sigTS2 (A : Set) (P : A -> Type) : Prop :=  existT2 : forall x : A, P x -> sigTS2 A P.

(*
Definition isomorphic3 (A B : Set) : Type := *)

Fail Check  (fun (A B : Set) => sigTS _ (fun R: A -> B -> Prop => (Total R * OneToOne R)%type)).
(*
The term "(Total R * OneToOne R)%type" has type "Type" while it is expected to have type
"Prop" (universe inconsistency).
 *)

Fail Check  (fun (A B : Set) => sigTS2 _ (fun R: A -> B -> Prop => (Total R * OneToOne R)%type)).
(*
The term "sigTS2" of type "forall A : Set, (A -> Type) -> Prop"
cannot be applied to the terms
 "A -> B -> Prop" : "Type"
 "fun R : A -> B -> Prop => (Total R * OneToOne R)%type" : "(A -> B -> Prop) -> Type"
The 1st term has type "Type" which should be coercible to "Set".
 *)

Check  (fun (A B : Set) => sigTS (A->B) (fun f: A -> B => sigTS (B->A) (fun g => left_identity f g /\ left_identity g f ))).

Goal False.
  set (t:= isomorphic).
  unfold isomorphic in t.
  unfold left_identity in t.
Abort.


Require Import Lists.List.

Fixpoint sum (xs: list nat) : nat :=
  match xs with
    | nil => 0
    | x :: xs => x + sum xs
  end.

Theorem Pigeon_Hole_Principle :
  forall (xs : list nat), length xs < sum xs -> (exists x, 1<x /\ In x xs).
Proof.
  intros.
  induction xs.
    simpl in H.
    apply False_ind, (Lt.lt_irrefl 0 H).

    assert ((exists x : nat, 1 < x /\ In x xs) -> forall n, exists x : nat, 1 < x /\ In x (n :: xs)).
      intros.
      destruct H0. destruct H0.
      exists x.
      split.
        assumption. assert (In x (n :: xs)) by (apply (in_cons n x xs H1)); assumption.

    induction a.
      simpl in H.
      assert (forall n m, S n < m -> n < m).
        intros.
        induction m.
          apply False_ind, (Lt.lt_n_0 (S n) H1).
          apply (Lt.lt_S n m (Lt.lt_S_n n m H1)).
      assert (exists x : nat, 1 < x /\ In x xs) by (apply (IHxs (H1 (length xs) (sum xs) H))).
      apply (H0 H2).

      induction a.
        simpl in H.
        apply (H0 (IHxs (Lt.lt_S_n (length xs) (sum xs) H))).

        exists (S (S a)).
        split.
          apply (Lt.lt_n_S 0 (S a)), (Lt.lt_0_Sn a).
          apply (in_eq).
Qed.


Require Import Tapl.LambdaSub.Base.

(* Our presentation of simply typed lambda calculus has a single base type, Unit. *)
Inductive type : Type :=
  | ty_unit  : type
  | ty_arrow : type → type → type
  | ty_top   : type.

Inductive term : Type :=
  | tm_var  : nat → term
  | tm_abs  : type → term → term
  | tm_app  : term → term → term
  | tm_unit : term.

Coercion tm_var : nat >-> term.

(* Values *)

Definition context := list type.
Inductive wf : context -> term -> Prop :=
  | wf_var  : forall G i,
         (exists T, get i G = Some T)
      -> wf G (tm_var i)
  | wf_abs  : forall G T t,
         wf (T :: G) t
      -> wf G (tm_abs T t)
  | wf_app  : forall G t1 t2,
         wf G t1
      -> wf G t2
      -> wf G (tm_app t1 t2)
  | wf_unit : forall G,
      wf G tm_unit.
Global Hint Constructors wf : core.

Definition closed (t: term) := wf nil t.

Inductive wnfX : term → Prop :=
  | wnf_val : ∀ T t, wnfX (tm_abs T t)
  | wnf_unit : wnfX tm_unit.
Global Hint Constructors wnfX : core.

Definition value (t : term) := wnfX t ∧ closed t.

(* Substitution *)

(* lift shifts all the free variables over by 1 *)

Fixpoint lift (k : nat) (t : term) :=
  match t with
  | tm_var i => match compare i k with
                | Lt => tm_var i
                | _  => tm_var (S i)
                end
  | tm_abs T t' => tm_abs T (lift (S k) t')
  | tm_app t1 t2 => tm_app (lift k t1) (lift k t2)
  | tm_unit => tm_unit
  end.

(*
Fixpoint lift (k : nat) (t : term) :=
  match t with
  | tm_var i => if leb k i
                then tm_var (S i)
                else tm_var i
  | tm_abs T t' => tm_abs T (lift (S k) t')
  | tm_app t1 t2 => tm_app (lift k t1) (lift k t2)
  | tm_unit => tm_unit
  end.
*)
(* [k -> s]t *)
(* substX replaces the k'th free variable with s in t.
   if s has free variables, s is lifted when substituting over binders to make sure the free variables in s are correct.
   All free variables j > k are shifted down one, to account for the fact that the k'th free variable has been substituted.
*)
Fixpoint substX (k : nat) (s : term) (t : term) :=
  match t with
  | tm_var i => match compare i k with
                | Eq => s
                | Lt => tm_var i
                | Gt => tm_var (pred i)
                end
  | tm_abs T t' => tm_abs T (substX (S k) (lift 0 s) t')
  | tm_app t1 t2 => tm_app (substX k s t1) (substX k s t2)
  | tm_unit => tm_unit
  end.

(* Examples *)
(* [0 -> (λ.T 0)] (1 0 2) = 0 (λ.T 0) 1*)
Example ex1 : substX 0 (tm_abs ty_unit 0) (tm_app (tm_app 1 0) 2)
            = tm_app (tm_app 0 (tm_abs ty_unit 0)) 1.
Proof.
  simpl. reflexivity.
Qed.

(* Evaluation *)

Reserved Notation "t '-->' t'" (at level 40).
Inductive step : term -> term -> Prop :=
  | st_app1 : forall t1 t1' t2,
      t1 --> t1' ->
      tm_app t1 t2 --> tm_app t1' t2
  | st_app2 : forall v1 t2 t2',
      value v1 ->
      t2 --> t2' ->
      tm_app v1 t2 --> tm_app v1 t2'
  | st_appAbs : forall T t1 v2,
      value v2 ->
      tm_app (tm_abs T t1) v2 --> substX 0 v2 t1

where "t '-->' t'" := (step t t').
Global Hint Constructors step : core.

(* multi_step is the reflexive/transitive closure of the step relation *)

Definition multi_step := multi_rel step.
Notation "t '-->*' t'" := (multi_step t t') (at level 40).
(*
Inductive multi_step : term -> term -> Prop :=
  | ms_refl : forall t,
      t -->* t
  | ms_trans : forall t1 t2 t3,
      t1 --> t2 ->
      t2 -->* t3 ->
      t1 -->* t3
where "t '-->*' t'" := (multi_step t t').
*)


Add LoadPath "../Basics".
Add LoadPath "../Induction".
Require Import EnumTypes.
Require Import Induction.
Require Import NamingCases.
Require Import Lists.
Require Import Reasoning.

(** Below is an implementation of the [!!] operation. What do we do if
    the given index is too high? In this case, we return the arbitrary
    value 42. *)
Fixpoint index_bad (n:nat) (l:natlist) : nat :=
   match l with
   | nil => 42 (* arbitrary *)
   | a :: l' => match beq_nat n O with
                | true => a
                | false => index_bad (pred n) l'
                end
   end.

(** Introducing [natoption], an inductive type for handling errors. It's
    basically just [Maybe Int] *)
Inductive natoption : Type :=
   | Some : nat -> natoption
   | None : natoption.

(** Let's rewrite [index_bad] with the added convenience of [natoption] *)
Fixpoint index (n:nat) (l:natlist) : natoption :=
   match l with
   | nil => None (* arbitrary *)
   | a :: l' => match beq_nat n O with
                | true => Some a
                | false => index (pred n) l'
                end
   end.

(* Some examples *)
Example test_index1 : index 0 [4;5;6;7] = Some 4.
Proof. reflexivity. Qed.
Example test_index2 : index 3 [4;5;6;7] = Some 7.
Proof. reflexivity. Qed.
Example test_index3 : index 10 [4;5;6;7] = None.
Proof. reflexivity. Qed.

(** Here's a function for taking the [nat] out of a [natoption]. The
    function returns a supplied default [d] if the [natoption] is
    [None] *)
Definition option_elim (d : nat) (o : natoption) : nat :=
   match o with
   | Some n => n
   | None   => d
   end.

(** EXERCISE [**]: Fix the hd function from earlier, so we don't have to
    pass a default case *)
Definition hd_opt (l : natlist) : natoption :=
   match l with
   | []     => None
   | h :: t => Some h
   end.

(* Tests *)
Example test_hd_opt1 : hd_opt [] = None.
Proof. reflexivity. Qed.

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

Example test_hd_opt3 : hd_opt [5;6] = Some 5.
Proof. reflexivity. Qed.

(** EXERCISE [*]: Prove the following theorem, relating [hd_opt] to
    [hd] *)
Theorem option_elim_hd : forall (l : natlist) (default : nat),
   hd default l = option_elim default (hd_opt l).

Proof.
   intros l default. destruct l as [| x l'].
   Case "l = []".
      reflexivity.
   Case "l = x :: l'".
      reflexivity. Qed.


Require Import Coq.ZArith.BinInt.
Require Import Coq.ZArith.Zcomplements.
Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.Znat.

Require Import compcert.lib.Integers.
Require Import compcert.common.Values.
Require Import compcert.exportclight.Clightdefs.

Require Import VST.veric.expr.
Require Import VST.veric.mpred.
Require Import VST.floyd.forward.
Require Import VST.floyd.sublist.
Require Import VST.floyd.field_at.
Require Import VST.floyd.coqlib3.
Require Import VST.msl.iter_sepcon.
Require Import VST.msl.seplog.

Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.graph.MathAdjMatGraph.

Section Spatial_AdjMat_Model_2.
  (* Model 2 is for a stack-allocated graph,
     where the graph is declared on the stack
     as a single-dimension array of size "size^2".
     Access to graph[u][v] is via graph[size*u + v].
   *)

  Context {size : Z}.
  Context {CompSpecs : compspecs}.
  Context {V_EqDec : EquivDec.EqDec V eq}.
  Context {E_EqDec: EquivDec.EqDec E eq}.

  (* SPATIAL REPRESENTATION *)

  (* Assumption:
     (v,0), (v,1) ... (v, size-1) are edges.

   Action:
    Makes a list containing each edge's elabel.
    The argument f is an opportunity to tweak the edges as needed
   *)
  Definition vert_to_list (g: AdjMatLG) (f : E -> E) (v : V) :=
    map (elabel g)
        (map (fun x => f (v,x))
             (nat_inc_list (Z.to_nat size))).

  (* Assumptions:
     1. 0, 1, ... (size-1) are vertices
     2. for any vertex v,
          (v,0), (v,1) ... (v, size-1) are edges.

     Action:
      Makes a list of lists, where each member list
      is a vertex's edge-label-list (see helper above).
   *)
  Definition graph_to_mat (g: AdjMatLG) (f : E -> E) : list (list Z) :=
    map (vert_to_list g f)
        (nat_inc_list (Z.to_nat size)).

  Lemma graph_to_mat_Zlength:
    forall g (f : E -> E),
      0 <= size ->
      Zlength (graph_to_mat g f) = size.
  Proof.
    intros. unfold graph_to_mat.
    rewrite Zlength_map, nat_inc_list_Zlength, Z2Nat.id; trivial.
  Qed.

  Lemma elabel_Znth_graph_to_mat:
    forall (g: AdjMatLG) (f: E -> E) src dst,
      0 <= size ->
      0 <= src < size ->
      0 <= dst < size ->
      elabel g (f (src, dst)) =
      Znth dst (Znth src (graph_to_mat g f)).
  Proof.
    intros.
    unfold graph_to_mat.
    rewrite Znth_map, nat_inc_list_i.
    unfold vert_to_list. rewrite Znth_map.
    rewrite Znth_map. rewrite nat_inc_list_i.
    reflexivity.
    3: rewrite Zlength_map.
    2, 3, 5: rewrite nat_inc_list_Zlength.
    all: rewrite Z2Nat.id; trivial.
  Qed.

  Definition graph_to_list (g: AdjMatLG) (f : E -> E) : list Z :=
    (concat (graph_to_mat g f)).

   Lemma Zlength_concat:
   forall size n f,
     0 <= n ->
     Forall (fun list : list Z => Zlength list = n)
            (map f (nat_inc_list size)) ->
     Zlength (concat (map f (nat_inc_list size))) =
     Z.of_nat size * n.
 Proof.
   intros.
   clear H. induction size0.
   1: simpl; apply Zlength_nil.
   rewrite Nat2Z.inj_succ, Z.mul_succ_l.
   simpl. rewrite map_app, concat_app, Zlength_app.
   simpl. rewrite app_nil_r.
   f_equal.
   - apply IHsize0.
     rewrite Forall_forall in H0 |- *.
     intros. apply H0.
     simpl. rewrite map_app.
     apply in_or_app; left; trivial.
   - rewrite Forall_forall in H0. apply H0.
     apply in_map. rewrite nat_inc_list_in_iff. lia.
 Qed.

 Lemma graph_to_list_Zlength:
    forall g (f : E -> E) n,
      0 <= size ->
      0 <= n ->
      Forall (fun list => Zlength list = n) (graph_to_mat g f) ->
      Zlength (graph_to_list g f) = size * n.
  Proof.
    intros.
    rewrite <- (Z2Nat.id size); trivial.
    unfold graph_to_list, graph_to_mat in *.
    apply Zlength_concat; trivial.
  Qed.

  Lemma graph_to_list_to_mat:
    forall g (f : E -> E) u i,
      0 <= u < size ->
      0 <= i < size ->
      0 < size ->
      Forall (fun list => Zlength list = size)
             (graph_to_mat g f) ->
      Znth (u * size + i) (graph_to_list g f) =
      Znth i (Znth u (graph_to_mat g f)).
  Proof.
    intros.
    assert (Htemp: 0 <= size) by lia.
    clear Htemp.
    unfold graph_to_list, graph_to_mat in *.
    rewrite <- (Z2Nat.id size) in H by lia.
    generalize dependent u.
    induction (Z.to_nat size).
    1: intros; lia.
    intros. simpl.
    rewrite map_app, concat_app.
    assert (Forall (fun list : list Z => Zlength list = size)
                   (map (vert_to_list g f) (nat_inc_list n))). {
      rewrite Forall_forall in H2 |- *.
      intros. apply H2. simpl. rewrite map_app.
      apply in_or_app. left; trivial.
    }
    specialize (IHn H3).
    destruct H.
    rewrite Nat2Z.inj_succ in H4.
    apply Z.lt_succ_r in H4.
    rewrite Z.le_lteq in H4. destruct H4.
    - repeat rewrite app_Znth1.
      + apply IHn; trivial; lia.
      + rewrite Zlength_map, nat_inc_list_Zlength; lia.
      + rewrite (Zlength_concat _ size); trivial; [|lia].
        rewrite <- (Z.succ_pred (Z.of_nat n)).
        rewrite Z.mul_succ_l.
        apply Z.add_le_lt_mono; try lia.
        apply Zorder.Zmult_le_compat_r; lia.
    - clear IHn. repeat rewrite app_Znth2.
      + rewrite (Zlength_concat _ size); trivial; [|lia].
        replace (u * size + i - Z.of_nat n * size)
          with
            (u * size - Z.of_nat n * size  + i) by lia.
        replace (u * size - Z.of_nat n * size)
          with
            ((u - Z.of_nat n) * size) by lia.
        rewrite Zlength_map, nat_inc_list_Zlength.
        simpl. rewrite app_nil_r.
        replace (u - Z.of_nat n) with 0 by lia.
        rewrite Znth_0_cons.
        replace (0 * size + i) with i by lia.
        reflexivity.
      + rewrite Zlength_map, nat_inc_list_Zlength; lia.
      + rewrite (Zlength_concat _ size); trivial; lia.
  Qed.

  Definition SpaceAdjMatGraph' sh g_contents gaddr : mpred :=
    data_at sh (tarray tint (size * size))
            (map Vint (map Int.repr g_contents))
            gaddr.

  Definition SpaceAdjMatGraph sh (f : E -> E) g gaddr : mpred :=
    SpaceAdjMatGraph' sh (graph_to_list g f) gaddr.

End Spatial_AdjMat_Model_2.


(*
 * --------------------
 * Avtor : Bespalov V.
 * Resheno zadach: 21
 * --------------------
*)

Require Import List.
Require Import Arith.
Require Import Setoid.
Open Scope list_scope.

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

Theorem O_is_min: forall n: nat, 0 <= n.
Proof.
  intros. induction n. apply (le_O_n 0). rewrite simpl_succ.
  apply (le_plus_trans 0 1 n).
  rewrite plus_n_O. apply le_plus_r.
Qed.

Theorem app_assoc: forall (A: Type) (l m n: list A), l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros. induction l. simpl. reflexivity.
  simpl. rewrite IHl. reflexivity.
Qed.

Theorem app_nil_r: forall (A : Type) (l: list A), l ++ nil = l.
Proof.
  intros. induction l. simpl. reflexivity.
  simpl. rewrite IHl. reflexivity.
Qed.

(* 1_1 *)
Theorem app_ge_0: forall (A : Type)
                         (l : list A),
                     0 <= length l.
Proof.
  intros. apply O_is_min.
Qed.

(* 1_2 *)
Theorem app_length: forall (A : Type)
                           (l l' : list A),
             length (l ++ l') = length l + length l'.
Proof.
  intros. induction l. simpl. reflexivity.
  simpl. rewrite IHl. reflexivity.
Qed.

Theorem Свойство_1: forall ls1 ls2 ls3 : list Set,
                       app (app ls1 ls2) ls3
                               = app ls1 (app ls2 ls3).
Proof.
  intros. induction ls1. simpl. reflexivity.
  rewrite <- app_assoc. reflexivity.
Qed.

Theorem Свойство_2: forall (x  : Set)
                           (ls : list Set),
                       app (cons x nil) ls = cons x ls.
Proof.
  intros. simpl. reflexivity.
Qed.

Theorem Свойство_3: forall (ys  : list Set)
                           (x z : Set),
                       app (z :: ys) (x :: nil)
                          = z :: (app ys (x :: nil)).
Proof.
  intros. reflexivity.
Qed.

Theorem rev_length': forall (A : Type)
                            (l : list A),
                        length (rev l) = length l.
Proof.
  intros. induction l. simpl. reflexivity.
  simpl. rewrite app_length.
  simpl. rewrite IHl. rewrite (simpl_succ (length l)).
  rewrite (plus_comm 1 (length l)). reflexivity.
Qed.

Theorem distr_rev': forall (A : Type)
                           (x y : list A),
                       rev (x ++ y) = rev y ++ rev x.
Proof.
  intros. induction x. simpl. rewrite app_nil_r. reflexivity.
  simpl. rewrite IHx. rewrite app_assoc. reflexivity.
Qed.

Theorem rev_involutive': forall (A : Type)
                                (l : list A),
                            rev (rev l) = l.
Proof.
  intros. induction l. simpl. reflexivity.
  simpl. rewrite distr_rev'. rewrite IHl.
  simpl. reflexivity.
Qed.

Theorem rev_one': forall {A : Type}
                         (x : A),
                     rev (x :: nil) = x :: nil.
Proof.
  intros. simpl. reflexivity.
Qed.

Theorem rev_unit': forall (A : Type)
                          (l : list A)
                          (a : A),
                      rev (l ++ a :: nil) = a :: rev l.
Proof.
  intros. rewrite distr_rev'. simpl. reflexivity.
Qed.

Theorem rev_append_rev: forall (A : Type)
                               (l l' : list A),
                         rev_append l l' = rev l ++ l'.
Proof.
  intros until l. induction l. simpl. reflexivity.
  intro. simpl. rewrite <- app_assoc. simpl.
  apply (IHl (a :: l')).
Qed.

Theorem rev_alt: forall (A : Type)
                        (l : list A),
                    rev l = rev_append l nil.
Proof.
  intros. rewrite rev_append_rev. rewrite app_nil_r. reflexivity.
Qed.

Theorem map_app': forall (A B : Type)
                         (f : A -> B)
                         (l l' : list A),
                  map f (l ++ l') = map f l ++ map f l'.
Proof.
  intros. induction l; induction l'. simpl. reflexivity.
  simpl. reflexivity. simpl. rewrite app_nil_r. rewrite app_nil_r.
  reflexivity. simpl. rewrite IHl. simpl. reflexivity.
Qed.

Theorem map_map': forall (A B C : Type)
                         (f : A -> B)
                         (g : B -> C)
                         (l : list A),
         map g (map f l) = map (fun x : A => g (f x)) l.
Proof.
  intros. induction l. simpl. reflexivity. simpl.
  rewrite IHl. reflexivity.
Qed.

Theorem map_ext': forall (A B : Type)
                         (f g : A -> B),
            (forall a : A, f a = g a)
                -> forall l : list A, map f l = map g l.
Proof.
  intros. induction l. simpl. reflexivity.
  simpl. rewrite (H a). rewrite IHl. reflexivity.
Qed.

Theorem map_length': forall (A B : Type)
                            (f : A -> B)
                            (l : list A),
                        length (map f l) = length l.
Proof.
  intros. induction l. simpl. reflexivity. simpl.
  rewrite IHl. reflexivity.
Qed.

Theorem map_rev: forall (A B : Type)
                        (f   : A -> B)
                        (ls  : list A),
                    map f (rev ls) = rev (map f ls).
Proof.
  intros. induction ls. simpl. reflexivity.
  simpl. rewrite map_app'. rewrite IHls.
  simpl. reflexivity.
Qed.

Theorem foldСвойство_1: forall (A B : Type)
                         (l : list B)
                         (e : A)
                         (x : B)
                         (f : B -> A -> A),
                    fold_right f e (x :: nil) = f x e.
Proof.
  intros. unfold fold_right. reflexivity.
Qed.

Theorem fold_right_length: forall (A : Type)
                                  (l : list A),
              fold_right (fun (_ : A) (x : nat) => S x)
                         0
                         l
                  = length l.
Proof.
  intros. induction l. simpl. reflexivity.
  simpl. rewrite IHl. reflexivity.
Qed.

Theorem fold_right_app': forall (A B : Type)
                                (f : A -> B -> B)
                                (l l' : list A)
                                (i : B),
         fold_right f i (l ++ l')
                  = fold_right f (fold_right f i l') l.
Proof.
  intros. induction l. simpl. reflexivity.
  simpl. rewrite <- IHl. reflexivity.
Qed.

Theorem foldСвойство_2: forall (A : Type)
                           (g : A -> A)
                           (l : list A)
                           (e : A),
      map g l = fold_right (fun (x : A)
                                (y : list A) => g x :: y)
                           nil
                           l.
Proof.
  intros. induction l. simpl. reflexivity.
  simpl. rewrite IHl. reflexivity.
Qed.


Require Import Arith List.

Set Implicit Arguments.

(** * A simple expression language and its semantics, the old-fashioned way *)

Inductive exp1 : Set :=
  | Num1 : nat -> exp1
  | Bool1 : bool -> exp1
  | Plus1 : exp1 -> exp1 -> exp1
  | Eq1 : exp1 -> exp1 -> exp1.

Definition eq_nat n1 n2 :=
  if eq_nat_dec n1 n2
    then true
    else false.

Inductive run_exp1 : exp1 -> exp1 -> Prop :=
  | RunNum1 : forall n,
    run_exp1 (Num1 n) (Num1 n)
  | RunBool1 : forall b,
    run_exp1 (Bool1 b) (Bool1 b)
  | RunPlus1 : forall e1 e2 n1 n2,
    run_exp1 e1 (Num1 n1)
    -> run_exp1 e2 (Num1 n2)
    -> run_exp1 (Plus1 e1 e2) (Num1 (n1 + n2))
  | RunEq1 : forall e1 e2 n1 n2,
    run_exp1 e1 (Num1 n1)
    -> run_exp1 e2 (Num1 n2)
    -> run_exp1 (Eq1 e1 e2) (Bool1 (eq_nat n1 n2)).

Inductive type1 : Set :=
  | TyNum1 : type1
  | TyBool1 : type1.

Inductive hasType1 : exp1 -> type1 -> Prop :=
  | HT_Num1 : forall n,
    hasType1 (Num1 n) TyNum1
  | HT_Bool1 : forall b,
    hasType1 (Bool1 b) TyBool1
  | HT_Plus1 : forall e1 e2,
    hasType1 e1 TyNum1
    -> hasType1 e2 TyNum1
    -> hasType1 (Plus1 e1 e2) TyNum1
  | HT_Eq1 : forall e1 e2,
    hasType1 e1 TyNum1
    -> hasType1 e2 TyNum1
    -> hasType1 (Eq1 e1 e2) TyBool1.

Hint Constructors run_exp1.

Inductive valueOf1 : exp1 -> type1 -> Prop :=
  | VO_Num1 : forall n, valueOf1 (Num1 n) TyNum1
  | VO_Bool1 : forall b, valueOf1 (Bool1 b) TyBool1.

Hint Constructors valueOf1.

Ltac ics H := inversion H; clear H; subst.

Ltac inverter1 :=
  match goal with
    | [ H : run_exp1 (Num1 _) _ |- _ ] => ics H
    | [ H : run_exp1 (Bool1 _) _ |- _ ] => ics H
    | [ H : run_exp1 (Plus1 _ _) _ |- _ ] => ics H
    | [ H : run_exp1 (Eq1 _ _) _ |- _ ] => ics H
  end.

Ltac magic_solver1 := repeat progress (firstorder eauto; repeat inverter1).

Theorem run_exp1_preserves : forall (e : exp1) (t : type1),
  hasType1 e t
  -> forall e', run_exp1 e e'
    -> valueOf1 e' t.
  induction 1; magic_solver1.
Qed.

Ltac use_preserves1 :=
  match goal with
    | [ H1 : hasType1 ?e1 _, H2 : run_exp1 ?e1 _ |- _ ] =>
      generalize (run_exp1_preserves H1 H2); clear H1; intro H1
  end.

Ltac inverter1' :=
  match goal with
    | [ H : valueOf1 _ TyNum1 |- _ ] => ics H
    | [ H : valueOf1 _ TyBool1 |- _ ] => ics H
  end.

Ltac magic_solver1' := repeat progress (magic_solver1; repeat use_preserves1; repeat inverter1').

Theorem run_exp1_terminates : forall (e : exp1) (t : type1),
  hasType1 e t
  -> exists e', run_exp1 e e'.
  induction 1; magic_solver1'.
Qed.

(** ** Let's start some running examples: *)

Hint Constructors hasType1.

Definition one : exp1 := Num1 1.

Theorem one_type : hasType1 one TyNum1.
  unfold one; auto.
Qed.

Print one_type.

Theorem one_result1 : run_exp1 one one.
  unfold one; auto.
Qed.

Print one_result1.

Definition zero : exp1 := Num1 0.
Definition test : exp1 := Eq1 (Plus1 one zero) (Plus1 zero one).

Theorem test_type : hasType1 test TyBool1.
  unfold test, zero, one; auto.
Qed.

Print test_type.

Theorem test_result1 : run_exp1 test (Bool1 true).
  unfold test, zero, one.
  change true with (eq_nat (1 + 0) (0 + 1)); auto.
Qed.

Print test_result1.

(** * Now let's try using a function instead of a relation.... *)

Inductive value2 : Set :=
  | VNum2 : nat -> value2
  | VBool2 : bool -> value2.

Fixpoint run_exp2 (e : exp1) : option value2 :=
  match e with
    | Num1 n => Some (VNum2 n)
    | Bool1 b => Some (VBool2 b)
    | Plus1 e1 e2 =>
      match run_exp2 e1, run_exp2 e2 with
	| Some (VNum2 n1), Some (VNum2 n2) =>
	  Some (VNum2 (n1 + n2))
	| _, _ => None
      end
    | Eq1 e1 e2 =>
      match run_exp2 e1, run_exp2 e2 with
	| Some (VNum2 n1), Some (VNum2 n2) =>
	  Some (VBool2 (eq_nat n1 n2))
	| _, _ => None
      end
  end.

Inductive valueOf2 : value2 -> type1 -> Prop :=
  | VO_Num2 : forall n, valueOf2 (VNum2 n) TyNum1
  | VO_Bool2 : forall b, valueOf2 (VBool2 b) TyBool1.

Hint Constructors valueOf2.

Ltac inverter2 :=
  match goal with
    | [ H : hasType1 (Num1 _) _ |- _ ] => ics H
    | [ H : hasType1 (Bool1 _) _ |- _ ] => ics H
    | [ H : hasType1 (Plus1 _ _) _ |- _ ] => ics H
    | [ H : hasType1 (Eq1 _ _) _ |- _ ] => ics H
  end.

Ltac magic_solver2 := repeat progress (simpl in *; subst; firstorder eauto; repeat inverter2).

Theorem run_exp2_preserves : forall (e : exp1) (t : type1),
  hasType1 e t
  -> match run_exp2 e with
       | None => True
       | Some v => valueOf2 v t
     end.
  intros until e;
    functional induction run_exp2 e;
      magic_solver2.
Qed.

Ltac use_preserves2 :=
  match goal with
    | [ H1 : hasType1 ?e1 _ |- _ ] =>
      generalize (run_exp2_preserves H1); clear H1
  end.

Ltac rewriter :=
  match goal with
    | [ H : _ |- _ ] => rewrite H
  end.

Ltac inverter2' :=
  match goal with
    | [ H : valueOf2 _ TyNum1 |- _ ] => ics H
    | [ H : valueOf2 _ TyBool1 |- _ ] => ics H
  end.

Ltac magic_solver2' := repeat progress (magic_solver2; repeat use_preserves2; repeat rewriter; repeat inverter2').

Theorem run_exp2_terminates : forall (e : exp1) (t : type1),
  hasType1 e t
  -> exists v, run_exp2 e = Some v.
  induction 1; magic_solver2'.
Qed.

(** ** Back to our running examples.... *)

Theorem one_result2 : run_exp2 one = Some (VNum2 1).
  reflexivity.
Qed.

Print one_result2.

Theorem test_result2 : run_exp2 test = Some (VBool2 true).
  reflexivity.
Qed.

Print test_result2.

(** * Time to wheel in the dependent types! *)

Definition value3 (t : type1) : Set :=
  match t with
    | TyNum1 => nat
    | TyBool1 => bool
  end.

Definition run_exp3 : forall (e : exp1) (t : type1), hasType1 e t -> value3 t.
  refine (fix run_exp3 (e : exp1) (t : type1) {struct e} : hasType1 e t -> value3 t :=
    match e return (hasType1 e t -> value3 t) with
      | Num1 n =>
	match t return (hasType1 (Num1 n) t -> value3 t) with
	  | TyNum1 => fun _ => n
	  | _ => fun pf => False_rec _ _
	end
      | Bool1 b =>
	match t return (hasType1 (Bool1 b) t -> value3 t) with
	  | TyBool1 => fun _ => b
	  | _ => fun pf => False_rec _ _
	end
      | Plus1 e1 e2 =>
	match t return (hasType1 (Plus1 e1 e2) t -> value3 t) with
	  | TyNum1 => fun pf => run_exp3 e1 TyNum1 _ + run_exp3 e2 TyNum1 _
	  | _ => fun pf => False_rec _ _
	end
      | Eq1 e1 e2 =>
	match t return (hasType1 (Eq1 e1 e2) t -> value3 t) with
	  | TyBool1 => fun pf => eq_nat (run_exp3 e1 TyNum1 _) (run_exp3 e2 TyNum1 _)
	  | _ => fun pf => False_rec _ _
	end
    end); magic_solver2.
Defined.

(** ** And the running examples: *)

Theorem one_result3 : run_exp3 one_type = 1.
  reflexivity.
Qed.

Print one_result3.

Theorem test_result3 : run_exp3 test_type = true.
  reflexivity.
Qed.

Print test_result3.

(** * Finally, the slickest formalization of this language :-) *)

Inductive exp4 : type1 -> Set :=
  | Num4 : nat -> exp4 TyNum1
  | Bool4 : bool -> exp4 TyBool1
  | Plus4 : exp4 TyNum1 -> exp4 TyNum1 -> exp4 TyNum1
  | Eq4 : exp4 TyNum1 -> exp4 TyNum1 -> exp4 TyBool1.

Fixpoint run_exp4 (t : type1) (e : exp4 t) {struct e} : value3 t :=
  match e in (exp4 t) return (value3 t) with
    | Num4 n => n
    | Bool4 b => b
    | Plus4 e1 e2 => run_exp4 e1 + run_exp4 e2
    | Eq4 e1 e2 => eq_nat (run_exp4 e1) (run_exp4 e2)
  end.

(** ** And the running examples: *)

Definition one4 : exp4 TyNum1 := Num4 1.

Theorem one_result4 : run_exp4 one4 = 1.
  reflexivity.
Qed.

Print one_result4.

Definition zero4 : exp4 TyNum1 := Num4 0.
Definition test4 : exp4 TyBool1 := Eq4 (Plus4 one4 zero4) (Plus4 zero4 one4).

Theorem test_result4 : run_exp4 test4 = true.
  reflexivity.
Qed.

Print test_result4.

(** * Now it's time for some lambda calculus. *)

Require Import LambdaTamer.LambdaTamer.
(** I haven't released this library yet.  If you want to run this code yourself,
  * e-mail me.... *)

Inductive ty : Set :=
  | Nat : ty
  | Arrow : ty -> ty -> ty.

Inductive term : list ty -> ty -> Set :=
  | Const : forall (G : list ty),
    nat
    -> term G Nat

  | EVar : forall (G : list ty) (t : ty),
    Var G t
    -> term G t
  | App : forall (G : list ty) (dom ran : ty),
    term G (Arrow dom ran)
    -> term G dom
    -> term G ran
  | Lam : forall (G : list ty) (dom ran : ty),
    term (dom :: G) ran
    -> term G (Arrow dom ran).

Fixpoint tyDenote (t : ty) : Set :=
  match t with
    | Nat => nat
    | Arrow t1 t2 => tyDenote t1 -> tyDenote t2
  end.

Fixpoint termDenote (G : list ty) (t : ty) (e : term G t) {struct e}
  : Subst tyDenote G -> tyDenote t :=
  match e in (term G t) return (Subst tyDenote G -> tyDenote t) with
    | Const _ n => fun _ => n
    | EVar _ _ x => fun s => VarDenote x s
    | App _ _ _ e1 e2 => fun s => (termDenote e1 s) (termDenote e2 s)
    | Lam _ _ _ e' => fun s => fun x => termDenote e' (SCons _ x s)
  end.

(** ** Some examples *)

Definition two : term nil Nat := Const _ 2.

Definition id : term nil (Arrow Nat Nat) := Lam (EVar (First _ _)).

Definition app_id : term nil Nat := App id two.

Eval compute in termDenote app_id (SNil _).

Definition call : term nil (Arrow (Arrow Nat Nat) (Arrow Nat Nat)) :=
  Lam (Lam (App (EVar (Next _ (First _ _))) (EVar (First _ _)))).

Eval compute in termDenote (App (App call id) two) (SNil _).

(** * A tiny compiler and its correctness proof *)

Inductive let_term : list ty -> ty -> Set :=
  | LConst : forall (G : list ty),
    nat
    -> let_term G Nat

  | LVar : forall (G : list ty) (t : ty),
    Var G t
    -> let_term G t
  | LApp : forall (G : list ty) (dom ran : ty),
    let_term G (Arrow dom ran)
    -> let_term G dom
    -> let_term G ran
  | LLam : forall (G : list ty) (dom ran : ty),
    let_term (dom :: G) ran
    -> let_term G (Arrow dom ran)

  | LLet : forall (G : list ty) (bound body : ty),
    let_term G bound
    -> let_term (bound :: G) body
    -> let_term G body.

Fixpoint let_termDenote (G : list ty) (t : ty) (e : let_term G t) {struct e}
  : Subst tyDenote G -> tyDenote t :=
  match e in (let_term G t) return (Subst tyDenote G -> tyDenote t) with
    | LConst _ n => fun _ => n
    | LVar _ _ x => fun s => VarDenote x s
    | LApp _ _ _ e1 e2 => fun s => (let_termDenote e1 s) (let_termDenote e2 s)
    | LLam _ _ _ e' => fun s => fun x => let_termDenote e' (SCons _ x s)

    | LLet _ _ _ e1 e2 => fun s => let_termDenote e2 (SCons _ (let_termDenote e1 s) s)
  end.

Fixpoint compiler (G : list ty) (t : ty) (e : let_term G t) {struct e} : term G t :=
  match e in (let_term G t) return (term G t) with
    | LConst _ n => Const _ n
    | LVar _ _ x => EVar x
    | LApp _ _ _ e1 e2 => App (compiler e1) (compiler e2)
    | LLam _ _ _ e' => Lam (compiler e')

    | LLet _ _ _ e1 e2 => App (Lam (compiler e2)) (compiler e1)
  end.

Check ext_eqT.

Theorem compiler_correct : forall G t (e : let_term G t),
  termDenote (compiler e) = let_termDenote e.
  induction e; simpl; intuition; repeat (apply ext_eqT; intro);
    repeat rewriter; trivial.
Qed.


Require Import Classical.
From src Require Export Props_LC.
From src Require Export Props_LI.
From src Require Export Props_LM.

(* Parte 5 de la tarea. *)

(* Lema auxiliar. El otro lado de Modus Tollens
 * Propiedad de lógica clásica *)
Lemma modus_tollens_2: forall (A B: Prop), (~A -> ~B) -> (B -> A).
Proof.
intros.
assert (~~B -> ~~A).
+ apply modus_tollens.
  trivial.
+ assert (~~B).
  - apply double_neg_intro.
    trivial.
  - apply H1 in H2.
    apply NNPP.
    trivial.
Qed.

(* Ejercicio 5a
 * Se usó lógica clásica. *)
Theorem fivea: forall (A B C D : Prop), (A -> B) /\ (~(A \/ C) -> D) /\
(A \/ B -> C) -> (~D -> C).
Proof.
intros.
destruct H.
destruct H1.
apply modus_tollens in H1.
+ apply NNPP in H1.
  destruct H1.
  - assert (A \/ B).
    * left; trivial.
    * apply H2; trivial.
  - trivial.
+ trivial.
Qed.

(* Ejercicio 5b
 * Se usó lógica clásica *)
Theorem fiveb: forall (A B C D: Prop), A \/ B -> (~D -> C) /\ (~B -> ~A) -> (C -> ~B) -> D.
Proof.
intros.
destruct H0.
destruct H.
+ assert (A -> B).
  - apply modus_tollens_2.
    trivial.
  - apply H3 in H.
    assert (B -> ~C).
    * apply modus_tollens_2.
      intro.
      apply NNPP in H4.
      apply H1.
      trivial.
    * apply H4 in H.
      assert (~C -> ~~D).
      ++ apply modus_tollens.
         trivial.
      ++ apply H5 in H.
         apply NNPP.
         trivial.
+ assert (B -> ~C).
  - apply modus_tollens_2.
    intro.
    apply H1.
    apply NNPP; trivial.
  - apply H3 in H.
    assert (~C -> D).
    * apply modus_tollens_2.
      intro.
      apply H0 in H4.
      apply double_neg_intro.
      trivial.
    * apply H4 in H.
      trivial.
Qed.

(* Ejercicio 5c
 * Se utilizó lógica clásica (modus tollens).*)
Theorem fivec: forall (T: Type) (a: T) (P B R: T -> Prop),
(forall x:T, P x -> ~B x) -> R a -> (forall x: T, R x -> B x) -> ~P a.
Proof.
intros.
intro.
apply H in H2.
assert (forall x: T, ~B x -> ~R x).
+ intro.
  apply modus_tollens.
  apply H1.
+ apply H3 in H2.
  contradiction.
Qed.

(* Ejercicio 5d
 * Se usó lógica clásica *)
Theorem fived: forall (T1: Type) (P B R S T: T1 -> Prop),
(forall x:T1, P x \/ B x -> ~R x) /\ (forall x:T1, S x -> R x) -> (forall x:T1, P x -> ~S x \/ T x).
Proof.
intros.
destruct H.
assert (P x \/ B x).
+ left; trivial.
+ apply H in H2.
  assert (forall x:T1, ~R x -> ~S x).
  - intro.
    apply modus_tollens.
    apply H1.
  - left;apply H3.
    trivial.
Qed.

(* Ejercicio 5e
 * La propiedad no se cumple para T vacío, por lo que agregamos la hipótesis
 * de que existe alguien en T.
 * Se usó lógica minimal. *)
Theorem fivee: forall (T: Type) (x: T) (P B: T -> Prop),(forall x:T, P x /\ exists y:T, B y) -> (exists x:T, P x /\ B x).
Proof.
intros.
apply H in x.
destruct x.
exists x.
split.
+ apply H.
+ trivial.
Qed.

(* Ejercicio 5f
 * Se usó lógica minimal *)
Theorem fivef: forall (T1 T2: Type) (P: T1 -> Prop) (R: T1 -> T2 -> Prop),
(forall x:T1, exists y:T2, P x -> R x y) -> (forall x:T1, P x -> exists y:T2, R x y).
Proof.
intros.
assert (exists y:T2, P x -> R x y).
+ apply H.
+ destruct H1.
  exists x0.
  apply H1; trivial.
Qed.

(* Ejercicio 5g
 * Se usó lógica minimal.*)
Theorem fiveg: forall (T : Type) (P B: T -> Prop),
(forall x:T, P x -> ~B x) -> (~exists x:T, P x /\ B x).
Proof.
intros.
intro.
destruct H0.
destruct H0.
apply H in H0.
apply H0.
trivial.
Qed.

(* Ejercicio 5h
 * Se usó lógica minimal. *)
Theorem fiveh: forall (T1 T2: Type) (P: T1 -> T2 -> Prop),
(exists x:T1, forall y:T2, P x y) -> (forall y:T2, exists x:T1, P x y).
Proof.
intros.
destruct H.
exists x.
apply H.
Qed.


Require Import Setoid.
Require Import Morphisms.
Require Import Coq.Program.Basics.
Require Import NArith.
Require Import List.
Import ListNotations.
Open Scope list.
Require Import Lia.

Unset Printing Records.

From Ordinal Require Import Defs.
From Ordinal Require Import Operators.
From Ordinal Require Import Arith.
From Ordinal Require Import Cantor.
From Ordinal Require Import Fixpoints.
From Ordinal Require Import Reflection.
From Ordinal Require Import VeblenDefs.
From Ordinal Require Import VeblenCon.
From Ordinal Require Import VeblenFacts.

Open Scope ord_scope.

Fixpoint vtower_fin (n:nat) : Ord -> Ord :=
  match n with
  | O    => addOrd 1
  | S n' => fun x => veblen (vtower_fin n') (1+x) 0
  end.

Definition SmallVeblenOrdinal := supOrd (fun i => vtower_fin i 0).

Lemma vtower_fin_succ n x : vtower_fin (S n) x = veblen (vtower_fin n) (1+x) 0.
Proof.
  reflexivity.
Qed.

Lemma vtower_fin_normal n :
  normal_function (vtower_fin n).
Proof.
  induction n; simpl.
  - apply onePlus_normal.
  - apply veblen_first_onePlus_normal; auto.
Qed.

Lemma vtower_fin_eq_mor n x y :
  x ≈ y -> vtower_fin n x ≈ vtower_fin n y.
Proof.
  intros; split; apply normal_monotone; auto.
  apply vtower_fin_normal.
  apply H.
  apply vtower_fin_normal.
  apply H.
Qed.

Lemma vtower_fin_complete n :
  forall x, complete x -> complete (vtower_fin n x).
Proof.
  apply normal_complete. apply vtower_fin_normal; auto.
Qed.

Add Parametric Morphism n : (veblen (vtower_fin n))
    with signature ord_le ==> ord_le ==> ord_le
      as veblen_vtower_fin_le_mor.
Proof.
  intros.
  apply veblen_le_mor; auto.
  intros; apply normal_monotone; auto.
  apply vtower_fin_normal; auto.
Qed.

Add Parametric Morphism n : (veblen (vtower_fin n))
    with signature ord_eq ==> ord_eq ==> ord_eq
      as veblen_vtower_fin_eq_mor.
Proof.
  intros.
  apply veblen_eq_mor; auto.
  intros; apply normal_monotone; auto.
  apply vtower_fin_normal; auto.
Qed.

Lemma zero_lt_onePlus x : 0 < 1 + x.
Proof.
  apply ord_lt_le_trans with 1; [ apply succ_lt | apply addOrd_le1 ].
Qed.

Local Hint Resolve
      vtower_fin_complete
      vtower_fin_normal
      veblen_complete
      veblen_normal
      veblen_first_normal
      veblen_first_onePlus_normal
      normal_monotone
      onePlus_normal
      powOmega_normal
      addOrd_complete
      addOrd_increasing
      succ_complete
      zero_complete
      natOrdSize_complete
      zero_lt_onePlus
  : core.

Lemma vtower_fin_succ_monotone :
  forall n i, complete i -> vtower_fin n i ≤ vtower_fin (S n) i.
Proof.
  induction n; simpl; intros.
  - apply (onePlus_least_normal (fun i => veblen (addOrd 1) (1+i) 0)); auto.
  - apply veblen_monotone_func; auto.
Qed.

Lemma vtower_fin_index_monotone :
  forall m n, (m <= n)%nat ->
    forall i, complete i -> vtower_fin m i ≤ vtower_fin n i.
Proof.
  intros. induction H; auto with ord.
  rewrite IHle.
  apply vtower_fin_succ_monotone; auto.
Qed.

Lemma vtower_fin_fixpoints_succ n : forall a x,
  0 < a ->
  complete a ->
  complete x ->
  veblen (vtower_fin (S n)) a x ≈ veblen (vtower_fin n) (veblen (vtower_fin (S n)) a x) 0.
Proof.
  intros.
  simpl.
  rewrite <- (veblen_fixpoints _ (vtower_fin_normal (S n)) 0 a x) at 1; auto.
  rewrite veblen_zero.
  simpl.
  rewrite onePlus_veblen; auto.
  reflexivity.
Qed.

Theorem vtower_fin_fixpoints n : forall m a x,
  (m < n)%nat ->
  0 < a ->
  complete a ->
  complete x ->
  veblen (vtower_fin n) a x ≈ veblen (vtower_fin m) (veblen (vtower_fin n) a x) 0.
Proof.
  destruct n.
  - intros. inversion H.
  - intros. inversion H.
    + subst m. apply vtower_fin_fixpoints_succ; auto.
    + split; simpl.
      * apply (normal_inflationary (fun i => veblen (vtower_fin m) i 0)); auto.
      * rewrite <- (veblen_fixpoints _ (vtower_fin_normal (S n)) 0 a x) at 2; auto.
        rewrite veblen_zero.
        simpl.
        rewrite onePlus_veblen; auto.
        apply veblen_monotone_func; auto.
        apply vtower_fin_index_monotone; auto.
        lia.
Qed.

Lemma vtower_fin_0_0 : vtower_fin 0 0 ≈ 1.
Proof.
  simpl.
  rewrite addOrd_zero_r.
  reflexivity.
Qed.

Lemma vtower_fin_1_func : forall x, complete x -> vtower_fin 1 x ≈ expOrd ω (1+x).
Proof.
  simpl; intros.
  rewrite veblen_onePlus; auto.
  rewrite addOrd_zero_r.
  reflexivity.
Qed.

Lemma vtower_fin_1_0 : vtower_fin 1 0 ≈ ω.
Proof.
  rewrite vtower_fin_1_func; auto.
  rewrite addOrd_zero_r.
  rewrite expOrd_one'; auto with ord.
  apply (index_lt _ 0%nat).
Qed.

Lemma vtower_fin_2_func : forall x, complete x -> vtower_fin 2 x ≈ veblen powOmega (1+x) 0.
Proof.
  intros.
  rewrite vtower_fin_succ.
  simpl.
  rewrite (veblen_func_onePlus (fun i => veblen (addOrd 1) i 0)); auto.
  split; apply veblen_monotone_func; auto.
  intros; rewrite veblen_onePlus; auto.
  rewrite addOrd_zero_r. reflexivity.
  intros; rewrite veblen_onePlus; auto.
  rewrite addOrd_zero_r. reflexivity.
Qed.

Lemma vtower_fin_2_0 : vtower_fin 2 0 ≈ ε 0.
Proof.
  rewrite vtower_fin_2_func; auto.
  rewrite addOrd_zero_r.
  rewrite veblen_succ; auto.
  unfold ε.
  split; apply enum_fixpoints_func_mono; auto;
    intros; rewrite veblen_zero; auto with ord.
Qed.

Lemma vtower_fin_3_func :
  forall x, complete x -> vtower_fin 3 x ≈ veblen (fun i => veblen powOmega i 0) (1+x) 0.
Proof.
  intros.
  rewrite vtower_fin_succ.
  symmetry.
  rewrite <- veblen_func_onePlus; auto.
  split; apply veblen_monotone_func; auto;
    intros; rewrite vtower_fin_2_func; auto with ord.
Qed.

Lemma vtower_fin_3_0 : vtower_fin 3 0 ≈ Γ 0.
Proof.
  rewrite vtower_fin_3_func; auto.
  transitivity (veblen (fun i : Ord => veblen powOmega i 0) 1 0).
  apply veblen_eq_mor; auto with ord.
  intros; apply veblen_monotone_first; auto.
  rewrite addOrd_zero_r; auto with ord.
  rewrite veblen_succ; auto.
  unfold Γ.
  split; apply enum_fixpoints_func_mono; auto;
    intros; rewrite veblen_zero; auto with ord.
Qed.


Set Implicit Arguments.
Require Import ZArith.

Inductive htree (A:Set) : nat -> Set :=
  | hleaf : htree A 0
  | hnode : forall n:nat, A -> htree A n -> htree A n -> htree A (S n).

Check htree_ind.
(*
forall (A : Set) (P : forall n : nat, htree A n -> Prop),
  P 0 (hleaf A) -> (forall (n : nat) (a : A) (left : htree A n), P n left -> forall right : htree A n, P n right -> P (S n) (hnode a left right))
  -> forall (n : nat) (h : htree A n), P n h
*)
Inductive Z_btree : Set :=
  | Z_leaf : Z_btree
  | Z_bnode : Z -> Z_btree -> Z_btree -> Z_btree.

Fixpoint htree_to_btree (n:nat)(t: htree Z n) : Z_btree :=
  match t with
    | hleaf             => Z_leaf
    | hnode n v t1 t2   => Z_bnode v (htree_to_btree t1) (htree_to_btree t2)
  end.

Fixpoint invert (A:Set)(n:nat)(t: htree A n) : htree A n :=
  match t in htree _ x return htree A x with
    | hleaf             => hleaf A
    | hnode n v t1 t2   => hnode v (invert t2) (invert t1)
  end.

Definition left (n:nat)(t: htree nat n) :=
  match t in htree _ x return htree nat x with
    | hleaf             =>  hleaf nat
    | hnode n v t1 t2   =>  t2
  end.

(*
Lemma injection: forall (n:nat)(t1 t2 t3 t4:htree nat n),
  hnode 0 t1 t2 = hnode 0 t3 t4 -> t1 = t3.
Proof.
  intros n t1 t2 t3 t4 H. discriminate H.
*)


Require Import EquivDec.
Import ListNotations.

(** Alphabet of two letters a b *)

Module BiLetters <: FiniteOrderedType.
 Inductive letter := a | b.
 Definition enumeration := [a;b].
 Lemma enumeration_spec : forall (x:letter), In x enumeration.
 Proof.
  intros [ ]; compute; intuition.
 Qed.
 Definition t := letter.
 Definition eq := @eq letter.
 Definition compare x y :=
   match x, y with
   | a,a | b,b => Eq
   | a,b => Lt
   | b,a => Gt
   end.
 Definition lt x y := compare x y = Lt.
 Definition eq_equiv := @eq_equivalence letter.
 Lemma lt_compat : Proper (eq==>eq==>iff) lt.
 Proof. now intros ? ? -> ? ? ->. Qed.
 Global Instance lt_strorder : StrictOrder lt.
 Proof. split; red. now intros [ ]. now intros [ ] [ ] [ ]. Qed.
 Lemma compare_spec (x y : letter) :
  CompareSpec (x=y) (lt x y) (lt y x) (compare x y).
 Proof. destruct x, y; now constructor. Qed.
 Definition eq_dec (x y : letter) : { x = y } + { x <> y }.
 Proof. destruct x, y; auto; now right. Qed.
 Definition eqb x y :=
   match x,y with a,a | b,b => true | _,_ => false end.
 Lemma eqb_eq (x y:t) : eqb x y = true <-> x = y.
 Proof. now destruct x,y. Qed.
End BiLetters.
Import BiLetters.

Module Import Regexp := RegEquivDec(BiLetters).

Coercion Letter : letter >-> re.

Bind Scope re_scope with re.
Delimit Scope re_scope with re.
Open Scope re.

(* Cat · \cdot
   Star ★ \bigstar
   Not ¬ \neg
*)

Local Infix "·" := Cat (at level 40, left associativity) : re_scope.
Local Infix "+" := Or : re_scope.
Local Notation "r ★" := (Star r) (at level 30, right associativity) : re_scope.
Local Notation "0" := Void : re_scope.
Local Notation "1" := Epsilon : re_scope.
Local Notation "¬ r" := (Not r) (at level 35, no associativity) : re_scope.

Definition a_regexp := a★·b★.

Compute matching a_regexp [a;a;b;b;b].
Compute matching a_regexp [a;a;a;b;b;b;a].

(* The bound on the derivative number is quickly huge *)
Compute derivs_bound a_regexp. (* 4608 *)
(* In fact, there's lots of redundancy in [over_derivs] : *)
Compute REs.cardinal (list2set (over_derivs a_regexp)).
(* ... only 16 distincts possible derivatives *)

(* Only 3 are really derivatives *)
Compute REs.elements (exact_derivs a_regexp).

Compute is_empty a_regexp. (* false : a_regexp isn't equivalent to Void *)

Compute is_equiv (a★·a★) (a★). (* true *)
Compute is_equiv (a·a★) (a★). (* false *)

(* all the 3 previous derivatives are distinct up to equiv,
   hence the minimal automata reckognizing a*.b* will have 3 states
   (including a sink state) *)
Compute minimal_derivs a_regexp.

(* You can try you own regexps ...
   If a alphabet with only two letters isn't enough, you could
   adapt to use Coq's Ascii type ! *)


(*
  Autor(s):
    Andrej Dudenhefner (1)
    Johannes Hostert (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

Require Import Arith Lia List.
From Undecidability.DiophantineConstraints Require Import H10C.

Set Default Proof Using "Type".

(* Utils for H10UPC *)

(* This section contains useful functions and lemmas for proofs later on. *)
Section Utils.

  (* In the relation h10upc_sem_direct ((a,b),(c,d)), d is a function of b. *)
  Lemma c2_full (x:nat) : {y:nat | x * S x = y+y}.
  Proof.
    induction x as [|x [y' IH]].
    - exists 0. lia.
    - exists (y'+x+1). nia.
  Qed.

  Definition c2 (x:nat) := match (c2_full x) with exist _ y _ => y end.

  Lemma c2_descr (x:nat) : x * S x = c2 x + c2 x.
  Proof.
    unfold c2. now destruct (c2_full x).
  Qed.

  (* Inversion lemma for h10upc_sem_direct (basically axiom 2) *)
  Lemma h10upc_inv (a b c d : nat) : h10upc_sem_direct ((a,S b),(c,d)) ->
           {c':nat & {d':nat & h10upc_sem_direct ((a,b),(c',d'))
                               /\ S c' = c /\ d' + b + 1 = d}}.
  Proof.
  intros [Hl Hr].
  exists (a + S b). exists (c2 b).
  repeat split.
  - lia.
  - apply c2_descr.
  - lia.
  - enough (2*(c2 b + b + 1) = d+d) by nia. rewrite <- Hr.
    cbn. rewrite Nat.mul_comm. cbn. symmetry.
    pose (c2_descr b) as Hb. nia.
  Qed.

  (* h10upc_sem_direct is irreflexive *)
  Lemma h10_rel_irref (p:nat*nat) : ~ (h10upc_sem_direct (p,p)).
  Proof.
  intros H. destruct p as [a b]. cbn in H. lia.
  Qed.

  (* Utility function for finding the highest variable in a h10upc constraint *)
  Definition highest_var (x:h10upc) := match x with ((a,b),(c,d)) => Nat.max a (Nat.max b (Nat.max c d)) end.
  Lemma highest_var_descr (x:h10upc) : let hv := highest_var x in match x with ((a,b),(c,d)) => a <= hv /\ b <= hv /\ c <= hv /\ d <= hv end.
  Proof.
  destruct x as [[a b] [c d]]. cbn. repeat split; lia.
  Qed.

  (* Utility function for finding the highest variable in a h10upc constraint collection *)
  Fixpoint highest_var_list (x:list h10upc) := match x with nil => 0 | x::xr => Nat.max (highest_var x) (highest_var_list xr) end.
  Lemma highest_var_list_descr (x:list h10upc) (h:h10upc) : In h x ->  highest_var h <= highest_var_list x.
  Proof.
  induction x as [|hh x IH].
  - intros [].
  - intros [hhh|hx].
    + cbn. rewrite hhh. lia.
    + cbn. specialize (IH hx). lia.
  Qed.

  (* Utility function for finding the highest value in an environment, considering variables up to some n *)
  Fixpoint highest_num (env: nat -> nat) (n:nat) : nat := match n with 0 => env 0 | S n => Nat.max (env (S n)) (highest_num env n) end.
  Lemma highest_num_descr (env:nat -> nat) (n:nat) (m:nat) : m <= n -> env m <= highest_num env n.
  Proof.
  induction n as [|n IH].
  - intros Hm. assert (m=0) as Hm0. 1:lia. cbn. rewrite Hm0. lia.
  - intros HmSn. cbn. destruct (Nat.eq_dec (S n) m) as [Heq|Hneq].
    + rewrite <- Heq. lia.
    + assert (m <= n) as Hmn. 1:lia. specialize (IH Hmn). lia.
  Qed.

End Utils.

(* This section contains an alternative characterization of h10upc_sem_direct and some meta-theory.
    h10upc_sem_direct is the equational characterization of the H10UPC relation.
    h10upc_ind is presented as an alternative, inductive characterization of that relation. *)
Section InductiveCharacterization.

  (* Characterizing equations for h10upc_sem_direct *)

  Definition ax1 (P : (nat*nat)*(nat*nat) -> Prop) := forall a c, P ((a,0),(c,0)) <-> a + 1 = c.
  Definition ax2 (P : (nat*nat)*(nat*nat) -> Prop) := forall a b c d , (b <> 0 /\ P ((a,b),(c,d))) <->
               (exists b' c' d', P ((a,b'),(c',d')) /\ P ((d',b'),(d,d')) /\ P ((b',0),(b,0)) /\ P ((c',0),(c,0))).
  Definition ax2w (P : (nat*nat)*(nat*nat) -> Prop) := forall a b c d ,
               (exists b' c' d', P ((a,b'),(c',d')) /\ P ((d',b'),(d,d')) /\ P ((b',0),(b,0)) /\ P ((c',0),(c,0)))
               -> (P ((a,b),(c,d))).
  Definition ax3 (P : (nat*nat)*(nat*nat) -> Prop) := forall a c d, P ((a,0),(c,d)) -> d = 0.

  Definition sat P := ax1 P /\ ax2 P /\ ax3 P.
  Definition satw P := ax1 P /\ ax2w P.

  (* Inductive definition of h10upc_sem_direct *)
  Inductive h10upc_ind : nat -> nat -> nat -> nat -> Prop :=
    base : forall a, h10upc_ind a 0 (S a) 0
  | step : forall a b c d b' c' d', h10upc_ind a b' c' d'
                                 -> h10upc_ind d' b' d d'
                                 -> h10upc_ind b' 0 b 0
                                 -> h10upc_ind c' 0 c 0
                                 -> h10upc_ind a b c d.

  (* Prove that h10upc_ind and h10upc_sem_direct are equivalent. *)
  (* First step: Show that there is no k < 0, since h10upc_ind is inductive. *)
  Lemma h10upc_ind_not_less_0 : forall k, h10upc_ind k 0 0 0 -> False.
  Proof.
  enough (forall a b c d, h10upc_ind a b c d -> b = 0 -> c = 0 -> d = 0 -> False) as H.
  1: intros k H1; apply (H k 0 0 0 H1); easy.
  intros a b c d H.
  unshelve eapply (h10upc_ind_ind
                   (fun a b c d => b = 0 -> c = 0 -> d = 0 -> False)
                   _ _ a b c d H); clear a b c d H.
  - intros a Hb Hc Hd. lia.
  - intros a b c d b' c' d' Hab'c'd' Eab'c'd' Hd'b'dd' Ed'b'dd' Hb'zbz Eb'zbz Hc'0c0 Ec'0c0 Hb Hc Hd; cbn in *; subst.
    apply Ec'0c0; easy.
  Qed.

  (* Next step: show equivalence for the base case. *)
  Lemma base_equiv a c d : h10upc_sem_direct ((a,0),(c,d)) <-> h10upc_ind a 0 c d.
  Proof. split.
  * intros [H1 H2]. assert (d=0) as -> by lia. assert (c = S a) as -> by lia. apply base.
  * intros H. inversion H as [a' H1|a' b' c' d' b'' c'' d'' H1 H2 H3 H4 H5].
    - cbn. lia.
    - exfalso. now eapply h10upc_ind_not_less_0 with b''.
  Qed.

  (* Last step: show equivalence for the "step" case. *)
  Lemma h10_equiv a b c d  : h10upc_sem_direct ((a,b),(c,d)) <-> h10upc_ind a b c d.
  Proof. induction b as [|b IH] in a,c,d|-*.
  - apply base_equiv.
  - symmetry. split.
    * intros H. inversion H; subst.
      rewrite <- base_equiv in H2, H3. cbn in H2,H3.
      assert (b' = b) as -> by lia.
      assert (S c' = c) as <- by lia.
      rewrite <- IH in H0,H1. cbn in H0,H1. cbn. lia.
    * intros [H1 H2]. eapply step with b (c-1) (d-b-1).
      + rewrite <- IH. cbn; lia.
      + rewrite <- IH. cbn; lia.
      + rewrite <- base_equiv. cbn; lia.
      + rewrite <- base_equiv. cbn; lia.
  Qed.

  (* Show that h10upc_sem_direct satisfies the axioms. *)
  Lemma eqRelSat : sat h10upc_sem_direct.
  Proof.
  split. 2:split.
  - intros a c. cbn. lia.
  - intros a. intros. split.
    * intros [H1 [H2 H3]]. destruct b as [|b']. 1:easy.
      exists b', (c-1), (d-b'-1). repeat split.
      all: lia.
    * intros [b' [c' [d' [H1 [H2 [H3 H4]]]]]]. cbn in H1,H2,H3,H4. cbn; lia.
  - intros a c d. cbn. lia.
  Qed.

  (* If P fulfills the axioms, and Q fulfills the weak axioms, then P is stronger than Q. *)
  (* Again, first the base case: *)
  Lemma satEquiv0 P Q : sat P -> satw Q -> forall a c d, P ((a,0),(c,d)) -> Q ((a,0),(c,d)).
  Proof. intros [HP1 [HP2 HP3]] [HQ1 HQ2] a c d.
  intros H.
  * pose proof (HP3 a c d H) as k. rewrite k in *.
    rewrite (HP1 a c) in H. rewrite (HQ1 a c). easy.
  Qed.

  (* Then the step case: *)
  Lemma satEquiv P Q : sat P -> satw Q -> forall a b c d, P ((a,b),(c,d)) -> Q ((a,b),(c,d)).
  Proof. intros [HP1 [HP2 HP3]] [HQ1 HQ2] a b c d.
  induction b as [|b' IH] in a,c,d|-*.
  * apply satEquiv0; firstorder.
  * destruct (HP2 a (S b') c d) as [HP21 HP22].
    pose proof (HQ2 a (S b') c d) as HQ22.
    intros H.
    - apply HQ22. destruct HP21 as [b'' [c' [d' [H1 [H2 [H3 H4]]]]]].
      + split; easy.
      + exists b'', c', d'. unfold ax1 in HP1. rewrite HP1 in H3. assert (b'' = b') as -> by lia.
        unfold ax1 in HQ1. rewrite !HQ1. rewrite <- !HP1. rewrite <- HP1 in H3. split. 2:split. 3:tauto.
        all: apply IH; easy.
  Qed.

  (* Congruence lemma: equivalent P,Q fulfill the same axioms *)
  Lemma satCongr P Q : (forall a b c d, P ((a,b),(c,d)) <-> Q ((a,b),(c,d))) -> sat P -> sat Q.
  Proof.
  intros H [H1 [H2 H3]]. split. 2:split.
  - unfold ax1 in *. intros a c. rewrite <- H. apply H1.
  - unfold ax2 in *. intros a b c d. rewrite <- H. split.
    * destruct (H2 a b c d) as [H2' _]. intros H4.
      destruct (H2' H4) as [b' [c' [d' H5]]].
      exists b', c', d'. rewrite <- !H. apply H5.
    * destruct (H2 a b c d) as [_ H2']. intros [b' [c' [d' H4]]].
      apply H2'. exists b',c',d'. rewrite !H. apply H4.
  - unfold ax3 in *. intros a c d. rewrite <- H. apply H3.
  Qed.

  Definition h10upc_ind' '((a,b),(c,d)) := h10upc_ind a b c d.

  (* It follows that h10upc_ind also fulfills the axioms. *)
  Lemma indRelSat : sat h10upc_ind'.
  Proof.
  eapply satCongr with h10upc_sem_direct.
  - intros a b c d. apply h10_equiv.
  - apply eqRelSat.
  Qed.

  (* The weak axioms are weaker. *)
  Lemma sat_satw P : sat P -> satw P.
  Proof.
  intros [H1 [H2 H3]]. split.
  * easy.
  * intros a b c d H. destruct (H2 a b c d) as [_ H2R]. now apply H2R.
  Qed.

End InductiveCharacterization.


(*|
#################################################
How can I automate counting within proofs in Coq?
#################################################

:Link: https://stackoverflow.com/q/42662141
|*)

(*|
Question
********

I have a function ``count`` that counts how many times a given
predicate is provable when applied to elements of a list. It is
defined as follows:
|*)

Parameter T : Type.

Parameter dec : forall (p : T -> Prop) (w : T), {p w} + {~ p w}.

Fixpoint count (p : T -> Prop) (l : list T) := match l with
  | nil => 0
  | cons head tail => if dec p head then 1 + count p tail else count p tail
end.

(*| I then use this function to state lemmas like the following: |*)

Parameter a b c : T.
Parameter q : T -> Prop.

Axiom Aa : q a.
Axiom Ab : q b.
Axiom Ac : ~ q c.

Lemma example : count q (cons a (cons b (cons c nil))) = 2.

(*| My proofs of such lemmas tend to be quite tedious: |*)

Proof.
  unfold count.
  assert (q a); [apply Aa | auto].
  assert (q b); [apply Ab | auto].
  assert (~ q c); [apply Ac | auto].
  destruct (dec q a); [auto | contradiction].
  destruct (dec q b); [auto | contradiction].
  destruct (dec q c); [contradiction | auto].
Qed.

(*|
What can I do to automate such tedious proofs that involve computation
with my ``count`` function?
|*)

(*|
Answer (Zimm i48)
*****************

This is typically the kind of cases where you are better off proving
things by reflection. See how things go smoothly (of course I modified
a bit your example to avoid all these axioms):
|*)

Reset Initial. (* .none *)
Require Import List.
Import ListNotations.

Fixpoint count {T : Type} (p : T -> bool) (l : list T) :=
  match l with
  | [] => 0
  | h :: t => if p h then S (count p t) else (count p t)
  end.

Inductive T := a | b | c.

Definition q x :=
  match x with
  | a => true
  | b => true
  | c => false
  end.

Lemma example : count q [a; b; c] = 2.
Proof.
  reflexivity.
Qed.

(*|
I realize that your definition of ``count`` was taking a propositional
predicate on type ``T`` (but with the assumption that all predicates
on type ``T`` are decidable) and instead I propose to define ``count``
to take a boolean predicate. But you may realize that having a
decidable propositional predicate or having a boolean predicate is
actually equivalent.

E.g. from your axioms, I can define a function which transform any
propositional predicate into a boolean one:
|*)

Reset Initial. (* .none *)
Parameter T : Type.

Parameter dec : forall (p : T -> Prop) (w : T), {p w} + {~ p w}.

Definition prop_to_bool_predicate (p : T -> Prop) (x : T) : bool :=
  if dec p x then true else false.

(*|
Of course, because there are axioms involved in your example, it won't
actually be possible to compute with the boolean predicate. But I'm
assuming that you put all these axioms for the purpose of the example
and that your actual application doesn't have them.

Answer to your comment
======================

As I told you, as soon as you have defined some function in terms of
an axiom (or of a `Parameter
<https://coq.inria.fr/refman/language/gallina-specification-language.html#coq:cmdv.parameter>`__
since this is the same thing), there is no way you can compute with it
anymore.

However, here is a solution where the decidability of propositional
predicate ``p`` is a lemma instead. I ended the proof of the lemma
with `Defined
<https://coq.inria.fr/refman/language/gallina-specification-language.html#coq:cmdv.defined>`__
instead of `Qed
<https://coq.inria.fr/refman/language/gallina-specification-language.html#coq:cmd.qed>`__
to allow computing with it (otherwise, it wouldn't be any better than
an axiom). As you can see I also redefined the ``count`` function to
take a predicate and a proof of its decidability. The proof by
reflection still works in that case. There is no ``bool`` but it is
strictly equivalent.
|*)

Reset Initial. (* .none *)
Require Import List.
Import ListNotations.

Fixpoint count {T : Type} (p : T -> Prop)
         (dec : forall (w: T), {p w} + {~ p w}) (l : list T) :=
  match l with
  | [] => 0
  | h :: t => if dec h then S (count p dec t) else count p dec t
  end.

Inductive T := a | b | c.

Definition p x := match x with | a => True | b => True | c => False end.

Lemma dec_p : forall (w : T), {p w} + {~ p w}.
Proof.
  intros []; simpl; auto.
Defined.

Lemma example2: count p dec_p [a; b; c] = 2.
Proof. reflexivity. Qed.

(*|
Answer (Anton Trunov)
*********************

Let's create our custom hint database and add your axioms there:

.. coq:: none
|*)

Reset Initial.

Parameter T : Type.

Parameter dec : forall (p : T -> Prop) (w : T), {p w} + {~ p w}.

Fixpoint count (p : T -> Prop) (l : list T) := match l with
  | nil => 0
  | cons head tail => if dec p head then 1 + count p tail else count p tail
end.

Parameter a b c : T.
Parameter q : T -> Prop.

Axiom Aa : q a.
Axiom Ab : q b.
Axiom Ac : ~ q c.

(*||*)

Hint Resolve Aa : axiom_db.
Hint Resolve Ab : axiom_db.
Hint Resolve Ac : axiom_db.

(*|
Now, the ``firstorder`` tactic can make use of the hint database:
|*)

Lemma example : count q (cons a (cons b (cons c nil))) = 2.
Proof.
  unfold count.
  destruct (dec q a), (dec q b), (dec q c); firstorder with axiom_db.
Qed.

(*|
----

We can automate our solution using the following piece of Ltac:
|*)

Ltac solve_the_probem :=
  match goal with
    |- context [if dec ?q ?x then _ else _] =>
      destruct (dec q x);
      firstorder with axioms_db;
      solve_the_probem
  end.

(*|
Then, ``unfold count; solve_the_probem.`` will be able to prove the
lemma.
|*)


Require Import compcert.lib.Coqlib.
Require Import List. Import ListNotations.
Require Import Coq.ZArith.BinInt. (* Z *)
Require Import Coq.ZArith.Zcomplements. (* Zlength *)
Require Import compcert.lib.Integers.          (* byte *)
Require Import Coq.Numbers.Natural.Peano.NPeano.

Require Import Coq.Strings.Ascii.
Require Import Coq.Program.Tactics.
Require Import sha.XorCorrespondence. (* Blist *)
Require Import sha.Bruteforce.
Require Import sha.general_lemmas.
Require Import sha.hmac_pure_lemmas.

Definition Blist := list bool.
Open Scope Z_scope.

Inductive InBlocks {A : Type} (n : nat) : list A -> Prop :=
  | InBlocks_nil : InBlocks n []
  | InBlocks_block : forall (front back full : list A),
                   length front = n ->
                   full = front ++ back ->
                   InBlocks n back ->
                   InBlocks n full.

Lemma InBlocks_len : forall {A : Type} (l : list A) (n : nat),
                       PeanoNat.Nat.divide (n) (length l) -> InBlocks n l.
Proof.
  intros A l n div.
  destruct div.
  revert A l n H.
  induction x; intros; simpl in *.
  - destruct l; simpl in *. constructor. inversion H.
  - destruct (list_splitLength _ _ _ H) as [l1 [l2 [L [L1 L2]]]]. clear H; subst.
    apply IHx in L2. clear IHx.
    apply (InBlocks_block _ l1 l2); trivial.
Qed.

(* ----- Inductive *)

Inductive bytes_bits_lists : Blist -> list Z -> Prop :=
  | eq_empty : bytes_bits_lists nil nil
  | eq_cons : forall (bits : Blist) (bytes : list Z)
                     (b0 b1 b2 b3 b4 b5 b6 b7 : bool) (byte : Z),
                bytes_bits_lists bits bytes ->
                convertByteBits [b0; b1; b2; b3; b4; b5; b6; b7] byte ->
                bytes_bits_lists (b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: bits)
                                 (byte :: bytes).

(* ----- Computational *)

(* TODO: assumes Z is positive and in range, does not use Z.positive *)

Definition div_mod (num : Z) (denom : Z) : bool * Z :=
  (Z.gtb (num / denom) 0, num mod denom).

Definition byteToBits (byte : Z) : Blist :=
  let (b7, rem7) := div_mod byte 128 in
  let (b6, rem6) := div_mod rem7 64 in
  let (b5, rem5) := div_mod rem6 32 in
  let (b4, rem4) := div_mod rem5 16 in
  let (b3, rem3) := div_mod rem4 8 in
  let (b2, rem2) := div_mod rem3 4 in
  let (b1, rem1) := div_mod rem2 2 in
  let (b0, rem0) := div_mod rem1 1 in
  [b0; b1; b2; b3; b4; b5; b6; b7].

Fixpoint bytesToBits (bytes : list Z) : Blist :=
  match bytes with
    | [] => []
    | byte :: xs => byteToBits byte ++ bytesToBits xs
  end.

Definition bitsToByte (bits : Blist) : Z :=
  match bits with
    | b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: nil =>
      1 * (asZ b0) + 2 * (asZ b1) + 4 * (asZ b2) + 8 * (asZ b3)
      + 16 * (asZ b4) + 32 * (asZ b5) + 64 * (asZ b6) + 128 * (asZ b7)
    | _ => -1                   (* should not happen *)
  end.

Fixpoint bitsToBytes (bits : Blist) : list Z :=
  match bits with
    | b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: xs =>
      bitsToByte [b0; b1; b2; b3; b4; b5; b6; b7] :: bitsToBytes xs
    | _ => []
  end.

Lemma bitsToByte_isbyteZ b0 b1 b2 b3 b4 b5 b6 b7:
      isbyteZ (bitsToByte [b0; b1; b2; b3; b4; b5; b6; b7]).
Proof. simpl. unfold asZ, isbyteZ.
  destruct b0; destruct b1; destruct b2; destruct b3;
  destruct b4; destruct b5; destruct b6; destruct b7; simpl; omega.
Qed.

(* -------------------- Various theorems and lemmas *)

Lemma byteToBits_length bt: length (byteToBits bt) = 8%nat.
Proof. reflexivity. Qed.

Lemma bytes_bits_length : forall (bits : Blist) (bytes : list Z),
  bytes_bits_lists bits bytes -> length bits = (length bytes * 8)%nat.
Proof.
  intros bits bytes corr.
  induction corr.
  - reflexivity.
  - simpl. repeat f_equal. apply IHcorr.
Qed.

Lemma bytesToBits_app : forall (l1 l2 : list Z),
                          bytesToBits (l1 ++ l2) = bytesToBits l1 ++ bytesToBits l2.
Proof.
  induction l1; intros.
  * reflexivity.
  *
    simpl. rewrite -> IHl1. reflexivity.
Qed.

Lemma bytesToBits_len : forall (l : list Z),
                          length (bytesToBits l) = (length l * 8)%nat.
Proof.
  induction l; intros; try reflexivity.
  -
    simpl.
    rewrite -> IHl.
    reflexivity.
Qed.

(* Prove by brute force (test all Z in range) *)
Theorem byte_bit_byte_id : forall (byte : Z),
                             0 <= byte < 256 ->
                                bitsToByte (byteToBits byte) = byte.
Proof.
  intros byte range.
  do_range range reflexivity.
Qed.

Theorem bits_byte_bits_id : forall (b0 b1 b2 b3 b4 b5 b6 b7 : bool),
                              [b0; b1; b2; b3; b4; b5; b6; b7] =
                              byteToBits (bitsToByte [b0; b1; b2; b3; b4; b5; b6; b7]).
Proof.
  intros.
  destruct b0; destruct b1; destruct b2; destruct b3;
  destruct b4; destruct b5; destruct b6; destruct b7;
  reflexivity.
Qed.

Theorem bytes_bits_bytes_id : forall (bytes : list Z),
                                Forall (fun b => 0 <= b < 256) bytes ->
                                bitsToBytes (bytesToBits bytes) = bytes.
Proof.
  intros range bytes.
  induction bytes as [ | byte bytes].
  - reflexivity.
  -
    unfold bytesToBits.
    fold bytesToBits.
    unfold byteToBits.
    unfold bitsToBytes.
    Opaque bitsToByte. Opaque bitsToBytes. Opaque bytesToBits.
    simpl.
    Transparent bitsToBytes. fold bitsToBytes.
    rewrite -> IHbytes.

    Transparent bitsToByte.
    unfold bitsToByte. f_equal.
    apply byte_bit_byte_id.

    apply H. Transparent bytesToBits.
Qed.

(* ------------------ Theorems relating inductive and computational definitions *)

Theorem bytes_bits_def_eq : forall (bytes : list Z),
                              Forall (fun b => 0 <= b < 256) bytes ->
                              bytes_bits_lists (bytesToBits bytes) bytes.
Proof.
  intros range bytes.
  induction bytes as [ | byte bytes ].
  -
    simpl. apply eq_empty.
  -
    apply eq_cons.

    *
      apply IHbytes.
    *
      unfold convertByteBits.
      do 8 eexists.
      split.
      +
        reflexivity.
      +
        do_range H reflexivity.
Qed.

Theorem bytes_bits_comp_ind : forall (bits : Blist) (bytes : list Z),
                               Forall (fun b => 0 <= b < 256) bytes ->
                               bits = bytesToBits bytes ->
                               bytes_bits_lists bits bytes.
Proof.
  intros bits bytes range corr.
  rewrite -> corr.
  apply bytes_bits_def_eq.
  assumption.
Qed.

Theorem bytes_bits_ind_comp : forall (bits : Blist) (bytes : list Z),
                                 Forall (fun b => 0 <= b < 256) bytes ->
                                 bytes_bits_lists bits bytes ->
                                 bytes = bitsToBytes bits.
Proof.
  intros bits bytes range corr.
  induction corr.
  - reflexivity.
  - rewrite -> IHcorr; clear IHcorr corr.
    * unfold bitsToBytes.
      fold bitsToBytes.
      f_equal. unfold convertByteBits in H.
        destruct H as [b8 [b9 [b10 [b11 [b12 [b13 [b14 [b15 [B BT]]]]]]]]].
        inversion B; clear B. subst. reflexivity.
    * eapply Forall_tl. eassumption.
Qed.

Theorem bits_bytes_ind_comp : forall (bits : Blist) (bytes : list Z),
                                 Forall (fun b => 0 <= b < 256) bytes ->
                                 bytes_bits_lists bits bytes ->
                                 bits = bytesToBits bytes.
Proof.
  intros bits bytes range corr.
  induction corr.
  - reflexivity.
  -
    unfold convertByteBits in H.
    destruct_exists.
    destruct H7.
    inversion H7.
    subst.
    clear H7.
    rewrite -> IHcorr.
    unfold bytesToBits.
    fold bytesToBits.
    assert (list_8 : forall {A : Type} (e0 e1 e2 e3 e4 e5 e6 e7 : A) (l : list A),
                       e0 :: e1 :: e2 :: e3 :: e4 :: e5 :: e6 :: e7 :: l =
                       [e0; e1; e2; e3; e4; e5; e6; e7] ++ l).
    reflexivity.
    rewrite -> list_8.
    f_equal.
    apply bits_byte_bits_id.

    eapply Forall_tl. eassumption.
Qed.

(* ----------------------------- *)
(* Relating bits to bytes *)

Lemma bitsToBytes_app : forall (l m : Blist),
                          InBlocks 8 l ->
                          bitsToBytes (l ++ m) = bitsToBytes l ++ bitsToBytes m.
Proof.
  intros l m len_l. revert m.
  induction len_l.
  * intros. reflexivity.
  *
    intros m.
    rewrite -> H0.
    rewrite <- app_assoc.
    destruct front as [ | x0 [| x1 [ | x2 [ | x3 [ | x4 [ | x5 [ | x6 [ | x7 ]]]]]]]];
      inversion H.
    unfold bitsToBytes.
    Opaque bitsToByte.
    simpl.
    fold bitsToBytes.
    apply list_nil in H2.
    rewrite -> H2.
    simpl.
    rewrite -> IHlen_l.
    reflexivity.
Qed.

Lemma bitsToBytes_len_gen : forall (l : Blist) (n : nat),
                          length l = (n * 8)%nat ->
                          length (bitsToBytes l) = n.
Proof.
  intros l n len.
  assert (blocks : InBlocks 8 l).
    apply InBlocks_len. rewrite -> len. exists n. reflexivity.
  revert n len.
  induction blocks.
  * intros. simpl in *. omega.
  *
    intros n len.
    rewrite -> H0.
    rewrite -> bitsToBytes_app.
    rewrite -> app_length.
    rewrite -> H0 in len.
    rewrite -> app_length in len.
    rewrite -> H in len.

    destruct n as [ | n'].
    (* strange that destruct works here but not after [rewrite -> IHblocks] *)
    - simpl in *.
      inversion len.
    -
      destruct front as [ | x0 [| x1 [ | x2 [ | x3 [ | x4 [ | x5 [ | x6 [ | x7 ]]]]]]]];
      inversion H.

      simpl.
      apply list_nil in H2.
      rewrite -> H2. simpl.
      assert (minus : forall (n m : nat), n = m -> (n - 8)%nat = (m - 8)%nat).
        intros. omega.
      apply minus in len.
      simpl in len.
      assert (min_zero : forall (n : nat), (n - 0)%nat = n). intros. omega.
      repeat rewrite -> min_zero in len.
      clear H2 minus min_zero.
      specialize (IHblocks n').
      rewrite -> IHblocks.
      reflexivity.
      apply len.
      -
        apply InBlocks_len.
        rewrite -> H. unfold PeanoNat.Nat.divide.
        exists 1%nat. reflexivity.
Qed.

Lemma bitsToBytes_len : forall (l : Blist),
                          length l = 512%nat ->
                          Zlength (bitsToBytes l) = 64%Z.
Proof.
  intros l len.
  rewrite -> Zlength_correct.
  pose proof bitsToBytes_len_gen as len_gen.
  specialize (len_gen l 64%nat).
  rewrite -> len_gen.
  - reflexivity.
  - apply len.
Qed.

Lemma bits_bytes_bits_id : forall (l : Blist),
                             InBlocks 8 l ->
                             bytesToBits (bitsToBytes l) = l.
Proof.
  intros l len.
  induction len.
  - reflexivity.
  -
    rewrite -> H0.
    destruct front as [ | x0 [| x1 [ | x2 [ | x3 [ | x4 [ | x5 [ | x6 [ | x7 ]]]]]]]];
      inversion H.
    simpl.
    apply list_nil in H2. rewrite -> H2. simpl.
    rewrite -> IHlen.

    destruct x0; destruct x1; destruct x2; destruct x3;
    destruct x4; destruct x5; destruct x6; destruct x7; reflexivity.
Qed.

Lemma bytes_bits_lists_append:
  forall (l1 : Blist) (l2 : list Z) (m1 : Blist) (m2 : list Z),
    bytes_bits_lists l1 l2
    -> bytes_bits_lists m1 m2
    -> bytes_bits_lists (l1 ++ m1) (l2 ++ m2).
Proof.
  intros l1 l2 m1 m2.
  intros fst_eq snd_eq.
  generalize dependent m1. generalize dependent m2.
  induction fst_eq; intros.
  - repeat rewrite app_nil_l.
    apply snd_eq.
  - simpl.
    apply eq_cons.
    + apply IHfst_eq.
      apply snd_eq.
    + apply H.
Qed.

Lemma bytesToBits_nil_inv l: nil = bytesToBits l -> l = nil.
Proof. destruct l; trivial. simpl; intros. discriminate. Qed.

Lemma bytesToBits_cons b l:
      bytesToBits (b::l) = byteToBits b ++ bytesToBits l.
Proof. reflexivity. Qed.

Lemma byteToBits_injective: forall a b,
      byteToBits a = byteToBits b ->
      isbyteZ a -> isbyteZ b -> a = b.
Proof. intros. unfold isbyteZ in *.
assert (bitsToByte (byteToBits a) = bitsToByte (byteToBits b)).
  rewrite H; trivial.
clear H.
rewrite byte_bit_byte_id in H2; trivial.
rewrite byte_bit_byte_id in H2; trivial.
Qed.

Lemma bytesToBits_injective: forall b1 b2, bytesToBits b1 = bytesToBits b2 ->
      Forall isbyteZ b1 -> Forall isbyteZ b2 -> b1=b2.
Proof. induction b1.
  intros; destruct b2; trivial. discriminate.
  destruct b2. discriminate.
  do 2 rewrite bytesToBits_cons.
  intros. destruct (app_inj1 _ _ _ _ H). reflexivity.
  rewrite (IHb1 _ H3).
  rewrite (byteToBits_injective _ _ H2). trivial.
    eapply Forall_inv; eassumption.
    eapply Forall_inv; eassumption.
    eapply Forall_tl; eassumption.
    eapply Forall_tl; eassumption.
Qed.

Lemma bitsToBytes_injective8 b1 b2 (B: bitsToBytes b1 = bitsToBytes b2)
       (L1: PeanoNat.Nat.divide 8 (length b1))
       (L2: PeanoNat.Nat.divide 8 (length b2)): b1 = b2.
Proof. intros.
  assert (bytesToBits (bitsToBytes b1) = bytesToBits (bitsToBytes b2)).
    rewrite B; trivial.
  rewrite bits_bytes_bits_id in H.
    rewrite bits_bytes_bits_id in H. trivial.
    apply InBlocks_len; assumption.
  apply InBlocks_len; assumption.
Qed.

Lemma bitsToByte_cons: forall bits h t, (h::t) = bitsToBytes bits ->
      exists b0, exists b1, exists b2, exists b3,
      exists b4, exists b5, exists b6, exists b7, exists xs,
      bits = b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: xs /\
      h = bitsToByte [b0; b1; b2; b3; b4; b5; b6; b7] /\
      t = bitsToBytes xs.
Proof. intros.
  destruct bits. inv H.
  destruct bits. inv H.
  destruct bits. inv H.
  destruct bits. inv H.
  destruct bits. inv H.
  destruct bits. inv H.
  destruct bits. inv H.
  destruct bits; inv H.
  eexists; eexists; eexists; eexists; eexists; eexists; eexists; eexists; eexists.
  split. reflexivity.
  split; reflexivity.
Qed.

Definition intsToBits (l : list Int.int) : list bool :=
  bytesToBits (intlist_to_Zlist l).

Definition bitsToInts (l : Blist) : list Int.int :=
  Zlist_to_intlist (bitsToBytes l).

Lemma bitsToBytes_isbyteZ: forall bytes bits,
                             bytes = bitsToBytes bits -> Forall isbyteZ bytes.
Proof. intros bytes.
  induction bytes; simpl; intros.
     constructor.
  apply bitsToByte_cons in H.
  destruct H as [b0 [b1 [b2 [b3 [b4 [b5 [b6 [b7 [xs [BITS [A BYTES]]]]]]]]]]].
  constructor.
     subst. apply bitsToByte_isbyteZ.
     eauto.
Qed.

Lemma convertByteBits_isbyteZ b0 b1 b2 b3 b4 b5 b6 b7 byte:
      convertByteBits [b0; b1; b2; b3; b4; b5; b6; b7] byte ->
      isbyteZ byte.
Proof. intros.
  destruct H as [b8 [b9 [b10 [b11 [b12 [b13 [b14 [b15 [BITS ZZ]]]]]]]]].
  inversion BITS. subst. clear BITS.
  unfold asZ, isbyteZ.
  destruct b8; destruct b9; destruct b10; destruct b11;
  destruct b12; destruct b13; destruct b14; destruct b15; simpl; omega.
Qed.

Lemma bytesBitsLists_isbyteZ bytes bits: bytes_bits_lists bits bytes -> Forall isbyteZ bytes.
Proof. intros.
  induction H. constructor.
  constructor; trivial. eapply convertByteBits_isbyteZ. apply H0.
Qed.


Load "include/ops_header.v".

Module precond.

Definition Sn (n k m : int) := (n >= 0) /\ (m > 0) /\ (n >= m).
Definition Sk (n k m : int) := true.
Definition Sm (n k m : int) := (n > 0) /\ (m > 0) /\ (n > m).

End precond.

Definition not_D1 (n k m : int) := (0 < m) && (m < n).
Definition not_D2 (n k m : int) := (0 < m) && (m < n).
Definition not_D3 (n k m : int) := (0 < m) && (m < n).
Definition not_D4 (n k m : int) := (0 < m) && (m < n).

Load "include/ann_d.v".

Definition CT1  (d : int -> int -> int -> rat) : Prop := forall (n_ k_ m_ : int),
  not_D1 n_ k_ m_ -> P1_horner (punk.pfun2 d m_) n_ k_ = Q1_flat d n_ k_ (int.shift 1 m_) - Q1_flat d n_ k_ m_.

Definition CT2  (d : int -> int -> int -> rat) := forall (n_ k_ m_ : int),
  not_D2 n_ k_ m_ -> P2_horner (punk.pfun2 d m_) n_ k_ = Q2_flat d n_ k_ (int.shift 1 m_) - Q2_flat d n_ k_ m_.

Definition CT3  (d : int -> int -> int -> rat) := forall (n_ k_ m_ : int),
  not_D3 n_ k_ m_ -> P3_horner (punk.pfun2 d m_) n_ k_ = Q3_flat d n_ k_ (int.shift 1 m_) - Q3_flat d n_ k_ m_.

Definition CT4  (d : int -> int -> int -> rat) := forall (n_ k_ m_ : int),
  not_D4 n_ k_ m_ -> P4_horner (punk.pfun2 d m_) n_ k_ = Q4_flat d n_ k_ (int.shift 1 m_) - Q4_flat d n_ k_ m_.

Record Ann d : Type := ann {
  Sn_  : Sn d;
  Sk_  : Sk d;
  Sm_  : Sm d
}.


Require Import Utf8.
Require Import GroupDefinition.
Require Import GroupAction.
Require Import GroupProofs.
Require Import Setoid.

Generalizable Variables G.

Definition operation_as_action `{Group G} : GroupActionOp G G := λ g h, g·h.

Proposition groups_act_over_themselves
    {G : Set} {op : SemiGroupOp G} {i : GroupInv G} {e : G} {P : @Group G op i e} :
    @GroupAction G e _ _ _ _ G operation_as_action.
Proof.
  split.
  intros.
  compute.
  rewrite (@sg_assoc G op _).
  reflexivity.
  intros.
  compute.
  rewrite (@left_identity G op i e P _).
  reflexivity.
Qed.


Theorem Disjunctive_syllogism : forall P Q : Prop, (P \/ Q) -> ~P -> Q.
Proof.
  intros.
  destruct H as [ H1 | H2 ].
  absurd P.
  apply H0.
  apply H1.
  assumption.
Qed.


Require Export SpecSyntax.
Set Implicit Arguments.

(******************************************************************************)
(* Shifting                                                                   *)
(******************************************************************************)

Fixpoint shiftIndex (c : nat) (i : nat) : nat :=
  match c with
    | O   => S i
    | S c =>
      match i with
        | O   => O
        | S i => S (shiftIndex c i)
      end
  end.

Fixpoint tshiftTy (c : nat) (T : Ty) : Ty :=
  match T with
    | tvar X       => tvar (shiftIndex c X)
    | tabs K T     => tabs K (tshiftTy (S c) T)
    | tapp T1 T2   => tapp (tshiftTy c T1) (tshiftTy c T2)
    | tarr T1 T2   => tarr (tshiftTy c T1) (tshiftTy c T2)
    | tall K T     => tall K (tshiftTy (S c) T)
  end.

Fixpoint tshiftTm (c : nat) (t : Tm) : Tm :=
  match t with
    | var x        => var x
    | abs T  t     => abs (tshiftTy c T) (tshiftTm c t)
    | app t1 t2    => app (tshiftTm c t1) (tshiftTm c t2)
    | tyabs K t    => tyabs K (tshiftTm (S c) t)
    | tyapp t T    => tyapp (tshiftTm c t) (tshiftTy c T)
  end.

Fixpoint shiftTm (c : nat) (t : Tm) : Tm :=
  match t with
    | var x        => var (shiftIndex c x)
    | abs T1 t2    => abs T1 (shiftTm (S c) t2)
    | app t1 t2    => app (shiftTm c t1) (shiftTm c t2)
    | tyabs K1 t2  => tyabs K1 (shiftTm c t2)
    | tyapp t1 T2  => tyapp (shiftTm c t1) T2
  end.

(******************************************************************************)
(* Type substitution.                                                         *)
(******************************************************************************)

Fixpoint tsubstIndex (X : nat) (T' : Ty) (Y : nat) : Ty :=
  match X , Y with
    | O   , O      => T'
    | O   , S Y    => tvar Y
    | S X , O      => tvar O
    | S X , S Y    => tshiftTy 0 (tsubstIndex X T' Y)
  end.

Fixpoint tsubstTy (X : nat) (T' : Ty) (T : Ty) : Ty :=
  match T with
    | tvar Y       => tsubstIndex X T' Y
    | tabs K T     => tabs K (tsubstTy (S X) T' T)
    | tapp T1 T2   => tapp (tsubstTy X T' T1) (tsubstTy X T' T2)
    | tarr T1 T2   => tarr (tsubstTy X T' T1) (tsubstTy X T' T2)
    | tall K T     => tall K (tsubstTy (S X) T' T)
  end.

Fixpoint tsubstTm (X : nat) (T' : Ty) (t : Tm) : Tm :=
  match t with
    | var x        => var x
    | abs T1 t2    => abs  (tsubstTy X T' T1) (tsubstTm X T' t2)
    | app t1 t2    => app  (tsubstTm X T' t1) (tsubstTm X T' t2)
    | tyabs K1 t2  => tyabs K1 (tsubstTm (S X) T' t2)
    | tyapp t1 T2  => tyapp (tsubstTm X T' t1) (tsubstTy X T' T2)

  end.

(******************************************************************************)
(* Term substitutions.                                                        *)
(******************************************************************************)

Inductive Trace : Set :=
  | I0
  | IV (i : Trace)
  | IT (i : Trace).

(*  means [x |-> t] y  *)
Fixpoint substIndex (x : Trace) (t : Tm) (y : nat) : Tm :=
  match x , y with
    | I0   , O     => t
    | I0   , S y   => var y
    | IV x , O     => var O
    | IV x , S y   => shiftTm O (substIndex x t y)
    | IT x , y     => tshiftTm 0 (substIndex x t y)
  end.

(*  means [x |-> t'] t  *)
Fixpoint substTm (x : Trace) (t' : Tm) (t : Tm) : Tm :=
  match t with
    | var y        => substIndex x t' y
    | abs T1 t2    => abs T1 (substTm (IV x) t' t2)
    | app t1 t2    => app (substTm x t' t1) (substTm x t' t2)
    | tyabs K1 t2  => tyabs K1 (substTm (IT x) t' t2)
    | tyapp t1 T2  => tyapp (substTm x t' t1) T2
  end.

(******************************************************************************)
(* Context lookups.                                                           *)
(******************************************************************************)

(* lookup_evar Γ x T  means  x:T ∈ Γ  *)
Inductive lookup_evar : Env → nat → Ty → Prop :=
  | lookup_evar_here {Γ T} :
      lookup_evar (evar Γ T) 0 T
  | lookup_evar_there_evar {Γ T T' x} :
      lookup_evar Γ x T →
      lookup_evar (evar Γ T') (S x) T
  | lookup_evar_there_etvar {Γ T K x} :
      lookup_evar Γ x T →
      lookup_evar (etvar Γ K) x (tshiftTy 0 T).
Hint Constructors lookup_evar.

Inductive lookup_etvar : Env → nat → Kind → Prop :=
  | lookup_etvar_here {Γ K} :
      lookup_etvar (etvar Γ K) 0 K
  | lookup_etvar_there_evar {Γ T T' X} :
      lookup_etvar Γ X T →
      lookup_etvar (evar Γ T') X T
  | lookup_etvar_there_etvar {Γ K K' X} :
      lookup_etvar Γ X K →
      lookup_etvar (etvar Γ K') (S X) K.
Hint Constructors lookup_etvar.


Add LoadPath "C:\Users\Jonathan\source\repos\PLT-Coq\Software Foundations\Logical Foundations".
Require Export Lists.

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

Check list.

Check (nil nat).

Check (cons nat 3 (nil nat)).

Check nil.

Check cons.

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

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

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

Example test_repeat2 : repeat bool false 1 = cons bool false (nil bool).
Proof. reflexivity. Qed.

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

Check repeat'.
Check repeat.

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

Definition list123 :=
  cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

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

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

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

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

Fixpoint app {X : Type} (l_1 l_2 : list X) : list X :=
  match l_1 with
  | nil => l_2
  | cons h t => cons h (app t l_2)
end.

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

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

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

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

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

Fail Definition mynil := nil.

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

Definition mynil' := @nil nat.

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

Definition list123''' := [1; 2; 3].

(* Exercises poly_exercises *)

Theorem app_nil_r : forall (X : Type), forall l: list X,
  l ++ [] = l.
Proof.
  induction l as [| h l' IHl'].
  + reflexivity.
  + simpl. rewrite IHl'. reflexivity.
Qed.

Theorem app_assoc : forall A (l m n : list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  induction l as [| h l' IHl'].
  + reflexivity.
  + intros. simpl. rewrite <- IHl'. reflexivity.
Qed.

Lemma app_length : forall (X: Type) (l_1 l_2 : list X),
  length (l_1 ++ l_2) = length l_1 + length l_2.
Proof.
  induction l_1 as [| h l_1' IHl1'].
  - reflexivity.
  - intros. simpl. rewrite -> IHl1'. reflexivity.
Qed.

(* Exercises more_poly exercises *)

Theorem rev_app_distr : forall X (l_1 l_2 : list X),
  rev (l_1 ++ l_2) = rev l_2 ++ rev l_1.
Proof.
  intros. induction l_1 as [| h l_1' IHl1'].
  - rewrite app_nil_r. reflexivity.
  - simpl. rewrite IHl1'. rewrite app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall X: Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros. induction l as [| h l' IHl'].
  - reflexivity.
  - simpl. rewrite -> rev_app_distr. rewrite -> IHl'. reflexivity.
Qed.

(* Polymorphic pairs *)

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

Arguments pair {X} {Y} _ _.

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

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

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

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

(* Exercise combine_checks *)

Check @combine.
Compute (combine [1;2] [false;false;true;true]).

(* Exercise split *)

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

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

Module OptionPlayground.

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

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

End OptionPlayground.

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

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.

Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
Proof. reflexivity. Qed.

Example test_nth_error3 : nth_error [true] 2 = None.
Proof. reflexivity. Qed.

(* Exercise hd_error_poly *)

Definition hd_error {X : Type} (l : list X)
  : option X :=
    match l with
    | [] => None
    | h :: t => Some h
end.

Example test_hd_error1 : hd_error [1;2] = Some 1.
Proof. reflexivity. Qed.

Example test_hd_error2 : hd_error [[1];[2]] = Some [1].
Proof. reflexivity. Qed.

(* Functions as Data *)

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

Check @doit3times.

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

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

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

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

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

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

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

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

Example test_countoddmembers'2: countoddmembers' [0;2;4] = 0.
Proof. reflexivity. Qed.

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

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

(* Exercise filter_even_gt7 *)
Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun n => (andb (evenb n) (negb (blt_nat n 7)))) l.

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

Example test_filter_event_gt7_2 : filter_even_gt7 [5;2;6;19;129] = [].
Proof. reflexivity. Qed.

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

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity. Qed.

Example test_partition2 : partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. reflexivity. Qed.

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

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

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

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

(* Exercise map_rev *)

Lemma map_app_distr : forall (X Y: Type) (f : X -> Y) (l_1 l_2 : list X),
  map f (l_1 ++ l_2) = (map f l_1) ++ (map f l_2).
Proof.
  intros.
  induction l_1 as [| h_1 l_1' IHl1'].
  - reflexivity.
  - simpl. rewrite -> IHl1'. reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros. induction l as [| h l' IHl'].
  - reflexivity.
  - simpl. rewrite -> map_app_distr. rewrite IHl'. reflexivity.
Qed.

(* Exercise flat_map *)

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

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

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

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

Check (fold andb).

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

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

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

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

Definition ftrue := constfun true.

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

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

Check plus.

Definition plus3 := plus 3.
Check plus3.

Example test_plus3 : plus3 4 = 7.
Proof. reflexivity. Qed.

Example test_plus3' : doit3times plus3 0 = 9.
Proof. reflexivity. Qed.

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

(* Exercise fold_length *)

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

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

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

(* Exercise fold_map *)

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

Example test_fold_map : fold_map (fun x => x) [1;2;3;4] = [1;2;3;4].
Proof. reflexivity. Qed.

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

(* Exercise currying *)

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

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

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

Check @prod_curry.
Check @prod_uncurry.

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

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

(* Exercise church_numerals *)

Module Church.

Definition nat := forall X : Type, (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 zero : nat := fun (X : Type) (f : X -> X) (x : X) => x.

Definition three : nat := @doit3times.

Definition succ (n : nat) : nat :=
  fun (X : Type) (f : X -> X) (x : X) => f ((n X f) x).

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

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

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

Definition plus (n m : nat) : nat :=
  fun (X : Type) (f : X -> X) (x : X) => m X f ((n X f) x).

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.

Definition mult (n m : nat) : nat :=
  fun (X : Type) (f : X -> X) (x : X) => (n X (m X f) x).

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.

Definition exp (n m  : nat) : nat :=
  fun (X : Type) (f : X -> X) (x : X) => (m (X -> X) (n X) f) x.

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.

End Church.


Require Import CT.Algebra.Lattice.
Require Import CT.Order.PartiallyOrderedSet.
Require Import Coq.Program.Basics.
Require Setoid.

(** * Boolean Algebras

There are many equivalent definitions of a boolean algebra, but the one we take
builds on our definition of a [Lattice]. In this definition, a [BooleanAlgebra]
is a [Lattice] with an additional function [notB] which is an endomorphism over
the carrier set that satisfies:

  - le (meet a b) c  iff  le a (join (notB b) c)

We use [notB] instead of [not] so as not to conflict with
[not : Prop -> Prop].
*)

Record BooleanAlgebra :=
  { L :> Lattice;
    notB : element L -> element L;
    condB : forall a b c : element L,
        le (poset L) (meet L a b) c <-> le (poset L) a (join L (notB b) c)
  }.

(* Play around in the context of [Prop]. *)
(*
Section ToyProp.
  Program Definition prop_poset : PartiallyOrderedSet :=
    {| le := fun a b => (a = (b /\ a)) <-> ((a \/ b) = b) |}.
  Next Obligation.

  Program Definition prop_lat : Lattice :=
    {| element := Prop;
       poset := prop_poset;
       meet := fun a b => a /\ b;
       join := fun a b => a \/ b;
    |}.
  Next Obligation.
*)