(* * Constructor and Deconstructor Machines for Lists *)

From Undecidability.TM Require Import ProgrammingTools.

Local Arguments plus : simpl never. Local Arguments mult : simpl never.

Set Default Proof Using "Type".

Lemma tl_length (X : Type) (xs : list X) :
  length (tl xs) = pred (length xs).
Proof. destruct xs; cbn; auto. Qed.

Section CaseList.

  (* ** Deconstructor *)

  Variable X : Type.
  Variable (sigX : finType).
  Hypothesis (cX : codable sigX X).

  Set Default Proof Using "Type".

  Definition stop (s: (sigList sigX)^+) :=
    match s with
    | inr (sigList_cons) => true
    | inr (sigList_nil) => true
    | inl _ => true
    | _ => false
    end.

  Definition Skip_cons : pTM (sigList sigX)^+ unit 1 :=
    Move Rmove;;
    MoveToSymbol stop id.

  Definition M1 : pTM (sigList sigX)^+ unit 2 :=
    LiftTapes Skip_cons [|Fin0|];;
    LiftTapes (Write (inl STOP)) [|Fin1|];;
    MovePar Lmove Lmove;;
    CopySymbols_L stop;;
    LiftTapes (Write (inl START)) [|Fin1|].

  Definition CaseList : pTM (sigList sigX)^+ bool 2 :=
    LiftTapes (Move Rmove) [|Fin0|];;
    Switch (LiftTapes (ReadChar) [|Fin0|])
          (fun s => match s with
                 | Some (inr sigList_nil) => (* nil *)
                   Return (LiftTapes (Move Lmove) [|Fin0|]) false
                 | Some (inr sigList_cons) => (* cons *)
                   M1;;
                   LiftTapes Skip_cons [|Fin0|];;
                   Return (LiftTapes (Move Lmove;; Write (inl START)) [|Fin0|]) true
                 | _ => Return Nop default (* invalid input *)
                 end).

  (* *** Corectness *)

  Definition Skip_cons_Rel : pRel (sigList sigX)^+ unit 1 :=
    Mk_R_p (
        ignoreParam (
            fun tin tout =>
              forall ls rs (x : X) (l : list X),
                tin = midtape (inl START :: ls) (inr sigList_cons)
                              (map inr (Encode_map _ _ x) ++ map inr (Encode_map _ _ l) ++ inl STOP :: rs) ->
                match l with
                | nil =>
                  tout = midtape (rev (map inr (Encode_map _ _ x)) ++ inr sigList_cons :: inl START :: ls)
                                 (inr sigList_nil) (inl STOP :: rs)
                | x'::l' =>
                  tout = midtape (rev (map inr (Encode_map _ _ x)) ++ inr sigList_cons :: inl START :: ls)
                                 (inr sigList_cons) (map inr (Encode_map _ _ x') ++ map inr (Encode_map _ _ l') ++ inl STOP :: rs)
                end)).

  Lemma stop_lemma x :
    forall s : (sigList sigX)^+, s el map inr (map sigList_X (encode x)) -> stop s = false.
  Proof.
    rewrite List.map_map. intros ? (?&<-&?) % in_map_iff. cbn. reflexivity.
  Qed.

  Lemma Skip_cons_Realise : Skip_cons ⊨ Skip_cons_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Skip_cons. TM_Correct. }
    {
      intros tin ((), tout) H. intros ls rs x l HTin. TMSimp. clear_trivial_eqs.
      destruct l as [ | x' l']; cbn.
      - rewrite MoveToSymbol_correct_moveright; cbn; auto.
        + now rewrite map_id.
        + apply stop_lemma.
      - rewrite MoveToSymbol_correct_moveright; cbn; auto.
        + now rewrite map_map, map_id, map_app, <- app_assoc, !map_map.
        + apply stop_lemma.
    }
  Qed.

  Definition M1_Rel : pRel (sigList sigX)^+ unit 2 :=
    ignoreParam (
        fun tin tout =>
          forall ls rs (x : X) (l : list X) (s1 : nat),
            tin[@Fin0] = midtape (inl START :: ls) (inr sigList_cons)
                                 (map inr (Encode_map _ _ x) ++ map inr (Encode_map _ _ l) ++ inl STOP :: rs) ->
            isVoid_size tin[@Fin1] s1 ->
            tout[@Fin0] = tin[@Fin0] /\
            tout[@Fin1] ≃(; s1 - (S (size x))) x).

  Lemma M1_Realise : M1 ⊨ M1_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold M1. TM_Correct. eapply Skip_cons_Realise. }
    {
      intros tin ((), tout) H. intros ls rs x l s HTin0 HRight. TMSimp; clear_trivial_eqs.
      rename H4 into HCopy.
      destruct HRight as (r1&r2&HRight&Hs). TMSimp.

      specialize H with (1 := eq_refl).
      destruct l as [ | x' l']; TMSimp.
      - rewrite CopySymbols_L_correct_moveleft in HCopy; cbn; auto.
        2: setoid_rewrite <- in_rev; apply stop_lemma.
        inv HCopy. TMSimp.
        cbn. rewrite !rev_involutive. repeat econstructor. cbn. f_equal. simpl_tape. reflexivity.
        + simpl_list. rewrite skipn_length. simpl_tape. unfold size. rewrite tl_length. lia.
      - rewrite CopySymbols_L_correct_moveleft in HCopy; cbn; auto.
        2: setoid_rewrite <- in_rev; apply stop_lemma.
        inv HCopy. TMSimp.
        cbn. rewrite !rev_involutive. repeat econstructor.
        + f_equal. cbn. rewrite !map_map, map_app, <- app_assoc, map_map. reflexivity.
        + cbn. f_equal. simpl_tape. reflexivity.
        + simpl_list. rewrite skipn_length. simpl_tape. unfold size. rewrite tl_length. lia.
    }
  Qed.

  Definition CaseList_size0 {sigX X : Type} {cX : codable sigX X} (x : X) (s0 : nat) := S (s0 + size x).
  Definition CaseList_size1 {sigX X : Type} {cX : codable sigX X} (x : X) (s1 : nat) := s1 - (S (size x)).

  Definition CaseList_Rel : pRel (sigList sigX)^+ bool 2 :=
    fun tin '(yout, tout) =>
      forall (l : list X) (s0 s1 : nat),
        tin[@Fin0] ≃(;s0) l ->
        isVoid_size tin[@Fin1] s1 ->
        match yout, l with
        | false, nil =>
          tout[@Fin0] ≃(;s0) @nil X /\
          isVoid_size tout[@Fin1] s1
        | true, x :: l' =>
          tout[@Fin0] ≃(; CaseList_size0 x s0) l' /\
          tout[@Fin1] ≃(; CaseList_size1 x s1) x
        | _, _ => False
        end.

  Lemma CaseList_Realise : CaseList ⊨ CaseList_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold CaseList. TM_Correct. eapply M1_Realise. eapply Skip_cons_Realise. }
    {
      intros tin (yout, tout) H. intros l s0 s1 HEncL HRight.
      unfold CaseList_size0, CaseList_size1 in *.
      destruct HEncL as (ls&HEncL&Hs0). pose proof HRight as (ls'&rs'&HRight'&Hs1). TMSimp; clear_trivial_eqs.
      destruct l as [ | x l'] in *; cbn in *; TMSimp; clear_trivial_eqs.
      { (* nil *)
        split; auto.
        - repeat econstructor; cbn; simpl_tape. auto.
      }
      { (* cons *)
        rewrite !map_map, map_app, <- app_assoc in *.
        setoid_rewrite map_map in H. setoid_rewrite map_map in H0.
        specialize H with (1 := eq_refl) (2 := HRight).
        TMSimp. specialize H0 with (1 := eq_refl).
        destruct l' as [ | x' l'']; TMSimp.
        - repeat split; auto. hnf. eexists. split. simpl_tape. f_equal.
          + rewrite tl_length. simpl_list. cbn. unfold size. lia.
        - repeat split; auto. hnf. eexists. simpl_tape. rewrite List.map_map. cbn. simpl_list. split.
          + f_equal. f_equal. now rewrite !map_map.
          + rewrite tl_length. simpl_list. cbn. unfold size. lia.
      }
    }
  Qed.

  (* *** Termination *)

  Lemma Skip_cons_Terminates :
    projT1 (Skip_cons) ↓
           (fun tin k =>
              exists ls rs (x : X) (l : list X),
                tin[@Fin0] = midtape (inl START :: ls) (inr sigList_cons)
                                     (map inr (Encode_map _ _ x) ++ map inr (Encode_map _ _ l) ++ inl STOP :: rs) /\
                 6 + 4 *size x <= k).
  Proof.
    eapply TerminatesIn_monotone.
    { unfold Skip_cons. TM_Correct. }
    {
      intros tin k (ls&rs&x&l&HTin&Hk). TMSimp.
      exists 1, (4 + 4 *size x). repeat split. 1-2: lia.
      intros tmid () H. TMSimp.
      destruct l as [ | x' l]; cbn.
      - rewrite MoveToSymbol_steps_moveright; cbn; auto. now rewrite !map_length.
      - rewrite MoveToSymbol_steps_moveright; cbn; auto. now rewrite !map_length.
    }
  Qed.

  Lemma M1_Terminates :
    projT1 M1 ↓
           (fun tin k =>
              exists ls rs (x : X) (l : list X),
                tin[@Fin0] = midtape (inl START :: ls) (inr sigList_cons)
                                     (map inr (Encode_map _ _ x) ++ map inr (Encode_map _ _ l) ++ inl STOP :: rs) /\
                 23 + 12 *size x <= k).
  Proof.
    eapply TerminatesIn_monotone.
    { unfold M1. TM_Correct. eapply Skip_cons_Realise. eapply Skip_cons_Terminates. }
    {
      intros tin k (ls&rs&x&l&HTin&Hk). TMSimp.
      exists (6 + 4 *size x), (16 + 8 *size x). repeat split; try lia. eauto 6.
      intros tmid_ (). intros (H&HInj); TMSimp. specialize H with (1 := eq_refl).
      destruct l as [ | x' l']; TMSimp. (* Both cases are identical *)
      1-2: exists 1, (14 + 8 *size x); repeat split; try lia.
      - intros tmid2 (). intros (_&HInj2); TMSimp.
        exists 3, (10 + 8 *size x). repeat split; try lia.
        intros tmid3 (). intros (H3&H3'); TMSimp.
        exists (8+8*size cX x), 1. repeat split; cbn; try lia.
        + rewrite CopySymbols_L_steps_moveleft; auto.
          now rewrite rev_length, !map_length.
      - intros tmid2 (). intros (_&HInj2); TMSimp.
        exists 3, (10 + 8 *size x). repeat split; try lia.
        intros tmid3 (). intros (H3&H3'); TMSimp.
        exists (8+8*size cX x), 1. repeat split; cbn; try lia.
        + rewrite CopySymbols_L_steps_moveleft; auto.
          now rewrite rev_length, !map_length.
    }
  Qed.

  Definition CaseList_steps_cons {sigX X : Type} {cX : codable sigX X} (x : X) := 42 + 16 *size x.

  Definition CaseList_steps_nil := 5.

  Definition CaseList_steps {sigX X : Type} {cX : codable sigX X} (l:list X) :=
    match l with
    | nil => CaseList_steps_nil
    | x::l' => CaseList_steps_cons x
    end.

  Lemma CaseList_Terminates :
    projT1 CaseList ↓
           (fun tin k =>
              exists l : list X,
                tin[@Fin0] ≃ l /\
                isVoid tin[@Fin1] /\
                CaseList_steps l <= k).
  Proof.
    unfold CaseList_steps, CaseList_steps_cons, CaseList_steps_nil. eapply TerminatesIn_monotone.
    { unfold CaseList. TM_Correct.
      - eapply M1_Realise.
      - eapply M1_Terminates.
      - eapply Skip_cons_Realise.
      - eapply Skip_cons_Terminates.
    }
    {
      cbn. intros tin k (l&HEncL&HRight&Hk).
      destruct HEncL as (ls&HEncL); TMSimp.
      destruct l as [ | x l']; cbn.
      {
        exists 1, 3. repeat split; try lia.
        intros tmid (). intros (H1&HInj1); TMSimp.
        exists 1, 1. repeat split; try lia.
        intros tmid2 ymid2 ((H2&H2')&HInj2). apply Vector.cons_inj in H2' as (H2'&_). TMSimp.
        lia.
      }
      {
        exists 1, (40 + 16 *size x). repeat split; try lia.
        intros tmid (). intros (H1&HInj1); TMSimp.
        exists 1, (38 + 16 *size x). repeat split; try lia.
        intros tmid2 ymid2 ((H2&H2')&HInj2). apply Vector.cons_inj in H2' as (H2'&_). TMSimp.
        exists (23 + 12 *size x), (14 + 4 *size x). repeat split; try lia.
        { TMSimp_goal. rewrite !map_map, List.map_app, <- app_assoc, !map_map. do 4 eexists; eauto. split.
          - f_equal. now rewrite !map_map.
          - lia.
        }
        intros tmid3 () H3'.
        rewrite !map_map, map_app, <- app_assoc in H3'.
        setoid_rewrite map_map in H3'.
        specialize H3' with (1 := eq_refl) (2 := isVoid_isVoid_size HRight). TMSimp.
        exists (6 + 4 *size x), 3. repeat split; try lia.
        { do 4 eexists; repeat split; eauto. now rewrite !map_map. }
        intros tmid4 () (H4&HInj4); TMSimp.
        setoid_rewrite map_map in H4.
        specialize H4 with (1 := eq_refl).
        destruct l' as [ | x' l'']; TMSimp. (* both cases are equal *)
        - exists 1, 1. repeat split; try lia.
        - exists 1, 1. repeat split; try lia.
      }
    }
  Qed.

  (* ** [IsNil] *)

  Definition IsNil : pTM (sigList sigX)^+ bool 1 :=
    Move Rmove;;
    Switch ReadChar
    (fun s =>
       match s with
       | Some (inr sigList_nil) =>
         Return (Move Lmove) true
       | _ => Return (Move Lmove) false
       end).

  Definition IsNil_Rel : pRel (sigList sigX)^+ bool 1 :=
    Mk_R_p (
        fun tin '(yout, tout) =>
          forall (xs : list X) (s : nat),
            tin ≃(;s) xs ->
            match yout, xs with
            | true, nil => tout ≃(;s) xs
            | false, _ :: _ => tout ≃(;s) xs
            | _, _ => False
            end).

  Definition IsNil_steps := 5.

  Lemma IsNil_Sem : IsNil ⊨c(IsNil_steps) IsNil_Rel.
  Proof.
    unfold IsNil_steps. eapply RealiseIn_monotone.
    { unfold IsNil. TM_Correct. }
    { Unshelve. 4-11: reflexivity. lia. }
    {
      intros tin (yout, tout) H. cbn. intros xs s HEncXs.
      destruct HEncXs as (ls & HEncXs & Hs). TMSimp.
      destruct xs as [ | x xs' ]; TMSimp.
      - now repeat econstructor.
      - now repeat econstructor.
    }
  Qed.

  (* ** Constructors *)

  (* *** [nil] *)

  Definition Constr_nil : pTM (sigList sigX)^+ unit 1 := WriteValue (@nil X).

  Goal Constr_nil = WriteMove (inl STOP) Lmove;; WriteMove (inr sigList_nil) Lmove;; Write (inl START).
  Proof. reflexivity. Qed.

  Definition Constr_nil_Rel : pRel (sigList sigX)^+ unit 1 :=
    Mk_R_p (ignoreParam (fun tin tout => forall (s : nat), isVoid_size tin s -> tout ≃(; pred s) @nil X)).

  Definition Constr_nil_steps := 5.

  Lemma Constr_nil_Sem : Constr_nil ⊨c(Constr_nil_steps) Constr_nil_Rel.
  Proof.
    unfold Constr_nil_steps. eapply RealiseIn_monotone.
    { unfold Constr_nil. TM_Correct. }
    { reflexivity. }
    { intros tin ((), tout) H. cbn in *. intros s HRight.
      specialize H with (1 := HRight). contains_ext. unfold WriteValue_size. lia. }
  Qed.

  (* *** [cons] *)

  Definition Constr_cons : pTM (sigList sigX)^+ unit 2 :=
    LiftTapes (MoveRight _;; Move Lmove) [|Fin1|];;
    LiftTapes (CopySymbols_L stop) [|Fin1;Fin0|];;
    LiftTapes (WriteMove (inr sigList_cons) Lmove;; Write (inl START)) [|Fin0|].

  Definition Constr_cons_size {sigX X : Type} {cX : codable sigX X} (y : X) (s0 : nat) := s0 - size y - 1.

  Definition Constr_cons_Rel : pRel (sigList sigX)^+ unit 2 :=
    ignoreParam (
        fun tin tout =>
          forall (l:list X) (y:X) (s0 s1 : nat),
            tin[@Fin0] ≃(;s0) l ->
            tin[@Fin1] ≃(;s1) y ->
            tout[@Fin0] ≃(;Constr_cons_size y s0) y :: l /\
            tout[@Fin1] ≃(;s1) y
      ).

  Lemma Constr_cons_Realise : Constr_cons ⊨ Constr_cons_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Constr_cons. TM_Correct. apply MoveRight_Realise with (X := X). }
    {
      intros tin ((), tout) H. intros l y s0 s HEncL HEncY.
      unfold Constr_cons_size in *.
      TMSimp; clear_trivial_eqs.
      modpon H. destruct H as (ls&H). TMSimp.
      destruct HEncL as (ls2&HEncL&Hs). TMSimp.
      rewrite CopySymbols_L_correct_moveleft in H0; swap 1 2; auto.
      { intros ? (?&<-& (?&<-&?) % in_rev % in_map_iff) % in_map_iff. cbn. reflexivity. }
      inv H0. TMSimp.
      repeat econstructor.
      - cbn. f_equal. simpl_tape. rewrite !map_rev, rev_involutive. f_equal.
        now rewrite !List.map_map, map_app, <- app_assoc, List.map_map.
      - simpl_tape. rewrite tl_length. simpl_list. rewrite skipn_length. unfold size. lia.
      - f_equal. now rewrite !map_rev, rev_involutive.
      - auto.
    }
  Qed.

  Definition Constr_cons_steps {sigX X : Type} {cX : codable sigX X} (x : X) := 23 + 12 * size x.

  Lemma Constr_cons_Terminates :
    projT1 Constr_cons ↓
           (fun tin k =>
              exists (l: list X) (y: X),
                tin[@Fin0] ≃ l /\
                tin[@Fin1] ≃ y /\
                Constr_cons_steps y <= k).
  Proof.
    unfold Constr_cons_steps. eapply TerminatesIn_monotone.
    { unfold Constr_cons. TM_Correct.
      - apply MoveRight_Realise with (X := X).
      - apply MoveRight_Realise with (X := X).
      - apply MoveRight_Terminates with (X := X).
    }
    {
      intros tin k (l&y&HEncL&HEncY&Hk). cbn.
      exists (10 + 4 * size y), (12 + 8 * size y). repeat split; try lia.
      - cbn. exists (8 + 4 * size y), 1. repeat split; try lia.
        + eexists. split. eauto. reflexivity.
      - intros tmid () (H&HInj). TMSimp.
        modpon H. destruct H as (ls&HEncY'). TMSimp.
        exists (8 + 8 * size y), 3. repeat split; try lia.
        + erewrite CopySymbols_L_steps_moveleft; eauto. now rewrite map_length, rev_length, map_length.
        + intros tmid2 (). intros (H2&HInj2). TMSimp.
          exists 1, 1. repeat split; try lia.
    }
  Qed.

End CaseList.

Arguments CaseList    : simpl never.
Arguments IsNil       : simpl never.
Arguments Constr_nil _ {_ _}: simpl never.
Arguments Constr_cons : simpl never.

Arguments CaseList_size0      {sigX X cX} : simpl never.
Arguments CaseList_size1      {sigX X cX} : simpl never.
Arguments Constr_cons_size    {sigX X cX} : simpl never.

Arguments CaseList_steps_cons {sigX X cX} : simpl never.
Arguments CaseList_steps      {sigX X cX} : simpl never.
Arguments Constr_cons_steps   {sigX X cX} : simpl never.
Arguments CaseList_steps_nil              : simpl never.

(*
(* ** Compatibility of running time functions with encoding mapping *)

Section Steps_comp.
  Variable (sig tau: finType) (X:Type) (cX: codable sig X).
  Variable (I : Retract sig tau).

  Lemma CaseList_steps_cons_comp x :
    CaseList_steps_cons (Encode_map cX I) x = CaseList_steps_cons cX x.
  Proof. unfold CaseList_steps_cons. now rewrite Encode_map_hasSize. Qed.

  Lemma CaseList_steps_comp l :
    CaseList_steps (Encode_map cX I) l = CaseList_steps cX l.
  Proof. unfold CaseList_steps. destruct l; auto. apply CaseList_steps_cons_comp. Qed.

  Lemma CaseList_size0_comp x s0 :
    CaseList_size0 (Encode_map cX I) x s0 = CaseList_size0 cX x s0.
  Proof. unfold CaseList_size0. now rewrite Encode_map_hasSize. Qed.

  Lemma CaseList_size1_comp x s1 :
    CaseList_size1 (Encode_map cX I) x s1 = CaseList_size1 cX x s1.
  Proof. unfold CaseList_size1. now rewrite Encode_map_hasSize. Qed.

  Lemma Constr_cons_steps_comp l :
    Constr_cons_steps (Encode_map cX I) l = Constr_cons_steps cX l.
  Proof. unfold Constr_cons_steps. now rewrite Encode_map_hasSize. Qed.

End Steps_comp.
*)

(* ** Tactic Support *)

Ltac smpl_TM_CaseList :=
  once lazymatch goal with
  | [ |- CaseList _ ⊨ _ ] => apply CaseList_Realise
  | [ |- projT1 (CaseList _) ↓ _ ] => apply CaseList_Terminates

  | [ |- IsNil _ ⊨ _ ] => eapply RealiseIn_Realise; apply IsNil_Sem
  | [ |- IsNil _ ⊨c(_) _ ] => apply IsNil_Sem
  | [ |- projT1 (IsNil _ ) ↓ _ ] => eapply RealiseIn_TerminatesIn; apply IsNil_Sem

  | [ |- Constr_nil _ ⊨ _ ] => eapply RealiseIn_Realise; apply Constr_nil_Sem
  | [ |- Constr_nil _ ⊨c(_) _ ] => apply Constr_nil_Sem
  | [ |- projT1 (Constr_nil _) ↓ _ ] => eapply RealiseIn_TerminatesIn; apply Constr_nil_Sem

  | [ |- Constr_cons _ ⊨ _ ] => apply Constr_cons_Realise
  | [ |- projT1 (Constr_cons _) ↓ _ ] => apply Constr_cons_Terminates
  end.

Smpl Add smpl_TM_CaseList : TM_Correct.

From Undecidability.TM.Hoare Require Import HoareLogic HoareRegister HoareTactics.

Section CaseList.

  Variable (X : Type) (sigX : finType) (codX : codable sigX X).

  Definition Constr_cons_sizefun (x : X) : Vector.t (nat->nat) 2 :=
    [|Constr_cons_size x; id|].

  Lemma Constr_cons_SpecT_size (x : X) (xs : list X) (ss : Vector.t nat 2) :
    TripleT
      (≃≃(([], withSpace  [|Contains _ xs; Contains _ x |] ss))) (Constr_cons_steps x) (Constr_cons sigX)
      (fun _ => ≃≃(([], withSpace  [|Contains _ (x::xs); Contains _ x|] (appSize (Constr_cons_sizefun x) ss)))).
  Proof. unfold withSpace.
    eapply Realise_TripleT.
    - apply Constr_cons_Realise.
    - apply Constr_cons_Terminates.
    - intros tin [] tout H HEnc. cbn in *.
      specialize (HEnc Fin0) as HEnc0; specialize (HEnc Fin1) as HEnc1; simpl_vector in *; cbn in *.
      modpon H. tspec_solve.
    - intros tin k HEnc Hk. cbn.
      specialize (HEnc Fin0) as HEnc0; specialize (HEnc Fin1) as HEnc1; simpl_vector in *; cbn in *.
      eauto.
  Qed.

  Lemma Constr_nil_SpecT_size (ss : Vector.t nat 1) :
    TripleT
      (≃≃(([], withSpace  [|Void |] ss))) Constr_nil_steps (Constr_nil X)
      (fun _ => ≃≃(([], withSpace  [|Contains _ (@nil X) |] (appSize [|pred|] ss)))).
  Proof. unfold withSpace.
    eapply RealiseIn_TripleT.
    - apply Constr_nil_Sem.
    - intros tin [] tout H HEnc. cbn in *.
      specialize (HEnc Fin0). simpl_vector in *; cbn in *. modpon H. tspec_solve.
  Qed.

  Definition CaseList_size (xs : list X) : Vector.t (nat->nat) 2 :=
    match xs with
    | nil => [|id;id|]
    | x :: xs => [|CaseList_size0 x; CaseList_size1 x|]
    end.

  Lemma CaseList_SpecT_size (xs : list X) (ss : Vector.t nat 2) :
    TripleT
      (≃≃(([], withSpace  [|Contains _ xs; Void |] ss))) (CaseList_steps xs) (CaseList sigX)
      (fun yout => ≃≃([yout = match xs with [] => false | _ => true end],withSpace
                         (match xs with
                          |   x::xs' => [|Contains _ xs'; Contains _ x|]
                          |    nil => [|Contains _ xs; Void|]
                          end)
                         (appSize (CaseList_size xs) ss))).
  Proof. unfold withSpace.
    eapply Realise_TripleT.
    - apply CaseList_Realise.
    - apply CaseList_Terminates.
    - intros tin yout tout H HEnc. cbn in *.
      specialize (HEnc Fin0) as HEnc0; specialize (HEnc Fin1) as HEnc1; simpl_vector in *; cbn in *.
      modpon H. destruct yout, xs; cbn in *; eauto.
      + destruct H as (H1&H2). tspec_solve. easy.
      + destruct H as (H1&H2). tspec_solve. easy.
    - intros tin k HEnc Hk. cbn.
      specialize (HEnc Fin0) as HEnc0; specialize (HEnc Fin1) as HEnc1; simpl_vector in *; cbn in *.
      eauto.
  Qed.

End CaseList.

Ltac hstep_List :=
  match goal with
  | [ |- TripleT ?P ?k (Constr_cons _) ?Q ] => eapply Constr_cons_SpecT_size
  | [ |- TripleT ?P ?k (Constr_nil  _) ?Q ] => eapply Constr_nil_SpecT_size
  | [ |- TripleT ?P ?k (CaseList    _) ?Q ] => eapply CaseList_SpecT_size
  end.

Smpl Add hstep_List : hstep_Spec.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.ftc.Rolle.
Require Export CoRN.tactics.DiffTactics3.

Opaque Min Max.

Section Various_Theorems.

(**
* Calculus Theorems

This file is intended to present a collection of miscellaneous, mostly
technical results in differential calculus that are interesting or
useful in future work.

We begin with some properties of continuous functions.  Every
continuous function commutes with the limit of a numerical sequence
(sometimes called Heine continuity).
*)

Lemma Continuous_imp_comm_Lim : forall F x e, [0] [<] e ->
 Continuous (clcr (Lim x[-]e) (Lim x[+]e)) F -> forall Hx Hxn H,
 F (Lim x) Hx [=] Lim (Build_CauchySeq IR (fun n => F (x n) (Hxn n)) H).
Proof.
 intros F x e H H0 Hx Hxn H1.
 set (a := Lim x) in *.
 set (I := clcr (a[-]e) (a[+]e)) in *.
 cut (compact_ I). intro H2.
  2: simpl in |- *.
  2: apply less_leEq; apply less_transitive_unfolded with a.
   2: apply shift_minus_less; apply shift_less_plus'.
   2: astepl ZeroR; auto.
  2: apply shift_less_plus'.
  2: astepl ZeroR; auto.
 apply Limits_unique.
 simpl in |- *.
 intros eps H3.
 set (H2' := H2) in *.
 cut (Continuous_I (a:=Lend H2) (b:=Rend H2) H2' F). intro H4.
  2: apply Int_Continuous; auto.
 elim (contin_prop _ _ _ _ H4 _ H3); intros d H5 H6.
 elim (Cauchy_complete x (Min d e)).
  2: apply less_Min; auto.
 intros N HN.
 exists N; intros.
 fold a in HN.
 apply AbsIR_imp_AbsSmall.
 elim (HN m H7); intros.
 apply H6.
   split; simpl in |- *.
    unfold cg_minus in |- *; apply shift_plus_leEq'.
    eapply leEq_transitive.
     2: apply H8.
    apply inv_resp_leEq; apply Min_leEq_rht.
   apply shift_leEq_plus'.
   eapply leEq_transitive.
    apply H9.
   apply Min_leEq_rht.
  split; simpl in |- *.
   apply shift_minus_leEq; apply shift_leEq_plus'.
   astepl ZeroR; apply less_leEq; auto.
  apply shift_leEq_plus'; astepl ZeroR.
  apply less_leEq; auto.
 apply AbsSmall_imp_AbsIR.
 apply AbsSmall_leEq_trans with (Min d e).
  apply Min_leEq_lft.
 auto.
Qed.

(**
This is a tricky result: if [F] is continuous and positive in both [[a,b]]
and [(b,c]], then it is positive in [[a,c]].
*)

Lemma Continuous_imp_pos : forall a b c (Hac : a [<=] c), a [<=] b -> b [<] c ->
 forall F, Continuous_I Hac F -> (forall t, a [<=] t -> t [<=] b -> forall Ht, [0] [<] F t Ht) ->
 (forall t, b [<] t -> t [<=] c -> forall Ht, [0] [<] F t Ht) -> forall t, a [<=] t -> t [<=] c -> forall Ht, [0] [<] F t Ht.
Proof.
 intros a b c Hac H H0 F H1 H2 H3 t H4 H5 Ht.
 elim H1; intros H6 H7; clear H1.
 cut (Compact Hac b); [ intro H1 | split; auto ].
  2: apply less_leEq; auto.
 set (e := F b (H6 _ H1) [/]TwoNZ) in *.
 cut ([0] [<] e); intros.
  2: unfold e in |- *; apply pos_div_two; apply H2; auto.
  2: apply leEq_reflexive.
 elim H7 with e; auto.
 intros d H9 H10.
 cut (b[-]d [<] b).
  2: apply shift_minus_less; apply shift_less_plus'.
  2: astepl ZeroR; auto.
 intro H11.
 elim (less_cotransitive_unfolded _ _ _ H11 t); intro.
  clear H11.
  elim (less_cotransitive_unfolded _ _ _ H9 (t[-]b)); intro.
   apply H3.
    astepl ([0][+]b); apply shift_plus_less; auto.
   auto.
  apply cont_no_sign_change_pos with (Hab := Hac) (e := e) (Hx := H6 _ H1); auto.
     split; auto.
    apply H10; auto.
     split; auto.
    apply AbsSmall_imp_AbsIR.
    apply AbsIR_eq_AbsSmall.
     rstepr ( [--] (t[-]b)); apply inv_resp_leEq.
     apply less_leEq; auto.
    apply less_leEq; apply shift_minus_less; apply shift_less_plus'; auto.
   unfold e in |- *.
   eapply less_leEq_trans.
    apply pos_div_two'.
    apply H2; auto.
    apply leEq_reflexive.
   apply leEq_AbsIR.
  unfold e in |- *.
  apply pos_div_two'.
  apply H2; auto.
  apply leEq_reflexive.
 apply H2; auto.
 apply less_leEq; auto.
Qed.

(**
Similar results for increasing functions:
*)

Lemma strict_inc_glues : forall a b c F (Hab : a [<=] b) (Hbc : b [<=] c) (Hac : a [<=] c),
 included (Compact Hac) (Dom F) ->
 (forall x y, Compact Hab x -> Compact Hab y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy) ->
 (forall x y, Compact Hbc x -> Compact Hbc y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy) ->
 forall x y, Compact Hac x -> Compact Hac y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy.
Proof.
 do 7 intro. intros H H0 H1 x y H2 H3 H4 Hx Hy.
 cut (Dom F a); [ intro Ha | apply H; apply compact_inc_lft ].
 cut (Dom F b); [ intro Hb | apply H; split; auto ].
 cut (Dom F c); [ intro Hc | apply H; apply compact_inc_rht ].
 elim (less_cotransitive_unfolded _ _ _ H4 b); intro.
  cut (Dom F (Min b y)); [ intro H5 | apply H; split ].
    2: apply leEq_Min; auto; elim H3; auto.
   2: eapply leEq_transitive; [ apply Min_leEq_lft | auto ].
  apply less_leEq_trans with (F _ H5).
   cut (Dom F (Min ((x[+]b) [/]TwoNZ) y)); [ intro Hxy | apply H; split ].
     3: elim H3; intros; eapply leEq_transitive; [ apply Min_leEq_rht | auto ].
    2: apply leEq_Min.
     3: elim H3; auto.
    2: apply shift_leEq_div; [ apply pos_two | rstepl (a[+]a) ].
    2: apply plus_resp_leEq_both; elim H2; auto.
   apply less_leEq_trans with (F _ Hxy).
    apply H0; try split.
        elim H2; auto.
       apply less_leEq; auto.
      apply leEq_Min.
       2: elim H3; auto.
      apply shift_leEq_div; [ apply pos_two | rstepl (a[+]a) ].
      apply plus_resp_leEq_both; elim H2; auto.
     eapply leEq_transitive.
      apply Min_leEq_lft.
     apply shift_div_leEq; [ apply pos_two | rstepr (b[+]b) ].
     apply plus_resp_leEq; apply less_leEq; auto.
    apply less_Min; auto.
    apply shift_less_div; [ apply pos_two | rstepl (x[+]x) ].
    apply plus_resp_leEq_less; [ apply leEq_reflexive | auto ].
   apply part_mon_imp_mon' with (Compact Hab); auto.
      intros x0 H6; apply H; inversion_clear H6; split; auto.
      apply leEq_transitive with b; auto.
     split.
      apply leEq_Min.
       apply shift_leEq_div; [ apply pos_two | rstepl (a[+]a) ].
       apply plus_resp_leEq_both; auto; elim H2; auto.
      elim H3; auto.
     eapply leEq_transitive.
      apply Min_leEq_lft.
     apply shift_div_leEq; [ apply pos_two | rstepr (b[+]b) ].
     apply plus_resp_leEq; apply less_leEq; auto.
    split.
     apply leEq_Min; auto; elim H3; auto.
    apply Min_leEq_lft.
   apply leEq_Min.
    eapply leEq_transitive.
     apply Min_leEq_lft.
    apply shift_div_leEq; [ apply pos_two | rstepr (b[+]b) ].
    apply plus_resp_leEq; apply less_leEq; auto.
   apply Min_leEq_rht.
  rewrite -> leEq_def; intro H6.
  cut (y [<=] b). intro H7.
   apply (less_irreflexive_unfolded _ (F y Hy)).
   eapply less_wdr.
    apply H6.
   apply pfwdef; eapply eq_transitive_unfolded.
    apply Min_comm.
   apply leEq_imp_Min_is_lft; auto.
  rewrite -> leEq_def; intro H7.
  apply (less_irreflexive_unfolded _ (F y Hy)).
  eapply less_transitive_unfolded.
   apply H6.
  apply less_wdl with (F b Hb).
   2: apply pfwdef; apply eq_symmetric_unfolded; apply leEq_imp_Min_is_lft; apply less_leEq; auto.
  apply H1; auto.
   apply compact_inc_lft.
  split; [ apply less_leEq | elim H3 ]; auto.
 cut (Dom F (Max b x)); [ intro H5 | apply H; split ].
   3: apply Max_leEq; auto; elim H2; auto.
  2: eapply leEq_transitive; [ apply Hab | apply lft_leEq_Max ].
 apply leEq_less_trans with (F _ H5).
  2: cut (Dom F (Max ((y[+]b) [/]TwoNZ) x)); [ intro Hxy | apply H; split ].
    3: elim H2; intros; eapply leEq_transitive; [ apply a0 | apply rht_leEq_Max ].
   3: apply Max_leEq.
    4: elim H2; auto.
   3: apply shift_div_leEq; [ apply pos_two | rstepr (c[+]c) ].
   3: apply plus_resp_leEq_both; elim H3; auto.
  2: apply leEq_less_trans with (F _ Hxy).
   3: apply H1; try split.
       6: elim H3; auto.
      5: apply less_leEq; auto.
     4: apply Max_leEq.
      5: elim H2; auto.
     4: apply shift_div_leEq; [ apply pos_two | rstepr (c[+]c) ].
     4: apply plus_resp_leEq_both; elim H3; auto.
    3: eapply leEq_transitive.
     4: apply lft_leEq_Max.
    3: apply shift_leEq_div; [ apply pos_two | rstepl (b[+]b) ].
    3: apply plus_resp_leEq; apply less_leEq; auto.
   3: apply Max_less; auto.
   3: apply shift_div_less; [ apply pos_two | rstepr (y[+]y) ].
   3: apply plus_resp_less_lft; auto.
  2: apply part_mon_imp_mon' with (Compact Hbc); auto.
     2: intros x0 H6; apply H; inversion_clear H6; split; auto.
     2: apply leEq_transitive with b; auto.
    3: split.
     4: apply Max_leEq.
      4: apply shift_div_leEq; [ apply pos_two | rstepr (c[+]c) ].
      4: apply plus_resp_leEq_both; auto; elim H3; auto.
     4: elim H2; auto.
    3: eapply leEq_transitive.
     4: apply lft_leEq_Max.
    3: apply shift_leEq_div; [ apply pos_two | rstepl (b[+]b) ].
    3: apply plus_resp_leEq; apply less_leEq; auto.
   2: split.
    3: apply Max_leEq; auto; elim H2; auto.
   2: apply lft_leEq_Max.
  2: apply Max_leEq.
   2: eapply leEq_transitive.
    3: apply lft_leEq_Max.
   2: apply shift_leEq_div; [ apply pos_two | rstepl (b[+]b) ].
   2: apply plus_resp_leEq; apply less_leEq; auto.
  2: apply rht_leEq_Max.
 rewrite -> leEq_def; intro H6.
 cut (b [<=] x); rewrite -> leEq_def; intro H7.
  apply (less_irreflexive_unfolded _ (F x Hx)).
  eapply less_wdl.
   apply H6.
  apply pfwdef; apply leEq_imp_Max_is_rht; rewrite -> leEq_def; auto.
 apply (less_irreflexive_unfolded _ (F x Hx)).
 eapply less_transitive_unfolded.
  2: apply H6.
 apply less_wdr with (F b Hb).
  2: apply pfwdef; apply eq_symmetric_unfolded; eapply eq_transitive_unfolded.
   2: apply Max_comm.
  2: apply leEq_imp_Max_is_rht; apply less_leEq; auto.
 apply H0; auto.
  2: apply compact_inc_rht.
 split; [ elim H2 | apply less_leEq ]; auto.
Qed.

Lemma strict_inc_glues' : forall a b c F, a [<] b -> b [<] c -> included (olor a c) (Dom F) ->
 (forall x y, olcr a b x -> olcr a b y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy) ->
 (forall x y, clor b c x -> clor b c y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy) ->
 forall x y, olor a c x -> olor a c y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy.
Proof.
 intros a b c F Hab Hbc H H0 H1 x y H2 H3 H4 Hx Hy.
 cut (Dom F b); [ intro Hb | apply H; split; auto ].
 elim (less_cotransitive_unfolded _ _ _ H4 b); intro.
  cut (Dom F (Min b y)); [ intro H5 | apply H; split ].
    2: apply less_Min; auto; elim H3; auto.
   2: eapply leEq_less_trans; [ apply Min_leEq_lft | auto ].
  apply less_leEq_trans with (F _ H5).
   cut (Dom F (Min ((x[+]b) [/]TwoNZ) y)); [ intro Hxy | apply H; split ].
     3: elim H3; intros; eapply leEq_less_trans; [ apply Min_leEq_rht | auto ].
    2: apply less_Min.
     3: elim H3; auto.
    2: apply shift_less_div; [ apply pos_two | rstepl (a[+]a) ].
    2: apply plus_resp_less_both; elim H2; auto.
   apply less_leEq_trans with (F _ Hxy).
    apply H0; try split.
        elim H2; auto.
       apply less_leEq; auto.
      apply less_Min.
       2: elim H3; auto.
      apply shift_less_div; [ apply pos_two | rstepl (a[+]a) ].
      apply plus_resp_less_both; elim H2; auto.
     eapply leEq_transitive.
      apply Min_leEq_lft.
     apply shift_div_leEq; [ apply pos_two | rstepr (b[+]b) ].
     apply plus_resp_leEq; apply less_leEq; auto.
    apply less_Min; auto.
    apply shift_less_div; [ apply pos_two | rstepl (x[+]x) ].
    apply plus_resp_leEq_less; [ apply leEq_reflexive | auto ].
   apply part_mon_imp_mon' with (iprop (olcr a b)); auto.
      intros x0 H6; apply H; inversion_clear H6; split; auto.
      apply leEq_less_trans with b; auto.
     split.
      apply less_Min.
       apply shift_less_div; [ apply pos_two | rstepl (a[+]a) ].
       apply plus_resp_less_both; auto; elim H2; auto.
      elim H3; auto.
     eapply leEq_transitive.
      apply Min_leEq_lft.
     apply shift_div_leEq; [ apply pos_two | rstepr (b[+]b) ].
     apply plus_resp_leEq; apply less_leEq; auto.
    split.
     apply less_Min; auto; elim H3; auto.
    apply Min_leEq_lft.
   apply leEq_Min.
    eapply leEq_transitive.
     apply Min_leEq_lft.
    apply shift_div_leEq; [ apply pos_two | rstepr (b[+]b) ].
    apply plus_resp_leEq; apply less_leEq; auto.
   apply Min_leEq_rht.
  rewrite -> leEq_def; intro H6.
  cut (y [<=] b); rewrite -> leEq_def; intro H7.
   apply (less_irreflexive_unfolded _ (F y Hy)).
   eapply less_wdr.
    apply H6.
   apply pfwdef; eapply eq_transitive_unfolded.
    apply Min_comm.
   apply leEq_imp_Min_is_lft; rewrite -> leEq_def; auto.
  apply (less_irreflexive_unfolded _ (F y Hy)).
  eapply less_transitive_unfolded.
   apply H6.
  apply less_wdl with (F b Hb).
   2: apply pfwdef; apply eq_symmetric_unfolded; apply leEq_imp_Min_is_lft; apply less_leEq; auto.
  apply H1; auto.
   split; auto; apply leEq_reflexive.
  split; [ apply less_leEq | elim H3 ]; auto.
 cut (Dom F (Max b x)); [ intro H5 | apply H; split ].
   3: apply Max_less; auto; elim H2; auto.
  2: eapply less_leEq_trans; [ apply Hab | apply lft_leEq_Max ].
 apply leEq_less_trans with (F _ H5).
  2: cut (Dom F (Max ((y[+]b) [/]TwoNZ) x)); [ intro Hxy | apply H; split ].
    3: elim H2; intros; eapply less_leEq_trans; [ apply a0 | apply rht_leEq_Max ].
   3: apply Max_less.
    4: elim H2; auto.
   3: apply shift_div_less; [ apply pos_two | rstepr (c[+]c) ].
   3: apply plus_resp_less_both; elim H3; auto.
  2: apply leEq_less_trans with (F _ Hxy).
   3: apply H1; try split.
       6: elim H3; auto.
      5: apply less_leEq; auto.
     4: apply Max_less.
      5: elim H2; auto.
     4: apply shift_div_less; [ apply pos_two | rstepr (c[+]c) ].
     4: apply plus_resp_less_both; elim H3; auto.
    3: eapply leEq_transitive.
     4: apply lft_leEq_Max.
    3: apply shift_leEq_div; [ apply pos_two | rstepl (b[+]b) ].
    3: apply plus_resp_leEq; apply less_leEq; auto.
   3: apply Max_less; auto.
   3: apply shift_div_less; [ apply pos_two | rstepr (y[+]y) ].
   3: apply plus_resp_less_lft; auto.
  2: apply part_mon_imp_mon' with (iprop (clor b c)); auto.
     2: intros x0 H6; apply H; inversion_clear H6; split; auto.
     2: apply less_leEq_trans with b; auto.
    3: split.
     4: apply Max_less.
      4: apply shift_div_less; [ apply pos_two | rstepr (c[+]c) ].
      4: apply plus_resp_less_both; auto; elim H3; auto.
     4: elim H2; auto.
    3: eapply leEq_transitive.
     4: apply lft_leEq_Max.
    3: apply shift_leEq_div; [ apply pos_two | rstepl (b[+]b) ].
    3: apply plus_resp_leEq; apply less_leEq; auto.
   2: split.
    3: apply Max_less; auto; elim H2; auto.
   2: apply lft_leEq_Max.
  2: apply Max_leEq.
   2: eapply leEq_transitive.
    3: apply lft_leEq_Max.
   2: apply shift_leEq_div; [ apply pos_two | rstepl (b[+]b) ].
   2: apply plus_resp_leEq; apply less_leEq; auto.
  2: apply rht_leEq_Max.
 rewrite -> leEq_def; intro H6.
 cut (b [<=] x); rewrite -> leEq_def; intro H7.
  apply (less_irreflexive_unfolded _ (F x Hx)).
  eapply less_wdl.
   apply H6.
  apply pfwdef; apply leEq_imp_Max_is_rht; rewrite -> leEq_def; auto.
 apply (less_irreflexive_unfolded _ (F x Hx)).
 eapply less_transitive_unfolded.
  2: apply H6.
 apply less_wdr with (F b Hb).
  2: apply pfwdef; apply eq_symmetric_unfolded; eapply eq_transitive_unfolded.
   2: apply Max_comm.
  2: apply leEq_imp_Max_is_rht; apply less_leEq; auto.
 apply H0; auto.
  split; [ elim H2 | apply less_leEq ]; auto.
 split; auto; apply leEq_reflexive.
Qed.

Lemma strict_dec_glues : forall a b c F (Hab : a [<=] b) (Hbc : b [<=] c) (Hac : a [<=] c),
 included (Compact Hac) (Dom F) ->
 (forall x y, Compact Hab x -> Compact Hab y -> y[<]x -> forall Hx Hy, F x Hx [<] F y Hy) ->
 (forall x y, Compact Hbc x -> Compact Hbc y -> y[<]x -> forall Hx Hy, F x Hx [<] F y Hy) ->
 forall x y, Compact Hac x -> Compact Hac y -> y[<]x -> forall Hx Hy, F x Hx [<] F y Hy.
Proof.
 intros.
 apply inv_cancel_less.
 astepl ( {--}F y Hy); astepr ( {--}F x Hx).
 apply strict_inc_glues with a b c Hab Hbc Hac; auto.
  intros; simpl in |- *; apply inv_resp_less; auto.
 intros; simpl in |- *; apply inv_resp_less; auto.
Qed.

Lemma strict_dec_glues' : forall a b c F, a [<] b -> b [<] c -> included (olor a c) (Dom F) ->
 (forall x y, olcr a b x -> olcr a b y -> y[<]x -> forall Hx Hy, F x Hx [<] F y Hy) ->
 (forall x y, clor b c x -> clor b c y -> y[<]x -> forall Hx Hy, F x Hx [<] F y Hy) ->
 forall x y, olor a c x -> olor a c y -> y[<]x -> forall Hx Hy, F x Hx [<] F y Hy.
Proof.
 intros.
 apply inv_cancel_less.
 astepl ( {--}F y Hy); astepr ( {--}F x Hx).
 apply strict_inc_glues' with a b c; auto.
  intros; simpl in |- *; apply inv_resp_less; auto.
 intros; simpl in |- *; apply inv_resp_less; auto.
Qed.

(** More on glueing intervals. *)

Lemma olor_pos_clor_nonneg : forall a b (F : PartIR),
 (forall x, olor a b x -> forall Hx, [0] [<] F x Hx) -> forall Ha,
 [0] [<=] F a Ha -> forall x, clor a b x -> forall Hx, [0] [<=] F x Hx.
Proof.
 intros a b F H Ha H0 x H1 Hx.
 rewrite -> leEq_def; intros H2.
 cut (Not (olor a b x)); intro H3.
  cut (x [=] a). intro H4.
   rewrite -> leEq_def in H0; apply H0.
   eapply less_wdl; [ apply H2 | algebra ].
  red in H3.
  apply not_ap_imp_eq; intro H4.
  inversion_clear H1.
  elim (ap_imp_less _ _ _ H4); intros.
   apply (less_irreflexive_unfolded _ a); apply leEq_less_trans with x; auto.
  apply H3; split; auto.
 apply (less_irreflexive_unfolded IR [0]); apply less_transitive_unfolded with (F x Hx); auto.
Qed.

Lemma olor_pos_olcr_nonneg : forall a b (F : PartIR),
 (forall x, olor a b x -> forall Hx, [0] [<] F x Hx) -> forall Hb,
 [0] [<=] F b Hb -> forall x, olcr a b x -> forall Hx, [0] [<=] F x Hx.
Proof.
 intros a b F H Ha H0 x H1 Hx.
 rewrite -> leEq_def; intros H2.
 cut (Not (olor a b x)); intro H3.
  cut (x [=] b). intro H4.
   rewrite -> leEq_def in H0; apply H0.
   eapply less_wdl; [ apply H2 | algebra ].
  red in H3.
  apply not_ap_imp_eq; intro H4.
  inversion_clear H1.
  elim (ap_imp_less _ _ _ H4); intros.
   apply H3; split; auto.
  apply (less_irreflexive_unfolded _ b); apply less_leEq_trans with x; auto.
 apply (less_irreflexive_unfolded IR [0]); apply less_transitive_unfolded with (F x Hx); auto.
Qed.

Lemma olor_pos_clcr_nonneg : forall a b (F : PartIR), a [<] b ->
 (forall x, olor a b x -> forall Hx, [0] [<] F x Hx) -> forall Ha, [0] [<=] F a Ha -> forall Hb, [0] [<=] F b Hb ->
 forall x, clcr a b x -> forall Hx, [0] [<=] F x Hx.
Proof.
 intros a b F Hab H Ha H0 Hb H1 x H2 Hx.
 rewrite -> leEq_def; intros H3.
 cut (Not (olor a b x)); intro H4.
  elim (less_cotransitive_unfolded _ _ _ Hab x); intro H5.
   cut (x [=] b). intro H6.
    rewrite -> leEq_def in H1; apply H1.
    eapply less_wdl; [ apply H3 | algebra ].
   red in H4.
   apply not_ap_imp_eq; intro H6.
   inversion_clear H2.
   elim (ap_imp_less _ _ _ H6); intros.
    apply H4; split; auto.
   apply (less_irreflexive_unfolded _ b); apply less_leEq_trans with x; auto.
  cut (x [=] a); intros.
   rewrite -> leEq_def in H0; apply H0.
   eapply less_wdl; [ apply H3 | algebra ].
  red in H4.
  apply not_ap_imp_eq; intro.
  inversion_clear H2.
  elim (ap_imp_less _ _ _ X); intros.
   apply (less_irreflexive_unfolded _ a); apply leEq_less_trans with x; auto.
  apply H4; split; auto.
 apply (less_irreflexive_unfolded IR [0]); apply less_transitive_unfolded with (F x Hx); auto.
Qed.

(**
Any function that has the null function as its derivative must be constant.
*)

Lemma FConst_prop : forall J pJ F', Derivative J pJ F' [-C-][0] -> {c : IR | Feq J F' [-C-]c}.
Proof.
 intros J pJ F' H.
 elim (nonvoid_point _ (proper_nonvoid _ pJ)); intros x0 Hx0.
 exists (F' x0 (Derivative_imp_inc _ _ _ _ H x0 Hx0)).
 FEQ. rename X into H0.
 simpl in |- *.
 apply cg_inv_unique_2.
 apply AbsIR_approach_zero; intros e H1.
 simpl in Hx'.
 elim (Law_of_the_Mean _ _ _ _ H _ _ Hx0 H0 e H1).
 intros y H2 H3.
 eapply leEq_wdl.
  apply (H3 (Derivative_imp_inc _ _ _ _ H _ Hx0) Hx I).
 apply AbsIR_wd; simpl in |- *; rational.
Qed.

(** As a corollary, two functions with the same derivative must differ
by a constant.
*)

Lemma Feq_crit_with_const : forall J pJ F G H,
 Derivative J pJ F H -> Derivative J pJ G H -> {c : IR | Feq J (F{-}G) [-C-]c}.
Proof.
 intros.
 apply FConst_prop with pJ.
 Derivative_Help; FEQ.
Qed.

(** This yields the following known result: any differential equation
of the form [f'=g] with initial condition [f(a) [=] b] has a unique solution.
*)

Lemma Feq_criterium : forall J pJ F G H, Derivative J pJ F H -> Derivative J pJ G H ->
 forall x, J x -> (forall Hx Hx', F x Hx [=] G x Hx') -> Feq J F G.
Proof.
 do 5 intro. intros H0 H1 x H2 H3.
 elim (Feq_crit_with_const _ _ _ _ _ H0 H1); intros c Hc.
 apply Feq_transitive with (F{-}G{+}G).
  FEQ.
 apply Feq_transitive with ( [-C-][0]{+}G).
  2: FEQ.
 apply Feq_plus.
  2: apply Feq_reflexive; Included.
 apply Feq_transitive with ( [-C-]c).
  auto.
 FEQ. rename X into H4.
 simpl in |- *.
 elim Hc; intros H5 H6.
 elim H6; clear H6; intros H7 H6.
 clear Hc H5 H7 Hx' Hx.
 simpl in H6.
 cut (Conj (Dom F) (Dom G) x). intro H5.
  apply eq_symmetric_unfolded; eapply eq_transitive_unfolded.
   2: apply H6 with (Hx := H5); auto.
  apply eq_symmetric_unfolded; apply x_minus_x; auto.
 split.
  exact (Derivative_imp_inc _ _ _ _ H0 _ H2).
 exact (Derivative_imp_inc _ _ _ _ H1 _ H2).
Qed.

(**
Finally, a well known result: any function with a (strictly) positive
derivative is (strictly) increasing.  Although the two lemmas look
quite similar the proofs are completely different, both from the
formalization and from the mathematical point of view.
*)

Lemma Derivative_imp_resp_less : forall J pJ a b F F', Derivative J pJ F F' ->
 a [<] b -> J a -> J b -> (forall contF', [0] [<] glb_funct _ _ (Min_leEq_Max a b) F' contF') ->
 forall Ha Hb, F a Ha [<] F b Hb.
Proof.
 intros J pJ a b F F' derF Hab HaJ HbJ Hglb Ha Hb.
 apply shift_zero_less_minus'.
 cut (Continuous_I (Min_leEq_Max a b) F'). intro H.
  2: apply included_imp_Continuous with J;
    [ apply Derivative_imp_Continuous' with pJ F | apply included_interval ]; auto.
 elim (glb_is_glb _ _ _ _ H).
 simpl in |- *; intros Hglb1 Hglb2.
 cut ([0] [<] glb_funct _ _ _ _ H); [ intro H0 | auto ].
 elim (Law_of_the_Mean _ _ _ _ derF a b) with (e := (glb_funct _ _ _ _ H[*] (b[-]a)) [/]TwoNZ); auto.
  intros x H1 H2.
  apply less_leEq_trans with (F' x (contin_imp_inc _ _ _ _ H x H1) [*] (b[-]a) [-]
    (glb_funct _ _ _ _ H[*] (b[-]a)) [/]TwoNZ).
   rstepr ((F' x (contin_imp_inc _ _ _ _ H x H1) [-]glb_funct _ _ _ _ H [/]TwoNZ) [*] (b[-]a)).
   apply mult_resp_pos.
    apply shift_less_minus; astepl (glb_funct _ _ _ _ H [/]TwoNZ).
    eapply less_leEq_trans.
     apply pos_div_two'; auto.
    apply glb_prop.
    auto.
   apply shift_less_minus; astepl a; auto.
  apply shift_minus_leEq; apply shift_leEq_plus'.
  rstepl ( [--] (Part _ _ Hb[-]Part _ _ Ha[-] Part _ _ (contin_imp_inc _ _ _ _ H _ H1) [*] (b[-]a))).
  eapply leEq_transitive.
   apply inv_leEq_AbsIR.
  apply H2.
 apply pos_div_two; apply mult_resp_pos; auto.
 apply shift_less_minus; astepl a; auto.
Qed.

Lemma Derivative_imp_resp_leEq : forall J pJ a b F F', Derivative J pJ F F' ->
 a [<=] b -> J a -> J b -> (forall contF', [0] [<=] glb_funct _ _ (Min_leEq_Max b a) F' contF') ->
 forall Ha Hb, F a Ha [<=] F b Hb.
Proof.
 intros J pJ a b F F' derF Hab HaJ HbJ Hglb Ha Hb.
 astepr ([0][+]Part _ _ Hb); apply shift_leEq_plus.
 cut (Continuous_I (Min_leEq_Max b a) F'). intro H.
  2: apply included_imp_Continuous with J;
    [ apply Derivative_imp_Continuous' with pJ F | apply included_interval ]; auto.
 elim (glb_is_glb _ _ _ _ H).
 simpl in |- *; intros Hglb1 Hglb2.
 cut ([0] [<=] glb_funct _ _ _ _ H); [ intro H0 | auto ].
 apply approach_zero_weak.
 intros.
 elim (Law_of_the_Mean _ _ _ _ derF b a) with (e := e); auto.
 intros x H2 H3.
 eapply leEq_transitive.
  2: apply (H3 Hb Ha (contin_imp_inc _ _ _ _ H x H2)).
 eapply leEq_transitive.
  2: apply leEq_AbsIR.
 rstepl (Part _ _ Ha[-]Part _ _ Hb[-][--][0]).
 unfold cg_minus at 1 3 in |- *; apply plus_resp_leEq_lft.
 apply inv_resp_leEq.
 rstepl ( [--] (Part _ _ (contin_imp_inc _ _ _ _ H _ H2) [*] (b[-]a))).
 apply inv_resp_leEq.
 apply mult_resp_nonneg.
  eapply leEq_transitive; [ apply H0 | apply Hglb1 ].
  exists x.
  split. auto.
   split; algebra.
  apply (contin_imp_inc _ _ _ _ H); auto.
 apply shift_leEq_minus; astepl a; auto.
Qed.

Lemma Derivative_imp_resp_less' : forall J pJ a b F F', Derivative J pJ F F' ->
 a [<] b -> J a -> J b -> (forall contF', [0] [<=] glb_funct _ _ (Min_leEq_Max b a) F' contF') ->
 forall Ha Hb, F a Ha [#] F b Hb -> F a Ha [<] F b Hb.
Proof.
 intros J pJ a b F F' H H0 H1 H2 H3 Ha Hb H4.
 elim (ap_imp_less _ _ _ H4); intro; auto.
 exfalso.
 apply less_irreflexive_unfolded with (x := F a Ha).
 apply leEq_less_trans with (F b Hb); auto.
 apply Derivative_imp_resp_leEq with J pJ F'; auto.
 apply less_leEq; auto.
Qed.

(** From these results we can finally prove that exponentiation to a
real power preserves the less or equal than relation!
*)

Lemma nexp_resp_leEq_odd : forall n, odd n -> forall x y : IR, x [<=] y -> x[^]n [<=] y[^]n.
Proof.
 intro; case n.
  intros; exfalso; inversion H.
 clear n; intros.
 astepl (Part (FId{^}S n) x I).
 astepr (Part (FId{^}S n) y I).
 apply Derivative_imp_resp_leEq with realline I (nring (R:=IR) (S n) {**}FId{^}n).
     Opaque nring.
     Derivative_Help.
     FEQ.
    Transparent nring.
    auto.
   split.
  split.
 intros.
 apply leEq_glb; intros.
 simpl in |- *.
 apply mult_resp_nonneg.
  apply less_leEq; eapply leEq_less_trans.
   2: apply less_plusOne.
  apply nring_nonneg.
 astepr (y0[^]n); apply nexp_even_nonneg.
 inversion H; auto.
Qed.

End Various_Theorems.


(* -*- mode: coq; mode: visual-line -*- *)

(** * The Freudenthal Suspension Theorem, and related results. (INCOMPLETE) *)

Require Import HoTT.Basics HoTT.Types.
Require Import HProp EquivalenceVarieties.
Require Import HIT.Connectedness HIT.Suspension HIT.Truncations.
Import TrM.
Local Open Scope trunc_scope.
Local Open Scope path_scope.

Generalizable Variables X A B f g n.

(** [proof_admitted] is used to implement the admit tactic, as in Coq 8.5 beta 1. *)
Local Axiom proof_admitted : False.
Local Ltac admit := case proof_admitted.

(* ** Connectedness of the suspension *)

Global Instance isconn_susp {n : trunc_index} {X : Type} `{H : IsConnected n X}
  : IsConnected n.+1 (Susp X).
Proof.
  apply isconnected_from_elim.
  intros C H' f. exists (f North).
  assert ({ p0 : f North = f South & forall x:X, ap f (merid x) = p0 })
    as [p0 allpath_p0] by (apply (isconnected_elim n); apply H').
  apply (Susp_ind (fun a => f a = f North) 1 p0^).
  intros x.
  apply (concat (transport_paths_Fl _ _)).
  apply (concat (concat_p1 _)).
  apply ap, allpath_p0.
Defined.

(** ** The Freudenthal Suspension Theorem *)
Section Freudenthal.

(** We assume funext and univalence.  In fact, since we will use funext at two different levels and local assumptions are monomorphic, we need to assume funext twice; we give the second assumption of it a name (so we can use it explicitly when we want it), and a different type (so it doesn’t get used when we don’t want it). TODO: perhaps this could be handled in a more uniform way?? *)
Context `{Funext} (funext_large : Funext * Unit) `{Univalence}
        {n : trunc_index} {Hn : ~ n = -2}
        (X : Type) (x0:X) `{IsConnMap n _ _ (unit_name x0)}.

(* TODO: eventually, change these to the weaker assumptions:
Context {n : trunc_index} (X : Type) `{IsConnected n.+1 X}.
*)

(** For convenience, we add some local abbreviations. *)
Notation No := (@North X).
Notation So := (@South X).
Notation mer := (@merid X).
Definition mer' := (fun x => mer x @ (mer x0)^).

(** The eventual theorem we want is: *)
Global Instance Freudenthal
  : IsConnMap (n +2+ n) (mer').
Proof.
  intros p. unfold IsConnected.
(** We are not ready to prove this yet.  For the remainder of the section, we will generalize this goal a bit, and prove some auxiliary lemmas; then we will return to the theorem. *)
Abort.

(** The goal we require for the FST is: *)
Definition FST_Codes_No (p : No = No)
  := (Trunc (n +2+ n) (hfiber mer' p)).

(** To prove it, we generalise it over [Susp X], by [Susp_ind].  This requires three components, which we construct (the main parts of) as lemmas in advance. *)
Definition FST_Codes_So (q : No = So)
  := (Trunc (n +2+ n) (hfiber mer q)).

(* TODO: move! *)
Definition hfiber_pair {A B} {f: A -> B} {b} (a:A) (p:f a = b) : hfiber f b
  := (a;p).

Definition FST_Codes_cross (x1 : X) (q : No = So)
  : FST_Codes_No (q @ (mer x1) ^) -> FST_Codes_So q.
Proof.
  unfold FST_Codes_No, FST_Codes_So, mer'.
  apply Trunc_rec.
  intros [x2 p]. revert x1 x2 p.
  refine (@wedge_incl_elim_uncurried _ n n X x0 _ X x0 _
    (fun x1 x2 => (mer x2 @ (mer x0) ^ = q @ (mer x1) ^)
                    -> Trunc (n +2+ n) (hfiber mer q)) _ _).
  refine (pr1 (@isconnected_elim n.+1 X _ _ _ _)).
  { apply @trunc_sigma; try typeclasses eauto.
    { apply @trunc_forall; try typeclasses eauto; intro.
      apply @trunc_arrow; try typeclasses eauto; intro.
      intros.
      admit. }
    admit. }
  refine (pr1 (@isconnected_elim n.+1 X _ _ _ _)).
  { apply @trunc_arrow; try typeclasses eauto; intros.
    admit. }
  { exists (fun b s => tr (hfiber_pair b (cancelR _ _ _ s))).
    exists (fun a r => tr (hfiber_pair a
                                                    (cancelR _ _ _ ((concat_pV _) @ (concat_pV _)^ @ r)))).
    apply path_forall; intros s. apply ap, ap, ap.
    exact ((concat_1p _)^ @ whiskerR (concat_pV _)^ _). }
Defined.

(** We will need to show that [FST_Codes_cross] is an equivalence, for each [x1, q]. By connectedness of [X], it will be enough to show this for the case [x1 = x0]; to show this, we first write that case in a tidier form. *)
Definition FST_Codes_cross_x0 (q : No = So)
  : FST_Codes_No (q @ (mer x0)^) -> FST_Codes_So q.
Proof.
  unfold FST_Codes_No, FST_Codes_So.
  apply Trunc_functor, (functor_sigma idmap).
  unfold mer'; intros x1. apply cancelR.
Defined.

Definition isequiv_FST_Codes_cross (x : X) (q : No = So)
  : IsEquiv (FST_Codes_cross x q).
Proof.
  revert x.
  apply (@conn_map_elim _ _ _ (unit_name x0) _
    (fun x => IsEquiv (FST_Codes_cross x q))).
  - intros x; generalize dependent n. intros [ | n'] imposs.
    + destruct (imposs 1).
    + intros ?. apply (@trunc_leq -1);[exact tt | apply hprop_isequiv].
  - intros []. unfold FST_Codes_cross.
    refine (isequiv_homotopic (FST_Codes_cross_x0 q) _).
    { unfold FST_Codes_cross_x0.
      apply isequiv_Trunc_functor, @isequiv_functor_sigma.
      - exact _.
      - intros a. apply isequiv_cancelR. }
    { hnf. apply Trunc_ind.
      - intros ?; apply trunc_succ.
      - intros [x r]; simpl.
        unfold functor_sigma; simpl.
        symmetry.
        exact (ap10 (wedge_incl_comp1 x0 x0 _ _ _ _ x) r). }
Defined.

Definition FST_Codes
  : forall (y : Susp X), (No = y) -> Type.
Proof.
  apply (Susp_ind (fun y => (No = y -> Type)) FST_Codes_No FST_Codes_So).
  intros x. apply (@path_forall (fst funext_large)); intros p.
  refine (transport_arrow _ _ _ @ _).
  refine (transport_const _ _ @ _).
  transitivity (FST_Codes_No (p @ (mer x)^)).
  { apply ap, transport_paths_r. }
  apply path_universe_uncurried.
  exists (FST_Codes_cross x p).
  apply isequiv_FST_Codes_cross.
Defined.

(** It now remains to show that each [FST_Codes y p] is contractible. It is easy to provide a canonical inhabitant, by transport. (More directly, we could use path-induction, but we will later need to use transport lemmas to reason about this.) *)
Definition FST_Codes_center (y : Susp X) (p : No = y)
  : FST_Codes y p.
Proof.
  assert (goal' : FST_Codes y (transport _ p 1)).
  - apply transportD. simpl; unfold FST_Codes_No.
    apply tr. exists x0; unfold mer'. apply concat_pV.
  - refine (transport _ _ goal'). refine (transport_paths_r _ _ @ _).
    apply concat_1p.
Defined.

(** TODO: move the following few lemmas. *)
Lemma transport_as_ap {A} (P : A -> Type) {x y} (p : x = y)
  : transport P p == transport idmap (ap P p).
Proof.
  intros ?; destruct p; exact 1.
Defined.

Lemma transportD'
  {A : Type} (B : A -> Type) (C : forall a : A, B a -> Type)
  {x1 x2 : A} (p : x1 = x2) (y : B x1)
: C x1 y -> C x2 (transport B p y).
Proof.
  refine (transport idmap _).
  refine (_ @ ap10 (apD C p) _).
  apply inverse.
  refine (transport_arrow _ _ _ @ _).
  refine (transport_const _ _ @ _).
  apply ap, transport_Vp.
Defined.

Arguments transportD' / [_] _ _ [_ _] _ _ _.

Lemma transportD_as_apD
  {A : Type} (B : A -> Type) (C : forall a : A, B a -> Type)
  {x1 x2 : A} (p : x1 = x2) (y : B x1)
: transportD B C p y == transportD' B C p y.
Proof.
  intros ?; destruct p; simpl. exact 1.
Defined.

(** A transport lemma. *)
Definition FST_Codes_transportD_concrete (x1 : X) (p : No = No)
  : FST_Codes No p -> FST_Codes So (transport (paths No) (mer x1) p).
Proof.
  intro rr. assert (goal' : FST_Codes So (p @ mer x1)).
  - apply (FST_Codes_cross x1).
    refine (transport FST_Codes_No _ rr). symmetry; apply concat_pp_V.
  - refine (transport FST_Codes_So _ goal').
    apply inverse, transport_paths_r.
Defined.

Definition FST_Codes_transportD (x1 : X) (p : No = No) (rr : FST_Codes No p)
  : transportD (paths No) FST_Codes (mer x1) p rr
  = FST_Codes_transportD_concrete x1 p rr.
Proof.
  refine (transportD_as_apD _ _ _ _ _ @ _).
  unfold transportD'.
  unfold FST_Codes. rewrite (Susp_ind_beta_merid _ _ _ _ x1); simpl.
    rewrite (@ap10_path_forall (fst funext_large)).
  unfold FST_Codes_transportD_concrete.
  rewrite ! transport_pp.
  refine (transport_path_universe _ _ @ _).
(*rewrite transport_paths_r.
  rewrite transport_as_ap.*)
Admitted.

(** Showing it is contractible, we will again need the universal property of the suspension. We will prove the components as separate lemmas first; to see the required types of these, we temporarily set up the theorem. *)
Definition FST_Codes_contr (y : Susp X) (p : No = y) (rr : FST_Codes y p)
  : rr = FST_Codes_center y p.
Proof.
  revert y p rr.
  Check (Susp_ind (fun y => forall p rr, rr = FST_Codes_center y p)).
Abort.

Definition FST_Codes_contr_No (p : No = No) (rr : FST_Codes No p)
  : (rr = FST_Codes_center No p).
Proof.
  revert rr. apply Trunc_ind.
  - intros ?; apply trunc_succ.
  - intros [x1 r]. destruct r. unfold FST_Codes_center. simpl.
  (*transitivity (tr
    (transport (fun p => hfiber mer' p) (transport_paths_r p 1 @ concat_1p p)
    (transportD (paths No))))
simpl in *.*)
Admitted.

Global Instance Freudenthal
  : IsConnMap (n +2+ n) (@merid X).
Proof.
  intros p; apply isconnected_from_elim; intros C ? f.
Admitted.

End Freudenthal.


Goal forall P Q, P <-> Q -> P -> Q.
Proof.
  intros P Q H. Fail rewrite H.
Abort.

Require Import List.

Goal forall P Q, P <-> Q -> P -> Q.
Proof.
  intros P Q H. rewrite H. easy.
Qed.


Require Export Coq.MSets.MSetInterface.
Require Import Coq.MSets.MSetProperties
        Coq.MSets.MSetFacts
        Coq.MSets.MSetDecide.
Require Import Fiat.Common.Instances.
Require Import Fiat.Common.BoolFacts.
Require Import Fiat.Common.

Module MSetExtensionsOn (E: DecidableType) (Import M: WSetsOn E).
  Module Export BasicFacts := WFactsOn E M.
  Module Export BasicProperties := WPropertiesOn E M.
  Module Export BasicDec := WDecideOn E M.

  Definition of_list (ls : list E.t) : t
    := List.fold_right
         add
         empty
         ls.

  Global Instance Equal_Equivalence : Equivalence Equal := _.

  Global Instance equal_Equivalence : Equivalence equal.
  Proof.
    setoid_rewrite <- equal_iff; exact _.
  Qed.

  Tactic Notation "setoid_rewrite_in_all" open_constr(lem) :=
    idtac;
    match goal with
    | _ => rewrite !lem
    | [ H : _ |- _ ] => rewrite !lem in H
    | _ => setoid_rewrite lem
    | [ H : _ |- _ ] => setoid_rewrite lem in H
    end.

  Tactic Notation "setoid_rewrite_in_all" "<-" open_constr(lem) :=
    idtac;
    match goal with
    | _ => rewrite <- !lem
    | [ H : _ |- _ ] => rewrite <- !lem in H
    | _ => setoid_rewrite <- lem
    | [ H : _ |- _ ] => setoid_rewrite <- lem in H
    end.

  Ltac eq_bools_to_is_trues :=
    idtac;
    let x := match goal with |- ?x = ?y :> bool => x end in
    let y := match goal with |- x = ?y :> bool => y end in
    let Hx := fresh in
    let Hy := fresh in
    destruct x eqn:Hx;
    [ symmetry
    | destruct y eqn:Hy;
      [ rewrite <- Hx; clear Hx
      | reflexivity ] ];
    fold_is_true.

  Ltac eq_bools_to_is_trues_in H :=
    idtac;
    let x := match type of H with ?x = ?y :> bool => x end in
    let y := match type of H with x = ?y :> bool => y end in
    let Hx := fresh in
    let Hy := fresh in
    destruct x eqn:Hx;
    [ symmetry
    | destruct y eqn:Hy;
      [ rewrite <- Hx; clear Hx
      | reflexivity ] ];
    fold_is_true.
  Ltac eq_bools_to_is_trues_in_all :=
    idtac;
    match goal with
    | [ H : _ = _ :> bool |- _ ]
      => eq_bools_to_is_trues_in H
    end.

  Ltac to_caps_step :=
    first [ setoid_rewrite_in_all subset_spec
          | setoid_rewrite_in_all equal_spec
          | setoid_rewrite_in_all <- not_true_iff_false
          | setoid_rewrite_in_all negb_true_iff
          | setoid_rewrite_in_all mem_spec
          | progress fold_is_true
          | progress eq_bools_to_is_trues
          | progress eq_bools_to_is_trues_in_all ].
  Ltac to_caps := repeat to_caps_step.

  Create HintDb sets discriminated.
  Create HintDb setsb discriminated.
  Global Hint Immediate union_subset_1 union_subset_2 inter_subset_1 inter_subset_2 equal_refl : sets.
  Global Hint Resolve (BasicFacts.inter_s_m : forall x y _ x' y' _, _) : sets.

  Ltac simplify_sets_step :=
    idtac;
    match goal with
    | [ H : ?x [<=] ?y, H' : ?y [<=] ?x |- _ ]
      => pose proof (subset_antisym H H');
         clear H H'
    | [ H : context[subset ?x ?y] |- _ ]
      => match type of H with
         | context[subset y x] => fail 1
         | _ => idtac
         end;
         progress replace (equal y x) with (equal x y)
           in H by auto with sets
    | [ |- context[subset ?x ?y] ]
      => match goal with
         | [ |- context[subset y x] ] => fail 1
         | _ => idtac
         end;
         progress replace (equal y x) with (equal x y)
           by auto with sets
    | _ => setoid_subst_rel Equal
    end.

  Ltac simplify_sets := repeat simplify_sets_step.

  Ltac push_In_step :=
    first [ progress unfold Equal in *
          | setoid_rewrite_in_all union_spec
          | setoid_rewrite_in_all inter_spec
          | setoid_rewrite_in_all filter_spec; [ | let H := fresh in intros ?? H; hnf in H; substs; reflexivity.. ] ].

  Ltac push_In := repeat push_In_step.

  Lemma equal_refl_b x : equal x x.
  Proof. to_caps; auto with sets. Qed.

  Lemma equal_sym_b x y : equal x y = equal y x.
  Proof. to_caps; fsetdec. Qed.

  Hint Immediate equal_sym_b : sets.

  Lemma union_subset_1b
    : forall s s', subset s (union s s').
  Proof. to_caps; auto with sets. Qed.

  Lemma union_subset_2b
    : forall s s', subset s' (union s s').
  Proof. to_caps; auto with sets. Qed.

  Lemma inter_subset_1b
    : forall s s', subset (inter s s') s.
  Proof. to_caps; auto with sets. Qed.

  Lemma inter_subset_2b
    : forall s s', subset (inter s s') s'.
  Proof. to_caps; auto with sets. Qed.

  Hint Rewrite union_subset_1b union_subset_2b inter_subset_1b inter_subset_2b equal_refl_b : setsb.

  Lemma union_idempotent x : Equal (union x x) x.
  Proof. fsetdec. Qed.

  Lemma inter_idempotent x : Equal (inter x x) x.
  Proof. fsetdec. Qed.

  Hint Immediate union_idempotent inter_idempotent : sets.

  Lemma union_idempotent_b x : equal (union x x) x.
  Proof. to_caps; auto with sets. Qed.

  Lemma inter_idempotent_b x : equal (inter x x) x.
  Proof. to_caps; auto with sets. Qed.

  Hint Rewrite union_idempotent_b inter_idempotent_b : sets.

  Global Instance Subset_Proper_Equal_iff
    : Proper (Equal ==> Equal ==> iff) Subset.
  Proof. repeat intro; split; fsetdec. Qed.
  Global Instance Subset_Proper_Equal : Proper (Equal ==> Equal ==> impl) Subset | 1.
  Proof. repeat intro; fsetdec. Qed.
  Global Instance Subset_Proper_Equal_flip : Proper (Equal ==> Equal ==> flip impl) Subset | 1.
  Proof. repeat intro; fsetdec. Qed.

  Global Instance subset_Proper_equal
    : Proper (equal ==> equal ==> Logic.eq) subset.
  Proof. repeat intro; to_caps; fsetdec. Qed.

  Lemma equal_or_subset_and_not_equal_subset_b {x y}
    : (equal x y || (subset x y && negb (equal x y))) = subset x y.
  Proof. to_caps; bool_congr_setoid; to_caps; intuition; try fsetdec. Qed.

  Lemma equal_or_subset_and_not_equal_subset {x y}
    : (Equal x y \/ (Subset x y /\ ~Equal x y)) <-> Subset x y.
  Proof.
    destruct (equal x y) eqn:?; simpl; bool_congr; to_caps; simplify_sets;
      intuition.
  Qed.

  Hint Rewrite @equal_or_subset_and_not_equal_subset : sets.
  Hint Rewrite @equal_or_subset_and_not_equal_subset_b : setsb.

  Ltac handle_known_comparisons_step :=
    idtac;
    lazymatch goal with
    | [ |- context[subset (inter ?x ?y) ?x] ]
      => replace (subset (inter x y) x) with true by (symmetry; apply inter_subset_1b)
    | [ |- context[subset (inter ?x ?y) ?y] ]
      => replace (subset (inter x y) y) with true by (symmetry; apply inter_subset_2b)
    | [ |- context[subset ?x (union ?x ?y)] ]
      => replace (subset x (union x y)) with true by (symmetry; apply union_subset_1b)
    | [ |- context[subset ?y (union ?x ?y)] ]
      => replace (subset y (union x y)) with true by (symmetry; apply union_subset_2b)
    | [ |- context[equal (?f ?x ?y) ?x] ]
      => replace (equal (f x y) x) with (equal x (f x y)) by apply equal_sym_b
    | [ |- context[equal (?f ?x ?y) ?y] ]
      => replace (equal (f x y) y) with (equal y (f x y)) by apply equal_sym_b
    end.

  Ltac handle_known_comparisons := repeat handle_known_comparisons_step.

  Ltac cardinal_to_list_step :=
    idtac;
    match goal with
    | [ H : cardinal _ = _ |- _ ]
      => rewrite cardinal_spec in H
    | [ H : List.length ?ls = S _ |- _ ]
      => destruct ls eqn:?; simpl in H; inversion H; clear H
    | [ H : List.length ?ls = 0 |- _ ]
      => destruct ls eqn:?; simpl in H; inversion H; clear H
    | [ H : ?ls = nil |- _ ] => is_var ls; subst ls
    | [ H : ?ls = (_::_) |- _ ] => is_var ls; subst ls
    end.
  Ltac cardinal_to_list := repeat cardinal_to_list_step.
  Ltac in_to_elements :=
    repeat setoid_rewrite_in_all BasicFacts.elements_iff;
    repeat match goal with
           | [ H : elements ?v = _ |- _ ]
             => rewrite !H
           | [ H : elements ?v = _, H' : appcontext[elements ?v] |- _ ]
             => rewrite !H in H'
           end.
  Ltac InA_concretize_step :=
    idtac;
    match goal with
    | _ => progress substs
    | [ H : SetoidList.InA _ _ nil |- _ ] => solve [ inversion H ]
    | [ H : SetoidList.InA _ _ (_::_) |- _ ] => inversion H; clear H
    | [ |- ~SetoidList.InA _ _ _ ] => intro
    end.
  Ltac InA_concretitze := repeat InA_concretize_step.

  Lemma cardinal_one_In_same v
        (H : cardinal v = 1)
    : forall x y, In x v -> In y v -> E.eq x y.
  Proof.
    cardinal_to_list.
    intros; in_to_elements; InA_concretitze.
    fsetdec.
  Qed.
End MSetExtensionsOn.

Module MSetExtensions (M: Sets) := MSetExtensionsOn M.E M.


From discprob.basic Require Import base order.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.monad Require Import monad monad_cost quicksort monad_cost_hoare.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
From mathcomp Require Import path.
Require Import Coq.omega.Omega Coq.Program.Wf.

(* Shocked this is not in the ssreflect library? *)
Lemma perm_eq_cat {A: eqType} (l1a l1b l2a l2b: seq A) :
  perm_eq l1a l2a →
  perm_eq l1b l2b →
  perm_eq (l1a ++ l1b) (l2a ++ l2b).
Proof.
  move /perm_eqP => Hpa.
  move /perm_eqP => Hpb.
  apply /perm_eqP.
  intros x. rewrite ?count_cat. rewrite (Hpa x) (Hpb x). done.
Qed.

Lemma sorted_cat {A: eqType} (l1 l2: seq A) (R: rel A):
  sorted R l1 → sorted R l2 →
  (∀ n1 n2, n1 \in l1 → n2 \in l2 → R n1 n2) →
  sorted R (l1 ++ l2).
Proof.
  revert l2. induction l1 => //=.
  intros l2 HP Hsorted Hle.
  rewrite cat_path. apply /andP; split; auto.
  induction l2 => //=. apply /andP; split; auto.
  apply Hle.
  - apply mem_last.
  - rewrite in_cons eq_refl //.
Qed.

Lemma quicksort_correct (l: list nat): mspec (qs l) (λ l', (sorted leq l' && perm_eq l l'):Prop).
Proof.
  remember (size l) as k eqn:Heq.
  revert l Heq.
  induction k as [k IH] using (well_founded_induction lt_wf) => l Heq.
  destruct l as [| a l].
  - rewrite //= => b. rewrite mem_seq1. move /eqP => -> //=.
  - destruct l as [| b0 l0].
    { rewrite //= => b. rewrite mem_seq1. move /eqP => -> //=. }
    rewrite qs_unfold.
    remember (b0 :: l0) as l eqn:Hl0. clear l0 Hl0.
    tbind (λ x, sval x \in a :: l).
    { intros (?&?) => //. }
    intros (pv&Hin) _.
    tbind (λ x, lower (sval x) = [ seq n <- (a :: l) | ltn n pv] ∧
                middle (sval x) = [ seq n <- (a :: l) | n == pv] ∧
                upper (sval x) = [ seq n <- (a :: l) | ltn pv n]).
    { remember (a :: l) as l0 eqn:Heql0.
      apply mspec_mret => //=. clear. induction l0 as [|a l]; first by rewrite //=.
      rewrite //=; case (ltngtP a pv) => //= ?;
      destruct (IHl) as (?&?&?); repeat split; auto; f_equal; done.
    }
    remember (a :: l) as l0 eqn:Heql0.
    intros (spl&Hin'). rewrite //=. intros (Hl&Hm&Hu).
    tbind (λ x, sorted leq x && perm_eq (lower spl) x).
    { rewrite //=.
      (* TODO: should probably just have an induction principle justifying this,
         we already had to prove that the list was smaller to justify that the defn
         was terminating *)
        eapply (IH (size (lower spl))); auto.
        rewrite Heq.
        move /andP in Hin'.
        destruct Hin' as (pf1&pf2); move /implyP in pf2.
        rewrite -(perm_eq_size pf1) //= ?size_cat -?plusE //;
          assert (Hlt: (lt O (size (middle spl)))) by
            ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=).
        rewrite //= in Hlt. omega.
    }
    intros ll. move /andP => [Hllsorted Hllperm].
    tbind (λ x, sorted leq x && perm_eq (upper spl) x).
    { rewrite //=.
        eapply (IH (size (upper spl))); auto.
        rewrite Heq.
        move /andP in Hin'.
        destruct Hin' as (pf1&pf2); move /implyP in pf2.
        rewrite -(perm_eq_size pf1) //= ?size_cat -?plusE //;
          assert (Hlt: (lt O (size (middle spl)))) by
            ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=).
        rewrite //= in Hlt. omega.
    }
    intros lu. move /andP => [Hlusorted Hluperm].
    apply mspec_mret => //=. apply /andP; split.
    * apply sorted_cat; [| apply sorted_cat |]; auto.
      ** rewrite Hm. clear. induction l0 => //=.
         case: ifP; auto.
         move /eqP => ->. rewrite //=.
         clear IHl0.
         induction l0 => //=.
         case: ifP; auto. move /eqP => -> //=. rewrite leqnn IHl0 //.
      ** rewrite Hm => a' b'; rewrite mem_filter.
         move /andP => [Heqpv Hin1 Hin2]. move /eqP in Heqpv.
         move: Hin2.
         rewrite -(perm_eq_mem Hluperm) Hu mem_filter.
         move /andP => [Hgtpv ?]. move /ltP in Hgtpv.
         rewrite Heqpv. apply /leP. omega.
      ** intros a' b'. rewrite -(perm_eq_mem Hllperm) Hl mem_filter.
         move /andP => [Hgtpv ?]. move /ltP in Hgtpv.
         rewrite mem_cat. move /orP => [].
         *** rewrite Hm; rewrite mem_filter.
             move /andP => [Heqpv ?]. move /eqP in Heqpv.
             rewrite Heqpv. apply /leP. omega.
         *** rewrite -(perm_eq_mem Hluperm) Hu mem_filter.
             move /andP => [Hltpv ?]. move /ltP in Hltpv.
             apply /leP. omega.
    * move /andP in Hin'. destruct Hin' as (Hperm&_).
      rewrite perm_eq_sym in Hperm.
      rewrite (perm_eq_trans Hperm) //.
      repeat apply perm_eq_cat; auto.
Qed.


Module Coq23.

  Inductive strange : Set :=
    cs : strange -> strange.

  Lemma silly : forall x : strange, cs x = x.
Proof.
  intros.
  induction x. rewrite IHx. auto.
Qed.
  Lemma strange_equ : forall x y : strange, x = y.
 Proof.
    intros. induction x.
    destruct y.
    rewrite <- IHx. apply silly.
Qed.

 Inductive A : Prop :=
   base : Set -> A
 | succ' : A -> A.

 Require Import Nat.
 Require Import Arith.

 Check (succ' (base nat)).