Require Import LogicMain.
Import ListNotations.

Obligation Tactic := congruence.

Inductive byzantineConsensus :=
	R' | B' | A | X | CR' | VR' | B | VB' | A' | P | R | Y | Z | VA' |  CA'.

Program Instance modelPortsEqDec : EqDec byzantineConsensus eq :=
	{equiv_dec x y :=
		 match x, y with
		| R' , R' => in_left
		| R' , B' => in_right
		| R' , A => in_right
		| R' , X => in_right
		| R' , CR' => in_right
		| R' , VR' => in_right
		| R' , B => in_right
		| R' , VB' => in_right
		| R' , A' => in_right
		| R' , P => in_right
		| R' , R => in_right
		| R' , Y => in_right
		| R' , Z => in_right
		| R' , VA' => in_right
		| R' , CA' => in_right
		| B' , R' => in_right
		| B' , B' => in_left
		| B' , A => in_right
		| B' , X => in_right
		| B' , CR' => in_right
		| B' , VR' => in_right
		| B' , B => in_right
		| B' , VB' => in_right
		| B' , A' => in_right
		| B' , P => in_right
		| B' , R => in_right
		| B' , Y => in_right
		| B' , Z => in_right
		| B' , VA' => in_right
		| B' , CA' => in_right
		| A , R' => in_right
		| A , B' => in_right
		| A , A => in_left
		| A , X => in_right
		| A , CR' => in_right
		| A , VR' => in_right
		| A , B => in_right
		| A , VB' => in_right
		| A , A' => in_right
		| A , P => in_right
		| A , R => in_right
		| A , Y => in_right
		| A , Z => in_right
		| A , VA' => in_right
		| A , CA' => in_right
		| X , R' => in_right
		| X , B' => in_right
		| X , A => in_right
		| X , X => in_left
		| X , CR' => in_right
		| X , VR' => in_right
		| X , B => in_right
		| X , VB' => in_right
		| X , A' => in_right
		| X , P => in_right
		| X , R => in_right
		| X , Y => in_right
		| X , Z => in_right
		| X , VA' => in_right
		| X , CA' => in_right
		| CR' , R' => in_right
		| CR' , B' => in_right
		| CR' , A => in_right
		| CR' , X => in_right
		| CR' , CR' => in_left
		| CR' , VR' => in_right
		| CR' , B => in_right
		| CR' , VB' => in_right
		| CR' , A' => in_right
		| CR' , P => in_right
		| CR' , R => in_right
		| CR' , Y => in_right
		| CR' , Z => in_right
		| CR' , VA' => in_right
		| CR' , CA' => in_right
		| VR' , R' => in_right
		| VR' , B' => in_right
		| VR' , A => in_right
		| VR' , X => in_right
		| VR' , CR' => in_right
		| VR' , VR' => in_left
		| VR' , B => in_right
		| VR' , VB' => in_right
		| VR' , A' => in_right
		| VR' , P => in_right
		| VR' , R => in_right
		| VR' , Y => in_right
		| VR' , Z => in_right
		| VR' , VA' => in_right
		| VR' , CA' => in_right
		| B , R' => in_right
		| B , B' => in_right
		| B , A => in_right
		| B , X => in_right
		| B , CR' => in_right
		| B , VR' => in_right
		| B , B => in_left
		| B , VB' => in_right
		| B , A' => in_right
		| B , P => in_right
		| B , R => in_right
		| B , Y => in_right
		| B , Z => in_right
		| B , VA' => in_right
		| B , CA' => in_right
		| VB' , R' => in_right
		| VB' , B' => in_right
		| VB' , A => in_right
		| VB' , X => in_right
		| VB' , CR' => in_right
		| VB' , VR' => in_right
		| VB' , B => in_right
		| VB' , VB' => in_left
		| VB' , A' => in_right
		| VB' , P => in_right
		| VB' , R => in_right
		| VB' , Y => in_right
		| VB' , Z => in_right
		| VB' , VA' => in_right
		| VB' , CA' => in_right
		| A' , R' => in_right
		| A' , B' => in_right
		| A' , A => in_right
		| A' , X => in_right
		| A' , CR' => in_right
		| A' , VR' => in_right
		| A' , B => in_right
		| A' , VB' => in_right
		| A' , A' => in_left
		| A' , P => in_right
		| A' , R => in_right
		| A' , Y => in_right
		| A' , Z => in_right
		| A' , VA' => in_right
		| A' , CA' => in_right
		| P , R' => in_right
		| P , B' => in_right
		| P , A => in_right
		| P , X => in_right
		| P , CR' => in_right
		| P , VR' => in_right
		| P , B => in_right
		| P , VB' => in_right
		| P , A' => in_right
		| P , P => in_left
		| P , R => in_right
		| P , Y => in_right
		| P , Z => in_right
		| P , VA' => in_right
		| P , CA' => in_right
		| R , R' => in_right
		| R , B' => in_right
		| R , A => in_right
		| R , X => in_right
		| R , CR' => in_right
		| R , VR' => in_right
		| R , B => in_right
		| R , VB' => in_right
		| R , A' => in_right
		| R , P => in_right
		| R , R => in_left
		| R , Y => in_right
		| R , Z => in_right
		| R , VA' => in_right
		| R , CA' => in_right
		| Y , R' => in_right
		| Y , B' => in_right
		| Y , A => in_right
		| Y , X => in_right
		| Y , CR' => in_right
		| Y , VR' => in_right
		| Y , B => in_right
		| Y , VB' => in_right
		| Y , A' => in_right
		| Y , P => in_right
		| Y , R => in_right
		| Y , Y => in_left
		| Y , Z => in_right
		| Y , VA' => in_right
		| Y , CA' => in_right
		| Z , R' => in_right
		| Z , B' => in_right
		| Z , A => in_right
		| Z , X => in_right
		| Z , CR' => in_right
		| Z , VR' => in_right
		| Z , B => in_right
		| Z , VB' => in_right
		| Z , A' => in_right
		| Z , P => in_right
		| Z , R => in_right
		| Z , Y => in_right
		| Z , Z => in_left
		| Z , VA' => in_right
		| Z , CA' => in_right
		| VA' , R' => in_right
		| VA' , B' => in_right
		| VA' , A => in_right
		| VA' , X => in_right
		| VA' , CR' => in_right
		| VA' , VR' => in_right
		| VA' , B => in_right
		| VA' , VB' => in_right
		| VA' , A' => in_right
		| VA' , P => in_right
		| VA' , R => in_right
		| VA' , Y => in_right
		| VA' , Z => in_right
		| VA' , VA' => in_left
		| VA' , CA' => in_right
		| CA' , R' => in_right
		| CA' , B' => in_right
		| CA' , A => in_right
		| CA' , X => in_right
		| CA' , CR' => in_right
		| CA' , VR' => in_right
		| CA' , B => in_right
		| CA' , VB' => in_right
		| CA' , A' => in_right
		| CA' , P => in_right
		| CA' , R => in_right
		| CA' , Y => in_right
		| CA' , Z => in_right
		| CA' , VA' => in_right
		| CA' , CA' => in_left
	end
	}.

Close Scope Q_scope.

Program Instance dataProp_eqdec2 {name data : Type} `{EqDec name eq} `{EqDec data eq} : EqDec (dataProp name data) eq :=
    {
      equiv_dec x y :=
        match x, y with
          | dataInPorts a x, dataInPorts b y => if a == b then if x == y then in_left else in_right else in_right
          | dataInFifo a x b, dataInFifo c y d => if a == c then if b == d then if x == y then in_left else in_right else in_right else in_right
          | dataBothPorts _ a b, dataBothPorts _ c d => if a == c then if b == d then in_left else in_right else in_right
          | dataInPorts a x , dataInFifo b y c => in_right
          | dataInPorts a x , dataBothPorts _ b y => in_right
          | dataInFifo a x b , dataInPorts c y => in_right
          | dataInFifo a x b , dataBothPorts _ c y => in_right
          | dataBothPorts _ a b , dataInPorts c y => in_right
          | dataBothPorts _ a b , dataInFifo c y d  => in_right
        end
     }.

Definition timerProp (n : nat) := true.

Definition presetTimerProp (n: nat) :=
  match n with
  | 0 => true
  | Datatypes.S m => false
  end.

Definition timerAPProp (n : nat) :=
  match n with
  | 1 => true
  | 0 => false
  | Datatypes.S m => false
  end.

Definition timerBPProp (n:nat) :=
  match n with
  | 0 => true
  | Datatypes.S m => false
  end.

Definition timerVAProp (n:nat) :=
  match n with
  | 0 => true
  | Datatypes.S m => false
  end.

