Require Import compcert.lib.Coqlib.
Require Import List. Import ListNotations.
Require Import compcert.lib.Integers.
Require Import msl.Coqlib2.
Require Import floyd.coqlib3.
Require Import floyd.sublist.

Local Open Scope nat.

Fixpoint map2 {A B C: Type} (f: A -> B -> C) (al: list A) (bl: list B) : list C :=
 match al, bl with
  | a::al', b::bl' => f a b :: map2 f al' bl'
  | _, _ => nil
  end.

Lemma length_map2:
 forall A B C (f: A -> B -> C) al bl n,
  length al = n -> length bl = n ->
  length (map2 f al bl) = n.
Proof.
induction al; destruct bl,n; simpl; intros; auto.
inv H.
Qed.

Lemma list_repeat_injective {A} (a a':A) n: (0<n)%nat ->
      list_repeat n a = list_repeat n a' -> a=a'.
  Proof. intros.
    destruct n. omega. simpl in H0. inversion H0. trivial.
  Qed.

Local Open Scope Z.

Definition roundup (a b : Z) := (a + (b-1))/b*b.

Lemma roundup_minus:
   forall a b,  b > 0 -> roundup a b - a = (- a) mod b.
Proof.
unfold roundup; intros.
replace (a+(b-1)) with (a-1+1*b) by omega.
rewrite Z_div_plus_full by omega.
rewrite Z.mul_add_distr_r.
assert (H4 := Zmod_eq a b H).
assert (a mod b = 0 \/ a mod b <> 0) by omega.
destruct H0; [rewrite Z.mod_opp_l_z | rewrite Z.mod_opp_l_nz]; try omega.
rewrite H0 in H4.
assert (a = a/b*b) by omega.
rewrite H1 at 1.
replace (a/b*b-1) with (a/b*b+ -1) by omega.
rewrite Z_div_plus_full_l by omega.
rewrite Z.mul_add_distr_r.
rewrite <- H1.
assert (b=1 \/ b>1) by omega.
destruct H2.
subst b. simpl. omega.
rewrite (Z_div_nz_opp_full 1) by (rewrite Z.mod_small; omega).
rewrite  Z.div_small by omega.
omega.
rewrite H4.
assert ( (a-1)/b*b = a/b*b); [ | omega].
f_equal.
assert (a = a mod b + a/b*b) by omega.
replace (a-1) with (a mod b - 1 + a/b*b) by omega.
rewrite Z_div_plus_full by omega.
rewrite Z.div_small; try omega.
pose proof (Z_mod_lt a b H).
omega.
Qed.

Definition isbyteZ (i: Z) := (0 <= i < 256)%Z.

Definition Shr b x := Int.shru x (Int.repr b).

Lemma isbyteZ_testbit:
  forall i j, 0 <= i < 256 -> j >= 8 -> Z.testbit i j = false.
Proof.
intros; erewrite Byte.Ztestbit_above with (n:=8%nat); auto.
Qed.

Fixpoint intlist_to_Zlist (l: list int) : list Z :=
 match l with
 | nil => nil
 | i::r =>
     Int.unsigned (Shr 24 i) ::
     Int.unsigned (Int.and (Shr 16 i) (Int.repr 255)) ::
     Int.unsigned (Int.and (Shr 8 i) (Int.repr 255)) ::
     Int.unsigned (Int.and i (Int.repr 255)) ::
     intlist_to_Zlist r
 end.

(*combining four Z into a Integer*)
Definition Z_to_Int (a b c d : Z) : Int.int :=
  Int.or (Int.or (Int.or (Int.shl (Int.repr a) (Int.repr 24)) (Int.shl (Int.repr b) (Int.repr 16)))
            (Int.shl (Int.repr c) (Int.repr 8))) (Int.repr d).

Fixpoint Zlist_to_intlist (nl: list Z) : list int :=
  match nl with
  | h1::h2::h3::h4::t => Z_to_Int h1 h2 h3 h4 :: Zlist_to_intlist t
  | _ => nil
  end.

Lemma int_min_signed_eq: Int.min_signed = -2147483648.
Proof. reflexivity. Qed.

Lemma int_max_signed_eq: Int.max_signed = 2147483647.
Proof. reflexivity. Qed.

Lemma int_max_unsigned_eq: Int.max_unsigned = 4294967295.
Proof. reflexivity. Qed.

Ltac repable_signed :=
   pose proof int_min_signed_eq;
   pose proof int_max_signed_eq;
   pose proof int_max_unsigned_eq;
   omega.

Hint Rewrite Int.bits_or using omega : testbit.
Hint Rewrite Int.bits_shl using omega : testbit.
Hint Rewrite Int.bits_and using omega : testbit.
Hint Rewrite Int.bits_shru using omega : testbit.
Hint Rewrite Int.unsigned_repr using omega : testbit.
Hint Rewrite Int.testbit_repr using omega : testbit.
Hint Rewrite if_false using omega : testbit.
Hint Rewrite if_true using omega : testbit.
Hint Rewrite Z.ones_spec_low using omega : testbit.
Hint Rewrite Z.ones_spec_high using omega : testbit.
Hint Rewrite orb_false_r orb_true_r andb_false_r andb_true_r : testbit.
Hint Rewrite orb_false_l orb_true_l andb_false_l andb_true_l : testbit.
Hint Rewrite Z.add_simpl_r : testbit.
Hint Rewrite Int.unsigned_repr using repable_signed : testbit.

Lemma Ztest_Inttest:
 forall a, Z.testbit (Int.unsigned a) = Int.testbit a.
Proof. reflexivity. Qed.
Hint Rewrite Ztest_Inttest : testbit.

Definition swap (i: int) : int :=
 Int.or (Int.shl (Int.and i (Int.repr 255)) (Int.repr 24))
   (Int.or (Int.shl (Int.and (Shr 8 i) (Int.repr 255)) (Int.repr 16))
      (Int.or (Int.shl (Int.and (Shr 16 i) (Int.repr 255)) (Int.repr 8))
         (Shr 24 i))).

Lemma swap_swap: forall w, swap (swap w) = w.
Proof.
unfold swap, Shr; intros.
apply Int.same_bits_eq; intros.
assert (Int.zwordsize=32) by reflexivity.
change 255 with (Z.ones 8).
assert (32 < Int.max_unsigned) by (compute; auto).
autorewrite with testbit.
if_tac; [if_tac; [if_tac | ] | ]; autorewrite with testbit; f_equal; omega.
Qed.

Lemma map_swap_involutive:
 forall l, map swap (map swap l)  = l.
Proof. intros.
 rewrite map_map.
 replace (fun x => swap (swap x)) with (@Datatypes.id int).
 apply map_id. extensionality x. symmetry; apply swap_swap.
Qed.

Lemma length_intlist_to_Zlist:
  forall l, length (intlist_to_Zlist l) = (4 * length l)%nat.
Proof.
induction l.
simpl. reflexivity. simpl. omega.
Qed.

Lemma intlist_to_Zlist_Z_to_int_cons:
  forall a b c d l,
      isbyteZ a -> isbyteZ b -> isbyteZ c -> isbyteZ d ->
     intlist_to_Zlist (Z_to_Int a b c d :: l) =
     a::b::c::d:: intlist_to_Zlist l.
Proof.
intros. simpl.
unfold isbyteZ in *.
assert (Int.zwordsize=32)%Z by reflexivity.
unfold Z_to_Int, Shr; simpl.
change 255%Z with (Z.ones 8).
repeat f_equal; auto;
match goal with |- _ = ?A => transitivity (Int.unsigned (Int.repr A));
   [f_equal | apply Int.unsigned_repr; repable_signed]
end;
apply Int.same_bits_eq; intros;
autorewrite with testbit.
*
if_tac; autorewrite with testbit; [ | symmetry; apply isbyteZ_testbit; omega].
rewrite (isbyteZ_testbit b) by omega.
rewrite (isbyteZ_testbit c) by omega.
rewrite (isbyteZ_testbit d) by omega.
autorewrite with testbit; auto.
*
if_tac; autorewrite with testbit; [ | symmetry; apply isbyteZ_testbit; omega].
if_tac; autorewrite with testbit; [ | symmetry; apply isbyteZ_testbit; omega].
rewrite (isbyteZ_testbit c) by omega.
rewrite (isbyteZ_testbit d) by omega.
autorewrite with testbit; auto.
*
if_tac; autorewrite with testbit; [ | symmetry; apply isbyteZ_testbit; omega].
if_tac; autorewrite with testbit; [ | symmetry; apply isbyteZ_testbit; omega].
if_tac; autorewrite with testbit; [ | symmetry; apply isbyteZ_testbit; omega].
rewrite (isbyteZ_testbit d) by omega.
autorewrite with testbit; auto.
*
destruct (zlt i 8); autorewrite with testbit;  [ | symmetry; apply isbyteZ_testbit; omega].
auto.
Qed.

Lemma intlist_to_Zlist_to_intlist:
  forall il: list int,
   Zlist_to_intlist (intlist_to_Zlist il) = il.
Proof.
induction il.
reflexivity.
simpl.
f_equal; auto. clear.
assert (Int.zwordsize=32)%Z by reflexivity.
unfold Z_to_Int, Shr; simpl.
change 255%Z with (Z.ones 8).
apply Int.same_bits_eq; intros.
rewrite Int.repr_unsigned.
autorewrite with testbit.
if_tac; autorewrite with testbit; [ | f_equal; omega].
if_tac; autorewrite with testbit; [ | f_equal; omega].
if_tac; autorewrite with testbit; [ | f_equal; omega].
auto.
Qed.

Lemma intlist_to_Zlist_app:
 forall al bl, intlist_to_Zlist (al++bl) = intlist_to_Zlist al ++ intlist_to_Zlist bl.
Proof. intros; induction al; simpl; auto. repeat f_equal; auto. Qed.
Local Open Scope nat.

Local Open Scope Z.

Lemma isbyte_intlist_to_Zlist : forall l, Forall isbyteZ (intlist_to_Zlist l).
Proof.
induction l; simpl; intros.
constructor.
assert (forall i, Int.unsigned (Int.and i (Int.repr 255)) < 256).
clear; intro.
eapply Z.lt_le_trans.
apply (Int.and_interval i (Int.repr (Z.ones 8))).
change (Int.size  (Int.repr (Z.ones 8))) with 8.
rewrite Zmin_spec.
if_tac.
eapply Z.le_trans with (two_p 8).
apply two_p_monotone.
split; [ | omega].
apply Int.size_range.
compute; congruence.
compute; congruence.
unfold Shr, isbyteZ; repeat constructor; try apply Int.unsigned_range; auto; clear IHl.
rewrite <- (Int.divu_pow2 a (Int.repr (2 ^ 24)) (Int.repr 24) (eq_refl _)).
unfold Int.divu.
rewrite Int.unsigned_repr.
rewrite Int.unsigned_repr by (compute; split; congruence).
apply Z.div_lt_upper_bound.
compute; congruence.
change (2 ^ 24 * 256)%Z with (Int.modulus).
apply Int.unsigned_range.
assert (0 < 2 ^ 24)
 by (apply Z.pow_pos_nonneg; clear; omega).
rewrite Int.unsigned_repr by (compute; split; congruence).
split.
apply Z.div_pos; auto.
apply Int.unsigned_range.
apply Z.div_le_upper_bound; auto.
apply Z.le_trans with (Int.modulus+1).
destruct (Int.unsigned_range a).
omega.
compute; congruence.
Qed.

Lemma isbyte_intlist_to_Zlist' : forall l,
   Forall isbyteZ (map Int.unsigned (map Int.repr (intlist_to_Zlist l))).
Proof.
intro.
replace (map Int.unsigned (map Int.repr (intlist_to_Zlist l))) with (intlist_to_Zlist l).
apply isbyte_intlist_to_Zlist.
induction l; simpl; auto.
repeat f_equal; auto; symmetry; apply Int.repr_unsigned.
Qed.

Lemma Forall_isbyte_repr_unsigned:
 forall l: list int, map Int.repr (map Int.unsigned l) = l.
Proof.
induction l; intros.
reflexivity.
simpl.
f_equal; auto.
apply Int.repr_unsigned.
Qed.

Lemma map_unsigned_repr_isbyte:
  forall l : list Z , Forall isbyteZ l -> map Int.unsigned (map Int.repr l) = l.
Proof. induction l; simpl; intros; auto.
  inv H. f_equal; auto. unfold isbyteZ in H2; apply Int.unsigned_repr.
 assert (Int.max_unsigned > 256)%Z by (compute; congruence).
 omega.
Qed.

Lemma int_unsigned_inj: forall a b, Int.unsigned a = Int.unsigned b -> a=b.
Proof.
intros.
rewrite <- (Int.repr_unsigned a); rewrite <- (Int.repr_unsigned b).
congruence.
Qed.

Lemma intlist_to_Zlist_inj: forall al bl, intlist_to_Zlist al = intlist_to_Zlist bl -> al=bl.
Proof.
induction al; destruct bl; intros; auto.
inv H.
inv H.
simpl in H.
injection H; intros.
f_equal; auto.
clear - H1 H2 H3 H4.
rename i into b.
apply int_unsigned_inj in H1.
apply int_unsigned_inj in H2.
apply int_unsigned_inj in H3.
apply int_unsigned_inj in H4.
unfold Shr in *.
apply Int.same_bits_eq; intros.
assert (Int.zwordsize=32)%Z by reflexivity.
change 255%Z with (Z.ones 8) in *.
destruct (zlt i 8).
transitivity (Int.testbit (Int.and a (Int.repr (Z.ones 8))) i).
autorewrite with testbit; auto.
rewrite H1. autorewrite with testbit; auto.
destruct (zlt i 16).
transitivity (Int.testbit (Int.and (Int.shru a (Int.repr 8)) (Int.repr (Z.ones 8))) (i-8)).
autorewrite with testbit.
change (Int.unsigned (Int.repr 8)) with 8%Z.
rewrite Z.sub_add; auto.
rewrite H2.
autorewrite with testbit.
rewrite Z.sub_add. auto.
destruct (zlt i 24).
transitivity (Int.testbit (Int.and (Int.shru a (Int.repr 16)) (Int.repr (Z.ones 8))) (i-16)).
autorewrite with testbit.
change (Int.unsigned (Int.repr 16)) with 16%Z.
rewrite Z.sub_add. auto.
rewrite H3.
autorewrite with testbit.
change (Int.unsigned (Int.repr 16)) with 16%Z.
rewrite Z.sub_add. auto.
transitivity (Int.testbit (Int.shru a (Int.repr 24)) (i-24)).
autorewrite with testbit.
change (Int.unsigned (Int.repr 24)) with 24%Z.
rewrite Z.sub_add. auto.
rewrite H4.
autorewrite with testbit.
change (Int.unsigned (Int.repr 24)) with 24%Z.
rewrite Z.sub_add. auto.
Qed.

Lemma Zlength_intlist_to_Zlist_app:
 forall al bl,  Zlength (intlist_to_Zlist (al++bl)) =
    (Zlength (intlist_to_Zlist al) + Zlength (intlist_to_Zlist bl))%Z.
Proof.
induction al; simpl; intros; auto.
repeat rewrite Zlength_cons.
rewrite IHal.
omega.
Qed.

Local Open Scope Z.

Lemma Forall_isbyteZ_unsigned_repr:
 forall l, Forall isbyteZ l -> Forall isbyteZ (map Int.unsigned (map Int.repr l)).
Proof. induction 1. constructor.
constructor. rewrite Int.unsigned_repr; auto.
unfold isbyteZ in H; repable_signed.
apply IHForall.
Qed.

Lemma divide_length_app:
 forall {A} n (al bl: list A),
      (n | Zlength al) ->
      (n | Zlength bl) ->
      (n | Zlength (al++bl)).
Proof.
 intros. destruct H,H0. exists (x+x0)%Z.
 rewrite Zlength_app,H,H0;
 rewrite Z.mul_add_distr_r; omega.
Qed.

Lemma nth_list_repeat: forall A i n (x :A),
    nth i (list_repeat n x) x = x.
Proof.
 induction i; destruct n; simpl; auto.
Qed.

Lemma map_list_repeat:
  forall A B (f: A -> B) n x,
     map f (list_repeat n x) = list_repeat n (f x).
Proof. induction n; simpl; intros; f_equal; auto.
Qed.

Lemma isbyteZ_sublist data lo hi: Forall isbyteZ data -> Forall isbyteZ (sublist lo hi data).
Proof. intros. destruct (Forall_forall isbyteZ data) as [F _].
   apply Forall_forall. intros. apply (F H x). eapply sublist_In. apply H0.
Qed.

Lemma map_IntReprOfBytes_injective: forall l m, Forall isbyteZ  l ->
  Forall isbyteZ m -> map Int.repr l = map Int.repr m -> l=m.
Proof. induction l; intros.
+ destruct m; simpl in *; inv H1; trivial.
+ destruct m; simpl in *. inv H1.
  assert (Int.repr a = Int.repr z /\  map Int.repr l = map Int.repr m).
  { forget (Int.repr a) as q. forget (Int.repr z) as w. inv H1; split; trivial. }
  clear H1. destruct H2. inv H. inv H0.
  rewrite (IHl m); trivial. f_equal.
  clear IHl H2 H6 H7.
  unfold isbyteZ in *. simpl in *.
  rewrite <- (Int.unsigned_repr a), <- (Int.unsigned_repr z), H1; trivial;
  rewrite int_max_unsigned_eq; omega.
Qed.


(** * Standard finite sets . Vladimir Voevodsky . Apr. - Sep. 2011 .

This file contains main constructions related to the standard finite sets defined as the initial intervals of [ nat ] and their properties . *)

(** ** Preambule *)

(** Settings *)

Unset Automatic Introduction. (* This line has to be removed for the file to compile with Coq8.2 *)

(** Imports. *)

Add LoadPath "../hlevel1" .
Add LoadPath "../Generalities".

Require Export hnat .

(* To up-stream files *)

(** ** Standard finite sets [ stn ] . *)

Definition stn ( n : nat ) := total2 ( fun m : nat => natlth m n ) .
Definition stnpair ( n : nat ) := tpair ( fun m : nat => natlth m n ) .
Definition stntonat ( n : nat ) : stn n -> nat := @pr1 _ _ .
Coercion stntonat : stn >-> nat .

Notation " 'stnel' ( i , j ) " := ( stnpair _ _  ( ctlong natlth isdecrelnatlth j i ( idpath true ) ) ) ( at level 70 ) .

Lemma isinclstntonat ( n : nat ) : isincl ( stntonat n ) .
Proof. intro .  apply isinclpr1 .  intro x .  apply ( pr2 ( natlth x n ) ) .  Defined.

Lemma isdecinclstntonat ( n : nat ) : isdecincl ( stntonat n ) .
Proof. intro . apply isdecinclpr1 .  intro x . apply isdecpropif . apply ( pr2 _ ) .   apply isdecrelnatgth .  Defined .

Lemma neghfiberstntonat ( n m : nat ) ( is : natgeh m n ) : neg ( hfiber ( stntonat n ) m ) .
Proof. intros . intro h . destruct h as [ j e ] .  destruct j as [ j is' ] .  simpl in e .  rewrite e in is' .  apply ( natgehtonegnatlth _ _ is is' ) . Defined .

Lemma iscontrhfiberstntonat ( n m : nat ) ( is : natlth m n ) : iscontr ( hfiber ( stntonat n ) m ) .
Proof. intros .  apply ( iscontrhfiberofincl ( stntonat n ) ( isinclstntonat n ) ( stnpair n m is ) ) .  Defined .

Lemma isisolatedinstn { n : nat } ( x : stn n ) : isisolated _ x.
Proof. intros . apply ( isisolatedinclb ( stntonat n ) ( isinclstntonat n ) x ( isisolatedn x ) ) .  Defined.

Corollary isdeceqstn ( n : nat ) : isdeceq (stn n).
Proof. intro.  unfold isdeceq. intros x x' . apply (isisolatedinstn x x' ). Defined.

Definition weqisolatedstntostn ( n : nat ) : weq ( isolated ( stn n ) ) ( stn n ) .
Proof . intro . apply weqpr1 . intro x .   apply iscontraprop1 .  apply ( isapropisisolated ) . set ( int := isdeceqstn n x  ) . assumption .  Defined .

Corollary isasetstn ( n : nat ) : isaset ( stn n ) .
Proof. intro . apply ( isasetifdeceq _ ( isdeceqstn n ) ) . Defined .

Definition stnposet ( i : nat ) : Poset .
Proof. intro. unfold Poset . split with ( hSetpair ( stn i ) ( isasetstn i ) ) . unfold po. split with ( fun j1 j2 : stn i => natleh j1 j2 ) . split with ( fun j1 j2 j3 : stn i => istransnatleh j1 j2 j3 ) . exact ( fun j : stn i => isreflnatleh j ) . Defined.

Definition lastelement ( n : nat ) : stn ( S n ) .
Proof. intro .   split with n .  apply ( natgthsnn ( S n ) ) .  Defined .

Definition stnmtostnn ( m n : nat ) (isnatleh: natleh m n ) : stn m -> stn n := fun x : stn m => match x with tpair i is => stnpair _ i ( natlthlehtrans i m n is isnatleh ) end .

(** ** "Boundary" maps [ dni : stn n -> stn ( S n ) ] and their properties . *)

Definition dni ( n : nat ) ( i : stn ( S n ) ) : stn n -> stn ( S n ) .
Proof. intros n i x .  destruct ( natlthorgeh x i ) . apply ( stnpair ( S n ) x ( natgthtogths _ _ ( pr2 x ) ) ) .  apply ( stnpair ( S n ) ( S x ) ( pr2 x ) ) .  Defined.

Lemma dnicommsq ( n : nat ) ( i : stn ( S n ) ) : commsqstr ( di i ) ( stntonat ( S n ) ) ( stntonat n ) ( dni n i ) .
Proof. intros . intro x . unfold dni . unfold di . destruct ( natlthorgeh x i ) .  simpl .  apply idpath . simpl .  apply idpath . Defined .

Theorem dnihfsq ( n : nat ) ( i : stn ( S n ) ) : hfsqstr ( di i ) ( stntonat ( S n ) ) ( stntonat n ) ( dni n i ) .
Proof. intros . apply ( ishfsqweqhfibersgtof' ( di i ) ( stntonat ( S n ) ) ( stntonat n ) ( dni n i ) ( dnicommsq _ _  ) ) . intro x . destruct ( natlthorgeh x n ) as [ g | l ] .

assert ( is1 : iscontr ( hfiber ( stntonat n ) x ) ) . apply iscontrhfiberstntonat . assumption .
assert ( is2 : iscontr ( hfiber ( stntonat ( S n ) ) ( di i x )  ) ) .    apply iscontrhfiberstntonat . apply ( natlehlthtrans _ ( S x ) ( S n ) ( natlehdinsn i x ) g ) .
apply isweqcontrcontr . assumption . assumption .

assert ( is1 : neg ( hfiber ( stntonat ( S n ) ) ( di i x ) ) ) . apply neghfiberstntonat . unfold di .   destruct ( natlthorgeh x i ) as [ l'' | g' ] .  destruct ( natgehchoice2 _ _ l ) as [ g' | e ] .   apply g' .  rewrite e in l'' .  set ( int := natlthtolehsn _ _ l'' ) .  destruct ( int ( pr2 i ) ) .  apply l .  apply ( isweqtoempty2 _ is1 ) .
Defined .

Lemma weqhfiberdnihfiberdi ( n : nat ) ( i j : stn ( S n ) ) : weq ( hfiber ( dni n i ) j ) ( hfiber ( di i ) j ) .
Proof.  intros . apply ( weqhfibersg'tof _ _ _ _ ( dnihfsq n i ) j ) . Defined .

Lemma neghfiberdni ( n : nat ) ( i : stn ( S n ) ) : neg ( hfiber ( dni n i ) i ) .
Proof. intros . apply ( negf ( weqhfiberdnihfiberdi n i i ) ( neghfiberdi i ) ) . Defined .

Lemma iscontrhfiberdni ( n : nat ) ( i j : stn ( S n ) ) ( ne : neg ( paths i j ) ) : iscontr ( hfiber ( dni n i ) j ) .
Proof . intros . set ( ne' := negf ( invmaponpathsincl _ ( isinclstntonat ( S n ) ) _ _ ) ne ) .  apply ( iscontrweqb ( weqhfiberdnihfiberdi n i j ) ( iscontrhfiberdi i j ne' ) ) .  Defined .

Lemma isdecincldni ( n : nat ) ( i : stn ( S n ) ) : isdecincl ( dni n i ) .
Proof.  intros . intro j . destruct ( isdeceqstn _ i j ) . rewrite i0 .  apply ( isdecpropfromneg ( neghfiberdni n j ) ) . apply ( isdecpropfromiscontr ( iscontrhfiberdni _ _ _ e ) ) .  Defined .

Lemma isincldni ( n : nat ) ( i : stn ( S n ) ) : isincl ( dni n i ) .
Proof. intros . apply ( isdecincltoisincl _  ( isdecincldni n i ) ) .  Defined .

(** ** Weak equivalences between standard finite sets and constructions on these sets *)

(** *** The weak equivalence from [ stn n ] to the compl of a point [ j ] in [ stn ( S n ) ] defined by [ dni n j ] *)

Definition dnitocompl ( n : nat ) ( i : stn ( S n ) ) ( j : stn n ) : compl ( stn ( S n ) ) i .
Proof. intros . split with ( dni n i j ) .  intro e .  apply ( neghfiberdni n i ( hfiberpair _ j ( pathsinv0 e ) ) ) .  Defined .

Lemma isweqdnitocompl  ( n : nat ) ( i : stn ( S n ) ) : isweq ( dnitocompl n i ) .
Proof. intros . intro jni . destruct jni as [ j ni ] . set ( jni := complpair _ i j ni ) .  destruct ( isdeceqnat i j )  .  destruct ( ni ( invmaponpathsincl _ ( isinclstntonat _ ) _ _ i0 ) ) .  set ( w := samehfibers ( dnitocompl n i )  _ ( isinclpr1compl _ i ) jni ) .   simpl in w . assert ( is : iscontr (hfiber (fun x : stn n => dni n i x) j) ) . apply iscontrhfiberdni .  assumption . apply ( iscontrweqb w is ) .  Defined .

Definition weqdnicompl ( n : nat ) ( i : stn ( S n ) ) := weqpair _ ( isweqdnitocompl n i ) .

(** *** Weak equivalence from [ coprod ( stn n ) unit ] to [ stn ( S n ) ] defined by [ dni n i ] *)

Definition weqdnicoprod  ( n : nat ) ( j : stn ( S n ) ) : weq ( coprod ( stn n ) unit ) ( stn ( S n ) ) .
Proof . intros . apply ( weqcomp ( weqcoprodf ( weqdnicompl n j ) ( idweq unit ) ) ( weqrecompl ( stn ( S n ) ) j ( isdeceqstn ( S n ) j ) ) ) .  Defined .

(** *** Weak equivalences from [ stn n ] for [ n = 0 , 1 , 2 ] to [ empty ] , [ unit ] and [ bool ] ( see also the section on [ nelstruct ] in finitesets.v ) . *)

Definition negstn0 : neg ( stn 0 ) .
Proof . intro x .  destruct x as [ a b ] .  apply ( negnatlthn0 _ b ) . Defined .

Definition weqstn0toempty : weq ( stn 0 ) empty .
Proof .  apply weqtoempty . apply negstn0 . Defined .

Definition weqstn1tounit : weq ( stn 1 ) unit .
Proof. set ( f := fun x : stn 1 => tt ) . apply weqcontrcontr .  split with ( lastelement 0 ) .   intro t .  destruct t as [ t l ] . set ( e := natlth1tois0 _ l ) .   apply ( invmaponpathsincl _ ( isinclstntonat 1 ) ( stnpair _ t l ) ( lastelement 0 ) e ) .  apply iscontrunit .  Defined .

Corollary iscontrstn1 : iscontr ( stn 1 ) .
Proof. apply iscontrifweqtounit . apply weqstn1tounit . Defined .

Lemma isinclfromstn1 { X : UU } ( f : stn 1 -> X ) ( is : isaset X ) : isincl f .
Proof. intros . apply ( isinclbetweensets f ( isasetstn 1 ) is ) . intros x x' e . apply ( invmaponpathsweq weqstn1tounit x x' ( idpath tt ) )  .  Defined .

Definition weqstn2tobool : weq ( stn 2 ) bool .
Proof. set ( f := fun j : stn 2 => match ( isdeceqnat j 0 ) with ii1 _ => false | ii2 _ => true end ) . set ( g := fun b : bool => match b with false => stnpair 2 0 ( idpath true ) | true => stnpair 2 1 ( idpath true ) end ) .  split with f .
assert ( egf : forall j : _ , paths ( g ( f j ) ) j ) . intro j . unfold f .  destruct ( isdeceqnat j 0 ) as [ e | ne ] .  apply ( invmaponpathsincl _ ( isinclstntonat 2 ) ) . rewrite e .   apply idpath .  apply ( invmaponpathsincl _ ( isinclstntonat 2 ) ) . destruct j as [ j l ] . simpl . set ( l' := natlthtolehsn _ _ l ) .  destruct ( natlehchoice _ _ l' ) as [ l'' | e ] . simpl in ne . destruct  ( ne ( natlth1tois0 _ l'' ) ) .  apply ( pathsinv0 ( invmaponpathsS _ _ e ) ) .
assert ( efg : forall b : _ , paths ( f ( g b ) ) b ) . intro b .  unfold g .  destruct b . apply idpath . apply idpath.
apply ( gradth _ _ egf efg ) . Defined .

(** ***  Weak equivalence between the coproduct of [ stn n ] and [ stn m ] and [ stn ( n + m ) ] *)

Theorem weqfromcoprodofstn ( n m : nat ) : weq ( coprod ( stn n ) ( stn m ) ) ( stn ( n + m ) ) .
Proof. intros .

assert ( i1 : forall i : nat , natlth i n -> natlth i ( n + m ) ) . intros i1 l . apply ( natlthlehtrans _ _ _ l ( natlehnplusnm n m ) ) .
assert ( i2 : forall i : nat , natlth i m -> natlth ( i + n ) ( n + m ) ) .  intros i2 l .  rewrite ( natpluscomm i2  n ) .  apply natgthandplusl . assumption .
set ( f := fun ab : coprod ( stn n ) ( stn m ) => match ab with ii1 a =>  stnpair ( n + m ) a ( i1 a ( pr2 a ) ) | ii2 b => stnpair ( n + m ) ( b + n ) ( i2 b ( pr2 b ) ) end ) .
split with f .

assert ( is : isincl f ) .  apply  isinclbetweensets . apply ( isofhlevelssncoprod 0 _ _ ( isasetstn n ) ( isasetstn m ) ) .  apply ( isasetstn ( n + m ) ) .  intros x x' . intro e .   destruct x as [ xn | xm ] .

destruct x' as [ xn' | xm' ] . apply ( maponpaths (@ii1 _ _ ) ) .  apply ( invmaponpathsincl _ ( isinclstntonat n ) _ _ ) .  destruct xn as [ x ex ] . destruct xn' as [ x' ex' ] . simpl in e .  simpl .  apply ( maponpaths ( stntonat ( n + m ) ) e  )  .   destruct xn as [ x ex ] . destruct xm' as [ x' ex' ] . simpl in e . assert ( l : natleh n x ) . set ( e' := maponpaths ( stntonat _ ) e ) .   simpl in e' . rewrite e' .  apply ( natlehmplusnm x' n  ) . destruct ( natlehtonegnatgth _ _ l ex ) .

destruct x' as [ xn' | xm' ] . destruct xm as [ x ex ] . destruct xn' as [ x' ex' ] . simpl in e .  assert ( e' := maponpaths ( stntonat _ ) e ) .  simpl in e' .  assert ( a : empty ) . clear e . rewrite ( pathsinv0 e' ) in ex' .  apply ( negnatgthmplusnm _ _ ex' )  .   destruct a . destruct xm as [ x ex ] . destruct xm' as [ x' ex' ] .  simpl in e .  apply ( maponpaths ( @ii2 _ _ ) ) .   simpl .  apply ( invmaponpathsincl _ ( isinclstntonat m ) _ _ ) .  simpl .  apply ( invmaponpathsincl _ ( isinclnatplusr n ) _ _ ( maponpaths ( stntonat _ ) e ) ) .

intro jl . apply iscontraprop1 .  apply ( is jl ) .   destruct jl as [ j l ] . destruct ( natgthorleh n j ) as [ i | ni ] .

split with ( ii1 ( stnpair _ j i ) ) . simpl .   apply ( invmaponpathsincl _ ( isinclstntonat ( n + m ) )  (stnpair (n + m) j (i1 j i)) ( stnpair _ j l )  ( idpath j ) ) .

set ( jmn := pr1 ( iscontrhfibernatplusr n j ni ) ) .   destruct jmn as [ k e ] . assert ( is'' : natlth k m ) . rewrite ( pathsinv0 e ) in l .  rewrite ( natpluscomm k n ) in l .  apply ( natgthandpluslinv _ _ _ l ) . split with ( ii2 ( stnpair _ k is'' ) ) .  simpl .  apply ( invmaponpathsincl _ ( isinclstntonat _ ) (stnpair _ (k + n) (i2 k is'')) ( stnpair _ j l ) e ) . Defined .

(** *** Weak equivalence from the total space of a family [ stn ( f x ) ]  over [ stn n ] to [ stn ( stnsum n f ) ] *)

Definition stnsum { n : nat } ( f : stn n -> nat ) : nat .
Proof. intro n . induction n as [ | n IHn ] . intro. apply 0 . intro f . apply (  ( IHn ( fun i : stn n => f ( dni n ( lastelement n ) i ) ) ) + f ( lastelement n ) ) . Defined .

Theorem weqstnsum { n : nat } ( P : stn n -> UU ) ( f : stn n -> nat ) ( ww : forall i : stn n , weq ( stn ( f i ) )  ( P i ) ) : weq ( total2 P ) ( stn ( stnsum f ) ) .
Proof . intro n . induction n as [ | n IHn ] . intros . simpl .  apply weqtoempty2 .  apply ( @pr1 _ _ ) .  apply negstn0 . intros .  simpl .  set ( a := stnsum (fun i : stn n => f (dni n (lastelement n) i)) ) . set ( b :=  f (lastelement n) ) . set ( w1 := invweq ( weqfp ( weqdnicoprod n ( lastelement n ) ) P ) ) . set ( w2 := weqcomp w1 ( weqtotal2overcoprod (fun x : coprod (stn n) unit => P ( weqdnicoprod n ( lastelement n )  x)) ) ) .  simpl in w2 . assert ( w3 : weq (total2 (fun x : stn n => P (dni n (lastelement n) x))) ( stn a ) ) .  assert ( int : forall x : stn n , weq  ( stn ( f ( dni n (lastelement n) x) ) ) ( P (dni n (lastelement n) x) ) ) .  intro x . apply ( ww ( dni n (lastelement n) x) ) .  apply ( IHn ( fun x : stn n => P (dni n (lastelement n) x)) ( fun x : stn n => f ( dni n (lastelement n) x ) ) int ) .  assert ( w4 : weq (total2 (fun _ : unit => P (lastelement n))) ( stn b) ) . apply ( weqcomp ( weqtotal2overunit (fun _ : unit => P (lastelement n)) ) ( invweq ( ww ( lastelement n ) ) ) ) .   apply ( weqcomp w2 ( weqcomp ( weqcoprodf w3 w4 ) ( weqfromcoprodofstn a b ) ) ) .  Defined .

Corollary weqstnsum2 { X : UU } ( n : nat ) ( f : stn n -> nat ) ( g : X -> stn n ) ( ww : forall i : stn n , weq ( stn ( f i ) ) ( hfiber g i ) ) : weq X ( stn ( stnsum f ) ) .
Proof. intros . assert ( w : weq X ( total2 ( fun i : stn n => hfiber g i ) ) ) . apply weqtococonusf . apply ( weqcomp w ( weqstnsum ( fun i : stn n => hfiber g i ) f ww ) ) .   Defined .

(** *** Weak equivalence between the direct product of [ stn n ] and [ stn m ] and [ stn n * m ] *)

Theorem weqfromprodofstn ( n m : nat ) : weq ( dirprod ( stn n ) ( stn m ) ) ( stn ( n * m ) ) .
Proof .  intros . destruct ( natgthorleh m 0 ) as [ is | i ] .

assert ( i1 : forall i j : nat , natlth i n -> natlth j m ->  natlth ( j + i * m ) ( n * m ) ).  intros i j li lj . apply ( natlthlehtrans ( j + i * m ) ( ( S i ) * m ) ( n * m ) ( natgthandplusr m j ( i * m ) lj ) ( natlehandmultr ( S i ) n m ( natgthtogehsn _ _ li ) ) ) .

set ( f := fun ij : dirprod ( stn n ) ( stn m ) => match ij with tpair i j => stnpair ( n * m ) ( j + i * m ) ( i1 i j ( pr2 i ) ( pr2 j ) ) end ) .  split with f .

assert ( isinf : isincl f ) . apply isinclbetweensets . apply ( isofhleveldirprod 2 _ _ ( isasetstn n ) ( isasetstn m ) ) .  apply ( isasetstn ( n * m ) ) . intros ij ij' e .  destruct ij as [ i j ] . destruct ij' as [ i' j' ] .  destruct i as [ i li ] . destruct i' as [ i' li' ] .  destruct j as [ j lj ] . destruct j' as [ j' lj' ] . simpl in e . assert ( e' := maponpaths ( stntonat ( n * m ) ) e )  .   simpl in e' .
assert ( eei : paths i i' ) . apply ( pr1 ( natdivremunique m i j i' j' lj lj' ( maponpaths ( stntonat _ ) e ) ) ) .
set ( eeis := invmaponpathsincl _ ( isinclstntonat _ ) ( stnpair _ i li ) ( stnpair _ i' li' ) eei ) .
assert ( eej : paths j j' ) . apply ( pr2 ( natdivremunique m i j i' j' lj lj' ( maponpaths ( stntonat _ ) e ) ) ) .
set ( eejs := invmaponpathsincl _ ( isinclstntonat _ ) ( stnpair _ j lj ) ( stnpair _ j' lj' ) eej ) . apply ( pathsdirprod eeis eejs ) .

intro xnm .  apply iscontraprop1 . apply ( isinf xnm ) . set ( e := pathsinv0 ( natdivremrule xnm m ( natgthtoneq _ _ is ) ) ) .  set ( i := natdiv xnm m ) .   set ( j := natrem xnm m ) . destruct xnm as [ xnm lxnm ] .   set ( li := natlthandmultrinv _ _ _ ( natlehlthtrans _ _ _ ( natlehmultnatdiv xnm m ( natgthtoneq _ _ is ) ) lxnm ) ) .  set ( lj := lthnatrem xnm m ( natgthtoneq _ _ is ) ) .  split with ( dirprodpair ( stnpair n i li ) ( stnpair m j lj ) ) .  simpl . apply ( invmaponpathsincl _ ( isinclstntonat _ ) _ _ ) .  simpl . apply e .

set ( e := natleh0tois0 _ i ) .  rewrite e .  rewrite ( natmultn0 n ) . split with ( @pr2 _ _ ) .   apply ( isweqtoempty2 _ ( weqstn0toempty ) ) . Defined .

(** *** Weak equivalences between decidable subsets of [ stn n ] and [ stn x ] *)

Theorem weqfromdecsubsetofstn { n : nat } ( f : stn n -> bool ) : total2 ( fun x : nat => weq ( hfiber f true ) ( stn x ) ) .
Proof . intro . induction n as [ | n IHn ] . intros .    split with 0 .  assert ( g : ( hfiber f true ) -> ( stn 0 ) ) . intro hf . destruct hf as [ i e ] .  destruct ( weqstn0toempty i ) .  apply ( weqtoempty2 g weqstn0toempty ) . intro . set ( g := weqfromcoprodofstn 1 n ) .   change ( 1 + n ) with ( S n ) in g .

set ( fl := fun i : stn 1 => f ( g ( ii1 i ) ) ) .   set ( fh := fun i : stn n => f ( g ( ii2 i ) ) ) . assert ( w : weq ( hfiber f true ) ( hfiber ( sumofmaps fl fh ) true ) ) .  set ( int := invweq ( weqhfibersgwtog g f true  ) ) .  assert ( h : forall x : _ , paths ( f ( g x ) ) ( sumofmaps fl fh x ) ) . intro . destruct x as [ x1 | xn ] . apply idpath . apply idpath .   apply ( weqcomp int ( weqhfibershomot _ _ h true ) ) .  set ( w' := weqcomp w ( invweq ( weqhfibersofsumofmaps fl fh true ) ) ) .

set ( x0 := pr1 ( IHn fh ) ) . set ( w0 := pr2 ( IHn fh ) ) . simpl in w0 . destruct ( boolchoice ( fl ( lastelement 0 ) ) ) as [ i | ni ] .

split with ( S x0 ) .  assert ( wi : weq ( hfiber fl true ) ( stn 1 ) ) . assert ( is : iscontr ( hfiber fl true ) ) . apply iscontraprop1 . apply ( isinclfromstn1 fl isasetbool true ) .  apply ( hfiberpair _ ( lastelement 0 ) i ) . apply ( weqcontrcontr is iscontrstn1 ) .  apply ( weqcomp ( weqcomp w' ( weqcoprodf wi w0 ) ) ( weqfromcoprodofstn 1 _ ) ) .

split with x0 .  assert ( g' : neg ( hfiber fl true ) ) . intro hf . destruct hf as [ j e ] .  assert ( ee : paths j ( lastelement 0 ) ) . apply ( proofirrelevance _ ( isapropifcontr iscontrstn1 ) _ _ ) .  destruct ( nopathstruetofalse ( pathscomp0 ( pathscomp0 ( pathsinv0 e ) ( maponpaths fl ee ) ) ni ) ) .  apply ( weqcomp w' ( weqcomp ( invweq ( weqii2withneg _ g' ) ) w0 )  )  .  Defined .

(** *** Weak equivalences between hfibers of functions from [ stn n ] over isolated points and [ stn x ] *)

Theorem weqfromhfiberfromstn { n : nat } { X : UU } ( x : X ) ( is : isisolated X x ) ( f : stn n -> X ) : total2 ( fun x0 : nat => weq ( hfiber f x ) ( stn x0 ) ) .
Proof . intros .  set ( t := weqfromdecsubsetofstn ( fun i : _ => eqbx X x is ( f i ) ) ) . split with ( pr1 t ) . apply ( weqcomp ( weqhfibertobhfiber f x is ) ( pr2 t ) ) .   Defined .

(** *** Weak equivalence between [ stn n -> stn m ] and [ stn ( natpower m n ) ] ( uses functional extensionality ) *)

Theorem weqfromfunstntostn ( n m : nat ) : weq ( stn n -> stn m ) ( stn ( natpower m n ) ) .
Proof. intro n . induction n as [ | n IHn ] . intro m .  apply weqcontrcontr . apply ( iscontrfunfromempty2 _ weqstn0toempty ) .  apply iscontrstn1 .
intro m . set ( w1 := weqfromcoprodofstn 1 n ) . assert ( w2 : weq ( stn ( S n ) -> stn m ) ( (coprod (stn 1) (stn n)) -> stn m ) ) .   apply ( weqbfun _ w1  ) .  set ( w3 := weqcomp w2 ( weqfunfromcoprodtoprod ( stn 1 ) ( stn n ) ( stn m ) ) ) .   set ( w4 := weqcomp w3 ( weqdirprodf ( weqfunfromcontr ( stn m ) iscontrstn1 ) ( IHn m ) ) ) .  apply ( weqcomp w4 ( weqfromprodofstn m ( natpower m n ) ) ) .  Defined .

(** *** Weak equivalence from the space of functions of a family [ stn ( f x ) ]  over [ stn n ] to [ stn ( stnprod n f ) ] ( uses functional extensionality ) *)

Definition stnprod { n : nat } ( f : stn n -> nat ) : nat .
Proof. intro n . induction n as [ | n IHn ] . intro. apply 1 . intro f . apply (  ( IHn ( fun i : stn n => f ( dni n ( lastelement n ) i ) ) ) * f ( lastelement n ) ) . Defined .

Theorem weqstnprod { n : nat } ( P : stn n -> UU ) ( f : stn n -> nat ) ( ww : forall i : stn n , weq ( stn ( f i ) )  ( P i ) ) : weq ( forall x : stn n , P x  ) ( stn ( stnprod f ) ) .
Proof . intro n . induction n as [ | n IHn ] . intros . simpl . apply ( weqcontrcontr ) .  apply ( iscontrsecoverempty2 _ ( negstn0 ) ) .   apply iscontrstn1 . intros .  set ( w1 := weqdnicoprod n ( lastelement n ) ) . set ( w2 := weqonsecbase P w1 ) .   set ( w3 := weqsecovercoprodtoprod ( fun x : _ => P ( w1 x ) ) ) .  set ( w4 := weqcomp w2 w3 ) .  set ( w5 := IHn ( fun x : stn n => P ( w1 ( ii1 x ) ) ) ( fun x : stn n => f ( w1 ( ii1 x ) ) ) ( fun i : stn n => ww ( w1 ( ii1 i ) ) ) ) . set ( w6 := weqcomp w4 ( weqdirprodf w5 ( weqsecoverunit _ ) ) ) .  simpl in w6 .  set ( w7 := weqcomp w6 ( weqdirprodf ( idweq _ ) ( invweq ( ww ( lastelement n ) ) ) ) ) .  apply ( weqcomp w7 ( weqfromprodofstn _ _ ) ) .   Defined .

(** *** Weak equivalence between [ weq ( stn n ) ( stn n ) ] and [ stn ( factorial n ) ] ( uses functional extensionality ) *)

Theorem  weqweqstnsn ( n : nat ) : weq ( weq ( stn ( S n ) ) ( stn ( S n ) ) ) ( dirprod ( stn ( S n ) ) ( weq ( stn n ) ( stn n ) ) ) .
Proof . intro . set ( nn := lastelement n ) . set ( is := isdeceqstn _ nn ) . set ( w1 := weqcutonweq ( stn ( S n ) ) nn is ) . set ( w2 := weqisolatedstntostn ( S n ) ) .  set ( w3 := invweq ( weqdnicompl n nn ) ) .  apply ( weqcomp w1 ( weqdirprodf w2 ( weqcomp ( weqbweq _ ( invweq w3 )) ( weqfweq _ w3 ) ) ) ) .  Defined .

Theorem weqfromweqstntostn ( n : nat ) : weq ( weq ( stn n ) ( stn n ) ) ( stn ( factorial n ) ) .
Proof . intro . induction n as [ | n IHn ] . simpl . apply ( weqcontrcontr ) . apply ( iscontraprop1 ) .    apply ( isapropweqtoempty2 _ ( negstn0 ) ) .  apply idweq . apply iscontrstn1 . change ( factorial ( S n ) ) with ( ( S n ) * ( factorial n ) ) .   set ( w1 := weqweqstnsn n ) . apply ( weqcomp w1 ( weqcomp ( weqdirprodf ( idweq _ ) IHn ) ( weqfromprodofstn _ _ ) ) ) .  Defined .

(* End of " weak equivalences between standard finite sets and constructions on these sets " . *)

(** ** Standard finite sets satisfy weak axiom of choice *)

Theorem ischoicebasestn ( n : nat ) : ischoicebase ( stn n ) .
Proof . intro . induction n as [ | n IHn ] .  apply ( ischoicebaseempty2 negstn0 ) .  apply ( ischoicebaseweqf ( weqdnicoprod n ( lastelement n ) ) ( ischoicebasecoprod IHn ischoicebaseunit ) ) .  Defined .

(** ** Weak equivalence class of [ stn n ] determines [ n ] . *)

Lemma negweqstnsn0 (n:nat): neg (weq (stn (S n)) (stn O)).
Proof. unfold neg. intro. assert (lp: stn (S n)). apply lastelement.  intro X.  apply weqstn0toempty .  apply (pr1 X lp). Defined.

Lemma negweqstn0sn (n:nat): neg (weq (stn O) (stn (S n))).
Proof.  unfold neg. intro. assert (lp: stn (S n)). apply lastelement.  intro X.  apply weqstn0toempty .  apply (pr1 ( invweq X ) lp). Defined.

Lemma weqcutforstn ( n n' : nat ) ( w : weq (stn (S n)) (stn (S n')) ) : weq (stn n) (stn n').
Proof. intros. set ( nn := lastelement n  ) . set ( w1 := weqoncompl w nn ) .  set ( w2 := weqdnicompl n nn ) . set ( w3 := weqdnicompl n' ( w nn ) ) .   apply ( weqcomp w2 ( weqcomp w1 ( invweq w3 ) ) ) . Defined .

Theorem weqtoeqstn ( n n' : nat ) ( w : weq (stn n) (stn n') ) : paths n n'.
Proof. intro. induction n as [ | n IHn ] . intro. destruct n' as [ | n' ] .  intros. apply idpath. intro X. apply (fromempty (negweqstn0sn  n' X)).
 intro n'. destruct n' as [ | n' ] . intro X. set (int:= isdeceqnat (S n) 0 ).  destruct int as [ i | e ] .  assumption. apply (fromempty ( negweqstnsn0 n X)).  intro X.
set (e:= IHn n' ( weqcutforstn _ _ X)). apply (maponpaths S e). Defined.

Corollary stnsdnegweqtoeq ( n n' : nat ) ( dw : dneg (weq (stn n) (stn n')) ) : paths n n'.
Proof. intros n n' X. apply (eqfromdnegeq nat isdeceqnat _ _  (dnegf (@weqtoeqstn n n') X)). Defined.

(** ** Some results on bounded quantification *)

Lemma weqforallnatlehn0 ( F : nat -> hProp ) : weq ( forall n : nat , natleh n 0 -> F n ) ( F 0 ) .
Proof . intros .  assert ( lg : ( forall n : nat , natleh n 0 -> F n ) <-> ( F 0 ) ) . split . intro f .  apply ( f 0 ( isreflnatleh 0 ) ) .  intros f0 n l .  set ( e := natleh0tois0 _ l ) .  rewrite e .  apply f0 . assert ( is1 : isaprop ( forall n : nat , natleh n 0 -> F n ) ) . apply impred . intro n . apply impred .   intro l .  apply ( pr2 ( F n ) ) .  apply ( weqimplimpl ( pr1 lg ) ( pr2 lg ) is1 ( pr2 ( F 0 ) ) ) . Defined .

Lemma weqforallnatlehnsn' ( n' : nat ) ( F : nat -> hProp ) : weq ( forall n : nat , natleh n ( S n' ) -> F n ) ( dirprod ( forall n : nat , natleh n n' -> F n ) ( F ( S n' ) ) ) .
Proof . intros . assert ( lg : ( forall n : nat , natleh n ( S n' ) -> F n ) <-> dirprod ( forall n : nat , natleh n n' -> F n ) ( F ( S n' ) ) ) .  split . intro f.  apply ( dirprodpair ( fun n => fun l => ( f n ( natlehtolehs _ _ l ) ) ) ( f ( S n' ) ( isreflnatleh _ ) ) ) .  intro d2 . intro n .  intro l .  destruct ( natlehchoice2 _ _ l ) as [ h | e ] . simpl in h .  apply ( pr1 d2 n h ) . destruct d2 as [ f2 d2 ] .  rewrite e .  apply d2 . assert ( is1 : isaprop ( forall n : nat , natleh n ( S n' ) -> F n ) ) . apply impred . intro n . apply impred . intro l . apply ( pr2 ( F n ) ) . assert ( is2 : isaprop ( dirprod ( forall n : nat , natleh n n' -> F n ) ( F ( S n' ) ) ) ) . apply isapropdirprod . apply impred . intro n . apply impred . intro l . apply ( pr2 ( F n ) ) .   apply ( pr2 ( F ( S n' ) ) ) .  apply ( weqimplimpl ( pr1 lg ) ( pr2 lg ) is1 is2 ) . Defined .

Lemma weqexistsnatlehn0 ( P : nat -> hProp  ) : weq ( hexists ( fun n : nat => dirprod ( natleh n 0 ) ( P n ) ) ) ( P 0 ) .
Proof . intro . assert ( lg : hexists ( fun n : nat => dirprod ( natleh n 0 ) ( P n ) ) <-> P 0  ) . split .  simpl . apply ( @hinhuniv _ ( P 0 ) ) .  intro t2 .  destruct t2 as [ n d2 ] . destruct d2 as [ l p ] . set ( e := natleh0tois0 _ l ) . clearbody e .  destruct e . apply p . intro p . apply hinhpr . split with 0 .  split with ( isreflnatleh 0 ) .  apply p . apply ( weqimplimpl ( pr1 lg ) ( pr2 lg ) ( pr2 _ ) ( pr2 _ ) ) .  Defined .

Lemma weqexistsnatlehnsn' ( n' : nat ) ( P : nat -> hProp  ) : weq ( hexists ( fun n : nat => dirprod ( natleh n ( S n' ) ) ( P n ) ) ) ( hdisj ( hexists ( fun n : nat => dirprod ( natleh n n' ) ( P n ) ) )  ( P ( S n' ) ) ) .
Proof . intros . assert ( lg : hexists ( fun n : nat => dirprod ( natleh n ( S n' ) ) ( P n ) )  <-> hdisj ( hexists ( fun n : nat => dirprod ( natleh n n' ) ( P n ) ) )  ( P ( S n' ) )  ) . split .  simpl . apply hinhfun .   intro t2 .  destruct t2 as [ n d2 ] . destruct d2 as [ l p ] . destruct ( natlehchoice2 _ _ l ) as [ h | nh ] . simpl in h . apply ii1 .  apply hinhpr . split with n .  apply ( dirprodpair h p ) . destruct nh .  apply ( ii2 p ) . simpl . apply ( @hinhuniv _ ( ishinh _ ) ) . intro c .  destruct c as [ t | p ] .  generalize t . simpl . apply hinhfun .  clear t . intro t . destruct t as [ n d2 ] . destruct d2 as [ l p ] . split with n .  split with ( natlehtolehs _ _ l ) .  apply p .  apply hinhpr . split with ( S n' ) .  split with ( isreflnatleh _ ) . apply p .  apply ( weqimplimpl ( pr1 lg ) ( pr2 lg ) ( pr2 _ ) ( pr2 _ ) ) .  Defined .

Lemma isdecbexists ( n : nat ) ( P : nat -> UU ) ( is : forall n' , isdecprop ( P n' ) ) : isdecprop ( hexists ( fun n' => dirprod ( natleh n' n ) ( P n' ) ) ) .
Proof . intros .  set ( P' := fun n' : nat => hProppair _ ( is n' ) ) . induction n as [ | n IHn ] . apply ( isdecpropweqb ( weqexistsnatlehn0 P' ) ) . apply ( is 0 ) .   apply ( isdecpropweqb ( weqexistsnatlehnsn' _ P' ) ) . apply isdecprophdisj . apply IHn . apply ( is ( S n ) ) . Defined .

Lemma isdecbforall ( n : nat ) ( P : nat -> UU ) ( is : forall n' , isdecprop ( P n' ) ) : isdecprop ( forall n' , natleh n' n -> P n' )  .
Proof . intros .  set ( P' := fun n' : nat => hProppair _ ( is n' ) ) . induction n as [ | n IHn ] . apply ( isdecpropweqb ( weqforallnatlehn0 P' ) ) . apply ( is 0 ) .   apply ( isdecpropweqb ( weqforallnatlehnsn' _ P' ) ) . apply isdecpropdirprod . apply IHn . apply ( is ( S n ) ) . Defined .

(** The following lemma finds the largest [ n' ] such that [ neg ( P n' ) ] . It is a stronger form of ( neg forall ) -> ( exists neg ) in the case of bounded quantification of decidable propositions. *)

Lemma negbforalldectototal2neg ( n : nat ) ( P : nat -> UU ) ( is : forall n' : nat , isdecprop ( P n' ) ) : neg ( forall n' : nat , natleh n' n -> P n' ) -> total2 ( fun n' => dirprod ( natleh n' n ) ( neg ( P n' ) ) ) .
Proof . intros n P is . set ( P' := fun n' : nat => hProppair _ ( is n' ) ) . induction n as [ | n IHn ] . intro nf . set ( nf0 := negf ( invweq ( weqforallnatlehn0 P' ) ) nf ) . split with 0 . apply ( dirprodpair ( isreflnatleh 0 ) nf0 ) .   intro nf . set ( nf2 := negf ( invweq ( weqforallnatlehnsn' n P' ) ) nf ) . set ( nf3 := fromneganddecy ( is ( S n ) ) nf2 ) . destruct nf3 as [ f1 | f2 ] . set ( int := IHn f1 ) .  destruct int as [ n' d2 ] . destruct d2 as [ l np ] . split with n' .  split with ( natlehtolehs _ _ l ) .  apply np . split with ( S n ) . split with ( isreflnatleh _ ) . apply f2 .  Defined .

(** ** Accesibility - the least element of an inhabited decidable subset of [nat] *)

Definition natdecleast ( F : nat -> UU ) ( is : forall n , isdecprop ( F n ) ) := total2 ( fun  n : nat => dirprod ( F n ) ( forall n' : nat , F n' -> natleh n n' ) ) .

Lemma isapropnatdecleast ( F : nat -> UU ) ( is : forall n , isdecprop ( F n ) ) : isaprop ( natdecleast F is ) .
Proof . intros . set ( P := fun n' : nat => hProppair _ ( is n' ) ) . assert ( int1 : forall n : nat, isaprop ( dirprod ( F n ) ( forall n' : nat , F n' -> natleh n n' ) ) ) .  intro n . apply isapropdirprod . apply ( pr2 ( P n ) ) .  apply impred . intro t .  apply impred .  intro .  apply ( pr2 ( natleh n t ) ) . set ( int2 := ( fun n : nat => hProppair _ ( int1 n ) ) : nat -> hProp ) .   change ( isaprop ( total2 int2 ) ) . apply isapropsubtype . intros x1 x2 .  intros c1 c2 . simpl in * . destruct c1 as [ e1 c1 ] . destruct c2 as [ e2 c2 ] . set ( l1 := c1 x2 e2 ) .  set ( l2 := c2 x1 e1 ) . apply ( isantisymmnatleh _ _ l1 l2 ) .  Defined .

Theorem accth ( F : nat -> UU ) ( is : forall n , isdecprop ( F n ) )  ( is' : hexists F ) : natdecleast F is .
Proof . intros F is . simpl . apply (@hinhuniv _ ( hProppair _ ( isapropnatdecleast F is ) ) ) . intro t2. destruct t2 as [ n l ] . simpl .

set ( F' := fun n' : nat => hexists ( fun n'' => dirprod ( natleh n'' n' ) ( F n'' ) ) ) .  assert ( X : forall n' , F' n' -> natdecleast F is ) .  intro n' .  simpl .    induction n' as [ | n' IHn' ] . apply ( @hinhuniv _  ( hProppair _ ( isapropnatdecleast F is ) ) ) . simpl .   intro t2 . destruct t2 as [ n'' is'' ] . destruct is'' as [ l'' d'' ] .  split with 0 .  split . set ( e := natleh0tois0 _ l'' ) . clearbody e . destruct e . apply d'' .  apply ( fun n' => fun f : _ => natleh0n n' ) .  apply ( @hinhuniv _  ( hProppair _ ( isapropnatdecleast F is ) ) ) . intro t2 .  destruct t2 as [ n'' is'' ] . set ( j := natlehchoice2 _ _ ( pr1 is'' ) ) .  destruct j as [ jl | je ] .  simpl .  apply ( IHn' ( hinhpr _ ( tpair _ n'' ( dirprodpair jl ( pr2 is'' ) ) ) ) ) .  simpl . rewrite je in is''  .  destruct is'' as [ nn is'' ] .  clear nn. clear je . clear n'' .

assert ( is' : isdecprop ( F' n' ) ) . apply ( isdecbexists n' F is ) .   destruct ( pr1 is' ) as [ f | nf ] .  apply ( IHn'  f ) .  split with ( S n' ) .  split with is'' . intros n0 fn0 . destruct ( natlthorgeh n0 ( S n' ) )  as [ l' | g' ] .  set ( i' := natlthtolehsn _ _ l' ) .  destruct ( nf ( hinhpr _ ( tpair _ n0 ( dirprodpair i' fn0 ) ) ) ) .   apply g' .

apply ( X n ( hinhpr _ ( tpair _ n ( dirprodpair ( isreflnatleh n ) l ) ) ) ) .  Defined .

(* End of the file stnfsets.v *)


(**
論理としてのProlog
========================

@suharahiromichi

2022/12/18

2022/12/19 ``ex_intro _`` を使うように修正した。

2023/1/21 変数名を1文字にした。
 *)

(**
# はじめに

Prologは、第1階述語論理の構文的なサブセットである「ホーン節」Horn Clauseの自動証明を
動作原理とするプログラミング言語です。
ここで使われる自動証明のことを「導出原理」Resolution Principleと呼びます。

ここでは、Prologのプログラムを論理式として証明してみましょう。

手で証明するのも大変なので、定理証明系（Coq/MathComp）を使ってみます。
すると、Prologと論理学や、Coqとの関係が見えてくるとおもいます。

この記事のソースコードは以下にありますが、実行にはCoq/MathCompは必要です。

https://github.com/suharahiromichi/coq/blob/master/ssr/ssr_prolog_in_logic.v

まず、対象とする論理式を明確にしてみます。
 *)

(**
# Prologのプログラムとしての論理式

ホーン節ということで間違いないのですが、後述する理由で、
「ホーン節」と「ゴール節」のふたつに分けて説明します。
いずれも定義は見たままのものなので、説明は省略します。
ここで、$ k,l,m,n \ge 0 $ とします。

- ホーン節

P、Qは原始論理式（∧、∨、〜、∀、∃などの論理記号を含まない論理式）
で、False（⊥）でないものとします。
論理記号の使い方の次のような文法的な制限を加えた論理式をホーン節といいます。

```math
\forall x_{1}~\forall x_{2}~ …\forall x_{n}~[(P_{1}~\land~P_{2}~\land~…~\land~P_{m})~\to~Q]
```

```coq
forall x1 x2 ... xn, P1 P2 ... Pm -> Q.
```

Prologのプログラムでは、次のように表します。

```Prolog
Q :- P1, P2, ... Pm.
```

量化子の変数は大文字で書き、``∀x``は書きません。
また、``:- true.``は省略します。

- ゴール節

Rは原始論理式で、False（⊥）でないものとします。
次の文法的な制限を加えた論理式をゴール節といいます。

```math
\exists x_{1}~\exists x_{2}~ …\exists x_{l}~[R]
```

```coq
exists x1 x2 ... xl, R.
```

Prologのプログラムでは、次のように表します。

```Prolog
?-R.
```

量化子の変数は大文字で書き、``∃x``は書きません。

- Prologのプログラムの論理式

複数のホーン節 $ H_{i} $ とひとつのゴール節 $ G $ からなります。

```math
(H_{1}~\land~H_{2}~\land~…\land~H_{k})~\to~G
```

Prologのプログラムは、ホーン節を並べたものです。
並べ方の順番は自動証明（導出原理）における選択の順番に反映されます。
ゴール節は対話形式で入力したり
コマンドラインの引数で与える場合が多いので``?-``はあまり使わないかもしれません。

この後、Prologで定数やデータ構造扱うためには、スコーレム関数(Skolem function)の説明が
必要ですが、多少本題からずれるので、省略させてください。
ここでは、PrologもCoqも同様の定数や、リストのデータ構造が使えることを前提とします。
*)

(**
# Prologのプログラムの例

例によって、リストの反転を考えてみます。

```
rev(L, R) :-
    rev3(L, [],  R).
rev3([X|L], A, R) :-
     rev3(L, [X|A], R).
rev3([], R, R).
```

これに対して、ふたつのゴール、ゴール1

```
?- rev([1, 2, 3], R).
```

と、ゴール2について

```
?- rev(L, [9, 8, 7]).
```

実行してみます。

なお、λPrologの文法だと次のようになります。
この場合は、述語の引数の指定の方法が違うだけですね。
```
pred rev i:list A, o:list A.
rev L R :-
    rev3 L [] R.
rev3 [X|L] A R :-
     rev3 L [X|A] R.
rev3 [] R R.
```

ホーン節の部分を論理式で表すと

```math

\forall L~\forall R~[rev3(L, [], R)~\to~rev(L, R)]
\\\land\\
\forall X~\forall L~\forall A~\forall R~[rev3(L, [X|A], R~\to~rev3([X|L],A,R)]
\\\land\\
\forall R~[true~\to~rev3([], R, R)]
```

ゴール1は

```math
\exists R~[rev([1, 2, 3], R)]
```

ゴール2は

```math
\exists L~[rev(L, [9, 8, 7])]
```

*)
From mathcomp Require Import all_ssreflect.

Variable rev : list nat -> list nat -> Prop.
Variable rev3 : list nat -> list nat -> list nat -> Prop.

(**
ホーン節の部分は以下のようになります。
ここでは便宜的にDefinitionでまとめていますが、論理式としての意味は変わりません。
*)
Definition prog0 :=
  (forall L R, rev3 L [::] R -> rev L R)
  /\
    (forall X L A R, rev3 L (X :: A) R -> rev3 (X :: L) A R)
  /\
    (forall R, rev3 [::] R R).

(**
ゴールの部分は
*)
Definition goal1 := exists R, rev [:: 1; 2; 3] R.
Definition goal2 := exists L, rev L [:: 9; 8; 7].

(**
Coqで証明してみます。
Coqにも導出原理に基づく自動証明のタクティク``auto``があるのでそれを使ってみます。
``apply: (ex_intro _)`` で、``∃ R``の``R``を Coq のメタ変数(``_``、
表示上は``?Goal``になる)に割り当てています。
*)
Goal prog0 -> goal1.
Proof.
  rewrite /prog0 /goal1.
  case=> [H [Hcons Hnil]].
  apply: (ex_intro _).
  apply: (H).
  apply: (Hcons).
  apply: (Hcons).
  apply: (Hcons).
  apply: (Hnil).

  Restart.
  rewrite /prog0 /goal1.
  case=> [H [Hcons Hnil]].
  apply: (ex_intro _).
  debug auto.
Qed.

Goal prog0 -> goal2.
Proof.
  rewrite /prog0 /goal2.
  case=> [H [Hcons Hnil]].
  apply: (ex_intro _).
  debug auto.
Qed.

(**
以上から、Prologのプログラムは、Coqの``auto``タクティクで証明できる（場合もある）ことが
わかりました。
*)

(**
# 補足説明

## Prologは古典論理か？

まず、ゴール節の否定を考えます。$ (\lnot~R) \Leftrightarrow (R~\to~False) $
なので、ホーン節の``→``の右をFalseにしたものになります。

```math
\lnot(\exists x_{1}~\exists x_{2}~ …\exists x_{l}~[R])
\\
\forall x_{1}~\forall x_{2}~ …\forall x_{l}~[\lnot~R]
\\
\forall x_{1}~\forall x_{2}~ …\forall x_{l}~[R~\to~False]
```

Prologのプログラムの論理式を否定します。さらに、含意を論理和と否定のかたち
$ (H~\to~G) \Leftrightarrow (\lnot~H~\lor~G) $ にします。
すると、ホーン節とゴール節の否定を連言になります。
上でみたように、ゴール節の否定は（特別な）ホーン節ですから、
Prologのプログラムは、ホーン節の連言ということができます。

```math
\lnot~(H_{1}~\land~H_{2}~\land~…\land~H_{k}~\to~G)
\\
\lnot~(\lnot~(H_{1}~\land~H_{2}~\land~…\land~H_{k})~\lor~G)
\\
\lnot(\lnot H_{1}~\lor~\lnot H_{2}~\lor~…\lor~\lnot H_{k}~\lor~G)
\\
H_{1}~\land~H_{2}~\land~…\land~H_{k}~\land~\lnot~G
```

最初にPrologのプログラムの論理式を否定を考えたのは、
導出原理は、論理式の反駁（はんばく）を導くことだからです。

教科書ではこのように説明されるのが通常ですが、
お気づきのとおり、上記の論理式を導くには
古典論理が必要になります。

これに対して、ホーン節とゴール節を別々に定義すれば、Prologの
論理式の意味を直観主義論理の範囲で示すことができ、
同じく、直観主義論理を使用するCoqの上で証明することができるわけです。

そして、おそらく大多数のPrologプログラマにとっては、
Prologプログラムの動作の理解は「直観的」なのではないかと思います。
ここで「Coqと同様に」と書きたいところなのですが…

## Prologの不完全性

実は、Prologでgoal2に対して実行すると無限ループになります。
なぜなら、最初のrev3の実行``rev3 L [] [9,8,7]``に対して、*節をならべた順番に従って*
``rev3 [X|L] A R :- rev3 L [X|A] R.``が選ばれます。
これは、第3引数は再帰呼び出しに対して、リストの分解が行われないため、
（コンストラクタが構造的に減っていかないため）再帰呼び出しの終了判定ができず、
無限ループになってしまうわけです。

これは、証明できるべき命題が証明できないという意味で、定理証明系としての
Prologの「不完全性」の一例になっています。

これに対して、Coqの完全性はタクティク(証明戦略)の停止性とは無関係です。
（この項は、あとで追記するかもしれません。）

## cut述語について

Prologにはcut述語、別名、カットオペレータ(``!``)があります。
これは、Prologの自動証明において、
ホーン節のしらみつぶしの選択を木構造の検索と見立てた場合、
バックトラックが生じた際に、ツリーの検索の一部をカット(枝を刈る)して、
検索せずにただちに失敗(fail)とする、ということからこの名前があります。

cut述語は、論理式としてもProlog言語ではなく、手続言語の側面を実現するものなので、
本資料では触れませんでした。

Coqにもcutタクティクがありますが、証明論におけるカット除去定理
（``A -> C`` かつ ``C -> B``なら``C``を除去して``A -> B``を導ける）
の逆のことを行うもので、Coqのゴール``A -> B`` を ``C -> B`` に置き換えることをします。
もちろん、そのあとに、``A -> C``を証明させられることになります。

このふたつは全く別の概念なので、注意してください。

 *)

(* END *)


From Equations Require Import Equations.
From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import eqtype ssrnat seq prime bigop ssrAC.
From favssr Require Import prelude bintree.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module Array.
Structure Array (T : Type) : Type :=
  make {tp :> Type;
        lookup : T -> tp -> nat -> T;
        update : nat -> T -> tp -> tp;
        len : tp -> nat;
        array : seq T -> tp;

        list : tp -> seq T;
        invar : tp -> bool;

        _ : forall x0 ar n, invar ar -> n < len ar ->
              lookup x0 ar n = nth x0 (list ar) n;
        _ : forall x ar n, invar ar -> n < len ar ->
              invar (update n x ar);
        _ : forall x0 x ar n, invar ar -> n < len ar ->
              list (update n x ar) = set_nth x0 (list ar) n x;
        _ : forall ar, invar ar -> len ar = size (list ar);
        _ : forall xs, invar (array xs);
        _ : forall xs, list (array xs) = xs
        }.
End Array.

Section BraunTrees.
Context {A : Type}.

Fixpoint braun (t : tree A) : bool :=
  if t is Node l _ r
    then [&& ((size_tree l == size_tree r) || (size_tree l == size_tree r + 1)),
             braun l & braun r]
    else true.

Lemma acomplete_compose (l : tree A) x r :
  acomplete l -> acomplete r ->
  size_tree l == size_tree r + 1 ->
  acomplete (Node l x r).
Proof.
move=>Hl Hr E; rewrite /acomplete.
have/eqP->: height (Node l x r) == up_log 2 (size1_tree r + 1) + 1.
- rewrite /= eqn_add2r (acomplete_h Hl) (acomplete_h Hr) size1_size (eqP E) -size1_size.
  by apply/eqP/maxn_idPl/leq_up_log/leq_addr.
have/eqP->: min_height (Node l x r) == trunc_log 2 (size1_tree r) + 1.
- rewrite /= eqn_add2r (acomplete_mh Hl) (acomplete_mh Hr) size1_size (eqP E) -size1_size.
  by apply/eqP/minn_idPr/leq_trunc_log/leq_addr.
rewrite -subnBA ?addnK; last by rewrite addn1.
rewrite up_log_trunc_log //; last by rewrite size1_size !addn1.
by rewrite addn1 /= subSnn.
Qed.

Lemma braun_acomplete t : braun t -> acomplete t.
Proof.
elim: t=>//=l IHl a r IHr /and3P [E /IHl Hl /IHr Hr].
case/orP: E=>[/eqP E|E]; last by apply: acomplete_compose.
rewrite /acomplete /= -subnBA ?addnK; last by rewrite addn1.
have ->: height l = height r.
- by rewrite (acomplete_h Hl) (acomplete_h Hr) !size1_size E.
have ->: min_height l = min_height r.
- by rewrite (acomplete_mh Hl) (acomplete_mh Hr) !size1_size E.
by rewrite maxnn minnn.
Qed.

End BraunTrees.

Section ArraysViaBraunTrees.
Context {A : Type}.

Fixpoint lookup1 (x0 : A) (t : tree A) (n : nat) : A :=
  if t is Node l x r then
    if n == 1 then x else lookup1 x0 (if ~~ odd n then l else r) n./2
    else x0.

Fixpoint update1 (n : nat) (x : A) (t : tree A) : tree A :=
  if t is Node l a r then
    if n == 1 then Node l x r
      else if ~~ odd n
        then Node (update1 n./2 x l) a r
        else Node l                  a (update1 n./2 x r)
    else Node leaf x leaf.

Fixpoint adds (xs : seq A) (n : nat) (t : tree A) : tree A :=
  if xs is x::s then
    adds s n.+1 (update1 n.+1 x t)
  else t.

(* operations *)

Definition br_tree T : Type := tree T * nat.

Definition lookup x0 (t : br_tree A) n :=
  lookup1 x0 t.1 n.+1.

Definition update n x (t : br_tree A) :=
  let: (t', m) := t in
  (update1 n.+1 x t', m).

Definition len (t : br_tree A) := t.2.

Definition array xs := (adds xs 0 leaf, size xs).

(* Functional Correctness *)

Equations? splice (xs ys : seq A) : seq A by wf (size xs + size ys) lt :=
splice [::]   ys => ys;
splice (x::s) ys => x :: splice ys s.
Proof. by apply: ssrnat.ltP; rewrite addnC addSn ltnS. Qed.

Lemma size_splice xs ys : size (splice xs ys) = size xs + size ys.
Proof. by funelim (splice xs ys); simp splice=>//=; rewrite H addnC addSn. Qed.

Fixpoint list1 (t : tree A) : seq A :=
  if t is Node l x r then x :: splice (list1 l) (list1 r) else [::].

Lemma size_list1 t : size_tree t = size (list1 t).
Proof. by elim: t=>//=l -> _ r ->; rewrite size_splice addn1. Qed.

Lemma list1_empty t : list1 t = [::] -> t = leaf.
Proof. by case: t. Qed.

(* TODO this is awkward *)
Lemma braun_iota (l : tree A) x r n :
  braun (Node l x r) -> n \in iota 1 (size_tree (Node l x r)) -> 1 < n ->
  (odd n ==> (n./2 \in iota 1 (size_tree r))) && (~~ odd n ==> (n./2 \in iota 1 (size_tree l))).
Proof.
rewrite /=; case/and3P=>E Hl Hr.
case: n=>//=; case=>//=; elim=>/=.
- rewrite !mem_iota /= addnC -addnA {1}(_ : 2 = 0+2) // ltn_add2r addn_gt0 => E2 _.
  rewrite addnC addn1=>/=; rewrite ltnS.
  by case/orP: E2=>//; case/orP: E=>/eqP->// _; rewrite addn1.
move=>n; rewrite !mem_iota /= addnC -addnA -addn2 leq_add2r ltn_add2r.
case Ho: (odd n)=>/=; rewrite andbT=>IH H _.
- have H': n < size_tree l + size_tree r by apply/ltn_trans/H/ltnSn.
  move: (IH H' erefl); rewrite addnC (addnC 1) -(addn1 n./2) -(addn1 (uphalf n)) !ltn_add2r.
  rewrite uphalf_half Ho /= addnC.
  case/orP: E=>/eqP S H''; last by rewrite S ltn_add2r.
  move: H; rewrite S addnn =>/uphalf_leq; rewrite uphalf_double=>H'''.
  apply/leq_trans/H'''; rewrite uphalf_half -{2}addn2 halfD /= Ho andbF /= add0n.
  by rewrite addn1 ltnS.
have H': n < size_tree l + size_tree r by apply/ltn_trans/H/ltnSn.
move: (IH H' erefl); rewrite addnC (addnC 1) -(addn1 n./2) -(addn1 (uphalf n)) !ltn_add2r.
rewrite uphalf_half Ho /= add0n.
case/orP: E=>/eqP S H''; first by rewrite -S.
move: (H); rewrite S addnAC -(addn1 n) ltn_add2r addnn =>/half_leq.
rewrite doubleK -(addn1 n) halfD Ho /= addn0 add0n.
rewrite ltn_neqAle=>->; rewrite andbT; apply/negP=>/eqP E.
by move: H; rewrite S -E addnAC addnn -{1}(odd_double_half n) Ho add0n addn1 ltnn.
Qed.

Lemma nth_splice x0 n xs ys :
  n < size xs + size ys -> size ys <= size xs <= size ys + 1 ->
  nth x0 (splice xs ys) n = nth x0 (if ~~odd n then xs else ys) n./2.
Proof.
funelim (splice xs ys); simp splice=>/=.
- rewrite add0n leqn0=>/[swap]; case/andP=>/eqP/size0nil->/=_.
  by move/ltnW; rewrite leqn0=>/eqP->.
case: n=>//=n H1 H2; rewrite H; first last.
- by move: H2; rewrite !addn1 ltnS; case/andP=>->->.
- by move: H1; rewrite addnC addnS.
by rewrite uphalf_half; case: (odd n).
Qed.

Lemma lookup1_braun x0 t n :
  braun t -> n < size_tree t -> lookup1 x0 t n.+1 = nth x0 (list1 t) n.
Proof.
elim: t n=>/=[|l IHl a r IHr] n; first by move=>_/ltnW; rewrite leqn0=>/eqP->.
case/and3P=>E Hl Hr; case: n=>//=n; rewrite -(addn1 n) ltn_add2r=>H.
rewrite nth_splice; first last.
- by rewrite -!size_list1; case/orP: E=>/eqP->; rewrite leqnn leq_addr.
- by rewrite -!size_list1.
have H' : braun (Node l a r) by rewrite /= E Hl Hr.
have H'': n.+2 \in iota 1 (size_tree (Node l a r)).
- by rewrite mem_iota /= addnC -addnA -addn2 leq_add2r.
move: (braun_iota H' H'' (isT : 1 < n.+2))=>/=.
by case Ho: (odd n)=>/=; rewrite ?andbT mem_iota /= add1n ltnS=>Hr';
[apply: IHr | apply: IHl].
Qed.

Lemma list_lookup1 x0 t :
  braun t -> list1 t = map (lookup1 x0 t) (iota 1 (size_tree t)).
Proof.
move=>H; apply/(eq_from_nth (x0:=x0)).
- by rewrite size_map size_iota size_list1.
move=>i Hi.
rewrite size_list1 (nth_map 0); last by rewrite size_iota.
by rewrite nth_iota // add1n lookup1_braun // size_list1.
Qed.

Lemma update1_size n x t :
  braun t -> n \in iota 1 (size_tree t) ->
  size_tree (update1 n x t) == size_tree t.
Proof.
elim: t n=>//=l IHl a r IHr n /and3P [E Hl Hr].
case: n=>/=; first by rewrite mem_iota ltnn.
case=>//=n H.
have H' : braun (Node l a r) by rewrite /= E Hl Hr.
have H'': n.+2 \in iota 1 (size_tree (Node l a r)) by [].
move: (braun_iota H' H'' (isT : 1 < n.+2))=>/=.
case Ho: (odd n)=>/=; rewrite ?andbT => Hn.
- by rewrite eqn_add2r eqn_add2l; apply: IHr.
by rewrite -!addnA eqn_add2r; apply: IHl.
Qed.

Lemma update1_braun n x t :
  braun t -> n \in iota 1 (size_tree t) ->
  braun (update1 n x t).
Proof.
elim: t n=>//=l IHl a r IHr n /and3P [E Hl Hr].
case: n=>/=; first by rewrite mem_iota ltnn.
case=>/= [_|n H]; first by rewrite E Hl Hr.
have H' : braun (Node l a r) by rewrite /= E Hl Hr.
have H'': n.+2 \in iota 1 (size_tree (Node l a r)) by [].
move: (braun_iota H' H'' (isT : 1 < n.+2))=>/=.
case Ho: (odd n)=>/=; rewrite ?andbT => Hn.
- rewrite Hl /=; apply/andP; split; last by apply: IHr.
  by case/orP: E=>/eqP->; apply/orP; [left|right];
    rewrite eq_sym ?eqn_add2r; apply: update1_size.
rewrite Hr andbT; apply/andP; split; last by apply: IHl.
by case/orP: E=>/eqP<-; apply/orP; [left|right];
  rewrite ?eqn_add2r; apply: update1_size.
Qed.

Lemma update1_lookup x0 n m x t :
  braun t -> n \in iota 1 (size_tree t) ->
  lookup1 x0 (update1 n x t) m = (if n == m then x else lookup1 x0 t m).
Proof.
elim: t n m=>//=l IHl a r IHr n m /and3P [E Hl Hr].
case: n=>/=; first by rewrite mem_iota ltnn.
case=>/=[_|n H].
- case: ifP; first by move/eqP=>->.
  by rewrite eq_sym=>->.
have H' : braun (Node l a r) by rewrite /= E Hl Hr.
have H'': n.+2 \in iota 1 (size_tree (Node l a r)) by [].
move: (braun_iota H' H'' (isT : 1 < n.+2))=>/=.
case Ho: (odd n)=>/=; rewrite ?andbT => Hn.
- case: ifP; first by move/eqP=>->.
  move=>_; case Hom: (odd m)=>/=.
  - rewrite IHr //.
    suff: (n./2.+1 == m./2) = (n.+2 == m) by move=>->.
    rewrite -(odd_double_half n.+2) /= Ho /= -{2}(odd_double_half m) Hom /=.
    by rewrite eqn_add2l -!muln2  eqn_pmul2r.
  by case: ifP=>//; move: Hom=>/[swap] /eqP<-; rewrite -odd2 Ho.
case: ifP; first by move/eqP=>->.
move=>_; case Hom: (odd m)=>/=.
- by case: ifP=>//; move: Hom=>/[swap] /eqP<-; rewrite -odd2 Ho.
rewrite IHl //.
suff: (n./2.+1 == m./2) = (n.+2 == m) by move=>->.
rewrite -(odd_double_half n.+2) /= Ho /= -{2}(odd_double_half m) Hom /=.
by rewrite eqn_add2l -!muln2  eqn_pmul2r.
Qed.

Lemma update1_list x0 n x t:
  braun t -> n \in iota 1 (size_tree t) ->
  list1 (update1 n x t) = set_nth x0 (list1 t) n.-1 x.
Proof.
move=>H1 H2; move/eqP: (update1_size x H1 H2)=>Hu.
move: (H2); rewrite mem_iota; case/andP=>H21 H22.
apply/(eq_from_nth (x0:=x0)).
- rewrite -size_list1 Hu size_set_nth prednK // -size_list1.
  by symmetry; apply/maxn_idPr.
move=>i; rewrite -size_list1 Hu=>Hi.
rewrite -lookup1_braun //; first last.
- by rewrite Hu.
- by apply: update1_braun.
rewrite nth_set_nth /= update1_lookup // lookup1_braun //.
case: ifP; first by move/eqP=>->/=; rewrite eq_refl.
move=>E; case: ifP=>//; move: E=>/[swap]/eqP->.
by rewrite prednK // eq_refl.
Qed.

Lemma update1_size_extend t x :
  braun t ->
  size_tree (update1 (size_tree t + 1) x t) = size_tree t + 1.
Proof.
elim: t=>//=l IHl a r IHr /and3P [E /IHl Hl /IHr Hr].
rewrite -{1 2}addnA addn2 /=.
case Ho: (odd (size_tree l + size_tree r))=>/=.
- apply/eqP; rewrite eqn_add2r -[X in _ == X]addnA eqn_add2l -Hr.
  suff : (size_tree l + size_tree r + 1 + 1)./2 == size_tree r + 1 by move/eqP=>->.
  rewrite -addnA halfD Ho /= add0n eqn_add2r.
  case/orP: E=>/eqP->; first by rewrite addnn doubleK.
  by rewrite addnAC addnn halfD odd_double /= addn0 add0n doubleK.
apply/eqP; rewrite eqn_add2r [X in _ == X]addnAC eqn_add2r -Hl -addnA halfD Ho /= add0n.
case/orP: E=>/eqP E; first by rewrite E addnn doubleK.
by move: Ho; rewrite E addnAC addnn addn1 /= odd_double.
Qed.

Lemma update1_braun_extend t x :
  braun t -> braun (update1 (size_tree t + 1) x t).
Proof.
elim: t=>//=l IHl a r IHr /and3P [E Hl Hr].
rewrite -{1 2}addnA addn2 /=.
have H' : braun (Node l a r) by rewrite /= E Hl Hr.
case Ho: (odd (size_tree l + size_tree r))=>/=.
- case/orP: E=>/eqP E; first by move: Ho; rewrite E addnn odd_double.
  move/eqP: (update1_size_extend x H')=>/=.
  rewrite -{1 2}addnA addn2 /= Ho /= eqn_add2r -[X in _ == X]addnA eqn_add2l=>/eqP->.
  rewrite E Hl /= eq_refl /= (addnAC _ 1 _) addnn -!addnA halfD odd_double /= add0n doubleK.
  by apply: IHr.
case/orP: E=>/eqP E; last by move: Ho; rewrite E addnAC addnn addn1 /= odd_double.
move/eqP: (update1_size_extend x H')=>/=.
rewrite -{1 2}addnA addn2 /= Ho /= eqn_add2r {2}addnAC eqn_add2r=>/eqP->.
rewrite E Hr /= eq_refl orbT /= andbT addnn -addnA halfD odd_double /= add0n doubleK -E.
by apply: IHl.
Qed.

Lemma splice_rcons x y xs ys :
  (size ys <= size xs     -> splice (rcons xs x) ys = rcons (splice xs ys) x) *
  (size xs <= size ys + 1 -> splice xs (rcons ys y) = rcons (splice xs ys) y).
Proof.
funelim (splice xs ys); do!(simp splice=>/=).
- by split=>//; rewrite leqn0=>/eqP/size0nil->.
split.
- by rewrite -addn1=>H1; case: (H y x0)=>_ /(_ H1) ->.
by rewrite addn1 ltnS=>H2; case: (H y x0)=>+ _ =>/(_ H2) ->.
Qed.

Lemma update1_braun_rcons t x :
  braun t -> list1 (update1 (size_tree t + 1) x t) = rcons (list1 t) x.
Proof.
elim: t=>//=l IHl a r IHr /and3P [E /IHl Hl /IHr Hr].
rewrite -{1 2}addnA addn2 /=.
case Ho: (odd (size_tree l + size_tree r))=>/=.
- case/orP: E=>/eqP E; first by move: Ho; rewrite E addnn odd_double.
  rewrite E /= (addnAC _ 1 _) addnn -!addnA halfD odd_double /= add0n doubleK.
  by rewrite Hr (splice_rcons x x) // -!size_list1 E.
case/orP: E=>/eqP E; last by move: Ho; rewrite E addnAC addnn addn1 /= odd_double.
rewrite E addnn -addnA halfD odd_double /= add0n doubleK -E.
by rewrite Hl (splice_rcons x x) // -!size_list1 E.
Qed.

Lemma adds_braun t xs :
  braun t ->
  (size_tree (adds xs (size_tree t) t) == size_tree t + size xs) &&
    braun (adds xs (size_tree t) t).
Proof.
elim: xs t=>[|x s IH] t /=; first by move=>->; rewrite addn0 eq_refl.
move=>H; move: (update1_braun_extend x H); rewrite addn1=>H'.
case/andP: (IH _ H'); move: (update1_size_extend x H); rewrite addn1=>->/eqP->->.
by rewrite andbT addSn addnS.
Qed.

Lemma adds_list t xs :
  braun t -> list1 (adds xs (size_tree t) t) = list1 t ++ xs.
Proof.
elim: xs t=>[|x s IH] t /=; first by rewrite cats0.
move=>H; move: (update1_braun_extend x H); rewrite addn1=>H'.
move: (IH _ H'); move: (update1_size_extend x H); rewrite addn1=>->->.
move: (update1_braun_rcons x H); rewrite addn1=>->.
by rewrite -cats1 -catA.
Qed.

(* corollaries *)

Definition invar (t : br_tree A) : bool := braun t.1 && (t.2 == size_tree t.1).

Definition list (t : br_tree A) := list1 t.1.

Corollary invar_lookup x0 ar n :
  invar ar -> n < len ar ->
  lookup x0 ar n = nth x0 (list ar) n.
Proof.
rewrite /invar /lookup /list; case: ar=>t ln /=; case/andP=>H1 /eqP-> H2.
by apply: lookup1_braun.
Qed.

Corollary invar_update x ar n :
  invar ar -> n < len ar ->
  invar (update n x ar).
Proof.
rewrite /invar /update; case: ar=>t ln /=; case/andP=>H1 /eqP-> H2.
have Hn: n.+1 \in iota 1 (size_tree t) by rewrite mem_iota /= add1n.
apply/andP; split; first by apply: update1_braun.
by rewrite eq_sym; apply: update1_size.
Qed.

Corollary invar_list_update x0 x ar n :
  invar ar -> n < len ar ->
  list (update n x ar) = set_nth x0 (list ar) n x.
Proof.
rewrite /invar /update /list; case: ar=>t ln /=; case/andP=>H1 /eqP-> H2.
by rewrite (update1_list x0)=>//; rewrite mem_iota /= add1n.
Qed.

Corollary invar_len t :
  invar t ->
  len t = size (list t).
Proof. case: t=>t n; rewrite /invar /len /list /=; case/andP=>_ /eqP->; exact: size_list1. Qed.

Corollary invar_array xs : invar (array xs).
Proof.
rewrite /invar /array /=.
have /(adds_braun xs)/=: braun (@Leaf A) by [].
by rewrite add0n; case/andP=>/eqP->->; rewrite eq_refl.
Qed.

Corollary invar_list_array xs : list (array xs) = xs.
Proof.
rewrite /list /array /=.
by have /(adds_list xs)/=: braun (@Leaf A) by [].
Qed.

Definition ArrayBraun :=
  @Array.make _ (br_tree A)
    lookup update len array
    list invar
    invar_lookup
    invar_update invar_list_update
    invar_len
    invar_array invar_list_array.

End ArraysViaBraunTrees.

(* TODO switch to packed structures *)
Module ArrayFlex.
Structure ArrayFlex (T : Type) : Type :=
  make {tp :> Type;
        lookup : T -> tp -> nat -> T;
        update : nat -> T -> tp -> tp;
        len : tp -> nat;
        array : seq T -> tp;

        add_lo : T -> tp -> tp;
        del_lo : tp -> tp;
        add_hi : T -> tp -> tp;
        del_hi : tp -> tp;

        list : tp -> seq T;
        invar : tp -> bool;

        _ : forall x0 ar n, invar ar -> n < len ar ->
              lookup x0 ar n = nth x0 (list ar) n;
        _ : forall x ar n, invar ar -> n < len ar ->
              invar (update n x ar);
        _ : forall x0 x ar n, invar ar -> n < len ar ->
              list (update n x ar) = set_nth x0 (list ar) n x;
        _ : forall ar, invar ar -> len ar = size (list ar);
        _ : forall xs, invar (array xs);
        _ : forall xs, list (array xs) = xs;

        _ : forall a ar, invar ar -> invar (add_lo a ar);
        _ : forall a ar, invar ar -> list (add_lo a ar) = a :: list ar;
        _ : forall ar, invar ar -> invar (del_lo ar);
        _ : forall ar, invar ar -> list (del_lo ar) = behead (list ar);
        _ : forall a ar, invar ar -> invar (add_hi a ar);
        _ : forall a ar, invar ar -> list (add_hi a ar) = rcons (list ar) a;
        _ : forall ar, invar ar -> invar (del_hi ar);
        _ : forall ar, invar ar -> list (del_hi ar) = butlast (list ar)
        }.
End ArrayFlex.

Section FlexibleArrays.
Context {A : Type}.

Fixpoint del_hi1 (n : nat) (t : tree A) : tree A :=
  if t is Node l x r then
    if n == 1 then leaf
      else if ~~ odd n then Node (del_hi1 n./2 l) x r
                       else Node l x (del_hi1 n./2 r)
  else leaf.

Fixpoint add_lo1 (x : A) (t : tree A) : tree A :=
  if t is Node l a r
    then Node (add_lo1 a r) x l
    else Node leaf x leaf.

Fixpoint merge (l r : tree A) : tree A :=
  if l is Node ll al rl
    then Node r al (merge ll rl)
    else r.

Definition del_lo1 (t : tree A) : tree A :=
  if t is Node l _ r
    then merge l r
    else leaf.

Definition add_lo (x : A) (t : br_tree A) : br_tree A :=
  let: (t,l) := t in (add_lo1 x t, l.+1).
Definition del_lo (t : br_tree A) : br_tree A :=
  let: (t,l) := t in (del_lo1 t, l.-1).
Definition add_hi (x : A) (t : br_tree A) : br_tree A :=
  let: (t,l) := t in (update1 l.+1 x t, l.+1).
Definition del_hi (t : br_tree A) : br_tree A :=
  let: (t,l) := t in (del_hi1 l t, l.-1).

(* Functional Correctness *)

Lemma butlast_splice (xs ys : seq A) :
  butlast (splice xs ys) = if size ys < size xs then splice (butlast xs) ys
                                                else splice xs (butlast ys).
Proof.
funelim (splice xs ys); simp splice=>//=.
rewrite ltnS; move: H; case: leqP=>{Heqcall}.
- case: s=>[|z s] /=; first by rewrite leqn0=>/eqP/size0nil->.
  simp splice=>_<-.
  by apply: belast_butlast; rewrite size_splice /= addnS.
case: ys=>[|y ys]/=; first by rewrite ltn0.
by simp splice=>/=_->.
Qed.

Lemma del_hi1_list t :
  braun t ->
  list1 (del_hi1 (size_tree t) t) = butlast (list1 t).
Proof.
elim: t=>//=l IHl a r IHr /and3P [E /IHl Hl /IHr Hr].
rewrite -{2}(add0n 1) eqn_add2r; case: ifP.
- by rewrite addn_eq0; case/andP=>/eqP/size0leaf->/eqP/size0leaf->.
move/negbT=>E1; rewrite addn1=>/=; case: ifP=>/=.
- move/negbNE; case/orP: E=>/eqP E; rewrite E; first by rewrite addnn odd_double.
  move=>_; rewrite addnAC addnn addn1 /= doubleK -addn1 -E Hl.
  rewrite belast_butlast; last first.
  - by rewrite size_splice -!size_list1 E addnAC addn1.
  by rewrite butlast_splice -!size_list1 E addn1 ltnS leqnn.
move/negbT/negbNE; case/orP: E=>/eqP E; rewrite E; last first.
- by rewrite addnAC addnn addn1 /= odd_double.
move=>_; rewrite addnn uphalf_double Hr belast_butlast; last first.
- by rewrite size_splice -!size_list1 lt0n.
by rewrite butlast_splice -!size_list1 E ltnn.
Qed.

Lemma del_hi1_braun t : braun t -> braun (del_hi1 (size_tree t) t).
Proof.
elim: t=>//=l IHl a r IHr /and3P [E Hl Hr].
rewrite -{2}(add0n 1) eqn_add2r; case: ifP=>//.
move/negbT=>E1; rewrite addn1=>/=; case: ifP=>/=.
- move/negbNE; case/orP: E=>/eqP E; rewrite E; first by rewrite addnn odd_double.
  move=>_; rewrite addnAC addnn addn1 /= doubleK -addn1 -E Hr IHl //= andbT.
  by rewrite size_list1 del_hi1_list // size_butlast -size_list1 E addn1 /= eq_refl.
move/negbT/negbNE; case/orP: E=>/eqP E; rewrite E; last first.
- by rewrite addnAC addnn addn1 /= odd_double.
move=>_; rewrite addnn uphalf_double Hl IHr //= andbT.
rewrite (size_list1 (del_hi1 _ _)) del_hi1_list // size_butlast -size_list1 addn1.
rewrite prednK ?eq_refl ?orbT //.
by move: E1; rewrite -lt0n addn_gt0 E orbb.
Qed.

Lemma add_lo1_list a t :
  braun t -> list1 (add_lo1 a t) = a :: list1 t.
Proof.
elim: t a=>//=l _ x r IHr a /and3P [_ _ Hr].
by rewrite IHr //; simp splice.
Qed.

Lemma add_lo1_braun x t :
  braun t -> braun (add_lo1 x t).
Proof.
elim: t x=>//=l IHl a r IHr x /and3P [E Hl Hr].
rewrite Hl IHr //= andbT size_list1 add_lo1_list //= -size_list1.
by case/orP: E=>/eqP->; rewrite addn1 eq_refl // orbT.
Qed.

Lemma merge_list l r :
  (size_tree l == size_tree r) || (size_tree l == size_tree r + 1) ->
  braun l -> braun r ->
  list1 (merge l r) = splice (list1 l) (list1 r).
Proof.
elim: l r=>//=ll IHl al rl _ r E /and3P [El Hll Hrl] Hr.
by simp splice; rewrite IHl.
Qed.

Lemma merge_braun l r :
  (size_tree l == size_tree r) || (size_tree l == size_tree r + 1) ->
  braun l -> braun r ->
  braun (merge l r).
Proof.
elim: l r=>//=ll IHl al rl _ r E /and3P [El Hll Hrl] -> /=.
apply/andP; split; last by apply: IHl.
rewrite (size_list1 (merge _ _)) merge_list // size_splice -!size_list1.
by case/orP: E; rewrite eq_sym ?eqn_add2r =>->//; rewrite orbT.
Qed.

Lemma del_lo1_list t : braun t -> list1 (del_lo1 t) = behead (list1 t).
Proof. by case: t=>//=l _ r /and3P [E Hl Hr]; apply: merge_list. Qed.

Lemma del_lo1_braun t : braun t -> braun (del_lo1 t).
Proof. by case: t=>//=l _ r /and3P [E Hl Hr]; apply: merge_braun. Qed.

(* Corollaries *)

Corollary invar_add_lo a t : invar t -> invar (add_lo a t).
Proof.
rewrite /invar /add_lo; case: t=>[t n]/= /andP [E /eqP ->].
apply/andP; split; first by apply: add_lo1_braun.
by rewrite !size_list1 add_lo1_list.
Qed.

Corollary list_add_lo a t : invar t -> list (add_lo a t) = a :: list t.
Proof.
rewrite /invar /add_lo /list; case: t=>[t n]/= /andP [E _].
by apply: add_lo1_list.
Qed.

Corollary invar_del_lo t : invar t -> invar (del_lo t).
Proof.
rewrite /invar /del_lo; case: t=>[t n]/= /andP [E /eqP ->].
apply/andP; split; first by apply: del_lo1_braun.
by rewrite !size_list1 del_lo1_list // size_behead.
Qed.

Corollary list_del_lo t : invar t -> list (del_lo t) = behead (list t).
Proof.
rewrite /invar /add_lo /list; case: t=>[t n]/= /andP [E _].
by apply: del_lo1_list.
Qed.

Corollary invar_add_hi a t : invar t -> invar (add_hi a t).
Proof.
rewrite /invar /add_hi; case: t=>[t n]/= /andP [E /eqP ->].
rewrite -addn1; apply/andP; split; first by apply: update1_braun_extend.
by rewrite update1_size_extend.
Qed.

Corollary list_add_hi a t : invar t -> list (add_hi a t) = rcons (list t) a.
Proof.
rewrite /invar /add_hi /list; case: t=>[t n]/= /andP [E /eqP ->].
by rewrite -addn1; apply: update1_braun_rcons.
Qed.

Corollary invar_del_hi t : invar t -> invar (del_hi t).
Proof.
rewrite /invar /del_hi; case: t=>[t n]/= /andP [E /eqP ->].
apply/andP; split; first by apply: del_hi1_braun.
by rewrite (size_list1 (del_hi1 _ _)) del_hi1_list // size_butlast size_list1.
Qed.

Corollary list_del_hi t : invar t -> list (del_hi t) = butlast (list t).
Proof.
rewrite /invar /del_hi /list; case: t=>[t n]/= /andP [E /eqP ->].
by rewrite del_hi1_list.
Qed.

Definition ArrayFlexBraun :=
  @ArrayFlex.make _ (br_tree A)
    lookup update len array
    add_lo del_lo add_hi del_hi
    list invar
    invar_lookup
    invar_update invar_list_update
    invar_len
    invar_array invar_list_array
    invar_add_lo list_add_lo
    invar_del_lo list_del_lo
    invar_add_hi list_add_hi
    invar_del_hi list_del_hi.

End FlexibleArrays.

Section BiggerBetterFasterMore.
Context {A : Type}.

(* Fast Size of Braun Trees *)

Fixpoint diff (t : tree A) (n : nat) : nat :=
  if t is Node l _ r then
    if n == 0 then 1
      else if ~~ odd n then diff r n./2.-1 else diff l n./2
  else 0.

Fixpoint size_fast (t : tree A) : nat :=
  if t is Node l _ r then
    let n := size_fast r in 1 + n.*2 + diff l n
  else 0.

Lemma diff_braun t n :
  braun t -> (size_tree t == n) || (size_tree t == n.+1) ->
  diff t n = size_tree t - n.
Proof.
elim: t n =>//=l IHl _ r IHr n /and3P [E Hl Hr] En.
case: eqP=>Hn.
- move: En; rewrite Hn; case/orP; first by rewrite addn1.
  by rewrite -{2}(add0n 1) eqn_add2r addn_eq0; case/andP=>/eqP->/eqP->.
case: ifP=>[|/negbT/negbNE] Ho.
- move: En; case/orP: E=>/eqP->.
  - rewrite addnn; case/orP.
    - by move: Ho=>/[swap]/eqP<- /=; rewrite oddD odd_double.
    rewrite -(addn1 n) eqn_add2r =>/eqP Hn'.
    have Hs : 0 < size_tree r.
    - by rewrite -(ltn_pmul2r (isT : 0 < 2)) mul0n muln2 Hn' lt0n; apply/eqP.
    rewrite IHr //; last first.
    - by rewrite -Hn' doubleK prednK // eq_refl orbT.
    by rewrite -Hn' doubleK -subn1 subnA // -addnBAC // !subnn.
  rewrite (addnAC _ 1) addnn; case/orP; last first.
    - by rewrite -(addn1 n) eqn_add2r; move: Ho=>/[swap]/eqP<-; rewrite oddD odd_double.
  rewrite !addn1=>/eqP <- /=; rewrite doubleK.
  by rewrite IHr // ?subnn // eq_refl.
move: En; case/orP: E=>/eqP E; rewrite E.
- rewrite addnn; case/orP; last first.
  - by rewrite -(addn1 n) eqn_add2r; move: Ho=>/[swap]/eqP<-; rewrite odd_double.
  move/eqP=>Hn'.
  rewrite -Hn' subnn addn1 /= uphalf_double -E.
  by rewrite IHl // ?subnn // eq_refl.
case/orP.
- by rewrite -addnA addnn => /eqP Hn'; move: Ho; rewrite -Hn' odd_double.
rewrite (addnAC _ 1) addnn -(addn1 n) eqn_add2r addn1 => /eqP<-/=.
rewrite uphalf_double -addnBAC // subnn add0n.
rewrite IHl // E; last by rewrite addn1 eq_refl orbT.
by rewrite -addnBAC // subnn.
Qed.

Lemma size_fast_size t : braun t -> size_fast t = size_tree t.
Proof.
elim: t=>//=l IHl _ r IHr /and3P [E Hl Hr].
rewrite (IHr Hr) diff_braun //; last by rewrite -addn1.
rewrite addnC (addnC 1) -addnn !addnA; apply/eqP.
rewrite !eqn_add2r subnK //.
by case/orP: E=>/eqP->//; apply: leq_addr.
Qed.

(* Initializing a Braun Tree with a Fixed Value *)

Equations? braun_of_naive (x : A) (n : nat) : tree A by wf n lt :=
braun_of_naive _ 0 => leaf;
braun_of_naive x (k.+1) with inspect k./2 => {
  | m eqn: Hm with inspect (~~ odd k) => {
    | true  eqn: Ho => Node (braun_of_naive x m   ) x (braun_of_naive x m)
    | false eqn: Ho => Node (braun_of_naive x m.+1) x (braun_of_naive x m)
    }
  }.
Proof.
all: apply: ssrnat.ltP; rewrite ltnS; try by apply: half_le.
by apply: half_lt; move/negbT/negbNE/odd_gt0: Ho.
Qed.

Equations? braun2_of (x : A) (n : nat) : tree A * tree A by wf n lt :=
braun2_of _ 0      => (leaf, Node leaf x leaf);
braun2_of x (k.+1) =>
  let: (s,t) := braun2_of x k./2 in
  if ~~ odd k then (Node s x s, Node t x s)
              else (Node t x s, Node t x t).
Proof. by apply: ssrnat.ltP ; rewrite ltnS; apply: half_le. Qed.

Definition braun_of (x : A) (n : nat) : tree A :=
  (braun2_of x n).1.

Lemma braun2_of_size_braun x n s t :
  braun2_of x n = (s, t) ->
  [&& size_tree s == n, size_tree t == n.+1, braun s & braun t].
Proof.
funelim (braun2_of x n); simp braun2_of; first by case=><-<-.
case Hbo: (braun2_of x k./2)=>[s' t']{Heqcall}.
case/and4P: (H _ _ Hbo)=>/eqP Hss /eqP Hst Hs Ht.
case: ifP=>[|/negbT/negbNE] Ho; case=>{s}<-{t}<-/=;
rewrite -!andbA Hss Hst Hs Ht !addn1 !eq_refl orbT /= andbT.
- rewrite addSn addnn; suff: (k./2).*2 = k by move=>->; rewrite !eq_refl.
  by rewrite -[in RHS](odd_double_half k) (negbTE Ho).
rewrite !addSn addnS addnn; suff: (k./2).*2.+1 = k by move=>->; rewrite !eq_refl.
by rewrite -[in RHS](odd_double_half k) Ho addnC addn1.
Qed.

Lemma splice_nseq k (x : A) : splice (nseq k x) (nseq k x) = nseq k.*2 x.
Proof. by elim: k=>//=k IH; simp splice; rewrite IH. Qed.

Lemma braun2_of_nseq x n s t :
  braun2_of x n = (s,t) ->
  list1 s = nseq n x /\ list1 t = nseq n.+1 x.
Proof.
funelim (braun2_of x n); simp braun2_of=>/=; first by case=><-<-.
case Hbo: (braun2_of x k./2)=>[s' t']{Heqcall}.
case:  (H _ _ Hbo)=>Es Et.
case: ifP=>[|/negbT/negbNE] Ho; case=>{s}<-{t}<-/=;
rewrite Es Et /=; simp splice.
- suff: splice (nseq k./2 x) (nseq k./2 x) = nseq k x by move=>->.
  rewrite -[in RHS](odd_double_half k) (negbTE Ho) add0n.
  by exact: splice_nseq.
suff: x :: splice (nseq k./2 x) (nseq k./2 x) = nseq k x by move=>->.
rewrite -[in RHS](odd_double_half k) Ho /=.
by rewrite splice_nseq.
Qed.

Corollary braun_of_braun x n : braun (braun_of x n).
Proof.
rewrite /braun_of; case Hbo: (braun2_of x n)=>[s t] /=.
by case/and4P: (braun2_of_size_braun Hbo).
Qed.

Corollary braun_of_nseq x n : list1 (braun_of x n) = nseq n x.
Proof.
rewrite /braun_of; case Hbo: (braun2_of x n)=>[s t] /=.
by case: (braun2_of_nseq Hbo).
Qed.

(* Converting a List into a Braun Tree *)

Equations nodes {A} (ls : seq (tree A)) (xs : seq A) (rs : seq (tree A)) : seq (tree A) :=
nodes (l::ls) (x::xs) (r::rs) => Node l    x r    :: nodes ls   xs rs;
nodes (l::ls) (x::xs) [::]    => Node l    x leaf :: nodes ls   xs [::];
nodes [::]    (x::xs) (r::rs) => Node leaf x r    :: nodes [::] xs rs;
nodes [::]    (x::xs) [::]    => Node leaf x leaf :: nodes [::] xs [::];
nodes ls      [::]    rs      => [::].

Equations? brauns {A} (k : nat) (xs : seq A) : seq (tree A) by wf (size xs) lt :=
brauns k [::] => [::];
brauns k xs   => let ys := take (2^k) xs in
                 let zs := drop (2^k) xs in
                 let ts := brauns k.+1 zs in
                 nodes ts ys (drop (2^k) ts).
Proof.
apply: ssrnat.ltP; rewrite /zs /xs ltnS.
rewrite size_drop /= -addn1 -subnBA; last by rewrite expn_gt0.
by apply: leq_subr.
Qed.

Definition brauns1 {A} (xs : seq A) : tree A :=
  nth leaf (brauns 0 xs) 0.

(* Functional Correctness *)

(* every 2k-th element in `drop i xs` *)
Fixpoint take_nths {A} (i k : nat) (xs : seq A) : seq A :=
  if xs is x::s
    then if i is j.+1 then take_nths j k s
                      else x :: take_nths (2^k-1) k s
  else [::].

Lemma take_nths_drop {T} i k j (xs : seq T) :
  take_nths i k (drop j xs) = take_nths (i + j) k xs.
Proof.
elim: xs j=>//=x s IH j; rewrite drop_cons.
case: j=>/=[|j]; first by rewrite addn0.
by rewrite addnS.
Qed.

Lemma take_nths_00 {T} (xs : seq T) : take_nths 0 0 xs = xs.
Proof. by elim: xs=>//=x s ->. Qed.

Lemma splice_take_nths {T} (xs : seq T) :
  splice (take_nths 0 1 xs) (take_nths 1 1 xs) = xs.
Proof. by elim: xs=>//=x s IH; simp splice; rewrite IH. Qed.

Lemma take_nths_take_nths {T} i m j n (xs : seq T) :
  take_nths i m (take_nths j n xs) = take_nths (i * 2^n + j) (m + n) xs.
Proof.
elim: xs i j=>//=x s IH i j.
have Hn: 0 < 2^n by rewrite expn_gt0.
case: j=>/=[|j]; last by rewrite addnS.
rewrite addn0; case: i=>/=[|i]; rewrite IH.
- rewrite expnD mulnBl mul1n addnBA // subnK //.
  by apply: leq_pmull; rewrite expn_gt0.
by rewrite mulSnr -{4}(prednK Hn) addnS subn1.
Qed.

Lemma take_nths_empty {T} i k (xs : seq T) :
  take_nths i k xs = [::] <-> size xs <= i.
Proof. by elim: xs i=>//=x s IH; case. Qed.

Lemma hd_take_nths {T} x0 i k (xs : seq T) :
  i < size xs -> head x0 (take_nths i k xs) = nth x0 xs i.
Proof. by elim: xs i=>//=x s IH; case. Qed.

Lemma take_nths_01_splice {T} (xs : seq T) ys :
  (size xs == size ys) || (size xs == size ys + 1) ->
  take_nths 0 1 (splice xs ys) = xs /\ take_nths 1 1 (splice xs ys) = ys.
Proof.
funelim (splice xs ys); simp splice=>/=.
- by rewrite addn1; case/orP=>//=; rewrite eq_sym=>/eqP/size0nil->.
rewrite -addn1 eqn_add2r orbC eq_sym [X in _||X]eq_sym.
by case/H=>->->.
Qed.

Lemma size_take_nths_00 {T} (xs : seq T) :
  (size (take_nths 0 1 xs) == size (take_nths 1 1 xs)) ||
  (size (take_nths 0 1 xs) == size (take_nths 1 1 xs) + 1).
Proof.
elim: xs=>//=_ s; rewrite (_ : 2^1 - 1 = 1) // -(addn1 (size _)) eqn_add2r.
by case/orP; rewrite eq_sym=>->//; rewrite orbT.
Qed.

Lemma size_nodes {T} ls (xs : seq T) rs : size (nodes ls xs rs) = size xs.
Proof. by funelim (nodes ls xs rs); simp nodes=>//=; rewrite H. Qed.

Lemma nth_nodes {T} x0 i ls (xs : seq T) rs :
  i < size xs ->
  nth leaf (nodes ls xs rs) i = Node (nth leaf ls i)
                                     (nth x0 xs i)
                                     (nth leaf rs i).
Proof.
funelim (nodes ls xs rs); simp nodes=>//=;
rewrite /= in H; rewrite ltnS; case: i=>//=i /(H x0)->;
by rewrite ?nth_nil.
Qed.

Theorem size_brauns {T} k (xs : seq T) :
  size (brauns k xs) = minn (size xs) (2 ^ k).
Proof.
funelim (brauns k xs); simp brauns=>/=; first by rewrite min0n.
by rewrite size_nodes size_take /= minnC.
Qed.

Fixpoint braun_list {T : eqType} (t : tree T) (xs : seq T) : bool :=
  if t is Node l a r
    then if xs is x::s
           then [&& a == x, braun_list l (take_nths 1 1 xs) &
                            braun_list r (take_nths 2 1 xs)]
         else false
  else nilp xs.

Lemma braun_list_eq {T : eqType} (t : tree T) xs :
  braun_list t xs <-> braun t /\ xs = list1 t.
Proof.
elim: t xs=>/=[|l IHl a r IHr] xs; first by split; [move/nilP | case=>_->].
case: xs=>/=[|x s]; first by split=>//; case.
move: (IHl (take_nths 0 1 s))=>{}IHl; move: (IHr (take_nths 1 1 s))=>{}IHr.
rewrite !size_list1; split.
- case/and3P=>/eqP->/IHl [-> <-] /IHr [-> <-] /=.
  by rewrite size_take_nths_00 splice_take_nths.
case; case/and3P=>E Hl Hr; case=>-> Es; rewrite eq_refl /=.
move: (take_nths_01_splice E); rewrite -Es; case=>El Er.
by apply/andP; split; [apply/IHl|apply/IHr].
Qed.

Lemma braun_list_not_nil {T : eqType} (x0 : T) t (xs : seq T) :
  ~~ nilp xs ->
  braun_list t xs <->
  exists l a r, [&& t == Node l a r,
                    a == head x0 xs,
                    braun_list l (take_nths 1 1 xs) &
                    braun_list r (take_nths 2 1 xs)].
Proof.
move=>H; case: t=>/=.
- by move/negbTE: H=>->; split=>//; case=>_[_][_].
move=>l a r; split.
- case: xs H=>//=x s _ /and3P [/eqP-> Hl Hr].
  by exists l, x, r; rewrite !eq_refl Hl Hr.
case=>l'[x'][r'] /and4P [/eqP [->->->]].
by case: xs H=>//=x s _ ->->->.
Qed.

Theorem brauns_correct {T : eqType} i (xs : seq T) k :
  i < minn (size xs) (2 ^ k) ->
  braun_list (nth leaf (brauns k xs) i) (take_nths i k xs).
Proof.
elim/(@size_ind T): xs i k=>[|n IH] xs + i k.
- by move=>->; rewrite min0n.
case: xs=>[|x s]; first by move=>_; rewrite min0n.
rewrite {4}[x::s]lock /= ltnS =>E Hi; simp brauns.
set zs := drop (2 ^ k) (x :: s); rewrite /=.
have Hz: size zs <= n.
- rewrite /zs size_drop /=; apply/leq_trans/E.
  rewrite -addn1 -subnBA; last by rewrite expn_gt0.
  by apply: leq_subr.
set ts := brauns k.+1 zs.
have H: forall m n, n = m + 2^k -> m < size ts ->
          braun_list (nth leaf ts m) (take_nths n k.+1 (x::s)).
- move=>m _ ->; rewrite {1}/ts size_brauns => Hm.
  by move: (IH _ Hz _ _ Hm); rewrite {2}/zs take_nths_drop.
set ts' := drop (2 ^ k) ts.
rewrite (nth_nodes x) /=; last first.
- by rewrite size_take /=; move: Hi; rewrite minnC.
move: (Hi); rewrite leq_min; case/andP=>Hi1 Hi2.
case Ht: (take_nths i k (locked (x :: s)))=>[|h t].
- by move/take_nths_empty: Ht; rewrite -lock leqNgt Hi1.
rewrite -Ht !take_nths_take_nths -lock; apply/andP; split.
- rewrite nth_take // -(hd_take_nths _ k) //.
  by move: Ht; rewrite -lock=>->.
rewrite mul1n addnC add1n -expnS; case: (ltnP i (size ts))=>Hit.
- apply/andP; split; first by apply: H.
  case: (ltnP i (size ts'))=>Hit'.
  - rewrite /ts' nth_drop; apply: H; first by rewrite addnAC addnn expnS mul2n.
    by move: Hit'; rewrite /ts' size_drop ltn_subRL.
  rewrite nth_default // [x :: s]lock /=.
  apply/nilP/take_nths_empty; rewrite -lock /=.
  move: Hit'; rewrite /ts' /ts /zs size_drop size_brauns size_drop /=.
  rewrite subn_minl geq_min {1}expnS mul2n -addnn addnK (leqNgt (2^k)) Hi2 orbF.
  by rewrite -subnDA addnn leq_subLR expnS mul2n.
have Hsi: size s < i + 2 ^ k.
- move: Hit; rewrite /ts size_brauns /zs size_drop /= geq_min.
  case/orP; first by rewrite leq_subLR addnC.
  move=>H'; move: (leq_ltn_trans H' Hi2).
  by rewrite expnS -{2}(mul1n (2^k)) ltn_mul2r andbF.
rewrite nth_default // [x :: s]lock /=; apply/andP; split.
- by apply/nilP/take_nths_empty; rewrite -lock.
rewrite nth_default /=; last first.
- by rewrite /ts' size_drop leq_subLR; apply/(leq_trans Hit)/leq_addl.
apply/nilP/take_nths_empty; rewrite -lock /=; apply: (ltn_trans Hsi).
by rewrite addnC ltn_add2r ltn_exp2l.
Qed.

Corollary brauns1_correct {T : eqType} (xs : seq T) :
  braun (brauns1 xs) /\ list1 (brauns1 xs) = xs.
Proof.
move: (leq0n (size xs)); rewrite leq_eqVlt eq_sym; case/orP.
- by move/eqP/size0nil=>->.
move: (brauns_correct (i:=0) (xs:=xs) (k:=0)).
rewrite expn0 leq_min andbT=>/[apply]/braun_list_eq [-> <-]; split=>//.
by exact: take_nths_00.
Qed.

(* Running Time Analysis *)

Equations? T_brauns (k : nat) (xs : seq A) : nat by wf (size xs) lt :=
T_brauns _ [::] => 0;
T_brauns k xs => let ys := take (2^k) xs in
                 let zs := drop (2^k) xs in
                 let ts := brauns (k+1) zs in
                 4 * minn (2^k) (size xs) + T_brauns (k+1) zs.
Proof.
apply: ssrnat.ltP; rewrite /zs /xs size_drop /= ltn_subrL andbT.
by apply: expn_gt0.
Qed.

Theorem T_brauns_eq k xs : T_brauns k xs = 4 * size xs.
Proof.
funelim (T_brauns k xs); simp T_brauns=>//=.
rewrite H size_drop /= -mulnDr; set x := 2^k; set y:= (size l).+1.
apply/eqP; rewrite eqn_pmul2l // minnC minnE -addnBn -subnDA.
suff: y - (x + y) == 0 by move/eqP=>->; rewrite addn0.
by rewrite subn_eq0; exact: leq_addl.
Qed.

(* Converting a Braun Tree into a List *)

Definition value {A} (t : tree A) : option A :=
  if t is Node _ x _ then Some x else None.

Definition left {A} (t : tree A) : option (tree A) :=
  if t is Node l _ _ then Some l else None.

Definition right {A} (t : tree A) : option (tree A) :=
  if t is Node _ _ r then Some r else None.

Definition phi {A} (ts : seq (tree A)) : nat :=
  \sum_(t <- ts) (2 * size_tree t + 1).

Lemma phi_left_right {T} (t : tree T) :
  phi (olist (left t)) + phi (olist (right t)) < phi [:: t].
Proof.
case: t=>/=[|l a r]; rewrite /phi !big_seq1 ?big_nil //=.
by rewrite addnAC ltn_add2r !mulnDr addnA muln1 ltn_add2l.
Qed.

Equations? list_fast_rec {T} (xs : seq (tree T)) : seq T by wf (phi xs) lt :=
list_fast_rec xs with inspect (omap value xs) => {
  | [::] eqn: _  => [::];
  | vs   eqn: Hv => let ls := omap left xs in
                    let rs := omap right xs in
                    vs ++ list_fast_rec (ls ++ rs)
}.
Proof.
apply: ssrnat.ltP; rewrite /phi {}/ls {}/rs.
case: {list_fast_rec}xs Hv=>//= x + _; elim=>/=[|h s IH].
- rewrite big_cat /= !omap_cons !omap_nil !cats0.
  by apply: phi_left_right.
rewrite !omap_cons !big_cat !big_cons /= -!/(phi _) !mul2n !addnA in IH *.
rewrite (ACl ((2*5)*(1*3*4*6))%AC) /= [X in _<X](ACl ((3*4)*(1*5)*2)%AC) /= addn1 ltnS.
apply: leq_add; last by rewrite [X in _<X]addnAC addn1 ltnS in IH.
by apply: ltnW; move: (phi_left_right h); rewrite {3}/phi big_seq1 mul2n.
Qed.

Definition list_fast {T} (t : tree T) : seq T :=
  list_fast_rec [::t].

(* Functional Correctness *)

Lemma list_fast_rec_all_leaf {T} (ts : seq (tree T)) :
  all (fun t => ~~ is_node t) ts -> list_fast_rec ts = [::].
Proof.
funelim (list_fast_rec ts); rewrite -Heqcall //= => Ha.
move: {H H0}Hv; suff: omap value xs = [::] by move=>->.
by apply/omap_empty/sub_all/Ha; case.
Qed.

Lemma take_nths_lt {T} i k (xs : seq T) :
  i < size xs <= 2 ^ k ->
  take_nths i k xs = take 1 (drop i xs).
Proof.
elim: xs i =>//=x s IH i; rewrite ltnS.
case: i=>/=[|i].
- have/prednK{1}<-: 0 < 2^k by rewrite expn_gt0.
  by rewrite subn1 take0 ltnS=>/take_nths_empty ->.
by case/andP=>Hi1 Hi2; rewrite IH // Hi1 /=; apply/ltnW.
Qed.

Lemma size_omap_lvr {T} (xs : seq (tree T)) :
  (size (omap value xs) = count is_node xs) *
  (size (omap left  xs) = count is_node xs) *
  (size (omap right xs) = count is_node xs).
Proof.
rewrite /omap !size_flatten /shape -!map_comp !(eq_map (f1:=size \o _) (f2:=is_node));
  try by case.
by rewrite sumn_count.
Qed.

Lemma nth_omap_lvr {T} (xs : seq (tree T)) x0 x1 i l a r :
  i < size xs ->
  (* technically we only need is_node upto i *)
  all is_node xs ->
  nth leaf xs i = Node l a r ->
  (nth x0 (omap value xs) i = a) *
  (nth x1 (omap left  xs) i = l) *
  (nth x1 (omap right xs) i = r).
Proof.
elim/last_ind: xs i=>//=s x IH i.
rewrite size_rcons nth_rcons all_rcons ltnS leq_eqVlt; case/orP.
- move/eqP=>->; case/andP=>_ Ha; rewrite ltnn eq_refl=>->.
  rewrite !omap_rcons !nth_cat /= !size_omap_lvr.
  by move: Ha; rewrite all_count=>/eqP->; rewrite ltnn subnn.
move=>Hi; case/andP=>Hx Ha; rewrite Hi !omap_rcons !nth_cat !size_omap_lvr => H.
by move: (Ha); rewrite all_count=>/eqP->; rewrite Hi !IH.
Qed.

(* x0 is a dummy variable for nth on xs *)
Theorem list_fast_rec_correct {T : eqType} (x0 : T) ts k (xs : seq T) :
  size ts = 2 ^ k ->
  (forall i, i < 2 ^ k -> braun_list (nth leaf ts i) (take_nths i k xs)) ->
  list_fast_rec ts = xs.
Proof.
elim/(@size_ind T): xs k ts=>[|n IH] xs + k ts.
- move/size0nil=>->/= Hs Hl.
  apply/list_fast_rec_all_leaf/(all_nthP leaf)=>i; rewrite Hs.
  by case/Hl/braun_list_eq=>_; case: (nth leaf ts i).
move=>Hs Ht Hl; case: (ltnP (size xs) (2 ^ k))=>Hs'.
- (* size xs < 2 ^ k *)
  have ->: ts = map (fun x => Node leaf x leaf) xs ++ nseq (size ts - size xs) leaf.
  - apply: (eq_from_nth (x0:=leaf)).
    - by rewrite size_cat size_map size_nseq subnKC // Ht; apply: ltnW.
    move=>i Hi; rewrite nth_cat size_map nth_nseq if_same.
    move: Hi; rewrite Ht=>{}/Hl; case: ltnP=>Hi'.
    - rewrite (nth_map x0) //.
      have/minn_idPl Hxi: 1 <= size xs - i by rewrite subn_gt0.
      rewrite take_nths_lt; last by rewrite Hi' /=; apply: ltnW.
      have ->: take 1 (drop i xs) = [:: nth x0 xs i].
      - apply: (eq_from_nth (x0:=x0)); first by rewrite /= size_take size_drop.
        move=>j; rewrite size_take size_drop -/(minn _ _) Hxi ltnS leqn0 =>/eqP{j}->/=.
        by rewrite nth_take // nth_drop addn0.
      case: (nth leaf ts i)=>[|l a r] //=.
      case/and3P=>/eqP->/braun_list_eq [_] Hl' /braun_list_eq [_] Hr'.
      by symmetry in Hl'; move/list1_empty: Hl'=>->; symmetry in Hr'; move/list1_empty: Hr'=>->.
    move/(take_nths_empty _ k): Hi' =>->/braun_list_eq [_ H'].
    by symmetry in H'; move/list1_empty: H'=>->.
  simp list_fast_rec=>/=.
  rewrite omap_cat [X in _ ++ X]omap_empty; last first.
  - by apply/(all_nthP leaf)=>i _; rewrite nth_nseq if_same.
  rewrite cats0; have->: omap value [seq Node leaf x leaf | x <- xs] = xs.
  - by rewrite /omap -map_comp /= (eq_map (f2:=fun x => [::x])) // flatten_seq1.
  case: {Hs Hl Hs'}xs=>//x s.
  rewrite list_fast_rec_all_leaf; first by rewrite cats0.
  apply/allP=>z; rewrite mem_cat; case/orP.
  - rewrite omap_cat mem_cat /omap; case/orP.
    - rewrite -map_comp (eq_map (f2:=fun=>[::leaf])) // flatten_map1.
      by case/mapP=>y _ ->.
    rewrite map_nseq /=; case/flattenP=>y; rewrite mem_nseq.
    by case/andP=>_/eqP->.
  rewrite omap_cat mem_cat /omap; case/orP.
  - rewrite -map_comp (eq_map (f2:=fun=>[::leaf])) // flatten_map1.
    by case/mapP=>y _ ->.
  rewrite map_nseq /=; case/flattenP=>y; rewrite mem_nseq.
  by case/andP=>_/eqP->.
(* 2 ^ k <= size xs *)
have {Hl}H' : forall i, i < 2^k ->
              exists lt xt rt,
              [&& nth leaf ts i == Node lt xt rt,
                  xt == nth x0 xs i,
                  braun_list lt (take_nths (i +     2 ^ k) k.+1 xs) &
                  braun_list rt (take_nths (i + 2 * 2 ^ k) k.+1 xs)].
- move=>i Hi; move: (Hl _ Hi).
  have Hn: ~~ nilp (take_nths i k xs).
  - case E: (take_nths i k xs)=>[|ht tt] //.
    by move/take_nths_empty: E; rewrite leqNgt; move: (leq_trans Hi Hs')=>->.
  rewrite (braun_list_not_nil x0) //; case=>l'[a'][r'].
  case/and4P=>Hnd Ha; rewrite !take_nths_take_nths mul1n addnC (addnC _ i) add1n=>Hl' Hr'.
  exists l', a', r'; rewrite Hnd; move: Ha; rewrite hd_take_nths; last by apply/leq_trans/Hs'.
  by move=>->/=; rewrite Hl' Hr'.
have Ha' : all is_node ts.
- apply/allP=>t /[dup] Hit.
  rewrite -index_mem; set i:= index t ts; rewrite Ht=>/H'.
  by case=>l'[a'][r']; case/and4P=>+ _ _ _; rewrite /i nth_index // =>/eqP->.
simp list_fast_rec=>/=; have {Hs'}->: omap value ts = take (2^k) xs.
- apply: (eq_from_nth (x0:=x0)).
  - rewrite size_take -/(minn _ _) (minn_idPl Hs') size_omap_lvr -Ht.
    by apply/eqP; rewrite -all_count.
  move=> i; rewrite size_omap_lvr; move: (Ha'); rewrite all_count=>/eqP->.
  rewrite Ht=>/[dup] Hi' /H'; case=>l'[a'][r']; case/and4P=>H1 H2 _ _.
  have Hi'': i < size xs by apply/leq_trans/Hs'.
  rewrite nth_take // -(eqP H2); rewrite -Ht in Hi'.
  by rewrite (nth_omap_lvr x0 _ Hi' Ha' (eqP H1)).
have{Hs H'}->: list_fast_rec (omap left ts ++ omap right ts) = drop (2^k) xs.
- apply: (IH _ _ k.+1).
  - rewrite size_drop leq_subLR; apply: (leq_trans Hs).
    by rewrite -{1}(add0n n) ltn_add2r expn_gt0.
  - rewrite size_cat !size_omap_lvr.
    by move: Ha'; rewrite all_count=>/eqP->; rewrite Ht addnn expnS mul2n.
  move=>i Hi; rewrite nth_cat size_omap_lvr.
  move: (Ha'); rewrite all_count=>/eqP->; rewrite Ht; case: ltnP; rewrite take_nths_drop.
  - move=>/[dup] Hi' /H'; case=>l'[a'][r']; case/and4P=>H1 _ H3 _.
    by rewrite -Ht in Hi'; rewrite (nth_omap_lvr x0 leaf Hi' Ha' (eqP H1)).
  move=>Hi'; have Hi'': i - 2^k < 2^k.
  - rewrite ltn_psubLR; last by rewrite expn_gt0.
    by rewrite addnn -mul2n -expnS.
  move: (H' _ Hi''); case=>l'[a'][r']; case/and4P=>H1 _ _.
  rewrite mul2n -addnn addnBAC // addnA addnK; rewrite -Ht in H1 Hi'' *.
  by rewrite (nth_omap_lvr x0 leaf Hi'' Ha' (eqP H1)).
case E: (take (2 ^ k) xs)=>[|ht tt].
- case: xs E=>// x s.
  rewrite take_cons; case E': (2^k)=>//.
  by move/eqP: E'; rewrite expn_eq0.
by rewrite -cat_cons -E cat_take_drop.
Qed.

Corollary list_fast_correct {T : eqType} (x0 : T) t (xs : seq T) :
  braun_list t xs -> list_fast t = xs.
Proof.
move=>H; apply: (list_fast_rec_correct x0 (k:=0))=>// i.
rewrite ltnS leqn0=>/eqP->/=.
by rewrite take_nths_00.
Qed.

(* Running Time Analysis *)

Equations? T_list_fast_rec {T} (ts : seq (tree T)) : nat by wf (phi ts) lt :=
T_list_fast_rec ts with inspect (omap value ts) => {
  | [::] eqn: _  => size ts;
  | vs   eqn: Hv => let ls := omap left ts in
                    let rs := omap right ts in
                    3*size ts + size vs + size ls + T_list_fast_rec (ls ++ rs)
}.
Proof.
apply: ssrnat.ltP; rewrite /phi {}/ls {}/rs.
case: {T_list_fast_rec}ts Hv=>//= x + _; elim=>/=[|h s IH].
- rewrite big_cat /= !omap_cons !omap_nil !cats0.
  by apply: phi_left_right.
rewrite !omap_cons !big_cat !big_cons /= -!/(phi _) !mul2n !addnA in IH *.
rewrite (ACl ((2*5)*(1*3*4*6))%AC) /= [X in _<X](ACl ((3*4)*(1*5)*2)%AC) /= addn1 ltnS.
apply: leq_add; last by rewrite [X in _<X]addnAC addn1 ltnS in IH.
by apply: ltnW; move: (phi_left_right h); rewrite {3}/phi big_seq1 mul2n.
Qed.

Lemma sum_tree_list_children {T} (ts : seq (tree T)) k :
  \sum_(t <- ts) (k * size_tree t) =
  \sum_(t <- omap left ts ++ omap right ts) (k * size_tree t) + k * (count is_node ts).
Proof.
elim: ts=>/=[|t ts IH]; first by rewrite big_nil muln0.
rewrite big_cons !omap_cons !big_cat /=.
case: t=>/=[|l a r].
- by rewrite big_nil muln0 !add0n IH big_cat.
rewrite !big_seq1 /= IH big_cat /= add1n mulnS.
by rewrite ![in RHS]addnA (ACl ((1*3*5)*(2*4*6))%AC) /= -mulnDr -mulnSr addn1.
Qed.

(* this upper bound is somewhat ad-hoc but still linear, right? *)
Theorem T_list_fast_rec_ub {T} (ts : seq (tree T)) :
  T_list_fast_rec ts <= \sum_(t <- ts) (8*size_tree t + 1) + 2*size ts.
Proof.
move: {2}(phi ts) (leqnn (phi ts)) =>n; elim: n ts=>[|n IH] ts.
- rewrite leqn0 /phi big_split /= sum1_size addn_eq0.
  by case/andP=>_ /eqP/size0nil->.
move=>H; simp T_list_fast_rec=>/=.
case Ho: (omap value ts)=>[|h t].
- rewrite mul2n -addnn addnA; apply: leq_addl.
(* vs is non-empty *)
rewrite (_ : (size t).+1 = size (h :: t)) // -Ho big_split /= sum1_size.
have/IH: phi (omap left ts ++ omap right ts) <= n.
- move: H; rewrite /phi big_split /= [X in _ -> X <= _]big_split /= !sum1_size => H.
  rewrite size_cat !size_omap_lvr addnn -mul2n -sum_tree_list_children.
  case E: ts Ho H=>[|h' t']//; rewrite -{1 2 4}E /= => Ho.
  by rewrite addnS ltnS=>H; apply/leq_trans/H/leq_addr.
rewrite big_split /= sum1_size size_cat !size_omap_lvr addnn -mul2n.
rewrite -(leq_add2l (3 * size ts + count is_node ts + count is_node ts))=>H'.
rewrite [X in _<=X+_+_]sum_tree_list_children; apply: (leq_trans H').
rewrite 2!addnA (ACl (4*(2*3*5*6)*1)%AC) /= -[X in _<=X]addnA.
by rewrite mulnA -{1 2}(mul1n (count _ _)) -!mulnDl -{2}(mul1n (size _)) -mulnDl.
Qed.

End BiggerBetterFasterMore.

Section Exercises.
Context {A : Type}.

(* Exercise 11.1 *)

Lemma braun_exp_ht (t : tree A) : braun t -> 2 ^ height t <= 2 * size_tree t + 1.
Proof.
Admitted.

Corollary braun_log (t : tree A) : braun t -> height t = up_log 2 (size1_tree t).
Proof.
Admitted.

(* Exercise 11.2 *)

Variable x0 : A.

Lemma bal_braun n xs t zs : n <= size xs -> bal x0 n xs = (t, zs) -> braun t.
Proof.
Admitted.

(* Exercise 11.3 *)

Fixpoint nat_of (bs : seq bool) : nat :=
  if bs is b :: s then
    2 * nat_of s + b
    else 1.

Lemma nat_of_gt0 bs : 0 < nat_of bs.
Proof. by elim: bs=>//=b s IH; rewrite addn_gt0 muln_gt0 IH. Qed.

Fixpoint lookup_trie (x0 : A) (t : tree A) (bs : seq bool) : A := x0. (* FIXME *)

Fixpoint update_trie (bs : seq bool) (x : A) (t : tree A) {struct t} : tree A := t. (* FIXME *)

Lemma braun_lookup_trie_1 t bs :
  braun t -> nat_of bs <= size_tree t -> (* nat_of bs always >= 1 *)
  lookup_trie x0 t bs = lookup1 x0 t (nat_of bs).
Proof.
Admitted.

Lemma update_trie_1 bs x t :
  update_trie bs x t = update1 (nat_of bs) x t.
Proof.
Admitted.

(* Exercise 11.4 *)

Fixpoint del_lo2 (t : tree A) : tree A := t. (* FIXME *)

Lemma del_lo_eq t : del_lo2 t = del_lo1 t.
Proof.
Admitted.

(* Exercise 11.5 *)

Fixpoint left_height (t : tree A) : nat := 0. (* FIXME *)

Lemma braun_lh t : braun t -> left_height t = height t.
Proof.
Admitted.

(* Exercise 11.6 *)

Fixpoint T_diff (t : tree A) (n : nat) : nat := 0. (* FIXME *)

Fixpoint T_size_fast (t : tree A) : nat := 0. (* FIXME *)

Lemma T_size_fast_bound t : T_size_fast t <= (height t)^2.
Proof.
Admitted.

(* Exercise 11.7 *)

Lemma braun_of_naive_nseq (x : A) n : list1 (braun_of_naive x n) = nseq n x.
Proof.
Admitted.

End Exercises.