(* Title:      Pre-Post Specifications
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Pre-Post Specifications\<close>

theory Pre_Post

imports Preconditions

begin

class pre_post =
  fixes pre_post :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<stileturn>" 55)

class pre_post_spec_greatest = bounded_idempotent_left_semiring + precondition + pre_post +
  assumes pre_post_galois: "-p \<le> x\<guillemotleft>-q \<longleftrightarrow> x \<le> -p\<stileturn>-q"
begin

text \<open>Theorem 42.1\<close>

lemma post_pre_left_antitone:
  "x \<le> y \<Longrightarrow> y\<guillemotleft>-q \<le> x\<guillemotleft>-q"
  by (smt order_refl order_trans pre_closed pre_post_galois)

lemma pre_left_sub_dist:
  "x\<squnion>y\<guillemotleft>-q \<le> x\<guillemotleft>-q"
  by (simp add: post_pre_left_antitone)

text \<open>Theorem 42.2\<close>

lemma pre_post_left_antitone:
  "-p \<le> -q \<Longrightarrow> -q\<stileturn>-r \<le> -p\<stileturn>-r"
  using order_lesseq_imp pre_post_galois by blast

lemma pre_post_left_sub_dist:
  "-p\<squnion>-q\<stileturn>-r \<le> -p\<stileturn>-r"
  by (metis sup.cobounded1 tests_dual.sba_dual.sub_sup_closed pre_post_left_antitone)

lemma pre_post_left_sup_dist:
  "-p\<stileturn>-r \<le> -p*-q\<stileturn>-r"
  by (metis tests_dual.sba_dual.sub_inf_def pre_post_left_sub_dist tests_dual.inf_absorb)

text \<open>Theorem 42.5\<close>

lemma pre_pre_post:
  "x \<le> (x\<guillemotleft>-p)\<stileturn>-p"
  by (metis order_refl pre_closed pre_post_galois)

text \<open>Theorem 42.6\<close>

lemma pre_post_pre:
  "-p \<le> (-p\<stileturn>-q)\<guillemotleft>-q"
  by (simp add: pre_post_galois)

text \<open>Theorem 42.8\<close>

lemma pre_post_zero_top:
  "bot\<stileturn>-q = top"
  by (metis order.eq_iff pre_post_galois sup.cobounded2 sup_monoid.add_0_right top_greatest tests_dual.top_double_complement)

text \<open>Theorem 42.7\<close>

lemma pre_post_pre_one:
  "(1\<stileturn>-q)\<guillemotleft>-q = 1"
  by (metis order.eq_iff pre_below_one tests_dual.sba_dual.top_double_complement pre_post_pre)

text \<open>Theorem 42.3\<close>

lemma pre_post_right_isotone:
  "-p \<le> -q \<Longrightarrow> -r\<stileturn>-p \<le> -r\<stileturn>-q"
  using order_lesseq_imp pre_iso pre_post_galois by blast

lemma pre_post_right_sub_dist:
  "-r\<stileturn>-p \<le> -r\<stileturn>-p\<squnion>-q"
  by (metis sup.cobounded1 tests_dual.sba_dual.sub_sup_closed pre_post_right_isotone)

lemma pre_post_right_sup_dist:
  "-r\<stileturn>-p*-q \<le> -r\<stileturn>-p"
  by (metis tests_dual.sub_sup_closed pre_post_right_isotone tests_dual.upper_bound_left)

text \<open>Theorem 42.7\<close>

lemma pre_post_reflexive:
  "1 \<le> -p\<stileturn>-p"
  using pre_one_increasing pre_post_galois by auto

text \<open>Theorem 42.9\<close>

lemma pre_post_compose:
  "-q \<le> -r \<Longrightarrow> (-p\<stileturn>-q)*(-r\<stileturn>-s) \<le> -p\<stileturn>-s"
  using order_lesseq_imp pre_compose pre_post_galois by blast

text \<open>Theorem 42.10\<close>

lemma pre_post_compose_1:
  "(-p\<stileturn>-q)*(-q\<stileturn>-r) \<le> -p\<stileturn>-r"
  by (simp add: pre_post_compose)

text \<open>Theorem 42.11\<close>

lemma pre_post_compose_2:
  "(-p\<stileturn>-p)*(-p\<stileturn>-q) = -p\<stileturn>-q"
  by (meson case_split_left order.eq_iff le_supI1 pre_post_compose_1 pre_post_reflexive)

text \<open>Theorem 42.12\<close>

lemma pre_post_compose_3:
  "(-p\<stileturn>-q)*(-q\<stileturn>-q) = -p\<stileturn>-q"
  by (meson order.eq_iff order.trans mult_right_isotone mult_sub_right_one pre_post_compose_1 pre_post_reflexive)

text \<open>Theorem 42.13\<close>

lemma pre_post_compose_4:
  "(-p\<stileturn>-p)*(-p\<stileturn>-p) = -p\<stileturn>-p"
  by (simp add: pre_post_compose_3)

text \<open>Theorem 42.14\<close>

lemma pre_post_one_one:
  "x\<guillemotleft>1 = 1 \<longleftrightarrow> x \<le> 1\<stileturn>1"
  by (metis order.eq_iff one_def pre_below_one pre_post_galois)

text \<open>Theorem 42.4\<close>

lemma post_pre_left_dist_sup:
  "x\<squnion>y\<guillemotleft>-q = (x\<guillemotleft>-q)*(y\<guillemotleft>-q)"
  apply (rule order.antisym)
  apply (metis mult_isotone pre_closed sup_commute tests_dual.sup_idempotent pre_left_sub_dist)
  by (smt (z3) order.refl pre_closed pre_post_galois sup.boundedI tests_dual.sba_dual.greatest_lower_bound tests_dual.sub_sup_closed)

proposition pre_post_right_dist_sup: "-p\<stileturn>-q\<squnion>-r = (-p\<stileturn>-q) \<squnion> (-p\<stileturn>-r)" nitpick [expect=genuine,card=4] oops

end

class pre_post_spec_greatest_2 = pre_post_spec_greatest + precondition_test_test
begin

subclass precondition_test_box
  apply unfold_locales
  by (smt (verit) sup_commute mult_1_right tests_dual.double_negation order.eq_iff mult_left_one mult_right_dist_sup one_def tests_dual.inf_complement tests_dual.inf_complement_intro pre_below_one pre_import pre_post_galois pre_test_test tests_dual.top_def bot_least)

lemma pre_post_seq_sub_associative:
  "(-p\<stileturn>-q)*-r \<le> -p\<stileturn>-q*-r"
  by (smt (z3) pre_compose pre_post_galois pre_post_pre sub_comm test_below_pre_test_mult tests_dual.sub_sup_closed)

lemma pre_post_right_import_mult:
  "(-p\<stileturn>-q)*-r = (-p\<stileturn>-q*-r)*-r"
  by (metis order.antisym mult_assoc tests_dual.sup_idempotent mult_left_isotone pre_post_right_sup_dist pre_post_seq_sub_associative)

lemma seq_pre_post_sub_associative:
  "-r*(-p\<stileturn>-q) \<le> --r\<squnion>-p\<stileturn>-q"
  by (smt (z3) pre_compose pre_post_galois pre_post_pre pre_test tests_dual.sba_dual.reflexive tests_dual.sba_dual.sub_sup_closed)

lemma pre_post_left_import_sup:
  "-r*(-p\<stileturn>-q) = -r*(--r\<squnion>-p\<stileturn>-q)"
  by (metis sup_commute order.antisym mult_assoc tests_dual.sup_idempotent mult_right_isotone pre_post_left_sub_dist seq_pre_post_sub_associative)

lemma pre_post_import_same:
  "-p*(-p\<stileturn>-q) = -p*(1\<stileturn>-q)"
  using pre_test pre_test_test_same pre_post_left_import_sup by auto

lemma pre_post_import_complement:
  "--p*(-p\<stileturn>-q) = --p*top"
  by (metis tests_dual.sup_idempotent tests_dual.inf_cases tests_dual.inf_closed pre_post_left_import_sup pre_post_zero_top tests_dual.top_def tests_dual.top_double_complement)

lemma pre_post_export:
  "-p\<stileturn>-q = (1\<stileturn>-q) \<squnion> --p*top"
proof (rule order.antisym)
  have 1: "-p*(-p\<stileturn>-q) \<le> (1\<stileturn>-q) \<squnion> --p*top"
    by (metis le_supI1 pre_test pre_test_test_same seq_pre_post_sub_associative)
  have "--p*(-p\<stileturn>-q) \<le> (1\<stileturn>-q) \<squnion> --p*top"
    by (simp add: pre_post_import_complement)
  thus "-p\<stileturn>-q \<le> (1\<stileturn>-q) \<squnion> --p*top"
    using 1 by (smt case_split_left eq_refl tests_dual.inf_complement)
next
  show "(1\<stileturn>-q) \<squnion> --p*top \<le> -p\<stileturn>-q"
    by (metis le_sup_iff tests_dual.double_negation tests_dual.sub_bot_least pre_neg_mult pre_post_galois pre_post_pre_one)
qed

lemma pre_post_left_dist_mult:
  "-p*-q\<stileturn>-r = (-p\<stileturn>-r) \<squnion> (-q\<stileturn>-r)"
proof -
  have "\<forall>p q . -p*(-p*-q\<stileturn>-r) = -p*(-q\<stileturn>-r)"
    using sup_monoid.add_commute tests_dual.sba_dual.sub_inf_def pre_post_left_import_sup tests_dual.inf_complement_intro by auto
  hence 1: "(-p\<squnion>-q)*(-p*-q\<stileturn>-r) \<le> (-p\<stileturn>-r) \<squnion> (-q\<stileturn>-r)"
    by (metis sup_commute le_sup_iff sup_ge2 mult_left_one mult_right_dist_sup tests_dual.inf_left_unit sub_comm)
  have "-(-p\<squnion>-q)*(-p*-q\<stileturn>-r) = -(-p\<squnion>-q)*top"
    by (smt (z3) sup.left_commute sup_commute tests_dual.sba_dual.sub_sup_closed tests_dual.sub_sup_closed pre_post_import_complement pre_post_left_import_sup tests_dual.inf_absorb)
  hence "-(-p\<squnion>-q)*(-p*-q\<stileturn>-r) \<le> (-p\<stileturn>-r) \<squnion> (-q\<stileturn>-r)"
    by (smt (z3) order.trans le_supI1 pre_post_left_sub_dist tests_dual.sba_dual.sub_sup_closed tests_dual.sub_sup_closed seq_pre_post_sub_associative)
  thus ?thesis
    using 1 by (smt (z3) le_sup_iff order.antisym case_split_left order_refl tests_dual.inf_closed tests_dual.inf_complement pre_post_left_sup_dist sub_comm)
qed

lemma pre_post_left_import_mult:
  "-r*(-p\<stileturn>-q) = -r*(-r*-p\<stileturn>-q)"
  by (metis sup_commute tests_dual.inf_complement_intro pre_post_left_import_sup sub_mult_closed)

lemma pre_post_right_import_sup:
  "(-p\<stileturn>-q)*-r = (-p\<stileturn>-q\<squnion>--r)*-r"
  by (smt (z3) sup_monoid.add_commute tests_dual.sba_dual.inf_cases_2 tests_dual.sba_dual.inf_complement_intro tests_dual.sub_complement tests_dual.sub_inf_def pre_post_right_import_mult)

lemma pre_post_shunting:
  "x \<le> -p*-q\<stileturn>-r \<longleftrightarrow> -p*x \<le> -q\<stileturn>-r"
proof -
  have "--p*x \<le> -p*-q\<stileturn>-r"
    by (metis tests_dual.double_negation order_trans pre_neg_mult pre_post_galois pre_post_left_sup_dist)
  hence 1: "-p*x \<le> -q\<stileturn>-r \<longrightarrow> x \<le> -p*-q\<stileturn>-r"
    by (smt case_split_left eq_refl order_trans tests_dual.inf_complement pre_post_left_sup_dist sub_comm)
  have "-p*(-p*-q\<stileturn>-r) \<le> -q\<stileturn>-r"
    by (metis mult_left_isotone mult_left_one tests_dual.sub_bot_least pre_post_left_import_mult)
  thus ?thesis
    using 1 mult_right_isotone order_lesseq_imp by blast
qed

proposition pre_post_right_dist_sup: "-p\<stileturn>-q\<squnion>-r = (-p\<stileturn>-q) \<squnion> (-p\<stileturn>-r)" oops

end

class left_zero_pre_post_spec_greatest_2 = pre_post_spec_greatest_2 + bounded_idempotent_left_zero_semiring
begin

lemma pre_post_right_dist_sup:
  "-p\<stileturn>-q\<squnion>-r = (-p\<stileturn>-q) \<squnion> (-p\<stileturn>-r)"
proof -
  have 1: "(-p\<stileturn>-q\<squnion>-r)*-q \<le> (-p\<stileturn>-q) \<squnion> (-p\<stileturn>-r)"
    by (metis le_supI1 pre_post_seq_sub_associative tests_dual.sba_dual.inf_absorb tests_dual.sba_dual.sub_sup_closed)
  have "(-p\<stileturn>-q\<squnion>-r)*--q = (-p\<stileturn>-r)*--q"
    by (simp add: pre_post_right_import_sup sup_commute)
  hence "(-p\<stileturn>-q\<squnion>-r)*--q \<le> (-p\<stileturn>-q) \<squnion> (-p\<stileturn>-r)"
    by (metis sup_ge2 mult_left_sub_dist_sup_right mult_1_right order_trans tests_dual.inf_left_unit)
  thus ?thesis
    using 1 by (metis le_sup_iff order.antisym case_split_right tests_dual.sub_bot_least tests_dual.inf_commutative tests_dual.inf_complement pre_post_right_sub_dist)
qed

end

class havoc =
  fixes H :: "'a"

class idempotent_left_semiring_H = bounded_idempotent_left_semiring + havoc +
  assumes H_zero : "H * bot = bot"
  assumes H_split: "x \<le> x * bot \<squnion> H"
begin

lemma H_galois:
  "x * bot \<le> y \<longleftrightarrow> x \<le> y \<squnion> H"
  apply (rule iffI)
  using H_split order_lesseq_imp sup_mono apply blast
  by (smt (verit, ccfv_threshold) H_zero mult_right_dist_sup sup.cobounded2 sup.orderE sup_assoc sup_bot_left sup_commute zero_right_mult_decreasing)

lemma H_greatest_finite:
  "x * bot = bot \<longleftrightarrow> x \<le> H"
  by (metis H_galois le_iff_sup sup_bot_left sup_monoid.add_0_right)

lemma H_reflexive:
  "1 \<le> H"
  using H_greatest_finite mult_left_one by blast

lemma H_transitive:
  "H = H * H"
  by (metis H_greatest_finite H_reflexive H_zero preorder_idempotent mult_assoc)

lemma T_split_H:
  "top * bot \<squnion> H = top"
  by (simp add: H_split order.antisym)

proposition "H * (x \<squnion> y) = H * x \<squnion> H * y" nitpick [expect=genuine,card=6] oops

end

class pre_post_spec_least = bounded_idempotent_left_semiring + precondition_test_test + precondition_promote + pre_post +
  assumes test_mult_right_distr_sup: "-p * (x \<squnion> y) = -p * x \<squnion> -p * y"
  assumes pre_post_galois: "-p \<le> x\<guillemotleft>-q \<longleftrightarrow> -p\<stileturn>-q \<le> x"
begin

lemma shunting_top:
  "-p * x \<le> y \<longleftrightarrow> x \<le> y \<squnion> --p * top"
proof
  assume "-p * x \<le> y"
  thus "x \<le> y \<squnion> --p * top"
    by (smt (verit, ccfv_SIG) case_split_left eq_refl le_supI1 le_supI2 mult_right_isotone tests_dual.sba_dual.top_def top_greatest)
next
  assume "x \<le> y \<squnion> --p * top"
  hence "-p * x \<le> -p * y"
    by (metis sup_bot_right mult_assoc tests_dual.sup_complement mult_left_zero mult_right_isotone test_mult_right_distr_sup)
  thus "-p * x \<le> y"
    by (metis mult_left_isotone mult_left_one tests_dual.sub_bot_least order_trans)
qed

lemma post_pre_left_isotone:
  "x \<le> y \<Longrightarrow> x\<guillemotleft>-q \<le> y\<guillemotleft>-q"
  by (smt order_refl order_trans pre_closed pre_post_galois)

lemma pre_left_sub_dist:
  "x\<guillemotleft>-q \<le> x\<squnion>y\<guillemotleft>-q"
  by (simp add: post_pre_left_isotone)

lemma pre_post_left_isotone:
  "-p \<le> -q \<Longrightarrow> -p\<stileturn>-r \<le> -q\<stileturn>-r"
  using order_lesseq_imp pre_post_galois by blast

lemma pre_post_left_sub_dist:
  "-p\<stileturn>-r \<le> -p\<squnion>-q\<stileturn>-r"
  by (metis sup_ge1 tests_dual.inf_closed pre_post_left_isotone)

lemma pre_post_left_sup_dist:
  "-p*-q\<stileturn>-r \<le> -p\<stileturn>-r"
  by (metis tests_dual.upper_bound_left pre_post_left_isotone sub_mult_closed)

lemma pre_pre_post:
  "(x\<guillemotleft>-p)\<stileturn>-p \<le> x"
  by (metis order_refl pre_closed pre_post_galois)

lemma pre_post_pre:
  "-p \<le> (-p\<stileturn>-q)\<guillemotleft>-q"
  by (simp add: pre_post_galois)

lemma pre_post_zero_top:
  "bot\<stileturn>-q = bot"
  using bot_least order.eq_iff pre_post_galois tests_dual.sba_dual.sub_bot_def by blast

lemma pre_post_pre_one:
  "(1\<stileturn>-q)\<guillemotleft>-q = 1"
  by (metis order.eq_iff pre_below_one pre_post_pre tests_dual.sba_dual.top_double_complement)

lemma pre_post_right_antitone:
  "-p \<le> -q \<Longrightarrow> -r\<stileturn>-q \<le> -r\<stileturn>-p"
  using order_lesseq_imp pre_iso pre_post_galois by blast

lemma pre_post_right_sub_dist:
  "-r\<stileturn>-p\<squnion>-q \<le> -r\<stileturn>-p"
  by (metis sup_ge1 tests_dual.inf_closed pre_post_right_antitone)

lemma pre_post_right_sup_dist:
  "-r\<stileturn>-p \<le> -r\<stileturn>-p*-q"
  by (metis tests_dual.upper_bound_left pre_post_right_antitone sub_mult_closed)

lemma pre_top:
  "top\<guillemotleft>-q = 1"
  using order.eq_iff pre_below_one pre_post_galois tests_dual.sba_dual.one_def top_greatest by blast

lemma pre_mult_top_increasing:
  "-p \<le> -p*top\<guillemotleft>-q"
  using pre_import_equiv pre_top tests_dual.sub_bot_least by auto

lemma pre_post_below_mult_top:
  "-p\<stileturn>-q \<le> -p*top"
  using pre_import_equiv pre_post_galois by auto

lemma pre_post_import_complement:
  "--p*(-p\<stileturn>-q) = bot"
proof -
  have "--p*(-p\<stileturn>-q) \<le> --p*(-p*top)"
    by (simp add: mult_right_isotone pre_post_below_mult_top)
  thus ?thesis
    by (metis mult_assoc mult_left_zero sub_comm tests_dual.top_def order.antisym bot_least)
qed

lemma pre_post_import_same:
  "-p*(-p\<stileturn>-q) = -p\<stileturn>-q"
proof -
  have "-p\<stileturn>-q = -p*(-p\<stileturn>-q) \<squnion> --p*(-p\<stileturn>-q)"
    by (metis mult_left_one mult_right_dist_sup tests_dual.inf_complement)
  thus ?thesis
    using pre_post_import_complement by auto
qed

lemma pre_post_export:
  "-p\<stileturn>-q = -p*(1\<stileturn>-q)"
proof (rule order.antisym)
  show "-p\<stileturn>-q \<le> -p*(1\<stileturn>-q)"
    by (metis tests_dual.sub_bot_least pre_import_equiv pre_post_galois pre_post_pre_one)
next
  have 1: "-p \<le> ((-p\<stileturn>-q) \<squnion> --p*top)\<guillemotleft>-q"
    by (simp add: pre_post_galois)
  have "--p \<le> ((-p\<stileturn>-q) \<squnion> --p*top)\<guillemotleft>-q"
    by (simp add: le_supI2 pre_post_galois pre_post_below_mult_top)
  hence "-p \<squnion> --p \<le> ((-p\<stileturn>-q) \<squnion> --p*top)\<guillemotleft>-q"
    using 1 le_supI by blast
  hence "1 \<le> ((-p\<stileturn>-q) \<squnion> --p*top)\<guillemotleft>-q"
    by simp
  hence "1\<stileturn>-q \<le> (-p\<stileturn>-q) \<squnion> --p*top"
    using pre_post_galois tests_dual.sba_dual.one_def by blast
  thus "-p*(1\<stileturn>-q) \<le> -p\<stileturn>-q"
    by (simp add: shunting_top)
qed

lemma pre_post_seq_associative:
  "-r*(-p\<stileturn>-q) = -r*-p\<stileturn>-q"
  by (metis pre_post_export tests_dual.sub_sup_closed mult_assoc)

lemma pre_post_left_import_mult:
  "-r*(-p\<stileturn>-q) = -r*(-r*-p\<stileturn>-q)"
  by (metis mult_assoc tests_dual.sup_idempotent pre_post_seq_associative)

lemma seq_pre_post_sub_associative:
  "-r*(-p\<stileturn>-q) \<le> --r\<squnion>-p\<stileturn>-q"
  by (metis le_supI1 pre_post_left_sub_dist sup_commute shunting_top)

lemma pre_post_left_import_sup:
  "-r*(-p\<stileturn>-q) = -r*(--r\<squnion>-p\<stileturn>-q)"
  by (metis tests_dual.sba_dual.sub_sup_closed pre_post_seq_associative tests_dual.sup_complement_intro)

lemma pre_post_left_dist_sup:
  "-p\<squnion>-q\<stileturn>-r = (-p\<stileturn>-r) \<squnion> (-q\<stileturn>-r)"
  by (metis mult_right_dist_sup tests_dual.inf_closed pre_post_export)

lemma pre_post_reflexive:
  "-p\<stileturn>-p \<le> 1"
  using pre_one_increasing pre_post_galois by auto

lemma pre_post_compose:
  "-q \<le> -r \<Longrightarrow> -p\<stileturn>-s \<le> (-p\<stileturn>-q)*(-r\<stileturn>-s)"
  by (meson pre_compose pre_post_galois pre_post_pre pre_post_right_antitone)

lemma pre_post_compose_1:
  "-p\<stileturn>-r \<le> (-p\<stileturn>-q)*(-q\<stileturn>-r)"
  by (simp add: pre_post_compose)

lemma pre_post_compose_2:
  "(-p\<stileturn>-p)*(-p\<stileturn>-q) = -p\<stileturn>-q"
  using order.eq_iff mult_left_isotone pre_post_compose_1 pre_post_reflexive by fastforce

lemma pre_post_compose_3:
  "(-p\<stileturn>-q)*(-q\<stileturn>-q) = -p\<stileturn>-q"
  by (metis order.antisym mult_right_isotone mult_1_right pre_post_compose_1 pre_post_reflexive)

lemma pre_post_compose_4:
  "(-p\<stileturn>-p)*(-p\<stileturn>-p) = -p\<stileturn>-p"
  by (simp add: pre_post_compose_3)

lemma pre_post_one_one:
  "x\<guillemotleft>1 = 1 \<longleftrightarrow> 1\<stileturn>1 \<le> x"
  using order.eq_iff pre_below_one pre_post_galois tests_dual.sub_bot_def by force

lemma pre_one_right:
  "-p\<guillemotleft>1 = -p"
  by (metis order.antisym mult_1_right one_def tests_dual.inf_complement pre_left_sub_dist pre_mult_top_increasing pre_one pre_seq pre_test_promote pre_top)

lemma pre_pre_one:
  "x\<guillemotleft>-q = x*-q\<guillemotleft>1"
  by (metis one_def pre_one_right pre_seq)

subclass precondition_test_diamond
  apply unfold_locales
  using tests_dual.sba_dual.sub_inf_def pre_one_right pre_pre_one by auto

proposition pre_post_shunting: "x \<le> -p*-q\<stileturn>-r \<longleftrightarrow> -p*x \<le> -q\<stileturn>-r" nitpick [expect=genuine,card=3] oops
proposition "(-p\<stileturn>-q)*-r = (-p\<stileturn>-q\<squnion>-r)*-r" nitpick [expect=genuine,card=3] oops
proposition "(-p\<stileturn>-q)*-r = (-p\<stileturn>-q\<squnion>--r)*-r" nitpick [expect=genuine,card=3] oops
proposition "(-p\<stileturn>-q)*-r = (-p\<stileturn>-q*-r)*-r" nitpick [expect=genuine,card=3] oops
proposition "(-p\<stileturn>-q)*-r = (-p\<stileturn>-q*--r)*-r" nitpick [expect=genuine,card=3] oops
proposition "-p\<stileturn>-q\<squnion>-r = (-p\<stileturn>-q) \<squnion> (-p\<stileturn>-r)" nitpick [expect=genuine,card=3] oops
proposition "-p\<stileturn>-q\<squnion>-r = (-p\<stileturn>-q) * (-p\<stileturn>-r)" nitpick [expect=genuine,card=3] oops
proposition pre_post_right_dist_mult: "-p\<stileturn>-q*-r = (-p\<stileturn>-q) * (-p\<stileturn>-r)" oops
proposition pre_post_right_dist_mult: "-p\<stileturn>-q*-r = (-p\<stileturn>-q) \<squnion> (-p\<stileturn>-r)" oops
proposition post_pre_left_dist_sup: "x\<squnion>y\<guillemotleft>-q = (x\<guillemotleft>-q) \<squnion> (y\<guillemotleft>-q)" oops

end

class havoc_dual =
  fixes Hd :: "'a"

class idempotent_left_semiring_Hd = bounded_idempotent_left_semiring + havoc_dual +
  assumes Hd_total: "Hd * top = top"
  assumes Hd_least: "x * top = top \<longrightarrow> Hd \<le> x"
begin

lemma Hd_least_total:
  "x * top = top \<longleftrightarrow> Hd \<le> x"
  by (metis Hd_least Hd_total order.antisym mult_left_isotone top_greatest)

lemma Hd_reflexive:
  "Hd \<le> 1"
  by (simp add: Hd_least)

lemma Hd_transitive:
  "Hd = Hd * Hd"
  by (simp add: Hd_least Hd_total order.antisym coreflexive_transitive total_mult_closed)

end

class pre_post_spec_least_Hd = idempotent_left_semiring_Hd + pre_post_spec_least +
  assumes pre_one_mult_top: "(x\<guillemotleft>1)*top = x*top"
begin

lemma Hd_pre_one:
  "Hd\<guillemotleft>1 = 1"
  by (metis Hd_total pre_seq pre_top)

lemma pre_post_below_Hd:
  "1\<stileturn>1 \<le> Hd"
  using Hd_pre_one pre_post_one_one by auto

lemma Hd_pre_post:
  "Hd = 1\<stileturn>1"
  by (metis Hd_least Hd_pre_one Hd_total order.eq_iff pre_one_mult_top pre_post_one_one)

lemma top_left_zero:
  "top*x = top"
  by (metis mult_assoc mult_left_one mult_left_zero pre_closed pre_one_mult_top pre_seq pre_top)

lemma test_dual_test:
  "(-p\<squnion>--p*top)*-p = -p\<squnion>--p*top"
  by (simp add: top_left_zero mult_right_dist_sup mult_assoc)

lemma pre_zero_mult_top:
  "(x\<guillemotleft>bot)*top = x*bot"
  by (metis mult_assoc mult_left_zero one_def pre_one_mult_top pre_seq pre_bot)

lemma pre_one_mult_Hd:
  "(x\<guillemotleft>1)*Hd \<le> x"
  by (metis Hd_pre_post one_def pre_closed pre_post_export pre_pre_post)

lemma Hd_mult_pre_one:
  "Hd*(x\<guillemotleft>1) \<le> x"
proof -
  have 1: "-(x\<guillemotleft>1)*Hd*(x\<guillemotleft>1) \<le> x"
    by (metis Hd_pre_post le_iff_sup mult_left_isotone pre_closed pre_one_right pre_post_export pre_pre_post sup_commute sup_monoid.add_0_right tests_dual.sba_dual.one_def tests_dual.top_def)
  have "(x\<guillemotleft>1)*Hd*(x\<guillemotleft>1) \<le> x"
    by (metis mult_isotone mult_1_right one_def pre_below_one pre_one_mult_Hd)
  thus ?thesis
    using 1 by (metis case_split_left pre_closed reflexive_one_closed tests_dual.sba_dual.one_def tests_dual.sba_dual.top_def mult_assoc)
qed

lemma pre_post_one_def_1:
  assumes "1 \<le> x\<guillemotleft>-q"
    shows "Hd*(-q\<squnion>--q*top) \<le> x"
proof -
  have "Hd*(-q\<squnion>--q*top) \<le> x*-q*(-q\<squnion>--q*top)"
    by (metis assms Hd_pre_post order.antisym pre_below_one pre_post_one_one pre_pre_one mult_left_isotone)
  thus ?thesis
    by (metis mult_assoc tests_dual.sup_complement mult_left_sub_dist_sup_left mult_left_zero mult_1_right tests_dual.inf_complement test_mult_right_distr_sup order_trans)
qed

lemma pre_post_one_def:
  "1\<stileturn>-q = Hd*(-q\<squnion>--q*top)"
proof (rule order.antisym)
  have "1 \<le> (1\<stileturn>1)*(-q\<squnion>--q)\<guillemotleft>1"
    by (metis pre_post_pre one_def mult_1_right tests_dual.inf_complement)
  also have "... \<le> (1\<stileturn>1)*(-q\<squnion>--q*top)\<guillemotleft>-q"
    by (metis sup_right_isotone mult_right_isotone mult_1_right one_def post_pre_left_isotone pre_seq pre_test_promote test_dual_test top_right_mult_increasing)
  finally show "1\<stileturn>-q \<le> Hd*(-q\<squnion>--q*top)"
    using Hd_pre_post pre_post_galois tests_dual.sub_bot_def by blast
next
  show "Hd*(-q\<squnion>--q*top) \<le> 1\<stileturn>-q"
    by (simp add: pre_post_pre_one pre_post_one_def_1)
qed

lemma pre_post_def:
  "-p\<stileturn>-q = -p*Hd*(-q\<squnion>--q*top)"
  by (simp add: pre_post_export mult_assoc pre_post_one_def)

end

end


(*<*)
theory Nameless_Representation_Of_Terms
imports Main
begin
(*>*)

section {* Nameless Representation of Terms *}
text {* \label{sec:nameless-rep-of-terms} *}

text {*
In the background section on $\lambda$-calculus (Section~\ref{sec:background-lambda-calculus}), we
presented the problem of name clashes that can arise when performing $\beta$-reduction. In its
definitions and proofs, the book only works up to $\alpha$-equivalence: assuming that the variables
would be implicitly renamed if such a name clash occurred. In a separate chapter, a different
representation of terms that avoids such problem is presented. It is described as one possible
encoding that can be used when implementing an compiler for the $\lambda$-calculus.

Even though we are not building a compiler, our computer-verified formalization requires us to
explicitly handle this problem. We chose to use this representation and, thus must also formalize
this chapter.

The idea behind this representation, known as de Bruijn indices, is to make variables reference
directly their corresponding binder, rather than referring to them by name. This is accomplished by
using an index that count the number of enclosing $\lambda$-abstractions between a variable and its
binder. Following is an example of de Bruijn indices representation for the function composition
combinator:
\begin{displaymath}
  \lambda f. \ \lambda g. \ \lambda x. \ f \ (g \ x)
    \equiv \lambda \ \lambda \ \lambda \ 2 \ (1 \ 0)
\end{displaymath}

This representation releases us from having to consider the case of variable name clashes at the
expense of being harder to read and having to maintain the correct indices when adding and removing
$\lambda$-abstractions. Using this representation, we define the syntax of the untyped lambda
calculus as follow:\footnote{The prefix \emph{ul} stands for \emph{untyped lambda-calculus}.}
*}

datatype ulterm =
  ULVar nat |
  ULAbs ulterm |
  ULApp ulterm ulterm

text {*
Using this syntax, the same example of the function composition combinator looks like this:

\begin{center}
  \small
  @{term "ULAbs (ULAbs (ULAbs (ULApp (ULVar 2) (ULApp (ULVar 1) (ULVar 0)))))"}
\end{center}
*}
(*<*)
(* Definition 6.1.2 *)

inductive n_term :: "nat \<Rightarrow> ulterm \<Rightarrow> bool" where
  n_term_ULVar: "0 \<le> k \<Longrightarrow> k < n \<Longrightarrow> n_term n (ULVar k)" |
  n_term_ULAbs: "n_term n t \<Longrightarrow> n > 0 \<Longrightarrow> n_term (n - 1) (ULAbs t)" |
  n_term_ULApp: "n_term n t1 \<Longrightarrow> n_term n t2 \<Longrightarrow> n_term n (ULApp t1 t2)"

(* Definition 6.2.1 *)
(*>*)
text {*
We define a shift function serving to increase or decrease, by a fix amount @{term d}, all indices
larger than @{term c} in a term:
*}

primrec shift_UL :: "int \<Rightarrow> nat \<Rightarrow> ulterm \<Rightarrow> ulterm" where
  "shift_UL d c (ULVar k) = ULVar (if k < c then k else nat (int k + d))" |
  "shift_UL d c (ULAbs t) = ULAbs (shift_UL d (Suc c) t)" |
  "shift_UL d c (ULApp t1 t2) = ULApp (shift_UL d c t1) (shift_UL d c t2)"

text {*
In this definition, there is a possible information loss. The variables use a
natural number as index but the function allows to shift both up and down, thus the use of an
integer for the shift increment. When a variable is encountered, we first convert the index from
natural number to integer, which is always safe, perform the integer addition, which correspond to a
subtraction if @{term d} is negative, and convert the result back to natural numbers to serve as the
new index. This last operation converts negative numbers to zero. We know that this loss of
information is safe, since it makes no sense to speak of negative indices. Our @{const shift_UL}
function thus has an implicit assumption that it should not be called with a negative number larger
than the smallest free variable in the term. Following is an example of shifting up every free
variable by 2:
*}

(* Exercise 6.2.2 *)

lemma "shift_UL 2 0
  (ULAbs (ULAbs (ULApp (ULVar 1) (ULApp (ULVar 0) (ULVar 2))))) =
   ULAbs (ULAbs (ULApp (ULVar 1) (ULApp (ULVar 0) (ULVar 4))))"
  by simp

text {*
On a first reading, the previous example may seems broken: the variables @{term "ULVar 0"} and
@{term "ULVar 1"} are not incremented. This is because the shift function operates on free
variables, i.e. variables whose index refers to a non-existing $\lambda$-abstraction. Since the
binding referred by @{term "ULVar 1"} is in the term, it is not a free variable: it is bound.
*}
(*<*)

lemma "shift_UL 2 0
  (ULAbs (ULApp (ULVar 0) (ULApp (ULVar 1) (ULAbs (ULApp (ULVar 0) (ULApp (ULVar 1) (ULVar 2))))))) =
   ULAbs (ULApp (ULVar 0) (ULApp (ULVar 3) (ULAbs (ULApp (ULVar 0) (ULApp (ULVar 1) (ULVar 4))))))"
  by simp

(* Exercise 6.2.3 *)

lemma "n_term n t \<Longrightarrow> n_term (n + nat d) (shift_UL d c t)"
proof (induction n t arbitrary: d c rule: n_term.induct)
  case (n_term_ULVar k n)
  thus ?case by (auto intro: n_term.intros)
next
  case (n_term_ULAbs n t)
  thus ?case
    using n_term.n_term_ULAbs by (auto)
next
  case (n_term_ULApp n t1 t2)
  thus ?case by (auto intro: n_term.intros)
qed

(*>*)
text {*
We now define a substitution function that replaces every free variable with index @{term j} by
the term @{term s}:
\newpage
*}
(* Definition 6.2.4 *)

primrec subst_UL :: "nat \<Rightarrow> ulterm \<Rightarrow> ulterm \<Rightarrow> ulterm" where
  "subst_UL j s (ULVar k) = (if k = j then s else ULVar k)" |
  "subst_UL j s (ULAbs t) = ULAbs (subst_UL (Suc j) (shift_UL 1 0 s) t)" |
  "subst_UL j s (ULApp t1 t2) = ULApp (subst_UL j s t1) (subst_UL j s t2)"

(* Exercise 6.2.5 *)

text {*
Here is an example of substituting the variable 0 by the variable 1:
*}

lemma "subst_UL 0 (ULVar 1)
  (ULApp (ULVar 0) (ULAbs (ULAbs (ULVar 2)))) =
   ULApp (ULVar 1) (ULAbs (ULAbs (ULVar 3)))"
  by simp

text {*
Note that the indices are relative to their position in the term. This is why @{term "ULVar 2"} is
also substituted in the previous example: counting the number of enclosing $\lambda$-abstractions
shows us that this variable is, indeed, the same as @{term "ULVar 0"} outside the
$\lambda$-abstractions. Of course, we must maintain this invariant by incrementing variables in our
substituting term accordingly.
*}

(*<*)
lemma "subst_UL 0 (ULApp (ULVar 1) (ULAbs (ULVar 2)))
  (ULApp (ULVar 0) (ULAbs (ULVar 1))) =
   ULApp (ULApp (ULVar 1) (ULAbs (ULVar 2))) (ULAbs (ULApp (ULVar 2) (ULAbs (ULVar 3))))"
  by simp

lemma "subst_UL 0 (ULVar 1)
  (ULAbs (ULApp (ULVar 0) (ULVar 2))) =
   ULAbs (ULApp (ULVar 0) (ULVar 2))"
  by simp

lemma "subst_UL 0 (ULVar 1)
  (ULAbs (ULApp (ULVar 1) (ULVar 0))) =
   ULAbs (ULApp (ULVar 2) (ULVar 0))"
  by simp

(* Exercise 6.2.6 *)

lemma n_term_shift_UL: "n_term n t \<Longrightarrow> n_term (n + nat j) (shift_UL j i t)"
  by (induction n t arbitrary: j i rule: n_term.induct)
    (auto intro: n_term.intros n_term_ULAbs[unfolded One_nat_def])

lemma "n_term n t \<Longrightarrow> n_term n s \<Longrightarrow> j \<le> n \<Longrightarrow> n_term n (subst_UL j s t)"
proof (induction n t arbitrary: s j rule: n_term.induct)
  case (n_term_ULVar k n)
  thus ?case by (auto intro: n_term.n_term_ULVar)
next
  case (n_term_ULAbs n t)
  thus ?case
    using n_term.intros n_term_shift_UL[OF n_term_ULAbs.prems(1), where j = 1]
    by (auto
      intro: n_term_ULAbs.IH
      intro!: n_term.n_term_ULAbs[unfolded One_nat_def]
      simp: n_term_shift_UL[OF n_term_ULAbs.prems(1), where j = 1])
next
  case (n_term_ULApp n t1 t2)
  thus ?case by (simp add: n_term.intros)
qed

end
(*>*)


(* Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com>
   Dedicated to Sandra H. for a wonderful relaxing summer
*)

section \<open>Euler's Partition Theorem\<close>

theory Euler_Partition
imports
  Main
  Card_Number_Partitions.Number_Partition
begin

subsection \<open>Preliminaries\<close>

subsubsection \<open>Additions to Divides Theory\<close>

lemma power_div_nat:
  assumes "c \<le> b"
  assumes "a > 0"
  shows  "(a :: nat) ^ b div a ^ c = a ^ (b - c)"
by (metis assms nonzero_mult_div_cancel_right le_add_diff_inverse2 less_not_refl2 power_add power_not_zero)

subsubsection \<open>Additions to Groups-Big Theory\<close>

lemma sum_div:
  assumes "finite A"
  assumes "\<And>a. a \<in> A \<Longrightarrow> (b::'b::euclidean_semiring) dvd f a"
  shows "(\<Sum>a\<in>A. f a) div b = (\<Sum>a\<in>A. (f a) div b)"
using assms
proof (induct)
  case insert from this show ?case by auto (subst div_add; auto intro!: dvd_sum)
qed (auto)

lemma sum_mod:
  assumes "finite A"
  assumes "\<And>a. a \<in> A \<Longrightarrow> f a mod b = (0::'b::unique_euclidean_semiring)"
  shows "(\<Sum>a\<in>A. f a) mod b = 0"
using assms by induct (auto simp add: mod_add_eq [symmetric])

subsubsection \<open>Additions to Finite-Set Theory\<close>

lemma finite_exponents:
  "finite {i. 2 ^ i \<le> (n::nat)}"
proof -
  have "{i::nat. 2 ^ i \<le> n} \<subseteq> {0..n}"
    using dual_order.trans by fastforce
  from finite_subset[OF this] show ?thesis by simp
qed

subsection \<open>Binary Encoding of Natural Numbers\<close>

definition bitset :: "nat \<Rightarrow> nat set"
where
  "bitset n = {i. odd (n div (2 ^ i))}"

lemma in_bitset_bound:
  "b \<in> bitset n \<Longrightarrow> 2 ^ b \<le> n"
unfolding bitset_def using not_less by fastforce

lemma in_bitset_bound_weak:
  "b \<in> bitset n \<Longrightarrow> b \<le> n"
by (meson order.trans in_bitset_bound self_le_ge2_pow[OF order_refl])

lemma finite_bitset:
  "finite (bitset n)"
proof -
  have "bitset n \<subseteq> {..n}" by (auto dest: in_bitset_bound_weak)
  from this show ?thesis using finite_subset by auto
qed

lemma bitset_0:
  "bitset 0 = {}"
unfolding bitset_def by auto

lemma bitset_2n: "bitset (2 * n) = Suc ` (bitset n)"
proof (rule set_eqI)
  fix x
  show "(x \<in> bitset (2 * n)) = (x \<in> Suc ` bitset n)"
    unfolding bitset_def by (cases x) auto
qed

lemma bitset_Suc:
  assumes "even n"
  shows "bitset (n + 1) = insert 0 (bitset n)"
proof (rule set_eqI)
  fix x
  from assms show "(x \<in> bitset (n + 1)) = (x \<in> insert 0 (bitset n))"
    unfolding bitset_def by (cases x) (auto simp add: Divides.div_mult2_eq)
qed

lemma bitset_2n1:
  "bitset (2 * n + 1) = insert 0 (Suc ` (bitset n))"
by (subst bitset_Suc) (auto simp add: bitset_2n)

lemma sum_bitset:
  "(\<Sum>i\<in>bitset n. 2 ^ i) = n"
proof (induct rule: nat_bit_induct)
  case zero
  show ?case by (auto simp add: bitset_0)
next
  case (even n)
  from this show ?case
    by (simp add: bitset_2n sum.reindex sum_distrib_left[symmetric])
next
  case (odd n)
  have "(\<Sum>i\<in>bitset (2 * n + 1). 2 ^ i) = (\<Sum>i\<in>insert 0 (Suc ` bitset n). 2 ^ i)"
    by (simp only: bitset_2n1)
  also have "... = 2 ^ 0 + (\<Sum>i\<in>Suc ` bitset n. 2 ^ i)"
    by (subst sum.insert) (auto simp add: finite_bitset)
  also have "... = 2 * n + 1"
    using odd by (simp add: sum.reindex sum_distrib_left[symmetric])
  finally show ?case by simp
qed

lemma binarysum_div:
  assumes "finite B"
  shows "(\<Sum>i\<in>B. (2::nat) ^ i) div 2 ^ j = (\<Sum>i\<in>B. if i < j then 0 else 2 ^ (i - j))"
  (is "_ = (\<Sum>i\<in>_. ?f i)")
proof -
  have split_B: "B = {i\<in>B. i < j} \<union> {i\<in>B. j \<le> i}" by auto
  have bound: "(\<Sum>i | i \<in> B \<and> i < j. (2::nat) ^ i) < 2 ^ j"
  proof (rule order.strict_trans1)
    show "(\<Sum>i | i \<in> B \<and> i < j. (2::nat) ^ i) \<le> (\<Sum>i<j. 2 ^ i)" by (auto intro: sum_mono2)
    show "... < 2 ^ j" using sum_power2 by (simp add: atLeast0LessThan)
  qed
  from this have zero: "(\<Sum>i | i \<in> B \<and> i < j. (2::nat) ^ i) div (2 ^ j) = 0" by (elim div_less)
  from assms have mod0: "(\<Sum>i | i \<in> B \<and> j \<le> i. (2::nat) ^ i) mod 2 ^ j = 0"
    by (auto intro!: sum_mod simp add: le_imp_power_dvd)
  from assms have "(\<Sum>i\<in>B. (2::nat) ^ i) div (2 ^ j) = ((\<Sum>i | i \<in> B \<and> i < j. 2 ^ i) + (\<Sum>i | i \<in> B \<and> j \<le> i. 2 ^ i)) div 2 ^ j"
    by (subst sum.union_disjoint[symmetric]) (auto simp add: split_B[symmetric])
  also have "... = (\<Sum>i | i \<in> B \<and> j \<le> i. 2 ^ i) div 2 ^ j"
    by (simp add: div_add1_eq zero mod0)
  also have "... = (\<Sum>i | i \<in> B \<and> j \<le> i. 2 ^ i div 2 ^ j)"
    using assms by (subst sum_div) (auto simp add: sum_div le_imp_power_dvd)
  also have "... = (\<Sum>i | i \<in> B \<and> j \<le> i. 2 ^ (i - j))"
    by (rule sum.cong[OF refl]) (auto simp add: power_div_nat)
  also have "... = (\<Sum>i\<in>B. ?f i)"
    using assms by (subst split_B; subst sum.union_disjoint) auto
  finally show ?thesis .
qed

lemma odd_iff:
  assumes "finite B"
  shows "odd (\<Sum>i\<in>B. if i < x then (0::nat) else 2 ^ (i - x)) = (x \<in> B)" (is "odd (\<Sum>i\<in>_. ?s i) = _")
proof -
  from assms have even: "even (\<Sum>i\<in>B - {x}. ?s i)"
    by (subst dvd_sum) auto
  show ?thesis
  proof
    assume "odd (\<Sum>i\<in>B. ?s i)"
    from this even show "x \<in> B" by (cases "x \<in> B") auto
  next
    assume "x \<in> B"
    from assms this have "(\<Sum>i\<in>B. ?s i) = 1 + (\<Sum>i\<in>B-{x}. ?s i)"
      by (auto simp add: sum.remove)
    from assms this even show "odd (\<Sum>i\<in>B. ?s i)" by auto
  qed
qed

lemma bitset_sum:
  assumes "finite B"
  shows "bitset (\<Sum>i\<in>B. 2 ^ i) = B"
using assms unfolding bitset_def by (simp add: binarysum_div odd_iff)

subsection \<open>Decomposition of a Number into a Power of Two and an Odd Number\<close>

function (sequential) index :: "nat \<Rightarrow> nat"
where
  "index 0 = 0"
| "index n = (if odd n then 0 else Suc (index (n div 2)))"
by (pat_completeness) auto

termination
proof
  show "wf {(x::nat, y). x < y}" by (simp add: wf)
next
  fix n show "(Suc n div 2, Suc n) \<in> {(x, y). x < y}" by simp
qed

function (sequential) oddpart :: "nat \<Rightarrow> nat"
where
  "oddpart 0 = 0"
| "oddpart n = (if odd n then n else oddpart (n div 2))"
by pat_completeness auto

termination
proof
  show "wf {(x::nat, y). x < y}" by (simp add: wf)
next
  fix n show "(Suc n div 2, Suc n) \<in> {(x, y). x < y}" by simp
qed

lemma odd_oddpart:
  "odd (oddpart n) \<longleftrightarrow> n \<noteq> 0"
by (induct n rule: index.induct) auto

lemma index_oddpart_decomposition:
  "n = 2 ^ (index n) * oddpart n"
proof (induct n rule: index.induct)
  case (2 n)
  from this show "Suc n = 2 ^ index (Suc n) * oddpart (Suc n)"
    by (simp add: mult.assoc)
qed (simp)

lemma oddpart_leq:
  "oddpart n \<le> n"
by (induct n rule: index.induct) (simp, metis div_le_dividend le_Suc_eq le_trans oddpart.simps(2))

lemma index_oddpart_unique:
  assumes "odd (m :: nat)" "odd m'"
  shows "(2 ^ i * m = 2 ^ i' * m') \<longleftrightarrow> (i = i' \<and> m = m')"
proof (induct i arbitrary: i')
  case 0
  from assms show ?case by auto
next
  case (Suc _ i')
  from assms this show ?case by (cases i') auto
qed

lemma index_oddpart:
  assumes "odd m"
  shows "index (2 ^ i * m) = i" "oddpart (2 ^ i * m) = m"
using index_oddpart_unique[where i=i and m=m and m'="oddpart (2 ^ i * m)" and i'="index (2 ^ i * m)"]
  assms odd_oddpart index_oddpart_decomposition by force+

subsection \<open>Partitions With Only Distinct and Only Odd Parts\<close>

definition odd_of_distinct :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat"
where
  "odd_of_distinct p = (\<lambda>i. if odd i then (\<Sum>j | p (2 ^ j * i) = 1. 2 ^ j) else 0)"

definition distinct_of_odd :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat"
where
  "distinct_of_odd p = (\<lambda>i. if index i \<in> bitset (p (oddpart i)) then 1 else 0)"

lemma odd:
  "odd_of_distinct p i \<noteq> 0 \<Longrightarrow> odd i"
unfolding odd_of_distinct_def by auto

lemma odd_of_distinct:
  assumes "odd_of_distinct p i \<noteq> 0"
  assumes "\<And>i. p i \<noteq> 0 \<Longrightarrow> i \<le> n"
  shows "1 \<le> i \<and> i \<le> n"
proof
  from assms(1) odd have "odd i"
    by simp
  then show "1 \<le> i"
    by (auto elim: oddE)
next
  from assms(1) obtain j where "p (2 ^ j * i) > 0"
    by (auto simp add: odd_of_distinct_def split: if_splits) fastforce
  with assms(2) have "i \<le> 2 ^ j * i" "2 ^ j * i \<le> n"
    by simp_all
  then show "i \<le> n"
    by (rule order_trans)
qed

lemma distinct_of_odd:
  assumes "\<And>i. p i * i \<le> n" "\<And>i. p i \<noteq> 0 \<Longrightarrow> odd i"
  assumes "distinct_of_odd p i \<noteq> 0"
  shows "1 \<le> i \<and> i \<le> n"
proof
  from assms(3) have index: "index i \<in> bitset (p (oddpart i))"
    unfolding distinct_of_odd_def by (auto split: if_split_asm)
  have "i \<noteq> 0"
  proof
    assume zero: "i = 0"
    from assms(2) have "p 0 = 0" by auto
    from index zero this show "False" by (auto simp add: bitset_0)
  qed
  from this show "1 \<le> i" by auto
  from assms(1) have leq_n: "p (oddpart i) * oddpart i \<le> n" by auto
  from index have "2 ^ index i \<le> p (oddpart i)" by (rule in_bitset_bound)
  from this leq_n show "i \<le> n"
    by (subst index_oddpart_decomposition[of i]) (meson dual_order.trans eq_imp_le mult_le_mono)
qed

lemma odd_distinct:
  assumes "\<And>i. p i \<noteq> 0 \<Longrightarrow> odd i"
  shows "odd_of_distinct (distinct_of_odd p) = p"
using assms unfolding odd_of_distinct_def distinct_of_odd_def
by (auto simp add: fun_eq_iff index_oddpart sum_bitset)

lemma distinct_odd:
  assumes "\<And>i. p i \<noteq> 0 \<Longrightarrow> 1 \<le> i \<and> i \<le> n" "\<And>i. p i \<le> 1"
  shows "distinct_of_odd (odd_of_distinct p) = p"
proof -
  from assms have "{i. p i = 1} \<subseteq> {..n}" by auto
  from this have finite: "finite {i. p i = 1}" by (simp add: finite_subset)
  have "\<And>x j. x > 0 \<Longrightarrow> p (2 ^ j * oddpart x) = 1 \<Longrightarrow>
    index (2 ^ j * oddpart x) \<in> index ` {i. p i = 1 \<and> oddpart x = oddpart i}"
    by (rule imageI) (auto intro: imageI simp add: index_oddpart odd_oddpart)
  from this have eq: "\<And>x. x > 0 \<Longrightarrow> {j. p (2 ^ j * oddpart x) = 1} = index ` {i. p i = 1 \<and> oddpart x = oddpart i}"
    by (auto simp add: index_oddpart odd_oddpart index_oddpart_decomposition[symmetric])
  from finite have all_finite: "\<And>x. x > 0 \<Longrightarrow> finite {j. p (2 ^ j * oddpart x) = 1}"
    unfolding eq by auto
  show ?thesis
  proof
    fix x
    from assms(1) have p0: "p 0 = 0" by auto
    show "distinct_of_odd (odd_of_distinct p) x = p x"
    proof (cases "x > 0")
      case False
      from this p0 show ?thesis
        unfolding odd_of_distinct_def distinct_of_odd_def
        by (auto simp add: odd_oddpart bitset_0)
    next
      case True
      from p0 assms(2)[of x] all_finite[OF True] show ?thesis
        unfolding odd_of_distinct_def distinct_of_odd_def
        by (auto simp add: odd_oddpart bitset_0 bitset_sum index_oddpart_decomposition[symmetric])
    qed
  qed
qed

lemma sum_distinct_of_odd:
  assumes "\<And>i. p i \<noteq> 0 \<Longrightarrow> 1 \<le> i \<and> i \<le> n"
  assumes "\<And>i. p i * i \<le> n"
  assumes "\<And>i. p i \<noteq> 0 \<Longrightarrow> odd i"
  shows "(\<Sum>i\<le>n. distinct_of_odd p i * i) = (\<Sum>i\<le>n. p i * i)"
proof -
  {
    fix m
    assume odd: "odd (m :: nat)"
    have finite: "finite {k. 2 ^ k * m \<le> n \<and> k \<in> bitset (p m)}" by (simp add: finite_bitset)
    have "(\<Sum>i | \<exists>k. i = 2 ^ k * m \<and> i \<le> n. distinct_of_odd p i * i) =
      (\<Sum>i | \<exists>k. i = 2 ^ k * m \<and> i \<le> n. if index i \<in> bitset (p (oddpart i)) then i else 0)"
      unfolding distinct_of_odd_def by (auto intro: sum.cong)
    also have "... = (\<Sum>i | \<exists>k. i = 2 ^ k * m \<and> k \<in> bitset (p m) \<and> i \<le> n. i)"
      using odd by (intro sum.mono_neutral_cong_right) (auto simp add: index_oddpart)
    also have "... = (\<Sum>k | 2 ^ k * m \<le> n \<and> k \<in> bitset (p m). 2 ^ k * m)"
      using odd by (auto intro!: sum.reindex_cong[OF _ _ refl] inj_onI)
    also have "... = (\<Sum>k\<in>bitset (p m). 2 ^ k * m)"
      using assms(2)[of m] finite dual_order.trans in_bitset_bound
      by (fastforce intro!: sum.mono_neutral_cong_right)
    also have "... = (\<Sum>k\<in>bitset (p m). 2 ^ k) * m"
      by (subst sum_distrib_right) auto
    also have "... = p m * m"
      by (auto simp add: sum_bitset)
    finally have "(\<Sum>i | \<exists>k. i = 2 ^ k * m \<and> i \<le> n. distinct_of_odd p i * i) = p m * m" .
  } note inner_eq = this

  have set_eq: "{i. 1 \<le> i \<and> i \<le> n} = \<Union>((\<lambda>m. {i. \<exists>k. i = (2 ^ k) * m \<and> i \<le> n}) ` {m. m \<le> n \<and> odd m})"
  proof -
    {
      fix x
      assume "1 \<le> x" "x \<le> n"
      from this oddpart_leq[of x] have "oddpart x \<le> n \<and> odd (oddpart x) \<and> (\<exists>k. 2 ^ index x * oddpart x = 2 ^ k * oddpart x)"
        by (auto simp add: odd_oddpart)
      from this have "\<exists>m\<le>n. odd m \<and> (\<exists>k. x = 2 ^ k * m)"
        by (auto simp add: index_oddpart_decomposition[symmetric])
    }
    from this show ?thesis by (auto simp add: Suc_leI odd_pos)
  qed
  let ?S = "(\<lambda>m. {i. \<exists>k. i = 2 ^ k * m \<and> i \<le> n}) ` {m. m \<le> n \<and> odd m}"
  have no_overlap: "\<forall>A\<in>?S. \<forall>B\<in>?S. A \<noteq> B \<longrightarrow> A \<inter> B = {}"
    by (auto simp add: index_oddpart_unique)
  have inj: "inj_on (\<lambda>m. {i. (\<exists>k. i = 2 ^ k * m) \<and> i \<le> n}) {m. m \<le> n \<and> odd m}"
    unfolding inj_on_def by auto (force simp add: index_oddpart_unique)
  have reindex: "\<And>F. (\<Sum>i | 1 \<le> i \<and> i \<le> n. F i) = (\<Sum>m | m \<le> n \<and> odd m. (\<Sum>i | \<exists>k. i = 2 ^ k * m \<and> i \<le> n. F i))"
    unfolding set_eq by (subst sum.Union_disjoint) (auto simp add: no_overlap intro: sum.reindex_cong[OF inj])
  have "(\<Sum>i\<le>n. distinct_of_odd p i * i) =  (\<Sum>i | 1 \<le> i \<and> i \<le> n. distinct_of_odd p i * i)"
    by (auto intro: sum.mono_neutral_right)
  also have "... = (\<Sum>m | m \<le> n \<and> odd m. \<Sum>i | \<exists>k. i = 2 ^ k * m \<and> i \<le> n. distinct_of_odd p i * i)"
    by (simp only: reindex)
  also have "... = (\<Sum>i | i \<le> n \<and> odd i. p i * i)"
    by (rule sum.cong[OF refl]; subst inner_eq) auto
  also have "... = (\<Sum>i\<le>n. p i * i)"
    using assms(3) by (auto intro: sum.mono_neutral_left)
  finally show ?thesis .
qed

lemma leq_n:
  assumes "\<forall>i. 0 < p i \<longrightarrow> 1 \<le> i \<and> i \<le> (n::nat)"
  assumes "(\<Sum>i\<le>n. p i * i) = n"
  shows "p i * i \<le> n"
proof (rule ccontr)
  assume "\<not> p i * i \<le> n"
  from this have gr_n: "p i * i > n" by auto
  from this assms(1) have "1 \<le> i \<and> i \<le> n" by force
  from this have "(\<Sum>j\<le>n. p j * j) = p i * i + (\<Sum>j | j \<le> n \<and> j \<noteq> i. p j * j)"
    by (subst sum.insert[symmetric]) (auto intro: sum.cong simp del: sum.insert)
  from this gr_n assms(2) show False by simp
qed

lemma distinct_of_odd_in_distinct_partitions:
  assumes "p \<in> {p. p partitions n \<and> (\<forall>i. p i \<noteq> 0 \<longrightarrow> odd i)}"
  shows "distinct_of_odd p \<in> {p. p partitions n \<and> (\<forall>i. p i \<le> 1)}"
proof
  have "distinct_of_odd p partitions n"
  proof (rule partitionsI)
    fix i assume "distinct_of_odd p i \<noteq> 0"
    from this assms show "1 \<le> i \<and> i \<le> n"
    unfolding partitions_def
    by (rule_tac distinct_of_odd) (auto simp add: leq_n)
  next
    from assms show "(\<Sum>i\<le>n. distinct_of_odd p i * i) = n"
      by (subst  sum_distinct_of_odd) (auto simp add: distinct_distinct_of_odd leq_n elim: partitionsE)
  qed
  moreover have "\<forall>i. distinct_of_odd p i \<le> 1"
    by (intro allI distinct_distinct_of_odd)
  ultimately show "distinct_of_odd p partitions n \<and> (\<forall>i. distinct_of_odd p i \<le> 1)" by simp
qed

lemma odd_of_distinct_in_odd_partitions:
  assumes "p \<in> {p. p partitions n \<and> (\<forall>i. p i \<le> 1)}"
  shows "odd_of_distinct p \<in> {p. p partitions n \<and> (\<forall>i. p i \<noteq> 0 \<longrightarrow> odd i)}"
proof
  from assms have distinct: "\<And>i. p i = 0 \<or> p i = 1"
    using le_imp_less_Suc less_Suc_eq_0_disj by fastforce
  from assms have set_eq: "{x. p x = 1} = {x \<in> {..n}. p x = 1}"
     unfolding partitions_def by auto
  from assms have sum: "(\<Sum>i\<le>n. p i * i) = n"
     unfolding partitions_def by auto
  {
    fix i
    assume i: "odd (i :: nat)"
    have 3: "inj_on index {x. p x = 1 \<and> oddpart x = i}"
      unfolding inj_on_def by auto (metis index_oddpart_decomposition)
    {
      fix j assume "p (2 ^ j * i) = 1"
      from this i have "j \<in> index ` {x. p x = 1 \<and> oddpart x = i}"
        by (auto simp add: index_oddpart(1, 2) intro!: image_eqI[where x="2 ^ j * i"])
    }
    from i this have "{j. p (2 ^ j * i) = 1} = index ` {x. p x = 1 \<and> oddpart x = i}"
      by (auto simp add: index_oddpart_decomposition[symmetric])
    from 3 this have "(\<Sum>j | p (2 ^ j * i) = 1. 2 ^ j) * i = (\<Sum>x | p x = 1 \<and> oddpart x = i. 2 ^ index x) * i"
      by (auto intro: sum.reindex_cong[where l = "index"])
    also have "... = (\<Sum>x | p x = 1 \<and> oddpart x = i. 2 ^ index x * oddpart x)"
      by (auto simp add: sum_distrib_right)
    also have "... = (\<Sum>x | p x = 1 \<and> oddpart x = i. x)"
       by (simp only: index_oddpart_decomposition[symmetric])
    also have "... \<le> (\<Sum>x | p x = 1. x)"
      using set_eq by (intro sum_mono2) auto
    also have "... = (\<Sum>x\<le>n. p x * x)"
      using distinct by (subst set_eq) (force intro!: sum.mono_neutral_cong_left)
    also have "... = n" using sum .
    finally have "(\<Sum>j | p (2 ^ j * i) = 1. 2 ^ j) * i \<le> n" .
  }
  from this have less_n: "\<And>i. odd_of_distinct p i * i \<le> n"
    unfolding odd_of_distinct_def by auto
  have "odd_of_distinct p partitions n"
  proof (rule partitionsI)
    fix i assume "odd_of_distinct p i \<noteq> 0"
    from this assms show "1 \<le> i \<and> i \<le> n"
      by (elim CollectE conjE partitionsE odd_of_distinct) auto
  next
    have "(\<Sum>i\<le>n. odd_of_distinct p i * i) = (\<Sum>i\<le>n. distinct_of_odd (odd_of_distinct p) i * i)"
      using assms less_n by (subst sum_distinct_of_odd) (auto elim!: partitionsE odd_of_distinct simp only: odd)
    also have "... = (\<Sum>i\<le>n. p i * i)" using assms
      by (auto elim!: partitionsE simp only:) (subst distinct_odd, auto)
    also with assms have "... = n" by (auto elim: partitionsE)
    finally show "(\<Sum>i\<le>n. odd_of_distinct p i * i) = n" .
  qed
  moreover have "\<forall>i. odd_of_distinct p i \<noteq> 0 \<longrightarrow> odd i"
    by (intro allI impI odd)
  ultimately show "odd_of_distinct p partitions n \<and> (\<forall>i. odd_of_distinct p i \<noteq> 0 \<longrightarrow> odd i)" by simp
qed

subsection \<open>Euler's Partition Theorem\<close>

theorem Euler_partition_theorem:
  "card {p. p partitions n \<and> (\<forall>i. p i \<le> 1)} = card {p. p partitions n \<and> (\<forall>i. p i \<noteq> 0 \<longrightarrow> odd i)}"
  (is "card ?distinct_partitions = card ?odd_partitions")
proof (rule card_bij_eq)
  from odd_of_distinct_in_odd_partitions show
    "odd_of_distinct ` ?distinct_partitions \<subseteq> ?odd_partitions" by auto
  moreover from distinct_of_odd_in_distinct_partitions show
    "distinct_of_odd ` ?odd_partitions \<subseteq> ?distinct_partitions" by auto
  moreover have "\<forall>p\<in>?distinct_partitions. distinct_of_odd (odd_of_distinct p) = p"
    by auto (subst distinct_odd; auto simp add: partitions_def)
  moreover have "\<forall>p\<in>?odd_partitions. odd_of_distinct (distinct_of_odd p) = p"
    by auto (subst odd_distinct; auto simp add: partitions_def)
  ultimately show "inj_on odd_of_distinct ?distinct_partitions"
    "inj_on distinct_of_odd ?odd_partitions"
    by (intro bij_betw_imp_inj_on bij_betw_byWitness; auto)+
  show "finite ?distinct_partitions" "finite ?odd_partitions"
    by (simp add: finite_partitions)+
qed

end


theory Binary_Decision_Diagrams_list
  imports
    Main
    "Boolean_Expression_Checkers.Boolean_Expression_Checkers"
    "Boolean_Expression_Checkers.Boolean_Expression_Checkers_AList_Mapping"
begin

text\<open>Beware that following @{term val_ifex} definition the left branch
corresponds to @{term True} and the left branch to @{term False}\<close>

fun depth :: "'a ifex \<Rightarrow> nat"
  where
    "depth Trueif = 0" | "depth Falseif = 0" |
    "depth (IF b t f) = 1 + max (depth t) (depth f)"

fun Alexander_dual :: "'a ifex \<Rightarrow> 'a ifex"
  where "Alexander_dual Trueif = Falseif" |
    "Alexander_dual Falseif = Trueif" |
    "Alexander_dual (IF b t f) = (IF b (Alexander_dual f) (Alexander_dual t))"

lift_definition neg_env :: "'a env_bool \<Rightarrow> 'a env_bool"
  is "\<lambda>m k. case m k of None \<Rightarrow> None | Some v \<Rightarrow> Some (\<not> v)" .

lemma "val_ifex (Alexander_dual t) env = (\<not> val_ifex (t) (\<lambda>x. \<not> env x))"
  by (induct t) auto

lemma "depth (Alexander_dual t) = depth t"
  by (induct t) auto

lemma "Alexander_dual (Alexander_dual t) = t"
  by (induct t) auto

value "Alexander_dual (IF (1::int) Trueif Falseif)"

value "Alexander_dual (IF (1::int) (IF 2 (Trueif) (Falseif))
                         (IF 3 (Trueif) (Falseif)))"

value "Alexander_dual (IF (1::int) (IF 2 ((IF 3 (Falseif) (Trueif))) (Falseif))
                         (IF 3 (Trueif) (Falseif)))"

text\<open>Beware that the depth of a reduced BDT is not always smaller than the
  one of the original BDT (it may depend on the chosen environment).\<close>

value "depth (IF finite_4.a\<^sub>1 (IF finite_4.a\<^sub>2 (IF finite_4.a\<^sub>3 Trueif Falseif) (IF finite_4.a\<^sub>4 Falseif Trueif)) Trueif)"

value "depth (IF finite_4.a\<^sub>1
                (IF finite_4.a\<^sub>1
                  (IF finite_4.a\<^sub>2 (IF finite_4.a\<^sub>3 Trueif Falseif)
                                  (IF finite_4.a\<^sub>4 Falseif Trueif))
                  Trueif)
                Trueif)"

value "depth (reduce_alist  [(finite_4.a\<^sub>1, True)]
    (IF finite_4.a\<^sub>1 (IF finite_4.a\<^sub>2 (IF finite_4.a\<^sub>3 Trueif Falseif) (IF finite_4.a\<^sub>4 Falseif Trueif))
                      Trueif))"

