From Complexity.Complexity Require Import NP.
From Undecidability.TM Require TM ProgrammingTools CaseList.
From Undecidability.TM Require Import TM_facts SizeBounds.

From Complexity.NP.TM  Require Import TMGenNP_fixed_mTM.
From Undecidability.TM.Single Require EncodeTapes StepTM.
From Complexity.TM.Single Require DecodeTapes.

From Undecidability Require Import TM.Util.VectorPrelim.
From Complexity.Libs Require Import PSLCompat.

Unset Printing Coercions.

From Coq Require Import Lia Ring Arith.

Module MultiToMono.
  Section multiToMono.

    (** We can simulate any machine while first testing that we indeed work on a valid n-tape encoding *)
    Import EncodeTapes DecodeTapes Single.StepTM ProgrammingTools Combinators Decode.
    Context (sig F:finType) (n:nat) (M__multi : pTM sig F n).

    Definition M : pTM ((sigList (sigTape sig)) ^+) (option F) 1 :=
      If (CheckTapeContains.M (CheckEncodesTapes.M n))
         (Move Lmove;;If (Relabel ReadChar (Option.apply (fun _ => false) true))
                     (Move Rmove;;Relabel (ToSingleTape M__multi) Some)
                     (Return Nop None))
         (Return Nop None).

    Definition Rel : pRel ((sigList (sigTape sig)) ^+) (option F) 1 :=
      fun t '(y,t') => match y with
                      None => ~ exists (v : tapes sig n), StepTM.contains_tapes t[@Fin0] v
                    | Some y => exists (v v': tapes sig n), StepTM.contains_tapes t[@Fin0] v
                                                      /\ StepTM.contains_tapes t'[@Fin0] v'
                                                      /\ Canonical_Rel M__multi v (y,v')
                    end.

    Lemma Realise : M ⊨ Rel .
    Proof.
      intros H__multi.
      eapply Realise_monotone.
      {unfold M. TM_Correct.
       -refine (CheckTapeContains.Realise _ _). now apply CheckEncodesTapes.Realise. now apply tapes_encode_prefixInjective.
       -eapply ToSingleTape_Realise', Canonical_Realise.
      }
      intros t (y,t'). cbn in *.
      intros [H|H];unfold Rel;cbn.
      2:{ destruct H as (?&([Henc]&_)&->&_&<-). intros (v&Hv). hnf in Hv. inversion Henc. apply H.
          exists v,[]. rewrite Hv. now rewrite Encode_map_id. }
      destruct H as (?&[[Henc] <-]&_&t1&Ht1&H). 2:easy.
      destruct H as [H|H].
      2:{ destruct H as (?&(?&?&->&<-)&->&_&<-). rewrite Ht1 in H. intros (v&Ht). hnf in Ht.
          rewrite Ht in H. now cbn in H. }
      destruct H as (?&(?&Hc1&->&->)&(_&t2&Ht2&y'&->&Hm)).
      rewrite Ht1 in Ht2. destruct (current t1[@Fin0]) eqn:Hc1';inv Hc1.
      inv Henc. rename H into Henc. destruct Henc as (x'&t__L&Henc). rewrite Encode_map_id in Henc.
      erewrite tape_move_left_right in Ht2. 2:now rewrite Henc.
      rewrite Ht2 in *. clear Ht2 t2. rewrite Ht1 in *. clear Ht1 t1.
      destruct t__L. 2:now rewrite Henc in Hc1'.
      specialize Hm with (1:=Henc) as (?&(?&?&?&<-&<-)&?).
      do 3 eexists. exact Henc. split. eauto.
      unfold Canonical_T;eauto.
    Qed.

    Context (T__multi : tRel sig n).

    Definition Ter : tRel ((sigList (sigTape sig)) ^+) 1 :=
      fun t k  => exists (k' k__sim: nat), (forall (v : tapes sig n),
                                   StepTM.contains_tapes t[@Fin0] v
                                   -> T__multi v k__sim
                                     /\ Loop_steps (start (projT1 M__multi)) v k__sim <= k')
                               /\ (S (| right t[@Fin0] |)*4*(n+1) + n*16 + 27 + k') <= k .
    Lemma Terminates  : projT1 M__multi ↓ T__multi -> projT1 M ↓ Ter.
    Proof.
      intros H__multi.
      eapply TerminatesIn_monotone.
      {unfold M. TM_Correct.
       -eapply CheckTapeContains.Realise. now apply CheckEncodesTapes.Realise. now apply tapes_encode_prefixInjective.
       -eapply CheckTapeContains.Terminates. now apply CheckEncodesTapes.Realise. apply CheckEncodesTapes.Terminates.
       -eapply ToSingleTape_Terminates'. eassumption.
      }
      intros t k (k'&k__sim&Hk__sim&Hk). infTer 2. infTer 2. hnf. reflexivity.
      split. shelve.
      intros ? b [Henc Hbeq]. destruct b. 2:now apply Nat.le_0_l.
      infTer 4. intros t1 [] Ht1. cbn in Ht1.
      infTer 4. cbn. intros t2 b (?&Hb&->&->).
      destruct b. 2:now apply Nat.le_0_l.
      infTer 4. intros t2 _ Ht2. hnf.
      destruct Henc. inv H. rename H0 into Henc. destruct Henc as (v&t__L&Heq).
      rewrite Ht1 in Ht2. specialize (Hbeq eq_refl). subst tout. cbn in *.
      rewrite Heq in Ht1. rewrite Ht1 in Hb. destruct t__L;inv Hb. rewrite Heq in Ht2. cbn in Ht2.
      rewrite Ht2. clear Ht2 Ht1 t1 t2.
      edestruct Hk__sim as (H__k&Hk__sim').  1:{ hnf. rewrite Heq. now rewrite map_id. }
      eexists v,_. split. 1:{ hnf. now rewrite map_id. }
      split. eassumption. eassumption.
      Unshelve. cbn - [plus mult]. rewrite CheckEncodesTapes.length_right_tape_move_right. cbn - [plus mult].
      ring_simplify.
      transitivity (S (| right t[@Fin0] |)*4*(n+1) + n*16 + 27 + k'). cbn - [plus mult].
      abstract nia. exact Hk.
    Qed.
  End multiToMono.
End MultiToMono.
Arguments MultiToMono.Rel : simpl never.
Arguments MultiToMono.Ter : simpl never.

Section putFirst.
  (** putting the first element at the end of an vector *)

  Definition putFirstAtEnd n: Vector.t (Fin.t (S n)) (S n):=
    Vectors.tabulate (fun i => match lt_dec (S (proj1_sig (Fin.to_nat i))) (S n) with
                      Specif.left H => Fin.of_nat_lt H
                    | _ => Fin.F1
                    end).
  Arguments putFirstAtEnd : simpl never.

  Definition putEndAtFirst n': Vector.t (Fin.t (S n')) (S n').
    refine (Vectors.tabulate (fun i => match Fin.to_nat i with
                            | exist 0 H => Fin.of_nat_lt (Nat.lt_succ_diag_r n')
                            | exist n' H => Fin.of_nat_lt (p:=n'-1) _
                            end )). abstract nia.
  Defined.
  Arguments putEndAtFirst : simpl never.

  Section printFin.
    Local Arguments Fin.t : clear implicits.
    Local Arguments Fin.FS : clear implicits.
    Local Arguments Fin.F1 : clear implicits.
    Local Arguments Vector.cast : clear implicits.

    Lemma putFirstAtEnd_dupfree m: VectorDupfree.dupfree (putFirstAtEnd m).
    Proof.
      clear_all. apply dupfree_tabulate_injective.
      intros i j. destruct (Fin.to_nat i) as [i' Hi] eqn:eqi. destruct (Fin.to_nat j) as [j' Hj] eqn:eqj .
      cbn. 1:do 2 destruct lt_dec. 2,3:easy.
      2:{ intros _. apply Fin.to_nat_inj. rewrite eqi. rewrite eqj. cbn. clear eqi eqj. nia. }
      intros H%Fin.FS_inj. apply Fin.to_nat_inj.
      rewrite eqi,eqj. cbn.
      assert (H1 : i' < m) by now apply Nat.succ_lt_mono.
      assert (H2 : j' < m) by now apply Nat.succ_lt_mono.
      erewrite <- (Fin.of_nat_ext H1), <- (Fin.of_nat_ext H2) in H.
      apply(f_equal Fin.to_nat) in H. rewrite !Fin.to_nat_of_nat in H.
      now inv H.
    Qed.

    Lemma putEndAtFirst_dupfree m: VectorDupfree.dupfree (putEndAtFirst m).
    Proof.
      clear_all. apply dupfree_tabulate_injective.
      intros i j.
      destruct (Fin.to_nat i) eqn:?;destruct (Fin.to_nat j) eqn:?; cbn in *.
      eassert (H'1:=Heqs). assert (H'2:=Heqs0).
      erewrite <- (Fin.of_nat_to_nat_inv i) in Heqs. erewrite <- (Fin.of_nat_to_nat_inv j) in Heqs0.
      rewrite Fin.to_nat_of_nat in Heqs. rewrite Fin.to_nat_of_nat in Heqs0. inversion Heqs; inversion Heqs0.
            destruct (fin_destruct_S i) as [ (i'&->) | ->]; destruct (fin_destruct_S j) as [ (j'&->) | ->].
            all:try change (Fin.FS m i') with (Fin.R 1 i') in *; try change (Fin.FS m j') with (Fin.R 1 j') in *.
            all:change (S m) with (1+m) in *.
            all: rewrite ?Fin.R_sanity in H0;rewrite ?Fin.R_sanity in H1. all: subst;cbn.
            all:intros Heq%(f_equal Fin.to_nat).
            all:rewrite !Fin.to_nat_of_nat in Heq.
            all:inversion Heq as [H2]. all:try rewrite ?Nat.sub_0_r in H2.
            all:try apply Fin.to_nat_inj in H2. all:try easy.
    Qed.

  End printFin.

  Import LiftTapes.

  Lemma putFirstAtEnd_to_list X n' (x:X) xs:
    (Vector.to_list (select (putFirstAtEnd n') (x ::: xs))) = Vector.to_list xs ++ [x].
  Proof.
    apply nth_error_inj. intros i.
    rewrite !vector_nth_error_nat. destruct lt_dec.
    { rewrite select_nth. unfold putFirstAtEnd. rewrite nth_tabulate,Fin.to_nat_of_nat;cbn.
      destruct lt_dec.
      -erewrite nth_error_app1. 2:now erewrite Vector.length_to_list.
       cbn. rewrite vector_nth_error_nat. destruct lt_dec. 2:exfalso;nia.
       erewrite Fin.of_nat_ext. reflexivity.
      -cbn. rewrite nth_error_app2. all:rewrite Vector.length_to_list. 2:nia. replace (i-n') with 0 by nia. easy.
    }
    symmetry. apply nth_error_None. erewrite app_length, Vector.length_to_list. cbn;nia.
  Qed.

  Lemma putEnd_invL X n' (v : Vector.t X _) :
    select (putEndAtFirst n') (select (putFirstAtEnd n') v) = v.
  Proof.
    apply Vector.eq_nth_iff. intros i ? <-. rewrite !select_nth.
    f_equal.
    unfold putEndAtFirst,putFirstAtEnd. rewrite !nth_tabulate.
    destruct (fin_destruct_S i) as  [(i'&->) | ->].
    2:{ cbn. rewrite Fin.to_nat_of_nat. cbn. destruct lt_dec. now exfalso;nia. easy. }
    eapply Fin.to_nat_inj.
    remember (Fin.to_nat (Fin.FS i')) as i0 eqn:H. set (tmp:=proj1_sig i0).
    rewrite (sig_eta i0). subst tmp i0. cbn.
    destruct (Fin.to_nat i') eqn:H.
    cbn. rewrite Fin.to_nat_of_nat;cbn. destruct lt_dec;cbn.
    -rewrite (sig_eta (Fin.to_nat _)). cbn. rewrite Fin.to_nat_of_nat. cbn. nia.
    -clear H. nia.
  Qed.

  Lemma putEndAtFirst_to_list X n' v (ts:X) v0:
    Vector.to_list v ++ [ts] = Vector.to_list v0 ->
    select (putEndAtFirst n') v0 = ts ::: v.
  Proof using.
    intros H. rewrite <- putFirstAtEnd_to_list in H. apply vector_to_list_inj in H.
    subst v0. now setoid_rewrite putEnd_invL.
  Qed.

End putFirst.

From Undecidability Require Import Datatypes.Lists LBool.
From Complexity Require Import L.TM.CompCode.

Section lemmas_for_LMGenNP_to_TMGenNP_mTM.
  Import EncodeTapes DecodeTapes Single.StepTM ProgrammingTools Combinators Decode.
  Import LVector.
  Import TM.

  Context (sig:finType) (n:nat)  (M : TM sig (S n)).

  Definition M__mono : pTM ((sigList (sigTape sig)) ^+) unit 1 :=
    If (Move Rmove ;; Relabel (MultiToMono.M (LiftTapes (M;(fun _ => tt)) (putEndAtFirst n) )) (Option.apply (fun _ => true) false))
       Nop
       Diverge.

  Local Arguments Canonical_Rel : simpl never.
  Lemma Realises__mono:
    M__mono ⊨(fun tin '(_,tout) =>
              exists v v' : tapes sig (S n),
                contains_tapes (tape_move_right tin[@Fin0]) v /\
                contains_tapes tout[@Fin0] v' /\
                Canonical_Rel (LiftTapes (existT (fun x : TM sig (S n) => state x -> unit) M (fun _ : state M => tt)) (putEndAtFirst n)) v
                              (tt, v')).
  Proof.
    eapply Realise_monotone.
    { unfold M__mono. TM_Correct. apply MultiToMono.Realise. } cbn.
    intros tin ([],tout). cbn. intros [H|H].
    2:now decompose record H.
    destruct H as (?&([]&t1&Ht1&b&Hb&H__mono)&<-). destruct b as [ [] | ] ;inv Hb.
    hnf in H__mono. cbn - [Canonical_Rel]in *|-*. rewrite Ht1 in *|-*. easy.
  Qed.

    Lemma Terminates_False sig' n' (M' : TM sig' n'): M' ↓ (fun _ _ => False).
  Proof.
    easy.
  Qed.

  Lemma Terminates__mono:
    projT1 M__mono ↓ (fun t k => exists (v : tapes _ (S n)) k',
                        contains_tapes (tape_move_right t[@Fin0]) v
                        /\ MultiToMono.Ter (LiftTapes (existT _ M (fun _  => tt)) (putEndAtFirst n))
                                          (LiftTapes_T (putEndAtFirst n) (Canonical_T M))
                                          [|(tape_move_right t[@Fin0])|] k'
                        /\ k' + 3 <= k).
  Proof.
    eapply TerminatesIn_monotone.
    { unfold M__mono. TM_Correct.
      -apply MultiToMono.Realise.
      -eapply MultiToMono.Terminates. apply LiftTapes_Terminates. apply putEndAtFirst_dupfree. eapply Canonical_TerminatesIn.
      -apply Terminates_False.
    }
    intros tin k (v&k'&Hv&HT&Hk). cbn.
    infTer 7. intros t1 _ Ht1. unfold tapes in *. destruct_vector;cbn in *. subst h. apply HT. shelve.
    intros tout b (?&t1&Ht1&[[]| ]&->&Hr). all:cbn. 2:{ apply Hr. cbn in *. rewrite <- Ht1 in *. easy. } reflexivity.
    Unshelve.
    { rewrite <- Hk. nia. }
  Qed.

  Lemma concat_eq_inv_borderL X isBorder xs R__L ys b (R__R : list X):
    (forall x, x el xs -> exists hd tl, x = hd::tl /\ isBorder hd /\ forall c, c el tl -> ~isBorder c) ->
    (forall x, x el ys -> exists hd tl, x = hd::tl /\ isBorder hd /\ forall c, c el tl -> ~isBorder c) ->
    (forall x, x el R__R -> ~isBorder x) ->
    isBorder b ->
    concat xs ++ b::R__L = concat ys++R__R ->
    (forall i, i < length xs -> nth_error xs i = nth_error ys i) /\ b::R__L = concat (skipn (length xs) ys) ++ R__R.
  Proof.
    clear. induction xs as [ | x xs] in ys|-*;intros HL HR HRR Hb Heq.
    { cbn in *. easy. }
    destruct ys as [ |y ys].
    { exfalso. cbn in Heq. subst R__R.
      destruct (HL x) as (?&?&->&?&?). easy. eapply HRR. 2:easy. cbn;easy. }
    cbn in Heq. autorewrite with list in Heq.
    destruct (HL x) as (x__hd&x__tl&->&Hxhd&Hxtl). easy.
    destruct (HR y) as (y__hd&y__tl&->&_&Hytl). easy.
    cbn in *.
    revert Heq. intros [= <- Heq].
    replace y__tl with x__tl in *.
    2:{ induction x__tl as [ | x' xtl] in y__tl,Heq,HL,HR,Hytl,Hxtl|-*.
        -destruct y__tl. easy. cbn in Heq. destruct xs.
         +now edestruct (Hytl x);inv Heq.
         +edestruct (HL l) as (?&?&->&?&?). easy. inv Heq. now edestruct Hytl.
        -destruct y__tl.
         2:{ inv Heq. f_equal. eapply IHxtl. 3-5:cbn;intros;auto.
             all:intros z [<-| ].  all:now eauto 7.
         }
         exfalso. destruct ys. 2:{ edestruct (HR l) as (?&?&->&?&?). easy. inv Heq. cbn in *. now eapply Hxtl. }
         cbn in Heq.
         inv Heq. eapply HRR. 2:exact Hb. eauto 10.
    }
    apply app_inv_head in Heq. apply IHxs in Heq.  2-5:now eauto 7.
    destruct Heq as (IH&->). split. 2:easy.
    intros [] ?. easy. cbn. apply IH. nia.
  Qed.

  Lemma contains_tapes_inj (sig' : finType) n' t (v v' : tapes sig' n'):
    contains_tapes t v -> contains_tapes t v' -> v = v'.
  Proof.
    unfold contains_tapes. intros -> [= eq]. apply app_inv_tail in eq. apply map_injective in eq. 2:congruence.
    eassert (H':=tapes_encode_prefixInjective (t:=[]) (t':=[])). rewrite !app_nil_r in H'. apply H' in eq. easy.
  Qed.

End lemmas_for_LMGenNP_to_TMGenNP_mTM.

Arguments putFirstAtEnd : simpl never.
Arguments putEndAtFirst : simpl never.


(* This file contains tactics that are similar to ssreflect tactics.
 * The tactics here use numbers to refer to hypotheses to the right
 * of the entailment.
 *)

Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.Classes.Morphisms.
Require Import ChargeCore.Logics.ILogic.
Require Import ChargeCore.Tactics.Tactics.

Section indexed.
  Context {L : Type}
          {ILO : ILogicOps L}
          {IL : ILogic L}.

  (* Destruct *)
  Theorem destruct_top
  : forall A B C D : L,
      A |-- B -->> C -->> D ->
      A |-- B //\\ C -->> D.
  Proof. intros. rewrite H. charge_tauto. Qed.

  (* Split *)
  Theorem split_top
  : forall A B C D : L,
      A |-- B -->> D ->
      A |-- C -->> D ->
      A |-- B \\// C -->> D.
  Proof.
    intros. charge_intros.
    charge_cases.
    - charge_apply H; charge_tauto.
    - charge_apply H0; charge_tauto.
  Qed.

  (* Move *)
  Theorem move_top
  : forall A B C D : L,
      A //\\ C |-- B -->> D ->
      (A //\\ B) //\\ C |-- D.
  Proof.
    intros. charge_apply H.
    charge_tauto.
  Qed.

  (* Copy *)
  Theorem copy_top
  : forall A B C : L,
      A |-- B -->> B -->> C ->
      A |-- B -->> C.
  Proof.
    intros. rewrite H. charge_tauto.
  Qed.

  (* Copy *)
  Theorem clear_top
  : forall A B C : L,
      A |-- C ->
      A |-- B -->> C.
  Proof.
    intros. rewrite H. charge_tauto.
  Qed.

  Theorem skip_top : forall A B C D : L,
      (A //\\ B) //\\ C |-- D ->
      A //\\ C |-- B -->> D.
  Proof.
    intros. charge_intros. charge_apply H.
    charge_tauto.
  Qed.

  Lemma apply_ctx : forall A B C : L,
      C |-- A ->
      C //\\ (A -->> B) |-- B.
  Proof.
    intros. rewrite H. charge_tauto.
  Qed.

  Lemma apply_ctx' : forall A B C D : L,
      C //\\ B |-- D ->
      C |-- A ->
      C //\\ (A -->> B) |-- D.
  Proof.
    intros. charge_apply H. rewrite <- H0 at 1.
    charge_tauto.
  Qed.
End indexed.

Ltac charge_destruct_n n :=
  match n with
  | 0 => apply destruct_top
  | S ?n => charge_intro; charge_destruct_n n ; charge_revert
  end.

Ltac charge_split_n n :=
  match n with
  | 0 => apply split_top
  | S ?n => charge_intro; charge_split_n n; charge_revert
  end.

Ltac charge_move_n n :=
  let rec move_n n :=
      match n with
      | 0 => apply limplAdj
      | S ?n => apply limplAdj ; move_n n ; apply move_top
      end
  in
  move_n n ; charge_revert.

Ltac charge_copy_n n :=
  match n with
  | 0 => apply copy_top
  | S ?n => charge_intro ; charge_copy_n n ; charge_revert
  end.

Ltac charge_clear_n n :=
  match n with
  | 0 => apply clear_top
  | S ?n => charge_intro ; charge_copy_n n ; charge_revert
  end.

Ltac charge_apply_n n :=
  charge_move_n n ; apply limplAdj ;
  let rec try_apply k :=
      first [ apply apply_ctx ; k
            | apply apply_ctx'; [ try_apply k | k ] ]
  in
  let rec try_each k :=
      first [ try_apply k
            | apply skip_top ;
              let k' := (charge_revert; k) in
              try_each k' ]
  in
  try_each idtac.

Tactic Notation "charge" "apply" constr(n) := charge_apply_n n.
Tactic Notation "charge" "move" constr(n) := charge_move_n n.
Tactic Notation "charge" "clear" constr(n) := charge_clear_n n.
Tactic Notation "charge" "destruct" constr(n) := charge_destruct_n n.
Tactic Notation "charge" "split" constr(n) := charge_split_n n.

Section demo.
  Context {L : Type}
          {ILO : ILogicOps L}
          {IL : ILogic L}.

  Goal forall D E F G : L,
      |-- (D -->> F) -->> E //\\ (F \\// D) -->> (E -->> F -->> G) -->> G.
  Proof. intros.
         charge destruct 1.
         charge split 2.
         { charge apply 3. charge_tauto. }
         { charge_tauto. }
  Qed.
End demo.


From CoindSemWhile Require Import SsrExport Trace Language BigRel.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Section Exec.

Variable tt: expr.
Hypothesis tt_spec: forall st, is_true (tt st) = true.

CoInductive exec1: stmt -> state -> trace -> Prop :=
| exec1_skip: forall st,
    exec1 Sskip st (Tnil st)
| exec1_assign: forall id a st,
    exec1 (Sassign id a) st (Tcons st (Tnil (update id (a st) st)))
| exec1_seq: forall s1 s2 st tr tr',
    exec1 s1 st tr ->
    execseq1 s2 tr tr' ->
    exec1 (Sseq s1 s2) st tr'
| exec1_ifthenelse_true: forall a s1 s2 st tr,
    is_true (a st) = true ->
    execseq1 s1 (Tcons st (Tnil st)) tr ->
    exec1 (Sifthenelse a s1 s2) st tr
| exec1_ifthenelse_false: forall a s1 s2 st tr,
    is_true (a st) = false ->
    execseq1 s2 (Tcons st (Tnil st)) tr ->
    exec1 (Sifthenelse a s1 s2) st tr
| exec1_while_false: forall a s st,
    is_true (a st) = false ->
    exec1 (Swhile a s) st (Tnil st)
| exec1_while_loop: forall a s st tr tr',
    is_true (a st) = true ->
    exec1 s st tr ->
    execseq1 (Swhile a s) tr tr' ->
    exec1 (Swhile a s) st tr'

with execseq1: stmt -> trace -> trace -> Prop :=
| exec1_nil: forall st s tr,
  exec1 s st tr ->
  execseq1 s (Tnil st) tr
| exec1_cons: forall tr s tr' e,
  execseq1 s tr tr' ->
  execseq1 s (Tcons e tr) (Tcons e tr').

Lemma lemma1: forall st tr, exec1 (Swhile tt Sskip) st tr.
Proof.
cofix COINDHYP. move => st tr. apply: exec1_while_loop.
* by apply: tt_spec.
* by apply exec1_skip.
* by have := exec1_nil (COINDHYP st tr); apply.
Qed.

CoInductive last_true (e: expr): trace -> Prop :=
| last_true_nil: forall st,
  is_true (e st) = true ->
  last_true e (Tnil st)
| last_true_cons: forall st tr,
  last_true e tr ->
  last_true e (Tcons st tr).

CoInductive last_false (e: expr): trace -> Prop :=
| last_false_nil: forall st,
  is_true (e st) = false ->
  last_false e (Tnil st)
| last_false_cons: forall st tr,
  last_false e tr ->
  last_false e (Tcons st tr).

CoFixpoint duplast (tr: trace): trace :=
match tr with
| Tnil st => Tcons st (Tnil st)
| Tcons st tr' => Tcons st (duplast tr')
end.

CoFixpoint updatelast (id: id) (e: expr) (tr: trace): trace :=
match tr with
| Tnil st => Tcons st (Tnil (update id (e st) st))
| Tcons st tr' => Tcons st (updatelast id e tr')
end.

CoInductive execseq2: stmt -> trace -> trace -> Prop :=
| execseq2_skip: forall tr,
    execseq2 Sskip tr tr
| execseq2_assign: forall id a tr,
    execseq2 (Sassign id a) tr (updatelast id a tr)
| execseq2_seq: forall s1 s2 tr tr' tr'',
    execseq2 s1 tr tr' ->
    execseq2 s2 tr' tr'' ->
    execseq2 (Sseq s1 s2) tr tr''
| execseq2_ifthenelse_true: forall a s1 s2 tr tr',
    last_true a tr ->
    execseq2 s1 (duplast tr) tr' ->
    execseq2 (Sifthenelse a s1 s2) tr tr'
| execseq2_ifthenelse_false: forall a s1 s2 tr tr',
    last_false a tr ->
    execseq2 s2 (duplast tr) tr' ->
    execseq2 (Sifthenelse a s1 s2) tr tr'
| execseq2_while_false: forall a s tr,
    last_false a tr ->
    execseq2 (Swhile a s) tr (duplast tr)
| execseq2_while_loop: forall a s tr tr' tr'',
  last_true a tr ->
  execseq2 s (duplast tr) tr' ->
  execseq2 (Swhile a s) tr' tr'' ->
  execseq2 (Swhile a s) tr tr''.

Inductive exec2: stmt -> state -> trace -> Prop :=
| exec2_intro: forall s st tr,  execseq2 s (Tnil st) tr -> exec2 s st tr.

Lemma lemma2: forall st tr, exec2 (Swhile tt Sskip) st tr.
Proof.
have h1: forall tr tr', execseq2 (Swhile tt Sskip) tr tr'.
* cofix COINDHYP. move => tr tr'.
  have := (@execseq2_while_loop _ _ _ (duplast tr) tr'); apply.
  * move: tr. cofix COINDHYP2. case.
    - move => st. apply: last_true_nil. by apply: tt_spec.
    - move => st tr. by have := last_true_cons _ (COINDHYP2 _); apply.
  * by apply: execseq2_skip.
  * by apply: COINDHYP.
* move => st tr. apply: exec2_intro. by apply: h1.
Qed.

Lemma lemma3: forall x st tr, exec2 (Swhile tt (Sassign x (fun st => (st x + 1)))) st tr.
Proof.
move => x.
have h1: forall tr tr', execseq2 (Swhile tt (Sassign x (fun st => (st x + 1)))) tr tr'.
* cofix COINDHYP. move => tr0 tr1.
  have := (@execseq2_while_loop _ _ _ (updatelast x (fun st => (st x + 1)) (duplast tr0)) tr1); apply.
  * move: tr0. cofix COINDHYP0. case.
    - move => st. apply: last_true_nil. by apply: tt_spec.
    - move => st tr. by have := last_true_cons _ (COINDHYP0 _); apply.
  * by apply: execseq2_assign.
  * by apply: COINDHYP.
* move => st tr. apply: exec2_intro. by apply: h1.
Qed.

End Exec.

CoInductive split: trace -> trace -> state -> trace -> Prop :=
| split_nil: forall st,
  split (Tnil st) (Tnil st) st (Tnil st)
| split_cons: forall st tr,
  split (Tcons st tr) (Tnil st) st (Tcons st tr)
| split_delay: forall st st' tr tr' tr'',
  split tr tr' st' tr'' ->
  split (Tcons st tr) (Tcons st tr') st' tr''.

CoInductive exec3: stmt -> state -> trace -> Prop :=
| exec3_skip: forall st,
  exec3 Sskip st (Tnil st)
| exec3_assign: forall id a st,
  exec3 (Sassign id a) st (Tcons st (Tnil (update id (a st) st)))
| exec3_seq: forall s1 s2 st st' tr tr' tr'',
  split tr tr' st' tr'' ->
  exec3 s1 st tr' ->
  exec3 s2 st' tr'' ->
  exec3 (Sseq s1 s2) st tr
| exec3_ifthenelse_true: forall a s1 s2 st tr,
  is_true (a st) = true ->
  exec3 s1 st tr ->
  exec3 (Sifthenelse a s1 s2) st (Tcons st tr)
| exec3_ifthenelse_false: forall a s1 s2 st tr,
  is_true (a st) = false ->
  exec3 s2 st tr ->
  exec3 (Sifthenelse a s1 s2) st (Tcons st tr)
| exec3_while_false: forall a s st,
  is_true (a st) = false ->
  exec3 (Swhile a s) st (Tcons st (Tnil st))
| exec3_while_loop: forall a s st st' tr tr' tr'',
  split tr tr' st' tr'' ->
  is_true (a st) = true ->
  exec3 s st tr' ->
  exec3 (Swhile a s) st' tr'' ->
  exec3 (Swhile a s) st (Tcons st tr).

Lemma lemma4: forall s st tr, exec3 s st tr -> exec s st tr.
Proof.
cofix  COINDHYP. move => s st tr h1. foo h1.
- by apply: exec_skip.
- by apply: exec_assign.
- have := exec_seq (COINDHYP _ _ _ H0); apply.
  move => {H0}. move: tr' st' tr'' tr H H1. cofix COINDHYP0.
  move => st0 st1 tr0 tr1 h1 h2. foo h1.
  - apply execseq_nil. by have := COINDHYP _ _ _ h2; apply.
  - apply execseq_nil. by have := COINDHYP _ _ _ h2; apply.
  - apply execseq_cons. by have := COINDHYP0 _ _ _ _ H h2; apply.
- apply exec_ifthenelse_true.
  * by apply H.
  * apply execseq_cons. apply execseq_nil.
     have := COINDHYP _ _ _ H0; apply.
- apply exec_ifthenelse_false.
  * by apply H.
  * apply execseq_cons. apply execseq_nil.
    have := COINDHYP _ _ _ H0; apply.
- apply exec_while_false. by apply H.
- apply: exec_while_loop.
  * by apply H0.
  * apply execseq_cons. apply execseq_nil.
     have h:= COINDHYP _ _ _ H1. by apply h.
  * apply execseq_cons. move => {H0 H1}. move: tr0 st' tr' tr'' H H2.
    cofix COINDHYP0. move => tr0 st0 tr1 tr2 h1 h2. foo h1.
    - apply execseq_nil. by have := COINDHYP _ _ _ h2; apply.
    - apply execseq_nil. by have := COINDHYP _ _ _ h2; apply.
    - apply execseq_cons. by have := COINDHYP0 _ _ _ _ H h2.
Qed.


Require Import Coq.Relations.Relations.
Require Import Coq.Setoids.Setoid.
Require Import Coq.funind.Recdef.
Require Import Coq.PArith.BinPos.
Require Import Lia.
From compcert.lib Require Import Maps.

Require Import Coq.Lists.List.
Import ListNotations.

Require Import Ltac2.Ltac2.
Import Ltac2.Notations.
Set Default Proof Mode "Ltac2".

Require Import Coq.Logic.JMeq.
Require Import Coq.Logic.Eqdep.
Ltac inv_ex :=
  repeat progress match goal with
  | H : existT ?P ?T _ = existT ?P ?T _ |- _ => apply inj_pairT2 in H
  end.

Require Export CertiCoq.LambdaANF.Frame.

Set Implicit Arguments.

(* -------------------- Annotations -------------------- *)

Definition Rec {A} (rhs : A) : A := rhs.
Definition BottomUp {A} (rhs : A) : A := rhs.

(* -------------------- Erased values -------------------- *)

(* An erased value of type [A] is a value which can only be used to construct Props.
   We can represent erased values [x] in CPS with answer type Prop, as functions of
   the form [fun k => k x]: *)
Definition erased A := (A -> Prop) -> Prop.
Class e_ok {A} (x : erased A) := erased_ok : exists (y : A), x = (fun k => k y).
(* These two items are carried separately so that they can both be erased during extraction.
   Bundling them together in a dependent pair type would erase to a pair type [box × box] *)

(* Erasing a value *)
Definition erase {A} : A -> erased A := fun x k => k x.
Instance erase_ok {A} (x : A) : e_ok (erase x). Proof. exists x; reflexivity. Qed.

(* Erased values can always be used to construct other erased values *)
Definition e_map {A B} (f : A -> B) (x : erased A) : erased B := fun k => x (fun x => k (f x)).
Instance e_map_ok {A B} (f : A -> B) (x : erased A) `{H : e_ok _ x} : e_ok (e_map f x).
Proof. destruct H as [y Hy]; subst x; unfold e_map; now exists (f y). Qed.

Definition e_map_fuse {A B C} (f : B -> C) (g : A -> B) (x : erased A) :
  e_map f (e_map g x) = e_map (fun x => f (g x)) x.
Proof. reflexivity. Qed.

(* Only proofs can be unerased *)
Definition recover (x : erased Prop) : Prop := x (fun x => x).
Notation "'«' P '»'" := (recover P).

(* Remove all erased operators from a goal using e_ok hypotheses *)
Ltac unerase :=
  repeat match goal with
  | H : e_ok ?x |- _ =>
    let x' := fresh x in
    rename x into x';
    destruct H as [x H];
    subst x'
  end;
  unfold recover, e_map, erase in *.

Ltac2 unerase () := ltac1:(unerase).
Ltac2 Notation "unerase" := unerase ().

(* Example *)
Require Import Lia.
Require Extraction.
Module Example.

Fixpoint thingy (n : erased nat) `{Hn : e_ok _ n} (m p : nat) (Hmp : «e_map (fun n => n + m = p) n») {struct m} : nat.
Proof.
  destruct m as [|m] > [exact p|].
  specialize (thingy (e_map S n) _ m p); apply thingy; clear thingy.
  ltac1:(unerase; lia).
Defined.

(* Print thingy. *)
(* (* Since n and its proof are carried separately, both are erased entirely *) *)
(* Recursive Extraction thingy. *)
End Example.

(* -------------------- Fixpoint combinator -------------------- *)

(* Equations and Program Fixpoint use a fixpoint combinator which has the following type when
   specialized to a particular measure [measure]:
     [forall arg_pack, (forall arg_pack', measure arg_pack' < measure arg_pack -> P arg_pack') -> P arg_pack]
   This requires wrapping and unwrapping [arg_pack]s. Instead we'll make
     [forall (cost : erased nat), e_ok cost -> (forall cost', e_ok cost' -> cost' < cost -> Q cost') -> Q cost]
   which can achieve the same thing without arg packs by setting
     [Q := fun cost => arg1 -> ‥ -> arg_n -> cost = measure(arg1, ‥, arg_n) -> P (arg1, ‥, arg_n)].

   After a function has been defined this way, unfolding all fixpoint combinators will leave behind a
   primitive fixpoint of type
     [forall (cost : erased nat), e_ok cost -> Accessible cost -> arg1 -> ‥ -> arg_n -> cost = measure ‥ -> P ‥]
   that is structurally recursive on the accessibility proof [Accessible cost].

   Extraction will erase [cost : erased nat], [e_ok cost], [Accessible cost], and [cost = measure ‥],
   leaving a plain recursive function of type [arg1 -> ‥ -> arg_n -> P ‥]. *)
Require Import Coq.Arith.Wf_nat.
Section WellfoundedRecursion.

(* Modelled after https://coq.inria.fr/library/Coq.Init.Wf.html#Acc *)
Section AccS.

  Context (A : Type) (B : A -> Prop) (R : forall x, B x -> forall y, B y -> Prop).

  Inductive AccS (x : A) (Hx : B x) : Prop :=
    AccS_intro : (forall (y : A) (Hy : B y), R Hy Hx -> @AccS y Hy) -> AccS Hx.

  Definition well_foundedS := forall (x : A) (Hx : B x), AccS Hx.

  Section FixS.

    Context
      (Rwf : well_foundedS)
      (P : A -> Type)
      (F : forall (x : A) (Hx : B x), (forall (y : A) (Hy : B y), R Hy Hx -> P y) -> P x).

    Fixpoint FixS_F (x : A) (Hx : B x) (H : AccS Hx) {struct H} : P x :=
      F (fun (y : A) (Hy : B y) (Hyx : R Hy Hx) =>
          FixS_F (let 'AccS_intro H := H in H y Hy Hyx)).

    Definition FixS (x : A) (Hx : B x) : P x := FixS_F (Rwf Hx).

  End FixS.

End AccS.

Section FixEN.

Definition enat := erased nat.
Definition e_lt : forall x : enat, e_ok x -> forall y : enat, e_ok y -> Prop :=
  fun n Hn m Hm => «e_map (fun n => «e_map (fun m => n < m) m») n».

Lemma e_lt_wf : well_foundedS e_ok e_lt.
Proof.
  intros n Hn; unerase.
  induction n as [n IHn] using Wf_nat.lt_wf_ind.
  constructor; intros m Hm Hmn; unerase.
  now (apply IHn).
Defined.

Definition FixEN :
  forall P : enat -> Type,
  (forall (x : enat) (Hx : e_ok x), (forall (y : enat) (Hy : e_ok y), e_lt Hy Hx -> P y) -> P x) ->
  forall x : enat, e_ok x -> P x
  := FixS e_lt_wf.

End FixEN.

End WellfoundedRecursion.

Extraction Inline FixEN FixS FixS_F.

Module FixENExample.

Definition plus : forall (cost : enat) `{e_ok _ cost}, forall n m : nat, «e_map (eq n) cost» -> nat.
Proof.
  apply (FixEN (fun cost => forall n m : nat, «e_map (eq n) cost» -> nat)).
  intros cost Hok rec n m Hcost.
  destruct n as [|n] > [exact m|].
  specialize rec with (n := n).
  specialize (rec (erase n) _).
  apply S, rec > [|exact m|]; unfold e_lt in *; ltac1:(unerase; lia).
Defined.

End FixENExample.

(* Print FixENExample.plus. *)
Set Extraction Flag 2031. (* default + linear let + linear beta *)
(* Recursive Extraction FixENExample.plus. *)

(* -------------------- 1-hole contexts built from frames -------------------- *)

(* A 1-hole context made out of frames F *)
Inductive frames_t' {U : Set} {F : U -> U -> Set} : U -> U -> Set :=
| frames_nil : forall {A}, frames_t' A A
| frames_cons : forall {A B C}, F A B -> frames_t' B C -> frames_t' A C.
Arguments frames_t' {U} F _ _.
Notation "C '>::' f" := (frames_cons f C) (at level 50, left associativity).
Notation "<[]>" := (frames_nil).
Notation "<[ x ; .. ; z ]>" := (frames_cons z .. (frames_cons x frames_nil) ..).

(* The 1-hole contexts you usually want *)
Definition frames_t {U : Set} `{Frame U} : U -> U -> Set := frames_t' frame_t.

(* Context application *)
Reserved Notation "C '⟦' x '⟧'" (at level 50, no associativity).
Fixpoint framesD {U : Set} `{Frame U} {A B : U}
         (fs : frames_t A B) : univD A -> univD B :=
  match fs with
  | <[]> => fun x => x
  | fs >:: f => fun x => fs ⟦ frameD f x ⟧
  end
where "C '⟦' x '⟧'" := (framesD C x).

Lemma framesD_cons {U : Set} `{Frame U} {A B C : U}
      (fs : frames_t B C) (f : frame_t A B)
      (x : univD A)
  : (fs >:: f) ⟦ x ⟧ = fs ⟦ frameD f x ⟧.
Proof. reflexivity. Qed.

Fixpoint frames_lift {U : Set} {F : U -> U -> Set}
      (P : U -> Set) (Hf : forall {A B}, F A B -> P A -> P B)
      {A B} (fs : frames_t' F A B)
  : P A -> P B :=
  match fs with
  | <[]> => fun pa => pa
  | fs >:: f => fun pa => frames_lift P (@Hf) fs (Hf f pa)
  end.

(* Context composition *)
Reserved Notation "gs '>++' fs" (at level 50, left associativity).
Fixpoint frames_compose {U : Set} {F : U -> U -> Set} {A B C : U}
         (fs : frames_t' F A B) : frames_t' F B C -> frames_t' F A C :=
  match fs with
  | <[]> => fun gs => gs
  | fs >:: f => fun gs => gs >++ fs >:: f
  end
where "gs '>++' fs" := (frames_compose fs gs).

(* Laws: functor laws + injectivity *)

Lemma frames_id_law {U : Set} `{Frame U} {A} (x : univD A) : <[]> ⟦ x ⟧ = x.
Proof. auto. Qed.

Lemma frames_compose_law {U : Set} `{Frame U} {A B C} :
  forall (fs : frames_t B C) (gs : frames_t A B) (x : univD A),
  (fs >++ gs) ⟦ x ⟧ = fs ⟦ gs ⟦ x ⟧ ⟧.
Proof. intros fs gs; revert fs; induction gs; simpl; auto. Qed.

Class Frame_inj (U : Set) `{Frame U} :=
  frame_inj :
    forall {A B : U} (f : frame_t A B) (x y : univD A),
    frameD f x = frameD f y -> x = y.

Lemma frames_inj {U : Set} `{Frame U} `{Frame_inj U} {A B} (fs : frames_t A B) :
  forall (x y : univD A), fs ⟦ x ⟧ = fs ⟦ y ⟧ -> x = y.
Proof.
  induction fs; auto; cbn; intros x y Heq.
  apply IHfs, (frame_inj f) in Heq; auto.
Qed.

(* Misc. lemmas (mostly about how frames_t is similar to list) *)

Definition flip {U} (F : U -> U -> Set) : U -> U -> Set := fun A B => F B A.
Fixpoint frames_rev {U : Set} {F : U -> U -> Set} {A B} (fs : frames_t' F A B) : frames_t' (flip F) B A :=
  match fs with
  | <[]> => <[]>
  | fs >:: f => <[f]> >++ frames_rev fs
  end.
Fixpoint frames_revD {U : Set} `{Frame U} {A B : U}
         (fs : frames_t' (flip frame_t) B A) : univD A -> univD B :=
  match fs with
  | <[]> => fun x => x
  | fs >:: f => fun x => frameD f (frames_revD fs x)
  end.

Lemma frames_nil_comp {U : Set} {F : U -> U -> Set} {A B : U}
      (fs : frames_t' F A B)
  : <[]> >++ fs = fs.
Proof. induction fs > [reflexivity|cbn; now (rewrite IHfs)]. Qed.

Lemma frames_revD_comp {U : Set} `{HFrame : Frame U} {A B C : U}
      (fs : frames_t' (flip frame_t) B A) (gs : frames_t' (flip frame_t) C B)
      (x : univD A)
  : frames_revD (fs >++ gs) x = frames_revD gs (frames_revD fs x).
Proof. induction gs > [reflexivity|cbn; now (rewrite IHgs)]. Qed.

Lemma framesD_rev {U : Set} `{Frame U} {A B : U} (fs : frames_t A B) (x : univD A)
  : fs ⟦ x ⟧ = frames_revD (frames_rev fs) x.
Proof.
  induction fs > [reflexivity|cbn].
  now (rewrite frames_revD_comp, <- IHfs).
Qed.

Lemma frames_rev_assoc {U : Set} {F : U -> U -> Set} {A B C D : U}
      (fs : frames_t' F A B) (gs : frames_t' F B C) (hs : frames_t' F C D)
  : hs >++ (gs >++ fs) = hs >++ gs >++ fs.
Proof. induction fs > [reflexivity|cbn; now (rewrite IHfs)]. Qed.

Lemma frames_rev_comp {U : Set} {F : U -> U -> Set} {A B C : U}
      (fs : frames_t' F A B) (gs : frames_t' F B C)
  : frames_rev (gs >++ fs) = frames_rev fs >++ frames_rev gs.
Proof.
  induction fs; cbn.
  - now (rewrite frames_nil_comp).
  - now (rewrite IHfs, frames_rev_assoc).
Qed.

Lemma frames_rev_rev {U : Set} `{Frame U} {A B : U} (fs : frames_t A B)
  : frames_rev (frames_rev fs) = fs.
Proof. induction fs > [reflexivity|cbn]. now (rewrite frames_rev_comp, IHfs). Qed.

Fixpoint frames_any {U : Set} {F : U -> U -> Set} (P : forall {A B : U}, F A B -> Prop)
         {A B} (fs : frames_t' F A B) : Prop :=
  match fs with
  | <[]> => False
  | fs >:: f => P f \/ frames_any (@P) fs
  end.

Lemma frames_any_app
      {U : Set} {F : U -> U -> Set} (P : forall {A B : U}, F A B -> Prop)
      {A B C} (gs : frames_t' F B C) (fs : frames_t' F A B)
  : frames_any (@P) (gs >++ fs) <-> frames_any (@P) gs \/ frames_any (@P) fs.
Proof. induction fs > [cbn; ltac1:(tauto)|cbn]. rewrite IHfs; ltac1:(tauto). Qed.

Lemma frames_any_cons
      {U : Set} {F : U -> U -> Set} (P : forall {A B : U}, F A B -> Prop)
      {A B C} (fs : frames_t' F B C) (f : F A B)
  : frames_any (@P) (fs >:: f) <-> frames_any (@P) fs \/ P f.
Proof. unfold frames_any; ltac1:(tauto). Qed.

Fixpoint frames_len {U : Set} {F : U -> U -> Set} {A B} (fs : frames_t' F A B) : nat :=
  match fs with
  | <[]> => O
  | fs >:: f => S (frames_len fs)
  end.

Lemma frames_len_compose {U : Set} {F : U -> U -> Set} {A B C}
      (fs : frames_t' F A B) (gs : frames_t' F B C) :
  frames_len (gs >++ fs) = frames_len fs + frames_len gs.
Proof. induction fs as [|A' AB B' f fs IHfs] > [reflexivity|cbn]. now (rewrite IHfs). Qed.

(* Useful in situations where [destruct] struggles with dependencies *)
Lemma frames_split' {U : Set} {F : U -> U -> Set} {A B} (fs : frames_t' F A B) :
  (exists AB (g : F A AB) (gs : frames_t' F AB B), fs = gs >:: g) \/
  (A = B /\ JMeq fs (<[]> : frames_t' F A A) /\ frames_len fs = 0%nat).
Proof. destruct fs as [| A' AB B' f fs] > [now right|left; now do 3 eexists]. Qed.

(* Like frames_split', but peels off frames from the left instead of from the right *)
Lemma frames_split {U : Set} {F : U -> U -> Set} {A B} (fs : frames_t' F A B) :
  (exists AB (g : F AB B) (gs : frames_t' F A AB), fs = <[g]> >++ gs) \/ (frames_len fs = O).
Proof.
  induction fs as [| A' AB B' f fs IHfs] > [now right|left].
  destruct IHfs as [[AB' [g [gs Hgs]]] | Hnil].
  - subst. do 2 eexists; exists (gs >:: f); reflexivity.
  - destruct fs; simpl in Hnil; inversion Hnil. do 2 eexists; exists <[]>; reflexivity.
Qed.

(* Well-founded induction on the length of the context *)
Lemma frames_len_ind (U : Set) (F : U -> U -> Set)
      (P : forall {A B}, frames_t' F A B -> Prop)
      (Hlt : forall {A B} (fs : frames_t' F A B),
        (forall {C D} (gs : frames_t' F C D), frames_len gs < frames_len fs -> P gs) ->
        P fs)
      A B (fs : frames_t' F A B)
  : P fs.
Proof.
  remember (frames_len fs) as n eqn:Hlen.
  ltac1:(generalize dependent B; generalize dependent A).
  induction n as [n IHn] using lt_wf_ind; intros A B fs Hlen.
  apply Hlt; intros C D gs Hlt_gs; eapply IHn > [|reflexivity]; ltac1:(lia).
Qed.

(* [frames_t] is a snoc-list of frames; this is an induction principle for reasoning about
   them as if they were cons-lists. *)
Lemma frames_rev_ind (U : Set) (F : U -> U -> Set)
      (P : forall {A B}, frames_t' F A B -> Prop)
      (Hnil : forall {A}, P (<[]> : frames_t' F A A))
      (Hcons : forall {A B C} (f : F B C) (fs : frames_t' F A B), P fs -> P (<[f]> >++ fs))
      A B (fs : frames_t' F A B)
  : P fs.
Proof.
  induction fs as [A B fs IHfs] using frames_len_ind.
  destruct (frames_split fs) as [[AB [f [fs' Hfs']]] | Hfs_nil] > [subst fs|].
  - apply Hcons, IHfs; rewrite frames_len_compose; cbn; ltac1:(lia).
  - destruct fs > [|now (cbn in Hfs_nil)]; apply Hnil.
Qed.

(* -------------------- Rewriters -------------------- *)
Section Rewriters.

Context
  (* Types the rewriter will encounter + type of 1-hole contexts *)
  (U : Set) `{HFrame : Frame U}
  (* The type of trees being rewritten *)
  (Root : U).

(* State variables, parameters, and delayed computations *)
Section Strategies.

Context
  (D : Set) (I_D : forall (A : U), univD A -> D -> Prop)
  (R : Set) (I_R : forall (A : U), frames_t A Root -> R -> Prop)
  (S : Set) (I_S : forall (A : U), frames_t A Root -> univD A -> S -> Prop).

Definition Delay {A} (e : univD A) : Set := {d | I_D A e d}.
Definition Param {A} (C : erased (frames_t A Root)) : Set :=
  {r | «e_map (fun C => I_R C r) C»}.
Definition State {A} (C : erased (frames_t A Root)) (e : univD A) : Set :=
  {s | «e_map (fun C => I_S C e s) C»}.

Class Delayed := {
  delayD : forall {A} (e : univD A), Delay e -> univD A;
  delay_id : forall {A} (e : univD A), Delay e;
  delay_id_law : forall {A} (e : univD A), delayD (delay_id e) = e }.

Class Preserves_R :=
  preserve_R :
    forall {A B : U} (fs : erased (frames_t B Root)) `{e_ok _ fs} (f : frame_t A B),
    Param fs -> Param (e_map (fun fs => fs >:: f) fs).

Class Preserves_S_up :=
  preserve_S_up :
    forall {A B : U} (fs : erased (frames_t B Root)) `{e_ok _ fs} (f : frame_t A B) (x : univD A),
    State (e_map (fun fs => fs >:: f) fs) x -> State fs (frameD f x).

Class Preserves_S_dn :=
  preserve_S_dn :
    forall {A B : U} (fs : erased (frames_t B Root)) `{e_ok _ fs} (f : frame_t A B) (x : univD A),
    State fs (frameD f x) -> State (e_map (fun fs => fs >:: f) fs) x.

Extraction Inline delayD delay_id preserve_R preserve_S_up preserve_S_dn.

End Strategies.

(* Handy instances *)

(* Structures with no invariants *)

Definition I_D_plain (D : Set) (A : U) (_ : univD A) (_ : D) : Prop := True.
Definition id_Delay := @Delay unit (@I_D_plain unit).

Global Instance Delayed_id_Delay : Delayed (@I_D_plain unit).
Proof.
  ltac1:(unshelve econstructor).
  - intros A x _; exact x.
  - intros; exists tt; exact I.
  - reflexivity.
Defined.

Definition I_R_plain (R : Set) (A : U) (C : frames_t A Root) (_ : R) : Prop := True.
Definition I_S_plain (S : Set) (A : U) (C : frames_t A Root) (_ : univD A) (_ : S) : Prop := True.

Global Instance Preserves_R_plain (R : Set) : Preserves_R (@I_R_plain R).
Proof. unfold Preserves_R; intros; assumption. Defined.

Global Instance Preserves_S_up_plain (S : Set) : Preserves_S_up (@I_S_plain S).
Proof. unfold Preserves_S_up; intros; assumption. Defined.

Global Instance Preserves_S_dn_plain (S : Set) : Preserves_S_dn (@I_S_plain S).
Proof. unfold Preserves_S_dn; intros; assumption. Defined.

Extraction Inline Delayed_id_Delay Preserves_R_plain Preserves_S_up_plain Preserves_S_dn_plain.

(* Composing two parameters *)
Section R_prod.

Context
  (R1 R2 : Set)
  (I_R1 : forall A, frames_t A Root -> R1 -> Prop)
  (I_R2 : forall A, frames_t A Root -> R2 -> Prop).

Definition I_R_prod A (C : frames_t A Root) : R1 * R2 -> Prop :=
  fun '(r1, r2) => I_R1 C r1 /\ I_R2 C r2.

Global Instance Preserves_R_prod
       `{H1 : @Preserves_R _ (@I_R1)}
       `{H2 : @Preserves_R _ (@I_R2)} :
  Preserves_R I_R_prod.
Proof.
  unfold I_R_prod; intros A B C C_ok f [[r1 r2] Hr12].
  assert (Hr1 : «e_map (fun C => I_R1 _ C r1) C»). { unerase; now (destruct Hr12). }
  assert (Hr2 : «e_map (fun C => I_R2 _ C r2) C»). { unerase; now (destruct Hr12). }
  pattern r1 in Hr1; pattern r2 in Hr2. apply exist in Hr1; apply exist in Hr2. clear Hr12 r1 r2.
  ltac1:(unshelve eapply preserve_R with (f := f) in Hr1); try assumption.
  ltac1:(unshelve eapply preserve_R with (f := f) in Hr2); try assumption.
  destruct Hr1 as [r1 Hr1], Hr2 as [r2 Hr2]; exists (r1, r2).
  unerase; auto.
Defined.

Extraction Inline Preserves_R_prod.

End R_prod.

(* Composing two states *)
Section S_prod.

Context
  (S1 S2 : Set)
  (I_S1 : forall A, frames_t A Root -> univD A -> S1 -> Prop)
  (I_S2 : forall A, frames_t A Root -> univD A -> S2 -> Prop).

Definition I_S_prod A (C : frames_t A Root) (e : univD A) : S1 * S2 -> Prop :=
  fun '(s1, s2) => I_S1 C e s1 /\ I_S2 C e s2.

Global Instance Preserves_S_up_prod
         `{H1 : @Preserves_S_up _ (@I_S1)}
         `{H2 : @Preserves_S_up _ (@I_S2)} :
  Preserves_S_up I_S_prod.
Proof.
  unfold I_S_prod; intros A B C C_ok f x [[s1 s2] Hs12].
  assert (Hs1 : «e_map (fun C => I_S1 _ (C >:: f) x s1) C»). { unerase; now (destruct Hs12). }
  assert (Hs2 : «e_map (fun C => I_S2 _ (C >:: f) x s2) C»). { unerase; now (destruct Hs12). }
  pattern s1 in Hs1; pattern s2 in Hs2; apply exist in Hs1; apply exist in Hs2; clear Hs12 s1 s2.
  ltac1:(unshelve eapply preserve_S_up with (f := f) in Hs1); try assumption.
  ltac1:(unshelve eapply preserve_S_up with (f := f) in Hs2); try assumption.
  destruct Hs1 as [s1 Hs1], Hs2 as [s2 Hs2]; exists (s1, s2); unerase; auto.
Defined.

Global Instance Preserves_S_dn_prod
         `{H1 : @Preserves_S_dn _ (@I_S1)}
         `{H2 : @Preserves_S_dn _ (@I_S2)} :
  Preserves_S_dn I_S_prod.
Proof.
  unfold I_S_prod; intros A B C C_ok f x [[s1 s2] Hs12].
  assert (Hs1 : «e_map (fun C => I_S1 _ C (frameD f x) s1) C»). { unerase; now (destruct Hs12). }
  assert (Hs2 : «e_map (fun C => I_S2 _ C (frameD f x) s2) C»). { unerase; now (destruct Hs12). }
  pattern s1 in Hs1; pattern s2 in Hs2; apply exist in Hs1; apply exist in Hs2; clear Hs12 s1 s2.
  ltac1:(unshelve eapply preserve_S_dn with (f := f) in Hs1); try assumption.
  ltac1:(unshelve eapply preserve_S_dn with (f := f) in Hs2); try assumption.
  destruct Hs1 as [s1 Hs1], Hs2 as [s2 Hs2]; exists (s1, s2); unerase; auto.
Defined.

Extraction Inline Preserves_S_up_prod Preserves_S_dn_prod.

End S_prod.

Section FuelAndMetric.

Definition Fuel (fueled : bool) := if fueled then positive else True.

Definition is_empty (fueled : bool) : Fuel fueled -> bool :=
  match fueled with
  | true => fun fuel => match fuel with xH => true | _ => false end
  | false => fun 'I => false
  end.

Definition fuel_dec (fueled : bool) : Fuel fueled -> Fuel fueled :=
  match fueled with
  | true => fun fuel => Pos.pred fuel
  | false => fun fuel => fuel
  end.

Definition lots_of_fuel : positive := (1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1~1)%positive.

Extraction Inline is_empty fuel_dec lots_of_fuel.

Definition Metric (fueled : bool) :=
  if fueled then unit
  else forall A, frames_t A Root -> univD A -> nat.

Definition run_metric (fueled : bool) (metric : Metric fueled)
           (fuel : Fuel fueled) A (C : frames_t A Root) (e : univD A) : nat :=
  match fueled return Fuel fueled -> Metric fueled -> nat with
  | true => fun fuel 'tt => Pos.to_nat fuel
  | false => fun fuel metric => metric A C e
  end fuel metric.

End FuelAndMetric.

(* The type of the rewriter *)
Section Rewriter.

Context
  (* Fueled rewriters use [positive] as fuel parameter *)
  (fueled : bool)
  (Fuel := Fuel fueled)
  (metric : Metric fueled)
  (run_metric := run_metric fueled metric)
  (* One rewriting step *)
  (Rstep : relation (univD Root))
  (* Delayed computation, parameter, and state variable *)
  (D : Set) (I_D : forall (A : U), univD A -> D -> Prop)
  (R : Set) (I_R : forall (A : U), frames_t A Root -> R -> Prop)
  (S : Set) (I_S : forall (A : U), frames_t A Root -> univD A -> S -> Prop)
  `{HDelay : Delayed _ I_D}.

(* The result returned by a rewriter when called with context C and exp e *)
Record result A (C : erased (frames_t A Root)) (e : univD A) : Set := mk_result {
  resTree : univD A;
  resState : State I_S C resTree;
  resProof : «e_map (fun C => clos_refl_trans _ Rstep (C ⟦ e ⟧) (C ⟦ resTree ⟧)) C» }.

Definition rw_for (fuel : Fuel) A (C : erased (frames_t A Root)) (e : univD A) :=
  forall n (eok : e_ok n) (r : Param I_R C) (s : State I_S C e),
  «e_map (fun n => «e_map (fun C => n = run_metric fuel C e) C») n» ->
  result C e.

Definition rewriter' :=
  forall (fuel : Fuel) A (C : erased (frames_t A Root)) (eok : e_ok C) (e : univD A) (d : Delay I_D e),
  rw_for fuel C (delayD d).

Definition res_chain A (C : erased (frames_t A Root)) `{e_ok _ C} (e : univD A) (m : result C e)
           (k : forall e (s : State I_S C e), result C e) : result C e.
Proof.
  destruct m as [e' s' Hrel1]; cbn in k.
  specialize (k e' s'); destruct k as [e'' s'' Hrel2].
  econstructor > [exact s''|unerase; eapply rt_trans; eauto].
Defined.

Extraction Inline res_chain.

End Rewriter.

End Rewriters.


Theorem frobenius (A : Set) (p : A -> Prop) (q : Prop) :
  (exists x : A, q /\ p x) <-> (q /\ exists x : A, p x).

Proof.
  firstorder.
Qed.


(** Author: Alexander Anisimov *)
From mathcomp Require Import ssreflect ssrbool eqtype seq choice.
From libs Require Import edone bcase base fset.

Set Implicit Arguments.
(*Unset Strict Implicit.*)

(** * Automation for finite Sets *)

Section TabRules.

  Variable T: choiceType.

  (** Simplification rules **)

  (** composite set operations and relations **)
  Lemma properSub (A B : {fset T}): A `<` B = (A `<=` B) && ~~ (B `<=` A).
  Proof. rewrite properEneq eqEsub. by case (A`<=`B), (B`<=`A). Qed.
  Lemma sepI (A B : {fset T}) : A `&` B = [fset x in A | x \in B].
  Proof. by rewrite /fsetI. Qed.
  Lemma sepD (A B : {fset T}) : A `\` B = [fset x in A | x \notin B].
  Proof. by rewrite /fsetD. Qed.

  Definition compSetOps := (sepI, sepD, properSub).

  (** ** Tableau rules **)

  (** nonbranching *)

  (** one premise*)
  Lemma prop_dn s : ~~ ~~ s -> s. (*P7*)
  Proof. exact (@ negbNE s). Qed.

  Lemma prop_conj s t : s && t -> s /\ t. (*P1*)
  Proof. apply: andP. Qed.

  Lemma prop_negDisj s t : ~~ (s || t) -> ~~ s /\ ~~ t. (*P5*)
  Proof. rewrite negb_or. apply: andP. Qed.

  Lemma prop_negImpl s t : ~~ (s ==> t) -> s /\ ~~ t. (*P6*)
  Proof. rewrite negb_imply. apply: andP. Qed.

  Lemma satr_eqSym (a b : T) : a == b -> b == a. (*S8*)
  Proof. by rewrite eq_sym. Qed.

  Lemma satr_memSgt (a b : T) : a \in [fset b] -> a == b. (*S9*)
  Proof. by rewrite in_fset1. Qed.

  Lemma satr_nmemSgt (a b : T) : a \notin [fset b] -> a != b. (*S10*)
  Proof. by rewrite in_fset1. Qed.

  Lemma satr_sgtSub (a:T) (A : {fset T}) : [fset a] `<=` A -> a \in A. (*S11*)
  Proof. by rewrite fsub1. Qed.

  Lemma satr_eqP (A B : {fset T}) : A == B -> (A `<=` B) /\ (B `<=` A). (*S4*)
  Proof. rewrite eqEsub. apply: andP. Qed.

  Lemma satr_nmemU (a:T) (A B : {fset T}) : a \notin A `|` B -> a \notin A /\ a \notin B. (*S13*)
  Proof. rewrite in_fsetU negb_or. apply: andP. Qed.

  Lemma pow_mem (A B : {fset T}) : A \in (powerset B) -> A `<=` B. (*Q1*)
  Proof. by rewrite powersetE. Qed.

  (** several premises *)
  Lemma satr_memSub (a:T) (A B : {fset T}) : a \in A -> A `<=` B -> a \in B. (*S1*)
  Proof. move => P Q. apply: (@subP T A) => //. Qed.

  Lemma satr_nmemSup (a:T) (A B : {fset T}) : a \notin A -> B `<=` A -> a \notin B. (*S2*)
  Proof. move => P Q. case R: (a \in B) => //. by rewrite (subP Q) in P. Qed.

  Lemma satr_eqMem (a b : T) (A : {fset T}) : a == b -> b \in A -> a \in A. (*S6*)
  Proof. intros P Q. by rewrite -(eqP P) in Q. Qed.

  Lemma satr_eqTrans (a b c : T) : a == b -> b == c -> a == c. (*S7*)
  Proof. intros P Q. by rewrite -(eqP P) in Q. Qed.

  (** fresh variable generation *)
  Lemma satr_notSub (A B : {fset T}) : ~~ (A `<=` B) -> exists a, (a \in A) /\ (a \notin B). (*S3*)
  Proof. move => P. move: (subPn A B P) => {P} [a P Q]. by exists a. Qed.

  Lemma pow_nmem (A B : {fset T}) : A \notin (powerset B) -> exists x, (x \in A) /\ (x \notin B). (*Q2*)
  Proof. rewrite powersetE => P. apply (satr_notSub A B P). Qed.

  (** branching *)

  Lemma prop_disj s t : s || t -> s \/ t. (*P2*)
  Proof. apply: orP. Qed.

  Lemma prop_impl s t : s ==> t -> ~~ s \/ t. (*P3*)
  Proof. rewrite implybE. apply: orP. Qed.

  Lemma prop_negConj s t : ~~ (s && t) -> ~~ s \/ ~~ t. (*P4*)
  Proof. rewrite negb_and. apply: orP. Qed.

  Lemma satr_memU (a:T) (A B : {fset T}) : a \in A `|` B -> a \in A \/ a \in B. (*S12*)
  Proof. rewrite in_fsetU. apply: orP. Qed.

  Lemma satr_neqP (A B : {fset T}) :
    A != B -> exists x, (x \in A /\ x \notin B) \/ (x \in B /\ x \notin A). (*S5*)
  Proof.
    rewrite eqEsub negb_and => P. move: (orP P) => {P} [P|P].
    - move: (satr_notSub A B P) => {P} [x [P Q]]. exists x; by left.
    - move: (satr_notSub B A P) => {P} [x [P Q]]. exists x; by right.
  Qed.

  (** branch closing *)

  Lemma clos_posNeg (s : bool) : s -> ~~ s -> False. (*D1*)
  Proof. by case s. Qed.

  Lemma clos_neqxx (a : T) : a != a -> False. (*D2*)
  Proof. by rewrite eqxx. Qed.

  Lemma clos_memEmp (a : T) : a \in fset0 -> False. (*D3*)
  Proof. by rewrite in_fset0. Qed.

  (** substitution *)

  Lemma subst_memSep (y:T) (A : {fset T}) (p : T -> bool) : y \in sep A p -> (y \in A) /\ (p y). (*R1*)
  Proof. rewrite in_sep. apply: andP. Qed.

  Lemma subst_nmemSep (y:T) (A : {fset T}) (p : T -> bool):
    y \notin [ fset x in A | p x] -> y \notin A \/ ~~ p y. (*R2*)
  Proof. rewrite in_sep => P . apply: orP. by rewrite -negb_and. Qed.

  (** cut *)

  Lemma cut_eq (a b : T) : a == b \/ a != b.
  Proof. case (a == b); first by left. right. by apply negbT. Qed. (*C1*)

  Lemma cut_mem a (A: {fset T}) : a \in A \/ a \notin A. (*C2*)
  Proof. case (a \in A); first by left. right. by apply negbT. Qed.

  Lemma cut_sub (A B : {fset T}) : A `<=` B \/ ~~ (A `<=` B). (*C3*)
  Proof. case (A `<=` B); first by left. right. by apply negbT. Qed.

End TabRules.

(** ** Implementation of the Tactic *)

(** adding conclusions of diffrerent rule types *)

Ltac extend X PX :=
  let V := fresh "H" in
  let X := constr:(is_true X) in
  match goal with
    | _:  X |- _ => fail 1
    | _ => have V: X by apply PX
  end.

Ltac extend_conj A B PX :=
  let U := fresh "H" in
  let V := fresh "H" in
  let A := (eval simpl in (is_true A)) in
  let B := (eval simpl in (is_true B)) in
  match goal with
    | _: A, _: B |- _ => fail 1
    | _ => have [U V]: A /\ B by apply PX
  end.

Ltac extend_disj A B PX :=
  let V := fresh "H" in
  let A := (eval simpl in (is_true A)) in
  let B := (eval simpl in (is_true B)) in
  match goal with
    | _: A |- _ => fail 1
    | _: B |- _ => fail 1
    | _ => have [V | V]: A \/ B by apply PX
  end.

Ltac extend_conj_ex A B PX :=
  let X := fresh "x" in
  let U := fresh "H" in
  let V := fresh "H" in
  match goal with
    | _: is_true(?x \in A), _: is_true (?x \notin B) |- _ => fail 1
    | _ => have [X [U V]]: exists x, (x \in A) /\ (x \notin B) by apply PX
  end.

Ltac extend_disconj_ex A B PX :=
  let X := fresh "x" in
  let U := fresh "H" in
  let V := fresh "H" in
  match goal with
    | _: is_true(?x \in A), _: is_true(?x \notin B) |- _ => fail 1
    | _: is_true(?x \in B), _: is_true(?x \notin A) |- _ => fail 1
    | _ => have [X [[U V] | [U V]]]:
             exists x, (x \in A /\ x \notin B) \/ (x \in B /\ x \notin A)
               by apply PX
  end.

(** saturation *)

Ltac closebranch :=
  match goal with
  | H0: is_true (?s), H1: is_true(~~ ?s) |- _ => apply (@ clos_posNeg s); first exact H0; exact H1
  | H0: is_true (?a != ?a)               |- _ => apply (@ clos_neqxx _ a); exact H0
  | H0: is_true (?a \in fset0)           |- _ => apply (@ clos_memEmp _ a); exact H0
  end.

Ltac nonbranching :=
  match goal with
  (* one premiss *)
  | _: is_true(~~ ~~ ?s)             |- _ => extend s (prop_dn s)
  | _: is_true(?s && ?t)             |- _ => extend_conj s t (prop_conj s t)
  | _: is_true(~~ (?s || ?t))        |- _ => extend_conj (~~ s) (~~ t) (prop_negDisj s t)
  | _: is_true(~~ (?s ==> ?t))       |- _ => extend_conj s (~~ t) (prop_negImpl s t)
  | _: is_true(?a == ?b)             |- _ => extend (b == a) (satr_eqSym a b)
  | _: is_true(?a \in [fset ?b])     |- _ => extend (a == b) (satr_memSgt _ a b)
  | _: is_true(?a \notin [fset ?b])  |- _ => extend (a != b) (satr_nmemSgt _ a b)
  | _: is_true([fset ?a] `<=` ?A)    |- _ => extend (a \in A) (satr_sgtSub a A)
  | _: is_true(?A == ?B)             |- _ => extend_conj (A `<=` B) (B `<=` A) (satr_eqP A B)
  | _: is_true(?a \notin ?A `|` ?B)  |- _ => extend_conj (a \notin A) (a \notin B) (satr_nmemU a A B)
  | _: is_true(?A \in (powerset ?B)) |- _ => extend (A `<=` B) (pow_mem A B)
  (* several premises *)
  | _: is_true(?a \in ?A), _: is_true(?A `<=` ?B)    |- _ => extend (a \in B) (satr_memSub a A B)
  | _: is_true(?a \notin ?A), _: is_true(?B `<=` ?A) |- _ => extend (a \notin B) (satr_nmemSup a A B)
  | _: is_true(?a == ?b), _: is_true(?b \in ?A)      |- _ => extend (a \in A) (satr_eqMem a b A)
  | _: is_true(?a == ?b), _: is_true(?b == ?c)       |- _ => extend (a == c) (satr_eqTrans _ a b c)
  (* freshvar *)
  | _: is_true(~~ (?A `<=` ?B))         |- _ => extend_conj_ex A B (satr_notSub A B)
  | _: is_true(?A \notin (powerset ?B)) |- _ => extend_conj_ex A B (pow_nmem A B)
  (* substitution *)
  | _: is_true(?a \in sep ?A ?p) |- _ => extend_conj (a \in A) (p a) (subst_memSep a A p)
  end.

Ltac branching :=
  match goal with
  | _: is_true(?s || ?t)            |- _ => extend_disj s t (prop_disj s t)
  | _: is_true(?s ==> ?t)           |- _ => extend_disj (~~ s) t (prop_impl s t)
  | _: is_true(~~ (?s && ?t))       |- _ => extend_disj (~~ s) (~~ t) (prop_negConj s t)
  (* basic saturation *)
  | _: is_true(?a \in ?A `|` ?B)    |- _ => extend_disj (a \in A) (a \in B) (satr_memU a A B)
  | _: is_true(?A != ?B)            |- _ => extend_disconj_ex A B (satr_neqP A B)
  (*substitution *)
  | _: is_true(?a \notin sep ?A ?p) |- _ => extend_disj (a \notin A) (~~ (p a)) (subst_nmemSep a A p)
  end.

Ltac cutrules :=
  match goal with
  | _: context[?a], _: context[?A] |- _ => extend_disj (a \in A) (a \notin A) (cut_mem a A)
  | _: context[?A], _: context[?B] |- _ => extend_disj (A `<=` B) (~~(A `<=` B)) (cut_sub A B)
  | _: context[?A], _: context[?B] |- _ => extend_disj (A == B) (A != B) (cut_eq _ A B)
  end.

(** form control *)

Ltac reverywhere X :=
  repeat rewrite X;
  repeat match goal with
           | H: _ |- _ => rewrite X in H
         end.

Ltac genSubst :=
  repeat (
      let V := fresh "su" in
      match goal with
        | H: is_true(?x == ?y) |- _ =>
          match goal with
            | _: x = y |- _ => fail 1
            | _ => move: (eqP H) => V
          end
        | x := _ |- _ => subst x
      end
    ); subst.

Ltac clearNonbools :=
  repeat(
      match goal with
      | H : _ |- _ =>
        match type of H with
        | is_true _ => fail 1
        | _ = _ => fail 1
        | _ => clear H
        end
      end
    ).

(** preprocessing *)

Lemma semiDN (b:bool) : ~ ~~ b -> b.
Proof. case: b => _ //. Qed.

Lemma eq2bool (T : eqType) (a b : T) : a = b -> a == b.
Proof. move => H. by rewrite H. Qed.

Ltac oDN :=
  let V := fresh "H" in
  match goal with
  | |- is_true _ => apply semiDN; hnf => V
  | |- _ = _ => apply:eqP; apply semiDN; hnf => V
  | |- False => idtac
  end.

Ltac eq2bool :=
  let V := fresh "H" in
  match goal with
  | H: _ = _ |- _ => move:(eq2bool _ H) => V
  | _ => idtac
  end.

Ltac preproc :=
  repeat (let V := fresh "H" in move => V);
  oDN;
  eq2bool;
  reverywhere compSetOps;
  clearNonbools.

(** automated saturation without cuts *)

Ltac core :=
  repeat(
      genSubst;
      repeat nonbranching;
      try closebranch;
      genSubst;
      try branching;
      try closebranch
    ).

(** ** User-level Tactics *)

Ltac fset_dec :=
  preproc;
  repeat(
      try closebranch;
      core;
      try cutrules
    ).

(** omits cut rules *)
Ltac fset_nocut := preproc; try closebranch; core.

Ltac invert X :=
  match X with
    | (?x, ?y) =>
      match x with
        | (?x0, ?x1) => let z := invert (x0, (x1, y)) in constr:(z)
      end
    | _ => constr:(X)
  end.

(** unfolds all definitions given in a tuple before applying fset_dec *)
Ltac fset_decu X :=
  let Y := invert X in
  match Y with
    | (?x, ?xs) => unfold x in *; fset_decu xs
    | ?x => unfold x in *; fset_dec
  end.

(** omits cut rules and unfolds definitions *)
Ltac fset_nocutu X :=
  let Y := invert X in
  match Y with
    | (?x, ?xs) => unfold x in *; fset_nocutu xs
    | ?x => unfold x in *; fset_nocut
  end.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************)
(*               Typed LambdaFactor Calculus                          *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus  from Project Coq                                  *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                      Unstar.v                                      *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import List.
Require Import Max.
Require Import Test.
Require Import General.
Require Import LamSF_Terms.
Require Import LamSF_Substitution_term.
Require Import LamSF_Tactics.
Require Import Components.
Require Import Compounds.
Require Import LamSF_reduction.
Require Import LamSF_Normal.
Require Import LamSF_Closed.
Require Import LamSF_Eval.
Require Import type_derivation.
Require Import type_derivation_resi.
Require Import operator_types.
Require Import subject_reduction.
Require Import Equal.

Definition id_type := Abs (funty (Ref 0) (Ref 0)).

Definition ref := Ref.
Definition ap := App .
Definition abs := Abs.
Definition abs_S := (abs (abs (abs (ap (ap (ref 2) (ref 0)) (ap (ref 1) (ref 0)))))) .
Definition abs_K := (abs (abs (ref 1))).
Definition abs_I := (abs (ref 0)).
Definition abs_KI := (abs (abs (ref 0))).

Lemma abs_S_type : derivation nil abs_S (opty Sop).
Proof.
unfold abs_S; unfold_opty; unfold abs, ap.
repeat eapply derive_gen1.  simpl.
repeat eapply derive_abs.
repeat eapply derive_app; var_tac.
Qed.

Lemma abs_K_type : derivation nil abs_K (opty Kop).
Proof.
unfold abs_K; unfold_opty; unfold abs, ap.
repeat eapply derive_gen1.  simpl.
repeat eapply derive_abs.
repeat eapply derive_app; var_tac.
Qed.

Definition abs_A u := Abs (Abs (App u (App (Ref 1) (Ref 0)))).

Lemma abs_A_type : derivation (cons id_type nil) (abs_A (Ref 2)) (opty Aop).
Proof.
unfold abs_A; unfold_opty.
repeat eapply derive_gen1.
unfold lift; simpl; repeat rewrite lift_rec_closed; try (split_all; omega).
unfold relocate; simpl.
repeat eapply derive_abs.
repeat eapply derive_app.
eapply derive_instance.
derive_tac.
eapply succ_red. eapply instance_rule.
2: wfcs_tac. instantiate(1:= varty 1).
wfcs_tac.
unfold subst; simpl. insert_Ref_out.
repeat rewrite lift_rec_null. eapply2 zero_red. derive_tac. derive_tac.
Qed.

(* unstar *)

Definition unstar_fn :=
Abs (App g_op
(App (App (Op DAop) (abs_A (Ref 2)))
(App (App (Op DKop) abs_K)
(App g_op (App (App (Op DSop) abs_S) i_op)))))
.

Definition unstar := App (App a_op y_op) unstar_fn.

(*
Definition unstar_fn :=
Abs (Abs (App (App (App is_abs (Ref 0))
                   (App (Abs (Abs (App (Ref 3) (App (Ref 1) (Ref 0))))) (Ref 0)))
              (App (App (App f_op (Ref 0)) (Ref 0))
                   (Abs (Abs (App (App (App f_op (Ref 1))
                                       (App (App d_op (Ref 1)) (Ref 0)))
                                   (Abs (Abs (App (App (App d_op (Ref 1))
                                                       (App (Ref 5) (Ref 0)))
                                                  (App (Ref 5) (Ref 2)))))))))))
.

Definition unstar := App (App a_op y_op) unstar_fn.
*)

Proposition unstar_type: derivation nil unstar (Abs (funty (varty 0) (varty 0))).
Proof.
unfold unstar.
eapply derive_app.
eapply derive_app.
eapply derive_A.
wfcs_tac.
2: wfcs_tac.
2: eapply derive_Y.
wfcs_tac.
wfcs_tac.
wfcs_tac.
unfold unstar_fn.
eapply derive_abs.
eapply derive_gen1.
unfold lift; simpl. relocate_lt.
eapply derive_app.
eapply derive_G.
wfcs_tac.
wfcs_tac.
wfcs_tac.
eapply derive_gen1.
unfold lift; simpl. relocate_lt. simpl.
eapply derive_app.
eapply derive_app.
eapply derive_DA.
wfcs_tac.
wfcs_tac.
eapply abs_A_type.
eapply derive_app.
eapply derive_app.
eapply derive_DK.
wfcs_tac.
wfcs_tac.
eapply derive_nil.
eapply abs_K_type.
wfcs_tac.
eapply derive_app.
eapply derive_G.
wfcs_tac. wfcs_tac. wfcs_tac.
eapply derive_gen1.
unfold lift; simpl. relocate_lt; simpl.
eapply derive_app.
eapply derive_app.
eapply derive_DS.
wfcs_tac.
wfcs_tac.
eapply derive_nil.
eapply abs_S_type.
wfcs_tac.
eapply2 derive_I; wfcs_tac.
Qed.

Theorem unstar_star : forall M, normal M -> lamSF_red (App unstar (star M)) (Abs M).
Proof.
rank_tac.
induction M; split_all.
(* 4 *)
case n; split_all.
(* 5 *)
unfold unstar. eval_lamSF.
eapply transitive_red.
eapply preserves_app_lamSF_red.
red; one_step.
eauto.
unfold unstar_fn at 1.
eval_lamSF.
g_tac.
unfold factorable; simpl in *; auto 20.
simpl.
insert_Ref_out.
eapply transitive_red.
eapply preserves_app_lamSF_red.
eapply succ_red.
eapply da_oth_lamSF_red.
unfold factorable; simpl in *; auto 20.
discriminate.
eapply succ_red.
eapply dk_oth_lamSF_red.
unfold factorable; simpl in *; auto 20.
discriminate.
g_tac.
unfold factorable; simpl in *; auto 20.
simpl.
eapply transitive_red.
eapply preserves_app_lamSF_red.
eapply succ_red.
eapply ds_s_lamSF_red.
eauto.
eauto.
eval_lamSF.
eauto.
eauto.
eval_lamSF.
eapply preserves_abs_lamSF_red.
eval_lamSF.
(* 4 *)
unfold unstar. eval_lamSF.
eapply transitive_red.
eapply preserves_app_lamSF_red.
red; one_step.
eauto.
unfold unstar_fn at 1.
eval_lamSF.
g_tac.
unfold factorable; simpl in *; auto 20.
simpl.
insert_Ref_out.
eapply transitive_red.
eapply preserves_app_lamSF_red.
eapply succ_red.
eapply da_oth_lamSF_red.
unfold factorable; simpl in *; auto 20.
discriminate.
eapply succ_red.
eapply dk_k_lamSF_red.
unfold factorable; simpl in *; auto 20.
eauto.
eval_lamSF.
eapply preserves_abs_lamSF_red.
relocate_lt. simpl; auto.
unfold lift; split_all. relocate_lt. auto.
(* 3 *)
unfold unstar. eval_lamSF.
eapply transitive_red.
eapply preserves_app_lamSF_red.
red; one_step.
eauto.
unfold unstar_fn at 1.
eval_lamSF.
g_tac.
unfold factorable; simpl in *; auto 20.
simpl.
insert_Ref_out.
eapply transitive_red.
eapply preserves_app_lamSF_red.
eapply succ_red.
eapply da_oth_lamSF_red.
unfold factorable; simpl in *; auto 20.
discriminate.
eapply succ_red.
eapply dk_k_lamSF_red.
eauto.
eauto.
eval_lamSF.
auto.
(* 2 *)
unfold unstar. eval_lamSF. eval_lamSF.
unfold unstar_fn at 1.
eval_lamSF.
g_tac.
unfold factorable; simpl in *; auto 20.
simpl.
insert_Ref_out.
eapply transitive_red.
eapply preserves_app_lamSF_red.
eapply2 succ_red.
auto.
eval_lamSF.
eapply preserves_abs_lamSF_red.
eapply transitive_red.
eapply preserves_app_lamSF_red.
instantiate(1:= unstar). auto.
unfold lift; simpl. eval_lamSF.
rewrite subst_rec_lift_rec2.
eapply2 IHp.
omega.
inversion H0; auto.
(* 1 *)
unfold unstar. eval_lamSF.
eapply transitive_red.
eapply preserves_app_lamSF_red.
red; one_step.
eauto.
unfold unstar_fn at 1.
eval_lamSF.
g_tac.
unfold factorable; simpl in *; auto 20.
simpl.
insert_Ref_out.
eapply transitive_red.
eapply preserves_app_lamSF_red.
eapply succ_red.
eapply da_oth_lamSF_red.
unfold factorable; simpl in *; auto 20.
discriminate.
eapply succ_red.
eapply dk_oth_lamSF_red.
unfold factorable; simpl in *; auto 20.
discriminate.
g_tac.
unfold factorable; simpl in *; auto 20.
eapply transitive_red.
eapply preserves_app_lamSF_red.
simpl. eapply succ_red.
eapply ds_s_lamSF_red.
eauto.
simpl. eauto. eval_lamSF.
eauto. eauto. eval_lamSF.
eapply preserves_abs_lamSF_red.
rewrite subst_rec_lift_rec; try omega.
eapply transitive_red.
eapply preserves_app_lamSF_red.
eval_lamSF.
unfold lift; simpl. eval_lamSF.
repeat rewrite subst_rec_lift_rec2.
auto.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.

(* Why3 assumption *)
Definition unit  := unit.

(* Why3 assumption *)
Inductive datatype  :=
  | Tint : datatype
  | Tbool : datatype .

(* Why3 assumption *)
Inductive operator  :=
  | Oplus : operator
  | Ominus : operator
  | Omult : operator
  | Ole : operator .

(* Why3 assumption *)
Definition ident  := Z.

(* Why3 assumption *)
Inductive term  :=
  | Tconst : Z -> term
  | Tvar : Z -> term
  | Tderef : Z -> term
  | Tbin : term -> operator -> term -> term .

(* Why3 assumption *)
Inductive fmla  :=
  | Fterm : term -> fmla
  | Fand : fmla -> fmla -> fmla
  | Fnot : fmla -> fmla
  | Fimplies : fmla -> fmla -> fmla
  | Flet : Z -> term -> fmla -> fmla
  | Fforall : Z -> datatype -> fmla -> fmla .

(* Why3 assumption *)
Inductive value  :=
  | Vint : Z -> value
  | Vbool : bool -> value .

Parameter map : forall (a:Type) (b:Type), Type.

Parameter get: forall (a:Type) (b:Type), (map a b) -> a -> b.
Implicit Arguments get.

Parameter set: forall (a:Type) (b:Type), (map a b) -> a -> b -> (map a b).
Implicit Arguments set.

Axiom Select_eq : forall (a:Type) (b:Type), forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (a1 = a2) -> ((get (set m a1 b1)
  a2) = b1).

Axiom Select_neq : forall (a:Type) (b:Type), forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (~ (a1 = a2)) -> ((get (set m a1 b1)
  a2) = (get m a2)).

Parameter const: forall (a:Type) (b:Type), b -> (map a b).
Set Contextual Implicit.
Implicit Arguments const.
Unset Contextual Implicit.

Axiom Const : forall (a:Type) (b:Type), forall (b1:b) (a1:a),
  ((get (const b1:(map a b)) a1) = b1).

(* Why3 assumption *)
Definition env  := (map Z value).

Parameter eval_bin: value -> operator -> value -> value.

Axiom eval_bin_def : forall (x:value) (op:operator) (y:value), match (x,
  y) with
  | ((Vint x1), (Vint y1)) =>
      match op with
      | Oplus => ((eval_bin x op y) = (Vint (x1 + y1)%Z))
      | Ominus => ((eval_bin x op y) = (Vint (x1 - y1)%Z))
      | Omult => ((eval_bin x op y) = (Vint (x1 * y1)%Z))
      | Ole => ((x1 <= y1)%Z -> ((eval_bin x op y) = (Vbool true))) /\
          ((~ (x1 <= y1)%Z) -> ((eval_bin x op y) = (Vbool false)))
      end
  | (_, _) => ((eval_bin x op y) = (Vbool false))
  end.

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint eval_term(sigma:(map Z value)) (pi:(map Z value))
  (t:term) {struct t}: value :=
  match t with
  | (Tconst n) => (Vint n)
  | (Tvar id) => (get pi id)
  | (Tderef id) => (get sigma id)
  | (Tbin t1 op t2) => (eval_bin (eval_term sigma pi t1) op (eval_term sigma
      pi t2))
  end.
Unset Implicit Arguments.

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint eval_fmla(sigma:(map Z value)) (pi:(map Z value))
  (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm t) => ((eval_term sigma pi t) = (Vbool true))
  | (Fand f1 f2) => (eval_fmla sigma pi f1) /\ (eval_fmla sigma pi f2)
  | (Fnot f1) => ~ (eval_fmla sigma pi f1)
  | (Fimplies f1 f2) => (eval_fmla sigma pi f1) -> (eval_fmla sigma pi f2)
  | (Flet x t f1) => (eval_fmla sigma (set pi x (eval_term sigma pi t)) f1)
  | (Fforall x Tint f1) => forall (n:Z), (eval_fmla sigma (set pi x (Vint n))
      f1)
  | (Fforall x Tbool f1) => forall (b:bool), (eval_fmla sigma (set pi x
      (Vbool b)) f1)
  end.
Unset Implicit Arguments.

Parameter subst_term: term -> Z -> Z -> term.

Axiom subst_term_def : forall (e:term) (r:Z) (v:Z),
  match e with
  | (Tconst _) => ((subst_term e r v) = e)
  | (Tvar _) => ((subst_term e r v) = e)
  | (Tderef x) => ((r = x) -> ((subst_term e r v) = (Tvar v))) /\
      ((~ (r = x)) -> ((subst_term e r v) = e))
  | (Tbin e1 op e2) => ((subst_term e r v) = (Tbin (subst_term e1 r v) op
      (subst_term e2 r v)))
  end.

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint fresh_in_term(id:Z) (t:term) {struct t}: Prop :=
  match t with
  | (Tconst _) => True
  | (Tvar v) => ~ (id = v)
  | (Tderef _) => True
  | (Tbin t1 _ t2) => (fresh_in_term id t1) /\ (fresh_in_term id t2)
  end.
Unset Implicit Arguments.

Axiom eval_subst_term : forall (sigma:(map Z value)) (pi:(map Z value))
  (e:term) (x:Z) (v:Z), (fresh_in_term v e) -> ((eval_term sigma pi
  (subst_term e x v)) = (eval_term (set sigma x (get pi v)) pi e)).

Axiom eval_term_change_free : forall (t:term) (sigma:(map Z value)) (pi:(map
  Z value)) (id:Z) (v:value), (fresh_in_term id t) -> ((eval_term sigma
  (set pi id v) t) = (eval_term sigma pi t)).

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint fresh_in_fmla(id:Z) (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm e) => (fresh_in_term id e)
  | ((Fand f1 f2)|(Fimplies f1 f2)) => (fresh_in_fmla id f1) /\
      (fresh_in_fmla id f2)
  | (Fnot f1) => (fresh_in_fmla id f1)
  | (Flet y t f1) => (~ (id = y)) /\ ((fresh_in_term id t) /\
      (fresh_in_fmla id f1))
  | (Fforall y ty f1) => (~ (id = y)) /\ (fresh_in_fmla id f1)
  end.
Unset Implicit Arguments.

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint subst(f:fmla) (x:Z) (v:Z) {struct f}: fmla :=
  match f with
  | (Fterm e) => (Fterm (subst_term e x v))
  | (Fand f1 f2) => (Fand (subst f1 x v) (subst f2 x v))
  | (Fnot f1) => (Fnot (subst f1 x v))
  | (Fimplies f1 f2) => (Fimplies (subst f1 x v) (subst f2 x v))
  | (Flet y t f1) => (Flet y (subst_term t x v) (subst f1 x v))
  | (Fforall y ty f1) => (Fforall y ty (subst f1 x v))
  end.
Unset Implicit Arguments.

Axiom eval_subst : forall (f:fmla) (sigma:(map Z value)) (pi:(map Z value))
  (x:Z) (v:Z), (fresh_in_fmla v f) -> ((eval_fmla sigma pi (subst f x v)) <->
  (eval_fmla (set sigma x (get pi v)) pi f)).

Axiom eval_swap : forall (f:fmla) (sigma:(map Z value)) (pi:(map Z value))
  (id1:Z) (id2:Z) (v1:value) (v2:value), (~ (id1 = id2)) -> ((eval_fmla sigma
  (set (set pi id1 v1) id2 v2) f) <-> (eval_fmla sigma (set (set pi id2 v2)
  id1 v1) f)).

Axiom eval_change_free : forall (f:fmla) (sigma:(map Z value)) (pi:(map Z
  value)) (id:Z) (v:value), (fresh_in_fmla id f) -> ((eval_fmla sigma (set pi
  id v) f) <-> (eval_fmla sigma pi f)).

(* Why3 assumption *)
Inductive stmt  :=
  | Sskip : stmt
  | Sassign : Z -> term -> stmt
  | Sseq : stmt -> stmt -> stmt
  | Sif : term -> stmt -> stmt -> stmt
  | Sassert : fmla -> stmt
  | Swhile : term -> fmla -> stmt -> stmt .

Axiom check_skip : forall (s:stmt), (s = Sskip) \/ ~ (s = Sskip).

(* Why3 assumption *)
Inductive one_step : (map Z value) -> (map Z value) -> stmt -> (map Z value)
  -> (map Z value) -> stmt -> Prop :=
  | one_step_assign : forall (sigma:(map Z value)) (pi:(map Z value)) (x:Z)
      (e:term), (one_step sigma pi (Sassign x e) (set sigma x
      (eval_term sigma pi e)) pi Sskip)
  | one_step_seq : forall (sigma:(map Z value)) (pi:(map Z value))
      (sigma':(map Z value)) (pi':(map Z value)) (i1:stmt) (i1':stmt)
      (i2:stmt), (one_step sigma pi i1 sigma' pi' i1') -> (one_step sigma pi
      (Sseq i1 i2) sigma' pi' (Sseq i1' i2))
  | one_step_seq_skip : forall (sigma:(map Z value)) (pi:(map Z value))
      (i:stmt), (one_step sigma pi (Sseq Sskip i) sigma pi i)
  | one_step_if_true : forall (sigma:(map Z value)) (pi:(map Z value))
      (e:term) (i1:stmt) (i2:stmt), ((eval_term sigma pi
      e) = (Vbool true)) -> (one_step sigma pi (Sif e i1 i2) sigma pi i1)
  | one_step_if_false : forall (sigma:(map Z value)) (pi:(map Z value))
      (e:term) (i1:stmt) (i2:stmt), ((eval_term sigma pi
      e) = (Vbool false)) -> (one_step sigma pi (Sif e i1 i2) sigma pi i2)
  | one_step_assert : forall (sigma:(map Z value)) (pi:(map Z value))
      (f:fmla), (eval_fmla sigma pi f) -> (one_step sigma pi (Sassert f)
      sigma pi Sskip)
  | one_step_while_true : forall (sigma:(map Z value)) (pi:(map Z value))
      (e:term) (inv:fmla) (i:stmt), (eval_fmla sigma pi inv) ->
      (((eval_term sigma pi e) = (Vbool true)) -> (one_step sigma pi
      (Swhile e inv i) sigma pi (Sseq i (Swhile e inv i))))
  | one_step_while_false : forall (sigma:(map Z value)) (pi:(map Z value))
      (e:term) (inv:fmla) (i:stmt), (eval_fmla sigma pi inv) ->
      (((eval_term sigma pi e) = (Vbool false)) -> (one_step sigma pi
      (Swhile e inv i) sigma pi Sskip)).

(* Why3 assumption *)
Inductive many_steps : (map Z value) -> (map Z value) -> stmt -> (map Z
  value) -> (map Z value) -> stmt -> Z -> Prop :=
  | many_steps_refl : forall (sigma:(map Z value)) (pi:(map Z value))
      (i:stmt), (many_steps sigma pi i sigma pi i 0%Z)
  | many_steps_trans : forall (sigma1:(map Z value)) (pi1:(map Z value))
      (sigma2:(map Z value)) (pi2:(map Z value)) (sigma3:(map Z value))
      (pi3:(map Z value)) (i1:stmt) (i2:stmt) (i3:stmt) (n:Z),
      (one_step sigma1 pi1 i1 sigma2 pi2 i2) -> ((many_steps sigma2 pi2 i2
      sigma3 pi3 i3 n) -> (many_steps sigma1 pi1 i1 sigma3 pi3 i3
      (n + 1%Z)%Z)).

Axiom steps_non_neg : forall (sigma1:(map Z value)) (pi1:(map Z value))
  (sigma2:(map Z value)) (pi2:(map Z value)) (i1:stmt) (i2:stmt) (n:Z),
  (many_steps sigma1 pi1 i1 sigma2 pi2 i2 n) -> (0%Z <= n)%Z.

Axiom many_steps_seq : forall (sigma1:(map Z value)) (pi1:(map Z value))
  (sigma3:(map Z value)) (pi3:(map Z value)) (i1:stmt) (i2:stmt) (n:Z),
  (many_steps sigma1 pi1 (Sseq i1 i2) sigma3 pi3 Sskip n) ->
  exists sigma2:(map Z value), exists pi2:(map Z value), exists n1:Z,
  exists n2:Z, (many_steps sigma1 pi1 i1 sigma2 pi2 Sskip n1) /\
  ((many_steps sigma2 pi2 i2 sigma3 pi3 Sskip n2) /\
  (n = ((1%Z + n1)%Z + n2)%Z)).

(* Why3 assumption *)
Definition valid_fmla(p:fmla): Prop := forall (sigma:(map Z value)) (pi:(map
  Z value)), (eval_fmla sigma pi p).

(* Why3 assumption *)
Definition valid_triple(p:fmla) (i:stmt) (q:fmla): Prop := forall (sigma:(map
  Z value)) (pi:(map Z value)), (eval_fmla sigma pi p) -> forall (sigma':(map
  Z value)) (pi':(map Z value)) (n:Z), (many_steps sigma pi i sigma' pi'
  Sskip n) -> (eval_fmla sigma' pi' q).

Parameter set1 : forall (a:Type), Type.

Parameter mem: forall (a:Type), a -> (set1 a) -> Prop.
Implicit Arguments mem.

(* Why3 assumption *)
Definition infix_eqeq (a:Type)(s1:(set1 a)) (s2:(set1 a)): Prop :=
  forall (x:a), (mem x s1) <-> (mem x s2).
Implicit Arguments infix_eqeq.

Axiom extensionality : forall (a:Type), forall (s1:(set1 a)) (s2:(set1 a)),
  (infix_eqeq s1 s2) -> (s1 = s2).

(* Why3 assumption *)
Definition subset (a:Type)(s1:(set1 a)) (s2:(set1 a)): Prop := forall (x:a),
  (mem x s1) -> (mem x s2).
Implicit Arguments subset.

Axiom subset_trans : forall (a:Type), forall (s1:(set1 a)) (s2:(set1 a))
  (s3:(set1 a)), (subset s1 s2) -> ((subset s2 s3) -> (subset s1 s3)).

Parameter empty: forall (a:Type), (set1 a).
Set Contextual Implicit.
Implicit Arguments empty.
Unset Contextual Implicit.

(* Why3 assumption *)
Definition is_empty (a:Type)(s:(set1 a)): Prop := forall (x:a), ~ (mem x s).
Implicit Arguments is_empty.

Axiom empty_def1 : forall (a:Type), (is_empty (empty :(set1 a))).

Parameter add: forall (a:Type), a -> (set1 a) -> (set1 a).
Implicit Arguments add.

Axiom add_def1 : forall (a:Type), forall (x:a) (y:a), forall (s:(set1 a)),
  (mem x (add y s)) <-> ((x = y) \/ (mem x s)).

Parameter remove: forall (a:Type), a -> (set1 a) -> (set1 a).
Implicit Arguments remove.

Axiom remove_def1 : forall (a:Type), forall (x:a) (y:a) (s:(set1 a)), (mem x
  (remove y s)) <-> ((~ (x = y)) /\ (mem x s)).

Axiom subset_remove : forall (a:Type), forall (x:a) (s:(set1 a)),
  (subset (remove x s) s).

Parameter union: forall (a:Type), (set1 a) -> (set1 a) -> (set1 a).
Implicit Arguments union.

Axiom union_def1 : forall (a:Type), forall (s1:(set1 a)) (s2:(set1 a)) (x:a),
  (mem x (union s1 s2)) <-> ((mem x s1) \/ (mem x s2)).

Parameter inter: forall (a:Type), (set1 a) -> (set1 a) -> (set1 a).
Implicit Arguments inter.

Axiom inter_def1 : forall (a:Type), forall (s1:(set1 a)) (s2:(set1 a)) (x:a),
  (mem x (inter s1 s2)) <-> ((mem x s1) /\ (mem x s2)).

Parameter diff: forall (a:Type), (set1 a) -> (set1 a) -> (set1 a).
Implicit Arguments diff.

Axiom diff_def1 : forall (a:Type), forall (s1:(set1 a)) (s2:(set1 a)) (x:a),
  (mem x (diff s1 s2)) <-> ((mem x s1) /\ ~ (mem x s2)).

Axiom subset_diff : forall (a:Type), forall (s1:(set1 a)) (s2:(set1 a)),
  (subset (diff s1 s2) s1).

Parameter choose: forall (a:Type), (set1 a) -> a.
Implicit Arguments choose.

Axiom choose_def : forall (a:Type), forall (s:(set1 a)), (~ (is_empty s)) ->
  (mem (choose s) s).

Parameter all: forall (a:Type), (set1 a).
Set Contextual Implicit.
Implicit Arguments all.
Unset Contextual Implicit.

Axiom all_def : forall (a:Type), forall (x:a), (mem x (all :(set1 a))).

(* Why3 assumption *)
Definition assigns(sigma:(map Z value)) (a:(set1 Z)) (sigma':(map Z
  value)): Prop := forall (i:Z), (~ (mem i a)) -> ((get sigma
  i) = (get sigma' i)).

Axiom assigns_refl : forall (sigma:(map Z value)) (a:(set1 Z)),
  (assigns sigma a sigma).

Axiom assigns_trans : forall (sigma1:(map Z value)) (sigma2:(map Z value))
  (sigma3:(map Z value)) (a:(set1 Z)), ((assigns sigma1 a sigma2) /\
  (assigns sigma2 a sigma3)) -> (assigns sigma1 a sigma3).

Axiom assigns_union_left : forall (sigma:(map Z value)) (sigma':(map Z
  value)) (s1:(set1 Z)) (s2:(set1 Z)), (assigns sigma s1 sigma') ->
  (assigns sigma (union s1 s2) sigma').

Axiom assigns_union_right : forall (sigma:(map Z value)) (sigma':(map Z
  value)) (s1:(set1 Z)) (s2:(set1 Z)), (assigns sigma s2 sigma') ->
  (assigns sigma (union s1 s2) sigma').

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint stmt_writes(i:stmt) (w:(set1 Z)) {struct i}: Prop :=
  match i with
  | (Sskip|(Sassert _)) => True
  | (Sassign id _) => (mem id w)
  | ((Sseq s1 s2)|(Sif _ s1 s2)) => (stmt_writes s1 w) /\ (stmt_writes s2 w)
  | (Swhile _ _ s) => (stmt_writes s w)
  end.
Unset Implicit Arguments.

(* Why3 goal *)
Theorem WP_parameter_compute_writes : forall (s:stmt),
  match s with
  | Sskip => True
  | (Sassign i _) => True
  | (Sseq s1 s2) => True
  | (Sif _ s1 s2) => forall (o:(set1 Z)), (forall (sigma:(map Z value))
      (pi:(map Z value)) (sigma':(map Z value)) (pi':(map Z value)) (n:Z),
      (many_steps sigma pi s2 sigma' pi' Sskip n) -> (assigns sigma o
      sigma')) -> forall (o1:(set1 Z)), (forall (sigma:(map Z value))
      (pi:(map Z value)) (sigma':(map Z value)) (pi':(map Z value)) (n:Z),
      (many_steps sigma pi s1 sigma' pi' Sskip n) -> (assigns sigma o1
      sigma')) -> forall (sigma:(map Z value)) (pi:(map Z value))
      (sigma':(map Z value)) (pi':(map Z value)) (n:Z), (many_steps sigma pi
      s sigma' pi' Sskip n) -> (assigns sigma (union o1 o) sigma')
  | (Swhile _ _ s1) => True
  | (Sassert _) => True
  end.
destruct s; intuition.
inversion H1; subst; clear H1.
inversion H2; subst; clear H2.
apply assigns_union_left.
eapply H0; eauto.
apply assigns_union_right.
eapply H; eauto.
Qed.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
Copyright (C) 2009-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library 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
COPYING file for more details.
*)

(** * Rounding to nearest, ties to even: existence, unicity... *)

From Coq Require Import ZArith Reals Lia.

Require Import Zaux Raux Defs Round_pred Generic_fmt Float_prop Ulp.

Notation ZnearestE := (Znearest (fun x => negb (Z.even x))).

Section Fcore_rnd_NE.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.

Context { valid_exp : Valid_exp fexp }.

Notation format := (generic_format beta fexp).
Notation canonical := (canonical beta fexp).

Definition NE_prop (_ : R) f :=
  exists g : float beta, f = F2R g /\ canonical g /\ Z.even (Fnum g) = true.

Definition Rnd_NE_pt :=
  Rnd_NG_pt format NE_prop.

Definition DN_UP_parity_pos_prop :=
  forall x xd xu,
  (0 < x)%R ->
  ~ format x ->
  canonical xd ->
  canonical xu ->
  F2R xd = round beta fexp Zfloor x ->
  F2R xu = round beta fexp Zceil x ->
  Z.even (Fnum xu) = negb (Z.even (Fnum xd)).

Definition DN_UP_parity_prop :=
  forall x xd xu,
  ~ format x ->
  canonical xd ->
  canonical xu ->
  F2R xd = round beta fexp Zfloor x ->
  F2R xu = round beta fexp Zceil x ->
  Z.even (Fnum xu) = negb (Z.even (Fnum xd)).

Lemma DN_UP_parity_aux :
  DN_UP_parity_pos_prop ->
  DN_UP_parity_prop.
Proof.
intros Hpos x xd xu Hfx Hd Hu Hxd Hxu.
destruct (total_order_T 0 x) as [[Hx|Hx]|Hx].
(* . *)
exact (Hpos x xd xu Hx Hfx Hd Hu Hxd Hxu).
elim Hfx.
rewrite <- Hx.
apply generic_format_0.
(* . *)
assert (Hx': (0 < -x)%R).
apply Ropp_lt_cancel.
now rewrite Ropp_involutive, Ropp_0.
destruct xd as (md, ed).
destruct xu as (mu, eu).
simpl.
rewrite <- (Bool.negb_involutive (Z.even mu)).
apply f_equal.
apply sym_eq.
rewrite <- (Z.even_opp mu), <- (Z.even_opp md).
change (Z.even (Fnum (Float beta (-md) ed)) = negb (Z.even (Fnum (Float beta (-mu) eu)))).
apply (Hpos (-x)%R _ _ Hx').
intros H.
apply Hfx.
rewrite <- Ropp_involutive.
now apply generic_format_opp.
now apply canonical_opp.
now apply canonical_opp.
rewrite round_DN_opp, F2R_Zopp.
now apply f_equal.
rewrite round_UP_opp, F2R_Zopp.
now apply f_equal.
Qed.

Class Exists_NE :=
  exists_NE : Z.even beta = false \/ forall e,
  ((fexp e < e)%Z -> (fexp (e + 1) < e)%Z) /\ ((e <= fexp e)%Z -> fexp (fexp e + 1) = fexp e).

Context { exists_NE_ : Exists_NE }.

Theorem DN_UP_parity_generic_pos :
  DN_UP_parity_pos_prop.
Proof with auto with typeclass_instances.
intros x xd xu H0x Hfx Hd Hu Hxd Hxu.
destruct (mag beta x) as (ex, Hexa).
specialize (Hexa (Rgt_not_eq _ _ H0x)).
generalize Hexa. intros Hex.
rewrite (Rabs_pos_eq _ (Rlt_le _ _ H0x)) in Hex.
destruct (Zle_or_lt ex (fexp ex)) as [Hxe|Hxe].
(* small x *)
assert (Hd3 : Fnum xd = Z0).
apply eq_0_F2R with beta (Fexp xd).
change (F2R xd = R0).
rewrite Hxd.
apply round_DN_small_pos with (1 := Hex) (2 := Hxe).
assert (Hu3 : xu = Float beta (1 * Zpower beta (fexp ex - fexp (fexp ex + 1))) (fexp (fexp ex + 1))).
apply canonical_unique with (1 := Hu).
apply (f_equal fexp).
rewrite <- F2R_change_exp.
now rewrite F2R_bpow, mag_bpow.
now apply valid_exp.
rewrite <- F2R_change_exp.
rewrite F2R_bpow.
apply sym_eq.
rewrite Hxu.
apply sym_eq.
apply round_UP_small_pos with (1 := Hex) (2 := Hxe).
now apply valid_exp.
rewrite Hd3, Hu3.
rewrite Zmult_1_l.
simpl.
destruct exists_NE_ as [H|H].
apply Zeven_Zpower_odd with (2 := H).
apply Zle_minus_le_0.
now apply valid_exp.
rewrite (proj2 (H ex)).
now rewrite Zminus_diag.
exact Hxe.
(* large x *)
assert (Hd4: (bpow (ex - 1) <= Rabs (F2R xd) < bpow ex)%R).
rewrite Rabs_pos_eq.
rewrite Hxd.
split.
apply (round_DN_pt beta fexp x).
apply generic_format_bpow.
ring_simplify (ex - 1 + 1)%Z.
lia.
apply Hex.
apply Rle_lt_trans with (2 := proj2 Hex).
apply (round_DN_pt beta fexp x).
rewrite Hxd.
apply (round_DN_pt beta fexp x).
apply generic_format_0.
now apply Rlt_le.
assert (Hxe2 : (fexp (ex + 1) <= ex)%Z) by now apply valid_exp.
assert (Hud: (F2R xu = F2R xd + ulp beta fexp x)%R).
rewrite Hxu, Hxd.
now apply round_UP_DN_ulp.
destruct (total_order_T (bpow ex) (F2R xu)) as [[Hu2|Hu2]|Hu2].
(* - xu > bpow ex  *)
elim (Rlt_not_le _ _ Hu2).
rewrite Hxu.
apply round_bounded_large_pos...
(* - xu = bpow ex *)
assert (Hu3: xu = Float beta (1 * Zpower beta (ex - fexp (ex + 1))) (fexp (ex + 1))).
apply canonical_unique with (1 := Hu).
apply (f_equal fexp).
rewrite <- F2R_change_exp.
now rewrite F2R_bpow, mag_bpow.
now apply valid_exp.
rewrite <- Hu2.
apply sym_eq.
rewrite <- F2R_change_exp.
apply F2R_bpow.
exact Hxe2.
assert (Hd3: xd = Float beta (Zpower beta (ex - fexp ex) - 1) (fexp ex)).
assert (H: F2R xd = F2R (Float beta (Zpower beta (ex - fexp ex) - 1) (fexp ex))).
unfold F2R. simpl.
rewrite minus_IZR.
unfold Rminus.
rewrite Rmult_plus_distr_r.
rewrite IZR_Zpower, <- bpow_plus.
ring_simplify (ex - fexp ex + fexp ex)%Z.
rewrite Hu2, Hud.
rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
unfold cexp.
rewrite mag_unique with beta x ex.
unfold F2R.
simpl. ring.
rewrite Rabs_pos_eq.
exact Hex.
now apply Rlt_le.
apply Zle_minus_le_0.
now apply Zlt_le_weak.
apply canonical_unique with (1 := Hd) (3 := H).
apply (f_equal fexp).
rewrite <- H.
apply sym_eq.
now apply mag_unique.
rewrite Hd3, Hu3.
unfold Fnum.
rewrite Z.even_mul. simpl.
unfold Zminus at 2.
rewrite Z.even_add.
rewrite eqb_sym. simpl.
fold (negb (Z.even (beta ^ (ex - fexp ex)))).
rewrite Bool.negb_involutive.
rewrite (Z.even_pow beta (ex - fexp ex)) by lia.
destruct exists_NE_.
rewrite H.
apply Zeven_Zpower_odd with (2 := H).
now apply Zle_minus_le_0.
apply Z.even_pow.
specialize (H ex).
lia.
(* - xu < bpow ex *)
revert Hud.
rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
unfold F2R.
rewrite Hd, Hu.
unfold cexp.
rewrite mag_unique with beta (F2R xu) ex.
rewrite mag_unique with (1 := Hd4).
rewrite mag_unique with (1 := Hexa).
intros H.
replace (Fnum xu) with (Fnum xd + 1)%Z.
rewrite Z.even_add.
now apply eqb_sym.
apply sym_eq.
apply eq_IZR.
rewrite plus_IZR.
apply Rmult_eq_reg_r with (bpow (fexp ex)).
rewrite H.
simpl. ring.
apply Rgt_not_eq.
apply bpow_gt_0.
rewrite Rabs_pos_eq.
split.
apply Rle_trans with (1 := proj1 Hex).
rewrite Hxu.
apply (round_UP_pt beta fexp x).
exact Hu2.
apply Rlt_le.
apply Rlt_le_trans with (1 := H0x).
rewrite Hxu.
apply (round_UP_pt beta fexp x).
Qed.

Theorem DN_UP_parity_generic :
  DN_UP_parity_prop.
Proof.
apply DN_UP_parity_aux.
apply DN_UP_parity_generic_pos.
Qed.

Theorem Rnd_NE_pt_total :
  round_pred_total Rnd_NE_pt.
Proof.
apply satisfies_any_imp_NG.
now apply generic_format_satisfies_any.
intros x d u Hf Hd Hu.
generalize (proj1 Hd).
unfold generic_format.
set (ed := cexp beta fexp d).
set (md := Ztrunc (scaled_mantissa beta fexp d)).
intros Hd1.
case_eq (Z.even md) ; [ intros He | intros Ho ].
right.
exists (Float beta md ed).
unfold Generic_fmt.canonical.
rewrite <- Hd1.
now repeat split.
left.
generalize (proj1 Hu).
unfold generic_format.
set (eu := cexp beta fexp u).
set (mu := Ztrunc (scaled_mantissa beta fexp u)).
intros Hu1.
rewrite Hu1.
eexists ; repeat split.
unfold Generic_fmt.canonical.
now rewrite <- Hu1.
rewrite (DN_UP_parity_generic x (Float beta md ed) (Float beta mu eu)).
simpl.
now rewrite Ho.
exact Hf.
unfold Generic_fmt.canonical.
now rewrite <- Hd1.
unfold Generic_fmt.canonical.
now rewrite <- Hu1.
rewrite <- Hd1.
apply Rnd_DN_pt_unique with (1 := Hd).
now apply round_DN_pt.
rewrite <- Hu1.
apply Rnd_UP_pt_unique with (1 := Hu).
now apply round_UP_pt.
Qed.

Theorem Rnd_NE_pt_monotone :
  round_pred_monotone Rnd_NE_pt.
Proof.
apply Rnd_NG_pt_monotone.
intros x d u Hd Hdn Hu Hun (cd, (Hd1, Hd2)) (cu, (Hu1, Hu2)).
destruct (Req_dec x d) as [Hx|Hx].
rewrite <- Hx.
apply sym_eq.
apply Rnd_UP_pt_idempotent with (1 := Hu).
rewrite Hx.
apply Hd.
rewrite (DN_UP_parity_aux DN_UP_parity_generic_pos x cd cu) in Hu2 ; try easy.
now rewrite (proj2 Hd2) in Hu2.
intros Hf.
apply Hx.
apply sym_eq.
now apply Rnd_DN_pt_idempotent with (1 := Hd).
rewrite <- Hd1.
apply Rnd_DN_pt_unique with (1 := Hd).
now apply round_DN_pt.
rewrite <- Hu1.
apply Rnd_UP_pt_unique with (1 := Hu).
now apply round_UP_pt.
Qed.

Theorem Rnd_NE_pt_round :
  round_pred Rnd_NE_pt.
Proof.
split.
apply Rnd_NE_pt_total.
apply Rnd_NE_pt_monotone.
Qed.

Lemma round_NE_pt_pos :
  forall x,
  (0 < x)%R ->
  Rnd_NE_pt x (round beta fexp ZnearestE x).
Proof with auto with typeclass_instances.
intros x Hx.
split.
now apply round_N_pt.
unfold NE_prop.
set (mx := scaled_mantissa beta fexp x).
set (xr := round beta fexp ZnearestE x).
destruct (Req_dec (mx - IZR (Zfloor mx)) (/2)) as [Hm|Hm].
(* midpoint *)
left.
exists (Float beta (Ztrunc (scaled_mantissa beta fexp xr)) (cexp beta fexp xr)).
split.
apply round_N_pt...
split.
unfold Generic_fmt.canonical. simpl.
apply f_equal.
apply round_N_pt...
simpl.
unfold xr, round, Znearest.
fold mx.
rewrite Hm.
rewrite Rcompare_Eq. 2: apply refl_equal.
case_eq (Z.even (Zfloor mx)) ; intros Hmx.
(* . even floor *)
change (Z.even (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zfloor x))) = true).
destruct (Rle_or_lt (round beta fexp Zfloor x) 0) as [Hr|Hr].
rewrite (Rle_antisym _ _ Hr).
unfold scaled_mantissa.
rewrite Rmult_0_l.
now rewrite Ztrunc_IZR.
rewrite <- (round_0 beta fexp Zfloor).
apply round_le...
now apply Rlt_le.
rewrite scaled_mantissa_DN...
now rewrite Ztrunc_IZR.
(* . odd floor *)
change (Z.even (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zceil x))) = true).
destruct (mag beta x) as (ex, Hex).
specialize (Hex (Rgt_not_eq _ _ Hx)).
rewrite (Rabs_pos_eq _ (Rlt_le _ _ Hx)) in Hex.
destruct (Z_lt_le_dec (fexp ex) ex) as [He|He].
(* .. large pos *)
assert (Hu := round_bounded_large_pos _ _ Zceil _ _ He Hex).
assert (Hfc: Zceil mx = (Zfloor mx + 1)%Z).
apply Zceil_floor_neq.
intros H.
rewrite H in Hm.
unfold Rminus in Hm.
rewrite Rplus_opp_r in Hm.
elim (Rlt_irrefl 0).
rewrite Hm at 2.
apply Rinv_0_lt_compat.
now apply IZR_lt.
destruct (proj2 Hu) as [Hu'|Hu'].
(* ... u <> bpow *)
unfold scaled_mantissa.
rewrite cexp_fexp_pos with (1 := conj (proj1 Hu) Hu').
unfold round, F2R. simpl.
rewrite cexp_fexp_pos with (1 := Hex).
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r.
rewrite Ztrunc_IZR.
fold mx.
rewrite Hfc.
now rewrite Z.even_add, Hmx.
(* ... u = bpow *)
rewrite Hu'.
unfold scaled_mantissa, cexp.
rewrite mag_bpow.
rewrite <- bpow_plus, <- IZR_Zpower.
rewrite Ztrunc_IZR.
case_eq (Z.even beta) ; intros Hr.
destruct exists_NE_ as [Hs|Hs].
now rewrite Hs in Hr.
destruct (Hs ex) as (H,_).
rewrite Z.even_pow.
exact Hr.
lia.
assert (Z.even (Zfloor mx) = true). 2: now rewrite H in Hmx.
replace (Zfloor mx) with (Zceil mx + -1)%Z by lia.
rewrite Z.even_add.
apply eqb_true.
unfold mx.
replace (Zceil (scaled_mantissa beta fexp x)) with (Zpower beta (ex - fexp ex)).
rewrite Zeven_Zpower_odd with (2 := Hr).
easy.
lia.
apply eq_IZR.
rewrite IZR_Zpower by lia.
apply Rmult_eq_reg_r with (bpow (fexp ex)).
unfold Zminus.
rewrite bpow_plus.
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_l, Rmult_1_r.
pattern (fexp ex) ; rewrite <- cexp_fexp_pos with (1 := Hex).
now apply sym_eq.
apply Rgt_not_eq.
apply bpow_gt_0.
generalize (proj1 (valid_exp ex) He).
lia.
(* .. small pos *)
assert (Z.even (Zfloor mx) = true). 2: now rewrite H in Hmx.
unfold mx, scaled_mantissa.
rewrite cexp_fexp_pos with (1 := Hex).
now rewrite mantissa_DN_small_pos.
(* not midpoint *)
right.
intros g Hg.
destruct (Req_dec x g) as [Hxg|Hxg].
rewrite <- Hxg.
apply sym_eq.
apply round_generic...
rewrite Hxg.
apply Hg.
set (d := round beta fexp Zfloor x).
set (u := round beta fexp Zceil x).
apply Rnd_N_pt_unique with (d := d) (u := u) (4 := Hg).
now apply round_DN_pt.
now apply round_UP_pt.
2: now apply round_N_pt.
rewrite <- (scaled_mantissa_mult_bpow beta fexp x).
unfold d, u, round, F2R. simpl. fold mx.
rewrite <- 2!Rmult_minus_distr_r.
intros H.
apply Rmult_eq_reg_r in H.
apply Hm.
apply Rcompare_Eq_inv.
rewrite Rcompare_floor_ceil_middle.
now apply Rcompare_Eq.
contradict Hxg.
apply sym_eq.
apply Rnd_N_pt_idempotent with (1 := Hg).
rewrite <- (scaled_mantissa_mult_bpow beta fexp x).
fold mx.
rewrite <- Hxg.
change (IZR (Zfloor mx) * bpow (cexp beta fexp x))%R with d.
now eapply round_DN_pt.
apply Rgt_not_eq.
apply bpow_gt_0.
Qed.

Theorem round_NE_opp :
  forall x,
  round beta fexp ZnearestE (-x) = (- round beta fexp ZnearestE x)%R.
Proof.
intros x.
unfold round. simpl.
rewrite scaled_mantissa_opp, cexp_opp.
rewrite Znearest_opp.
rewrite <- F2R_Zopp.
apply (f_equal (fun v => F2R (Float beta (-v) _))).
set (m := scaled_mantissa beta fexp x).
unfold Znearest.
case Rcompare ; trivial.
apply (f_equal (fun (b : bool) => if b then Zceil m else Zfloor m)).
rewrite Bool.negb_involutive.
rewrite Z.even_opp.
rewrite Z.even_add.
now rewrite eqb_sym.
Qed.

Lemma round_NE_abs:
  forall x : R,
  round beta fexp ZnearestE (Rabs x) = Rabs (round beta fexp ZnearestE x).
Proof with auto with typeclass_instances.
intros x.
apply sym_eq.
unfold Rabs at 2.
destruct (Rcase_abs x) as [Hx|Hx].
rewrite round_NE_opp.
apply Rabs_left1.
rewrite <- (round_0 beta fexp ZnearestE).
apply round_le...
now apply Rlt_le.
apply Rabs_pos_eq.
rewrite <- (round_0 beta fexp ZnearestE).
apply round_le...
now apply Rge_le.
Qed.

Theorem round_NE_pt :
  forall x,
  Rnd_NE_pt x (round beta fexp ZnearestE x).
Proof with auto with typeclass_instances.
intros x.
destruct (total_order_T x 0) as [[Hx|Hx]|Hx].
apply Rnd_NG_pt_opp_inv.
apply generic_format_opp.
unfold NE_prop.
intros _ f ((mg,eg),(H1,(H2,H3))).
exists (Float beta (- mg) eg).
repeat split.
rewrite H1.
now rewrite F2R_Zopp.
now apply canonical_opp.
simpl.
now rewrite Z.even_opp.
rewrite <- round_NE_opp.
apply round_NE_pt_pos.
now apply Ropp_0_gt_lt_contravar.
rewrite Hx, round_0...
apply Rnd_NG_pt_refl.
apply generic_format_0.
now apply round_NE_pt_pos.
Qed.

End Fcore_rnd_NE.

(** Notations for backward-compatibility with Flocq 1.4. *)
Notation rndNE := ZnearestE (only parsing).