(** * 6.512 Formal Reasoning About Programs, Spring 2023 - Pset 1 *)

(* Welcome to 6.512!  Read through `Pset1Signature.v` before starting here. *)

Require Import Frap Pset1Signature.

Module Impl.
  (* The first part of this assignment involves the [bool] datatype,
   * which has the following definition.
   * <<
       Inductive bool :=
       | true
       | false.
     >>
   * We will define logical negation and conjunction of Boolean values,
   * and prove some properties of these definitions.
   *)

  (* Define [Neg] so that it implements Boolean negation, which flips
   * the truth value of a Boolean value.
   *)
  Definition Neg (b : bool) : bool.
  Admitted.

  (* For instance, the negation of [true] should be [false].
   * This proof should follow from reducing both sides of the equation
   * and observing that they are identical.
   *)
  Theorem Neg_true : Neg true = false.
  Proof.
  Admitted.

  (* Negation should be involutive, meaning that if we negate
   * any Boolean value twice, we should get the original value back.

   * To prove a fact like this that holds for all Booleans, it suffices
   * to prove the fact for both [true] and [false] by using the
   * [cases] tactic.
   *)
  Theorem Neg_involutive : forall b : bool, Neg (Neg b) = b.
  Proof.
  Admitted.

  (* Define [And] so that it implements Boolean conjunction. That is,
   * the result value should be [true] exactly when both inputs
   * are [true].
   *)
  Definition And (x y : bool) : bool.
  Admitted.

  (* Here are a couple of examples of how [And] should act on
   * concrete inputs.
   *)
  Theorem And_true_true : And true true = true.
  Proof.
  Admitted.

  Theorem And_false_true : And false true = false.
  Proof.
  Admitted.

  (* Prove that [And] is commutative, meaning that switching the order
   * of its arguments doesn't affect the result.
   *)
  Theorem And_comm : forall x y : bool, And x y = And y x.
  Proof.
  Admitted.

  (* Prove that the conjunction of a Boolean value with [true]
   * doesn't change that value.
   *)
  Theorem And_true_r : forall x : bool, And x true = x.
  Proof.
  Admitted.

  (* You may have noticed that the [=] operator above does not return a [bool]. *)
  Check (true = false).

  (* [a = b] is instead a [Prop], short for proposition, the type of logical
   * statements. The set of propositions in Coq is large and contains a variety
   * of statements, many of which are undecideable, so we can't in general
   * treat statements in [Prop] as functions with Boolean output. This means
   * that you can't use expressions of type [Prop] when defining a program,
   * since they don't have computational behavior. For example, compare how
   * the following two expressions evaluate. The first expression uses functions
   * we can compute with, while the second uses propositions:
   *)
  Compute (if 1 ==n 2 then (And true false) else true).
  Compute (1 = 2 -> True /\ False).

  (* The following operations that you have seen or will see soon are in [Prop],
   * so they cannot be used in if-then-else statements:
   * - [a = b] (equality at an arbitrary type)
   * - [a <= b] (a less than or equal to b for natural numbers)
   * - [a < b] (a less than b for natural numbers)
   * - [a >= b] (a greater than or equal to b for natural numbers)
   * - [a > b] (a greater than b for natural numbers)
   * - [a <> b] (inequality at an arbitrary type)
   * - [a /\ b] (propositional conjunction)
   * - [~ a] (propositional negation)
   *
   * These operations are defined as functions, so you can evalute them:
   * - [a ==n b] (decidable equality for natural numbers)
   * - [a ==v b] (decidable equality for variables)
   * - [And a b] (Boolean conjunction, defined above)
   * - [Neg a] (Boolean negation, defined above)
   *)

  (* In the second part of this assignment, we will work with a simple language
   * of imperative arithmetic programs that sequentially apply operations
   * to a natural-number-valued state.

   * The [Prog] datatype defines abstract syntax trees for this language.
   *)

  Print Prog.

  (* Define [run] such that [run p n] gives the final state
   * that running the program [p] should result in, when the
   * initial state is [n].
   *)
  Fixpoint run (p : Prog) (initState : nat) : nat.
  Admitted.

  Theorem run_Example1 : run Done 0 = 0.
  Proof.
  Admitted.

  Theorem run_Example2 : run (MulThen 5 (AddThen 2 Done)) 1 = 7.
  Proof.
  Admitted.

  Theorem run_Example3 : run (SetToThen 3 (MulThen 2 Done)) 10 = 6.
  Proof.
  Admitted.

  (* Define [numInstructions] to compute the number of instructions
   * in a program, not counting [Done] as an instruction.
   *)
  Fixpoint numInstructions (p : Prog) : nat.
  Admitted.

  Theorem numInstructions_Example :
    numInstructions (MulThen 5 (AddThen 2 Done)) = 2.
  Proof.
  Admitted.

  (* Define [concatProg] such that [concatProg p1 p2] is the program
   * that first runs [p1] and then runs [p2].
   *)
  Fixpoint concatProg (p1 p2 : Prog) : Prog.
  Admitted.

  Theorem concatProg_Example :
       concatProg (AddThen 1 Done) (MulThen 2 Done)
       = AddThen 1 (MulThen 2 Done).
  Proof.
  Admitted.

  (* Prove that the number of instructions in the concatenation of
   * two programs is the sum of the number of instructions in each
   * program.
   *)
  Theorem concatProg_numInstructions
    : forall (p1 p2 : Prog), numInstructions (concatProg p1 p2)
                        = numInstructions p1 + numInstructions p2.
  Proof.
  Admitted.

  (* Prove that running the concatenation of [p1] with [p2] is
     equivalent to running [p1] and then running [p2] on the
     result. *)
  Theorem concatProg_run
    : forall (p1 p2 : Prog) (initState : nat),
      run (concatProg p1 p2) initState =
      run p2 (run p1 initState).
  Proof.
  Admitted.

  (* Read this definition and understand how division by zero is handled. *)
  Fixpoint runPortable (p : Prog) (state : nat) : bool * nat :=
    match p with
    | Done => (true, state)
    | AddThen n p => runPortable p (n+state)
    | MulThen n p => runPortable p (n*state)
    | DivThen n p =>
        if n ==n 0 then (false, state) else
        runPortable p (state/n)
    | VidThen n p =>
        if state ==n 0 then (false, 0) else
        runPortable p (n/state)
    | SetToThen n p =>
        runPortable p n
    end.
  Arguments Nat.div : simpl never. (* you don't need to understand this line *)

  (* Here are a few examples: *)

  Definition goodProgram1 := AddThen 1 (VidThen 10 Done).
  Example runPortable_good : forall n,
    runPortable goodProgram1 n = (true, 10/(1+n)).
  Proof. simplify. equality. Qed.

  Definition badProgram1 := AddThen 0 (VidThen 10 Done).
  Example runPortable_bad : let n := 0 in
    runPortable badProgram1 n = (false, 0).
  Proof. simplify. equality. Qed.

  Definition badProgram2 := AddThen 1 (DivThen 0 Done).
  Example runPortable_bad2 : forall n,
    runPortable badProgram2 n = (false, 1+n).
  Proof. simplify. equality. Qed.

  (* Prove that running the concatenation [p] using [runPortable]
     coincides with using [run], as long as [runPortable] returns
     [true] to confirm that no divison by zero occurred. *)
  Lemma runPortable_run : forall p s0 s1,
    runPortable p s0 = (true, s1) -> run p s0 = s1.
  Proof.
  Admitted.

  (* The final goal of this pset is to implement [validate : Prog -> bool]
     such that if this function returns [true], the program would not trigger
     division by zero regardless of what state it starts out in.  [validate] is
     allowed to return [false] for some perfectly good programs that never cause
     division by zero, but it must recognize as good the examples given below.  In
     jargon, [validate] is required to be sound but not complete, but "complete
     enough" for the use cases defined by the examples given here: *)

  Definition goodProgram2 := AddThen 0 (MulThen 10 (AddThen 0 (DivThen 1 Done))).
  Definition goodProgram3 := AddThen 1 (MulThen 10 (AddThen 0 (VidThen 1 Done))).
  Definition goodProgram4 := Done.
  Definition goodProgram5 := SetToThen 0 (DivThen 1 Done).
  Definition goodProgram6 := SetToThen 1 (VidThen 1 Done).
  Definition goodProgram7 := AddThen 1 (DivThen 1 (DivThen 1 (VidThen 1 Done))).

  (* If you already see a way to build [validate] that meets the
   * requirements above, _and have a plan for how to prove it correct_,
   * feel free to just code away. Our solution uses one intermediate definition
   * and one intermediate lemma in the soundness proof -- both of which are more
   * sophisticated than the top-level versions given here. *)

  (* If a clear plan hasn't emerged in 10 minutes (or if you get stuck later),
   * take a look at the hints for this pset at the end of the signature file.
   * It is not expected that this pset is doable for everyone without the hints,
   * and some planning is required to complete the proof successfully.
   * In particular, repeatedly trying out different combinations of tactics
   * and ideas from hints until something sticks can go on for arbitrarily long
   * with little insight and no success; just guessing a solution is unlikely.
   * Thus, we encourage you to take your time to think, look at the hints when
   * necessary, and only jump into coding when you have some idea why it should
   * succeed. Some may call Coq a video game, but it is not a grinding contest. *)

  Definition validate (p : Prog) : bool.
  Admitted.

  (* Start by making sure that your solution passes the following tests, and add
   * at least one of your own tests: *)

  Example validate1 : validate goodProgram1 = true. Admitted.
  Example validate2 : validate goodProgram2 = true. Admitted.
  Example validate3 : validate goodProgram3 = true. Admitted.
  Example validate4 : validate goodProgram4 = true. Admitted.
  Example validate5 : validate goodProgram5 = true. Admitted.
  Example validate6 : validate goodProgram6 = true. Admitted.
  Example validate7 : validate goodProgram7 = true. Admitted.
  Example validateb1 : validate badProgram1 = false. Admitted.
  Example validateb2 : validate badProgram2 = false. Admitted.

  (* Then, add your own example of a bad program here, and check that `validate`
   * returns `false` on it: *)

  Definition badProgram3 : Prog. Admitted.
  Example validateb3 : validate badProgram3 = false. Admitted.

  (* Finally, before diving into the Coq proof, try to convince yourself that
   * your code is correct by applying induction by hand.  Can you describe the
   * high-level structure of the proof?  Which cases will you have to reason
   * about?  What do the induction hypotheses look like?  Which key lemmas do
   * you need?  Write a short (~10-20 lines) informal proof sketch before
   * proceeding. *)

  (** Proof sketch: **)
  (* [[Fill in your proof sketch here.]] *)

  (* Now you're ready to write the proof in Coq: *)

  Lemma validate_sound : forall p, validate p = true ->
    forall s, runPortable p s = (true, run p s).
  Admitted.

  (* Here is the complete list of commands used in one possible solution:
    - Search, for example Search (_ + 0).
    - induct, for example induct x
    - simplify
    - propositional
    - equality
    - linear_arithmetic
    - cases, for example cases (X ==n Y)
    - apply, for example apply H
    - apply in, for example apply H1 in H2 or apply somelemma in H1
    - apply with, for example apply H1 with (x:=2)
    - apply in with, for example apply H1 with (x:=2) in H2
    - rewrite, for example rewrite H
    - rewrite in, for example rewrite H1 in H2 or rewrite somelemma in H1
    - ;, for example simplify; propositional *)
End Impl.

(* The following line checks that your `Impl` module implements the right
   signature.  Make sure that it works, or the auto-grader will break!
   If there are mismatches, Coq will report them (`Signature components for
   label … do not match`): *)
Module ImplCorrect : Pset1Signature.S := Impl.


Require Export Induction.
Module Natlist.

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

  Check (pair 3 5).

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

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

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

  Compute (fst (3,5)).

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

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

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

  Theorem surjective_pairing' : forall (n m : nat),
      (n, m) = (fst (n, m), snd (n, m)).
  Proof.
    refine (fun n m => eq_refl).
  Qed.

  Theorem surjective_pairing : forall (p : natprod),
      p = (fst p, snd p).
  Proof.
    refine (fun p => match p with
                  | (x, y) => eq_refl
                  end).
  Qed.

  Theorem snd_fst_is_swap : forall (p : natprod),
      (snd p, fst p) = swap_pair p.
  Proof.
    refine (fun p => match p with
                  | (x, y) => eq_refl
                  end).
  Qed.

  Theorem fst_swap_is_snd : forall (p : natprod),
      fst (swap_pair p) = snd p.
  Proof.
    refine (fun p => match p with
                  | (x, y) => eq_refl
                  end).
  Qed.

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

  Definition mylist := cons 1 (cons 2 (cons 3 nil)).

  Notation "x :: l" := (cons x l)
                         (at level 60, right associativity).

  Notation "[ ]" := nil.
  Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

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

  Notation "x + y" := (plus x y)
                        (at level 50, left associativity).

  Fixpoint repeat (n count : nat) : natlist :=
    match count with
    | O => []
    | S count' => n :: repeat n count'
    end.

  Fixpoint length (l : natlist) : nat :=
    match l with
    | [] => O
    | _ :: tl => S (length tl)
    end.

  Fixpoint app (l1 l2 : natlist) : natlist :=
    match l1 with
    | [] => l2
    | h :: tl => h :: app tl l2
    end.

  Notation "x ++ y" := (app x y)
                         (right associativity, at level 60).
  Example test_app1: [1;2;3] ++ [4;5] = [1;2;3;4;5].
  Proof. reflexivity. Qed.
  Example test_app2: nil ++ [4;5] = [4;5].
  Proof. reflexivity. Qed.
  Example test_app3: [1;2;3] ++ nil = [1;2;3].
  Proof. reflexivity. Qed.

  Definition hd (default : nat) (l : natlist) : nat :=
    match l with
    | [] => default
    | h :: _ => h
    end.

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

  Example test_hd1: hd 0 [1;2;3] = 1.
  Proof. reflexivity. Qed.
  Example test_hd2: hd 0 [] = 0.
  Proof. reflexivity. Qed.
  Example test_tl: tl [1;2;3] = [2;3].
  Proof. reflexivity. Qed.

  Fixpoint nonzeros (l : natlist) : natlist :=
    match l with
    | [] => []
    | h :: t => if beq_nat h 0 then nonzeros t else h :: nonzeros t
    end.

  Example test_nonzeros:
    nonzeros [0;1;0;2;3;0;0] = [1;2;3].
  Proof.
    exact eq_refl.
  Qed.

  Fixpoint oddmembers (l : natlist) : natlist :=
    match l with
    | [] => []
    | h :: t => if evenb h then oddmembers t else h :: oddmembers t
    end.

  Example test_oddmembers:
    oddmembers [0;1;0;2;3;0;0] = [1;3].
  Proof.
    exact eq_refl.
  Qed.

  Definition countoddmembers (l : natlist) : nat :=
    length (oddmembers l).

  Example test_countoddmembers1:
    countoddmembers [1;0;3;1;4;5] = 4.
  exact eq_refl.
  Qed.

  Example test_countoddmembers2:
    countoddmembers [0;2;4] = 0.
  exact eq_refl.
  Qed.

  Example test_countoddmembers3:
    countoddmembers nil = 0.
  exact eq_refl.
  Qed.

  Fixpoint alternate (l1 l2 : natlist) : natlist :=
    match l1 with
    | [] => l2
    | h1 :: t1 => match l2 with
               | [] => h1 :: t1
               | h2 :: t2 => h1 :: h2 :: alternate t1 t2
                 end
    end.

  Example test_alternate1:
    alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6].
  exact eq_refl. Qed.

  Example test_alternate2:
    alternate [1] [4;5;6] = [1;4;5;6].
  cbn. exact eq_refl. Qed.

  Example test_alternate3:
    alternate [1;2;3] [4] = [1;4;2;3].
  exact eq_refl. Qed.

  Example test_alternate4:
    alternate [] [20;30] = [20;30].
  exact eq_refl. Qed.

  Definition bag := natlist.

  Fixpoint count (v : nat) (s : bag) : nat :=
    match s with
    | [] => 0
    | h :: t => if beq_nat v h then S (count v t) else count v t
    end.

  Example test_count1: count 1 [1;2;3;1;4;1] = 3.
  cbn. exact eq_refl.  Qed.

  Example test_count2: count 6 [1;2;3;1;4;1] = 0.
  exact eq_refl. Qed.

  Definition sum := app.

  Example test_sum1: count 1 (sum [1;2;3] [1;4;1]) = 3.
  exact eq_refl. Qed.

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

  Example test_add1: count 1 (add 1 [1;4;1]) = 3.
  exact eq_refl. Qed.

  Example test_add2: count 5 (add 1 [1;4;1]) = 0.
  exact eq_refl. Qed.

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

  Example test_member1: member 1 [1;4;1] = true.
  exact eq_refl. Qed.

  Example test_member2: member 2 [1;4;1] = false.
  exact eq_refl. Qed.

  Fixpoint remove_one (v : nat) (s : bag) : bag :=
    match s with
    | [] => []
    | h :: t => if beq_nat h v then t else h :: remove_one v t
    end.

  Example test_remove_one1:
    count 5 (remove_one 5 [2;1;5;4;1]) = 0.
  exact eq_refl. Qed.

  Example test_remove_one2:
    count 5 (remove_one 5 [2;1;4;1]) = 0.
  exact eq_refl. Qed.

  Example test_remove_one3:
    count 4 (remove_one 5 [2;1;4;5;1;4]) = 2.
  exact eq_refl. Qed.

  Example test_remove_one4:
    count 5 (remove_one 5 [2;1;5;4;5;1;4]) = 1.
  exact eq_refl. Qed.

  Fixpoint remove_all (v : nat) (s : bag) : bag :=
    match s with
    | [] => []
    | h :: t => if beq_nat v h then remove_all v t else h :: remove_all v t
    end.

  Example test_remove_all1: count 5 (remove_all 5 [2;1;5;4;1]) = 0.
  exact eq_refl. Qed.

  Example test_remove_all2: count 5 (remove_all 5 [2;1;4;1]) = 0.
  exact eq_refl. Qed.

  Example test_remove_all3: count 4 (remove_all 5 [2;1;4;5;1;4]) = 2.
  exact eq_refl. Qed.

  Example test_remove_all4: count 5 (remove_all 5 [2;1;5;4;5;1;4;5;1;4]) = 0.
  exact eq_refl. Qed.

  Fixpoint subset (s1 : bag) (s2 : bag) : bool :=
    match s1 with
    | [] => true
    | h :: t => if member h s2 then subset t (remove_one h s2) else false
    end.

  Example test_subset1: subset [1;2] [2;1;4;1] = true.
  exact eq_refl. Qed.

  Example test_subset2: subset [1;2;2] [2;1;4;1] = false.
  exact eq_refl. Qed.

  Theorem nil_app : forall l:natlist,
      [] ++ l = l.
    refine (fun l => eq_refl).
  Qed.

  Theorem tl_length_pred : forall l : natlist,
      pred (length l) = length (tl l).
  Proof.
    refine (fun l => match l with
                  | [] => eq_refl
                  | h :: t => eq_refl
                  end).
  Qed.

  Theorem app_assoc : forall l1 l2 l3 : natlist,
      (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
  Proof.
    refine (fix Fn l1 :=
              match l1 as l1' return (forall l2 l3,  (l1' ++ l2) ++ l3 = l1' ++ l2 ++ l3) with
              | [] => fun l2 l3 => eq_refl
              | h :: t => _ (* some more lemma *)
              end).
    cbn; intros l2 l3; f_equal; apply Fn.
  Qed.

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

  Example test_rev1: rev [1;2;3] = [3;2;1].
  Proof. reflexivity. Qed.
  Example test_rev2: rev nil = nil.
  Proof. reflexivity. Qed.

  Theorem app_length : forall l1 l2 : natlist,
      length (l1 ++ l2) = length l1 + length l2.
  Proof.
    refine (fix Fn l1 :=
              match l1 as l1' return
                    l1 = l1' ->  forall l2, length (l1' ++ l2) = length l1' + length l2 with
              | [] => fun H l2 => eq_refl
              | h :: t => fun H l2 => _
              end eq_refl).
    cbn; f_equal; apply Fn.
  Qed.

  Theorem rev_length : forall l : natlist,
      length (rev l) = length l.
  Proof.
    refine (fix Fn l :=
              match l as l' return l = l' ->  length (rev l') = length l' with
              | [] => fun H => eq_refl
              | h :: t => _
              end eq_refl).
    cbn; intro H. (* Now we need a way to discharge
                     length (rev t ++ [h]) = S (length t) => S (length (rev t)) = S (length t) *)
    rewrite app_length, plus_comm; cbn; f_equal; apply Fn.
  Qed.

  Inductive subsetrel : natlist -> natlist -> Type :=
  | emptylist l : subsetrel [] l
  | firstcons x l1 l2 : subsetrel l1 l2 -> subsetrel (x :: l1) (x :: l2)
  | secondcons x l1 l2 : subsetrel l1 l2 -> subsetrel l1 (x :: l2)
  | thirdcons x y l : subsetrel (x :: y :: l) (y :: x :: l).

  Example subset_rel1 : forall l, subsetrel [] l.
  refine (fun l => match l with
                | [] => emptylist []
                | h :: t => emptylist (h :: t)
                end).
  Qed.

  Theorem subset_connect : forall l1 l2, subset l1 l2 = true -> subsetrel l1 l2.
  Proof.
    induction l1.
    + cbn; intros l2 H.
      apply emptylist.
    + cbn; intros l2 H.
      remember (member n l2) as Hm.
      destruct Hm as [H1 | H1].
      (* At this point  true = member n l2 asserts that In n l2 -> l2 = l3 ++ [n] ++ l4
         But my subset relation is not good enough to capture it :( *)
  Admitted.

  Theorem app_nil_r : forall l : natlist,
      l ++ [] = l.
  Proof.
    refine (fix Fn l :=
              match l with
              | [] => eq_refl
              | h :: t => _
              end).
    cbn. rewrite Fn. exact eq_refl.  Show Proof.
  Qed.

  Theorem rev_app_distr: forall l1 l2 : natlist,
      rev (l1 ++ l2) = rev l2 ++ rev l1.
  Proof.
    refine (fix Fn l1 :=
              match l1 as l1' return l1 = l1' -> forall l2, rev (l1' ++ l2) = rev l2 ++ rev l1' with
              | [] => fun H l2 => _
              | h :: t => fun H l2 => _
              end eq_refl).
    cbn. rewrite app_nil_r. exact eq_refl.
    cbn. rewrite Fn, app_assoc. exact eq_refl.
  Qed.

  Theorem rev_involutive : forall l : natlist,
      rev (rev l) = l.
  Proof.
    refine (fix Fn l :=
              match l with
              | [] => eq_refl
              | h :: t => _
              end).
    cbn. rewrite rev_app_distr; cbn; f_equal; rewrite Fn; exact eq_refl.
  Qed.

  Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist,
      l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
  Proof.
    intros l1 l2 l3 l4.
    repeat rewrite app_assoc; exact eq_refl.
  Qed.

  Lemma nonzeros_app : forall l1 l2 : natlist,
      nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
  Proof.
    refine (fix Fn l1 :=
              match l1 with
              | [] => _
              | h :: t => _
              end).
    + cbn; intro l2; exact eq_refl.
    + cbn; intro l2. destruct (beq_nat h 0); try auto.
      cbn; f_equal. rewrite Fn. auto.
  Qed.

  Fixpoint beq_natlist (l1 l2 : natlist) : bool :=
    match l1, l2 with
    | [], [] => true
    | [], _ => false
    | _, [] => false
    | h1 :: t1, h2 :: t2 => if beq_nat h1 h2 then beq_natlist t1 t2 else false
    end.

  Example test_beq_natlist1 :
    (beq_natlist nil nil = true).
  cbn. auto. Qed.

  Example test_beq_natlist2 :
    beq_natlist [1;2;3] [1;2;3] = true.
  auto. Qed.

  Example test_beq_natlist3 :
    beq_natlist [1;2;3] [1;2;4] = false.
  auto. Qed.

  Theorem beq_natlist_refl : forall l:natlist,
      true = beq_natlist l l.
  Proof.
    refine (fix Fn l :=
              match l with
              | [] => eq_refl
              | h :: t => _
              end).
    cbn. remember (beq_nat h h) as Hb. destruct Hb as [Hb | Hb].
    apply Fn. assert (beq_nat h h = true). induction h.  inversion HeqHb.
    cbn in *. auto. rewrite <- HeqHb in H. inversion H.
  Qed.

  Theorem count_member_nonzero : forall (s : bag),
      leb 1 (count 1 (1 :: s)) = true.
  Proof.
    cbn. refine (fun H => eq_refl).
  Qed.

  Theorem ble_n_Sn : forall n,
      leb n (S n) = true.
  Proof.
    refine (fix Fn n :=
              match n with
              | O => eq_refl
              | S n' => _
              end).
    cbn. apply Fn.
  Qed.

  Theorem remove_does_not_increase_count: forall (s : bag),
      leb (count 0 (remove_one 0 s)) (count 0 s) = true.
  Proof.
    refine (fix Fn s :=
              match s with
              | [] =>  eq_refl
              | h :: t => _
              end).
    cbn. destruct h; cbn. rewrite ble_n_Sn; auto.
    apply Fn.
  Qed.

  Theorem rev_injective :
    forall (l1 l2 : natlist), rev l1 = rev l2 -> l1 = l2.
  Proof.
    intros l1 l2 H.
    rewrite <- rev_involutive.
    rewrite <- H. rewrite rev_involutive.
    auto.
  Qed.

  Fixpoint nth_bad (l:natlist) (n:nat) : nat :=
    match l with
    | nil => 42 (* arbitrary! *)
    | a :: l' => match beq_nat n O with
                | true => a
                | false => nth_bad l' (pred n)
                end
    end.

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

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

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

  Example test_nth_error2 : nth_error [4;5;6;7] 3 = Some 7.
  auto. Qed.

  Example test_nth_error3 : nth_error [4;5;6;7] 9 = None.
  auto. Qed.

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

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

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

  Example test_hd_error1 : hd_error [] = None.
  auto. Qed.

  Example test_hd_error2 : hd_error [1] = Some 1.
  auto. Qed.

  Example test_hd_error3 : hd_error [5;6] = Some 5.
  auto. Qed.

  Theorem option_elim_hd : forall (l:natlist) (default:nat),
      hd default l = option_elim default (hd_error l).
  Proof.
    refine (fix Fn l :=
              match l with
              | [] => _
              | h :: t => _
              end).
    + cbn; intro default; try auto.
    + cbn; intro default; try auto.
  Qed.

End Natlist.

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

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

Theorem beq_id_refl : forall x, true = beq_id x x.
Proof.
  intro x. destruct x; cbn.
  induction n; try auto.
Qed.

Module PartialMap.
  Export Natlist.

  Inductive partial_map : Type :=
  | empty : partial_map
  | record : id -> nat -> partial_map -> partial_map.

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

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

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

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

End PartialMap.


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

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

Eval simpl in (next_weekday friday).
Compute (next_weekday (next_weekday saturday)).

Example test_next_weekday:
 (next_weekday (next_weekday saturday)) = tuesday.

simpl. reflexivity. Qed.
(* "The assertion we've just made can be proved by observing that both sides
of the equality evaluate to the same thing, after some simplification."*)

Extraction Language Haskell.
Extraction "day.hs" day next_weekday.

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

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

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

Example test_and: (and true true) = true.
Proof. simpl. reflexivity. Qed.

Infix "&&" := and.

Eval simpl in (true && true).

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

Infix "||" := or.

Definition nandb (b1:bool) (b2:bool) : bool := not (b1 && b2).

Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

Compute (false || (not (true && (not false)))).
Check and.

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
  b1 && b2 && b3. (* and (and b1 b2) b3 *)

Example test_andb31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

Module Playground1.

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

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

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

Compute (succ (S O)).

Extraction Language Haskell.
Extraction "nat.hs" nat pred.

End Playground1.

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

Compute (minusTwo 5).
Check S.
Check pred.
Check minusTwo.

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

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

Example test_oddb1: oddb 1 = true.
Proof. simpl. reflexivity. Qed.
Example test_oddb2: oddb 4 = false.
Proof. reflexivity. Qed.

Module Playground2.

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

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

Example test_plus: plus 5 5 = 10.
Proof. simpl. reflexivity. Qed.

Compute (plus 5 5).

End Playground2.

Fixpoint exp (base power : nat) : nat :=
  match power with
    | O => S O
    | S p => mult base (exp base p)
  end.

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

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

Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. simpl. reflexivity. Qed.

Notation "x + y" := (plus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x - y" := (minus x y)
                       (at level 50, left associativity)
                       : nat_scope.

Notation "x + y" := (plus x y)
                       (at level 50, left associativity)
                       : nat_scope.

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

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

Example test_beq_nat: (beq_nat 5 5) = (beq_nat2 5 5).
Proof. simpl. reflexivity. Qed.

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

Example test_leb1: (leb 2 2) = true.
Proof. simpl. reflexivity. Qed.
Example test_leb2: (leb 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_leb3: (leb 4 2) = false.
Proof. simpl. reflexivity. Qed.

(* less than for natural numbers *)
Definition blt_nat (n m : nat) : bool :=
  leb n m && not (beq_nat n m)
.

Example test_blt_nat1: (blt_nat 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_blt_nat2: (blt_nat 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_blt_nat3: (blt_nat 4 2) = false.
Proof. simpl. reflexivity. Qed.

(* Proof by Simplification *)
(* (Until now) The proofs of these claims were always the same: use simpl
 to simplify both sides of the equation, then use reflexivity to check that
 both sides contain identical values.*)

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

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

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

(* Example and Theorem (and a few others, including Lemma, Fact, and Remark)
   mean exactly the same thing to Coq*)

(* Theorem plus_n_O : forall n, n = n + 0.
Proof.
  intros n. simpl. *)

Theorem plus_id_example : forall n m: nat, n = m -> n+n = m+m .
Proof.
  (* move both quantifiers into the context: *)
  intros n m.
  (* move the hypothesis into the context: *)
  intros H.
  (* rewrite the goal using the hypothesis: *)
  rewrite -> H.
  reflexivity. Qed.

(* The first line of the proof moves the universally quantified variables
   n and m into the context.
   The second moves the hypothesis n = m into the context and gives it the name H.
   The third tells Coq to rewrite the current goal (n + n = m + m) by
   replacing the left side of the equality hypothesis H with the right side. *)

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

Theorem mult_0_plus : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  rewrite -> plus_O_n.
  reflexivity. Qed.

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

(* Proof by case analysis *)

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


Require Import Arith.

Definition zero_one_dec : forall n:nat, n<=1 -> {n=0}+{n=1}.
 simple destruct n.
 left; auto.
 simple destruct n0.
 right; auto.
 intros  n1 H1; absurd (S (S n1) <= 1); auto with arith.
Defined.

Definition div2_mod2 :
  forall n:nat, {q:nat & {r:nat | n = 2*q + r /\ r <= 1}}.
 induction n.
 exists 0; exists 0; simpl; auto with arith.
 case IHn; intros q' Hq'; case Hq'; intros r' [H1 H2]; simpl.
 case (zero_one_dec  r' H2); intro H3.
 Require Import Omega.
 exists q'; exists 1; omega.
 exists (S q'); exists 0; omega.
Defined.


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

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

Compute (next_day friday).

Example example: next_day monday = tuesday.
Proof. simpl. reflexivity. Qed.

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

(* Exercise: 1 star (nandb) *)

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

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

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

Compute (nandb true true).

Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

(* Exercise: 1 star (andb3) *)

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

       end.

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

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

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

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

Example test_andb31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

Check andb3.

Module NatPlayground.

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

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

Check (S(S(O))).

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

Compute (plus 5 4).

(* Exercise: 1 star (factorial)*)

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

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

Compute (factorial (S(S(S(S(O)))))).

Example test_factorial1: (factorial 3) = 6.
Proof. reflexivity. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. reflexivity. Qed.

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

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

Compute (leq1 (S(S(S(S(O))))) (S(S(S(S(O)))))).

(* Exercise: 1 star (blt nat)) *)

Definition blt_nat (n m : nat) : bool :=
     andb (leq1 n m) (negb (beq_nat n m)).

Example test_blt_nat1: (blt_nat 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_blt_nat2: (blt_nat 2 4 ) = true.
Proof. simpl. reflexivity. Qed.
Example test_blt_nat3: (blt_nat 4 2) = false.
Proof. simpl. reflexivity. Qed.

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

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

(*Exercise: 1 star (plus id exercise) *)
Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o .
  intros H.
  intros G.
  rewrite -> H.
  rewrite -> G.
  reflexivity.
  Qed.

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

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

Theorem mult_0_plus : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  rewrite -> plus_0_n.
  reflexivity. Qed.

(* exercise: 2 stars (mult S 1) *)

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

(*Exercise: 1 star (zero_nbeq_plus_1)*)

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

(*
Exercise: 2 stars (andb_eq_orb)*)

Theorem andb_eq_orb : forall (b c : bool),
  (andb b c = orb b c) ->  b = c.
Proof.
  intros b c. destruct b.
   simpl.
   intros H.
   rewrite -> H.
   reflexivity.
   simpl.
   intros G.
   rewrite -> G. reflexivity. Qed.

(* Exercise: 2 stars (andb_true_elim2) *)

Theorem andb_true_elim2 : forall b c :bool,
  andb b c = true ->
  c = true.
Proof. intros b c . destruct b. simpl.
       intros H.
       rewrite -> H.
       reflexivity.
       simpl.
       intros G.
       rewrite <- G.
       destruct c.
       rewrite -> G.
       reflexivity.
       reflexivity. Qed.
        (* a little bit long, but that's my best solution for now *)

Theorem andb3_exchange :
  forall b c d, andb (andb b c) d = andb (andb b d) c.
Proof.
  intros b c d. destruct b.
  - destruct c.
    { destruct d.
      - reflexivity.
      - reflexivity. }
    { destruct d.
      - reflexivity.
      - reflexivity. }
  - destruct c.
    { destruct d.
      - reflexivity.
      - reflexivity. }
    { destruct d.
      - reflexivity.
      - reflexivity. }
Qed.

(* Exercise: 2 starsM (boolean_functions)*)

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


(* From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat. *)
From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.

Module Playground1.
Theorem modus_ponens : forall (P Q : Prop),
  (P -> Q) -> P -> Q.
Proof.
  move=> P Q PiQ P_holds.
  (* apply PiQ. clear PiQ. *)
  apply: PiQ.
  exact: P_holds.
Qed.

(* Since we know that [P -> Q], proving that [P] holds would also
   prove that [Q] holds. Therefore, we use [apply] to transform our goal. *)

Theorem modus_ponens_imp : forall (P Q : Prop),
  (P -> Q) -> P -> Q.
Proof.
  move=> P Q PiQ P_holds.
  (* apply PiQ. clear PiQ. *)
  move: PiQ.
  apply.
  exact: P_holds.
Qed.

(* Alternatively, we notice that [P] holds in our context, and
   because we know that [P -> Q], we can [apply] that implication to
   our hypothesis that [P] holds to transform it. *)

Theorem modus_ponens' : forall (P Q : Prop),
  (P -> Q) -> P -> Q.
Proof.
  move=> P Q PiQ P_holds.
  apply PiQ in P_holds.
  (* clear PiQ. *)
  exact: P_holds.
Qed.

(* Note that this replaces our previous hypothesis (and now its
   name is no longer very applicable)! To prevent this, we can give
   our new hypothesis its own name using the [apply..in..as..] syntax. *)

Theorem modus_ponens'' : forall (P Q : Prop),
  (P -> Q) -> P -> Q.
Proof.
  move=> P Q PiQ P_holds.
  apply PiQ in P_holds as Q_holds. (* give a new name to our hypothesis *)
  (* clear PiQ P_holds. *)
  exact Q_holds.
Qed.

Section LongSmth.
Variables A B C D E F G : Prop.
Lemma long_smth' :
  (A -> B -> C -> D) -> (A -> B -> C) -> (A -> B) -> A -> D.
Proof.
  move=> H1 H2 H3 H4.
  move: H2.
  (* Здесь C (заключение импликации) сопоставляется с D (хвост цели).
     А они не одинаковы, получаем ошибку. *)
  Undo 1.
  move: H1. apply. exact H4.
  move: H3. apply. exact H4.
  move: H2. apply. exact H4.
  move: H3. apply. exact H4.
  Undo 12.
  exact: (H1 H4 (H3 H4) (H2 H4 (H3 H4))).
Qed.
End LongSmth.

End Playground1.


(******************************************************************************)
(* A formalization of Folia                                                   *)
(*   Folia is a problem in a competitive programming contest, NOMURA          *)
(* programming contest 2020. The problem is described as follows [1]:         *)
(*                                                                            *)
(* ``` (the beginning of a quote)                                             *)
(* Given is an integer sequence of length N + 1: A[0], A[1], A[2], ..., A[N]. *)
(* Is there a binary tree of depth N such that, for each d = 0, 1, ..., N,    *)
(* there are exactly A[d] leaves at depth d? If such a tree exists, print the *)
(* maximum possible number of vertices in such a tree; otherwise, print −1.   *)
(* ``` (the end)                                                              *)
(*                                                                            *)
(*   This file extends the problem in the following way:                      *)
(* - Besides the maximum possible number, compute the minimum possible number *)
(* - Replace "a binary tree" in the above statement with a set of n binary    *)
(*   trees (a forest); the generalization naturally arises in ensuring the    *)
(*   correctness of a solution for the original version. Suppose that you     *)
(*   prove its correctness by structural induction on the sequence [A[0], ... *)
(*   A[N]]. In this case, the induction hypothesis gives information on all   *)
(*   nodes in a tree except the root, in other words, the second layer (depth *)
(*   2) and the lower layers. Since removing the root from a tree may create  *)
(*   some trees but not a single tree, it is necessary to extend the problem  *)
(*   to forests.                                                              *)
(* Then this file verifies the extended version as follows:                   *)
(* 1. Define functions computing a bound (lb, ub) (a pair of a lower bound    *)
(*    and an upper bound) of the size of forests satisfying the condition on  *)
(*    leaves. These functions ignore the condition on the size of forests.    *)
(* 2. Prove that there exists a forest of size n with the desired property if *)
(*    and only if lb <= n <= ub, which shows that (lb, ub) is a tight bound.  *)
(* 3. Define functions computing a bound (lb', ub') of the total numbers of   *)
(*    nodes in forests consisting n trees and satisfying the condition on     *)
(*    leaves.                                                                 *)
(* 4. Prove that there exists a forest that has n trees and m nodes in total  *)
(*    if and only if lb <= n <= ub and lb' <= m <= ub', which shows that      *)
(*    (lb', ub') is a tight bound.                                            *)
(* 5. Define functions that are equivalent to the ones described in (1) but   *)
(*    are efficiently computed.                                               *)
(*                                                                            *)
(*   As a result, we can solve the problem in the following way:              *)
(* 1. Calculate lb and ub                                                     *)
(* 2. Check if lb <= n <= ub. If so, go to (3); otherwise print -1            *)
(* 3. Calculate lb' and ub' and print them                                    *)
(*                                                                            *)
(* References:                                                                *)
(* [1] https://atcoder.jp/contests/nomura2020/tasks/nomura2020_c              *)
(*                                                                            *)
(* Binary trees and their forests                                             *)
(*             bintree := a binary tree                                       *)
(*              forest := a sequence of trees                                 *)
(*        count_node t := the number of nodes on a tree t                     *)
(* count_node_forest f := the number of nodes on a forest f                   *)
(*          subtrees t := trees just below the root of a tree t               *)
(*         subforest f := subtrees of trees in a forest f                     *)
(*                                                                            *)
(* Specifications of leaves:                                                  *)
(*             leave_spec := a sequence specifying the number of leaves at    *)
(*                           each level in a forest                           *)
(* satisfy_leave_spec f s := check whether a forest f satisfies a spec s      *)
(*                           (for a tree t, use satisfy_leave_spec [:: t] s)  *)
(*                                                                            *)
(* Forest lifts:                                                              *)
(*    simple_lift f : adds one node on to the top of each tree in a forest f  *)
(* pairing_lift p f : divides trees in a forest f into p pairs and other      *)
(*                    individuals, and adds one node on to the top of each    *)
(*                    group                                                   *)
(*                                                                            *)
(* Bounds:                                                                    *)
(*     lower_bound_bottomup s, : a tight bound of the size of forests that    *)
(*     upper_bound_bottomup s    satisfy a spec s; see in_bottomup_boundP     *)
(* lower_bounds_backforth s n, : tight bounds of the number of nodes at all   *)
(* upper_bounds_backforth s n    levels of forests consisting n trees and     *)
(*                               satisfying a spec s                          *)
(*      lower_bound_total s n, : a tight bound of the total numbers of nodes  *)
(*      upper_bound_total s n    in forests consisting n trees and satisfying *)
(*                               a spec s; see in_total_boundP                *)
(*                                                                            *)
(* Efficiently computed bounds:                                               *)
(*    lower_bounds_topdown s n, : bounds of the number of nodes at all levels *)
(*    upper_bounds_topdown s n    of forests consisting n trees and           *)
(*                                satisfying a spec s; they may not be tight  *)
(* lower_bounds_backforth' s n, : the same as lower/upper_bound_backforth     *)
(* upper_bounds_backforth' s n                                                *)
(*      lower_bound_total' s n, : the same as lower/upper_bound_total; the    *)
(*      upper_bound_total' s n    time complexity is Θ(|s|) (|s| is the size  *)
(*                                of s)                                       *)
(******************************************************************************)

From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

From Coq Require Import Lia.
From mathcomp.zify Require Import zify.

Section SsrnatExt.
Lemma leq_div2 n : n./2 <= n.
Proof. by rewrite -divn2 leq_div. Qed.

Lemma leq_uphalf n : uphalf n <= n.
Proof.
  (* TODO: Use leqRHS instead of [in X in _ <= X] in the later versions of MathComp 1.15.0 *)
  rewrite [in X in _ <= X](divn_eq n 2) addnC uphalf_half -modn2 -divn2.
  by apply: leq_add => //; apply: leq_pmulr.
Qed.

(* Note: homo_maxl can be generalized as follows: if a <= b and c <= d, then  *)
(* maxn a c <= maxn b d                                                       *)
Lemma homo_maxl n :
  {homo maxn n : m l / m <= l}.
Proof.
  move=> m l leq_ml.
  by rewrite geq_max leq_maxl leq_max leq_ml orbT.
Qed.

Lemma homo_minl n :
  {homo minn n : m l / m <= l}.
Proof.
  move=> m l leq_ml.
  by rewrite leq_min geq_minl geq_min leq_ml orbT.
Qed.
End SsrnatExt.

Section SeqExt.
Lemma flatten_nseq_nil (T : Type) (n : nat) :
  @flatten T (nseq n [::]) = [::].
Proof. by elim: n. Qed.

Section Map.
  Variable A B C : Type.

  (* Note: [map2] is defined by fix, instead of Fixpoint, to exclude [f] from the recursive definition *)
  Definition map2 (f : A -> B -> C) :=
    fix map2 (s1 : seq A) (s2 : seq B) :=
      match s1, s2 with
        x :: s1', y :: s2' => f x y :: map2 s1' s2'
      | _, _ => [::]
      end.
End Map.

Section Scan.
Variable T S : Type.
Variable f : T -> S -> S.
Variable y0 : S.

(* Note: scanr_aux corresponds to scanr in Haskell, although the former       *)
(* definition is rather complicated than the latter one. In Coq, partial      *)
(* functions are rejected so it is required to guarantee that scanr_aux does  *)
(* not return the empty sequence.                                             *)
Fixpoint scanr_aux (s : seq T) : {r : seq S | size r > 0} :=
  match s with
    [::] => exist _ [:: y0] erefl
  | x :: s' =>
      match scanr_aux s' with
        exist r Hr =>
          (match r return size r > 0 -> {r : seq S | size r > 0} with
             [::] => fun cont => match notF cont with end
           | y :: _ => fun Hr => exist _ (f x y :: r) erefl
           end) Hr
      end
  end.

Lemma scanr_auxE (x : T) (s' : seq T) :
  scanr_aux (x :: s') =
    match scanr_aux s' with
      exist r Hr =>
        (match r return size r > 0 -> {r : seq S | size r > 0} with
           [::] => fun cont => match notF cont with end
         | y :: _ => fun Hr => exist _ (f x y :: r) erefl
         end) Hr
    end.
Proof. by []. Qed.

Definition scanr (s : seq T) := proj1_sig (scanr_aux s).

Lemma scanrE (x : T) (s : seq T) :
  scanr (x :: s) = foldr f y0 (x :: s) :: scanr s.
Proof.
  rewrite /scanr.
  elim: s => // x' s' IH in x *.
  rewrite scanr_auxE.
  case: (scanr_aux (x' :: s')) (IH x') => /= r Hr Er.
  rewrite Er /= in Hr *.
  by congr (_ :: _).
Qed.
End Scan.
End SeqExt.

Section BinaryTree.
Inductive bintree := L | B1 of bintree | B2 of bintree & bintree.
Definition forest := seq bintree.

Fixpoint bintree_eq (t1 t2 : bintree) :=
  match t1, t2 with
  | L, L => true
  | B1 t1', B1 t2' => bintree_eq t1' t2'
  | B2 t11 t12, B2 t21 t22 => bintree_eq t11 t21 && bintree_eq t12 t22
  | _, _ => false
  end.

Lemma bintree_eqP : Equality.axiom bintree_eq.
Proof.
move=> t1 t2; apply/(iffP idP).
- elim: t1 t2 => [| t1' IH | t11 IH1 t12 IH2].
  + by case.
  + by case => //= t2' E; congr B1; apply: IH.
  + by case => //= t21 t22 /andP [E1 E2]; congr B2; [ apply: IH1 | apply: IH2 ].
- by move<-; elim: t1 => //= t11 IH1 t12 IH2; rewrite IH1 IH2.
Qed.

Canonical bintree_eqMixin := EqMixin bintree_eqP.
Canonical bintree_eqType := Eval hnf in EqType bintree bintree_eqMixin.

Fixpoint count_node (t : bintree) :=
  match t with
    L => 1
  | B1 t1 => (count_node t1).+1
  | B2 t1 t2 => (count_node t1 + count_node t2).+1
  end.

Definition count_node_forest (f : forest) :=
  sumn (map count_node f).

Lemma count_node_forest_cat (f1 f2 : forest) :
  count_node_forest (f1 ++ f2) = count_node_forest f1 + count_node_forest f2.
Proof. by rewrite /count_node_forest map_cat sumn_cat. Qed.

Lemma count_node_forest_nseq n t :
  count_node_forest (nseq n t) = (count_node t) * n.
Proof. by rewrite /count_node_forest map_nseq sumn_nseq. Qed.

Definition subtrees (t : bintree) : forest :=
  match t with
    L => [::]
  | B1 t => [:: t]
  | B2 t1 t2 => [:: t1; t2]
  end.

Definition subforest (f : forest) : forest :=
  flatten (map subtrees f).

Lemma subforest_cat f1 f2 :
  subforest (f1 ++ f2) = subforest f1 ++ subforest f2.
Proof. by rewrite /subforest map_cat flatten_cat. Qed.

Lemma subforest_nseq n t :
  subforest (nseq n t) = flatten (nseq n (subtrees t)).
Proof. by rewrite /subforest map_nseq. Qed.

Lemma eq_count_node t :
  count_node t = (count_node_forest (subtrees t)).+1.
Proof.
  rewrite /count_node_forest.
  by case: t => //= [t1 | t1 t2]; rewrite addn0.
Qed.

Lemma eq_count_node_forest f :
  count_node_forest f = size f + count_node_forest (subforest f).
Proof.
  rewrite /count_node_forest /subforest.
  elim: f => //= t0 f' IH.
  rewrite map_cat sumn_cat.
  (* Note: addn.[AC (2*2) ((3*2)*(1*4))] replaces a term like (a + b) + (c + d) *)
  (* with (c + b) + (a + d). In general, MathComp provides a handy tool to      *)
  (* rewrite terms built by an operation using its commutativity and its        *)
  (* associativity; see ssrAC.v in MathComp.                                    *)
  rewrite -addn1 addn.[AC (2*2) ((3*2)*(1*4))] addn1.
  congr (_ + _) => //.
  by apply: eq_count_node.
Qed.
End BinaryTree.

Section LeaveSpec.
Definition leave_spec := seq nat.

Fixpoint satisfy_leave_spec (f : forest) (s : leave_spec) :=
  match s with
    [::] => f == [::]
  | l0 :: s' =>
      let f' := subforest f in
      (count_mem L f == l0) && satisfy_leave_spec f' s'
  end.
End LeaveSpec.

(******************************************************************************)
(* Step 1: Compute a bound of the size of forests                             *)
(******************************************************************************)

Definition lower_bound_bottomup (s : leave_spec) :=
  foldr (fun l0 lb => l0 + uphalf lb) 0 s.

Definition upper_bound_bottomup (s : leave_spec) :=
  foldr (fun l0 ub => l0 + ub) 0 s.

Lemma leq_bottomup_bound (s : leave_spec) :
  lower_bound_bottomup s <= upper_bound_bottomup s.
Proof.
  elim: s => //= l0 s' IH.
  by rewrite leq_add2l (leq_trans _ IH) ?leq_uphalf.
Qed.

Section ForestLift.
Definition simple_lift (f : forest) := map B1 f.

Fixpoint pairing_lift (p : nat) (f : forest) :=
  match p, f with
    p'.+1, t0 :: t1 :: f' => B2 t0 t1 :: pairing_lift p' f'
  | _, _ => simple_lift f
  end.

Lemma subforest_simple_lift f :
  subforest (simple_lift f) = f.
Proof.
  rewrite /subforest.
  elim: f => //= t0 f' IH.
  by congr (_ :: _).
Qed.

Lemma subforest_pairing_lift p f :
  subforest (pairing_lift p f) = f.
Proof.
  rewrite /subforest.
  elim: p f => [| p' IH]; first by apply: subforest_simple_lift.
  case => [| t0 [| t1 f']] //=.
  by congr (_ :: _ :: _).
Qed.

Lemma size_simple_lift f :
  size (simple_lift f) = size f.
Proof. by rewrite size_map. Qed.

Lemma size_pairing_lift p f :
  p <= half (size f) ->
  size (pairing_lift p f) = size f - p.
Proof.
  elim: p => [| p' IH] in f *.
  - by rewrite subn0 size_simple_lift.
  - case: f => [| t0 [| t1 f']] //= /[!ltnS] ltn_p'.
    rewrite subSS subSn; last first.
    + by apply/(leq_trans ltn_p')/leq_div2.
    + by congr _.+1; apply: IH.
Qed.

Lemma count_mem_L_simple_lift f :
  count_mem L (simple_lift f) = 0.
Proof. by rewrite count_map count_pred0. Qed.

Lemma count_mem_L_pairing_lift p f :
  count_mem L (pairing_lift p f) = 0.
Proof.
  elim: p => [| p' IH] in f *; first by rewrite count_mem_L_simple_lift.
  case: f => [| t0 [| t1 f']] //=.
  by rewrite add0n.
Qed.

Lemma count_node_forest_pairing_lift p f :
  p <= half (size f) ->
  count_node_forest (pairing_lift p f) = count_node_forest f + (size f - p).
Proof.
  move=> ltn_p.
  rewrite eq_count_node_forest.
  by rewrite size_pairing_lift // subforest_pairing_lift addnC.
Qed.
End ForestLift.

Lemma in_size_forest f :
  count_mem L f + uphalf (size (subforest f)) <= size f <= count_mem L f + size (subforest f).
Proof.
  rewrite /subforest.
  elim: f => // t0 f' IH.
  case: t0 => [| t0' | t01 t02] /=.
  - by rewrite add1n !addSn ltnS.
  - case/andP: IH => IHlb IHub.
    rewrite add0n !addnS !ltnS; apply/andP; split => //.
    by rewrite (leq_trans _ IHlb) ?leq_add2l ?uphalf_half ?leq_addl.
  - case/andP: IH => IHlb IHub.
    rewrite add0n !addnS !ltnS; apply/andP; split => //.
    by rewrite (leq_trans IHub).
Qed.

(******************************************************************************)
(* Step 2: Prove the existence of a forest whose size is included in the      *)
(*         bound defined in Step 1                                            *)
(******************************************************************************)

Proposition in_bottomup_boundP (n : nat) (s : leave_spec) :
  reflect (exists2 f, size f = n & satisfy_leave_spec f s) (lower_bound_bottomup s <= n <= upper_bound_bottomup s).
Proof.
  apply: (iffP idP).
  - elim: s => [| l0 s' IH] /= in n *.
    + by rewrite leqn0 => /eqP ->; exists [::].
    + move=> ineq_n.
      set lbb' := lower_bound_bottomup s'.
      set ubb' := upper_bound_bottomup s'.
      (* the number of internal nodes on the top *)
      set i0 := n - l0.
      case: (leqP lbb' i0).
      * (* The case where lbb' <= i0:                                                 *)
        (*   Since lbb' <= i0 <= ubb', using the induction hypothesis, we obtain a    *)
        (* forest f' of size i0 satisfying the spec s'. We can construct a desired    *)
        (* forest from f' by adding one node on to the top of each tree in f' and     *)
        (* creating l0 roots. The total number of trees is i0 + l0 = n.               *)
        move=> le_lbb'_i0.
        have ineq_i0 : lbb' <= i0 <= ubb' by lia.
        case: (IH _ ineq_i0) => f' eq_size_f' sat_f'.
        exists (simple_lift f' ++ nseq l0 L).
        -- by rewrite size_cat size_simple_lift eq_size_f' size_nseq; lia.
        -- apply/andP; split.
           ++ by rewrite count_cat count_mem_L_simple_lift count_nseq mul1n.
           ++ rewrite subforest_cat subforest_simple_lift.
              by rewrite subforest_nseq flatten_nseq_nil cats0.
      * (* The case where i0 < lbb':                                                  *)
        (*   Since lbb' <= lbb' <= ubb', using the induction hypothesis, we obtain a  *)
        (* forest f' of size lbb' satisfying the spec s'. Combining trees in f', we   *)
        (* can make at most floor(lbb' / 2) pairs. By the hypothesis on n, we obtain  *)
        (* the inequality lbb' - i0 <= floor(lbb' / 2). Hence we can make lbb' - i0   *)
        (* pairs. Using them, we construct a desired forest. We first connect each    *)
        (* pair with one node, then, for the remaining trees, add one node on to the  *)
        (* top of each tree. Finally, we create l0 roots. The size of the resulting   *)
        (* forest is (lbb' - i0) + (lbb' - 2 * (lbb' - i0)) + l0 = n.                 *)
        move=> lt_i0_lbb'.
        have ? := leq_bottomup_bound s'.
        have ineq_lbb' : lbb' <= lbb' <= ubb' by lia.
        case: (IH _ ineq_lbb') => f' eq_size_f' sat_f'.
        exists (pairing_lift (lbb' - i0) f' ++ nseq l0 L).
        -- by rewrite size_cat size_pairing_lift ?eq_size_f' ?size_nseq; lia.
        -- apply/andP; split.
           ++ by rewrite count_cat count_mem_L_pairing_lift count_nseq mul1n.
           ++ rewrite subforest_cat subforest_pairing_lift.
              by rewrite subforest_nseq flatten_nseq_nil cats0.
  - elim: s => [| l0 s' IH] in n *.
    + by case; case; case: n. (* :) *)
    + set lbb' := lower_bound_bottomup s'.
      set ubb' := upper_bound_bottomup s'.
      case => f Esize /= /andP [/eqP EcountL sat].
      have /[!Esize] /[!EcountL] := in_size_forest f.
      have : lbb' <= size (subforest f) <= ubb'.
      { by apply: IH; exists (subforest f). }
      by lia.
Qed.

(******************************************************************************)
(* Step 3: Define a bound of the number of nodes                              *)
(******************************************************************************)

Fixpoint lower_bounds_backforth (s : leave_spec) (n : nat) :=
  match s with
    [::] => [::]
  | l0 :: s' =>
      n :: lower_bounds_backforth s' (maxn (lower_bound_bottomup s') (n - l0))
  end.

Fixpoint upper_bounds_backforth (s : leave_spec) (n : nat) :=
  match s with
    [::] => [::]
  | l0 :: s' =>
      n :: upper_bounds_backforth s' (minn (upper_bound_bottomup s') (n - l0).*2)
  end.

(* N.B. lower/upper_bounds_total are slow. The time complexity is Θ(|s|^2).   *)
(* We will define the faster version in Step 5; see lower/upper_bound_total'. *)
Definition lower_bound_total s n :=
  sumn (lower_bounds_backforth s n).

Definition upper_bound_total s n :=
  sumn (upper_bounds_backforth s n).

Lemma homo_lower_bound_total s :
  {homo lower_bound_total s : n m / n <= m}.
Proof.
  rewrite /lower_bound_total.
  elim: s => //= l0 s' IH n m leq_nm.
  by apply/leq_add => //; apply/IH/homo_maxl/leq_sub2r.
Qed.

Lemma homo_upper_bound_total s :
  {homo (upper_bound_total s) : n m / n <= m}.
Proof.
  rewrite /upper_bound_total.
  elim: s => //= l0 s' IH n m leq_nm.
  apply/leq_add => //; apply/IH.
  by rewrite homo_minl ?leq_double ?leq_sub2r.
Qed.

Lemma leq_total_bound s n m :
  [&& lower_bound_bottomup s <= n, n <= m & m <= upper_bound_bottomup s] ->
  lower_bound_total s n <= upper_bound_total s m.
Proof.
  rewrite /lower_bound_total /upper_bound_total.
  elim: s => //= l0 s' IH in n m *.
  move=> ineq_nm.
  apply: leq_add; first by lia.
  by apply: IH; move: (leq_bottomup_bound s'); lia.
Qed.

(* The lemma below shows that the closed intervals of the form                *)
(*   [lower_bound_total s n, upper_bound_total s n]                           *)
(*   (lower_bound_bottomup s <= n <= upper_bound_bottomup s)                  *)
(* can be depicted as follows (double-headed arrows represent intervals):     *)
(*                                                                            *)
(*              1st: <-------->                                               *)
(*              2nd:       <------>                                           *)
(*              3rd:            <------->                                     *)
(*                                    <--- ........ --->                      *)
(* the last but one:                                  <---->                  *)
(*         the last:                                      <------>            *)
(*                                                                            *)
(* This picture tells us that they cover the closed interval                  *)
(*   [lower_bound_total s (lower_bound_bottomup s),                           *)
(*    upper_bound_total s (upper_bound_bottomup s)].                          *)
Lemma consecutive_total_bounds_touch_each_other s n :
  lower_bound_bottomup s <= n ->
  n.+1 <= upper_bound_bottomup s ->
  lower_bound_total s n <= lower_bound_total s n.+1 <= (upper_bound_total s n).+1.
Proof.
  rewrite /lower_bound_total /upper_bound_total.
  case: s => //= l0 s' in n *.
  move=> geq_n leq_n1.
  apply/andP; split.
  - rewrite ltnW // addSn ltnS leq_add2l homo_lower_bound_total //.
    by lia.
  - rewrite addSn ltnS leq_add2l.
    apply: leq_total_bound.
    apply/and3P; split; [ apply: leq_maxl | | apply: geq_minl ].
    have := leq_bottomup_bound s'.
    suff : 1 <= n - l0 by lia.
    rewrite ltnNge.
    apply/negP => leq_nl0.
    have : upper_bound_bottomup s' > 0 by lia.
    apply/negP.
    rewrite -leqNgt leqn0.
    have : lower_bound_bottomup s' == 0 by lia.
    elim: s' {l0 n geq_n leq_n1 leq_nl0} => //= l1 s'' IH.
    by lia.
Qed.

Lemma interval_chain_forms_closed_interval (f g : nat -> nat) (a b n : nat) :
  a <= b ->
  (forall x, a <= x <= b -> f x <= g x) ->
  (forall x, a <= x -> x.+1 <= b -> f x <= f x.+1 <= (g x).+1) ->
  f a <= n <= g b ->
  exists2 m, a <= m <= b & f m <= n <= g m.
Proof.
  move/leP.
  elim: b / => [| b /leP leq_ab IH] leq_fg touching ineq_n.
  - by exists a; rewrite ?leqnn.
  - case: (leqP n (g b)) => [le_n_gb | lt_gb_n].
    + case: IH.
      * by move=> ??; apply: leq_fg; lia.
      * by move=> ???; apply: touching; lia.
      * by lia.
      * move=> m ineq_m ineq_fgm.
        exists m => //.
        by lia.
    + have ? := touching b leq_ab (leqnn _).
      by exists b.+1; lia.
Qed.

Lemma total_bound_chain_forms_closed_interval m s lb ub :
  [&& lower_bound_bottomup s <= lb, lb <= ub & ub <= upper_bound_bottomup s] ->
  lower_bound_total s lb <= m <= upper_bound_total s ub ->
  exists2 n, lb <= n <= ub & lower_bound_total s n <= m <= upper_bound_total s n.
Proof.
  move=> ineq_bound ineq_m.
  case: (@interval_chain_forms_closed_interval (lower_bound_total s) (upper_bound_total s) lb ub m) => //.
  - by lia.
  - by move=> ??; apply: leq_total_bound; lia.
  - by move=> ???; apply: consecutive_total_bounds_touch_each_other; lia.
  - by move=> n ??; exists n.
Qed.

(******************************************************************************)
(* Step 4: Prove the existence of a forest in which the number of nodes is    *)
(*         included in the bound defined in Step 3                            *)
(******************************************************************************)

Proposition in_total_boundP (n m : nat) (s : leave_spec) :
  lower_bound_bottomup s <= n <= upper_bound_bottomup s ->
  reflect (exists f, [/\ count_node_forest f = m, size f = n & satisfy_leave_spec f s]) (lower_bound_total s n <= m <= upper_bound_total s n).
Proof.
  rewrite /lower_bound_total /upper_bound_total.
  move=> ineq_n.
  apply: (iffP idP).
  - elim: s => [| l0 s' IH] /= in m n ineq_n *.
    + move: ineq_n; rewrite !leqn0; do 2!move/eqP->.
      by exists [::].
    + move=> ineq_m.
      set lb := maxn _ _ in ineq_m.
      set ub := minn _ _ in ineq_m.
      (* By the combination of total_bound_chain_forms_closed_interval and the      *)
      (* induction hypothesis, for all m' \in [lb, ub], we obtain a forest of size  *)
      (* m' satisfying the spec s'. See total_bound_chain_forms_closed_interval.    *)
      case: (@total_bound_chain_forms_closed_interval (m - n) s' lb ub).
      * by move: (leq_bottomup_bound s'); lia.
      * by rewrite /lower_bound_total /upper_bound_total; lia.
      * move=> n' ineq_n' ineq_m'.
        case: (IH (m - n) n').
        -- by lia.
        -- by rewrite /lower_bound_total /upper_bound_total in ineq_m'; lia.
        -- move=> f' [Ecount Esize sat].
           exists (pairing_lift (n' - (n - l0)) f' ++ nseq l0 L); split.
           ++ by rewrite count_node_forest_cat count_node_forest_pairing_lift ?Ecount ?Esize ?count_node_forest_nseq /=; lia.
           ++ by rewrite size_cat size_pairing_lift Esize ?size_nseq; lia.
           ++ apply/andP; split.
              ** by rewrite count_cat count_mem_L_pairing_lift count_nseq mul1n.
              ** rewrite subforest_cat subforest_pairing_lift.
                 by rewrite subforest_nseq flatten_nseq_nil cats0.
  - elim: s => [| l0 s' IH] /= in m n ineq_n *.
    + case => f [Ecount _ /eqP Ef].
      rewrite Ef in Ecount.
      by rewrite -Ecount.
    + case => f [Ecount Esize /andP [/eqP EcountL sat]].
      set f' := subforest f.
      have ineq_size_f' : lower_bound_bottomup s' <= size f' <= upper_bound_bottomup s'.
      { by apply/in_bottomup_boundP; exists f' => //. }
      have ex_f' : exists f, [/\ count_node_forest f = m - n, size f = size f' & satisfy_leave_spec f s'].
      {
        exists f'; split => //.
        (* Note: To obtain the equality (n + m) - n = m, use addKn. It is hard to search. *)
        by rewrite -Ecount (eq_count_node_forest f) Esize addKn.
      }
      have {ex_f'} := IH _ _ ineq_size_f' ex_f'.
      set lb := maxn _ _.
      set ub := minn _ _.
      have ineq_n' := in_size_forest f.
      rewrite EcountL Esize -/f' in ineq_n'.
      have : lower_bound_total s' lb <= lower_bound_total s' (size f').
      { by apply: homo_lower_bound_total; lia. }
      have : upper_bound_total s' (size f') <= upper_bound_total s' ub.
      { by apply: homo_upper_bound_total; lia. }
      have : n <= m.
      { by rewrite -Esize -Ecount eq_count_node_forest leq_addr. }
      rewrite /lower_bound_total /upper_bound_total.
      by lia.
Qed.

(******************************************************************************)
(* Step 5: Speed up the functions defined in Step 3                           *)
(******************************************************************************)

Definition lower_bounds_topdown (s : leave_spec) (n : nat) :=
  belast n (scanl subn n s).

Definition upper_bounds_topdown (s : leave_spec) (n : nat) :=
  belast n (scanl (fun ub l0 => (ub - l0).*2) n s).

Definition lower_bounds_bottomup s :=
  scanr (fun l0 lb : nat => l0 + uphalf lb) 0 s.

Definition upper_bounds_bottomup s :=
  scanr (fun l0 ub : nat => l0 + ub) 0 s.

Definition lower_bounds_backforth' s n :=
  map2 maxn (lower_bounds_bottomup s) (lower_bounds_topdown s n).

Definition upper_bounds_backforth' s n :=
  map2 minn (upper_bounds_bottomup s) (upper_bounds_topdown s n).

Lemma lower_bounds_backforth'E l0 s n :
  lower_bounds_backforth' (l0 :: s) n =
    maxn (lower_bound_bottomup (l0 :: s)) n :: lower_bounds_backforth' s (n - l0).
Proof. by rewrite /lower_bounds_backforth' /lower_bounds_bottomup scanrE. Qed.

Lemma upper_bounds_backforth'E l0 s n :
  upper_bounds_backforth' (l0 :: s) n =
    minn (upper_bound_bottomup (l0 :: s)) n :: upper_bounds_backforth' s (n - l0).*2.
Proof. by rewrite /upper_bounds_backforth' /upper_bounds_bottomup scanrE. Qed.

Definition lower_bound_total' s n :=
  sumn (lower_bounds_backforth' s n).

Definition upper_bound_total' s n :=
  sumn (upper_bounds_backforth' s n).

Lemma lower_bound_lower_bounds_backforth' s n :
  n <= lower_bound_bottomup s ->
  lower_bounds_backforth' s n = lower_bounds_backforth' s (lower_bound_bottomup s).
Proof.
  elim: s => //= l0 s' IH in n *.
  move=> leq_n.
  rewrite !lower_bounds_backforth'E /=.
  congr (_ :: _).
  - by rewrite maxnn; apply/maxn_idPl.
  - rewrite addKn !IH //.
    + by apply: leq_uphalf.
    + by lia.
Qed.

Lemma upper_bound_upper_bounds_backforth' s n :
  upper_bound_bottomup s <= n ->
  upper_bounds_backforth' s n = upper_bounds_backforth' s (upper_bound_bottomup s).
Proof.
  elim: s => //= l0 s' IH in n *.
  move=> leq_n.
  rewrite !upper_bounds_backforth'E /=.
  congr (_ :: _).
  - by rewrite minnn; apply/minn_idPl.
  - rewrite addKn !IH //.
    + by rewrite -mul2n leq_pmull.
    + by lia.
Qed.

Lemma lower_bounds_backforth_equiv s n :
  lower_bound_bottomup s <= n ->
  lower_bounds_backforth' s n = lower_bounds_backforth s n.
Proof.
  elim: s => //= l0 s' IH in n *.
  move=> geq_n.
  rewrite lower_bounds_backforth'E /=.
  congr (_ :: _).
  - by apply/maxn_idPr.
  - set lbb' := lower_bound_bottomup s'.
    case: (ltnP lbb' (n - l0)).
    + by move=> ?; apply/IH/ltnW.
    + by move=> le_nl0_lbb'; rewrite lower_bound_lower_bounds_backforth' // IH.
Qed.

Lemma upper_bounds_backforth_equiv s n :
  n <= upper_bound_bottomup s ->
  upper_bounds_backforth' s n = upper_bounds_backforth s n.
Proof.
  rewrite /upper_bound_total /upper_bound_total'.
  elim: s => //= l0 s' IH in n *.
  move=> leq_n.
  rewrite upper_bounds_backforth'E /=.
  congr (_ :: _).
  - by apply/minn_idPr.
  - set ubb' := upper_bound_bottomup s'.
    case: (ltnP (n - l0).*2 ubb').
    + by move=> ?; apply/IH/ltnW.
    + by move=> le_ubb'_nl02; rewrite upper_bound_upper_bounds_backforth' // IH.
Qed.

Lemma lower_bound_total_equiv s n :
  lower_bound_bottomup s <= n ->
  lower_bound_total' s n = lower_bound_total s n.
Proof. by move=> ?; rewrite /lower_bound_total' lower_bounds_backforth_equiv. Qed.

Lemma upper_bound_total_equiv s n :
  n <= upper_bound_bottomup s ->
  upper_bound_total' s n = upper_bound_total s n.
Proof. by move=> ?; rewrite /upper_bound_total' upper_bounds_backforth_equiv. Qed.

Require Extraction.
Extract Inductive list => "list" [ "[]" "( :: )" ].
Extract Inductive nat => "int" [ "0" "succ" ] "(fun fO fS n -> if n = 0 then fO () else fS (n - 1))".
Extract Inlined Constant addn => "( + )".
Extract Inlined Constant subn => "( - )".
Extract Inlined Constant maxn => "max".
Extract Inlined Constant minn => "min".
Extract Inlined Constant double => "(fun n -> n * 2)".
Extract Inlined Constant half => "(fun n -> n / 2)".
Extract Inlined Constant uphalf => "(fun n -> (n + 1) / 2)".
Extraction Inline scanr_aux.

Extraction "folia" lower_bound_bottomup upper_bound_total'.