value "depth (reduce_alist [(finite_4.a\<^sub>1, True)] (IF finite_4.a\<^sub>1
                (IF finite_4.a\<^sub>1
                  (IF finite_4.a\<^sub>2 (IF finite_4.a\<^sub>3 Trueif Falseif)
                                  (IF finite_4.a\<^sub>4 Falseif Trueif))
                  Trueif)
                Trueif))"

value "depth (reduce_alist  [] (IF finite_4.a\<^sub>1
                (IF finite_4.a\<^sub>1
                  (IF finite_4.a\<^sub>2 (IF finite_4.a\<^sub>3 Trueif Falseif)
                                  (IF finite_4.a\<^sub>4 Falseif Trueif))
                  Trueif)
                Trueif))"

value "depth (reduce_alist  [(finite_4.a\<^sub>1, False)]
    (IF finite_4.a\<^sub>1 (IF finite_4.a\<^sub>2 (IF finite_4.a\<^sub>3 Trueif Falseif) (IF finite_4.a\<^sub>4 Falseif Trueif))
                      Trueif))"

lemma depth_mkIF: "depth (mkIF x t1 t2) \<le> Suc (max (depth t1) (depth t2))"
  unfolding mkIF_def by auto

fun vars :: "'a ifex \<Rightarrow> 'a set"
  where "vars (IF x t f) = insert x (vars t \<union> vars f)" |
        "vars _ = {}"

