(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Set Implicit Arguments.

Require Import Notations.
Require Import Logic.
Declare ML Module "nat_syntax_plugin".

(********************************************************************)
(** * Datatypes with zero and one element *)

(** [Empty_set] is a datatype with no inhabitant *)

Inductive Empty_set : Set :=.

(** [unit] is a singleton datatype with sole inhabitant [tt] *)

Inductive unit : Set :=
    tt : unit.

(********************************************************************)
(** * The boolean datatype *)

(** [bool] is the datatype of the boolean values [true] and [false] *)

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

Add Printing If bool.

Delimit Scope bool_scope with bool.

Bind Scope bool_scope with bool.

(** Basic boolean operators *)

Definition andb (b1 b2:bool) : bool := if b1 then b2 else false.

Definition orb (b1 b2:bool) : bool := if b1 then true else b2.

Definition implb (b1 b2:bool) : bool := if b1 then b2 else true.

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

Definition negb (b:bool) := if b then false else true.

Infix "||" := orb : bool_scope.
Infix "&&" := andb : bool_scope.

(** Basic properties of [andb] *)

Lemma andb_prop : forall a b:bool, andb a b = true -> a = true /\ b = true.
Proof.
  destruct a, b; repeat split; assumption.
Qed.
Hint Resolve andb_prop: bool.

Lemma andb_true_intro :
  forall b1 b2:bool, b1 = true /\ b2 = true -> andb b1 b2 = true.
Proof.
  destruct b1; destruct b2; simpl; intros [? ?]; assumption.
Qed.
Hint Resolve andb_true_intro: bool.

(** Interpretation of booleans as propositions *)

Inductive eq_true : bool -> Prop := is_eq_true : eq_true true.

Hint Constructors eq_true : eq_true.

(** Another way of interpreting booleans as propositions *)

Definition is_true b := b = true.

(** [is_true] can be activated as a coercion by
   ([Local]) [Coercion is_true : bool >-> Sortclass].
*)

(** Additional rewriting lemmas about [eq_true] *)

Lemma eq_true_ind_r :
  forall (P : bool -> Prop) (b : bool), P b -> eq_true b -> P true.
Proof.
  intros P b H H0; destruct H0 in H; assumption.
Defined.

Lemma eq_true_rec_r :
  forall (P : bool -> Set) (b : bool), P b -> eq_true b -> P true.
Proof.
  intros P b H H0; destruct H0 in H; assumption.
Defined.

Lemma eq_true_rect_r :
  forall (P : bool -> Type) (b : bool), P b -> eq_true b -> P true.
Proof.
  intros P b H H0; destruct H0 in H; assumption.
Defined.

(** The [BoolSpec] inductive will be used to relate a [boolean] value
    and two propositions corresponding respectively to the [true]
    case and the [false] case.
    Interest: [BoolSpec] behave nicely with [case] and [destruct].
    See also [Bool.reflect] when [Q = ~P].
*)

Inductive BoolSpec (P Q : Prop) : bool -> Prop :=
  | BoolSpecT : P -> BoolSpec P Q true
  | BoolSpecF : Q -> BoolSpec P Q false.
Hint Constructors BoolSpec.

(********************************************************************)
(** * Peano natural numbers *)

(** [nat] is the datatype of natural numbers built from [O] and successor [S];
    note that the constructor name is the letter O.
    Numbers in [nat] can be denoted using a decimal notation;
    e.g. [3%nat] abbreviates [S (S (S O))] *)

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

Delimit Scope nat_scope with nat.
Bind Scope nat_scope with nat.
Arguments S _%nat.

(********************************************************************)
(** * Container datatypes *)

(* Set Universe Polymorphism. *)

(** [option A] is the extension of [A] with an extra element [None] *)

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

Arguments Some {A} a.
Arguments None {A}.

Definition option_map (A B:Type) (f:A->B) (o : option A) : option B :=
  match o with
    | Some a => @Some B (f a)
    | None => @None B
  end.

(** [sum A B], written [A + B], is the disjoint sum of [A] and [B] *)

Inductive sum (A B:Type) : Type :=
  | inl : A -> sum A B
  | inr : B -> sum A B.

Notation "x + y" := (sum x y) : type_scope.

Arguments inl {A B} _ , [A] B _.
Arguments inr {A B} _ , A [B] _.

(** [prod A B], written [A * B], is the product of [A] and [B];
    the pair [pair A B a b] of [a] and [b] is abbreviated [(a,b)] *)

Inductive prod (A B:Type) : Type :=
  pair : A -> B -> prod A B.

Add Printing Let prod.

Notation "x * y" := (prod x y) : type_scope.
Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.

Arguments pair {A B} _ _.

Section projections.
  Context {A : Type} {B : Type}.

  Definition fst (p:A * B) := match p with
				| (x, y) => x
                              end.
  Definition snd (p:A * B) := match p with
				| (x, y) => y
                              end.
End projections.

Hint Resolve pair inl inr: core.

Lemma surjective_pairing :
  forall (A B:Type) (p:A * B), p = pair (fst p) (snd p).
Proof.
  destruct p; reflexivity.
Qed.

Lemma injective_projections :
  forall (A B:Type) (p1 p2:A * B),
    fst p1 = fst p2 -> snd p1 = snd p2 -> p1 = p2.
Proof.
  destruct p1; destruct p2; simpl; intros Hfst Hsnd.
  rewrite Hfst; rewrite Hsnd; reflexivity.
Qed.

Definition prod_uncurry (A B C:Type) (f:prod A B -> C)
  (x:A) (y:B) : C := f (pair x y).

Definition prod_curry (A B C:Type) (f:A -> B -> C)
  (p:prod A B) : C := match p with
                       | pair x y => f x y
                       end.

(** Polymorphic lists and some operations *)

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

Arguments nil {A}.
Arguments cons {A} a l.
Infix "::" := cons (at level 60, right associativity) : list_scope.
Delimit Scope list_scope with list.
Bind Scope list_scope with list.

Local Open Scope list_scope.

Definition length (A : Type) : list A -> nat :=
  fix length l :=
  match l with
   | nil => O
   | _ :: l' => S (length l')
  end.

(** Concatenation of two lists *)

Definition app (A : Type) : list A -> list A -> list A :=
  fix app l m :=
  match l with
   | nil => m
   | a :: l1 => a :: app l1 m
  end.

Infix "++" := app (right associativity, at level 60) : list_scope.

(* Unset Universe Polymorphism. *)

(********************************************************************)
(** * The comparison datatype *)

Inductive comparison : Set :=
  | Eq : comparison
  | Lt : comparison
  | Gt : comparison.

Lemma comparison_eq_stable : forall c c' : comparison, ~~ c = c' -> c = c'.
Proof.
  destruct c, c'; intro H; reflexivity || destruct H; discriminate.
Qed.

Definition CompOpp (r:comparison) :=
  match r with
    | Eq => Eq
    | Lt => Gt
    | Gt => Lt
  end.

Lemma CompOpp_involutive : forall c, CompOpp (CompOpp c) = c.
Proof.
  destruct c; reflexivity.
Qed.

Lemma CompOpp_inj : forall c c', CompOpp c = CompOpp c' -> c = c'.
Proof.
  destruct c; destruct c'; auto; discriminate.
Qed.

Lemma CompOpp_iff : forall c c', CompOpp c = c' <-> c = CompOpp c'.
Proof.
  split; intros; apply CompOpp_inj; rewrite CompOpp_involutive; auto.
Qed.

(** The [CompareSpec] inductive relates a [comparison] value with three
   propositions, one for each possible case. Typically, it can be used to
   specify a comparison function via some equality and order predicates.
   Interest: [CompareSpec] behave nicely with [case] and [destruct]. *)

Inductive CompareSpec (Peq Plt Pgt : Prop) : comparison -> Prop :=
 | CompEq : Peq -> CompareSpec Peq Plt Pgt Eq
 | CompLt : Plt -> CompareSpec Peq Plt Pgt Lt
 | CompGt : Pgt -> CompareSpec Peq Plt Pgt Gt.
Hint Constructors CompareSpec.

(** For having clean interfaces after extraction, [CompareSpec] is declared
    in Prop. For some situations, it is nonetheless useful to have a
    version in Type. Interestingly, these two versions are equivalent. *)

Inductive CompareSpecT (Peq Plt Pgt : Prop) : comparison -> Type :=
 | CompEqT : Peq -> CompareSpecT Peq Plt Pgt Eq
 | CompLtT : Plt -> CompareSpecT Peq Plt Pgt Lt
 | CompGtT : Pgt -> CompareSpecT Peq Plt Pgt Gt.
Hint Constructors CompareSpecT.

Lemma CompareSpec2Type : forall Peq Plt Pgt c,
 CompareSpec Peq Plt Pgt c -> CompareSpecT Peq Plt Pgt c.
Proof.
 destruct c; intros H; constructor; inversion_clear H; auto.
Defined.

(** As an alternate formulation, one may also directly refer to predicates
 [eq] and [lt] for specifying a comparison, rather that fully-applied
 propositions. This [CompSpec] is now a particular case of [CompareSpec]. *)

Definition CompSpec {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Prop :=
 CompareSpec (eq x y) (lt x y) (lt y x).

Definition CompSpecT {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Type :=
 CompareSpecT (eq x y) (lt x y) (lt y x).
Hint Unfold CompSpec CompSpecT.

Lemma CompSpec2Type : forall A (eq lt:A->A->Prop) x y c,
 CompSpec eq lt x y c -> CompSpecT eq lt x y c.
Proof. intros. apply CompareSpec2Type; assumption. Defined.

(******************************************************************)
(** * Misc Other Datatypes *)

(** [identity A a] is the family of datatypes on [A] whose sole non-empty
    member is the singleton datatype [identity A a a] whose
    sole inhabitant is denoted [identity_refl A a] *)

Inductive identity (A:Type) (a:A) : A -> Type :=
  identity_refl : identity a a.
Hint Resolve identity_refl: core.

Arguments identity_ind [A] a P f y i.
Arguments identity_rec [A] a P f y i.
Arguments identity_rect [A] a P f y i.

(** Identity type *)

Definition ID := forall A:Type, A -> A.
Definition id : ID := fun A x => x.

Definition IDProp := forall A:Prop, A -> A.
Definition idProp : IDProp := fun A x => x.

(* begin hide *)

(* Compatibility *)

Notation prodT := prod (only parsing).
Notation pairT := pair (only parsing).
Notation prodT_rect := prod_rect (only parsing).
Notation prodT_rec := prod_rec (only parsing).
Notation prodT_ind := prod_ind (only parsing).
Notation fstT := fst (only parsing).
Notation sndT := snd (only parsing).
Notation prodT_uncurry := prod_uncurry (only parsing).
Notation prodT_curry := prod_curry (only parsing).

(* end hide *)


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf2 : natural) (z : natural) (x : natural) (lf1 : natural)
  : natural := plus lf1 Zero.


Require Import bf_stack bf bf_semantics.
Require Import Lists.Streams.

Inductive ae : Set :=
| Int : nat -> ae
| Plus : ae -> ae -> ae
| Minus : ae -> ae -> ae
| Mult : ae -> ae -> ae.

Coercion Int : nat >-> ae.
Notation "a + b" := (Plus a b) : ae_scope.
Notation "a - b" := (Minus a b) : ae_scope.
Notation "a * b" := (Mult a b) : ae_scope.
Delimit Scope ae_scope with ae.

Fixpoint interpret (ae : ae) : nat :=
  match ae with
    | Int n => n
    | Plus e1 e2 => interpret e1 + interpret e2
    | Minus e1 e2 => interpret e1 - interpret e2
    | Mult e1 e2 => interpret e1 * interpret e2
  end.

Fixpoint compile (ae : ae) : Instr.instruction :=
  match ae with
    | Int n => push n
    | Plus e1 e2 => compile e1; compile e2; add
    | Minus e1 e2 => compile e1; compile e2; sub
    | Mult e1 e2 => compile e1; compile e2; mult
  end.

Example interpret_compile_example1 :
  iter (compile (4+5-2*3)%ae, init zeroes)
       (END, state[zeroes, interpret (4+5-2*3), zeroes, zeroes, nil]).
Proof.
  unfold init, compile, interpret.
  repeat bf_step.
  unfold sub.
  repeat bf_step.
Qed.

Theorem compiler_correctness :
  forall ae ls x,
    iter (compile ae, state[ls, x, zeroes, zeroes, nil])
         (END, state[Cons x ls, interpret ae, zeroes, zeroes, nil]).
Proof.
  intro ae.
  induction ae.
  simpl.
  intros.
  apply (iter_trans _
                    (END, state[Cons x ls, n, zeroes, zeroes, nil])).
  apply (about_push n ls x zeroes nil).
  bf_step.

  intros.
  simpl.
  apply (about_sequence (compile ae1) (compile ae2; add)
                        _ state[Cons x ls, interpret ae1, zeroes, zeroes, nil]).
  apply IHae1.
  apply (about_sequence (compile ae2) (add)
                        _ state[Cons (interpret ae1) (Cons x ls),
                                interpret ae2, zeroes, zeroes, nil]).
  apply IHae2.
  rewrite Arith.Plus.plus_comm.
  apply about_add.

  intros.
  simpl.
  apply (about_sequence (compile ae1) (compile ae2; sub)
                        _ state[Cons x ls, interpret ae1, zeroes, zeroes, nil]).
  apply IHae1.
  apply (about_sequence (compile ae2) sub
                        _ state[Cons (interpret ae1) (Cons x ls),
                                interpret ae2, zeroes, zeroes, nil]).
  apply IHae2.
  apply about_sub.

  intros.
  simpl.
  apply (about_sequence (compile ae1) (compile ae2; mult)
                        _ state[Cons x ls, interpret ae1, zeroes, zeroes, nil]).
  apply IHae1.
  apply (about_sequence (compile ae2) mult
                        _ state[Cons (interpret ae1) (Cons x ls),
                                interpret ae2, zeroes, zeroes, nil]).
  apply IHae2.
  apply about_mult.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


(*** Predicates on a list ***)

Require Import Arith.
Require Import Bool.
Require Import List.
Require Import ott_list_base.
Require Import ott_list_core.
Require Import ott_list_takedrop.

Section List_predicate_inductive.
(* Properties of [Forall_list] and [Exists_list] *)

Variables A : Set.
Implicit Types x : A.
Implicit Types xs l : list A.
Implicit Types p : A -> bool.
Implicit Types P : A -> Prop.
Set Implicit Arguments.

Lemma not_Exists_list_nil : forall P, ~(Exists_list P nil).
Proof. intros P H; inversion H. Qed.
Hint Resolve not_Exists_list_nil.

Lemma Forall_list_dec :
  forall P (dec : forall x, {P x} + {~P x}) l,
    {Forall_list P l} + {~Forall_list P l}.
Proof.
  induction l; simpl in * . solve [auto].
  destruct (dec a); [destruct IHl | idtac]; auto;
    right; intro; inversion_clear H; tauto.
Qed.

Lemma Exists_list_dec :
  forall P (dec : forall x, {P x} + {~P x}) l,
    {Exists_list P l} + {~Exists_list P l}.
Proof.
  induction l; simpl in * . solve [auto].
  destruct (dec a); [idtac | destruct IHl]; auto;
    right; intro; inversion_clear H; tauto.
Qed.

Lemma Forall_Exists_list_dec :
  forall P Q (dec : forall x, {P x} + {Q x}) l,
    {Forall_list P l} + {Exists_list Q l}.
Proof.
  induction l; simpl in * . solve [auto].
  destruct (dec a); destruct IHl; auto.
Qed.

Lemma Forall_list_In :
  forall P x l, In x l -> Forall_list P l -> P x.
Proof.
  induction l; intros; simpl in *; destruct H;
    inversion H0; subst; auto.
Qed.

Lemma In_Forall_list :
  forall P l, (forall x, In x l -> P x) -> Forall_list P l.
Proof.
  induction l; firstorder.
Qed.

Lemma exists_In_Exists_list :
  forall P l, Exists_list P l -> exists x, In x l /\ P x.
Proof.
  induction 1.
  exists x; simpl; tauto.
  elim IHExists_list; intros. exists x0; simpl; tauto.
Qed.

Lemma Forall_list_app_left :
  forall P l l', Forall_list P (l++l') -> Forall_list P l.
