(** * IndistRelations.v: indistinguishability relation for annotated programs *)
(*Require FFun.*)
Require Export DEX_BigStepAnnot.
Require Export Annotated.

Open Scope type_scope.

Import DEX_BigStepAnnot.DEX_BigStepAnnot DEX_BigStep.DEX_BigStep DEX_Dom DEX_Prog.

(* Hendra 12082016 - remove beta function, focus on DEX I *)
Inductive Value_in  (*b b':FFun.t Location*) : DEX_value -> DEX_value -> Prop :=
| Value_in_num: forall n,
  Value_in (*b b'*) (Num n) (Num n).

Inductive Value_in_opt (*b b':FFun.t Location*) :
  option DEX_value -> option DEX_value -> Prop :=
| Value_in_opt_some:
  forall v v',
    Value_in (*b b'*) v v' ->
    Value_in_opt (*b b'*) (Some v) (Some v')
| Value_in_opt_none: Value_in_opt (*b b'*) None None.

(* older regs in
Inductive Reg_in (observable:L.t) :
  L.t -> L.t -> DEX_value -> DEX_value -> Prop :=
| Reg_high_in : forall k k' v v', ~(L.leql k observable) -> ~(L.leql k' observable) ->
    Reg_in observable k k' v v'
| Reg_nhigh_in : forall k k' v v', Value_in v v' -> Reg_in observable k k' v v'.

Inductive Regs_in (observable:L.t) (r r': DEX_Registers.t) (rt rt': TypeRegisters) : Prop :=
| Build_Regs_in : eq_set (VarMap.dom _ rt) (VarMap.dom _ rt') ->
  (forall (rn:DEX_Reg),
  In rn (VarMap.dom _ rt) -> In rn (VarMap.dom _ rt') ->
  (forall v v' k k',
  Some v = DEX_Registers.get r rn -> Some v' = DEX_Registers.get r' rn ->
  Some k = VarMap.get _ rt rn -> Some k' = VarMap.get _ rt' rn ->
  Reg_in observable k k' v v')) -> Regs_in observable r r' rt rt'. *)

Inductive Reg_in (observable:L.t) (r r': DEX_Registers.t) (rt rt': TypeRegisters) (rn:DEX_Reg) : Prop :=
| Reg_high_in : forall k k', VarMap.get L.t rt rn = Some k -> VarMap.get L.t rt' rn = Some k' ->
    ~(L.leql k observable) -> ~(L.leql k' observable) -> Reg_in observable r r' rt rt' rn
| Reg_nhigh_in : Value_in_opt (DEX_Registers.get r rn) (DEX_Registers.get r' rn) -> Reg_in observable r r' rt rt' rn.

Inductive Regs_in (observable:L.t) (r r': DEX_Registers.t) (rt rt': TypeRegisters) : Prop :=
| Build_Regs_in : eq_set (VarMap.dom _ rt) (VarMap.dom _ rt') ->
  (forall (rn:DEX_Reg), Reg_in observable r r' rt rt' rn) -> Regs_in observable r r' rt rt'.

(* Inductive Regs_in (observable:L.t) (r r': DEX_Registers.t) (rt rt': TypeRegisters) : Prop :=
| High_Regs_in :
  (forall (rn:DEX_Reg) k k',
  Some k = VarMap.get _ rt rn -> Some k' = VarMap.get _ rt' rn ->
  ~(L.leql k observable) /\ ~(L.leql k' observable)) -> Regs_in observable r r' rt rt'
| nHigh_Regs_in :
  (forall (rn:DEX_Reg) v v' k k',
(*   In rn (DEX_Registers.dom r) -> In rn (DEX_Registers.dom r') -> *)
  Some v = DEX_Registers.get r rn -> Some v' = DEX_Registers.get r' rn ->
  Some k = VarMap.get _ rt rn -> Some k' = VarMap.get _ rt' rn ->
  Value_in v v') -> Regs_in observable r r' rt rt'. *)

Inductive st_in (observable:L.t) (*newArT : Method * PC -> L.t') (ft:FieldSignature -> L.t'*)
(*lvt:Var->L.t'*)  (*b b':FFun.t Location*) (rt rt':TypeRegisters) :
  DEX_PC * (*Heap.t * OperandStack.t * LocalVar.t*) DEX_Registers.t ->
  DEX_PC * (*Heap.t * OperandStack.t * LocalVar.t*) DEX_Registers.t -> Prop :=
| Build_st_in: forall (*h h'*) pc pc' (*l l'*) r r',
    (*localvar_in observable lvt (*b b'*) l l' ->*)
    Regs_in observable (*b b'*) r r' rt rt' ->
    (*hp_in observable newArT ft b b' h h' ->*)
    st_in observable (*newArT ft lvt b b'*) rt rt' (pc,r(*,l*)) (pc',r'(*,l'*)).

Inductive indist_return_value (observable:L.t) (s:DEX_sign) (*h1 h2:Heap.t*) :
    DEX_ReturnVal -> DEX_ReturnVal -> (*FFun.t Location -> FFun.t Location ->*) Prop :=
| indist_return_val : forall v1 v2 (*b1 b2*) k,
  s.(DEX_resType) = Some k ->
  (L.leql k observable -> Value_in (*b1 b2*) v1 v2) ->
  indist_return_value observable s (*h1 h2*) (Normal (Some v1)) (Normal (Some v2)) (*b1 b2 *)
| indist_return_void : (*forall b1 b2 ,*)
  s.(DEX_resType) = None ->
  indist_return_value observable s (*h1 h2*) (Normal None) (Normal None) (*b1 b2 *).

Inductive high_result (observable:L.t) (s:DEX_sign) (*h:Heap.t*) : DEX_ReturnVal -> Prop :=
| high_result_void :
  s.(DEX_resType) = None ->
  high_result observable s (*h*) (Normal None)
| high_result_value : forall v k,
  s.(DEX_resType) = Some k ->
  ~ L.leql k observable ->
  high_result observable s (*h*) (Normal (Some v)).

Inductive state : Type :=
  intra : DEX_IntraNormalState -> TypeRegisters -> (*FFun.t Location ->*) state
| ret : (*Heap.t ->*) DEX_ReturnVal -> (*FFun.t Location ->*) state.

Inductive indist (observable:L.t) (p:DEX_ExtendedProgram) (m:DEX_Method) (sgn:DEX_sign) : state -> state -> Prop :=
| indist_intra : forall  (*h h'*) pc pc' (*l l'*) r r' rt rt' (*b b'*),
  st_in observable (*newArT p) (ft p sgn.(DEX_lvt) b b'*) rt rt' (pc,(*h,*)r(*,l*)) (pc',(*h',*)r'(*,l'*)) ->
  indist observable p m sgn (intra (pc,((*h,*)r(*,l*))) rt (*b*)) (intra (pc',((*h',*)r'(*,l'*))) rt' (*b'*))
(*| indist_intra_return_case : forall pc h s l st b h' v' b',
  indist_intra_return observable p sgn (pc,(h,s,l)) st b h' v' b' ->
  indist observable p m sgn (intra (pc,(h,s,l)) st b) (ret h' v' b')
| indist_return_intra_case : forall pc h s l st b h' v' b',
  indist_intra_return observable p sgn (pc,(h,s,l)) st b h' v' b' ->
  indist observable p m sgn (ret h' v' b') (intra (pc,(h,s,l)) st b) *)
| indist_return : forall (*b b' h h'*) v v',
  (*hp_in observable (newArT p) (ft p) b b' h h' ->*)
  indist_return_value observable sgn (*h h'*) v v' (*b b'*) ->
  indist observable p m sgn (ret (*h*) v (*b*)) (ret (*h'*) v' (*b'*)).

 (** Indistinguishability relations *)

Section p.
  Variable kobs : L.t.
  Variable p : DEX_ExtendedProgram.
  (*Notation ft := (ft p).
  Notation newArT := (newArT p).*)

 (** Basic results on indistinguishability relations *)

  Lemma Value_in_sym : forall v1 v2 (*b1 b2*),
    Value_in (*b1 b2*) v1 v2 ->
    Value_in (*b2 b1*) v2 v1.
  Proof.
    intros.
    inversion_clear H; try constructor.
    (* Hendra 15082016 - related to beta function - constructor 3 with n; auto.*)
  Qed.

  Lemma Value_in_opt_sym : forall v1 v2 (*b1 b2*),
    Value_in_opt (*b1 b2*) v1 v2 ->
    Value_in_opt (*b2 b1*) v2 v1.
  Proof.
    intros.
    inversion_clear H; try constructor.
    apply Value_in_sym; auto.
  Qed.

  Lemma Value_in_trans : forall v1 v2 v3 (*b1 b2 b3*),
    (*FFun.is_inj b2 ->*)
    Value_in (*b1 b2*) v1 v2 ->
    Value_in (*b2 b3*) v2 v3 ->
    Value_in (*b1 b3*) v1 v3.
  Proof.
    intros.
    inversion H0; inversion H; subst; rewrite H4; constructor.
    (*inversion_clear H0 in H1; inversion_clear H1; try constructor.
    rewrite <- (H _ _ _ H3 H0) in H4.
    constructor 3 with n; auto.*)
  Qed.

  Lemma Value_in_opt_trans : forall v1 v2 v3 (*b1 b2 b3*),
    (*FFun.is_inj b2 ->*)
    Value_in_opt (*b1 b2*) v1 v2->
    Value_in_opt (*b2 b3*) v2 v3 ->
    Value_in_opt (*b1 b3*) v1 v3.
  Proof.
    intros.
    inversion_clear H in H0; inversion_clear H0; try constructor.
    (*inversion_clear H0 in H1; inversion_clear H1; try constructor.*)
    eapply Value_in_trans; eauto.
  Qed.

  Lemma leql_join1 : forall k1 k2 k3,
    L.leql k2 k3 ->
    L.leql k2 (L.join k1 k3).
  Proof.
    intros.
    apply L.leql_trans with (1:=H).
    apply L.join_right.
  Qed.

  Lemma leql_join2 : forall k1 k2 k3,
    L.leql k2 k1 ->
    L.leql k2 (L.join k1 k3).
  Proof.
    intros.
    apply L.leql_trans with (1:=H).
    apply L.join_left.
  Qed.

  Lemma not_leql_trans : forall k1 k2 k3,
    ~ L.leql k1 k3 ->
    L.leql k1 k2 ->
    ~ L.leql k2 k3.
  Proof.
    red; intros.
    elim H.
    apply L.leql_trans with (1:=H0); auto.
  Qed.

  Lemma not_leql_join1 : forall k1 k2 k3,
    ~ L.leql k1 k3 ->
    ~ L.leql (L.join k1 k2) k3.
  Proof.
    intros; apply not_leql_trans with k1; auto.
    apply L.join_left.
  Qed.

  Lemma not_leql_join2 : forall k1 k2 k3,
    ~ L.leql k2 k3 ->
    ~ L.leql (L.join k1 k2) k3.
  Proof.
    intros; apply not_leql_trans with k2; auto.
    apply L.join_right.
  Qed.

  Lemma leql_join_each: forall k k1 k2, L.leql (L.join k k1) k2 -> L.leql k k2 /\ L.leql k1 k2.
  Proof. intros.
    split. apply L.leql_trans with (l2:=L.join k k1); auto. apply L.join_left.
    apply L.leql_trans with (l2:=L.join k k1); auto. apply L.join_right.
  Qed.

(*   Lemma Reg_in_inv : forall obs k k' v v',
    Reg_in obs k k' v v' <->
      (~(L.leql k obs) /\ ~(L.leql k' obs)) \/ (Value_in v v').
  Proof.
    intros. split.
      intros. inversion H. left; auto. right; auto.
      intros. inversion H.
      apply Reg_high_in; inversion H0; auto.
      apply Reg_nhigh_in; auto.
  Qed.

  Lemma Reg_in_sym : forall obs k k' v v',
    Reg_in obs k k' v v' ->
    Reg_in obs k' k v' v.
  Proof.
    intros.
    inversion H.
      constructor 1; auto.
      constructor 2; auto.
      apply Value_in_sym; auto.
  Qed.

  Lemma Reg_in_refl : forall obs k v, Reg_in obs k k v v.
  Proof. intros. constructor 2. destruct v. constructor; auto. Qed.

  Lemma Reg_in_monotony_left : forall obs k k' v v' k'',
    Reg_in obs k k' v v' ->
    L.leql k k'' ->
    Reg_in obs k'' k' v v'.
  Proof.
    intros. inversion H; subst.
    constructor 1; auto.
    apply not_leql_trans with (k1:=k) (k3:=obs) (k2:=k'') in H1; auto.
    constructor 2; auto.
  Qed.  *)

 (* Lemma Regs_in_inv : forall r1 r2 rt1 rt2,
    Regs_in kobs r1 r2 rt1 rt2 -> forall (rn:DEX_Reg), In rn (VarMap.dom _ rt1) -> In rn (VarMap.dom _ rt2) ->
    (forall k k', Some k = VarMap.get _ rt1 rn -> Some k' = VarMap.get _ rt2 rn ->
      (~L.leql k kobs /\ ~L.leql k' kobs)) \/
    (forall v v', (Some v = DEX_Registers.get r1 rn /\ Some v' = DEX_Registers.get r2 rn /\ Value_in v v')).
  Proof.
    intros.
    inversion H.
    specialize (H3 rn H0 H1).
    apply VarMap.in_dom_get_some in H0.
    apply VarMap.in_dom_get_some in H1.
    apply not_none_some with (A:=L.t) (a:=VarMap.get L.t rt1 rn) in H0. admit. apply not_none_some with (A:=L.t) in H1.
    destruct H0; destruct H1.
    apply H4 in H0.
    inversion H0.

    left; split; auto.
    right. repeat (split; auto).
    admit. admit.
 subst. admit. split; auto. *)

  Lemma Reg_in_sym : forall obs r r' rt rt' rn,
    Reg_in obs r r' rt rt' rn ->
    Reg_in obs r' r rt' rt rn.
  Proof.
    intros.
    inversion H.
      constructor 1 with (k:=k') (k':=k); auto.
      constructor 2; auto.
      apply Value_in_opt_sym; auto.
  Qed.

 Lemma Regs_in_sym : forall r1 r2 rt1 rt2,
    Regs_in kobs r1 r2 rt1 rt2 ->
    Regs_in kobs r2 r1 rt2 rt1.
  Proof.
    induction 1.
    constructor. apply eq_set_sym; auto.
    intros.
    apply Reg_in_sym; auto.
(*     apply H0 with (k:=k') (k':=k) (v:=v') (v':=v) in H3; auto. *)
  Qed.

  Lemma st_in_sym : forall (*lvt b b'*) rt rt' r r',
    st_in kobs (*newArT ft lvt b b'*) rt rt' r r' ->
    st_in kobs (*newArT ft lvt b' b*) rt' rt r' r.
  Proof.
    intros.
    inversion_clear H; constructor.
    (*apply localvar_in_sym; auto.
    apply os_in_sym; auto.
    apply hp_in_sym; auto.*)
    apply Regs_in_sym; auto.
  Qed.
  Implicit Arguments st_in_sym.

  Lemma Value_in_opt_some_aux: forall ov ov' v v' (*b b'*),
    Value_in (*b b'*) v v' ->
    ov=(Some v)  ->
    ov'= (Some v') ->
    Value_in_opt (*b b'*) ov ov'.
  Proof.
    intros;  subst; constructor; auto.
  Qed.

  Lemma ex_comp_Z : forall x y z:Z,
    (x <= y < z \/ ~ x <= y < z)%Z.
  Proof.
    intros.
    destruct (Z_le_dec x y).
    destruct (Z_lt_dec y z); intuition.
    intuition.
  Qed.

  Lemma nth_error_none_length : forall (A:Set) (l:list A) i,
    nth_error l i = None -> (length l <= i)%nat.
  Proof.
    induction l; destruct i; simpl; intros; try omega.
    discriminate.
    generalize (IHl _ H); omega.
  Qed.

  Lemma nth_error_some_length : forall (A:Set) (l:list A) i a,
    nth_error l i = Some a -> (length l > i)%nat.
  Proof.
    induction l; destruct i; simpl; intros; try discriminate; try omega.
    generalize (IHl _ _ H); omega.
  Qed.

  Hint Resolve
    not_leql_join1 (*not_leql_join1'*) not_leql_join2 (*not_leql_join2'*) not_leql_trans
    L.join_left L.join_right (*leql'_leql*)
    L.leql_trans : lattice.

End p.

  Hint Resolve
    not_leql_join1 (*not_leql_join1'*) not_leql_join2 (*not_leql_join2'*) not_leql_trans
    L.join_left L.join_right (*leql'_leql*)
    L.leql_trans : lattice.

(*
*** Local Variables: ***
*** coq-prog-name: "~/Soft/src/coq-8.2pl1/bin/coqtop" ***
*** coq-prog-args: ("-emacs-U" "-I" "../Library" "-I" "../Library/Map/") ***
*** End: ***
 *)


From Paco Require Import paco.
From ITree Require Import ITree.
Require Import sflib.

Require Import StdlibExt IntegersExt.
Require Import SysSem.
Require Import SyncSysModel.
Require Import RTSysEnv.
Require Import Executable.

Require Import CProgEventSem.

Require Import FMSim FMSim_Switch.
Require Import PALSSystem.
Require Import BehavUtils.
Require Import SystemAbstraction.

Require Import AcStSystem.

Require Import ZArith Streams List Lia.

Import ITreeNotations.

Local Opaque Z.of_nat Z.to_nat.

Set Nested Proofs Allowed.

(* Local Notation sysE := (extcallE +' errE). *)

Inductive abs_msg: Set :=
| Tgl
| Acq
| Rel
| Grant
| Heartbeat
.

Inductive amsgE: Type -> Type :=
| SendAbsMsg (msg: abs_msg): amsgE unit.

(* abstract system itree_step (possibly fails) *)
Inductive itree_astep {E S}
  : itree (E +' amsgE) S ->
    events E -> list abs_msg -> S? -> Prop :=
| ITreeAStep_Fail
    itr
  : itree_astep itr [] [] None
| ITreeAStep_Ret
    itr (s: S)
    (OBS_RET: observe itr = RetF s)
  : itree_astep itr [] [] (Some s)
| ITreeAStep_Tau
    itr itr' es ms (res: S?)
    (OBS_RET: observe itr = TauF itr')
    (ASTEP_REST: itree_astep itr' es ms res)
  : itree_astep itr es ms res
| ITreeAStep_Evt
    itr R (e: E R) k (ret: R)
    (es': events E) ms' (res: S?)
    (OBS_VIS: observe itr = VisF (inl1 e) k)
    (ASTEP_REST: itree_astep (k ret) es' ms' res)
  : itree_astep itr (Event e ret :: es') ms' res
| ITreeAStep_Msg
    itr msg k
    (es': events E) ms' (res: S?)
    (OBS_VIS: observe itr = VisF (inr1 (SendAbsMsg msg)) k)
    (ASTEP_REST: itree_astep (k tt) es' ms' res)
  : itree_astep itr es' (msg :: ms') res
.

Module AbsAcSt.

  Definition MAX_TIMEOUT: nat := 5.

  Inductive ctrl_state: Type :=
  | CtrlUninit
  | SentHB
  .

  Inductive dev_state: Type :=
  | DevUninit
  (* Send Rel and be Idle *)
  | SentRel
  | Idle
  (* Send Acq and be Waiting *)
  | SentAcq (demand: nat)
  | Waiting (demand: nat)
  (* Owner (including the case Grant just arrived) *)
  | Owner (demand_left: nat)
  .

  Inductive failed_side_t: Set :=
  | AllWorking
  | FstFailed (recover: bool)
  | SndFailed (recover: bool)
  .

  Inductive state: Type :=
  | PreState
  | Running
      (active_side: bool)
      (failed_side: failed_side_t)
      (queue: list Tid)
      (timeout: nat)

      (to_toggle: bool)
      (dev1: dev_state?)
      (dev2: dev_state?)
      (dev3: dev_state?)
  | OutOfService
  .

  Definition console_itree: itree (obsE +' amsgE) unit :=
    inp <- trigger GetUserInput ;;
    (if negb (Int.eq Int.zero inp) then
       trigger (SendAbsMsg Tgl)
     else Ret tt);;
    trigger (WriteLog 0).

  Definition ctrl_itree
             (is_active: bool)
    : itree (obsE +' amsgE) unit :=
    trigger (SendAbsMsg Grant) ;;
    trigger (SendAbsMsg Heartbeat) ;;
    trigger (WriteLog (if is_active then 1 else 2)).

  (* at the beginning of period *)
  Definition set_active_side
             (tgl: bool) (asd: bool)
             (hb_from1 hb_from2: bool)
    : bool * bool(* if changed by hb_check *) :=
    (* match oasd with *)
    (* | None => (true, false) *)
    (* | Some asd => *)
      let hb_actv := if asd then hb_from1 else hb_from2 in
      let hb_stby := if asd then hb_from2 else hb_from1 in
      if negb hb_actv then
        (negb asd, true)
      else
        if (tgl && hb_stby)%bool then
          (negb asd, false)
        else (asd, false)
               (* end. *)
  .

  (* Reset timeout if (1) hb not arrived from active side *)
  (* (2) and not sure about sending Grant *)
  Definition check_and_reset_timeout
             (achg_by_hbchk: bool)
             (tout: nat)
    : nat :=
    if achg_by_hbchk then
      if (tout =? MAX_TIMEOUT) then 0 else tout
    else tout.

  Definition apply_devmsg (tid_dev: Tid) (dst: dev_state?)
             (q: list Tid) (tout: nat)
    : list Tid * nat :=
    admit_t.

  Definition pick_new_owner (q: list Tid) (tout: nat)
    : list Tid * nat * Tid? :=
    admit_t.

  Definition update_queue
             (dst1: dev_state?)
             (dst2: dev_state?)
             (dst3: dev_state?)
             (q: list Tid) (tout: nat)
    : list Tid * nat * (Tid?) :=
    let (q1, tout1) := apply_devmsg tid_dev1 dst1 q tout in
    let (q2, tout2) := apply_devmsg tid_dev2 dst2 q1 tout1 in
    let (q3, tout3) := apply_devmsg tid_dev3 dst3 q2 tout2 in
    pick_new_owner q3 tout3.

  Definition active_side_sent_grant (asd': bool)
             (ms_c1 ms_c2: list abs_msg)
    : bool :=
    admit_t.

  Definition get_failed_side (es_c1 es_c2: events obsE)
    : failed_side_t? :=
    admit_t.

  Definition check_toggle (ms_con: list abs_msg): bool :=
    admit_t.

  Inductive step (sytm: Z)
    : state -> list (events obsE) -> state -> Prop :=
  | Step_AlreadyFailed
      (es_con es_c1 es_c2 es_d1 es_d2 es_d3: events obsE)
    : step sytm OutOfService
           [es_con; es_c1; es_c2; es_d1; es_d2; es_d3]
           OutOfService

  | Step_PrePre
      es_con ms_con (ou: unit?)
      (ASTEP_CON: itree_astep console_itree es_con ms_con ou)
    : step sytm PreState (es_con :: repeat [] 5) PreState
  | Step_PreFail
      (es_con es_d1 es_d2 es_d3: events obsE)
      (DEV_COMP_FIRST:
         es_d1 = [Event (inl1 (WriteLog 0)) tt] \/
         es_d2 = [Event (inl1 (WriteLog 0)) tt] \/
         es_d3 = [Event (inl1 (WriteLog 0)) tt])
    : step sytm PreState [es_con; []; []; es_d1; es_d2; es_d3]
           OutOfService
  | Step_StartRunning
      es_con ms_con ou
      es_c1 ms_c1 ocst1
      es_c2 ms_c2 ocst2
      odst1 odst2 odst3
      ttgl' fsd'
      (ASTEP_CON: itree_astep console_itree es_con ms_con ou)
      (ASTEP_CTRL1: itree_astep (ctrl_itree true)
                                es_c1 ms_c1 ocst1)
      (ASTEP_CTRL2: itree_astep (ctrl_itree false)
                                es_c2 ms_c2 ocst2)
      (TO_TOGGLE: ttgl' = check_toggle ms_con)
      (FAILED_SIDE: get_failed_side es_c1 es_c2 = Some fsd')
      (DST1: option_rel1 (fun dst => dst = Uninit) odst1)
      (DST2: option_rel1 (fun dst => dst = Uninit) odst2)
      (DST3: option_rel1 (fun dst => dst = Uninit) odst3)
    : step sytm PreState [es_con; es_c1; es_c2; []; []; []]
           (Running true fsd' [] O ttgl' odst1 odst2 odst3)

  | Step_RunningOK
      asd fsd q tout ttgl odst1 odst2 odst3
      asd' fsd' q' tout' ttgl' odst1' odst2' odst3'
      es_con es_c1 es_c2 es_d1 es_d2 es_d3
      chg_byhb

      (NEW_ACTIVE_SIDE:
         set_active_side ttgl asd (check_hb
         =
(asd', chg_byhb)
    : step sytm
           (Running asd fsd q tout ttgl odst1 odst2 odst3)
           [es_con; es_c1; es_c2; es_d1; es_d2; es_d3]
           (Running asd' fsd' q' tout' ttgl' odst1' odst2' odst3')

  | Step_RunningFails
      asd fsd q tout ttgl odst1 odst2 odst3
      es_con es_c1 es_c2 es_d1 es_d2 es_d3
      (* asd' fsd' q' tout' ttgl' odst1' odst2' odst3' *)
    : step sytm
           (Running asd fsd q tout ttgl odst1 odst2 odst3)
           [es_con; es_c1; es_c2; es_d1; es_d2; es_d3]
           OutOfService
  .

  (* active_side  *)

  AbsSys.t


(* F1Prop.v *)

Require Import Utf8 QArith NPeano Sorted.

Require Import Misc.
Require Import QbarM.
Require Import SplitList.
Require Import Field2.
Require Import Fpolynomial.
Require Import Fsummation.
Require Import Newton.
Require Import ConvexHullMisc.
Require Import ConvexHull.
Require Import Puiseux_base.
Require Import Power_series.
Require Import Puiseux_series.
Require Import Ps_add.
Require Import Ps_mul.
Require Import Ps_div.
Require Import PSpolynomial.
Require Import AlgCloCharPol.
Require Import CharactPolyn.
Require Import F1Eq.
Require Import PosOrder.
Require Import InK1m.

Set Implicit Arguments.

Section theorems.

Variable α : Type.
Variable R : ring α.
Variable K : field R.
Variable acf : algeb_closed_field K.

Theorem eq_poly_lap_add : ∀ α (R : ring α) la lb,
  (POL la + POL lb = POL (la + lb)%lap)%pol.
Proof. reflexivity. Qed.

Theorem ps_poly_lap_summ : ∀ f g l,
  (∀ i, (f i = POL (g i))%pspol)
  → (ps_pol_summ ps_field l f = POL (ps_lap_summ ps_field l g))%pspol.
Proof.
intros f g l Hi.
unfold ps_pol_eq, ps_pol in Hi.
unfold ps_pol_eq, ps_pol, ps_pol_summ, ps_lap_summ.
induction l as [| x]; [ reflexivity | simpl ].
rewrite <- eq_poly_lap_add.
rewrite <- IHl, <- Hi.
reflexivity.
Qed.

(* things similar with order_add, perhaps good theorems? *)
Theorem order_add_eq_min : ∀ a b,
  (order a ≠ order b)%Qbar
  → (order (a + b) = Qbar.min (order a) (order b))%Qbar.
Proof.
intros a b Hab.
set (k₁ := ps_polydo b).
set (k₂ := ps_polydo a).
set (v₁ := (ps_ordnum a * Zpos k₁)%Z).
set (v₂ := (ps_ordnum b * Zpos k₂)%Z).
set (n₁ := Z.to_nat (v₂ - Z.min v₁ v₂)).
set (n₂ := Z.to_nat (v₁ - Z.min v₁ v₂)).
pose proof (ps_adjust_eq K a n₂ k₁) as Ha.
pose proof (ps_adjust_eq K b n₁ k₂) as Hb.
symmetry.
rewrite Hb in Hab.
rewrite Ha in Hab.
rewrite Hb in |- * at 1.
rewrite Ha in |- * at 1.
rewrite eq_ps_add_add₂.
unfold ps_add₂.
unfold adjust_ps_from.
fold k₁ k₂.
fold v₁ v₂.
rewrite Z.min_comm.
fold n₁ n₂.
remember (adjust_ps n₂ k₁ a) as pa eqn:Hpa .
remember (adjust_ps n₁ k₂ b) as pb eqn:Hpb .
remember (order pa) as opa eqn:Hopa .
remember (order pb) as opb eqn:Hopb .
progress unfold order in Hopa, Hopb.
progress unfold order; simpl.
remember (ps_terms pa) as sa eqn:Hsa .
remember (ps_terms pb) as sb eqn:Hsb .
remember (series_order sa 0) as na eqn:Hna .
remember (series_order sb 0) as nb eqn:Hnb .
remember (series_order (sa + sb)%ser 0) as nc eqn:Hnc .
symmetry in Hna, Hnb, Hnc.
clear Hsa Hsb Ha Hb.
apply series_order_iff in Hna; simpl in Hna.
apply series_order_iff in Hnb; simpl in Hnb.
apply series_order_iff in Hnc; simpl in Hnc.
destruct na as [na| ].
 destruct Hna as (Hina, Hna).
 destruct nb as [nb| ].
  destruct Hnb as (Hinb, Hnb).
  subst pa pb; simpl in Hopa, Hopb; simpl.
  subst k₁ k₂ n₁ n₂; simpl in Hopa, Hopb; simpl.
  subst v₁ v₂; simpl in Hopa, Hopb.
  rewrite Pos.mul_comm in Hopb.
  rewrite Z2Nat.id in Hopa.
   rewrite Z2Nat.id in Hopb.
    rewrite Z.sub_sub_distr in Hopa, Hopb.
    rewrite Z.sub_diag, Z.add_0_l in Hopa, Hopb.
    unfold cm_factor; simpl.
    rewrite Z2Nat.id.
     rewrite Z.sub_sub_distr.
     rewrite Z.sub_diag, Z.add_0_l.
     subst opa opb; simpl.
     rewrite Qmin_same_den.
     unfold Qeq; simpl.
     simpl in Hab.
     unfold Qeq in Hab; simpl in Hab.
     destruct nc as [nc| ].
      destruct Hnc as (Hinc, Hnc).
      apply Z.mul_cancel_r; [ apply Pos2Z_ne_0 | idtac ].
      rewrite Z.add_min_distr_l.
      apply Z.add_cancel_l.
      rewrite <- Nat2Z.inj_min.
      apply Nat2Z.inj_iff.
      destruct (eq_nat_dec (min na nb) nc) as [| H]; [ assumption | idtac ].
      exfalso; apply Hab; clear Hab.
      apply Z.mul_cancel_r; [ apply Pos2Z_ne_0 | idtac ].
      apply Z.add_cancel_l.
      apply Nat2Z.inj_iff.
      destruct (eq_nat_dec na nb) as [| Hab]; [ assumption | idtac ].
      exfalso; apply H; clear H.
      destruct (le_dec na nb) as [H₁| H₁].
       apply Nat_le_neq_lt in H₁; [ idtac | assumption ].
       destruct (lt_dec na nc) as [H₂| H₂].
        apply Hinb in H₁.
        apply Hinc in H₂.
        rewrite H₁, rng_add_0_r in H₂; contradiction.

        apply Nat.nlt_ge in H₂.
        destruct (eq_nat_dec na nc) as [H₃| H₃].
         rewrite Nat.min_l; [ assumption | idtac ].
         apply Nat.lt_le_incl; assumption.

         apply Nat.neq_sym in H₃.
         apply Nat_le_neq_lt in H₂; [ idtac | assumption ].
         eapply Nat.lt_trans in H₁; [ idtac | eassumption ].
         apply Hina in H₂.
         apply Hinb in H₁.
         rewrite H₂, H₁ in Hnc.
         rewrite rng_add_0_l in Hnc.
         exfalso; apply Hnc; reflexivity.

       apply Nat.nle_gt in H₁.
       destruct (lt_dec nb nc) as [H₂| H₂].
        apply Hina in H₁.
        apply Hinc in H₂.
        rewrite H₁, rng_add_0_l in H₂; contradiction.

        apply Nat.nlt_ge in H₂.
        destruct (eq_nat_dec nb nc) as [H₃| H₃].
         rewrite Nat.min_r; [ assumption | idtac ].
         apply Nat.lt_le_incl; assumption.

         apply Nat.neq_sym in H₃.
         apply Nat_le_neq_lt in H₂; [ idtac | assumption ].
         eapply Nat.lt_trans in H₁; [ idtac | eassumption ].
         apply Hinb in H₂.
         apply Hina in H₁.
         rewrite H₂, H₁ in Hnc.
         rewrite rng_add_0_l in Hnc.
         exfalso; apply Hnc; reflexivity.

      simpl in Hab.
      apply Hab; clear Hab.
      apply Z.mul_cancel_r; [ apply Pos2Z_ne_0 | idtac ].
      apply Z.add_cancel_l.
      apply Nat2Z.inj_iff.
      destruct (eq_nat_dec na nb) as [| Hab]; [ assumption | idtac ].
      destruct (le_dec na nb) as [H₁| H₁].
       apply Nat_le_neq_lt in H₁; [ idtac | assumption ].
       apply Hinb in H₁.
       pose proof (Hnc na) as H.
       rewrite H₁, rng_add_0_r in H.
       contradiction.

       apply Nat.nle_gt in H₁.
       apply Hina in H₁.
       pose proof (Hnc nb) as H.
       rewrite H₁, rng_add_0_l in H.
       contradiction.

     rewrite <- Z.sub_max_distr_l.
     rewrite Z.sub_diag.
     rewrite <- Z2Nat_id_max.
     apply Nat2Z.is_nonneg.

    rewrite <- Z.sub_max_distr_l.
    rewrite Z.sub_diag.
    rewrite Z.max_comm, <- Z2Nat_id_max.
    apply Nat2Z.is_nonneg.

   rewrite <- Z.sub_max_distr_l.
   rewrite Z.sub_diag.
   rewrite <- Z2Nat_id_max.
   apply Nat2Z.is_nonneg.

  subst opb; simpl.
  rewrite Qbar.min_comm; simpl.
  destruct nc as [nc| ].
   destruct Hnc as (Hinc, Hnc).
   subst opa.
   apply Qbar.qfin_inj_wd.
   unfold Qeq; simpl.
   apply Z.mul_cancel_r; [ apply Pos2Z_ne_0 | idtac ].
   apply Z.add_cancel_l.
   apply Nat2Z.inj_iff.
   destruct (eq_nat_dec na nc) as [| Hac]; [ assumption | idtac ].
   destruct (le_dec na nc) as [H₁| H₁].
    apply Nat_le_neq_lt in H₁; [ idtac | assumption ].
    apply Hinc in H₁.
    rewrite Hnb, rng_add_0_r in H₁.
    contradiction.

    apply Nat.nle_gt in H₁.
    apply Hina in H₁.
    rewrite H₁, Hnb, rng_add_0_l in Hnc.
    exfalso; apply Hnc; reflexivity.

   pose proof (Hnc na) as H.
   rewrite Hnb, rng_add_0_r in H.
   contradiction.

 subst opa; simpl.
 destruct nb as [nb| ].
  destruct Hnb as (Hinb, Hnb).
  destruct nc as [nc| ].
   destruct Hnc as (Hinc, Hnc).
   destruct (eq_nat_dec nb nc) as [| Hbc]; [ subst nb | idtac ].
    subst.
    subst n₁ n₂ v₁ v₂ k₁ k₂; simpl.
    unfold cm_factor; simpl.
    rewrite Z2Nat.id.
     rewrite Z2Nat.id.
      do 2 rewrite Z.sub_sub_distr.
      do 2 rewrite Z.sub_diag, Z.add_0_l.
      rewrite Pos.mul_comm; reflexivity.

      rewrite <- Z.sub_max_distr_l.
      rewrite Z.sub_diag.
      rewrite <- Z2Nat_id_max.
      apply Nat2Z.is_nonneg.

     rewrite <- Z.sub_max_distr_l.
     rewrite Z.sub_diag.
     rewrite Z.max_comm, <- Z2Nat_id_max.
     apply Nat2Z.is_nonneg.

    destruct (le_dec nb nc) as [H₁| H₁].
     apply Nat_le_neq_lt in H₁; [ idtac | assumption ].
     apply Hinc in H₁.
     rewrite Hna, rng_add_0_l in H₁.
     contradiction.

     apply Nat.nle_gt in H₁.
     apply Hinb in H₁.
     rewrite Hna, rng_add_0_l in Hnc.
     contradiction.

   pose proof (Hnc nb) as H.
   rewrite Hna, rng_add_0_l in H.
   contradiction.

  subst opb.
  exfalso; apply Hab; reflexivity.
Qed.

Theorem ps_lap_nth_x_le_pow_mul : ∀ la m n,
  (n ≤ m)%nat
  → (ps_lap_nth m ([0; 1 … []] ^ n * la) = ps_lap_nth (m - n) la)%ps.
Proof.
intros la m n Hnm.
revert m Hnm.
induction n; intros.
 progress unfold ps_lap_pow; simpl.
 progress unfold ps_lap_mul.
 rewrite lap_mul_1_l.
 rewrite Nat.sub_0_r.
 reflexivity.

 rewrite <- Nat.add_1_l.
 unfold ps_lap_pow.
 rewrite lap_power_add.
 rewrite lap_power_1.
 progress unfold ps_lap_mul.
 rewrite <- lap_mul_assoc.
 rewrite lap_mul_cons_l.
 rewrite lap_eq_0, lap_mul_nil_l, lap_add_nil_l, lap_mul_1_l.
 destruct m; [ exfalso; revert Hnm; apply Nat.nlt_0_r | simpl ].
 apply le_S_n in Hnm.
 apply IHn; assumption.
Qed.

Theorem ps_lap_nth_x_gt_pow_mul : ∀ la m n,
  (m < n)%nat
  → (ps_lap_nth m ([0; 1 … []] ^ n * la) = 0)%ps.
Proof.
intros la m n Hmn.
revert m Hmn.
induction n; intros.
 exfalso; revert Hmn; apply Nat.nlt_0_r.

 unfold ps_lap_mul, ps_lap_pow; simpl.
 rewrite <- lap_mul_assoc.
 rewrite lap_mul_cons_l.
 rewrite lap_eq_0, lap_mul_nil_l, lap_add_nil_l, lap_mul_1_l.
 destruct m; [ reflexivity | idtac ].
 apply lt_S_n in Hmn.
 unfold ps_lap_nth; simpl.
 apply IHn; assumption.
Qed.

Theorem ps_lap_nth_0_cons_pow : ∀ a la n,
  (ps_lap_nth 0 ([a … la] ^ n) = a ^ n)%ps.
Proof.
intros a la n.
induction n; simpl.
 progress unfold ps_lap_pow; simpl.
 reflexivity.

 unfold ps_lap_pow; simpl.
 unfold ps_lap_nth.
 rewrite list_nth_lap_mul; simpl.
 unfold summation; simpl.
 rewrite IHn.
 rewrite ps_add_0_r; reflexivity.
Qed.

Theorem eq_1_0_all_0 : (1 = 0)%K → ∀ a, (a = 0)%K.
Proof.
intros H a.
rewrite <- rng_mul_1_l.
rewrite H, rng_mul_0_l.
reflexivity.
Qed.

Theorem order_pow : ∀ a n,
  (a ≠ 0)%ps
  → (order (a ^ n) = qfin (Qnat n) * order a)%Qbar.
Proof.
intros a n Ha.
induction n; simpl.
 remember (order a) as v eqn:Hv .
 symmetry in Hv.
 destruct v as [v| ].
  unfold Qnat; simpl.
  rewrite Qmult_0_l.
  unfold ps_one.
  rewrite ps_monom_order; [ reflexivity | idtac ].
  intros H; apply Ha.
  rewrite <- ps_mul_1_l.
  unfold ps_one.
  rewrite H, ps_zero_monom_eq.
  rewrite ps_mul_0_l.
  reflexivity.

  exfalso; apply Ha.
  apply order_inf; assumption.

 rewrite order_mul.
 rewrite IHn.
 remember (order a) as v eqn:Hv .
 symmetry in Hv.
 destruct v as [v| ]; [ simpl | reflexivity ].
 rewrite <- Nat.add_1_l.
 unfold Qnat.
 rewrite Nat2Z.inj_add, QZ_plus.
 rewrite Qmult_plus_distr_l; simpl.
 rewrite Qmult_1_l; reflexivity.
Qed.

Theorem ps_lap_nth_0_apply_0 : ∀ la,
  (ps_lap_nth 0 la = @apply_lap _ (ps_ring K) la 0)%ps.
Proof.
intros la.
induction la as [| a]; [ reflexivity | simpl ].
rewrite ps_mul_0_r, ps_add_0_l.
reflexivity.
Qed.

Theorem apply_lap_inject_K_in_Kx_monom : ∀ P c,
  (@apply_lap _ (ps_ring K) (lap_inject_K_in_Kx P) (ps_monom c 0) =
   ps_monom (apply_lap P c) 0)%ps.
Proof.
intros P c.
unfold apply_lap; simpl.
unfold lap_inject_K_in_Kx.
rename c into d.
rewrite list_fold_right_map.
induction P as [| a]; simpl.
 rewrite ps_zero_monom_eq; reflexivity.

 rewrite IHP.
 rewrite ps_monom_add_l, ps_monom_mul_l.
 reflexivity.
Qed.

Theorem ps_monom_0_coeff_0 : ∀ c pow, (ps_monom c pow = 0)%ps → (c = 0)%K.
Proof.
intros c pow Hc.
apply ps_series_order_inf_iff in Hc.
apply series_order_iff in Hc; simpl in Hc.
pose proof (Hc O); assumption.
Qed.

Theorem in_power_list_lt : ∀ A la h (hv : puiseux_series A) pow,
  (h, hv) ∈ qpower_list pow la
  → (nat_num h < pow + length la)%nat.
Proof.
intros A la h hv pow Hh.
unfold qpower_list in Hh.
unfold pair_rec in Hh; simpl in Hh.
revert pow Hh.
induction la as [| a]; intros; [ contradiction | simpl ].
simpl in Hh.
destruct Hh as [Hh| Hh].
 injection Hh; clear Hh; intros; subst h hv.
 rewrite nat_num_Qnat.
 apply Nat.lt_sub_lt_add_l.
 rewrite Nat.sub_diag.
 apply Nat.lt_0_succ.

 rewrite Nat.add_succ_r, <- Nat.add_succ_l.
 apply IHla; assumption.
Qed.

Theorem in_points_of_ps_lap_gen_lt : ∀ la pow pt,
  pt ∈ points_of_ps_lap_gen pow la
  → (nat_num (fst pt) < pow + length la)%nat.
Proof.
intros la pow pt Hpt.
unfold points_of_ps_lap_gen in Hpt.
destruct pt as (h, hv); simpl.
eapply in_pts_in_ppl with (def := 0%ps) in Hpt; try reflexivity.
destruct Hpt as (Hpt, Hord).
eapply in_power_list_lt; eassumption.
Qed.

Theorem in_points_of_ps_lap_lt : ∀ la pt,
  pt ∈ points_of_ps_lap la
  → (nat_num (fst pt) < length la)%nat.
Proof.
intros la pt Hpt.
apply in_points_of_ps_lap_gen_lt in Hpt.
assumption.
Qed.

(* [Walker, p. 101] «
      Since O(āh-ah.x^αh) > αh, and O(āl.x^lγ₁) > β₁, we obtain
         f₁(x,y₁) = b₁.y₁^r + b₂.y₁^(r+1) + ... + g(x,y₁) »

   We prove here that
         f₁(x,y₁) = y₁^r.(c₁+y)^j.Ψ(c₁+y) + g(x,y₁) »
*)
Theorem f₁_eq_term_with_Ψ_plus_g : ∀ f L j αj c₁ r f₁ Ψ,
  newton_segments f = Some L
  → ini_pt L = (Qnat j, αj)
    → c₁ = ac_root (Φq f L)
      → r = root_multiplicity acf c₁ (Φq f L)
        → Ψ = quotient_phi_x_sub_c_pow_r (Φq f L) c₁ r
          → f₁ = next_pol f (β L) (γ L) c₁
            → (f₁ =
               POL [0%ps; 1%ps … []] ^ r *
               POL [ps_monom c₁ 0; 1%ps … []] ^ j *
               POL (lap_inject_K_in_Kx (al Ψ)) ∘
               POL [ps_monom c₁ 0; 1%ps … []] +
               g_of_ns f L)%pspol.
Proof.
intros f L j αj c₁ r f₁ Ψ HL Hini Hc₁ Hr HΨ Hf₁.
subst f₁.
remember (g_lap_of_ns f L) as gg.
remember Heqgg as H; clear HeqH.
unfold g_lap_of_ns in H; subst gg.
rewrite <- Hc₁ in H.
remember [ini_pt L … oth_pts L ++ [fin_pt L]] as pl eqn:Hpl .
remember (List.map (term_of_point f) pl) as tl eqn:Htl .
remember (List.map (λ t : term α nat, power t) tl) as l₁ eqn:Hl₁ .
remember (list_seq_except 0 (length (al f)) l₁) as l₂ eqn:Hl₂ .
symmetry in Hc₁.
rewrite f₁_eq_term_with_Ψ_plus_sum with (l₂ := l₂); try eassumption.
 rewrite ps_poly_lap_summ; [ idtac | intros i; simpl; apply lap_eq_refl ].
 rewrite ps_poly_lap_summ; [ simpl | intros i; simpl; apply lap_eq_refl ].
 unfold ps_pol_add, poly_add; simpl.
 unfold ps_lap_add in H; simpl in H.
 unfold ps_lap_mul in H; simpl in H.
 progress unfold ps_lap_pow in H.
 simpl in H; rewrite <- H; clear H.
 reflexivity.

 apply except_split_seq; [ idtac | idtac | assumption ].
  rewrite Hl₁, Htl, Hpl.
  do 2 apply Sorted_map; simpl.
  apply Sorted_fst_lt_nat_num_fst.
   intros a Ha.
   remember (points_of_ps_polynom f) as pts.
   symmetry in Heqpts.
   eapply pt_absc_is_nat; [ eassumption | idtac ].
   eapply ns_in_init_pts; [ idtac | eassumption ].
   rewrite <- Heqpts; assumption.

   eapply ini_oth_fin_pts_sorted; eassumption.

  simpl.
  rewrite Hl₁.
  apply List.Forall_forall; intros i Hi.
  split; [ apply Nat.le_0_l | idtac ].
  apply List.in_map_iff in Hi.
  destruct Hi as (x, (Hxi, Hx)).
  subst i.
  rewrite Htl in Hx.
  apply List.in_map_iff in Hx.
  destruct Hx as (y, (Hi, Hy)).
  subst x; simpl.
  rename y into pt.
  rewrite Hpl in Hy.
  eapply ns_in_init_pts in Hy; [ idtac | eassumption ].
  unfold points_of_ps_polynom in Hy.
  apply in_points_of_ps_lap_lt; assumption.
Qed.

Theorem nth_g_order_pos : ∀ f L h,
  newton_segments f = Some L
  → (order (ps_lap_nth h (g_lap_of_ns f L)) > 0)%Qbar.
Proof.
intros f L h HL.
destruct (lt_dec h (length (g_lap_of_ns f L))) as [Hlt| Hge].
 eapply each_power_of_y₁_in_g_has_coeff_pos_ord; try eassumption.
  reflexivity.

  unfold g_of_ns; simpl.
  unfold ps_lap_nth.
  apply list_nth_in; assumption.

 apply Nat.nlt_ge in Hge.
 unfold ps_lap_nth.
 rewrite List.nth_overflow; [ idtac | assumption ].
 rewrite order_0; constructor.
Qed.

Theorem order_nth_inject_K : ∀ la i,
  (0 ≤ order (ps_lap_nth i (lap_inject_K_in_Kx la)))%Qbar.
Proof.
intros la i.
revert i.
induction la as [| a]; intros; simpl.
 unfold ps_lap_nth.
 rewrite list_nth_nil.
 rewrite order_0; constructor.

 destruct i; [ idtac | apply IHla ].
 unfold ps_lap_nth; simpl.
 apply ps_monom_order_ge.
Qed.

Theorem monom_y_plus_c_is_inject_K : ∀ c,
  ([ps_monom c 0; 1%ps … []] = lap_inject_K_in_Kx [c; 1%K … []])%pslap.
Proof.
intros c.
unfold ps_lap_eq.
reflexivity.
Qed.

Theorem fold_lap_inject_K_in_Kx : ∀ la,
  List.map (λ c : α, ps_monom c 0) la = lap_inject_K_in_Kx la.
Proof. reflexivity. Qed.

Theorem lap_add_cons : ∀ α (R : ring α) a b la lb,
  ([a … la] + [b … lb] = [(a + b)%K … la + lb])%lap.
Proof. reflexivity. Qed.

Theorem lap_inject_add : ∀ la lb,
  (lap_inject_K_in_Kx la + lap_inject_K_in_Kx lb =
   lap_inject_K_in_Kx (la + lb)%lap)%pslap.
Proof.
intros la lb.
unfold lap_inject_K_in_Kx.
revert lb.
induction la as [| a]; intros; simpl.
 progress unfold ps_lap_add.
 rewrite lap_add_nil_l; reflexivity.

 destruct lb as [| b]; simpl.
  progress unfold ps_lap_add.
  rewrite lap_add_nil_r; reflexivity.

  progress unfold ps_lap_add.
  rewrite lap_add_cons.
  constructor; [ simpl | apply IHla ].
  rewrite ps_monom_add; reflexivity.
Qed.

Theorem lap_inject_mul : ∀ la lb,
  (lap_inject_K_in_Kx la * lap_inject_K_in_Kx lb =
   lap_inject_K_in_Kx (la * lb)%lap)%pslap.
Proof.
intros la lb.
unfold lap_inject_K_in_Kx.
revert lb.
induction la as [| a]; intros; simpl.
 progress unfold ps_lap_mul.
 do 2 rewrite lap_mul_nil_l; reflexivity.

 destruct lb as [| b]; simpl.
  progress unfold ps_lap_mul.
  do 2 rewrite lap_mul_nil_r; reflexivity.

  progress unfold ps_lap_mul.
  do 2 rewrite lap_mul_cons; simpl.
  constructor; [ simpl; apply ps_monom_mul | idtac ].
  symmetry.
  eapply ps_lap_eq_trans; [ apply lap_add_map_ps | ].
  unfold ps_lap_mul in IHla.
  unfold ps_lap_eq in IHla.
  rewrite IHla.
  progress unfold ps_lap_add.
  simpl.
  rewrite ps_zero_monom_eq.
  apply lap_add_compat; [ idtac | reflexivity ].
  eapply ps_lap_eq_trans; [ apply lap_add_map_ps | ].
  apply lap_add_compat.
   eapply ps_lap_eq_trans; [ apply lap_mul_map_ps | reflexivity ].
   eapply ps_lap_eq_trans; [ apply lap_mul_map_ps | reflexivity ].
Qed.

Theorem lap_inject_comp : ∀ la lb,
  (lap_inject_K_in_Kx la ∘ lap_inject_K_in_Kx lb =
   lap_inject_K_in_Kx (lap_compose la lb))%pslap.
Proof.
intros la lb.
progress unfold lap_inject_K_in_Kx; simpl.
progress unfold ps_lap_comp.
progress unfold lap_compose.
revert lb.
induction la as [| a]; intros; [ reflexivity | simpl ].
rewrite IHla.
do 3 rewrite fold_lap_inject_K_in_Kx.
rewrite fold_ps_lap_mul.
rewrite lap_inject_mul.
rewrite <- lap_inject_add.
reflexivity.
Qed.

(* [Walker, p 101] « O(bi) ≥ 0,  i = 0,...,n » *)
Theorem order_bbar_nonneg : ∀ f L c₁ r f₁,
  newton_segments f = Some L
  → c₁ = ac_root (Φq f L)
    → r = root_multiplicity acf c₁ (Φq f L)
      → f₁ = next_pol f (β L) (γ L) c₁
        → ∀ i, (order (ps_poly_nth i f₁) ≥ 0)%Qbar.
Proof.
intros f L c₁ r f₁ HL Hc₁ Hr Hf₁ i.
remember (quotient_phi_x_sub_c_pow_r (Φq f L) c₁ r) as Ψ eqn:HΨ .
remember HL as Hini; clear HeqHini.
apply exists_ini_pt_nat in Hini.
destruct Hini as (j, (αj, Hini)).
rewrite f₁_eq_term_with_Ψ_plus_g; try eassumption.
unfold ps_poly_nth; simpl.
rewrite fold_ps_lap_add.
rewrite ps_lap_nth_add.
rewrite fold_ps_lap_comp.
eapply Qbar.le_trans; [ idtac | apply order_add ].
apply Qbar.min_glb.
 rewrite <- lap_mul_assoc.
 rewrite fold_ps_lap_mul, fold_ps_lap_pow.
 destruct (le_dec r i) as [Hle| Hgt].
  rewrite ps_lap_nth_x_le_pow_mul; [ idtac | assumption ].
  progress unfold ps_lap_comp.
  rewrite monom_y_plus_c_is_inject_K.
  rewrite fold_ps_lap_pow.
  rewrite lap_power_map_ps.
  rewrite fold_ps_lap_comp.
  rewrite lap_inject_comp.
  rewrite fold_ps_lap_mul.
  rewrite lap_inject_mul.
  apply order_nth_inject_K.

  apply Nat.nle_gt in Hgt.
  rewrite ps_lap_nth_x_gt_pow_mul; [ idtac | assumption ].
  rewrite order_0; constructor.

 apply Qbar.lt_le_incl.
 apply nth_g_order_pos; assumption.
Qed.

(* [Walker, p 101] « O(bi) > 0,  i = 0,...,r-1 » *)
Theorem order_bbar_pos : ∀ f L c₁ r f₁,
  newton_segments f = Some L
  → c₁ = ac_root (Φq f L)
    → r = root_multiplicity acf c₁ (Φq f L)
      → f₁ = next_pol f (β L) (γ L) c₁
        → ∀ i, (i < r)%nat
          → (order (ps_poly_nth i f₁) > 0)%Qbar.
Proof.
intros f L c₁ r f₁ HL Hc₁ Hr Hf₁ i Hir.
remember (quotient_phi_x_sub_c_pow_r (Φq f L) c₁ r) as Ψ eqn:HΨ .
remember HL as Hini; clear HeqHini.
apply exists_ini_pt_nat in Hini.
destruct Hini as (j, (αj, Hini)).
rewrite f₁_eq_term_with_Ψ_plus_g; try eassumption.
unfold ps_poly_nth; simpl.
rewrite fold_ps_lap_add.
rewrite ps_lap_nth_add.
rewrite fold_ps_lap_comp.
eapply Qbar.lt_le_trans; [ idtac | apply order_add ].
apply Qbar.min_glb_lt.
 rewrite <- lap_mul_assoc.
 rewrite fold_ps_lap_mul.
 rewrite fold_ps_lap_pow.
 rewrite ps_lap_nth_x_gt_pow_mul; [ idtac | assumption ].
 rewrite order_0; constructor.

 apply nth_g_order_pos; assumption.
Qed.

Theorem char_pol_root_ne_0 : ∀ f L m c₁,
  newton_segments f = Some L
  → pol_in_K_1_m f m
  → c₁ = ac_root (Φq f L)
  → (c₁ ≠ 0)%K.
Proof.
intros f L m c₁ HL Hm Hc₁.
remember HL as Happ; clear HeqHapp.
eapply cpol_degree_ge_1 with (K := K) in Happ; eauto .
apply ac_prop_root in Happ.
rewrite <- Hc₁ in Happ.
remember HL as Hini; clear HeqHini.
apply exists_ini_pt_nat in Hini.
destruct Hini as (j, (αj, Hini)).
intros Hc; rewrite Hc in Happ.
unfold apply_poly in Happ; simpl in Happ.
rewrite Nat.sub_diag, list_pad_0 in Happ.
simpl in Happ.
rewrite rng_mul_0_r, rng_add_0_l in Happ.
revert Happ.
eapply ord_coeff_non_zero_in_newt_segm; eauto .
rewrite Hini; left; simpl.
rewrite nat_num_Qnat; reflexivity.
Qed.

(* [Walker, p 101] « O(br) = 0 » *)
Theorem order_bbar_r_is_0 : ∀ f L m c₁ r f₁,
  newton_segments f = Some L
  → pol_in_K_1_m f m
  → c₁ = ac_root (Φq f L)
  → r = root_multiplicity acf c₁ (Φq f L)
  → f₁ = next_pol f (β L) (γ L) c₁
  → (order (ps_poly_nth r f₁) = 0)%Qbar.
Proof.
intros f L m c₁ r f₁ HL Hm Hc₁ Hr Hf₁.
remember (quotient_phi_x_sub_c_pow_r (Φq f L) c₁ r) as Ψ eqn:HΨ .
remember HL as Hini; clear HeqHini.
apply exists_ini_pt_nat in Hini.
destruct Hini as (j, (αj, Hini)).
rewrite f₁_eq_term_with_Ψ_plus_g; try eassumption.
unfold ps_poly_nth; simpl.
remember ([0%ps; 1%ps … []] ^ r)%pslap as yr.
remember ([ps_monom c₁ 0; 1%ps … []] ^ j)%pslap as ycj.
remember (lap_inject_K_in_Kx (al Ψ)) as psi.
remember [ps_monom c₁ 0; 1%ps … []] as yc.
assert (order (ps_lap_nth r (yr * ycj * psi ∘ yc)) = 0)%Qbar as Hor.
 subst yr ycj psi yc.
 progress unfold ps_lap_mul.
 rewrite <- lap_mul_assoc.
 do 2 rewrite fold_ps_lap_mul.
 erewrite ps_lap_nth_x_le_pow_mul; [ idtac | reflexivity ].
 rewrite Nat.sub_diag.
 progress unfold ps_lap_mul.
 progress unfold lap_mul.
 progress unfold ps_lap_nth; simpl.
 rewrite list_nth_lap_convol_mul; [ idtac | reflexivity ].
 unfold summation; simpl.
 rewrite ps_add_0_r.
 rewrite order_mul.
 rewrite fold_ps_lap_nth.
 rewrite ps_lap_nth_0_cons_pow.
 rewrite order_pow.
  rewrite ps_monom_order.
   rewrite Qbar.mul_0_r; [ idtac | intros HH; discriminate HH ].
   rewrite Qbar.add_0_l.
   rewrite fold_ps_lap_nth.
   rewrite ps_lap_nth_0_apply_0.
   unfold ps_lap_comp.
   rewrite apply_lap_compose.
   unfold apply_lap at 2; simpl.
   rewrite ps_mul_0_l, ps_add_0_l.
   rewrite ps_mul_0_r, ps_add_0_l.
   rewrite apply_lap_inject_K_in_Kx_monom.
   rewrite ps_monom_order; [ reflexivity | idtac ].
   eapply psi_c₁_ne_0 in HΨ; eassumption.

   eapply char_pol_root_ne_0; eassumption.

  intros HH.
  apply ps_monom_0_coeff_0 in HH.
  revert HH.
  eapply char_pol_root_ne_0; eassumption.

 subst yr ycj psi yc.
 rewrite fold_ps_lap_add.
 rewrite ps_lap_nth_add.
 rewrite fold_ps_lap_comp.
 rewrite order_add_eq_min; rewrite Hor.
 rewrite Qbar.min_l; [ reflexivity | idtac ].
  apply Qbar.lt_le_incl.
  apply nth_g_order_pos; assumption.

  apply Qbar.lt_neq.
  apply nth_g_order_pos; assumption.
Qed.

Theorem exists_pol_ord : ∀ f, ∃ m,
  m = ps_pol_com_polydo f ∧ pol_in_K_1_m f m.
Proof.
intros f.
unfold pol_in_K_1_m.
remember (ps_pol_com_polydo f) as m eqn:Hm.
exists m; split; [ reflexivity | ].
apply ps_lap_forall_forall.
 intros a b Hab H.
 rewrite <- Hab; assumption.

 intros a Ha.
 unfold ps_pol_com_polydo in Hm.
 remember (al f) as la; clear Heqla.
 revert a m Ha Hm.
 induction la as [| b]; intros; [ contradiction | idtac ].
 simpl in Ha.
 destruct Ha as [(Hbla, Hba)| Ha].
  constructor.
  simpl in Hm.
  remember (ps_lap_com_polydo la) as m' eqn:Hm' .
  exists (adjust_ps 0 m' b).
  split; [ idtac | simpl; rewrite Pos.mul_comm; symmetry; assumption ].
  transitivity b; [ idtac | assumption ].
  symmetry; apply ps_adjust_eq.

  subst m; simpl.
  apply in_K_1_m_lap_mul_r_compat.
  apply IHla; [ apply Ha | reflexivity ].
Qed.

(* [Walker, p 101] «
     O(bi) ≥ 0,  i = 0,...,n
     O(bi) > 0,  i = 0,...,r-1
     O(br) = 0
   »
*)
Theorem f₁_orders : ∀ f L c₁ r f₁,
  newton_segments f = Some L
  → c₁ = ac_root (Φq f L)
  → r = root_multiplicity acf c₁ (Φq f L)
  → f₁ = next_pol f (β L) (γ L) c₁
  → (∀ i, (order (ps_poly_nth i f₁) ≥ 0)%Qbar)
    ∧ (∀ i, (i < r)%nat → (order (ps_poly_nth i f₁) > 0)%Qbar)
    ∧ (order (ps_poly_nth r f₁) = 0)%Qbar.
Proof.
intros f L c₁ r f₁ HL Hc₁ Hr Hf₁.
split; [ eapply order_bbar_nonneg; eassumption | idtac ].
split; [ eapply order_bbar_pos; eassumption | idtac ].
pose proof (exists_pol_ord f) as H.
destruct H as (m, (Hm, Hp)).
eapply order_bbar_r_is_0; eassumption.
Qed.

End theorems.


(** This file implements an interface to [expr] that
 ** makes star, emp, and pure assertions apparent.
 **)
(* Require Import ExtLib.Data.Positive. *)
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Data.List.
Require Import ExtLib.Data.Option.
Require Import ExtLib.Structures.Traversable.
Require Import ExtLib.Tactics.
Require Import BILogic Pure.
Require Import MirrorCore.EnvI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.AppN.
Require Import MirrorCore.Lambda.TypedFoldApp.
(*
Require Import MirrorCore.Ext.Expr.
Require Import MirrorCore.Ext.AppFull.
*)

Set Implicit Arguments.
Set Strict Implicit.

(** NOTE: This could work on arbitrary expr's **)
Section seplog_fold.
  Variable typ : Type.
  Variable RType_typ : RType typ.
  Variable Typ2_Fun : Typ2 _ Fun.
  Variable sym : Type.
  Variable RSym_sym : RSym sym.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

  Let Expr_expr := @Expr_expr typ sym _ _ _.
  Local Existing Instance Expr_expr.

  Variable T : Type.
  Variable SL : typ.

  Record SepLogArgs : Type :=
  { do_other : expr typ sym -> list (expr typ sym * T) -> T
  ; do_pure : expr typ sym -> T
  ; do_emp : T
  ; do_star : T -> T -> T
  }.

  Record SepLogSpec : Type :=
  { is_pure : expr typ sym -> bool
  ; is_emp : expr typ sym -> bool
  ; is_star : expr typ sym -> bool
  }.

  Variable sla : SepLogArgs.
  Variable sls : SepLogSpec.

  Record SepLogSpecOk (sls : SepLogSpec)
         (OPS : ILogic.ILogicOps (typD SL))
         (BI : BILOperators (typD SL)) : Type :=
  { _PureOp : @PureOp (typD SL)
  ; _Pure : @Pure _ OPS BI _PureOp
  ; His_pure : forall e,
                 sls.(is_pure) e = true ->
                 forall us vs val,
                   exprD us vs e SL = Some val ->
                   pure val
  ; His_emp : forall e,
                sls.(is_emp) e = true ->
                forall us vs,
                  exprD us vs e SL = Some empSP
  ; His_star : forall e,
                 sls.(is_star) e = true ->
                 forall us vs,
                   exprD us vs e (tyArr SL (tyArr SL SL)) =
                   Some match eq_sym (typ2_cast SL (tyArr SL SL)) in _ = t
                              return t
                        with
                          | eq_refl =>
                            match eq_sym (typ2_cast SL SL) in _ = t
                                  return _ -> t
                            with
                              | eq_refl => sepSP
                            end
                        end
  }.

  Record SepLogArgsOk (R_t : expr typ sym -> T -> tenv typ -> tenv typ -> Prop) :=
  { otherOk
    : forall e es tus tvs,
        @typeof_apps typ sym _ _ _ tus tvs e (List.map fst es) = Some SL ->
        (forall x y,
           In (x,y) es ->
           typeof_expr tus tvs x = Some SL ->
           R_t x y tus tvs) ->
        R_t (apps e (List.map fst es)) (sla.(do_other) e es) tus tvs
  ; pureOk
    : forall e tus tvs,
        typeof_expr tus tvs e = Some SL ->
        sls.(is_pure) e = true ->
        R_t e (sla.(do_pure) e) tus tvs
  ; empOk
    : forall e tus tvs,
        typeof_sym e = Some SL ->
        sls.(is_emp) (Inj e) = true ->
        R_t (Inj e) sla.(do_emp) tus tvs
  ; starOk
    : forall e l r l_res r_res tus tvs,
        typeof_sym e = Some (tyArr SL (tyArr SL SL)) ->
        typeof_expr tus tvs l = Some SL ->
        typeof_expr tus tvs r = Some SL ->
        sls.(is_star) (Inj e) = true ->
        R_t l l_res tus tvs ->
        R_t r r_res tus tvs ->
        R_t (apps (Inj e) (l :: r :: nil)) (sla.(do_star) l_res r_res) tus tvs
  }.

  Require Import ExtLib.Structures.Applicative.
  Instance Applicative_Lazy : Applicative Lazy :=
  { ap := fun _ _ f x z =>
            match f z , x z with
              | Some f , Some x => Some (f x)
              | _ , _ => None
            end
  ; pure := fun _ x => fun _ => Some x }.

  (** NOTE: This does not need to be typed! **)
  Definition AppFullFoldArgs_SepLogArgs
  : AppFullFoldArgs typ sym T.
  refine
    match sla , sls with
      | {| do_other := do_other
         ; do_pure := do_pure
         ; do_star := do_star
         ; do_emp := do_emp |}
      , {| is_pure := is_pure
         ; is_star := is_star
         ; is_emp := is_emp |} =>
        @Build_AppFullFoldArgs
          typ sym T
          (fun v _ _ =>
             if is_pure (Var v) then
               Some (do_pure (Var v))
             else
               if is_emp (Var v) then
                 Some do_emp
               else
                 Some (do_other (Var v) nil))
          (fun u _ _ =>
             if is_pure (UVar u) then
               Some (do_pure (UVar u))
             else
               if is_emp (UVar u) then
                 Some do_emp
               else
                 Some (do_other (UVar u) nil))
          (fun i _ _ =>
             if is_emp (Inj i) then
               Some do_emp
             else
               if is_pure (Inj i) then
                 Some (do_pure (Inj i))
               else
                 Some (do_other (Inj i) nil))
          (fun tus tvs t f fres args z =>
             if is_star f then
               match args with
                 | (_,_,l) :: (_,_,r) :: nil =>
                   match l z , r z with
                     | Some l , Some r =>
                       Some (do_star l r)
                     | _ , _ => None
                   end
                 | _ => Some do_emp
               end
             else
               let original := apps f (map (fun x => snd (fst x)) args) in
               if is_pure original then
                 Some (do_pure original)
               else
                 ap (pure (do_other f))
                    (mapT (fun tev => let '(t,e,v) := tev in
                                      match v tt with
                                        | None => None
                                        | Some v => Some (e,v)
                                      end) args))
          (fun tus tvs t _ e eres _ =>
             if is_pure (Abs t e) then
               Some (do_pure (Abs t e))
             else
               if is_emp (Abs t e) then
                 Some do_emp
               else
                 Some (do_other (Abs t e) nil))
    end.
  Defined.

(* TODO(gmalecha): Port the proof!
  Section sound.
    Hypothesis BILOps : BILOperators (typD nil SL).
    Context R_t `{slaok : SepLogArgsOk R_t}.

    Lemma atomic_ok
    : forall ts (tus tvs : tenv typ) e (t : typ),
        typeof_expr ts tus tvs e = Some t ->
        t = SL ->
        R_t e (sla.(do_other) e nil) tus tvs.
    Proof.
      destruct slaok. simpl; intros. subst.
      change e with (apps e nil) at 1.
      eapply (otherOk0 ts e nil tus tvs); simpl.
      { unfold typeof_apps. simpl. rewrite H. reflexivity. }
      { intuition. }
    Qed.

    Hypothesis is_starOk
    : forall i,
        sls.(is_star) (Inj i) = true ->
        typeof_sym i = Some (tyArr SL (tyArr SL SL)).

    Lemma lem_other
    : forall ts0 t rs tus tvs l_res do_atomic_app0,
        Forall2
          (fun (t0 : typ) (x : expr sym * (tenv typ -> tenv typ -> T)) =>
             typeof_expr tus tvs (fst x) = Some t0 /\
             (t0 = SL -> R_t (fst x) (snd x tus tvs) tus tvs)) ts0 rs ->
        forall e : expr sym,
          typeof_expr tus tvs (apps e (map fst rs)) = Some t ->
          (fold_right tyArr t ts0 = SL -> R_t e (l_res tus tvs) tus tvs) ->
          typeof_apps RSym_sym tus tvs e (map fst rs) = Some SL ->
          (forall (e0 : expr sym) (es : list (expr sym * T)) (tus0 tvs0 : tenv typ),
             typeof_apps RSym_sym tus0 tvs0 e0 (map fst es) = Some SL ->
             (forall (x : expr sym) (y : T),
                In (x, y) es -> typeof_expr tus0 tvs0 x = Some SL -> R_t x y tus0 tvs0) ->
             R_t (apps e0 (map fst es)) (do_atomic_app0 e0 es) tus0 tvs0) ->
          R_t (apps e (map fst rs))
              (do_atomic_app0 e
                              (map
                                 (fun x : expr sym * (tenv typ -> tenv typ -> T) =>
                                    (fst x, snd x tus tvs)) rs)) tus tvs.
    Proof.
      intros.
      specialize (H3 e (map
                          (fun x : expr sym * (tenv typ -> tenv typ -> T) =>
                             (fst x, snd x tus tvs)) rs) tus tvs).
      rewrite map_map in *. simpl in *.
      eapply H3; eauto.
      clear - H. induction H; simpl; intuition.
      inv_all. subst. rewrite H1 in *. inv_all; subst.
      eauto.
    Qed.

    Definition AppFullFoldArgsOk_SepLogsOk
    : AppFullFoldArgsOk _ (AppFullFoldArgs_SepLogArgs sla)
                        (fun t e res tus tvs =>
                           t = SL ->
                           R_t e res tus tvs).
    Proof.
      remember sla as s; destruct s; simpl; remember sls as s; destruct s.
      constructor.
      { simpl; intros.
        replace do_other0 with (sla.(do_other)).
        eapply atomic_ok; eauto. rewrite <- Heqs; reflexivity. }
      { simpl; intros.
        replace do_other0 with (sla.(do_other)).
        eapply atomic_ok; eauto. rewrite <- Heqs; reflexivity. }
      { simpl; intros.
        consider (is_emp0 v); intros.
        { replace do_emp0 with (sla.(do_emp)).
          eapply (@empOk _ slaok); eauto.
          Cases.rewrite_all_goal. auto.
          rewrite <- Heqs0. simpl. auto.
          rewrite <- Heqs. reflexivity. }
        { replace do_other0 with (sla.(do_other)).
          eapply atomic_ok; eauto. rewrite <- Heqs; reflexivity. } }
      { simpl; intros.
        replace do_other0 with (sla.(do_other)).
        eapply atomic_ok; eauto. rewrite <- Heqs; reflexivity. }
      { intros. subst ft. simpl.
        assert (typeof_apps RSym_sym tus tvs l (map fst rs) = Some SL).
        { rewrite <- typeof_expr_apps. congruence. }
        generalize (otherOk slaok). rewrite <- Heqs. simpl.
        destruct l; eauto using lem_other.
        consider (is_star0 s); eauto using lem_other; intros.
        { generalize H4. eapply is_starOk in H4.
          unfold typeof_apps in H3.
          simpl in H3. rewrite H4 in *.
          inversion H1; clear H1; try subst.
          { subst rs ts0; intros.
            simpl in *. clear - H3. inv_all.
            symmetry in H3. eapply tyArr_circ_L in H3. intuition. }
          { subst rs ts0. inversion H7; clear H7.
            { subst l l'; intros; simpl in *.
              rewrite H4 in *. forward.
              intuition. inv_all. subst y t0.
              clear - H8. symmetry in H8.
              eapply tyArr_circ_L in H8. intuition. }
            { subst l l'. inversion H8; clear H8.
              { subst l0 l'0. intuition. subst t.
                destruct y, y0; simpl in *.
                rewrite H8 in *. rewrite H6 in *. rewrite H4 in *.
                unfold type_of_apply in *. forward.
                inv_all.
                subst x0 x t1 t2 t3 p0 p.
                replace do_star0 with (sla.(do_star));
                  [ | rewrite <- Heqs; reflexivity ].
                eapply (starOk slaok); eauto.
                rewrite <- Heqs0. auto. }
              { exfalso. clear Heqs Heqs0. subst.
                simpl in H3. intuition.
                rewrite H2 in *. rewrite H6 in *. rewrite H1 in *.
                forward. inv_all; try subst.
                clear H15 H13. subst x x0 x1.
                clear - H14.
                eapply type_of_applys_circle_False in H14. auto. } } } } }
    Qed.

    Definition seplog_fold (sla : SepLogArgs) : expr sym -> tenv typ -> tenv typ -> T :=
      app_fold_args (AppFullFoldArgs_SepLogArgs sla).

    Theorem seplog_fold_sound
    : forall e tus tvs result,
        seplog_fold sla e tus tvs = result ->
        typeof_expr tus tvs e = Some SL ->
        R_t e result tus tvs.
    Proof.
      intros.
      eapply (app_fold_args_sound AppFullFoldArgsOk_SepLogsOk) in H; eauto.
    Qed.
  End sound.
*)

(*
  Variable OPS : ILogic.ILogicOps (typD ts nil SL).
  Variable BI : BILOperators (typD ts nil SL).
  Variable slsok : SepLogSpecOk sls OPS BI.

  Require Import Relations.
  Require Import ExtLib.Data.HList.

  Record SepLogArgsSemOk
         (TD : T -> forall tus tvs, tenv typ -> tenv typ -> option (typD ts nil SL))
         (R : forall tus tvs,
                relation (hlist (typD ts nil) tus ->
                          hlist (typD ts nil) tvs ->
                          typD ts nil SL)) :=
  { atomic_appOk
    : forall e es tus tvs val,
        exprD' tus tvs (apps e es) SL = Some val ->
        R tus tvs val (TD (sla.(do_other) e es))
  ; pureOk
    : forall e tus tvs,
        typeof_expr tus tvs e = Some SL ->
        sls.(is_pure) e = true ->
        R_t e (sla.(do_pure) e) tus tvs
  ; empOk
    : forall e tus tvs,
        typeof_sym e = Some SL ->
        sls.(is_emp) e = true ->
        R_t (Inj e) sla.(do_emp) tus tvs
  ; starOk
    : forall e l r l_res r_res tus tvs,
        typeof_sym e = Some (tyArr SL (tyArr SL SL)) ->
        typeof_expr tus tvs l = Some SL ->
        typeof_expr tus tvs r = Some SL ->
        sls.(is_star) e = true ->
        R_t l l_res tus tvs ->
        R_t r r_res tus tvs ->
        R_t (apps (Inj e) (l :: r :: nil)) (sla.(do_star) l_res r_res) tus tvs
  }.
*)

End seplog_fold.


Require Import Crypto.Util.Notations.

Local Set Boolean Equality Schemes.
Local Set Decidable Equality Schemes.
Local Set Implicit Arguments.
Inductive ErrorT {ErrT T} :=
| Success (v : T)
| Error (msg : ErrT).

Global Arguments ErrorT : clear implicits.
Declare Scope error_scope.
Delimit Scope error_scope with error.
Bind Scope error_scope with ErrorT.

Definition invert_result {ErrT T} (v : ErrorT ErrT T)
  := match v return match v with Success _ => T | _ => ErrT end with
     | Success v => v
     | Error msg => msg
     end.

Definition bind {A B ErrT} (x : ErrorT ErrT A) (k : A -> ErrorT ErrT B) : ErrorT ErrT B
  := match x with
     | Success v => k v
     | Error msg => Error msg
     end.

Definition map2 {ErrT1 ErrT2 A B} (f : A -> B) (fe : ErrT1 -> ErrT2) (x : ErrorT ErrT1 A) : ErrorT ErrT2 B
  := match x with
     | Success v => Success (f v)
     | Error e => Error (fe e)
     end.

Definition map {ErrT A B} (f : A -> B) : ErrorT ErrT A -> ErrorT ErrT B
  := map2 f id.

Definition map_error {ErrT1 ErrT2 A} (fe : ErrT1 -> ErrT2) : ErrorT ErrT1 A -> ErrorT ErrT2 A
  := map2 id fe.

Definition error_bind {ErrT1 ErrT2 A} (x : ErrorT ErrT1 A) (k : ErrT1 -> ErrorT ErrT2 A) : ErrorT ErrT2 A
  := match x with
     | Success v => Success v
     | Error msg => k msg
     end.

Notation "x <- y ; f" := (bind y (fun x => f%error)) : error_scope.

(** ** Equality for [ErrorT] *)
Section ErrorT.
  Local Notation ErrorT_code u v
    := (match u, v with
        | Success u', Success v'
        | Error u', Error v'
          => u' = v'
        | Success _, _
        | Error _, _
          => False
        end).

  (** *** Equality of [ErrorT] is a [match] *)
  Definition path_ErrorT {A B} (u v : ErrorT A B) (p : ErrorT_code u v)
    : u = v.
  Proof. destruct u, v; first [ apply f_equal | exfalso ]; exact p. Defined.

  (** *** Equivalence of equality of [ErrorT] with [ErrorT_code] *)
  Definition unpath_ErrorT {A B} {u v : ErrorT A B} (p : u = v)
    : ErrorT_code u v.
  Proof. subst v; destruct u; reflexivity. Defined.

  Definition path_ErrorT_iff {A B}
             (u v : @ErrorT A B)
    : u = v <-> ErrorT_code u v.
  Proof.
    split; [ apply unpath_ErrorT | apply path_ErrorT ].
  Defined.

  (** *** Eta-expansion of [@eq (ErrorT _ _)] *)
  Definition path_ErrorT_eta {A B} {u v : @ErrorT A B} (p : u = v)
    : p = path_ErrorT u v (unpath_ErrorT p).
  Proof. destruct u, p; reflexivity. Defined.

  (** *** Induction principle for [@eq (ErrorT _ _)] *)
  Definition path_ErrorT_rect {A B} {u v : @ErrorT A B} (P : u = v -> Type)
             (f : forall p, P (path_ErrorT u v p))
    : forall p, P p.
  Proof. intro p; specialize (f (unpath_ErrorT p)); destruct u, p; exact f. Defined.
  Definition path_ErrorT_rec {A B u v} (P : u = v :> @ErrorT A B -> Set) := path_ErrorT_rect P.
  Definition path_ErrorT_ind {A B u v} (P : u = v :> @ErrorT A B -> Prop) := path_ErrorT_rec P.
End ErrorT.

(** ** Useful Tactics *)
(** *** [inversion_ErrorT] *)
Ltac induction_path_ErrorT H :=
  induction H as [H] using path_ErrorT_rect;
  try match type of H with
      | False => exfalso; exact H
      end.
Ltac inversion_ErrorT_step :=
  match goal with
  | [ H : Success _ = Success _ |- _ ]
    => induction_path_ErrorT H
  | [ H : Success _ = Error _ |- _ ]
    => induction_path_ErrorT H
  | [ H : Error _ = Success _ |- _ ]
    => induction_path_ErrorT H
  | [ H : Error _ = Error _ |- _ ]
    => induction_path_ErrorT H
  end.
Ltac inversion_ErrorT := repeat inversion_ErrorT_step.


Require Import Arith.
Require Import Zee.vals.
Require Import Zee.dec Zee.maplike.
Require Import Lia.
Require Import String.

Section Frame.
  Context {A : Set}.
  Definition V := @V A.
  Definition SecTyV := @SecTyV A.

(*  Definition Lab := @Lab A.
  Definition Ty := @Ty A.
  Definition LabVar := @LabVar A.
  Definition SecTy := @SecTy A.
  Definition AtomSecTy := @AtomSecTy A.
*)

  Definition Range : Type := nat * nat.
  Opaque Range.

  Class HasRange (A : Type) :=
    {
      dom: A -> Range
    }.
  Hint Constructors HasRange.

  Global Instance HasRange_Range : HasRange Range.
  Proof.
    constructor.
    eapply id.
  Defined.

  Definition in_range {T : Type} `{HasRange T} (n : nat) (x : T) : Prop :=
    let (n1, n2) := dom x in n1 <= n /\ n <= n1 + n2.
  Hint Unfold in_range.

  Infix "∈" := in_range (at level 70).
  Infix "∉" := (fun n r => not (in_range n r)) (at level 80).

  Lemma in_range_dec {T : Type} `{HasRange T} n r:
    { n ∈ r } + { n ∉ r }.
  Proof.
    destruct (dom r) as [n1 n2] eqn:?H.
    unfold in_range.
    rewrite -> H0.
    destruct (le_dec n1 n).
    - destruct (le_dec n (n1 + n2)).
      + left.
        split; assumption.
      + right.
        intro.
        eapply n0.
        eapply (proj2 H1).
    - right.
      intro.
      eapply n0.
      eapply (proj1 H1).
  Defined.

  Class HasVersion (A : Type) :=
    {
      version: A -> Version
    }.
  Hint Constructors HasVersion.

  Record EFrame (M : Type) `{MapLike M nat V} :=
    {
      range_of : Range;
      mem_of : M;
      version_of: Version
    }.
  Hint Constructors EFrame.
  Global Arguments Build_EFrame { _ } { _ }.
  Global Arguments range_of { _ } { _ }.
  Global Arguments mem_of { _ } { _ }.
  Global Arguments version_of { _ } { _ }.

  Global Instance HasRange_EFrame {M : Type} `{MapLike M nat V} :
    HasRange (EFrame M) := {}.
  intros.
  eapply (dom (range_of X)).
  Defined.

  Global Instance HasVersion_EFrame {M : Type} `{MapLike M nat V} :
    HasVersion (EFrame M) := {}.
  intros.
  eapply (version_of X).
  Defined.

  Global Instance ReadableMapLike_EFrame {M : Type} `{MapLike M nat V} :
    ReadableMapLike (EFrame M) nat V := {}.
  - intros efr n.
    eapply (mem_of efr ? n).
  - eapply (Build_EFrame (0, 0) ∅ 0).
  - intros.
    simpl.
    eapply lookup_empty_map.
  Defined.

  Global Instance WriteableMapLike_EFrame {M : Type} `{MapLike M nat V} :
    WriteableMapLike (EFrame M) nat V := {}.
  intros n v efr.
  eapply (Build_EFrame (dom efr) (mem_of efr [n ↦ v]) (version_of efr)).
  Defined.

  Global Instance MapLike_EFrame {M : Type} `{MapLike M nat V} :
    MapLike (EFrame M) nat V := {}.
  - intros.
    simpl.
    eapply lookup_update_eq.
  - intros.
    simpl.
    eapply lookup_update_neq.
    assumption.
  Defined.

  Definition fp_of {T : Type} `{HasRange T} (x : T) := fst (dom x).
  Definition sp_of {T : Type} `{HasRange T} (x : T) := fst (dom x) + snd (dom x).
  Hint Unfold fp_of sp_of.

  Definition wf_EFrame {M : Type} `{MapLike M nat V} (efr : EFrame M) : Prop :=
    forall a, a ∈ efr -> efr ? a <> None.
  Hint Unfold wf_EFrame.

  Record PFrame (Var Arg Loc : Type) `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} :=
    {
      pvar_of : Var;
      parg_of : Arg;
      ploc_of : Loc;
    }.
  Hint Constructors PFrame.
  Global Arguments Build_PFrame { _ } { _ } { _ } { _ } { _ } { _ }.
  Global Arguments pvar_of { _ } { _ } { _ } { _ } { _ } { _ }.
  Global Arguments parg_of { _ } { _ } { _ } { _ } { _ } { _ }.
  Global Arguments ploc_of { _ } { _ } { _ } { _ } { _ } { _ }.

  Global Instance ReadableMapLike_PFrame {Var Arg Loc : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} : ReadableMapLike (PFrame Var Arg Loc) string (A + SecTyV) := {}.
  - intros pfr x.
    eapply (pvar_of pfr ? x).
  - eapply (Build_PFrame ∅ ∅ ∅).
  - intros.
    simpl.
    eapply lookup_empty_map.
  Defined.

  Global Instance WriteableMapLike_PFrame {Var Arg Loc : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} : WriteableMapLike (PFrame Var Arg Loc) string (A + SecTyV) := {}.
  intros x τℓ pfr.
  eapply (Build_PFrame (pvar_of pfr [x ↦ τℓ]) (parg_of pfr) (ploc_of pfr)).
  Defined.

  Global Instance MapLike_PFrame {Var Arg Loc : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} : MapLike (PFrame Var Arg Loc) string (A + SecTyV) := {}.
  - intros.
    simpl.
    eapply lookup_update_eq.
  - intros.
    simpl.
    eapply lookup_update_neq.
    assumption.
  Defined.

  Global Instance FinMapLike_PFrame {Var Arg Loc : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} : FinMapLike (PFrame Var Arg Loc) string (A + SecTyV) := {}.
  - intros pfr.
    eapply (values (pvar_of pfr)).
  - cbn.
    eapply values_empty.
  - intros.
    eapply values_add.
  Defined.

  Definition upd_loc {Var Arg Loc : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} (x : string) (τ : SecTyV) (pfr : PFrame Var Arg Loc): PFrame Var Arg Loc.
    eapply (Build_PFrame (pvar_of pfr)
                         (parg_of pfr)
                         (update x τ (ploc_of pfr))).
  Defined.

  Definition upd_arg {Var Arg Loc : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} (x : string) (τ : SecTyV) (pfr : PFrame Var Arg Loc): PFrame Var Arg Loc.
    eapply (Build_PFrame (pvar_of pfr)
                         (update x τ (parg_of pfr))
                         (ploc_of pfr)).
  Defined.

  Definition upd_var {Var Arg Loc : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} (x : string) (τℓ : A + SecTyV) (pfr : PFrame Var Arg Loc) : PFrame Var Arg Loc.
    eapply (Build_PFrame (update x τℓ (pvar_of pfr))
                         (parg_of pfr)
                         (ploc_of pfr)).
  Defined.
  Hint Unfold upd_loc upd_arg upd_var.

  Record Frame (Var Arg Loc Mem : Type) `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V} :=
    {
      pframe_of : PFrame Var Arg Loc;
      eframe_of : EFrame Mem
    }.
  Hint Constructors Frame.

  Global Arguments pframe_of { _ } { _ } { _ } { _ } { _ } { _ } { _ } { _ }.
  Global Arguments eframe_of { _ } { _ } { _ } { _ } { _ } { _ } { _ } { _ }.
  Global Arguments Build_Frame { _ } { _ } { _ } { _ } { _ } { _ } { _ } { _ }.

  Global Instance ReadableMapLike_nat_V_Fr {Var Arg Loc Mem : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V} : ReadableMapLike (Frame Var Arg Loc Mem) nat V := {}.
  - exact (fun fr n => eframe_of fr ? n).
  - eapply (Build_Frame ∅ ∅).
  - intros.
    simpl.
    eapply lookup_empty_map.
  Defined.

  Global Instance WriteableMapLike_nat_V_Fr {Var Arg Loc Mem : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V}: WriteableMapLike (Frame Var Arg Loc Mem) nat V := {}.
  exact (fun n v fr => Build_Frame (pframe_of fr) (eframe_of fr [n ↦ v])).
  Defined.

  Global Instance MapLike_nat_V_Fr {Var Arg Loc Mem : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V}: MapLike (Frame Var Arg Loc Mem) nat V := {}.
  Proof.
    - intros.
      simpl.
      eapply lookup_update_eq.
    - intros.
      simpl.
      eapply lookup_update_neq; assumption.
  Defined.
  Hint Resolve MapLike_nat_V_Fr.

  Global Instance HasVersion_Fr {Var Arg Loc Mem : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V} : HasVersion (Frame Var Arg Loc Mem).
  constructor.
  intros.
  eapply (version (eframe_of X)).
  Defined.
  Hint Resolve HasVersion_Fr.

  Global Instance ReadableMapLike_var_ty_or_sec_Fr {Var Arg Loc Mem : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V}: ReadableMapLike (Frame Var Arg Loc Mem) string (A + SecTyV) := {}.
  - exact (fun fr x => pframe_of fr ? x).
  - eapply (Build_Frame ∅ ∅).
  - intros.
    simpl.
    eapply lookup_empty_map.
  Defined.

  Global Instance WriteableMapLike_var_ty_or_sec_Fr {Var Arg Loc Mem : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V}: WriteableMapLike (Frame Var Arg Loc Mem) string (A + SecTyV) := {}.
  exact (fun x τℓ fr => Build_Frame (pframe_of fr [x ↦ τℓ]) (eframe_of fr)).
  Defined.

  Global Instance MapLike_var_ty_or_sec_Fr {Var Arg Loc Mem : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V}: MapLike (Frame Var Arg Loc Mem) string (A + SecTyV) := {}.
  - intros.
    simpl.
    eapply lookup_update_eq.
  - intros.
    simpl.
    eapply lookup_update_neq; assumption.
  Defined.
  Hint Resolve MapLike_var_ty_or_sec_Fr.

  Global Instance FinMapLike_var_ty_or_sec_Fr {Var Arg Loc Mem : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V}: FinMapLike (Frame Var Arg Loc Mem) string (A + SecTyV) := {}.
  exact (fun fr => values (pframe_of fr)).
  - cbn.
    eapply values_empty.
  - intros.
    cbn.
    eapply values_add.
  Defined.
  Hint Resolve FinMapLike_var_ty_or_sec_Fr.

  Global Instance HasRange_Frame {Var Arg Loc Mem : Type} `{FinMapLike Var string (A + SecTyV)} `{FinMapLike Arg string SecTyV} `{FinMapLike Loc string SecTyV} `{MapLike Mem nat V}: HasRange (Frame Var Arg Loc Mem) := {}.
  intros fr.
  eapply (dom (eframe_of fr)).
  Defined.

End Frame.

Infix "∈" := in_range (at level 70).
Infix "∉" := (fun n r => not (in_range n r)) (at level 80).


From RecoveryRefinement Require Import Lib.
Require Import Spec.HoareTactics.

Require Import Examples.Logging.Impl.

From Classes Require Import Classes.

Opaque plus.
Opaque lt.

Import EqualDecNotation.

Record LogValues :=
  { values :> list block;
    values_ok: length values = LOG_LENGTH }.

Coercion addresses : Descriptor >-> list.

Record PhysicalState :=
  { p_hdr: LogHdr;
    p_desc: Descriptor;
    p_log_values: LogValues;
    p_data_region: disk; }.

Inductive PhyDecode (d: disk) : PhysicalState -> Prop :=
| phy_decode hdr desc (log_values:LogValues) data
             (Hhdr: index d 0 = Some (LogHdr_fmt.(encode) hdr))
             (Hdesc: index d 1 = Some (Descriptor_fmt.(encode) desc))
             (Hlog_values: forall i,
                 i < LOG_LENGTH ->
                 index d (2+i) = index log_values i)
             (Hdata: forall i,
                 index d (2+LOG_LENGTH+i) = index data i) :
    PhyDecode d {| p_hdr := hdr;
                   p_desc := desc;
                   p_log_values := log_values;
                   p_data_region := data; |}
.

Lemma log_length_nonzero : LOG_LENGTH > 0.
  unfold LOG_LENGTH.
  lia.
Qed.

(* coercion magic makes this theorem seem odd - the proof comes from inside
log_values *)
Lemma length_log (log_values:LogValues) :
  length log_values = LOG_LENGTH.
Proof.
  destruct log_values; auto.
Qed.

#[export] Hint Rewrite length_log : length.

(* TODO: Hint Rewrite length_descriptor breaks a proof here *)

Theorem PhyDecode_disk_bound d ps :
  PhyDecode d ps ->
  length d >= 2 + LOG_LENGTH.
Proof.
  pose proof log_length_nonzero.
  inversion 1; subst.
  specialize (Hlog_values (LOG_LENGTH-1) ltac:(lia)).
  rewrite (index_inbounds log_values (LOG_LENGTH-1)) in Hlog_values;
    autorewrite with length;
    try lia.
  apply index_some_bound in Hlog_values.
  lia.
Qed.

Theorem PhyDecode_data_len d ps :
  PhyDecode d ps ->
  length ps.(p_data_region) = length d - 2 - LOG_LENGTH.
Proof.
  inversion 1; subst; simpl.
  apply length_bounds.
  - apply index_none_bound.
    rewrite <- Hdata; array.
  - assert (length d <= 2 + LOG_LENGTH + length data); try lia.
    apply index_none_bound.
    rewrite Hdata; array.
Qed.

Theorem PhyDecode_disk_len d ps :
  PhyDecode d ps ->
  length d = 2 + LOG_LENGTH + length ps.(p_data_region).
Proof.
  intros.
  pose proof (PhyDecode_disk_bound H).
  pose proof (PhyDecode_data_len H).
  lia.
Qed.

Lemma one_disk_failure_unfold s s' r :
  D.one_disk_failure s s' r ->
  s' = s.
Proof.
  inversion 1; auto.
Qed.

Lemma ODLayer_crash s s' r :
  D.ODLayer.(crash_step) s s' r ->
  s' = s.
Proof.
  simpl; eauto using one_disk_failure_unfold.
Qed.

Global Hint Resolve ODLayer_crash : core.

Ltac match_abs :=
  match goal with
  | [ H: PhyDecode ?d _ |- PhyDecode ?d _ ] => exact H
  | [ H: PhyDecode ?d ?ps |- context[PhyDecode ?d _] ] =>
    match goal with
    | |- exists _, _ => solve [ destruct ps; descend; eauto ]
    end
  end.

Ltac simplify :=
  repeat match goal with
         | _ => match_abs
         | _ => progress propositional
         | [ H: D.one_disk_failure _ _ _ |- _ ] =>
           apply one_disk_failure_unfold in H
         | [ H: D.ODLayer.(sem).(crash_step) _ _ _ |- _ ] =>
           apply ODLayer_crash in H
         | |- _ /\ _ => split; [ solve [ auto ] | ]
         | |- _ /\ _ => split; [ | solve [ auto ] ]
         | _ => destruct_tuple
         | [ u: unit |- _ ] => destruct u
         | [ H: (_, _) = (_, _) |- _ ] => inv_clear H
         | _ => progress cbn [pre post alternate] in *
         end.

Ltac finish :=
  repeat match goal with
         | _ => match_abs
         | _ => solve [ eauto ]
         | _ => congruence
         | _ => lia
         end.

Lemma and_wlog (P Q:Prop) :
  P ->
  (P -> Q) ->
  P /\ Q.
Proof.
  firstorder.
Qed.

Ltac split_wlog :=
  repeat match goal with
         | _ => match_abs
         | |- _ /\ _ => apply and_wlog
         | [ H: _ \/ _ |- _ ] => destruct H
         | _ => progress propositional
         | _ => solve [ auto ]
         end.

Ltac split_cases :=
  repeat match goal with
         | _ => match_abs
         | |- _ /\ _ => split
         | [ H: _ \/ _ |- _ ] => destruct H
         | _ => progress propositional
         | _ => solve [ eauto ]
         end.

(* specs for one-disk primitives (restatement of semantics as specs) *)
Ltac prim :=
  eapply proc_hspec_impl; [ unfold spec_impl | eapply op_spec_sound ];
  simpl in *;
  propositional;
  (intuition eauto);
  propositional;
  repeat match goal with
         | [ H: D.one_disk_failure _ _ _ |- _ ] =>
           apply one_disk_failure_unfold in H
         end.

Local Notation proc_hspec := (Hoare.proc_hspec D.ODLayer.(sem)).
Arguments Hoare.proc_hspec {Op State} sem {T}.

Theorem read_ok a :
  proc_hspec
    (read a)
    (fun state =>
       {| pre := True;
          post state' r :=
            index state a ?|= eq r /\
            state' = state;
          alternate state' _ :=
            state' = state; |}).
Proof.
  unfold read.
  prim;
    repeat match goal with
           | [ H: D.op_step _ _ _ _ |- _ ] => invert H; clear H
           end;
    propositional;
    auto.
  destruct (index s' a); simpl; finish.
Qed.

Theorem write_ok a v :
  proc_hspec
    (write a v)
    (fun state =>
       {| pre := True;
          post state' r :=
            r = tt /\
            state' = assign state a v;
          alternate state' _ :=
            state' = state \/
            state' = assign state a v; |}).
Proof.
  unfold write.
  prim;
    repeat match goal with
           | [ H: D.op_step _ _ _ _ |- _ ] => invert H; clear H
           end;
    propositional;
    auto.
Qed.

Theorem size_ok :
  proc_hspec
    (size)
    (fun state =>
       {| pre := True;
          post state' r :=
            r = length state /\
            state' = state;
          alternate state' _ :=
            state' = state; |}).
Proof.
  unfold size.
  prim;
    repeat match goal with
           | [ H: D.op_step _ _ _ _ |- _ ] => invert H; clear H
           end;
    propositional;
    auto.
Qed.

Local Hint Resolve read_ok write_ok size_ok : core.

Ltac step :=
  step_proc; simplify; eauto.

Opaque index.
Opaque D.ODLayer.

Theorem gethdr_ok ps :
  proc_hspec
    gethdr
    (fun state =>
       {| pre := PhyDecode state ps;
          post state' r :=
            r = ps.(p_hdr) /\
            state' = state;
          alternate state' _ :=
            state' = state; |}).
Proof.
  unfold gethdr.
  step.
  step.
  inversion H; subst; simpl in *.
  replace (index state 0) in *; simpl in *; subst.
  rewrite LogHdr_fmt.(encode_decode); eauto.
Qed.

Local Hint Resolve gethdr_ok : core.

Lemma phy_writedesc:
  forall (ps : PhysicalState) (desc : Descriptor) (s : D.State),
    PhyDecode s ps ->
    PhyDecode (assign s 1 (Descriptor_fmt.(encode) desc))
              {|
                p_hdr := ps.(p_hdr);
                p_desc := desc;
                p_log_values := ps.(p_log_values);
                p_data_region := ps.(p_data_region) |}.
Proof.
  intros ps desc s H.
  pose proof (PhyDecode_disk_len H).
  inv_clear H; constructor; intros; array.
Qed.

Local Hint Resolve phy_writedesc : core.

Lemma phy_writehdr:
  forall (ps : PhysicalState) (hdr : LogHdr) (s : D.ODLayer.(State)),
    PhyDecode s ps ->
    PhyDecode (assign s 0 (LogHdr_fmt.(encode) hdr))
              {| p_hdr := hdr;
                 p_desc := ps.(p_desc);
                 p_log_values := ps.(p_log_values);
                 p_data_region := ps.(p_data_region) |}.
Proof.
  intros ps hdr s H.
  pose proof (PhyDecode_disk_len H).
  inv_clear H; constructor; intros; array.
Qed.

Local Hint Resolve phy_writehdr : core.

Ltac spec_impl :=
  eapply proc_hspec_impl; [ unfold spec_impl | solve [ eauto] ];
  simplify.

Theorem writehdr_ok ps hdr :
  proc_hspec
    (writehdr hdr)
    (fun state =>
       {| pre := PhyDecode state ps;
          post state' r :=
            PhyDecode state' {| p_hdr := hdr;
                            p_desc := ps.(p_desc);
                            p_log_values := ps.(p_log_values);
                            p_data_region := ps.(p_data_region); |};
          alternate state' _ :=
            PhyDecode state' ps \/
            PhyDecode state' {| p_hdr := hdr;
                            p_desc := ps.(p_desc);
                            p_log_values := ps.(p_log_values);
                            p_data_region := ps.(p_data_region); |}
       |}).
Proof.
  unfold writehdr.
  spec_impl; split_wlog.
Qed.

Local Hint Resolve writehdr_ok : core.

Theorem writedesc_ok ps desc :
  proc_hspec
    (writedesc desc)
    (fun state =>
       {| pre := PhyDecode state ps;
          post state' r :=
            r = tt /\
            PhyDecode state' {| p_hdr := ps.(p_hdr);
                            p_desc := desc;
                            p_log_values := ps.(p_log_values);
                            p_data_region := ps.(p_data_region); |};
          alternate state' _ :=
            PhyDecode state' ps \/
            PhyDecode state' {| p_hdr := ps.(p_hdr);
                            p_desc := desc;
                            p_log_values := ps.(p_log_values);
                            p_data_region := ps.(p_data_region); |}
       |}).
Proof.
  unfold writedesc.
  spec_impl; split_wlog.
Qed.

Local Hint Resolve writedesc_ok : core.

Definition log_assign (log_values:LogValues) i b : LogValues :=
  {| values := assign log_values i b;
     values_ok := ltac:(autorewrite with length; auto); |}.

Local Hint Resolve addresses_length : core.

Definition desc_assign (desc:Descriptor) i a : Descriptor :=
  {| addresses := assign desc i a;
     addresses_length := ltac:(autorewrite with length; auto); |}.

Lemma phy_set_log_value:
  forall (ps : PhysicalState) (i : nat) (a : addr) (v : block),
    i < LOG_LENGTH ->
    forall s : D.State,
      PhyDecode s
                {|
                  p_hdr := ps.(p_hdr);
                  p_desc := add_addr ps.(p_desc) i a;
                  p_log_values := ps.(p_log_values);
                  p_data_region := ps.(p_data_region) |} ->
      PhyDecode (assign s (2 + i) v)
                {|
                  p_hdr := ps.(p_hdr);
                  p_desc := desc_assign ps.(p_desc) i a;
                  p_log_values := log_assign ps.(p_log_values) i v;
                  p_data_region := ps.(p_data_region) |}.
Proof.
  intros ps i a v Hbound s H.
  pose proof (PhyDecode_disk_len H); simpl in *.
  inv_clear H; constructor; intros;
    cbn [log_assign values]; array.

  destruct (i == i0); subst; array.
Qed.

Local Hint Resolve phy_set_log_value : core.

Theorem getdesc_ok ps :
  proc_hspec
    (getdesc)
    (fun state =>
       {| pre := PhyDecode state ps;
          post state' r :=
            r = ps.(p_desc) /\
            state' = state;
          alternate state' _ :=
            state' = state; |}).
Proof.
  unfold getdesc.
  step.
  step.
  inv_clear H; simpl in *.
  replace (index state 1) in *; simpl in *; propositional.
  rewrite Descriptor_fmt.(encode_decode); eauto.
Qed.

Local Hint Resolve getdesc_ok : core.

Theorem set_desc_ok ps desc i a v :
  proc_hspec
    (set_desc desc i a v)
    (fun state =>
       {| pre := PhyDecode state ps /\
                 ps.(p_desc) = desc /\
                 i < LOG_LENGTH;
          post state' r :=
            r = tt /\
            PhyDecode state' {| p_hdr := ps.(p_hdr);
                           p_desc := desc_assign desc i a;
                           p_log_values :=
                             log_assign ps.(p_log_values) i v;
                           p_data_region := ps.(p_data_region) |};
          alternate state' _ :=
            exists desc' log_values',
              PhyDecode state' {| p_hdr := ps.(p_hdr);
                              p_desc := desc';
                              p_log_values := log_values';
                              p_data_region := ps.(p_data_region); |};
       |}).
Proof.
  unfold set_desc.
  step; split_cases; simplify; finish.
  spec_impl; split_wlog; simplify; finish.
Qed.

Local Hint Resolve set_desc_ok : core.

Theorem phy_log_size_ok ps :
  proc_hspec
    (log_size)
    (fun state =>
       {| pre := PhyDecode state ps;
          post state' r :=
            state' = state /\
            r = length ps.(p_data_region);
          alternate state' _ :=
            state' = state; |}).
Proof.
  unfold log_size.
  step.
  step.
  pose proof (PhyDecode_data_len H).
  intuition eauto.
  lia.
Qed.

Local Hint Resolve phy_log_size_ok : core.

Lemma sel_log_value d ps i :
  PhyDecode d ps ->
  i < LOG_LENGTH ->
  sel d (2 + i) = sel ps.(p_log_values) i.
Proof.
  intros; inv_clear H; simpl.
  apply sel_index_eq.
  eauto.
Qed.

Theorem get_logwrite_ok ps desc i :
  proc_hspec
    (get_logwrite desc i)
    (fun state =>
       {| pre := PhyDecode state ps /\
                 i < LOG_LENGTH /\
                 ps.(p_desc) = desc;
          post state' r :=
            state' = state /\
            r = (sel ps.(p_desc) i, sel ps.(p_log_values) i);
          alternate state' _ :=
            state' = state; |}).
Proof.
  unfold get_logwrite.
  step.
  step.
  intuition eauto.
  pose proof (PhyDecode_disk_len H).
  f_equal.
  (* BUG: rewrite does not try to instantiate def using the typeclass without
  the (def:=_) *)
  rewrite (index_inbounds (def:=_)) in H1 by lia.
  simpl in *; propositional.
  auto using sel_log_value.
Qed.

Local Hint Resolve get_logwrite_ok : core.

Lemma phy_index_data:
  forall (ps : PhysicalState) (a : nat) (s : D.ODLayer.(State)),
    PhyDecode s ps ->
    forall v : block,
      index s (2 + LOG_LENGTH + a) ?|= eq v ->
      index ps.(p_data_region) a ?|= eq v.
Proof.
  intros ps a s H v H0.
  pose proof (PhyDecode_disk_len H).
  inv_clear H; simpl in *.

  destruct (index_dec data a);
    propositional;
    autorewrite with array in *;
    auto.

  rewrite (index_inbounds (def:=_)) in * by lia; simpl.
  simpl in *; propositional.
  apply sel_index_eq; auto.
Qed.

Local Hint Resolve phy_index_data : core.

Theorem data_read_ok ps a :
  proc_hspec
    (data_read a)
    (fun state =>
       {| pre := PhyDecode state ps;
          post state' r :=
            state' = state /\
            index ps.(p_data_region) a ?|= eq r;
          alternate state' _ :=
            state' = state; |}).
Proof.
  unfold data_read.
  spec_impl; finish.
Qed.

Local Hint Resolve data_read_ok : core.

Lemma phy_data_write:
  forall (ps : PhysicalState) (a : nat) (v : block) (s : D.ODLayer.(State)),
    PhyDecode s ps ->
    PhyDecode (assign s (2 + LOG_LENGTH + a) v)
              {|
                p_hdr := ps.(p_hdr);
                p_desc := ps.(p_desc);
                p_log_values := ps.(p_log_values);
                p_data_region := assign ps.(p_data_region) a v |}.
Proof.
  intros ps a v s H.
  pose proof (PhyDecode_disk_len H).
  inv_clear H; constructor; intros; simpl in *; array.
  destruct (a == i); subst; array.
  destruct (index_dec data i); propositional; array.
Qed.

Local Hint Resolve phy_data_write : core.

Theorem data_write_ok ps a v :
  proc_hspec
    (data_write a v)
    (fun state =>
       {| pre := PhyDecode state ps;
          post state r :=
            r = tt /\
            PhyDecode state {| p_hdr := ps.(p_hdr);
                           p_desc := ps.(p_desc);
                           p_log_values := ps.(p_log_values);
                           p_data_region :=
                             assign ps.(p_data_region) a v; |};
          alternate state' _ :=
            exists data,
              (data = ps.(p_data_region) \/
               data = assign ps.(p_data_region) a v) /\
              PhyDecode state' {| p_hdr := ps.(p_hdr);
                              p_desc := ps.(p_desc);
                              p_log_values := ps.(p_log_values);
                              p_data_region := data |};
       |}).
Proof.
  unfold data_write.
  spec_impl; split_wlog; simplify; finish.
Qed.

Local Hint Resolve data_write_ok : core.

Theorem log_write_ok ps a v :
  proc_hspec
    (log_write a v)
    (fun state =>
       {| pre := PhyDecode state ps;
          post state' r :=
            match r with
            | TxnD.WriteOK =>
              let hdr := ps.(p_hdr) in
              exists pf,
                PhyDecode state'
                          {| p_hdr := hdr_inc hdr pf;
                             p_desc :=
                               desc_assign ps.(p_desc) hdr.(log_length) a;
                             p_log_values :=
                               log_assign ps.(p_log_values) hdr.(log_length) v;
                             p_data_region := ps.(p_data_region); |}
            | TxnD.WriteErr =>
              state' = state /\
              ps.(p_hdr).(log_length) = LOG_LENGTH
            end;
          alternate state' _ :=
            (* if we crash the log will still be uncommited, so just promise
            that the data is unaffected *)
            exists hdr desc log_values,
              PhyDecode state' {| p_hdr := hdr;
                              p_desc := desc;
                              p_log_values := log_values;
                              p_data_region := ps.(p_data_region) |} /\
              hdr.(committed) = ps.(p_hdr).(committed);
       |}).
Proof.
  unfold log_write.
  step_proc; split_wlog; simplify; finish.
  destruct (hdr_full r).
  { step; simplify; finish. }
  destruct ps; eauto.
  step; split_wlog; simplify; finish.
  step; split_wlog; simplify; finish.
  step; split_wlog; simplify; finish.
  step; split_wlog; simplify; finish.
Qed.

(* this is just a physical description of [apply_at]; it precisely encodes the
data since we can't accurately abstract it that this level (we need to refer to
the old disk, which isn't tracked in these specs) *)
Theorem apply_at_ok ps desc i :
  proc_hspec
    (apply_at desc i)
    (fun state =>
       {| pre := PhyDecode state ps /\
                 desc = ps.(p_desc) /\
                 i < LOG_LENGTH;
          post state' r :=
            r = tt /\
            PhyDecode state' {| p_hdr := ps.(p_hdr);
                            p_desc := ps.(p_desc);
                            p_log_values := ps.(p_log_values);
                            p_data_region :=
                              let a := sel ps.(p_desc) i in
                              let v := sel ps.(p_log_values) i in
                              assign ps.(p_data_region) a v; |};
          alternate state' _ :=
            exists data,
              (data = ps.(p_data_region) \/
               let a := sel ps.(p_desc) i in
               let v := sel ps.(p_log_values) i in
               data = assign ps.(p_data_region) a v) /\
            PhyDecode state' {| p_hdr := ps.(p_hdr);
                            p_desc := ps.(p_desc);
                            p_log_values := ps.(p_log_values);
                            p_data_region := data; |};
       |}).
Proof.
  unfold apply_at.
  step; split_wlog; simplify; finish.
  step; split_wlog; simplify; finish.
  step; split_wlog; simplify; finish.
Qed.

Lemma log_subslice_len_ok:
  forall state : D.ODLayer.(State),
    ~ length state < 2 + LOG_LENGTH -> length (subslice state 2 LOG_LENGTH) = LOG_LENGTH.
Proof.
  intros.
  rewrite length_subslice; lia.
Qed.

Theorem phy_log_init_ok :
  proc_hspec
    (log_init)
    (fun state =>
       {| pre := True;
          post state' r :=
            match r with
            | Initialized =>
              exists ps, PhyDecode state' ps /\
                    ps.(p_hdr).(committed) = false /\
                    ps.(p_hdr).(log_length) = 0
            | InitFailed => state' = state
            end;
          alternate state' _ := True |}).
Proof.
  unfold log_init.
  step.
  destruct matches.
  - step.
  - unfold writehdr, writedesc.
    repeat step.
    exists {| p_hdr := empty_hdr;
          p_desc := default;
           p_log_values := {| values := subslice state 2 LOG_LENGTH;
                               values_ok := ltac:(auto using log_subslice_len_ok) |};
            p_data_region := subslice state (2+LOG_LENGTH) (length state - 2 - LOG_LENGTH); |};
      simpl.
    intuition eauto.
    constructor; intros; simpl; array.
    destruct (index_dec state (2 + LOG_LENGTH + i)); propositional; array.
Qed.


Require Import CodeProofDeps.
Require Import Ident.
Require Import Constants.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef2.Spec.
Require Import TableDataOpsRef2.Layer.
Require Import TableDataOpsRef3.Code.table_unmap3.

Require Import TableDataOpsRef3.LowSpecs.table_unmap3.

Local Open Scope Z_scope.

Section CodeProof.

  Context `{real_params: RealParams}.
  Context {memb} `{Hmemx: Mem.MemoryModelX memb}.
  Context `{Hmwd: UseMemWithData memb}.

  Let mem := mwd (cdata RData).

  Context `{Hstencil: Stencil}.
  Context `{make_program_ops: !MakeProgramOps Clight.function type Clight.fundef type}.
  Context `{Hmake_program: !MakeProgram Clight.function type Clight.fundef type}.

  Let L : compatlayer (cdata RData) :=
    _table_unmap ↦ gensem table_unmap_spec
      ⊕ _table_unmap2 ↦ gensem table_unmap2_spec
  .

  Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.
  Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

  Section BodyProof.

    Context `{Hwb: WritableBlockOps}.
    Variable (sc: stencil).
    Variables (ge: genv) (STENCIL_MATCHES: stencil_matches sc ge).

    Variable b_table_unmap: block.
    Hypothesis h_table_unmap_s : Genv.find_symbol ge _table_unmap = Some b_table_unmap.
    Hypothesis h_table_unmap_p : Genv.find_funct_ptr ge b_table_unmap
                                 = Some (External (EF_external _table_unmap
                                                  (signature_of_type (Tcons Tptr (Tcons tulong (Tcons tulong Tnil))) tulong cc_default))
                                        (Tcons Tptr (Tcons tulong (Tcons tulong Tnil))) tulong cc_default).
    Local Opaque table_unmap_spec.

    Variable b_table_unmap2: block.
    Hypothesis h_table_unmap2_s : Genv.find_symbol ge _table_unmap2 = Some b_table_unmap2.
    Hypothesis h_table_unmap2_p : Genv.find_funct_ptr ge b_table_unmap2
                                  = Some (External (EF_external _table_unmap2
                                                   (signature_of_type (Tcons Tptr (Tcons tulong (Tcons tulong Tnil))) tulong cc_default))
                                         (Tcons Tptr (Tcons tulong (Tcons tulong Tnil))) tulong cc_default).
    Local Opaque table_unmap2_spec.

    Lemma table_unmap3_body_correct:
      forall m d d' env le g_rd_base g_rd_offset map_addr level res
             (Henv: env = PTree.empty _)
             (Hinv: high_level_invariant d)
             (HPTg_rd: PTree.get _g_rd le = Some (Vptr g_rd_base (Int.repr g_rd_offset)))
             (HPTmap_addr: PTree.get _map_addr le = Some (Vlong map_addr))
             (HPTlevel: PTree.get _level le = Some (Vlong level))
             (Hspec: table_unmap3_spec0 (g_rd_base, g_rd_offset) (VZ64 (Int64.unsigned map_addr)) (VZ64 (Int64.unsigned level)) d = Some (d', VZ64 (Int64.unsigned res))),
           exists le', (exec_stmt ge env le ((m, d): mem) table_unmap3_body E0 le' (m, d') (Out_return (Some (Vlong res, tulong)))).
    Proof.
      solve_code_proof Hspec table_unmap3_body; eexists; solve_proof_low.
    Qed.

  End BodyProof.

End CodeProof.