lemma vars_IFT_subset: "vars t \<subseteq> vars (IF x t f)" by auto
lemma vars_IFF_subset: "vars f \<subseteq> vars (IF x t f)" by auto

lemma vars_mkIF: "vars (mkIF x t f) \<subseteq> vars (IF x t f)"
  by (metis dual_order.eq_iff mkIF_def vars_IFT_subset)

lemma
  shows "vars (reduce env b) \<subseteq> vars b"
proof (induction b arbitrary: env)
  case Trueif
  then show ?case by simp
next
  case Falseif
  then show ?case by simp
next
  case (IF x1 b1 b2)
  show ?case
  proof (cases "Mapping.lookup env x1 = None")
    case True
    have vt: "vars (reduce (Mapping.update x1 True env) b1) \<subseteq> vars b1"
        and vf: "vars (reduce (Mapping.update x1 False env) b2) \<subseteq> vars b2"
      using IF.IH by simp_all
    with vars_mkIF show ?thesis unfolding reduce.simps using True by fastforce
  next
    case False
    have vt: "vars (reduce env b1) \<subseteq> vars b1"
        and vf: "vars (reduce env b2) \<subseteq> vars b2" using IF.IH by simp_all
    thus ?thesis unfolding reduce.simps using False
      by auto (metis (mono_tags, lifting) subset_eq)
  qed
