(** * 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 "../../" .

Require Export Foundations.hlevel2.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( dni n i )  ( stntonat ( S n ) ) ( stntonat n ) ( di 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 *)


(** printing now %\coqdockw{now}% *)
(** printing simp %\coqdoctac{simp}% *)
(** printing by %\coqdockw{by}% *)
(** printing rec %\coqdockw{rec}% *)
(* begin hide *)
From Equations Require Import Equations.

Require Import Lia Utf8 List.

From Coq Require Import
     Arith.PeanoNat
     Bool.

Import ListNotations.
Set Keyed Unification.

Section list_size.
  Context {A : Type} (f : A -> nat).
  Equations list_size (l : list A) : nat :=
  list_size nil := 0;
  list_size (cons x xs) := S (f x + list_size xs).
  Global Transparent list_size.

  Context {B : Type}.
  Equations? list_map_size (l : list A)
           (g : forall (x : A), f x < list_size l -> B) : list B :=
  list_map_size nil _ := nil;
  list_map_size (cons x xs) g := cons (g x _) (list_map_size xs (fun x H => g x _)).

  Proof. auto with arith. lia. Defined.

  Lemma list_map_size_spec (g : A -> B) (l : list A) :
    list_map_size l (fun x _ => g x) = List.map g l.
  Proof.
    funelim (list_map_size l (λ (x : A) (_ : f x < list_size l), g x)); simpl; trivial.
    now rewrite H.
  Qed.
End list_size.

Require Import List.
(* end hide *)
(** To solve measure subgoals *)
#[local] Hint Extern 4 (_ < _) => simpl; lia : rec_decision.
Obligation Tactic := CoreTactics.equations_simpl; try (simpl; lia); try typeclasses eauto with rec_decision.

(* begin hide *)
Section RoseTree.
(* end hide *)
  (* Context {A : Type}. *)

  Inductive rose : Type :=
  | node (n : nat) (l : list rose) : rose.

  (** This is a nested inductive type we can measure assuming a
      [list_size] function for measuring lists. Here we use the usual
      guardedness check of %\Coq% that is able to unfold the
      definition of [list_size] to check that this definition is terminating. *)

  Equations size (r : rose) : nat :=
    size (node _ l) := S (list_size size l).

  (* begin hide *)
  Transparent size.
  Derive NoConfusion for rose.

  (* end hide *)
  Section Induction.
    Variable P : rose -> Prop.
    Hypothesis IH_NODE : forall n children, (forall u, In u children -> P u) -> P (node n children).

    Lemma rose_ind_strong : forall (t : rose), P t.
    Proof.
      fix IH 1.
      destruct t.
      apply IH_NODE.
      revert l.
      fix IHNODES 1. intros [|u children'].
      - intros. inversion H.
      - intros u' [<-|Hin].
        + apply IH.
        + eapply IHNODES. apply Hin.
    Qed.
  End Induction.

  Equations rose_eqb (r1 r2 : rose) : bool by wf (size r1) lt :=
    rose_eqb (node n1 []) (node n2 []) := Nat.eqb n1 n2;
    rose_eqb (node n1 (x :: xs)) (node n2 (y :: ys)) := rose_eqb (node n1 xs) (node n2 ys) && rose_eqb x y;
    rose_eqb _ _ := false.

  Lemma rose_eqb_refl : forall a, rose_eqb a a = true.
  Proof.
    induction a using rose_ind_strong.
    induction children; simp rose_eqb.
    - rewrite Nat.eqb_refl. reflexivity.
    - rewrite IHchildren. rewrite H; auto.
      + left. auto.
      + intros. apply H. right. auto.
  Qed.

  Lemma rose_eqb_n : forall l l' n n', rose_eqb (node n l) (node n' l') = true -> n = n'.
  Proof.
    induction l; intros; simp rose_eqb in H; try inversion H.
    2: {
      destruct l'. inversion H.
      simp rose_eqb in H. apply andb_prop in H. destruct H.
      eapply IHl; eauto.
    }
    destruct l'. simp rose_eqb in H. apply EqNat.beq_nat_true in H. auto.
    inversion H.
  Qed.

  Lemma rose_eqb_eq : forall a b, rose_eqb a b = true -> a = b.
  Proof.
    induction a using rose_ind_strong. induction children.
    - intros. destruct b. destruct l. 2: inversion H0.
      f_equal. apply rose_eqb_n in H0. auto.
    - intros. destruct b. destruct l. inversion H0.
      pose proof (rose_eqb_n _ _ _ _ H0). subst.
      simp rose_eqb in H0. f_equal.
      apply andb_prop in H0. destruct H0.
      f_equal.
      + apply H; auto. left. auto.
      + epose proof (IHchildren _).
        Unshelve.
        2: { intros. apply H; auto. right. auto. }
        specialize (H2 _ H0). inversion H2. auto.
  Qed.

  Lemma rose_eqb_spec : forall a b, reflect (a = b) (rose_eqb a b).
  Proof.
    intros. destruct (rose_eqb a b) eqn:?.
    - constructor 1. apply rose_eqb_eq; auto.
    - constructor 2. intro. subst. rewrite rose_eqb_refl in Heqb0. inversion Heqb0.
  Qed.

  Lemma rose_eq_dec : forall (a b : rose), {a = b} + {a <> b}.
  Proof.
    intros. apply (reflect_dec _ _ (rose_eqb_spec _ _)).
  Qed.

  Lemma rose_eqb_trans : forall a b c,
      rose_eqb a b = true ->
      rose_eqb b c = true ->
      rose_eqb a c = true.
  Proof.
    intros. apply rose_eqb_eq in H, H0. subst. apply rose_eqb_refl.
  Qed.

  Equations parent (r1 : rose) (r2 : rose) : bool by wf (size r2) lt :=
    parent r1 (node n l) := match find (rose_eqb r1) l with
                           | Some _ => true (* found directly at this level *)
                           | None => aux r1 l _ (* find at a lower level *)
                           end
  (* find in the lists in each [rose] in [l'] *)
  where aux r1' (l' : list rose) (H : list_size size l' < size (node _ l)) : bool
    by wf (list_size size l') lt :=
    aux _ nil _ := false;
    aux r1' (x :: xs) H := parent r1' x || aux r1' xs _.

  Goal parent (node 1 nil) (node 1 [node 1 [node 2 nil; node 1 nil]]) = true. auto. Qed.
  Goal parent (node 1 nil) (node 1 [node 1 [node 2 nil; node 3 nil]]) = false. auto. Qed.
  Goal parent (node 1 [node 2 nil; node 3 nil])
       (node 1 [node 1 [node 2 nil; node 3 nil]]) = true. auto. Qed.
  Goal parent (node 1 [node 2 nil])
       (node 1 [node 1 [node 2 nil; node 3 nil]]) = false. auto. Qed.

  Lemma parent_foo r n x xs :
    parent r (node n xs) = true ->
    parent r (node n (x :: xs)) = true.
  Proof.
    simp parent. simpl.
    intros. destruct (rose_eqb r x); auto. destruct (find (rose_eqb r) xs); auto.
    destruct xs; cbn in *. inversion H.

    cbn.
  Abort.

  (* todo: rewrite this with parent in last case, then try using parents_elim *)
  Lemma parent_cases r n x xs :
    parent r (node n (x :: xs)) = true ->
    (exists i, find (rose_eqb r) (x :: xs) = Some i) \/ parent r x = true \/
      parent_unfold_clause_1_aux r n (x :: xs) r xs
        (parent_obligations_obligation_3 n (x :: xs) x xs
           (parent_obligations_obligation_5 n (x :: xs))) = true.
  Proof.
    intros. simp parent in H.
    destruct (find (rose_eqb r) (x :: xs)) eqn:Hfind; auto.
    left. eexists. auto.
    right.
    apply orb_prop in H. destruct H.
    left; auto. right. auto.
  Qed.

  Lemma parent_trans (r1 r2 r3 : rose) :
    parent r1 r2 = true ->
    parent r2 r3 = true ->
    parent r1 r3 = true.
  Proof.
    revert r2.
    (* revert r1 r2 r3. *)
    eapply (parent_elim
              (fun r1 r2 b => forall r',
                   parent r1 r' = true ->
                   parent r' r2 = true ->
                   (* parent r1 r2 = b -> *)
                   b = true)
              (fun r1 n l r' l' H b => forall r'',
                   r1 = r' ->
                   parent r1 r'' = true ->
                   parent r'' (node n l') = true ->
                   match find (rose_eqb r1) l' with
                   | Some _ => true
                   | None => b
                   end = true
           )).
    - intros. eapply H; eauto.
    - intros. inversion H2.
    - clear r1 r3. intros. subst. unfold find. fold (find (rose_eqb r1') xs).
      destruct (rose_eqb r1' x) eqn:Heqb; auto.
      destruct (find (rose_eqb r1') xs) eqn:Hfind; auto.
      apply parent_cases in H4. destruct H4 as [? | [? | ?]].
      + destruct H2. unfold find in H2. fold (find (rose_eqb r'') xs) in H2.
        destruct (rose_eqb r'' x) eqn:?.
        * inversion H2. subst.
          rewrite <- (reflect_iff _ _ (rose_eqb_spec r'' x0)) in Heqb0. subst.
          rewrite H3. auto.
        * erewrite H1; eauto.
          rewrite orb_true_r. auto.
          simp parent. rewrite H2. auto.
      + erewrite H0; eauto.
      + erewrite H1; eauto. rewrite orb_true_r. auto.
        (* eapply parent_foo. *)
          (* simp parent in H4. rewrite H *)
      (* erewrite H1. admit. *)
      (* apply H2. *)

      (* simp parent in H3. unfold find in H3. fold (find (rose_eqb r'') xs) in H3. rewrite Hfind in H3. *)
  Admitted.

    (** As explained at the beginning of this section, however, if we want
      to program more complex recursions, or rearrange our terms
      slightly and freely perform dependent pattern-matching, the
      limited syntactic guardness check will quickly get in our way.

      Using a _nested_ [where] clause and the support of %\Equations% for
      well-founded recursion, we can define the following function
      gathering the elements in a rose tree efficiently: *)

  Equations elements (r : rose) (acc : list rose) : list rose by wf (size r) lt :=
  elements (node n l) acc := aux l _
    where aux x (H : list_size size x < size (node _ l)) : list rose by wf (list_size size x) lt :=
    aux nil _ := acc;
    aux (cons x xs) H := elements x (aux xs _).

  Definition elems r := elements r nil.

  (** The function is nesting a well-founded recursion inside
    another one, based on the measure of [rose] trees and lists ([MR R
    f] is a combinator for [λ x y, R (f x) (f y)]).  The termination
    of this definition is ensured solely by logical means, it does not
    require any syntactic check. Note that the auxiliary definition's
    type mentions the variable [l] bound by the enclosing
    pattern-matching, to pass around information on the size of
    arguments. Local [where] clauses allow just that.
    This kind of nested pattern-matching and well-founded recursion was not
    supported by previous definition packages for %\Coq% like
    %\textsc{Function}% or %\textsc{Program}%, and due to the required
    dependencies it is not supported by %\textsc{Isabelle}%'s
    %\texttt{Function}% package either (see %\cite{BoveKraussSozeau2011}% for
    a survey of the treatment of recursion in type-theory based tools). *)

  (** We can show that [elems] is actually computing the same thing as
      the naïve algorithm concatenating elements of each tree in each forest. *)

  Equations elements_spec (r : rose) : list rose :=
    elements_spec (node _ l) := concat (List.map elements_spec l).

  (** As [elements] takes an accumulator, we first have to prove a generalized
      lemma, typical of tail-recursive functions: *)

  Lemma elements_correct (r : rose) acc : elements r acc = elements_spec r ++ acc.
  Proof.
    apply (elements_elim (fun r acc f => f = elements_spec r ++ acc)
                         (fun n l acc x H r => r = concat (List.map elements_spec x) ++ acc));
      intros; simp elements_spec; simpl; trivial. now rewrite H1, H0, app_assoc. Qed.

  (** We apply the eliminator providing the predicate for the nested
      recursive call and simplify using the [simp elements_spec] tactic
      which is rewriting with the defining equations of [elements_spec].
      The induction hypotheses and associativity of concatenation are
      enough to solve the remaining goal which involves the two
      recursive calls to [elements] and [aux]. The above proof is very
      quick as the eliminator frees us from redoing all the nested
      recursive reasoning and the proofs that the induction hypotheses
      can be applied. It is now trivial to prove the correctness of our
      fast implementation: *)

  Lemma elems_correct (r : rose) : elems r = elements_spec r.
  (* begin hide *)
  Proof. now unfold elems; rewrite elements_correct, app_nil_r. Qed.
  (* end hide *)
(* begin hide *)
End RoseTree.
(* end hide *)


Require Import Vector.

Require Import MathClasses.interfaces.canonical_names.
Require Import MCInstances.
Require Import ackermannSteering.
Require Import MCMisc.tactics.
Require Import CartIR.
Require Import fastReals.interface.
Require Import fastReals.misc.
Require Import geometry2D.
Require Import geometry2DProps.
Require Import MathClasses.orders.rings.
Require Import MathClasses.interfaces.orders.
Require Import IRMisc.LegacyIRRing.
Hint Unfold One_instance_IR : IRMC.
Require Import CartIR2.

  Local Notation minxy := (lstart).
  Local Notation maxxy := (lend).
  Local Notation  "∫" := Cintegral.
  Local Notation ConfineRect := (Line2D).

Local Opaque CSine.
Local Opaque CCos.
Local Opaque Sine.
Local Opaque Cosine.
Local Opaque Sin.
Local Opaque Cos.
Local Opaque Min Max.

Require Import CoRN.metric2.Metric.
Require Import CRMisc.OldMetricAsNew.
Require Import MCMisc.rings.
Require Import MathClasses.theory.rings.

(* Move *)
  Lemma noSignChangeDuringWeaken: forall F a1 b1 a2 b2,
    noSignChangeDuring F a1 b1
    -> a1 ≤ a2
    -> b2 ≤ b1
    -> noSignChangeDuring F a2 b2.
  Proof using .
    intros ? ? ? ? ? Hn ? ?. destruct Hn as [Hn | Hn];[left|right];
      intros t Hb; apply Hn; destruct Hb; split; eauto 2 with CoRN.
  Qed.

Let rball : Qpos → IR → IR → Prop  :=
@ball (fromOldMetricTheory IR_as_CMetricSpace).

(*
  Lemma ss (x: Cart2D IR) : x ≤ x.
  Lemma ss (x: Rigid2DState IR) : x ≤ x. *)

  Definition turnRigidStateAtθ (init : Rigid2DState IR)
  (tr θ : IR)
  :=
  let θi := θ2D init in
  {|pos2D := pos2D init + {|X:=Sin θ - Sin θi; Y:=Cos θi - Cos θ|}*'tr;
    θ2D := θ|}.

  Global Instance ProperturnRigidStateAtθ: Proper
  (equiv ==> equiv ==> equiv ==> equiv) turnRigidStateAtθ.
  Proof using.
    intros ? ? H1 ? ? H2 ? ? H3.
    unfold turnRigidStateAtθ.
    rewrite H1.
    rewrite H2.
    rewrite H3. reflexivity.
  Qed.

  Definition turnRigidStateAtDist (init : Rigid2DState IR)
  (tc: NonZeroT IR) (d : IR) :
    Rigid2DState IR
  :=
  let tr :IR := recip1T tc in
  let θi := θ2D init in
  let θ :IR := θi + (projT1 tc)*d in
  turnRigidStateAtθ init tr θ.

  Definition stateDuringIdealTurn (tc: NonZeroT IR)
    (dist : IR) (init s : Rigid2DState IR) : Prop :=
    let θi := θ2D init in
    let tr :IR := recip1T tc in
    exists θ, inBetweenR θ θi (θi + (projT1 tc) * dist) /\
    s = turnRigidStateAtθ init tr θ.

Section Car.
Add Ring TContRisaRing: (stdlib_ring_theory TContR).

  Context  {maxTurnCurvature : Qpos}
   (acs : AckermannCar maxTurnCurvature).
  Section Turn.
  Variable tstart : Time.
  Variable tend : Time.
  Hypothesis timeInc : (tstart ≤ tend).

  Let dist := ∫ (mkIntBnd timeInc) (linVel acs).
  Let adist := ∫ (mkIntBnd timeInc) (CFAbs (linVel acs)).

  Lemma noChangeAbs:
  noSignChangeDuring (linVel acs) tstart tend
  -> adist = AbsIR dist.
  Proof using.
    intros.
    unfold adist, dist.
    rewrite noSignChangeAbsOfIntegral; auto.
  Qed.

  Variable tc : IR.

  Variable tcErr : IR.
(*  One step at a time .. will worry about it later.
 Variable distErr : IR. *)

  (** assume that the steering wheel is already in the right position *)
  Definition steeringAlmostFixed :=
    (∀ (t:Time), (tstart ≤ t ≤ tend)
          ->  AbsSmall tcErr (({turnCurvature acs} t) - tc)).
  (** Another useful version of the lemma could consider 2 different runs of the car
      for the same duration of the time. Both the controls (steering wheel and linVel)
      differ by atmost epsilon at all corresponding times.

      The version in this file assumes nothing about how linVel evolves,
      except that it doesnt change sign. But it assumes that steering wheel is held
      nearly constant.
      So neither of these versions is more
      general than the other.
   *)

  Hypothesis amec: steeringAlmostFixed.

(*
Local Opaque Time.
    destruct acs. simpl in *.
Local Transparent Time.

*)

(* Move *)
Lemma prodConj : forall (A B : Prop), (prod A B) ↔ (A ∧ B).
Proof using.
  intros. tauto.
Qed.

(* cant use TDerivativeAbs because the time difference is unbounded *)
  Lemma thetaBall :
    AbsSmall
      (| tcErr * adist|)
      ({theta acs} tend - {theta acs} tstart - tc*dist) .
  Proof using timeInc amec.
    setoid_rewrite <- TBarrow with (p:=timeInc);[| apply derivRot].
    set (per  := (ContConstFun _ _ tc): TContR).
    assert (turnCurvature acs = (per + (turnCurvature acs - per))) as Heq by ring.
    rewrite Heq. clear Heq.
    rewrite plus_mult_distr_l.
    setoid_rewrite mult_comm at 2.
    setoid_rewrite CIntegral_plus. unfold per.
    unfold mult at 2. unfold Mult_instance_TContR.
    rewrite CIntegral_scale.
    fold dist.
    setoid_rewrite <- PlusShuffle3l.
    rewrite plus_negate_r, plus_0_r.
    apply AbsIR_imp_AbsSmall.
    rewrite AbsOfIntegral.
    setoid_rewrite CFAbs_resp_mult.
    rewrite IntegralMonotone with
        (G:= (ContConstFun (closel [0]) I (AbsIR (tcErr)))*(CFAbs (linVel acs))).
  - setoid_rewrite CIntegral_scale.
    setoid_rewrite AbsIR_resp_mult.
    rewrite (AbsIR_eq_x adist);[reflexivity|].
    apply DerivNonNegIntegral.
    intros ? ?. rewrite CFAbsAp. apply AbsIR_nonneg.
  - intros ? Hb.
    rewrite mult_comm.
    unfold mult, Mult_instance_TContR, negate, Negate_instance_TContR, plus, Plus_instance_TContR.
    autorewrite with IContRApDown.
    apply mult_resp_leEq_lft;[| apply AbsIR_nonneg].
    simpl in Hb.
    apply prodConj in Hb.
    rewrite leEq_imp_Min_is_lft in Hb by assumption.
    rewrite leEq_imp_Max_is_rht in Hb by assumption.
    apply amec in Hb.
    apply AbsSmall_imp_AbsIR in Hb.
    eapply transitivity; eauto using leEq_AbsIR.
  Qed.

  Hypothesis tcNZ : (tc [#] 0).

  Local Notation turnRadius  (* :IR *) := (f_rcpcl tc tcNZ).

  (** [X] coordinate of the [position] at a given time. Note that in CoRN,
      division is a ternary operator. [a[/]b[//][bp]] denotes the real number [a]
      divided by the non-zero real number [b], where [bp] is the proof of non-zero-hood
      of [b].

    Note that the error scales linearly with turn radius.
    So this is not a good characterization
    for driving (nearly) straight.
   *)
  Lemma fixedSteeeringX :
    let ideal := ((Sin ({theta acs} tend) - Sin ({theta acs} tstart)) [/] tc [//] tcNZ) in
    AbsSmall
        (|tcErr * adist [/] tc [//] tcNZ|)
        (({X (position acs)} tend - {X (position acs)} tstart) - ideal).
  Proof using timeInc amec.
    simpl.
    setoid_rewrite <- TBarrow with (p:= timeInc);[| apply (derivX acs)].
    pose proof (@TContRDerivativeSin _ _ _ _ (derivRot acs)) as X.
    apply AbsIR_imp_AbsSmall.
    apply mult_cancel_leEq with (z:= (AbsIR tc));[apply AbsIR_pos; assumption | ].
    rewrite <- AbsIR_resp_mult.
    setoid_rewrite <- AbsIR_resp_mult.
    setoid_rewrite ring_distr2.
    setoid_rewrite div_1.
    rewrite (@mult_commut_unfolded IR).
    rewrite <- CIntegral_scale.
    set (per  := (ContConstFun _ _ tc): TContR).
    assert (per = (turnCurvature acs + (per - turnCurvature acs))) as Heq by ring.
    rewrite Heq. clear Heq.
    setoid_rewrite plus_mult_distr_r.
    setoid_rewrite CIntegral_plus.
    rewrite MultShuffle3l.
    rewrite mult_comm.
    rewrite TBarrow;[| apply X]. fold (CFSine (theta acs)).
    rewrite CFSineAp, CFSineAp.
    setoid_rewrite <- PlusShuffle3l.
    setoid_rewrite plus_negate_r. rewrite plus_0_r.

    (* now only the error term is left *)
    rewrite AbsOfIntegral.
    setoid_rewrite CFAbs_resp_mult.
    unfold mult, Mult_instance_TContR, Mult_instance_IR.
    rewrite CFAbs_resp_mult.
    rewrite IntegralMonotone with
        (G:= (ContConstFun (closel [0]) I (AbsIR (tcErr)))*(CFAbs (linVel acs))).
  - setoid_rewrite CIntegral_scale.
    setoid_rewrite AbsIR_resp_mult.
    rewrite (AbsIR_eq_x adist);[reflexivity|].
    apply DerivNonNegIntegral.
    intros ? ?. rewrite CFAbsAp. apply AbsIR_nonneg.
  - intros ? Hb.
    rewrite mult_comm.
    unfold mult, Mult_instance_TContR, negate, Negate_instance_TContR, plus, Plus_instance_TContR.
    subst per.
    autorewrite with IContRApDown.
    setoid_rewrite MultShuffle3l.
    rewrite <- (@mult_assoc IR) by (eauto with typeclass_instances).
    apply mult_resp_leEq_lft;[| apply AbsIR_nonneg].
    simpl in Hb.
    apply prodConj in Hb.
    rewrite leEq_imp_Min_is_lft in Hb by assumption.
    rewrite leEq_imp_Max_is_rht in Hb by assumption.
    apply amec in Hb.
    apply AbsSmall_imp_AbsIR in Hb.
    setoid_rewrite AbsIR_minus.
    rewrite (leEq_AbsIR tcErr) in Hb.
    rewrite <- (mult_1_r (AbsIR tcErr)).
    apply mult_resp_leEq_both;
      try apply AbsIR_nonneg; auto;[].
    apply AbsIR_Cos_leEq_One.
  Qed.

  Lemma fixedSteeeringY :
    let ideal := ((Cos ({theta acs} tstart) - Cos ({theta acs} tend)) [/] tc [//] tcNZ) in
    AbsSmall
        (|tcErr * adist [/] tc [//] tcNZ|)
        (({Y (position acs)} tend - {Y (position acs)} tstart) - ideal).
  Proof using  timeInc amec.
    simpl.
    setoid_rewrite <- TBarrow with (p:= timeInc);[| apply (derivY acs)].
    pose proof (@IContRDerivativeCos _ _ _ _ (derivRot acs)) as X.
  SearchAbout AbsSmall cr_mult.
    apply AbsIR_imp_AbsSmall.
    apply mult_cancel_leEq with (z:= (AbsIR (tc)));[apply AbsIR_pos; assumption | ].
    rewrite (AbsIR_inv tc) at 1.
    rewrite <- AbsIR_resp_mult.
    setoid_rewrite <- AbsIR_resp_mult.
    setoid_rewrite ring_distr2. unfold cg_minus.
    rewrite <- cring_inv_mult_lft.
    setoid_rewrite (@negate_involutive IR);[| eauto with typeclass_instances].
    rewrite div_1.
    setoid_rewrite div_1.
    rewrite cring_inv_mult_lft.
    rewrite <- cring_inv_mult_rht.
    unfold FSin.
    rewrite (@mult_commut_unfolded IR).
    rewrite <- CIntegral_opp.
    setoid_rewrite <-cring_inv_mult_lft.
    rewrite <- CIntegral_scale.
    set (per  := (ContConstFun _ _ tc): TContR).
    rewrite <- CartIR2.composeIContRNegate.
    assert (per = (turnCurvature acs + (per - turnCurvature acs))) as Heq by ring.
    rewrite Heq. clear Heq.
    setoid_rewrite plus_mult_distr_r.
    setoid_rewrite CIntegral_plus.
    setoid_rewrite MultShuffle3l.
    rewrite mult_comm.
    rewrite TBarrow; [| apply X]. fold (CFCos (theta acs)).
    do 2 rewrite CFCosAp.
    setoid_rewrite <- PlusShuffle3l.
    rewrite (@negate_swap_r IR _ _ _ _ _ _ _ _) at 1.
    setoid_rewrite plus_negate_r. rewrite plus_0_r.

    (* now only the error term is left *)
    rewrite AbsOfIntegral.
    setoid_rewrite CFAbs_resp_mult.
    change ((linVel acs * (per - turnCurvature acs)))
      with ( (linVel acs [*] (per - turnCurvature acs))).
    rewrite CFAbs_resp_mult.
    rewrite IntegralMonotone with
        (G:= (ContConstFun (closel [0]) I (AbsIR (tcErr)))*(CFAbs (linVel acs))).
  - setoid_rewrite CIntegral_scale.
    setoid_rewrite AbsIR_resp_mult.
    rewrite (AbsIR_eq_x adist);[reflexivity|].
    apply DerivNonNegIntegral.
    intros ? ?. rewrite CFAbsAp. apply AbsIR_nonneg.
  - intros ? Hb.
    rewrite mult_comm.
    unfold mult, Mult_instance_TContR, negate, Negate_instance_TContR, plus, Plus_instance_TContR.
    subst per.
    autorewrite with IContRApDown.
    rewrite <- (@mult_assoc_unfolded IR).
    apply mult_resp_leEq_lft;[| apply AbsIR_nonneg].
    simpl in Hb.
    apply prodConj in Hb.
    rewrite leEq_imp_Min_is_lft in Hb by assumption.
    rewrite leEq_imp_Max_is_rht in Hb by assumption.
    apply amec in Hb.
    apply AbsSmall_imp_AbsIR in Hb.
    setoid_rewrite AbsIR_minus in Hb.
    rewrite (leEq_AbsIR tcErr) in Hb.
    rewrite <- (mult_1_r (AbsIR tcErr)).
    apply mult_resp_leEq_both;
      try apply AbsIR_nonneg; auto;[].
    rewrite CartIR2.composeIContRNegate.
    fold (CFCos (theta acs)).
    autorewrite with IContRApDown.
    rewrite <- AbsIR_inv.
    fold (CFSine (theta acs)).
    setoid_rewrite CFSineAp.
    apply AbsIR_Sin_leEq_One.
  Qed.

(*
Typeclasses eauto :=4.
  Lemma fixedSteeeringTurn :
  let rs:= rigidStateAtTime acs in
  let tcc := (existT _ tc tcNZ) in
    pNorm (rs tend -
            (turnRigidStateAtDist (rs tstart) tcc dist))
    ≤ {| pos2D := '(|tcErr * adist [/] tc [//] tcNZ|); θ2D := (| tcErr * adist|)|}.
  Proof.
    unfold turnRigidStateAtDist, recipT, RecipTIR.
    simpl. split;  simpl;[split;simpl|]; apply AbsSmall_imp_AbsIR.
  - Fail apply fixedSteeeringX. admit.
  - rewrite negate_plus_distr.
    setoid_rewrite (@simple_associativity IR _ plus _ _ _ _).
Fail apply fixedSteeeringY.

Doesn't work!! Now, angle at tend is not known exactly. So turnRigidStateAtDist
doesn't work. use turnRigidStateAtθ instead.

  - rewrite negate_plus_distr.
    setoid_rewrite (@simple_associativity IR _ plus _ _ _ _).
    apply thetaBall.
Qed.
*)

  Definition turnErr  (adist tr:IR) : Rigid2DState IR :=
{| pos2D := '(|tcErr * adist * tr |); θ2D := (| tcErr * adist|)|}.

  Lemma fixedSteeeringTurn :
  let rs:= rigidStateAtTime acs in
    pNorm (rs tend -
            (turnRigidStateAtθ (rs tstart) turnRadius ({theta acs} tend)))
    ≤ turnErr adist turnRadius.
  Proof.
    unfold turnRigidStateAtDist, recipT, RecipTIR.
    simpl. split;  simpl;[split;simpl|]; apply AbsSmall_imp_AbsIR; simpl;
    try (rewrite negate_plus_distr;
    setoid_rewrite (@simple_associativity IR _ plus _ _ _ _));
    try apply fixedSteeeringX;
    try apply fixedSteeeringY;[].
    rewrite plus_negate_r.
    apply zero_AbsSmall. apply AbsIR_nonneg.
  Qed.

  End Turn.

  Section TurnIntermediate.
  Variable tstart : Time.
  Variable tend : Time.
  Hypothesis timeInc : (tstart ≤ tend).
  Variable tcc: NonZeroT IR.
  Let tr : IR := recip1T tcc.
  Variable tcErr : IR.

  Let tc :IR := projT1 tcc.

  (* All possible states in the trajectory satisfy this
    predicate (see [possibleStateDuringTurnCorrect]). So
    if this predicate implies some safety condition, that condition must hold.
    Furthermore, this condition only depends on its formal arguments and
    the section variable [tcc]. In particular, it does not depend on how
    [linVel] evolved.
    Assuming the intermediate value theorem, this may be be a necessary condition
  *)
  Definition possibleStateDuringTurn
    (dis : IR) (init s : Rigid2DState IR) : Type :=
    let θi := θ2D init in
    let θs := θ2D s in
    sigT (fun d => inBetweenR d 0 dis ∧
    pNorm (s - (turnRigidStateAtθ init tr θs))
    ≤ turnErr tcErr (|d|) tr).

  Hypothesis nsc : noSignChangeDuring (linVel acs) tstart tend.
  Let dist := ∫ (mkIntBnd timeInc) (linVel acs).
  Let adist := ∫ (mkIntBnd timeInc) (CFAbs (linVel acs)).
  Let init := (rigidStateAtTime acs tstart).

  Hypothesis amec: steeringAlmostFixed tstart tend tc tcErr.

  Lemma possibleStateDuringTurnCorrect :
   ∀ t : Time, tstart ≤ t ≤ tend →
     possibleStateDuringTurn dist init (rigidStateAtTime acs t).
  Proof using nsc amec.
    intros ? Hb.
    unfold possibleStateDuringTurn. simpl.
    exists (∫ (mkIntBnd (proj1 Hb)) (linVel acs)).
    subst dist.
    split; [apply nosignChangeInBwInt; tauto | ].
    eapply noSignChangeDuringWeaken with (a2:=tstart) (b2:=t) in nsc;
      eauto with relations; try tauto.
    unfold turnErr.
    setoid_rewrite <- noChangeAbs; auto.
    apply fixedSteeeringTurn.
    intros ? Hbb.
    apply amec. repnd. eauto with relations.
  Qed.

  (* for every point (state) in the trajectory, there is a point in the ideal trajectory
    that is not too far
  Lemma possibleStateErrIdeal : ∀ s
   (p : possibleStateDuringTurn dist init s),
   sigT  (fun si =>  stateDuringIdealTurn tcc dist init si
      ∧ pNorm (s-si) ≤ (turnErr tcErr (|projT1 p|) tr)).

(* we know that [(|projT1 p|) ≤ (|dist|)] *)

  Proof using.
    intros ? ?. destruct p. simpl in *.
    repnd.
  Abort.
*)

(*
  Lemma holdsDuringAMIf : forall(P: (Rigid2DState IR) -> Prop)
    `{@Setoid_Morphism  _ _ _ _ P},
    (∀ θe, AbsSmall (| tcErr * adist|)  (θe - (θs + tc*dist)) (* remove this quantif to get 1 range *)
        ->
       ∀ (θ : IR), inBetweenR θ θs θe
      -> P (turnRigidStateAtθ (rigidStateAtTime acs tstart) turnRadius θ))
     ->  (∀ t : Time, tstart ≤ t ≤ tend → P (rigidStateAtTime acs t)).
  Abort.
*)

  End TurnIntermediate.

(* we need the intermediate values of theta. Unless we end the section
  and force generalization, we only have [theta] for [tend]. *)

  Section Straight.
  Variable tstart : Time.
  Variable tend : Time.
  Hypothesis timeInc : (tstart ≤ tend).

  Let dist := ∫ (mkIntBnd timeInc) (linVel acs).
  Let adist := ∫ (mkIntBnd timeInc) (CFAbs (linVel acs)).

  Variable tcErr : IR.
(*  One step at a time .. will worry about it later.
 Variable distErr : IR. *)

  Hypothesis amec: steeringAlmostFixed tstart tend 0 tcErr.

  Local Opaque Half.

  Lemma thetaBallInter (r:Time)  (Hb : tstart [<=] r ∧ r [<=] tend):
    AbsIR ({theta acs} r - {theta acs} tstart)
    [<=] AbsIR (tcErr [*] adist).
  Proof.
    pose proof (thetaBall _ _ (proj1 Hb) 0 tcErr) as Ht.
    rewrite mult_0_l, minus_0_r in Ht.
    (* tc=0 was not used above. *)
    lapply Ht;
     [ | intros ? ?; apply amec; split; try tauto;
         repnd; eapply transitivity; eauto].
    clear Ht. intro Ht.
    apply AbsSmall_imp_AbsIR in Ht.
    eapply transitivity; eauto.
    setoid_rewrite AbsIR_resp_mult.
    apply mult_resp_leEq_lft;[| apply AbsIR_nonneg].
    unfold adist.
    do 2 (rewrite AbsIR_eq_x;
      [| apply DerivNonNegIntegral;
         intros ? ?; rewrite CFAbsAp; apply AbsIR_nonneg]).
    rewrite CintegralSplit with (pl := (proj1 Hb)) (pr := (proj2 Hb)).
    apply RingLeProp1l.
    apply DerivNonNegIntegral;
         intros ? ?; rewrite CFAbsAp; apply AbsIR_nonneg.
  Qed.

(* this lemma is different from the work in iCreate beause here there
   is no dependence on the duration of motion. there, there was a dependence.
  There, the linear velocity was nearly constant. Here we are making
  no such assumption *)

  Lemma AtomicMoveZX :
    let ideal := (∫ (mkIntBnd timeInc) (linVel acs)) * (Cos ({theta acs} tstart))  in
    AbsSmall ( (|tcErr|) * sqr (adist))
      ({X (position acs)} tend - {X (position acs)} tstart
        - ideal).
  Proof using amec.
    simpl. remember ((| tcErr |) * sqr adist) as errb.
    rewrite mult_comm.
    setoid_rewrite <- TBarrow with (p := timeInc);
      [| apply derivX].
    set (per := (ContConstFun _ _ (Cos ({theta acs} tstart))):TContR).
    set (fc:=FCos (theta acs):TContR).
    assert (fc  = fc - per + per) as Heq by ring.
    rewrite Heq. clear Heq.
    rewrite plus_mult_distr_l.
    setoid_rewrite mult_comm at 2.
    setoid_rewrite CIntegral_plus. unfold per.
    unfold mult at 2. unfold Mult_instance_TContR.
    rewrite CIntegral_scale.
    fold dist.
    setoid_rewrite RingProp2.
  (* now only the error term is left *)
    apply AbsIR_imp_AbsSmall.
    rewrite AbsOfIntegral.
    setoid_rewrite CFAbs_resp_mult.
    rewrite IntegralMonotone with
        (G:= (ContConstFun (closel [0]) I (AbsIR (tcErr * adist)))
              * (CFAbs (linVel acs))).
  - setoid_rewrite CIntegral_scale. fold adist.
    subst errb. apply eq_imp_leEq.
    setoid_rewrite AbsIR_resp_mult.
    unfold sqr, norm, NormSpace_instance_IR.
    rewrite (AbsIR_eq_x adist);[IRring|].
    apply DerivNonNegIntegral.
    intros ? ?. rewrite CFAbsAp. apply AbsIR_nonneg.
  - intros ? Hb.
    rewrite mult_comm.
    unfold fc.
    unfold mult, Mult_instance_TContR, negate, Negate_instance_TContR,
      plus, Plus_instance_TContR, Mult_instance_IR.
    autorewrite with IContRApDown.
    remember (tcErr [*] adist) as rhs.
    apply mult_resp_leEq_lft;[| apply AbsIR_nonneg].
    simpl in Hb.
    apply prodConj in Hb.
    rewrite leEq_imp_Min_is_lft in Hb by assumption.
    rewrite leEq_imp_Max_is_rht in Hb by assumption.
    setoid_rewrite minus_cos.
    do 1 setoid_rewrite AbsIR_resp_mult.
    rewrite <- (mult_1_r (AbsIR rhs)).
    apply mult_resp_leEq_both;
      try apply AbsIR_nonneg; auto;[| apply AbsIR_Sin_leEq_One].
    do 1 setoid_rewrite AbsIR_resp_mult.
    setoid_rewrite <- AbsIR_inv.
    eapply transitivity;
      [apply mult_resp_leEq_lft;[apply sineAbsXLe| apply AbsIR_nonneg] | ].
    do 1 setoid_rewrite AbsIR_resp_mult.
    rewrite AbsIR_eq_x;[| apply less_leEq, pos_two].
    rewrite AbsIR_eq_x;[| apply less_leEq, pos_half].
    rewrite mult_assoc_unfolded.
    setoid_rewrite mult_commut_unfolded at 2.
    rewrite half_1. setoid_rewrite mult_1_l.
    subst rhs.
    apply thetaBallInter. assumption.
  Qed.

  Lemma AtomicMoveZY :
    let ideal := (∫ (mkIntBnd timeInc) (linVel acs))
                  * (Sin ({theta acs} tstart))  in
    AbsSmall ( (|tcErr|) * sqr (adist))
      ({Y (position acs)} tend - {Y (position acs)} tstart
        - ideal).
  Proof using amec.
    simpl. remember ((| tcErr |) * sqr adist) as errb.
    rewrite mult_comm.
    setoid_rewrite <- TBarrow with (p := timeInc);
      [| apply derivY].
    set (per := (ContConstFun _ _ (Sin ({theta acs} tstart))):TContR).
    set (fc:=FSin (theta acs):TContR).
    assert (fc  = fc - per + per) as Heq by ring.
    rewrite Heq. clear Heq.
    rewrite plus_mult_distr_l.
    setoid_rewrite mult_comm at 2.
    setoid_rewrite CIntegral_plus. unfold per.
    unfold mult at 2. unfold Mult_instance_TContR.
    rewrite CIntegral_scale.
    fold dist.
    setoid_rewrite RingProp2.
  (* now only the error term is left *)
    apply AbsIR_imp_AbsSmall.
    rewrite AbsOfIntegral.
    setoid_rewrite CFAbs_resp_mult.
    rewrite IntegralMonotone with
        (G:= (ContConstFun (closel [0]) I (AbsIR (tcErr * adist)))
              * (CFAbs (linVel acs))).
  - setoid_rewrite CIntegral_scale. fold adist.
    subst errb. apply eq_imp_leEq.
    setoid_rewrite AbsIR_resp_mult. unfold sqr, norm, NormSpace_instance_IR.
    rewrite (AbsIR_eq_x adist);[IRring|].
    apply DerivNonNegIntegral.
    intros ? ?. rewrite CFAbsAp. apply AbsIR_nonneg.
  - intros ? Hb.
    rewrite mult_comm.
    unfold fc.
    unfold mult, Mult_instance_TContR, negate, Negate_instance_TContR,
      plus, Plus_instance_TContR, Mult_instance_IR.
    autorewrite with IContRApDown.
    remember (tcErr [*] adist) as rhs.
    apply mult_resp_leEq_lft;[| apply AbsIR_nonneg].
    simpl in Hb.
    apply prodConj in Hb.
    rewrite leEq_imp_Min_is_lft in Hb by assumption.
    rewrite leEq_imp_Max_is_rht in Hb by assumption.
    setoid_rewrite minus_sin.
    do 1 setoid_rewrite AbsIR_resp_mult.
    rewrite <- (mult_1_r (AbsIR rhs)).
    apply mult_resp_leEq_both;
      try apply AbsIR_nonneg; auto;[| apply AbsIR_Cos_leEq_One].
    do 1 setoid_rewrite AbsIR_resp_mult.
    eapply transitivity;
      [apply mult_resp_leEq_lft;[apply sineAbsXLe| apply AbsIR_nonneg] | ].
    do 1 setoid_rewrite AbsIR_resp_mult.
    rewrite AbsIR_eq_x;[| apply less_leEq, pos_two].
    rewrite AbsIR_eq_x;[| apply less_leEq, pos_half].
    rewrite mult_assoc_unfolded.
    setoid_rewrite mult_commut_unfolded at 2.
    rewrite half_1. setoid_rewrite mult_1_l.
    subst rhs.
    apply thetaBallInter. assumption.
  Qed.

End Straight.

End Car.