From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.
From BitBlasting Require Import QFBV CNF BBCommon BBAnd BBXor BBOr BBSignExtend BBMul BBUmulo.
From ssrlib Require Import ZAriths Tactics Bools Seqs.
From nbits Require Import NBits.

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

(* The algorithm is from https://www.researchgate.net/publication/3045091_Integer_multipliers_with_overflow_detection *)

Section BBSmulo.
  Infix "++r" := catrev (right associativity, at level 60): seq_scope.
  (* ===== bit_blast_smulo ===== *)

  (* ===== smulo_rec is same as umulo_rec *)

  Definition bit_blast_smulo_rec := bit_blast_umulo_rec.

  Definition mk_env_smulo_rec := mk_env_umulo_rec.

  (* orb_all and andb_orb_all defined in Umulo *)

  Lemma bit_blast_smulo_rec_correct g bs1 bs2 E ls1 ls2 g' cs lr_or lr_and_or :
    bit_blast_smulo_rec g ls1 ls2 = (g', cs, lr_or, lr_and_or) ->
    size ls1 == size ls2 ->
    enc_bits E ls1 bs1 -> enc_bits E ls2 bs2 ->
    interp_cnf E (add_prelude cs) ->
    enc_bit E lr_or (orb_all bs1) && enc_bit E lr_and_or (andb_orb_all bs1 bs2).
  Proof.
    exact: bit_blast_umulo_rec_correct.
  Qed.

  Lemma mk_env_smulo_rec_is_bit_blast_smulo_rec E g ls1 ls2 E' g' cs lr_or lr_and_or:
    mk_env_smulo_rec E g ls1 ls2 = (E', g', cs, lr_or, lr_and_or) ->
    bit_blast_smulo_rec g ls1 ls2 = (g', cs, lr_or, lr_and_or).
  Proof.
    exact: mk_env_umulo_rec_is_bit_blast_umulo_rec.
  Qed.

  Lemma mk_env_smulo_rec_newer_gen E g ls1 ls2 E' g' cs lr_or lr_and_or:
    mk_env_smulo_rec E g ls1 ls2 = (E', g', cs, lr_or, lr_and_or) ->
    (g <=? g')%positive.
  Proof.
    exact: mk_env_umulo_rec_newer_gen.
  Qed.

  Lemma mk_env_smulo_rec_newer_res E g ls1 ls2 E' g' cs lr_or lr_and_or:
    mk_env_smulo_rec E g ls1 ls2 = (E', g', cs, lr_or, lr_and_or) ->
    newer_than_lit g lit_tt ->
    newer_than_lit g' lr_or && newer_than_lit g' lr_and_or.
    exact: mk_env_umulo_rec_newer_res.
  Qed.

  Lemma mk_env_smulo_rec_newer_cnf E g ls1 ls2 E' g' cs lr_or lr_and_or:
    mk_env_smulo_rec E g ls1 ls2 = (E', g', cs, lr_or, lr_and_or) ->
    newer_than_lit g lit_tt ->
    newer_than_lits g ls1 ->
    newer_than_lits g ls2 ->
    newer_than_cnf g' cs.
  Proof.
    exact: mk_env_umulo_rec_newer_cnf.
  Qed.

  Lemma mk_env_smulo_rec_preserve E g ls1 ls2 E' g' cs lr_or lr_and_or:
    mk_env_smulo_rec E g ls1 ls2 = (E', g', cs, lr_or, lr_and_or) ->
    env_preserve E E' g.
  Proof.
    exact: mk_env_umulo_rec_preserve.
  Qed.

  Lemma mk_env_smulo_rec_sat E g ls1 ls2 E' g' cs lr_or lr_and_or:
    mk_env_smulo_rec E g ls1 ls2 = (E', g', cs, lr_or, lr_and_or) ->
    newer_than_lit g lit_tt ->
    newer_than_lits g ls1 ->
    newer_than_lits g ls2 ->
    interp_cnf E' cs.
  Proof.
    exact: mk_env_umulo_rec_sat.
  Qed.

  Definition bit_blast_smulo (g: generator) ls1 ls2 : generator * cnf * literal:=
    let (ls1_tl, ls1_sign) := eta_expand (splitmsl ls1) in
    let (ls2_tl, ls2_sign) := eta_expand (splitmsl ls2) in
    let wsign1 := copy (size ls1_tl) ls1_sign in
    let wsign2 := copy (size ls2_tl) ls2_sign in
    let '(g_xls1, cs_xls1, xls1) := bit_blast_xor g ls1_tl wsign1 in
    let '(g_xls2, cs_xls2, xls2) := bit_blast_xor g_xls1 ls2_tl wsign2 in
    let (xls1_low, xls1_hightl) := eta_expand (splitlsl xls1) in
    let (xls2_low, xls2_hightl) := eta_expand (splitlsl xls2) in
    let '(g_rec, cs_rec, r_or_rec, r_or_and_rec) := bit_blast_smulo_rec g_xls2 xls1_hightl xls2_hightl in
    let '(g_wls1, cs_wls1, wls1) := bit_blast_signextend 1 g_rec ls1 in
    let '(g_wls2, cs_wls2, wls2) := bit_blast_signextend 1 g_wls1 ls2 in
    let '(g_mul, cs_mul, mul) := bit_blast_mul g_wls2 wls1 wls2 in
    let (mul_tl, mul_n) := eta_expand (splitmsl mul) in
    let (_, mul_n_minus1) := eta_expand (splitmsl mul_tl) in
    let '(g_xor1, cs_xor1, xor1) := bit_blast_xor1 g_mul mul_n mul_n_minus1 in
    let '(g_or1, cs_or1, or1) := bit_blast_or1 g_xor1 r_or_and_rec xor1 in
    (g_or1, cs_xls1 ++r cs_xls2 ++r cs_rec ++r cs_wls1 ++r cs_wls2  ++r cs_mul ++r cs_xor1 ++r cs_or1, or1).

  Definition mk_env_smulo E (g: generator) ls1 ls2 : env * generator * cnf * literal :=
    let (ls1_tl, ls1_sign) := eta_expand (splitmsl ls1) in
    let (ls2_tl, ls2_sign) := eta_expand (splitmsl ls2) in
    let wsign1 := copy (size ls1_tl) ls1_sign in
    let wsign2 := copy (size ls2_tl) ls2_sign in
    let '(E_xls1, g_xls1, cs_xls1, xls1) := mk_env_xor E g ls1_tl wsign1 in
    let '(E_xls2, g_xls2, cs_xls2, xls2) := mk_env_xor E_xls1 g_xls1 ls2_tl wsign2 in
    let (xls1_low, xls1_hightl) := eta_expand (splitlsl xls1) in
    let (xls2_low, xls2_hightl) := eta_expand (splitlsl xls2) in
    let '(E_rec, g_rec, cs_rec, r_or_rec, r_or_and_rec) := mk_env_smulo_rec E_xls2 g_xls2 xls1_hightl xls2_hightl in
    let '(E_wls1, g_wls1, cs_wls1, wls1) := mk_env_signextend 1 E_rec g_rec ls1 in
    let '(E_wls2, g_wls2, cs_wls2, wls2) := mk_env_signextend 1 E_wls1 g_wls1 ls2 in
    let '(E_mul, g_mul, cs_mul, mul) := mk_env_mul E_wls2 g_wls2 wls1 wls2 in
    let (mul_tl, mul_n) := eta_expand (splitmsl mul) in
    let (_, mul_n_minus1) := eta_expand (splitmsl mul_tl) in
    let '(E_xor1, g_xor1, cs_xor1, xor1) := mk_env_xor1 E_mul g_mul mul_n mul_n_minus1 in
    let '(E_or1, g_or1, cs_or1, or1) := mk_env_or1 E_xor1 g_xor1 r_or_and_rec xor1 in
    (E_or1, g_or1, cs_xls1 ++r cs_xls2 ++r cs_rec ++r cs_wls1 ++r cs_wls2  ++r cs_mul ++r cs_xor1 ++r cs_or1, or1).

  Lemma bit_blast_smulo_correct g bs1 bs2 E ls1 ls2 g' cs lr :
    bit_blast_smulo g ls1 ls2 = (g', cs, lr) ->
    size ls1 == size ls2 ->
    enc_bits E ls1 bs1 ->
    enc_bits E ls2 bs2 ->
    interp_cnf E (add_prelude cs) ->
    enc_bit E lr (Smulo bs1 bs2).
  Proof.
    rewrite /bit_blast_smulo /Smulo.
    rewrite (lock bit_blast_signextend) (lock bit_blast_xor1 )/= -2!lock.
    dcase (bit_blast_xor g (belastd ls1) (copy (size (belastd ls1)) (lastd lit_ff ls1)))
    => [[[g_xls1 cs_xls1] xls1] Hblast_xls1].
    dcase (bit_blast_xor g_xls1 (belastd ls2) (copy (size (belastd ls2)) (lastd lit_ff ls2)))
    => [[[g_xls2 cs_xls2] xls2] Hblast_xls2].
    dcase (bit_blast_smulo_rec g_xls2 (behead xls1) (behead xls2))
    => [[[[g_rec cs_rec] r_or ] r_or_and_rec] Hblast_rec].
    dcase (bit_blast_signextend 1 g_rec ls1) => [[[g_wls1 cs_wls1] wls1] Hblast_wls1].
    dcase (bit_blast_signextend 1 g_wls1 ls2) => [[[g_wls2 cs_wls2] wls2] Hblast_wls2].
    dcase (bit_blast_mul g_wls2 wls1 wls2) => [[[g_mul cs_mul] mul] Hblast_mul].
    dcase (bit_blast_xor1 g_mul (lastd lit_ff mul) (lastd lit_ff (belastd mul)))
    => [[[g_xor1 cs_xor1] xor1] Hblast_xor1].
    dcase (bit_blast_or1 g_xor1 r_or_and_rec xor1) => [[[g_or1 cs_or1] or1] Hblast_or1].
    case => _ <- <- Hsz Henc1 Henc2.
    move: (enc_bits_size Henc1) => Hsz1.
    move: (enc_bits_size Henc2) => Hsz2.
    have HszB : size bs1 == size bs2 by rewrite -Hsz1 -Hsz2 (eqP Hsz).
    rewrite !add_prelude_catrev.
    move=> /andP [Hcnf_xls1 /andP [Hcnf_xls2 /andP [Hcnf_rec /andP [Hcnf_wls1 /andP [Hcnf_wls2 /andP [Hcnf_mul /andP [Hcnf_xor1 Hcnf_or1]]]]]]].
    move: (add_prelude_enc_bit_tt Hcnf_xls1) => Htt.
    rewrite /enc_bit in Htt.
    move/eqP in Htt.
    move: (enc_bits_splitmsb Htt Henc1) => /= /andP [Henc_ls1tl Henc_ls1sign].
    move: (enc_bits_splitmsb Htt Henc2) => /= /andP [Henc_ls2tl Henc_ls2sign].
    move: (enc_bits_copy (size (belastd ls1)) Henc_ls1sign) => Henc_wsign1.
    move: (enc_bits_copy (size (belastd ls2)) Henc_ls2sign) => Henc_wsign2.
    move: (bit_blast_xor_correct Hblast_xls1 Henc_ls1tl Henc_wsign1 Hcnf_xls1) => Henc_xls1.
    move: (bit_blast_xor_correct Hblast_xls2 Henc_ls2tl Henc_wsign2 Hcnf_xls2) => Henc_xls2.
    have Hsz_xls : size (behead xls1) = size (behead xls2).
    {
      rewrite !size_behead /=; f_equal.
      rewrite (enc_bits_size Henc_xls1).
      rewrite (enc_bits_size Henc_xls2).
      move: (size_belastd_eq (eqP Hsz)) => Hsz_wsign.
      rewrite Hsz_wsign.
      rewrite /xorB.
      rewrite !size_lift.
      move: (size_belastd_eq (eqP HszB)) => Hsz_wsignB.
      rewrite Hsz_wsignB.
      f_equal.
        by rewrite !size_copy.
    }
    move/eqP: Hsz_xls => Hsz_xls.
    move: (enc_bits_splitlsb Htt Henc_xls1) => /= /andP [_ Henc_xls1tl].
    move: (enc_bits_splitlsb Htt Henc_xls2) => /= /andP [_ Henc_xls2tl].
    move: (bit_blast_smulo_rec_correct Hblast_rec Hsz_xls Henc_xls1tl Henc_xls2tl Hcnf_rec)
    => /andP [_ Henc_rec].
    move: (bit_blast_signextend_correct Hblast_wls1 Henc1 Hcnf_wls1) => Henc_wls1.
    move: (bit_blast_signextend_correct Hblast_wls2 Henc2 Hcnf_wls2) => Henc_wls2.
    have Hsz_wls: size wls1 = size wls2.
    {
      rewrite (enc_bits_size Henc_wls1) (enc_bits_size Henc_wls2).
      rewrite /sext !size_cat !size_copy /=.
        by rewrite (eqP HszB).
    }
    move: (bit_blast_mul_correct Hblast_mul Henc_wls1 Henc_wls2 Hcnf_mul Hsz_wls) => Henc_mul.
    move: (enc_bits_splitmsb Htt Henc_mul) => /= /andP [Henc_multl Henc_muln].
    move: (enc_bits_splitmsb Htt Henc_multl) => /= /andP [_ Henc_muln1].
    move: (bit_blast_xor1_correct Hblast_xor1 Henc_muln Henc_muln1 Hcnf_xor1) => Henc_xor1.
    have -> : size (belastd bs1) = size (belastd ls1).
    {
      apply size_belastd_eq.
        by rewrite Hsz1.
    }
    have -> : size (belastd bs2) = size (belastd ls2).
    {
      apply size_belastd_eq.
        by rewrite Hsz2.
    }
    exact: (bit_blast_or1_correct Hblast_or1 Henc_rec Henc_xor1 Hcnf_or1).
  Qed.

  Lemma mk_env_smulo_is_bit_blast_smulo  E g ls1 ls2 E' g' cs lr:
    mk_env_smulo E g ls1 ls2 = (E', g', cs, lr) ->
    bit_blast_smulo g ls1 ls2 = (g', cs, lr).
  Proof.
    rewrite /mk_env_smulo /bit_blast_smulo.
    rewrite (lock bit_blast_signextend) (lock bit_blast_xor1)
            (lock mk_env_signextend) (lock mk_env_xor1)
            /= -4!lock.
    dcase (mk_env_xor E g (belastd ls1) (copy (size (belastd ls1)) (lastd lit_ff ls1)))
    => [[[ [ E_xls1 g_xls1 ]  cs_xls1] xls1] Henv_xls1].
    dcase (mk_env_xor E_xls1 g_xls1 (belastd ls2) (copy (size (belastd ls2)) (lastd lit_ff ls2)))
    => [[[[ E_xls2 g_xls2] cs_xls2] xls2] Henv_xls2].
    dcase (mk_env_smulo_rec E_xls2 g_xls2 (behead xls1) (behead xls2))
    => [[[[[ E_rec g_rec] cs_rec] r_or ] r_or_and_rec] Henv_rec].
    dcase (mk_env_signextend 1 E_rec g_rec ls1) => [[[[E_wls1 g_wls1] cs_wls1] wls1] Henv_wls1].
    dcase (mk_env_signextend 1 E_wls1 g_wls1 ls2) => [[[[E_wls2 g_wls2] cs_wls2] wls2] Henv_wls2].
    dcase (mk_env_mul E_wls2 g_wls2 wls1 wls2) => [[[[ E_mul g_mul ] cs_mul] mul] Henv_mul].
    dcase (mk_env_xor1 E_mul g_mul (lastd lit_ff mul) (lastd lit_ff (belastd mul)))
    => [[[[ E_xor1 g_xor1 ] cs_xor1] xor1] Henv_xor1].
    dcase (mk_env_or1 E_xor1 g_xor1 r_or_and_rec xor1) => [[[[ E_or1 g_or1 ] cs_or1] or1] Henv_or1].
    rewrite (mk_env_xor_is_bit_blast_xor Henv_xls1).
    rewrite (mk_env_xor_is_bit_blast_xor Henv_xls2).
    rewrite (mk_env_smulo_rec_is_bit_blast_smulo_rec Henv_rec).
    rewrite (mk_env_signextend_is_bit_blast_signextend Henv_wls1).
    rewrite (mk_env_signextend_is_bit_blast_signextend Henv_wls2).
    rewrite (mk_env_mul_is_bit_blast_mul Henv_mul).
    rewrite (mk_env_xor1_is_bit_blast_xor1 Henv_xor1).
    rewrite (mk_env_or1_is_bit_blast_or1 Henv_or1).
      by case=> _ <- <- <-.
  Qed.

  Lemma mk_env_smulo_newer_gen E g ls1 ls2 E' g' cs lr:
    mk_env_smulo E g ls1 ls2 = (E', g', cs, lr) ->
    (g <=? g')%positive.
  Proof.
    rewrite /mk_env_smulo /bit_blast_smulo.
    rewrite (lock mk_env_signextend) (lock mk_env_xor1) /= -2!lock.
    dcase (mk_env_xor E g (belastd ls1) (copy (size (belastd ls1)) (lastd lit_ff ls1)))
    => [[[ [ E_xls1 g_xls1 ]  cs_xls1] xls1] Henv_xls1].
    dcase (mk_env_xor E_xls1 g_xls1 (belastd ls2) (copy (size (belastd ls2)) (lastd lit_ff ls2)))
    => [[[[ E_xls2 g_xls2] cs_xls2] xls2] Henv_xls2].
    dcase (mk_env_smulo_rec E_xls2 g_xls2 (behead xls1) (behead xls2))
    => [[[[[ E_rec g_rec] cs_rec] r_or ] r_or_and_rec] Henv_rec].
    dcase (mk_env_signextend 1 E_rec g_rec ls1) => [[[[E_wls1 g_wls1] cs_wls1] wls1] Henv_wls1].
    dcase (mk_env_signextend 1 E_wls1 g_wls1 ls2) => [[[[E_wls2 g_wls2] cs_wls2] wls2] Henv_wls2].
    dcase (mk_env_mul E_wls2 g_wls2 wls1 wls2) => [[[[ E_mul g_mul ] cs_mul] mul] Henv_mul].
    dcase (mk_env_xor1 E_mul g_mul (lastd lit_ff mul) (lastd lit_ff (belastd mul)))
    => [[[[ E_xor1 g_xor1 ] cs_xor1] xor1] Henv_xor1].
    dcase (mk_env_or1 E_xor1 g_xor1 r_or_and_rec xor1) => [[[[ E_or1 g_or1 ] cs_or1] or1] Henv_or1].
    case=> _ <- _ _.
    apply: (pos_leb_trans (mk_env_xor_newer_gen Henv_xls1)).
    apply: (pos_leb_trans (mk_env_xor_newer_gen Henv_xls2)).
    apply: (pos_leb_trans (mk_env_smulo_rec_newer_gen Henv_rec)).
    apply: (pos_leb_trans (mk_env_signextend_newer_gen Henv_wls1)).
    apply: (pos_leb_trans (mk_env_signextend_newer_gen Henv_wls2)).
    apply: (pos_leb_trans (mk_env_mul_newer_gen Henv_mul)).
    apply: (pos_leb_trans (mk_env_xor1_newer_gen Henv_xor1)).
    apply: (pos_leb_trans (mk_env_or1_newer_gen Henv_or1)).
    exact: Pos.leb_refl.
  Qed.

  Lemma mk_env_smulo_newer_res  E g ls1 ls2 E' g' cs lr:
    mk_env_smulo E g ls1 ls2 = (E', g', cs, lr) ->
    newer_than_lit g lit_tt ->
    newer_than_lits g ls1 ->
    newer_than_lits g ls2 ->
    newer_than_lit g' lr.
  Proof.
    rewrite /mk_env_smulo .
    rewrite (lock mk_env_signextend) (lock mk_env_xor1) /= -2!lock.
    dcase (mk_env_xor E g (belastd ls1) (copy (size (belastd ls1)) (lastd lit_ff ls1)))
    => [[[ [ E_xls1 g_xls1 ]  cs_xls1] xls1] Henv_xls1].
    dcase (mk_env_xor E_xls1 g_xls1 (belastd ls2) (copy (size (belastd ls2)) (lastd lit_ff ls2)))
    => [[[[ E_xls2 g_xls2] cs_xls2] xls2] Henv_xls2].
    dcase (mk_env_smulo_rec E_xls2 g_xls2 (behead xls1) (behead xls2))
    => [[[[[ E_rec g_rec] cs_rec] r_or ] r_or_and_rec] Henv_rec].
    dcase (mk_env_signextend 1 E_rec g_rec ls1) => [[[[E_wls1 g_wls1] cs_wls1] wls1] Henv_wls1].
    dcase (mk_env_signextend 1 E_wls1 g_wls1 ls2) => [[[[E_wls2 g_wls2] cs_wls2] wls2] Henv_wls2].
    dcase (mk_env_mul E_wls2 g_wls2 wls1 wls2) => [[[[ E_mul g_mul ] cs_mul] mul] Henv_mul].
    dcase (mk_env_xor1 E_mul g_mul (lastd lit_ff mul) (lastd lit_ff (belastd mul)))
    => [[[[ E_xor1 g_xor1 ] cs_xor1] xor1] Henv_xor1].
    dcase (mk_env_or1 E_xor1 g_xor1 r_or_and_rec xor1) => [[[[ E_or1 g_or1 ] cs_or1] or1] Henv_or1].
    case=> _ <- _ <- . move=> Hgtt Hgls1 Hgls2.
    move: (newer_than_lits_splitmsl Hgtt Hgls1) => /andP [Hgls1tl Hgls1sign].
    move: (newer_than_lits_copy (size (belastd ls1)) Hgls1sign) => Hgls1signs.
    move: (mk_env_xor_newer_res Henv_xls1 Hgtt Hgls1tl Hgls1signs) => Hnew_xls1.
    move: (newer_than_lits_splitmsl Hgtt Hgls2) => /andP [Hgls2tl Hgls2sign].
    move: (newer_than_lits_copy (size (belastd ls2)) Hgls2sign) => Hgls2signs.
    move: (mk_env_xor_newer_gen Henv_xls1) => Hgxls1.
    move: (newer_than_lits_le_newer Hgls2signs Hgxls1) => Hgx1ls2signs.
    move: (newer_than_lits_le_newer Hgls2tl Hgxls1) => Hgx1ls2tl.
    have Hgxls1tt: newer_than_lit g_xls1 lit_tt by t_newer_hook.
    move: (mk_env_xor_newer_res Henv_xls2 Hgxls1tt Hgx1ls2tl Hgx1ls2signs) => Hnew_xls2.
    move: (mk_env_xor_newer_gen Henv_xls2) => Hgxls2.
    move: (newer_than_lits_le_newer Hnew_xls1 Hgxls2) => {Hnew_xls1} Hnew_xls1.
    have Hgxls2tt: newer_than_lit g_xls2 lit_tt by t_newer_hook.
    move: (newer_than_lit_le_newer Hgtt Hgxls1) => Hgx1tt.
    move: (newer_than_lit_le_newer Hgx1tt Hgxls2) => Hgx2tt.
    move: (newer_than_lits_le_newer Hgls1 Hgxls1) => Hgx1ls1.
    move: (newer_than_lits_le_newer Hgx1ls1 Hgxls2) => Hgx2ls1.
    move: (newer_than_lits_le_newer Hgls2 Hgxls1) => Hgx1ls2.
    move: (newer_than_lits_le_newer Hgx1ls2 Hgxls2) => Hgx2ls2.
    move: (mk_env_smulo_rec_newer_res Henv_rec Hgx2tt) => /andP [_ Hnew_rec_rec].
    move: (mk_env_smulo_rec_newer_gen Henv_rec) => Hgx2grec.
    move: (newer_than_lit_le_newer Hgx2tt Hgx2grec) => Hgrectt.
    move: (newer_than_lits_le_newer Hgx2ls1 Hgx2grec) => Hgrecls1.
    move: (newer_than_lits_le_newer Hgx2ls2 Hgx2grec) => Hgrecls2.
    move: (mk_env_signextend_newer_res Henv_wls1 Hgrectt Hgrecls1) => Hnew_wls1.
    move: (mk_env_signextend_newer_gen Henv_wls1) => Hgrecwls1.
    move: (newer_than_lit_le_newer Hgrectt Hgrecwls1) => Hgwls1tt.
    move: (newer_than_lits_le_newer Hgrecls2 Hgrecwls1) => Hgwls1ls2.
    move: (mk_env_signextend_newer_res Henv_wls2 Hgwls1tt Hgwls1ls2) => Hnew_wls2.
    move: (mk_env_signextend_newer_gen Henv_wls2) => Hgwls1wls2.
    move: (newer_than_lit_le_newer Hgwls1tt Hgwls1wls2) => Hgwls2tt.
    move: (mk_env_mul_newer_res Henv_mul Hgwls2tt) => Hnew_gmulmul.
    move: (mk_env_mul_newer_gen Henv_mul) => Hgwls2mul.
    have Hgmultt: newer_than_lit g_mul lit_tt by t_newer_hook.
    move: (newer_than_lits_splitmsl Hgmultt Hnew_gmulmul) => /= /andP [Hnew_mul_tl Hnew_mul_n].
    move: (newer_than_lits_splitmsl Hgmultt Hnew_mul_tl) => /= /andP [_ Hnew_mul_n_minus1].
    move: (mk_env_xor1_newer_res Henv_xor1) => tmp.
    have Hnew_xor1xor1: newer_than_lit g_xor1 xor1 by apply tmp; t_newer_hook.
    move: (mk_env_xor1_newer_gen Henv_xor1) => Hgmulxor1.
    move: (pos_leb_trans Hgrecwls1 Hgwls1wls2) => Hgrecwls2.
    move: (pos_leb_trans Hgrecwls2 Hgwls2mul) => Hgrecmul.
    move: (pos_leb_trans Hgrecmul Hgmulxor1) => Hgrecxor1.
    move: (newer_than_lit_le_newer Hnew_rec_rec Hgrecxor1) => {tmp} tmp.
    exact: (mk_env_or1_newer_res Henv_or1 tmp Hnew_xor1xor1).
  Qed.

  Lemma mk_env_smulo_newer_cnf  E g ls1 ls2 E' g' cs lr:
    mk_env_smulo E g ls1 ls2 = (E', g', cs, lr) ->
    newer_than_lit g lit_tt ->
    newer_than_lits g ls1 ->
    newer_than_lits g ls2 ->
    newer_than_cnf g' cs.
  Proof.
    rewrite /mk_env_smulo .
    rewrite (lock mk_env_signextend) (lock mk_env_xor1) /= -2!lock.
    dcase (mk_env_xor E g (belastd ls1) (copy (size (belastd ls1)) (lastd lit_ff ls1)))
    => [[[ [ E_xls1 g_xls1 ]  cs_xls1] xls1] Henv_xls1].
    dcase (mk_env_xor E_xls1 g_xls1 (belastd ls2) (copy (size (belastd ls2)) (lastd lit_ff ls2)))
    => [[[[ E_xls2 g_xls2] cs_xls2] xls2] Henv_xls2].
    dcase (mk_env_smulo_rec E_xls2 g_xls2 (behead xls1) (behead xls2))
    => [[[[[ E_rec g_rec] cs_rec] r_or ] r_or_and_rec] Henv_rec].
    dcase (mk_env_signextend 1 E_rec g_rec ls1) => [[[[E_wls1 g_wls1] cs_wls1] wls1] Henv_wls1].
    dcase (mk_env_signextend 1 E_wls1 g_wls1 ls2) => [[[[E_wls2 g_wls2] cs_wls2] wls2] Henv_wls2].
    dcase (mk_env_mul E_wls2 g_wls2 wls1 wls2) => [[[[ E_mul g_mul ] cs_mul] mul] Henv_mul].
    dcase (mk_env_xor1 E_mul g_mul (lastd lit_ff mul) (lastd lit_ff (belastd mul)))
    => [[[[ E_xor1 g_xor1 ] cs_xor1] xor1] Henv_xor1].
    dcase (mk_env_or1 E_xor1 g_xor1 r_or_and_rec xor1) => [[[[ E_or1 g_or1 ] cs_or1] or1] Henv_or1].
    case=> _ <- <- _. move=> Hgtt Hgls1 Hgls2.
    move: (newer_than_lits_splitmsl Hgtt Hgls1) => /= /andP [Hgls1tl Hgls1sign].
    move: (newer_than_lits_copy (size (belastd ls1)) Hgls1sign) => Hgls1signs.
    move: (mk_env_xor_newer_res Henv_xls1 Hgtt Hgls1tl Hgls1signs) => Hnew_xls1.
    move: (mk_env_xor_newer_cnf Henv_xls1 Hgtt Hgls1tl Hgls1signs) => Hnewcnf_xls1.
    move: (newer_than_lits_splitmsl Hgtt Hgls2) => /= /andP [Hgls2tl Hgls2sign].
    move: (newer_than_lits_copy (size (belastd ls2)) Hgls2sign) => Hgls2signs.
    move: (mk_env_xor_newer_gen Henv_xls1) => Hgxls1.
    move: (newer_than_lits_le_newer Hgls2signs Hgxls1) => Hgx1ls2signs.
    move: (newer_than_lits_le_newer Hgls2tl Hgxls1) => Hgx1ls2tl.
    have Hgxls1tt: newer_than_lit g_xls1 lit_tt by t_newer_hook.
    move: (mk_env_xor_newer_res Henv_xls2 Hgxls1tt Hgx1ls2tl Hgx1ls2signs) => Hnew_xls2.
    move: (mk_env_xor_newer_cnf Henv_xls2 Hgxls1tt Hgx1ls2tl Hgx1ls2signs) => Hnewcnf_xls2.
    move: (mk_env_xor_newer_gen Henv_xls2) => Hgxls2.
    move: (newer_than_lits_le_newer Hnew_xls1 Hgxls2) => {Hnew_xls1} Hnew_xls1.
    have Hgxls2tt: newer_than_lit g_xls2 lit_tt by t_newer_hook.
    move: (newer_than_lits_splitlsl Hgxls2tt Hnew_xls1) => {Hnew_xls1} /= /andP [_ Hnew_xls1].
    move: (newer_than_lits_splitlsl Hgxls2tt Hnew_xls2) => {Hnew_xls2} /= /andP [_ Hnew_xls2].
    move: (newer_than_lit_le_newer Hgtt Hgxls1) => Hgx1tt.
    move: (newer_than_lit_le_newer Hgx1tt Hgxls2) => Hgx2tt.
    move: (newer_than_lits_le_newer Hgls1 Hgxls1) => Hgx1ls1.
    move: (newer_than_lits_le_newer Hgx1ls1 Hgxls2) => Hgx2ls1.
    move: (newer_than_lits_le_newer Hgls2 Hgxls1) => Hgx1ls2.
    move: (newer_than_lits_le_newer Hgx1ls2 Hgxls2) => Hgx2ls2.
    move: (mk_env_smulo_rec_newer_res Henv_rec Hgx2tt) => /andP [_ Hnew_rec_rec].
    move: (mk_env_smulo_rec_newer_cnf Henv_rec Hgx2tt Hnew_xls1 Hnew_xls2) => Hnewcnf_rec_rec.
    move: (mk_env_smulo_rec_newer_gen Henv_rec) => Hgx2grec.
    move: (newer_than_lit_le_newer Hgx2tt Hgx2grec) => Hgrectt.
    move: (newer_than_lits_le_newer Hgx2ls1 Hgx2grec) => Hgrecls1.
    move: (newer_than_lits_le_newer Hgx2ls2 Hgx2grec) => Hgrecls2.
    move: (mk_env_signextend_newer_res Henv_wls1 Hgrectt Hgrecls1) => Hnew_wls1.
    move: (mk_env_signextend_newer_cnf Henv_wls1 Hgrectt Hgrecls1) => Hnewcnf_wls1.
    move: (mk_env_signextend_newer_gen Henv_wls1) => Hgrecwls1.
    move: (newer_than_lit_le_newer Hgrectt Hgrecwls1) => Hgwls1tt.
    move: (newer_than_lits_le_newer Hgrecls2 Hgrecwls1) => Hgwls1ls2.
    move: (mk_env_signextend_newer_res Henv_wls2 Hgwls1tt Hgwls1ls2) => Hnew_wls2.
    move: (mk_env_signextend_newer_cnf Henv_wls2 Hgwls1tt Hgwls1ls2) => Hnewcnf_wls2.
    move: (mk_env_signextend_newer_gen Henv_wls2) => Hgwls1wls2.
    move: (newer_than_lit_le_newer Hgwls1tt Hgwls1wls2) => Hgwls2tt.
    move: (newer_than_lits_le_newer Hnew_wls1 Hgwls1wls2) => Hnew_wls2wls1.
    move: (mk_env_mul_newer_res Henv_mul Hgwls2tt) => Hnew_gmulmul.
    move: (mk_env_mul_newer_cnf Henv_mul Hgwls2tt Hnew_wls2wls1 Hnew_wls2) => Hnewcnf_gmulmul.
    move: (mk_env_xor1_newer_cnf Henv_xor1).
    move: (mk_env_xor1_newer_res Henv_xor1).
    move: (mk_env_mul_newer_gen Henv_mul) => Hgwls2mul.
    have Hgmultt: newer_than_lit g_mul lit_tt by t_newer_hook.
    move: (newer_than_lits_splitmsl Hgmultt Hnew_gmulmul) => /= /andP [Hnew_mul_tl Hnew_mul_n].
    move: (newer_than_lits_splitmsl Hgmultt Hnew_mul_tl) => /= /andP [_ Hnew_mul_n_minus1].
    move=> tmp tmp2. move: (tmp Hnew_mul_n Hnew_mul_n_minus1) => {tmp} Hnew_xor1xor1.
    move: (tmp2 Hnew_mul_n Hnew_mul_n_minus1) => {tmp2} Hnewcnf_xor1xor1.
    move: (mk_env_xor1_newer_gen Henv_xor1) => Hgmulxor1.
    move: (pos_leb_trans Hgrecwls1 Hgwls1wls2) => Hgrecwls2.
    move: (pos_leb_trans Hgrecwls2 Hgwls2mul) => Hgrecmul.
    move: (pos_leb_trans Hgrecmul Hgmulxor1) => Hgrecxor1.
    move: (newer_than_lit_le_newer Hnew_rec_rec Hgrecxor1) => tmp.
    move: (newer_than_lit_le_newer Hgrectt Hgrecxor1) => tmp2.
    move: (mk_env_or1_newer_res Henv_or1 tmp Hnew_xor1xor1) => Hnew_or1or1.
    move: (mk_env_or1_newer_cnf Henv_or1 tmp Hnew_xor1xor1) => Hnewcnf_or1or1.
    rewrite !newer_than_cnf_catrev.
    rewrite Hnewcnf_or1or1.
    move: (mk_env_or1_newer_gen Henv_or1) => Hgxor1or1.
    rewrite (newer_than_cnf_le_newer Hnewcnf_xor1xor1 Hgxor1or1).
    move: (pos_leb_trans Hgmulxor1 Hgxor1or1) => Hgmulor1.
    move: (pos_leb_trans Hgrecxor1 Hgxor1or1) => Hgrecor1.
    rewrite (newer_than_cnf_le_newer Hnewcnf_gmulmul Hgmulor1).
    rewrite (newer_than_cnf_le_newer Hnewcnf_rec_rec Hgrecor1).
    move: (pos_leb_trans Hgwls2mul Hgmulor1) => Hgwls2or1.
    rewrite (newer_than_cnf_le_newer Hnewcnf_wls2 Hgwls2or1).
    move: (pos_leb_trans Hgwls1wls2 Hgwls2or1) => Hgwls1or1.
    rewrite (newer_than_cnf_le_newer Hnewcnf_wls1 Hgwls1or1).
    move: (pos_leb_trans Hgx2grec Hgrecor1) => Hgx2or1.
    rewrite (newer_than_cnf_le_newer Hnewcnf_xls2 Hgx2or1).
    move: (pos_leb_trans Hgxls2 Hgx2or1) => Hgx1or1.
    rewrite (newer_than_cnf_le_newer Hnewcnf_xls1 Hgx1or1).
    done.
  Qed.

  Lemma mk_env_smulo_preserve E g ls1 ls2 E' g' cs lr:
    mk_env_smulo E g ls1 ls2 = (E', g', cs, lr) ->
    env_preserve E E' g.
  Proof.
    rewrite /mk_env_smulo .
    rewrite (lock mk_env_signextend) (lock mk_env_xor1) /= -2!lock.
    dcase (mk_env_xor E g (belastd ls1) (copy (size (belastd ls1)) (lastd lit_ff ls1)))
    => [[[ [ E_xls1 g_xls1 ]  cs_xls1] xls1] Henv_xls1].
    dcase (mk_env_xor E_xls1 g_xls1 (belastd ls2) (copy (size (belastd ls2)) (lastd lit_ff ls2)))
    => [[[[ E_xls2 g_xls2] cs_xls2] xls2] Henv_xls2].
    dcase (mk_env_smulo_rec E_xls2 g_xls2 (behead xls1) (behead xls2))
    => [[[[[ E_rec g_rec] cs_rec] r_or ] r_or_and_rec] Henv_rec].
    dcase (mk_env_signextend 1 E_rec g_rec ls1) => [[[[E_wls1 g_wls1] cs_wls1] wls1] Henv_wls1].
    dcase (mk_env_signextend 1 E_wls1 g_wls1 ls2) => [[[[E_wls2 g_wls2] cs_wls2] wls2] Henv_wls2].
    dcase (mk_env_mul E_wls2 g_wls2 wls1 wls2) => [[[[ E_mul g_mul ] cs_mul] mul] Henv_mul].
    dcase (mk_env_xor1 E_mul g_mul (lastd lit_ff mul) (lastd lit_ff (belastd mul)))
    => [[[[ E_xor1 g_xor1 ] cs_xor1] xor1] Henv_xor1].
    dcase (mk_env_or1 E_xor1 g_xor1 r_or_and_rec xor1) => [[[[ E_or1 g_or1 ] cs_or1] or1] Henv_or1].
    case=> <- _ _ _.
    move: (mk_env_xor_preserve Henv_xls1) => Hpre_xls1.
    apply (env_preserve_trans Hpre_xls1).
    move: (mk_env_xor_newer_gen Henv_xls1) => Hng_xls1.
    move: (mk_env_xor_preserve Henv_xls2) => Hpre_xls2.
    move: (mk_env_xor_newer_gen Henv_xls2) => Hng_xls2.
    move: (pos_leb_trans Hng_xls1 Hng_xls2) => Hgxls2.
    move: (env_preserve_le Hpre_xls2 Hng_xls1) => {Hpre_xls2} Hpre_xls2.
    apply (env_preserve_trans Hpre_xls2).
    move: (mk_env_smulo_rec_preserve Henv_rec) => Hpre_rec.
    move: (mk_env_smulo_rec_newer_gen Henv_rec) => Hng_rec.
    move: (pos_leb_trans Hgxls2 Hng_rec) => Hgrec.
    move: (env_preserve_le Hpre_rec Hgxls2) => {Hpre_rec} Hpre_rec.
    apply (env_preserve_trans Hpre_rec).
    move: (mk_env_signextend_preserve Henv_wls1) => Hpre_wls1.
    move: (mk_env_signextend_newer_gen Henv_wls1) => Hng_wls1.
    move: (pos_leb_trans Hgrec Hng_wls1) => Hgwls1.
    move: (env_preserve_le Hpre_wls1 Hgrec) => {Hpre_wls1} Hpre_wls1.
    apply (env_preserve_trans Hpre_wls1).
    move: (mk_env_signextend_preserve Henv_wls2) => Hpre_wls2.
    move: (mk_env_signextend_newer_gen Henv_wls2) => Hng_wls2.
    move: (pos_leb_trans Hgwls1 Hng_wls2) => Hgwls2.
    move: (env_preserve_le Hpre_wls2 Hgwls1) => {Hpre_wls2} Hpre_wls2.
    apply (env_preserve_trans Hpre_wls2).
    move: (mk_env_mul_preserve Henv_mul) => Hpre_mul.
    move: (mk_env_mul_newer_gen Henv_mul) => Hng_mul.
    move: (pos_leb_trans Hgwls2 Hng_mul) => Hgmul.
    move: (env_preserve_le Hpre_mul Hgwls2) => {Hpre_mul} Hpre_mul.
    apply (env_preserve_trans Hpre_mul).
    move: (mk_env_xor1_preserve Henv_xor1) => Hpre_xor1.
    move: (mk_env_xor1_newer_gen Henv_xor1) => Hng_xor1.
    move: (pos_leb_trans Hgmul Hng_xor1) => Hgxor1.
    move: (env_preserve_le Hpre_xor1 Hgmul) => {Hpre_xor1} Hpre_xor1.
    apply (env_preserve_trans Hpre_xor1).
    move: (mk_env_or1_preserve Henv_or1) => Hpre_or1.
    move: (mk_env_or1_newer_gen Henv_or1) => Hng_or1.
    move: (pos_leb_trans Hgxor1 Hng_or1) => Hgor1.
    move: (env_preserve_le Hpre_or1 Hgxor1) => {Hpre_or1} Hpre_or1.
    apply (env_preserve_trans Hpre_or1).
    exact: env_preserve_refl.
  Qed.

  Lemma mk_env_smulo_sat E g ls1 ls2 E' g' cs lr:
    mk_env_smulo E g ls1 ls2 = (E', g', cs, lr) ->
    newer_than_lit g lit_tt ->
    newer_than_lits g ls1 ->  newer_than_lits g ls2 ->
    interp_cnf E' cs.
  Proof.
    rewrite /mk_env_smulo .
    rewrite (lock mk_env_signextend) (lock mk_env_xor1) /= -2!lock.
    dcase (mk_env_xor E g (belastd ls1) (copy (size (belastd ls1)) (lastd lit_ff ls1)))
    => [[[ [ E_xls1 g_xls1 ]  cs_xls1] xls1] Henv_xls1].
    dcase (mk_env_xor E_xls1 g_xls1 (belastd ls2) (copy (size (belastd ls2)) (lastd lit_ff ls2)))
    => [[[[ E_xls2 g_xls2] cs_xls2] xls2] Henv_xls2].
    dcase (mk_env_smulo_rec E_xls2 g_xls2 (behead xls1) (behead xls2))
    => [[[[[ E_rec g_rec] cs_rec] r_or ] r_or_and_rec] Henv_rec].
    dcase (mk_env_signextend 1 E_rec g_rec ls1) => [[[[E_wls1 g_wls1] cs_wls1] wls1] Henv_wls1].
    dcase (mk_env_signextend 1 E_wls1 g_wls1 ls2) => [[[[E_wls2 g_wls2] cs_wls2] wls2] Henv_wls2].
    dcase (mk_env_mul E_wls2 g_wls2 wls1 wls2) => [[[[ E_mul g_mul ] cs_mul] mul] Henv_mul].
    dcase (mk_env_xor1 E_mul g_mul (lastd lit_ff mul) (lastd lit_ff (belastd mul)))
    => [[[[ E_xor1 g_xor1 ] cs_xor1] xor1] Henv_xor1].
    dcase (mk_env_or1 E_xor1 g_xor1 r_or_and_rec xor1) => [[[[ E_or1 g_or1 ] cs_or1] or1] Henv_or1].
    case=> <- _ <- _. move=> Hgtt Hgls1 Hgls2.
    move: (newer_than_lits_splitmsl Hgtt Hgls1) => /= /andP [Hgls1tl Hgls1sign].
    move: (newer_than_lits_copy (size (belastd ls1)) Hgls1sign) => Hgls1signs.
    move: (mk_env_xor_newer_res Henv_xls1 Hgtt Hgls1tl Hgls1signs) => Hnew_xls1.
    move: (mk_env_xor_newer_cnf Henv_xls1 Hgtt Hgls1tl Hgls1signs) => Hnewcnf_xls1.
    move: (mk_env_xor_sat Henv_xls1 Hgtt Hgls1tl Hgls1signs) => Hsat_xls1.
    move: (mk_env_xor_preserve Henv_xls1) => Hpre_xls1.
    move: (newer_than_lits_splitmsl Hgtt Hgls2) => /= /andP [Hgls2tl Hgls2sign].
    move: (newer_than_lits_copy (size (belastd ls2)) Hgls2sign) => Hgls2signs.
    move: (mk_env_xor_newer_gen Henv_xls1) => Hgxls1.
    move: (newer_than_lits_le_newer Hgls2signs Hgxls1) => Hgx1ls2signs.
    move: (newer_than_lits_le_newer Hgls2tl Hgxls1) => Hgx1ls2tl.
    have Hgxls1tt: newer_than_lit g_xls1 lit_tt by t_newer_hook.
    move: (mk_env_xor_newer_res Henv_xls2 Hgxls1tt Hgx1ls2tl Hgx1ls2signs) => Hnew_xls2.
    move: (mk_env_xor_newer_cnf Henv_xls2 Hgxls1tt Hgx1ls2tl Hgx1ls2signs) => Hnewcnf_xls2.
    move: (mk_env_xor_newer_gen Henv_xls2) => Hgxls2.
    move: (mk_env_xor_sat Henv_xls2 Hgxls1tt Hgx1ls2tl Hgx1ls2signs) => Hsat_xls2.
    move: (mk_env_xor_preserve Henv_xls2) => Hpre_xls2.
    move: (newer_than_lits_le_newer Hnew_xls1 Hgxls2) => {Hnew_xls1} Hnew_xls1.
    have Hgxls2tt: newer_than_lit g_xls2 lit_tt by t_newer_hook.
    move: (newer_than_lits_splitlsl Hgxls2tt Hnew_xls1) => {Hnew_xls1} /= /andP [_ Hnew_xls1].
    move: (newer_than_lits_splitlsl Hgxls2tt Hnew_xls2) => {Hnew_xls2} /= /andP [_ Hnew_xls2].
    move: (newer_than_lit_le_newer Hgtt Hgxls1) => Hgx1tt.
    move: (newer_than_lit_le_newer Hgx1tt Hgxls2) => Hgx2tt.
    move: (newer_than_lits_le_newer Hgls1 Hgxls1) => Hgx1ls1.
    move: (newer_than_lits_le_newer Hgx1ls1 Hgxls2) => Hgx2ls1.
    move: (newer_than_lits_le_newer Hgls2 Hgxls1) => Hgx1ls2.
    move: (newer_than_lits_le_newer Hgx1ls2 Hgxls2) => Hgx2ls2.
    move: (mk_env_smulo_rec_newer_res Henv_rec Hgx2tt) => /andP [_ Hnew_rec_rec].
    move: (mk_env_smulo_rec_newer_cnf Henv_rec Hgx2tt Hnew_xls1 Hnew_xls2) => Hnewcnf_rec_rec.
    move: (mk_env_smulo_rec_sat Henv_rec Hgx2tt Hnew_xls1 Hnew_xls2) => Hsat_rec_rec.
    move: (mk_env_smulo_rec_preserve Henv_rec) => Hpre_rec.
    move: (mk_env_smulo_rec_newer_gen Henv_rec) => Hgx2grec.
    move: (newer_than_lit_le_newer Hgx2tt Hgx2grec) => Hgrectt.
    move: (newer_than_lits_le_newer Hgx2ls1 Hgx2grec) => Hgrecls1.
    move: (newer_than_lits_le_newer Hgx2ls2 Hgx2grec) => Hgrecls2.
    move: (mk_env_signextend_newer_res Henv_wls1 Hgrectt Hgrecls1) => Hnew_wls1.
    move: (mk_env_signextend_newer_cnf Henv_wls1 Hgrectt Hgrecls1) => Hnewcnf_wls1.
    move: (mk_env_signextend_sat Henv_wls1 Hgrectt Hgrecls1) => Hsat_wls1.
    move: (mk_env_signextend_preserve Henv_wls1) => Hpre_wls1.
    move: (mk_env_signextend_newer_gen Henv_wls1) => Hgrecwls1.
    move: (newer_than_lit_le_newer Hgrectt Hgrecwls1) => Hgwls1tt.
    move: (newer_than_lits_le_newer Hgrecls2 Hgrecwls1) => Hgwls1ls2.
    move: (mk_env_signextend_newer_res Henv_wls2 Hgwls1tt Hgwls1ls2) => Hnew_wls2.
    move: (mk_env_signextend_newer_cnf Henv_wls2 Hgwls1tt Hgwls1ls2) => Hnewcnf_wls2.
    move: (mk_env_signextend_sat Henv_wls2 Hgwls1tt Hgwls1ls2) => Hsat_wls2.
    move: (mk_env_signextend_preserve Henv_wls2) => Hpre_wls2.
    move: (mk_env_signextend_newer_gen Henv_wls2) => Hgwls1wls2.
    move: (newer_than_lit_le_newer Hgwls1tt Hgwls1wls2) => Hgwls2tt.
    move: (newer_than_lits_le_newer Hnew_wls1 Hgwls1wls2) => Hnew_wls2wls1.
    move: (mk_env_mul_newer_res Henv_mul Hgwls2tt) => Hnew_gmulmul.
    move: (mk_env_mul_newer_cnf Henv_mul Hgwls2tt Hnew_wls2wls1 Hnew_wls2) => Hnewcnf_gmulmul.
    move: (mk_env_mul_sat Henv_mul Hgwls2tt Hnew_wls2wls1 Hnew_wls2) => Hsat_gmulmul.
    move: (mk_env_mul_preserve Henv_mul) => Hpre_mul.
    move: (mk_env_xor1_sat Henv_xor1).
    move: (mk_env_xor1_newer_cnf Henv_xor1).
    move: (mk_env_xor1_newer_res Henv_xor1).
    move: (mk_env_xor1_preserve Henv_xor1) => Hpre_xor1.
    move: (mk_env_mul_newer_gen Henv_mul) => Hgwls2mul.
    have Hgmultt: newer_than_lit g_mul lit_tt by t_newer_hook.
    move: (newer_than_lits_splitmsl Hgmultt Hnew_gmulmul) => /= /andP [Hnew_mul_tl Hnew_mul_n].
    move: (newer_than_lits_splitmsl Hgmultt Hnew_mul_tl) => /= /andP [_ Hnew_mul_n_minus1].
    move=> tmp tmp2 tmp3.
    move: (tmp Hnew_mul_n Hnew_mul_n_minus1) => {tmp} Hnew_xor1xor1.
    move: (tmp2 Hnew_mul_n Hnew_mul_n_minus1) => {tmp2} Hnewcnf_xor1xor1.
    move: (tmp3 Hnew_mul_n Hnew_mul_n_minus1) => {tmp3} Hsat_xor1xor1.
    move: (mk_env_xor1_newer_gen Henv_xor1) => Hgmulxor1.
    move: (pos_leb_trans Hgrecwls1 Hgwls1wls2) => Hgrecwls2.
    move: (pos_leb_trans Hgrecwls2 Hgwls2mul) => Hgrecmul.
    move: (pos_leb_trans Hgrecmul Hgmulxor1) => Hgrecxor1.
    move: (newer_than_lit_le_newer Hnew_rec_rec Hgrecxor1) => tmp.
    move: (newer_than_lit_le_newer Hgrectt Hgrecxor1) => tmp2.
    move: (mk_env_or1_newer_res Henv_or1 tmp Hnew_xor1xor1) => Hnew_or1or1.
    move: (mk_env_or1_newer_cnf Henv_or1 tmp Hnew_xor1xor1) => Hnewcnf_or1or1.
    move: (mk_env_or1_sat Henv_or1 tmp Hnew_xor1xor1) => Hsat_or1or1.
    move: (mk_env_or1_preserve Henv_or1) => Hpre_or1.
    rewrite !interp_cnf_catrev.
    rewrite Hsat_or1or1.
    rewrite (env_preserve_cnf Hpre_or1 Hnewcnf_xor1xor1).
    rewrite Hsat_xor1xor1.
    move: (newer_than_cnf_le_newer Hnewcnf_gmulmul Hgmulxor1) => H.
    rewrite (env_preserve_cnf Hpre_or1 H).
    rewrite (env_preserve_cnf Hpre_xor1 Hnewcnf_gmulmul).
    rewrite (Hsat_gmulmul) => {H}.
    move: (newer_than_cnf_le_newer Hnewcnf_wls2 Hgwls2mul) => H.
    move: (newer_than_cnf_le_newer H Hgmulxor1) => H1.
    rewrite (env_preserve_cnf Hpre_or1 H1).
    rewrite (env_preserve_cnf Hpre_xor1 H).
    rewrite (env_preserve_cnf Hpre_mul Hnewcnf_wls2).
    rewrite (Hsat_wls2) => {H H1}.
    move: (newer_than_cnf_le_newer Hnewcnf_wls1 Hgwls1wls2) => H.
    move: (newer_than_cnf_le_newer H Hgwls2mul) => H1.
    move: (newer_than_cnf_le_newer H1 Hgmulxor1) => H2.
    rewrite (env_preserve_cnf Hpre_or1 H2).
    rewrite (env_preserve_cnf Hpre_xor1 H1).
    rewrite (env_preserve_cnf Hpre_mul H).
    rewrite (env_preserve_cnf Hpre_wls2 Hnewcnf_wls1).
    rewrite (Hsat_wls1) => {H H1 H2}.
    move: (newer_than_cnf_le_newer Hnewcnf_rec_rec Hgrecwls1) => H.
    move: (newer_than_cnf_le_newer H Hgwls1wls2) => H1.
    move: (newer_than_cnf_le_newer H1 Hgwls2mul) => H2.
    move: (newer_than_cnf_le_newer H2 Hgmulxor1) => H3.
    rewrite (env_preserve_cnf Hpre_or1 H3).
    rewrite (env_preserve_cnf Hpre_xor1 H2).
    rewrite (env_preserve_cnf Hpre_mul H1).
    rewrite (env_preserve_cnf Hpre_wls2 H).
    rewrite (env_preserve_cnf Hpre_wls1 Hnewcnf_rec_rec).
    rewrite (Hsat_rec_rec) => {H H1 H2 H3}.
    move: (newer_than_cnf_le_newer Hnewcnf_xls2 Hgx2grec) => H.
    move: (newer_than_cnf_le_newer H Hgrecwls1) => H1.
    move: (newer_than_cnf_le_newer H1 Hgwls1wls2) => H2.
    move: (newer_than_cnf_le_newer H2 Hgwls2mul) => H3.
    move: (newer_than_cnf_le_newer H3 Hgmulxor1) => H4.
    rewrite (env_preserve_cnf Hpre_or1 H4).
    rewrite (env_preserve_cnf Hpre_xor1 H3).
    rewrite (env_preserve_cnf Hpre_mul H2).
    rewrite (env_preserve_cnf Hpre_wls2 H1).
    rewrite (env_preserve_cnf Hpre_wls1 H).
    rewrite (env_preserve_cnf Hpre_rec Hnewcnf_xls2).
    rewrite (Hsat_xls2) => {H H1 H2 H3 H4}.
    move: (newer_than_cnf_le_newer Hnewcnf_xls1 Hgxls2) => H.
    move: (newer_than_cnf_le_newer H Hgx2grec) => H1.
    move: (newer_than_cnf_le_newer H1 Hgrecwls1) => H2.
    move: (newer_than_cnf_le_newer H2 Hgwls1wls2) => H3.
    move: (newer_than_cnf_le_newer H3 Hgwls2mul) => H4.
    move: (newer_than_cnf_le_newer H4 Hgmulxor1) => H5.
    rewrite (env_preserve_cnf Hpre_or1 H5).
    rewrite (env_preserve_cnf Hpre_xor1 H4).
    rewrite (env_preserve_cnf Hpre_mul H3).
    rewrite (env_preserve_cnf Hpre_wls2 H2).
    rewrite (env_preserve_cnf Hpre_wls1 H1).
    rewrite (env_preserve_cnf Hpre_rec H).
    rewrite (env_preserve_cnf Hpre_xls2 Hnewcnf_xls1).
    rewrite (Hsat_xls1) => {H H1 H2 H3 H4 H5}.
    done.
  Qed.
End BBSmulo.

Lemma mk_env_smulo_env_equal E1 E2 g ls1 ls2 E1' E2' g1' g2' cs1 cs2 lr1 lr2 :
  env_equal E1 E2 ->
  mk_env_smulo E1 g ls1 ls2 = (E1', g1', cs1, lr1) ->
  mk_env_smulo E2 g ls1 ls2 = (E2', g2', cs2, lr2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lr1 = lr2.
Proof.
  rewrite /mk_env_smulo => Heq.
  dcase (mk_env_xor
           E1 g (fst (splitmsl ls1)) (copy (size (fst (splitmsl ls1))) (snd (splitmsl ls1))))
  => [[[[E_xls1 g_xls1] cs_xls1] xls1] Hxls1].
  dcase (mk_env_xor
           E2 g (fst (splitmsl ls1)) (copy (size (fst (splitmsl ls1))) (snd (splitmsl ls1))))
  => [[[[E_xls2 g_xls2] cs_xls2] xls2] Hxls2].
  move: (mk_env_xor_env_equal Heq Hxls1 Hxls2) => {Heq Hxls1 Hxls2} [Heq [? [? ?]]]; subst.
  dcase (mk_env_xor E_xls1 g_xls2 (fst (splitmsl ls2))
                    (copy (size (fst (splitmsl ls2))) (snd (splitmsl ls2))))
  => [[[[E_xls3 g_xls3] cs_xls3] xls3] Hxls3].
  dcase (mk_env_xor E_xls2 g_xls2 (fst (splitmsl ls2))
                    (copy (size (fst (splitmsl ls2))) (snd (splitmsl ls2))))
  => [[[[E_xls4 g_xls4] cs_xls4] xls4] Hxls4].
  move: (mk_env_xor_env_equal Heq Hxls3 Hxls4) => {Heq Hxls3 Hxls4} [Heq [? [? ?]]]; subst.
  dcase (mk_env_smulo_rec E_xls3 g_xls4 (snd (splitlsl xls2)) (snd (splitlsl xls4)))
  => [[[[[E_rec1 g_rec1] cs_rec1] lrs_rec1] lrsao_rec1] Hrec1].
  dcase (mk_env_smulo_rec E_xls4 g_xls4 (snd (splitlsl xls2)) (snd (splitlsl xls4)))
  => [[[[[E_rec2 g_rec2] cs_rec2] lrs_rec2] lrsao_rec2] Hrec2].
  move: (mk_env_umulo_rec_zip_env_equal Heq Hrec1 Hrec2)
  => {Heq Hrec1 Hrec2} [Heq [? [? [? ?]]]]; subst.
  dcase (mk_env_signextend 1 E_rec1 g_rec2 ls1) => [[[[E_wls1 g_wls1] cs_wls1] lrs_wls1] Hwls1].
  dcase (mk_env_signextend 1 E_rec2 g_rec2 ls1) => [[[[E_wls2 g_wls2] cs_wls2] lrs_wls2] Hwls2].
  move: (mk_env_signextend_env_equal Heq Hwls1 Hwls2) => {Heq Hwls1 Hwls2} [Heq [? [? ?]]]; subst.
  dcase (mk_env_signextend 1 E_wls1 g_wls2 ls2) => [[[[E_wls3 g_wls3] cs_wls3] lrs_wls3] Hwls3].
  dcase (mk_env_signextend 1 E_wls2 g_wls2 ls2) => [[[[E_wls4 g_wls4] cs_wls4] lrs_wls4] Hwls4].
  move: (mk_env_signextend_env_equal Heq Hwls3 Hwls4) => {Heq Hwls3 Hwls4} [Heq [? [? ?]]]; subst.
  dcase (mk_env_mul E_wls3 g_wls4 lrs_wls2 lrs_wls4)
  => [[[[E_mul1 g_mul1] cs_mul1] lrs_mul1] Hmul1].
  dcase (mk_env_mul E_wls4 g_wls4 lrs_wls2 lrs_wls4)
  => [[[[E_mul2 g_mul2] cs_mul2] lrs_mul2] Hmul2].
  move: (mk_env_mul_env_equal Heq Hmul1 Hmul2) => {Heq Hmul1 Hmul2} [Heq [? [? ?]]]; subst.
  dcase (mk_env_xor1 E_mul1 g_mul2 (snd (splitmsl lrs_mul2))
                     (snd (splitmsl (fst (splitmsl lrs_mul2)))))
  => [[[[E_xor1 g_xor1] cs_xor1] lrs_xor1] Hxor1].
  dcase (mk_env_xor1 E_mul2 g_mul2 (snd (splitmsl lrs_mul2))
                     (snd (splitmsl (fst (splitmsl lrs_mul2)))))
  => [[[[E_xor2 g_xor2] cs_xor2] lrs_xor2] Hxor2].
  move: (mk_env_xor1_env_equal Heq Hxor1 Hxor2) => {Heq Hxor1 Hxor2} [Heq [? [? ?]]]; subst.
  dcase (mk_env_or1 E_xor1 g_xor2 lrsao_rec2 lrs_xor2) => [[[[E_or1 g_or1] cs_or1] lrs_or1] Hor1].
  dcase (mk_env_or1 E_xor2 g_xor2 lrsao_rec2 lrs_xor2) => [[[[E_or2 g_or2] cs_or2] lrs_or2] Hor2].
  move: (mk_env_or1_env_equal Heq Hor1 Hor2) => {Heq Hor1 Hor2} [Heq [? [? ?]]]; subst.
  case=> ? ? ? ?; case=> ? ? ? ?; subst. repeat split. assumption.
Qed.


(* Type constructors are split into several groups depending on how
   many arguments need to be applied for the overall type to be
   well formed. We keep primitive types like Read, Write and Ref fully
   applied to make the mechanisation easier. In the full language the
   ability to partially apply these could be recovered using
   type synonyms. *)
Require Export Iron.Language.SystemF2Effect.Kind.

(********************************************************************)
(* Type Constructors. *)
Inductive tycon0 : Type :=
 | TyConFun    : tycon0
 | TyConUnit   : tycon0
 | TyConBool   : tycon0
 | TyConNat    : tycon0.
Hint Constructors tycon0.

Fixpoint kindOfTyCon0 (tc : tycon0) :=
 match tc with
 | TyConFun     => KFun KData (KFun KEffect (KFun KData KData))
 | TyConUnit    => KData
 | TyConBool    => KData
 | TyConNat     => KData
 end.

Fixpoint tycon0_beq tc1 tc2 :=
 match tc1, tc2 with
 | TyConFun,    TyConFun    => true
 | TyConUnit,   TyConUnit   => true
 | TyConBool,   TyConBool   => true
 | TyConNat,    TyConNat    => true
 | _,           _           => false
 end.

(********************************************************************)
(* Type constructors with at least one applied argument. *)
Inductive tycon1 : Type :=
 | TyConRead   : tycon1
 | TyConWrite  : tycon1
 | TyConAlloc  : tycon1.

Fixpoint kindOfTyCon1 (tc : tycon1) :=
 match tc with
 | TyConRead    => KFun KRegion KEffect
 | TyConWrite   => KFun KRegion KEffect
 | TyConAlloc   => KFun KRegion KEffect
 end.

Fixpoint tycon1_beq tc1 tc2 :=
 match tc1, tc2 with
 | TyConRead,   TyConRead   => true
 | TyConWrite,  TyConWrite  => true
 | TyConAlloc,  TyConAlloc  => true
 | _,           _           => false
 end.

Definition isEffectTyCon_b (tc : tycon1) :=
 match tc with
 | TyConRead     => true
 | TyConWrite    => true
 | TyConAlloc    => true
 end.

(********************************************************************)
(* Type constructors with at least two applied arguments. *)
Inductive tycon2 : Type :=
 | TyConRef    : tycon2.
Hint Constructors tycon2.

Fixpoint kindOfTyCon2 (tc : tycon2) :=
 match tc with
 | TyConRef      => KFun KRegion (KFun KData KData)
 end.

Fixpoint tycon2_beq tc1 tc2 :=
 match tc1, tc2 with
 | TyConRef,     TyConRef  => true
 end.


Require Import Leapfrog.Benchmarks.ProofHeader.
Require Import Leapfrog.Benchmarks.MPLSVectorized.

Lemma prebisim_mpls_vect_unroll:
  pre_bisimulation MPLSVectUnroll.aut
                   (WPSymLeap.wp (H:=_))
                   (separated _ _ _ _)
                   nil
                   (mk_init 10 MPLSVectUnroll.aut MPLSPlain.ParseMPLS MPLSInline.ParseMPLS)
                   (inl (inl MPLSPlain.ParseMPLS), [], [])
                   (inl (inr MPLSInline.ParseMPLS), [], []).
Proof.
  set (rel0 := mk_init 10 MPLSVectUnroll.aut MPLSPlain.ParseMPLS MPLSInline.ParseMPLS).
  cbv in rel0.
  subst rel0.
  time (repeat (time solve_bisim)).
  cbv in *.
  intuition (try congruence).
Time Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O B C Bprime Cprime X Y C0 : Universe, ((wd_ Cprime O /\ (wd_ Bprime O /\ (wd_ B O /\ (wd_ B C /\ (wd_ C O /\ (wd_ X Y /\ (wd_ B Cprime /\ (wd_ Y C /\ (wd_ X C /\ (wd_ Y B /\ (wd_ X B /\ (wd_ B Bprime /\ (wd_ C C0 /\ (wd_ C Bprime /\ (wd_ Cprime C /\ (wd_ Cprime Bprime /\ (col_ O Bprime Cprime /\ (col_ B O C /\ (col_ O X Y /\ (col_ X Y C0 /\ (col_ B B Cprime /\ col_ O B Cprime))))))))))))))))))))) -> col_ O B Bprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import funs.
Require Import dataset.
Require Import ssrnat.
Require Import seq.
Require Import paths.
Require Import finset.
Require Import connect.
Require Import hypermap.
Require Import geometry.
Require Import color.
Require Import coloring.
Require Import cube.
Require Import present.
Require Import unavoidability.
Require Import reducibility.

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

Theorem four_color_hypermap : forall g, planar_bridgeless g -> four_colorable g.
Proof.
move=> g Hg; apply cube_colorable.
have Hqg: planar_bridgeless_plain_precubic (cube g).
  split; last by apply cubic_precubic; exact: cubic_cube.
  split; last exact: plain_cube.
  split; [rewrite planar_cube | rewrite bridgeless_cube]; exact Hg.
pose n := S (card (cube g)); move: Hqg (leqnn n); rewrite {1}/n.
elim: {g Hg}n (cube g) => // n Hrec g Hg Hgn.
rewrite ltnS leq_eqVlt in Hgn; case/orP: Hgn; auto.
move/eqP=> Dn; rewrite -{n}Dn in Hrec.
case: (decide_colorable g) => Hkg; first done.
case: (@unavoidability the_reducibility g); split; auto.
Qed.

Set Strict Implicit.
Unset Implicit Arguments.


(**********************************************************************************

 The comma category

 Contents
 1. Definition via two-sided displayed categories
 2. Discreteness and univalence
 3. It is a two-sided fibration
 4. The representable profunctors

 **********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedFibration.

Local Open Scope cat.

Section CommaTwoSidedDispCat.
  Context {C₁ C₂ C₃ : category}
          (F : C₁ ⟶ C₃)
          (G : C₂ ⟶ C₃).

  (**
   1. Definition via two-sided displayed categories
   *)
  Definition comma_twosided_disp_cat_ob_mor
    : twosided_disp_cat_ob_mor C₁ C₂.
  Proof.
    simple refine (_ ,, _).
    - exact (λ x y, F x --> G y).
    - exact (λ x₁ x₂ y₁ y₂ h₁ h₂ f g, #F f · h₂ = h₁ · #G g).
  Defined.

  Definition comma_twosided_disp_cat_id_comp
    : twosided_disp_cat_id_comp comma_twosided_disp_cat_ob_mor.
  Proof.
    split.
    - intros x y xy ; cbn.
      rewrite !functor_id.
      rewrite id_left, id_right.
      apply idpath.
    - intros x₁ x₂ x₃ y₁ y₂ y₃ h₁ h₂ h₃ f₁ f₂ g₁ g₂ hh₁ hh₂ ; cbn in *.
      rewrite !functor_comp.
      rewrite !assoc'.
      rewrite hh₂.
      rewrite !assoc.
      apply maponpaths_2.
      exact hh₁.
  Qed.

  Definition comma_twosided_disp_cat_data
    : twosided_disp_cat_data C₁ C₂.
  Proof.
    simple refine (_ ,, _).
    - exact comma_twosided_disp_cat_ob_mor.
    - exact comma_twosided_disp_cat_id_comp.
  Defined.

  Definition isaprop_comma_twosided_mor
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             (xy₁ : comma_twosided_disp_cat_data x₁ y₁)
             (xy₂ : comma_twosided_disp_cat_data x₂ y₂)
             (f : x₁ --> x₂)
             (g : y₁ --> y₂)
    : isaprop (xy₁ -->[ f ][ g ] xy₂).
  Proof.
    apply homset_property.
  Qed.

  Definition comma_twosided_disp_cat_axioms
    : twosided_disp_cat_axioms comma_twosided_disp_cat_data.
  Proof.
    repeat split.
    - intro ; intros.
      apply isaprop_comma_twosided_mor.
    - intro ; intros.
      apply isaprop_comma_twosided_mor.
    - intro ; intros.
      apply isaprop_comma_twosided_mor.
    - intro ; intros.
      apply isasetaprop.
      apply isaprop_comma_twosided_mor.
  Qed.

  Definition comma_twosided_disp_cat
    : twosided_disp_cat C₁ C₂.
  Proof.
    simple refine (_ ,, _).
    - exact comma_twosided_disp_cat_data.
    - exact comma_twosided_disp_cat_axioms.
  Defined.

  (**
   2. Discreteness and univalence
   *)
  Definition comma_twosided_disp_cat_is_iso
    : all_disp_mor_iso comma_twosided_disp_cat.
  Proof.
    intro ; intros.
    simple refine (_ ,, _ ,, _) ; cbn in *.
    - rewrite !functor_on_inv_from_z_iso.
      use z_iso_inv_on_right.
      rewrite assoc.
      use z_iso_inv_on_left ; cbn.
      exact fg.
    - apply isaprop_comma_twosided_mor.
    - apply isaprop_comma_twosided_mor.
  Qed.

  Definition is_univalent_comma_twosided_disp_cat
    : is_univalent_twosided_disp_cat comma_twosided_disp_cat.
  Proof.
    intros x₁ x₂ y₁ y₂ p₁ p₂ xy₁ xy₂.
    induction p₁, p₂ ; cbn.
    use isweqimplimpl.
    - intros f.
      pose (p := pr1 f) ; cbn in p.
      rewrite !functor_id in p.
      rewrite id_left, id_right in p.
      exact (!p).
    - apply homset_property.
    - use isaproptotal2.
      + intro.
        apply isaprop_is_iso_twosided_disp.
      + intros.
        apply homset_property.
  Qed.

  Definition discrete_comma_twosided_disp_cat
    : discrete_twosided_disp_cat comma_twosided_disp_cat.
  Proof.
    repeat split.
    - intro ; intros.
      apply homset_property.
    - exact comma_twosided_disp_cat_is_iso.
    - exact is_univalent_comma_twosided_disp_cat.
  Qed.

  (**
   3. It is a two-sided fibration
   *)
  Definition comma_twosided_opcleaving
    : twosided_opcleaving comma_twosided_disp_cat.
  Proof.
    intros x₁ x₂ x₃ f g ; cbn in *.
    simple refine (f · #G g ,, _ ,, _) ; cbn.
    - rewrite functor_id.
      rewrite id_left.
      apply idpath.
    - intros x₄ x₅ h k l p.
      use iscontraprop1.
      + use invproofirrelevance.
        intros φ₁ φ₂.
        use subtypePath.
        {
          intro.
          apply isaset_disp_mor.
        }
        apply isaprop_comma_twosided_mor.
      + cbn in *.
        simple refine (_ ,, _).
        * rewrite id_left, functor_comp, assoc in p.
          exact p.
        * apply isaprop_comma_twosided_mor.
  Qed.

  Definition comma_twosided_cleaving
    : twosided_cleaving comma_twosided_disp_cat.
  Proof.
    intros x₁ x₂ x₃ f g ; cbn in *.
    simple refine (#F g · f ,, _ ,, _) ; cbn.
    - rewrite functor_id.
      rewrite id_right.
      apply idpath.
    - intros x₄ x₅ h k l p.
      use iscontraprop1.
      + use invproofirrelevance.
        intros φ₁ φ₂.
        use subtypePath.
        {
          intro.
          apply isaset_disp_mor.
        }
        apply isaprop_comma_twosided_mor.
      + cbn in *.
        simple refine (_ ,, _).
        * rewrite id_right, functor_comp, assoc' in p.
          exact p.
        * apply isaprop_comma_twosided_mor.
  Qed.

  Definition comma_twosided_fibration
    : twosided_fibration comma_twosided_disp_cat.
  Proof.
    simple refine (_ ,, _ ,, _).
    - exact comma_twosided_opcleaving.
    - exact comma_twosided_cleaving.
    - intro ; intros.
      apply comma_twosided_disp_cat_is_iso.
  Defined.
End CommaTwoSidedDispCat.

(**
 4. The representable profunctors
 *)
Definition left_repr_twosided_disp_cat
           {C₁ C₂ : category}
           (F : C₁ ⟶ C₂)
  : twosided_disp_cat C₁ C₂
  := comma_twosided_disp_cat F (functor_identity _).

Definition right_repr_twosided_disp_cat
           {C₁ C₂ : category}
           (F : C₁ ⟶ C₂)
  : twosided_disp_cat C₂ C₁
  := comma_twosided_disp_cat (functor_identity _) F.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal4.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj11eqsynthconj4 : forall  (lv0 : lst) (lv1 : lst), (@eq lst (append lv0 lv1) (append lv0 (append Nil lv1))).
Admitted.
QuickChick conj11eqsynthconj4.


Require Import TestSuite.admit.
(* File reduced by coq-bug-finder from 335 lines to 115 lines. *)
Set Implicit Arguments.
Set Universe Polymorphism.
Generalizable All Variables.
Record Category (obj : Type) :=
  Build_Category {
      Object :> _ := obj;
      Morphism : obj -> obj -> Type;

      Identity : forall x, Morphism x x;
      Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d'
    }.

Arguments Identity {obj%type} [!C] x : rename.

Arguments Compose {obj%type} [!C s d d'] m1 m2 : rename.
Record > Category' :=
  {
    LSObject : Type;

    LSUnderlyingCategory :> @Category LSObject
  }.

Section Functor.

  Context `(C : @Category objC).
  Context `(D : @Category objD).
  Record Functor :=
    {
      ObjectOf :> objC -> objD;
      MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d)
    }.

End Functor.
Section FunctorComposition.

  Context `(C : @Category objC).
  Context `(D : @Category objD).
  Context `(E : @Category objE).
  Definition ComposeFunctors (G : Functor D E) (F : Functor C D) : Functor C E.

  Admitted.
End FunctorComposition.
Section IdentityFunctor.

  Context `(C : @Category objC).
  Definition IdentityFunctor : Functor C C.

    admit.
  Defined.
End IdentityFunctor.
Section ProductCategory.

  Context `(C : @Category objC).
  Context `(D : @Category objD).
  Definition ProductCategory : @Category (objC * objD)%type.

    refine (@Build_Category _
                            (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type)
                            (fun o => (Identity (fst o), Identity (snd o)))
                            (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1)))).
  Defined.
End ProductCategory.
Parameter TerminalCategory : Category unit.

Section ComputableCategory.

  Variable I : Type.
  Variable Index2Object : I -> Type.
  Variable Index2Cat : forall i : I, @Category (@Index2Object i).
  Local Coercion Index2Cat : I >-> Category.

  Definition ComputableCategory : @Category I.

    refine (@Build_Category _
                            (fun C D : I => Functor C D)
                            (fun o : I => IdentityFunctor o)
                            (fun C D E : I => ComposeFunctors (C := C) (D := D) (E := E))).
  Defined.
End ComputableCategory.
Definition LocallySmallCat := ComputableCategory _ LSUnderlyingCategory.
Section CommaCategory.

  Context `(A : @Category objA).
  Context `(B : @Category objB).
  Context `(C : @Category objC).
  Variable S : Functor A C.
  Variable T : Functor B C.
  Record CommaCategory_Object := { CommaCategory_Object_Member :> { ab : objA * objB & C.(Morphism) (S (fst ab)) (T (snd ab)) } }.

End CommaCategory.
Definition SliceCategory_Functor `(C : @Category objC) (a : C) : Functor TerminalCategory C
  := {| ObjectOf := (fun _ => a);
        MorphismOf := (fun _ _ _ => Identity a)
     |}.

Definition SliceCategoryOver
: forall (objC : Type) (C : Category objC) (a : C),
    Category
      (CommaCategory_Object (IdentityFunctor C)
                            (SliceCategory_Functor C a)).

  admit.
Defined.
Section CommaCategoryProjectionFunctor.

  Context `(A : Category objA).
  Context `(B : Category objB).
  Let X : LocallySmallCat.

  Proof.
    hnf.
    pose (@SliceCategoryOver _ LocallySmallCat).
    exact (ProductCategory A B).
    Set Printing Universes.
  Defined.
(* Error: Illegal application:
The term
 "CommaCategory_Object (* Top.306 Top.307 Top.305 Top.300 Top.305 Top.306 *)"
of type
 "forall (objA : Type (* Top.305 *))
    (A : Category (* Top.306 Top.305 *) objA) (objB : Type (* Top.307 *))
    (B : Category (* Top.300 Top.307 *) objB) (objC : Type (* Top.305 *))
    (C : Category (* Top.306 Top.305 *) objC),
  Functor (* Top.306 Top.305 Top.305 Top.306 *) A C ->
  Functor (* Top.300 Top.307 Top.305 Top.306 *) B C ->
  Type (* max(Top.307, Top.305, Top.306) *)"
cannot be applied to the terms
 "Category' (* Top.312 Top.311 *)" : "Type (* max(Top.311+1, Top.312+1) *)"
 "LocallySmallCat (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314 Top.306 Top.316 Top.305 *)"
   : "Category (* Top.306 Top.305 *) Category' (* Top.312 Top.311 *)"
 "unit" : "Set"
 "TerminalCategory (* Top.300 *)" : "Category (* Top.300 Set *) unit"
 "Category' (* Top.312 Top.311 *)" : "Type (* max(Top.311+1, Top.312+1) *)"
 "LocallySmallCat (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314 Top.306 Top.316 Top.305 *)"
   : "Category (* Top.306 Top.305 *) Category' (* Top.312 Top.311 *)"
 "IdentityFunctor (* Top.299 Top.302 Top.301 Top.305 Top.306 *)
    LocallySmallCat (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314
    Top.306 Top.316 Top.305 *)"
   : "Functor (* Top.306 Top.305 Top.305 Top.306 *) LocallySmallCat
        (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314 Top.306 Top.316
        Top.305 *) LocallySmallCat (* Top.309 Top.310 Top.311 Top.312 Top.313
        Top.314 Top.306 Top.316 Top.305 *)"
 "SliceCategory_Functor (* Top.305 Top.306 Top.307 Top.300 *) LocallySmallCat
    (* Top.309 Top.310 Top.311 Top.312 Top.313 Top.314 Top.306 Top.316
    Top.305 *) a"
   : "Functor (* Top.300 Top.307 Top.305 Top.306 *) TerminalCategory
        (* Top.300 *) LocallySmallCat (* Top.309 Top.310 Top.311 Top.312
        Top.313 Top.314 Top.306 Top.316 Top.305 *)"
The 4th term has type "Category (* Top.300 Set *) unit"
which should be coercible to "Category (* Top.300 Top.307 *) unit". *)


From Undecidability.Synthetic Require Import Definitions Undecidability.
From Undecidability.Synthetic Require Import DecidabilityFacts EnumerabilityFacts ReducibilityFacts.
From Undecidability.Synthetic Require Import ListEnumerabilityFacts MoreEnumerabilityFacts.
From Undecidability.Shared Require Import Dec.
From Equations Require Import Equations.
Require Import ConstructiveEpsilon.
Require Import List.
Import ListNotations.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

(* Post's Theorem *)

Definition mu (p : nat -> Prop) :
  (forall x, dec (p x)) -> ex p -> sig p.
Proof.
  apply constructive_indefinite_ground_description_nat_Acc.
Qed.

Definition ldecidable {X} (p : X -> Prop) :=
  forall x, p x \/ ~ p x.

Theorem weakPost X (p : X -> Prop) :
  discrete X -> ldecidable p -> enumerable p -> enumerable (fun x => ~ p x) -> decidable p.
Proof.
  intros [E] % discrete_iff Hl [f Hf] [g Hg].
  eapply decidable_iff. econstructor. intros x.
  assert (exists n, f n = Some x \/ g n = Some x) by (destruct (Hl x); firstorder).
  destruct (@mu (fun n => f n = Some x \/ g n = Some x)) as [n HN]; trivial.
  - intros n. exact _.
  - decide (f n = Some x); decide (g n = Some x); firstorder.
Qed.

Lemma enumerable_equiv X (P Q : X -> Prop) :
  (forall x, P x <-> Q x) -> enumerable P -> enumerable Q.
Proof.
  intros H [f Hf]. exists f. intros x. rewrite <- H. apply Hf.
Qed.

Section Abstract.

  (* ** Abstract Incompleteness *)

  Variable sentences : Type.
  Hypothesis sentences_discrete : discrete sentences.

  Variable provable : sentences -> Prop.
  Hypothesis provable_enum : enumerable provable.

  Variable neg : sentences -> sentences.

  Hypothesis neg_dec : forall phi, { psi | phi = neg psi } + (forall psi, phi <> neg psi).
  Hypothesis neg_inj : forall phi psi, neg phi = neg psi -> phi = psi.
  Hypothesis consistency : forall phi, ~ (provable phi /\ provable (neg phi)).

  Lemma refutable_enum :
    enumerable (fun phi => provable (neg phi)).
  Proof.
    destruct provable_enum as [f Hf]. unshelve eexists.
    - intros n. destruct (f n) as [phi|].
      + destruct (neg_dec phi) as [[psi _]|H].
        * exact (Some psi).
        * exact None.
      + exact None.
    - intros phi. cbn. split; intros H.
      + apply Hf in H as [n Hn]. exists n. rewrite Hn. destruct neg_dec as [[psi Hp]|Hp].
        * f_equal. now apply neg_inj.
        * exfalso. now apply (Hp phi).
      + destruct H as [n Hn]. destruct (f n) as [psi|] eqn: Heq; try congruence.
        destruct neg_dec as [[theta Hp]|Hp]; try congruence.
        apply Hf. exists n. congruence.
  Qed.

  Definition completeness :=
    forall phi, provable phi \/ provable (neg phi).

  Lemma completeness_decidable :
    completeness -> decidable provable.
  Proof.
    intros HC. apply weakPost.
    - apply sentences_discrete.
    - intros phi. destruct (HC phi) as [H|H]; try now left.
      right. intros H'. now apply (@consistency phi).
    - apply provable_enum.
    - apply enumerable_equiv with (fun phi => provable (neg phi)).
      + intros phi. split; intros Hp.
        * intros H. now apply (@consistency phi).
        * destruct (HC phi) as [H|H]; tauto.
      + apply refutable_enum.
  Qed.

  (* ** Abstract Undecidability *)

  Variable models : Type.
  Variable sat : models -> sentences -> Prop.

  Definition valid phi :=
    forall M, sat M phi.

  Hypothesis soundness : forall phi, provable phi -> valid phi.

  Variable standard : models -> Prop.
  Hypothesis standard_exists : exists M, standard M.

  Section Reduction.

    Variable X : Type.
    Variable p : X -> Prop.

    Hypothesis F : X -> sentences.
    Hypothesis F_provable : forall x, p x -> provable (F x).
    Hypothesis F_standard : forall M x, standard M -> sat M (F x) -> p x.

    Theorem reduction_provable :
      reduction F p provable.
    Proof.
      intros x. split; try apply F_provable.
      intros H % soundness. destruct standard_exists as [M HM].
      apply (F_standard HM). apply H.
    Qed.

    Theorem reduction_valid :
      reduction F p valid.
    Proof.
      intros x. split; intros H.
      - apply soundness, F_provable, H.
      - destruct standard_exists as [M HM]. apply (F_standard HM), H.
    Qed.

    Theorem incompleteness :
      completeness -> decidable p.
    Proof.
      intros H. eapply dec_red.
      - exists F. apply reduction_provable.
      - now apply completeness_decidable.
    Qed.

  End Reduction.

End Abstract.

(* ** Instantiation to first-order logic *)

From Undecidability.FOL Require Import FullSyntax Incompleteness.Axiomatisations.

Lemma reduction_equiv X Y (P P' : X -> Prop) (Q Q' : Y -> Prop) f :
  (forall x, P x <-> P' x) -> (forall y, Q y <-> Q' y) -> reduction f P Q -> reduction f P' Q'.
Proof.
  firstorder.
Qed.

Section Instantiation.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Fact abs_reduction_theorem (T : form -> Prop) X (P : X -> Prop) f (standard : forall D : Type, interp D -> Prop) :
    (forall x : X, P x -> T ⊨T f x) ->
    (forall (D : Type) (I : interp D) rho (x : X), standard D I -> T <<= (sat rho) -> rho ⊨ f x -> P x) ->
    (forall (p : peirce) (x : X), P x -> T ⊢T f x) ->
    forall S : form -> Prop, T <<= S -> (exists D (I : interp D) (d : D), standard D I /\ I ⊨=T S) -> treduction f P S.
  Proof.
    intros H1 H2 H3 S HS HM. split.
    - eapply reduction_equiv. 1: reflexivity.
      2: unshelve eapply (@reduction_valid form (tprv S) {D & {I : interp D & {rho | S <<= (sat rho)}}}).
      3: intros [D[I[rho Hr]]] phi; exact (rho ⊨ phi).
      + unfold Abstract.valid. intros phi. split.
        * intros H D I rho Hp. specialize (H (existT _ D (existT _ I (exist _ rho Hp)))). apply H.
        * intros H [D[I[rho Hr]]]. apply H, Hr.
      + exact intu.
      + intros [D[I[rho Hr]]]. exact (standard D I).
      + intros phi Hp. unfold Abstract.valid. intros [D[I[rho Hr]]]. apply (tsoundness Hp), Hr.
      + destruct HM as [D[I[d H]]]. unshelve eexists.
        * exists D, I, (fun _ => d). intros phi Hp. now apply H.
        * cbn. apply H.
      + intros phi Hp. now eapply WeakT; try apply H3.
      + cbn. intros [D[I[rho Hr]]] x HI. eapply H2; auto.
    - unshelve eapply (@reduction_provable form (tprv S) {D & {I : interp D & {rho | S <<= (sat rho)}}}).
      + intros [D[I[rho Hr]]] phi; exact (rho ⊨ phi).
      + intros [D[I[rho Hr]]]. exact (standard D I).
      + intros phi Hp. unfold Abstract.valid. intros [D[I[rho Hr]]]. apply (tsoundness Hp), Hr.
      + destruct HM as [D[I[d H]]]. unshelve eexists.
        * exists D, I, (fun _ => d). intros phi Hp. now apply H.
        * cbn. apply H.
      + intros phi Hp. now eapply WeakT; try apply H3.
      + cbn. intros [D[I[rho Hr]]] x HI. eapply H2; auto.
  Qed.

  Context {enum_funcs : enumerable__T Σ_funcs} {eqdec_funcs : eq_dec syms}.
  Context {enum_preds : enumerable__T Σ_preds} {eqdec_preds : eq_dec preds}.

  Instance eqdec_on :
    EqDecPoint falsity_flag falsity_on.
  Proof.
    intros ff. decide equality.
  Qed.

  Instance EqDec_syms : EqDec syms.
  Proof.
    intros x y. apply eqdec_funcs.
  Qed.

  Instance EqDec_preds : EqDec preds.
  Proof.
    intros x y. apply eqdec_preds.
  Qed.

  Definition closed phi :=
    (if bounded_dec phi 0 then true else false) = true.

  Lemma closed_mere phi (H H' : closed phi) :
    H = H'.
  Proof.
    apply EqDec.peq_proofs_unicity.
  Qed.

  Lemma bounded_closed phi :
    bounded 0 phi <-> closed phi.
  Proof.
    unfold closed. destruct bounded_dec; intuition congruence.
  Qed.

  Lemma closed_dec phi :
    dec (closed phi).
  Proof.
    eapply dec_transfer; try apply bounded_closed. apply bounded_dec.
  Qed.

  Lemma bot_closed :
    closed ⊥.
  Proof.
    apply bounded_closed. constructor.
  Qed.

  Lemma closed_discrete :
    discrete {phi | closed phi}.
  Proof.
    apply decidable_iff. constructor. intros [[phi H1] [psi H2]].
    unfold dec.
    destruct dec_form with falsity_on phi psi as [->|H]; eauto.
    - left. f_equal. apply uip.
    - right. injection. apply H.
  Qed.

  Lemma closed_enum :
    enumerable__T form -> enumerable__T {phi | closed phi}.
  Proof.
    intros [f Hf]. unshelve eexists.
    - intros n. destruct (f n) as [phi|].
      + destruct (closed_dec phi) as [H|_].
        * apply Some. now exists phi.
        * exact None.
      + exact None.
    - intros [phi Hp]. destruct (Hf phi) as [n Hn].
      exists n. cbn. rewrite Hn. destruct closed_dec as [H|H]; try tauto.
      repeat f_equal. apply closed_mere.
  Qed.

  Lemma neg_dec phi :
    { psi | phi = ¬ psi } + (forall psi, phi <> ¬ psi).
  Proof.
    depelim phi.
    - apply EqDec.inj_right_sigma_point in H as ->. right. intros phi. congruence.
    - right. intros phi. congruence.
    - destruct b0. 1,2: right; intros phi; congruence.
      destruct dec_form with falsity_on phi2 ⊥ as [->|H]; eauto.
      right. intros psi. intros Heq. injection Heq. intros H1%Eqdep_dec.inj_pair2_eq_dec _. 2:decide equality. tauto.
    - right. intros psi. congruence.
  Qed.

  Fact abstr_complete_decidable (T : form -> Prop) :
    enumerable T -> ~ T ⊢TC ⊥ -> complete T -> decidable (fun phi : form => bounded 0 phi /\ T ⊢TC phi).
  Proof.
    intros H1 H2 H3. apply dec_red with {phi | closed phi} (fun phi => T⊢TC (proj1_sig phi)).
    { exists (fun phi => match closed_dec phi with left H => exist _ phi H | _ => exist _ ⊥ bot_closed end).
      intros phi. rewrite bounded_closed. destruct closed_dec; cbn; tauto. }
    unshelve eapply completeness_decidable.
    - intros [phi Hp % bounded_closed]. exists (¬ phi). apply bounded_closed. repeat constructor. apply Hp.
    - apply closed_discrete.
    - apply enumerable_red with form (fun phi => closed phi /\ T ⊢TC phi).
      { exists (fun phi => proj1_sig phi). intros [phi Hp]. cbn. tauto. }
      { apply closed_enum. unshelve eapply form_enumerable; eauto. }
      { apply form_discrete. }
      apply enumerable_conj; try apply form_discrete.
      + apply dec_count_enum; try unshelve eapply form_enumerable; eauto.
        apply decidable_iff. constructor. intros phi. unshelve eapply closed_dec; eauto.
      + unshelve eapply tprv_enumerable; eauto.
    - intros [phi H]. cbn. destruct (neg_dec phi) as [[psi Hp]|Hp].
      + left. unshelve eexists.
        * exists psi. rewrite Hp in H. rewrite <- bounded_closed in *.
          inversion H. now repeat resolve_existT.
        * cbn. subst. f_equal. apply closed_mere.
      + right. intros [psi Hp']. intros [=]. now apply Hp in H4.
    - cbn. intros [phi H] [psi H']. cbn. intros [=]. resolve_existT. f_equal. apply closed_mere.
    - cbn. intros [phi Hp] [[A [HA1 HA2]] [B [HB1 HB2]]]. cbn in *.
      apply H2. exists (A ++ B). split.
      + intros psi [H|H] % in_app_iff; intuition.
      + apply IE with phi. apply (Weak HB2). 1:apply incl_appr, incl_refl. apply (Weak HA2). apply incl_appl,incl_refl.
    - intros [phi Hp]; cbn. apply bounded_closed in Hp. now apply H3.
  Qed.

End Instantiation.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj5synthconj3 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 (plus lv1 Zero)) (plus lv1 lv0)).
Admitted.
QuickChick conj5synthconj3.


Require Export SpecSemantics.
Require Export BoilerplateSyntax.
Set Implicit Arguments.

(******************************************************************************)
(* Weakening lemmas                                                           *)
(******************************************************************************)

Lemma PTyping_bindPat_lengthExt {Γ p T Δ} (wp: PTyping Γ p T Δ) :
  bindPat p = lengthExt Δ.
Proof.
  induction wp; simpl; try rewrite lengthExt_append; congruence.
Qed.

Lemma shift_evar_ptyping {Γ1 p T Δ} (wp: PTyping Γ1 p T Δ) :
  ∀ {c Γ2}, shift_evar c Γ1 Γ2 → PTyping Γ2 p T Δ.
Proof.
  induction wp; econstructor; eauto.
Qed.

Lemma shift_evar_typing {Γ1 t T} (wt: Typing Γ1 t T) :
  ∀ {c Γ2}, shift_evar c Γ1 Γ2 → Typing Γ2 (shiftTm c t) T.
Proof.
  induction wt; simpl; intros; try (econstructor; eauto; fail).
  - rewrite (PTyping_bindPat_lengthExt H).
    econstructor; eauto using shift_evar_ptyping.
Qed.

Lemma weaken_typing {Γ} Δ :
  ∀ {t T}, Typing Γ t T → Typing (extend Γ Δ) (weakenTm t (lengthExt Δ)) T.
Proof.
  induction Δ; simpl; eauto using shift_evar_typing.
Qed.

(******************************************************************************)
(* Substitution lemmas                                                        *)
(******************************************************************************)

Inductive subst_evar (Γ: Env) (U : Ty) : nat → Env → Env → Prop :=
  | subst_evar_here :
      subst_evar Γ U 0 (evar Γ U) Γ
  | subst_evar_there_evar {Γ1 Γ2 : Env} {x T} :
      subst_evar Γ U x     Γ1           Γ2 →
      subst_evar Γ U (S x) (evar Γ1 T) (evar Γ2 T).
Hint Constructors subst_evar.

Lemma weaken_subst_evar {Γ U} (Δ : Ext) :
  ∀ {x Γ1 Γ2},
    subst_evar Γ U x Γ1 Γ2 →
    subst_evar Γ U (lengthExt Δ + x) (extend Γ1 Δ) (extend Γ2 Δ).
Proof.
  induction Δ; simpl; intros; try constructor; auto.
Qed.
Hint Resolve weaken_subst_evar.

Lemma subst_evar_ptyping {Γ s S} (wts: Typing Γ s S)
  {Γ1 p T Δ} (wp: PTyping Γ1 p T Δ) :
  ∀ {x Γ2}, subst_evar Γ S x Γ1 Γ2 → PTyping Γ2 p T Δ.
Proof.
  induction wp; simpl; econstructor; eauto.
Qed.

Lemma subst_evar_lookup_evar {Γ s S} (wt: Typing Γ s S)
  {x Γ1 Γ2} (esub: subst_evar Γ S x Γ1 Γ2) :
  ∀ {y T}, lookup_evar Γ1 y T → Typing Γ2 (substIndex x s y) T.
Proof.
  induction esub; inversion 1; subst; simpl;
    eauto using T_Var, shift_evar_typing.
Qed.

Lemma subst_evar_typing {Γ s S Γ1 t T} (wts: Typing Γ s S) (wt: Typing Γ1 t T) :
  ∀ {x Γ2}, subst_evar Γ S x Γ1 Γ2 → Typing Γ2 (substTm x s t) T.
Proof.
  induction wt; simpl; intros; eauto using subst_evar_lookup_evar;
    try (econstructor; eauto; fail).
  - rewrite (PTyping_bindPat_lengthExt H).
    eapply T_Let; eauto using subst_evar_ptyping.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable triangle_ : Universe -> Universe -> Universe -> Prop.
Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable supp_ : Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable oS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable meet_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable ltA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_betweennotequal_1 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable defoppositeside_2 : (forall P A B Q : Universe, (exists X : Universe, (tS_ P A B Q -> (betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P)))))).
Variable defoppositeside2_3 : (forall P A B Q X : Universe, ((betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P))) -> tS_ P A B Q)).
Variable defcollinear_4 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_5 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_6 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_7 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_8 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_9 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_10 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_equalanglessymmetric_11 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).
Variable defequalangles_12 : (forall A B C Ca Cb Cc : Universe, (exists U V Su Sv : Universe, (congA_ A B C Ca Cb Cc -> (out_ B A U /\ (out_ B C V /\ (out_ Cb Ca Su /\ (out_ Cb Cc Sv /\ (cong_ B U Cb Su /\ (cong_ B V Cb Sv /\ (cong_ U V Su Sv /\ ~(col_ A B C))))))))))).
Variable defequalangles2_13 : (forall A B C Ca Cb Cc U V Su Sv : Universe, ((out_ B A U /\ (out_ B C V /\ (out_ Cb Ca Su /\ (out_ Cb Cc Sv /\ (cong_ B U Cb Su /\ (cong_ B V Cb Sv /\ (cong_ U V Su Sv /\ ~(col_ A B C)))))))) -> congA_ A B C Ca Cb Cc)).
Variable lemma_angledistinct_14 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> (A <> B /\ (B <> C /\ (A <> C /\ (Xa <> Xb /\ (Xb <> Xc /\ Xa <> Xc))))))).
Variable lemma_inequalitysymmetric_15 : (forall A B : Universe, (A <> B -> B <> A)).
Variable defmeet_16 : (forall A B C D : Universe, (exists X : Universe, (meet_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X)))))).
Variable defmeet2_17 : (forall A B C D X : Universe, ((A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X))) -> meet_ A B C D)).
Variable lemma_collinearorder_18 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_collinear4_19 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable lemma_ray4_1_20 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_21 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_22 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable defsupplement_23 : (forall A B C D F : Universe, (supp_ A B C D F -> (out_ B C D /\ betS_ A B F))).
Variable defsupplement2_24 : (forall A B C D F : Universe, ((out_ B C D /\ betS_ A B F) -> supp_ A B C D F)).
Variable axiom_betweennesssymmetry_25 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable lemma_ABCequalsCBA_26 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C C B A)).
Variable lemma_equalanglestransitive_27 : (forall A B C D E F P Q R : Universe, ((congA_ A B C D E F /\ congA_ D E F P Q R) -> congA_ A B C P Q R)).
Variable lemma_supplements_28 : (forall A B C D F Xa Xb Xc Xd Xf : Universe, ((congA_ A B C Xa Xb Xc /\ (supp_ A B C D F /\ supp_ Xa Xb Xc Xd Xf)) -> congA_ D B F Xd Xb Xf)).
Variable lemma_equalanglesflip_29 : (forall A B C D E F : Universe, (congA_ A B C D E F -> congA_ C B A F E D)).
Variable defsameside_30 : (forall P Q A B : Universe, (exists X U V : Universe, (oS_ P Q A B -> (col_ A B U /\ (col_ A B V /\ (betS_ P U X /\ (betS_ Q V X /\ (~(col_ A B P) /\ ~(col_ A B Q))))))))).
Variable defsameside2_31 : (forall P Q A B X U V : Universe, ((col_ A B U /\ (col_ A B V /\ (betS_ P U X /\ (betS_ Q V X /\ (~(col_ A B P) /\ ~(col_ A B Q)))))) -> oS_ P Q A B)).
Variable lemma_samesidesymmetric_32 : (forall A B P Q : Universe, (oS_ P Q A B -> (oS_ Q P A B /\ (oS_ P Q B A /\ oS_ Q P B A)))).
Variable lemma_planeseparation_33 : (forall A B C D E : Universe, ((oS_ C D A B /\ tS_ D A B E) -> tS_ C A B E)).
Variable lemma_collinear5_34 : (forall A B C D E : Universe, ((A <> B /\ (col_ A B C /\ (col_ A B D /\ col_ A B E))) -> col_ C D E)).
Variable deftriangle_35 : (forall A B C : Universe, (triangle_ A B C -> ~(col_ A B C))).
Variable deftriangle2_36 : (forall A B C : Universe, (~(col_ A B C) -> triangle_ A B C)).
Variable proposition_16_37 : (forall A B C D : Universe, ((triangle_ A B C /\ betS_ B C D) -> (ltA_ B A C A C D /\ ltA_ C B A A C D))).
Variable lemma_angleorderrespectscongruence_38 : (forall A B C D E F P Q R : Universe, ((ltA_ A B C D E F /\ congA_ P Q R D E F) -> ltA_ A B C P Q R)).
Variable defray_39 : (forall A B C : Universe, (exists X : Universe, (out_ A B C -> (betS_ X A C /\ betS_ X A B)))).
Variable defray2_40 : (forall A B C X : Universe, ((betS_ X A C /\ betS_ X A B) -> out_ A B C)).
Variable lemma_equalanglesreflexive_41 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C A B C)).
Variable lemma_equalangleshelper_42 : (forall A B C Xa Xb Xc Xp Xq : Universe, ((congA_ A B C Xa Xb Xc /\ (out_ Xb Xa Xp /\ out_ Xb Xc Xq)) -> congA_ A B C Xp Xb Xq)).
Variable lemma_angleorderrespectscongruence2_43 : (forall A B C D E F Xa Xb Xc : Universe, ((ltA_ A B C D E F /\ congA_ Xa Xb Xc A B C) -> ltA_ Xa Xb Xc D E F)).
Variable lemma_angletrichotomy_44 : (forall A B C D E F : Universe, (ltA_ A B C D E F -> ~(ltA_ D E F A B C))).
Variable lemma_ray5_45 : (forall A B C : Universe, (out_ A B C -> out_ A C B)).
Variable lemma_ray1_46 : (forall A B P : Universe, (out_ A B P -> (betS_ A P B \/ (B = P \/ betS_ A B P)))).
Variable lemma_3_7b_47 : (forall A B C D : Universe, ((betS_ A B C /\ betS_ B C D) -> betS_ A B D)).
Variable axiom_innertransitivity_48 : (forall A B C D : Universe, ((betS_ A B D /\ betS_ B C D) -> betS_ A B C)).
Variable lemma_collinearbetween_49 : (forall A B C D E F H : Universe, ((col_ A E B /\ (col_ C F D /\ (A <> B /\ (C <> D /\ (A <> E /\ (F <> D /\ (~(meet_ A B C D) /\ (betS_ A H D /\ col_ E F H)))))))) -> betS_ E H F)).
Variable defparallel_50 : (forall A B C D : Universe, (exists U V Su Sv X : Universe, (par_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V))))))))))))).
Variable defparallel2_51 : (forall A B C D U V Su Sv X : Universe, ((A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V)))))))))) -> par_ A B C D)).