qed

fun ifex_no_twice where
  "ifex_no_twice (IF v t e) = (
  v \<notin> (vars t \<union> vars e) \<and> ifex_no_twice t \<and> ifex_no_twice e)" |
 "ifex_no_twice _ = True"

lemma
  env_not_in_vars:
  assumes m: "Mapping.lookup env x = Some b"
  shows "x \<notin> vars (reduce env bdd)"
  using m proof (induction bdd arbitrary: env b)
  case Trueif
  then show ?case by simp
next
  case Falseif
  then show ?case by simp
next
  case (IF x1 bdd1 bdd2 _ b)
  show ?case
  proof (cases "x = x1")
    case True
    have rw: "reduce env (IF x1 bdd1 bdd2) = reduce env (if b then bdd1 else bdd2)"
      using IF.prems True unfolding reduce.simps by auto
    show ?thesis unfolding rw using IF.IH [OF IF.prems] by (cases b, auto)
  next
    case False
    have "x \<notin> vars (reduce (Mapping.update x1 True env) bdd1)"
      and "x \<notin> vars (reduce (Mapping.update x1 False env) bdd2)"
      using False IF.IH(1,2) IF.prems by auto
    moreover have "x \<notin> vars (reduce env bdd1)"
      and "x \<notin> vars (reduce env bdd2)"
      using False IF.IH(1,2) IF.prems by auto
    ultimately show ?thesis unfolding reduce.simps
      apply (cases "Mapping.lookup env x1 = None")
      using False unfolding mkIF_def by (simp_all) force
  qed