Proof.
  intros; induction l; simpl in * . auto.
  inversion_clear H. auto.
Qed.
Lemma Forall_list_app_right :
  forall P l l', Forall_list P (l++l') -> Forall_list P l'.
Proof.
  induction l; intros. auto. inversion_clear H; auto.
Qed.
Lemma app_Forall_list :
  forall P l l', Forall_list P l -> Forall_list P l' -> Forall_list P (l++l').
Proof.
  intros; induction l; simpl in * . assumption.
  inversion_clear H. auto.
Qed.
Hint Resolve app_Forall_list Forall_list_app_left Forall_list_app_right.

Lemma Exists_list_app_or :
  forall P l l', Exists_list P (l++l') ->
    Exists_list P l \/ Exists_list P l'.
Proof.
  intros; induction l; simpl in * . solve [auto].
  inversion_clear H. solve [auto].
  destruct (IHl H0); solve [auto].
Qed.
Lemma app_Exists_list_left :
  forall P l l', Exists_list P l -> Exists_list P (l++l').
Proof.
  intros; induction l; inversion_clear H; simpl; auto.
Qed.
Lemma app_Exists_list_right :
  forall P l l', Exists_list P l' -> Exists_list P (l++l').
Proof.
  intros; induction l; simpl; auto.
Qed.
Hint Resolve Exists_list_app_or app_Exists_list_left app_Exists_list_right.

Lemma rev_Forall_list :
  forall P l, Forall_list P l -> Forall_list P (rev l).
Proof. induction 1; simpl; auto. Qed.
Lemma rev_Exists_list :
  forall P l, Exists_list P l -> Exists_list P (rev l).
Proof. induction 1; simpl; auto. Qed.
Lemma Forall_list_rev :
  forall P l, Forall_list P (rev l) -> Forall_list P l.
Proof.
  intros. rewrite <- (rev_involutive l). apply rev_Forall_list; assumption.
Qed.
Lemma Exists_list_rev :
  forall P l, Exists_list P (rev l) -> Exists_list P l.
Proof.
  intros. rewrite <- (rev_involutive l). apply rev_Exists_list; assumption.
Qed.

Lemma take_Forall_list :
  forall P n l, Forall_list P l -> Forall_list P (take n l).
Proof.
  intros; generalize dependent n; induction l; intros;
    inversion_clear H; destruct n; simpl; auto.
Qed.
Lemma drop_Forall_list :
  forall P n l, Forall_list P l -> Forall_list P (drop n l).
Proof.
  intros; generalize dependent n; induction l; intros;
    inversion_clear H; destruct n; simpl; auto.
Qed.
Lemma Forall_list_take_drop :
  forall P n l,
    Forall_list P (take n l) -> Forall_list P (drop n l) -> Forall_list P l.
Proof. intros; rewrite <- (take_app_drop l n); auto. Qed.

Lemma take_drop_Exists_list :
  forall P n l, Exists_list P l ->
    Exists_list P (take n l) \/ Exists_list P (drop n l).
Proof. intros; rewrite <- (take_app_drop l n) in H; auto. Qed.
Lemma Exists_list_take :
  forall P n l, Exists_list P (take n l) -> Exists_list P l.
Proof. intros; rewrite <- (take_app_drop l n); auto. Qed.
Lemma Exists_list_drop :
  forall P n l, Exists_list P (drop n l) -> Exists_list P l.
Proof. intros; rewrite <- (take_app_drop l n); auto. Qed.

Lemma Forall_list_implies :
  forall (P Q:A->Prop) xs,
    (forall x, In x xs -> P x -> Q x) ->
    Forall_list P xs -> Forall_list Q xs.
Proof. induction 2; firstorder. Qed.
Lemma Exists_list_implies :
  forall (P Q:A->Prop) xs,
    (forall x, In x xs -> P x -> Q x) ->
    Exists_list P xs -> Exists_list Q xs.
Proof. induction 2; firstorder. Qed.

End List_predicate_inductive.

Hint Resolve not_Exists_list_nil : lists.
Hint Resolve In_Forall_list : lists.
Hint Resolve Forall_list_app_left Forall_list_app_right : lists.
Hint Resolve app_Forall_list Exists_list_app_or : lists.
Hint Resolve app_Exists_list_left app_Exists_list_right : lists.
Hint Resolve rev_Forall_list rev_Exists_list : lists.
Hint Resolve Forall_list_rev Exists_list_rev : lists.
Hint Resolve take_Forall_list drop_Forall_list Forall_list_take_drop
             take_drop_Exists_list Exists_list_take Exists_list_drop
             : take_drop.
Hint Resolve Forall_list_implies Exists_list_implies : lists.

Section List_predicate_fold.
(* Properties of [forall_list] and [exists_list] *)

Variables A : Set.
Implicit Types x : A.
Implicit Types xs l : list A.
Implicit Types p : A -> bool.
Implicit Types P : A -> Prop.
Set Implicit Arguments.

Lemma forall_list_eq_fold_left_map :
  forall p l,
    forall_list p l = fold_left andb (map p l) true.
Proof.
  unfold forall_list; intros. generalize true.
  induction l; intros; simpl in * . reflexivity.
  rewrite IHl. reflexivity.
Qed.
Lemma forall_list_eq_fold_right_map :
  forall p l,
    forall_list p l = fold_right andb true (map p l).
Proof.
  intros. rewrite forall_list_eq_fold_left_map.
  apply fold_symmetric; auto with bool.
Qed.
Lemma forall_list_eq_fold_left :
  forall p l,
    forall_list p l = fold_left (fun b z => b && p z) l true.
Proof. auto. Qed.
Lemma forall_list_eq_fold_right :
  forall p l,
    forall_list p l = fold_right (fun z b => b && p z) true l.
Proof.
  intros; rewrite forall_list_eq_fold_right_map.
  induction l; simpl. reflexivity. rewrite IHl. auto with bool.
Qed.

Lemma exists_list_eq_fold_left_map :
  forall p l,
    exists_list p l = fold_left orb (map p l) false.
Proof.
  unfold exists_list; intros. generalize false.
  induction l; intros; simpl in * . reflexivity.
  rewrite IHl. reflexivity.
Qed.
Lemma exists_list_eq_fold_right_map :
  forall p l,
    exists_list p l = fold_right orb false (map p l).
Proof.
  intros. rewrite exists_list_eq_fold_left_map.
  apply fold_symmetric; auto with bool.
Qed.
Lemma exists_list_eq_fold_left :
  forall p l,
    exists_list p l = fold_left (fun b z => b || p z) l false.
Proof. auto. Qed.
Lemma exists_list_eq_fold_right :
  forall p l,
    exists_list p l = fold_right (fun z b => b || p z) false l.
Proof.
  intros; rewrite exists_list_eq_fold_right_map.
  induction l; simpl. reflexivity. rewrite IHl. auto with bool.
Qed.

Lemma forall_list_extensionality :
  forall p p' l, (forall x, p x = p' x) -> forall_list p l = forall_list p' l.
Proof.
  intros; repeat rewrite forall_list_eq_fold_right.
  induction l; simpl. reflexivity. rewrite IHl; rewrite H. reflexivity.
Qed.

Lemma exists_list_extensionality :
  forall p p' l, (forall x, p x = p' x) -> exists_list p l = exists_list p' l.
Proof.
  intros; repeat rewrite exists_list_eq_fold_right.
  induction l; simpl. reflexivity. rewrite IHl; rewrite H. reflexivity.
Qed.

End List_predicate_fold.

Section List_predicate_relationship.

Variables A : Set.
Implicit Types x : A.
Implicit Types xs l : list A.
Implicit Types p : A -> bool.
Implicit Types P : A -> Prop.
Set Implicit Arguments.

(* TODO: lemmas relating Forall_list and forall_list, Exists_list
   and exists_list, forall_list and exists_list. *)

Lemma Forall_if_implies_if_forall :
  forall P p l,
    Forall_list (fun z => if p z then P z else ~P z) l ->
    if forall_list p l then Forall_list P l else ~Forall_list P l.
Proof.
  intros; rewrite forall_list_eq_fold_right.
  induction H; simpl in * . apply Forall_nil.
  destruct (fold_right (fun (z : A) (b : bool) => b && p z) true l).
  destruct (p x); simpl. apply Forall_cons; assumption.
  intro No; inversion No; tauto.
  simpl; intro No; inversion No; tauto.
Qed.

End List_predicate_relationship.

(*** More about maps ***)

Section List_predicate_map.

Variables A B C : Set.
Implicit Types x : A.
Implicit Types y : B.
Implicit Types z : C.
Implicit Types xs l : list A.
Implicit Types ys : list B.
Implicit Types zs : list C.
Implicit Types f : A -> B.
Implicit Types g : B -> C.
Implicit Types P : A -> Prop.
Implicit Types Q : B -> Prop.
Implicit Types R : C -> Prop.
Implicit Types m n : nat.
Set Implicit Arguments.

Lemma map_take :
  forall f l n, map f (take n l) = take n (map f l).
Proof.
  intros. generalize dependent n; induction l; intros.
  destruct n; reflexivity.
  destruct n. reflexivity. simpl; rewrite IHl; reflexivity.
Qed.

Lemma map_drop :
  forall f l n, map f (drop n l) = drop n (map f l).
Proof.
  intros. generalize dependent n; induction l; intros.
  destruct n; reflexivity.
  destruct n. reflexivity. simpl; rewrite IHl; reflexivity.
Qed.

Lemma Forall_list_implies_map :
  forall P Q f l,
    (forall x, P x -> Q (f x)) ->
    Forall_list P l -> Forall_list Q (map f l).
