Require Import Classical_Prop Classical_Pred_Type.
Require Import IndefiniteDescription ChoiceFacts.
From mathcomp
Require Import ssreflect ssrbool.
From Topology
Require Import MetricSpaces SubspaceTopology
ContinuousFactorization Homeomorphisms Compactness.

(******** eqProp *******)
Lemma cddo : forall T : Type, ConstructiveDefiniteDescription_on T.
Proof.
move=>T P E1xTPx.
apply: (constructive_indefinite_description _).
case : E1xTPx => x [hPx Ax'Px_xx'].
  by exists x.
Qed.

Lemma eqProp : forall P : Prop, {P} + {~P}.
Proof.
apply: (constructive_definite_descr_excluded_middle cddo) => P.
exact: (classic P).
Qed.

(********************)
Open Scope R_scope.

Module Cellularity.
  Variable X Y : TopologicalSpace.

  Definition top_to_type (T : TopologicalSpace) : Type := point_set T.

  Local Coercion top_to_type : TopologicalSpace >-> Sortclass.
(*** Preliminary Lemmas ***)
  Lemma Im_compat_Included {U V : Type} (A B : Ensemble U) (f : U -> V) :
    Included A B -> Included (Im A f) (Im B f).
  Proof.
    move => IncAB y InImAfy.
    have [x [InAx fx_y]] : exists x : U, In A x /\ f x = y by apply Im_inv in InImAfy.
    have InBx : In B x by apply (IncAB x).
      by apply (Im_intro _ _ B f x).
  Qed.

  Lemma ponnq_poq (p q : Prop) : p \/ (~ ~ q) -> p \/ q.
  Proof.
  case=> H.
    by apply: or_introl.
  apply NNPP in H.
    by apply or_intror.
  Qed.

  Lemma id_homeo : homeomorphism (fun x : X => x).
  Proof.
    exists (fun x : X => x).
    apply continuous_identity.
    apply continuous_identity.
    trivial.
    trivial.
  Qed.

  Lemma homeo_is_bijective : forall {Xt Yt : TopologicalSpace} (f : Xt -> Yt),
                       homeomorphism f -> bijective f.
  Proof.
  move=>X Y f [g _ _ gf_I fg_I].
  split.
  move => x1 x2 fx1fx2.
  have gfx1_gfx2 : g (f x1) = g (f x2) by rewrite fx1fx2.
   by repeat rewrite gf_I in gfx1_gfx2.
   move=>y.
   exists (g y).
     by apply fg_I.
  Qed.

  Lemma Im_Complement_comm_for_bijection : forall {A B : Type} (f : A -> B) (D : Ensemble A),
       bijective f -> Complement (Im D f) = Im (Complement D) f.

  Proof.
  move => A B f D f_bij.
  case : f_bij => f_inj f_surj.
  apply Extensionality_Ensembles.
  split.
  move=> y InCfDy.
  Print surjective.
  have [x fx_y] : exists x : A, f x = y by apply (f_surj y).
  rewrite  -fx_y.
  suff InCDx : In (Complement D) x by apply (Im_intro _ _ (Complement D) f x InCDx).
  move=> InDx.
  have InfDy : In (Im D f) y.
  rewrite -fx_y.
    by apply (Im_intro _ _ D f x InDx).
  by apply (InCfDy InfDy).
  move => x InfCDx.
  case : InfCDx => x0 InCDx0 y y_fx0 InfDy.
  destruct InfDy as [x1 InDx1 y1].
  rewrite H in y_fx0.
  have x1_x0 : x1 = x0 by apply (f_inj _ _ y_fx0).
  rewrite x1_x0 in InDx1.
    by apply (InCDx0 InDx1).
  Qed.

  Lemma homeo_maps_closed_to_closed :
    forall {X1 Y1 : TopologicalSpace} (h : X1 -> Y1) (F : Ensemble X1),
      homeomorphism h -> closed F -> closed (Im F h).
  Proof.
    move=> X1 Y1 h F h_homeo F_closed.
    red.
    rewrite Im_Complement_comm_for_bijection.
    by apply homeomorphism_is_open_map.
      by apply homeo_is_bijective.
  Qed.

  (*** End Preliminary Lemmas ***)

  (*** We use the following form of Axiom of Choice ****)
Axiom FDC : FunctionalDependentChoice_on ({h : X -> X | homeomorphism h} * nat).
(******)

Definition abstract_cell (D : Ensemble X) : Prop :=
  Inhabited (interior D) /\ closed D /\
  forall (x : X) (U : Ensemble X), open U -> In U x -> Included U D ->
      exists h : X -> X, homeomorphism h /\ h x = x /\
         Included (Im D h) U /\
         (forall y : X, In (Complement D) y -> h y = y).

(** homeo_image of abstract_cell is abstract_cell **)
(** i.e., abstract_cell is invariant under ambient homeomorphism **)

Lemma homeo_image_abstract_cell (D : Ensemble X) (h : X -> X) :
  abstract_cell D -> homeomorphism h -> abstract_cell (Im D h).
Proof.
  move=> [IniD [D_closed D_acell]] h_homeo.
    case : IniD => x IniDx. case : IniDx => U0 x0 HU0 InU0x0.
    case : HU0 => HU0. move: HU0 => [U0_open IncU0D]. split.
exists (h x0).
exists (Im U0 h).
constructor; split.
apply homeomorphism_is_open_map.
assumption.
assumption.
move=>x1 InImU0x1.
case:InImU0x1 => x2 InU0x2 y y_hx2.
exists x2.
  by apply IncU0D.
  assumption.
    by apply (Im_intro _ _ U0 h x0 InU0x0).
    split.
by apply homeo_maps_closed_to_closed.
move=>x1 U U_open InUx1 IncUImDh.
case : h_homeo=>[g] h_conti g_conti gh_I hg_I.
have gU_open : open (Im U g).
apply homeomorphism_is_open_map.
apply: (intro_homeomorphism _ h g_conti h_conti  hg_I gh_I).
assumption.
have IngUgx1 : In (Im U g) (g x1) by apply (@Im_intro X X U g x1 InUx1).
have IncgUD : Included (Im U g) D .
move=>z InImUgz. case : InImUgz =>x2 InUx2 w w_gx2. rewrite w_gx2.
have InhDx2 : In (Im D h) x2 by apply IncUImDh.
case : InhDx2 => x3 InDx3 y1 y1_x3. rewrite y1_x3.
by rewrite  gh_I.
have [h1 [h1_homeo [h1gx1_gx1 [IncIDh1IUg HCompl]]]] :
  exists h1 : X -> X, homeomorphism h1 /\ h1 (g x1) = (g x1) /\ Included (Im D h1) (Im U g) /\
  (forall y : X, In (Complement D) y -> h1 y = y)  by apply  (D_acell (g x1) (Im U g) gU_open IngUgx1 IncgUD).
pose h0 := fun (x : X) => h (h1 (g x)).
exists h0.
case h1_homeo => [g1] h1_conti g1_conti g1h1_I h1g1_I.
split.
pose g0 := fun (x:X) => h (g1 (g x)).
have g0_conti : continuous g0.
apply continuous_composition.
rewrite/g0.
apply continuous_composition.
assumption.
by apply continuous_composition.
apply continuous_identity.
have h0_conti : continuous h0.
rewrite/h0.
apply continuous_composition.
assumption.
apply continuous_composition.
assumption.
assumption.
have h0g0_I : forall x : X, h0 (g0 x) = x.
rewrite/h0 /g0.
move=> x2.
by rewrite gh_I h1g1_I hg_I.
have g0h0_I : forall x : X, g0 (h0 x) = x.
rewrite/h0 /g0.
move=> x2.
by rewrite gh_I g1h1_I hg_I.
by apply: (intro_homeomorphism _ g0 h0_conti g0_conti  g0h0_I h0g0_I).
split.
by rewrite/h0 h1gx1_gx1 hg_I.
split.
move=>w Inh0hDw.
case : Inh0hDw  => x2 InhDx2 y y_h0x2.
rewrite y_h0x2 /h0; clear w.
have  IngUh1gx2 : In (Im U g) (h1 (g x2)).
case: InhDx2=> x3 InDx3 y0 y0_hx3.
rewrite y0_hx3 gh_I; clear y0_hx3 y0  y_h0x2 x2 y.
apply IncIDh1IUg.
by exists x3.
case : IngUh1gx2 => x4 InUx4 w w_gx4.
by rewrite w_gx4  hg_I.
move=>y InChDy.
rewrite/ h0.
have InCDgy : In (Complement D) (g y).
suff Dgy_hDy : D (g y) -> (Im D h) y.
move=> Dgy.
repeat red in InChDy.
apply InChDy.
by apply Dgy_hDy.
move=>Dgy.
  by exists (g y).