qed

lemma "x \<notin> vars (reduce (Mapping.update x b env) bdd)"
  using env_not_in_vars by force

lemma "ifex_no_twice (reduce env b)"
proof (induction b arbitrary: env)
  case Trueif
  then show ?case by simp
next
  case Falseif
  then show ?case by simp
next
  case (IF x1 b1 b2)
  show ?case
  proof (cases "Mapping.lookup env x1 = None")
    case True
    have vt: "ifex_no_twice (reduce (Mapping.update x1 True env) b1)"
        and vf: "ifex_no_twice (reduce (Mapping.update x1 False env) b2)"
      using IF.IH by simp_all
    show ?thesis unfolding reduce.simps using True
      by auto (simp add: env_not_in_vars mkIF_def vf vt)
  next
    case False
    have vt: "ifex_no_twice (reduce env b1)"
        and vf: "ifex_no_twice (reduce env b2)"
      using IF.IH by simp_all
    show ?thesis unfolding reduce.simps using False
      using vf vt by force
  qed
qed

lemma
  depth_reduce_le:
  assumes ib: "ifex_no_twice b"
    and k: "vars b \<inter> Mapping.keys env = {}"
  shows "depth (reduce env b) \<le> depth b"
using ib k proof (induction b arbitrary: env)
  case Trueif show ?case by simp