Proof. induction 2; simpl; auto with lists. Qed.
Lemma Exists_list_implies_map :
  forall P Q f l,
    (forall x, P x -> Q (f x)) ->
    Exists_list P l -> Exists_list Q (map f l).
Proof. induction 2; simpl; auto with lists. Qed.

Lemma Forall_list_map_implies :
  forall P Q f l,
    (forall x, Q (f x) -> P x) ->
    Forall_list Q (map f l) -> Forall_list P l.
Proof.
  intros. induction l; simpl in * . apply Forall_nil.
  inversion_clear H0. auto with lists.
Qed.
Lemma Exists_list_map_implies :
  forall P Q f l,
    (forall x, Q (f x) -> P x) ->
    Exists_list Q (map f l) -> Exists_list P l.
Proof.
  intros. induction l; simpl in *;
    inversion_clear H0; auto with lists.
Qed.

Lemma Forall_list_map_intro :
  forall Q f l,
    Forall_list (fun x => Q (f x)) l -> Forall_list Q (map f l).
Proof. induction 1; simpl; auto with lists. Qed.
Lemma Exists_list_map_intro :
  forall Q f l,
    Exists_list (fun x => Q (f x)) l -> Exists_list Q (map f l).
Proof. induction 1; simpl; auto with lists. Qed.

Lemma Forall_list_map_elim :
  forall Q f l,
    Forall_list Q (map f l) -> Forall_list (fun x => Q (f x)) l.
Proof.
  intros. induction l; simpl in * . apply Forall_nil.
  inversion_clear H. auto with lists.
Qed.
Lemma Exists_list_map_elim :
  forall Q f l,
    Exists_list Q (map f l) -> Exists_list (fun x => Q (f x)) l.
Proof.
  intros. induction l; simpl in *;
    inversion_clear H; auto with lists.
Qed.

End List_predicate_map.

Hint Rewrite map_take map_drop : take_drop.
Hint Resolve Forall_list_implies_map Exists_list_implies_map : lists.
Hint Resolve Forall_list_map_implies Exists_list_map_implies : lists.
Hint Resolve Forall_list_map_intro Exists_list_map_intro : lists.
Hint Resolve Forall_list_map_elim Exists_list_map_elim : lists.

(* Simplify hypotheses and goals involving [Forall_list]. Simplifications
   involve rewriting [Forall_list ?P ?l] into equivalent statements
   where [?l] is simpler. Recognised ``complex'' constructors for [?l]
   are [nil], [cons], [app], [map], [rev]. In the goal, only
   simplifications that do not solve or split the goal are considered.
 *)
Ltac simplify_Forall_list :=
  let tmp := fresh "tmp" in (
    repeat match goal with
             | H : Forall_list ?P nil |- _ => clear H
             | H : Forall_list ?P (cons ?a ?l) |- _ =>
               inversion_clear H;
               match goal with H':_ |- _ => rename H' into H end
             | H : Forall_list ?P (app ?l0 ?l1) |- _ =>
               rename H into tmp;
               assert (H := Forall_list_app_right l0 l1 tmp);
               generalize H; clear H;
               assert (H := Forall_list_app_left l0 l1 tmp);
               intro; match goal with H':_ |- _ =>
                        move H' after tmp; simpl in H'
                      end;
               move H after tmp; clear tmp; simpl in H
             | H : Forall_list ?P (map ?f ?l) |- _ =>
               (*apply Forall_list_map_elim in H*) (*>=V8.1 only*)
               rename H into tmp;
               assert (H := Forall_list_map_elim f l tmp);
               move H after tmp; clear tmp; simpl in H
             | H : Forall_list ?P (rev ?l) |- _ =>
               rename H into tmp;
               assert (tmp := Forall_list_rev l H);
               move H after tmp; clear tmp; simpl in H
           end;
    repeat ((apply Forall_list_map_intro ||
             apply rev_Forall_list
            ); simpl)
  ).


Require Export BaseLists Dupfree.

Definition elAt := nth_error.
Notation "A '.[' i  ']'" := (elAt A i) (no associativity, at level 50).