have h1gy_gy : h1 (g y) = (g y) by apply (HCompl (g y) InCDgy).
by rewrite h1gy_gy  hg_I.
Qed.

Definition abstract_cellular (K : Ensemble X) : Prop :=
  exists D : IndexedFamily nat X,
    (forall n : nat, abstract_cell (D n) /\  Included (D (S n)) (interior (D n)) ) /\
    IndexedIntersection D = K.

Definition point_cellular (D : Ensemble X)
  := forall x : X, In D x -> abstract_cellular (Singleton x).

Section Shrinking_cellular_Maps.

  Hypothesis X_point_cellular : point_cellular  Full_set.

  Lemma Cellular_with_one_sing_shrinkable (f : X -> Y) :
  surjective f ->
  forall y0 : Y, (forall x1 x2 : X,  f x1 = f x2 -> f x1 <> y0 -> x1 = x2)
                  /\ abstract_cellular (inverse_image f (Singleton y0))
  -> forall V : Ensemble Y, In V y0 -> open V ->
                            exists h : X -> Y, homeomorphism h /\
                                               (forall x : X, In (Complement V) (f x) -> h x = f x ).
  Proof.
  move=> f_surj y0 [H_inj H_cell] V InVy0 Vopen.
  have [x0] : exists x0, (f x0) = y0  by apply f_surj.
  have [Dn [Hn Hint]] : exists Dn : IndexedFamily nat X,
    (forall n : nat, abstract_cell (Dn n) /\  Included (Dn (S n)) (interior (Dn n)) ) /\
    IndexedIntersection Dn = Singleton x0 by apply (X_point_cellular x0).
  move=> fx0y0.
  have [En [Kn Kint]] : exists En : IndexedFamily nat X,
    (forall n : nat, abstract_cell (En n) /\ Included (En (S n)) (interior (En n)) ) /\
    IndexedIntersection En = (inverse_image f (Singleton y0)) by apply H_cell.

  pose IStep (kn kn' : {h : X->X | homeomorphism h} * nat) : Prop := (proj1_sig (fst kn)) x0 = x0 ->
    (proj1_sig (fst kn')) x0 = x0  /\  (snd kn') = S (snd kn) /\
    (forall x : X, In (Complement (En (snd kn))) x -> (proj1_sig (fst kn)) x = (proj1_sig (fst kn')) x) /\
    Included (Im (En (snd kn')) (proj1_sig (fst kn'))) (Dn (snd kn')).

  have IChoice : forall kn : {h:X->X | homeomorphism h} * nat, exists kn' :  {h:X->X | homeomorphism h} * nat, IStep kn kn'.
  move=> [[hn hn_homeo] n].
(* em *)
  have exc_middle := classic (hn x0 = x0).
  case : exc_middle.
(* hn x0 = x0 case *)
move => hnx0_x0.
  have acellhnEn : abstract_cell (Im (En n) hn).
  apply homeo_image_abstract_cell.
  case : (Kn n) => [acell_En IncEn'intEn].
  exact acell_En.
  exact hn_homeo.
  case : acellhnEn => InhInthnEn [clImEnhn Exh].
  set U := Intersection (interior (Im (En n) hn)) (interior (Dn (S n))).
  have U_open : open U.
  rewrite /U - interior_intersection.
  apply interior_open.
  have InUx0 : In U x0.
  apply Intersection_intro.
  have Infinvy0_x0 : In (inverse_image f (Singleton y0)) x0.
  constructor.
    by rewrite fx0y0.
    have InEnsx0 : In (IndexedIntersection En) x0 by rewrite Kint.
    have InEn'x0 : In (En (S n)) x0.
    case : InEnsx0 => x InAx.
      by apply (InAx (S n)).
      have InintEnx0 : In (interior (En n)) x0.
case : (Kn n) => Enn_acell EnEn'.
by apply EnEn'.
have InhnEnx0 : In (En n) x0 by apply (interior_deflationary (En n)).
have InImEnhnx0 : In (Im (En n) hn) x0 by apply (Im_intro _ _ (En n) hn x0).
have InIminEnhx0 : In (Im (interior (En n)) hn) (hn x0) by apply (Im_intro _ _ (interior (En n)) hn x0).
have IncImintEhImEh : Included (Im (interior (En n)) hn) (Im (En n) hn).
move=> t Init.
case : Init => t1 Inint1 t2 t2_hnt2.
rewrite t2_hnt2; clear t2 t2_hnt2.
have InEnt1 : In (En n) t1.
by apply interior_deflationary.
  by apply (Im_intro _ _ (En n) hn t1).

rewrite hnx0_x0 in InIminEnhx0.
have IminEn_open : open (Im (interior (En n)) hn).

apply homeomorphism_is_open_map.
assumption.
apply interior_open.
Print interior_maximal.
have Inc_ohn_homeo_int : Included (Im (interior (En n)) hn) (interior (Im (En n) hn)).
apply interior_maximal.
assumption.
assumption.
have IncliIEIE : Included (Im (interior (En n)) hn) (interior (Im (En n) hn)).
apply (interior_maximal _ _ IminEn_open).
assumption.
by apply (IncliIEIE _ InIminEnhx0).
case : (Hn (S n)) => _ IncDSSniDSn.
apply IncDSSniDSn.
have IncIIDn_Dn : Included (IndexedIntersection Dn) (Dn (S (S n))).
move => t InIIDnt.
by case : InIIDnt.
rewrite Hint in IncIIDn_Dn.
by apply IncIIDn_Dn.
have IncUImEnnhn : Included U (Im (En n) hn).
rewrite/U.
move=> t  InIntEDt.
suff InintImEnt : In (interior (Im (En n) hn)) t.
  by apply (interior_deflationary  (Im (En n) hn)).
  have In_and_In: (In (interior (Im (En n) hn)) t) /\ (In (interior (Dn (S n))) t) by apply: Intersection_inv.
by case : InIntEDt =>x IniE _.

have [h [h_homeo [hx0_x0 [InchhnEnU HComp]]]] :  exists h: X -> X, homeomorphism h /\ (h x0) = x0 /\
            Included (Im (Im (En n) hn) h) U  /\ (forall y : X, In (Complement (Im (En n) hn)) y -> h y = y)
                                          by apply (Exh x0  U U_open InUx0 IncUImEnnhn).

(* construction of kn' *)
pose n' := (S n).
pose hn' := fun (x : X) => h (hn x).

case h_homeo => [g] h_conti g_conti gh_I hg_I.
case hn_homeo => [gn] hn_conti gn_conti gnhn_I hngn_I.
pose gn' := fun(x : X) => gn (g x).
have gn'hn'_I : forall x, gn' (hn' x) = x.
move=> x.
  by rewrite /hn' /gn' gh_I gnhn_I.
have hn'gn'_I : forall x, hn' (gn' x) = x.
move=> x.
  by rewrite /gn' /hn' hngn_I hg_I.
have hn'_conti : continuous hn' by apply (continuous_composition h hn h_conti hn_conti).
have gn'_conti : continuous gn' by apply (continuous_composition gn g gn_conti g_conti).
have hn'_homeo : homeomorphism hn' by apply (intro_homeomorphism _ gn' hn'_conti gn'_conti gn'hn'_I hn'gn'_I).
pose kn' := (exist _ hn' hn'_homeo, n') : {k0 : X -> X | homeomorphism k0} * nat.
exists kn'.
split.
simpl.
  by rewrite /hn' hnx0_x0 hx0_x0.
split.
  by [].
split.
simpl.
move=> x InCEnnx.
rewrite /hn'.
have InCIEhnx : In (Complement (Im (En n) hn)) (hn x).
move=> InImEhnx.
have [x1 [InEx1 hnx1_hnx]] : exists x1 : X, In (En n) x1 /\ (hn x1) = (hn x) by apply Im_inv.
have x1_x : gn (hn x1) = gn (hn x) by rewrite hnx1_hnx.
repeat rewrite gnhn_I in x1_x.
  by rewrite x1_x in InEx1.
apply eq_sym.
  by apply HComp.
simpl.
have Imhn'_ImImhnh : Im (En n') hn' = Im (Im (En n') hn) h.
apply Extensionality_Ensembles; split.
move=> x InImEn'hn'x.
have [x1 [InEn'x1 hn'x1_x]] : exists x1 : X, In (En n') x1 /\ hn' x1 = x by apply Im_inv in InImEn'hn'x.
rewrite/hn' in hn'x1_x.
have InImEn'hnhnx1 : In (Im (En n') hn) (hn x1) by apply (Im_intro _ _ (En n') hn x1 InEn'x1).
  by apply (Im_intro _ _ (Im (En n') hn) h (hn x1)).
  move=> x InIIE'hnhx.
have [x1 [InImEn'hnx1 hx1_x]] : exists x1 : X, In (Im (En n') hn) x1 /\ h x1 = x by apply Im_inv in InIIE'hnhx.
have [x2 [InEn'x2 hnx2_x1]] : exists x2 : X, In (En n') x2  /\ hn x2 = x1 by  apply Im_inv in InImEn'hnx1.
apply (Im_intro _ _ (En n') hn' x2).
assumption.
by rewrite/hn' hnx2_x1.
rewrite Imhn'_ImImhnh.
SearchAbout Im.
rewrite/hn'. have Intmed : forall (y : X), In (Im (En n) hn) y -> exists z : X, In (En n) z /\ hn z = y.
move=>y. by apply (Im_inv (En n) hn y).
have : Included (Im (Im (En n') hn) h) (Im (Im (En n) hn) h).
repeat apply Im_compat_Included.
rewrite/n'.
apply Inclusion_is_transitive with (interior (En n)).
by apply (proj2 (Kn n)).
by apply interior_deflationary.
move => IncIIEn'hnhIIEnhnh.
apply Inclusion_is_transitive with (Im (Im (En n) hn) h).
assumption.
apply Inclusion_is_transitive with U.
assumption.
rewrite/U.
apply Inclusion_is_transitive with (interior (Dn (S n))).
  by apply Intersection_decreases_r.
rewrite/n'.
  by apply interior_deflationary.
move=> hnx0_n_x0.
(* hn x0 <> x0 case *)
exists ((exist _ hn hn_homeo), (S n)).
move=> hnx0_x0.
by simpl in hnx0_x0.

(*** apply FDC **)

pose k0 := ((exist _ (fun x : X => x) id_homeo), O).
have [kn] : exists kn : nat -> {h : X -> X | homeomorphism h} * nat,
            (kn O) = k0 /\ (forall n : nat, IStep (kn n) (kn (S n))) by apply FDC.
(*****)

have x_to_n : forall x : X, In (En O) x -> f x <> y0 ->
                     exists n : nat, In (En n) x /\ ~ In (En (S n)) x.
move=> x InE0x fxny0.
apply not_all_not_ex.
move=> nEnEn'.

have nEniEn' : forall n : nat, In (En n) x -> In (En (S n)) x.
move=>n.
apply or_to_imply.
apply ponnq_poq.
apply not_and_or.
apply nEnEn'.
clear nEnEn'.
have AnInEnx : forall n : nat, In (En n) x.
induction n.
assumption.
  by apply: nEniEn'.
  clear nEniEn'.
have InKx : In (inverse_image f (Singleton y0)) x.
rewrite  -Kint.
by apply indexed_intersection_intro.
case: InKx => InSy0fx.
apply Singleton_inv in InSy0fx.
apply eq_sym in InSy0fx.
by apply (fxny0 InSy0fx).
move => [kn0_k0 AnISpknkn'].
Print uniqueness.
pose DefRelh (x : X) (y : Y) := (x = x0 /\ y = y0) \/ (In (Complement (Im ((En 1) x /\ y = f x)
                                                          \/ (exists n : nat, In (Intersection

move: (Intmed (hn x)). InImEhnx).
case InImEhnx. => x1 InEnx1 y y_hnx1.
pose hn' := fun (x : X) => match (eqProp ((En n) x)) with
                             | left _ => h (hn x)
                             | right _ => hn x
                           end.
exists (exist hn' (S n)).
  Print FunctionalDependentChoice_on.
have em : homeomorphism (fst kn) \/ ~ homeomorphism (fst kn) by apply (classic _).
pose Tn := {kn : nat * (X->X) | (homeomorphism (snd kn)) /\ Included (Im (D'n (fst kn)) (snd kn)) (interior (Dn (fst kn)))}.
Check Tn.
Check (FunctionalDependentChoice_on Tn).
  pose IStep (kn kn' : Tn) : Prop :=
    forall x : X, In (Complement (D'n (fst (proj1_sig kn)))) x  -> (snd (proj1_sig kn)) x = (snd (proj1_sig kn')) x.

End Shrinking_cellular_Maps.

Proof.
move=> y0 [Hi Hc] V InVy0 openV.

End Cellularity.

Section Def_rs_shrinkable.

  Variable X : TopologicalSpace.
  Variable B : Ensemble (point_set X).
  Hypothesis B_closed : closed B.
  Variable x : point_set X.

  (* s_shrinkable = stably shrinkable *)
  Definition s_shrinkable : Prop :=
    forall U: Ensemble (point_set X),
      open U -> In U x ->
      exists h : (point_set X) -> (point_set X),
        closed (Im B h) /\ open (Im (Complement B) h) /\
        exists V : Ensemble (point_set X),
          continuous h /\ Included (Im Full_set h) U /\
          homeomorphism (continuous_surj_factorization h) /\
          open V /\ In V x /\
          forall y : point_set X, In V y -> h y = y.

  (* r_shrinkable = relatively shrinkable *)
  Definition r_shrinkable : Prop :=
    forall (K U : Ensemble (point_set X)),
      compact (SubspaceTopology K) -> open U ->
      Intersection K B = Empty_set -> In U x ->
      exists h : point_set X -> point_set X, homeomorphism h /\ Included (Im Full_set h) U /\
                         forall b : point_set X, In B b -> (h b) = b.

End Def_rs_shrinkable.

Definition abstract_cell (D : TopologicalSpace) (B : Ensemble (point_set D)) : Prop :=
  forall x : point_set D, s_shrinkable D B x /\ r_shrinkable D B x.

Definition abstract_cellular (X : TopologicalSpace) (K : Ensemble (point_set X)) : Prop :=
  exists Dn : IndexedFamily nat (point_set X),
    exists Bn : IndexedFamily nat (point_set X),
      forall n : nat,


Require Import Vector.
Require Import Arith.

Inductive Bool: Prop :=
  BTrue: Bool | BFalse: Bool.

Fixpoint t_n (A: Type) (n: nat) (x: A): t A n :=
  match n with
    | O => nil A
    | S m => cons A x m (t_n A m x)
  end.

Inductive preserves_false (n: nat) (f: t Bool n -> Bool) :=
  preserves: (f(t_n Bool n BFalse) = BFalse) -> preserves_false n f.

Definition compose {m: nat} {n: nat} (f: t Bool m -> Bool) (gs: t (t Bool n -> Bool) m) (xs: t Bool n) : Bool :=
  f (map ( fun (g: t Bool n -> Bool) => g xs ) gs).

Lemma preserves_false_vector: forall {n: nat} {m: nat} (gs: t (t Bool n -> Bool) m),
  Forall (fun (g: t Bool n -> Bool) => preserves_false n g) gs ->
    (map ( fun (g: t Bool n -> Bool) => g (t_n Bool n BFalse) ) gs) = (t_n Bool m BFalse).
Proof.
intros.
induction H.
auto.
simpl.
induction H.
rewrite e.
induction map.
auto.
rewrite IHForall.
auto.
Qed.

Inductive compose_closed (c: forall k, (t Bool k -> Bool) -> Prop) :=
  compose_is_c:
    (forall
      {m: nat} {n: nat}
      (f: t Bool m -> Bool) (gs: t (t Bool n -> Bool) m),
      (c m f) -> Forall (fun (g: t Bool n -> Bool) => c n g) gs -> (c n (compose f gs))) ->
        compose_closed c.

Definition preserves_false_is_composed_closed: compose_closed preserves_false.
Proof.
apply compose_is_c.
intros.
induction H.
apply preserves.
unfold compose.
rewrite preserves_false_vector.
assumption.
assumption.
Qed.

Inductive preserves_true (n: nat) (f: t Bool n -> Bool) :=
  preserve_true: (f(t_n Bool n BTrue) = BTrue) -> preserves_true n f.

Lemma preserves_true_vector: forall {n: nat} {m: nat} (gs: t (t Bool n -> Bool) m),
  Forall (fun (g: t Bool n -> Bool) => preserves_true n g) gs ->
    (map ( fun (g: t Bool n -> Bool) => g (t_n Bool n BTrue) ) gs) = (t_n Bool m BTrue).
Proof.
intros.
induction H.
auto.
simpl.
induction H.
rewrite e.
induction map.
auto.
rewrite IHForall.
auto.
Qed.

Definition preserves_true_is_composed_closed: compose_closed preserves_true.
Proof.
apply compose_is_c.
intros.
induction H.
apply preserve_true.
unfold compose.
rewrite preserves_true_vector.
assumption.
assumption.
Qed.

Import VectorNotations.

(*for self-duality*)

Definition is_same_bool (x y: Bool) : Bool:=
  match (x, y) with
    | (BTrue, BTrue) => BTrue
    | (BFalse, BFalse) => BTrue
    | (BTrue, BFalse) => BFalse
    | (BFalse, BTrue) => BFalse
  end.

(*Fixpoint is_same_set  {n: nat} {p: nat} (x: t Bool n) (y: t Bool p): Bool :=
  match x, y with
    |[], [] => BTrue
    | xh :: xt, yh :: yt=>
        match is_same_bool xh yh with
          | BTrue => is_same_set xt yt
          | BFalse => BFalse
        end
    | _, _ => BFalse
    end.*)

Definition is_not_same_bool (x y: Bool) : Bool:=
  match (x, y) with
    | (BTrue, BTrue) => BFalse
    | (BFalse, BFalse) => BFalse
    | (BTrue, BFalse) => BTrue
    | (BFalse, BTrue) => BTrue
  end.

Fixpoint is_revert_set_rec {n: nat} {p: nat} (x: t Bool n) (y: t Bool p): Bool :=
  match x, y with
    |[], [] => BTrue
    | xh :: xt, yh :: yt=>
        match is_same_bool xh yh with
          | BFalse => is_revert_set_rec xt yt
          | BTrue => BFalse
        end
    | _, _ => BFalse
    end.

Definition is_revert_set {n: nat} {p: nat} (x: t Bool n) (y: t Bool p): Bool :=
   match x, y with
    |[], [] => BFalse
    | xh :: xt, yh :: yt=> is_revert_set_rec (xh :: xt) (yh :: yt)
    | _, _ => BFalse
   end.

Inductive revert_sets {n: nat} (x y: t Bool n):=
  revert: (is_revert_set x y = BTrue) -> revert_sets x y.

(*
Inductive self_duality (n: nat) (f: t Bool n -> Bool): Prop:=
  self_dual:
    (forall (x y: t (t Bool n) (2^n)) (xs ys : t Bool n),
    Forall2 (fun (xs ys: t Bool n) => (revert_sets xs ys -> ((is_not_same_bool (f xs) (f ys)) = BTrue) )) x y) -> self_duality n f .
*)

(*
Definition self_duality_is_composed_closed: compose_closed self_duality.
Proof.
apply compose_is_c.
intros.
unfold compose.
induction H0.
simpl.
admit.
apply self_dual.
intros.
admit.
Qed.
*)

(* for monotonous*)
Definition is_less_bool (x y: Bool) : Bool:=
  match (x, y) with
    | (BTrue, BTrue) => BFalse
    | (BFalse, BFalse) => BFalse
    | (BTrue, BFalse) => BFalse
    | (BFalse, BTrue) => BTrue
  end.

Definition is_less_or_equal_bool (x y: Bool) : Bool:=
  match (x, y) with
    | (BTrue, BTrue) => BTrue
    | (BFalse, BFalse) => BTrue
    | (BTrue, BFalse) => BFalse
    | (BFalse, BTrue) => BTrue
  end.

Fixpoint is_preced_sets {n: nat} {p: nat} (x: t Bool n) (y: t Bool p): Bool :=
    match x, y with
    | [], [] => BTrue
    | xh :: xt, yh :: yt =>
         match is_less_or_equal_bool xh yh with
            | BTrue => is_preced_sets xt yt
            | BFalse => BFalse
         end
     | _, _ => BFalse
    end.

Inductive preced_sets {n: nat} (x y: t Bool n):=
  preced: (is_preced_sets x y = BTrue) -> preced_sets x y.

Inductive monotonous (n: nat) (f: t Bool n -> Bool): Prop :=
  monotony:
    (forall (x : t ( t Bool n) (2^n)) (* (xs ys : t Bool n)*),
    Forall2 (fun (xs ys: t Bool n) => (preced_sets xs ys -> (is_less_or_equal_bool (f xs) (f ys) = BTrue ))) x x)-> monotonous n f .

(*
Definition monotonous_is_composed_closed: compose_closed monotonous.
Proof.
apply compose_is_c.
intros.
induction H.
apply monotony.
intros.
auto.
simpl.
admit.
Qed.

Definition xor (x y: Bool): Bool :=
  match x, y with
    | BFalse, BFalse => BFalse
    | BFalse, BTrue => BTrue
    | BTrue, BFalse => BTrue
    | BTrue, BTrue => BFalse
  end.

Fixpoint is_more_one_true_in_set {n: nat} (x: t Bool n) (diff: nat) : Bool :=
  match x with
    | [] =>
        match diff with
          | O => BFalse
          | S O => BFalse
          | _ => BTrue
        end
    | xh :: xt =>
        match is_same_bool xh BTrue with
          | BTrue => is_more_one_true_in_set xt (S diff)
          | BFalse => is_more_one_true_in_set xt diff
        end
   end.

Inductive false_coef_for_set {n: nat} (x: t Bool n) (f: t Bool n -> Bool) :=
  false_coef: (get_coef_for_set x f
 = BFalse) -> false_coef_for_set x.

Inductive more_one_true_in_set {n: nat} (x: t Bool n):=
  mote_one_true: (is_more_one_true_in_set x 0 = BTrue) -> more_one_true_in_set x.

Inductive linearity (n: nat) (f: t Bool n -> Bool) : Prop :=
  linear: forall (x : t (t Bool n) (2^n)) (xs: t Bool n),
    Forall more_one_true_in_set x -> false_coef_for_set xs -> linearity n f.

*)

Definition not (x: Bool) := match x with
  | BTrue => BFalse
  | BFalse => BTrue
end.

Definition not_t {n: nat} (xs: t Bool n) :=
  map (fun x => not x) xs.

Definition dual {n: nat} (f: t Bool n -> Bool) (xs: t Bool n) :=
  not (f (not_t xs)).

Definition dual_t {m: nat} {n: nat} (gs: t (t Bool n -> Bool) m) :=
  map (fun g => dual g) gs.

Inductive self_dual (n: nat) (f: t Bool n -> Bool) :=
  is_self_dual: (f = dual f) -> self_dual n f.

Require Import Coq.Logic.FunctionalExtensionality.

Lemma compose_assoc {m : nat} {n : nat} {h: Bool -> Bool}:
  forall (f : t Bool m -> Bool) (gs : t (t Bool n -> Bool) m),
    (fun xs : t Bool n => h (compose f gs xs)) = compose (fun xs : t Bool m => h (f xs)) gs.
Proof.
intros.
unfold compose.
apply functional_extensionality.
intros.
apply f_equal.
apply f_equal.
apply f_equal.
reflexivity.
Qed.

Lemma involution: forall (x: Bool), not (not x) = x.
Proof.
intros.
unfold not.
destruct x.
reflexivity.
reflexivity.
Qed.

Check involution.

Lemma dual_vector {m: nat} {n: nat}:
  forall (gs : t (t Bool n -> Bool) m) (xs : t Bool n),
    map (fun g : t Bool n -> Bool => g (not_t xs)) gs =
      not_t (map (fun g : t Bool n -> Bool => g xs) (dual_t gs)).
Proof.
intros.
unfold dual_t.
unfold dual.
unfold not_t.
induction gs.
simpl.
reflexivity.
simpl.
rewrite involution.
apply f_equal.
assumption.
Qed.

Theorem dual_composition:
  forall {m: nat} {n: nat}
    (f: t Bool m -> Bool) (gs: t (t Bool n -> Bool) m),
    dual (compose f gs) = compose (dual f) (dual_t gs).
Proof.
intros.
unfold dual.
unfold compose.
apply functional_extensionality.
intros.
apply f_equal.
apply f_equal.
apply dual_vector.
Qed.

Theorem self_dual_is_compose_closed: compose_closed self_dual.
Proof.
apply compose_is_c.
intros.
apply is_self_dual.
rewrite dual_composition.
apply f_equal2.
induction H.
assumption.
clear H.
clear f.
induction H0.
simpl.
reflexivity.
simpl.
induction H.
destruct e.
apply f_equal.
apply IHForall.
Qed.

(* curried `and` *)
Definition and (x y: Bool) : Bool :=
  match (x, y) with
    | (BFalse, BFalse) => BFalse
    | (BFalse, BTrue) => BFalse
    | (BTrue, BFalse) => BFalse
    | (BTrue, BTrue) => BTrue
  end.

(* uncurried `and`, i. e. boolean function and *)
Definition and_bf (xs: t Bool 2) := and (hd xs) (hd (tl xs)).

(* curried Zhegalkin plus, i. e. boolean function plus *)
Definition plus (x y: Bool) : Bool:=
  match (x, y) with
    | (BFalse, BFalse) => BFalse
    | (BFalse, BTrue) => BTrue
    | (BTrue, BFalse) => BTrue
    | (BTrue, BTrue) => BFalse
  end.

(* uncurried Zhegalkin plus *)
Definition plus_bf (xs: t Bool 2) := plus (hd xs) (hd (tl xs)).

(* computes Zhegalkin polynomm for the given coefficients:
   c is the free coefficient and cs are variable coefficients *)
Definition compute_polynom {n: nat} (c: Bool) (cs: t Bool n) (xs: t Bool n): Bool :=
  fold_left
    (fun (result value: Bool) => plus result value)
      c
       (map2 (fun (c x: Bool) => and c x) cs xs).

Inductive linear (n: nat) (f: t Bool n -> Bool): Prop :=
  of_coefficients:
    forall (c: Bool) (cs: t Bool n),
      (forall (xs: t Bool n), compute_polynom c cs xs = f xs)
        -> linear n f.

Check of_coefficients.

Check caseS' [BTrue; BTrue].

(*
  Vector_0_is_nil' and Vector_0_is_nil: easier proofs that 0-length vectors are equal to nil
  see http://coq-club.inria.narkive.com/wrDwvaNY/how-to-prove-that-all-vectors-of-0-length-are-equal-to-vector-nil
*)

Lemma Vector_0_is_nil' : forall T n (v : Vector.t T n),
match n return Vector.t T n -> Prop with
| O => fun v => v = Vector.nil T
| _ => fun _ => (True: Prop)
end v.
Proof.
destruct v; auto.
Qed.

Theorem Vector_0_is_nil : forall T (v : Vector.t T 0), v = Vector.nil T.
Proof.
intros; apply (Vector_0_is_nil' _ _ v).
Qed.

(* example proof that Zhegalkin plus has a corresponding polynom *)
Example plus_bf_has_polynom: forall (xs: t Bool 2), compute_polynom BFalse [BTrue; BTrue] xs = plus_bf xs.

Proof.

intros.

(* first introduce all the xs since it has fixed length *)
apply (caseS' xs).
intros.
clear xs.
apply (caseS' t).
clear t.
intros.

(* the rest of xs is [] *)
rewrite (Vector_0_is_nil Bool t).

(* unfold all the definitions *)
unfold compute_polynom.
unfold plus_bf.
unfold plus.

(* now enumerate all the xs by destructing h and h0 *)
destruct h.
destruct h0.
simpl.
reflexivity.
simpl.
reflexivity.
destruct h0.
simpl.
reflexivity.
simpl.
reflexivity.

Qed.

Example plus_bf_is_linear: linear 2 plus_bf.
Proof.
(* propose the polynom that we already know *)
apply (of_coefficients 2 plus_bf BFalse [BTrue; BTrue]).
intros.
apply plus_bf_has_polynom.
Qed.

Theorem linear_is_compose_closed: compose_closed linear.
Proof.
(* Work in Progress *)
Admitted.


Require Export
  Coq.Arith.Arith
  Coq.Lists.List
  Coq.Bool.Bool
  Coq.Unicode.Utf8
  Coq.micromega.Lia
  Coq.Classes.SetoidClass
  Coq.Classes.Morphisms
  Pact.Data.Eq
  Pact.Data.Ord.

Require Export Equations.Prop.DepElim.
From Equations Require Export Equations.

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

Set Equations With UIP.

Generalizable All Variables.
Set Primitive Projections.

(** General utility library providing partial maps, built
    on a foundation isomorphic to association lists. *)

Section Map.

Import ListNotations.

Context {k v : Type}.

Inductive Map (k v : Type) : Type :=
  | Add : k → v → Map k v → Map k v
  | Empty : Map k v.

Arguments Empty {_ _}.
Arguments Add {_ _} _ _ _.

Inductive MapsTo `{Eq k} (i : k) (x : v) : Map k v -> Prop :=
  | MapsTo_hd i' x' m :
    i == i' = true -> x = x' → MapsTo i x (Add i' x' m)
  | MapsTo_tl i' x' m :
    i == i' = false → MapsTo i x m -> MapsTo i x (Add i' x' m).

Fixpoint lookup `{Eq k} (i : k) (m : Map k v) : option v :=
  match m with
  | Empty => None
  | Add i' x m =>
      if i == i'
      then Some x
      else lookup i m
  end.

Lemma MapsTo_lookup `{Eq k} i x m : MapsTo i x m ↔ lookup i m = Some x.
Proof.
  split; intros.
  - induction H0; simpl; subst;
    now rewrite H0.
  - induction m; simpl in *; [|discriminate].
    destruct (i == k0) eqn:Heqe.
    + inversion H0; subst.
      now constructor.
    + apply MapsTo_tl; auto.
Qed.

#[export]
Program Instance Map_Typeoid `{Eq k} : Setoid (Map k v) := {|
  equiv := λ m1 m2, ∀ k, lookup k m1 = lookup k m2
|}.
Next Obligation.
  constructor; repeat intro; auto.
  transitivity (lookup k0 y); congruence.
Qed.

Fixpoint member `{Eq k} (i : k) (m : Map k v) : bool :=
  match m with
  | Empty => false
  | Add i' _ m => (i == i') || member i m
  end.

#[export]
Program Instance member_respects `{Eq k} :
  Proper (eq ==> equiv ==> eq) member.
Next Obligation.
  repeat intro; subst.
  specialize (H0 x).
  generalize dependent y.
  induction x0; simpl; intros.
  - destruct (x == k0) eqn:Heqe; simpl.
    + apply eqb_eq in Heqe; subst.
      clear -H0.
      induction y; simpl in *; auto.
      * destruct (k0 == k1) eqn:Heqe; simpl; auto.
      * congruence.
    + now apply IHx0.
  - induction y; simpl in *; auto.
    destruct (x == k0) eqn:Heqe; simpl.
    + congruence.
    + now apply IHy.
Qed.

Fixpoint toList (m : Map k v) : list (k * v) :=
  match m with
  | Empty => []
  | Add i x m => (i, x) :: toList m
  end.

Fixpoint fromList (l : list (k * v)) : Map k v :=
  match l with
  | [] => Empty
  | (i, x) :: xs => Add i x (fromList xs)
  end.

Lemma toList_fromList (l : list (k * v)) : toList (fromList l) = l.
Proof.
  induction l; simpl; auto.
  destruct a; simpl.
  now rewrite IHl.
Qed.

Lemma fromList_toList (m : Map k v) : fromList (toList m) = m.
Proof.
  induction m; simpl; auto.
  now rewrite IHm.
Qed.

Definition null (m : Map k v) : bool :=
  if m then false else true.

#[export]
Program Instance null_respects `{Eq k} : Proper (equiv ==> eq) null.
Next Obligation.
  repeat intro.
  generalize dependent y.
  induction x, y; simpl; intros; auto.
  - specialize (H0 k0).
    rewrite eqb_refl in H0.
    discriminate.
  - specialize (H0 k0).
    rewrite eqb_refl in H0.
    discriminate.
Qed.

Fixpoint delete `{Eq k} (i : k) (m : Map k v) : Map k v :=
  match m with
  | Empty => m
  | Add i' x m =>
      if i == i'
      then delete i m
      else Add i' x (delete i m)
  end.

Lemma delete_idem `{Eq k} i m :
  delete i (delete i m) = delete i m.
Proof.
  induction m; simpl; auto.
  destruct (i == k0) eqn:Heqe; auto; simpl.
  rewrite Heqe.
  now rewrite IHm.
Qed.

Lemma delete_comm `{Eq k} i j m :
  delete i (delete j m) = delete j (delete i m).
Proof.
  generalize dependent j.
  generalize dependent i.
  induction m; simpl; intros; auto.
  destruct (i == k0) eqn:Heqe1; auto; simpl.
  - destruct (j == k0) eqn:Heqe2; auto; simpl.
    now rewrite Heqe1.
  - destruct (j == k0) eqn:Heqe2; auto; simpl.
    rewrite Heqe1.
    now rewrite IHm.
Qed.

Fixpoint size (m : Map k v) : nat :=
  match m with
  | Add _ _ m => 1 + size m
  | Empty => 0
  end.

Lemma size_delete `{Eq k} i m : (size (delete i m) <= size m)%nat.
Proof.
  induction m; simpl; auto.
  destruct (i == k0) eqn:Heqe;
  auto; simpl; lia.
Qed.

Equations compress `{Eq k} (m : Map k v) : Map k v by wf (size m) :=
  compress Empty := Empty;
  compress (Add i' x m) := Add i' x (compress (delete i' m)).
Next Obligation.
  specialize (compress H m).
  pose proof (size_delete i' m); lia.
Qed.

Lemma compress_delete `{Eq k} i m :
  compress (delete i m) = delete i (compress m).
Proof.
  generalize dependent i.
  funelim (compress m); simpl; intros; auto.
  simp compress; simpl.
  destruct (i == i') eqn:Heqe.
  - apply eqb_eq in Heqe; subst.
    rewrite <- H0.
    now rewrite delete_idem.
  - simp compress; simpl.
    f_equal.
    rewrite <- H0.
    now rewrite delete_comm.
Qed.

Lemma size_compress `{Eq k} m : (size (compress m) <= size m)%nat.
Proof.
  induction m; auto.
  simp compress; simpl.
  apply le_n_S.
  rewrite compress_delete.
  now rewrite size_delete.
Qed.

Fixpoint findWithDefault `{Eq k} (d : v) (i : k) (m : Map k v) : v :=
  match m with
  | Empty => d
  | Add i' x m =>
      if i == i'
      then x
      else findWithDefault d i m
  end.

Definition empty : Map k v := Empty.

Definition singleton (i : k) (x : v) : Map k v := Add i x empty.

Fixpoint insert `{Eq k} (i : k) (x : v) (m : Map k v) : Map k v :=
  match m with
  | Empty => singleton i x
  | Add i' x' m =>
      if i == i'
      then Add i x m
      else Add i' x' (insert i x m)
  end.

Lemma lookup_insert `{Eq k} i j x m :
  lookup i (insert j x m) = if i == j then Some x else lookup i m.
Proof.
  destruct (i == j) eqn:Heqe1.
  - induction m; simpl; intros.
    + destruct (j == k0) eqn:Heqe2; simpl.
      * now rewrite Heqe1.
      * apply eqb_eq in Heqe1; subst.
        now rewrite Heqe2.
    + now destruct (i == j).
  - induction m; simpl; intros.
    + destruct (j == k0) eqn:Heqe2; simpl.
      * rewrite Heqe1.
        apply eqb_eq in Heqe2; subst.
        now rewrite Heqe1.
      * now rewrite IHm.
    + now destruct (i == j).
Qed.

Lemma lookup_delete `{Eq k} i j m :
  lookup i (delete j m) = if i == j then None else lookup i m.
Proof.
  induction m; simpl.
  - destruct (i == j) eqn:Heqe1.
    + destruct (j == k0) eqn:Heqe2; auto.
      simpl.
      apply eqb_eq in Heqe1; subst.
      now rewrite Heqe2.
    + destruct (j == k0) eqn:Heqe2; simpl; auto.
      * apply eqb_eq in Heqe2; subst.
        now rewrite Heqe1.
      * now destruct (i == k0).
  - now destruct (i == j).
Qed.

Lemma compress_equiv `{Eq k} m :
  m == compress m.
Proof.
  funelim (compress m); repeat intro; auto.
  simp compress; simpl.
  rewrite <- H0.
  rewrite lookup_delete.
  now destruct (k0 == i').
Qed.

Lemma insert_delete `{Eq k } i x m :
  insert i x (delete i m) == insert i x m.
Proof.
  induction m; simpl; intros; auto.
  destruct (i == k0) eqn:Heqe.
  - rewrite IHm; clear IHm.
    now rewrite lookup_insert.
  - simpl.
    rewrite Heqe; simpl.
    now rewrite IHm.
Qed.

Fixpoint insertWith `{Eq k} (f : v → v → v) (i : k) (x : v) (m : Map k v) : Map k v :=
  match m with
  | Empty => singleton i x
  | Add i' x' m =>
      if i == i'
      then Add i (f x x') m
      else insertWith f i x m
  end.

Fixpoint insertWithKey `{Eq k} (f : k → v → v → v) (i : k) (x : v) (m : Map k v) : Map k v :=
  match m with
  | Empty => singleton i x
  | Add i' x' m =>
      if i == i'
      then Add i (f i x x') m
      else insertWithKey f i x m
  end.

Fixpoint insertLookupWithKey `{Eq k} (f : k → v → v → v) (i : k) (x : v) (m : Map k v) :
  option v * Map k v :=
  match m with
  | Empty => (None, singleton i x)
  | Add i' x' m =>
      if i == i'
      then (Some x', Add i (f i x x') m)
      else insertLookupWithKey f i x m
  end.

Fixpoint adjust `{Eq k} (f : v → v) (i : k) (m : Map k v) : Map k v :=
  match m with
  | Empty => Empty
  | Add i' x' m =>
      if i == i'
      then Add i' (f x') m
      else Add i' x' (adjust f i m)
  end.

Fixpoint adjustWithKey `{Eq k} (f : k → v → v) (i : k) (m : Map k v) : Map k v :=
  match m with
  | Empty => Empty
  | Add i' x' m =>
      if i == i'
      then Add i' (f i' x') m
      else Add i' x' (adjustWithKey f i m)
  end.

Fixpoint alter `{Eq k} (f : option v → option v) (i : k) (m : Map k v) : Map k v :=
  match m with
  | Empty =>
      match f None with
      | None => empty
      | Some v => singleton i v
      end
  | Add i' x' m =>
      if i == i'
      then
        match f (Some x') with
        | None => m
        | Some v => Add i' v m
        end
      else Add i' x' (alter f i m)
  end.

Context {b : Type}.

Fixpoint map (f : v → b) (m : Map k v) : Map k b :=
  match m with
  | Empty => Empty
  | Add i x m => Add i (f x) (map f m)
  end.

Fixpoint mapWithKey (f : k → v → b) (m : Map k v) : Map k b :=
  match m with
  | Empty => Empty
  | Add i x m => Add i (f i x) (mapWithKey f m)
  end.

Fixpoint fold (f : v → b → b) (z : b) (m : Map k v) : b :=
  match m with
  | Empty => z
  | Add _ x m => fold f (f x z) m
  end.

Fixpoint foldrWithKey (f : k → v → b → b) (z : b) (m : Map k v) : b :=
  match m with
  | Empty => z
  | Add i x m => f i x (foldrWithKey f z m)
  end.

Fixpoint foldlWithKey (f : k → v → b → b) (z : b) (m : Map k v) : b :=
  match m with
  | Empty => z
  | Add i x m => foldlWithKey f (f i x z) m
  end.

Fixpoint elems (m : Map k v) : list v :=
  match m with
  | Empty => []
  | Add _ x m => x :: elems m
  end.

Fixpoint keys (m : Map k v) : list k :=
  match m with
  | Empty => []
  | Add i _ m => i :: keys m
  end.

Definition assocs (m : Map k v) : list (k * v) := toList m.

Fixpoint filter (f : v → bool) (m : Map k v) : Map k v :=
  match m with
  | Empty => Empty
  | Add i x m =>
      if f x
      then Add i x (filter f m)
      else filter f m
  end.

Fixpoint mapMaybe (f : v → option b) (m : Map k v) : Map k b :=
  match m with
  | Empty => Empty
  | Add i x m =>
      match f x with
      | Some x' => Add i x' (mapMaybe f m)
      | None => mapMaybe f m
      end
  end.

End Map.


Require Import AutoSep WordLemmas.

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

Fixpoint fact (n : nat) :=
  match n with
    | 0 => 1
    | S n' => fact n' * n
  end.

Definition factS : spec := SPEC("n") reserving 1
  PRE[V]  Emp
  POST[R] [| R = natToW (fact (wordToNat (V "n"))) |].

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

Definition m := bmodule "factorial" {{
  bfunction "fact" ("n", "r" ) [factS]
    "r" <- 1;;
    [ PRE[V]  Emp
      POST[R] [| R = (wordToNat (V "r")
                      * fact (wordToNat (V "n")))%nat |] ]
    While ("n" > 1) {
      "r" <- "r" * "n";;
      "n" <- "n" - 1
    };;
    Return "r"
  end
  }}.

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

Lemma fact_gt_1 : forall (r n : W), natToW 1 < n
             -> natToW (wordToNat (r ^* n)
                        * fact (wordToNat (n ^- natToW 1)))
                = natToW (wordToNat r * fact (wordToNat n)).
  intros; destruct_words; roundtrip.
  destruct w0; simpl; try omega.
  replace (w0 - 0) with w0 by omega.
  rewrite Mult.mult_succ_r.

  rewrite ! natToWord_mult.
  roundtrip.
  rewrite <- wmult_assoc.
  f_equal.
  replace (S w0) with (1 + w0) by omega.
  rewrite ! natToWord_plus.
  rewrite ! natToWord_mult.
  words.
Qed.
Hint Resolve fact_gt_1.

Lemma fact_le_1 : forall r n : W, n <= natToW 1
          -> r = natToW (wordToNat r * fact (wordToNat n)).
  intros; destruct_words; roundtrip.
  f_equal.
  repeat (destruct w0; simpl; try omega).
Qed.
Hint Resolve fact_le_1.

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

Ltac finish :=
  match goal with
    | _ => solve [auto]
    | H: Regs _ Rv = _ |- _ => rewrite H
  end.

Hint Extern 1 (natToW _ = natToW _) => roundtrip; auto.

Theorem ok : moduleOk m.
  vcgen; sep_auto; repeat finish.
Qed.

Print Assumptions ok.


(*
                       j
   -------------------->
  | 0  1  3  6  10  ...
  |    2  4  7  11  ...
  |       5  8  12  ...
  |          9  13  ...
  |             14  ...
  |
i V

*)

Inductive visit : nat -> nat -> Prop :=
| visit_first : visit 0 0
| visit_down : forall i j, i < j -> visit i j -> visit (S i) j
| visit_right : forall i j, i >= j -> visit i j -> visit 0 (S j).

Definition task := forall i j, visit i j -> i <= j.


Require Import SOL.
Require Import Decidable Enumerable.

Require Import List.
Import ListNotations.

Inductive full_logic_sym : Type :=
| Conj : full_logic_sym
| Disj : full_logic_sym
| Impl : full_logic_sym.

Inductive full_logic_quant : Type :=
| All : full_logic_quant
| Ex : full_logic_quant.

Instance full_operators : operators :=
{| binop := full_logic_sym ; quantop := full_logic_quant |}.

Instance eqdec_full_logic_sym : eq_dec full_logic_sym.
Proof.
  intros x y. unfold dec. decide equality.
Qed.

Instance eqdec_full_logic_quant : Decidable.eq_dec full_logic_quant.
Proof.
  intros x y. unfold dec. decide equality.
Qed.

Definition L_binop (n : nat) := [Conj; Impl; Disj].

Instance enum_binop :
  list_enumerator__T L_binop binop.
Proof.
  intros []; exists 0; cbn; tauto.
Qed.

Definition L_quantop (n : nat) := [All; Ex].

Instance enum_quantop :
  list_enumerator__T L_quantop quantop.
Proof.
  intros []; exists 0; cbn; tauto.
Qed.

Lemma enumT_binop :
  enumerable__T binop.
Proof.
  apply enum_enumT. exists L_binop. apply enum_binop.
Qed.

Lemma enumT_quantop :
  enumerable__T quantop.
Proof.
  apply enum_enumT. exists L_quantop. apply enum_quantop.
Qed.

(** Mutliple quantors and closing operations *)

Require Import Lia.

Section Close.

  Fixpoint iter {X} (f : X -> X) n x := match n with O => x | S n' => f (iter f n' x) end.

  Lemma iter_switch {X} f n (x : X) :
    iter f n (f x) = f (iter f n x).
  Proof.
    induction n; cbn; congruence.
  Qed.

  Context {Σf : funcs_signature}.
  Context {Σp : preds_signature}.

  Definition quant_indi_n op n := iter (@quant_indi _ _ full_operators op) n.
  Definition quant_pred_n op ar n := iter (quant_pred op ar) n.

  Definition close_indi op phi := quant_indi_n op (proj1_sig (find_bounded_indi phi)) phi.

  Definition close_pred' ar op phi := quant_pred_n op ar (proj1_sig (find_bounded_pred ar phi)) phi.
  Fixpoint close_pred'' n op phi := match n with 0 => phi | S n => close_pred' n op (close_pred'' n op phi) end.
  Definition close_pred op phi := close_pred'' (find_arity_bound_p phi) op phi.

  Definition close op phi := close_indi op (close_pred op phi).

  Fixpoint forall_n n phi := match n with
    | 0 => phi
    | S n => quant_indi All (forall_n n phi)
  end.

  Lemma nat_ind_2 (P : nat -> nat -> Prop) :
    (forall x, P x 0) -> (forall x y, P x y -> P y x -> P x (S y)) -> forall x y, P x y.
  Proof.
    intros H1 H2. intros x y. revert x. induction y.
    - apply H1.
    - intros x. apply H2. apply IHy. induction x; firstorder.
  Qed.

  Lemma close_indi_correct op phi :
    bounded_indi 0 (close_indi op phi).
  Proof.
    enough (forall n m, bounded_indi n phi -> bounded_indi (n-m) (iter (quant_indi op) m phi)) as X.
    { unfold close_indi. destruct find_bounded_indi as [n H]. cbn.
      specialize (X n n). replace (n-n) with 0 in X by lia. now apply X. }
    apply (nat_ind_2 (fun n m => bounded_indi n phi -> bounded_indi (n - m) (iter (quant_indi op) m phi))); cbn.
    - intros n B. now replace (n-0) with n by lia.
    - intros n m IH _ B. eapply bounded_indi_up. 2: apply IH. lia. exact B.
  Qed.

  Lemma close_indi_bounded_pred ar n op phi :
    bounded_pred ar n phi -> bounded_pred ar n (close_indi op phi).
  Proof.
    intros H. unfold close_indi. destruct find_bounded_indi as [b B]; cbn. clear B. now induction b.
  Qed.

  Lemma close_pred'_correct ar op phi :
    bounded_pred ar 0 (close_pred' ar op phi).
  Proof.
    enough (forall n m, bounded_pred ar n phi -> bounded_pred ar (n-m) (iter (quant_pred op ar) m phi)) as X.
    { unfold close_pred'. destruct find_bounded_pred as [n H]. cbn.
      specialize (X n n). replace (n-n) with 0 in X by lia. now apply X. }
    apply (nat_ind_2 (fun n m => bounded_pred ar n phi -> bounded_pred ar (n - m) (iter (quant_pred op ar) m phi))); cbn.
    - intros n B. now replace (n-0) with n by lia.
    - intros n m IH _ B. left. split. reflexivity. eapply bounded_pred_up. 2: apply IH. lia. exact B.
  Qed.

  Lemma close_pred'_bounded_pred ar n m op phi :
    bounded_pred ar n phi -> bounded_pred ar n (close_pred' m op phi).
  Proof.
    intros H. unfold close_pred'. destruct find_bounded_pred as [b B]. cbn.
    clear B. induction b; cbn. easy. assert (ar = m \/ ar <> m) as [] by lia.
    left. split. easy. eapply bounded_pred_up. 2: apply IHb. lia. now right.
  Qed.

  Lemma close_pred'_arity_bounded_p n m op phi :
    arity_bounded_p n phi -> arity_bounded_p n (close_pred' m op phi).
  Proof.
    intros H. unfold close_pred'. destruct find_bounded_pred as [b B]. cbn.
    clear B. now induction b.
  Qed.

  Lemma close_pred''_arity_bounded_p n m op phi :
    arity_bounded_p n phi -> arity_bounded_p n (close_pred'' m op phi).
  Proof.
    intros H. induction m; cbn. easy. apply close_pred'_arity_bounded_p, IHm.
  Qed.

  Lemma close_pred_correct op phi :
    forall ar, bounded_pred ar 0 (close_pred op phi).
  Proof.
    intros ar. assert (ar >= find_arity_bound_p phi \/ ar < find_arity_bound_p phi) as [H|H] by lia.
    - eapply bounded_pred_arity_bound. 2: apply H.
      apply close_pred''_arity_bounded_p, find_arity_bound_p_correct.
    - revert H. enough (forall n, ar < n -> bounded_pred ar 0 (close_pred'' n op phi)) by eauto.
      induction n. lia. intros H. assert (ar = n \/ ar < n) as [->|] by lia.
      + apply close_pred'_correct.
      + now apply close_pred'_bounded_pred, IHn.
  Qed.

  Lemma close_indi_funcfree op phi :
    funcfree phi -> funcfree (close_indi op phi).
  Proof.
    intros F. unfold close_indi. destruct find_bounded_indi as [n B]. cbn.
    clear B. now induction n.
  Qed.

  Lemma close_pred_funcfree op phi :
    funcfree phi -> funcfree (close_pred op phi).
  Proof.
    intros F. unfold close_pred. enough (forall n, funcfree (close_pred'' n op phi)) by easy.
    induction n; cbn. apply F. enough (forall psi m, funcfree psi -> funcfree (close_pred' m op psi)) by firstorder.
    intros psi m. unfold close_pred'. destruct find_bounded_pred as [b B]. cbn.
    clear B. now induction b.
  Qed.

  Lemma forall_n_funcfree n phi :
    funcfree phi -> funcfree (forall_n n phi).
  Proof.
    now induction n.
  Qed.

End Close.

Notation "∀i Phi" := (@quant_indi _ _ full_operators All Phi) (at level 50).
Notation "∃i Phi" := (@quant_indi _ _ full_operators Ex Phi) (at level 50).

Notation "∀f ( ar ) Phi" := (@quant_func _ _ full_operators All ar Phi) (at level 50).
Notation "∃f ( ar ) Phi" := (@quant_func _ _ full_operators Ex ar Phi) (at level 50).

Notation "∀p ( ar ) Phi" := (@quant_pred _ _ full_operators All ar Phi) (at level 50).
Notation "∃p ( ar ) Phi" := (@quant_pred _ _ full_operators Ex ar Phi) (at level 50).

Notation "⊥" := fal.
Notation "A ∧ B" := (@bin _ _ full_operators Conj A B) (at level 41).
Notation "A ∨ B" := (@bin _ _ full_operators Disj A B) (at level 42).
Notation "A '-->' B" := (@bin _ _ full_operators Impl A B) (at level 43, right associativity).
Notation "A '<-->' B" := ((A --> B) ∧ (B --> A)) (at level 43).
Notation "¬ A" := (A --> ⊥) (at level 40).


(* Loop: While and For. *)

(* I was unable to implement and run While statement, although I do have the resources abou this topic. Please check out Software Foundations - Volume 1: Simple Imperative Programs.

https://softwarefoundations.cis.upenn.edu/lf-current/Imp.html#dfe50505b2b595242030c436d0d7d15f *)

(* Function that takes in two numbers, multiplies them, and returns the output. *)

Definition multiplyTwoNumbers (x y : nat) : nat := x * y.
Compute multiplyTwoNumbers 4 5.

(* Write a recursive function. *)
Require Import Coq.Arith.Compare_dec.

(* Adding two numbers recursively. If m = 0, then m + n = n.
If m = m' + 1, then m + n = m' + n + 1. Repeat until m' = 0. *)

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

Print add''.
Eval compute in add'' 4 3.

(* Function that takes in a string, splits it into two strings, then returns them both. *)
(* Best I can give you is a substring method from Coq. *)

Require Import Coq.Strings.String.

(* Syntax is substring n m s: Returns the substring of s that starts at position n
and end at position m. *)
Compute substring 0 5 "Hello World!".

(* Call your functions and save the results of the function calls in variables. *)

Definition s : nat := add'' 5 6.
Compute s.

(* Function that tests whether your language is pass-by-reference or pass-by-value.*)
(* I don't have an answer to this quesiton. *)


Module minimal_Gallina_introduction.

Variable x : Prop.
Variables A B : Prop.
Variable t2 : Prop.

Check A -> B : Prop.
(* NB: we will see later why this holds *)
Check A -> B : Set.                         (* 補足説明：Set でもある。 *)

Check (fun y => y -> y) : Prop -> Prop.
Definition t1_oops := fun y => y -> y.
Check t1_oops.
Definition t1 := fun y : Prop => y -> y.
Check t1.
Check t1 A : Prop.

Fail Check (fun y : Prop => y -> y) -> B.
(* NB: we will see later why this does not hold *)

End minimal_Gallina_introduction.

Require Import ssreflect.

Module propositions_as_types_example.

Lemma hilbertS (A B C : Prop) :
  (A -> B -> C) -> (A -> B) -> A -> C.
Show Proof.
move=> H1.
Show Proof. (* observe the effect of move=> on the proof-term *)
move=> H2.
move=> H3.
cut B. (* NB: this is a traditional Coq tactic, seldom used in practice *)
cut A.
assumption.
assumption.
cut A.
assumption.
assumption.
Show Proof.
Qed.

Definition hilbertS_proof :=
  fun (A B C : Prop) (H1 : A -> B -> C) (H2 : A -> B) (H3 : A) =>
    (fun H : B => (fun H0 : A => H1 H0) H3 H) ((fun H : A => H2 H) H3).

Lemma hilbertS_direct_proof (A B C : Prop) :
  (A -> B -> C) -> (A -> B) -> A -> C.
exact (hilbertS_proof A B C).
Qed.

Lemma hilbertS_in_practice (A B C : Prop) :
  (A -> B -> C) -> (A -> B) -> A -> C.
move=> H1.
move=> H2.
move=> H3.
apply H1.
exact H3.
apply H2.
exact H3.
Show Proof.
Qed.

Definition hilbertS_in_practice_proof :=
  fun (A B C : Prop) (H1 : A -> B -> C) (H2 : A -> B) (H3 : A) =>
    H1 H3 (H2 H3).

Goal hilbertS_proof = hilbertS_in_practice_proof.
reflexivity.
Qed.

End propositions_as_types_example.

Module move_and_apply_tactics.

Lemma modus_ponens : forall P Q : Prop, (P -> Q) -> P -> Q.
Show Proof.
move=> P.
Show Proof.
move: P.
Show Proof.
move=> P Q PQ p.
apply: PQ.
done.
Qed.

Goal forall P Q : Prop, (forall R : Prop, R -> Q) -> P -> Q.
Proof.
move=> P Q rq p.
Fail apply rq.
apply: rq p.
(*
compare with:
refine (rq _ _).
exact p.
*)
Qed.

Lemma exo0 : forall P : Prop, P -> P.
Proof.
  by [].
Qed.

Lemma exo1 : forall P Q : Prop, P -> (P -> Q) -> Q.
Proof.
  move=> P Q HP.
  by apply.
Qed.

Lemma exo2 : forall P : Prop, (P -> P) -> P -> P.
Proof.
  Check modus_ponens.
  move=> P.
  by apply: (modus_ponens P P).
Qed.

(* transitivity of implication *)
Lemma exo3 P Q R : (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  move=> HPQ HQR HP.

  apply: HQR.
  by apply: HPQ.
  Undo 2.
  Check HQR (HPQ HP).
  by apply: (HQR (HPQ HP)).
Qed.

End move_and_apply_tactics.

Section logical_connectives.

Print True.
Check True.
Check I.

Goal True.
apply: I.
Qed.

Print False.

Goal True -> False.
case.
Abort.                                      (* OK *)

Check False_ind.

Goal False -> 1 = 0.
case.
Qed.

Print and.
Print and_ind.
Print and_rect.

Goal forall P Q, P /\ Q -> Q /\ P.
move=> P Q.
case.
move=> p q.
split.
exact q.
exact p.
Qed.

Print or.
Print or_ind.

Check (or_intror False I).
About or_intror.
Check (@or_intror False True I).
Check (@or_intror False _ I).
Check (@or_intror _ _ I).
Check (@or_intror _ _ I) :  False \/ True.

Goal forall A B, A \/ B -> B \/ A.
move=> A B.
  case=> [a | b].
  right.
  exact a.
left.
exact b.
Qed.

End logical_connectives.

Lemma exo4 : False \/ True.
Proof.
  by right.
Qed.

Lemma exo5 : forall A B C : Prop, A /\ B <-> B /\ A.
Proof.
  move=> A B C.
  by split; case.
Qed.

Lemma exo6 (A B C : Prop) : A /\ B /\ C ->
  (A /\ B) /\ C.
Proof.
  move=> HABC.
  case: HABC=> HA HBC.
  case: HBC=> HB HC.
  by split; [split|].
Qed.

Section Set_Prop.

Check nat.

Goal 0 = 1 -> False.
move=> abs.
discriminate.
Qed.

Goal (exists n : nat, True) -> nat.
Fail case.
(*  Error: Case analysis on sort Set is not allowed for inductive definition ex *)
Abort.

Goal {n : nat | True} -> nat.
case.
move=> m _.
exact m.
Undo 1.
by apply: m.                                (* 補足 *)
Qed.

Goal forall n m : nat, n = m /\ n <> m -> nat.
move=> n m.
case => nm nm'.
exact O.
Undo 1.
by apply: O.                                (* 補足 *)
Qed.

(* 追加 *)
Goal nat.
apply: 10.
Qed.

End Set_Prop.

(* ssr_jsst2014_product_sample.v に分離した。 *)