next
  case Falseif show ?case by simp
next
  case (IF x t f)
  from IF.prems
  have int: "ifex_no_twice t" and inf: "ifex_no_twice f"
    and xt: "x \<notin> vars t" and xf: "x \<notin> vars f"
    and vt: "vars t \<inter> Mapping.keys (Mapping.update x True env) = {}"
    and vf: "vars f \<inter> Mapping.keys (Mapping.update x False env) = {}"
    by auto
  have drdt: "depth (reduce (Mapping.update x True env) t) \<le> depth t"
    and drdf: "depth (reduce (Mapping.update x False env) f) \<le> depth f"
     by (rule IF.IH, intro int, intro vt)
          (rule IF.IH, intro inf, intro vf)
  have mlxnone: "Mapping.lookup env x = None"
     using IF.prems (2)
     by (metis disjoint_iff_not_equal domIff insertCI keys_dom_lookup vars.simps(1))
  have "depth (reduce env (IF x t f)) =
          depth (mkIF x (reduce (Mapping.update x True env) t)
      (reduce (Mapping.update x False env) f))"
        (is "_ = depth (mkIF x ?xt ?xf)")
      using mlxnone reduce.simps (1) [of env x t f] by simp
  also have "... \<le> Suc (max (depth ?xt) (depth ?xf))"
      using depth_mkIF by metis
  also have "... \<le> Suc (max (depth t) (depth f))"
      using drdt drdf by auto
  also have "... = depth (IF x t f)" by simp
  finally show ?case .
qed

text\<open>Do notice that we treat similarly the case where
  we compute the path of a constant that the case where we
  compute the path with respect to an environment that does not
  include some of the variables in the @{typ "'a ifex"} expression.
  We will hav eto include premises in our lemmas to discard the
  latter case.\<close>

fun path :: "'a env_bool \<Rightarrow> 'a ifex \<Rightarrow> 'a list"
  where "path _ Trueif = []" |
  "path _ Falseif = []" |
  "path eval (IF x t f) = (case Mapping.lookup eval x of
      None \<Rightarrow> [] |
      Some True \<Rightarrow> x # (path eval t) |
      Some False \<Rightarrow> x # (path eval f))"

value "path Mapping.empty (IF x Trueif Falseif)"

lemma "path (Mapping.update x False env) (IF x (IF y Trueif Falseif) Falseif)
  = [x]"
  by simp

lemma "path (Mapping.of_alist [(x, True), (y, True)])
                  (IF x (IF y Trueif Falseif) Falseif)
  = [x, y]"
  by auto (simp add: lookup_of_alist)

value "length (path (Mapping.of_alist [(finite_4.a\<^sub>1, True)])
            (IF finite_4.a\<^sub>1 Falseif Falseif))"

value "length (path (Mapping.of_alist [(finite_4.a\<^sub>3, False)])
            (IF finite_4.a\<^sub>3 (IF finite_4.a\<^sub>1 Falseif Falseif) (Falseif)))"

(*lemma
  path_exists:
  assumes v: "vars bdd \<subseteq> Mapping.keys eval"
  shows "path eval bdd \<noteq> None"
  using v proof (induction bdd)
  case Trueif
  then show ?case by simp
next
  case Falseif
  then show ?case by simp
next
  case (IF x1 b11 b12)
  from IF.prems
  have vb11: "vars b11 \<subseteq> Mapping.keys eval" and vb12: "vars b12 \<subseteq> Mapping.keys eval"
    and x1: "x1 \<in> Mapping.keys eval"
    by simp_all
  obtain l11 l12 x11
    where "path eval b11 = Some l11" and "path eval b12 = Some l12"
      and "Mapping.lookup eval x1 = Some x11"
    using IF.IH (1) [OF vb11] IF.IH (2) [OF vb12] x1
    by auto (meson in_keysD)
  then show ?case unfolding path.simps
    by (simp add: case_bool_if)
qed

lemma
  path_reduce_exists:
  assumes v: "vars bdd \<subseteq> Mapping.keys eval"
  shows "path eval (reduce env bdd) \<noteq> None"
  using v path_exists [OF v] proof (induction bdd arbitrary: env)
  case Trueif
  then show ?case by simp
next
  case Falseif
  then show ?case by simp
next
  case (IF x1 b1 b2)
  show ?case
  proof (cases "Mapping.lookup env x1 = None")
    case False
    then obtain x11 where mx1: "Mapping.lookup env x1 = Some (x11)" by auto
    from IF.prems (1)
    have vb1: "vars b1 \<subseteq> Mapping.keys eval" and vb2: "vars b2 \<subseteq> Mapping.keys eval"
      by simp_all
    obtain l11 l12
      where perb1: "path eval (reduce env b1) = Some l11"
        and perb2: "path eval (reduce env b2) = Some l12"
      using IF.IH (1) [OF vb1 path_exists [OF vb1]]
        IF.IH (2) [OF vb2 path_exists [OF vb2]] (*x1*)
      by auto (meson in_keysD)
    thus ?thesis unfolding reduce.simps using mx1 by auto
  next
    case True
    from IF.prems (1)
    have vb1: "vars b1 \<subseteq> Mapping.keys eval" and vb2: "vars b2 \<subseteq> Mapping.keys eval"
      and x1: "x1 \<in> Mapping.keys eval"
      by simp_all
    obtain l11 l12 x11
      where perb1: "path eval (reduce (Mapping.update x1 True env) b1) = Some l11"
        and perb2: "path eval (reduce (Mapping.update x1 True env) b2) = Some l12"
        and mx1: "Mapping.lookup eval x1 = Some x11"
      using IF.IH (1) [OF vb1 path_exists [OF vb1]]
        IF.IH (2) [OF vb2 path_exists [OF vb2]] x1
      by auto (meson in_keysD)
    thus ?thesis
      using True perb1 perb2 unfolding reduce.simps mkIF_def
      apply auto
      apply (cases x11)
      by (simp add: IF.IH(2) option.case_eq_if path_exists vb2)+
  qed
qed

corollary
  path_some:
  assumes v: "vars bdd \<subseteq> Mapping.keys eval"
  obtains l
  where "path eval bdd = Some l"
  using path_exists [OF v] by auto

corollary
  path_reduce_some:
  assumes v: "vars bdd \<subseteq> Mapping.keys eval"
  obtains l
  where "path eval (reduce env bdd) = Some l"
  using path_reduce_exists [OF v] by auto

corollary
  olength_some:
  assumes v: "vars bdd \<subseteq> Mapping.keys eval"
  obtains i
  where "olength (path eval bdd) = Some i"
  using path_some [OF v] unfolding olength_def
  by (metis option.simps(5))

corollary
  olength_reduce_some:
  assumes v: "vars bdd \<subseteq> Mapping.keys eval"
  obtains i
  where "olength (path eval (reduce env bdd)) = Some i"
  using path_reduce_some [OF v] unfolding olength_def
  by (metis option.simps(5))
*)
(*lemma assumes pm: "path eval
       (mkIF x1 (reduce env1 b1) (reduce env2 b2)) = Some l"
      and p: "path eval (IF x1 b1 b2) = Some m"
    shows "set l \<subseteq> set m" and "length l \<le> length m"
proof (cases "(reduce (Mapping.update x1 True env1) b1) =
         (reduce (Mapping.update x1 False env1) b2)")
  case True
  hence "mkIF x1 (reduce (Mapping.update x1 True env1) b1)
         (reduce (Mapping.update x1 False env2) b2) =
         reduce (Mapping.update x1 True env1) b1"
    unfolding mkIF_def by simp*)

text\<open>Beware that if we omit the first premise of the following result
  then it does not hold:
  Nitpick found a counterexample for card 'a = 6:
  Free variables:
    @{term "b = IF a\<^sub>1 (IF a\<^sub>2 (IF a\<^sub>3 Falseif Trueif) Falseif) Trueif"},
    @{term "env = [a\<^sub>1 \<mapsto> True, a\<^sub>6 \<mapsto> False]"},
    @{term "eval =
      [a\<^sub>1 \<mapsto> False, a\<^sub>2 \<mapsto> True, a\<^sub>3 \<mapsto> False, a\<^sub>4 \<mapsto> False, a\<^sub>5 \<mapsto> False, a\<^sub>6
        \<mapsto> False]"},
    @{term "i = 2"},
    @{term "j = 1"}.
\<close>

theorem
  assumes v: "vars bdd \<subseteq> Mapping.keys eval"
    and c: "\<forall>x\<in>Mapping.keys eval.
          (Mapping.lookup env x = Mapping.lookup eval x \<or> Mapping.lookup env x = None)"
  shows "length (path eval (reduce env bdd)) \<le> length (path eval bdd)"
  using c v proof (induction bdd arbitrary: eval env)
  case Trueif
  then show ?case by simp
next
  case Falseif
  then show ?case by simp
next
  case (IF x1 b1 b2)
  from IF.prems (2)
  have vb1: "vars b1 \<subseteq> Mapping.keys eval" and vb2: "vars b2 \<subseteq> Mapping.keys eval"
    and x1: "x1 \<in> Mapping.keys eval"
    by simp_all
  obtain x11 :: bool where x1some: "Mapping.lookup eval x1 = Some x11"
    using x1 by (meson in_keysD)
  have i1j1: "length (path eval (reduce env b1)) \<le> length (path eval b1)"
    using IF.IH (1) [OF IF.prems (1) vb1] .
  have i2j2: "length (path eval (reduce env b2)) \<le> length (path eval b2)"
    using IF.IH (2) [OF IF.prems (1) vb2] .
  show ?case
  proof (cases "Mapping.lookup env x1 = None")
    case True note x1none = True
    have r: "reduce env (IF x1 b1 b2) =
      mkIF x1 (reduce (Mapping.update x1 True env) b1)
              (reduce (Mapping.update x1 False env) b2)"
      unfolding reduce.simps using True by simp
    show ?thesis
    proof (cases "reduce (Mapping.update x1 True env) b1 =
           reduce (Mapping.update x1 False env) b2")
      case False note neq = False
      hence mk: "mkIF x1 (reduce (Mapping.update x1 True env) b1)
              (reduce (Mapping.update x1 False env) b2) =
        IF x1 (reduce (Mapping.update x1 True env) b1)
              (reduce (Mapping.update x1 False env) b2)"
        unfolding mkIF_def by simp
    show ?thesis
    proof (cases "x11")
      case True
      show ?thesis
        using IF.IH (1) [OF _ vb1]
        unfolding reduce.simps
        using x1none x1some True neq
        using IF.prems
        unfolding mkIF_def
        by auto (simp add: lookup_update_unfold)
    next
    case False
    show ?thesis
      using IF.IH (2) [OF _ vb2]
      unfolding reduce.simps
      using x1none x1some False neq IF.prems
      unfolding mkIF_def
      by auto (simp add: lookup_update_unfold)
    qed
  next
    case True note b1b2eq = True
    have rb1: "reduce env (IF x1 b1 b2) = reduce (Mapping.update x1 True env) b1"
      unfolding r unfolding mkIF_def using True
      unfolding reduce.simps using x1some by auto
    show ?thesis
    proof (cases "x11")
      case True
      show ?thesis
        using IF.prems (1,2)
        using IF.IH (1) [OF _ vb1] True x1none x1some b1b2eq
        unfolding reduce.simps mkIF_def
      by auto (metis le_SucI lookup_update_unfold)
   next
     case False
     show ?thesis
        using IF.prems (1,2)
        using IF.IH (2) [OF _ vb2] False x1none x1some b1b2eq
        unfolding reduce.simps mkIF_def
      by auto (metis le_SucI lookup_update_unfold)
    qed
  qed
  next
  case False
  then obtain bl where x1envsome: "Mapping.lookup env x1 = Some bl" by auto
  show ?thesis
  proof (cases bl)
    case True
    have r: "reduce env (IF x1 b1 b2) = reduce env b1"
      unfolding reduce.simps using x1envsome True by auto
    show ?thesis
      using IF.prems (1,2) True x1some x1envsome
      using IF.IH (1) [OF IF.prems (1) vb1] le_SucI by auto
  next
    case False note nbl = False
    have r: "reduce env (IF x1 b1 b2) = reduce env b2"
      unfolding reduce.simps using x1envsome False by auto
    show ?thesis
      using IF.prems (1,2) x1some x1envsome nbl
      using IF.IH (2) [OF IF.prems (1) vb2] by auto
    qed
  qed
qed

definition depth_path :: "'a ifex \<Rightarrow> nat"
  where "depth_path bdd = (GREATEST n. \<exists>eval. n = length (path eval bdd) \<and>
                            vars bdd \<subseteq> Mapping.keys eval)"

lemma
  valuation_exists:
  fixes bdd :: "'a ifex"
  shows "\<exists>eval::'a env_bool. vars bdd \<subseteq> Mapping.keys eval"
proof (induct bdd)
  case Trueif
  then show ?case by (rule exI [of _ Mapping.empty], simp)
next
  case Falseif
  then show ?case by (rule exI [of _ Mapping.empty], simp)
next
  case (IF x1 bdd1 bdd2)
  from IF.hyps obtain eval1 :: "'a env_bool" and eval2 :: "'a env_bool"
    where v1: "vars bdd1 \<subseteq> Mapping.keys eval1"
    and v2: "vars bdd2 \<subseteq> Mapping.keys eval2" by metis
  show ?case
    apply (rule exI [of _ "Mapping.update x1 True (Mapping.combine (\<lambda>x y. x) eval1 eval2)"])
    using v1 v2 by fastforce
qed

lemma depth_path_exists:
  fixes bdd :: "'a ifex"
  shows "\<exists>n::nat. depth_path bdd = n" by simp

lemma "depth_path Trueif = 0" and "depth_path Falseif = 0"
  unfolding depth_path_def by (simp add: Greatest_equality)+

lemma "depth (IF a\<^sub>1 Falseif (IF a\<^sub>1 Falseif Falseif)) = 2"
  unfolding depth.simps by simp

lemma "depth (reduce Mapping.empty (IF a\<^sub>1 Falseif (IF a\<^sub>1 Falseif Falseif))) = 0"
  unfolding depth.simps reduce.simps mkIF_def by (simp)

lemma "depth_path (IF a\<^sub>1 Falseif Falseif) = 1"
proof (unfold depth_path_def, rule Greatest_equality)
  show "(\<exists>eval.
        1 = length (path eval (IF a\<^sub>1 Falseif Falseif)) \<and>
        vars (IF a\<^sub>1 Falseif Falseif) \<subseteq> Mapping.keys eval)"
  proof (rule exI [of _ "Mapping.of_alist [(a\<^sub>1,True)]"], rule conjI)
    show "1 = length (path (Mapping.of_alist [(a\<^sub>1, True)]) (IF a\<^sub>1 Falseif Falseif))"
      unfolding path.simps by (simp add: lookup_of_alist)
    show "vars (IF a\<^sub>1 Falseif Falseif) \<subseteq> Mapping.keys (Mapping.of_alist [(a\<^sub>1, True)])"
      by simp
    qed
  next
    fix y :: nat
    show "(\<exists>eval.
            y = length (path eval (IF a\<^sub>1 Falseif Falseif)) \<and>
            vars (IF a\<^sub>1 Falseif Falseif) \<subseteq> Mapping.keys eval) \<Longrightarrow> y \<le> 1"
    proof -
      assume e: "\<exists>eval::'a env_bool. y = length (path eval (IF a\<^sub>1 Falseif Falseif)) \<and>
        vars (IF a\<^sub>1 Falseif Falseif) \<subseteq> Mapping.keys eval"
      show "y \<le> 1"
      proof -
      from e obtain eval
        where y: "y = length (path eval (IF a\<^sub>1 Falseif Falseif))" and
                 vars: "vars (IF a\<^sub>1 Falseif Falseif) \<subseteq> Mapping.keys eval" by auto
      from vars have "a\<^sub>1 \<in> Mapping.keys eval" by simp
      hence "path eval (IF a\<^sub>1 Falseif Falseif) = [a\<^sub>1]"
        unfolding path.simps
        by (metis bool.case_eq_if in_keysD option.simps(5))
      with y show ?thesis by simp
    qed
  qed