Definition BizantineConsensusFlowProgram := [flowFilter timerProp R' B'; flowSync nat B' A; flowSync nat B' X;
flowFilter timerProp X CR'; flowFilter timerProp A VR'; flowFilter timerProp B VB'; flowFilter timerBPProp A' B;
flowFilter timerAPProp A' P; flowFilter timerProp  P R; flowSync nat R Y; flowSync nat R Z; flowFilter timerVAProp Y VA';
flowFilter timerProp Z CA'].

Definition BizantineConsensusBlockProgram := [flowSyncdrain A X; flowaSyncdrain VR' CR'; flowaSyncdrain VB' A;
flowaSyncdrain VA' CA'; flowSyncdrain Y Z].

Definition pi := sProgram (reoProg BizantineConsensusFlowProgram BizantineConsensusBlockProgram).

Definition piStar := star (reoProg BizantineConsensusFlowProgram BizantineConsensusBlockProgram).

Definition t := [dataPorts A' 1].

(*Property 1 - For the data to be in CA, it requires no data in any of the V's*)

 Definition property1 := Eval compute in constructModel
  [R'; B' ; A ; X ; CR' ; VR' ; B ; VB' ; A' ; P ; R ; Y ; Z ; VA'; CA'] [t]
  (((imp (box t piStar(proposition (dataInPorts CA' 1)))
         (box t piStar(and (and (neg(proposition (dataInPorts VA' 1)))
                           (neg(proposition (dataInPorts VB' 1))))
                      (neg(proposition (dataInPorts VR' 1))))))))
  (length(BizantineConsensusFlowProgram) + length(BizantineConsensusBlockProgram)).

Eval compute in property1.

Eval compute in singleFormulaVerify property1 (((imp
                  (box t piStar(proposition (dataInPorts CA' 1)))
                  (box t piStar(and (and (neg(proposition (dataInPorts VA' 1))) (neg(proposition (dataInPorts VB' 1))))
                        (neg(proposition (dataInPorts VR' 1)))))))) t.

(*Property 2 - For the data to be in CA, it requires no data in any of the V's*)

Definition t' := [dataPorts A' 0].

(*  Definition property2 := Eval compute in constructModel
  [R'; B' ; A ; X ; CR' ; VR' ; B ; VB' ; A' ; P ; R ; Y ; Z ; VA'; CA'] [t']
  (((imp (and(box t' piStar(proposition (dataInPorts VA' 0)))
              (box t' piStar (proposition (dataInPorts VR' 0))))
         (box t' piStar((and (neg(proposition (dataInPorts CA' 0)))
                            (neg(proposition (dataInPorts CR' 0)))))))))
  (length(BizantineConsensusFlowProgram) + length(BizantineConsensusBlockProgram)).  *)

Definition property2 := Eval compute in constructModel
  [R'; B' ; A ; X ; CR' ; VR' ; B ; VB' ; A' ; P ; R ; Y ; Z ; VA'; CA'] [t']
  (((imp ((box t' piStar(proposition (dataInPorts VA' 0))))
         (box t' piStar((and (neg(proposition (dataInPorts CA' 0)))
                            (neg(proposition (dataInPorts CR' 0)))))))))
  (length(BizantineConsensusFlowProgram) + length(BizantineConsensusBlockProgram)).

Eval compute in property2.

Eval compute in singleFormulaVerify property2 (((imp ((box t' piStar(proposition (dataInPorts VA' 0))))
         (box t' piStar((and (neg(proposition (dataInPorts CA' 0)))
                            (neg(proposition (dataInPorts CR' 0))))))))) t.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.ModalLogic.Syntax.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.Extensions.Syntax_CoreTransit.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.MinimunLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.ModalLogic.ProofTheory.ModalLogic.
Require Import Logic.ModalLogic.ProofTheory.RewriteClass.
Require Import Logic.ModalLogic.ProofTheory.IntuitionisticDerivedRules.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.Extensions.ProofTheory.Stable.
Require Import Logic.Extensions.ProofTheory.ModalSeparation.
Require Import Logic.Extensions.ProofTheory.Corable.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import CoreTransitNotation.

Class CoreTransitSeparationLogic (L: Language) {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {sL: SeparationLanguage L} {CtsL: CoreTransitSeparationLanguage L} (Gamma: ProofTheory L) {minAX: MinimunAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {sGamma: SeparationLogic L Gamma} {CosGamma: Corable L Gamma}:= {
  core_tr_SystemK: @SystemK L minL pL (ct_mL L) Gamma minAX ipGamma;
  core_tr_PTransparent: @PropositionalTransparentModality L minL pL (ct_mL L) Gamma minAX ipGamma core_tr_SystemK;
  core_tr_STransparent1: @SeparationTransparentModality1 L minL pL (ct_mL L) sL Gamma minAX ipGamma core_tr_SystemK sGamma;
  core_tr_STransparent2: @SeparationTransparentModality2 L minL pL (ct_mL L) sL Gamma minAX ipGamma core_tr_SystemK sGamma;
  core_tr_andp_sepcon: forall x y, |-- core_tr (x && y) --> core_tr (x * y);
  coreAbsorb: @ModalAbsorbStable L minL (ct_mL L) Gamma corable
}.

Section CoreTransit.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {sL: SeparationLanguage L}
        {CtsL: CoreTransitSeparationLanguage L}
        {Gamma: ProofTheory L}
        {minAX: MinimunAxiomatization L Gamma}
        {ipGamma: IntuitionisticPropositionalLogic L Gamma}
        {sGamma: SeparationLogic L Gamma}
        {CosGamma: Corable L Gamma}
        {CtsGamma: CoreTransitSeparationLogic L Gamma}.

Lemma core_tr_andp: forall x y, |-- core_tr (x && y) <--> core_tr x && core_tr y.
Proof. intros. apply (@boxp_andp L _ _ (ct_mL L) Gamma _ _ core_tr_SystemK). Qed.

Lemma core_tr_orp: forall x y, |-- core_tr (x || y) <--> core_tr x || core_tr y.
Proof. intros. apply (@boxp_orp L _ _ (ct_mL L) Gamma _ _ _ core_tr_PTransparent). Qed.

Lemma core_tr_sepcon: forall x y, |-- core_tr x * core_tr y <--> core_tr (x * y).
Proof.
  intros.
  apply solve_andp_intros.
  + apply (@sepcon_boxp L _ _ (ct_mL L) sL Gamma _ _ _ _ core_tr_STransparent1).
  + apply (@boxp_sepcon L _ _ (ct_mL L) sL Gamma _ _ _ _ core_tr_STransparent2).
Qed.

Instance core_tr_proper_impp: Proper ((fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) core_tr.
Proof. apply (@boxp_proper_impp L _ _ (ct_mL L) Gamma _ _ core_tr_SystemK). Qed.

Instance core_tr_proper_iffp: Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) core_tr.
Proof. apply (@boxp_proper_iffp L _ _ (ct_mL L) Gamma _ _ core_tr_SystemK). Qed.

Lemma core_tr_andp_sepcon_iffp {GC: GarbageCollectSeparationLogic L Gamma}: forall x y, |-- core_tr (x && y) <--> core_tr (x * y).
Proof.
  intros.
  apply solve_andp_intros.
  + apply core_tr_andp_sepcon.
  + (* TODO: modularize this proof. *)
    pose proof (@axiom_K L _ _ (ct_mL L) Gamma _ _ core_tr_SystemK).
    simpl in H; rewrite <- H; clear H.
    apply (@rule_N L _ _ (ct_mL L) Gamma _ _ core_tr_SystemK).
    apply solve_impp_andp.
    - rewrite <- (sepcon_elim1 x y) at 2.
      apply provable_impp_refl.
    - rewrite <- (sepcon_elim2 x y) at 2.
      apply provable_impp_refl.
Qed.

Lemma core_tr_dup {GC: GarbageCollectSeparationLogic L Gamma}: forall x, |-- core_tr x <--> core_tr x * core_tr x.
Proof.
  intros.
  rewrite <- (andp_dup x) at 1.
  rewrite core_tr_andp_sepcon_iffp.
  rewrite core_tr_sepcon.
  apply provable_iffp_refl.
Qed.

Lemma core_tr_absorb_corable: forall x, corable x -> |-- x --> core_tr x.
Proof. intros. apply (@boxp_absorb_stable _ _ (ct_mL L) Gamma corable coreAbsorb); auto. Qed.

End CoreTransit.

Existing Instances core_tr_proper_impp core_tr_proper_iffp.


Require Import Core.Core Core.StructNormalizer VstLib.
Require Import VST.floyd.proofauto.
(* Require Import BFL.Exec. *)
Require Import Clight.ber_tlv_length.
Require Import Core.Notations Core.SepLemmas Core.Tactics Core.VstTactics.

Instance CompSpecs : compspecs. Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs. Proof. mk_varspecs prog. Defined.

Section Ber_fetch_len.

Open Scope  bool.
Open Scope int.
Fixpoint aux_loop ptr len skip oct size sizeofval :
   (int * int * int * int) :=
  match ptr with
  | x :: xs => if (negb (oct == 0)) && ((skip + 1) <=u size)
              then if (len >> ((Int.repr 8 * sizeofval) - (Int.repr 8 + 1))) == 0
                   then let len' := Int.or (len << Int.repr 8) x in
                        aux_loop xs len' (skip + 1) (oct - 1) size sizeofval
                   else (Int.neg 1, oct, len, skip)
              else (0, oct, len, skip)
  | nil => (0, 0, 0, 0)
  end.

Definition bfl_loop ptr len  skip oct size sizeofval
  := aux_loop ptr len skip oct size sizeofval.

Definition ber_fetch_len ptr isc len_r size sizeofval rssizem :
   (int * int) :=
  if eq_dec size 0
  then (0, len_r)
  else let oct := Znth 0 ptr in
       if eq_dec (oct & Int.repr 128) 0
       then (1, oct)
       else if (negb (isc =? 0)) && (oct == Int.repr 128)
            then (1, Int.neg 1)
            else if eq_dec oct (Int.repr 255)
                 then (Int.neg 1, len_r)
                 else let oct := oct & (Int.repr 127) in
                      match bfl_loop (skipn 1%nat ptr) 0 1 oct size sizeofval with
                      | (z, oct, len, skip) => if eq_dec z (Int.neg 1)
                                       then (z, len_r)
                                       else
                                         if eq_dec oct 0
                                              then if (len < 0) || (rssizem < len)
                                                   then (Int.neg 1, len_r)
                                                   else (skip, len)
                                              else (0, len_r)
                      end.
Open Scope Z.

Definition ber_fetch_len_spec : ident * funspec :=
  DECLARE _ber_fetch_length
    WITH c : Z,  b : block, i : ptrofs,
         size : int, data : list int,
         len_r : val
    PRE [tint, tptr tvoid, tuint, tptr tint]
      PROP ((* definite length *)
           (Znth 0 data & Int.repr 128)%int = 0%int;
             (* primitive tag *)
            c = 0;
            Ptrofs.unsigned i + len data < Ptrofs.modulus;
            Forall (fun x => 0 <= Int.unsigned x <= Byte.max_unsigned) data;
            0 < len data)
      PARAMS (Vint (Int.repr 0); (Vptr b i); Vint size; len_r)
      GLOBALS ()
      SEP (data_at Tsh (tarray tuchar (Zlength data))
                   (map Vint data) (Vptr b i);
           data_at_ Tsh tint len_r)
    POST [tint]
      let r := ber_fetch_len data c 0%int size (Int.repr (sizeof tuint))
       (Int.repr (Int.max_unsigned)) in
      PROP ()
      LOCAL (temp ret_temp (Vint ((fst r))))
      SEP (data_at Tsh (tarray tuchar (Zlength data))
                   (map Vint (data)) (Vptr b i);
           if eq_dec (fst r) 0%int
           then  data_at_ Tsh tint len_r
           else if eq_dec (fst r) (Int.neg 1%int)
                then  data_at_ Tsh tint len_r
                else
                  data_at Tsh tint (Vint (snd r)) len_r).

Definition Gprog := ltac:(with_library prog [ber_fetch_len_spec]).

Lemma Znth_0_cons_sublist :  forall (ls : list int),
             0 < len ls ->
             Znth 0 ls :: sublist 1 (len ls) ls = ls.
  { intros.
    erewrite Znth_cons_sublist.
    autorewrite with sublist.
    auto. lia. }
Qed.

Theorem ber_fetch_len_correctness : semax_body Vprog Gprog
                                          (normalize_function f_ber_fetch_length
                                                              composites)
                                          ber_fetch_len_spec.
Proof.
  start_function.
  forward.
  forward_if.
  forward.
  assert (data_at Tsh (tarray tuchar (len data)) (map Vint data) (Vptr b i) =
          (data_at Tsh tuchar (Vint (Znth 0 data)) (Vptr b i) *
          data_at Tsh (tarray tuchar (len data - 1))
                  (sublist 1 (len data) (map Vint data))
                  (Vptr b (i + 1)%ptrofs))%logic) as D.
  { erewrite split_non_empty_list
      with (i := Vint (Znth 0 data))
           (j2 := len data - 1)
           (ls' := sublist 1 (len data) (map Vint data)).
    auto. erewrite <- map_sublist;
            erewrite <- map_cons;
            f_equal; erewrite Znth_0_cons_sublist; try lia; auto.
    all: autorewrite with sublist; strip_repr. }
  erewrite D.
  Intros.
  forward.
  entailer!.
  eapply Forall_Znth with (i0 := 0) in H2; try lia.
  forward_if; try contradiction.
  forward.
  forward.
  unfold ber_fetch_len.
  repeat rewrite_if_b.
  simpl.
  erewrite <- D.
  entailer!.
Qed.

(* Indefinite length branch:
- forward_if (temp _t'1 Vzero); try contradiction.
  + admit.
    (* forward.
       entailer!. *)
  + forward_if; try contradiction.
    forward_if.
    * admit. (* forward.
      { unfold ber_fetch_len.
        repeat rewrite_if_b.
        simpl.
        entailer!.
        admit. (* split as before *) } *)
    * repeat forward.
      (* Loop *)
       match goal with
       | [ _ : _ |-  semax _ ?P ?C ?Post ] =>
         forward_loop (PROP ( )
                       LOCAL (temp _skipped (Vint (Int.repr 1));
                              temp _buf (Vptr b (i + 1)%ptrofs);
                              temp _len (Vint (Int.repr 0));
                              temp _oct (Vint (Znth 0 data & Int.repr 127)%int);
                              temp _t'1 Vzero;
                              temp __is_constructed (Vint (Int.repr 0));
                              temp _bufptr (Vptr b i);
                              temp _size (Vint size);
                              temp _len_r len_r)
                       SEP (data_at Tsh tuchar (Vint (Znth 0 data)) (Vptr b i);
                            data_at Tsh (tarray tuchar (len data - 1))
                                    (sublist 1 (len data) (map Vint data))
                                    (Vptr b (i + 1)%ptrofs); data_at_ Tsh tint len_r))
         break: P
        end.
       -- (* PRE to LI *)
         entailer!.
       -- (* LI C LI *)
         forward_if [temp _skipped (if eq_dec (Znth 0 data & Int.repr 127)%int 0%int
                                   then Vone
                                   else (Vint (1 + 1)%int)) ;
                     temp _t'2 (if eq_dec (Znth 0 data & Int.repr 127)%int 0%int
                                then Vzero
                                else Val.of_bool ((1 + 1)%int <=u size))].
         ++ repeat forward.
            repeat rewrite_if_b.
            entailer!.
         ++ forward.
            repeat rewrite_if_b.
            entailer!.
         Arguments eq_dec : simpl never.
         ++ forward_if.
            ** forward_if; try discriminate.
               normalize.
               erewrite split_non_empty_list
                 with (i := Vint (Znth 1 data))
                      (j2 := len data - 2)
                      (ls' := sublist 2 (len data) (map Vint data)).
               Intros.
               forward.
               entailer!.
               eapply Forall_Znth with (i0 := 1) in H1; try lia.
               admit. (* 0 <= 1 < len data *)
               repeat forward.
               entailer!.
               1-5: admit.
            ** forward.
               entailer!.
               admit.
       -- (* BREAK rest POST *)
         forward_if.
         forward_if (temp _t'4 (if (0 <? 0)
                                then Vone
                                else (Val.of_bool ((-1) >> 1 >> 1 <? 0)))).
         ** forward.
            entailer!.
         ** forward.
            entailer!.
            admit.
         ** forward_if.
            --- forward.
                entailer!.
                admit.
                admit.
            --- forward.
                forward.
                entailer!.
                admit.
                admit.
         ** forward.
            entailer!.
            admit.
            admit.
Admitted.
*)

End Ber_fetch_len.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__3__6b.
Require Export lemma__betweennotequal.
Require Export lemma__congruenceflip.
Require Export lemma__congruencesymmetric.
Require Export lemma__differenceofparts.
Require Export lemma__equalitysymmetric.
Require Export lemma__extensionunique.
Require Export lemma__interior5.
Require Export lemma__partnotequalwhole.
Require Export lemma__ray1.
Require Export logic.
Definition lemma__layoffunique : forall A B C D, (euclidean__defs.Out A B C) -> ((euclidean__defs.Out A B D) -> ((euclidean__axioms.Cong A C A D) -> (C = D))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro H.
intro H0.
intro H1.
assert (* Cut *) (euclidean__axioms.Cong A D A C) as H2.
- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A A C D H1).
- assert (* Cut *) ((euclidean__axioms.BetS A C B) \/ ((B = C) \/ (euclidean__axioms.BetS A B C))) as H3.
-- apply (@lemma__ray1.lemma__ray1 A B C H).
-- assert (* Cut *) ((euclidean__axioms.BetS A D B) \/ ((B = D) \/ (euclidean__axioms.BetS A B D))) as H4.
--- apply (@lemma__ray1.lemma__ray1 A B D H0).
--- assert (* Cut *) (euclidean__axioms.Cong A B A B) as H5.
---- apply (@euclidean__axioms.cn__congruencereflexive A B).
---- assert (* Cut *) (euclidean__axioms.Cong B C B C) as H6.
----- apply (@euclidean__axioms.cn__congruencereflexive B C).
----- assert (* Cut *) (euclidean__axioms.Cong C B C B) as H7.
------ apply (@euclidean__axioms.cn__congruencereflexive C B).
------ assert (* Cut *) (euclidean__axioms.Cong A C A C) as H8.
------- apply (@euclidean__axioms.cn__congruencereflexive A C).
------- assert (* Cut *) (C = D) as H9.
-------- assert ((euclidean__axioms.BetS A C B) \/ ((B = C) \/ (euclidean__axioms.BetS A B C))) as H9 by exact H3.
assert ((euclidean__axioms.BetS A C B) \/ ((B = C) \/ (euclidean__axioms.BetS A B C))) as __TmpHyp by exact H9.
destruct __TmpHyp as [H10|H10].
--------- assert (* Cut *) (C = D) as H11.
---------- assert ((euclidean__axioms.BetS A D B) \/ ((B = D) \/ (euclidean__axioms.BetS A B D))) as H11 by exact H4.
assert ((euclidean__axioms.BetS A D B) \/ ((B = D) \/ (euclidean__axioms.BetS A B D))) as __TmpHyp0 by exact H11.
destruct __TmpHyp0 as [H12|H12].
----------- assert (* Cut *) (euclidean__axioms.Cong C B D B) as H13.
------------ apply (@lemma__differenceofparts.lemma__differenceofparts A C B A D B H1 H5 H10 H12).
------------ assert (* Cut *) (euclidean__axioms.Cong B C B D) as H14.
------------- assert (* Cut *) ((euclidean__axioms.Cong B C B D) /\ ((euclidean__axioms.Cong B C D B) /\ (euclidean__axioms.Cong C B B D))) as H14.
-------------- apply (@lemma__congruenceflip.lemma__congruenceflip C B D B H13).
-------------- destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
exact H15.
------------- assert (* Cut *) (euclidean__axioms.Cong C C C D) as H15.
-------------- apply (@lemma__interior5.lemma__interior5 A C B C A C B D H10 H10 H8 H7 H1 H14).
-------------- assert (* Cut *) (euclidean__axioms.Cong C D C C) as H16.
--------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric C C C D H15).
--------------- assert (* Cut *) (~(euclidean__axioms.neq C D)) as H17.
---------------- intro H17.
assert (* Cut *) (euclidean__axioms.neq C C) as H18.
----------------- apply (@euclidean__axioms.axiom__nocollapse C D C C H17 H16).
----------------- assert (* Cut *) (C = C) as H19.
------------------ assert (* Cut *) (False) as H19.
------------------- assert (* Cut *) (C = C) as H19.
-------------------- apply (@logic.eq__refl Point C).
-------------------- apply (@H18 H19).
------------------- assert (False) as H20 by exact H19.
apply (@logic.eq__refl Point C).
------------------ apply (@H18 H19).
---------------- apply (@euclidean__tactics.NNPP (C = D)).
-----------------intro H18.
assert (* Cut *) (False) as H19.
------------------ apply (@H17 H18).
------------------ contradiction H19.

----------- destruct H12 as [H13|H13].
------------ assert (* Cut *) (euclidean__axioms.BetS A C D) as H14.
------------- apply (@eq__ind__r euclidean__axioms.Point D (fun B0 => (euclidean__defs.Out A B0 C) -> ((euclidean__defs.Out A B0 D) -> ((euclidean__axioms.Cong A B0 A B0) -> ((euclidean__axioms.Cong B0 C B0 C) -> ((euclidean__axioms.Cong C B0 C B0) -> ((euclidean__axioms.BetS A C B0) -> (euclidean__axioms.BetS A C D)))))))) with (x := B).
--------------intro H14.
intro H15.
intro H16.
intro H17.
intro H18.
intro H19.
exact H19.

-------------- exact H13.
-------------- exact H.
-------------- exact H0.
-------------- exact H5.
-------------- exact H6.
-------------- exact H7.
-------------- exact H10.
------------- assert (* Cut *) (~(euclidean__axioms.neq C D)) as H15.
-------------- intro H15.
assert (* Cut *) (~(euclidean__axioms.Cong A C A D)) as H16.
--------------- apply (@lemma__partnotequalwhole.lemma__partnotequalwhole A C D H14).
--------------- apply (@H16 H1).
-------------- apply (@euclidean__tactics.NNPP (C = D)).
---------------intro H16.
assert (* Cut *) (False) as H17.
---------------- apply (@H15 H16).
---------------- contradiction H17.

------------ assert (* Cut *) (euclidean__axioms.BetS A C D) as H14.
------------- apply (@lemma__3__6b.lemma__3__6b A C B D H10 H13).
------------- assert (* Cut *) (~(euclidean__axioms.neq C D)) as H15.
-------------- intro H15.
assert (* Cut *) (~(euclidean__axioms.Cong A C A D)) as H16.
--------------- apply (@lemma__partnotequalwhole.lemma__partnotequalwhole A C D H14).
--------------- apply (@H16 H1).
-------------- apply (@euclidean__tactics.NNPP (C = D)).
---------------intro H16.
assert (* Cut *) (False) as H17.
---------------- apply (@H15 H16).
---------------- contradiction H17.

---------- exact H11.
--------- destruct H10 as [H11|H11].
---------- assert (* Cut *) (euclidean__axioms.Cong A B A D) as H12.
----------- apply (@eq__ind__r euclidean__axioms.Point C (fun B0 => (euclidean__defs.Out A B0 C) -> ((euclidean__defs.Out A B0 D) -> (((euclidean__axioms.BetS A D B0) \/ ((B0 = D) \/ (euclidean__axioms.BetS A B0 D))) -> ((euclidean__axioms.Cong A B0 A B0) -> ((euclidean__axioms.Cong B0 C B0 C) -> ((euclidean__axioms.Cong C B0 C B0) -> (euclidean__axioms.Cong A B0 A D)))))))) with (x := B).
------------intro H12.
intro H13.
intro H14.
intro H15.
intro H16.
intro H17.
exact H1.

------------ exact H11.
------------ exact H.
------------ exact H0.
------------ exact H4.
------------ exact H5.
------------ exact H6.
------------ exact H7.
----------- assert (* Cut *) (euclidean__axioms.Cong A D A B) as H13.
------------ apply (@eq__ind__r euclidean__axioms.Point C (fun B0 => (euclidean__defs.Out A B0 C) -> ((euclidean__defs.Out A B0 D) -> (((euclidean__axioms.BetS A D B0) \/ ((B0 = D) \/ (euclidean__axioms.BetS A B0 D))) -> ((euclidean__axioms.Cong A B0 A B0) -> ((euclidean__axioms.Cong B0 C B0 C) -> ((euclidean__axioms.Cong C B0 C B0) -> ((euclidean__axioms.Cong A B0 A D) -> (euclidean__axioms.Cong A D A B0))))))))) with (x := B).
-------------intro H13.
intro H14.
intro H15.
intro H16.
intro H17.
intro H18.
intro H19.
exact H2.

------------- exact H11.
------------- exact H.
------------- exact H0.
------------- exact H4.
------------- exact H5.
------------- exact H6.
------------- exact H7.
------------- exact H12.
------------ assert (* Cut *) (C = D) as H14.
------------- assert ((euclidean__axioms.BetS A D B) \/ ((B = D) \/ (euclidean__axioms.BetS A B D))) as H14 by exact H4.
assert ((euclidean__axioms.BetS A D B) \/ ((B = D) \/ (euclidean__axioms.BetS A B D))) as __TmpHyp0 by exact H14.
destruct __TmpHyp0 as [H15|H15].
-------------- assert (* Cut *) (~(euclidean__axioms.neq C D)) as H16.
--------------- intro H16.
assert (* Cut *) (~(euclidean__axioms.Cong A D A B)) as H17.
---------------- apply (@lemma__partnotequalwhole.lemma__partnotequalwhole A D B H15).
---------------- apply (@H17 H13).
--------------- apply (@euclidean__tactics.NNPP (C = D)).
----------------intro H17.
assert (* Cut *) (False) as H18.
----------------- apply (@H16 H17).
----------------- contradiction H18.

-------------- destruct H15 as [H16|H16].
--------------- assert (* Cut *) (C = B) as H17.
---------------- apply (@lemma__equalitysymmetric.lemma__equalitysymmetric C B H11).
---------------- assert (* Cut *) (D = B) as H18.
----------------- apply (@eq__ind euclidean__axioms.Point B (fun C0 => (euclidean__defs.Out A B C0) -> ((euclidean__axioms.Cong A C0 A D) -> ((euclidean__axioms.Cong A D A C0) -> ((euclidean__axioms.Cong B C0 B C0) -> ((euclidean__axioms.Cong C0 B C0 B) -> ((euclidean__axioms.Cong A C0 A C0) -> ((C0 = B) -> (D = B))))))))) with (y := C).
------------------intro H18.
intro H19.
intro H20.
intro H21.
intro H22.
intro H23.
intro H24.
apply (@eq__ind__r euclidean__axioms.Point D (fun B0 => (euclidean__defs.Out A B0 B0) -> ((euclidean__defs.Out A B0 D) -> ((euclidean__axioms.Cong A D A B0) -> ((euclidean__axioms.Cong A B0 A D) -> ((euclidean__axioms.Cong A B0 A B0) -> ((euclidean__axioms.Cong A B0 A B0) -> ((euclidean__axioms.Cong B0 B0 B0 B0) -> ((euclidean__axioms.Cong B0 B0 B0 B0) -> ((euclidean__axioms.Cong A B0 A D) -> ((euclidean__axioms.Cong A D A B0) -> ((B0 = B0) -> (D = B0))))))))))))) with (x := B).
-------------------intro H25.
intro H26.
intro H27.
intro H28.
intro H29.
intro H30.
intro H31.
intro H32.
intro H33.
intro H34.
intro H35.
exact H35.

------------------- exact H16.
------------------- exact H18.
------------------- exact H0.
------------------- exact H20.
------------------- exact H19.
------------------- exact H5.
------------------- exact H23.
------------------- exact H22.
------------------- exact H21.
------------------- exact H12.
------------------- exact H13.
------------------- exact H24.

------------------ exact H11.
------------------ exact H.
------------------ exact H1.
------------------ exact H2.
------------------ exact H6.
------------------ exact H7.
------------------ exact H8.
------------------ exact H17.
----------------- assert (* Cut *) (C = D) as H19.
------------------ apply (@eq__ind euclidean__axioms.Point B (fun D0 => (euclidean__defs.Out A B D0) -> ((euclidean__axioms.Cong A C A D0) -> ((euclidean__axioms.Cong A D0 A C) -> ((euclidean__axioms.Cong A B A D0) -> ((euclidean__axioms.Cong A D0 A B) -> ((D0 = B) -> (C = D0)))))))) with (y := D).
-------------------intro H19.
intro H20.
intro H21.
intro H22.
intro H23.
intro H24.
apply (@eq__ind euclidean__axioms.Point B (fun C0 => (euclidean__defs.Out A B C0) -> ((euclidean__axioms.Cong A B A C0) -> ((euclidean__axioms.Cong A C0 A B) -> ((euclidean__axioms.Cong B C0 B C0) -> ((euclidean__axioms.Cong C0 B C0 B) -> ((euclidean__axioms.Cong A C0 A C0) -> ((C0 = B) -> ((B = B) -> (C0 = B)))))))))) with (y := C).
--------------------intro H25.
intro H26.
intro H27.
intro H28.
intro H29.
intro H30.
intro H31.
assert (B = B) as H32 by exact H31.
intro H33.
exact H33.

-------------------- exact H11.
-------------------- exact H.
-------------------- exact H21.
-------------------- exact H20.
-------------------- exact H6.
-------------------- exact H7.
-------------------- exact H8.
-------------------- exact H17.
-------------------- exact H24.

------------------- exact H16.
------------------- exact H0.
------------------- exact H1.
------------------- exact H2.
------------------- exact H12.
------------------- exact H13.
------------------- exact H18.
------------------ exact H19.
--------------- assert (* Cut *) (euclidean__axioms.BetS A C D) as H17.
---------------- apply (@eq__ind__r euclidean__axioms.Point C (fun B0 => (euclidean__defs.Out A B0 C) -> ((euclidean__defs.Out A B0 D) -> ((euclidean__axioms.Cong A B0 A B0) -> ((euclidean__axioms.Cong B0 C B0 C) -> ((euclidean__axioms.Cong C B0 C B0) -> ((euclidean__axioms.Cong A B0 A D) -> ((euclidean__axioms.Cong A D A B0) -> ((euclidean__axioms.BetS A B0 D) -> (euclidean__axioms.BetS A C D)))))))))) with (x := B).
-----------------intro H17.
intro H18.
intro H19.
intro H20.
intro H21.
intro H22.
intro H23.
intro H24.
exact H24.

----------------- exact H11.
----------------- exact H.
----------------- exact H0.
----------------- exact H5.
----------------- exact H6.
----------------- exact H7.
----------------- exact H12.
----------------- exact H13.
----------------- exact H16.
---------------- assert (* Cut *) (~(euclidean__axioms.neq C D)) as H18.
----------------- intro H18.
assert (* Cut *) (~(euclidean__axioms.Cong A C A D)) as H19.
------------------ apply (@lemma__partnotequalwhole.lemma__partnotequalwhole A C D H17).
------------------ apply (@H19 H1).
----------------- apply (@euclidean__tactics.NNPP (C = D)).
------------------intro H19.
assert (* Cut *) (False) as H20.
------------------- apply (@H18 H19).
------------------- contradiction H20.

------------- exact H14.
---------- assert (* Cut *) (C = D) as H12.
----------- assert ((euclidean__axioms.BetS A D B) \/ ((B = D) \/ (euclidean__axioms.BetS A B D))) as H12 by exact H4.
assert ((euclidean__axioms.BetS A D B) \/ ((B = D) \/ (euclidean__axioms.BetS A B D))) as __TmpHyp0 by exact H12.
destruct __TmpHyp0 as [H13|H13].
------------ assert (* Cut *) (euclidean__axioms.BetS A D C) as H14.
------------- apply (@lemma__3__6b.lemma__3__6b A D B C H13 H11).
------------- assert (euclidean__axioms.Cong A D A C) as H15 by exact H2.
assert (* Cut *) (~(euclidean__axioms.neq C D)) as H16.
-------------- intro H16.
assert (* Cut *) (~(euclidean__axioms.Cong A D A C)) as H17.
--------------- apply (@lemma__partnotequalwhole.lemma__partnotequalwhole A D C H14).
--------------- apply (@H17 H15).
-------------- apply (@euclidean__tactics.NNPP (C = D)).
---------------intro H17.
assert (* Cut *) (False) as H18.
---------------- apply (@H16 H17).
---------------- contradiction H18.

------------ destruct H13 as [H14|H14].
------------- assert (* Cut *) (euclidean__axioms.BetS A D C) as H15.
-------------- apply (@eq__ind__r euclidean__axioms.Point D (fun B0 => (euclidean__defs.Out A B0 C) -> ((euclidean__defs.Out A B0 D) -> ((euclidean__axioms.Cong A B0 A B0) -> ((euclidean__axioms.Cong B0 C B0 C) -> ((euclidean__axioms.Cong C B0 C B0) -> ((euclidean__axioms.BetS A B0 C) -> (euclidean__axioms.BetS A D C)))))))) with (x := B).
---------------intro H15.
intro H16.
intro H17.
intro H18.
intro H19.
intro H20.
exact H20.

--------------- exact H14.
--------------- exact H.
--------------- exact H0.
--------------- exact H5.
--------------- exact H6.
--------------- exact H7.
--------------- exact H11.
-------------- assert (* Cut *) (~(euclidean__axioms.neq C D)) as H16.
--------------- intro H16.
assert (* Cut *) (~(euclidean__axioms.Cong A D A C)) as H17.
---------------- apply (@lemma__partnotequalwhole.lemma__partnotequalwhole A D C H15).
---------------- apply (@H17 H2).
--------------- apply (@euclidean__tactics.NNPP (C = D)).
----------------intro H17.
assert (* Cut *) (False) as H18.
----------------- apply (@H16 H17).
----------------- contradiction H18.

------------- assert (* Cut *) (euclidean__axioms.neq A B) as H15.
-------------- assert (* Cut *) ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq A B) /\ (euclidean__axioms.neq A D))) as H15.
--------------- apply (@lemma__betweennotequal.lemma__betweennotequal A B D H14).
--------------- destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
exact H18.
-------------- assert (* Cut *) (euclidean__axioms.Cong B C B D) as H16.
--------------- apply (@lemma__differenceofparts.lemma__differenceofparts A B C A B D H5 H1 H11 H14).
--------------- assert (* Cut *) (C = D) as H17.
---------------- apply (@lemma__extensionunique.lemma__extensionunique A B C D H11 H14 H16).
---------------- exact H17.
----------- exact H12.
-------- exact H9.
Qed.


(** * Well-founded relation on [parse_of] *)
Require Import Coq.Strings.String Coq.Lists.List Coq.Program.Program Coq.Program.Wf Coq.Arith.Wf_nat Coq.Relations.Relation_Definitions.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.

Section rel.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {G : grammar Char}.

  Section size.
    Definition size_of_parse_item'
               (size_of_parse : forall {str pats} (p : parse_of G str pats), nat)
               {str it} (p : parse_of_item G str it) : nat
      := match p with
           | ParseTerminal _ _ _ _ => 0
           | ParseNonTerminal _ _ p' => S (size_of_parse p')
         end.

    Section bodies.
      Context (size_of_parse : forall {str pats} (p : parse_of G str pats), nat)
              (size_of_parse_production : forall {str pat} (p : parse_of_production G str pat), nat).

      Definition size_of_parse_step {str pats} (p : parse_of G str pats) : nat
        := match p with
             | ParseHead _ _ p' => S (@size_of_parse_production _ _ p')
             | ParseTail _ _ p' => S (@size_of_parse _ _ p')
           end.

      Definition size_of_parse_production_step {str pat} (p : parse_of_production G str pat) : nat
        := match p with
             | ParseProductionNil _ => 0
             | ParseProductionCons _ _ _ p' p''
               => S (size_of_parse_item' (@size_of_parse) p' + @size_of_parse_production _ _ p'')
           end.

      Global Arguments size_of_parse_step _ _ !_ / .
      Global Arguments size_of_parse_production_step _ _ !_ / .
    End bodies.

    Fixpoint size_of_parse {str pats} (p : parse_of G str pats) : nat
      := @size_of_parse_step (@size_of_parse) (@size_of_parse_production) str pats p
    with size_of_parse_production {str pat} (p : parse_of_production G str pat) : nat
         := @size_of_parse_production_step (@size_of_parse) (@size_of_parse_production) str pat p.

    Definition size_of_parse_item
               {str it} (p : parse_of_item G str it) : nat
      := @size_of_parse_item' (@size_of_parse) str it p.
  End size.

  Definition parse_of_lt {str pats} : relation (parse_of G str pats)
    := ltof _ size_of_parse.
  Definition parse_of_production_lt {str pat} : relation (parse_of_production G str pat)
    := ltof _ size_of_parse_production.
  Definition parse_of_item_lt {str it} : relation (parse_of_item G str it)
    := ltof _ size_of_parse_item.

  Definition parse_of_wf {str pats} : well_founded (@parse_of_lt str pats)
    := well_founded_ltof _ _.
  Definition parse_of_production_wf {str pat} : well_founded (@parse_of_production_lt str pat)
    := well_founded_ltof _ _.
  Definition parse_of_item_wf {str it} : well_founded (@parse_of_item_lt str it)
    := well_founded_ltof _ _.
End rel.

Ltac simpl_size_of_parse :=
  repeat match goal with
           | [ |- appcontext[@size_of_parse ?Char ?HSLM ?HSL ?G ?str ?pat ?p] ]
             => change (@size_of_parse Char HSLM HSL G str pat p)
                with (@size_of_parse_step Char HSLM HSL G (@size_of_parse Char HSLM HSL G) (@size_of_parse_production Char HSLM HSL G) str pat p);
               simpl @size_of_parse_step
           | [ |- appcontext[@size_of_parse_production ?Char ?HSLM ?HSL ?G ?str ?pat ?p] ]
             => change (@size_of_parse_production Char HSLM HSL G str pat p)
                with (@size_of_parse_production_step Char HSLM HSL G (@size_of_parse Char HSLM HSL G) (@size_of_parse_production Char HSLM HSL G) str pat p);
               simpl @size_of_parse_production_step
         end.


Require Import AutoSep.

(** Factorial is mandatory, isn't it? *)

Inductive factR : W -> W -> Prop :=
| FR0 : factR 0 1
| FRS : forall w r : W, w <> 0 -> factR (w ^- $1) r -> factR w (w ^* r).

Lemma FR0' : forall w : W, w = 0 -> factR w $1.
  intros; subst; apply FR0.
Qed.

Lemma FRS' : forall w r v : W, w <> 0 -> factR (w ^- $1) r -> v = w ^* r -> factR w v.
  intros; subst; eapply FRS; eauto.
Qed.

Hint Resolve FR0' FRS'.

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

Definition fact := bmodule "fact" {{
  bfunction "fact"("n", "acc") [factS]
    "acc" <- 1;;

    [PRE[V] Emp
     POST[R] [| exists r, factR (V "n") r /\ R = V "acc" ^* r |] ]
    While ("n" <> 0) {
      "acc" <- "n" * "acc";;
      "n" <- "n" - 1
    };;

    Return "acc"
  end
}}.

Lemma times_1 : forall (n m x : W), factR n x
  -> m = $1 ^* x
  -> factR n m.
  intros; subst; replace ($1 ^* x) with x by W_eq; auto.
Qed.

Hint Resolve times_1.

Theorem factOk : moduleOk fact.
(*TIME  Clear Timing Profile. *)
  vcgen; abstract (sep_auto; eauto; words).

  (* sep_canceler ltac:(isConst) auto_ext ltac:(hints_ext_simplifier auto_ext).  *)
  (* simpl. intros. refine (H8 _ _ _ _).  *)
(*TIME  Print Timing Profile. *)
Qed.

Definition factDriver := bimport [[ "fact"!"fact" @ [factS] ]]
  bmodule "factDriver" {{
    bfunction "main"("x") [SPEC reserving 4
      PRE[_] Emp
      POST[R] [| R = $24 |] ]
      "x" <-- Call "fact"!"fact"(4)
      [PRE[_, R] Emp
       POST[R'] [| R' = R |]];;
      Return "x"
    end
  }}.

Theorem factR_4 : forall r, factR 4 r -> r = 24.
  intros;
    repeat match goal with
             | [ H : factR _ _ |- _ ] => inversion H; clear H; subst; []
           end;
    match goal with
      | [ H : factR _ _ |- _ ] => inversion H; clear H; subst; [ reflexivity
        | elimtype False; match goal with
                            | [ H : _ |- _ ] => apply H; reflexivity
                          end ]
    end.
Qed.

Hint Resolve factR_4.

Theorem factDriverOk : moduleOk factDriver.
(*TIME  Clear Timing Profile. *)
  vcgen; abstract (sep_auto; words).
(*TIME  Print Timing Profile. *)
Qed.

Definition factProg := link fact factDriver.

Theorem factProgOk : moduleOk factProg.
  link factOk factDriverOk.
Qed.


From stdpp Require Import tactics.
From stdpp Require Import options.
Local Set Universe Polymorphism.

(* Not using [list Type] in order to avoid universe inconsistencies *)
Inductive tlist := tnil : tlist | tcons : Type → tlist → tlist.

Inductive hlist : tlist → Type :=
  | hnil : hlist tnil
  | hcons {A As} : A → hlist As → hlist (tcons A As).

Fixpoint tapp (As Bs : tlist) : tlist :=
  match As with tnil => Bs | tcons A As => tcons A (tapp As Bs) end.
Fixpoint happ {As Bs} (xs : hlist As) (ys : hlist Bs) : hlist (tapp As Bs) :=
  match xs with hnil => ys | hcons x xs => hcons x (happ xs ys) end.

Definition hhead {A As} (xs : hlist (tcons A As)) : A :=
  match xs with hnil => () | hcons x _ => x end.
Definition htail {A As} (xs : hlist (tcons A As)) : hlist As :=
  match xs with hnil => () | hcons _ xs => xs end.

Fixpoint hheads {As Bs} : hlist (tapp As Bs) → hlist As :=
  match As with
  | tnil => λ _, hnil
  | tcons A As => λ xs, hcons (hhead xs) (hheads (htail xs))
  end.
Fixpoint htails {As Bs} : hlist (tapp As Bs) → hlist Bs :=
  match As with
  | tnil => id
  | tcons A As => λ xs, htails (htail xs)
  end.

Fixpoint himpl (As : tlist) (B : Type) : Type :=
  match As with tnil => B | tcons A As => A → himpl As B end.

Definition hinit {B} (y : B) : himpl tnil B := y.
Definition hlam {A As B} (f : A → himpl As B) : himpl (tcons A As) B := f.
Arguments hlam _ _ _ _ _ / : assert.

Definition hcurry {As B} (f : himpl As B) (xs : hlist As) : B :=
  (fix go {As} xs :=
    match xs in hlist As return himpl As B → B with
    | hnil => λ f, f
    | hcons x xs => λ f, go xs (f x)
    end) _ xs f.
Coercion hcurry : himpl >-> Funclass.

Fixpoint huncurry {As B} : (hlist As → B) → himpl As B :=
  match As with
  | tnil => λ f, f hnil
  | tcons x xs => λ f, hlam (λ x, huncurry (f ∘ hcons x))
  end.

Lemma hcurry_uncurry {As B} (f : hlist As → B) xs : huncurry f xs = f xs.
Proof. by induction xs as [|A As x xs IH]; simpl; rewrite ?IH. Qed.

Fixpoint hcompose {As B C} (f : B → C) {struct As} : himpl As B → himpl As C :=
  match As with
  | tnil => f
  | tcons A As => λ g, hlam (λ x, hcompose f (g x))
  end.


Set Implicit Arguments.
Unset Strict Implicit.
Require Import stdpp.list stdpp.list_numbers.
From Undecidability Require Import Synthetic.DecidabilityFacts Synthetic.SemiDecidabilityFacts Synthetic.EnumerabilityFacts reductions partial Axioms.bestaxioms  principles Shared.Dec.
Require Import ssreflect Nat.
Require Import Undecidability.Shared.FilterFacts.

Section Reverse_Induction.

  Lemma rev_list_rect {A} :
    forall P:list A -> Type,
	    P [] ->
	    (forall (a:A) (l:list A), P (rev l) -> P (rev (a :: l))) ->
	    forall l:list A, P (rev l).
  Proof.
    induction l; auto.
  Qed.

  Theorem rev_rect {A} :
    forall P:list A -> Type,
	    P [] ->
	    (forall (x:A) (l:list A), P l -> P (l ++ [x])) -> forall l:list A, P l.
  Proof.
    move => P H H0 l.
    generalize (rev_involutive l).
    move => E; rewrite <- E.
    apply (@rev_list_rect _ P).
    auto.

    simpl.
    move => a l0 H1.
    apply (H0 a (rev l0)).
    auto.
  Qed.

End Reverse_Induction.

Lemma lookup_map X Y {l : list X} n y (f : X -> Y) :
  map f l !! n = Some y <-> exists x, l !! n = Some x /\ y = f x.
Proof.
  induction l in n |- *; cbn in *.
  - split. congruence. move => [? []]. congruence.
  - destruct n.
    + cbn. split.
      * move => [] <-. eauto.
      * now move => [] x [] [] -> ->.
    + cbn. now rewrite IHl.
Qed.

Lemma length_inv {X} {n1 n2} {l : list X} :
  length l = n1 + n2 -> exists l1 l2 : list X, l = l1 ++ l2 /\ length l1 = n1 /\ length l2 = n2.
Proof.
  intros. induction l in n1, n2, H |- *.
  - exists [], []. destruct n1, n2; cbn in *; try lia. eauto.
  - cbn in H. destruct n1.
    + cbn in H. destruct n2. lia.
      inversion H.
      eapply (IHl 0 n2) in H1 as [l1 [l2 [-> [Hl1 Hl2]]]].
      destruct l1; cbn in *; try congruence.
      exists [], (a :: l2). cbn. eauto.
    + cbn in H. inversion H.
      eapply (IHl n1 n2) in H1 as [l1 [l2 [-> [Hl1 Hl2]]]].
      exists (a :: l1), l2. cbn. eauto.
Qed.

Lemma Is_true_iff b :
  Is_true b <-> b = true.
Proof.
  destruct b; cbv; firstorder congruence.
Qed.

Lemma Is_true_neg_iff b :
  ~ Is_true b <-> b = false.
Proof.
  destruct b; cbv; firstorder congruence.
Qed.

Definition listable {X} (p : X -> Prop) := ∑ L : list X, forall x, p x <-> In x L.

Lemma listable_forall_dec {X} (p q : X -> Prop) :
  listable p -> (forall x, dec (q x)) -> dec (forall x, p x -> q x).
Proof.
  intros [L HL] D.
  destruct (forallb (fun x => if D x is left _ then true else false) L) eqn:E.
  - left. setoid_rewrite forallb_forall in E.
    intros x H % HL % E. destruct (D x); firstorder congruence.
  - right. intros H.
    rewrite <- Is_true_neg_iff in E.
    setoid_rewrite forallb_True in E.
    rewrite <- Exists_Forall_neg in E. 2: intros x; destruct (D x); cbv; firstorder congruence.
    eapply List.Exists_exists in E as [x [H1 % HL H2]].
    destruct (D x); firstorder.
Qed.

Lemma listable_exists_dec {X} (p q : X -> Prop) :
  listable p -> (forall x, dec (q x)) -> dec (exists x, p x /\ q x).
Proof.
  intros [L HL] D.
  destruct (existsb (fun x => if D x is left _ then true else false) L) eqn:E.
  - left. setoid_rewrite existsb_exists in E.
    destruct E as [x [H1 % HL H2]].
    destruct (D x); try congruence. eauto.
  - right. intros [x [H1 % HL H2]].
    edestruct (existsb_exists (λ x : X, if D x is left _ then true else false) L) as [_ EE]. rewrite EE in E.
    + clear EE. exists x. split. eauto. destruct (D x); eauto.
    + inv E.
Qed.

Lemma listable_list_length:
  ∀ k : nat, listable (λ x : list bool, length x = k).
Proof.
  induction k as [ | k [L IH] ].
  - exists [ [] ]. intros [] ; cbv ; firstorder; try lia; congruence.
  - exists (map (cons true) L ++ map (cons false) L).
    intros l.
    rewrite in_app_iff !in_map_iff.
    repeat setoid_rewrite <- IH.
    destruct l as [ | [] ].
    + cbn. split. inversion 1. firstorder congruence.
    + cbn. split.
      * inversion 1. eauto.
      * firstorder congruence.
    + cbn. split.
      * inversion 1. eauto.
      * firstorder congruence.
Qed.

Lemma listable_list_length_lt : ∀ k : nat, listable (λ x : list bool, length x < k).
Proof.
  induction k as [ | k [L IH] ].
  - exists []. intros [] ; cbv ; firstorder auto with *.
  - destruct (listable_list_length k) as [Lk Hk].
    exists (L ++ Lk).
    intros l. cbn.
    rewrite in_app_iff - IH - Hk. lia.
Qed.

Record is_tree (tree_T : list bool -> Prop) :=
  {
    tree_inhab : exists l : list bool, tree_T l ;
    tree_p : forall l1 l2, prefix l1 l2 -> tree_T l2 -> tree_T l1 ;
    tree_dec :       decidable tree_T ;
  }.

Record tree :=
  {
  tree_T :> list bool -> Prop ;
  tree_is_tree :> is_tree tree_T
  }.

Definition bounded_tree (T : list bool -> Prop) :=
  exists k, forall a, length a >= k -> ~ T a.

Definition infinite_tree (T : list bool -> Prop) :=
  forall k, exists a, T a /\ (length a >= k ).

Definition infinite_path (T : list bool -> Prop) :=
  exists f : nat -> bool, forall n, T (map f (seq 0 n)).

Definition wellfounded_tree (T : list bool -> Prop) :=
  forall f : nat -> bool, exists n, ~ T (map f (seq 0 n)).

Lemma tree_nil T :
  is_tree T -> T nil.
Proof.
  intros [[inhab Hinhab] Hclos d].
  eapply Hclos. 2:eapply Hinhab. now econstructor.
Qed.

Hint Immediate tree_is_tree.
Hint Extern 2 => eapply tree_nil : core.

Record Kleene_tree :=
  {
  Kleene_T :> tree ;
  Kleene_infinite : infinite_tree Kleene_T ;
  Kleene_inf_exit :  wellfounded_tree Kleene_T ;
  }.

Lemma bounded_infinite_contra T :
  bounded_tree T -> infinite_tree T -> False.
Proof.
  firstorder.
Qed.

Definition bounded_tree' (T : list bool -> Prop) :=
  exists k, forall a, length a = k -> ~ T a.

Lemma not_bounded_infinite' :
  ∀ T, (∀ x : list bool, dec (T x)) → ¬ bounded_tree' T → infinite_tree T.
Proof.
  intros T D H k. cbn in *. enough (exists a, T a /\ length a = k) as [a [H1 H2]]. exists a. split. eassumption. lia.
  enough (∃ a : list bool, length a = k /\ T a) by firstorder.
  edestruct (listable_exists_dec (X := list bool)).
  3:{ eapply e. }
  -- eapply listable_list_length.
  -- eauto.
  -- cbn in *. destruct H.
     exists k. intros ? ? ?. eapply n. eauto.
Qed.

Lemma bounded_iff (T : tree) k :
  (∀ a : list bool, length a ≥ k → ¬ T a) <-> forall l, length l = k -> ~ T l.
Proof.
  split.
  destruct T as [T [? ? ?]]; cbn. clear tree_inhab0.
  - intros H l ?. eapply H. lia.
  - intros H l [d [l1 [l2 [-> [Hl1 Hl2]]]] % length_inv] % nat_le_sum.
    intros Hl. eapply tree_p in Hl. 2:eapply T. 2:eexists; reflexivity.
    eapply H; eauto.
Qed.

Lemma bounded_tree_iff (T : tree) :
  bounded_tree T <-> bounded_tree' T.
Proof.
  split; intros [k]; exists k; now eapply bounded_iff.
Qed.

Lemma not_bounded_infinite:
  ∀ T : tree, ¬ bounded_tree T → infinite_tree T.
Proof.
  intros T H.
  pose proof (tree_dec T) as [D] % decidable_iff.
  setoid_rewrite bounded_tree_iff in H. now eapply not_bounded_infinite'.
Qed.

Lemma not_bounded_infinite_iff :
  ∀ T : tree, ¬ bounded_tree T <-> infinite_tree T.
Proof.
  intros T.
  split.
  - eapply not_bounded_infinite.
  - intros ? ?. eapply bounded_infinite_contra; eassumption.
Qed.

Lemma path_wellfounded_contra T :
  infinite_path T -> wellfounded_tree T -> False.
Proof.
  by move => [f] H / (_ f) [n].
Qed.

Lemma bounded_to_wellfounded T :
  bounded_tree T -> wellfounded_tree T.
Proof.
  intros [n H] f. exists n. eapply H.
  rewrite map_length seq_length. lia.
Qed.

Lemma infinite_path_to_infinite T :
  infinite_path T -> infinite_tree T.
Proof.
  intros [f Hf] n.
  exists (map f (seq 0 n)). split. eauto.
  rewrite map_length seq_length. lia.
Qed.

(** ** Constructions  *)
Section fix_enum.

Context {Part : partiality}.

Variable e : nat -> (nat ↛ bool).
Hypothesis e_enum : forall f : nat ↛ bool, ~~ exists n, e n ≡{nat ↛ bool} f.

Definition inconsistent {A B} (f : A ↛ B) (g : A -> B) := ~~ exists a b, f a =! b /\ g a <> b.

Definition d n := bind (e n n) (fun y => ret (negb y)).

Lemma diag f : inconsistent d f.
Proof.
  intros G.
  apply (@e_enum (fun x : nat => ret (f x))). intros [c Hc].
  apply G.
  exists c. exists (negb (f c)).
  rewrite bind_hasvalue.
  specialize (Hc c). hnf in Hc. setoid_rewrite Hc.
  split.
  - exists (f c). split; eapply ret_hasvalue.
  - destruct (f c); cbn; congruence.
Qed.

Definition D k n := seval (d n) k.

(** * Kleene trees  *)

Definition MP_tree' := forall T : tree, ~ infinite_path T -> wellfounded_tree T.

Definition T_K : MP_tree' -> Kleene_tree.
Proof.
  intros mp.
  unshelve econstructor.
  exists (fun a : list bool => forall n, n < length a -> forall x, D (length a) n = Some x -> a !! n = Some x).
  econstructor.
  - exists []. cbn. move => n H. lia.
  - move => l1 l2 [l3 ->].
    rewrite !app_length.
    move => H n Hn x Hx.
    assert (Hg : D (length l1 + length l3) n = Some x). {
      eapply seval_mono. eassumption. lia. }
    specialize (H n (lt_plus_trans _ _ (length l3) Hn) x Hg).
    erewrite <- (lookup_app_l _ _ _ Hn). eassumption.
  - eapply decidable_iff. econstructor. move => a. generalize (length a) at 2 as k.
    induction a as [ | b a] using rev_rect; move => k; cbn.
    + left. move => n Hn. lia.
    + destruct (IHa k) as [L | R].
      * destruct (D k (length a)) as [ x | ] eqn:E.
        -- destruct (bool_eq_dec x b).
           ++ left. rewrite app_length. cbn. move => n Hn x' Hx'.
              destruct (nat_eq_dec n (length a)).
              ** subst. rewrite lookup_app_r. lia.
                 rewrite minus_diag. cbn. congruence.
              ** rewrite lookup_app_l. lia.
                 eapply L. lia. eassumption.
           ++ right. rewrite app_length. cbn. move => / (fun H => H (length a)) H.
              rewrite lookup_app_r ?minus_diag in H. lia. cbn in H.
              eapply n.
              eapply Some_inj. symmetry. eapply H. lia. eauto.
        -- left. rewrite app_length. cbn. move => n Hn x' Hx'.
           destruct (nat_eq_dec n (length a)).
           ** congruence.
           ** rewrite lookup_app_l. lia.
              eapply L. lia. eassumption.
      * right. move => H. contradiction R.
        move => n Hn x Hx.
        specialize (H n). rewrite app_length in H. cbn in H.
        rewrite lookup_app_l in H. lia.
        eapply H. lia. eassumption.
  - unfold infinite_tree, tree_T. move => k.
    pose (f k := (fix f n := match n with 0 => [] | S n => f n ++ [(if D k n is Some x then x else false)] end)).
    exists (f k k).
    assert (H_length : forall n, length (f k n) = n). {
      induction n; cbn; rewrite ?app_length; cbn.
      reflexivity.
      rewrite IHn. lia.
    }
    split.
    + rewrite H_length. generalize k at 1 4.
      move => m n Hn x Hx.
      induction m.
      * lia.
      * cbn. destruct (nat_eq_dec n m).
        -- subst. rewrite Hx. destruct m. cbn. reflexivity.
           rewrite lookup_app_r. rewrite H_length. lia.
           rewrite H_length minus_diag. reflexivity.
        -- rewrite lookup_app_l. rewrite H_length. lia.
           eapply IHm. lia.
    + rewrite H_length. lia.
  - eapply mp. move => [f H].
    pose proof (@diag f) as Df. red in Df.
    eapply Df. intros [n [b [H1 H2]]].
    eapply seval_hasvalue in H1 as [k H1].
    fold (D k n) in H1. cbn in *.
    specialize (H (1 + k + n) n).
    rewrite map_length seq_length in H.
    assert (Hlt : n < 1 + k + n) by lia.
    setoid_rewrite lookup_map in H. setoid_rewrite (lookup_seq) in H.
    edestruct H as [x [[H3 H4] H5]].
    + lia.
    + eapply seval_mono. eassumption. lia.
    + subst. cbn in H2. congruence.
Qed.

End fix_enum.

(** ** Omniscience principles as axioms on trees  *)

Definition subtree_at b (T : list bool -> Prop) := fun l => T (b ++ l).

Lemma is_tree_subtree_at (T : tree) l :
  T l -> is_tree (subtree_at l T).
Proof.
  (* destruct T as [T]; cbn in *. *)
  split.
  - exists []. unfold subtree_at. rewrite app_nil_r. exact H.
  - intros l1 l2 Hp Hl1. red in Hl1. eapply tree_p in Hl1. eassumption. eapply T.
    now eapply prefix_app_alt.
  - pose proof (tree_dec T) as [D] % decidable_iff.
    eapply decidable_iff. econstructor. eauto.
Qed.

Definition LLPO_tree :=
  forall T : tree, infinite_tree T ->
              (is_tree (subtree_at [true] T) /\ infinite_tree ((subtree_at [true] T)))
              \/ (is_tree (subtree_at [false] T) /\ infinite_tree ((subtree_at [false] T))).

Definition LPO_tree :=
  forall T : tree, bounded_tree T \/ infinite_tree T.

Definition WLPO_tree :=
  forall T : tree, infinite_tree T \/ ~ infinite_tree T.

Definition T_inf_sdec (T : list bool -> Prop) (D : forall l, dec (T l)) : nat -> bool.
  intros k.
  destruct (@listable_forall_dec _ (fun x => length x = k) (fun x => ~ T x)).
  * eapply listable_list_length.
  * eauto.
  * exact true.
  * exact false.
Defined.

Lemma T_inf_sdec_iff' T (D : forall l, dec (T l)) :
  bounded_tree' T <-> (exists k, T_inf_sdec D k = true).
Proof.
  split.
  - intros [k]. exists k.
    unfold T_inf_sdec. destruct listable_forall_dec. reflexivity.
    destruct n. intros. eapply H. lia.
  - cbn in *. intros H.
    destruct H as [k H]. unfold T_inf_sdec in H.
    edestruct (listable_forall_dec); try inv H.
    now exists k.
Qed.

Lemma T_inf_sdec_iff (T : tree) (D : forall l, dec (T l)) :
  bounded_tree T <-> (exists k, T_inf_sdec D k = true).
Proof.
  rewrite <- T_inf_sdec_iff'.
  split; intros [k]; exists k; now eapply bounded_iff.
Qed.

Program Definition tree_from (f : nat -> bool) := (@Build_tree (fun l => forallb (fun n => negb (f n)) (seq 0 (length l)) = true) _).
Next Obligation.
  econstructor.
    + now exists [].
    + intros l1 l2 [k ->] % prefix_length % nat_le_sum.
      now rewrite seq_app forallb_app andb_true_iff.
    + eapply decidable_iff. econstructor. intros x. hnf. decide equality.
Qed.

Lemma tree_from_f_bounded_iff f :
  bounded_tree (tree_from f) <-> exists n, f n = true.
Proof.
  split.
  - intros [k Hb].
    specialize (Hb (map (fun _ => true) (seq 0 k))).
    rewrite map_length seq_length in Hb.
    specialize (Hb (le_refl _)).
    unfold tree_from in Hb. cbn in Hb.
    rewrite <- Is_true_iff in Hb.
    setoid_rewrite forallb_True in Hb.
    eapply Exists_Forall_neg in Hb.
    * eapply List.Exists_exists in Hb as [n [_ H2]].
      exists n. destruct (f n); cbv in *; tauto.
    * intros x; destruct (f x); cbn; eauto.
  - intros [n Hn].
    exists (S n). intros l Hll Hl.
    unfold tree_from in Hl.
    eapply forallb_forall in Hl.
    setoid_rewrite Hn in Hl. inv Hl.
    eapply in_seq. lia.
Qed.

Lemma tree_from_f_bounded_iff_wf f :
  wellfounded_tree (tree_from f) <-> exists n, f n = true.
Proof.
  split.
  - intros H. specialize (H f) as [n Hn].
    cbn in Hn.
    eapply not_true_is_false in Hn.
    eapply Is_true_neg_iff in Hn.
    setoid_rewrite forallb_True in Hn.
    eapply Exists_Forall_neg in Hn.
    * eapply List.Exists_exists in Hn as [m [_ H2]].
      exists m. destruct (f m); cbv in *; tauto.
    * intros x; destruct (f x); cbn; eauto.
  - intros [n Hn]. intros g.
    exists (S n).
    eapply not_true_iff_false, Is_true_neg_iff.
    intros Hl % Is_true_iff.
    eapply forallb_forall in Hl.
    setoid_rewrite Hn in Hl. inv Hl.
    eapply in_seq. rewrite map_length seq_length. lia.
Qed.

Lemma LPO_tree_iff :
  LPO <-> LPO_tree.
Proof.
  split.
  - intros LPO T. pose proof (tree_dec T) as [D] % decidable_iff.
    destruct (LPO (T_inf_sdec D)).
    + left. eapply T_inf_sdec_iff. eapply H.
    + right. rewrite <- T_inf_sdec_iff in H.
      now eapply not_bounded_infinite.
  - intros H f.
    destruct (H (tree_from f)).
    + left. now eapply tree_from_f_bounded_iff.
    + right. intros ? % tree_from_f_bounded_iff.
      eapply bounded_infinite_contra; eauto.
Qed.

Lemma WLPO_tree_iff :
  WLPO <-> WLPO_tree.
Proof.
  split.
  - intros WLPO T. unfold bounded_tree.
    pose proof (tree_dec T) as [D] % decidable_iff.
    destruct (WLPO (T_inf_sdec D)).
    + left.
      eapply not_bounded_infinite. eauto.
      rewrite T_inf_sdec_iff.
      now eapply forall_neg_exists_iff.
    + cbn in *.
      right. intros Hi.
      eapply H. intros. destruct T_inf_sdec eqn:E; eauto.
      exfalso.
      eapply bounded_infinite_contra; eauto.
      eapply T_inf_sdec_iff. eauto.
  - intros H f.
    destruct (H (tree_from f)).
    + left. eapply forall_neg_exists_iff.
      intros ? % tree_from_f_bounded_iff.
      eapply bounded_infinite_contra; eauto.
    + right. intros ? % forall_neg_exists_iff.
      rewrite <- tree_from_f_bounded_iff in H2.
      eapply H0. eapply not_bounded_infinite; eauto.
Qed.

Lemma is_tree_subtree_at_from_inf (T : tree) l :
  infinite_tree (subtree_at l T) -> is_tree (subtree_at l T).
Proof.
  intros H. destruct (H 0) as [l' [H1 H2]].
  split.
  - eauto.
  - intros l1 l2 Hp Hl1. red in Hl1. eapply tree_p in Hl1. eassumption. eapply T.
    now eapply prefix_app_alt.
  - pose proof (tree_dec T) as [D] % decidable_iff.
    eapply decidable_iff. econstructor. eauto.
Qed.

Definition is_infinite_tree τ := is_tree τ /\ infinite_tree τ.

Lemma LLPO_LLPO_tree_iff :
  LLPO <-> LLPO_tree.
Proof.
  split.
  - intros LLPO % LLPO_to_DM_Sigma_0_1 T infT.
    pose proof (tree_dec T) as [D] % decidable_iff.
    assert (D1 : forall l, dec (subtree_at [true] T l)) by intuition.
    assert (D2 : forall l, dec (subtree_at [false] T l)) by intuition.
    destruct (LLPO (T_inf_sdec D1) (T_inf_sdec D2)).
    + rewrite <- !T_inf_sdec_iff'. intros [[b1 Hb1] [b2 Hb2]].
      eapply bounded_infinite_contra; eauto.
      exists (1 + Nat.max b1 b2). intros l Hl.
      destruct l; cbn in *; try lia.
      eapply le_S_n in Hl.
      pose proof (Max.max_lub_l _ _ _ Hl).
      pose proof (Max.max_lub_r _ _ _ Hl).
      destruct b; intros HT.
      * assert (T [true]). eapply tree_p. eapply T. 2:eauto. now eexists.
        eapply is_tree_subtree_at in H1.
        eapply (bounded_iff (Build_tree H1)) in Hb1. eapply Hb1. cbn. exact HT. lia.
      * assert (T [false]). eapply tree_p. eapply T. 2:eauto. now eexists.
        eapply is_tree_subtree_at in H1.
        eapply (bounded_iff (Build_tree H1)) in Hb2. eapply Hb2. cbn. exact HT. lia.
    + left. rewrite <- T_inf_sdec_iff' in H.
      eapply not_bounded_infinite' in H. 2:eauto.
      split. eapply is_tree_subtree_at_from_inf. eauto. eauto.
    + right. rewrite <- T_inf_sdec_iff' in H.
      eapply not_bounded_infinite' in H. 2:eauto.
      split. eapply is_tree_subtree_at_from_inf. eauto. eauto.
  - intros H. eapply LLPO_split_to_LLPO, DM_Sigma_0_1_to_LLPO_split. intros f g Hfg.
    unshelve epose proof (H (@Build_tree (fun l => match l with [] => True
                                                        | true :: l => forallb (fun n => negb (f n)) (seq 0 (length l)) = true
                                                        | false :: l => forallb (fun n => negb (g n)) (seq 0 (length l)) = true end) _)).
    econstructor.
    + now exists [].
    + intros [|[]] [|[]] pref; cbn; try tauto.
      all: try now (destruct pref as [ll Hll]; inv Hll).
      * eapply prefix_cons_inv_2 in pref.
        eapply prefix_length in pref.
        rewrite !forallb_forall.
        intros Hall x [_ Hl] % in_seq.
        eapply Hall, in_seq. lia.
      * eapply prefix_cons_inv_2 in pref.
        eapply prefix_length in pref.
        rewrite !forallb_forall.
        intros Hall x [_ Hl] % in_seq.
        eapply Hall, in_seq. lia.
    + eapply decidable_iff. econstructor. intros [ | []]; hnf; eauto; decide equality.
    + cbn in H0. destruct H0.
      * cbn. eapply not_bounded_infinite'.
        -- intros [ | []]; hnf; eauto; decide equality.
        -- intros [k Hk].
           destruct k. now eapply (Hk [] eq_refl).
           pose proof (Hk (true :: map (fun _ => true) (seq 0 k)) (ltac:(now cbn; rewrite map_length seq_length))) as Hf.
           cbn in Hf.
           destruct forallb eqn:E. congruence. clear Hf.
           eapply Is_true_neg_iff in E. setoid_rewrite forallb_True in E.
           eapply neg_Forall_Exists_neg in E.
           2: intros; destruct (f x); cbn; firstorder congruence.
           eapply List.Exists_exists in E as [n [Hn HHn]].

           pose proof (Hk (false :: map (fun _ => true) (seq 0 k)) (ltac:(now cbn; rewrite map_length seq_length))) as Hg.
           cbn in Hg.
           destruct forallb eqn:E. congruence. clear Hg.
           eapply Is_true_neg_iff in E. setoid_rewrite forallb_True in E.
           eapply neg_Forall_Exists_neg in E.
           2: intros; destruct (g x); cbn; firstorder congruence.
           eapply List.Exists_exists in E as [n2 [Hn2 HHn2]].
           eapply Hfg. split.
           ++ exists n. destruct (f n); cbv in *; firstorder.
           ++ exists n2. destruct (g n2); cbv in *; firstorder.
      * cbn in *. destruct H0 as [_ H0].
        left. intros [n Hn]. destruct (H0 (S n)) as [l [H1 H2]]. clear H0.
        cbn in *. setoid_rewrite forallb_forall in H1.
        specialize (H1 n).
        setoid_rewrite in_seq in H1.
        destruct (f n); try congruence. cbn in H1.
        enough (false = true) by congruence.
        eapply H1. split; lia.
      * cbn in *. destruct H0 as [_ H0].
        right. intros [n Hn]. destruct (H0 (S n)) as [l [H1 H2]]. clear H0.
        cbn in *. setoid_rewrite forallb_forall in H1.
        specialize (H1 n).
        setoid_rewrite in_seq in H1.
        destruct (g n); try congruence. cbn in H1.
        enough (false = true) by congruence.
        eapply H1. split; lia.
Qed.

Definition MP_tree := forall T : tree, ~ infinite_tree T -> bounded_tree T.

Lemma MP_tree_iff :
  MP <-> MP_tree.
Proof.
  split.
  - intros H T HT.
    pose proof (tree_dec T) as [D] % decidable_iff.
    eapply T_inf_sdec_iff.
    eapply H.
    rewrite <- T_inf_sdec_iff.
    intros not_bounded.
    eapply HT, not_bounded_infinite; eauto.
  - intros H f Hf.
    eapply (tree_from_f_bounded_iff).
    eapply H. intros Hinf.
    eapply Hf. rewrite <- tree_from_f_bounded_iff.
    intros Hb. eapply bounded_infinite_contra; eauto.
Qed.

(* Definition MP_tree' := forall T : tree, ~ infinite_path T -> wellfounded_tree T. *)

Lemma MP_tree_iff' :
  MP <-> MP_tree'.
Proof.
  split.
  - intros H T Hnp f.
    pose proof (tree_dec T) as [d Hd]. do 2 red in Hd.
    setoid_rewrite Hd.
    setoid_rewrite not_true_iff_false.
    setoid_rewrite <- negb_true_iff.
    eapply H.
    rewrite <- forall_neg_exists_iff.
    setoid_rewrite negb_false_iff.
    setoid_rewrite <- Hd.
    intros n.
    eapply Hnp. now exists f.
  - intros H f Hf.
    eapply tree_from_f_bounded_iff_wf, H.
    intros p. eapply Hf. intros Hff.
    eapply tree_from_f_bounded_iff_wf in Hff.
    eapply path_wellfounded_contra; eauto.
Qed.

(** ** WKL *)

Definition WKL :=
  forall T : tree, infinite_tree T -> infinite_path T.

Definition FAN :=
  forall T : tree, wellfounded_tree T -> bounded_tree T.

Definition KT := exists T : tree, infinite_tree T /\ wellfounded_tree T.

Lemma KT_WKL_contra :
  KT -> WKL -> False.
Proof.
  by move => [T] [] Hinf Hwf / (_ T Hinf) / path_wellfounded_contra.
Qed.

Lemma KT_FAN_contra :
  KT -> FAN -> False.
Proof.
  by move => [T] [] Hinf Hwf / (_ T Hwf) / bounded_infinite_contra.
Qed.

Definition LPL :=
  forall T : tree, exists f : nat -> bool, forall a, T a -> T (map f (seq 0 (length a))).

Lemma decidable_stable {X} (p : X -> Prop) :
  decidable p -> stable p.
Proof.
  intros [d] % decidable_iff a.
  destruct (d a) as [H1 | H1]; tauto.
Qed.

Lemma prefix_length_eq {X} (u v : list X)  :
  length u = length v -> prefix u v -> u = v.
Proof.
  intros Hl [w ->].
  rewrite <- firstn_all.
  rewrite <- (firstn_all u) at 1.
  now rewrite Hl firstn_app Hl minus_diag firstn_O app_nil_r.
Qed.

Lemma take_prefix {X} n (l : list X) :
  prefix (take n l) l.
Proof.
  induction l in n |- *.
  - destruct n; cbn; eapply prefix_nil.
  - destruct n; cbn.
    + eapply prefix_nil.
    + now eapply prefix_cons.
Qed.

Lemma prefixes_inv {X} (l1 l2 l : list X) :
  l1 `prefix_of` l -> l2 `prefix_of` l -> l1 `prefix_of` l2 \/ l2 `prefix_of` l1.
Proof.
  intros [l' ->] [l'' [[l''' [-> ->]] | [l''' [-> ->]]] % app_eq_inv].
  - right. eexists; eauto.
  - left. eexists; eauto.
Qed.

Lemma listable_prefix {X} (l : list X) :
  listable (fun u => prefix u l).
Proof.
  induction l as [ | x l [L IH]].
  - exists [[]]. intros []. firstorder.
    split.
    + intros [] % prefix_nil_not.
    + cbn. firstorder congruence.
  - exists ([] :: map (cons x) L).
    intros u. cbn. rewrite in_map_iff. split.
    + destruct u.
      * eauto.
      * intros H.
        pose proof (prefix_cons_inv_1 _ _ _ _ H) as ->.
        pose proof (prefix_cons_inv_2 _ _ _ _ H) as H0 % IH.
        eauto.
    + intros [ <- | [l' [<- H]]].
      * eapply prefix_nil.
      * eapply prefix_cons. now eapply IH.
Qed.

Lemma decidable_length_T T :
  (∀ x : list bool, dec (T x)) → ∀ n : nat, dec (∃ v : list bool, length v = n ∧ T v).
Proof.
  intros d n.
  eapply listable_exists_dec. eapply listable_list_length.
  eauto.
Qed.

Lemma listable_has_max {X} (f : X -> nat) p x0 :
  @listable X p -> p x0 -> exists x, p x /\ forall y, p y -> f x >= f y.
Proof.
  intros [L HL]. setoid_rewrite HL. intros H.
  pose proof (max_list_with_spec' L f ) as (x & E & Hx) % in_map_iff.
  exists x. split. eauto.
  intros. rewrite E.
  now eapply max_list_with_spec.
  firstorder auto with *.
Qed.

Lemma bounded_longest_path (T : tree) :
  bounded_tree T -> exists u, T u /\ forall v, T v -> length v <= length u.
Proof.
  pose proof (tree_dec T) as [d] % decidable_iff.
  intros [n H].
  assert (listable T).
  - destruct (listable_list_length_lt n) as [L HL].
    exists (List.filter d L).
    intros l. rewrite in_filter_iff.
    split.
    + intros Hl. split.
      * eapply HL. destruct (lt_dec (length l) n). eauto. edestruct H.
        2:eauto. lia.
      * destruct (d l); firstorder.
    + intros [ ]. destruct (d l); firstorder auto with *.
  - eapply (@listable_has_max _ length T []); eauto.
Qed.

Section WKL_to_LPL.

  Variable T : tree.

  Definition T' u := T u \/ exists v, prefix v u /\ T v /\ ~ exists w, length w = length v + 1 /\ T w.

  Lemma is_tree_T' : is_tree T'.
  Proof.
    pose proof (tree_dec T) as [d] % decidable_iff.
    econstructor.
    - exists []. left. eapply tree_nil, T.
    - intros l1 l2 Hpref [Hl2|[v [Hpref2 [Hv1 Hv2]]]].
      + left. eapply tree_p; eauto.
      + destruct (d l1) as [Hl1 | Hl1]; clear d. left; eauto.
        assert (Hl2 : ~ T l2) by (intros ? % (tree_p T (l1 := l1)); eauto).
        right. exists v. split. 2: firstorder.
        destruct (prefixes_inv Hpref Hpref2) as [H1 | H1]; eauto.
        exfalso. eapply Hl1, tree_p; eauto.
    - eapply decidable_disj. eapply T.
      eapply decidable_iff. econstructor.
      intros l. eapply listable_exists_dec. eapply listable_prefix.
      clear - d. intros l. eapply and_dec. eauto.
      eapply not_dec. eapply decidable_length_T; eauto.
  Qed.

  Lemma inf_T' : infinite_tree T'.
  Proof.
    pose proof (tree_dec T) as [d] % decidable_iff.
    intros n.
    destruct (decidable_length_T d n) as [ [v [] ] | ].
    + exists v. split; try lia. now left.
    + assert (bounded_tree T) as [u [Hu1 Hu2]] % bounded_longest_path. {
        exists n. intros u Hu HuT. eapply n0.
        exists (take n u). split. rewrite firstn_length_le; lia.
        eapply tree_p. 3:eauto. eauto. eapply take_prefix.
      }
      exists (u ++ repeat false n).
      split. 2:{ rewrite app_length repeat_length. lia. }
      right. exists u. split. eexists; eauto.
      split. eauto.
      intros [v [Hv1 Hv2]]. eapply Hu2 in Hv2. lia.
  Qed.

  Lemma inf_to_longest f :
    (∀ n : nat, T' (map f (seq 0 n))) -> forall a, T a -> T (map f (seq 0 (length a))).
  Proof.
    intros Hf a Ha.
    pose proof (tree_dec T) as [d] % decidable_iff.
    eapply decidable_stable. eapply T.
    intros HT.
    destruct (Hf (length a)) as [HH | [v [Hpref Hv]]]; eauto.
    destruct (lt_eq_lt_dec (length v) (length a)) as [[H1 | H2] | H3].
    - eapply Hv. exists (take (1 + length v) a).
      split. rewrite firstn_length_le; lia.
      eapply tree_p. eapply T. 2:exact Ha.
      eapply take_prefix.
    - eapply HT.
      eapply prefix_length_eq in Hpref.
      + subst. eapply Hv.
      + now rewrite map_length seq_length.
    - eapply prefix_length in Hpref.
      rewrite map_length seq_length in Hpref. lia.
  Qed.

End WKL_to_LPL.

Lemma WKL_to_FAN :
  WKL -> FAN.
Proof.
  intros wkl T wfT.
  specialize (wkl (Build_tree (is_tree_T' T)) (inf_T' T)) as [f Hf]. cbn in Hf.
  destruct (wfT f) as [n Hn].
  exists n. intros a Ha Hta.
  eapply inf_to_longest in Hta; eauto.
  eapply Hn, tree_p. eauto. 2:eassumption.
  eapply nat_le_sum in Ha as (k & ->).
  rewrite seq_app map_app. eexists; eauto.
Qed.

(** ** WKL equivalences  *)

Lemma WKL_to_LLPO :
  WKL -> LLPO.
Proof.
  intros H. eapply LLPO_LLPO_tree_iff.
  intros T infT.
  pose proof (tree_dec T) as [D] % decidable_iff.
  specialize (H T infT) as [f Hf].
  destruct (f 0) eqn:E.
  + left. split.
    * eapply is_tree_subtree_at.
      rewrite <- E. eapply (Hf 1).
    * intros k. exists (map f (seq 1 k)).
      split. 2:rewrite map_length seq_length; lia.
      red. cbn. rewrite <- E.
      eapply (Hf (S k)).
  + right.
    split.
    * eapply is_tree_subtree_at.
      rewrite <- E. eapply (Hf 1).
    * intros k. exists (map f (seq 1 k)).
      split. 2:rewrite map_length seq_length; lia.
      red. cbn. rewrite <- E.
      eapply (Hf (S k)).
Qed.

Definition coS_AC_on X Y := forall R : X -> Y -> Prop,
    co_semi_decidable (fun '(x,y) => R x y) ->
    (∀ x : X, ∃ y : Y, R x y) → ∃ f : X → Y, ∀ x : X, R x (f x).

Lemma listable_lt n :
  listable (fun m => m < n).
Proof.
  exists (seq 0 n). intros. rewrite in_seq. lia.
Qed.

Lemma WKL_to_coS_AC_on_nat_bool :
  WKL -> coS_AC_on nat bool.
Proof.
  intros wkl R [f Hf'] Htot.
  assert (Hf : forall x b, R x b <-> forall n, f (x, b) n = false). {
    intros x b. eapply (Hf' (x, b)).
  } clear Hf'.
  pose (τ u := forall i, i < length u -> forall m, m < length u -> f (i,nth i u false) m = false).
  assert (tree_τ : is_tree τ). {
    split.
    - exists []. cbv. intros; lia.
    - intros l1 ? [l2 ->] H. intros i Hi. cbn in *.
      specialize (H i (ltac:(rewrite app_length; lia))).
      rewrite (app_nth1 _ _ _ Hi) in H.
      intros. eapply H. rewrite app_length; lia.
    - eapply decidable_iff. econstructor. intros u. eapply listable_forall_dec.
      + eapply listable_lt.
      + intros i. eapply listable_forall_dec.
        * eapply listable_lt.
        * intros j. exact _.
  }
  assert (infinite_tree τ) as [g Hg] % (wkl (Build_tree tree_τ)). {
    intros n.
    enough (∃ u : list bool, (forall i, i < length u -> forall m, f (i,nth i u false) m = false) ∧ length u = n) as (? & ? & ?). {
      eexists. split. intros ? ? ? ?. eapply H. lia. lia.
    }
    induction n as [ | n (u & IH & Hu)].
    - exists []; cbn. split. intros; lia. eauto.
    - destruct (Htot n) as [b Hb].
      exists (u ++ [b]). split. 2:rewrite app_length; cbn; lia.
      intros i Hi'. rewrite app_length in Hi'; cbn in *.
      assert (i = length u \/ i < length u) as [-> | Hi] by lia.
      + subst. rewrite app_nth2. lia.
        intros. rewrite minus_diag. cbn. now eapply Hf.
      + intros. rewrite app_nth1. lia. now eapply IH.
  }
  exists g. intros n. cbn in *. eapply Hf. intros m.
  specialize (Hg (1 + n + m) n ltac:(rewrite map_length seq_length; cbn; lia) m ltac:(rewrite map_length seq_length; cbn; lia)).
  erewrite nth_indep in Hg. 2: rewrite map_length seq_length; cbn; lia.
  erewrite map_nth, seq_nth in Hg. eassumption. lia.
  Unshelve. exact 0.
Qed.

Definition coS_AC_on_weak X Y := forall R : X -> Y -> Prop,
    co_semi_decidable (fun '(x,y) => R x y) ->
    (∀ x : X, ~~ ∃ y : Y, R x y) → ∃ f : X → Y, ∀ x : X, R x (f x).

Definition coS_ADC_on_weak X := forall R : list X -> X -> Prop,
    co_semi_decidable (fun '(x,y) => R x y) ->
    (forall x, ~~ exists x', R x x') -> exists f : nat -> X, forall n, R (map f (seq 0 n)) (f n).

Lemma LLPO_coS_AC_on_to_coS_AC_on_weak :
  LLPO -> coS_AC_on nat bool -> coS_AC_on_weak nat bool.
Proof.
  intros llpo % LLPO_to_DM_Sigma_0_1 C R HR Htot.
  eapply C. eassumption.
  intros. eapply DM_Sigma_0_1_iff_totality; eauto.
Qed.

Lemma cos_AC_on_weak_to_coS_ADC_on_weak :
  coS_AC_on_weak nat bool -> coS_ADC_on_weak bool.
Proof.
  intros C R HR Htot.
  assert (datatype (list bool)) as (G & F & HFG). {
    eapply enumerable_discrete_datatype; eauto.
    eapply discrete_iff. econstructor. exact _.
  }
  pose (F' n := match F n with Some u => u | _ => [] end).
  destruct (C (fun n b => R (F' n) b)) as [f Hf].
  - destruct HR as [f Hf].
    exists (fun '(x,y) n => f (F' x,y) n). intros (n, b).
    now rewrite (Hf (_, _)).
  - eauto.
  - pose (g := fix g n := match n with 0 => []
                             | S n => g n ++ [f (G (g n))]
                     end).
    assert (Hg : forall n, length (g n) = n). { induction n; cbn; rewrite ?app_length; cbn; lia. }
    exists (fun n => f (G (g n))).
    induction n.
    + cbn. specialize (Hf (G [])). unfold F' in Hf.
      now rewrite HFG in Hf.
    + specialize (Hf (G (g (S n)))).
      rewrite /F' HFG in Hf.
      match goal with
      | [ H : R ?a _ |- R ?b _ ] => enough (a = b) as <- by eassumption
      end.
      generalize (S n) as m.
      clear - Hg. induction m.
      * reflexivity.
      * replace (S m) with (m + 1) at 2 by lia.
        rewrite seq_app map_app. cbn. congruence.
Qed.

Lemma inf_path_iff_inf (τ : tree) f :
  (forall n, infinite_tree (subtree_at (map f (seq 0 n)) τ)) -> (forall n, τ (map f (seq 0 n))).
Proof.
  intros H n.
  destruct (H n 0) as (v & Hv1 & Hv2).
  eapply tree_p. eapply τ. 2:eassumption.
  now exists v.
Qed.

Lemma co_semi_decidable_iff {X} (p : nat -> X -> Prop) :
  (forall x y, dec (p x y)) -> co_semi_decidable (fun x => forall n : nat, p n x).
Proof.
  intros D.
  exists (fun n x => if D x n then false else true).
  intros x. split; intros; destruct (D n x); cbn; firstorder.
  specialize (H n); destruct (D n x); cbn in *; congruence.
Qed.

Lemma coS_ADC_on_weak_to_WKL :
  coS_ADC_on_weak bool -> WKL.
Proof.
  intros C τ inf_τ.
  pose proof (tree_dec τ) as [D] % decidable_iff.
  pose (d u m := exists v, length v = m /\ τ (u ++ v)).
  assert (Dd : forall u m, dec (d u m) ). {
    intros u m. eapply listable_exists_dec.
    eapply listable_list_length.
    eauto.
  }
  assert (Hd : forall u, infinite_tree (subtree_at u τ) <-> forall m, d u m). {
    split.
    - intros H m. specialize (H m) as (v & Hv1 & Hv2).
      exists (take m v). split.
      rewrite firstn_length_le. lia. reflexivity.
      eapply tree_p. eapply τ. 2:eauto.
      exists (drop m v).
      rewrite <- (firstn_skipn m v) at 1. now rewrite <- app_assoc.
    - intros H m. destruct (H m) as (v & Hv1 & Hv2).
      exists v. split; try lia. eassumption.
  }
  destruct (C (fun u b => forall m, d (u ++ [b]) m \/ ~ d (u ++ [negb b]) m)) as [f Hf].
  - destruct (@co_semi_decidable_iff _ (fun m '(x,y) => d (x ++ [y]) m
                                                     ∨ ¬ d (x ++ [negb y]) m)) as [f Hf].
    + intros n (u, b). exact _.
    + exists f. intros (u, b).
      eapply (Hf (_, _)).
  - intros u H.
    assert (H1 : ~ forall m, d (u ++ [true]) m \/ ~ d (u ++ [false]) m).
    { intros ?. eapply H. exists true. cbn. eauto. }
    assert (H2 : ~ forall m, d (u ++ [false]) m \/ ~ d (u ++ [true]) m).
    { intros ?. eapply H. exists false. cbn. eauto. }
    eapply H1. intros m1.
    destruct (Dd (u ++ [true]) m1) as [H3 | H3]. eauto.
    right. intros H4.
    eapply H2. intros m2.
    destruct (Dd (u ++ [false]) m2) as [H5 | H5]. eauto.
    right. intros H6.
    destruct (le_ge_dec m1 m2).
    + eapply H3. destruct H6 as (v & Hv1 & Hv2).
      exists (take m1 v). split.
      rewrite firstn_length_le. lia. reflexivity.
      eapply tree_p. eapply τ.
      2:eauto.
      exists (drop m1 v).
      rewrite <- (firstn_skipn m1 v) at 1.
      now rewrite !app_assoc.
    + eapply H5. destruct H4 as (v & Hv1 & Hv2).
      exists (take m2 v). split.
      rewrite firstn_length_le. lia. reflexivity.
      eapply tree_p. eapply τ.
      2:eauto.
      exists (drop m2 v).
      rewrite <- (firstn_skipn m2 v) at 1.
      now rewrite !app_assoc.
   - exists f. eapply inf_path_iff_inf.
    induction n.
    + cbn. eapply inf_τ.
    + replace (S n) with (n + 1) by lia.
      rewrite seq_app map_app. cbn.
      rewrite !Hd in IHn |- *.
      intros H m. destruct (H (S m)) as (v & Hv1 & Hv2).
      destruct v as [ | [] v]; inv Hv1.
      * destruct (f n) eqn:E.
        -- exists v. split; eauto.
           rewrite <- app_assoc. eassumption.
        -- edestruct Dd. eassumption.
           specialize (Hf n (length v)) as [].
           congruence. rewrite E in H0.
           cbn in *. destruct H0.
           exists v. split. eauto.
           now rewrite <- app_assoc.
      * destruct (f n) eqn:E.
        -- edestruct Dd. eassumption.
           specialize (Hf n (length v)) as [].
           congruence. rewrite E in H0.
           cbn in *. destruct H0.
           exists v. split. eauto.
           now rewrite <- app_assoc.
        -- exists v. split; eauto.
           rewrite <- app_assoc. eassumption.
Qed.

Lemma LEM_FAN_KT :
  LEM -> ~ FAN -> KT.
Proof.
  intros lem wkl.
  destruct (lem KT); eauto.
  exfalso. eapply wkl. intros T infT.
  destruct (lem (bounded_tree T)); eauto.
  exfalso. eapply H. exists T.
  split; eauto. now eapply not_bounded_infinite.
Qed.

Lemma LEM_WKL_KT :
  LEM -> ~ WKL -> KT.
Proof.
  intros lem wkl.
  destruct (lem KT); eauto.
  exfalso. eapply wkl. intros T infT.
  destruct (lem (infinite_path T)); eauto.
  exfalso. eapply H. exists T.
  split; eauto.
  assert (MP) as mp % MP_tree_iff'. { eapply LPO_MP_WLPO_iff. intros ?. eapply lem. }
  now eapply mp.
Qed.

(* Lemma is_tree_ext : *)
(*   Proper (pointwise_relation _ iff ==> iff) is_tree.  *)
(* Proof. *)
(*   intros T1 T2 H. split; intros []; repeat split. *)
(*   - firstorder. *)
(*   - intros. rewrite <- H in *. eauto. *)
(*   - rewrite <- H. eauto. *)
(*   - firstorder. *)
(*   - intros. rewrite H in H1 |- *. eauto. *)
(*   - rewrite H. eauto. *)
(* Qed. *)

(* Lemma infinite_tree_ext : *)
(*   Proper (pointwise_relation _ iff ==> iff) infinite_tree. *)
(* Proof. *)
(*   intros T1 T2 H. unfold infinite_tree. split; intros H1 k. *)
(*   - now setoid_rewrite <- H. *)
(*   - now setoid_rewrite H. *)
(* Qed. *)

(* Lemma subtree_at_app T l1 l2 : *)
(*   is_tree (subtree_at l2 (subtree_at l1 T)) <-> is_tree (subtree_at (l1 ++ l2) T). *)
(* Proof. *)
(*   rewrite is_tree_ext. reflexivity. *)
(*   red. unfold subtree_at. intros. now rewrite app_assoc. *)
(* Qed. *)

(* Lemma subtree_at_app_inf T l1 l2 : *)
(*   infinite_tree (subtree_at l2 (subtree_at l1 T)) <-> infinite_tree (subtree_at (l1 ++ l2) T). *)
(* Proof. *)
(*   rewrite infinite_tree_ext. reflexivity. *)
(*   red. unfold subtree_at. intros. now rewrite app_assoc. *)
(* Qed. *)

(* Lemma subtree_at_app' T l1 l2 : *)
(*   is_tree (subtree_at l2 (subtree_at l1 T)) -> is_tree (subtree_at (l1 ++ l2) T). *)
(* Proof. *)
(*   eapply subtree_at_app. *)
(* Qed. *)

(* Lemma subtree_at_app_inf' T l1 l2 : *)
(*   infinite_tree (subtree_at l2 (subtree_at l1 T)) -> infinite_tree (subtree_at (l1 ++ l2) T). *)
(* Proof. *)
(*   eapply subtree_at_app_inf. *)
(* Qed. *)

(* Hint Resolve subtree_at_app' subtree_at_app_inf' : core. *)

(* Lemma LLPO_ADCC_WKL : *)
(*   LLPO_tree -> (forall P, (ADC_on (sig (fun l : list bool => P l)))) -> WKL. *)
(* Proof. *)
(*   move => LLPO C T Hinf. *)
(*   unshelve edestruct (C (fun l => is_tree (subtree_at l T) /\ infinite_tree (subtree_at l T))  (fun l1 l2 => exists b, proj1_sig l2 = proj1_sig l1 ++ [b])) as [f [H0 Hf]]. *)
(*   - exists []. split. eapply T. eapply Hinf. *)
(*   - intros [l [l_tree l_inf]]. *)
(*     destruct (LLPO (Build_tree l_tree) l_inf) as [[Htree Hinft] | [Htree Hinft]]; cbn in *. *)
(*     + unshelve eexists. *)
(*       * exists (l ++ [true]). eauto. *)
(*       * exists true. reflexivity. *)
(*     + unshelve eexists. *)
(*       * exists (l ++ [false]). eauto. *)
(*       * exists false. reflexivity. *)
(*   - assert (Hl : forall n, length (proj1_sig (f n)) = n). { *)
(*       induction n. *)
(*       + rewrite H0. reflexivity. *)
(*       + destruct (Hf n) as [b ->].  rewrite app_length IHn //=. lia. *)
(*     } *)
(*     assert (Hmap : forall n, (map (λ n0 : nat, nth_default false (proj1_sig (f (S n0))) n0) (seq 0 n) = proj1_sig (f n))). { *)
(*       intros n. induction n. *)
(*       - cbn. rewrite H0. reflexivity. *)
(*       - replace (S n) with (n + 1) at 1 by lia. *)
(*         rewrite seq_app map_app IHn. cbn. *)
(*         specialize (Hf n) as [b ->]. *)
(*         rewrite nth_default_eq app_nth2. *)
(*         + rewrite Hl. lia. *)
(*         + rewrite Hl. cbn. now rewrite minus_diag. *)
(*     } *)
(*     exists (fun n => nth_default false (proj1_sig (f (S n))) n). *)
(*     intros n. rewrite Hmap. destruct (f n) as [l [Htree]]. *)
(*     cbn. eapply tree_nil in Htree. unfold subtree_at in Htree. *)
(*     revert Htree. now simpl_list. *)
(* Qed. *)

(* Definition DC_lor := forall p q, (forall u : list bool, p u \/ q u) -> exists f, forall n, if f n then p (map f (seq 0 n)) else q (map f (seq 0 n)). *)
(* Definition CC_lor := forall p q, (forall n : nat, p n \/ q n) ->      exists f, forall n, if f n then p n else q n. *)

(* Lemma Delta_DC_lor : forall p q, decidable p -> decidable q -> (forall u : list bool, p u \/ q u) -> exists f, forall n, if f n then p (map f (seq 0 n)) else q (map f (seq 0 n)). *)
(* Proof. *)
(*   intros p q [f Hf] [g Hg] H. *)
(*   pose (F := fix F n := match n with *)
(*                         | 0 => if f [] then [true] else [false] *)
(*                         | S n => if f (F n) then F n ++ [true] else F n ++ [false] *)
(*                         end). *)
(*   assert (HF : forall n, length (F n) = S n). { *)
(*     induction n; cbn. *)
(*     - destruct (f []); reflexivity. *)
(*     - destruct (f (F n)); rewrite app_length; cbn; lia. *)
(*   } *)
(*   exists (fun n => nth n (F n) false). *)
(*   induction n. *)
(*   - cbn. specialize (Hf []). *)
(*     destruct (f []); cbn. *)
(*     + now eapply Hf.  *)
(*     + edestruct (H []) as [H1 | H1]; eauto. eapply Hf in H1. congruence.  *)
(*   - specialize (Hf (F n)). *)
(*     cbn -[seq]. *)
(*     assert (E : map (λ n0 : nat, nth n0 (F n0) false) (seq 0 (length (F n))) = F n). *)
(*     + clear Hf. clear - HF. induction n. *)
(*       * cbn. destruct (f []); reflexivity. *)
(*       * cbn. destruct (f (F n)) eqn:E. *)
(*         -- rewrite app_length seq_app map_app. *)
(*            cbn. rewrite HF. cbn -[seq]. rewrite E. rewrite app_nth2. rewrite HF. lia. *)
(*            cbn -[seq]. rewrite HF minus_diag. *)
(*            rewrite <- IHn. now rewrite HF. *)
(*         -- rewrite app_length seq_app map_app. *)
(*            cbn. rewrite HF. cbn -[seq]. rewrite E. rewrite app_nth2. rewrite HF. lia. *)
(*            cbn -[seq]. rewrite HF minus_diag. *)
(*            rewrite <- IHn. now rewrite HF. *)
(*     + destruct (f (F n)). *)
(*       * rewrite app_nth2. rewrite HF. lia. *)
(*         rewrite HF minus_diag. cbn [nth]. *)
(*         rewrite <- HF, E. now eapply Hf. *)
(*       * rewrite app_nth2. rewrite HF. lia. *)
(*         rewrite HF minus_diag. cbn [nth]. *)
(*         rewrite <- HF, E. *)
(*         destruct (H (F n)); eauto. eapply Hf in H0. congruence. *)
(* Qed. *)

(* Lemma DC_CC_iff : *)
(*   DC_lor <-> CC_lor. *)
(* Proof. *)
(*   split. *)
(*   - intros dc p q H. *)
(*     destruct (dc (fun u => p (length u)) (fun u => q (length u))) as [f Hf]; eauto. *)
(*     exists f. intros n. specialize (Hf n). *)
(*     now rewrite map_length seq_length in Hf. *)
(*   - assert (countable (list bool)) as (G & F & HFG). { *)
(*       eapply enumerable_discrete_countable; eauto. *)
(*       eapply discrete_iff. econstructor. exact _. *)
(*     } *)
(*     intros cc p q H. *)
(*     pose (F' n := match F n with Some u => u | _ => [] end). *)
(*     destruct (cc (fun n => p (F' n)) (fun n => q (F' n))) as [f Hf]; eauto. *)
(*     assert (forall u, f (G u) = true \/ f (G u) = false) as [g Hg] % Delta_DC_lor. { *)
(*       intros u. destruct (f (G u)); eauto.  *)
(*     } *)
(*     + exists g. intros n. specialize (Hg n). *)
(*       specialize (Hf (G (map g (seq 0 n)))). *)
(*       destruct (g n); now rewrite Hg /F' HFG in Hf. *)
(*     + eapply decidable_iff. econstructor. *)
(*       intros. exact _. *)
(*     + eapply decidable_iff. econstructor. *)
(*       intros. exact _. *)
(* Qed. *)

(* (* Lemma LLPO_DC_WKL : *) *)
(* (*   LLPO_tree -> DC_lor -> WKL. *) *)
(* (* Proof. *) *)
(* (*   move => LLPO C T Hinf. *) *)
(* (*   specialize (C (fun u => is_tree (subtree_at (u) T) /\ infinite_tree (subtree_at (u) T) -> is_tree (subtree_at (u ++ [true]) T) /\ infinite_tree (subtree_at (u ++ [true]) T)) (fun u => is_tree (subtree_at (u) T) /\ infinite_tree (subtree_at (u) T) -> is_tree (subtree_at (u ++ [false]) T) /\ infinite_tree (subtree_at (u ++ [false]) T))) as [f Hf]. *) *)
(* (*   - induction u using rev_ind. *) *)
(* (*     + destruct (LLPO T); eauto. *) *)
(* (*     + destruct IHu as [(v & H1 & H2 & H3)|(v & H1 & H2 & H3)]. *) *)
(* (*       * eapply (LLPO (Build_tree H2)) in H3 as [[H3 H4] | [H3 H4]]; cbn in *. *) *)
(* (*         -- eapply subtree_at_app in H3. eapply subtree_at_app_inf in H4. *) *)
(* (*            left. exists (v ++ [true]). split. rewrite! app_length. cbn. lia. eauto. *) *)
(* (*         -- eapply subtree_at_app in H3. eapply subtree_at_app_inf in H4. *) *)
(* (*            right. exists (v ++ [true]). split. rewrite! app_length. cbn. lia. eauto. *) *)
(* (*       * eapply (LLPO (Build_tree H2)) in H3 as [[H3 H4] | [H3 H4]]; cbn in *. *) *)
(* (*         -- eapply subtree_at_app in H3. eapply subtree_at_app_inf in H4. *) *)
(* (*            left. exists (v ++ [false]). split. rewrite! app_length. cbn. lia. eauto. *) *)
(* (*         -- eapply subtree_at_app in H3. eapply subtree_at_app_inf in H4. *) *)
(* (*            right. exists (v ++ [false]). split. rewrite! app_length. cbn. lia. eauto. *) *)
(* (*   - exists f. induction n. *) *)
(* (*     + cbn. eauto. *) *)
(* (*     + replace (S n) with (n + 1) by lia. *) *)
(* (*       rewrite seq_app. cbn. *) *)

(* (* . *) *)
(* (*   destruct (C (fun u => T (u ++ [true])) (fun u => T (u ++ [false]))). *) *)
(* (*   unshelve edestruct (C (fun l => is_tree (subtree_at l T) /\ infinite_tree (subtree_at l T))  (fun l1 l2 => exists b, proj1_sig l2 = proj1_sig l1 ++ [b])) as [f [H0 Hf]]. *) *)
(* (*   - exists []. split. eapply T. eapply Hinf. *) *)
(* (*   - intros [l [l_tree l_inf]]. *) *)
(* (*     destruct (LLPO (Build_tree l_tree) l_inf) as [[Htree Hinft] | [Htree Hinft]]; cbn in *. *) *)
(* (*     + unshelve eexists. *) *)
(* (*       * exists (l ++ [true]). eauto. *) *)
(* (*       * exists true. reflexivity. *) *)
(* (*     + unshelve eexists. *) *)
(* (*       * exists (l ++ [false]). eauto. *) *)
(* (*       * exists false. reflexivity. *) *)
(* (*   - assert (Hl : forall n, length (proj1_sig (f n)) = n). { *) *)
(* (*       induction n. *) *)
(* (*       + rewrite H0. reflexivity. *) *)
(* (*       + destruct (Hf n) as [b ->].  rewrite app_length IHn //=. lia. *) *)
(* (*     } *) *)
(* (*     assert (Hmap : forall n, (map (λ n0 : nat, nth_default false (proj1_sig (f (S n0))) n0) (seq 0 n) = proj1_sig (f n))). { *) *)
(* (*       intros n. induction n. *) *)
(* (*       - cbn. rewrite H0. reflexivity. *) *)
(* (*       - replace (S n) with (n + 1) at 1 by lia. *) *)
(* (*         rewrite seq_app map_app IHn. cbn. *) *)
(* (*         specialize (Hf n) as [b ->]. *) *)
(* (*         rewrite nth_default_eq app_nth2. *) *)
(* (*         + rewrite Hl. lia. *) *)
(* (*         + rewrite Hl. cbn. now rewrite minus_diag. *) *)
(* (*     } *) *)
(* (*     exists (fun n => nth_default false (proj1_sig (f (S n))) n). *) *)
(* (*     intros n. rewrite Hmap. destruct (f n) as [l [Htree]]. *) *)
(* (*     cbn. eapply tree_nil in Htree. unfold subtree_at in Htree. *) *)
(* (*     revert Htree. now simpl_list. *) *)
(* (* Qed. *) *)

(* Lemma test : *)
(*   WKL <->   coS_ADC_on_weak bool. *)
(* Proof. *)
(*   split. *)
(*   - intros WKL. *)
(*     eapply maria, bla. *)
(*     eapply WKL_to_LPOO. eassumption. *)
(*     eapply WKL_to_coS_AC_on_nat_bool. eassumption. *)
(*   - eapply andback. *)
(* Qed. *)