Require Import String.
Require Import List.
Import List.ListNotations.
Require Bvector.
Require ZArith.
Require Zdigits.
Require Import Omega.

Require Import StructTact.StructTactics.
Require Import StructTact.Util.
Require Import Verdi.DynamicNet.

Require Import Chord.Sorting.
Require Import Chord.IDSpace.
Require Import Chord.Bitvectors.

(* Axioms and top-level parameters *)

(* number of successors each node has to track *)
Parameter SUCC_LIST_LEN : nat.
Parameter succ_list_len_lower_bound :
  SUCC_LIST_LEN >= 2.
(* byte-width of node identifiers *)
Parameter N : nat.
(* bit-width of node identifiers *)
Definition bit_len := 8 * N.
Definition id := Bvector.Bvector bit_len.
Definition addr := String.string.

(* ID type is finite so it has decidable equality *)
Definition id_eq_dec :
  forall a b : id, {a = b} + {a <> b}
  := (VectorEq.eq_dec _ Bool.eqb Bool.eqb_true_iff _).

(* hash function from names to our mystery type (it's probably a 16-byte string...) *)
Parameter ocaml_hash : addr -> { s : string | String.length s = N }.

(* conversions between strings and ids *)
Definition ascii_to_id (asc : { s : string | String.length s = N }) : id :=
  Bitvectors.fixed_length_string_to_vec asc.

(* n.b. only used in extracted code *)
Definition id_to_ascii : id -> string :=
  Bitvectors.vec_to_string.

Definition hash (a : addr) : id :=
  ascii_to_id (ocaml_hash a).

Parameter client_addr : string -> Prop.
Parameter client_addr_dec :
  forall a,
    {client_addr a} + {~ client_addr a}.

Definition z_of_id : id -> BinNums.Z :=
  Zdigits.binary_value _.

Definition id_of_z : BinNums.Z -> id :=
  Zdigits.Z_to_binary _.

Lemma z_of_id_inv :
  forall x,
    id_of_z (z_of_id x) = x.
Proof using.
  unfold id_of_z, z_of_id.
  intros.
  apply Zdigits.binary_to_Z_to_binary.
Qed.

Definition id_ltb (x y : id) : bool :=
  BinInt.Z.ltb (z_of_id x) (z_of_id y).

Definition addr_eq_dec := String.string_dec.

Module ChordIDParams <: IDSpaceParams.
  Definition name := addr.
  Definition id := id.
  Definition hash := hash.
  Definition ltb := id_ltb.
  Definition lt := fun a b => id_ltb a b = true.

  Definition name_eq_dec := addr_eq_dec.
  Definition id_eq_dec := id_eq_dec.

  (* useful notations for lt and ltb *)
  Notation "a < b" := (lt a b) : id_scope.
  Notation "a <? b" := (ltb a b) : id_scope.
  Open Scope id_scope.

  (* ltb is a decision procedure for the lt relation *)
  Definition ltb_correct :
    forall a b,
      a <? b = true <-> a < b.
  Proof.
    intuition.
  Qed.

  Lemma ltb_leb :
    forall x y,
      BinInt.Z.ltb x y = true ->
      BinInt.Z.leb x y = true.
  Proof.
    intros.
    unfold BinInt.Z.ltb, BinInt.Z.leb in *.
    repeat break_match; congruence.
  Qed.

  (* The lt relation is a strict total order *)
  Definition lt_asymm :
    forall a b,
      a < b ->
      ~ b < a.
  Proof.
    intuition.
    unfold lt, id_ltb in *.
    find_rewrite_lem BinInt.Z.ltb_antisym.
    find_apply_lem_hyp ltb_leb.
    find_rewrite. simpl in *. congruence.
  Qed.

  Definition lt_trans :
    forall a b c,
      a < b ->
      b < c ->
      a < c.
  Proof.
    intros.
    unfold lt, id_ltb in *.
    apply BinInt.Z.ltb_lt.
    find_apply_lem_hyp BinInt.Z.ltb_lt.
    eapply BinInt.Z.lt_trans; [|eauto].
    now apply BinInt.Z.ltb_lt.
  Qed.

  Definition lt_irrefl :
    forall a,
      ~ a < a.
  Proof.
    intros.
    unfold lt, id_ltb in *.
    rewrite BinInt.Z.ltb_irrefl.
    congruence.
  Qed.

  Lemma plus_2x_inj :
    forall b x y,
      BinInt.Z.add b (2 * x) = BinInt.Z.add b (2 * y) ->
      x = y.
  Proof. intros. omega.
  Qed.

  Lemma bit_adds_equal :
    forall b1 b2  x y,
      ((Zdigits.bit_value b1) + (2 * x))%Z = ((Zdigits.bit_value b2) + (2 * y))%Z ->
      b1 = b2.
  Proof.
    intros. destruct b1; destruct b2; auto.
    - exfalso. unfold Zdigits.bit_value in *. omega.
    - exfalso. unfold Zdigits.bit_value in *. omega.
  Qed.

  Lemma binary_value_inj :
    forall n (a : Bvector.Bvector n) b,
      Zdigits.binary_value n a = Zdigits.binary_value n b ->
      a = b.
  Proof.
    induction n; intros.
    - destruct a using Vector.case0.
      destruct b using Vector.case0.
      auto.
    - destruct a using Vector.caseS'.
      destruct b using Vector.caseS'.
      repeat rewrite Zdigits.binary_value_Sn in H.
      find_copy_apply_lem_hyp bit_adds_equal.
      subst.
      find_copy_apply_lem_hyp plus_2x_inj.
      find_apply_hyp_hyp. congruence.
  Qed.

  Definition lt_total :
    forall a b,
      a < b \/ b < a \/ a = b.
  Proof.
    intros.
    unfold lt, id_ltb, z_of_id.
    match goal with
    | |- context [(?x <? ?y)%Z] =>
      destruct ( Z_lt_le_dec x y)
    end; auto.
    - left. apply Z.ltb_lt. auto.
    - find_apply_lem_hyp Z_le_lt_eq_dec.
      intuition.
      + right. left.
        apply Z.ltb_lt. auto.
      + find_apply_lem_hyp binary_value_inj.
        auto.
  Qed.

  Close Scope id_scope.
End ChordIDParams.

Module ChordIDSpace := IDSpace(ChordIDParams).
Export ChordIDSpace.

(* only need this to make client.ml work :/ *)
Definition forge_pointer (i : id) : ChordIDSpace.pointer :=
  {| ptrAddr := "FAKE"%string;
     ptrId := i |}.

Ltac inv_prop P :=
  match goal with
  | [ H : context[P] |- _] =>
    inv H
  end.

Module ChordSystem <: DynamicSystem.
  Definition addr := addr.
  Definition addr_eq_dec :
    forall a b : addr, {a = b} + {a <> b}
    := string_dec.
  Definition id := id.

  Definition client_addr := client_addr.
  Definition client_addr_dec := client_addr_dec.

  Inductive _payload :=
  | Busy : _payload
  | GetBestPredecessor : pointer -> _payload
  | GotBestPredecessor : pointer -> _payload
  | GetSuccList : _payload
  | GotSuccList : list pointer -> _payload
  | GetPredAndSuccs : _payload
  | GotPredAndSuccs : option pointer -> list pointer -> _payload
  | Notify : _payload
  | Ping : _payload
  | Pong : _payload.
  Definition payload := _payload.

  Inductive _client_payload : payload -> Prop :=
  | CPGetBestPredecessor : forall p, _client_payload (GetBestPredecessor p)
  | CPGetSuccList : _client_payload GetSuccList.
  Definition client_payload := _client_payload.
  Definition client_payload_dec :
    forall p,
      {client_payload p} + {~client_payload p}.
  Proof using.
    destruct p; (left; constructor) || right; intro H; inversion H.
  Defined.

  Lemma option_eq_dec : forall A : Type,
    (forall x y : A, {x = y} + {x <> y}) ->
    forall a b : option A, {a = b} + {a <> b}.
  Proof using.
    decide equality.
  Defined.

  Definition payload_eq_dec : forall x y : payload,
      {x = y} + {x <> y}.
    decide equality.
    - apply pointer_eq_dec.
    - apply pointer_eq_dec.
    - apply (list_eq_dec pointer_eq_dec).
    - apply (list_eq_dec pointer_eq_dec).
    - apply (option_eq_dec _ pointer_eq_dec).
  Defined.

  Inductive _timeout :=
  | Tick : _timeout
  | RectifyTick : _timeout
  | KeepaliveTick : _timeout
  | Request : addr -> payload -> _timeout.
  Definition timeout := _timeout.

  Definition timeout_eq_dec : forall x y : timeout,
      {x = y} + {x <> y}.
    decide equality.
    - subst.
      apply payload_eq_dec.
    - apply addr_eq_dec.
  Defined.

  Inductive _query :=
  (* needs a pointer to the notifier *)
  | Rectify : pointer -> _query
  | Stabilize : _query
  (* needs a new successor *)
  | Stabilize2 : pointer -> _query
  (* needs a known node *)
  | Join : pointer -> _query
  (* needs to know new successor *)
  | Join2 : pointer -> _query.
  Definition query := _query.

  Record _data := mkData { ptr : pointer;
                          pred : option pointer;
                          succ_list : list pointer;
                          known : pointer;
                          joined : bool;
                          rectify_with : option pointer;
                          cur_request : option (pointer * query * payload);
                          delayed_queries : list (addr * payload) }.
  Definition data := _data.

  Definition res := (data * list (addr * payload) * list timeout * list timeout)%type.

  Definition is_request (p : payload) : bool :=
    match p with
    | GetBestPredecessor _ => true
    | GetSuccList => true
    | GetPredAndSuccs => true
    | Ping => true
    | _ => false
    end.

  Definition add_tick (r : res) : res :=
    let '(st, sends, newts, cts) := r in
    (st, sends, Tick :: newts, cts).

  Definition chop_succs (succs : list pointer) : list pointer :=
    firstn SUCC_LIST_LEN succs.

  Definition make_succs (head : pointer) (rest : list pointer) : list pointer :=
    chop_succs (head :: rest).

  Definition update_pred (st : data) (p : pointer) : data :=
    {| ptr := ptr st;
       pred := Some p;
       succ_list := succ_list st;
       known := known st;
       joined := joined st;
       rectify_with := rectify_with st;
       cur_request := cur_request st;
       delayed_queries := delayed_queries st |}.

  Definition update_succ_list (st : data) (succs : list pointer) : data :=
    {| ptr := ptr st;
       pred := pred st;
       succ_list := succs;
       known := known st;
       joined := joined st;
       rectify_with := rectify_with st;
       cur_request := cur_request st;
       delayed_queries := delayed_queries st |}.

  Definition update_query (st : data) (dst : pointer) (q : query) (m : payload) : data :=
    {| ptr := ptr st;
       pred := pred st;
       succ_list := succ_list st;
       known := known st;
       joined := joined st;
       rectify_with := rectify_with st;
       cur_request := Some (dst, q, m);
       delayed_queries := delayed_queries st |}.

  Definition update_for_join (st : data) (succs : list pointer) : data :=
    {| ptr := ptr st;
       pred := None;
       succ_list := succs;
       known := known st;
       joined := true;
       rectify_with := rectify_with st;
       cur_request := cur_request st;
       delayed_queries := delayed_queries st |}.

  Definition clear_rectify_with (st : data) : data :=
    {| ptr := ptr st;
       pred := pred st;
       succ_list := succ_list st;
       known := known st;
       joined := joined st;
       rectify_with := None;
       cur_request := cur_request st;
       delayed_queries := delayed_queries st |}.

  Definition clear_query (st : data) : data :=
    {| ptr := ptr st;
       pred := pred st;
       succ_list := succ_list st;
       known := known st;
       joined := joined st;
       rectify_with := rectify_with st;
       cur_request := None;
       delayed_queries := delayed_queries st |}.

  Definition clear_delayed_queries (st : data) : data :=
    {| ptr := ptr st;
       pred := pred st;
       succ_list := succ_list st;
       known := known st;
       joined := joined st;
       rectify_with := rectify_with st;
       cur_request := cur_request st;
       delayed_queries := [] |}.

  Definition init_state_preset (h : addr) (pred : option pointer) (succs : list pointer) : data :=
    {| ptr := make_pointer h;
       pred := pred;
       succ_list := succs;
       known := make_pointer h;
       joined := true;
       rectify_with := None;
       cur_request := None;
       delayed_queries := [] |}.

  Definition init_state_join (h k : addr) : data :=
    {| ptr := make_pointer h;
       pred := None;
       succ_list := [];
       known := make_pointer k;
       joined := false;
       rectify_with := None;
       cur_request := None;
       delayed_queries := [] |}.

  Definition empty_start_res (h : addr) : data * list (addr * payload) * list timeout :=
    ({| ptr := make_pointer h;
        pred := None;
        succ_list := [];
        known := make_pointer h;
        joined := false;
        rectify_with := None;
        cur_request := None;
        delayed_queries := [] |},
     [],
     []).

  Definition set_rectify_with (st : data) (rw : pointer) : data :=
    {| ptr := ptr st;
       pred := pred st;
       succ_list := succ_list st;
       known := known st;
       joined := joined st;
       rectify_with := Some rw;
       cur_request := cur_request st;
       delayed_queries := delayed_queries st |}.

  Definition schedule_rectify_with (st : data) (rw : pointer) : res :=
    match rectify_with st with
    | Some rw0 =>
      if ptr_between_bool rw0 rw (ptr st)
      then (set_rectify_with st rw, [], [], [])
      else (st, [], [], [])
    | None => (set_rectify_with st rw, [], [RectifyTick], [])
    end.

  Definition send_eq_dec :
    forall x y : addr * payload,
      {x = y} + {x <> y}.
    decide equality.
    - subst.
      apply payload_eq_dec.
    - apply addr_eq_dec.
   Defined.

  Definition delay_query (st : data) (src : addr) (msg : payload) : data :=
    {| ptr := ptr st;
       pred := pred st;
       succ_list := succ_list st;
       known := known st;
       joined := joined st;
       rectify_with := rectify_with st;
       cur_request := cur_request st;
       delayed_queries := dedup send_eq_dec ((src, msg) :: delayed_queries st) |}.

  Definition make_request (h : addr) (st : data) (k : query) : option (pointer * payload) :=
    match k with
    | Rectify notifier =>
      option_map (fun p => (p, Ping)) (pred st)
    | Stabilize =>
      option_map (fun succ => (succ, GetPredAndSuccs)) (hd_error (succ_list st))
    | Stabilize2 new_succ =>
      Some (new_succ, GetSuccList)
    | Join known =>
      Some (known, GetBestPredecessor (make_pointer h))
    | Join2 new_succ =>
      Some (new_succ, GetSuccList)
    end.

  Definition timeouts_in (st : data) : list timeout :=
    match cur_request st with
    | Some (dst, _, m) => [Request (addr_of dst) m]
    | None => []
    end.

  Definition start_query (h : addr) (st : data) (k : query) : res :=
    let cst := timeouts_in st in
    match make_request h st k with
    | Some (dst, msg) =>
      (update_query st dst k msg,
       [(addr_of dst, msg)],
       [Request (addr_of dst) msg],
       cst)
    | None =>
      (* only happens if succ_list = [], which is contra protocol assumptions *)
      (clear_query st, [], [], cst)
    end.

  Definition best_predecessor (h : pointer) (succs : list pointer) (them : pointer) : pointer :=
    hd h (filter (fun s => ptr_between_bool h s them)
                 (rev succs)).

  Definition handle_query_req (st : data) (src : addr) (msg : payload) : list (addr * payload) :=
    match msg with
    | GetSuccList =>
      [(src, GotSuccList (succ_list st))]
    | GetPredAndSuccs =>
      [(src, GotPredAndSuccs (pred st) (succ_list st))]
    | GetBestPredecessor p =>
      [(src, GotBestPredecessor (best_predecessor (ptr st) (succ_list st) p))]
    | _ => []
    end.

  Definition handle_delayed_query (h : addr) (st : data) (q : addr * payload) : list (addr * payload) :=
    let (src, msg) := q in
    handle_query_req st src msg.

  Definition do_delayed_queries (h : addr) (st : data) : res :=
    match cur_request st with
    | Some _ => (st, [], [], [])
    | None =>
      let sends := concat (map (handle_delayed_query h st) (delayed_queries st)) in
      (clear_delayed_queries st, sends, [], [KeepaliveTick])
    end.

  (* need to prove that this never gets called with requests in the sends of r *)
  Definition end_query (r : res) : res :=
    let '(st, outs, nts, cts) := r in
    let clearreq := timeouts_in st in
    let st' := clear_query st in
    (st', outs, nts, clearreq ++ cts).

  Definition handle_rectify (st : data) (my_pred : pointer) (notifier : pointer) : res :=
    if ptr_between_bool my_pred notifier (ptr st)
    then (update_pred st notifier, [], [], [])
    else (st, [], [], []).

  Definition handle_stabilize (h : addr) (src : pointer) (st : data) (q : query) (new_succ : option pointer) (succs : list pointer) : res :=
    let new_st := update_succ_list st (make_succs src succs) in
    match new_succ with
    | Some new_succ =>
      if ptr_between_bool (ptr st) new_succ src
      then start_query h new_st (Stabilize2 new_succ)
      else end_query (new_st, [(addr_of src, Notify)], [], [])
    | None =>
      end_query (new_st, [(addr_of src, Notify)], [], [])
    end.

  Definition next_msg_for_join (self : pointer) (src best_pred : addr) : payload :=
    if addr_eq_dec best_pred src
    then GetSuccList
    else GetBestPredecessor self.

  Definition handle_query_res (src h : addr) (st : data) (q : query) (p : payload) : res :=
    match q, p with
    | Rectify notifier, Pong =>
      match pred st with
      | Some p => end_query (handle_rectify st p notifier)
      | None => end_query (update_pred st notifier, [], [], [])
      end
    | Stabilize, GotPredAndSuccs new_succ succs =>
      handle_stabilize h (make_pointer src) st q new_succ succs
    | Stabilize2 new_succ, GotSuccList succs =>
      end_query (update_succ_list st (make_succs new_succ succs),
                 [(addr_of new_succ, Notify)],
                 [],
                 [])
    | Join known, GotBestPredecessor best_pred =>
      let a := addr_of best_pred in
      let req := next_msg_for_join (ptr st) src a in
      (update_query st best_pred (Join known) req,
       [(a, req)],
       [Request a req],
       timeouts_in st)
    | Join known, GotSuccList l =>
      match l with
      | (new_succ :: _) =>
        if between_bool (hash src) (hash h) (id_of new_succ)
        then add_tick (end_query (update_for_join st l, [], [], []))
        else end_query (st, [], [], []) (* this is bad *)
      | [] => end_query (st, [], [], []) (* this is bad *)
      end
    | Join2 new_succ, GotSuccList l =>
      let succs := make_succs new_succ l in
      add_tick (end_query (update_for_join st succs, [], [], []))
    | _, Busy => (st, [], timeouts_in st, timeouts_in st)
    | _, _ => (st, [], [], [])
    end.

  Definition handle_query_req_busy (src : addr) (st : data) (msg : payload) : res :=
    if list_eq_dec send_eq_dec (delayed_queries st) nil
    then (delay_query st src msg, [(src, Busy)], [KeepaliveTick], [])
    else (delay_query st src msg, [(src, Busy)], [], []).

  Definition is_safe (msg : payload) :=
    match msg with
    | Notify => true
    | Ping => true
    | _ => false
    end.

  Definition handle_msg (src : addr) (dst : addr) (st : data) (msg : payload) : res :=
    match msg, cur_request st, is_request msg with
    | Notify, _, _ => schedule_rectify_with st (make_pointer src)
    | Ping, _, _ => (st, [(src, Pong)], [], [])
    | _, Some (query_dst, q, _), true => handle_query_req_busy src st msg
    | _, Some (query_dst, q, _), false =>
      if addr_eq_dec (addr_of query_dst) src
      then handle_query_res src dst st q msg
      else (st, [], [], [])
    | _, None, _ => (st, handle_query_req st src msg, [], [])
    end.

  Definition recv_handler (src : addr) (dst : addr) (st : data) (msg : payload) : res :=
    let '(st, ms1, nts1, cts1) := handle_msg src dst st msg in
    let '(st, ms2, nts2, cts2) := do_delayed_queries dst st in
    let nts := nts2 ++ remove_all timeout_eq_dec cts2 nts1 in
    (st, ms2 ++ ms1, nts, cts1 ++ cts2).

  Definition pi {A B C D : Type} (t : A * B * C * D) : A * B * C :=
    let '(a, b, c, d) := t in (a, b, c).

  Definition sort_by_between (h : addr) : list pointer -> list pointer :=
    sort pointer (unroll_between_ptr h).

  Lemma sort_by_between_permutes :
    forall h l l',
      l' = sort_by_between h l ->
      Permutation.Permutation l l'.
  Proof.
    unfold sort_by_between, unroll_between_ptr.
    intro.
    apply sort_permutes;
      eauto using unrolling_reflexive, unrolling_transitive, unrolling_total.
  Qed.

  Definition find_pred (h : addr) (sorted_ring : list pointer) : option pointer :=
    hd_error (rev sorted_ring).

  Definition start_handler (h : addr) (knowns : list addr) : data * list (addr * payload) * list timeout :=
    match sort_by_between h (map make_pointer knowns) with
    (* prohibited by semantics *)
    | [] =>
      empty_start_res h
    | [k] =>
      pi (start_query h (init_state_join h (addr_of k)) (Join k))
    | sorted_ring =>
      let succs := chop_succs (List.tl sorted_ring) in
      let pred := find_pred h sorted_ring in
      (init_state_preset h pred succs, [], [Tick])
    end.

  Inductive timeout_effect :=
  | Ineffective : timeout_effect
  | StartStabilize : timeout_effect
  | DetectFailure : timeout_effect
  | StartRectify : timeout_effect
  | SetPred : timeout_effect
  | SendKeepalives : timeout_effect.

  Definition timeout_effect_eq_dec :
    forall x y : timeout_effect,
      {x = y} + {x <> y}.
  Proof using.
    decide equality; auto using addr_eq_dec, list_eq_dec, pointer_eq_dec.
  Defined.

  Definition tick_handler (h : addr) (st : data) : res * timeout_effect :=
    match cur_request st, joined st with
    | None, true => (add_tick (start_query h st Stabilize), StartStabilize)
    | _, _ => ((st, [], [Tick], []), Ineffective)
    end.

  Definition handle_query_timeout (h : addr) (st : data) (dead : pointer) (q : query) : res :=
    match q with
    | Rectify notifier =>
      end_query (update_pred st notifier, [], [], [])
    | Stabilize =>
      match succ_list st with
      | _ :: rest =>
        start_query h (update_succ_list st rest) Stabilize
      (* will not happen in a good network *)
      | [] =>
        end_query (st, [], [], [])
      end
    | Stabilize2 new_succ =>
      match succ_list st with
      | next :: _ =>
        end_query (st, [(addr_of next, Notify)], [], [])
      (* again, won't happen in a good network *)
      | [] =>
        end_query (st, [], [], [])
      end
    (* Join, Join2 *)
    | _ => end_query (st, [], [], [])
    end.

  Definition send_keepalives (st : data) : list (addr * payload) :=
    map (fun q => (fst q, Busy)) (delayed_queries st).

  Definition keepalive_handler (st : data) : res * timeout_effect :=
    let ms := send_keepalives st in
    ((st, ms, [KeepaliveTick], []), SendKeepalives).

  Definition request_timeout_handler (h : addr) (st : data) (dst : addr) (msg : payload) : res * timeout_effect :=
    match cur_request st with
    | Some (ptr, q, _) =>
      if addr_eq_dec (addr_of ptr) dst
      then let '(st', ms, nts, cts) := handle_query_timeout h st ptr q in
           let '(st'', ms', nts', cts') := do_delayed_queries h st' in
           (st'', ms ++ ms', nts ++ nts', cts ++ cts', DetectFailure)
      else ((st, [], [], []), Ineffective) (* shouldn't happen *)
    | None => ((st, [], [], []), Ineffective) (* shouldn't happen *)
    end.

  Definition do_rectify (h : addr) (st : data) : res * timeout_effect :=
    match joined st, cur_request st, rectify_with st with
    | true, None, Some new =>
      let st := clear_rectify_with st in
      match pred st with
      | Some _ => (start_query h st (Rectify new), StartRectify)
      | None => ((update_pred st new, [], [], []), SetPred)
      end
    | _, Some cr, Some new =>
      ((st, [], [RectifyTick], []), Ineffective)
    | _, _, _ =>
      ((st, [], [], []), Ineffective) (* shouldn't happen *)
    end.

  Definition timeout_handler_eff (h : addr) (st : data) (t : timeout) : res * timeout_effect :=
    match t with
    | Request dst msg => request_timeout_handler h st dst msg
    | Tick => tick_handler h st
    | KeepaliveTick => keepalive_handler st
    | RectifyTick => do_rectify h st
    end.

  Definition timeout_handler (h : addr) (st : data) (t : timeout) : res :=
    fst (timeout_handler_eff h st t).

  Inductive _label :=
  | Input : addr -> addr -> payload -> _label
  | Output : addr -> addr -> payload -> _label
  | RecvMsg : addr -> addr -> payload -> _label
  | Timeout : addr -> timeout -> timeout_effect -> _label.
  Definition label := _label.

  Definition label_eq_dec :
    forall x y : label,
      {x = y} + {x <> y}.
  Proof using.
    decide equality;
      auto using addr_eq_dec, payload_eq_dec, timeout_eq_dec, timeout_effect_eq_dec.
  Defined.

  Definition data_eq_dec :
    forall st st' : data,
      {st = st'} + {st <> st'}.
  Proof using.
    repeat (decide equality; auto using list_eq_dec, pointer_eq_dec, addr_eq_dec, id_eq_dec).
  Defined.

  Definition timeout_handler_l (h : addr) (st : data) (t : timeout) :=
    let '(res, effect) := timeout_handler_eff h st t in
    (res, Timeout h t effect).

  Definition recv_handler_l (src : addr) (dst : addr) (st : data) (msg : payload) :=
    (recv_handler src dst st msg, RecvMsg src dst msg).

  Lemma recv_handler_labeling :
    forall src dst st p r,
      (recv_handler src dst st p = r ->
       exists l,
         recv_handler_l src dst st p = (r, l)) /\
      (forall l,
          recv_handler_l src dst st p = (r, l) ->
          recv_handler src dst st p = r).
  Proof using.
    unfold recv_handler_l.
    intuition.
    - find_rewrite.
      now eexists.
    - now tuple_inversion.
  Qed.

  Definition label_input : addr -> addr -> payload -> label := Input.
  Definition label_output : addr -> addr -> payload -> label := Output.

  Lemma timeout_handler_labeling :
    forall h st t r,
      (timeout_handler h st t = r ->
      exists l,
        timeout_handler_l h st t = (r, l)) /\
      (forall l,
          timeout_handler_l h st t = (r, l) ->
          timeout_handler h st t = r).
  Proof using.
    unfold timeout_handler_l, timeout_handler.
    intuition.
    - destruct (timeout_handler_eff h st t) as [r' l].
      simpl in *.
      subst_max.
      eexists; eauto.
    - break_let.
      tuple_inversion.
      reflexivity.
  Qed.

End ChordSystem.
Export ChordSystem.

(* Requests and responses *)
Inductive request_payload : payload -> Prop :=
| req_GetBestPredecessor : forall p, request_payload (GetBestPredecessor p)
| req_GetSuccList : request_payload GetSuccList
| req_GetPredAndSuccs : request_payload GetPredAndSuccs
| req_Ping : request_payload Ping.

Ltac request_payload_inversion :=
  match goal with
  | H : request_payload _ |- _ => inv H
  end.

(* this is not quite what it sounds like, since Chord.start_query will sometimes not send anything *)
Inductive query_request : query -> payload -> Prop :=
| QReq_RectifyPing : forall n, query_request (Rectify n) Ping
| QReq_StabilizeGetPredAndSuccs : query_request Stabilize GetPredAndSuccs
| QReq_Stabilize2 : forall p, query_request (Stabilize2 p) GetSuccList
| QReq_JoinGetBestPredecessor : forall k a, query_request (Join k) (GetBestPredecessor a)
| QReq_JoinGetSuccList : forall k, query_request (Join k) GetSuccList
| QReq_Join2 : forall n, query_request (Join2 n) GetSuccList.
Hint Constructors query_request.

Inductive query_response : query -> payload -> Prop :=
| QRes_RectifyPong : forall n, query_response (Rectify n) Pong
| QRes_StabilizeGetPredAndSuccs : forall p l, query_response Stabilize (GotPredAndSuccs p l)
| QRes_Stabilize2 : forall p l, query_response (Stabilize2 p) (GotSuccList l)
| QRes_JoinGotBestPredecessor : forall k p, query_response (Join k) (GotBestPredecessor p)
| QRes_JoinGotSuccList : forall k l, query_response (Join k) (GotSuccList l)
| QRes_Join2 : forall n l, query_response (Join2 n) (GotSuccList l).
Hint Constructors query_response.

Inductive response_payload : payload -> Prop :=
| res_GotBestPredecessor : forall p, response_payload (GotBestPredecessor p)
| res_GotSuccList : forall l, response_payload (GotSuccList l)
| res_GotPredAndSuccs : forall p l, response_payload (GotPredAndSuccs p l)
| res_Pong : response_payload Pong.

Definition response_payload_dec :
  forall p,
    {response_payload p} + {~ response_payload p}.
Proof.
  destruct p;
    solve [left; constructor|right; intro; inv_prop response_payload].
Defined.

Inductive request_response_pair : payload -> payload -> Prop :=
| pair_GetBestPredecessor : forall n p, request_response_pair (GetBestPredecessor n) (GotBestPredecessor p)
| pair_GetSuccList : forall l, request_response_pair GetSuccList (GotSuccList l)
| pair_GetPredAndSuccs : forall p l, request_response_pair GetPredAndSuccs (GotPredAndSuccs p l)
| pair_Ping : request_response_pair Ping Pong.

Lemma is_request_same_as_request_payload : forall msg : payload,
    is_request msg = true <-> request_payload msg.
Proof.
  unfold is_request.
  intuition.
  - break_match;
      discriminate || eauto using req_GetBestPredecessor, req_GetSuccList, req_GetPredAndSuccs, req_Ping.
  - now request_payload_inversion.
Qed.

(* Safe messages (Notify and Ping) *)
Lemma safe_msgs :
  forall msg,
    is_safe msg = true ->
    msg = Ping \/ msg = Notify.
Proof.
  unfold is_safe.
  intuition.
  break_match; auto || discriminate.
Qed.

Module ConstrainedChord <: ConstrainedDynamicSystem.
  Include ChordSystem.

  Definition msg : Type := (addr * (addr * payload))%type.

  Inductive event : Type :=
  | e_send : msg -> event
  | e_recv : msg -> event
  | e_timeout : addr -> timeout -> event
  | e_fail : addr -> event.

  Record global_state :=
    { nodes : list addr;
      failed_nodes : list addr;
      timeouts : addr -> list timeout;
      sigma : addr -> option data;
      msgs : list msg;
      trace : list event
    }.

  Inductive _timeout_constraint : global_state -> addr -> timeout -> Prop :=
  | Tick_unconstrained : forall gst h,
      _timeout_constraint gst h Tick
  | KeepaliveTick_unconstrained : forall gst h,
      _timeout_constraint gst h KeepaliveTick
  | RectifyTick_unconstrained : forall gst h,
      _timeout_constraint gst h RectifyTick
  | Request_needs_dst_dead_and_no_msgs : forall gst dst h p,
      In dst (failed_nodes gst) ->
      (forall m, request_response_pair p m -> ~ In (dst, (h, m)) (msgs gst)) ->
      _timeout_constraint gst h (Request dst p).
  Definition timeout_constraint := _timeout_constraint.

  Definition start_constraint (gst : global_state) (h : addr) : Prop :=
    ~ In (hash h) (map hash (nodes gst)).

  Definition live_node (gst : global_state) (h : addr) : Prop :=
    In h (nodes gst) /\
    ~ In h (failed_nodes gst) /\
    exists st,
      sigma gst h = Some st /\
      joined st = true.

  Definition dead_node (gst : global_state) (h : addr) : Prop :=
    In h (nodes gst) /\
    In h (failed_nodes gst) /\
    exists st,
      sigma gst h = Some st.

  Definition best_succ (gst : global_state) (h s : addr) : Prop :=
    exists st xs ys,
      live_node gst h /\
      sigma gst h = Some st /\
      map ChordIDSpace.addr_of (succ_list st) = xs ++ s :: ys /\
      (forall o, In o xs -> dead_node gst o) /\
      live_node gst s.

  Definition live_node_in_msg_succ_lists' (gst : global_state) (ms : list msg) : Prop :=
    forall src dst succs p,
      In (src, (dst, GotPredAndSuccs p succs)) ms \/
      In (src, (dst, GotSuccList succs)) ms ->
      length succs > 0 \/ (exists st, sigma gst src = Some st /\ joined st = true) ->
      Exists (live_node gst) (map addr_of (chop_succs (make_pointer src :: succs))).
  Hint Unfold live_node_in_msg_succ_lists'.

  Definition live_node_in_msg_succ_lists_join (gst : global_state) (ms : list msg) : Prop :=
    forall src dst succs,
      In (src, (dst, GotSuccList succs)) ms ->
      length succs > 0 ->
      Exists (live_node gst) (map addr_of succs).
  Hint Unfold live_node_in_msg_succ_lists_join.

  Definition live_node_in_msg_succ_lists (gst : global_state) : Prop :=
    live_node_in_msg_succ_lists' gst (msgs gst) /\
    live_node_in_msg_succ_lists_join gst (msgs gst).
  Hint Unfold live_node_in_msg_succ_lists.

  Definition live_node_in_succ_lists (gst : global_state) : Prop :=
    forall h st,
      sigma gst h = Some st ->
      live_node gst h ->
      exists s,
        best_succ gst h s.

  Definition not_skipped (h : id) (succs : list id) (n : id) : Prop :=
    forall a b xs ys,
      h :: succs = xs ++ [a; b] ++ ys ->
      ~ between a n b.

  Inductive succs_msg : payload -> list pointer -> Prop :=
  | SuccsMsgGotSuccList :
      forall succs, succs_msg (GotSuccList succs) succs
  | SuccsMsgGotPredAndSuccs :
      forall p succs,
      succs_msg (GotPredAndSuccs p succs) succs.
  Hint Constructors succs_msg.

  Definition no_live_node_skips (gst : global_state) (p : addr) : Prop :=
    forall h st succs,
      live_node gst h ->
      sigma gst h = Some st ->
      succs = map ChordIDSpace.id_of (succ_list st) ->
      not_skipped (hash h) succs (hash p).
  Hint Unfold no_live_node_skips.

  Definition no_msg_to_live_node_skips (gst : global_state) (p : addr) : Prop :=
    forall src h m succs,
      In h (nodes gst) ->
      ~ In h (failed_nodes gst) ->
      In (src, (h, m)) (msgs gst) ->
      succs_msg m succs ->
      not_skipped (hash src) (map ChordIDSpace.id_of succs) (hash p).
  Hint Unfold no_msg_to_live_node_skips.

  (* "A principal node is a member that is not skipped by any member's
     extended successor list" *)
  Definition principal (gst : global_state) (p : addr) : Prop :=
    live_node gst p /\
    no_live_node_skips gst p /\
    no_msg_to_live_node_skips gst p.

  Definition principals (gst : global_state) (ps : list addr) : Prop :=
    NoDup ps /\
    Forall (principal gst) ps /\
    forall p,
      principal gst p ->
      In p ps.

  (* f can fail unless it's the (SUCC_LIST_LEN+1)th principal. *)
  Definition principal_failure_constraint (gst : global_state) (f : addr) : Prop :=
    principal gst f ->
    forall ps,
      principals gst ps ->
      length ps = SUCC_LIST_LEN + 1 ->
      False.

  Definition failure_constraint (gst : global_state) (f : addr) (gst' : global_state) : Prop :=
    live_node_in_msg_succ_lists gst' /\
    live_node_in_succ_lists gst' /\
    principal_failure_constraint gst f.

End ConstrainedChord.

Module ChordSemantics := DynamicSemantics(ConstrainedChord).

Export ChordSemantics.
Export ConstrainedChord.

Definition hash_injective_on (gst : global_state) : Prop :=
  forall n m,
    In n (nodes gst) ->
    In m (nodes gst) ->
    hash n = hash m ->
    n = m.

Definition initial_st (gst : global_state) : Prop :=
  (* at least N+1 nodes *)
  length (nodes gst) >= SUCC_LIST_LEN + 1 /\
  (* no duplicate addresses *)
  NoDup (nodes gst) /\
  (* all addresses hash to distinct IDs *)
  hash_injective_on gst /\
  (* nodes aren't clients *)
  (forall h, In h (nodes gst) -> ~client_addr h) /\
  (* no messages, failed nodes, or events *)
  failed_nodes gst = [] /\
  msgs gst = [] /\
  trace gst = [] /\
  (* start handler has been run at all nodes *)
  (forall h,
      In h (nodes gst) ->
      forall st ms nts,
        start_handler h (nodes gst) = (st, ms, nts) ->
        ms = [] /\
        timeouts gst h = nts /\
        sigma gst h = Some st) /\
  (* no other timeouts or state *)
  (forall h, ~ In h (nodes gst) -> timeouts gst h = []) /\
  (forall h, ~ In h (nodes gst) -> sigma gst h = None).


(** Plotting graphs in the plane *)
(* This file is based on examples/Plot.v *)
(* I define the image of a path, a [Compact] subset of the plane.*)
(* Finally, plot a hi-res Circle*)

Require Import Plot RasterQ Qmetric.
Require Import CoRN.reals.fast.Interval.
Require Import CoRN.metric2.MetricMorphisms.
Require Import CoRN.reals.faster.ARArith.
Require Import ARplot.
Require Import CoRN.reals.faster.ARcos
        CoRN.reals.faster.ARsin
        CoRN.reals.faster.ARexp
        CoRN.reals.faster.ARbigD
        CoRN.reals.faster.ARinterval.
Require Import CoRN.reals.fast.CRtrans.
Require Import CoRN.dump.theories.Loader.

Local Open Scope uc_scope.

Section PlotCirclePath.
Context `{AppRationals AQ}.

Definition CirclePath_faster
  : AQ_as_MetricSpace --> Complete (ProductMS AQ_as_MetricSpace AQ_as_MetricSpace) :=
  (uc_compose (uc_compose Couple (together ARcos_uc ARsin_uc))
              (diag AQ_as_MetricSpace)).

Definition CosPath_faster
  : AQ_as_MetricSpace --> Complete (ProductMS AQ_as_MetricSpace AQ_as_MetricSpace) :=
  (uc_compose (uc_compose Couple (together Cunit ARcos_uc))
              (diag AQ_as_MetricSpace)).

(* 7 is above 2 pi, which finishes a circle. *)
(* Lemma zeroSeven : (0 <= 7)%Q.
Proof. discriminate. Qed. *)

Definition Circle_faster : sparse_raster _ _
  := let (_,r) := ARplot.PlotPath 0 7 (-(1)) 1 (reflexivity _)
                             (-(1)) 1 (reflexivity _) 200 CirclePath_faster
      in r.

Definition Cos_faster : sparse_raster _ _
  := let (_,r) := ARplot.PlotPath 0 7 0 7 (reflexivity _)
                             (-(1)) 1 (reflexivity _) 800 CosPath_faster
      in r.

End PlotCirclePath.

(* 6 seconds *)
Time Definition Circle_bigD : sparse_raster _ _
  := Eval vm_compute in
      @Circle_faster bigD _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ bigD_appRat.

DumpGrayMap Circle_bigD.
(* Now have a look at plot.pgm *)

Time Definition Cos_bigD : sparse_raster _ _
  := Eval vm_compute in
      @Cos_faster bigD _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ bigD_appRat.

DumpGrayMap Cos_bigD.
(* Now have a look at plot.pgm *)

Definition CircleFunction_aux
  : ProductMS Q_as_MetricSpace Q_as_MetricSpace --> ProductMS CR CR
  := together cos_uc sin_uc.

Definition CirclePath : Q_as_MetricSpace --> Complete Q2:=
  (uc_compose (uc_compose Couple CircleFunction_aux) (diag Q_as_MetricSpace)).
(* The following hangs:
Definition CirclePath': UCFunction Q R2:=
  ucFunction (fun q:Q => Couple (cos_uc q, sin_uc q)).*)

(* 20 seconds *)
(* The raster must be evaluated before being plotted by DumpGrayMap,
   here with vm_compute. *)
Time Definition Circle : sparse_raster _ _
  := Eval vm_compute in
      (let (_,r) := Plot.PlotPath 0 7 (-(1)) 1 (reflexivity _)
                             (-(1)) 1 (reflexivity _) 200 CirclePath
      in r).

DumpGrayMap Circle.
(* Now have a look at plot.pgm *)


(** Definitions to build decidable predicates. **)

From Lib Require Export common.

(** * General definitions **)

(** In contrary to [Decidable.decidable] this file is based on a computable version. **)
Definition decidable P := { P } + { ~ P }.

Create HintDb decidability.

Hint Resolve left : decidability.
Hint Resolve right : decidability.

Hint Resolve reflect_dec : decidability.

Ltac prove_decidable := now eauto with decidability.

Definition decidable_to_bool P (D : decidable P) :=
  if D then true else false.

Notation "'decide' P" :=
  (decidable_to_bool P ltac:(prove_decidable))
  (at level 70, only parsing).

Lemma dec_reflect : forall P (D : decidable P),
  reflect P (decidable_to_bool P D).
Proof.
  intros P [?|?]; now constructor.
Defined.

Lemma dec_BoolSpec : forall P D,
  BoolSpec P (~ P) (decidable_to_bool P D).
Proof.
  now intros P [?|?]; constructor.
Qed.

Lemma and_decidable : forall P1 P2,
  decidable P1 ->
  decidable P2 ->
  decidable (P1 /\ P2).
Proof.
  intros P1 P2 [?|?].
  - now intros [?|?]; [left| right].
  - now right.
Defined.

Hint Resolve and_decidable : decidability.

Lemma or_decidable : forall P1 P2,
  decidable P1 ->
  decidable P2 ->
  decidable (P1 \/ P2).
Proof.
  intros P1 P2 [?|?].
  - now do 2 left.
  - now intros [?|?]; [left; right| right; intros [?|?]].
Defined.

Hint Resolve or_decidable : decidability.

Lemma impl_decidable : forall P1 P2,
  decidable P1 ->
  decidable P2 ->
  decidable (P1 -> P2).
Proof.
  intros P1 P2 [?|?].
  - now intros [?|?]; [left| right; auto].
  - now left.
Defined.

Hint Resolve impl_decidable : decidability.

Lemma equiv_decidable : forall P1 P2,
  decidable P1 ->
  decidable P2 ->
  decidable (P1 <-> P2).
Proof.
  prove_decidable.
Defined.

Lemma decidable_equiv : forall P1 P2,
  (P1 <-> P2) ->
  decidable P1 ->
  decidable P2.
Proof.
  intros P1 P2 [I1 I2] [H | nH].
  - now left; auto.
  - now right; auto.
Defined.

Lemma is_true_bool : forall b1 b2 : bool,
  (b1 = b2) <-> (b1 <-> b2).
Proof.
  do 2 intros [|]; split;
    tauto
    || (intros H; rewrite H; tauto)
    || (intros [? ?]; exfalso;
        match goal with
        | H : is_true true -> is_true false |- _ =>
          let H' := fresh H in
          set (H' := H eq_refl); inversion H'
        | _ => idtac
        end).
Qed.

Lemma is_true_decidable : forall b : bool, decidable b.
Proof.
  now intros [|]; [left|right].
Defined.

Hint Resolve is_true_decidable : decidability.

Lemma True_decidable : decidable True.
Proof.
  now left.
Defined.

Hint Resolve True_decidable : decidability.

Lemma False_decidable : decidable False.
Proof.
  now right.
Defined.

Hint Resolve False_decidable : decidability.

Lemma not_decidable : forall P,
  decidable P ->
  decidable (~ P).
Proof.
  prove_decidable.
Defined.

Lemma eq_refl_decidable : forall T (x : T),
  decidable (x = x).
Proof.
  now left.
Defined.

Hint Resolve eq_refl_decidable : decidability.

(** [test P] splits the goal into two: one in which P holds, and one in which it doesn’t.
  Only works for propositions [P] that [prove_decidable] can prove decidable. **)
Ltac test P :=
  let D := fresh "D" in
  assert (D : decidable P);
  [ prove_decidable
  | let d := fresh "d" in
    destruct D as [d|d]; generalize d; clear d ].

Definition comparable T := forall x y : T, decidable (x = y).

Hint Unfold comparable : decidability.

(** * Classical logic **)

(** Once a proposition is proven decidable, we get all the usual classical properties
  for free, without having to add any axioms to Coq. **)

Lemma dec_excluded_middle : forall P,
  decidable P ->
  P \/ ~ P.
Proof.
  now intros P [?|?]; [left|right].
Qed.

Lemma dec_not_not : forall P,
  decidable P ->
  ~ ~ P ->
  P.
Proof.
  now intros P [?|?].
Qed.

Lemma not_not : forall P : Prop,
  P ->
  ~ ~ P.
Proof.
  now auto.
Qed.

Lemma not_not_iff : forall P,
  decidable P ->
  ~ ~ P <-> P.
Proof.
  intros P D. split.
  - now apply dec_not_not.
  - now apply not_not.
Qed.

Lemma dec_pierce : forall P Q,
  decidable P ->
  ((P -> Q) -> P) -> P.
Proof.
  intros P Q [?|?] F; auto.
  now apply F.
Qed.

Lemma dec_not_and : forall P Q,
  decidable P ->
  ~ (P /\ Q) ->
  ~ P \/ ~ Q.
Proof.
  now intros P Q [?|?]; auto.
Qed.

Lemma or_not : forall P Q,
  ~ P \/ ~ Q ->
  ~ (P /\ Q).
Proof.
  now intros P Q [?|?]; auto.
Qed.

Lemma not_and_iff : forall P Q,
  decidable P ->
  ~ (P /\ Q) <-> ~ P \/ ~ Q.
Proof.
  intros P Q D. split.
  - now apply dec_not_and.
  - now apply or_not.
Qed.

Lemma not_or : forall P Q,
  ~ (P \/ Q) ->
  ~ P /\ ~ Q.
Proof.
  now auto.
Qed.

Lemma and_not : forall P Q,
  ~ P /\ ~ Q ->
  ~ (P \/ Q).
Proof.
  now intros P Q [? ?] [?|?]; auto.
Qed.

Lemma not_or_iff : forall P Q,
  ~ (P \/ Q) <-> ~ P /\ ~ Q.
Proof.
  intros P Q. split.
  - now apply not_or.
  - now apply and_not.
Qed.

Lemma dec_flatten_impl : forall P Q : Prop,
  decidable P ->
  (P -> Q) ->
  ~ P \/ Q.
Proof.
  now intros P Q [?|?]; auto.
Qed.

Lemma dec_not_impl : forall P Q : Prop,
  decidable P ->
  ~ (P -> Q) ->
  P /\ ~ Q.
Proof.
  intros P Q [?|?] N; split; auto.
  exfalso. now apply N.
Qed.

Lemma impl_not : forall P Q,
  P /\ ~ Q ->
  ~ (P -> Q).
Proof.
  now intros P Q [? ?] I; auto.
Qed.

Lemma not_impl_iff : forall P Q : Prop,
  decidable P ->
  ~ (P -> Q) <-> P /\ ~ Q.
Proof.
  intros P Q D. split.
  - now apply dec_not_impl.
  - now apply impl_not.
Qed.

Lemma contrapositive : forall P Q : Prop,
  (P -> Q) ->
  ~ Q -> ~ P.
Proof.
  now auto.
Qed.

Lemma dec_contrapositive : forall P Q,
  decidable P ->
  (~ P -> ~ Q) ->
  Q -> P.
Proof.
  intros P Q D nf q. apply (dec_not_not _ D).
  now apply (contrapositive _ (~ Q)); auto.
Qed.

Lemma True_and_iff : forall P,
  True /\ P <-> P.
Proof.
  now auto.
Qed.

Lemma and_True_iff : forall P,
  P /\ True <-> P.
Proof.
  now auto.
Qed.

Lemma False_or_iff : forall P,
  False \/ P <-> P.
Proof.
  intros P; split.
  - now intros [?|?].
  - now right.
Qed.

Lemma or_False_iff : forall P,
  P \/ False <-> P.
Proof.
  intros P; split.
  - now intros [?|?].
  - now left.
Qed.

(** Simplify an hypothesis. **)
Ltac dsimpl_in H :=
  repeat match type of H with
  | context [~ ~ ?P] =>
    let D := fresh "D" in
    assert (D : decidable P); [
        prove_decidable
      | rewrite -> (not_not_iff P D) in H; clear D ]
  | context [~ (?P \/ ?Q)] =>
    rewrite -> (not_or_iff P Q) in H
  | context [~ (?P /\ ?Q)] =>
    let D := fresh "D" in
    assert (D : decidable P); [
        prove_decidable
      | rewrite -> (not_and_iff P Q D) in H; clear D ]
  | context [~ (?P -> ?Q)] =>
    let D := fresh "D" in
    assert (D : decidable P); [
        prove_decidable
      | rewrite -> (not_impl_iff P Q D) in H; clear D ]
  | context [True /\ ?P] => rewrite -> (True_and_iff P) in H
  | context [?P /\ True] => rewrite -> (and_True_iff P) in H
  | context [False \/ ?P] => rewrite -> (False_or_iff P) in H
  | context [?P \/ False] => rewrite -> (or_False_iff P) in H
  end.

Tactic Notation "dsimpl" "in" hyp(H) :=
  dsimpl_in H.

(** Simplify the goal. **)
Ltac dsimpl :=
  lazymatch goal with
  | |- ~ _ -> ~ _ => apply contrapositive; dsimpl
  | |- _ -> _ =>
    let H := fresh "H" in
    intro H;
    dsimpl in H;
    dsimpl;
    generalize H; clear H
  | |- _ =>
    repeat lazymatch goal with
    | |- ~ ~ ?P => apply (not_not P)
    | |- ~ (?P \/ ?Q) => apply (and_not P Q)
    | |- ~ (?P /\ ?Q) => apply (or_not P Q)
    | |- True /\ ?P => split; [now auto|]
    | |- ?P /\ True => split; [|now auto]
    | |- False \/ ?P => right
    | |- ?P \/ False => left
    end;
    repeat match goal with
    | |- context [~ ~ ?P] =>
      let D := fresh "D" in
      assert (D : decidable P); [
          prove_decidable
        | rewrite -> (not_not_iff P D); clear D ]
    | |- context [~ (?P \/ ?Q)] =>
      rewrite -> (not_or_iff P Q)
    | |- context [~ (?P /\ ?Q)] =>
      let D := fresh "D" in
      assert (D : decidable P); [
          prove_decidable
        | rewrite -> (not_and_iff P Q D); clear D ]
    | |- context [~ (?P -> ?Q)] =>
      let D := fresh "D" in
      assert (D : decidable P); [
          prove_decidable
        | rewrite -> (not_impl_iff P Q D); clear D ]
    | |- context [True /\ ?P] => rewrite -> (True_and_iff P)
    | |- context [?P /\ True] => rewrite -> (and_True_iff P)
    | |- context [False \/ ?P] => rewrite -> (False_or_iff P)
    | |- context [?P \/ False] => rewrite -> (or_False_iff P)
    end
  end.

Tactic Notation "dsimpl" "in" "*" :=
  dsimpl;
  repeat match goal with
  | H : _ |- _ => progress dsimpl in H
  end.

Ltac dtest P :=
  test P; dsimpl.

(** * Adding external lemmas to the database **)

(** ** Basic data types **)

Lemma unit_comparable : comparable unit.
Proof.
  now intros [] []; left.
Defined.

Hint Resolve unit_comparable : decidability.

Lemma bool_comparable : comparable bool.
Proof.
  intros [|] [|]; solve [ now left | now right ].
Defined.

Hint Resolve bool_comparable : decidability.

Lemma comparison_comparable : comparable comparison.
Proof.
  intros [| |] [| |]; solve [ now right | now left ].
Defined.

Hint Resolve comparison_comparable : decidability.

(** ** Lists **)

Lemma list_comparable : forall T,
  comparable T ->
  comparable (list T).
Proof.
  intros T C l1. induction l1 as [|a1 l1]; intro l2; destruct l2 as [|a2 l2];
    try first [ now left | now right ].
  test (a1 = a2).
  - intro. subst. test (l1 = l2).
    + intro. subst. prove_decidable.
    + right. now inversion 1.
  - right. now inversion 1.
Defined.

Hint Resolve list_comparable : decidability.

Lemma list_comparable_nil : forall T (l : list T),
  decidable (l = nil).
Proof.
  intros T [|? ?]; [left|right]; prove_decidable.
Defined.

Hint Resolve list_comparable_nil : decidability.

Lemma decidable_In : forall T (a : T) l,
  comparable T ->
  decidable (List.In a l).
Proof.
  intros T a l C. induction l as [|b l]; prove_decidable.
Defined.

Hint Resolve decidable_In : decidability.

Lemma decidable_Forall : forall T (P : T -> Prop) l,
  (forall a, decidable (P a)) ->
  decidable (List.Forall P l).
Proof.
  intros T P l D. induction l as [|a l].
  - left. now constructor.
  - apply decidable_equiv with (P a /\ List.Forall P l); [| prove_decidable ].
    split.
    + intros [? ?]. now constructor.
    + now inversion 1.
Defined.

Hint Resolve decidable_Forall : decidability.

Lemma decidable_Exists : forall T (P : T -> Prop) l,
  (forall a, decidable (P a)) ->
  decidable (List.Exists P l).
Proof.
  intros T P l D. induction l as [|a l].
  - right. now inversion 1.
  - apply decidable_equiv with (P a \/ List.Exists P l); [| prove_decidable ].
    split.
    + intros [?|?]; now constructor.
    + now inversion 1; [left|right].
Defined.

Hint Resolve decidable_Exists : decidability.

Lemma decidable_Forall2 : forall T1 T2 (P : T1 -> T2 -> Prop) l1 l2,
  (forall a b, decidable (P a b)) ->
  decidable (List.Forall2 P l1 l2).
Proof.
  intros T1 T2 P l1 l2 D. generalize l2. clear l2.
  induction l1 as [|a1 l1]; intros [|a2 l2]; try now right; inversion 1.
  - left. now constructor.
  - apply decidable_equiv with (P a1 a2 /\ List.Forall2 P l1 l2); [| prove_decidable ].
    split.
    + intros [? ?]. now constructor.
    + now inversion 1.
Defined.

Hint Resolve decidable_Forall2 : decidability.

Lemma decidable_NoDup : forall T (l : list T),
  comparable T ->
  decidable (List.NoDup l).
Proof.
  intros T l C. induction l as [|a l].
  - left. now constructor.
  - apply decidable_equiv with (~ List.In a l /\ List.NoDup l); [| prove_decidable ].
    split.
    + intros [? ?]. now constructor.
    + now inversion 1.
Defined.

Hint Resolve decidable_NoDup : decidability.

(** ** Arithmetic **)

Lemma nat_comparable : comparable nat.
Proof.
  intros n m. eapply reflect_dec. now apply Nat.eqb_spec.
Defined.

Hint Resolve nat_comparable : decidability.

Lemma ltb_decidable : forall n m : nat,
  decidable (n < m).
Proof.
  intros n m. eapply reflect_dec. now apply Nat.ltb_spec0.
Defined.

Hint Resolve ltb_decidable : decidability.

Lemma gtb_decidable : forall n m : nat,
  decidable (n > m).
Proof.
  prove_decidable.
Defined.

Lemma leb_decidable : forall n m : nat,
  decidable (n <= m).
Proof.
  intros n m. eapply reflect_dec. now apply Nat.leb_spec0.
Defined.

Hint Resolve leb_decidable : decidability.

Lemma geb_decidable : forall n m : nat,
  decidable (n >= m).
Proof.
  prove_decidable.
Defined.


(* copied from an earlier version from mit-plv/coqutil:

https://github.com/mit-plv/coqutil/blob/f3209a5b2c22eb36c3c1a8688b2a18b0d40fd476/src/coqutil/Word/LittleEndian.v
 *)
From Coq Require Import ZArith.ZArith.
From coqutil Require Import Z.Lia.
From coqutil Require Import Word.Interface Datatypes.HList Datatypes.PrimitivePair.
From coqutil Require Import Word.Properties.
From coqutil Require Import Z.bitblast.
Local Set Universe Polymorphism.

Local Open Scope Z_scope.

Section LittleEndian.
  Context {byte: word 8}.

  Fixpoint combine (n : nat) : forall (bs : tuple byte n), Z :=
    match n with
    | O => fun _ => 0
    | S n => fun bs => Z.lor (word.unsigned (pair._1 bs))
                             (Z.shiftl (combine n (pair._2 bs)) 8)
    end.

  Fixpoint split (n : nat) (w : Z) : tuple byte n :=
    match n with
    | O => tt
    | S n => pair.mk (word.of_Z w) (split n (Z.shiftr w 8))
    end.

  Lemma combine_split {ok : word.ok byte} (n : nat) (z : Z) :
    combine n (split n z) = z mod 2 ^ (Z.of_nat n * 8).
  Proof.
    revert z; induction n.
    - cbn. intros. rewrite Z.mod_1_r. trivial.
    - cbn [split combine PrimitivePair.pair._1 PrimitivePair.pair._2]; intros.
      erewrite IHn; clear IHn.
      rewrite word.unsigned_of_Z, Nat2Z.inj_succ, Z.mul_succ_l by blia.
      unfold word.wrap.
      rewrite <-! Z.land_ones by blia.
      Z.bitblast.
  Qed.

  Lemma split_combine {ok : word.ok byte} (n: nat) bs :
    split n (combine n bs) = bs.
  Proof.
    revert bs; induction n.
    - destruct bs. reflexivity.
    - destruct bs; cbn [split combine PrimitivePair.pair._1 PrimitivePair.pair._2]; intros.
      specialize (IHn _2).
      f_equal.
      { eapply Properties.word.unsigned_inj.
        rewrite word.unsigned_of_Z, <-Properties.word.wrap_unsigned; cbv [word.wrap].
        Z.bitblast; cbn; subst.
        rewrite (Z.testbit_neg_r _ (i-8)) by blia.
        Z.bitblast_core. }
      { rewrite <-IHn.
        rewrite combine_split.
        f_equal.
        rewrite <-word.wrap_unsigned.
        Z.bitblast; subst; cbn.
        rewrite <-IHn.
        rewrite combine_split.
        Z.bitblast_core. }
  Qed.

End LittleEndian.

Arguments combine: simpl never.
Arguments split: simpl never.


Require Export GeoCoq.Elements.OriginalProofs.lemma_extension.

Section Euclid.

Context `{Ax1:euclidean_neutral_ruler_compass}.

Lemma lemma_samesidereflexive :
   forall A B P,
   nCol A B P ->
   OS P P A B.
Proof.
intros.
assert (eq A A) by (conclude cn_equalityreflexive).
assert (~ eq P A).
 {
 intro.
 assert (Col A B A) by (conclude_def Col ).
 assert (Col A B P) by (conclude cn_equalitysub).
 contradict.
 }
assert (neq A P) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists C, (BetS P A C /\ Cong A C A P)) by (conclude lemma_extension);destruct Tf as [C];spliter.
assert (Col A B A) by (conclude_def Col ).
assert (OS P P A B) by (conclude_def OS ).
close.
Qed.

End Euclid.


Require Import Coq.Arith.Even.
Require Import Coq.Arith.Minus.
Require Import Coq.Logic.FunctionalExtensionality.

(* A spec with an arbitrary T, foo, and axiom about foo being the identity *)
Module Type spec_id.
  Parameter T : Set.
  Parameter foo : T -> T.
  Axiom foo_is_id : forall x, foo x = x.
End spec_id.

(* A witness showing consistency of spec_id *)
Module spec_id_consistent : spec_id.
  Definition T := nat.
  Definition foo := fun (x:T) => x.
  Lemma foo_is_id : forall x, foo x = x.
    intros; reflexivity.
  Qed.
End spec_id_consistent.

(* A refinement of spec_id, where foo is defined as the identity *)
Module Type spec_id_foo.
  Parameter T : Set.
  Definition foo : T -> T := fun x => x.
  Parameter foo_is_id : forall x, foo x = x.

  (* README: don't prove the lemma in the spec, as this requires all
     *proofs* to be equal to this proof
  Lemma foo_is_id : forall x, foo x = x.
    intro; reflexivity.
  Qed.
   *)
End spec_id_foo.

(* a morphism : spec_id >=> spec_id_foo is a functor : spec_id_foo -> spec_id *)
Module morph_foo (s_foo : spec_id_foo) : spec_id.
  Definition T := s_foo.T.
  Definition foo := s_foo.foo.
  Definition foo_is_id := s_foo.foo_is_id.
  (*
  Lemma foo_is_id : forall x, foo x = x.
    intro; reflexivity.
  Qed.
   *)
End morph_foo.

(* README: reverse morphism not possible, because spec_id is not a
   refinement of spec_id_foo! In Coq encoding here, this is prevented
   because the module definition below does not match the spec_id_foo module
   type, as foo has the wrong definition *)
(*
Module morph_21 (s1 : spec_id) : spec_id_foo.
  Definition T := s1.T.
  Definition foo := s1.foo.
  Definition foo_is_id := s1.foo_is_id.
End morph_21.
*)

(* A refinement of spec_id where T is defined as nat *)
Module Type spec_id_T.
  Definition T : Set := nat.
  Parameter foo : T -> T.
  Axiom foo_is_id : forall x, foo x = x.
End spec_id_T.

(* A refinement of spec_id where both T and foo are defined *)
Module Type spec_id_T_foo.
  Definition T : Set := nat.
  Definition foo : T -> T := fun x => x.
  Parameter foo_is_id : forall x, foo x = x.
End spec_id_T_foo.

(* morphism from spec_id >=> spec_id_T *)
Module morph_T (s_T : spec_id_T) : spec_id.
  Definition T := s_T.T.
  Definition foo := s_T.foo.
  Definition foo_is_id := s_T.foo_is_id.
End morph_T.

(* morphism from spec_id_T >=> spec_id_T_foo *)
Module morph_foo' (s_T_foo : spec_id_T_foo) : spec_id_T.
  Definition T := s_T_foo.T.
  Definition foo := s_T_foo.foo.
  Definition foo_is_id := s_T_foo.foo_is_id.
End morph_foo'.

(* morphism from spec_id >=> spec_id_T_foo, composing morph_T and morph_foo' *)
Module morph_T_foo (s_T_foo : spec_id_T_foo) : spec_id.
  Module s_T := morph_foo' s_T_foo.
  Module s_id := morph_T s_T.
  Include s_id.
End morph_T_foo.

(*** Handling imports ***)

(* A version of spec_id_foo that imports spec_id and sets foo := fun x => x *)
Module Type spec_id_foo_I.
  (* Module Type s' := spec_id with Definition foo := fun (x:T) => x. *)
  (* Module Type s' := spec_id with Parameter T : Set with Definition foo := fun (x:spec_id.T) => x. *)

  (*
  Parameter T : Set.
  Module Type s' := spec_id with Definition foo := fun (x:T) => x.
  *)

  (* Re-declare all dependencies of definitions that change *)
  Parameter T : Set.
  (* Include (spec_id with Definition T := T with Definition foo := fun (x:T) => x). *)
  Declare Module s' : spec_id with Definition T := T with Definition foo := fun (x:T) => x.
  (* Definition foo := s'.foo. *)
End spec_id_foo_I.

(* an instance of the above module type, i.e., a witness to its consistency *)
Module spec_id_foo_I_inst : spec_id_foo_I.
  Definition T := nat.
  Module s'.
    Definition T := T.
    Definition foo := fun (x:T) => x.
    Lemma foo_is_id : forall x, foo x = x.
      intros; reflexivity.
    Qed.
  End s'.
End spec_id_foo_I_inst.

(* a morphism from spec_id to the above-defined spec *)
Module morph_foo_I (s : spec_id_foo_I) : spec_id.
  Definition T := s.T.
  Definition foo := s.s'.foo.
  Definition foo_is_id := s.s'.foo_is_id.
End morph_foo_I.

(** Another apporach: duplicate any spec which has any renamings / defs **)

Module Type renaming1_spec_id.
  Parameter T : Set.
  Definition foo : T -> T := fun x => x.
  Parameter foo_is_id : forall x, foo x = x.
End renaming1_spec_id.

(* the import then becomes trivial, as there is no "rest" of the spec *)
Module Type spec_id_foo_I2.
  Include renaming1_spec_id.
End spec_id_foo_I2.

(* a morphism from spec_id >=> spec_id_foo_I2 *)
Module morph_foo_I2 (s : spec_id_foo_I2) : spec_id.
  Definition T := s.T.
  Definition foo := s.foo.
  Definition foo_is_id := s.foo_is_id.
End morph_foo_I2.

(** An import that changes T -> U and foo -> bar **)

Module Type renaming2_spec_id.
  Parameter U : Set.
  Parameter bar : U -> U.
  Parameter bar_is_id : forall x, bar x = x.
End renaming2_spec_id.

Module Type spec_id_U.
  Include renaming2_spec_id.
End spec_id_U.

(* morphism from spec_id >=> spec_id_U *)
Module morph_U (s : spec_id_U) : spec_id.
  Definition T := s.U.
  Definition foo := s.bar.
  Definition foo_is_id := s.bar_is_id.
End morph_U.

(** A spec that imports spec_id twice, once with T/foo and once with U/bar **)
Module Type spec_id2.
  Include spec_id.
  Include spec_id_U.
End spec_id2.

(* The first morphism from spec_id >=> spec_id2 *)
Module morph_id2_proj1 (s : spec_id2) : spec_id.
  Definition T := s.T.
  Definition foo := s.foo.
  Definition foo_is_id := s.foo_is_id.
End morph_id2_proj1.

(* The second morphism from spec_id >=> spec_id2 *)
Module morph_id2_proj2 (s : spec_id2) : spec_id.
  Definition T := s.U.
  Definition foo := s.bar.
  Definition foo_is_id := s.bar_is_id.
End morph_id2_proj2.

(*** Handling propositional but not definitional equality in specs ***)

(* A spec with a more complex version of the identity function *)
Module Type spec_id_complexid.
  Definition T : Set := nat.
  Definition foo : T -> T :=
    fun x => match x with | 0 => 0 | _ => S (x - 1) end.
  Parameter foo_is_id : forall x, foo x = x.
  (*
  Lemma foo_is_id : forall x, foo x = x.
    intro x; induction x.
    reflexivity.
    unfold foo. rewrite <- pred_of_minus. unfold minus. reflexivity.
  Qed.
   *)
End spec_id_complexid.

(* morphism spec_id_foo >=> spec_id_complexid *)
Module morph_complexid (s : spec_id_complexid) : spec_id_foo.
  Definition T := s.T.
  Definition foo := fun (x:T) => x.
  (* need to prove that this definition of foo equals the expected one *)
  Lemma foo_eq : foo = s.foo.
    apply functional_extensionality.
    intros; rewrite s.foo_is_id. reflexivity.
  Qed.
  (*  *)
  Lemma foo_is_id : forall x, foo x = x.
    intros; reflexivity.
  Qed.
End morph_complexid.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Coq.omega.Omega.
Require Import Rsequence_def.
Require Import Morphisms Setoid.
Require Import Lra.

Open Scope R_scope.
Open Scope Rseq_scope.
(** printing ~	~ *)
(** ** Extensionnal equality. *)

(** * Extensional equality is an equivalence relation. *)

(**********)
Lemma Rseq_eq_refl : forall Un, Un == Un.
Proof.
intros Un n; reflexivity.
Qed.

(**********)
Lemma Rseq_eq_sym : forall Un Vn, Un == Vn -> Vn == Un.
Proof.
intros Un Vn Heq n.
symmetry; apply Heq.
Qed.

(**********)
Lemma Rseq_eq_trans : forall Un Vn Wn, Un == Vn -> Vn == Wn -> Un == Wn.
Proof.
intros Un Vn Wn Heq1 Heq2 n.
transitivity (Vn n); [apply Heq1|apply Heq2].
Qed.

(**********)
Instance Rseq_eq_Equivalence : Equivalence Rseq_eq.
Proof.
split.
  exact Rseq_eq_refl.
  exact Rseq_eq_sym.
  exact Rseq_eq_trans.
Qed.

(** * Rseq_opp is involutive. *)

Lemma Rseq_opp_invol : forall Un, - - Un == Un.
Proof.
intros Un n ; unfold Rseq_opp ; rewrite Ropp_involutive ;
 reflexivity.
Qed.

(** * Compatibility of extensional equality with convergence. *)

(**********)
Lemma Rseq_cv_eq_compat :
  forall Un Vn l, Un == Vn ->
  (Rseq_cv Un l <-> Rseq_cv Vn l).
Proof.
intros Un Vn l Heq ; split ; intros Hcv eps Heps ;
destruct (Hcv eps Heps) as [N HN] ;
exists N; intros n Hn ;
[rewrite <- Heq | rewrite Heq] ;
apply HN; assumption.
Qed.

(**********)
Lemma Rseq_cv_pos_infty_eq_compat :
  forall Un Vn, Un == Vn -> Rseq_cv_pos_infty Un -> Rseq_cv_pos_infty Vn.
Proof.
intros Un Vn Heq Hdiv.
intros m.
destruct (Hdiv m) as [N HN].
exists N; intros n Hn.
rewrite <- (Heq n).
apply HN; assumption.
Qed.

(**********)
Lemma Rseq_cv_neg_infty_eq_compat :
  forall Un Vn, Un == Vn -> Rseq_cv_neg_infty Un -> Rseq_cv_neg_infty Vn.
Proof.
intros Un Vn Heq Hdiv.
intros m.
destruct (Hdiv m) as [N HN].
exists N; intros n Hn.
rewrite <- (Heq n).
apply HN; assumption.
Qed.

(** * Compatibility of extensional equality with Laudau relations. *)

(**********)
Lemma Rseq_big_O_eq_compat :
  forall Un Vn Wn Xn, Un == Wn -> Vn == Xn ->
    Un = O(Vn) -> Wn = O(Xn).
Proof.
intros Un Vn Wn Xn Huw Hvx Huv.
destruct Huv as [M [HM [N HN]]].
exists M; split.
  assumption.
  exists N; intros n Hn.
  rewrite <- Huw; rewrite <- Hvx.
  apply HN; assumption.
Qed.

(**********)
Lemma Rseq_little_O_eq_compat :
  forall Un Vn Wn Xn, Un == Wn -> Vn == Xn ->
    Un = o(Vn) -> Wn = o(Xn).
Proof.
intros Un Vn Wn Xn Huw Hvx Huv.
intros eps Heps.
destruct (Huv eps Heps) as [N HN].
exists N; intros n Hn.
rewrite <- Huw; rewrite <- Hvx.
apply HN; assumption.
Qed.

(**********)
Lemma Rseq_equiv_eq_compat :
  forall Un Vn Wn Xn, Un == Wn -> Vn == Xn ->
    Un ~ Vn -> Wn ~ Xn.
Proof.
intros Un Vn Wn Xn Huw Hvx Huv.
intros eps Heps.
destruct(Huv eps Heps) as [N HN].
exists N; intros n Hn.
unfold Rseq_minus.
rewrite <- Huw; rewrite <- Hvx.
apply HN; apply Hn.
Qed.

(** ** Boundedness and subsequences *)

Lemma even_odd_boundedness : forall (An : nat -> R) (M1 M2 : R),
     Rseq_bound (fun n => An (2 * n)%nat) M1 ->
     Rseq_bound (fun n => An (S (2 * n))) M2 ->
     Rseq_bound An (Rmax M1 M2).
Proof.
intros An M1 M2 HM1 HM2 n ; destruct (n_modulo_2 n) as [n_even | n_odd].
 destruct n_even as [p Hp] ; rewrite Hp ; apply Rle_trans with M1 ; [apply HM1 | apply RmaxLess1].
 destruct n_odd as [p Hp] ; rewrite Hp ; apply Rle_trans with M2 ; [apply HM2 | apply RmaxLess2].
Qed.

(** ** Partial sequences. *)

Section Rseq_partial.

Variable Un : nat -> R.

(**********)
Lemma Rseq_partial_bound_max : forall N, exists M, forall n, (n <= N)%nat -> Un n <= M.
Proof.
induction N.
exists (Un 0).
intros n Hn; inversion Hn as [H|H]; apply Rle_refl.
destruct IHN as [M IHN].
exists (Rmax M (Un (S N))).
intros n Hn.
destruct (le_lt_eq_dec n (S N)) as [He|He]; try assumption.
eapply Rle_trans; [apply IHN|apply RmaxLess1].
apply lt_n_Sm_le; assumption.
rewrite He; apply RmaxLess2.
Qed.

(**********)
Lemma Rseq_partial_bound_min : forall N, exists m, forall n, (n <= N)%nat -> m <= Un n.
Proof.
induction N.
exists (Un 0).
intros n Hn; inversion Hn as [H|H]; apply Rle_refl.
destruct IHN as [m IHN].
exists (Rmin m (Un (S N))).
intros n Hn.
destruct (le_lt_eq_dec n (S N)) as [He|He]; try assumption.
eapply Rle_trans; [apply Rmin_l|apply IHN].
apply lt_n_Sm_le; assumption.
rewrite He; apply Rmin_r.
Qed.

(**********)
Lemma Rseq_partial_bound : forall N, exists M, forall n, (n <= N)%nat -> Rabs (Un n) <= M.
Proof.
intros N.
destruct (Rseq_partial_bound_max N) as [M HM].
destruct (Rseq_partial_bound_min N) as [m Hm].
exists (Rmax (Rabs m) (Rabs M)).
intros n Hn.
apply RmaxAbs; [apply Hm|apply HM]; assumption.
Qed.

End Rseq_partial.

(** ** Asymptotic properties. *)

(**********)
Definition Rseq_asymptotic P :=
  forall (Q : Rseq -> Prop) Un,
    (forall Vn, Q Vn -> P Vn) -> Rseq_eventually Q Un -> P Un.

(**********)
Definition Rseq_asymptotic2 P :=
  forall (Q : Rseq -> Rseq -> Prop) Un Vn,
    (forall Wn Xn, Q Wn Xn -> P Wn Xn) -> Rseq_eventually2 Q Un Vn -> P Un Vn.

(** * Convergence is asymptotic. *)

(**********)
Lemma Rseq_cv_asymptotic : forall l, Rseq_asymptotic (fun Un => Rseq_cv Un l).
Proof.
intros l Q Un HQ He eps Heps.
destruct He as [Ne HNe].
edestruct HQ as [N HN]; [eexact HNe|eexact Heps|].
exists (Ne + N)%nat; intros n Hn.
assert (Hn0 : exists n0, (n = Ne + n0)%nat).
induction Hn.
exists N; reflexivity.
destruct IHHn as [n0 H]; exists (S n0).
rewrite <- plus_Snm_nSm; simpl; rewrite H; reflexivity.
destruct Hn0 as [n0 Hn0].
rewrite Hn0; apply HN; omega.
Qed.

(**********)
Lemma Rseq_cv_asymptotic_eq_compat : forall Un Vn l,
    (exists N, forall n : nat, (N <= n)%nat -> Un n = Vn n) -> Rseq_cv Un l -> Rseq_cv Vn l.
Proof.
intros Un Vn l [N HN] Hu eps Heps.
destruct (Hu eps Heps) as [N' HN'].
exists (N+N')%nat.
intros n Hn; unfold R_dist.
replace (Vn n -l)%R with ((Vn n - Un n) + (Un n -l))%R by ring.
apply Rle_lt_trans with (Rabs (Vn n - Un n)+ Rabs(Un n -l))%R.
apply Rabs_triang.
rewrite HN at 1.
unfold Rminus at 1.
rewrite Rplus_opp_r, Rabs_R0, Rplus_0_l.
apply HN'.
intuition.
intuition.
Qed.

(**********)
Lemma Rseq_cv_pos_infty_asymptotic : Rseq_asymptotic Rseq_cv_pos_infty.
Proof.
intros Q Un HQ He M.
destruct He as [Ne HNe].
edestruct HQ as [N HN]; [eexact HNe|].
exists (Ne + N)%nat; intros n Hn.
assert (Hn0 : exists n0, (n = Ne + n0)%nat).
induction Hn.
exists N; reflexivity.
destruct IHHn as [n0 H]; exists (S n0).
rewrite <- plus_Snm_nSm; simpl; rewrite H; reflexivity.
destruct Hn0 as [n0 Hn0].
rewrite Hn0; apply HN; omega.
Qed.

(**********)
Lemma Rseq_cv_neg_infty_asymptotic : Rseq_asymptotic Rseq_cv_neg_infty.
Proof.
intros Q Un HQ He M.
destruct He as [Ne HNe].
edestruct HQ as [N HN]; [eexact HNe|].
exists (Ne + N)%nat; intros n Hn.
assert (Hn0 : exists n0, (n = Ne + n0)%nat).
induction Hn.
exists N; reflexivity.
destruct IHHn as [n0 H]; exists (S n0).
rewrite <- plus_Snm_nSm; simpl; rewrite H; reflexivity.
destruct Hn0 as [n0 Hn0].
rewrite Hn0; apply HN; omega.
Qed.

(** * Landau relations are asymptotic. *)

(**********)
Lemma Rseq_big_O_asymptotic : Rseq_asymptotic2 Rseq_big_O.
Proof.
intros Q Un Vn HQ He.
destruct He as [Ne HNe].
edestruct HQ as [M [HM [N HN]]]; [eexact HNe|].
exists M; split.
assumption.
exists (Ne + N)%nat; intros n Hn.
assert (Hn0 : exists n0, (n = Ne + n0)%nat).
induction Hn.
exists N; reflexivity.
destruct IHHn as [n0 H]; exists (S n0).
rewrite <- plus_Snm_nSm; simpl; rewrite H; reflexivity.
destruct Hn0 as [n0 Hn0].
rewrite Hn0; apply HN; omega.
Qed.

(**********)
Lemma Rseq_little_O_asymptotic : Rseq_asymptotic2 Rseq_little_O.
Proof.
intros Q Un Vn HQ He.
destruct He as [Ne HNe].
intros eps Heps.
edestruct HQ as [N HN]; [eexact HNe|apply Heps|].
exists (Ne + N)%nat; intros n Hn.
assert (Hn0 : exists n0, (n = Ne + n0)%nat).
induction Hn.
exists N; reflexivity.
destruct IHHn as [n0 H]; exists (S n0).
rewrite <- plus_Snm_nSm; simpl; rewrite H; reflexivity.
destruct Hn0 as [n0 Hn0].
rewrite Hn0; apply HN; omega.
Qed.

(**********)
Lemma Rseq_equiv_asymptotic : Rseq_asymptotic2 Rseq_equiv.
Proof.
intros Q Un Vn HQ He.
destruct He as [Ne HNe].
intros eps Heps.
edestruct HQ as [N HN]; [eexact HNe|apply Heps|].
exists (Ne + N)%nat; intros n Hn.
assert (Hn0 : exists n0, (n = Ne + n0)%nat).
induction Hn.
exists N; reflexivity.
destruct IHHn as [n0 H]; exists (S n0).
rewrite <- plus_Snm_nSm; simpl; rewrite H; reflexivity.
destruct Hn0 as [n0 Hn0].
unfold Rseq_minus in HN.
rewrite Hn0; apply HN; omega.
Qed.


Require Import BenB.

(*
  De systematische vertaalmethode met de blokkendozen is
  conceptueel natuurlijk mooi, maar werkt voor ingewikkeldere
  zinnen alleen maar goed als u over veel en vooral groot papier
  beschikt.

  U kunt echter ook Coq gebruiken voor het administratieve deel van
  deze methode.

  De 'dozen' en de 'hertalingen' kunnen in Coq gesimuleerd worden door
  voor elke stap een nieuwe 'Definition' in te voeren. Gebruik als
  naam voor de definitie de hoofdzin uit de methode, waarbij u natuurlijk
  moet zorgen dat er wel een geldige naam uit komt, dus vervang spaties
  en leestekens door een underscore. Zorg dat eventuele variabelen zichtbaar
  zijn in de namen.

  Helaas kan Coq een 'Definition' alleen maar accepteren als alle
  dingen die in die definitie gebruikt worden al netjes gedefinieerd
  zijn.
  Dat betekent dat de oorspronkelijke zin onderaan in het bestand
  staat en u per stap daarboven een  nieuwe definitie moet toevoegen
  totdat u op het niveau bent waar u direct de predikaten uit het
  domeinmodel kunt gebruiken.
*)

(* Domeinmodel *)

(* Domeinen *)
Variable M : Set.
  (* De verzameling mensen. *)

(* Constanten *)
(* Functies *)

(* Predikaten *)
Variable isMan (* x *) : M -> Prop.
  (* Mens x is een man. *)
  (* Opzoeken bij de gemeentelijke basisadministratie. *)
Variable isVaderVan (* x y *) : M -> M -> Prop.
  (* Mens x is vader van mens y. *)
  (* Opzoeken bij de gemeentelijke basisadministratie. *)
Variable isBroerVan (* x y *) : M -> M -> Prop.
  (* Mens x is een broer van mens y. *)
  (* Opzoeken bij de gemeentelijke basisadministratie. *)

(*
  Hieronder staat een lange lijst definities die u ofwel
  verstandig uitwerkt omdat u de definitie nodig heeft,
  ofwel voorziet van een dummy zodat Coq de regel kan
  uitvoeren, bijvoorbeeld
  'Definition D1 := True.'
*)

Definition iedereenIsBroerVan (x:M) :=
forall (b:M),
    isBroerVan x b
.

Definition iedereenIsZoonVan (x:M) :=
forall(z:M),
    isVaderVan x z
.

Definition D3:= True
.

Definition D4:= True
.

Definition D5:= True
.

Definition D6:= True
.

Definition D7:= True
.

Definition D8:= True
.

Definition D9:= True
.

Definition D10:= True
.

Definition D11:= True
.

Definition D12:= True
.

Definition D13:= True
.

Definition D14:= True
.

Definition D15:= True
.

Definition D16:= True
.

(*
  En hier de zin die u moet gaan formaliseren:
  "Wiens vader iedereens vader is, die heeft elke man tot broer."
*)

Definition wiens_vader_iedereens_vader_is_die_heeft_elke_man_tot_broer :=
forall x:M,
    (exists y:M,
        isVaderVan y x
        /\
        iedereenIsZoonVan y
    )
    ->
    iedereenIsBroerVan x
.

(*
   Uiteindelijk moet u de formule waarbij volgens Coq overbodige haakjes
   zijn weggelaten kopieren naar de leertaak. Om dat eenvoudiger te maken,
   passen we hier een truc toe.
*)

(*
   We maken een kopie van de expressie.
*)
Definition zelfde :=
wiens_vader_iedereens_vader_is_die_heeft_elke_man_tot_broer
.

(*
   Deze kopie is natuurlijk gelijk aan het origineel,
   dus de volgende stelling moet bewijsbaar zijn.
*)
Theorem gelijk :
wiens_vader_iedereens_vader_is_die_heeft_elke_man_tot_broer = zelfde
.
Proof.
(*
   Door stap voor stap een deel van de formule uit te vouwen, toont Coq
   uiteindelijk iets van de vorm 'uitgewerkte formule = zelfde'.
   U kunt dan eenvoudig de formule naar de leertaak kopieren (zonder
   het '= zelfde' deel).
   Zorg wel dat uw kopie een leesbare layout heeft.

   De eerste unfold is al voorgedaan. De rest moet u tussen de placeholder
   'proof' en de tactiek 'reflexivity' zetten.
*)

unfold wiens_vader_iedereens_vader_is_die_heeft_elke_man_tot_broer.
(*! proof *)
unfold iedereenIsZoonVan.
unfold iedereenIsBroerVan.
(*
   Om technische redenen moet u bij de volgende tactiek 'reflexivity'
   de commentaartekens verwijderen.
*)
reflexivity.
Qed.