qed

value "depth (IF a\<^sub>1 (IF a\<^sub>1 (IF a\<^sub>1 Falseif Falseif) Falseif)
       (IF a\<^sub>1 Falseif (IF a\<^sub>1 Falseif Falseif)))"

lemma "depth_path (IF a\<^sub>1 (IF a\<^sub>1 (IF a\<^sub>1 Falseif Falseif) Falseif)
       (IF a\<^sub>1 Falseif (IF a\<^sub>1 Falseif Falseif))) = 3" (is "depth_path ?IF = 3")
proof (unfold depth_path_def, rule Greatest_equality)
  show "(\<exists>eval.
        3 = length (path eval ?IF) \<and>
        vars ?IF \<subseteq> Mapping.keys eval)"
  proof (rule exI [of _ "Mapping.of_alist [(a\<^sub>1,True)]"], rule conjI)
    show "3 = length (path (Mapping.of_alist [(a\<^sub>1, True)]) ?IF)"
      unfolding path.simps by (simp add: lookup_of_alist)
    show "vars ?IF \<subseteq> Mapping.keys (Mapping.of_alist [(a\<^sub>1, True)])"
      by simp
    qed
  next
    fix y :: nat
    show "(\<exists>eval.
            y = length (path eval ?IF) \<and>
            vars ?IF \<subseteq> Mapping.keys eval) \<Longrightarrow> y \<le> 3"
    proof -
      assume e: "\<exists>eval::'a env_bool. y = length (path eval ?IF) \<and>
        vars ?IF \<subseteq> Mapping.keys eval"
      show "y \<le> 3"
      proof -
      from e obtain eval
        where y: "y = length (path eval ?IF)" and
                 vars: "vars ?IF \<subseteq> Mapping.keys eval" by auto
      from vars have "a\<^sub>1 \<in> Mapping.keys eval" by simp
      hence "path eval ?IF = [a\<^sub>1, a\<^sub>1, a\<^sub>1]"
        unfolding path.simps
        by (metis bool.case_eq_if in_keysD option.simps(5))
      with y show ?thesis by simp
    qed
  qed
qed

lemma "depth_path (IF a\<^sub>1 (IF a\<^sub>1 (IF a\<^sub>1 Falseif Falseif) Falseif)
       (IF a\<^sub>1 (IF a\<^sub>1 Falseif Falseif) Falseif)) = 3" (is "depth_path ?IF = 3")
proof (unfold depth_path_def, rule Greatest_equality)
  show "(\<exists>eval.
        3 = length (path eval ?IF) \<and>
        vars ?IF \<subseteq> Mapping.keys eval)"
  proof (rule exI [of _ "Mapping.of_alist [(a\<^sub>1,True)]"], rule conjI)
    show "3 = length (path (Mapping.of_alist [(a\<^sub>1, True)]) ?IF)"
      unfolding path.simps by (simp add: lookup_of_alist)
    show "vars ?IF \<subseteq> Mapping.keys (Mapping.of_alist [(a\<^sub>1, True)])"
      by simp
    qed
  next
    fix y :: nat
    show "(\<exists>eval.
            y = length (path eval ?IF) \<and>
            vars ?IF \<subseteq> Mapping.keys eval) \<Longrightarrow> y \<le> 3"
    proof -
      assume e: "\<exists>eval::'a env_bool. y = length (path eval ?IF) \<and>
        vars ?IF \<subseteq> Mapping.keys eval"
      show "y \<le> 3"
      proof -
      from e obtain eval
        where y: "y = length (path eval ?IF)" and
                 vars: "vars ?IF \<subseteq> Mapping.keys eval" by auto
      from vars
      have a1: "a\<^sub>1 \<in> Mapping.keys eval" by simp
      have "path eval ?IF = [a\<^sub>1, a\<^sub>1, a\<^sub>1] \<or> path eval ?IF = [a\<^sub>1, a\<^sub>1]"
      proof (cases "Mapping.lookup eval a\<^sub>1 = None")
        case True show ?thesis using a1
          by (simp add: True domIff keys_dom_lookup)
      next
        case False note a1some = False
        then obtain x1 where x1: "Mapping.lookup eval a\<^sub>1 = Some x1" by auto
        show ?thesis
        proof (cases x1)
          case True
          thus ?thesis unfolding path.simps using a1some x1 by simp
        next
          case False
          thus ?thesis unfolding path.simps using a1some x1 by simp
        qed
      qed
      with y show ?thesis by auto
    qed
  qed
qed

section\<open>Chemins\<close>

fun chemins :: "'a ifex \<Rightarrow> 'a list list"
  where "chemins Trueif = [[]]" |
  "chemins Falseif = [[]]" |
  "chemins (IF x t f) = append (map (Cons x) (chemins t)) (map (Cons x) (chemins f))"

definition chemins_set :: "'a ifex \<Rightarrow> 'a list set"
  where "chemins_set bdd = set (chemins bdd)"

lemma "chemins Trueif = [[]]" by simp

lemma "chemins (IF a1 Falseif Falseif) = [[a1],[a1]]" by simp

lemma "set (chemins Falseif) = {[]}" and "set (chemins Trueif) = {[]}"
  unfolding chemins_set_def by simp_all

lemma "set (chemins (IF a1 Falseif Falseif)) = {[a1]}"
  unfolding chemins_set_def by simp

value "chemins (IF a\<^sub>1 (IF a\<^sub>1 (IF a\<^sub>1 Falseif Falseif) Falseif)
       (IF a\<^sub>1 Falseif (IF a\<^sub>1 Falseif Falseif)))"

value "set (chemins (IF a\<^sub>1 (IF a\<^sub>1 (IF a\<^sub>1 Falseif Falseif) Falseif)
       (IF a\<^sub>1 Falseif (IF a\<^sub>1 Falseif Falseif))))"

lemma
  path_is_chemin:
  assumes v: "vars bdd \<subseteq> Mapping.keys eval"
  shows "path eval bdd \<in> set (chemins bdd)"
using v proof (induction bdd arbitrary: eval)
  case Trueif
  then show ?case by simp
next
  case Falseif
  then show ?case by simp
next
  case (IF x1 bdd1 bdd2)
  show ?case
  proof (cases "Mapping.lookup eval x1 = None")
    case True
    then show ?thesis using IF.prems by auto (simp add: keys_is_none_rep)
  next
    case False
    then obtain x11 where m: "Mapping.lookup eval x1 = Some x11" by auto
    have p1: "path eval bdd1 \<in> set (chemins bdd1)"
      and p2: "path eval bdd2 \<in> set (chemins bdd2)"
      using IF.IH (1,2) using IF.prems by simp_all
    show ?thesis
      using m p1 p2 unfolding path.simps chemins_set_def
      by (cases x11, auto)
  qed
qed

fun max_list :: "'a::ord list \<Rightarrow> 'a" where
  "max_list (x # xs) = (case xs of [] \<Rightarrow> x | _ \<Rightarrow> max x (max_list xs))"

definition "max_chemins bdd = max_list (map length (chemins bdd))"

value "max_chemins Falseif"

value "max_chemins Trueif"

value "max_chemins (IF a\<^sub>1 Falseif Falseif)"

value "chemins (IF a\<^sub>1 (IF a\<^sub>1 (IF a\<^sub>1 Falseif Falseif) Falseif)
       (IF a\<^sub>1 Falseif (IF a\<^sub>1 Falseif Falseif)))"

value "max_chemins (IF a\<^sub>1 (IF a\<^sub>1 (IF a\<^sub>1 Falseif Falseif) Falseif)
       (IF a\<^sub>1 Falseif (IF a\<^sub>1 Falseif Falseif)))"

lemma chemins_nonempty[simp]: "chemins bdd \<noteq> []"
  by (induction bdd) simp_all

lemma chemins_finite[simp]: "finite (set (chemins bdd))"
  by (induction bdd) simp_all

lemma chemins_map: "chemins (IF x1 bdd1 bdd2) = map (Cons x1) (append (chemins bdd1) (chemins bdd2))"
  using chemins.simps (3) by simp

lemma
  assumes a: "a \<in> set (chemins bdd1) \<union> set (chemins bdd1)"
  shows "x1 # a \<in> set (chemins (IF x1 bdd1 bdd2))"
  unfolding chemins_map using a by simp

lemma
  set_chemins_IF_cons:
  assumes a: "a \<in> set (chemins (IF x1 bdd1 bdd2))"
  shows "\<exists>l\<in>set (chemins bdd1) \<union> set (chemins bdd2). a = x1 # l"
  using a unfolding chemins_map by auto

lemma
  max_list_in:
  fixes l :: "'a::ord list"
  assumes l: "l \<noteq> []"
  shows "\<exists>x\<in>(set l). x = max_list l"
  using l by (induct l, auto) (metis list.case_eq_if max_def)

lemma
  max_list_list_in:
  fixes l :: "'a list list"
  assumes l: "l \<noteq> []"
  shows "\<exists>x\<in>(set l). length x = max_list (map length l)"
  using l by (induct l, auto)
   (metis list.case_eq_if list.map_disc_iff max_def)

lemma max_list_Max:
  assumes xs: "xs \<noteq> []"
  shows "max_list xs = Max (set xs)"
  using xs by (induction xs rule: induct_list012)(auto)

lemma
  max_chemins_in:
  shows "\<exists>l\<in>set(chemins bdd). length l = max_chemins bdd"
  unfolding max_chemins_def
  apply (rule max_list_list_in)
  using chemins_nonempty by auto

lemma
  assumes a: "a \<in> A" and ne: "a \<noteq> Max A" and f: "finite A"
  shows "a \<le> Max A"
  using a ne f by simp

lemma
  max_list_map:
  fixes l :: "nat list"
  assumes l: "l \<noteq> []"
  shows "max_list (map (\<lambda>x. x + 1) l) = 1 + max_list l"
  using l by (induct l, auto) (simp add: list.case_eq_if)

lemma max_list_append:
  fixes l :: "nat list"
  assumes l: "l \<noteq> []" and m: "m \<noteq> []"
  shows "max_list (l @ m) = max (max_list l) (max_list m)"
  using l m by (induct l, auto) (simp add: list.case_eq_if max.assoc)

lemma max_chemins_IF:
  "max_chemins (IF x1 bdd1 bdd2) =
      1 + max (max_chemins bdd1) (max_chemins bdd2)"
