Require Export Task.driver_state.
Require Export Task.trig.
Import ListNotations.
Import FloatIO.
Import DebugIO.
Import DScopeNotations.
Import RecordSetNotations'.
Open Scope D_scope.
Import CoqTrig.

Definition z_terminate_sim_event := {| key := "z_terminate_sim_event"; time := 0%D |}.

Definition sq (f: float) := f * f.

Definition log_miss (sim: simTy) (dt_miss: float) : simTy :=
  let svars := sim.(vars) in
  let t := svGetFloat SvT svars in
  let x_tb_i := svGetFloat SvX_TB_I svars in
  let y_tb_i := svGetFloat SvY_TB_I svars in
  let z_tb_i := svGetFloat SvZ_TB_I svars in
  let xd_tb_i := svGetFloat SvXD_TB_I svars in
  let yd_tb_i := svGetFloat SvYD_TB_I svars in
  let zd_tb_i := svGetFloat SvZD_TB_I svars in

  let r_miss := sqrt
                  (((x_tb_i - xd_tb_i * dt_miss) * (x_tb_i - xd_tb_i * dt_miss))
                   + ((y_tb_i - yd_tb_i * dt_miss) * (y_tb_i - yd_tb_i * dt_miss))
                   + ((z_tb_i - zd_tb_i * dt_miss) * (z_tb_i - zd_tb_i * dt_miss))
                  ) in
  let miss_vars :=
      [("t", print_float t);
       ("r_miss", print_float r_miss);
       ("dt_miss", print_float dt_miss)] in
  let miss_entry := {| le_caption := "log_miss"; le_vars := miss_vars; le_events := [] |} in
  sim[[log_entries ::= (fun oldlog => miss_entry :: oldlog)]].

Definition z_terminate_sim_event_func  : event_function_signature :=
  fun (this: eventTy) (sim: simTy) =>
    let svars := sim.(vars) in
    let x_tb_i := svGetFloat SvX_TB_I svars in
    let y_tb_i := svGetFloat SvY_TB_I svars in
    let z_tb_i := svGetFloat SvZ_TB_I svars in
    let xd_tb_i := svGetFloat SvXD_TB_I svars in
    let yd_tb_i := svGetFloat SvYD_TB_I svars in
    let zd_tb_i := svGetFloat SvZD_TB_I svars in

    let time_to_go := -(x_tb_i * xd_tb_i + y_tb_i * yd_tb_i + z_tb_i * zd_tb_i) /
                        ((sq xd_tb_i) + (sq yd_tb_i) + (sq zd_tb_i)) in
    let result_sim :=
        if (time_to_go <? 0%D) then
          let sim1 := log_miss sim time_to_go in
          let flags2 := sim1.(flags)[[end_of_run := true]] in
          sim1[[flags := flags2]]
        else
          sim
    in
    (result_sim, None).

Definition model_handlers :=
  ("z_terminate_sim_event", z_terminate_sim_event_func) ::
  driver_default_handlers.

(*+ Initial the modules *)
Definition actuator_init (sim: simTy) := sim.
Definition aero_init (sim: simTy) := sim.
Definition mass_init (sim: simTy) := sim.