Section Fix_X.

  Variable X : eqType.

  Fixpoint pos (s : X) (A : list X) :=
    match A with
    | nil => None
    | a :: A => if Dec (s = a) then Some 0 else match pos s A with None => None | Some n => Some (S n) end
    end.

  Lemma el_pos s A : s el A -> exists m, pos s A = Some m.
  Proof.
    revert s; induction A; simpl; intros s H.
    - contradiction.
    - decide (s = a) as [D | D]; eauto;
        destruct H; try congruence.
      destruct (IHA s H) as [n Hn]; eexists; now rewrite Hn.
  Qed.

  Lemma pos_elAt s A i : pos s A = Some i -> A .[i] = Some s.
  Proof.
    revert i s. induction A; intros i s.
    - destruct i; inversion 1.
    - simpl. decide (s = a).
      + inversion 1; subst; reflexivity.
      + destruct i; destruct (pos s A) eqn:B; inversion 1; subst; eauto.
  Qed.

  Lemma elAt_app (A : list X) i B s : A .[i] = Some s -> (A ++ B).[i] = Some s.
  Proof.
    revert s B i. induction A; intros s B i H; destruct i; simpl; intuition; inv H.
  Qed.

  Lemma elAt_el  A (s : X) m : A .[ m ] = Some s -> s el A.
  Proof.
    revert A. induction m; intros []; inversion 1; eauto.
  Qed.

  Lemma el_elAt (s : X) A : s el A -> exists m, A .[ m ] = Some s.
  Proof.
    intros H; destruct (el_pos H);  eexists; eauto using pos_elAt.
  Qed.

  Lemma dupfree_elAt (A : list X) n m s : dupfree A -> A.[n] = Some s -> A.[m] = Some s -> n = m.
  Proof with try tauto.
    intros H; revert n m; induction A; simpl; intros n m H1 H2.
    - destruct n; inv H1.
    - destruct n, m; inv H...
      + inv H1. simpl in H2. eapply elAt_el in H2...
      + inv H2. simpl in H1. eapply elAt_el in H1...
      + inv H1. inv H2. rewrite IHA with n m...
  Qed.

  Lemma nth_error_none A n l : nth_error l n = @None A -> length l <= n.
  Proof. revert n;
           induction l; intros n.
         - simpl; omega.
         - simpl. intros. destruct n. inv H. inv H. assert (| l | <= n). eauto. omega.
  Qed.

  Lemma pos_None (x : X) l l' : pos x l = None-> pos x l' = None -> pos x (l ++ l') = None.
  Proof.
    revert x l'; induction l; simpl; intros; eauto.
    have (x = a).
    destruct (pos x l) eqn:E; try congruence.
    rewrite IHl; eauto.
  Qed.

  Lemma pos_first_S (x : X)  l l' i  : pos x l = Some i -> pos x (l ++ l') = Some i.
  Proof.
    revert x i; induction l; intros; simpl in *.
    - inv H.
    - decide (x = a); eauto.
      destruct (pos x l) eqn:E.
      + eapply IHl in E. now rewrite E.
      + inv H.
  Qed.

  Lemma pos_second_S x l l' i : pos x l = None ->
                                pos x l' = Some i ->
                                pos x (l ++ l') = Some ( i + |l| ).
  Proof.
    revert i l'; induction l; simpl; intros.
    - rewrite plus_comm. eauto.
    - destruct _; subst; try congruence.
      destruct (pos x l) eqn:EE. congruence.
      erewrite IHl; eauto.
  Qed.

  Lemma pos_length (e : X) n E : pos e E = Some n -> n < |E|.
  Proof.
    revert e n; induction E; simpl; intros.
    - inv H.
    - decide (e = a).
      + inv H. simpl. omega.
      + destruct (pos e E) eqn:EE.
        * inv H. assert (n1 < |E|) by eauto.  omega.
        * inv H.
  Qed.

  Fixpoint replace (xs : list X) (y y' : X) :=
    match xs with
    | nil => nil
    | x :: xs' => (if Dec (x = y) then y' else x) :: replace xs' y y'
    end.

  Lemma replace_same xs x : replace xs x x = xs.
  Proof.
    revert x; induction xs; intros; simpl; [ | destruct _; subst ]; congruence.
  Qed.

  Lemma replace_diff xs x y : x <> y -> ~ x el replace xs x y.
  Proof.
    revert x y; induction xs; intros; simpl; try destruct _; firstorder.
  Qed.

  Lemma replace_pos xs x y y' : x <> y -> x <> y' -> pos x xs = pos x (replace xs y y').
  Proof.
    induction xs; intros; simpl.
    - reflexivity.
    - repeat destruct Dec; try congruence; try omega; subst.
      + rewrite IHxs; eauto. + rewrite IHxs; eauto.
  Qed.

End Fix_X.

Arguments replace {_} _ _ _.

(* Fixpoint  getPosition {E: eqType} (A: list E) x := match A with *)
(*                                                    | nil => 0 *)
(*                                                    | cons x' A' => if Dec (x=x') then 0 else 1 + getPosition A' x end. *)

(* Lemma getPosition_correct {E: eqType} (x:E) A: if Dec (x el A) then forall z, (nth (getPosition A x) A z) = x else getPosition A x = |A |. *)
(* Proof. *)
(*   induction A;cbn. *)
(*   -dec;tauto. *)
(*   -dec;intuition; congruence. *)
(* Qed. *)


(** * FlipG : Hofstadter's flipped G tree *)

Require Import Arith Omega Wf_nat List Program Program.Wf NPeano.
Require Import DeltaList Fib FunG.
Set Implicit Arguments.

(** See first the file [FunG] for the study of:

     - [G (S n) + G (G n) = S n]
     - [G 0 = 0]

   and the associated tree where nodes are labeled breadth-first
   from left to right.

   Now, question by Hofstadter: what if we still label the nodes
   from right to left, but for the mirror tree ?
   What is the algebraic definition of the "parent" function
   for this flipped tree ?

<<
9 10 11 12  13
 \/   |  \ /
  6   7   8
   \   \ /
    4   5
     \ /
      3
      |
      2
      |
      1
>>

   References:
    - Hofstadter's book: Goedel, Escher, Bach, page 137.
    - Sequence A123070 on the Online Encyclopedia of Integer Sequences
      ##http://oeis.org/A123070##
*)

(*=============================================================*)

(** * The [flip] function *)

(** If we label the node from right to left, the effect
   on node numbers is the [flip] function below.
   The idea is to map a row [ [1+fib (k+1);...;fib (k+2)] ]
   to the flipped row [ [fib (k+2);...;1+fib (k+1)] ].
*)

Definition flip n :=
  if n <=? 1 then n else S (fib (S (S (S (depth n))))) - n.

Ltac tac_leb := rewrite <- ?Bool.not_true_iff_false, leb_le.

Lemma flip_depth n : depth (flip n) = depth n.
Proof.
 unfold flip.
 case_eq (n <=? 1); tac_leb; trivial.
 intros.
 assert (depth n <> 0) by (rewrite depth_0; omega).
 apply depth_carac; trivial.
 set (k := depth n) in *.
 assert (S (fib (S k)) <= n <= fib (S (S k)))
  by now apply depth_carac.
 rewrite fib_eqn.
 omega.
Qed.

Lemma flip_eqn0 n : depth n <> 0 ->
 flip n = S (fib (S (S (S (depth n))))) - n.
Proof.
 intros.
 rewrite depth_0 in *.
 unfold flip.
 case_eq (n <=? 1); tac_leb; omega.
Qed.

Lemma flip_eqn k n : 1 <= n <= fib k ->
 flip (fib (S k) + n) = S (fib (S (S k))) - n.
Proof.
 intros Hn.
 unfold flip.
 case_eq (fib (S k) + n <=? 1); tac_leb.
 - generalize (@fib_nz (S k)); omega.
 - intros H.
   replace (depth (fib (S k) + n)) with k.
   + rewrite fib_eqn. omega.
   + assert (k<>0).
     { intros ->. simpl in Hn; omega. }
     symmetry. apply depth_carac; auto.
     rewrite fib_eqn; omega.
Qed.

(** Two special cases : leftmost and rightmost node at a given depth *)

Lemma flip_Sfib k : 1<k -> flip (S (fib k)) = fib (S k).
Proof.
 intros H.
 destruct k.
 - omega.
 - rewrite <- Nat.add_1_r.
   rewrite flip_eqn.
   omega.
   split; trivial. apply fib_nz. omega.
Qed.

Lemma flip_fib k : 1<k -> flip (fib (S k)) = S (fib k).
Proof.
 intros H.
 destruct k.
 - omega.
 - rewrite fib_eqn' by omega.
   rewrite flip_eqn; auto.
   rewrite fib_eqn'; auto. omega.
   replace (S k - 1) with k by omega.
   split; auto. apply fib_nz. omega.
Qed.

(** flip is involutive (and hence a bijection) *)

Lemma flip_flip n : flip (flip n) = n.
Proof.
 unfold flip at 2.
 case_eq (n <=? 1).
 - unfold flip. now intros ->.
 - tac_leb.
   intros Hn.
   set (k := depth n).
   assert (k<>0).
   { contradict Hn. unfold k in *. rewrite depth_0 in Hn. omega. }
   assert (Hn' : S (fib (S k)) <= n <= fib (S (S k))).
   { apply depth_carac; auto. }
   rewrite fib_eqn.
   replace (S (fib (S (S k)) + fib (S k)) - n) with
    (fib (S k) + (S (fib (S (S k))) - n)) by omega.
   rewrite flip_eqn; auto. omega.
   split. omega. rewrite fib_eqn'; auto.
   replace (S k - 1) with k by omega.
   omega.
Qed.

Lemma flip_eq n m : flip n = flip m <-> n = m.
Proof.
 split; intros H.
 - rewrite <- (flip_flip n), <- (flip_flip m). now f_equal.
 - now subst.
Qed.

Lemma flip_swap n m : flip n = m <-> n = flip m.
Proof.
 rewrite <- (flip_flip m) at 1. apply flip_eq.
Qed.

Lemma flip_low n : n <= 1 <-> flip n <= 1.
Proof.
 split; intros.
 - assert (EQ : n = 0 \/ n = 1) by omega.
   destruct EQ as [-> | ->]; compute; auto.
 - assert (EQ : flip n = 0 \/ flip n = 1) by omega.
   rewrite !flip_swap in EQ. compute in EQ. omega.
Qed.

Lemma flip_high n : 1 < n <-> 1 < flip n.
Proof.
 generalize (flip_low n). omega.
Qed.

(** flip and neighbors *)

Lemma flip_S n : 1<n -> depth (S n) = depth n ->
  flip (S n) = flip n - 1.
Proof.
 intros Hn EQ.
 assert (depth n <> 0) by (rewrite depth_0; omega).
 rewrite !flip_eqn0, EQ; omega.
Qed.

Lemma flip_pred n : 1<n -> depth (n-1) = depth n ->
  flip (n-1) = S (flip n).
Proof.
 intros Hn EQ.
 assert (depth n <> 0) by (rewrite depth_0; omega).
 rewrite !flip_eqn0, EQ; try omega.
 assert (n <= fib (S (S (depth n)))) by (apply depth_carac; auto).
 rewrite fib_eqn; omega.
Qed.

(*=============================================================*)

(** * The [fg] function corresponding to the flipped [G] tree *)

Definition fg n := flip (g (flip n)).

(* Compute map fg (seq 0 10). *)

Lemma fg_depth n : depth (fg n) = depth n - 1.
Proof.
 unfold fg. now rewrite flip_depth, g_depth, flip_depth.
Qed.

Lemma fg_fib k : k<>0 -> fg (fib (S k)) = fib k.
Proof.
 destruct k as [|[|[|k]]].
 - omega.
 - reflexivity.
 - reflexivity.
 - intros _.
   unfold fg.
   now rewrite flip_fib, g_Sfib, flip_Sfib by omega.
Qed.

Lemma fg_Sfib k : 1<k -> fg (S (fib (S k))) = S (fib k).
Proof.
 intros Hk.
 unfold fg.
 rewrite flip_Sfib by omega.
 rewrite g_fib by omega.
 rewrite flip_fib; auto.
Qed.

Lemma fg_fib' k : 1<k -> fg (fib k) = fib (k-1).
Proof.
 destruct k.
 - omega.
 - intros. rewrite fg_fib; f_equal; omega.
Qed.

Lemma fg_Sfib' k : 2<k -> fg (S (fib k)) = S (fib (k-1)).
Proof.
 destruct k.
 - inversion 1.
 - intros. rewrite Nat.sub_1_r. apply fg_Sfib. simpl. omega.
Qed.

Lemma fg_step n : fg (S n) = fg n \/ fg (S n) = S (fg n).
Proof.
 destruct (le_lt_dec n 1) as [LE|LT].
 - assert (EQ : n = 0 \/ n = 1) by omega.
   destruct EQ as [-> | ->]; compute; auto.
 - set (k := depth n).
   assert (k<>0) by (unfold k; rewrite depth_0; omega).
   assert (S (fib (S k)) <= n <= fib (S (S k))).
   { apply depth_carac; auto. }
   destruct (eq_nat_dec n (fib (S (S k)))) as [EQ|NE].
   + rewrite EQ. rewrite fg_Sfib, fg_fib; auto. omega.
   + assert (depth (S n) = k). { apply depth_carac; omega. }
     assert (depth (flip (S n)) = k). { rewrite flip_depth; auto. }
     assert (1 < flip n). { now apply (flip_high n). }
     unfold fg.
     rewrite flip_S in *; auto.
     destruct (eq_nat_dec (g (flip n - 1)) (g (flip n))) as [EQ|NE'].
     * left; f_equal; trivial.
     * right.
       rewrite g_prev in NE' by omega.
       rewrite NE'.
       apply flip_pred.
       { unfold lt. change 2 with (g 3). apply g_mono.
         assert (flip n <> 2).
         { intros EQ. rewrite EQ in *. now compute in NE'. }
         omega. }
       { rewrite <- NE'. rewrite !g_depth. rewrite flip_depth.
         unfold k in *; omega. }
Qed.

Lemma fg_mono_S n : fg n <= fg (S n).
Proof.
 generalize (fg_step n). omega.
Qed.

Lemma fg_mono n m : n<=m -> fg n <= fg m.
Proof.
induction 1.
- trivial.
- transitivity (fg m); auto using fg_mono_S.
Qed.

Lemma fg_lipschitz n m : fg m - fg n <= m - n.
Proof.
destruct (le_ge_dec n m) as [H|H].
- induction H; try generalize (fg_step m); omega.
- generalize (fg_mono H). omega.
Qed.

Lemma fg_nonzero n : 0 < n -> 0 < fg n.
Proof.
 unfold lt. intros. change 1 with (fg 1). now apply fg_mono.
Qed.

Lemma fg_0_inv n : fg n = 0 -> n = 0.
Proof.
destruct n; trivial.
assert (0 < fg (S n)) by (apply fg_nonzero; auto with arith).
omega.
Qed.

Lemma fg_nz n : n <> 0 -> fg n <> 0.
Proof.
intros H. contradict H. now apply fg_0_inv.
Qed.

Lemma fg_fix n : fg n = n <-> n <= 1.
Proof.
 unfold fg.
 now rewrite flip_low, <- g_fix, flip_swap.
Qed.

Lemma fg_le n : fg n <= n.
Proof.
 generalize (fg_lipschitz 0 n). change (fg 0) with 0. omega.
Qed.

Lemma fg_lt n : 1<n -> fg n < n.
Proof.
intros H.
destruct (le_lt_or_eq _ _ (fg_le n)); trivial.
rewrite fg_fix in *. omega.
Qed.

Lemma fg_onto a : exists n, fg n = a.
Proof.
 unfold fg. destruct (g_onto (flip a)) as (x,H).
 exists (flip x). now rewrite flip_swap, flip_flip.
Qed.

Lemma fg_nonflat n : fg (S n) = fg n -> fg (S (S n)) = S (fg n).
Proof.
 intros H.
 destruct (le_lt_dec n 1) as [Hn|Hn].
 - assert (EQ : n = 0 \/ n = 1) by omega.
   destruct EQ as [-> | ->]; reflexivity.
 - destruct (fg_step (S n)) as [H'|H']; [|omega].
   exfalso.
   set (k := depth n).
   assert (Hk : k<>0) by (unfold k; rewrite depth_0; omega).
   assert (Hnk : S (fib (S k)) <= n <= fib (S (S k))).
   { apply depth_carac; auto. }
   destruct (eq_nat_dec n (fib (S (S k)))) as [EQ|NE].
   + rewrite EQ in H. rewrite fg_fib, fg_Sfib in H; omega.
   + destruct (eq_nat_dec (S n) (fib (S (S k)))) as [EQ|NE'].
     * rewrite EQ in H'. rewrite fg_fib, fg_Sfib in H'; omega.
     * revert H'. rewrite H; clear H. unfold fg. rewrite flip_eq.
       assert (depth (S n) = k). { apply depth_carac; omega. }
       assert (depth (flip (S n)) = k). { rewrite flip_depth; auto. }
       assert (depth (S (S n)) = k). { apply depth_carac; omega. }
       assert (depth (flip (S (S n))) = k). { rewrite flip_depth; auto. }
       rewrite flip_S by omega.
       rewrite flip_S by (unfold k in H; omega).
       assert (HH : forall m, 1<m -> g (m-1-1) <> g m).
       { intros.
         generalize (@g_max_two_antecedents (g m) (m-1-1) m).
         omega. }
       apply HH. apply flip_high in Hn. auto.
Qed.

Lemma fg_max_two_antecedents n m :
 fg n = fg m -> n < m -> m = S n.
Proof.
 intros H LT.
 unfold lt in LT.
 assert (LE := fg_mono LT).
 rewrite <- H in LE.
 destruct (fg_step n) as [EQ|EQ]; [|omega].
 apply fg_nonflat in EQ.
 destruct (le_lt_dec m (S n)) as [LE'|LT']; [omega|].
 unfold lt in LT'. apply fg_mono in LT'. omega.
Qed.

Lemma fg_inv n m : fg n = fg m -> n = m \/ n = S m \/ m = S n.
Proof.
 intros H.
 destruct (lt_eq_lt_dec n m) as [[LT|EQ]|LT]; auto.
 - apply fg_max_two_antecedents in LT; auto.
 - apply fg_max_two_antecedents in LT; auto.
Qed.

Lemma fg_eqn n : 3 < n -> fg n + fg (S (fg (n-1))) = S n.
Proof.
 intros Hn.
 set (k := depth n).
 assert (3<=k).
 { unfold k. change 3 with (depth 4).
   apply depth_mono; auto. }
 assert (LE : S (fib (S k)) <= n <= fib (S (S k))).
 { apply depth_carac. omega. auto. }
 destruct (eq_nat_dec (S (fib (S k))) n) as [EQ|NE].
 - (* n = S (fib (S k)) *)
   replace (n-1) with (fib (S k)) by omega.
   rewrite <- EQ.
   rewrite fg_fib, !fg_Sfib' by omega.
   replace (S k - 1) with k by omega.
   rewrite fib_eqn'; omega.
 - (* n > S (fib (S k)) *)
   assert (Hk : depth (n-1) = k).
   { apply depth_carac; omega. }
   assert (Hk' : depth (fg (n-1)) = k-1).
   { now rewrite fg_depth, Hk. }
   assert (LE' : S (fib k) <= fg (n-1) <= fib (S k)).
   { replace k with (S (k-1)) by omega.
     apply depth_carac; auto. omega. }
   destruct (eq_nat_dec (fg (n-1)) (fib (S k))) as [EQ|NE'].
   + (* fg(n-1) = fib (S k) *)
     rewrite EQ.
     rewrite fg_Sfib' by omega.
     assert (EQ' : fg n = fib (S k)).
     { destruct (fg_step (n-1)) as [EQ'|EQ'];
       replace (S (n-1)) with n in EQ'; try omega.
       rewrite EQ in EQ'.
       assert (H' : depth (fg n) = k) by (apply depth_carac; omega).
       rewrite fg_depth in H'. unfold k in *. omega. }
     rewrite EQ'.
     rewrite Nat.add_succ_r. rewrite <- fib_eqn' by omega.
     f_equal.
     assert (EQ'' : fg (n-1) = fg (fib (S (S k)))) by now rewrite EQ, fg_fib.
     apply fg_max_two_antecedents in EQ''; omega.
   + (* fg(n-1) <> fib (S k) *)
     assert (Hk'' : depth (S (fg (n-1))) = k-1).
     { apply depth_carac. omega.
       replace (S (k-1)) with k by omega.
       omega. }
     unfold fg at 2.
     rewrite flip_eqn0;
     rewrite g_depth, flip_depth, Hk''; [|omega].
     replace (S (S (k-1-1))) with k by omega.
     assert (LT : 1 < fg (n-1)).
     { unfold lt. change 2 with (fg 3). apply fg_mono. omega. }
     rewrite flip_S by omega.
     unfold fg at 2. rewrite flip_flip.
     rewrite flip_pred; try (unfold k in Hk; omega).
     clear LT Hk'' NE' LE' Hk Hk'.
     replace (g (g (S (flip n)) - 1)) with (flip n - g (flip n))
     by (generalize (g_alt_eqn (flip n)); omega).
     rewrite <- (flip_flip (g (flip n))).
     fold (fg n).
     rewrite !flip_eqn0 by (rewrite ?fg_depth; unfold k in H; omega).
     rewrite fg_depth.
     change (depth n) with k.
     replace (S (k-1)) with k by omega.
     rewrite fib_eqn.
     assert (Hnk : depth (fg n) = k-1).
     { rewrite fg_depth. unfold k. omega. }
     apply depth_carac in Hnk; [|omega].
     replace (S (k-1)) with k in Hnk by omega.
     replace (fib k) with (fib (S (S k)) - fib (S k)) in Hnk;
      [|rewrite fib_eqn; omega].
     set (FSSK := fib (S (S k))) in *.
     set (FSK := fib (S k)) in *.
     replace (S (FSSK+FSK) -n - (S FSSK - fg n))
      with (FSK + fg n - n) by omega.
     omega.
Qed.

(** This equation, along with initial values up to [n=3],
    characterizes [fg] entirely. It can hence be used to
    give an algebraic recursive definition to [fg], answering
    the Hofstader's question. *)

Lemma fg_eqn_unique f :
  f 0 = 0 ->
  f 1 = 1 ->
  f 2 = 1 ->
  f 3 = 2 ->
  (forall n, 3<n -> f n + f (S (f (n-1))) = S n) ->
  forall n, f n = fg n.
Proof.
 intros F0 F1 F2 F3 Fn.
 induction n as [n IH] using lt_wf_rec.
 destruct (le_lt_dec n 3) as [Hn|Hn].
 - destruct n as [|[|[|n]]]; try assumption.
   replace n with 0 by omega. assumption.
 - assert (E := fg_eqn Hn).
   specialize (Fn n Hn).
   rewrite (IH (n-1)) in Fn by omega.
   rewrite (IH (S (fg (n-1)))) in Fn.
   + generalize (@fg_lt n). omega.
   + generalize (@fg_lt (n-1)). omega.
Qed.

(*=============================================================*)

(** * [fg] and the shape of its tree

    We already know that [fg] is onto, hence each node has
    at least a child. Moreover, [fg_max_two_antecedents] says
    that we have at most two children per node.
*)

Lemma unary_flip a : Unary fg a <-> Unary g (flip a).
Proof.
 split; intros U n m Hn Hm; apply flip_eq; apply U;
 unfold fg in *; rewrite ?flip_flip; now apply flip_swap.
Qed.

Lemma multary_flip a : Multary fg a <-> Multary g (flip a).
Proof.
 unfold Multary.
 now rewrite unary_flip.
Qed.

Lemma fg_multary_binary a : Multary fg a <-> Binary fg a.
Proof.
 unfold Multary.
 split.
 - intros U.
   assert (Ha : a<>0).
   { contradict U.
     subst.
     intros u v Hu Hv. apply fg_0_inv in Hu. apply fg_0_inv in Hv.
     now subst. }
   destruct (fg_onto a) as (n,Hn).
   assert (Hn' : n<>0).
   { contradict Ha. now subst. }
   destruct (eq_nat_dec (fg (S n)) a);
   destruct (eq_nat_dec (fg (n-1)) a).
   + exfalso.
     generalize (@fg_max_two_antecedents (n-1) (S n)). omega.
   + exists n; exists (S n); repeat split; auto.
     intros k Hk.
     destruct (fg_inv n k) as [H|[H|H]]; try omega.
     subst n. simpl in *. rewrite Nat.sub_0_r in *. omega.
   + exists n; exists (n-1); repeat split; auto; try omega.
     intros k Hk.
     destruct (fg_inv n k) as [H|[H|H]]; try omega.
     subst k. omega.
   + elim U.
     intros u v Hu Hv.
     assert (u = n).
     { destruct (fg_inv n u) as [H|[H|H]]; subst;
       simpl in *; rewrite ?Nat.sub_0_r in *; omega. }
     assert (v = n).
     { destruct (fg_inv n v) as [H'|[H'|H']]; subst;
       simpl in *; rewrite ?Nat.sub_0_r in *; omega. }
     omega.
 - intros (n & m & Hn & Hm & Hnm & H) U.
   apply Hnm. now apply (U n m).
Qed.

Lemma unary_or_multary n : Unary fg n \/ Multary fg n.
Proof.
 rewrite unary_flip, multary_flip.
 apply unary_or_multary.
Qed.

Lemma unary_xor_multary n : Unary fg n -> Multary fg n -> False.
Proof.
 unfold Multary. intuition.
Qed.

(** We could even exhibit at least one child for each node *)

Definition rchild n :=
 if eq_nat_dec n 1 then 2 else n + fg (S n) - 1.
 (** rightmost son, always there *)

Lemma rightmost_child_carac a n : fg n = a ->
 (fg (S n) = S a <-> n = rchild a).
Proof.
 intros Hn.
 destruct (le_lt_dec n 2).
 - rewrite <- Hn.
   destruct n as [|[|n]].
   + compute. auto.
   + compute. auto.
   + replace n with 0 by omega. compute. auto.
 - assert (2 <= a).
   { change 2 with (fg 3). rewrite <- Hn. apply fg_mono. assumption. }
   unfold rchild.
   destruct eq_nat_dec.
   + destruct a as [|[|[|a]]]; trivial; omega.
   + assert (Hn' : 3 < S n) by omega.
     assert (H' := fg_eqn Hn').
     replace (S n - 1) with n in H' by omega.
     rewrite Hn in H'.
     omega.
Qed.

Lemma fg_onto_eqn a : fg (rchild a) = a.
Proof.
destruct (fg_onto a) as (n,Hn).
destruct (fg_step n) as [H|H].
- assert (H' := fg_nonflat _ H).
  rewrite Hn in *.
  rewrite rightmost_child_carac in H'; auto.
  now rewrite <- H'.
- rewrite Hn in *.
  rewrite rightmost_child_carac in H; auto.
  now rewrite <- H.
Qed.

Definition lchild n :=
 if eq_nat_dec n 1 then 1 else flip (FunG.rchild (flip n)).
 (** leftmost son, always there (but might be equal to
     the rightmost son for unary nodes) *)

Lemma lchild'_alt n : n<>1 -> lchild n = flip (flip n + flip (fg n)).
Proof.
 unfold lchild, FunG.rchild, fg.
 destruct eq_nat_dec; [intros; omega|intros].
 f_equal. f_equal.
 symmetry. apply flip_flip.
Qed.

Lemma fg_onto_eqn' n : fg (lchild n) = n.
Proof.
 unfold fg, lchild.
 destruct eq_nat_dec.
 - now subst.
 - rewrite flip_flip, g_onto_eqn.
   apply flip_flip.
Qed.

Lemma lchild_leftmost n : fg (lchild n - 1) = n - 1.
Proof.
 destruct (le_lt_dec n 1).
 - destruct n as [|n].
   + now compute.
   + replace n with 0 by omega; now compute.
 - set (k:=depth n).
   assert (k<>0) by (unfold k; rewrite depth_0; omega).
   assert (S (fib (S k)) <= n <= fib (S (S k))).
   { apply depth_carac; auto. }
   destruct (eq_nat_dec n (S (fib (S k)))) as [E|N].
   + rewrite E.
     replace (S (fib (S k)) - 1) with (fib (S k)) by omega.
     unfold lchild.
     destruct eq_nat_dec.
     * generalize (@fib_nz k); intros; omega.
     * rewrite flip_Sfib by omega.
       unfold FunG.rchild. rewrite g_fib by omega.
       rewrite <- fib_eqn.
       rewrite flip_fib by omega.
       replace (S (fib (S (S k))) - 1) with (fib (S (S k))) by omega.
       apply fg_fib; omega.
   + unfold fg. apply flip_swap.
     assert (1 < lchild n).
     { generalize (fg_onto_eqn' n).
       generalize (@fg_mono (lchild n) 2). change (fg 2) with 1.
       omega. }
     rewrite !flip_pred; auto.
     * unfold lchild.
       destruct eq_nat_dec; [omega|].
       rewrite flip_flip.
       rewrite FunG.rightmost_child_carac; auto.
       apply g_onto_eqn.
     * change (depth n) with k; apply depth_carac; omega.
     * assert (D : depth (lchild n) = S k).
       { unfold k. rewrite <- (fg_onto_eqn' n) at 2.
         rewrite fg_depth. generalize (depth_0 (lchild n)).
         omega. }
       rewrite D.
       apply depth_carac in D; auto.
       assert (lchild n <> S (fib (S (S k)))).
       { contradict N.
         rewrite <- (fg_onto_eqn' n), N. rewrite fg_Sfib; omega. }
       apply depth_carac; auto. omega.
Qed.

Lemma lchild_leftmost' n a :
  fg n = a -> n = lchild a \/ n = S (lchild a).
Proof.
 intros Hn.
 destruct (fg_inv (lchild a) n) as [H|[H|H]]; try omega.
 - rewrite <- Hn. apply fg_onto_eqn'.
 - exfalso.
   generalize (lchild_leftmost a).
   rewrite H. simpl. rewrite Nat.sub_0_r, Hn.
   intros. replace a with 0 in * by omega.
   discriminate.
Qed.

Lemma rchild_lchild n :
 rchild n = lchild n \/ rchild n = S (lchild n).
Proof.
 apply lchild_leftmost'. apply fg_onto_eqn.
Qed.

Lemma lchild_rchild n : lchild n <= rchild n.
Proof.
 destruct (rchild_lchild n); omega.
Qed.

Lemma fg_children a n :
  fg n = a -> (n = lchild a \/ n = rchild a).
Proof.
 intros H.
 destruct (lchild_leftmost' _ H) as [Hn|Hn]; auto.
 destruct (rchild_lchild a) as [Ha|Ha]; try omega.
 exfalso.
 symmetry in Ha. apply rightmost_child_carac in Ha.
 rewrite <- Hn in Ha. omega.
 apply fg_onto_eqn'.
Qed.

Lemma binary_lchild_is_unary n :
 1<n -> Multary fg n -> Unary fg (lchild n).
Proof.
 rewrite multary_flip, unary_flip.
 unfold lchild.
 destruct eq_nat_dec; try omega.
 rewrite flip_flip.
 intros. now apply binary_rchild_is_unary.
Qed.

Lemma rightmost_son_is_binary n :
  1<n -> Multary fg (rchild n).
Proof.
 intros.
 rewrite multary_flip.
 apply leftmost_son_is_binary with (flip n).
 - apply flip_swap. apply fg_onto_eqn.
 - rewrite <- flip_swap.
   set (k:=depth n).
   assert (k<>0) by (unfold k; rewrite depth_0; omega).
   assert (S (fib (S k)) <= n <= fib (S (S k))).
   { apply depth_carac; auto. }
   destruct (eq_nat_dec n (fib (S (S k)))) as [E|N].
   + assert (E' : rchild n = fib (S (S (S k)))).
     { symmetry.
       apply rightmost_child_carac.
       - now rewrite fg_fib.
       - rewrite fg_Sfib; omega. }
     rewrite E'.
     rewrite flip_fib by omega.
     replace (S (fib (S (S k))) - 1) with (fib (S (S k))) by omega.
     rewrite g_fib by omega.
     rewrite E, flip_swap, flip_fib; omega.
   + assert (1 < rchild n).
     { generalize (fg_onto_eqn n).
       generalize (@fg_mono (rchild n) 2). change (fg 2) with 1.
       omega. }
     rewrite <- flip_S; auto.
     * change (fg (S (rchild n)) <> n).
       assert (H' := fg_onto_eqn n).
       destruct (fg_step (rchild n)); try omega.
       apply rightmost_child_carac in H'. omega.
     * assert (D : depth (rchild n) = S k).
       { unfold k. rewrite <- (fg_onto_eqn n) at 2.
         rewrite fg_depth. generalize (depth_0 (rchild n)).
         omega. }
       rewrite D.
       apply depth_carac in D; auto.
       assert (rchild n <> fib (S (S (S k)))).
       { contradict N.
         rewrite <- (fg_onto_eqn n), N. now rewrite fg_fib. }
       apply depth_carac; auto. omega.
Qed.

Lemma unary_child_is_binary n :
 n <> 0 -> Unary fg n -> Multary fg (rchild n).
Proof.
 intros Hn H.
 destruct (le_lt_dec n 1).
 - replace n with 1 in * by omega.
   exfalso.
   specialize (H 1 2). compute in H. omega.
 - now apply rightmost_son_is_binary.
Qed.

Lemma binary_rchild_is_binary n :
 1<n -> Multary fg n -> Multary fg (rchild n).
Proof.
 intros. now apply rightmost_son_is_binary.
Qed.

(** Hence the shape of the [fg] tree is a repetition of
    this pattern:
<<
    r
    |
    p   q
     \ /
      n
>>
  where [n] and [q] and [r] are binary nodes and [p] is unary.

  As expected, this is the mirror of the [G] tree.
  We hence retrieve the fractal aspect of [G], flipped.
*)

(*=============================================================*)

(** * Comparison of [fg] and [g] *)

(** First, a few technical lemmas *)

Lemma fg_g_S_inv n : 3<n ->
 fg (S (fg (n-1))) = g (g (n-1)) ->
 fg n = S (g n).
Proof.
 intros Hn H.
 replace (fg n) with (S n - fg (S (fg (n-1))))
   by (rewrite <- fg_eqn; omega).
 replace n with (S (n-1)) at 3 by omega.
 rewrite g_S.
 replace (S (n-1)) with n by omega.
 rewrite H.
 assert (g (g (n-1)) <= n).
 { transitivity (g (n-1)). apply g_le.
   generalize (g_le (n-1)); omega. }
 omega.
Qed.

Lemma fg_g_eq_inv n : 3<n ->
 fg (S (fg (n-1))) = S (g (g (n-1))) ->
 fg n = g n.
Proof.
 intros Hn H.
 replace (fg n) with (S n - fg (S (fg (n-1))))
   by (rewrite <- fg_eqn; omega).
 replace n with (S (n-1)) at 3 by omega.
 rewrite g_S.
 replace (S (n-1)) with n by omega.
 rewrite H. omega.
Qed.

(** Now, the proof that [fg(n)] is either [g(n)] or [g(n)+1].
    This proof is split in many cases according to the shape
    of the Fibonacci decomposition of [n]. *)

Definition IHeq n :=
 forall m, m<n -> ~Fib.ThreeOdd 2 m -> fg m = g m.
Definition IHsucc n :=
 forall m, m<n -> Fib.ThreeOdd 2 m -> fg m = S (g m).

Lemma fg_g_aux0 n : IHeq n -> Fib.ThreeOdd 2 n -> fg n = S (g n).
Proof.
 intros IH TE.
 assert (6 <= n) by now apply ThreeOdd_le.
 apply fg_g_S_inv; try omega.
 rewrite (IH (n-1)), IH; try (generalize (@g_lt (n-1)); omega).
 - rewrite Odd_gP by auto. apply g_Two, Three_g; auto.
 - rewrite Odd_gP by auto.
   now apply ThreeEven_not_ThreeOdd', ThreeOdd_Sg.
 - apply Two_not_ThreeOdd, Odd_pred_Two; auto.
Qed.

Lemma fg_g_aux1 n : IHeq n -> 3<n -> Fib.Two 2 n -> fg n = g n.
Proof.
 intros IH N FO.
 apply fg_g_eq_inv; auto.
 assert (High 2 (n-1)). { apply Two_pred_High; auto; omega. }
 assert (Even 2 (g n)) by now apply Two_g.
 rewrite (IH (n-1)) by (auto;omega).
 rewrite 2 Even_gP; auto using Two_Even.
 assert (g n <> 0) by (apply g_nz; omega).
 assert (g (g n) <> 0) by now apply g_nz.
 replace (S (g n - 1)) with (g n) by omega.
 rewrite IH; auto; try apply g_lt; omega.
Qed.

Lemma fg_g_aux2 n :
 IHeq n -> IHsucc n -> 3<n -> Fib.ThreeEven 2 n -> fg n = g n.
Proof.
 intros IH1 IH2 N TO.
 apply fg_g_eq_inv; try omega.
 assert (H' := @g_lt (n-1)).
 rewrite (IH1 (n-1)), IH2; try omega.
 - rewrite Odd_gP by auto.
   f_equal. apply g_Two. apply Three_g; auto.
 - rewrite Odd_gP by auto. now apply ThreeEven_Sg.
 - apply Two_not_ThreeOdd, Three_pred_Two; auto.
Qed.

Lemma fg_g_aux3 n : IHeq n -> IHsucc n -> 3<n ->
 Fib.High 2 n -> fg n = g n.
Proof.
 intros IH1 IH2 Hn (k & K & L).
 apply fg_g_eq_inv; auto.
 destruct (Nat.Even_or_Odd k) as [(p,Hp)|(p,Hp)]; subst k.
 - (* even *)
   assert (E1 : g (n-1) = g n - 1) by (apply Even_gP; now exists p).
   assert (S (fg (n-1)) < n) by (generalize (@fg_lt (n-1)); omega).
   assert (g n <> 0) by (apply g_nz; omega).
   assert (E2 : S (g n - 1) = g n) by omega.
   destruct p as [|[|[|p]]].
   + omega.
   + omega.
   + (* four *)
     simpl in *.
     assert (T : Three 2 (g n)) by (revert L; apply g_Low; auto).
     rewrite E1, Odd_gP by auto.
     destruct L as (l & E & D & _).
     destruct l as [|k l]; [simpl in E; omega|].
     destruct (Nat.Even_or_Odd k) as [(p,Hp)|(p,Hp)]; subst k.
     * (* next term after 3 is even *)
       assert (ThreeEven 2 (n-1)).
       { exists p; exists l; auto. subst; split; auto.
         eapply Delta_low_hd with 4; auto. }
       rewrite (IH1 (n-1)) in * by (auto; omega).
       rewrite E1, E2, IH2 in *; auto.
       replace n with (S (n-1)) by omega.
       rewrite g_not_Two. now apply ThreeEven_Sg.
       intro. eapply Two_not_Three; eauto using ThreeEven_Three.
     * (* next term after 4 is odd *)
       assert (ThreeOdd 2 (n-1)).
       { exists p; exists l; auto. subst; split; auto.
         eapply Delta_low_hd with 4; auto. }
       rewrite (IH2 (n-1)) in * by (auto; omega).
       rewrite E1, E2, IH1 in *; auto using Odd_succ_Even.
       apply g_not_Two.
       intro. eapply Even_xor_Odd; eauto using Two_Even.
   + (* high odd *)
     remember (S (S p)) as k eqn:K'.
     assert (1<k) by omega. clear K K'.
     assert (Even 2 n) by now exists (S k).
     assert (~Two 2 n).
     { intro O. generalize (Low_unique L O). omega. }
     assert (~Four 2 n).
     { intro T. generalize (Low_unique L T). omega. }
     assert (ThreeOdd 2 (n-1)) by now apply EvenHigh_pred_ThreeOdd.
     rewrite (IH2 (n-1)) in *; auto; try omega.
     rewrite E1, E2 in *.
     assert (Ev : Odd 2 (g n)) by now apply Even_g.
     rewrite Odd_gP by auto.
     rewrite IH1; auto using Odd_succ_Even.
     apply g_not_Two.
     intro. apply Even_xor_Odd with (g n); eauto using Two_Even.
 - (* odd *)
   assert (High 2 n) by (exists (2*p+1); auto).
   assert (Odd 2 n) by now exists p.
   rewrite (IH1 (n-1));
     [ | omega | now apply Two_not_ThreeOdd, Odd_pred_Two ].
   assert (S (g (n-1)) < n) by (generalize (@g_lt (n-1)); omega).
   rewrite Odd_gP in * by auto.
   rewrite IH1; try omega.
   + apply g_not_Two. now apply High_g.
   + now apply Even_not_ThreeOdd, High_Sg.
Qed.

(** The main result: *)

Lemma fg_g n :
 (Fib.ThreeOdd 2 n -> fg n = S (g n)) /\
 (~Fib.ThreeOdd 2 n -> fg n = g n).
Proof.
 induction n  as [n IH] using lt_wf_rec.
 assert (IH1 := fun m (H:m<n) => proj1 (IH m H)).
 assert (IH2 := fun m (H:m<n) => proj2 (IH m H)).
 clear IH.
 split.
 - now apply fg_g_aux0.
 - intros.
   destruct (le_lt_dec n 3) as [LE|LT].
   + destruct n as [|[|[|n]]]; try reflexivity.
     replace n with 0 by omega. reflexivity.
   + assert (LT' : 2 < n) by omega.
     destruct (decomp_complete' LT') as [X|[X|[X|X]]].
     * now apply fg_g_aux1.
     * now apply fg_g_aux2.
     * intuition.
     * now apply fg_g_aux3.
Qed.

(** Note: the positions where [fg] and [g] differ start at 7
    and then are separated by 5 or 8 (see [Fib.ThreeOdd_next]
    and related lemmas). Moreover these positions are always
    unary nodes in [G] (see [FunG.decomp_unary]).

    In fact, the [g] tree can be turned into the [fg] tree
    by repeating the following transformation whenever [s] below
    is ThreeOdd:
<<
  r   s t             r s   t
   \ /  |             |  \ /
    p   q   becomes   p   q
     \ /               \ /
      n                 n
>>

    In the left pattern above, [s] is ThreeOdd, hence [r] and
    [p] and [n] are Two, [q] is ThreeEven and [t] is High.
*)

(** Some immediate consequences: *)

Lemma fg_g_step n : fg n = g n \/ fg n = S (g n).
Proof.
 destruct (le_lt_dec n 3) as [LE|LT].
 - left.
   destruct n as [|[|[|n]]]; try reflexivity.
   replace n with 0 by omega. reflexivity.
 - assert (LT' : 2 < n) by omega.
   destruct (decomp_complete' LT') as [X|[X|[X|X]]].
   * left. apply fg_g. now apply Two_not_ThreeOdd.
   * left. apply fg_g. now apply ThreeEven_not_ThreeOdd.
   * right. now apply fg_g.
   * left. apply fg_g. now apply High_not_ThreeOdd.
Qed.

Lemma g_le_fg n : g n <= fg n.
Proof.
 destruct (fg_g_step n); omega.
Qed.

(*=============================================================*)

(** * [fg] and "delta" equations *)

(** We can characterize [fg] via its "delta" (a.k.a increments).
   Let [d(n) = fg(n+1)-fg(n)].  For [n>3] :

    - a) if [d(n-1) = 0] then [d(n) = 1]
    - b) if [d(n-1) <> 0] and [d(fg(n)) = 0] then [d(n) = 1]
    - c) if [d(n-1) <> 0] and [d(fg(n)) <> 0] then [d(n) = 0]

   In fact these deltas are always 0 or 1.
*)

(** [FD] is a relational presentation of these "delta" equations. *)

Inductive FD : nat -> nat -> Prop :=
 | FD_0 : FD 0 0
 | FD_1 : FD 1 1
 | FD_2 : FD 2 1
 | FD_3 : FD 3 2
 | FD_4 : FD 4 3
 | FD_a n x : 4<n -> FD (n-2) x -> FD (n-1) x -> FD n (S x)
 | FD_b n x y z : 4<n -> FD (n-2) x -> FD (n-1) y -> x<>y ->
                   FD y z -> FD (S y) z -> FD n (S y)
 | FD_c n x y z t : 4<n -> FD (n-2) x -> FD (n-1) y -> x<>y ->
                     FD y z -> FD (S y) t -> z <> t -> FD n y.
Hint Constructors FD.

Lemma FD_le n k : FD n k -> k <= n.
Proof.
induction 1; auto with arith; omega.
Qed.

Lemma FD_nz n k : FD n k -> 0<n -> 0<k.
Proof.
induction 1; auto with arith; omega.
Qed.

Lemma FD_lt n k : FD n k -> 1<n -> 0<k<n.
Proof.
induction 1; auto with arith; omega.
Qed.

(* begin hide *)
Ltac uniq :=
match goal with
| U:forall k, FD ?x k -> _, V:FD ?x ?y |- _ =>
   apply U in V; try subst y; uniq
| U:?x<>?x |- _ => now elim U
end.
(* end hide *)

Lemma FD_unique n k k' : FD n k -> FD n k' -> k = k'.
Proof.
intros H1.
revert k'.
induction H1; inversion 1; subst; auto; try omega; uniq.
Qed.

Lemma FD_step n k k' : FD n k -> FD (S n) k' -> k'=k \/ k' = S k.
Proof.
inversion 2; subst; intros; simpl in *; rewrite ?Nat.sub_0_r in *.
- replace k with 0 by (apply FD_unique with 0; auto). auto.
- replace k with 1 by (apply FD_unique with 1; auto). auto.
- replace k with 1 by (apply FD_unique with 2; auto). auto.
- replace k with 2 by (apply FD_unique with 3; auto). auto.
- replace x with k by (apply FD_unique with n; auto). omega.
- replace y with k by (apply FD_unique with n; auto). omega.
- replace k' with k by (apply FD_unique with n; auto). omega.
Qed.

(** [fg] is an implementation of [FD] (hence the only one). *)

Lemma fg_implements_FD n : FD n (fg n).
Proof.
induction n as [n IH] using lt_wf_rec.
destruct (le_lt_dec n 4) as [Hn|Hn].
- destruct n as [|[|[|[|n]]]]; try constructor.
  replace n with 0 by omega. constructor.
- assert (FD (n-2) (fg (n-2))) by (apply IH; omega).
  assert (FD (n-1) (fg (n-1))) by (apply IH; omega).
  destruct (fg_step (n-2)) as [E|N].
  + replace n with (S (S (n-2))) at 2 by omega.
    rewrite (fg_nonflat (n-2)); auto.
    constructor; auto. rewrite <- E.
    replace (S (n-2)) with (n-1) by omega. auto.
  + replace (S (n-2)) with (n-1) in N by omega.
    set (x := fg (n-2)) in *.
    set (y := fg (n-1)) in *.
    assert (FD y (fg y)).
    { apply IH. unfold y. generalize (fg_le (n-1)); omega. }
    assert (FD (S y) (fg (S y))).
    { apply IH. unfold y. generalize (@fg_lt (n-1)); omega. }
    assert (Hn' : 3 < n) by omega.
    assert (Hn'' : 3 < n-1) by omega.
    assert (EQ := fg_eqn Hn').
    assert (EQ' := fg_eqn Hn'').
    change (fg(n-1)) with y in EQ,EQ'.
    replace (n-1-1) with (n-2) in EQ' by omega.
    change (fg(n-2)) with x in EQ'.
    rewrite <- N in EQ'.
    destruct (fg_step y) as [E'|N'].
    * replace (fg n) with (S y) by omega.
      eapply FD_b; eauto. omega. rewrite <- E'; auto.
    * replace (fg n) with y by omega.
      eapply FD_c; eauto. omega. omega.
Qed.

Lemma fg_unique n k : FD n k <-> k = fg n.
Proof.
split.
- intros. eapply FD_unique; eauto. apply fg_implements_FD.
- intros ->. apply fg_implements_FD.
Qed.

(** The three situations a) b) c) expressed in terms of [fg]. *)

Lemma fg_a n : 0<n -> fg (n-2) = fg (n-1) -> fg n = S (fg (n-1)).
Proof.
destruct (le_lt_dec n 4).
- destruct n as [|[|[|[|n]]]].
  + omega.
  + reflexivity.
  + discriminate.
  + reflexivity.
  + replace n with 0 by omega. compute. reflexivity.
- intros.
  symmetry. apply fg_unique.
  apply FD_a; auto using fg_implements_FD.
  now apply fg_unique.
Qed.

Lemma fg_b n y : 4<n ->
 y = fg (n-1) ->
 fg (n-2) <> y ->
 fg (S y) = fg y ->
 fg n = S y.
Proof.
 intros.
 symmetry. apply fg_unique.
 apply (@FD_b n (fg (n-2)) y (fg y));
  auto using fg_implements_FD.
 - subst. apply fg_implements_FD.
 - now apply fg_unique.
Qed.

Lemma fg_c n y : 4<n ->
 y = fg (n-1) ->
 fg (n-2) <> y ->
 fg (S y) <> fg y ->
 fg n = y.
Proof.
 intros.
 symmetry. apply fg_unique.
 apply (@FD_c n (fg (n-2)) y (fg y) (fg (S y)));
  auto using fg_implements_FD.
 subst. apply fg_implements_FD.
Qed.

(** An old auxiliary lemma stating the converse of the c) case *)

Lemma fg_c_inv n :
  2<n -> fg n = fg (n-1) -> fg (S (fg n)) = S (fg (fg n)).
Proof.
 intros Hn Hg.
 symmetry in Hg. apply fg_unique in Hg.
 remember fg as f eqn:Hf.
 inversion Hg; subst.
 - reflexivity.
 - compute in H1. discriminate.
 - omega.
 - compute in H1. discriminate.
 - compute in H1. discriminate.
 - assert (x = fg(n-1)).
   { eapply FD_unique; eauto using fg_implements_FD. }
   omega.
 - assert (y = fg(n-1)).
   { eapply FD_unique; eauto using fg_implements_FD. }
   omega.
 - set (y := fg(n-1)) in *.
   assert (y = fg n).
   { eapply FD_unique with n; eauto using fg_implements_FD. }
   assert (z = fg y).
   { eapply FD_unique; eauto using fg_implements_FD. }
   assert (t = fg (S y)).
   { eapply FD_unique; eauto using fg_implements_FD. }
   destruct (fg_step y); congruence.
Qed.

(** Presentation via a "delta" function *)

Definition d n := fg (S n) - fg n.

Lemma delta_0_1 n : d n = 0 \/ d n = 1.
Proof.
 unfold d. destruct (fg_step n); omega.
Qed.

Lemma delta_a n : n<>0 -> d (n-1) = 0 -> d n = 1.
Proof.
 intro Hn.
 unfold d in *.
 generalize (fg_nonflat (n-1)).
 generalize (fg_mono_S (n-1)).
 replace (S (n-1)) with n by omega.
 omega.
Qed.

Lemma delta_b n : 4<=n ->
 d (n-1) = 1 -> d (fg n) = 0 -> d n = 1.
Proof.
 unfold d.
 intros.
 replace (S (n-1)) with n in * by omega.
 rewrite (@fg_b (S n) (fg n)); try omega.
 f_equal. omega.
 simpl. omega.
 generalize (fg_step (fg n)). omega.
Qed.

Lemma delta_c n : 4<=n ->
 d (n-1) = 1 -> d (fg n) = 1 -> d n = 0.
Proof.
 unfold d.
 intros.
 replace (S (n-1)) with n in * by omega.
 rewrite (@fg_c (S n) (fg n)); try omega.
 f_equal. omega.
 simpl. omega.
Qed.

Lemma delta_bc n : 4<=n -> d (n-1) = 1 -> d n = 1 - d (fg n).
Proof.
 intros.
 destruct (delta_0_1 (fg n)) as [E|E]; rewrite E.
 - now apply delta_b.
 - now apply delta_c.
Qed.

(* A short formula giving delta:
   This could be used to define fg. *)

Lemma delta_eqn n : 4<=n ->
 d n = 1 - d (n-1) * d (fg n).
Proof.
 intros.
 destruct (delta_0_1 (n-1)) as [E|E]; rewrite E.
 - simpl. apply delta_a; auto; omega.
 - rewrite Nat.mul_1_l. now apply delta_bc.
Qed.

(*============================================================*)

(** * An alternative equation for [fg]

   Another short equation for [fg], but this one cannot be used
   for defining [fg] recursively :-(
*)

Lemma fg_alt_eqn n : 3 < n -> fg (fg n) + fg (n-1) = n.
Proof.
 intros.
 set (k := depth n).
 assert (Hk : 3<=k).
 { unfold k. change 3 with (depth 4).
   apply depth_mono; auto. }
 assert (LE : S (fib (S k)) <= n <= fib (S (S k))).
 { apply depth_carac. omega. auto. }
 unfold fg. rewrite flip_flip.
 rewrite flip_eqn0; rewrite !g_depth, flip_depth; [|unfold k in *; omega].
 fold k.
 replace (S (S (k-1-1))) with k by omega.
 destruct (eq_nat_dec n (S (fib (S k)))) as [EQ|NE].
 - rewrite EQ.
   replace (S (fib (S k)) - 1) with (fib (S k)) by omega.
   rewrite flip_Sfib by omega.
   replace k with (S (k-1)) by omega.
   rewrite flip_fib by omega.
   rewrite !g_fib by omega.
   replace (k-1) with (S (k-2)) at 3 by omega.
   rewrite g_Sfib by omega.
   rewrite flip_Sfib by omega.
   replace (S (k-2)) with (k-1) by omega.
   rewrite fib_eqn'; omega.
 - assert (Hk' : depth (n-1) = k).
   { apply depth_carac; omega. }
   rewrite (flip_eqn0 (g _)); rewrite g_depth, flip_depth, Hk';
    [|omega].
   replace (S (k-1)) with k by omega.
   rewrite flip_pred by (unfold k in Hk'; omega).
   rewrite g_S.
   rewrite (flip_eqn0 n) at 2 by (unfold k in Hk; omega).
   fold k.
   assert (Hk'' : depth (g (g (flip n))) = k-2).
   { rewrite !g_depth, flip_depth. unfold k; omega. }
   apply depth_carac in Hk'' ; [|omega].
   rewrite (fib_eqn (S k)).
   replace (S (S (k-2))) with k in * by omega.
   assert (fib k <= fib (S k)).
   { apply fib_mono. omega. }
   omega.
Qed.

(** This last equation f(f(n)) + f(n-1) = n for n > 3
    is nice and short, but unfortunately it doesn't define
    a unique function, even if the first values are fixed to
    0 1 1 2. For instance: *)

Definition oups n :=
 match n with
 | 0 => 0
 | 1 => 1
 | 2 => 1
 | 3 => 2
 | 4 => 3
 | 5 => 3
 | 6 => 5
 | 7 => 3
 | _ => if even n then n-2 else 4
 end.

Lemma oups_def n : 7<n -> oups n = if even n then n-2 else 4.
Proof.
 do 8 (destruct n; try omega). reflexivity.
Qed.

Lemma oups_alt_eqn n : 3<n -> oups (oups n) + oups (n-1) = n.
Proof.
intros.
destruct (le_lt_dec n 9).
- do 10 (destruct n; simpl; try omega).
- case_eq (even n); intros E.
  + rewrite (@oups_def n),E,!oups_def by omega.
    rewrite !Nat.even_sub,E by omega. simpl. omega.
  + rewrite (@oups_def n),E by omega. simpl.
    rewrite oups_def by omega.
    rewrite !Nat.even_sub,E by omega. simpl. omega.
Qed.

(** We will show below that if we require this equation along
    with a monotonicity constraint, then there is a unique
    solution (which is hence [fg]). *)

(** Study of the alternative equation and its consequences. *)

Definition AltSpec (f:nat->nat) :=
  (f 0 = 0 /\ f 1 = 1 /\ f 2 = 1 /\ f 3 = 2) /\
  (forall n, 3<n -> f (f n) + f (n-1) = n).

Lemma alt_spec_fg : AltSpec fg.
Proof.
split. now compute. apply fg_alt_eqn.
Qed.

Lemma alt_spec_oups : AltSpec oups.
Proof.
split. now compute. apply oups_alt_eqn.
Qed.

Lemma alt_bound f : AltSpec f -> forall n, 1<n -> 0 < f n < n.
Proof.
intros ((H0 & H1 & H2 & H3),Hf).
induction n as [n IH] using lt_wf_rec.
intros Hn.
destruct (le_lt_dec n 3) as [Hn'|Hn'].
- destruct n as [|[|[|n]]]; try omega. replace n with 0; omega.
- assert (1 < f (f n) < n).
  { generalize (IH (n-1)) (Hf n). omega. }
  assert (f (f (S n)) + f n = S n).
  { replace n with (S n - 1) at 2 by omega. apply Hf; omega. }
  assert (f n <> 0). { intros E. rewrite E in *. omega. }
  assert (f n <> n). { intros E. rewrite !E in *. omega. }
  assert (f n <> S n).
  { intros E. rewrite E in *. specialize (IH (f (S n))). omega. }
  omega.
Qed.

Lemma alt_bound' f : AltSpec f -> forall n, 0 <= f n <= n.
Proof.
intros Hf [|[|n]].
- replace (f 0) with 0. auto. symmetry. apply Hf.
- replace (f 1) with 1. auto. symmetry. apply Hf.
- generalize (@alt_bound _ Hf (S (S n))). omega.
Qed.

Lemma alt_4 f : AltSpec f -> f 4 = 3.
Proof.
 intros Hf.
 assert (0 < f 4 < 4) by (apply alt_bound; auto).
 assert (f (f 4) + f 3 = 4) by (apply Hf; auto).
 destruct Hf as ((F0 & F1 & F2 & F3),_).
 destruct (f 4) as [|[|[|[|n]]]]; omega.
Qed.

Lemma alt_5 f : AltSpec f -> f 5 = 3.
Proof.
 intros Hf.
 assert (0 < f 5 < 5) by (apply alt_bound; auto).
 assert (f (f 5) + f 4 = 5) by (apply Hf; auto).
 assert (f 4 = 3) by (apply alt_4; auto).
 destruct Hf as ((F0 & F1 & F2 & F3),_).
 destruct (f 5) as [|[|[|[|[|n]]]]]; omega.
Qed.

(** Alas, [f(n)] isn't unique for [n>5] (e.g 4 or 5 for [n=6]) *)

Lemma monotone_equiv f :
 (forall n, f n <= f (S n)) ->
 (forall n m, n <= m -> f n <= f m).
Proof.
intros Mon.
induction 1.
- reflexivity.
- now transitivity (f m).
Qed.

Lemma alt_mono_bound f : AltSpec f ->
  (forall n, f n <= f (S n)) ->
  forall n m, n <= m -> f m - f n <= m-n.
Proof.
intros Hf Mon.
assert (main : forall n m, 3 < n <= m -> f m - f n <= m - n).
{
  intros.
  destruct Hf as (_,Hf).
  generalize (Hf (S n)) (Hf (S m)); simpl; intros.
  rewrite Nat.sub_0_r in *.
  generalize (@monotone_equiv _ Mon (S n) (S m)).
  generalize (@monotone_equiv _ Mon (f (S n)) (f (S m))).
  omega.
}
intros n m. destruct (le_lt_dec n 3); intros.
- destruct (le_lt_dec m 3); intros.
  + destruct Hf as ((F0 & F1 & F2 & F3), _).
    destruct m as [|[|[|[|m]]]], n as [|[|[|[|n]]]]; omega.
  + specialize (main 4 m). rewrite alt_4 in main; auto.
    destruct Hf as ((F0 & F1 & F2 & F3), _).
    destruct n as [|[|[|[|n]]]]; omega.
- apply main; auto.
Qed.

Lemma alt_mono_unique f1 f2 :
  AltSpec f1 -> (forall n, f1 n <= f1 (S n)) ->
  AltSpec f2 -> (forall n, f2 n <= f2 (S n)) ->
  forall n, f1 n = f2 n.
Proof.
intros Hf1 Mon1 Hf2 Mon2.
induction n as [n IH] using lt_wf_rec.
destruct (le_lt_dec n 3).
- destruct Hf1 as ((F10 & F11 & F12 & F13),_),
           Hf2 as ((F20 & F21 & F22 & F23),_).
  destruct n as [|[|[|[|n]]]]; omega.
- assert (f1 (n-1) = f2 (n-1)) by (apply IH; omega).
  assert (f1 (f1 n) = f2 (f2 n)).
  { destruct Hf1 as (_,Hf1), Hf2 as (_,Hf2).
    specialize (Hf1 n). specialize (Hf2 n). omega. }
  set (x1:=f1 n) in *.
  set (x2:=f2 n) in *.
  assert (f1 x1 = f2 x1).
  { apply IH. apply alt_bound; auto. omega. }
  assert (f1 x2 = f2 x2).
  { apply IH. apply alt_bound; auto. omega. }
  assert (f2 (n-1) <= x2 /\ x2-f2(n-1) <= 1).
  { unfold x2; split.
    - generalize (Mon2 (n-1)); replace (S (n-1)) with n; omega.
    - generalize (@alt_mono_bound _ Hf2 Mon2 (n-1) n); omega. }
  assert (f1 (n-1) <= x1 /\ x1-f1(n-1) <= 1).
  { unfold x1; split.
    - generalize (Mon1 (n-1)); replace (S (n-1)) with n; omega.
    - generalize (@alt_mono_bound _ Hf1 Mon1 (n-1) n); omega. }
  destruct (lt_eq_lt_dec x1 x2) as [[LT|EQ]|LT]; trivial; exfalso.
  + (* x1 < x2 *)
    assert (f1 (S x1) <= f1 x2).
    { apply monotone_equiv. apply Mon1. apply LT. }
    assert (f1 (f1 (S n)) = S (f1 x1)).
    { destruct Hf1 as (_,Hf1).
      generalize (Hf1 (S n)) (Hf1 n); simpl.
      rewrite Nat.sub_0_r.
      unfold x1 in *; omega. }
    assert (f1 (f1 (S n)) = f1 (S x1)).
    { f_equal.
      generalize
        (@alt_mono_bound _ Hf1 Mon1 n (S n))
        (@alt_mono_bound _ Hf1 Mon1 x1 (f1 (S n)) (Mon1 n)).
      unfold x1 in *; omega. }
    omega.
  + (* x2 < x1 *)
    assert (f2 (S x2) <= f2 x1).
    { apply monotone_equiv. apply Mon2. apply LT. }
    assert (f2 (f2 (S n)) = S (f2 x2)).
    { destruct Hf2 as (_,Hf2).
      generalize (Hf2 (S n)) (Hf2 n); simpl.
      rewrite Nat.sub_0_r.
      unfold x2 in *; omega. }
    assert (f2 (f2 (S n)) = f2 (S x2)).
    { f_equal.
      generalize
        (@alt_mono_bound _ Hf2 Mon2 n (S n))
        (@alt_mono_bound _ Hf2 Mon2 (f2 n) (f2 (S n)) (Mon2 n)).
      unfold x2 in *; omega. }
    omega.
Qed.

Lemma alt_mono_is_fg f :
  AltSpec f -> (forall n, f n <= f (S n)) ->
  forall n, f n = fg n.
Proof.
 intros Hg Mon. apply alt_mono_unique; auto.
 - split. now compute. apply fg_alt_eqn.
 - apply fg_mono_S.
Qed.


(*******************************************************************************

Title: CommutativeSquares.v
Authors: Jeremy Avigad, Chris Kapulkin, Peter LeFanu Lumsdaine
Date: 1 March 2013

Some basic results on commutative squares, considered as maps of
arrows.

*******************************************************************************)

Require Import HoTT.
Require Import Auxiliary.

Section Comm_Squares.

(* Commutative squares compose. *)
Lemma comm_square_comp
  {A B} {f:A->B} {A' B'} {f':A'->B'} {A'' B''} {f'':A''->B''}
  {h' : A' -> A''} {g' : B' -> B''} (comm' : f'' o h' == g' o f')
  {h : A -> A'} {g : B -> B'} (comm : f' o h == g o f)
: f'' o (h' o h) == (g' o g) o f.
Proof.
  intros x. path_via (g' (f' (h x))).
  apply ap, comm.
Defined.

(* We show that given any commutative square from [f] to [f'] whose verticals
[wA, wB] are equivalences, the equiv_inv square from [f'] to [f] with verticals
[wA ^-1, wB ^-1] also commutes. *)
Lemma comm_square_inverse
  {A B : Type} {f : A -> B}
  {A' B' : Type} {f' : A' -> B'}
  {wA : A <~> A'} {wB : B <~> B'}
  (wf : f' o wA == wB o f)
: f o (wA ^-1) == (wB ^-1) o f'.
Proof.
  intros a'.
  path_via (wB ^-1 (wB (f (wA ^-1 a')))).
    apply inverse, eissect.
  apply ap, (concat (wf _)^).
  apply ap, eisretr.
Defined.

(* Up to naturality, the result of [comm_square_inverse] really is a
retraction (aka left inverse); *)
Lemma comm_square_inverse_is_sect
  {A B : Type} {f : A -> B}
  {A' B' : Type} {f' : A' -> B'}
  (wA : A <~> A') (wB : B <~> B')
  (wf : f' o wA == wB o f)
: (fun a:A => (comm_square_comp (comm_square_inverse wf) wf a)
             @ eissect wB (f a))
   == fun a:A => (ap f (eissect wA a)).
Proof.
  intros a; simpl. unfold comm_square_inverse, comm_square_comp; simpl.
  repeat apply (concat (concat_pp_p)). apply moveR_Vp.
  path_via' (ap (wB ^-1 o wB) (ap f (eissect wA a)) @ eissect wB (f a)).
    Focus 2. apply (concat (concat_Ap (eissect wB) _)). apply ap, ap_idmap.
  apply (concat (concat_p_pp)), whiskerR.
  apply (concat (ap_pp (wB ^-1) _ _)^), (concatR (ap_compose wB _ _)^).
  apply ap, (concat concat_pp_p), moveR_Vp.
  path_via (ap (f' o wA) (eissect wA a) @ wf a).
    apply whiskerR.  apply (concatR (ap_compose wA f' _)^).
    apply ap, eisadj.
  apply (concat (concat_Ap wf _)).
  apply whiskerL, (ap_compose f wB).
Defined.

(* and similarly, [comm_square_inverse] is a section (aka right equiv_inv). *)
(* TODO (low) : simplify proof!? *)
Lemma comm_square_inverse_is_retr
  {A B : Type} {f : A -> B}
  {A' B' : Type} {f' : A' -> B'}
  (wA : A <~> A') (wB : B <~> B')
  (wf : f' o wA == wB o f)
: (fun a:A' => (comm_square_comp wf (comm_square_inverse wf) a)
             @ eisretr wB (f' a))
   == fun a:A' => (ap f' (eisretr wA a)).
Proof.
  intros a; simpl. unfold comm_square_inverse, comm_square_comp; simpl.
  rewrite !ap_pp. rewrite <- !concat_pp_p.
  rewrite concat_pp_p.
  set (p := (ap wB (ap (wB ^-1) (ap f' (eisretr wA a)))
            @ eisretr wB (f' a))).
  path_via ((eisretr wB _)^ @ p).
  apply whiskerR.
    apply moveR_pM.
    path_via ((eisretr wB (f' (wA (wA ^-1 a))))^ @
       ap (wB o wB ^-1) (wf ((wA ^-1) a))).
      rewrite ap_V. rewrite <- eisadj.
      path_via' (ap idmap (wf ((wA ^-1) a))
        @ (eisretr wB (wB (f ((wA ^-1) a))))^).
      apply whiskerR. apply inverse. apply ap_idmap.
      apply (concat_Ap
         (fun b' => (eisretr wB b')^) (wf ((wA ^-1) a)) ).
    apply ap. rewrite ap_compose. rewrite !ap_V.
    apply inverse. apply inv_V.
  apply moveR_Vp. subst p. rewrite <- ap_compose.
  path_via (eisretr wB (f' (wA ((wA ^-1) a)))
            @ ap idmap (ap f' (eisretr wA a))).
  apply (concat_Ap
    (eisretr wB) (ap f' (eisretr wA a)) ).
  apply ap. apply ap_idmap.
Defined.

End Comm_Squares.

(*
Local Variables:
coq-prog-name: "hoqtop"
End:
*)


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

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

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

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

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma append_assoc: forall l1 l2 l3,
  append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
induction l1.
  - simpl. intros. rewrite IHl1. reflexivity.
  - reflexivity.
Qed.

Lemma lem: forall l n, Cons n (rev l) = rev (append l (Cons n Nil)).
Proof.
intros. induction l.
  - simpl. rewrite <- IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem2: forall l, rev (rev l) = l.
Proof.
induction l.
  - simpl. lfind.  rewrite IHl.  reflexivity.
Admitted.

Lemma lem3: forall l, append l Nil = l.
Proof.
induction l.
  - simpl. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (append (rev x) (rev y))) (append y x).
Proof.
 induction x.
 - intros. simpl. rewrite <- append_assoc. simpl.
   rewrite lem. rewrite IHx. rewrite <- append_assoc. reflexivity.
 - intros. simpl. rewrite lem2. rewrite lem3. reflexivity.
Qed.


Set Warnings "-notation-overridden,-parsing".
From LF Require Export Poly.

(* apply tactics *)

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

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

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

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

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

Theorem rev_ex1 : forall(l l': list nat),
    l = rev l' ->
    l' = rev l.
Proof.
  intros.
  rewrite H.
  symmetry.
  apply rev_involutive. Qed.

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

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

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

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

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

Example injection_ex3 : forall(X : Type) (x y z : X) (l j : list X),
  x :: y :: l = z :: j ->
  y :: l = x :: j ->
  x = y.
Proof.
  intros.
  injection H0.
  intros sH1 sH2.
  symmetry. apply sH2.
Qed.

Theorem eqb_0_l : forall n,
    0=?n = true -> n = 0.
Proof.
  intros n.
  destruct n as [| n'] eqn:E.
  - intros H. reflexivity.
  - simpl.
    intros H. discriminate H.
Qed.

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

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

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

Theorem plus_n_n_injective : forall n m,
    n+n = m+m ->
    n = m.
Proof.
  intros n. induction n as [| n'].
  intros m H. destruct m as [|m'].
    reflexivity.
    inversion H.
  intros m. destruct m as [|m'].
    intros. inversion H.
    intros eq. inversion eq.
    rewrite <- plus_n_Sm in H0. rewrite <- plus_n_Sm in H0.
    inversion H0. apply IHn' in H1. rewrite -> H1. reflexivity.
Qed.

Definition square n := n * n.

Theorem plus_assoc : forall n m p : nat, n + (m + p) = (n + m) + p.
Proof.
  intros n m p. induction n as [| n'].
  - reflexivity.
  - simpl. rewrite IHn'. reflexivity.
Qed.

Lemma mult_plus_distr_r : forall n m p : nat,
  (n + m) * p = (n * p) + (m * p).
Proof.
  intros n m p.
  induction n.
  reflexivity.
  simpl.
  rewrite IHn.
  rewrite plus_assoc.
  reflexivity.
Qed.

Theorem mult_assoc: forall n m p: nat,
    n*(m*p)=(n*m)*p.
Proof.
  intros.
  induction n.
  - reflexivity.
  - simpl.
    rewrite IHn. rewrite mult_plus_distr_r.
    reflexivity.
Qed.

Theorem plus_swap : forall n m p : nat, n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  assert (H: n + m = m + n).
  - rewrite plus_comm. reflexivity.
  - rewrite plus_assoc. rewrite H. rewrite plus_assoc. reflexivity.
Qed.

Theorem mult_plus : forall n m : nat, n * S m = n + (n * m).
Proof.
  intros n m.
  induction n as [| n'].
  - reflexivity.
  - simpl. rewrite IHn'. rewrite plus_swap. reflexivity.
Qed.

Theorem mult_0_r : forall n : nat, n * 0 = 0.
Proof.
  intros n. induction n as [| n'].
  - reflexivity.
  - simpl. rewrite IHn'. reflexivity.
Qed.

Theorem mult_comm : forall m n : nat, m * n = n * m.
Proof.
  intros m n. induction m as [| m'].
  - rewrite mult_0_r. reflexivity.
  - simpl. rewrite mult_plus. rewrite IHm'. reflexivity.
Qed.

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


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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