proof -
  have m: "map length (map ((#) x1) (chemins bdd1 @ chemins bdd2)) =
    map (\<lambda>x. x + 1) (map length (chemins bdd1 @ chemins bdd2))"
    by (induct "(chemins bdd1 @ chemins bdd2)", auto)
  have "max_chemins (IF x1 bdd1 bdd2) =
    max_list (map length (map ((#) x1) (chemins bdd1 @ chemins bdd2)))"
    unfolding max_chemins_def [of "(IF x1 bdd1 bdd2)"]
    unfolding chemins_map ..
  also have "max_list (map length (map ((#) x1) (chemins bdd1 @ chemins bdd2))) =
    1 + max_list (map length (chemins bdd1 @ chemins bdd2))"
    unfolding m
    by (rule max_list_map, simp)
  also have "... = 1 + max_list (map length (chemins bdd1) @ map length (chemins bdd2))"
    by simp
  also have "... = 1 + max (max_list (map length (chemins bdd1))) (max_list (map length (chemins bdd2)))"
    using max_list_append by simp
  also have "... = 1 + max (max_chemins bdd1) (max_chemins bdd2)"
    unfolding max_chemins_def [symmetric]..
  finally show ?thesis .
qed

theorem depth_eq_max_chemins: "depth bdd = max_chemins bdd"
proof (induction bdd)
  case Trueif
  then show ?case unfolding max_chemins_def by auto
next
  case Falseif
  then show ?case unfolding max_chemins_def by auto
next
  case (IF x1 bdd1 bdd2)
  show ?case
  proof (cases "max_chemins bdd1 \<le> max_chemins bdd2")
    case True hence d: "depth bdd1 \<le> depth bdd2" using IF.IH by simp
    have dIF: "depth (IF x1 bdd1 bdd2) = 1 + (depth bdd2)"
      using d by simp
    have "max_chemins (IF x1 bdd1 bdd2) =
      1 + max (max_chemins bdd1) (max_chemins bdd2)"
      by (rule max_chemins_IF)
    hence mIF: "max_chemins (IF x1 bdd1 bdd2) = 1 + (max_chemins bdd2)"
      using True by simp
    show ?thesis unfolding dIF mIF using IF.IH (2) by simp
  next
    case False hence d: "depth bdd2 < depth bdd1" using IF.IH by simp
    have dIF: "depth (IF x1 bdd1 bdd2) = 1 + (depth bdd1)"
      using d by simp
    have "max_chemins (IF x1 bdd1 bdd2) =
      1 + max (max_chemins bdd1) (max_chemins bdd2)"
      by (rule max_chemins_IF)
    hence mIF: "max_chemins (IF x1 bdd1 bdd2) = 1 + (max_chemins bdd1)"
      using False by simp
    show ?thesis unfolding dIF mIF using IF.IH (1) by simp
  qed
qed

corollary depth_path_le_max_chemins:
  "depth_path (bdd::'a ifex) \<le> max_chemins bdd"
proof (rule ccontr)
  assume "\<not> depth_path bdd \<le> max_chemins bdd"
  hence "\<exists>eval. length (path eval bdd) > max_chemins bdd \<and> vars bdd \<subseteq> Mapping.keys eval"
    unfolding depth_path_def using depth_path_exists [of bdd]
    by auto (smt (z3) GreatestI_nat le_refl less_imp_le_nat nat_neq_iff valuation_exists)
  then obtain eval where leval: "length (path eval bdd) > max_chemins bdd"
    and vbdd: "vars bdd \<subseteq> Mapping.keys eval" by auto
  show False
    using path_is_chemin [OF vbdd] leval
    unfolding max_chemins_def
    using chemins_nonempty [of bdd]
    by auto (metis (no_types, lifting) List.finite_set Max_ge imageI \<open>chemins bdd \<noteq> []\<close> le_imp_less_Suc list.map_disc_iff list.set_map max_list_Max not_less_eq)
qed

corollary "depth_path bdd \<le> depth bdd"
  by (simp add: depth_eq_max_chemins depth_path_le_max_chemins)

section\<open>Free Binary Decision Diagrams\<close>

text\<open>Free binary decision diagrams (FBDDs) are graph-based
  data structures representing Boolean functions with the
  constraint (additional to binary decision diagram) that
  each variable is tested at most once during the computation.\<close>

abbreviation "fbdd == ifex_no_twice"

value "fbdd (IF x1 Trueif Falseif)"

value "fbdd (IF x1 (IF x1 Trueif Falseif) Falseif)"

lemma
  assumes f: "fbdd (IF x1 bdd1 bdd2)"
  shows "fbdd bdd1" using f by simp

lemma
  assumes f: "fbdd (IF x1 bdd1 bdd2)"
  shows "fbdd bdd2" using f by simp

lemma
  assumes f: "fbdd (IF x1 bdd1 bdd2)"
  shows "x1 \<notin> vars (bdd1)" using f by simp

lemma
  assumes f: "fbdd (IF x1 bdd1 bdd2)"
  shows "x1 \<notin> vars (bdd2)" using f by simp

lemma
  assumes g: "P (k::nat)"
  shows "P (LEAST n. P n)"
  by (rule LeastI, rule g)

lemma
  assumes p: "(LEAST n. P n) = n"
  shows "P (n::nat)" using p try

lemma
  assumes p: "(GREATEST n. P n) = n"
  shows "P (n::nat)" using p try

  apply (rule GreatestI_nat) using g
  apply simp try

lemma
  assumes f: "fbdd (IF x bdd1 bdd2)"
  shows "depth_path (IF x bdd1 bdd2) = 1 + max (depth_path bdd1) (depth_path bdd2)"
proof (cases "depth_path bdd1 < depth_path bdd2")
  case True
  show ?thesis using f True
  proof (induction bdd2)
    case Trueif
    then show ?case
      by (metis bot_nat_0.extremum_strict bot_nat_0.extremum_unique depth.simps(1) depth_eq_max_chemins depth_path_le_max_chemins)  sorry
  next
    case Falseif
    then show ?case
      by (metis depth.simps(2) depth_eq_max_chemins depth_path_le_max_chemins le_eq_less_or_eq not_less_zero)
  next
    case (IF x1 bdd11 bdd12)
    have "fbdd (IF x1 bdd1 bdd11)" using IF.prems (1) apply auto try
    then show ?case
  qed

  obtain n1 n2 where n1: "depth_path bdd1 = n1" and n2: "depth_path bdd2 = n2"
    (*using depth_path_exists [of ]*) by simp_all
  have "(\<exists>eval. n2 = length (path eval bdd2) \<and> vars bdd2 \<subseteq> Mapping.keys eval)"
    using n2 unfolding depth_path_def apply auto try

    show "\<exists>eval. n2 = length (path eval bdd2) \<and> vars bdd2 \<subseteq> Mapping.keys eval"
      using n2
      unfolding depth_path_def [of bdd2] try apply auto try

      unfolding Greatest_def apply auto

  from n1 obtain eval1
    where "n1 = length (path eval1 bdd2) \<and> vars bdd1 \<subseteq> Mapping.keys eval1"
    apply (rule GreatestI_nat)
    unfolding depth_path_def [of bdd1]
    using GreatestI_nat  apply auto try

  obtain n where g: "(GREATEST n.
      \<exists>eval. n = length (path eval bdd2) \<and> vars bdd2 \<subseteq> Mapping.keys eval) =
      n" by simp
  have "(\<exists>eval. n = length (path eval bdd2) \<and> vars bdd2 \<subseteq> Mapping.keys eval)"
    using Greatest_equality [OF ]

    unfolding depth_path_def
    using Greatest_equality
    unfolding depth_path_def using Greatest_equality apply auto try
    find_theorems "(GREATEST n. ?P n)"
    then obtain eval :: "'a env_bool"
    where "n = length (path eval bdd2) \<and> vars bdd2 \<subseteq> Mapping.keys eval"
    unfolding depth_path_def
    unfolding Greatest_def apply auto
    try using True unfolding depth_path_def

lemma assumes f: "fbdd bdd"
  shows "depth bdd = depth_path bdd"
  using f proof (induction bdd)
  case Trueif
  then show ?case
    by (metis bot_nat_0.extremum_uniqueI depth.simps(1) depth_eq_max_chemins depth_path_le_max_chemins)
next
  case Falseif
  then show ?case
    by (metis bot_nat_0.extremum_uniqueI depth.simps(2) depth_eq_max_chemins depth_path_le_max_chemins)
next
  case (IF x1 bdd1 bdd2)
  then show ?case
  proof -
    have dbbd1: "depth bdd1 = depth_path bdd1" and
      dbdd2: "depth bdd2 = depth_path bdd2"
      using IF.IH (1,2) IF.prems by simp_all
    show ?thesis
    proof (cases "(depth bdd1) < (depth bdd2)")
      case True
      hence "max (depth bdd1) (depth bdd2) = (depth bdd2)" by simp
      show ?thesis unfolding depth_path_def
      unfolding depth.simps depth_path_def

qed

(*datatype ifex = CIF bool | VIF nat | IF ifex ifex ifex*)

datatype ifex = CIF bool | IF nat ifex ifex

primrec
valif :: "ifex => (nat => bool) => bool"
  where
  "valif (CIF b)    env = b" |
  "valif (IF b f t) env = (if env b then valif f env
                                      else valif t env)"

(*primrec valif :: "ifex => (nat => bool) => bool"
  where
  "valif (CIF b)    env = b" |
  "valif (VIF x)    env = env x" |
  "valif (IF b t e) env = (if valif b env then valif t env
                                      else valif e env)"
*)

lemma "valif (CIF True) f" by simp

lemma "\<not> valif (CIF False) f" by simp

(*lemma "valif (VIF 3) (\<lambda>x. True)" by simp*)

(*lemma "\<not> valif (VIF 3) (\<lambda>x. False)" by simp*)

lemma "valif (IF 3 (IF 3 (CIF True) (CIF False))
                         (IF 3 (CIF True) (CIF False)))
              (\<lambda>x. if x = 3 then True else False)" by simp

(*lemma "valif (IF (VIF 3) (IF (VIF 3) (CIF True) (CIF False))
                         (IF (VIF 3) (CIF True) (CIF False)))
              (\<lambda>x. if x = 3 then True else False)" by simp*)

(*lemma "\<not> valif (IF (VIF 3) (IF (VIF 2) (CIF True) (CIF False))
                         (IF (VIF 4) (CIF True) (CIF False)))
              (\<lambda>x. if x = 3 then True else False)" by simp*)

lemma "\<not> valif (IF 3 (IF 3 (CIF True) (CIF False))
                         (IF 3 (CIF True) (CIF False)))
              (\<lambda>x. if x = 2 then True else False)" by simp

(*lemma "\<not> valif (IF (VIF 3) (IF (VIF 3) (CIF True) (CIF False))
                         (IF (VIF 3) (CIF True) (CIF False)))
              (\<lambda>x. if x = 2 then True else False)" by simp*)

lemma "\<not> valif (IF 1 (IF 2 (IF 3 (IF 4 (CIF True) (CIF False))
                                 (IF 4 (CIF True) (CIF False)))
                           (IF 3 (IF 4 (CIF True) (CIF False))
                                 (IF  4 (CIF True) (CIF False))))
                           (IF 4 (CIF True) (CIF False)))
              (\<lambda>x. if x = 3 then True else False)" by simp

(*lemma "\<not> valif (IF (VIF 1) (IF (VIF 2) (IF (VIF 3) (IF (VIF 4) (CIF True) (CIF False))
                                                   (IF (VIF 4) (CIF True) (CIF False)))
                                       (IF (VIF 3) (IF (VIF 4) (CIF True) (CIF False))
                                                   (IF (VIF 4) (CIF True) (CIF False))))
                           (IF (VIF 4) (CIF True) (CIF False)))
              (\<lambda>x. if x = 3 then True else False)" by simp*)

fun vars :: "ifex \<Rightarrow> nat set"
  where
  "vars (IF v f t) =  insert v (vars f \<union> vars t)" |
  "vars (CIF b) = {}"

fun ifex_unique_var :: "ifex \<Rightarrow> bool"
  where
    "ifex_unique_var (CIF b) = True" |
    "ifex_unique_var (IF n f t) = (n \<notin> vars t \<and> n \<notin> vars f)"

lemma "ifex_unique_var (IF 1 (IF 2 (IF 3 (IF 4 (CIF True) (CIF False))
                                 (IF 4 (CIF True) (CIF False)))
                           (IF 3 (IF 4 (CIF True) (CIF False))
                                 (IF  4 (CIF True) (CIF False))))
                           (IF 4 (CIF True) (CIF False)))" by simp

lemma "\<not> ifex_unique_var (IF 3 (IF 3 (CIF True) (CIF False))
                         (IF 3 (CIF True) (CIF False)))" by simp

fun depth :: "ifex \<Rightarrow> nat"
  where
    "depth (CIF b) = 0" |
    "depth (IF b f t) = 1 + min (depth f) (depth t)"

lemma "depth (IF 1 (IF 2 (IF 3 (IF 4 (CIF True) (CIF False))
                                 (IF 4 (CIF True) (CIF False)))
                           (IF 3 (IF 4 (CIF True) (CIF False))
                                 (IF  4 (CIF True) (CIF False))))
                           (IF 4 (CIF True) (CIF False))) = 2" by simp

text\<open>Pending definition\<close>

fun reduce :: "ifex \<Rightarrow> (nat \<Rightarrow> bool) \<Rightarrow> ifex"
  where
    "reduce (CIF b) env = CIF b" |
    "reduce (IF a f t) env = (if f = t then (reduce f env) else IF a (reduce f (env(a:=True)))
                               (reduce t (env(a:=False))))"

value "reduce (IF 1 (IF 2 (IF 3 (IF 4 (CIF True) (CIF False))
                                 (IF 4 (CIF True) (CIF False)))
                           (IF 3 (IF 4 (CIF True) (CIF False))
                                 (IF  4 (CIF True) (CIF False))))
                           (IF 4 (CIF True) (CIF False))) (\<lambda>x. if x = 3 then False else True)"

section\<open>Boolean expressions\<close>

text\<open>We are interested in boolean expressions that come from
  simplicial complexes, that is, collections of simplices
  that can be expressed as conjunctive normal forms.\<close>

datatype 'a bexp =
  Const bool |
  Atom 'a |
  Neg "'a bexp" |
  And "'a bexp" "'a bexp" |
  Or "'a bexp" "'a bexp"

fun bval where
  "bval (Const b) s = b" |
  "bval (Atom a) s = s a" |
  "bval (Neg b) s = (\<not> bval b s)" |
  "bval (And b1 b2) s = (bval b1 s \<and> bval b2 s)" |
  "bval (Or b1 b2) s = (bval b1 s \<or> bval b2 s)"

fun bool_expr_of_bexp :: "'a bexp \<Rightarrow> 'a bool_expr"
where
  "bool_expr_of_bexp (Const b) = Const_bool_expr b"
  | "bool_expr_of_bexp (Atom a) = Atom_bool_expr a"
  | "bool_expr_of_bexp (Neg b) = Neg_bool_expr(bool_expr_of_bexp b)"
  | "bool_expr_of_bexp (And b1 b2) = And_bool_expr (bool_expr_of_bexp b1) (bool_expr_of_bexp b2)"
  | "bool_expr_of_bexp (Or b1 b2) = Or_bool_expr (bool_expr_of_bexp b1) (bool_expr_of_bexp b2)"

lemma val_preservation:
  "val_bool_expr (bool_expr_of_bexp b) s = bval b s"
  by (induction b) auto
term range
definition bexp_from_simplice :: "nat set => nat \<Rightarrow> nat bexp"
  where "bexp_from_simplice \<sigma> n = range
    (\<lambda>i. if i \<in> \<sigma> then (And i (bexp_from_simplice (\<sigma> - {i})) else (bexp_from_simplice (\<sigma> - {i})) {..<n}"

lemma

  assumes "depth (IF a t f) = n"
    and "a \<in> vars t"
  shows "True"

end