Require Import sflib.

Require Import String List.
Require Import Arith ZArith Lia.

Require Import StdlibExt IntegersExt.
Require Import IPModel DiscreteTimeModel IntByteModel.
Require Import NWSysModel.

Generalizable Variable sysE.

Notation Tid := nat (only parsing).

Definition resize_bytes (size: nat) (bs: bytes): bytes :=
  firstn size bs ++ List.repeat Byte.zero (size - length bs).

Lemma resize_bytes_length sz bs bs_r
      (RESIZED: resize_bytes sz bs = bs_r)
  : length bs_r = sz.
Proof.
  subst. unfold resize_bytes.
  rewrite app_length.
  rewrite repeat_length.
  destruct (le_lt_dec sz (length bs)).
  - rewrite firstn_length_le; ss.
    nia.
  - rewrite firstn_all2 by nia.
    nia.
Qed.

Definition base_time (prd: nat) (tm: nat): nat :=
  tm - Nat.modulo tm prd.

Definition base_time' (prd: nat) (tm: nat): nat :=
  tm / prd * prd.

Lemma base_times_equiv prd tm
      (PRD_POS: 0 < prd)
      (TIME_POS: 0 < tm)
  : base_time prd tm = base_time' prd tm.
Proof.
  unfold base_time, base_time'.
  rewrite (Nat.div_mod tm prd) at 1 by nia.
  rewrite Nat.add_sub. nia.
Qed.

Lemma div_and_mult_range a b
      (POS_B: 0 < b)
  : a - b <= a / b * b <= a.
Proof.
  split.
  - cut (exists r, r < b /\ a = (a / b) * b + r).
    { i. des. nia. }
    exists (Nat.modulo a b).
    split.
    { apply Nat.mod_upper_bound. nia. }
    rewrite mult_comm.
    apply Nat.div_mod. nia.
  - rewrite mult_comm.
    etransitivity.
    { apply Nat.div_mul_le. nia. }
    rewrite mult_comm.
    rewrite Nat.div_mul; nia.
Qed.

Lemma div_ub_inv a b c
      (* (POS_A: 0 <= a) *)
      (POS_B: 0 < b)
      (* (POS_C: 0 <= c) *)
      (COND: a / b < c)
  : a < c * b.
Proof.
  hexploit (div_and_mult_range a b); eauto. i.
  assert (a <= c * b) by nia.
  assert (~ a = c * b).
  { ii. subst a.
    clear - COND POS_B.
    rewrite Nat.div_mul in COND; nia. }
  nia.
Qed.

Lemma base_time_spec prd tm btm
      (PRD_POS: 0 < prd)
      (TIME_POS: 0 < tm)
  : btm = base_time prd tm <->
    Nat.divide prd btm /\ btm <= tm < btm + prd.
Proof.
  split; intro HYP.
  - subst.
    split.
    + unfold base_time.
      rewrite (Nat.div_mod tm prd) by nia.
      rewrite Nat.add_mod_idemp_r by nia.
      rewrite <- (plus_comm tm).
      rewrite (mult_comm prd).
      rewrite Nat.mod_add by nia.
      rewrite Nat.add_sub.
      apply Nat.divide_factor_r.
    + unfold base_time.
      split.
      * nia.
      * cut (tm mod prd < prd).
        { nia. }
        apply Nat.mod_upper_bound. nia.
  - destruct HYP as (DIV & RANGE1 & RANGE2).
    rewrite base_times_equiv; ss.
    unfold base_time'.
    r in DIV. des.
    generalize (lt_eq_lt_dec z (tm/prd)).
    destruct 1 as [[A | ?] | B]; subst; ss; exfalso.
    + hexploit (Nat.div_le_mono tm).
      2: { apply Nat.lt_le_incl. apply RANGE2. }
      { instantiate (1:= prd). nia. }
      replace (z * prd + prd) with ((z + 1) * prd) by nia.
      rewrite Nat.div_mul by nia.
      i.
      assert (DIV_VAL_EQ: tm / prd = z + 1) by nia.
      cut ( prd * (z + 1) <= tm ).
      { nia. }
      rewrite <- DIV_VAL_EQ.
      rewrite mult_comm.
      eapply div_and_mult_range; nia.
    + hexploit div_ub_inv; try apply B.
      { nia. }
      i. nia.
Qed.

Inductive abst_sendE {msgT: Set}: Type -> Type :=
| AbstSendEvent (tid: Tid) (msg: msgT): abst_sendE unit.

Definition bsendE: Type -> Type := @abst_sendE bytes.
Definition BSendEvent (tid_dest: nat) (msg: bytes)
  : bsendE unit :=
  AbstSendEvent tid_dest msg.