Theorem proposition_27_52 : (forall A B C D E F : Universe, ((betS_ A E B /\ (betS_ C F D /\ (congA_ A E F E F D /\ tS_ A E F D))) -> par_ A B C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** * Smallstep: Small-step Operational Semantics *)

Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Import ListNotations.

(* ################################################################# *)
(** * Relations *)

(** We will be working with several different single-step relations,
    so it is helpful to generalize a bit and state a few definitions
    and theorems about relations in general.  (The optional chapter
    [Rel.v] develops some of these ideas in a bit more detail; it may
    be useful if the treatment here is too dense.)

    A _binary relation_ on a set [X] is a family of propositions
    parameterized by two elements of [X] -- i.e., a proposition about
    pairs of elements of [X].  *)

Definition relation (X: Type) := X->X->Prop.

(** Our main examples of such relations in this chapter will be
    the single-step reduction relation, [==>], and its multi-step
    variant, [==>*] (defined below), but there are many other
    examples -- e.g., the "equals," "less than," "less than or equal
    to," and "is the square of" relations on numbers, and the "prefix
    of" relation on lists and strings. *)

(** One simple property of the [==>] relation is that, like the
    big-step evaluation relation for Imp, it is _deterministic_.

    _Theorem_: For each [t], there is at most one [t'] such that [t]
    steps to [t'] ([t ==> t'] is provable).  Formally, this is the
    same as saying that [==>] is deterministic. *)

(** _Proof sketch_: We show that if [x] steps to both [y1] and
    [y2], then [y1] and [y2] are equal, by induction on a derivation
    of [step x y1].  There are several cases to consider, depending on
    the last rule used in this derivation and the last rule in the
    given derivation of [step x y2].

      - If both are [ST_PlusConstConst], the result is immediate.

      - The cases when both derivations end with [ST_Plus1] or
        [ST_Plus2] follow by the induction hypothesis.

      - It cannot happen that one is [ST_PlusConstConst] and the other
        is [ST_Plus1] or [ST_Plus2], since this would imply that [x]
        has the form [P t1 t2] where both [t1] and [t2] are
        constants (by [ST_PlusConstConst]) _and_ one of [t1] or [t2]
        has the form [P _].

      - Similarly, it cannot happen that one is [ST_Plus1] and the
        other is [ST_Plus2], since this would imply that [x] has the
        form [P t1 t2] where [t1] has both the form [P t11 t12] and the
        form [C n]. [] *)

(** Formally: *)

Definition deterministic {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

(** There is some annoying repetition in this proof.  Each use of
    [inversion Hy2] results in three subcases, only one of which is
    relevant (the one that matches the current case in the induction
    on [Hy1]).  The other two subcases need to be dismissed by finding
    the contradiction among the hypotheses and doing inversion on it.

    The following custom tactic, called [solve_by_inverts], can be
    helpful in such cases.  It will solve the goal if it can be solved
    by inverting some hypothesis; otherwise, it fails. *)

Ltac solve_by_inverts n :=
  match goal with | H : ?T |- _ =>
  match type of T with Prop =>
    solve [
      inversion H;
      match n with S (S (?n')) => subst; solve_by_inverts (S n') end ]
  end end.

(** The details of how this works are not important for now, but it
    illustrates the power of Coq's [Ltac] language for
    programmatically defining special-purpose tactics.  It looks
    through the current proof state for a hypothesis [H] (the first
    [match]) of type [Prop] (the second [match]) such that performing
    inversion on [H] (followed by a recursive invocation of the same
    tactic, if its argument [n] is greater than one) completely solves
    the current goal.  If no such hypothesis exists, it fails.

    We will usually want to call [solve_by_inverts] with argument
    [1] (especially as larger arguments can lead to very slow proof
    checking), so we define [solve_by_invert] as a shorthand for this
    case. *)

Ltac solve_by_invert :=
  solve_by_inverts 1.

(** The idea of "making progress" can be extended to tell us something
    interesting about values: in this language, values are exactly the
    terms that _cannot_ make progress in this sense.

    To state this observation formally, let's begin by giving a name
    to terms that cannot make progress.  We'll call them _normal
    forms_.  *)

Definition normal_form {X:Type} (R:relation X) (t:X) : Prop :=
  ~ exists t', R t t'.

(* ################################################################# *)
(** * Multi-Step Reduction *)

(** We've been working so far with the _single-step reduction_
    relation [==>], which formalizes the individual steps of an
    abstract machine for executing programs.

    We can use the same machine to reduce programs to completion -- to
    find out what final result they yield.  This can be formalized as
    follows:

    - First, we define a _multi-step reduction relation_ [==>*], which
      relates terms [t] and [t'] if [t] can reach [t'] by any number
      (including zero) of single reduction steps.

    - Then we define a "result" of a term [t] as a normal form that
      [t] can reach by multi-step reduction. *)

(** Since we'll want to reuse the idea of multi-step reduction many
    times, let's take a little extra trouble and define it
    generically.

    Given a relation [R], we define a relation [multi R], called the
    _multi-step closure of [R]_ as follows. *)

Inductive multi {X:Type} (R: relation X) : relation X :=
  | multi_refl  : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi R y z ->
                    multi R x z.

(** (In the [Rel] chapter and the Coq standard library, this relation
    is called [clos_refl_trans_1n].  We give it a shorter name here
    for the sake of readability.)

    The effect of this definition is that [multi R] relates two
    elements [x] and [y] if

       - [x = y], or
       - [R x y], or
       - there is some nonempty sequence [z1], [z2], ..., [zn] such that

           R x z1
           R z1 z2
           ...
           R zn y.

    Thus, if [R] describes a single-step of computation, then [z1]...[zn]
    is the sequence of intermediate steps of computation between [x] and
    [y]. *)

(* Notation " t '==>*' t' " := (multi step t t') (at level 40). *)

(** The relation [multi R] has several crucial properties.

    First, it is obviously _reflexive_ (that is, [forall x, multi R x
    x]).  In the case of the [==>*] (i.e., [multi step]) relation, the
    intuition is that a term can execute to itself by taking zero
    steps of execution.

    Second, it contains [R] -- that is, single-step executions are a
    particular case of multi-step executions.  (It is this fact that
    justifies the word "closure" in the term "multi-step closure of
    [R].") *)

Theorem multi_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> (multi R) x y.
Proof.
  intros X R x y H.
  apply multi_step with y. apply H. apply multi_refl.   Qed.

(** Third, [multi R] is _transitive_. *)

Theorem multi_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      multi R x y  ->
      multi R y z ->
      multi R x z.
Proof.
  intros X R x y z G H.
  induction G.
    - (* multi_refl *) assumption.
    - (* multi_step *)
      apply multi_step with y. assumption.
      apply IHG. assumption.  Qed.

(** In particular, for the [multi step] relation on terms, if
    [t1==>*t2] and [t2==>*t3], then [t1==>*t3]. *)