Definition kinematics_init (sim: simTy) :=
  let svars := sim.(vars) in
  let psi_b := svGetFloat SvPSI_B_IC_DG svars / rd_to_dg in
  let theta_b := svGetFloat SvTHETA_B_IC_DG svars / rd_to_dg in
  let phi_b := svGetFloat SvPHI_B_IC_DG svars / rd_to_dg in
  let p_b := svGetFloat SvP_B_IC_DG svars / rd_to_dg in
  let q_b := svGetFloat SvQ_B_IC_DG svars / rd_to_dg in
  let r_b := svGetFloat SvR_B_IC_DG svars / rd_to_dg in

  let cpsio2 := cos("0.5"#D * psi_b) in
  let cthetao2 := cos("0.5"#D * theta_b) in
  let cphio2 := cos("0.5"#D * phi_b) in
  let spsio2 := sin("0.5"#D * psi_b) in
  let sthetao2 := sin("0.5"#D * theta_b) in
  let sphio2 := sin("0.5"#D * phi_b) in
  let q0_b := cpsio2 * cthetao2 * cphio2 + spsio2 * sthetao2 * sphio2 in
  let q1_b := cpsio2 * cthetao2 * sphio2 - spsio2 * sthetao2 * cphio2 in
  let q2_b := cpsio2 * sthetao2 * cphio2 + spsio2 * cthetao2 * sphio2 in
  let q3_b := spsio2 * cthetao2 * cphio2 - cpsio2 * sthetao2 * sphio2 in
  union_vars sim
             [
               (SvPSI_B, psi_b);
               (SvTHETA_B, theta_b);
               (SvPHI_B, phi_b);
               (SvP_B, p_b);
               (SvQ_B, q_b);
               (SvR_B, r_b);
               (SvQ0_B, q0_b);
               (SvQ1_B, q1_b);
               (SvQ2_B, q2_b);
               (SvQ3_B, q3_b);
               (SvX_BI_I, svGetFloat SvX_BI_I_IC svars);
               (SvY_BI_I, svGetFloat SvY_BI_I_IC svars);
               (SvZ_BI_I, svGetFloat SvZ_BI_I_IC svars);
               (SvXD_BI_I, svGetFloat SvXD_BI_I_IC svars);
               (SvYD_BI_I, svGetFloat SvYD_BI_I_IC svars);
               (SvZD_BI_I, svGetFloat SvZD_BI_I_IC svars)
             ].

Definition gyro_init (sim: simTy) := sim.

Definition target_init (sim: simTy) :=
  let svars := sim.(vars) in
  union_vars sim
             [
               (SvX_TI_I, svGetFloat SvX_TI_I_IC svars);
               (SvY_TI_I, svGetFloat SvY_TI_I_IC svars);
               (SvZ_TI_I, svGetFloat SvZ_TI_I_IC svars);
               (SvXD_TI_I, svGetFloat SvXD_TI_I_IC svars);
               (SvYD_TI_I, svGetFloat SvYD_TI_I_IC svars);
               (SvZD_TI_I, svGetFloat SvZD_TI_I_IC svars)
             ].

Definition seeker_init (sim: simTy) := sim.

Definition flight_computer_init (sim: simTy) :=
  let svars := sim.(vars) in
  let psi_b_est_dg := svGetFloat SvPSI_B_EST_DG svars in
  let theta_b_est_dg := svGetFloat SvTHETA_B_EST_DG svars in
  let phi_b_est_dg := svGetFloat SvPHI_B_EST_DG svars in

  (* Begin flight computer initialization: *)
  (* Initial flight computer states *)

  (* Trig functions of half Euler angles *)
  let cpsio2 := cos("0.5"#D * psi_b_est_dg / rd_to_dg) in
  let cthetao2 := cos("0.5"#D * theta_b_est_dg / rd_to_dg) in
  let cphio2 := cos("0.5"#D * phi_b_est_dg / rd_to_dg) in
  let spsio2 := sin("0.5"#D * psi_b_est_dg / rd_to_dg) in
  let sthetao2 := sin("0.5"#D * theta_b_est_dg / rd_to_dg) in
  let sphio2 := sin("0.5"#D * phi_b_est_dg / rd_to_dg) in

  (* Initial quaternion values *)
  let q0_b_est := cpsio2 * cthetao2 * cphio2 + spsio2 * sthetao2 * sphio2 in
  let q1_b_est := cpsio2 * cthetao2 * sphio2 + spsio2 * sthetao2 * cphio2 in
  let q2_b_est := cpsio2 * sthetao2 * cphio2 + spsio2 * cthetao2 * sphio2 in
  let q3_b_est := spsio2 * cthetao2 * cphio2 + cpsio2 * sthetao2 * sphio2 in

  union_vars sim
             [
               (SvQ0_B_EST, q0_b_est);
               (SvQ1_B_EST, q1_b_est);
               (SvQ2_B_EST, q2_b_est);
               (SvQ3_B_EST, q3_b_est)
             ].

Definition init_sim (sim0: simTy) :=
  let sim1 := actuator_init sim0 in
  let sim2 := aero_init sim1 in
  let sim3 := mass_init sim2 in
  let sim4 := kinematics_init sim3 in
  let sim5 := gyro_init sim4 in
  let sim6 := target_init sim5 in
  let sim7 := seeker_init sim6 in
  let sim8 := flight_computer_init sim7 in
  let sim9 := union_vars sim8
                         [
                           (SvROLL_GUIDANCE_GAIN, "-20.0"#D);
                           (SvPITCH_GUIDANCE_GAIN, "4.0"#D);
                           (SvX_TI_I, "500.0"#D);
                           (SvY_TI_I, "-250.0"#D)
                         ] in
  sim9[[sim_events ::= (fun others => z_terminate_sim_event::others)]].

Definition limit (x l u  : float) : float :=
  if (x <? l) then l
  else if (x >? u) then u
  else  x.

Definition max (x y: float) : float :=
  if x >? y then x else y.

Definition actuator (sim: simTy) : simTy :=
  let svars := sim.(vars) in
  let fl := svGetFloat SvFIN_LIMIT svars in
  let fin_1_cmd := svGetFloat SvFIN_1_CMD svars in
  let fin_2_cmd := svGetFloat SvFIN_2_CMD svars in
  let fin_3_cmd := svGetFloat SvFIN_3_CMD svars in
  let fin_4_cmd := svGetFloat SvFIN_4_CMD svars in
  union_vars sim
             [
               (SvFIN_1_POSITION, limit fin_1_cmd  (-fl)  fl) ;
               (SvFIN_2_POSITION, limit fin_2_cmd  (-fl)  fl) ;
               (SvFIN_3_POSITION, limit fin_3_cmd  (-fl)  fl) ;
               (SvFIN_4_POSITION, limit fin_4_cmd  (-fl)  fl)
             ].

Definition aero (sim: simTy) : simTy :=
  let svars := sim.(vars) in
  let air_density := svGetFloat SvAIR_DENSITY svars in
  let ref_area := svGetFloat SvREF_AREA svars in
  let ref_length := svGetFloat SvREF_LENGTH svars in
  let cx_base := svGetFloat SvCX_BASE svars in
  let cx_per_alpha_total := svGetFloat SvCX_PER_ALPHA_TOTAL svars in
  let cy_per_beta := svGetFloat SvCY_PER_BETA svars in
  let cz_per_alpha := svGetFloat SvCZ_PER_ALPHA svars in
  let cmy_per_alpha := svGetFloat SvCMY_PER_ALPHA svars in
  let cmz_per_beta := svGetFloat SvCMZ_PER_BETA svars in
  let cmx_per_delp := svGetFloat SvCMX_PER_DELP svars in
  let cmy_per_delq := svGetFloat SvCMY_PER_DELQ svars in
  let cmz_per_delr := svGetFloat SvCMZ_PER_DELR svars in
  let cmp := svGetFloat SvCMP svars in
  let cmq := svGetFloat SvCMQ svars in
  let cmr := svGetFloat SvCMR svars in
  let xd_bi_i := svGetFloat SvXD_BI_I svars in
  let yd_bi_i := svGetFloat SvYD_BI_I svars in
  let zd_bi_i := svGetFloat SvZD_BI_I svars in
  let p_b := svGetFloat SvP_B svars in
  let q_b := svGetFloat SvQ_B svars in
  let r_b := svGetFloat SvR_B svars in
  let q0_b := svGetFloat SvQ0_B svars in
  let q1_b := svGetFloat SvQ1_B svars in
  let q2_b := svGetFloat SvQ2_B svars in
  let q3_b := svGetFloat SvQ3_B svars in
  let fin_1_position := svGetFloat SvFIN_1_POSITION svars in
  let fin_2_position := svGetFloat SvFIN_2_POSITION svars in
  let fin_3_position := svGetFloat SvFIN_3_POSITION svars in
  let fin_4_position := svGetFloat SvFIN_4_POSITION svars in

  (* Begin math model: *)

  (* Evaluate ICS to BCS transformation matrix *)
  let tib11 := q0_b * q0_b + q1_b * q1_b - q2_b * q2_b - q3_b * q3_b in
  let tib12 := "2.0"#D * (q1_b * q2_b + q0_b * q3_b) in
  let tib13 := "2.0"#D * (q1_b * q3_b - q0_b * q2_b) in
  let tib21 := "2.0"#D * (q1_b * q2_b - q0_b * q3_b) in
  let tib22 := q0_b * q0_b + q2_b * q2_b - q1_b * q1_b - q3_b * q3_b in
  let tib23 := "2.0"#D * (q2_b * q3_b + q0_b * q1_b) in
  let tib31 := "2.0"#D * (q1_b * q3_b + q0_b * q2_b) in
  let tib32 := "2.0"#D * (q2_b * q3_b - q0_b * q1_b) in
  let tib33 := q0_b * q0_b + q3_b * q3_b - q1_b * q1_b - q2_b * q2_b in

  (* Missile velocity WRT ICS origin in BCS *)
  let xd_bi_b := xd_bi_i * tib11 + yd_bi_i * tib12 + zd_bi_i * tib13 in
  let yd_bi_b := xd_bi_i * tib21 + yd_bi_i * tib22 + zd_bi_i * tib23 in
  let zd_bi_b := xd_bi_i * tib31 + yd_bi_i * tib32 + zd_bi_i * tib33 in
  let velsq := xd_bi_i * xd_bi_i + yd_bi_i * yd_bi_i + zd_bi_i * zd_bi_i in
  let vmag := sqrt(velsq) in

  (* Angle of attack, sideslip angle, and total angle-of-attack *)
  let alpha := atan2 zd_bi_b xd_bi_b in
  let beta := atan2 yd_bi_b xd_bi_b in
  let alpha_total := atan2 (sqrt (yd_bi_b * yd_bi_b + zd_bi_b * zd_bi_b)) xd_bi_b in

  (* Dynamic pressure and multipliers for forces and moments *)
  let qbar_b := "0.5"#D * air_density * velsq in
  let qbarsref := qbar_b * ref_area in
  let qbarsreflref := qbarsref * ref_length in
  let lrefo2vmag := ref_length / ("2.0"#D * vmag) in

  (* Equivalent fin deflections *)
  let del_eff_p := "-0.25"#D * (fin_1_position + fin_2_position + fin_3_position + fin_4_position) in
  let del_eff_q := "0.5"#D * (fin_3_position - fin_1_position) in
  let del_eff_r := "0.5"#D * (fin_4_position - fin_2_position) in

  (* Aerodynamics forces *)
  let faerox_bi_b := (cx_base + cx_per_alpha_total * alpha_total) * qbarsref in
  let faeroy_bi_b := cy_per_beta * beta * qbarsref in
  let faeroz_bi_b := cz_per_alpha * alpha * qbarsref in

  (* Aerodynamics moments *)
  let maerox_bi_b := qbarsreflref * (cmx_per_delp * del_eff_p + cmp * p_b * lrefo2vmag) in
  let maeroy_bi_b := qbarsreflref * (cmy_per_alpha * alpha + cmy_per_delq * del_eff_q + cmq * q_b * lrefo2vmag) in
  let maeroz_bi_b := qbarsreflref * (cmz_per_beta * beta + cmz_per_delr * del_eff_r + cmr * r_b * lrefo2vmag) in
  union_vars sim
             [
               (SvTIB11, tib11);
               (SvTIB12, tib12);
               (SvTIB13, tib13);
               (SvTIB21, tib21);
               (SvTIB22, tib22);
               (SvTIB23, tib23);
               (SvTIB31, tib31);
               (SvTIB32, tib32);
               (SvTIB33, tib33);
               (SvALPHA, alpha);
               (SvBETA, beta);
               (SvALPHA_TOTAL, alpha_total);
               (SvFAEROX_BI_B, faerox_bi_b);
               (SvFAEROY_BI_B, faeroy_bi_b);
               (SvFAEROZ_BI_B, faeroz_bi_b);
               (SvMAEROX_BI_B, maerox_bi_b);
               (SvMAEROY_BI_B, maeroy_bi_b);
               (SvMAEROZ_BI_B, maeroz_bi_b)
             ].

Definition mass (sim: simTy) : simTy := sim.

Definition kinematics (sim: simTy) : simTy :=
  let svars := sim.(vars) in
    let faerox_bi_b := svGetFloat SvFAEROX_BI_B svars in
    let faeroy_bi_b := svGetFloat SvFAEROY_BI_B svars in
    let faeroz_bi_b := svGetFloat SvFAEROZ_BI_B svars in
    let maerox_bi_b := svGetFloat SvMAEROX_BI_B svars in
    let maeroy_bi_b := svGetFloat SvMAEROY_BI_B svars in
    let maeroz_bi_b := svGetFloat SvMAEROZ_BI_B svars in
    let ixx_b := svGetFloat SvIXX_B svars in
    let iyy_b := svGetFloat SvIYY_B svars in
    let izz_b := svGetFloat SvIZZ_B svars in
    let mass_b := svGetFloat SvMASS_B svars in
    let p_b := svGetFloat SvP_B svars in
    let q_b := svGetFloat SvQ_B svars in
    let r_b := svGetFloat SvR_B svars in
    let tib11 := svGetFloat SvTIB11 svars in
    let tib12 := svGetFloat SvTIB12 svars in
    let tib13 := svGetFloat SvTIB13 svars in
    let tib21 := svGetFloat SvTIB21 svars in
    let tib22 := svGetFloat SvTIB22 svars in
    let tib23 := svGetFloat SvTIB23 svars in
    let tib31 := svGetFloat SvTIB31 svars in
    let tib32 := svGetFloat SvTIB32 svars in
    let tib33 := svGetFloat SvTIB33 svars in
    let acc_gravity := svGetFloat SvACC_GRAVITY svars in
    let q0_b := svGetFloat SvQ0_B svars in
    let q1_b := svGetFloat SvQ1_B svars in
    let q2_b := svGetFloat SvQ2_B svars in
    let q3_b := svGetFloat SvQ3_B svars in

    (* Begin math model: *)

    (* Evaluate Euler angles *)
    let stheta_b := limit (-tib13) ("-1.0"#D) ("1.0"#D) in
    let theta_b := asin(stheta_b) in
    let psi_b := atan2 tib12 tib11 in
    let phi_b := atan2 tib23 tib33 in

    (* Missile velocity rate in ICS WRT ICS *)
    let xdd_bi_i := (tib11 * faerox_bi_b + tib21 * faeroy_bi_b + tib31 * faeroz_bi_b) / mass_b in
    let ydd_bi_i := (tib12 * faerox_bi_b + tib22 * faeroy_bi_b + tib32 * faeroz_bi_b) / mass_b in
    let zdd_bi_i := (tib13 * faerox_bi_b + tib23 * faeroy_bi_b + tib33 * faeroz_bi_b) / mass_b + acc_gravity in

    (* Angular rate derivatives *)
    let pd_b := maerox_bi_b / ixx_b in
    let qd_b := (maeroy_bi_b + p_b * r_b * (izz_b - ixx_b)) / iyy_b in
    let rd_b := (maeroz_bi_b + q_b * p_b * (ixx_b - iyy_b)) / izz_b in

    (* Quaternion constraint equation *)
    let qmag := sqrt(q0_b * q0_b + q1_b * q1_b + q2_b * q2_b + q3_b * q3_b) in
    let q0_b := q0_b / qmag in
    let q1_b := q1_b / qmag in
    let q2_b := q2_b / qmag in
    let q3_b := q3_b / qmag in

    (* Quaternion derivative *)
    let q0d_b := "-0.5"#D * (q1_b * p_b + q2_b * q_b + q3_b * r_b) in
    let q1d_b :=  "0.5"#D * (q0_b * p_b + q2_b * r_b - q3_b * q_b) in
    let q2d_b :=  "0.5"#D * (q0_b * q_b + q3_b * p_b - q1_b * r_b) in
    let q3d_b :=  "0.5"#D * (q0_b * r_b + q1_b * q_b - q2_b * p_b) in

  union_vars sim
             [
               (SvQ0D_B, q0d_b);
               (SvQ1D_B, q1d_b);
               (SvQ2D_B, q2d_b);
               (SvQ3D_B, q3d_b);
               (SvPD_B, pd_b);
               (SvQD_B, qd_b);
               (SvRD_B, rd_b);
               (SvXDD_BI_I, xdd_bi_i);
               (SvYDD_BI_I, ydd_bi_i);
               (SvZDD_BI_I, zdd_bi_i);
               (SvPSI_B, psi_b);
               (SvTHETA_B, theta_b);
               (SvPHI_B, phi_b);
               (SvQ0_B, q0_b);
               (SvQ1_B, q1_b);
               (SvQ2_B, q2_b);
               (SvQ3_B, q3_b)
             ].

Definition target (sim: simTy) : simTy :=
  let svars := sim.(vars) in
  let time := svGetFloat SvT svars in
  let x_ti_i_ic := svGetFloat SvX_TI_I_IC svars in
  let y_ti_i_ic := svGetFloat SvY_TI_I_IC svars in
  let z_ti_i_ic := svGetFloat SvZ_TI_I_IC svars in
  let xd_ti_i := svGetFloat SvXD_TI_I svars in
  let yd_ti_i := svGetFloat SvYD_TI_I svars in
  let zd_ti_i := svGetFloat SvZD_TI_I svars in

  union_vars sim
             [
               (SvX_TI_I, x_ti_i_ic + xd_ti_i * time);
               (SvY_TI_I, y_ti_i_ic + yd_ti_i * time);
               (SvZ_TI_I, z_ti_i_ic + zd_ti_i * time)
             ].

Definition seeker (sim: simTy) : simTy :=
  let svars := sim.(vars) in
  let tib21 := svGetFloat SvTIB21 svars in
  let tib22 := svGetFloat SvTIB22 svars in
  let tib23 := svGetFloat SvTIB23 svars in
  let tib31 := svGetFloat SvTIB31 svars in
  let tib32 := svGetFloat SvTIB32 svars in
  let tib33 := svGetFloat SvTIB33 svars in
  let x_bi_i := svGetFloat SvX_BI_I svars in
  let x_ti_i := svGetFloat SvX_TI_I svars in
  let xd_bi_i := svGetFloat SvXD_BI_I svars in
  let xd_ti_i := svGetFloat SvXD_TI_I svars in
  let y_bi_i := svGetFloat SvY_BI_I svars in
  let y_ti_i := svGetFloat SvY_TI_I svars in
  let yd_bi_i := svGetFloat SvYD_BI_I svars in
  let yd_ti_i := svGetFloat SvYD_TI_I svars in
  let z_bi_i := svGetFloat SvZ_BI_I svars in
  let z_ti_i := svGetFloat SvZ_TI_I svars in
  let zd_bi_i := svGetFloat SvZD_BI_I svars in
  let zd_ti_i := svGetFloat SvZD_TI_I svars in

  let x_tb_i := x_ti_i - x_bi_i in
  let y_tb_i := y_ti_i - y_bi_i in
  let z_tb_i := z_ti_i - z_bi_i in
  let xd_tb_i := xd_ti_i - xd_bi_i in
  let yd_tb_i := yd_ti_i - yd_bi_i in
  let zd_tb_i := zd_ti_i - zd_bi_i in

  (* Missile/target svGetFloat Svange, squared & limited *)
  let range_tb_sq := max small (x_tb_i * x_tb_i + y_tb_i * y_tb_i + z_tb_i * z_tb_i) in

  (* Beam rotation rate WRT inertial space in ICS *)
  let p_s := (y_tb_i * zd_tb_i - z_tb_i * yd_tb_i) / range_tb_sq in
  let q_s := (z_tb_i * xd_tb_i - x_tb_i * zd_tb_i) / range_tb_sq in
  let r_s := (x_tb_i * yd_tb_i - y_tb_i * xd_tb_i) / range_tb_sq in

  (* Beam rotation rate WRT inertial space in BCS *)
  let q_si_b_meas := tib21 * p_s + tib22 * q_s + tib23 * r_s in
  let r_si_b_meas := tib31 * p_s + tib32 * q_s + tib33 * r_s in

  union_vars sim
             [
               (SvP_S, p_s);
               (SvQ_S, q_s);
               (SvQ_SI_B_MEAS, q_si_b_meas);
               (SvR_S, r_s);
               (SvR_SI_B_MEAS, r_si_b_meas);
               (SvRANGE_TB_SQ, range_tb_sq);
               (SvXD_TB_I, xd_tb_i);
               (SvYD_TB_I, yd_tb_i);
               (SvZD_TB_I, zd_tb_i);
               (SvX_TB_I, x_tb_i);
               (SvY_TB_I, y_tb_i);
               (SvZ_TB_I, z_tb_i)
             ].

Definition gyro (sim: simTy) : simTy :=
  let svars := sim.(vars) in
  union_vars sim
             [
               (SvP_G_MEAS, svGetFloat SvP_B svars);
               (SvQ_G_MEAS, svGetFloat SvQ_B svars);
               (SvR_G_MEAS, svGetFloat SvR_B svars)
             ].

Definition flight_computer (sim: simTy) : simTy :=
  let svars := sim.(vars) in
  let p_g_meas := svGetFloat SvP_G_MEAS svars in
  let q_g_meas := svGetFloat SvQ_G_MEAS svars in
  let r_g_meas := svGetFloat SvR_G_MEAS svars in
  let pitch_guidance_gain := svGetFloat SvPITCH_GUIDANCE_GAIN svars in
  let roll_guidance_gain := svGetFloat SvROLL_GUIDANCE_GAIN svars in
  let yaw_guidance_gain := svGetFloat SvYAW_GUIDANCE_GAIN svars in
  let q_b_cmd_bias := svGetFloat SvQ_B_CMD_BIAS svars in
  let del_cmd_per_p_cmd := svGetFloat SvDEL_CMD_PER_P_CMD svars in
  let del_cmd_per_q_cmd := svGetFloat SvDEL_CMD_PER_Q_CMD svars in
  let del_cmd_per_r_cmd := svGetFloat SvDEL_CMD_PER_R_CMD svars in
  let q_si_b_meas := svGetFloat SvQ_SI_B_MEAS svars in
  let r_si_b_meas := svGetFloat SvR_SI_B_MEAS svars in
  let q0_b_est := svGetFloat SvQ0_B_EST svars in
  let q1_b_est := svGetFloat SvQ1_B_EST svars in
  let q2_b_est := svGetFloat SvQ2_B_EST svars in
  let q3_b_est := svGetFloat SvQ3_B_EST svars in

  (* Begin flight computer emulation: *)

  (* Navigation section *)
  (* Evaluate the ICS to BCS transformation matrix *)
  let tib11_est := q0_b_est * q0_b_est + q1_b_est * q1_b_est - q2_b_est * q2_b_est - q3_b_est * q3_b_est in
  let tib12_est := "2.0"#D * (q1_b_est * q2_b_est + q0_b_est * q3_b_est) in
  let tib13_est := "2.0"#D * (q1_b_est * q3_b_est - q0_b_est * q2_b_est) in
  let tib23_est := "2.0"#D * (q2_b_est * q3_b_est + q0_b_est * q1_b_est) in
  let tib33_est := q0_b_est * q0_b_est + q3_b_est * q3_b_est - q1_b_est * q1_b_est - q2_b_est * q2_b_est in

  (* Evaluate Euler roll angle *)
  let stheta_b_est := limit (-tib13_est) ("-1.0"#D) ("1.0"#D) in
  let psi_b_est := atan2 tib12_est tib11_est in
  let theta_b_est := asin stheta_b_est in
  let phi_b_est := atan2 tib23_est tib33_est in

  (* Quaternion constraint equation *)
  let qmag_est := sqrt (q0_b_est * q0_b_est + q1_b_est * q1_b_est + q2_b_est * q2_b_est + q3_b_est * q3_b_est) in
  let q0_b_est := q0_b_est / qmag_est in
  let q1_b_est := q1_b_est / qmag_est in
  let q2_b_est := q2_b_est / qmag_est in
  let q3_b_est := q3_b_est / qmag_est in

  (* Quaternion derivative *)
  let q0d_b_est := "-0.5"#D * (q1_b_est * p_g_meas + q2_b_est * q_g_meas + q3_b_est * r_g_meas) in
  let q1d_b_est := "0.5"#D * (q0_b_est * p_g_meas + q2_b_est * r_g_meas - q3_b_est * q_g_meas) in
  let q2d_b_est := "0.5"#D * (q0_b_est * q_g_meas + q3_b_est * p_g_meas - q1_b_est * r_g_meas) in
  let q3d_b_est := "0.5"#D * (q0_b_est * r_g_meas + q1_b_est * q_g_meas - q2_b_est * p_g_meas) in

  (* Maintain zero roll angle *)
  let p_b_cmd := roll_guidance_gain * phi_b_est in

  (* Compute yaw & pitch rate command via proportional navigation *)
  let q_b_cmd := pitch_guidance_gain * q_si_b_meas + q_b_cmd_bias * cos(theta_b_est) in
  let r_b_cmd := yaw_guidance_gain * r_si_b_meas in

  (* Autopilot *)
  let del_p_cmd := del_cmd_per_p_cmd * p_b_cmd in
  let del_q_cmd := del_cmd_per_q_cmd * q_b_cmd in
  let del_r_cmd := del_cmd_per_r_cmd * r_b_cmd in

  (* Fin mixing *)
  let fin_1_cmd := -del_q_cmd - del_p_cmd in
  let fin_2_cmd := -del_r_cmd - del_p_cmd in
  let fin_3_cmd := del_q_cmd - del_p_cmd in
  let fin_4_cmd := del_r_cmd - del_p_cmd in

 union_vars sim
             [
               (SvPSI_B_EST, psi_b_est);
               (SvTHETA_B_EST, theta_b_est);
               (SvPHI_B_EST, phi_b_est);
               (SvQ0D_B_EST, q0d_b_est);
               (SvQ1D_B_EST, q1d_b_est);
               (SvQ2D_B_EST, q2d_b_est);
               (SvQ3D_B_EST, q3d_b_est);
               (SvP_B_CMD, p_b_cmd);
               (SvQ_B_CMD, q_b_cmd);
               (SvR_B_CMD, r_b_cmd);
               (SvQ0_B_EST, q0_b_est);
               (SvQ1_B_EST, q1_b_est);
               (SvQ2_B_EST, q2_b_est);
               (SvQ3_B_EST, q3_b_est);
               (SvFIN_1_CMD, fin_1_cmd);
               (SvFIN_2_CMD, fin_2_cmd);
               (SvFIN_3_CMD, fin_3_cmd);
               (SvFIN_4_CMD, fin_4_cmd)
             ].

Definition differential_equations (sim0: simTy) : simTy :=
  let sim1 := actuator sim0 in
  let sim2 := aero sim1 in
  let sim3 := mass sim2 in
  let sim4 := kinematics sim3 in
  let sim5 := target sim4 in
  let sim6 := seeker sim5 in
  let sim7 := gyro sim6 in
  let sim8 := flight_computer sim7 in
  sim8.


(* Fix and Cofix were missing in tactic unification *)

Goal exists e, (fix foo (n : nat) : nat := match n with O => e | S n' => foo n' end)
               = (fix foo (n : nat) : nat := match n with O => O | S n' => foo n' end).
Proof.
  eexists.
  reflexivity.
Qed.

CoInductive stream := cons : nat -> stream -> stream.

Goal exists e, (cofix foo := cons e foo) = (cofix foo := cons 0 foo).
Proof.
  eexists.
  reflexivity.
Qed.


(****************************************************************************)
(*                                                                          *)
(*                                   Menhir                                 *)
(*                                                                          *)
(*           Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud         *)
(*                                                                          *)
(*  Copyright Inria. All rights reserved. This file is distributed under    *)
(*  the terms of the GNU Lesser General Public License as published by the  *)
(*  Free Software Foundation, either version 3 of the License, or (at your  *)
(*  option) any later version, as described in the file LICENSE.            *)
(*                                                                          *)
(****************************************************************************)

From Coq Require Import List.
From Coq.ssr Require Import ssreflect.
Require Import Alphabet.

Class IsValidator (P : Prop) (b : bool) :=
  is_validator : b = true -> P.
Global Hint Mode IsValidator + - : typeclass_instances.

Global Instance is_validator_true : IsValidator True true.
Proof. done. Qed.

Global Instance is_validator_false : IsValidator False false.
Proof. done. Qed.

Global Instance is_validator_eq_true b :
  IsValidator (b = true) b.
Proof. done. Qed.

Global Instance is_validator_and P1 b1 P2 b2 `{IsValidator P1 b1} `{IsValidator P2 b2}:
  IsValidator (P1 /\ P2) (if b1 then b2 else false).
Proof. by split; destruct b1, b2; apply is_validator. Qed.

Global Instance is_validator_comparable_leibniz_eq A (C:Comparable A) (x y : A) :
  ComparableLeibnizEq C ->
  IsValidator (x = y) (compare_eqb x y).
Proof. intros ??. by apply compare_eqb_iff. Qed.

Global Instance is_validator_comparable_eq_impl A `(Comparable A) (x y : A) P b :
  IsValidator P b ->
  IsValidator (x = y -> P) (if compare_eqb x y then b else true).
Proof.
  intros Hval Val ->. rewrite /compare_eqb compare_refl in Val. auto.
Qed.

Lemma is_validator_forall_finite A P b `(Finite A) :
  (forall (x : A), IsValidator (P x) (b x)) ->
  IsValidator (forall (x : A), P x) (forallb b all_list).
Proof.
  move=> ? /forallb_forall Hb ?.
  apply is_validator, Hb, all_list_forall.
Qed.

(* We do not use an instance directly here, because we need somehow to
   force Coq to instantiate b with a lambda. *)
Global Hint Extern 2 (IsValidator (forall x : ?A, _) _) =>
    eapply (is_validator_forall_finite _ _ (fun (x:A) => _))
  : typeclass_instances.

(* Hint for synthetizing pattern-matching. *)
Global Hint Extern 2 (IsValidator (match ?u with _ => _ end) ?b0) =>
    let b := fresh "b" in
    unshelve notypeclasses refine (let b : bool := _ in _);
      [destruct u; intros; shelve|];    (* Synthetize `match .. with` in the validator. *)
    unify b b0;
    unfold b; destruct u; clear b
  : typeclass_instances.

(* Hint for unfolding definitions. This is necessary because many
  hints for IsValidator use [Hint Extern], which do not automatically
  unfold identifiers. *)
Global Hint Extern 100 (IsValidator ?X _) => unfold X
  : typeclass_instances.


Require Export List Undecidability.Shared.Dec Undecidability.Shared.FilterFacts.
Export ListNotations.

Module ListAutomationNotations.

  Notation "x 'el' L" := (In x L) (at level 70).
  Notation "A '<<=' B" := (incl A B) (at level 70).

  Notation "( A × B × .. × C )" := (list_prod .. (list_prod A B) .. C) (at level 0, left associativity).

  Notation "[ s | p ∈ A ',' P ]" :=
    (map (fun p => s) (filter (fun p => Dec P) A)) (p pattern).
  Notation "[ s | p ∈ A ]" :=
    (map (fun p => s) A) (p pattern).

End ListAutomationNotations.
Import ListAutomationNotations.

Instance list_in_dec X (x : X) (A : list X) :
  eq_dec X -> dec (x el A).
Proof.
  intros D. apply in_dec. exact D.
Qed.

Lemma in_concat_iff A l (a:A) : a el concat l <-> exists l', a el l' /\ l' el l.
Proof.
  induction l; cbn.
  - intuition. now destruct H.
  - rewrite in_app_iff, IHl. clear. firstorder subst. auto.
Qed.

Ltac in_app n :=
  (match goal with
  | [ |- In _ (_ ++ _) ] =>
    match n with
    | 0 => idtac
    | 1 => eapply in_app_iff; left
    | S ?n => eapply in_app_iff; right; in_app n
    end
  | [ |- In _ (_ :: _) ] => match n with 0 => idtac | 1 => left | S ?n => right; in_app n end
  end) || (repeat (try right; eapply in_app_iff; right)).

Lemma to_dec (P : Prop) `{dec P} : P <-> is_true (Dec P).
Proof.
  split; destruct (Dec P); cbn in *; firstorder congruence.
Qed.

Ltac in_collect a :=
  eapply in_map_iff; exists a; split; [ eauto | match goal with [ |- In _ (filter _ _) ] =>  eapply in_filter_iff; split; [ try (rewrite !in_prod_iff; repeat split) | eapply Dec_auto; repeat split; eauto ] | _ => try (rewrite !in_prod_iff; repeat split) end ].
Ltac inv_collect :=
  repeat
    (match goal with
    | [ H : ?x el concat _ |- _ ] => eapply in_concat_iff in H as (? & ? & ?)
    | [ H : ?x el map _ _ |- _ ] => let x := fresh "x" in eapply in_map_iff in H as (x & ? & ?)
    | [ x : ?A * ?B |- _ ] => destruct x; subst
    | [ H : ?x el filter _ _ |- _ ] => let H' := fresh "H" in eapply in_filter_iff in H as (? & H' % to_dec)
    | [ H : ?x el list_prod _ _ |- _ ] => eapply in_prod_iff in H
    | [ H : _ el _ ++ _ |- _ ] => try eapply in_app_iff in H as []
    | [H : _ el _ :: _ |- _ ] => destruct H
     end; intuition; subst).

Require Import Lia Arith.
Local Set Implicit Arguments.
Local Unset Strict Implicit.

Hint Extern 4 =>
match goal with
|[ H: ?x el nil |- _ ] => destruct H
end : core.

Hint Extern 4 =>
match goal with
|[ H: False |- _ ] => destruct H
|[ H: true=false |- _ ] => discriminate H
|[ H: false=true |- _ ] => discriminate H
end : core.
Lemma incl_nil X (A : list X) :
  nil <<= A.
Proof. intros x []. Qed.

Hint Rewrite <- app_assoc : list.
Hint Rewrite rev_app_distr map_app prod_length : list.
Hint Resolve in_eq in_nil in_cons in_or_app : core.
Hint Resolve incl_refl incl_tl incl_cons incl_appl incl_appr incl_app incl_nil : core.

Lemma app_incl_l X (A B C : list X) :
A ++ B <<= C -> A <<= C.
Proof.
firstorder eauto.
Qed.

Lemma app_incl_R X (A B C : list X) :
A ++ B <<= C -> B <<= C.
Proof.
firstorder eauto.
Qed.

Lemma cons_incl X (a : X) (A B : list X) : a :: A <<= B -> A <<= B.
Proof.
intros ? ? ?. eapply H. firstorder.
Qed.

Lemma incl_sing X (a : X) A : a el A -> [a] <<= A.
Proof.
now intros ? ? [-> | [] ].
Qed.

Hint Resolve app_incl_l app_incl_R cons_incl incl_sing : core.

Hint Extern 4 (_ el map _ _) => eapply in_map_iff : core.
Hint Extern 4 (_ el filter _ _) => eapply filter_In : core.

Section Inclusion.
  Variable X : Type.
  Implicit Types A B : list X.

  Lemma incl_nil_eq A :
    A <<= nil -> A=nil.

  Proof.
    intros D. destruct A as [|x A].
    - reflexivity.
    - exfalso. apply (D x). auto.
  Qed.

  Lemma incl_shift x A B :
    A <<= B -> x::A <<= x::B.

  Proof. auto. Qed.

  Lemma incl_lcons x A B :
    x::A <<= B <-> x el B /\ A <<= B.
  Proof.
    split.
    - intros D. split; hnf; auto.
    - intros [D E] z [F|F]; subst; auto.
  Qed.

  Lemma incl_rcons x A B :
    A <<= x::B -> ~ x el A -> A <<= B.

  Proof. intros C D y E. destruct (C y E) as [F|F]; congruence. Qed.

  Lemma incl_lrcons x A B :
    x::A <<= x::B -> ~ x el A -> A <<= B.

  Proof.
    intros C D y E.
    assert (F: y el x::B) by auto.
    destruct F as [F|F]; congruence.
  Qed.

  Lemma incl_app_left A B C :
    A ++ B <<= C -> A <<= C /\ B <<= C.
  Proof.
    firstorder.
  Qed.

End Inclusion.

Require Import Setoid Morphisms.

Instance incl_preorder X :
  PreOrder (@incl X).
Proof.
  constructor; hnf; unfold incl; auto.
Qed.

Definition equi X (A B : list X) : Prop := incl A B /\ incl B A.
Local Notation "A === B" := (equi A B) (at level 70).
Hint Unfold equi : core.

Instance equi_Equivalence X :
  Equivalence (@equi X).
Proof.
  constructor; hnf; firstorder.
Qed.

Instance incl_equi_proper X :
  Proper (@equi X ==> @equi X ==> iff) (@incl X).
Proof.
  hnf. intros A B D. hnf. firstorder.
Qed.

Instance cons_incl_proper X x :
  Proper (@incl X ==> @incl X) (@cons X x).
Proof.
  hnf. apply incl_shift.
Qed.

Instance cons_equi_proper X x :
  Proper (@equi X ==> @equi X) (@cons X x).
Proof.
  hnf. firstorder.
Qed.

Instance in_incl_proper X x :
  Proper (@incl X ==> Basics.impl) (@In X x).
Proof.
  intros A B D. hnf. auto.
Qed.

Instance in_equi_proper X x :
  Proper (@equi X ==> iff) (@In X x).
Proof.
  intros A B D. firstorder.
Qed.

Instance app_incl_proper X :
  Proper (@incl X ==> @incl X ==> @incl X) (@app X).
Proof.
  intros A B D A' B' E. auto.
Qed.

Instance app_equi_proper X :
  Proper (@equi X ==> @equi X ==> @equi X) (@app X).
Proof.
  hnf. intros A B D. hnf. intros A' B' E.
  destruct D, E; auto.
Qed.


(** * Grothendick toposes *)
(** ** Contents
- Definition of Grothendieck topology
 - Grothendieck topologies
 - Precategory of sheaves
- Grothendieck toposes
*)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import UniMath.CategoryTheory.limits.equalizers.
Require Import UniMath.CategoryTheory.limits.products.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Local Open Scope cat.
Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import UniMath.CategoryTheory.slicecat.
Require Import UniMath.CategoryTheory.Monics.
Require Import UniMath.CategoryTheory.Subobjects.
Require Import UniMath.CategoryTheory.yoneda.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Limits.
Require Import UniMath.CategoryTheory.limits.graphs.pullbacks.
Require Import UniMath.CategoryTheory.limits.graphs.equalizers.
Require Import UniMath.CategoryTheory.Subcategory.Core.
Require Import UniMath.CategoryTheory.Subcategory.Full.
Require Import UniMath.CategoryTheory.Equivalences.Core.

(** * Definiton of Grothendieck topology
    The following definition is a formalization of the definition in Sheaves in Geometry and Logic,
    Saunders Mac Lane and Ieke Moerdijk, pages 109 and 110.

    Grothendieck topology is a collection J(c) of subobjects of the Yoneda functor, for every object
    of C, such that:
    - The Yoneda functor y(c) is in J(c).
    - Pullback of a subobject in J(c) along any morphism h : c' --> c is in J(c')
    - If S is a subobject of y(c) such that for all objects c' and all morphisms
      h : c' --> c in C the pullback of S along h is in J(c'), then S is in J(c).
  *)
Section def_grothendiecktopology.

  Variable C : category.

  (** A sieve on c is a subobject of the yoneda functor. *)
  Definition sieve (c : C) : UU :=
    Subobjectscategory (yoneda C c).

  (* Coq does not automatically convert the following types *)
  Definition FunctorPrecatObToFunctor (c : [C^op, HSET])
    : functor (op_cat C) HSET
    := c.

  Definition FunctorPrecatMorToNatTrans
             {c c': functor_precategory (opp_precat C) HSET has_homsets_HSET} (h : c --> c') :
    nat_trans (FunctorPrecatObToFunctor c) (FunctorPrecatObToFunctor c') := h.

  Definition sieve_functor {c : C} (S : sieve c) : functor (opp_precat C) HSET :=
    precategory_object_from_sub_precategory_object _ _ (slicecat_ob_object _ _ S).

  Definition sieve_nat_trans {c : C} (S : sieve c) :
    nat_trans (sieve_functor S) (FunctorPrecatObToFunctor (yoneda C c)) :=
    precategory_morphism_from_sub_precategory_morphism _ _ _ _ (slicecat_ob_morphism _ _ S).

  (** ** Grothendieck topology *)

  Definition collection_of_sieves : UU := ∏ (c : C), hsubtype (sieve c).

  Definition isGrothendieckTopology_maximal_sieve (COS : collection_of_sieves) : UU :=
    ∏ (c : C), COS c (Subobjectscategory_ob
                        (identity (yoneda C c)) (identity_isMonic _)).

  Definition isGrothendieckTopology_stability (COS : collection_of_sieves) : UU :=
    ∏ (c c' : C) (h : c' --> c) (s : sieve c),
    COS c s ->
    COS c' (PullbackSubobject
              (FunctorcategoryPullbacks C^op HSET HSET_Pullbacks)
              s (yoneda_morphisms C  _ _ h)).

  Definition isGrothendieckTopology_transitivity (COS : collection_of_sieves) : UU :=
    ∏ (c : C) (s : sieve c),
    (∏ (c' : C) (h : c' --> c),
     COS c' (PullbackSubobject
               (FunctorcategoryPullbacks C^op HSET HSET_Pullbacks)
               s (yoneda_morphisms C  _ _ h))
     -> COS c s).

  Definition isGrothendieckTopology (COS : collection_of_sieves) : UU :=
    (isGrothendieckTopology_maximal_sieve COS)
      × (isGrothendieckTopology_stability COS)
      × (isGrothendieckTopology_transitivity COS).

  Definition GrothendieckTopology : UU :=
    ∑ COS : collection_of_sieves, isGrothendieckTopology COS.

  (** Accessor functions *)
  Definition GrothendieckTopology_COS (GT : GrothendieckTopology) : collection_of_sieves := pr1 GT.

  Definition GrothendieckTopology_isGrothendieckTopology (GT : GrothendieckTopology) :
    isGrothendieckTopology (GrothendieckTopology_COS GT) := pr2 GT.

  (** ** Sheaves *)

  (** For some reason I need the following *)
  Definition Presheaf : UU := functor (opp_precat C) HSET.

  Definition PresheafToFunctor (P : Presheaf) : functor (opp_precat C) HSET := P.

  Definition make_Presheaf (F : functor (opp_precat C) HSET) : Presheaf := F.

  (** This is a formalization of the definition on page 122 *)
  Definition isSheaf (P : Presheaf) (GT : GrothendieckTopology) : UU :=
    ∏ (c : C) (S : sieve c) (isCOS : GrothendieckTopology_COS GT c S)
      (τ : nat_trans (sieve_functor S) (PresheafToFunctor P)),
    iscontr (∑ η : nat_trans (FunctorPrecatObToFunctor (yoneda C c)) (PresheafToFunctor P),
                   nat_trans_comp _ _ _ (sieve_nat_trans S) η = τ).

  Lemma isaprop_isSheaf (GT : GrothendieckTopology) (P : Presheaf) : isaprop(isSheaf P GT).
  Proof.
    apply impred_isaprop; intros t.
    apply impred_isaprop; intros S.
    apply impred_isaprop; intros isCOS.
    apply impred_isaprop; intros τ.
    apply isapropiscontr.
  Qed.

  (** The category of sheaves is the full subcategory of presheaves consisting of the presheaves
      which satisfy the isSheaf proposition. *)
  Definition hsubtype_obs_isSheaf (GT : GrothendieckTopology) :
    hsubtype (functor_category C^op HSET) :=
    (λ P : functor_precategory (opp_precat C) HSET has_homsets_HSET,
       make_hProp _ (isaprop_isSheaf GT (make_Presheaf P))).

  Definition categoryOfSheaves (GT : GrothendieckTopology) :
    sub_precategories (functor_category C^op HSET) :=
    full_sub_precategory (hsubtype_obs_isSheaf GT).

End def_grothendiecktopology.

(** * Definition of Grothendieck topos
    Grothendieck topos is a precategory which is equivalent to the category of sheaves on some
    Grothendieck topology. *)
Section def_grothendiecktopos.

  Variable C : category.

  (** Here (pr1 D) is the precategory which is equivalent to the precategory of sheaves on the
      Grothendieck topology (pr2 D). *)
  Definition GrothendieckTopos : UU :=
    ∑ D' : (∑ D : category × (GrothendieckTopology C),
                  functor (pr1 D) (categoryOfSheaves C (pr2 D))),
           (adj_equivalence_of_cats (pr2 D')).

  (** Accessor functions *)
  Definition GrothendieckTopos_category (GT : GrothendieckTopos) : category :=
    pr1 (pr1 (pr1 GT)).
  Coercion GrothendieckTopos_category : GrothendieckTopos >-> category.

  Definition GrothendieckTopos_GrothendieckTopology (GT : GrothendieckTopos) :
    GrothendieckTopology C := pr2 (pr1 (pr1 GT)).

  Definition GrothendieckTopos_functor (GT : GrothendieckTopos) :
    functor (GrothendieckTopos_category GT)
            (categoryOfSheaves C (GrothendieckTopos_GrothendieckTopology GT)) :=
    pr2 (pr1 GT).

  Definition GrothendieckTopos_equivalence (GT : GrothendieckTopos) :
    adj_equivalence_of_cats (GrothendieckTopos_functor GT) := pr2 GT.

End def_grothendiecktopos.


Require Import Prelude.
Require Import Control.Applicative.Successors.
Require Import Proofs.GHC.Base.

Ltac unfold__Succs_Instances :=
  repeat
  unfold Successors.Functor__Succs,
         Successors.Applicative__Succs,
         Successors.Monad__Succs,
         Successors.Functor__Succs_fmap,
         Successors.Applicative__Succs_pure,
         Successors.Applicative__Succs_op_zlztzg__,
         Successors.Monad__Succs_op_zgzgze__,
         Successors.Monad__Succs_return_.

(* A tactic to rewrite with the list functor *)
Ltac rewrite_Functor__list :=
  let K := fresh in
  let L := fresh in
  pose (K := @functor_identity list Functor__list instance_FunctorLaws_list); clearbody K;
  pose (L := @functor_composition list Functor__list instance_FunctorLaws_list); clearbody L;
  try rewrite K; try rewrite L;
  unfold fmap, Functor__list, Base.Functor__list_fmap in K, L;
  try rewrite K; try rewrite L;
  clear K; clear L.

Lemma functor_law_1:
  forall a (x : Succs a),
  fmap id x = x.
Proof.
  intros.
  destruct x.
  unfold fmap, fmap__, Functor__Succs. simpl.
  rewrite_Functor__list.
  auto.
Qed.

Lemma functor_law_2:
  forall a b c (f : a -> b) (g : b -> c) (x : Succs a),
  fmap g (fmap f x) = fmap (g ∘ f) x.
Proof.
  intros.
  destruct x.
  unfold fmap, fmap__, Functor__Succs. simpl.
  rewrite_Functor__list.
  auto.
Qed.

Instance FunctorLaws__Succs : FunctorLaws Succs :=
  { functor_identity := functor_law_1;
    functor_composition := functor_law_2}
.

Lemma applicative_law_1:
  forall a (x : Succs a),
  (pure id <*> x) = x.
Proof.
  intros.
  destruct x.
  unfold op_zlztzg__, op_zlztzg____, pure, pure__,
         Applicative__Succs. simpl.
  rewrite_Functor__list.
  auto.
Qed.

Lemma applicative_law_2:
  forall a b c
    (x : Succs (b -> c))
    (y : Succs (a -> b))
    (z : Succs a),
  (pure (_∘_) <*> x <*> y <*> z) = (x <*> (y <*> z)).
Proof.
  intros.
  destruct x, z, y.
  simpl.
  unfold op_z2218U__.
  unfold op_zlztzg__, op_zlztzg____, pure, pure__,
         Applicative__Succs. simpl.
  f_equal.
  repeat (rewrite map_append || rewrite_Functor__list || rewrite app_assoc).
  reflexivity.
Qed.

Lemma applicative_law_3:
  forall a b (f : a -> b) (x : a),
  (pure f <*> pure x) = @pure Succs _ _ _ (f x).
Proof.
  intros.
  reflexivity.
Qed.

Lemma applicative_law_4:
  forall a b (f : Succs (a -> b)) (x : a),
  (f <*> pure x) = (pure (fun y => y x) <*> f).
Proof.
  intros.
  destruct f.
  unfold op_zlztzg__, op_zlztzg____, pure, pure__,
         Applicative__Succs. simpl.
  simpl.
  rewrite app_nil_r.
  reflexivity.
Qed.

Lemma applicative_law_5:
  forall (a b : Type) (f : a -> b) (x : Succs a), fmap f x = _<*>_ (pure f) x.
Proof.
  intros.
  reflexivity.
Qed.

Instance ApplicativeLaws__Succs : ApplicativeLaws Succs.
split.
exact applicative_law_1.
exact applicative_law_2.
exact applicative_law_3.
exact applicative_law_4.
reflexivity.
exact applicative_law_5.
Qed.

Lemma monad_law_1:
  forall a b (x : a) (k : a -> Succs b),
  ((return_ x >>= k) = k x).
Proof.
  intros.
  unfold op_zgzgze__, op_zgzgze____, return_, return___,
         Monad__Succs. simpl.
  simpl.
  destruct (k x).
  auto.
Qed.

Lemma monad_law_2:
  forall a (x : Succs a),
  (x >>= return_) = x.
Proof.
  intros.
  destruct x.
  unfold op_zgzgze__, op_zgzgze____, return_, return___,
         Monad__Succs. simpl.
  simpl.
  rewrite map_id.
  rewrite app_nil_r.
  reflexivity.
Qed.

Lemma monad_law_3:
  forall a b c (m : Succs a) (k : a -> Succs b) (h : b -> Succs c),
  (m >>= (fun x => k x >>= h)) = ((m >>= k) >>= h).
Proof.
  intros.
  destruct m.
  unfold op_zgzgze__, op_zgzgze____, return_, return___,
         Monad__Succs. simpl.
  unfold__Succs_Instances.
  unfold getCurrent, op_z2218U__, compose.
  destruct (k a0).
  destruct (h b0).
  f_equal.
  repeat (rewrite_Functor__list || rewrite map_append || rewrite <- app_assoc ||
    unfold getCurrent, op_z2218U__).
  f_equal.
  apply map_cong; intro.
  destruct (k x).
  destruct (h b1).
  reflexivity.
Qed.

Lemma monad_law_5 :
  forall (A B : Type) (f : Succs (A -> B)) (x : Succs A), _<*>_ f x = ap f x.
Proof.
  intros.
  destruct f. destruct x.
  unfold ap, op_zgzgze__, op_zgzgze____, return_, return___,
         op_zlztzg__, op_zlztzg____,
         Monad__Succs, Applicative__Succs. simpl.
  f_equal.
  unfold compose.
  rewrite app_nil_r.
  f_equal.
Qed.

Instance MonadLaws__Succs : MonadLaws Succs.
split.
exact monad_law_1.
exact monad_law_2.
exact monad_law_3.
reflexivity.
reflexivity.
exact monad_law_5.
Qed.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Require Import Classical.

Coq < Section Exercise_12.

Coq < Goal forall u r n p h q:Prop, (~(u \/ r) /\ ((~r \/ n) -> (p /\ h)) /\ (q -> ~h)) -> (~q).
1 subgoal

  ============================
   forall u r n p h q : Prop,
   ~ (u \/ r) /\ (~ r \/ n -> p /\ h) /\ (q -> ~ h) -> ~ q

Unnamed_thm < intros.
1 subgoal

  u : Prop
  r : Prop
  n : Prop
  p : Prop
  h : Prop
  q : Prop
  H : ~ (u \/ r) /\ (~ r \/ n -> p /\ h) /\ (q -> ~ h)
  ============================
   ~ q

Unnamed_thm < elim H.
1 subgoal

  u : Prop
  r : Prop
  n : Prop
  p : Prop
  h : Prop
  q : Prop
  H : ~ (u \/ r) /\ (~ r \/ n -> p /\ h) /\ (q -> ~ h)
  ============================
   ~ (u \/ r) -> (~ r \/ n -> p /\ h) /\ (q -> ~ h) -> ~ q

Unnamed_thm < intro.
1 subgoal

  u : Prop
  r : Prop
  n : Prop
  p : Prop
  h : Prop
  q : Prop
  H : ~ (u \/ r) /\ (~ r \/ n -> p /\ h) /\ (q -> ~ h)
  H0 : ~ (u \/ r)
  ============================
   (~ r \/ n -> p /\ h) /\ (q -> ~ h) -> ~ q

Unnamed_thm < intro.
1 subgoal

  u : Prop
  r : Prop
  n : Prop
  p : Prop
  h : Prop
  q : Prop
  H : ~ (u \/ r) /\ (~ r \/ n -> p /\ h) /\ (q -> ~ h)
  H0 : ~ (u \/ r)
  H1 : (~ r \/ n -> p /\ h) /\ (q -> ~ h)
  ============================
   ~ q

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
firstorder .

Unnamed_thm is defined

Coq <

*)

Require Import Classical.
Section Exercise_12.
Goal forall u r n p h q:Prop, (~(u \/ r) /\ ((~r \/ n) -> (p /\ h)) /\ (q -> ~h)) -> (~q).
intros.
elim H.
intro.
intro.
 firstorder .
 Qed.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

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

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export sequents_tacs.
Require Export sequents_useful.
Require Export per_props_equality.
Require Export sequents_equality.
Require Export list. (* why *)
(** printing |- $\vdash$ *)
(** printing ->  $\rightarrow$ *)
(* begin hide *)

(* end hide *)

(**

  We now prove the truth of several rules about the intensional PER type.

*)

(* [14] ============ IPERTYPE MEMBER EQUALITY ============ *)

(**

  The following rule is called the ``ipertype member equality'' rule.
  It allows one to prove that terms are well-formed partial
  equivalence relations, i.e., members of a ``ipertype'' type.
<<
   H |- t1 = t2 in ipertype(R)

     By ipertypeMemberEquality i

     H |- ipertype(R) in Type(i)
     H |- R t1 t2
     H |- t1 in Base
>>
 *)

Definition rule_ipertype_member_equality {o}
           (t1 t2 R e : NTerm)
           (i : nat)
           (H : @barehypotheses o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality t1 t2 (mk_ipertype R))))
    [ mk_baresequent H (mk_conclax (mk_member (mk_ipertype R) (mk_uni i))),
      mk_baresequent H (mk_concl (mk_apply2 R t1 t2) e),
      mk_baresequent H (mk_conclax (mk_member t1 mk_base))
    ]
    [].

Lemma rule_ipertype_member_equality_true {o} :
  forall lib (t1 t2 R e : NTerm),
  forall i : nat,
  forall H : @barehypotheses o,
    rule_true lib (rule_ipertype_member_equality
                 t1 t2 R e
                 i
                 H).
Proof.
  unfold rule_ipertype_member_equality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  rename Hyp2 into hyp3.
  destseq; allsimpl; proof_irr; GC.

  exists (@covered_axiom o (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  (* xxx *)
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  lift_lsubst.
  rw @member_eq.
  rw <- @member_equality_iff.

  vr_seq_true in hyp1.
  generalize (hyp1 s1 s2); intro h.
  repeat (autodimp h hyp); exrepnd.
  lsubst_tac.
  allrw @member_eq.
  allrw <- @member_member_iff.
  allapply @member_in_uni.
  apply tequality_in_uni_implies_tequality in h0; auto.

  generalize (teq_and_eq_if_equality
                lib (mk_ipertype R) t1 t2 s1 s2 H wT w1 w2 c1 c3 c2 c4 cT cT0
                eqh sim); intro k; lsubst_tac; apply k; clear k; auto.

  clear dependent s1.
  clear dependent s2.
  introv hf sim.
  lsubst_tac.

  generalize (hyp1 s1 s2 hf sim); clear hyp1; intro hyp1; exrepnd.

  vr_seq_true in hyp2.
  generalize (hyp2 s1 s2 hf sim); clear hyp2; intro hyp2; exrepnd.

  vr_seq_true in hyp3.
  generalize (hyp3 s1 s2 hf sim); clear hyp3; intro hyp3; exrepnd.

  lsubst_tac.
  allrw @member_eq.
  allrw <- @member_member_iff.
  allrw @tequality_mkc_member_base.
  allapply @member_in_uni.
  apply tequality_in_uni_implies_tequality in hyp0; auto.
  allapply @inhabited_type_if_equality.
  rw @tequality_mkc_ipertype in hyp0; repnd.
  spcast.

  rw @equality_in_mkc_ipertype2; dands; auto.
  apply @inhabited_type_tequality with (a := mkc_apply2 (lsubstc R w0 s1 c1)
                                                       (lsubstc t1 w1 s1 ca1)
                                                       (lsubstc t2 w2 s1 c3)); auto.
  apply @tequality_trans with (t2 := mkc_apply2 (lsubstc R w0 s2 c0)
                                               (lsubstc t1 w1 s2 ct2)
                                               (lsubstc t2 w2 s2 cb2)); auto.
  apply @tequality_sym.
  apply @tequality_respects_cequivc_left with (T1 := mkc_apply2 (lsubstc R w0 s1 c1)
                                                                (lsubstc t1 w1 s2 ct2)
                                                                (lsubstc t2 w2 s2 cb2)); auto.
  apply implies_cequivc_apply2; sp.
  apply cequivc_sym; auto.
Qed.

(* begin hide *)

(* end hide *)

(* [15] ============ IPERTYPE ELIMINATION ============ *)

(**

  We can state the ipertype elimination rule as follows:
<<
   H, x : t1 = t2 in ipertype(R), J |- C ext e

     By ipertypeElimination i z

     H, x : t1 = t2 in ipertype(R), [z : R t1 t2], J |- C ext e
     H |- R t1 t2 in Type(i)
>>
 *)

Definition rule_ipertype_elimination {o}
           (R t1 t2 C e : NTerm)
           (x z : NVar)
           (i : nat)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hyp x (mk_equality t1 t2 (mk_ipertype R))) ++ J)
       (mk_concl C e))
    [ mk_baresequent
        (snoc (snoc H (mk_hyp x (mk_equality t1 t2 (mk_ipertype R))))
              (mk_hhyp z (mk_apply2 R t1 t2))
              ++ J)
        (mk_concl C e),
      mk_baresequent
        H
        (mk_conclax (mk_member (mk_apply2 R t1 t2) (mk_uni i)))
    ]
    [sarg_var z].

Lemma rule_ipertype_elimination_true {o} :
  forall lib (R t1 t2 C e : NTerm),
  forall x z : NVar,
  forall i : nat,
  forall H J : @barehypotheses o,
    rule_true lib (rule_ipertype_elimination
                 R t1 t2 C e
                 x z
                 i
                 H J).
Proof.
  unfold rule_ipertype_elimination, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1; rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.

  assert (covered e
                  (nh_vars_hyps
                     (snoc H (mk_hyp x (mk_equality t1 t2 (mk_ipertype R))) ++ J))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # !LIn x (free_vars t1)
           # !LIn x (free_vars t2)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  clear hyp1.
  dwfseq.
  sp;
    try (complete (discover; repeat(first[progress(allrw in_app_iff)|progress(allrw in_snoc)]); sp));
    try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                   allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                   generalize (subvars_hs_vars_hyps H); intros;
                   generalize (subvars_hs_vars_hyps J); intros;
                   allrw subvars_prop; apply_in_hyp p; sp)).

  destruct vhyps as [ nixr vhyps ].
  destruct vhyps as [ nixt1 vhyps ].
  destruct vhyps as [ nixt2 vhyps ].
  destruct vhyps as [ nizc  vhyps ].
  destruct vhyps as [ nize  vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  rw @equality_in_mkc_equality in sim2; repnd.
  rw @equality_in_mkc_ipertype in sim0; repnd.

  vr_seq_true in hyp1.
  unfold inhabited_type in sim7; exrepnd.
  generalize (hyp1 ((snoc (snoc s1a0 (x, t0)) (z, t)) ++ s1b)
                   ((snoc (snoc s2a0 (x, t3)) (z, t)) ++ s2b));
    clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd.

  (* hyps_functionality *)
  introv sim.
  rw @similarity_app in sim; simpl in sim; exrepnd; subst; cpx.
  apply app_split in sim7; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  rw @similarity_snoc in sim14; simpl in sim14; exrepnd; subst; cpx.
  lsubst_tac.
  generalize (eqh (s2a1 ++ s2b0)); intro j.
  autodimp j hyp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t0)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.
  rewrite substitute_hyps_snoc_sub_weak in sim10; sp.

  rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
  apply app_split in j0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  apply app_split in j2; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).

  duplicate j5 as dup_eqhyps_snoc.
  rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
  lsubst_tac.

  rw @eq_hyps_app; simpl.
  exists (snoc (snoc s1a (x, t6)) (z, t4))
         s1b
         (snoc (snoc s2a1 (x, t7)) (z, t5))
         s2b1; repeat (rw length_snoc); dands; try (complete sp).

  assert (cover_vars (mk_apply2 R t1 t2) (snoc s2a1 (x, t7)))
         as cv
         by (apply cover_vars_apply2; sp;
             try (apply cover_vars_var);
             repeat (apply cover_vars_snoc_weak); sp;
             repeat (rw dom_csub_snoc); simpl; repeat (rw in_snoc); sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a (x, t6)) (snoc s2a1 (x, t7)) t4 t5 w3 p0 cv;
    dands; try (complete sp).

  lsubst_tac.

(*
rw @tequality_mkc_equality in j0; repnd.
rw @tequality_mkc_ipertype in j2; repnd.
destruct j5 as [j5 | j5].
rw @equality_in_mkc_ipertype in j5; repnd.
*)

  vr_seq_true in hyp2.
  generalize (hyp2 s1a s2a1); clear hyp2; intro hyp2.
  repeat (autodimp hyp2 hyp); exrepnd.
  generalize (hyps_functionality_init_seg_snoc
                lib s1a t6 t7 H (mk_hyp x (mk_equality t1 t2 (mk_ipertype R))) w4 p1);
    simpl; intro k.
  apply k; sp.

  apply hyps_functionality_init_seg with (s3 := s2b1) in eqh; sp.
  rw @substitute_hyps_snoc_sub_weak in sim10; sp.

  rw @similarity_snoc in sim15; simpl in sim15; exrepnd; cpx.
  lsubst_tac; sp.

  rw @similarity_snoc in sim15; simpl in sim15; exrepnd; cpx.
  lsubst_tac.
  rw @tequality_mkc_member in hyp0; repnd.
  repdors.
  apply equality_in_uni in hyp4; sp.
  spcast; apply type_respects_cequivc_right; sp.

  apply sub_eq_hyps_snoc_weak; sp.

  (* similarity *)
  rw @similarity_app; simpl.
  exists (snoc (snoc s1a0 (x, t0)) (z, t))
         s1b
         (snoc (snoc s2a0 (x, t3)) (z, t))
         s2b; repeat (rw length_snoc); sp.

  assert (wf_term (mk_apply2 R t1 t2))
         as wfap by (apply wf_apply2; sp).

  assert (cover_vars (mk_apply2 R t1 t2) (snoc s1a0 (x, t0)))
         as cvap
         by (apply cover_vars_snoc_weak;rw @cover_vars_apply2; sp).

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (x, t0)) (snoc s2a0 (x, t3)) t t wfap cvap; sp.

  lsubst_tac.
  rw @member_eq; sp.

  rewrite substitute_hyps_snoc_sub_weak; sp.
  (* similarity proved *)

  assert (lsubstc C wfct (snoc (snoc s1a0 (x, t0)) (z, t) ++ s1b) pC0
          = lsubstc C wfct (snoc s1a0 (x, t0) ++ s1b) pC1)
         as eq1
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc C wfct (snoc (snoc s2a0 (x, t3)) (z, t) ++ s2b) pC3
          = lsubstc C wfct (snoc s2a0 (x, t3) ++ s2b) pC2)
         as eq2
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s1a0 (x, t0)) (z, t) ++ s1b) pt0
          = lsubstc e wfce (snoc s1a0 (x, t0) ++ s1b) pt1)
         as eq3
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s2a0 (x, t3)) (z, t) ++ s2b) pt3
          = lsubstc e wfce (snoc s2a0 (x, t3) ++ s2b) pt2)
         as eq4
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  rw eq1 in hyp0.
  rw eq1 in hyp1.
  rw eq2 in hyp0.
  rw eq3 in hyp1.
  rw eq4 in hyp1.
  sp.
Qed.

(* begin hide *)

Lemma rule_ipertype_elimination_true_ex {o} :
  forall lib i z R t1 t2 C e x H J,
    rule_true_if lib (@rule_ipertype_elimination o
                 R t1 t2 C e
                 x z
                 i
                 H J).
Proof.
  intros.
  generalize (rule_ipertype_elimination_true lib R t1 t2 C e x z i H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* end hide *)

(**

  This is a variant of [rule_ipertype_elimination] but where the
  well-formedness goal is stated using a ``type'' sequent.  Also it
  allows one to use all the hypotheses:
<<
   H, x : t1 = t2 in ipertype(R), J |- C ext e

     By ipertypeElimination i z

     H, x : t1 = t2 in ipertype(R), [z : R t1 t2], J |- C ext e
     H, x : t1 = t2 in ipertype(R), J |- R t1 t2 is a type
>>
 *)

Definition rule_ipertype_elimination_t {o}
           (R t1 t2 C e : NTerm)
           (x z : NVar)
           (i : nat)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hyp x (mk_equality t1 t2 (mk_ipertype R))) ++ J)
       (mk_concl C e))
    [ mk_baresequent
        (snoc (snoc H (mk_hyp x (mk_equality t1 t2 (mk_ipertype R))))
              (mk_hhyp z (mk_apply2 R t1 t2))
              ++ J)
        (mk_concl C e),
      mk_baresequent
        (snoc H (mk_hyp x (mk_equality t1 t2 (mk_ipertype R))) ++ J)
        (mk_concl_t (mk_apply2 R t1 t2))
    ]
    [sarg_var z].

Lemma rule_ipertype_elimination_t_true {o} :
  forall lib (R t1 t2 C e : NTerm),
  forall x z : NVar,
  forall i : nat,
  forall H J : @barehypotheses o,
    rule_true lib (rule_ipertype_elimination_t
                 R t1 t2 C e
                 x z
                 i
                 H J).
Proof.
  unfold rule_ipertype_elimination_t, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.

  assert (covered e
                  (nh_vars_hyps
                     (snoc H (mk_hyp x (mk_equality t1 t2 (mk_ipertype R))) ++ J))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # !LIn x (free_vars t1)
           # !LIn x (free_vars t2)
           # disjoint (free_vars R) (vars_hyps J)
           # disjoint (free_vars t1) (vars_hyps J)
           # disjoint (free_vars t2) (vars_hyps J)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
    try (complete (allunfold @disjoint; introv p; discover; allrw in_app_iff; allrw in_snoc; sp));
    try (complete (discover; repeat (first [ progress (allrw in_app_iff) | progress (allrw in_snoc) ]); sp));
    try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                   allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                   generalize (subvars_hs_vars_hyps H); intros;
                   generalize (subvars_hs_vars_hyps J); intros;
                   allrw subvars_prop; apply_in_hyp p; sp));
    try (complete (unfold disjoint; unfold disjoint in wfh13; introv k l; discover;
                   repeat (first [ progress (allrw in_app_iff) | progress (allrw in_snoc) ]); sp)).

  destruct vhyps as [ nixr vhyps ].
  destruct vhyps as [ nixt1 vhyps ].
  destruct vhyps as [ nixt2 vhyps ].
  destruct vhyps as [ nizc  vhyps ].
  destruct vhyps as [ nize  vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  rw @equality_in_mkc_equality in sim2; repnd.
  rw @equality_in_mkc_ipertype in sim0; repnd.

  vr_seq_true in hyp1.
  unfold inhabited_type in sim7; exrepnd.
  generalize (hyp1 ((snoc (snoc s1a0 (x, t0)) (z, t)) ++ s1b)
                   ((snoc (snoc s2a0 (x, t3)) (z, t)) ++ s2b));
    clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd.

  (* hyps_functionality *)
  introv sim.
  rw @similarity_app in sim; simpl in sim; exrepnd; subst; cpx.
  apply app_split in sim7; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  rw @similarity_snoc in sim14; simpl in sim14; exrepnd; subst; cpx.
  lsubst_tac.
  generalize (eqh (s2a1 ++ s2b0)); intro j.
  autodimp j hyp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t0)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.
  rewrite substitute_hyps_snoc_sub_weak in sim10; sp.

  rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
  apply app_split in j0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  apply app_split in j2; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).

  duplicate j5 as dup_eqhyps_snoc.
  rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
  lsubst_tac.

  rw @eq_hyps_app; simpl.
  exists (snoc (snoc s1a (x, t6)) (z, t4))
         s1b
         (snoc (snoc s2a1 (x, t7)) (z, t5))
         s2b1; repeat (rw length_snoc); dands; try (complete sp).

  assert (cover_vars (mk_apply2 R t1 t2) (snoc s2a1 (x, t7)))
         as cv
         by (apply cover_vars_apply2; sp;
             try (apply cover_vars_var);
             repeat (apply cover_vars_snoc_weak); sp;
             repeat (rw dom_csub_snoc); simpl; repeat (rw in_snoc); sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a (x, t6)) (snoc s2a1 (x, t7)) t4 t5 wfct0 p0 cv;
    dands; try (complete sp).

  lsubst_tac.

  vr_seq_true in hyp2.
  generalize (hyp2 (snoc s1a  (x, t6) ++ s1b)
                   (snoc s2a1 (x, t7) ++ s2b));
    clear hyp2; intro hyp2.
  repeat (autodimp hyp2 hyp); exrepnd.

  rw @similarity_app; simpl.
  exists (snoc s1a (x,t6)) s1b (snoc s2a1 (x,t7)) s2b; repeat (rw length_snoc); sp.
  lsubst_tac.
  auto.

  apply sub_eq_hyps_snoc_weak; sp.

  (* similarity *)
  rw @similarity_app; simpl.
  exists (snoc (snoc s1a0 (x, t0)) (z, t))
         s1b
         (snoc (snoc s2a0 (x, t3)) (z, t))
         s2b; repeat (rw length_snoc); sp.

  assert (wf_term (mk_apply2 R t1 t2))
         as wfap by (apply wf_apply2; sp).

  assert (cover_vars (mk_apply2 R t1 t2) (snoc s1a0 (x, t0)))
         as cvap
         by (apply cover_vars_snoc_weak;rw @cover_vars_apply2; sp).

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (x, t0)) (snoc s2a0 (x, t3)) t t wfap cvap; sp.

  lsubst_tac.
  rw @member_eq; sp.

  rewrite substitute_hyps_snoc_sub_weak; sp.
  (* similarity proved *)

  assert (lsubstc C wfct (snoc (snoc s1a0 (x, t0)) (z, t) ++ s1b) pC0
          = lsubstc C wfct (snoc s1a0 (x, t0) ++ s1b) pC1)
         as eq1
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc C wfct (snoc (snoc s2a0 (x, t3)) (z, t) ++ s2b) pC3
          = lsubstc C wfct (snoc s2a0 (x, t3) ++ s2b) pC2)
         as eq2
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s1a0 (x, t0)) (z, t) ++ s1b) pt0
          = lsubstc e wfce (snoc s1a0 (x, t0) ++ s1b) pt1)
         as eq3
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s2a0 (x, t3)) (z, t) ++ s2b) pt3
          = lsubstc e wfce (snoc s2a0 (x, t3) ++ s2b) pt2)
         as eq4
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  rw eq1 in hyp0.
  rw eq1 in hyp1.
  rw eq2 in hyp0.
  rw eq3 in hyp1.
  rw eq4 in hyp1.
  sp.
Qed.

(* begin hide *)

Lemma rule_ipertype_elimination_t_true_ex {o} :
  forall lib i z R t1 t2 C e x H J,
    rule_true_if lib (@rule_ipertype_elimination_t o
                 R t1 t2 C e
                 x z
                 i
                 H J).
Proof.
  intros.
  generalize (rule_ipertype_elimination_t_true lib R t1 t2 C e x z i H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* end hide *)

(* [16] ============ IPERTYPE EQUALITY ============ *)

(**

  We can state the ipertype equality rule as follows:
<<
   H |- ipertype(R1) = ipertype(R2) in Type(i)

     By ipertypeMemberEquality x y z u v

     H, x : Base, y : Base |- R1 x y = R2 x y in Type(i)
     H, x : Base, y : Base, z : R1 x y |- R1 y x
     H, x : Base, y : Base, z : Base, u : R1 z y, v : R1 y z |- R1 x z
>>
 *)

Definition rule_ipertype_equality {o}
           (R1 R2 e1 e2 : NTerm)
           (x y z u v : NVar)
           (i : nat)
           (H : @barehypotheses o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality (mk_ipertype R1) (mk_ipertype R2) (mk_uni i))))
    [ mk_baresequent
        (snoc (snoc H (mk_hyp x mk_base)) (mk_hyp y mk_base))
        (mk_conclax (mk_equality
                       (mk_apply2 R1 (mk_var x) (mk_var y))
                       (mk_apply2 R2 (mk_var x) (mk_var y))
                       (mk_uni i))),
      mk_baresequent
        (snoc (snoc (snoc H (mk_hyp x mk_base))
                    (mk_hyp y mk_base))
              (mk_hyp z (mk_apply2 R1 (mk_var x) (mk_var y))))
        (mk_concl (mk_apply2 R1 (mk_var y) (mk_var x)) e1),
      mk_baresequent
        (snoc (snoc (snoc (snoc (snoc H (mk_hyp x mk_base))
                                (mk_hyp y mk_base))
                          (mk_hyp z mk_base))
                    (mk_hyp u (mk_apply2 R1 (mk_var x) (mk_var y))))
              (mk_hyp v (mk_apply2 R1 (mk_var y) (mk_var z))))
        (mk_concl (mk_apply2 R1 (mk_var x) (mk_var z)) e2)
    ]
    [].

Lemma rule_ipertype_equality_true {o} :
  forall lib (R1 R2 e1 e2 : NTerm),
  forall x y z u v : NVar,
  forall i : nat,
  forall H : @barehypotheses o,
    rule_true lib (rule_ipertype_equality
                 R1 R2 e1 e2
                 x y z u v
                 i
                 H).
Proof.
  unfold rule_ipertype_equality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1; rename Hyp1 into hyp2; rename Hyp2 into hyp3.
  destseq; allsimpl; proof_irr; GC.

  allunfold @closed_type; allunfold @closed_extract; allsimpl.

  exists (@covered_axiom o (nh_vars_hyps H)).

  dup hyp1 as hypmem.
  apply sequent_equality_implies_member in hypmem; exrepnd.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R1)
           # !LIn y (free_vars R1)
           # !LIn z (free_vars R1)
           # !LIn u (free_vars R1)
           # !LIn v (free_vars R1)
           # !LIn x (free_vars R2)
           # !LIn y (free_vars R2)
           # !LIn z (free_vars R2)
           # !LIn u (free_vars R2)
           # !LIn v (free_vars R2)
           # !LIn x (vars_hyps H)
           # !LIn y (vars_hyps H)
           # !LIn z (vars_hyps H)
           # !x = y
           # !x = z
           # !y = z) as vhyps.

  clear hyp1 hyp2 hyp3 hypmem0.
  dwfseq.
  sp.

  destruct vhyps as [ nixr1 vhyps ].
  destruct vhyps as [ niyr1 vhyps ].
  destruct vhyps as [ nizr1 vhyps ].
  destruct vhyps as [ niur1 vhyps ].
  destruct vhyps as [ nivr1 vhyps ].
  destruct vhyps as [ nixr2 vhyps ].
  destruct vhyps as [ niyr2 vhyps ].
  destruct vhyps as [ nizr2 vhyps ].
  destruct vhyps as [ niur2 vhyps ].
  destruct vhyps as [ nivr2 vhyps ].
  destruct vhyps as [ nixh vhyps ].
  destruct vhyps as [ niyh vhyps ].
  destruct vhyps as [ nizh vhyps ].
  destruct vhyps as [ nxy vhyps ].
  destruct vhyps as [ nxz nyz ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  lsubst_tac.
  rw @member_eq.
  rw <- @member_equality_iff.

  generalize (teq_and_eq_if_equality
                lib (mk_uni i) (mk_ipertype R1) (mk_ipertype R2) s1 s2 H
                wT w1 w2 c1 c4 c2 c5 cT cT0
                eqh sim);
    intro k; repeat (autodimp k hyp); lsubst_tac; auto; try (apply @tequality_mkc_uni).

  clear dependent s1; clear dependent s2.
  introv hf sim; lsubst_tac.

  assert (cover_vars R1 s2)
    as cvr12
      by (apply cover_vars_change_sub with (sub1 := s1); auto;
          allapply @similarity_dom; repnd; allrw; sp).

  assert (cover_vars R2 s1)
    as cvr21
      by (apply cover_vars_change_sub with (sub1 := s2); auto;
          allapply @similarity_dom; repnd; allrw; sp).

  generalize (membership_apply2_eq
                lib H R1 R2 x y i s1 s2 w0 w3
                c1 cvr12 cvr21 c0 (wfh2, (wfct2, wfce), (ct1, ce1))
                hyp1 hf sim);
    introv fty.
  repeat (autodimp fty hyp).

  repeat (rw @mkc_ipertype_equality_in_uni); dands.

  introv.
  generalize (fty x0 y0); intro k; repnd.
  apply equality_commutes in k0; auto.

  allunfold @is_per_type; repnd; dands.

  generalize (is_sym_type
                lib R1 H i x y z e1 s1 s2 w0 c1
                wc' (wfh1, (wfct1, wfce1), (ct0, ce0))).
  intro j; repeat (destimp j hyp).

  generalize (is_trans_type
                lib R1 H i x y z u v e2 s1 s2 w0 c1
                wc' (wfh0, (wfct0, wfce0), (ct, ce))).
  intro j; repeat (destimp j hyp).
Qed.

(* begin hide *)

(* end hide *)

(* [20] ============ IPERTYPE ELIMINATION 2 ============ *)

(**

  Let us now provide another ipertype elimination rule.  This version
  is stated in terms of a ipertype hypothesis and not an equality in a
  ipertype:

<<
   H, x : ipertype(R), J |- C ext e

     By ipertypeElimination i z

     H, x : ipertype(R), [z : R x x], J |- C ext e
     H, x : ipertype(R) |- R x x in Type(i)
>>
 *)

Definition rule_ipertype_elimination2 {o}
           (R C e : NTerm)
           (x z : NVar)
           (i : nat)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hyp x (mk_ipertype R)) ++ J)
       (mk_concl C e))
    [ mk_baresequent
        (snoc (snoc H (mk_hyp x (mk_ipertype R)))
              (mk_hhyp z (mk_apply2 R (mk_var x) (mk_var x)))
              ++ J)
        (mk_concl C e),
      mk_baresequent
        (snoc H (mk_hyp x (mk_ipertype R)))
        (mk_conclax (mk_member
                       (mk_apply2 R (mk_var x) (mk_var x))
                       (mk_uni i)))
    ]
    [sarg_var z].

Lemma rule_ipertype_elimination2_true {o} :
  forall lib (R C e : NTerm),
  forall x z : NVar,
  forall i : nat,
  forall H J : @barehypotheses o,
    rule_true lib (rule_ipertype_elimination2
                 R C e
                 x z
                 i
                 H J).
Proof.
  unfold rule_ipertype_elimination2, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1; rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.

  assert (covered e (nh_vars_hyps (snoc H (mk_hyp x (mk_ipertype R)) ++ J))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # !LIn x (vars_hyps H)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
    try (complete (discover; allrw in_snoc; sp));
    try (complete (generalize (wg9 x); allrw remove_nvars_nil_l; allrw app_nil_r; sp));
    try (complete (generalize (wfh6 z); allrw in_snoc; sp));
    try (complete (generalize (cg z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (wfh z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                   allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                   generalize (subvars_hs_vars_hyps H); intros;
                   generalize (subvars_hs_vars_hyps J); intros;
                   allrw subvars_prop; apply_in_hyp p; sp)).

  destruct vhyps as [ nixr vhyps ].
  destruct vhyps as [ nixh vhyps ].
  destruct vhyps as [ nizc vhyps ].
  destruct vhyps as [ nize vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  applydup @equality_refl in sim2 as simt1.
  rw @equality_in_mkc_ipertype in sim2; repnd.
  rw @equality_in_mkc_ipertype in simt1; repnd.

  vr_seq_true in hyp1.
  unfold inhabited_type in sim0; exrepnd.
  unfold inhabited_type in simt0; destruct simt0 as [t' simt0].
  generalize (hyp1 ((snoc (snoc s1a0 (x, t1)) (z, t')) ++ s1b)
                   ((snoc (snoc s2a0 (x, t2)) (z, t')) ++ s2b));
    clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd.

  (* hyps_functionality *)
  introv sim.
  rw @similarity_app in sim; simpl in sim; exrepnd; subst; cpx.
  apply app_split in sim0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  rw @similarity_snoc in sim12; simpl in sim12; exrepnd; subst; cpx.
  lsubst_tac.
  generalize (eqh (s2a1 ++ s2b0)); intro j.
  autodimp j hyp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t1)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.
  rewrite substitute_hyps_snoc_sub_weak in sim8; sp.

  rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
  apply app_split in j0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  apply app_split in j2; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).

  duplicate j5 as dup_eqhyps_snoc.
  rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
  lsubst_tac.

  rw @eq_hyps_app; simpl.
  exists (snoc (snoc s1a (x, t4)) (z, t0))
         s1b
         (snoc (snoc s2a1 (x, t5)) (z, t3))
         s2b1; repeat (rw length_snoc); dands; try (complete sp).

  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x)) (snoc s2a1 (x, t5)))
         as cv
         by (apply cover_vars_apply2; sp;
             try (apply cover_vars_var);
             repeat (apply cover_vars_snoc_weak); sp;
             repeat (rw @dom_csub_snoc); simpl; repeat (rw in_snoc); sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a (x, t4)) (snoc s2a1 (x, t5)) t0 t3 w0 p0 cv;
    dands; try (complete sp).

  lsubst_tac.

  vr_seq_true in hyp2.
  generalize (hyp2 (snoc s1a (x,t4)) (snoc s2a1 (x,t5))); clear hyp2; intro hyp2.
  repeat (autodimp hyp2 hyp); exrepnd.

  apply hyps_functionality_init_seg with (s3 := s2b) in eqh; sp.

  lsubst_tac.
  apply @tequality_in_uni_implies_tequality with (i := i); sp.

  apply sub_eq_hyps_snoc_weak; sp.

  (* similarity *)
  rw @similarity_app; simpl.
  exists (snoc (snoc s1a0 (x, t1)) (z, t'))
         s1b
         (snoc (snoc s2a0 (x, t2)) (z, t'))
         s2b; repeat (rw length_snoc); sp.

  assert (wf_term (mk_apply2 R (mk_var x) (mk_var x)))
         as wfap by (apply wf_apply2; sp).

  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x)) (snoc s1a0 (x, t1)))
         as cvap
         by (rw @cover_vars_apply2; sp;
             try (complete (apply cover_vars_snoc_weak; sp));
             apply cover_vars_var; rw @dom_csub_snoc; simpl; rw in_snoc; sp).

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (x, t1)) (snoc s2a0 (x, t2)) t' t' wfap cvap; sp.

  lsubst_tac.
  rw @member_eq; sp.

  rewrite substitute_hyps_snoc_sub_weak; sp.
  (* similarity proved *)

  assert (lsubstc C wfct (snoc (snoc s1a0 (x, t1)) (z, t') ++ s1b) pC0
          = lsubstc C wfct (snoc s1a0 (x, t1) ++ s1b) pC1)
         as eq1
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc C wfct (snoc (snoc s2a0 (x, t2)) (z, t') ++ s2b) pC3
          = lsubstc C wfct (snoc s2a0 (x, t2) ++ s2b) pC2)
         as eq2
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s1a0 (x, t1)) (z, t') ++ s1b) pt0
          = lsubstc e wfce (snoc s1a0 (x, t1) ++ s1b) pt1)
         as eq3
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s2a0 (x, t2)) (z, t') ++ s2b) pt3
          = lsubstc e wfce (snoc s2a0 (x, t2) ++ s2b) pt2)
         as eq4
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  rw eq1 in hyp0.
  rw eq1 in hyp1.
  rw eq2 in hyp0.
  rw eq3 in hyp1.
  rw eq4 in hyp1.
  sp.
Qed.

(* begin hide *)

Lemma rule_ipertype_elimination2_true_ex {o} :
  forall lib i z R C e x H J,
    rule_true_if lib (@rule_ipertype_elimination2 o
                 R C e
                 x z
                 i
                 H J).
Proof.
  intros.
  generalize (rule_ipertype_elimination2_true lib R C e x z i H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* end hide *)

(* [21] ============ IPERTYPE ELIMINATION 3 ============ *)

(**

  We state yet another ipertype elimination rule.  This one is similar
  to the second one presented above but does not require us to provide
  a level for [R x x]:

<<
   H, x : ipertype(R), J |- C ext e

     By ipertypeElimination i z

     H, x : ipertype(R), [z : R x x], J |- C ext e
     H, x : ipertype(R) |- (R x x) is a type
>>
 *)

Definition rule_ipertype_elimination3 {o}
           (R C e : NTerm)
           (x z : NVar)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent (snoc H (mk_hyp x (mk_ipertype R)) ++ J)
                   (mk_concl C e))
    [ mk_baresequent (snoc (snoc H (mk_hyp x (mk_ipertype R)))
                          (mk_hhyp z (mk_apply2 R (mk_var x) (mk_var x)))
                          ++ J)
                   (mk_concl C e),
      mk_baresequent (snoc H (mk_hyp x (mk_ipertype R)))
                    (mk_concl_t (mk_apply2 R (mk_var x) (mk_var x)))
    ]
    [sarg_var z].

Lemma rule_ipertype_elimination3_true {o} :
  forall lib (R C e : NTerm),
  forall x z : NVar,
  forall H J : @barehypotheses o,
    rule_true lib (rule_ipertype_elimination3
                 R C e
                 x z
                 H J).
Proof.
  unfold rule_ipertype_elimination3, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  generalize (hyps (mk_baresequent
                      (snoc (snoc H (mk_hyp x (mk_ipertype R)))
                            (mk_hhyp z (mk_apply2 R (mk_var x) (mk_var x))) ++ J)
                      (mk_concl C e))
                   (inl eq_refl))
             (hyps (mk_baresequent
                      (snoc H (mk_hyp x (mk_ipertype R)))
                      (mk_concl_t (mk_apply2 R (mk_var x) (mk_var x))))
                   (inr (inl eq_refl)));
    simpl; intros hyp1 hyp2.
  destruct hyp1 as [ ws1 hyp1 ].
  destruct hyp2 as [ ws2 hyp2 ].
  destseq; allsimpl; proof_irr; GC.

  assert (covered e (nh_vars_hyps (snoc H (mk_hyp x (mk_ipertype R)) ++ J))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # !LIn x (vars_hyps H)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
    try (complete (discover; allrw in_snoc; sp));
    try (complete (generalize (wg9 x); allrw remove_nvars_nil_l; allrw app_nil_r; sp));
    try (complete (generalize (wfh6 z); allrw in_snoc; sp));
    try (complete (generalize (cg z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (wfh z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                   allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                   generalize (subvars_hs_vars_hyps H); intros;
                   generalize (subvars_hs_vars_hyps J); intros;
                   allrw subvars_prop; apply_in_hyp p; sp)).

  destruct vhyps as [ nixr  vhyps ].
  destruct vhyps as [ nixh  vhyps ].
  destruct vhyps as [ nizc  vhyps ].
  destruct vhyps as [ nize  vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  applydup @equality_refl in sim2 as simt1.
  rw @equality_in_mkc_ipertype in sim2; repnd.
  rw @equality_in_mkc_ipertype in simt1; repnd.

  vr_seq_true in hyp1.
  unfold inhabited_type in sim0; exrepnd.
  unfold inhabited_type in simt0; destruct simt0 as [t' simt0].
  generalize (hyp1 ((snoc (snoc s1a0 (x, t1)) (z, t')) ++ s1b)
                   ((snoc (snoc s2a0 (x, t2)) (z, t')) ++ s2b));
    clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd.

  (* hyps_functionality *)
  introv sim.
  rw @similarity_app in sim; simpl in sim; exrepnd; subst; cpx.
  apply app_split in sim0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  rw @similarity_snoc in sim12; simpl in sim12; exrepnd; subst; cpx.
  lsubst_tac.
  generalize (eqh (s2a1 ++ s2b0)); intro j.
  autodimp j hyp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t1)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.
  rewrite substitute_hyps_snoc_sub_weak in sim8; sp.

  rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
  apply app_split in j0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  apply app_split in j2; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).

  duplicate j5 as dup_eqhyps_snoc.
  rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
  lsubst_tac.

  rw @eq_hyps_app; simpl.
  exists (snoc (snoc s1a (x, t4)) (z, t0))
         s1b
         (snoc (snoc s2a1 (x, t5)) (z, t3))
         s2b1; repeat (rw length_snoc); dands; try (complete sp).

  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x)) (snoc s2a1 (x, t5)))
         as cv
         by (apply cover_vars_apply2; sp;
             try (apply cover_vars_var);
             repeat (apply cover_vars_snoc_weak); sp;
             repeat (rw @dom_csub_snoc); simpl; repeat (rw in_snoc); sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a (x, t4)) (snoc s2a1 (x, t5)) t0 t3 wfct0 p0 cv;
    dands; try (complete sp).

  lsubst_tac.

  vr_seq_true in hyp2.
  generalize (hyp2 (snoc s1a (x,t4)) (snoc s2a1 (x,t5))); clear hyp2; intro hyp2.
  repeat (autodimp hyp2 hyp); exrepnd.

  apply hyps_functionality_init_seg with (s3 := s2b) in eqh; sp.

  lsubst_tac; sp.

  apply sub_eq_hyps_snoc_weak; sp.

  (* similarity *)
  rw @similarity_app; simpl.
  exists (snoc (snoc s1a0 (x, t1)) (z, t'))
         s1b
         (snoc (snoc s2a0 (x, t2)) (z, t'))
         s2b; repeat (rw length_snoc); sp.

  assert (wf_term (mk_apply2 R (mk_var x) (mk_var x)))
         as wfap by (apply wf_apply2; sp).

  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x)) (snoc s1a0 (x, t1)))
         as cvap
         by (rw @cover_vars_apply2; sp;
             try (complete (apply cover_vars_snoc_weak; sp));
             apply cover_vars_var; rw @dom_csub_snoc; simpl; rw in_snoc; sp).

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (x, t1)) (snoc s2a0 (x, t2)) t' t' wfap cvap; sp.

  lsubst_tac.
  rw @member_eq; sp.

  rewrite substitute_hyps_snoc_sub_weak; sp.
  (* similarity proved *)

  assert (lsubstc C wfct (snoc (snoc s1a0 (x, t1)) (z, t') ++ s1b) pC0
          = lsubstc C wfct (snoc s1a0 (x, t1) ++ s1b) pC1)
         as eq1
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc C wfct (snoc (snoc s2a0 (x, t2)) (z, t') ++ s2b) pC3
          = lsubstc C wfct (snoc s2a0 (x, t2) ++ s2b) pC2)
         as eq2
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s1a0 (x, t1)) (z, t') ++ s1b) pt0
          = lsubstc e wfce (snoc s1a0 (x, t1) ++ s1b) pt1)
         as eq3
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s2a0 (x, t2)) (z, t') ++ s2b) pt3
          = lsubstc e wfce (snoc s2a0 (x, t2) ++ s2b) pt2)
         as eq4
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  rw eq1 in hyp0.
  rw eq1 in hyp1.
  rw eq2 in hyp0.
  rw eq3 in hyp1.
  rw eq4 in hyp1.
  sp.
Qed.

(* begin hide *)

Lemma rule_ipertype_elimination3_true_ex {o} :
  forall lib z R C e x H J,
    rule_true_if lib (@rule_ipertype_elimination3 o
                 R C e
                 x z
                 H J).
Proof.
  intros.
  generalize (rule_ipertype_elimination3_true lib R C e x z H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* end hide *)

(* [21] ============ IPERTYPE ELIMINATION 4 ============ *)

(**

  We state yet another ipertype elimination rule.  This one is similar
  to the third one presented above but [R x x] is now the last hypothesis
  in the first subgoal:

<<
   H, x : ipertype(R), J |- C ext e

     By ipertypeElimination i z

     H, x : ipertype(R), J, [z : R x x] |- C ext e
     H, x : ipertype(R) |- (R x x) is a type
>>
 *)

Definition rule_ipertype_elimination4 {o}
           (R C e : NTerm)
           (x z : NVar)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent (snoc H (mk_hyp x (mk_ipertype R)) ++ J)
                   (mk_concl C e))
    [ mk_baresequent (snoc ((snoc H (mk_hyp x (mk_ipertype R))) ++ J)
                           (mk_hhyp z (mk_apply2 R (mk_var x) (mk_var x))))
                   (mk_concl C e),
      mk_baresequent (snoc H (mk_hyp x (mk_ipertype R)))
                    (mk_concl_t (mk_apply2 R (mk_var x) (mk_var x)))
    ]
    [sarg_var z].

Lemma rule_ipertype_elimination4_true {o} :
  forall lib (R C e : NTerm),
  forall x z : NVar,
  forall H J : @barehypotheses o,
    rule_true lib (rule_ipertype_elimination4
                 R C e
                 x z
                 H J).
Proof.
  unfold rule_ipertype_elimination4, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.

  assert (covered e (nh_vars_hyps (snoc H (mk_hyp x (mk_ipertype R)) ++ J))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # disjoint (free_vars R) (vars_hyps J)
           # !LIn x (vars_hyps H)
           # !LIn x (vars_hyps J)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
    try (complete (allunfold @disjoint; discover; allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (wg9 x); allrw remove_nvars_nil_l; allrw app_nil_r; sp));
    try (complete (generalize (wfh3 z); allrw in_snoc; sp));
    try (complete (generalize (wfh6 z); allrw in_snoc; sp));
    try (complete (generalize (cg z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (wfh z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                   allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                   generalize (subvars_hs_vars_hyps H); intros;
                   generalize (subvars_hs_vars_hyps J); intros;
                   allrw subvars_prop; apply_in_hyp p; sp));
    try (complete (unfold disjoint; unfold disjoint in wfh11; introv k;
                   discover; auto)).

  destruct vhyps as [ nixr vhyps ].
  destruct vhyps as [ disjRJ vhyps ].
  destruct vhyps as [ nixh vhyps ].
  destruct vhyps as [ nixj vhyps ].
  destruct vhyps as [ nizc vhyps ].
  destruct vhyps as [ nize vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  applydup @equality_refl in sim2 as simt1.
  rw @equality_in_mkc_ipertype in sim2; repnd.
  rw @equality_in_mkc_ipertype in simt1; repnd.

  vr_seq_true in hyp1.
  unfold inhabited_type in sim0; exrepnd.
  unfold inhabited_type in simt0; destruct simt0 as [t' simt0].
  generalize (hyp1 (snoc (snoc s1a0 (x, t1) ++ s1b) (z, t'))
                   (snoc (snoc s2a0 (x, t2) ++ s2b) (z, t')));
    clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd.

  (* hyps_functionality *)
  introv sim.
  rw @similarity_snoc in sim; simpl in sim; exrepnd; subst; cpx.
  rw @similarity_app in sim10; simpl in sim10; exrepnd; subst; cpx.
  apply app_split in sim0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  lsubst_tac.
  generalize (eqh (s2a1 ++ s2b0)); intro j.
  autodimp j hyp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t1)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.

  rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
  apply app_split in j0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  apply app_split in j2; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).

  duplicate j5 as dup_eqhyps_snoc.
  rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
  lsubst_tac.

  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x))
                     (snoc s2a1 (x,t5) ++ s2b1))
    as cv
      by (apply cover_vars_apply2; sp;
          try (apply cover_vars_var);
          try (apply cover_vars_app_weak);
          repeat (apply cover_vars_snoc_weak); sp;
          repeat (rw @dom_csub_app); simpl;
          repeat (rw @dom_csub_snoc); simpl;
          repeat (rw in_app_iff);
          repeat (rw in_snoc); sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a (x,t4) ++ s1b) (snoc s2a1 (x,t5) ++ s2b1) t0 t3
         wfct0 p0 cv; repeat (rw length_snoc); dands; try (complete sp).

  rw @eq_hyps_app; simpl.
  exists (snoc s1a (x, t4))
         s1b
         (snoc s2a1 (x, t5))
         s2b1; repeat (rw length_snoc); dands; try (complete sp).

  lsubst_tac.

rw @tequality_mkc_ipertype in j0; repnd.

  vr_seq_true in hyp2.
  generalize (hyp2 (snoc s1a (x,t4)) (snoc s2a1 (x,t5))); clear hyp2; intro hyp2.
  repeat (autodimp hyp2 hyp); exrepnd.

  apply hyps_functionality_init_seg with (s3 := s2b) in eqh; sp.

  lsubst_tac; sp.

  (* similarity *)
  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x)) (snoc s1a0 (x,t1) ++s1b))
         as cvap
           by (rw @cover_vars_apply2; sp;
               try (complete (apply cover_vars_app_weak; apply cover_vars_snoc_weak; sp));
               apply cover_vars_var; rw @dom_csub_app; rw @dom_csub_snoc; simpl; rw in_app_iff; rw in_snoc; sp).

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (x,t1) ++ s1b) (snoc s2a0 (x,t2) ++ s2b) t' t'
         wfct0 cvap; sp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t1))
         s1b
         (snoc s2a0 (x, t2))
         s2b; repeat (rw length_snoc); sp.

  lsubst_tac.
  rw @member_eq; sp.
  (* similarity proved *)

  lsubst_tac.
  sp.
Qed.

(* begin hide *)

Lemma rule_ipertype_elimination4_true_ex {o} :
  forall lib z R C e x H J,
    rule_true_if lib (@rule_ipertype_elimination4 o
                 R C e
                 x z
                 H J).
Proof.
  intros.
  generalize (rule_ipertype_elimination4_true lib R C e x z H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* end hide *)