Class SystemEnv `{rnws_params} : Type :=
  {
  (* fixed hyper-parameters for middleware *)
  max_num_tasks: nat;
  max_num_mcasts: nat;
  msg_size_k: nat;
  (* msg_size := 8 * msg_size_k + 7; *)
  msg_size: nat;

  (* parameters specific to this system *)
  period: nat ;
  port: nat;

  task_ips_brep: list bytes ;
  task_ips: list ip_t ;
  mcasts: list (bytes * list Tid) ;
  mcast_ips: list ip_t ;

  (* conditions *)
  min_num_tasks: 0 < length task_ips ;
  num_tasks_bound: length task_ips <= max_num_tasks ;
  num_mcasts_bound: length mcast_ips <= max_num_mcasts ;

  range_max_num_tasks: IntRange.sint8 max_num_tasks ;
  range_max_num_mcasts: IntRange.sint8 max_num_mcasts ;

  range_valid_dest_ids:
    IntRange.sint8 (length task_ips + length mcast_ips) ;
  range_period: IntRange.uint64 period ;
  period_cond: 2 * max_clock_skew + max_nw_delay + max_wait_delay < period ;
  period_mul_10_lt_max:
    (Z.of_nat period * 10 < Int64.max_unsigned)%Z ;

  range_port: IntRange.sint port ;

  task_ips_convert_brep:
    Forall2 (fun bs ip => IP.convert_brep bs = Some ip)
            task_ips_brep task_ips ;

  task_ips_local_ip: Forall (IP.local_ip) task_ips ;
  task_ips_unique: List.NoDup task_ips ;

  mcast_ips_convert_brep:
    Forall2 (fun mc ip => IP.convert_brep (fst mc) = Some ip)
            mcasts mcast_ips ;
  mcast_ips_mcast_ip:
    Forall (IP.mcast_ip) mcast_ips ;
  mcast_ips_unique: List.NoDup mcast_ips ;

  mcast_members_valid:
    Forall (fun mc => Forall (fun tid_m => tid_m < length task_ips) (snd mc)) mcasts;

  msg_size_bound: msg_size <= (msg_size_k * 8 + 7);

  packet_length_bound: (msg_size_k * 8 + 16) < Packet.maxlen ;
  }.

Section SYS_ENV.
  (* Context `{msgT: Set}. *)
  Context `{SystemEnv}.
  Let msgT: Set := bytes.

  Definition num_tasks : nat := length task_ips.
  Definition num_mcasts : nat := length mcast_ips.

  Lemma num_mcasts_eq
    : num_mcasts = length mcasts.
  Proof.
    pose proof mcast_ips_convert_brep.
    hexploit Forall2_length; eauto.
  Qed.

  Definition max_msg_size := msg_size_k * 8 + 7.
  Definition max_pld_size: nat := max_msg_size + 9.
  Definition pld_size: nat := msg_size + 9.

  Definition MAX_TIME: nat :=
    Z.to_nat Int64.max_unsigned - period * 10.
  Definition MAX_TIME_Z: Z :=
    Int64.max_unsigned - Z.of_nat period * 10.

  Lemma max_time_to_z
    : Z.of_nat MAX_TIME = MAX_TIME_Z.
  Proof.
    pose proof period_mul_10_lt_max.
    unfold MAX_TIME, MAX_TIME_Z.

    rewrite Nat2Z.inj_sub by nia.
    rewrite Z2Nat.id by ss.
    rewrite Nat2Z.inj_mul.
    replace (Z.of_nat 5) with 5%Z by ss.
    reflexivity.
  Qed.

  Definition DELTA: nat := 2 * max_clock_skew + max_nw_delay.

  Definition dest_ips_brep: list bytes :=
    task_ips_brep ++ map fst mcasts.

  Definition dest_ips: list ip_t := task_ips ++ mcast_ips.

  Definition tid2ip (tid: Tid): ip_t :=
    nth tid dest_ips 0.

  Definition valid_task_id (tid: Tid): Prop :=
    tid < num_tasks.

  Definition valid_mcast_id (mid: Tid): Prop :=
    exists midx, mid = num_tasks + midx /\
            midx < num_mcasts.

  Definition valid_dest_id (dest_id: Tid): Prop :=
    dest_id < num_tasks + num_mcasts.

  Definition group_memflags (ginfo: bytes * (list Tid))
    : list bool :=
    imap (fun n _ => existsb (Nat.eqb n) (snd ginfo))
         0 (List.repeat tt num_tasks).

  Definition mcast_memflags: list (list bool) :=
    map group_memflags mcasts.

  Lemma mcast_memflags_spec
        mid midx mip_bs mems
        (MID: mid = num_tasks + midx)
        (MCAST: nth_error mcasts midx = Some (mip_bs, mems))
    : exists r_mf,
      <<MFLAG_ROW: nth_error mcast_memflags midx = Some r_mf>> /\
      <<MFLAG_ROW_LEN: length r_mf = num_tasks>> /\
      <<MFLAG_ROW_IFF:
          forall tid (VALID_TID: tid < num_tasks),
            nth_error r_mf tid = Some true <->
            In tid mems>>.
  Proof.
    assert (exists r_mf, <<ROW: nth_error mcast_memflags midx = Some r_mf>>).
    { apply Some_not_None.
      apply nth_error_Some.
      unfold mcast_memflags.
      rewrite map_length.
      apply nth_error_Some.
      congruence. }
    des.
    exists r_mf.
    split; auto.
    unfold mcast_memflags in ROW.
    rewrite map_nth_error_iff in ROW. des.
    subst. clarify.

    unfold group_memflags.
    splits.
    - rewrite imap_length.
      rewrite repeat_length. ss.
    - i. ss.
      rewrite imap_nth_error_iff.
      rewrite repeat_nth_error_Some by ss.
      ss.
      split.
      + i. clarify.
        rewrite existsb_exists in *. des.
        hexploit beq_nat_true; eauto. i. subst. ss.
      + intro IN.
        f_equal. apply existsb_exists.
        esplits.
        { eauto. }
        rewrite <- beq_nat_refl. ss.
  Qed.

  (* Arguments Nat.ltb: simpl nomatch. *)

  Lemma range_num_tasks
    : IntRange.sint8 num_tasks.
  Proof.
    pose proof range_valid_dest_ids as RANGE_VT.
    fold num_tasks in RANGE_VT.
    rr in RANGE_VT. rr.
    split.
    - transitivity 0%Z; ss. nia.
    - nia.
  Qed.

  Lemma range_num_mcasts
    : IntRange.sint8 num_mcasts.
  Proof.
    pose proof range_valid_dest_ids as RANGE_VT.
    fold num_mcasts in RANGE_VT.
    range_stac.
  Qed.

  Definition task_id_ip (tid: Tid) (ip: ip_t): Prop :=
    nth_error task_ips tid = Some ip.

  Definition mcast_id_ip (mid: Tid) (ip: ip_t): Prop :=
    exists midx, mid = num_tasks + midx /\
            nth_error mcast_ips midx = Some ip.

  Lemma valid_task_id_ip
        tid
        (VALID_TID: valid_task_id tid)
    : task_id_ip tid (tid2ip tid).
  Proof.
    r. unfold tid2ip.
    r in VALID_TID.
    hexploit nth_error_Some2; eauto. i. des.
    erewrite nth_error_nth; eauto.
    unfold dest_ips.
    rewrite nth_error_app1; eauto.
  Qed.

  Lemma valid_mcast_id_ip
        mid
        (VALID_MID: valid_mcast_id mid)
    : mcast_id_ip mid (tid2ip mid).
  Proof.
    r. unfold tid2ip.
    r in VALID_MID. des.
    exists midx. split; ss.
    hexploit nth_error_Some2; eauto. i. des.

    pose proof mcast_ips_convert_brep as CONV.
    eapply Forall2_nth2 in CONV; eauto.
    des.

    erewrite nth_error_nth; eauto.
    unfold dest_ips.
    (*   apply map_nth_error. eauto. } *)
    rewrite nth_error_app2; eauto.
    2: { fold num_tasks. nia. }
    fold num_tasks.
    replace (mid - num_tasks) with midx by nia.
    eauto.
  Qed.

  Lemma task_id_ip_comput
        tid ip
        (TASK_ID_IP: task_id_ip tid ip)
    : tid2ip tid = ip /\ IP.local_ip ip = true.
  Proof.
    r in TASK_ID_IP.
    unfold tid2ip.
    split.
    - erewrite nth_error_nth; eauto.
      unfold dest_ips.
      rewrite nth_error_app1; eauto.
      apply nth_error_Some. congruence.
    - pose proof task_ips_local_ip as FA.
      eapply Forall_nth in FA.
      rewrite TASK_ID_IP in FA. ss.
  Qed.

  Lemma mcast_id_ip_comput
        mid ip
        (MCAST_ID_IP: mcast_id_ip mid ip)
    : tid2ip mid = ip /\ IP.mcast_ip ip = true.
  Proof.
    r in MCAST_ID_IP. des.
    unfold tid2ip.
    split.
    - erewrite nth_error_nth; eauto.
      subst mid.
      unfold dest_ips.
      rewrite nth_error_app2.
      + rewrite minus_plus. eauto.
      + fold num_tasks. nia.
    - pose proof mcast_ips_mcast_ip as FA.
      eapply Forall_nth in FA.
      rewrite MCAST_ID_IP0 in FA. ss.
  Qed.

  Lemma mcast_id_ip_det
        mid mip1 mip2
        (MIP1: mcast_id_ip mid mip1)
        (MIP2: mcast_id_ip mid mip2)
    : mip1 = mip2.
  Proof.
    inv MIP1. inv MIP2. des.
    assert (x = x0) by nia.
    clarify.
  Qed.

  (* tid & mcast *)
  Definition dest_id_ip (tid: Tid) (ip: ip_t): Prop :=
    nth_error dest_ips tid = Some ip.

  Definition get_mcast_of (tid: Tid)
    : list Tid :=
    map fst (ifilter (fun _ mc_mems =>
                        existsb (Nat.eqb tid)
                                (snd mc_mems))
                     num_tasks mcasts).

  Lemma get_mcast_of_spec
        tid mid
        (MID_IN: In mid (get_mcast_of tid))
    : exists midx mip_bs mip mems,
      <<MCAST_GROUP_ID_EQ: mid = num_tasks + midx>> /\
      <<MCAST_MEMBER: nth_error mcasts midx = Some (mip_bs, mems)>> /\
      <<MCAST_IP: nth_error mcast_ips midx = Some mip>> /\
      <<CONV_IP_BREP: IP.convert_brep mip_bs = Some mip>> /\
      <<TID_IN_MEMBERS: In tid mems>>.
  Proof.
    unfold get_mcast_of in MID_IN.
    apply in_map_iff in MID_IN.
    destruct MID_IN as [[mid' [mip mems]] [MID_EQ IN_IFLT]].
    ss. subst mid'.
    apply ifilter_spec in IN_IFLT. des. ss.

    pose proof mcast_ips_convert_brep as CONV.
    eapply Forall2_nth1 in CONV; eauto. des. ss.

    esplits; eauto.
    apply existsb_exists in F_TRUE. des.
    hexploit beq_nat_true; eauto. i. subst. ss.
  Qed.

  Lemma member_impl_get_mcast_of
        mid midx mip_bs mems tid
        (MID_EQ: mid = num_tasks + midx)
        (MEMBERS: nth_error mcasts midx = Some (mip_bs, mems))
        (TID_MEMBER: In tid mems)
    : In mid (get_mcast_of tid).
  Proof.
    unfold get_mcast_of.
    apply in_map_iff.
    exists (mid, (mip_bs, mems)). ss.

    split; ss.
    apply ifilter_spec.
    esplits; eauto. ss.
    apply existsb_exists.
    esplits.
    { eauto. }
    apply Nat.eqb_refl.
  Qed.

  Definition mcast_member (tid mid: Tid): Prop :=
    In mid (get_mcast_of tid).

  Lemma task_ips_not_mcast
        tip
        (TASK_IP: In tip task_ips)
    : IP.mcast_ip tip = false.
  Proof.
    hexploit task_ips_local_ip; eauto.
    rewrite Forall_forall.
    intro FA. hexploit FA; eauto.
    intro LOCAL.
    generalize (IP.normal_mcast_disjoint tip).
    rewrite LOCAL. ss.
  Qed.

  Lemma dest_id_ip_inv_det
        id1 id2 ip
        (DEST1: dest_id_ip id1 ip)
        (DEST2: dest_id_ip id2 ip)
    : id1 = id2.
  Proof.
    r in DEST1. r in DEST2.
    unfold dest_ips in *.
    destruct (lt_ge_dec id1 (length task_ips)).
    - rewrite nth_error_app1 in DEST1 by ss.
      destruct (lt_ge_dec id2 (length task_ips)).
      + rewrite nth_error_app1 in DEST2 by ss.
        eapply NoDup_nth_error; eauto.
        * apply task_ips_unique.
        * congruence.
      + rewrite nth_error_app2 in DEST2 by ss.
        hexploit task_ips_not_mcast.
        { eapply nth_error_In; eauto. }
        intro MC.

        pose proof mcast_ips_mcast_ip as MC_MC.
        rewrite Forall_forall in MC_MC.
        hexploit MC_MC; eauto.
        { eapply nth_error_In; eauto. }
        i. congruence.
    - rewrite nth_error_app2 in DEST1 by ss.
      destruct (lt_ge_dec id2 (length task_ips)).
      + rewrite nth_error_app1 in DEST2 by ss.
        hexploit task_ips_not_mcast.
        { eapply nth_error_In; eauto. }
        intro MC.

        pose proof mcast_ips_mcast_ip as MC_MC.
        rewrite Forall_forall in MC_MC.
        hexploit MC_MC; eauto.
        { eapply nth_error_In; eauto. }
        i. congruence.
      + rewrite nth_error_app2 in DEST2 by ss.
        cut (id1 - length task_ips =
             id2 - length task_ips).
        { nia. }
        eapply NoDup_nth_error; eauto.
        * apply mcast_ips_unique.
        * eapply nth_error_Some; eauto. congruence.
        * congruence.
  Qed.

  Lemma mcast_member_valid
        tid mid
        (MCM: mcast_member tid mid)
    : exists mip, mcast_id_ip mid mip.
  Proof.
    unfold mcast_member in MCM.
    unfold get_mcast_of in MCM.
    apply get_mcast_of_spec in MCM.
    des.

    pose proof mcast_ips_convert_brep as CONV.
    eapply Forall2_nth1 in CONV; eauto. des.

    exists mip.
    r. esplits; eauto.
    (* apply map_nth_error_iff. *)
    (* esplits; eauto. *)
  Qed.

  Definition parse_msg (pld: list byte)
    : (nat * Tid * list byte)? :=
    match list_divide pld 8 with
    | None => None
    | Some (bs_tm, bs1) =>
      match bs1 with
      | [] => None
      | b_tid :: bs_data =>
        let dtm_i64: int64 := IntByte.of_bytes64 bs_tm in
        let dtm_n : nat := Z.to_nat (Int64.unsigned dtm_i64) in
        match Z_to_nat2 (Byte.signed b_tid) with
        | None => None
        | Some tid_s =>
          (* let msg := abst_msg tid_s tid_r bs_data in *)
          Some (dtm_n, tid_s, bs_data)
        end
      end
    end.

  Definition serialize_msg (sytm: nat) (tid: Tid) (msg: bytes)
    : bytes :=
    let sytm_i: int64 := IntNat.of_nat64 sytm in
    (IntByte.to_bytes64 sytm_i)
      ++ [Byte.repr (Z.of_nat tid)] ++ msg.

  Lemma serialize_parse_msg_inv
        tm tid bs bs_srl
        (RANGE_TM: IntRange.uint64 tm)
        (RANGE_TID: IntRange.sint8 tid)
        (SERIALIZE: serialize_msg tm tid bs = bs_srl)
    : parse_msg bs_srl = Some (tm, tid, bs).
  Proof.
    unfold serialize_msg in SERIALIZE. subst. ss.
    unfold parse_msg.
    rewrite list_divide_succ.
    2: { apply IntByte.to_bytes_length64. }

    rewrite Byte.signed_repr by range_stac.
    unfold Z_to_nat2.
    destruct (Z.ltb_spec (Z.of_nat tid) 0).
    { inv RANGE_TID. nia. }

    rewrite IntByte.to_bytes_inv64.
    unfold IntNat.of_nat64.
    rewrite Int64.unsigned_repr by range_stac.
    do 2 rewrite Nat2Z.id. ss.
  Qed.

  Lemma packet_length_bound_z
    : (Z.of_nat max_pld_size < Z.of_nat Packet.maxlen)%Z.
  Proof.
    pose proof packet_length_bound as PLB.
    apply Nat2Z.inj_lt in PLB.
    (* unfold Packet.maxlen in *. *)
    (* rewrite Z2Nat.id in PLB by nia. *)
    unfold max_pld_size, max_msg_size.
    nia.
  Qed.

  Lemma range_packet_maxlen
    : IntRange.sint Packet.maxlen.
  Proof.
    unf_ranges.
    unfold Packet.maxlen.
    rewrite Z2Nat.id by ss.
    ss.
  Qed.

  Lemma range_max_pld_size
    : IntRange.sint max_pld_size.
  Proof.
    pose proof packet_length_bound_z.
    pose proof range_packet_maxlen.
    range_stac.
  Qed.

  Lemma pld_size_bound
    : pld_size <= max_pld_size.
  Proof.
    unfold max_pld_size, pld_size.
    unfold max_msg_size.
    generalize msg_size_bound. nia.
  Qed.

  Lemma num_tasks_bound'
    : num_tasks <= max_num_tasks.
  Proof.
    pose proof num_tasks_bound.
    unfold num_tasks. ss.
  Qed.

  Lemma msg_size_bound'
    : msg_size <= max_msg_size.
  Proof.
    pose proof msg_size_bound.
    unfold max_msg_size. ss.
  Qed.

  Lemma range_pld_size
    : IntRange.sint pld_size.
  Proof.
    pose proof pld_size_bound.
    pose proof range_max_pld_size.
    range_stac.
  Qed.

  Lemma range_msg_size
    : IntRange.sint msg_size.
  Proof.
    pose proof range_pld_size.
    unfold pld_size in *.
    range_stac.
  Qed.

  Lemma range_max_msg_size
    : IntRange.sint max_msg_size.
  Proof.
    pose proof range_max_pld_size.
    unfold max_pld_size, max_msg_size in *.
    range_stac.
  Qed.

  Lemma serialize_msg_size_eq
        tm tid bs bs_srl
        (SERIALIZE: serialize_msg tm tid bs = bs_srl)
    : length bs_srl = length bs + 9.
  Proof.
    unfold serialize_msg in SERIALIZE.
    subst. do 2 rewrite app_length. ss.
    rewrite IntByte.to_bytes_length64. nia.
  Qed.

  Lemma serialize_msg_size_lt_maxlen
        tm tid bs bs_srl
        (* (RANGE_TM: IntRange.uint64 tm) *)
        (* (RANGE_TID: IntRange.sint8 tid) *)
        (SERIALIZE: serialize_msg tm tid bs = bs_srl)
        (MSG_LENGTH: length bs <= msg_size)
    : length bs_srl < Packet.maxlen.
  Proof.
    assert (length bs_srl <= pld_size).
    { unfold serialize_msg in SERIALIZE.
      subst. do 2 rewrite app_length. ss.
      rewrite IntByte.to_bytes_length64.
      unfold pld_size. nia.
    }
    unfold pld_size in *.
    pose proof (msg_size_bound).
    pose proof (packet_length_bound). nia.
  Qed.

  (* true => available, false => not *)
  Definition check_send_hist_read
             (sh: list bool) (tid: Tid): bool :=
    match nth_error sh tid with
    | Some b => negb b
    | None => false
    end.

  Definition check_send_hist_write
             (sh: list bool) (tids: list Tid)
    : list bool :=
    imap (fun tid_ent hist_ent =>
            if existsb (Nat.eqb tid_ent) tids
            then true else hist_ent)
         0 sh.

  Definition check_send_hist (sh: list bool)
             (id_dest: Tid)
    : (list bool)? :=
    if id_dest <? num_tasks then
      if check_send_hist_read sh id_dest then
        Some (check_send_hist_write sh [id_dest])
      else None
    else
      match nth_error mcasts (id_dest - num_tasks) with
      | Some (_, members) =>
        if andb_all (map (check_send_hist_read sh)
                         members) then
          Some (check_send_hist_write sh members)
        else None
      | None => None
      end
  .

  Lemma check_send_hist_write_spec
        sh tids sh'
        (SH_LEN: length sh = num_tasks)
        (SH_WRITE: check_send_hist_write sh tids = sh')
    : forall tid (VALID: tid < num_tasks),
      (<<IN_TIDS: In tid tids>> /\
       <<SH_TRUE: nth_error sh' tid = Some true>>) \/
      (<<NOT_IN_TIDS: ~ In tid tids>> /\
       <<SH_INVAR: nth_error sh' tid = nth_error sh tid>>).
  Proof.
    i. hexploit (In_dec Nat.eq_dec tid tids).
    intros [IN | NOT_IN].
    - left. esplits; ss.
      unfold check_send_hist_write in SH_WRITE.
      subst sh'.
      rewrite imap_nth_error_iff. ss.
      hexploit (nth_error_Some2 _ sh tid).
      { nia. }
      i. des.
      rewrite NTH_EX. ss.

      replace (existsb (Nat.eqb tid) tids) with true; ss.
      symmetry.
      apply existsb_exists.
      exists tid.
      split; ss.
      apply Nat.eqb_refl.

    - right. esplits; ss.
      unfold check_send_hist_write in SH_WRITE.
      subst sh'.
      rewrite imap_nth_error_iff. ss.

      replace (existsb (Nat.eqb tid) tids) with false.
      { destruct (nth_error sh tid); ss. }
      symmetry.
      apply existsb_false_iff.
      apply Forall_forall. i.
      destruct (Nat.eqb_spec tid x); ss.
      subst. ss.
  Qed.

  Lemma check_send_hist_Some
        sh id_d sh'
        (SEND_HIST_LEN: length sh = num_tasks)
        (SH: check_send_hist sh id_d = Some sh')
    : <<SEND_HIST_LEN': length sh' = num_tasks>> /\
      ((<<DEST_TASK_ID: valid_task_id id_d>> /\
        <<SEND_AVAILABLE: nth_error sh id_d = Some false>> /\
        <<UPD_HIST: nth_error sh' id_d = Some true>> /\
        <<UPD_HIST_OTHERS:
          forall tid
            (TID_NEQ: tid <> id_d),
            nth_error sh' tid = nth_error sh tid>>)
       \/
       (<<DEST_MCAST_ID: valid_mcast_id id_d>> /\
        <<UPD_HIST:
          forall tid
            (* (VALID_TID: valid_task_id tid) *)
            (MEMBER: mcast_member tid id_d),
            valid_task_id tid /\
            nth_error sh tid = Some false /\
            nth_error sh' tid = Some true >> /\
        <<UPD_HIST_OTHERS:
              forall tid
                (NOT_MEMBER: ~ mcast_member tid id_d),
                nth_error sh' tid = nth_error sh tid>>)).
  Proof.
    unfold check_send_hist in SH.
    destruct (Nat.ltb_spec id_d num_tasks).
    { (* unicast *)
      unfold check_send_hist_read in SH.
      hexploit (nth_error_Some2 _ sh id_d).
      { nia. }
      i. des. renames e1 NTH_EX into sh_d SH_D.
      rewrite SH_D in SH.
      destruct sh_d; ss.
      clarify.

      pose (sh' := check_send_hist_write sh [id_d]).
      fold sh'.
      assert (SH'_LEN: length sh' = num_tasks).
      { subst sh'.
        unfold check_send_hist_write.
        rewrite imap_length. ss. }
      splits; ss.
      left.

      hexploit (check_send_hist_write_spec sh [id_d]); eauto.
      ss. i. des; ss.
      2: { exfalso.
           apply NOT_IN_TIDS. eauto. }

      splits; ss.
      i.
      destruct (lt_ge_dec tid num_tasks).
      2: { rewrite nth_error_None2 by nia.
           rewrite nth_error_None2 by nia.
           ss. }

      hexploit (check_send_hist_write_spec sh [id_d]); eauto.
      i. des; ss.
      des; ss. clarify.
    }
    { (* multicast *)
      pose (idx := id_d - num_tasks).
      fold idx in SH.
      destruct (nth_error mcasts idx)
        as [[mip_bs mems]|] eqn: MCAST_IDX; ss.

      assert (CHK_TRUE: andb_all (map (check_send_hist_read sh) mems) = true).
      { desf. }

      rewrite CHK_TRUE in SH. clarify.

      pose (sh' := check_send_hist_write sh mems).
      fold sh'.
      assert (SH'_LEN: length sh' = num_tasks).
      { subst sh'.
        unfold check_send_hist_write.
        rewrite imap_length. ss. }
      splits; ss.

      right.
      rewrite andb_all_true_iff in CHK_TRUE.

      splits.
      - r. exists idx.
        pose proof mcast_ips_convert_brep as CONV_M.
        apply Forall2_length in CONV_M.
        split.
        + nia.
        + unfold num_mcasts. rewrite <- CONV_M.
          apply nth_error_Some. unfold bytes in *. congruence.
      - intros tid MCAST_MEM.
        r in MCAST_MEM.
        eapply get_mcast_of_spec in MCAST_MEM. des.
        assert (midx = idx) by nia.
        subst midx.
        assert (mip_bs0 = mip_bs /\ mems0 = mems).
        { clarify. }
        des. subst mip_bs0 mems0.

        assert (CH_TID_TRUE: check_send_hist_read sh tid = true).
        { apply CHK_TRUE.
          apply in_map. eauto. }

        unfold check_send_hist_read in CH_TID_TRUE.
        desf.
        destruct b; ss.

        assert (VALID_TID: tid < num_tasks).
        { rewrite <- SEND_HIST_LEN.
          apply nth_error_Some. congruence. }

        split; ss.
        subst sh'.
        hexploit (check_send_hist_write_spec sh mems); eauto.
        i. des.
        2: { congruence. }
        ss.
      - i.
        destruct (lt_ge_dec tid num_tasks).
        2: { rewrite nth_error_None2 by nia.
             rewrite nth_error_None2 by nia. ss. }

        r in NOT_MEMBER.
        subst sh'.
        hexploit (check_send_hist_write_spec sh mems); eauto.
        i. des; ss.
        exfalso.
        apply NOT_MEMBER. r.
        eapply member_impl_get_mcast_of; eauto.
        nia.
    }
  Qed.

  Lemma check_send_hist_None
        sh id_d
        (SEND_HIST_LENGTH: length sh = num_tasks)
        (SH_NONE: check_send_hist sh id_d = None)
    : <<INVALID_DEST_ID: ~ valid_dest_id id_d>> \/
      (<<DEST_TASK_ID: valid_task_id id_d>> /\
       <<SEND_DONE: nth_error sh id_d = Some true>>) \/
      (<<DEST_MCAST_ID: valid_mcast_id id_d>> /\
       exists tid_sent,
         <<MEMBER: mcast_member tid_sent id_d>> /\
         (<<TID_INVALID: ~ valid_task_id tid_sent>> \/
          <<SEND_DONE: nth_error sh tid_sent = Some true>>)).
  Proof.
    unfold check_send_hist in SH_NONE.
    destruct (Nat.ltb_spec id_d num_tasks).
    { unfold check_send_hist_read in SH_NONE.
      hexploit (nth_error_Some2 _ sh id_d).
      { nia. }
      i. des. renames e1 NTH_EX into sh_d SH_D.
      rewrite SH_D in SH_NONE.
      destruct sh_d; ss. eauto.
    }
    pose proof mcast_ips_convert_brep as CONV_M.
    apply Forall2_length in CONV_M.

    destruct (nth_error mcasts (id_d - num_tasks))
      as [[mid mems]|] eqn:MCASTS_N.
    { destruct (andb_all (map (check_send_hist_read sh) mems))
               eqn: ANDB_ALL; ss.
      rewrite andb_all_false_iff in ANDB_ALL.
      apply in_map_iff in ANDB_ALL. des.

      right. right.
      esplits.
      - r. exists (id_d - num_tasks).
        split.
        + nia.
        + unfold num_mcasts. rewrite <- CONV_M.
          apply nth_error_Some. unfold bytes in *. congruence.
      - r. eapply member_impl_get_mcast_of; eauto.
        nia.
      - unfold check_send_hist_read in ANDB_ALL.
        destruct (nth_error sh x) eqn:SH_X.
        2: { eapply nth_error_None in SH_X.
             left. unfold valid_task_id. nia. }
        right. destruct b; ss.
    }
    { left. r.
      unfold valid_dest_id.
      eapply nth_error_None in MCASTS_N.
      fold num_mcasts in *.
      unfold bytes in *.
      nia. }
  Qed.

End SYS_ENV.

Section SKWD_BASE_TIME.
  Context `{SystemEnv}.

  Definition get_skwd_base_time
             (period: nat) (gtm: DTime.t): nat :=
    base_time period (DTime.to_ns_rd gtm + max_clock_skew).

  Definition exact_skwd_base_time
             (period: nat)
             (gtm: DTime.t) : nat? :=
    match DTime.to_ns_exact gtm with
    | None => None
    | Some gtm_ns =>
      let sytm_cand := gtm_ns + max_clock_skew in
      if (sytm_cand mod period =? O)%nat
      then Some sytm_cand else None
    end.

  Section LEMMAS.

    Let prd := period.
    Let MAX_CSKEW_POS: 0 < max_clock_skew.
    Proof. apply max_clock_skew_pos. Qed.
    Let PRD_COND: 2 * max_clock_skew + max_nw_delay + max_wait_delay < prd.
    Proof. apply period_cond. Qed.

    Lemma base_time_mono
          (tm1 tm2: nat)
          (LE: tm1 <= tm2)
      : base_time prd tm1 <= base_time prd tm2.
    Proof.
      unfold base_time.
      hexploit (Nat.div_mod tm1 prd).
      { nia. }
      hexploit (Nat.div_mod tm2 prd).
      { nia. }
      intros TM2 TM1.
      replace (tm1 - tm1 mod prd) with
          (prd * (tm1 / prd)) by nia.
      replace (tm2 - tm2 mod prd) with
          (prd * (tm2 / prd)) by nia.
      clear TM1 TM2.
      cut (tm1 / prd <= tm2 / prd).
      { nia. }
      apply Nat.div_le_mono; ss.
      nia.
    Qed.

    Lemma get_skwd_base_time_mono
          (tm1 tm2: DTime.t)
          (TM_LE: tm1 <= tm2)
      : get_skwd_base_time prd tm1 <=
        get_skwd_base_time prd tm2.
    Proof.
      hexploit (DTime_to_ns_rd_le_mono tm1 tm2); eauto.
      i. unfold get_skwd_base_time.
      apply base_time_mono.
      nia.
    Qed.

    Lemma get_skwd_base_time_iff
          tm sbt
      : get_skwd_base_time prd tm = sbt <->
        (DTime.of_ns (sbt - max_clock_skew) <= tm
         < DTime.of_ns (sbt + prd - max_clock_skew) /\
         Nat.divide prd sbt).
    Proof.
      pose proof DTime.units_per_ns_pos as UNITS_POS.
      split.
      - unfold get_skwd_base_time.
        intros BASE_TIME. symmetry in BASE_TIME.
        apply base_time_spec in BASE_TIME; cycle 1.
        { nia. }
        { nia. }

        destruct BASE_TIME as (SBT_DIV & R1 & R2).

        (* assert (TM_DIV_MUL: tm / DTime.units_per_ns * DTime.units_per_ns <= tm). *)
        (* { apply div_and_mult_range. nia. } *)

        splits.
        + hexploit (div_and_mult_range
                      tm DTime.units_per_ns); eauto.
          intros TM_DIV_MUL.

          ss. unfold DTime.to_ns_rd in *.
          assert (AUX1: sbt * DTime.units_per_ns <=
                        (tm / DTime.units_per_ns + max_clock_skew) *
                        DTime.units_per_ns) by nia.
          rewrite Nat.mul_add_distr_r in AUX1. nia.
        + clear R1.
          pose (n := DTime.to_ns_rd tm).
          fold n in R2.

          assert (EQ: DTime.to_ns_rd tm = n) by ss.
          eapply DTime_to_ns_rd_spec in EQ.
          destruct EQ as (r & TM_EQ & RANGE_R).

          assert (AUX1: (n + max_clock_skew) *
                        DTime.units_per_ns + r <
                        (sbt + prd) * DTime.units_per_ns)
            by nia.
          ss. nia.
        + ss.

      - intros (RANGE & DIV).
        unfold get_skwd_base_time.
        symmetry.
        apply base_time_spec.
        { nia. }
        { nia. }

        hexploit (DTime_to_ns_rd_spec tm); eauto.
        intros (R & TM_EQ & RANGE_R).
        destruct tm as [u]; ss.

        splits; ss.
        + nia.
        + nia.
    Qed.

    Lemma get_skwd_base_time_range
          tm sbt
          (SKWD_BASE_TIME: sbt = get_skwd_base_time prd tm)
      : DTime.of_ns (sbt - max_clock_skew) <= tm
        < DTime.of_ns (sbt + prd - max_clock_skew).
    Proof.
      symmetry in SKWD_BASE_TIME.
      apply get_skwd_base_time_iff in SKWD_BASE_TIME.
      des. eauto.
    Qed.

    Lemma exact_skwd_base_time_None_iff (t: DTime.t)
          (TIME_POS: 0 < t)
      : exact_skwd_base_time prd t = None <->
        (exists sbt,
           (sbt - max_clock_skew) * DTime.units_per_ns < t <
           (sbt + prd - max_clock_skew) * DTime.units_per_ns
           /\ Nat.divide prd sbt).
    Proof.
      split.
      - intro EXACT_NONE.
        unfold exact_skwd_base_time in EXACT_NONE.
        destruct (DTime.to_ns_exact t)
          as [tm_ns|] eqn: EXACT.
        + destruct (Nat.eqb_spec ((tm_ns + max_clock_skew) mod prd) 0) as [EQ_Z | NEQ_Z].
          { congruence. }

          eapply DTime_to_ns_exact_spec in EXACT.
          destruct t as [u]. ss. subst.

          hexploit (Nat.div_mod
                      (tm_ns + max_clock_skew) prd).
          { nia. }

          remember ((tm_ns + max_clock_skew) / prd) as q.
          remember ((tm_ns + max_clock_skew) mod prd) as r.
          assert (RANGE_R: 0 < r < prd).
          { split.
            { nia. }
            subst r.
            apply Nat.mod_bound_pos; nia.
          }

          intros TM_NS_EQ.
          exists (prd * q).
          splits; ss.
          * nia.
          * nia.
          * apply Nat.divide_factor_l.
        + apply DTime_to_ns_exact_None_iff in EXACT.
          destruct EXACT as (tm_ns & r & T_EQ & _ & RANGE_R).
          destruct t as [u]; ss. subst u.

          assert (SBT: exists sbt, sbt = base_time prd (tm_ns + max_clock_skew)).
          { esplits; ss. }
          des.
          eapply base_time_spec in SBT; cycle 1.
          { nia. }
          { nia. }
          destruct SBT as (SBT_DIV & RANGE_SBT).

          exists sbt. splits; ss; nia.

      - intros (sbt & RANGE_SBT & SBT_DIV).
        unfold exact_skwd_base_time.
        unfold DTime.to_ns_exact.

        destruct t as [u]; ss.
        destruct (Nat.eqb_spec (u mod DTime.units_per_ns) 0) as [MOD_Z|]; ss.
        rewrite Nat.mod_divide in MOD_Z by nia.
        r in MOD_Z.

        desH MOD_Z. rename z into z1. subst u.
        assert (RANGE2: sbt < z1 + max_clock_skew < sbt + prd).
        { nia. }

        (* assert (RANGE2: (sbt - max_clock_skew) < z1 < sbt + prd - max_clock_skew). *)
        (* { nia. } *)
        clear RANGE_SBT.

        unfold DTime.to_ns_rd. ss.
        rewrite Nat.div_mul by nia.

        destruct (Nat.eqb_spec ((z1 + max_clock_skew) mod prd) 0) as [MOD_Z|]; ss.

        exfalso.
        rewrite Nat.mod_divide in MOD_Z by nia.
        r in MOD_Z.
        desH MOD_Z. rename z into z2.
        rewrite MOD_Z in RANGE2.

        r in SBT_DIV.
        desH SBT_DIV. subst sbt.
        cut (z < z2 < (z + 1)).
        { nia. }
        nia.
    Qed.

    Lemma exact_skwd_base_time_iff
          (t: DTime.t) sbt
          (* (TIME_LB: DTime.of_ns (prd - max_clock_skew) <= t) *)
      : exact_skwd_base_time prd t = Some sbt <->
        (0 < sbt /\
         (* DTime.of_ns (prd - max_clock_skew) <= t /\ *)
         (t:nat) = (sbt - max_clock_skew) * DTime.units_per_ns /\
         Nat.divide prd sbt).
    Proof.
      split; intro X.
      - unfold exact_skwd_base_time in X.
        unfold DTime.to_ns_exact in X.
        desf.
        rewrite Nat.add_sub.
        unfold DTime.to_ns_rd.
        rewrite Nat.mul_comm.
        splits.
        + assert (EXACT: Nat.divide DTime.units_per_ns
                                    (DTime.units t)).
          { apply Nat.mod_divide.
            { pose proof DTime.units_per_ns_pos. nia. }
            apply beq_nat_true. ss. }
          rr in EXACT. des.
          ss. rewrite EXACT.
          cut (prd - max_clock_skew <= z).
          { nia. }

          erewrite DTime_to_ns_rd_eq_exact in *; eauto.

          assert (EXACT2: Nat.divide prd (z + max_clock_skew)).
          { apply Nat.mod_divide.
            { pose proof DTime.units_per_ns_pos. nia. }
            apply beq_nat_true. ss. }

          rr in EXACT2.
          rename z into y. des.
          cut (prd <= y + max_clock_skew).
          { nia. }
          destruct z; nia.
        + apply Nat.div_exact.
          * pose proof DTime.units_per_ns_pos.
            nia.
          * apply beq_nat_true. ss.
        + assert (T: exists n, (t:nat) = DTime.units_per_ns * n).
          { apply Nat.mod_divides.
            - pose proof DTime.units_per_ns_pos. nia.
            - apply beq_nat_true. ss. }
          des. rewrite Nat.mul_comm in T.
          rewrite (DTime_to_ns_rd_eq_exact n t) in * by ss.
          apply Nat.mod_divide.
          { nia. }
          cut (t / DTime.units_per_ns = n).
          { intro R. rewrite R.
            apply beq_nat_true. ss. }
          rewrite T.
          apply Nat.div_mul.
          pose proof DTime.units_per_ns_pos. nia.
      - destruct X as [? [T_EQ SBT_SYNC]].
        unfold exact_skwd_base_time.
        unfold DTime.to_ns_exact.
        rewrite T_EQ.
        rewrite Nat.mod_mul. ss.

        erewrite DTime_to_ns_rd_eq_exact; eauto.
        2: { pose proof DTime.units_per_ns_pos.
             nia. }

        assert (max_clock_skew <= sbt).
        { rr in SBT_SYNC. des. subst.
          destruct z; nia. }
        rewrite Nat.sub_add by nia.
        apply Nat.mod_divide in SBT_SYNC.
        2: { nia. }
        rewrite SBT_SYNC. ss.

        (* assert (prd <= sbt). *)
        (* { pose proof DTime.units_per_ns_pos. *)
        (*   nia. } *)
        (* rewrite Nat.sub_add by nia. *)
        (* apply Nat.mod_divide in SBT_SYNC. *)
        (* 2: { nia. } *)
        (* rewrite SBT_SYNC. ss. *)
    Qed.

    Lemma exact_skwd_impl_get
          tm tm_ex
          (EXACT: exact_skwd_base_time period tm = Some tm_ex)
      : get_skwd_base_time period tm = tm_ex.
    Proof.
      apply exact_skwd_base_time_iff in EXACT.
      des.
      destruct tm as [u]. ss. subst u.
      apply get_skwd_base_time_iff. ss.
      pose proof DTime.units_per_ns_pos.

      splits.
      - nia.
      - nia.
      - ss.
    Qed.

    Lemma skwd_time_range_almost_overwrap
          (tm: DTime.t)
          sbt1 sbt2
          (SYNC1: Nat.divide prd sbt1)
          (SYNC2: Nat.divide prd sbt2)
          (RANGE1: (sbt1 - max_clock_skew) *
                   DTime.units_per_ns <= tm <
                   (sbt1 + prd - max_clock_skew) *
                   DTime.units_per_ns)
          (RANGE2: (sbt2 - max_clock_skew) *
                   DTime.units_per_ns < tm <=
                   (sbt2 + prd - max_clock_skew) *
                   DTime.units_per_ns)
      : sbt1 = sbt2 \/
        (sbt1 = sbt2 + prd /\
         (sbt1 - max_clock_skew) * DTime.units_per_ns = tm).
    Proof.
      destruct RANGE2 as [TM_LB TM_UB].
      apply le_lt_or_eq in TM_UB.

      assert (F1: get_skwd_base_time prd tm = sbt1).
      { apply get_skwd_base_time_iff; ss. }

      desH TM_UB.
      - left.
        cut (get_skwd_base_time prd tm = sbt2).
        { i. clarify. }
        apply get_skwd_base_time_iff; eauto. ss.
        split; ss. nia.
      - right.
        cut (get_skwd_base_time prd tm = (sbt2 + prd)).
        { i.
          cut (sbt1 = sbt2 + prd).
          { split; auto.
            congruence. }
          clarify.
        }

        apply get_skwd_base_time_iff. ss.
        split.
        2: { apply Nat.divide_add_r; auto.
             apply Nat.divide_refl. }
        rewrite TM_UB. ss.
        split.
        { nia. }
        clear - PRD_COND.
        pose proof DTime.units_per_ns_pos.
        nia.
    Qed.

    (* Lemma lt_maxtime_nxt_in_range' *)
    (*       cbt' *)
    (*       (CBT_LT: cbt' < MAX_TIME) *)
    (*   : cbt' + period <= Z.to_nat Int64.max_unsigned. *)
    (* Proof. *)
    (*   revert cbt' CBT_LT. *)
    (*   unfold MAX_TIME. *)
    (*   i. nia. *)
    (* Qed. *)

    Lemma lt_maxtime_nxt_in_range
      : forall cbt'
          (CBT_LT: cbt' < MAX_TIME),
        IntRange.uint64 (cbt' + period).
    Proof.
      i.
      cut (Z.of_nat (cbt' + period) <
           MAX_TIME_Z + Z.of_nat period)%Z.
      { clear.
        unfold MAX_TIME_Z.
        i. range_stac. }
      pose proof max_time_to_z. nia.
    Qed.

    (* Lemma pld_size_lt_intmax *)
    (*   : pld_size < Z.to_nat Int.max_signed. *)
    (* Proof. *)
    (*   pose proof msg_size_bound as MSIZE_BD. *)
    (*   eapply le_lt_trans with (m:= max_pld_size). *)
    (*   { unfold pld_size, max_pld_size. ss. *)
    (*     unfold max_msg_size. nia. } *)
    (*   eapply lt_trans with (m:=Packet.maxlen). *)
    (*   { pose proof packet_length_bound. *)
    (*     unfold max_pld_size, max_msg_size. nia. } *)
    (*   { unfold Packet.maxlen. *)
    (*     apply Z2Nat.inj_lt; ss. } *)
    (* Qed. *)

  End LEMMAS.
End SKWD_BASE_TIME.


Require Import
  MathClasses.interfaces.canonical_names MathClasses.misc.util.
Require Bool.

Class Decision P := decide: sumbool P (¬P).
Arguments decide _ {Decision}.

#[global]
Instance: ∀ P, Decision P → Stable P.
Proof. firstorder. Qed.

Ltac case_decide := match goal with
  | H : context [@decide ?P ?dec] |- _ => case (@decide P dec) in *
  | |- context [@decide ?P ?dec] => case (@decide P dec) in *
  end.

Ltac solve_trivial_decision :=
  match goal with
  | [ |- Decision (?P) ] => apply _
  | [ |- sumbool ?P (¬?P) ] => change (Decision P); apply _
  end.

Ltac solve_decision :=
  first [solve_trivial_decision | unfold Decision; decide equality; solve_trivial_decision].

(* We cannot state this as Proper (iff ==> iffT) Decision due to the lack of setoid rewriting in Type *)
Program Definition decision_proper (P Q : Prop) (PiffQ : P ↔ Q) (P_dec : Decision P) : Decision Q :=
  match P_dec with
  | left _ => left _
  | right _ => right _
  end.
Solve Obligations with (program_simpl; tauto).

Definition bool_decide (P : Prop) `{dec : !Decision P} : bool := if dec then true else false.

Lemma bool_decide_true `{dec : Decision P} : bool_decide P ≡ true ↔ P.
Proof. unfold bool_decide. split; intro; destruct dec; firstorder with bool. Qed.

Lemma bool_decide_false `{dec : !Decision P} : bool_decide P ≡ false ↔ ¬P.
Proof. unfold bool_decide. split; intro; destruct dec; firstorder with bool. Qed.

(*
  Because [vm_compute] evaluates terms in [Prop] eagerly and does not remove dead code we
  need the decide_rel hack. Suppose we have [(x = y) =def  (f x = f y)], now:
     bool_decide (x = y) → bool_decide (f x = f y) → ...
  As we see, the dead code [f x] and [f y] is actually evaluated, which is of course an utter waste.
  Therefore we introduce decide_rel and bool_decide_rel.
     bool_decide_rel (=) x y → bool_decide_rel (λ a b, f a = f b) x y → ...
  Now the definition of equality remains under a lambda and our problem does not occur anymore!
*)

Definition decide_rel `(R : A → B → Prop) {dec : ∀ x y, Decision (R x y)} (x : A) (y : B) : Decision (R x y)
  := dec x y.

Definition bool_decide_rel `(R : relation A) {dec : ∀ x y, Decision (R x y)} : A → A → bool
  := λ x y, if dec x y then true else false.

Lemma bool_decide_rel_true `(R : relation A) {dec : ∀ x y, Decision (R x y)} :
  ∀ x y, bool_decide_rel R x y ≡ true ↔ R x y.
Proof. unfold bool_decide_rel. split; intro; destruct dec; firstorder with bool. Qed.

Lemma bool_decide_rel_false `(R : relation A)`{dec : ∀ x y, Decision (R x y)} :
  ∀ x y, bool_decide_rel R x y ≡ false ↔ ¬R x y.
Proof. unfold bool_decide_rel. split; intro; destruct dec; firstorder with bool. Qed.

Program Definition decision_from_bool_decide {P b} (prf : b ≡ true ↔ P) :
  Decision P := match b with true => left _ | false => right _ end.
Next Obligation. now apply prf. Qed.
Next Obligation. rewrite <-prf. discriminate. Qed.

#[global]
Program Instance prod_eq_dec `(A_dec : ∀ x y : A, Decision (x ≡ y))
     `(B_dec : ∀ x y : B, Decision (x ≡ y)) : ∀ x y : A * B, Decision (x ≡ y) := λ x y,
  match A_dec (fst x) (fst y) with
  | left _ => match B_dec (snd x) (snd y) with left _ => left _ | right _ => right _ end
  | right _ => right _
  end.
Solve Obligations with (program_simpl; f_equal; firstorder).

#[global]
Program Instance and_dec `(P_dec : Decision P) `(Q_dec : Decision Q) : Decision (P ∧ Q) :=
  match P_dec with
  | left _ => match Q_dec with left _ => left _ | right _ => right _ end
  | right _ => right _
  end.
Solve Obligations with (program_simpl; tauto).

#[global]
Program Instance or_dec `(P_dec : Decision P) `(Q_dec : Decision Q) : Decision (P ∨ Q) :=
  match P_dec with
  | left _ => left _
  | right _ => match Q_dec with left _ => left _ | right _ => right _ end
  end.
Solve Obligations with (program_simpl; firstorder).

#[global]
Program Instance is_Some_dec `(x : option A) : Decision (is_Some x) :=
  match x with
  | None => right _
  | Some _ => left _
  end.

#[global]
Program Instance is_None_dec `(x : option A) : Decision (is_None x) :=
  match x with
  | None => left _
  | Some _ => right _
  end.

#[global]
Program Instance option_eq_dec `(A_dec : ∀ x y : A, Decision (x ≡ y))
     : ∀ x y : option A, Decision (x ≡ y) := λ x y,
  match x with
  | Some r =>
    match y with
    | Some s => match A_dec r s with left _ => left _ | right _ => right _ end
    | None => right _
    end
  | None =>
    match y with
    | Some s => right _
    | None => left _
    end
  end.

#[global]
Program Instance True_dec: Decision True := left _.
#[global]
Program Instance False_dec: Decision False := right _.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export Arith.
Require Export Compare_dec.
Require Export ArithRing.
Require Export Omega.
Require Export ZArith.
Require Export ZArithRing.

Ltac CaseEq f := generalize (refl_equal f); pattern f at -1 in |- *; case f.

Inductive Qpositive : Set :=
  | nR : Qpositive -> Qpositive
  | dL : Qpositive -> Qpositive
  | One : Qpositive.

Fixpoint Qpositive_i (w : Qpositive) : nat * nat :=
  match w with
  | One => (1, 1)
  | nR w' => match Qpositive_i w' with
             | (p, q) => (p + q, q)
             end
  | dL w' => match Qpositive_i w' with
             | (p, q) => (p, p + q)
             end
  end.
Coercion Z_of_nat : nat >-> Z.

Theorem interp_reduced_fraction :
 forall w : Qpositive,
 exists a : Z,
   (exists b : Z, (a * fst (Qpositive_i w) + b * snd (Qpositive_i w))%Z = 1%Z).
intros w; elim w; clear w.
intros w Hrec; elim Hrec; intros a Hrec2; elim Hrec2; intros b; simpl in |- *;
 case (Qpositive_i w); simpl in |- *.
intros p q Heq; exists a; exists (b - a)%Z.
rewrite <- Heq; repeat rewrite Znat.inj_plus; ring.
intros w Hrec; elim Hrec; intros a Hrec2; elim Hrec2; intros b; simpl in |- *;
 case (Qpositive_i w); simpl in |- *.
intros p q Heq; exists (a - b)%Z; exists b.
rewrite <- Heq; repeat rewrite Znat.inj_plus; ring.
exists 1%Z; exists 0%Z; simpl in |- *; omega.
Qed.

Fixpoint Qpositive_inv (w : Qpositive) : Qpositive :=
  match w with
  | One => One
  | nR w' => dL (Qpositive_inv w')
  | dL w' => nR (Qpositive_inv w')
  end.

Theorem inv_correct :
 forall (w : Qpositive) (p q : nat),
 Qpositive_i w = (p, q) -> Qpositive_i (Qpositive_inv w) = (q, p).
 let T_local :=
  (intros w'; simpl in |- *; case (Qpositive_i w'); intros p' q' Hrec p q Heq;
    rewrite (Hrec p' q'); auto; injection Heq; intros H1 H2;
    rewrite <- H1; rewrite <- H2; rewrite plus_comm;
    auto) in
 (intros w; elim w; clear w;
   [ T_local
   | T_local
   | simpl in |- *; intros p q Heq; injection Heq; intros H1 H2;
      rewrite <- H1; rewrite <- H2; auto with * ]).
Qed.

Theorem interp_non_zero :
 forall w : Qpositive,
 exists p : nat, (exists q : nat, Qpositive_i w = (S p, S q)).
simple induction w; simpl in |- *;
 (repeat exists 0; auto; fail) ||
   (intros w' Hrec; elim Hrec; intros p' Hex; elim Hex; intros q' Heq;
     rewrite Heq).
exists (p' + S q'); exists q'; auto.
exists p'; exists (p' + S q'); auto.
Qed.

Fixpoint Qpositive_c (p q n : nat) {struct n} : Qpositive :=
  match n with
  | O => One
  | S n' =>
      match p - q with
      | O => match q - p with
             | O => One
             | v => dL (Qpositive_c p v n')
             end
      | v => nR (Qpositive_c v q n')
      end
  end.

Theorem minus_O_le : forall n m : nat, n - m = 0 -> n <= m.
intros n; elim n; clear n.
auto with arith.
intros n Hrec m; case m; clear m.
simpl in |- *; intros Heq; discriminate Heq.
simpl in |- *; intros; apply le_n_S; apply Hrec; auto.
Qed.

Theorem le_minus_O : forall n m : nat, n <= m -> n - m = 0.
intros n; elim n; clear n.
simpl in |- *; auto.
intros n Hrec m; case m; clear m.
intros Hle; inversion Hle.
intros m' Hle; simpl in |- *; apply Hrec; auto with arith.
Qed.

Theorem minus_le : forall m n : nat, m - n <= m.
intros m; elim m.
simpl in |- *; auto.
intros m' Hrec n; case n; simpl in |- *; auto.
Qed.

Theorem mult_reg_l : forall n m p : nat, S n * m = S n * p -> m = p.
intros n m; elim m; clear m.
intros p; case p; simpl in |- *.
auto.
intros p'; rewrite <- mult_n_O.
intros H; discriminate H.
intros m' Hrec p; case p.
rewrite <- mult_n_O; simpl in |- *; intros H; discriminate H.
intros p'; repeat rewrite (mult_comm (S n)); simpl in |- *.
intros H; injection H.
intros H'; apply f_equal with (f := S).
apply Hrec.
repeat rewrite (mult_comm (S n)).
apply plus_reg_l with n.
exact H'.
Qed.

Theorem absolu_inj_nat : forall x : nat, Zabs_nat (Z_of_nat x) = x.
intros x; case x.
auto.
simpl in |- *.
exact nat_of_P_o_P_of_succ_nat_eq_succ.
Qed.

Theorem absolu_mult :
 forall x y : Z, Zabs_nat (x * y) = Zabs_nat x * Zabs_nat y.
intros x; case x; auto; intros p y; case y; auto; simpl in |- *; intros;
 apply nat_of_P_mult_morphism.
Qed.

Theorem Qpositive_c_unfold1 :
 forall p q n : nat,
 S p + S q + S q <= S n ->
 Qpositive_c (S p + S q) (S q) (S n) = nR (Qpositive_c (S p) (S q) n).
intros p q n Hle; simpl in |- *.
rewrite <- (plus_n_Sm p q).
rewrite <- (minus_Sn_m (p + q) q).
rewrite (plus_comm p); rewrite minus_plus; auto with *.
auto with arith.
Qed.

Theorem Qpositive_c_unfold2 :
 forall p q n : nat,
 S p + (S p + S q) <= S n ->
 Qpositive_c (S p) (S p + S q) (S n) = dL (Qpositive_c (S p) (S q) n).
intros p q n Hle; simpl in |- *.
rewrite le_minus_O.
rewrite minus_plus.
auto.
auto with arith.
Qed.

Theorem construct_correct :
 forall (w : Qpositive) (p q n : nat),
 Qpositive_i w = (p, q) -> p + q <= n -> Qpositive_c p q n = w.
intros w; elim w; clear w.
intros w'; simpl in |- *.
elim (interp_non_zero w'); intros p' Hex; elim Hex; intros q' Heq.
rewrite Heq.
intros Hrec p q n Heq_pair.
injection Heq_pair; intros Heq2 Heq1; rewrite <- Heq2; rewrite <- Heq1.
case n.
simpl in |- *; intros Hle; inversion Hle.
clear n; intros n.
intros Hle.
 replace (Qpositive_c (S (p' + S q')) (S q') (S n)) with
  (nR (Qpositive_c (S p') (S q') n)).
apply f_equal with (f := nR).
apply Hrec; auto with *.
rewrite <- plus_Sn_m.
rewrite Qpositive_c_unfold1. auto with *.
auto with *.
intros w'; simpl in |- *.
elim (interp_non_zero w'); intros p' Hex; elim Hex; intros q' Heq.
rewrite Heq.
intros Hrec p q n Heq_pair.
injection Heq_pair; intros Heq2 Heq1; rewrite <- Heq2; rewrite <- Heq1.
case n.
simpl in |- *; intros Hle; inversion Hle.
clear n; intros n.
intros Hle.
 replace (Qpositive_c (S p') (S (p' + S q')) (S n)) with
  (dL (Qpositive_c (S p') (S q') n)).
apply f_equal with (f := dL).
apply Hrec; auto with *.
rewrite <- plus_Sn_m.
rewrite Qpositive_c_unfold2; auto with *.

simpl in |- *; intros p q n Heq; injection Heq; intros Heq2 Heq1; case n.
rewrite <- Heq1; simpl in |- *; intros Hle; inversion Hle.
rewrite <- Heq1; rewrite <- Heq2; simpl in |- *; auto with *.

Qed.

Theorem construct_correct2 :
 forall n p q : nat,
 S p + S q <= n ->
 exists d : nat,
   S p = fst (Qpositive_i (Qpositive_c (S p) (S q) n)) * S d /\
   S q = snd (Qpositive_i (Qpositive_c (S p) (S q) n)) * S d.
intros n; elim n.
intros p q Hle; inversion Hle.
clear n; intros n.
intros Hrec p q Hle; case (le_gt_dec (S p) (S q)).
simpl in |- *.
intros Hle'; rewrite (le_minus_O p q).
CaseEq (q - p).
intros Heq_minus; exists p.
simpl in |- *; split; auto with arith.
rewrite <- plus_n_O.
apply le_antisym; auto with arith.
apply minus_O_le.
auto.
intros q' Heq_minus; elim (Hrec p q').
intros d; simpl in |- *; case (Qpositive_i (Qpositive_c (S p) (S q') n));
 repeat rewrite <- (mult_comm (S d)); intros p'' q'' (Heq1, Heq2).
exists d; split.
exact Heq1.
rewrite (le_plus_minus (S p) (S q)).
simpl in |- *.
rewrite Heq_minus; rewrite Heq2.
simpl in |- *.
replace (S (p + q'' * S d)) with (S p + q'' * S d).
rewrite Heq1.
simpl in |- *.
ring.
simpl in |- *; auto.
auto with arith.
apply le_S_n.
rewrite plus_n_Sm.
apply le_trans with (S p + S q).
apply plus_le_compat_l.
apply le_n_S.
rewrite <- Heq_minus; apply minus_le.
exact Hle.
auto with arith.
intros Hgt; simpl in |- *; CaseEq (p - q).
intros H; elim (gt_not_le _ _ Hgt).
apply le_n_S.
apply minus_O_le.
exact H.
intros p'.
intros Heq_minus; simpl in |- *; elim (Hrec p' q).
intros d; case (Qpositive_i (Qpositive_c (S p') (S q) n)).
simpl in |- *; intros p'' q'' (Heq1, Heq2).
exists d; split; auto.
rewrite (le_plus_minus (S q) (S p)); simpl in |- *.
rewrite Heq_minus.
replace (S (q + S p')) with (S q + S p').
rewrite Heq2; rewrite Heq1; ring.
simpl in |- *; auto.
auto with arith.
rewrite <- Heq_minus.
replace (p - q) with (S p - S q).
rewrite <- (plus_comm (S q)).
rewrite <- (le_plus_minus (S q) (S p)).
apply le_trans with (S p + q).
auto with arith.
apply le_S_n; rewrite plus_n_Sm.
exact Hle.
auto with arith.
auto.
Qed.

Theorem construct_correct2' :
 forall n p q : nat,
 1 <= p ->
 1 <= q ->
 p + q <= n ->
 exists d : nat,
   p = fst (Qpositive_i (Qpositive_c p q n)) * S d /\
   q = snd (Qpositive_i (Qpositive_c p q n)) * S d.
intros n p; case p.
intros q H; inversion H.
intros p' q; case q.
intros Hle H; inversion H.
intros q' Hle Hle2; exact (construct_correct2 n p' q').
Qed.

Theorem construct_correct3 :
 forall n n' p q p' q' d : nat,
 S p = S d * p' ->
 S q = S d * q' ->
 S p + S q <= S n ->
 p' + q' <= S n' -> Qpositive_c (S p) (S q) (S n) = Qpositive_c p' q' (S n').
intros n; elim n; clear n.
intros n' p q p' q' d; rewrite <- plus_n_Sm.
simpl in |- *.
intros H1 H2 H3; inversion H3.
inversion H0.
intros n0 Hrec n' p q p' q' d Heqd1 Heqd2 Hle1 Hle2.
simpl in |- *.
CaseEq (p - q).
CaseEq (q - p).
intros H H0.
cut (p' = q').
intros Heq'; rewrite Heq'; rewrite <- (minus_n_n q').
auto.
apply mult_reg_l with d.
rewrite <- Heqd2; rewrite <- Heqd1.
apply le_antisym; apply minus_O_le; assumption.
intros q2 Heq2 Heqp.
cut (p' <= q').
intros H; generalize (le_minus_O _ _ H).
intros Heq3; rewrite Heq3.
CaseEq (q' - p').
intros Heq4; cut (q' = p').
intros Heq5; generalize Heq2; replace (q - p) with (S q - S p).
rewrite Heqd2; rewrite Heqd1; rewrite Heq5.
rewrite <- minus_n_n; intros Heq6; discriminate Heq6.
auto.
apply le_antisym; apply minus_O_le; assumption.
intros q'2.
generalize Hle2; case n'.
generalize Heqd1 Heqd2; case p'; case q'.
simpl in |- *; intros H'1 H'2 H'3 H'4; discriminate H'4.
intros x; rewrite <- (mult_comm 0); simpl in |- *; intros Dummy;
 discriminate Dummy.
simpl in |- *; intros x H'1 H'2 H'3 H'4; discriminate H'4.
simpl in |- *; intros n n1 H'1 H'2; rewrite <- plus_n_Sm; intros H'3;
 inversion H'3.
inversion H1.
intros n''.
intros Hle3 Heq4.
simpl in |- *.
CaseEq p'.
intros Heqp'; generalize Heqd1; rewrite Heqp'.
rewrite <- (mult_comm 0); simpl in |- *; intros Dummy; discriminate Dummy.
intros p'2 Heqp'2.
change
  (dL (Qpositive_c (S p) (S q2) (S n0)) =
   dL (Qpositive_c (S p'2) (S q'2) (S n''))) in |- *.
apply f_equal with (f := dL).
apply Hrec with d; auto with *.
rewrite <- Heqp'2; assumption.
rewrite <- Heq4; rewrite <- Heq2; rewrite (mult_comm (S d)).
rewrite mult_minus_distr_r.
repeat rewrite <- (mult_comm (S d)).
rewrite <- Heqd2; rewrite <- Heqd1.
simpl in |- *; auto.
apply mult_S_le_reg_l with d.
rewrite <- Heqd2; rewrite <- Heqd1.
apply le_n_S.
apply minus_O_le; assumption.
intros p2 Heqp2.
CaseEq (p' - q').
intros Heqm'; cut (S p - S q = 0).
simpl in |- *; rewrite Heqp2; intros Dummy; discriminate Dummy.
rewrite Heqd2; rewrite Heqd1.
repeat rewrite (mult_comm (S d)).
rewrite <- mult_minus_distr_r.
rewrite Heqm'; simpl in |- *; auto.
intros p'2.
generalize Hle2; case n'.
generalize Heqd1 Heqd2; case p'; case q'.
simpl in |- *; intros H'1 H'2 H'3 H'4; discriminate H'4.
intros x; rewrite <- (mult_comm 0); simpl in |- *; intros Dummy;
 discriminate Dummy.
intros x; rewrite <- (mult_comm 0); simpl in |- *; intros Dummy1 Dummy2;
 discriminate Dummy2.
simpl in |- *; intros n n1 H'1 H'2; rewrite <- plus_n_Sm; intros H'3;
 inversion H'3.
inversion H0.
intros n''.
intros Hle3 Heq4.
CaseEq q'.
intros Heq5; generalize Heqd2; rewrite Heq5; simpl in |- *.
rewrite <- (mult_comm 0); simpl in |- *; intros Dummy; discriminate Dummy.
intros q'2 Heqq'2.
change
  (nR (Qpositive_c (S p2) (S q) (S n0)) =
   nR (Qpositive_c (S p'2) (S q'2) (S n''))) in |- *.
apply f_equal with (f := nR).
apply Hrec with d; auto with *.
rewrite <- Heq4; rewrite <- Heqp2; rewrite (mult_comm (S d)).
rewrite mult_minus_distr_r.
repeat rewrite <- (mult_comm (S d)).
rewrite <- Heqd2; rewrite <- Heqd1.
simpl in |- *; auto.
rewrite <- Heqq'2; assumption.
Qed.

Theorem construct_correct4 :
 forall p q p' q' n n' : nat,
 S p + S q <= S n ->
 S p' + S q' <= S n' ->
 S p * S q' = S p' * S q ->
 Qpositive_c (S p) (S q) (S n) = Qpositive_c (S p') (S q') (S n').
intros p q p' q' n n' H H0 H1.
elim (construct_correct2 _ _ _ H).
intros d (Heq1, Heq2).
elim (construct_correct2 _ _ _ H0).
intros d' (Heq3, Heq4).
elim (interp_non_zero (Qpositive_c (S p) (S q) (S n))).
intros p0 Hex1; elim Hex1; intros q0 Heq5; clear Hex1.
elim (interp_non_zero (Qpositive_c (S p') (S q') (S n'))).
intros p'0 Hex1; elim Hex1; intros q'0 Heq6; clear Hex1.
elim (interp_reduced_fraction (Qpositive_c (S p) (S q) (S n))); intros a Hex1;
 elim Hex1; intros b; clear Hex1.
rewrite Heq6 in Heq4; rewrite Heq6 in Heq3; rewrite Heq5 in Heq2;
 rewrite Heq5 in Heq1; rewrite Heq5; unfold fst, snd in |- *;
 intros Heq7.
generalize H1; rewrite Heq1; rewrite Heq2; rewrite Heq3; rewrite Heq4;
 unfold fst, snd in |- *; clear H1; intros H1.
unfold fst, snd in Heq1, Heq2, Heq3, Heq4.
cut (S p0 * S q'0 = S p'0 * S q0).
intros Heq8.
cut (S p'0 = Zabs_nat (a * S p'0 + b * S q'0) * S p0).
intros Heq9.
cut (S q'0 = Zabs_nat (a * S p'0 + b * S q'0) * S q0).
intros Heq10.
cut (exists d'' : nat, Zabs_nat (a * S p'0 + b * S q'0) = S d'').
intros Hex; elim Hex; intros d'' Heq11; rewrite Heq11 in Heq9;
 rewrite Heq11 in Heq10.
replace (S p0 * S d) with (S (d + p0 * S d)).
replace (S q0 * S d) with (S (d + q0 * S d)).
rewrite
 (construct_correct3 n n (d + p0 * S d) (d + q0 * S d) (S p0) (S q0) d)
 .
replace (S p'0 * S d') with (S (d' + p'0 * S d')).
replace (S q'0 * S d') with (S (d' + q'0 * S d')).
symmetry  in |- *.
apply construct_correct3 with (d := d' + d'' * S d').
replace (S (d' + p'0 * S d')) with (S p'0 * S d').
rewrite Heq9; ring.
auto.
replace (S (d' + q'0 * S d')) with (S q'0 * S d').
rewrite Heq10; ring.
auto.
replace (S (d' + q'0 * S d')) with (S q'0 * S d').
replace (S (d' + p'0 * S d')) with (S p'0 * S d').
rewrite <- Heq3; rewrite <- Heq4.
exact H0.
auto.
auto.
apply le_trans with (S p + S q).
rewrite Heq1; rewrite Heq2.
rewrite <- mult_plus_distr_r.
rewrite mult_comm; simpl in |- *; auto with arith.
assumption.
auto.
auto.
rewrite (mult_comm (S d)); auto.
rewrite (mult_comm (S d)); auto.
replace (S (d + q0 * S d)) with (S q0 * S d).
replace (S (d + p0 * S d)) with (S p0 * S d).
rewrite <- Heq1; rewrite <- Heq2.
exact H.
auto.
auto.
apply le_trans with (S p + S q).
rewrite Heq1; rewrite Heq2.
rewrite <- mult_plus_distr_r.
rewrite mult_comm; simpl in |- *; auto with arith.
assumption.
auto.
auto.
CaseEq (Zabs_nat (a * S p'0 + b * S q'0)).
intros Dummy; rewrite Dummy in Heq10; simpl in Heq10; discriminate Heq10.
intros d'' Heq; exists d''; auto.
rewrite <- (absolu_inj_nat (S q0)).
pattern (S q'0) at 1 in |- *; rewrite <- (absolu_inj_nat (S q'0)).
rewrite <- absolu_mult.
apply f_equal with (f := Zabs_nat).
pattern (Z_of_nat (S q'0)) at 1 in |- *; rewrite <- Zmult_1_r.
rewrite <- Heq7.
replace (S q'0 * (a * S p0 + b * S q0))%Z with
 (S p0 * S q'0 * a + S q'0 * (b * S q0))%Z.
rewrite <- (Znat.inj_mult (S p0)).
rewrite Heq8.
rewrite Znat.inj_mult; ring.
ring.
rewrite <- (absolu_inj_nat (S p0)).
pattern (S p'0) at 1 in |- *; rewrite <- absolu_inj_nat.
rewrite <- absolu_mult.
apply f_equal with (f := Zabs_nat).
pattern (Z_of_nat (S p'0)) at 1 in |- *; rewrite <- Zmult_1_r.
rewrite <- Heq7.
replace (S p'0 * (a * S p0 + b * S q0))%Z with
 (S p'0 * S q0 * b + S p'0 * (a * S p0))%Z.
rewrite <- (Znat.inj_mult (S p'0)).
rewrite <- Heq8.
rewrite Znat.inj_mult; ring.
ring.
apply mult_reg_l with (d' + d * S d').
replace (S (d' + d * S d')) with (S d * S d').
transitivity (S p0 * S d * (S q'0 * S d')).
ring.
rewrite H1.
ring.
auto.
Qed.

Theorem construct_correct4' :
 forall p q p' q' n n' : nat,
 1 <= p ->
 1 <= q ->
 1 <= p' ->
 1 <= q' ->
 p + q <= n ->
 p' + q' <= n' -> p * q' = p' * q -> Qpositive_c p q n = Qpositive_c p' q' n'.
intros p; case p.
intros q p' q' n n' H; inversion H.
intros p0 q; case q.
intros p' q' n n' H H1; inversion H1.
intros q0 p'; case p'.
intros q' n n' H H1 H2; inversion H2.
intros p'0 q'; case q'.
intros n n' H H1 H2 H3; inversion H3.
intros q'0 n; case n.
simpl in |- *; intros n' H H1 H2 H3 H4; inversion H4.
intros n0 n'; case n'.
simpl in |- *; intros H H1 H2 H3 H4 H5; inversion H5.
intros; apply construct_correct4; auto.
Qed.

Theorem interp_inject :
 forall w w' : Qpositive, Qpositive_i w = Qpositive_i w' -> w = w'.
intros w w' H; CaseEq (Qpositive_i w).
intros p q Heq.
rewrite <- construct_correct with (1 := Heq) (n := p + q).
apply construct_correct; auto.
rewrite <- H; auto.
auto.
Qed.

Theorem minus_decompose :
 forall a b c d : nat, a = b -> c = d -> a - c = b - d.
intros a b c d H H1; rewrite H; rewrite H1; auto.
Qed.

Theorem Qpositive_c_equiv :
 forall n p q n' p' q' : nat,
 S p + S q <= n ->
 S p' + S q' <= n' ->
 Qpositive_c (S p) (S q) n = Qpositive_c (S p') (S q') n' ->
 S p * S q' = S p' * S q.
intros n; elim n.
simpl in |- *; intros p q n' p' q' H; inversion H.
intros n0 Hrec p q n'.
case n'.
simpl in |- *; intros p' q' H H1; inversion H1.
unfold Qpositive_c in |- *.
CaseEq (S p - S q).
CaseEq (S q - S p).
intros Heq1 Heq2 n1 p' q'; CaseEq (S p' - S q').
CaseEq (S q' - S p').
intros Heq3 Heq4; cut (p = q).
intros Heq5; rewrite Heq5.
cut (p' = q').
intros Heq6; rewrite Heq6.
intros; apply mult_comm.
apply eq_add_S; apply le_antisym; apply minus_O_le; auto with *.
apply eq_add_S; apply le_antisym; apply minus_O_le; auto with *.
intros p2 H H1 H2 H3 H4; discriminate H4.
intros n2 H H1 H2 H4; discriminate H4.
intros q2 Heq1 Heq2 n2 p' q'; CaseEq (S p' - S q').
CaseEq (S q' - S p').
intros H3 H4 H H1 H2; discriminate H2.
intros q'2 H H1 H2 H3 H4; injection H4; intros H5.
rewrite (le_plus_minus (S p) (S q)).
rewrite (le_plus_minus (S p') (S q')).
rewrite (mult_comm (S p)); rewrite (mult_comm (S p')).
repeat rewrite mult_plus_distr_r; repeat rewrite <- (mult_comm (S p)).
apply f_equal with (f := fun x : nat => S p * S p' + x).
rewrite Heq1; rewrite H.
rewrite <- (mult_comm (S p')).
apply Hrec with n2.
rewrite <- Heq1.
rewrite <- le_plus_minus.
apply le_trans with (p + S q).
auto with arith.
apply le_S_n; exact H2.
apply minus_O_le; auto.
rewrite <- H.
rewrite <- le_plus_minus.
apply le_trans with (p' + S q').
auto with arith; fail.
apply le_S_n; exact H3.
apply minus_O_le; auto.
exact H5.
apply minus_O_le; auto.
apply minus_O_le; auto.
intros n1 dummy1 Dummy2 Dummy3 Dummy; discriminate Dummy.
intros n1 Heq1 n2 p' q' Hle1 Hle2; CaseEq (S p' - S q').
CaseEq (S q' - S p').
intros Dummy3 Dummy1 Dummy2; discriminate Dummy2.
intros n3 Dummy Dummy1 Dummy2; discriminate Dummy2.
intros p'2 Heq2 Heq3.
injection Heq3; clear Heq3; intros Heq3.
rewrite (le_plus_minus (S q) (S p)).
rewrite Heq1.
rewrite (le_plus_minus (S q') (S p')).
rewrite Heq2.
repeat rewrite mult_plus_distr_r; repeat rewrite (mult_comm (S q')).
apply f_equal with (f := fun x : nat => S q * S q' + x).
apply Hrec with n2.
rewrite plus_comm; rewrite <- Heq1.
rewrite <- le_plus_minus.
apply le_trans with (p + S q).
rewrite <- plus_n_Sm.
auto with arith.
apply le_S_n; assumption.
omega.
rewrite <- Heq2.
rewrite plus_comm; rewrite <- le_plus_minus.
apply le_trans with (p' + S q').
rewrite <- plus_n_Sm; auto with arith.
apply le_S_n; exact Hle2.
omega.
exact Heq3.
omega.
omega.
Qed.

Theorem Qpositive_c_equiv' :
 forall n p q n' p' q' : nat,
 1 <= p ->
 1 <= q ->
 1 <= p' ->
 1 <= q' ->
 p + q <= n ->
 p' + q' <= n' -> Qpositive_c p q n = Qpositive_c p' q' n' -> p * q' = p' * q.
intros n p q n' p' q'; case p.
intros H; inversion H.
clear p; intros p Hlp.
case q; [ intros H; inversion H | clear q; intros q Dummy; clear Dummy ].
case p'; [ intros H; inversion H | clear p'; intros p' Dummy; clear Dummy ].
case q'; [ intros H; inversion H | clear q'; intros q' Dummy; clear Dummy ].
intros; apply Qpositive_c_equiv with n n'; auto.
Qed.