(*  Title:      While_Combinator_Exts.thy
    Author:     Denis Lohner
*)

section {* Code Generation *}
subsection {* While Combinator Extensions *}

theory While_Combinator_Exts imports
  "~~/src/HOL/Library/While_Combinator"
begin
lemma while_option_None_invD:
  assumes "while_option b c s = None" and "wf r"
  and "I s" and "\<And>s. \<lbrakk> I s; b s \<rbrakk> \<Longrightarrow> I (c s)"
  and "\<And>s. \<lbrakk> I s; b s \<rbrakk> \<Longrightarrow> (c s, s ) \<in> r"
  shows "False"
  using assms
  by -(drule wf_rel_while_option_Some [of r I b c], auto)

lemma while_option_NoneD:
  assumes "while_option b c s = None"
  and "wf r" and "\<And>s. b s \<Longrightarrow> (c s, s) \<in> r"
  shows "False"
  using assms
  by (blast intro: while_option_None_invD)

lemma while_option_sim:
  assumes start: "R (Some s1) (Some s2)"
  and cond: "\<And>s1 s2. \<lbrakk> R (Some s1) (Some s2); I s1 \<rbrakk> \<Longrightarrow> b1 s1 = b2 s2"
  and step : "\<And>s1 s2. \<lbrakk> R (Some s1) (Some s2); I s1; b1 s1 \<rbrakk> \<Longrightarrow> R (Some (c1 s1)) (Some (c2 s2))"
  and diverge: "R None None"
  and inv_start: "I s1"
  and inv_step: "\<And>s1. \<lbrakk> I s1; b1 s1 \<rbrakk> \<Longrightarrow> I (c1 s1)"
  shows "R (while_option b1 c1 s1) (while_option b2 c2 s2)"
proof -
  { fix k
    assume "\<forall>k' < k. b1 ((c1 ^^ k') s1)"
    with start cond step inv_start inv_step
    have "b1 ((c1 ^^ k) s1) = b2 ((c2 ^^ k) s2)" and "I ((c1 ^^ k) s1)"
      and "R (Some ((c1 ^^ k) s1)) (Some ((c2 ^^ k) s2))"
      by (induction k) auto
  }
  moreover
  { fix k
    assume "\<not> b1 ((c1 ^^ k) s1)"
    hence "\<forall>k' < LEAST k. \<not> b1 ((c1 ^^ k) s1). b1 ((c1 ^^ k') s1)"
      by (metis (lifting) not_less_Least)
  }
  moreover
  { fix k
    assume "\<not> b2 ((c2 ^^ k) s2)"
    hence "\<forall>k' < LEAST k. \<not> b2 ((c2 ^^ k) s2). b2 ((c2 ^^ k') s2)"
      by (metis (lifting) not_less_Least)
  }
  moreover
  {
    assume "\<exists>k. \<not> b1 ((c1 ^^ k) s1)"
      and "\<exists>k. \<not> b2 ((c2 ^^ k) s2)"
    hence not_cond_Least: "\<not> b1 ((c1 ^^ (LEAST k. \<not> b1 ((c1 ^^ k) s1))) s1)"
      "\<not> b2 ((c2 ^^ (LEAST k. \<not> b2 ((c2 ^^ k) s2))) s2)"
      by -(drule LeastI_ex, assumption)+
    { fix k
      assume "\<forall>k' < k. b1 ((c1 ^^ k') s1)"
      with calculation(1) dual_order.strict_trans
      have "\<forall>k' < k. b2 ((c2 ^^ k') s2)"
        by blast
    }
    hence "(LEAST k'. \<not> b1 ((c1 ^^ k') s1)) = (LEAST k'. \<not> b2 ((c2 ^^ k') s2))"
      by (metis (no_types, lifting) not_cond_Least calculation(1,4,5) less_linear)
    with calculation(3,4)
    have "R (Some ((c1 ^^ (LEAST k. \<not> b1 ((c1 ^^ k) s1))) s1))
      (Some ((c2 ^^ (LEAST k. \<not> b2 ((c2 ^^ k) s2))) s2))"
      by auto
  }
  ultimately show ?thesis using diverge
    unfolding while_option_def
    apply (split split_if)
    apply (rule conjI)
     apply (split split_if)
     apply metis
    apply (split split_if)
    by (metis (lifting) LeastI_ex)
qed

end


(*  File:       Plurality_Module_Ref.thy
    Copyright   2022  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Valentin Springsklee, Karlsruhe Institute of Technology (KIT)"\<close>

theory Plurality_Module_Ref
  imports
          "Verified_Voting_Rule_Construction.Plurality_Rule"
           "Component_Types/Elimination_Module_Ref"
begin

section \<open>Refined Plurality Module\<close>

subsection \<open>Definition\<close>

definition plur_score_ref :: "'a Evaluation_Function_Ref" where
  "plur_score_ref x A p = (wc_fold p x)"

definition plurality_ref :: "'a::{default, heap, hashable} Electoral_Module_Ref" where
  "plurality_ref A pl \<equiv> do {
   scores \<leftarrow> (pre_compute_scores plur_score_ref A pl);
   max_eliminator_ref scores A pl
}"

lemma plur_score_correct:
  fixes A:: "'a::{default, heap, hashable} set"
  fixes pl:: "'a Profile_List" and pr:: "'a Profile"
  assumes
    fina: "finite A"
    and prel: "(pl, pr) \<in> profile_rel"
    and profp: "profile A pr"
  shows "\<forall> a \<in> A. plur_score_ref a A pl \<le> SPEC (\<lambda> sc. sc = (plur_score a A pr))"
  unfolding plur_score_ref_def plur_score.simps
proof safe
  fix a :: 'a
  from prel profp have profl: "profile_l A pl" using profile_ref by auto
  show "wc_fold pl a \<le> SPEC (\<lambda>sc. sc = win_count pr a) "
    by (refine_vcg fina prel profl wc_fold_correct)
qed

text \<open>Optimized Map Compuation\<close>

definition pre_compute_plur_scores :: "'a set
   \<Rightarrow> 'a Profile_List \<Rightarrow> 'a Scores_Map nres"
  where "pre_compute_plur_scores A pl \<equiv>
  if (A = {}) then RETURN Map.empty else
  do {
   zeromap:: 'a Scores_Map  \<leftarrow> init_map A;
  nfoldli pl (\<lambda>_. True)
    (\<lambda>ballot map.
     do{
      ASSERT (length ballot > 0);
      let top = ballot!0;
      ASSERT (op_map_contains_key top map);
      let scx = the (op_map_lookup top map);
        RETURN (op_map_update top (scx + 1) map)})
     (zeromap)}"

sepref_definition plurmap_sep is "uncurry pre_compute_plur_scores" ::
  "(alts_set_impl_assn nat_assn)\<^sup>k *\<^sub>a (profile_impl_assn nat_assn)\<^sup>k \<rightarrow>\<^sub>a (hm.assn nat_assn nat_assn)"
  unfolding pre_compute_plur_scores_def init_map_def op_set_is_empty_def[symmetric]
     hm.fold_custom_empty
  apply sepref_dbg_keep
  done

declare plurmap_sep.refine [sepref_fr_rules]

definition plurality_ref_opt :: "'a::{default, heap, hashable} Electoral_Module_Ref" where
  "plurality_ref_opt A pl \<equiv> do {
   scores \<leftarrow> (pre_compute_plur_scores A pl);
   max_eliminator_ref scores A pl
}"

subsection \<open>Refinement Lemmas\<close>

lemma plurality_map_correct:
  fixes A :: "'a set" and
        pr :: "'a Profile" and
        pl :: "'a Profile_List"
  assumes fina: "finite A" and
        prel : "(pl, pr) \<in> profile_rel" and
        profl: "profile_l A pl"
  shows "(pre_compute_plur_scores A pl) \<le> SPEC (\<lambda> map. map =(scores_map plur_score A pr))"
  unfolding pre_compute_plur_scores_def scores_map_def plur_score.simps
  apply (refine_vcg empty_map fina prel profl
          nfoldli_rule[where I = "\<lambda> p1 p2 si. ( \<forall> a \<in> A. ((si a) = Some (win_count_l p1 a)))
          \<and>  (\<forall> a . (a \<notin> A \<longrightarrow> si a = None))"] )
     apply (auto)
proof -
  fix xa :: "'a Preference_List"
  fix xb :: 'a
  fix l1 l2 :: "'a Profile_List"
  assume "xb \<in> A"
  from this have nempa: "A \<noteq> {}" by auto
  assume "pl = l1 @ [] # l2"
  from this profl show "False"
    unfolding profile_l_def well_formed_pl_def losimp using nempa
    by (metis in_set_conv_decomp in_set_conv_nth list.set(1))
next
  fix xa :: "'a Preference_List"
  fix l1 l2 :: "'a Profile_List"
  fix sigma :: "'a Scores_Map"
  assume nempxa: "xa \<noteq> []"
  assume "pl = l1 @ xa # l2"
  from this have "set xa = A"
    using profl  unfolding profile_l_def well_formed_pl_def losimp
    by (metis in_set_conv_decomp in_set_conv_nth)
  from this nempxa have innit: "xa ! 0 \<in> A" by auto
  assume somev: "\<forall>a\<in>A. sigma a = Some (fold (\<lambda>x ac. if x \<noteq> [] \<and> x ! 0 = a then ac + 1 else ac) l1 0)"
  assume "sigma (xa ! 0) = None"
  from this somev innit show False
    by simp
next
  fix xa :: 'a
  assume "xa \<in> A"
  from this have nempa: "A \<noteq> {}" by auto
  fix sigma ::  "('a \<Rightarrow> nat option)"
  assume valuemap: "\<forall>a\<in>A. sigma a = Some (fold (\<lambda>x ac. if x \<noteq> [] \<and> x ! 0 = a then ac + 1 else ac) pl 0)"
  assume outnone: " \<forall>a. a \<notin> A \<longrightarrow> sigma a = None"
  from valuemap this have wclmap: "(sigma) = (\<lambda>a . Some (win_count_l pl a))|`A"
    unfolding restrict_map_def win_count_l.simps by auto
  from prel profl have "(pl, pr) \<in> profile_on_A_rel A"
    by (simp add: in_br_conv list_rel_eq_listrel listrel_iff_nth profile_l_def relAPP_def relcomp.intros)
  from this wclmap have wcmap: "(sigma) = (\<lambda>a . Some (win_count pr a))|`A"
    using  win_count_l_correct[THEN fun_relD,THEN fun_relD, where x1 = pl and x'1 = pr and A2 = A]
    by fastforce
  assume neg: "sigma \<noteq> (\<lambda>a. Some (card {i. i < length pr \<and> above (pr ! i) a = {a}})) |` A"
  from wcmap this show False by auto
qed

lemma plurality_ref_correct:
  shows "(uncurry plurality_ref, uncurry (RETURN oo plurality_mod)) \<in>
  ([\<lambda> (A, pl). finite_profile A
            pl]\<^sub>f (\<langle>Id\<rangle>set_rel \<times>\<^sub>r profile_rel)
   \<rightarrow> \<langle>\<langle>Id\<rangle>set_rel \<times>\<^sub>r \<langle>Id\<rangle>set_rel \<times>\<^sub>r \<langle>Id\<rangle>set_rel\<rangle>nres_rel)"
proof (intro frefI nres_relI,  clarsimp simp del:  plurality_mod.simps plur_score.simps,
     unfold plurality_ref_def plurality_mod.simps
     RETURN_SPEC_conv, rename_tac A pl pr)
  note max_eliminator_ref_correct_default[where A = A and efn_ref = plur_score_ref and
       efn = plur_score]
  fix A :: "'a::{default, heap, hashable} set"
  fix pr :: "'a Profile"
  fix pl :: "'a Profile_List"
  assume fina: "finite A"
  assume prel: "(pl, pr) \<in> profile_rel"
  assume profp: "profile A pr"
  show " pre_compute_scores plur_score_ref A pl \<bind> (\<lambda>scores. max_eliminator_ref scores A pl)
       \<le> SPEC (\<lambda>x. x = max_eliminator plur_score A pr)"
    using max_eliminator_ref_correct_default plur_score_correct fina prel profp
    by metis
qed

lemma plurality_ref_opt_correct:
  shows "(uncurry plurality_ref_opt, uncurry (RETURN oo plurality_mod)) \<in>
  ([\<lambda> (A, pl). finite_profile A
            pl]\<^sub>f (\<langle>Id\<rangle>set_rel \<times>\<^sub>r profile_rel)
   \<rightarrow> \<langle>\<langle>Id\<rangle>set_rel \<times>\<^sub>r \<langle>Id\<rangle>set_rel \<times>\<^sub>r \<langle>Id\<rangle>set_rel\<rangle>nres_rel)"
proof (intro frefI nres_relI,  clarsimp simp del:  plurality_mod.simps plur_score.simps,
     unfold plurality_ref_opt_def plurality_mod.simps
     RETURN_SPEC_conv, rename_tac A pl pr)
  fix A :: "'a::{default, heap, hashable} set"
  fix pr :: "'a Profile"
  fix pl :: "'a Profile_List"
  assume fina: "finite A"
  assume prel: "(pl, pr) \<in> profile_rel"
  assume profp: "profile A pr"
  from this have profl: "profile_l A pl" using prel profile_ref by blast
  show "pre_compute_plur_scores A pl \<bind> (\<lambda>scores. max_eliminator_ref scores A pl)
       \<le> SPEC (\<lambda>x. x = max_eliminator plur_score A pr)"
    by (refine_vcg max_eliminator_ref_correct_pc plurality_map_correct fina prel profl)
qed

subsection \<open>Imperative HOL Synthesis Using Sepref\<close>

sepref_definition plurality_elim_sep is
  "uncurry plurality_ref"::
    "(hs.assn id_assn)\<^sup>k *\<^sub>a (profile_impl_assn id_assn)\<^sup>k
   \<rightarrow>\<^sub>a (result_impl_assn id_assn)"
  unfolding plurality_ref_def  max_eliminator_ref_def plur_score_ref_def
    less_eliminator_ref_def  elimination_module_ref_def[abs_def] eliminate_def[abs_def]
    pre_compute_scores_def[abs_def] scoremax_def[abs_def] wc_fold_def[abs_def]
    short_circuit_conv hm.fold_custom_empty
  apply (rewrite in "FOREACH _ _ rewrite_HOLE" hs.fold_custom_empty)
  apply (rewrite in "FOREACH _ _ rewrite_HOLE" hs.fold_custom_empty)
  apply (rewrite in "RETURN (_, _, rewrite_HOLE)" hs.fold_custom_empty)
  apply (rewrite in "RETURN (_, rewrite_HOLE, _)" hs.fold_custom_empty)
  apply (rewrite in "RETURN (rewrite_HOLE, _, _)" hs.fold_custom_empty)
  apply (rewrite in "_ \<bind> (\<lambda>(rej, def). if def = {} then RETURN (rewrite_HOLE, _, rej) else RETURN ({}, rej, def))" hs.fold_custom_empty)
  apply (rewrite in "_ \<bind> (\<lambda>(rej, def). if def = {} then RETURN (_, rewrite_HOLE, rej) else RETURN ({}, rej, def))" hs.fold_custom_empty)
  apply (rewrite in "_ \<bind> (\<lambda>(rej, def). if def = {} then RETURN (_, _, rej) else RETURN (rewrite_HOLE, rej, def))" hs.fold_custom_empty)
  apply sepref_dbg_keep
  done

sepref_definition plurality_elim_sep_opt is
  "uncurry plurality_ref_opt"::
    "(alts_set_impl_assn id_assn)\<^sup>k *\<^sub>a (profile_impl_assn id_assn)\<^sup>k
   \<rightarrow>\<^sub>a (result_impl_assn id_assn)"
  unfolding plurality_ref_opt_def  max_eliminator_ref_def plur_score_ref_def
    less_eliminator_ref_def  elimination_module_ref_def[abs_def] eliminate_def[abs_def]
    scoremax_def[abs_def] op_set_is_empty_def[symmetric]
   pre_compute_plur_scores_def init_map_def op_set_is_empty_def[symmetric]
     hm.fold_custom_empty
  apply (rewrite in "RETURN (_, _, rewrite_HOLE)" hs.fold_custom_empty)
  apply (rewrite in "RETURN (_, rewrite_HOLE, _)" hs.fold_custom_empty)+
  apply (rewrite in "RETURN (rewrite_HOLE, _, _)" hs.fold_custom_empty)+
  apply (rewrite in "FOREACH _ _ rewrite_HOLE" hs.fold_custom_empty)+
  by sepref

subsection \<open>Overall Correctness Lemma for Imperative HOL function\<close>

lemma plurality_elim_sep_correct:
  shows "(uncurry plurality_elim_sep_opt, uncurry (RETURN \<circ>\<circ> plurality_mod))
        \<in> elec_mod_seprel id_assn"
  unfolding ballot_assn_def
  using plurality_elim_sep_opt.refine[FCOMP plurality_ref_opt_correct]
  set_rel_id hr_comp_Id2 by simp

declare plurality_elim_sep_correct [sepref_fr_rules]

end


theory Proof_1_7
  imports HandDryer VCTheoryLemmas Extra
begin

theorem proof_1_7:
"VC7 inv1 s0 hands_value"
  apply(simp only: VC7_def inv1_def R1_def dryer_def)
  apply(rule impI; rule conjI)
proof -
  print_state
  assume VC: " ((toEnvP s0 \<and>
      (\<forall>s1 s2.
          substate s1 s2 \<and>
          substate s2 s0 \<and>
          toEnvP s1 \<and>
          toEnvP s2 \<and>
          toEnvNum s1 s2 = hands \<and>
          getVarBool s1 hands = OFF \<and>
          getVarBool s1 (Suc (Suc 0)) = OFF \<and>
          getVarBool s2 hands = ON \<longrightarrow>
          (\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> hands \<and>
                getVarBool s4 (Suc (Suc 0)) = ON \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 hands = ON)))) \<and>
     extraInv s0) \<and>
    env (setVarAny s0 hands_value) hands_value \<and>
    getPstate (setVarAny s0 hands_value) Ctrl =
    drying \<and>
    getVarBool (setVarAny s0 hands_value) hands \<noteq>
    ON \<and>
    \<not> 10 \<le> ltimeEnv (setVarAny s0 hands_value)
             Ctrl"
  show " toEnvP (toEnv (setVarAny s0 hands_value)) \<and>
    (\<forall>s1 s2.
        substate s1 s2 \<and>
        substate s2
         (toEnv (setVarAny s0 hands_value)) \<and>
        toEnvP s1 \<and>
        toEnvP s2 \<and>
        toEnvNum s1 s2 = hands \<and>
        getVarBool s1 hands = OFF \<and>
        getVarBool s1 (Suc (Suc 0)) = OFF \<and>
        getVarBool s2 hands = ON \<longrightarrow>
        (\<exists>s4. toEnvP s4 \<and>
              substate s2 s4 \<and>
              substate s4
               (toEnv (setVarAny s0 hands_value)) \<and>
              toEnvNum s2 s4 \<le> hands \<and>
              getVarBool s4 (Suc (Suc 0)) = ON \<and>
              (\<forall>s3. toEnvP s3 \<and>
                    substate s2 s3 \<and>
                    substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                    getVarBool s3 hands = ON)))"
    apply(rule conjI)
     apply(simp)
  proof(rule allI; rule allI; rule impI)
    fix s1 s2
    assume req_prems: " substate s1 s2 \<and>
       substate s2
         (toEnv (setVarAny s0 hands_value)) \<and>
       toEnvP s1 \<and>
       toEnvP s2 \<and>
       toEnvNum s1 s2 = hands \<and>
       getVarBool s1 hands = OFF \<and>
       getVarBool s1 (Suc (Suc 0)) = OFF \<and>
       getVarBool s2 hands = ON "
    show " \<exists>s4. toEnvP s4 \<and>
            substate s2 s4 \<and>
            substate s4
             (toEnv (setVarAny s0 hands_value)) \<and>
            toEnvNum s2 s4 \<le> hands \<and>
            getVarBool s4 (Suc (Suc 0)) = ON \<and>
            (\<forall>s3. toEnvP s3 \<and>
                  substate s2 s3 \<and>
                  substate s3 s4 \<and>
                  s3 \<noteq> s4 \<longrightarrow>
                  getVarBool s3 hands = ON)"
    proof cases
      assume 1: "s2 =   (toEnv (setVarAny s0 hands_value))"
      have " (toEnvP s2 \<and>
         substate s2 s2 \<and>
         substate s2
          (toEnv (setVarAny s0 hands_value)) \<and>
         toEnvNum s2 s2 \<le> hands \<and>
         getVarBool s2 (Suc (Suc 0)) = ON) \<and>
         (\<forall>s3. toEnvP s3 \<and>
               substate s2 s3 \<and>
               substate s3 s2 \<and>
               s3 \<noteq> s2 \<longrightarrow>
               getVarBool s3 hands = ON)"
      proof
        from 1  VC req_prems show "toEnvP s2 \<and>
    substate s2 s2 \<and>
    substate s2
     (toEnv (setVarAny s0 hands_value)) \<and>
    toEnvNum s2 s2 \<le> hands \<and>
    getVarBool s2 (Suc (Suc 0)) = ON" by auto
      next
        from substate_asym show " \<forall>s3. toEnvP s3 \<and>
         substate s2 s3 \<and>
         substate s3 s2 \<and> s3 \<noteq> s2 \<longrightarrow>
         getVarBool s3 hands = ON"
          by auto
      qed
      thus ?thesis by blast
    next
       assume 1: "s2 \<noteq>   (toEnv (setVarAny s0 hands_value))"
       with req_prems have 2: "substate s2 s0"
         by (simp split: if_splits)
       from VC req_prems 2 obtain "\<exists>s4. toEnvP s4 \<and>
           substate s2 s4 \<and>
           substate s4 s0 \<and>
           toEnvNum s2 s4 \<le> hands \<and>
           getVarBool s4 (Suc (Suc 0)) = ON \<and>
           (\<forall>s3. toEnvP s3 \<and>
                 substate s2 s3 \<and>
                 substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                 getVarBool s3 hands = ON)"by auto
       then obtain s4 where 3: "toEnvP s4 \<and>
           substate s2 s4 \<and>
           substate s4 s0 \<and>
           toEnvNum s2 s4 \<le> hands \<and>
           getVarBool s4 (Suc (Suc 0)) = ON \<and>
           (\<forall>s3. toEnvP s3 \<and>
                 substate s2 s3 \<and>
                 substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                 getVarBool s3 hands = ON)" ..
       have "toEnvP s4 \<and>
      substate s2 s4 \<and>
      substate s4
        (toEnv (setVarAny s0 hands_value)) \<and>
      toEnvNum s2 s4 \<le> hands \<and>
      getVarBool s4 (Suc (Suc 0)) = ON \<and>
      (\<forall>s3. toEnvP s3 \<and>
            substate s2 s3 \<and>
            substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
            getVarBool s3 hands = ON)"
         using 3 by auto
       thus ?thesis ..
     qed
   qed
 next
   assume VC: "((toEnvP s0 \<and>
      (\<forall>s1 s2.
          substate s1 s2 \<and>
          substate s2 s0 \<and>
          toEnvP s1 \<and>
          toEnvP s2 \<and>
          toEnvNum s1 s2 = hands \<and>
          getVarBool s1 hands = OFF \<and>
          getVarBool s1 (Suc (Suc 0)) = OFF \<and>
          getVarBool s2 hands = ON \<longrightarrow>
          (\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> hands \<and>
                getVarBool s4 (Suc (Suc 0)) = ON \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 hands = ON)))) \<and>
     extraInv s0) \<and>
    env (setVarAny s0 hands_value) hands_value \<and>
    getPstate (setVarAny s0 hands_value) Ctrl =
    drying \<and>
    getVarBool (setVarAny s0 hands_value) hands \<noteq>
    ON \<and>
    \<not> 10 \<le> ltimeEnv (setVarAny s0 hands_value)
             Ctrl"
   with extra7
   show "extraInv (toEnv (setVarAny s0 hands_value))"
     by (auto simp add: VC7_def)
 qed

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_44
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun zip :: "'a list => 'b list => (('a, 'b) pair) list" where
  "zip (nil2) y = nil2"
| "zip (cons2 z x2) (nil2) = nil2"
| "zip (cons2 z x2) (cons2 x3 x4) = cons2 (pair2 z x3) (zip x2 x4)"

fun zipConcat :: "'a => 'a list => 'b list =>
                  (('a, 'b) pair) list" where
  "zipConcat x y (nil2) = nil2"
| "zipConcat x y (cons2 y2 ys) = cons2 (pair2 x y2) (zip y ys)"

theorem property0 :
  "((zip (cons2 x xs) ys) = (zipConcat x xs ys))"
  oops

end


(*
Author: Alexander Katovsky
*)

header "Natural Transformation"

theory NatTrans
imports Functors
begin

record ('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans =
  NTDom :: "('o1, 'o2, 'm1, 'm2, 'a, 'b) Functor"
  NTCod :: "('o1, 'o2, 'm1, 'm2, 'a, 'b) Functor"
  NatTransMap :: "'o1 \<Rightarrow> 'm2"

abbreviation
  NatTransApp :: "('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans \<Rightarrow> 'o1 \<Rightarrow> 'm2" (infixr "$$" 70) where
  "NatTransApp \<eta> X \<equiv> (NatTransMap \<eta>) X"

definition  "NTCatDom \<eta> \<equiv> CatDom (NTDom \<eta>)"
definition  "NTCatCod \<eta> \<equiv> CatCod (NTCod \<eta>)"

locale NatTransExt =
  fixes \<eta> :: "('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans" (structure)
  assumes  NTExt : "NatTransMap \<eta> \<in> extensional (Obj (NTCatDom \<eta>))"

locale NatTransP =
  fixes \<eta> :: "('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans" (structure)
  assumes NatTransFtor:   "Functor (NTDom \<eta>)"
  and     NatTransFtor2:  "Functor (NTCod \<eta>)"
  and     NatTransFtorDom:   "NTCatDom \<eta> = CatDom (NTCod \<eta>)"
  and     NatTransFtorCod:   "NTCatCod \<eta> = CatCod (NTDom \<eta>)"
  and    NatTransMapsTo:  "X \<in> obj\<^bsub>NTCatDom \<eta>\<^esub> \<Longrightarrow>
                           (\<eta> $$ X) maps\<^bsub>NTCatCod \<eta>\<^esub> ((NTDom \<eta>) @@ X) to ((NTCod \<eta>) @@ X)"
  and    NatTrans:  "f maps\<^bsub>NTCatDom \<eta>\<^esub> X to Y \<Longrightarrow>
                     ((NTDom \<eta>) ## f) ;;\<^bsub>NTCatCod \<eta>\<^esub> (\<eta> $$ Y) = (\<eta> $$ X) ;;\<^bsub>NTCatCod \<eta>\<^esub> ((NTCod \<eta>) ## f)"

locale NatTrans = NatTransP + NatTransExt

definition MakeNT :: "('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans \<Rightarrow> ('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans" where
"MakeNT \<eta> \<equiv> \<lparr>
      NTDom = NTDom \<eta> ,
      NTCod = NTCod \<eta> ,
      NatTransMap = restrict (NatTransMap \<eta>) (Obj (NTCatDom \<eta>))
  \<rparr>"

definition
  nt_abbrev ("NT _ : _ \<Longrightarrow> _" [81]) where
  "NT f : F \<Longrightarrow> G \<equiv> (NatTrans f) \<and> (NTDom f = F) \<and> (NTCod f = G)"

lemma nt_abbrevE[elim]: "\<lbrakk>NT f : F \<Longrightarrow> G ; \<lbrakk>(NatTrans f) ; (NTDom f = F) ; (NTCod f = G)\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
by (auto simp add: nt_abbrev_def)

lemma MakeNT: "NatTransP \<eta> \<Longrightarrow> NatTrans (MakeNT \<eta>)"
  by(auto simp add: NatTransP_def NatTrans_def MakeNT_def NTCatDom_def NTCatCod_def Category.MapsToObj
    NatTransExt_def)

lemma MakeNT_comp: "X \<in> Obj (NTCatDom f) \<Longrightarrow> (MakeNT f) $$ X = f $$ X"
by (simp add: MakeNT_def)

lemma MakeNT_dom: "NTCatDom f = NTCatDom (MakeNT f)"
by (simp add: NTCatDom_def MakeNT_def)

lemma MakeNT_cod: "NTCatCod f = NTCatCod (MakeNT f)"
by (simp add: NTCatCod_def MakeNT_def)

lemma MakeNTApp: "X \<in> Obj (NTCatDom (MakeNT f)) \<Longrightarrow> f $$ X = (MakeNT f) $$ X"
by(simp add: MakeNT_def NTCatDom_def)

lemma NatTransMapsTo:
  assumes "NT \<eta> : F \<Longrightarrow> G" and "X \<in> Obj (CatDom F)"
  shows "\<eta> $$ X maps\<^bsub>CatCod G \<^esub>(F @@ X) to (G @@ X)"
proof-
  have NTP: "NatTransP \<eta>" using assms by auto
  have NTC: "NTCatCod \<eta> = CatCod G" using assms by (auto simp add: NTCatCod_def)
  have NTD: "NTCatDom \<eta> = CatDom F" using assms by (auto simp add: NTCatDom_def)
  hence Obj: "X \<in> Obj (NTCatDom \<eta>)" using assms by simp
  have DF: "NTDom \<eta> = F" and CG: "NTCod \<eta> = G" using assms by auto
  have NTmapsTo: "\<eta> $$ X maps\<^bsub>NTCatCod \<eta> \<^esub>((NTDom \<eta>) @@ X) to ((NTCod \<eta>) @@ X)"
    using NTP Obj by (simp add: NatTransP.NatTransMapsTo)
  thus ?thesis using NTC NTD DF CG by simp
qed

definition
   NTCompDefined :: "('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans
                      \<Rightarrow> ('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans \<Rightarrow> bool" (infixl "\<approx>>\<bullet>" 65) where
  "NTCompDefined \<eta>1 \<eta>2 \<equiv> NatTrans \<eta>1 \<and> NatTrans \<eta>2 \<and> NTCatDom \<eta>2 = NTCatDom \<eta>1 \<and>
                         NTCatCod \<eta>2 = NTCatCod \<eta>1 \<and> NTCod \<eta>1 = NTDom \<eta>2"

lemma NTCompDefinedE[elim]: "\<lbrakk>\<eta>1 \<approx>>\<bullet> \<eta>2 ; \<lbrakk>NatTrans \<eta>1 ; NatTrans \<eta>2 ; NTCatDom \<eta>2 = NTCatDom \<eta>1 ;
                         NTCatCod \<eta>2 = NTCatCod \<eta>1 ; NTCod \<eta>1 = NTDom \<eta>2\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
by (simp add: NTCompDefined_def)

lemma NatTransExt0:
  assumes "NTDom \<eta>1 = NTDom \<eta>2" and "NTCod \<eta>1 = NTCod \<eta>2"
  and     "\<And>X . X \<in> Obj (NTCatDom \<eta>1) \<Longrightarrow> \<eta>1 $$ X = \<eta>2 $$ X"
  and     "NatTransMap \<eta>1 \<in> extensional (Obj (NTCatDom \<eta>1))"
  and     "NatTransMap \<eta>2 \<in> extensional (Obj (NTCatDom \<eta>2))"
  shows   "\<eta>1 = \<eta>2"
proof-
  have "NatTransMap \<eta>1 = NatTransMap \<eta>2"
  proof(rule extensionalityI [of "NatTransMap \<eta>1" "Obj (NTCatDom \<eta>1)"])
    show "NatTransMap \<eta>1 \<in> extensional (Obj (NTCatDom \<eta>1))" using assms by simp
    have "NTCatDom \<eta>1 = NTCatDom \<eta>2" using assms by (simp add: NTCatDom_def)
    moreover have "NatTransMap \<eta>2 \<in> extensional (Obj (NTCatDom \<eta>2))" using assms by simp
    ultimately show "NatTransMap \<eta>2 \<in> extensional (Obj (NTCatDom \<eta>1))" by simp
    {fix X assume "X \<in> Obj (NTCatDom \<eta>1)" thus "\<eta>1 $$ X = \<eta>2 $$ X" using assms by simp}
  qed
  thus ?thesis using assms by (simp)
qed

lemma NatTransExt:
  assumes "NatTrans \<eta>1" and "NatTrans \<eta>2" and "NTDom \<eta>1 = NTDom \<eta>2" and "NTCod \<eta>1 = NTCod \<eta>2"
  and     "\<And>X . X \<in> Obj (NTCatDom \<eta>1) \<Longrightarrow> \<eta>1 $$ X = \<eta>2 $$ X"
  shows   "\<eta>1 = \<eta>2"
proof-
  have "NatTransMap \<eta>1 \<in> extensional (Obj (NTCatDom \<eta>1))" and
       "NatTransMap \<eta>2 \<in> extensional (Obj (NTCatDom \<eta>2))" using assms
  by(simp only: NatTransExt_def NatTrans_def)+
  thus ?thesis using assms by (simp add: NatTransExt0)
qed

definition
  IdNatTrans' :: "('o1, 'o2, 'm1, 'm2, 'a1, 'a2) Functor \<Rightarrow> ('o1, 'o2, 'm1, 'm2, 'a1, 'a2) NatTrans" where
  "IdNatTrans' F \<equiv> \<lparr>
      NTDom = F ,
      NTCod = F ,
      NatTransMap = \<lambda> X . id\<^bsub>CatCod F\<^esub> (F @@ X)
  \<rparr>"

definition "IdNatTrans F \<equiv> MakeNT(IdNatTrans' F)"

lemma IdNatTrans_map: "X \<in> obj\<^bsub>CatDom F\<^esub> \<Longrightarrow> (IdNatTrans F) $$ X = id\<^bsub>CatCod F\<^esub> (F @@ X)"
by(auto simp add: IdNatTrans_def IdNatTrans'_def MakeNT_comp MakeNT_def NTCatDom_def)

lemmas IdNatTrans_defs = IdNatTrans_def IdNatTrans'_def MakeNT_def IdNatTrans_map NTCatCod_def NTCatDom_def

lemma IdNatTransNatTrans': "Functor F \<Longrightarrow> NatTransP(IdNatTrans' F)"
proof(auto simp add:NatTransP_def IdNatTrans'_def NTCatDom_def NTCatCod_def Category.Simps
        PreFunctor.FunctorId2 functor_simps Functor.FunctorMapsTo)
  {
    fix f X Y
    assume a: "Functor F" and b: "f maps\<^bsub>CatDom F\<^esub> X to Y"
    show "(F ## f) ;;\<^bsub>CatCod F\<^esub> (id\<^bsub>CatCod F\<^esub> (F @@ Y)) = (id\<^bsub>CatCod F\<^esub> (F @@ X)) ;;\<^bsub>CatCod F\<^esub> (F ## f)"
    proof-
      have 1: "Category (CatCod F)" using a by simp
      have "F ## f maps\<^bsub>CatCod F\<^esub> (F @@ X) to (F @@ Y)" using a b by (auto simp add: Functor.FunctorMapsTo)
      hence 2: "F ## f \<in> mor\<^bsub>CatCod F\<^esub>" and 3: "cod\<^bsub>CatCod F\<^esub> (F ## f) = (F @@ Y)"
        and 4: "dom\<^bsub>CatCod F\<^esub> (F ## f) = (F @@ X)" by auto
      have "(F ## f) ;;\<^bsub>CatCod F\<^esub> (id\<^bsub>CatCod F\<^esub> (F @@ Y)) = (F ## f) ;;\<^bsub>CatCod F\<^esub> (id\<^bsub>CatCod F\<^esub> (cod\<^bsub>CatCod F\<^esub> (F ## f)))"
        using 3 by simp
      also have "... = F ## f" using 1 2 by (auto simp add: Category.Cidr)
      also have "... = (id\<^bsub>CatCod F\<^esub> (dom\<^bsub>CatCod F\<^esub> (F ## f))) ;;\<^bsub>CatCod F\<^esub> (F ## f)"
        using 1 2 by (auto simp add: Category.Cidl)
      also have "... = (id\<^bsub>CatCod F\<^esub> (F @@ X)) ;;\<^bsub>CatCod F\<^esub> (F ## f)" using 4 by simp
      finally show ?thesis .
    qed
  }
qed

lemma IdNatTransNatTrans: "Functor F \<Longrightarrow> NatTrans (IdNatTrans F)"
by (simp add: IdNatTransNatTrans' IdNatTrans_def MakeNT)

definition
  NatTransComp' :: "('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans \<Rightarrow>
                   ('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans \<Rightarrow>
                   ('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans" (infixl "\<bullet>1" 75) where
  "NatTransComp' \<eta>1 \<eta>2 = \<lparr>
      NTDom = NTDom \<eta>1 ,
      NTCod = NTCod \<eta>2 ,
      NatTransMap = \<lambda> X . (\<eta>1 $$ X) ;;\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ X)
  \<rparr>"

definition NatTransComp (infixl "\<bullet>" 75) where "\<eta>1 \<bullet> \<eta>2 \<equiv> MakeNT(\<eta>1 \<bullet>1 \<eta>2)"

lemma NatTransComp_Comp1: "\<lbrakk>x \<in> Obj (NTCatDom f) ; f \<approx>>\<bullet> g\<rbrakk> \<Longrightarrow> (f \<bullet> g) $$ x = (f $$ x) ;;\<^bsub>NTCatCod g\<^esub> (g $$ x)"
by(auto simp add: NatTransComp_def NatTransComp'_def MakeNT_def NTCatCod_def NTCatDom_def)

lemma NatTransComp_Comp2: "\<lbrakk>x \<in> Obj (NTCatDom f) ; f \<approx>>\<bullet> g\<rbrakk> \<Longrightarrow> (f \<bullet> g) $$ x = (f $$ x) ;;\<^bsub>NTCatCod f\<^esub> (g $$ x)"
by(auto simp add: NatTransComp_def NatTransComp'_def MakeNT_def NTCatCod_def NTCatDom_def)

lemmas NatTransComp_defs = NatTransComp_def NatTransComp'_def MakeNT_def
  NatTransComp_Comp1  NTCatCod_def NTCatDom_def

lemma [simp]: "\<eta>1 \<approx>>\<bullet> \<eta>2 \<Longrightarrow> NatTrans \<eta>1" by auto
lemma [simp]: "\<eta>1 \<approx>>\<bullet> \<eta>2 \<Longrightarrow> NatTrans \<eta>2" by auto
lemma NTCatDom:        "\<eta>1 \<approx>>\<bullet> \<eta>2 \<Longrightarrow> NTCatDom \<eta>1 = NTCatDom \<eta>2" by auto
lemma NTCatCod:        "\<eta>1 \<approx>>\<bullet> \<eta>2 \<Longrightarrow> NTCatCod \<eta>1 = NTCatCod \<eta>2" by auto
lemma [simp]: "\<eta>1 \<approx>>\<bullet> \<eta>2 \<Longrightarrow> NTCatDom (\<eta>1 \<bullet>1 \<eta>2) = NTCatDom \<eta>1" by (auto simp add: NatTransComp'_def NTCatDom_def)
lemma [simp]: "\<eta>1 \<approx>>\<bullet> \<eta>2 \<Longrightarrow> NTCatCod (\<eta>1 \<bullet>1 \<eta>2) = NTCatCod \<eta>1" by (auto simp add: NatTransComp'_def NTCatCod_def)
lemma [simp]: "\<eta>1 \<approx>>\<bullet> \<eta>2 \<Longrightarrow> NTCatDom (\<eta>1 \<bullet> \<eta>2) = NTCatDom \<eta>1" by (auto simp add: NatTransComp_defs)
lemma [simp]: "\<eta>1 \<approx>>\<bullet> \<eta>2 \<Longrightarrow> NTCatCod (\<eta>1 \<bullet> \<eta>2) = NTCatCod \<eta>1" by (auto simp add: NatTransComp_defs)
lemma [simp]: "NatTrans \<eta> \<Longrightarrow> Category(NTCatDom \<eta>)" by (simp add:  NatTransP.NatTransFtor NTCatDom_def)
lemma [simp]: "NatTrans \<eta> \<Longrightarrow> Category(NTCatCod \<eta>)" by (simp add:  NatTransP.NatTransFtor2 NTCatCod_def)
lemma DDDC: assumes "NatTrans f" shows "CatDom (NTDom f) = CatDom (NTCod f)"
proof-
  have "CatDom (NTDom f) = NTCatDom f" by (simp add: NTCatDom_def)
  thus ?thesis using assms by (simp add: NatTransP.NatTransFtorDom)
qed
lemma CCCD: assumes "NatTrans f" shows "CatCod (NTCod f) = CatCod (NTDom f)"
proof-
  have "CatCod (NTCod f) = NTCatCod f" by (simp add: NTCatCod_def)
  thus ?thesis using assms by (simp add: NatTransP.NatTransFtorCod)
qed

lemma IdNatTransCompDefDom: "NatTrans f \<Longrightarrow> (IdNatTrans (NTDom f)) \<approx>>\<bullet> f"
apply(rule NTCompDefinedI)
apply(simp_all add: IdNatTransNatTrans NatTransP.NatTransFtor)
apply(simp_all add: IdNatTrans_defs CCCD)
done

lemma IdNatTransCompDefCod: "NatTrans f \<Longrightarrow> f \<approx>>\<bullet> (IdNatTrans (NTCod f))"
apply(rule NTCompDefinedI)
apply(simp_all add: IdNatTransNatTrans NatTransP.NatTransFtor2)
apply(simp_all add: IdNatTrans_defs DDDC)
done

lemma NatTransCompDefCod:
  assumes "NatTrans \<eta>" and "f maps\<^bsub>NTCatDom \<eta>\<^esub> X to Y"
  shows "(\<eta> $$ X) \<approx>>\<^bsub>NTCatCod \<eta>\<^esub> (NTCod \<eta> ## f)"
proof(rule CompDefinedI)
  have b: "X \<in> obj\<^bsub>NTCatDom \<eta>\<^esub>" and c: "Y \<in> obj\<^bsub>NTCatDom \<eta>\<^esub>" using assms by (auto simp add: Category.MapsToObj)
  have d: "(\<eta> $$ X) maps\<^bsub>NTCatCod \<eta>\<^esub> ((NTDom \<eta>) @@ X) to ((NTCod \<eta>) @@ X)" using assms b
    by (simp add: NatTransP.NatTransMapsTo)
  thus "\<eta> $$ X \<in> mor\<^bsub>NTCatCod \<eta>\<^esub>" by auto
  have "f maps\<^bsub>CatDom (NTCod \<eta>)\<^esub> X to Y" using assms by (simp add: NatTransP.NatTransFtorDom)
  hence e: "NTCod \<eta> ## f maps\<^bsub>CatCod (NTCod \<eta>)\<^esub> (NTCod \<eta> @@ X) to (NTCod \<eta> @@ Y)" using assms
    by (simp add: FunctorM.FunctorCompM NatTransP.NatTransFtor2)
  thus "NTCod \<eta> ## f \<in> mor\<^bsub>NTCatCod \<eta>\<^esub>" by (auto simp add: NTCatCod_def)
  have "cod\<^bsub>NTCatCod \<eta>\<^esub> (\<eta> $$ X) = (NTCod \<eta> @@ X)" using d by auto
  also have "... = dom\<^bsub>CatCod (NTCod \<eta>)\<^esub> (NTCod \<eta> ## f)" using e by auto
  finally show "cod\<^bsub>NTCatCod \<eta>\<^esub> (\<eta> $$ X) = dom\<^bsub>NTCatCod \<eta>\<^esub> (NTCod \<eta> ## f)" by (auto simp add: NTCatCod_def)
qed

lemma NatTransCompDefDom:
  assumes "NatTrans \<eta>" and "f maps\<^bsub>NTCatDom \<eta>\<^esub> X to Y"
  shows "(NTDom \<eta> ## f)  \<approx>>\<^bsub>NTCatCod \<eta>\<^esub> (\<eta> $$ Y)"
proof(rule CompDefinedI)
  have b: "X \<in> obj\<^bsub>NTCatDom \<eta>\<^esub>" and c: "Y \<in> obj\<^bsub>NTCatDom \<eta>\<^esub>" using assms by (auto simp add: Category.MapsToObj)
  have d: "(\<eta> $$ Y) maps\<^bsub>NTCatCod \<eta>\<^esub> ((NTDom \<eta>) @@ Y) to ((NTCod \<eta>) @@ Y)" using assms c
    by (simp add: NatTransP.NatTransMapsTo)
  thus "\<eta> $$ Y \<in> mor\<^bsub>NTCatCod \<eta>\<^esub>" by auto
  have "f maps\<^bsub>CatDom (NTDom \<eta>)\<^esub> X to Y" using assms by (simp add: NTCatDom_def)
  hence e: "NTDom \<eta> ## f maps\<^bsub>CatCod (NTDom \<eta>)\<^esub> (NTDom \<eta> @@ X) to (NTDom \<eta> @@ Y)" using assms
    by (simp add: FunctorM.FunctorCompM NatTransP.NatTransFtor)
  thus "NTDom \<eta> ## f \<in> mor\<^bsub>NTCatCod \<eta>\<^esub>" using assms by (auto simp add: NatTransP.NatTransFtorCod)
  have "dom\<^bsub>NTCatCod \<eta>\<^esub> (\<eta> $$ Y) = (NTDom \<eta> @@ Y)" using d by auto
  also have "... = cod\<^bsub>CatCod (NTDom \<eta>)\<^esub> (NTDom \<eta> ## f)" using e by auto
  finally show "cod\<^bsub>NTCatCod \<eta>\<^esub> (NTDom \<eta> ## f) = dom\<^bsub>NTCatCod \<eta>\<^esub> (\<eta> $$ Y)"
    using assms by (auto simp add: NatTransP.NatTransFtorCod)
qed

lemma NatTransCompCompDef:
  assumes "\<eta>1 \<approx>>\<bullet> \<eta>2" and "X \<in> obj\<^bsub>NTCatDom \<eta>1\<^esub>"
  shows "(\<eta>1 $$ X) \<approx>>\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ X)"
proof(rule CompDefinedI)
  have 1: "(\<eta>1 $$ X) maps\<^bsub>NTCatCod \<eta>1\<^esub> ((NTDom \<eta>1) @@ X) to ((NTCod \<eta>1) @@ X)" using assms
    by (simp add: NatTransP.NatTransMapsTo)
  have "NTCatCod \<eta>1 = NTCatCod \<eta>2" using assms by auto
  hence 2: "(\<eta>2 $$ X) maps\<^bsub>NTCatCod \<eta>1\<^esub> ((NTDom \<eta>2) @@ X) to ((NTCod \<eta>2) @@ X)" using assms
    by (simp add: NatTransP.NatTransMapsTo NTCatDom)
  show "\<eta>1 $$ X \<in> mor\<^bsub>NTCatCod \<eta>1\<^esub>"
    and "\<eta>2 $$ X \<in> mor\<^bsub>NTCatCod \<eta>1\<^esub>"  using 1 2 by auto
  have "cod\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>1 $$ X) = ((NTCod \<eta>1) @@ X)" using 1 by auto
  also have "... = ((NTDom \<eta>2) @@ X)" using assms by auto
  finally show "cod\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>1 $$ X) = dom\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ X)" using 2 by auto
qed

lemma NatTransCompNatTrans':
  assumes "\<eta>1 \<approx>>\<bullet> \<eta>2"
  shows   "NatTransP (\<eta>1 \<bullet>1 \<eta>2)"
proof(auto simp add: NatTransP_def)
  show "Functor (NTDom (\<eta>1 \<bullet>1 \<eta>2))" and "Functor (NTCod (\<eta>1 \<bullet>1 \<eta>2))" using assms
    by (auto simp add: NatTransComp'_def NatTransP.NatTransFtor NatTransP.NatTransFtor2)
  show "NTCatDom (\<eta>1 \<bullet>1 \<eta>2) = CatDom (NTCod (\<eta>1 \<bullet>1 \<eta>2))" and
       "NTCatCod (\<eta>1 \<bullet>1 \<eta>2) = CatCod (NTDom (\<eta>1 \<bullet>1 \<eta>2))"
  proof (auto simp add: NatTransComp'_def NTCatCod_def NTCatDom_def)
    have "CatDom (NTDom \<eta>1) = NTCatDom \<eta>1" by (simp add: NTCatDom_def)
    thus "CatDom (NTDom \<eta>1) = CatDom (NTCod \<eta>2)" using assms by (auto simp add: NatTransP.NatTransFtorDom)
    have "CatCod (NTCod \<eta>2) = NTCatCod \<eta>2" by (simp add: NTCatCod_def)
    thus "CatCod (NTCod \<eta>2) = CatCod (NTDom \<eta>1)" using assms by (auto simp add: NatTransP.NatTransFtorCod)
  qed
  {
    fix X assume aa: "X \<in> obj\<^bsub>NTCatDom (\<eta>1 \<bullet>1 \<eta>2)\<^esub>"
    show "(\<eta>1 \<bullet>1 \<eta>2) $$ X maps\<^bsub>NTCatCod (\<eta>1 \<bullet>1 \<eta>2)\<^esub> NTDom (\<eta>1 \<bullet>1 \<eta>2) @@ X to NTCod (\<eta>1 \<bullet>1 \<eta>2) @@ X"
    proof-
      have "X \<in> obj\<^bsub>NTCatDom \<eta>1\<^esub>" and "NatTrans \<eta>1" using assms aa by simp+
      hence "(\<eta>1 $$ X) maps\<^bsub>NTCatCod \<eta>1\<^esub> ((NTDom \<eta>1) @@ X) to ((NTCod \<eta>1) @@ X)"
        by (simp add: NatTransP.NatTransMapsTo)
      moreover have "(\<eta>2 $$ X) maps\<^bsub>NTCatCod \<eta>1\<^esub> ((NTCod \<eta>1) @@ X) to ((NTCod \<eta>2) @@ X)"
      proof-
        have "X \<in> obj\<^bsub>NTCatDom \<eta>2\<^esub>" and "NatTrans \<eta>2" using assms aa by auto
        hence "(\<eta>2 $$ X) maps\<^bsub>NTCatCod \<eta>2\<^esub> ((NTDom \<eta>2) @@ X) to ((NTCod \<eta>2) @@ X)"
          by (simp add: NatTransP.NatTransMapsTo)
        thus ?thesis using assms by auto
      qed
      ultimately have "(\<eta>1 $$ X) ;;\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ X) maps\<^bsub>NTCatCod \<eta>1\<^esub> ((NTDom \<eta>1) @@ X) to ((NTCod \<eta>2) @@ X)"
        using assms by (simp add: Category.Ccompt)
      thus ?thesis using assms by (auto simp add: NatTransComp'_def NTCatCod_def)
    qed
  }
  {
    fix f X Y assume a: "f maps\<^bsub>(NTCatDom (\<eta>1 \<bullet>1 \<eta>2))\<^esub> X to Y"
    show "(NTDom (\<eta>1 \<bullet>1 \<eta>2) ## f) ;;\<^bsub>NTCatCod (\<eta>1 \<bullet>1 \<eta>2)\<^esub> (\<eta>1 \<bullet>1 \<eta>2 $$ Y) =
       ((\<eta>1 \<bullet>1 \<eta>2) $$ X) ;;\<^bsub>NTCatCod (\<eta>1 \<bullet>1 \<eta>2)\<^esub> (NTCod (\<eta>1 \<bullet>1 \<eta>2) ## f)"
    proof-
      have b: "X \<in> obj\<^bsub>NTCatDom \<eta>1\<^esub>" and c: "Y \<in> obj\<^bsub>NTCatDom \<eta>1\<^esub>" using assms a by (auto simp add: Category.MapsToObj)
      have "((NTDom \<eta>1) ## f) ;;\<^bsub>NTCatCod \<eta>1\<^esub> ((\<eta>1 $$ Y) ;;\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ Y)) =
            (((NTDom \<eta>1) ## f) ;;\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>1 $$ Y)) ;;\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ Y)"
      proof-
        have "((NTDom \<eta>1) ## f) \<approx>>\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>1 $$ Y)" using assms a by (auto simp add: NatTransCompDefDom)
        moreover have "(\<eta>1 $$ Y) \<approx>>\<^bsub>NTCatCod \<eta>1\<^esub>  (\<eta>2 $$ Y)" using assms by (simp add: NatTransCompCompDef c)
        ultimately show ?thesis using assms by (simp add: Category.Cassoc)
      qed
      also have "... = ((\<eta>1 $$ X) ;;\<^bsub>NTCatCod \<eta>1\<^esub> ((NTDom \<eta>2) ## f)) ;;\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ Y)"
        using assms a by (auto simp add: NatTransP.NatTrans)
      also have "... = (\<eta>1 $$ X) ;;\<^bsub>NTCatCod \<eta>1\<^esub> (((NTDom \<eta>2) ## f) ;;\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ Y))"
      proof-
        have "(\<eta>1 $$ X) \<approx>>\<^bsub>NTCatCod \<eta>1\<^esub> ((NTCod \<eta>1) ## f)" using assms a by (simp add: NatTransCompDefCod)
        moreover have "((NTDom \<eta>2) ## f) \<approx>>\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ Y)" using assms a
          by (simp add: NatTransCompDefDom NTCatDom NTCatCod)
        ultimately show ?thesis using assms by (auto simp add: Category.Cassoc)
      qed
      also have "... = (\<eta>1 $$ X) ;;\<^bsub>NTCatCod \<eta>1\<^esub> ((\<eta>2 $$ X) ;;\<^bsub>NTCatCod \<eta>1\<^esub> ((NTCod \<eta>2) ## f))"
        using assms a by (simp add: NatTransP.NatTrans NTCatDom NTCatCod)
      also have "... = (\<eta>1 $$ X) ;;\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ X) ;;\<^bsub>NTCatCod \<eta>1\<^esub> ((NTCod \<eta>2) ## f)"
      proof-
        have "(\<eta>1 $$ X) \<approx>>\<^bsub>NTCatCod \<eta>1\<^esub> (\<eta>2 $$ X)" using assms by (simp add: NatTransCompCompDef b)
        moreover have "(\<eta>2 $$ X) \<approx>>\<^bsub>NTCatCod \<eta>1\<^esub> ((NTCod \<eta>2) ## f)" using assms a
          by (simp add: NatTransCompDefCod NTCatCod NTCatDom)
        ultimately show ?thesis using assms by (simp add: Category.Cassoc)
      qed
      finally show ?thesis using assms by (auto simp add: NatTransComp'_def NTCatCod_def)
    qed
  }
qed

lemma NatTransCompNatTrans: "\<eta>1 \<approx>>\<bullet> \<eta>2 \<Longrightarrow> NatTrans (\<eta>1 \<bullet> \<eta>2)"
by (simp add: NatTransCompNatTrans' NatTransComp_def MakeNT)

definition
  CatExp' :: "('o1,'m1,'a) Category_scheme \<Rightarrow> ('o2,'m2,'b) Category_scheme \<Rightarrow>
                     (('o1, 'o2, 'm1, 'm2, 'a, 'b) Functor,
                      ('o1, 'o2, 'm1, 'm2, 'a, 'b) NatTrans) Category"  where
  "CatExp' A B \<equiv> \<lparr>
      Category.Obj = {F . Ftor F : A \<longrightarrow> B} ,
      Category.Mor = {\<eta> . NatTrans \<eta> \<and> NTCatDom \<eta> = A \<and> NTCatCod \<eta> = B} ,
      Category.Dom = NTDom ,
      Category.Cod = NTCod ,
      Category.Id  = IdNatTrans ,
      Category.Comp = \<lambda>f g. (f \<bullet> g)
  \<rparr>"

definition "CatExp A B \<equiv> MakeCat(CatExp' A B)"

lemma IdNatTransMapL:
  assumes NT: "NatTrans f"
  shows "IdNatTrans (NTDom f) \<bullet> f = f"
proof(rule NatTransExt)
  show "NatTrans f" using assms .
  show "NatTrans (IdNatTrans (NTDom f) \<bullet> f)" using NT
    by (simp add: NatTransP.NatTransFtor IdNatTransNatTrans IdNatTransCompDefDom NatTransCompNatTrans)
  show "NTDom (IdNatTrans (NTDom f) \<bullet> f) = NTDom f" and
    "NTCod (IdNatTrans (NTDom f) \<bullet> f) = NTCod f" by (simp add: IdNatTrans_defs NatTransComp_defs)+
  {
    fix x assume aa: "x \<in> Obj (NTCatDom (IdNatTrans (NTDom f) \<bullet> f))"
    show "(IdNatTrans (NTDom f) \<bullet> f) $$ x = f $$ x"
    proof-
      have XObj: "x \<in> Obj(NTCatDom f)" using aa by (simp add: IdNatTrans_defs NatTransComp_defs)
      have fMap: "f $$ x maps\<^bsub>NTCatCod f\<^esub> NTDom f @@ x to NTCod f @@ x" using NT XObj
        by (simp add: NatTransP.NatTransMapsTo)
      have "(IdNatTrans (NTDom f) \<bullet> f) $$ x = (IdNatTrans (NTDom f) $$ x) ;;\<^bsub>NTCatCod f \<^esub>(f $$ x)"
      proof(rule NatTransComp_Comp1)
        show "x \<in> obj\<^bsub>NTCatDom (IdNatTrans (NTDom f))\<^esub>" using XObj by (simp add: IdNatTrans_defs)
        show "IdNatTrans (NTDom f) \<approx>>\<bullet> f" using NT by (simp add: IdNatTransCompDefDom)
      qed
      also have "... = id\<^bsub>NTCatCod f\<^esub> (dom\<^bsub>NTCatCod f\<^esub> (f $$ x)) ;;\<^bsub>NTCatCod f \<^esub>(f $$ x)"
        using XObj NT fMap by (auto simp add: IdNatTrans_map NTCatDom_def CCCD NTCatCod_def)
      also have "... = f $$ x"
      proof-
        have "f $$ x \<in> mor\<^bsub>NTCatCod f\<^esub>" using fMap by (auto)
        thus ?thesis using NT by (simp add: Category.Cidl)
      qed
      finally show ?thesis .
    qed
  }
qed

lemma IdNatTransMapR:
  assumes NT: "NatTrans f"
  shows "f \<bullet> IdNatTrans (NTCod f) = f"
proof(rule NatTransExt)
  show "NatTrans f" using assms .
  show "NatTrans (f \<bullet> IdNatTrans (NTCod f))" using NT
    by (simp add: NatTransP.NatTransFtor IdNatTransNatTrans IdNatTransCompDefCod NatTransCompNatTrans)
  show "NTDom (f \<bullet> IdNatTrans (NTCod f)) = NTDom f" and
    "NTCod (f \<bullet> IdNatTrans (NTCod f)) = NTCod f" by (simp add: IdNatTrans_defs NatTransComp_defs)+
  {
    fix x assume aa: "x \<in> Obj (NTCatDom (f \<bullet> IdNatTrans (NTCod f)))"
    show "(f \<bullet> IdNatTrans (NTCod f)) $$ x = f $$ x"
    proof-
      have XObj: "x \<in> Obj(NTCatDom f)" using aa by (simp add:  NatTransComp_defs)
      have fMap: "f $$ x maps\<^bsub>NTCatCod f\<^esub> NTDom f @@ x to NTCod f @@ x" using NT XObj
        by (simp add: NatTransP.NatTransMapsTo)
      have "(f \<bullet> IdNatTrans (NTCod f)) $$ x = (f $$ x) ;;\<^bsub>NTCatCod f\<^esub> (IdNatTrans (NTCod f) $$ x)"
        using XObj NT by (auto simp add: NatTransComp_Comp2 IdNatTransCompDefCod)
      also have "... = (f $$ x) ;;\<^bsub>NTCatCod f\<^esub> (id\<^bsub>NTCatCod f\<^esub> (cod\<^bsub>NTCatCod f\<^esub> (f $$ x)))"
      proof-
        have "x \<in> obj\<^bsub>CatDom (NTCod f)\<^esub>" using XObj NT by (simp add: IdNatTrans_defs DDDC)
        moreover have "(cod\<^bsub>NTCatCod f\<^esub> (f $$ x)) = (NTCod f) @@ x" using fMap by auto
        ultimately have "(IdNatTrans (NTCod f) $$ x) = (id\<^bsub>NTCatCod f\<^esub> (cod\<^bsub>NTCatCod f\<^esub> (f $$ x)))"
          by (simp add: IdNatTrans_map NTCatCod_def)
        thus ?thesis by simp
      qed
      also have "... = f $$ x"
      proof-
        have "f $$ x \<in> mor\<^bsub>NTCatCod f\<^esub>" using fMap by (auto)
        thus ?thesis using NT by (simp add: Category.Cidr)
      qed
      finally show ?thesis .
    qed
  }
qed

lemma NatTransCompDefined:
  assumes "f \<approx>>\<bullet> g" and "g \<approx>>\<bullet> h"
  shows "(f \<bullet> g) \<approx>>\<bullet> h" and "f \<approx>>\<bullet> (g \<bullet> h)"
proof-
  show "(f \<bullet> g) \<approx>>\<bullet> h"
  proof(rule NTCompDefinedI)
    show "NatTrans (f \<bullet> g)" and "NatTrans h" using assms by (auto simp add: NatTransCompNatTrans)
    have "NTCatDom f = NTCatDom h" using assms by (simp add: NTCatDom)
    thus "NTCatDom h = NTCatDom (f \<bullet> g)" by (simp add: NatTransComp_defs)
    have "NTCatCod h = NTCatCod g" using assms by (simp add: NTCatCod)
    thus "NTCatCod h = NTCatCod (f \<bullet> g)" by ( simp add: NatTransComp_defs)
    show "NTCod (f \<bullet> g) = NTDom h" using assms by (auto simp add: NatTransComp_defs)
  qed
  show "f \<approx>>\<bullet> (g \<bullet> h)"
  proof(rule NTCompDefinedI)
    show "NatTrans f" and "NatTrans (g \<bullet> h)" using assms by (auto simp add: NatTransCompNatTrans)
    have "NTCatDom f = NTCatDom g" using assms by (simp add: NTCatDom)
    thus "NTCatDom (g \<bullet> h) = NTCatDom f" by (simp add: NatTransComp_defs)
    have "NTCatCod h = NTCatCod f" using assms by (simp add: NTCatCod)
    thus "NTCatCod (g \<bullet> h) = NTCatCod f" by ( simp add: NatTransComp_defs)
    show "NTCod f = NTDom (g \<bullet> h)" using assms by (auto simp add: NatTransComp_defs)
  qed
qed

lemma NatTransCompAssoc:
  assumes "f \<approx>>\<bullet> g" and "g \<approx>>\<bullet> h"
  shows "(f \<bullet> g) \<bullet> h = f \<bullet> (g \<bullet> h)"
proof(rule NatTransExt)
  show "NatTrans ((f \<bullet> g) \<bullet> h)" using assms by (simp add: NatTransCompNatTrans NatTransCompDefined)
  show "NatTrans (f \<bullet> (g \<bullet> h))" using assms by (simp add: NatTransCompNatTrans NatTransCompDefined)
  show "NTDom (f \<bullet> g \<bullet> h) = NTDom (f \<bullet> (g \<bullet> h))" and "NTCod (f \<bullet> g \<bullet> h) = NTCod (f \<bullet> (g \<bullet> h))"
    by(simp add: NatTransComp_defs)+
  {
    fix x assume aa: "x \<in> obj\<^bsub>NTCatDom (f \<bullet> g \<bullet> h)\<^esub>" show "((f \<bullet> g) \<bullet> h) $$ x = (f \<bullet> (g \<bullet> h)) $$ x"
    proof-
      have ntd1: "NTCatDom (f \<bullet> g) = NTCatDom (f \<bullet> g \<bullet> h)" and ntd2: "NTCatDom f = NTCatDom (f \<bullet> g \<bullet> h)"
        using assms by (simp add: NatTransCompDefined)+
      have obj1: "x \<in> Obj (NTCatDom f)" using aa ntd2 by simp
      have  1: "(f \<bullet> g) $$ x = (f $$ x) ;;\<^bsub>NTCatCod h\<^esub> (g $$ x)" and
            2: "(g \<bullet> h) $$ x = (g $$ x) ;;\<^bsub>NTCatCod h\<^esub> (h $$ x)" using obj1
        using assms by (auto simp add: NatTransComp_Comp1)
      have "((f \<bullet> g) \<bullet> h) $$ x = ((f \<bullet> g) $$ x) ;;\<^bsub>NTCatCod h\<^esub> (h $$ x)"
      proof(rule NatTransComp_Comp1)
        show "x \<in> obj\<^bsub>NTCatDom (f \<bullet> g)\<^esub>" using aa ntd1 by simp
        show "f \<bullet> g \<approx>>\<bullet> h" using assms by (simp add: NatTransCompDefined)
      qed
      also have "... = ((f $$ x) ;;\<^bsub>NTCatCod h\<^esub> (g $$ x)) ;;\<^bsub>NTCatCod h\<^esub> (h $$ x)" using 1 by simp
      also have "... = (f $$ x) ;;\<^bsub>NTCatCod h\<^esub> ((g $$ x) ;;\<^bsub>NTCatCod h\<^esub> (h $$ x))"
      proof-
        have 1: "NTCatCod h = NTCatCod f" and 2: "NTCatCod h = NTCatCod g" using assms by (simp add: NTCatCod)+
        hence "(f $$ x) \<approx>>\<^bsub>NTCatCod h\<^esub> (g $$ x)" using obj1 assms by (simp add: NatTransCompCompDef)
        moreover have "(g $$ x) \<approx>>\<^bsub>NTCatCod h\<^esub> (h $$ x)" using obj1 assms 2 by (simp add: NatTransCompCompDef NTCatDom)
        moreover have "Category (NTCatCod h)" using assms by auto
        ultimately show ?thesis by (simp add: Category.Cassoc)
      qed
      also have "... = (f $$ x) ;;\<^bsub>NTCatCod h\<^esub> ((g \<bullet> h) $$ x)" using 2 by simp
      also have "... = (f \<bullet> (g \<bullet> h)) $$ x"
      proof-
        have "NTCatCod f = NTCatCod h" using assms by (simp add: NTCatCod)
        moreover have "(f \<bullet> (g \<bullet> h)) $$ x = (f $$ x) ;;\<^bsub>NTCatCod f\<^esub> ((g \<bullet> h) $$ x)"
        proof(rule NatTransComp_Comp2)
          show "x \<in> obj\<^bsub>NTCatDom f\<^esub>" using obj1 assms by (simp add: NTCatDom)
          show "f \<approx>>\<bullet> g \<bullet> h" using assms by (simp add: NatTransCompDefined)
        qed
        ultimately show ?thesis by simp
      qed
      finally show ?thesis .
    qed
  }
qed

lemma CatExpCatAx:
  assumes "Category A" and "Category B"
  shows "Category_axioms (CatExp' A B)"
proof(auto simp add: Category_axioms_def)
  {
    fix f assume "f \<in> mor\<^bsub>CatExp' A B\<^esub>"
    thus "dom\<^bsub>CatExp' A B\<^esub> f \<in> obj\<^bsub>CatExp' A B\<^esub>" and
         "cod\<^bsub>CatExp' A B\<^esub> f \<in> obj\<^bsub>CatExp' A B\<^esub>"
      by(auto simp add: CatExp'_def NatTransP.NatTransFtor
        NatTransP.NatTransFtor2 NatTransP.NatTransFtorDom NatTransP.NatTransFtorCod DDDC CCCD functor_abbrev_def)
  }
  {
    fix F assume a: "F \<in> obj\<^bsub>CatExp' A B\<^esub>"
    show "id\<^bsub>CatExp' A B\<^esub> F maps\<^bsub>CatExp' A B\<^esub> F to F"
    proof(rule MapsToI)
      have "Ftor F : A \<longrightarrow> B" using a by (simp add: CatExp'_def)
      thus "id\<^bsub>CatExp' A B\<^esub> F \<in> mor\<^bsub>CatExp' A B\<^esub>"
        apply(simp add: CatExp'_def NTCatDom_def NTCatCod_def IdNatTransNatTrans functor_abbrev_def)
        apply(simp add: IdNatTrans_defs)
        done
      show "dom\<^bsub>CatExp' A B\<^esub> (id\<^bsub>CatExp' A B\<^esub> F) = F" by (simp add: CatExp'_def IdNatTrans_defs)
      show "cod\<^bsub>CatExp' A B\<^esub> (id\<^bsub>CatExp' A B\<^esub> F) = F" by (simp add: CatExp'_def IdNatTrans_defs)
    qed
  }
  {
    fix f assume a: "f \<in> mor\<^bsub>CatExp' A B\<^esub>"
    show "(id\<^bsub>CatExp' A B\<^esub> (dom\<^bsub>CatExp' A B\<^esub> f)) ;;\<^bsub>CatExp' A B\<^esub> f = f" and
         "f ;;\<^bsub>CatExp' A B\<^esub> (id\<^bsub>CatExp' A B\<^esub> (cod\<^bsub>CatExp' A B\<^esub> f)) = f"
    proof(simp_all add: CatExp'_def)
      have NT: "NatTrans f" using a by (simp add: CatExp'_def)
      show "IdNatTrans (NTDom f) \<bullet> f = f" using NT by (simp add:IdNatTransMapL)
      show "f \<bullet> IdNatTrans (NTCod f) = f" using NT by (simp add:IdNatTransMapR)
    qed
  }
  {
    fix f g h assume aa: "f \<approx>>\<^bsub>CatExp' A B\<^esub> g" and bb: "g \<approx>>\<^bsub>CatExp' A B\<^esub> h"
    {
      fix f g assume "f \<approx>>\<^bsub>CatExp' A B\<^esub> g" hence "f \<approx>>\<bullet> g"
        apply(simp only: NTCompDefined_def)
        by (auto simp add:  CatExp'_def)
    }
    hence "f \<approx>>\<bullet> g" and "g \<approx>>\<bullet> h" using aa bb by auto
    thus "f ;;\<^bsub>CatExp' A B\<^esub> g ;;\<^bsub>CatExp' A B\<^esub> h = f ;;\<^bsub>CatExp' A B\<^esub> (g ;;\<^bsub>CatExp' A B\<^esub> h)"
    by(simp add: CatExp'_def NatTransCompAssoc)
  }
  {
    fix f g X Y Z assume a: "f maps\<^bsub>CatExp' A B\<^esub> X to Y" and b: "g maps\<^bsub>CatExp' A B\<^esub> Y to Z"
    show "f ;;\<^bsub>CatExp' A B\<^esub> g maps\<^bsub>CatExp' A B\<^esub> X to Z"
    proof(rule MapsToI, auto simp add: CatExp'_def)
      have nt1: "NatTrans f" and cd1: "NTCatDom f = A"
        and cc1: "NTCatCod f = B" and d1: "NTDom f = X" and c1: "NTCod f = Y"
        using a by (auto simp add: CatExp'_def)
      moreover have nt2: "NatTrans g" and cd2: "NTCatDom g = A"
        and cc2: "NTCatCod g = B" and d2: "NTDom g = Y" and c2: "NTCod g = Z"
        using b by (auto simp add: CatExp'_def)
      ultimately have Comp: "f \<approx>>\<bullet> g" by(auto intro: NTCompDefinedI)
      thus "NatTrans (f \<bullet> g)" by (simp add: NatTransCompNatTrans)
      show "NTCatDom (f \<bullet> g) = A" using Comp cd1 by (simp add: NTCatDom)
      show "NTCatCod (f \<bullet> g) = B" using Comp cc2 by (simp add: NTCatCod)
      show "NTDom (f \<bullet> g) = X" using d1 by (simp add: NatTransComp_defs)
      show "NTCod (f \<bullet> g) = Z" using c2 by (simp add: NatTransComp_defs)
    qed
  }
qed

lemma CatExpCat: "\<lbrakk>Category A ; Category B\<rbrakk> \<Longrightarrow> Category (CatExp A B)"
by(simp add: CatExpCatAx CatExp_def MakeCat)

lemmas CatExp_defs = CatExp_def CatExp'_def MakeCat_def

lemma CatExpDom: "f \<in> Mor (CatExp A B) \<Longrightarrow> dom\<^bsub>CatExp A B\<^esub> f = NTDom f"
by (simp add: CatExp_defs)

lemma CatExpCod: "f \<in> Mor (CatExp A B) \<Longrightarrow> cod\<^bsub>CatExp A B\<^esub> f = NTCod f"
by (simp add: CatExp_defs)

lemma CatExpId: "X \<in> Obj (CatExp A B) \<Longrightarrow> Id (CatExp A B) X = IdNatTrans X"
by (simp add: CatExp_defs)

lemma CatExpNatTransCompDef: assumes "f \<approx>>\<^bsub>CatExp A B\<^esub> g" shows "f \<approx>>\<bullet> g"
proof-
  have 1: "f \<approx>>\<^bsub>CatExp' A B\<^esub> g" using assms by (simp add: CatExp_def MakeCatCompDef)
  show "f \<approx>>\<bullet> g"
  proof(rule NTCompDefinedI)
    show "NatTrans f" using 1 by (auto simp add: CatExp'_def)
    show "NatTrans g" using 1 by (auto simp add: CatExp'_def)
    show "NTCatDom g = NTCatDom f" using 1 by (auto simp add: CatExp'_def)
    show "NTCatCod g = NTCatCod f" using 1 by (auto simp add: CatExp'_def)
    show "NTCod f = NTDom g" using 1 by (auto simp add: CatExp'_def)
  qed
qed

lemma CatExpDist:
  assumes "X \<in> Obj A" and "f \<approx>>\<^bsub>CatExp A B\<^esub> g"
  shows "(f ;;\<^bsub>CatExp A B\<^esub> g) $$ X = (f $$ X) ;;\<^bsub>B\<^esub> (g $$ X)"
proof-
  have "f \<in> Mor (CatExp' A B)" using assms by (auto simp add: CatExp_def MakeCatMor)
  hence 1: "NTCatDom f = A" and 2: "NTCatCod f = B" by (simp add: CatExp'_def)+
  hence 4: "X \<in> Obj (NTCatDom f)" using assms by simp
  have 3: "f \<approx>>\<bullet> g" using assms(2) by (simp add: CatExpNatTransCompDef)
  have "(f ;;\<^bsub>CatExp A B\<^esub> g) $$ X = (f ;;\<^bsub>CatExp' A B\<^esub> g) $$ X" using assms(2) by (simp add: CatExp_def MakeCatComp2)
  also have "... = (f \<bullet> g) $$ X" by (simp add: CatExp'_def)
  also have "... = (f $$ X) ;;\<^bsub>B\<^esub> (g $$ X)" using 4 2 3 by (simp add: NatTransComp_Comp2[of X f g])
  finally show ?thesis .
qed

lemma CatExpMorNT: "f \<in> Mor (CatExp A B) \<Longrightarrow> NatTrans f"
by (simp add: CatExp_defs)

end


theory GabrielaLimonta
imports Main
begin

(** Score: 7/10
  3.1: 6/10
    Wrong aux-lemma, gen not done

  3.2: Not proven: 1/5

*)

(* Homework 3.1 *)
datatype instr = LDI int | LD nat | ST nat | ADD nat

type_synonym state = "nat \<Rightarrow> int"

fun exec :: "instr \<Rightarrow> state \<Rightarrow> state" where
  "exec (LDI i) s = s(0 := i)"
| "exec (LD n) s = s(0 := (s (n + 1)))"
| "exec (ST n) s = s((n+1) := (s 0))"
| "exec (ADD n) s = s(0 := (s 0) + (s (n + 1)))"

fun execs :: "instr list \<Rightarrow> state \<Rightarrow> state" where
  "execs [] s = s"
| "execs (x#xs) s = execs xs (exec x s)"

datatype expr = C int | V nat | A expr expr

fun val :: "expr \<Rightarrow> (nat \<Rightarrow> int) \<Rightarrow> int" where
  "val (C i) s = i"
| "val (V n) s = s n"
| "val (A a1 a2) s = val a1 s + val a2 s"

fun cmp :: "expr \<Rightarrow> nat \<Rightarrow> instr list" where
  "cmp (C i) n = (LDI i # ST n # [])"
| "cmp (V x) n = (LD x # ST n # [])"
| "cmp (A a1 a2) n = cmp a1 (n + 1) @ cmp a2 (n + 2) @ (LD (n+1) # ADD (n+2) # ST n # [])"

value "cmp (A (C 21) (A (V 1) (C 21))) 2"

fun maxvar :: "expr \<Rightarrow> nat" where
  "maxvar (C i) = 0"
| "maxvar (V n) = n"
| "maxvar (A a1 a2) = (if maxvar a1 > maxvar a2 then maxvar a1 else maxvar a2)"

value "maxvar (A (C 21) (A (V 1) (V 42)))"

lemma [simp]: "\<forall> n \<le> maxvar e. s n = s' n \<Longrightarrow> val e s = val e s'"
  apply(induction)
  apply(auto)
  done

lemma [simp]: "\<forall> n \<le> maxvar e. n > 0 \<Longrightarrow> s n = (execs (cmp e (n+1)) s) n"
(**
  This lemma does not quite state what you expect it to state.
  The \<Longrightarrow> has lower binding priority than the \<forall>.

  The following proof illustrates what I mean:
**)
proof -
  assume A: "\<forall> n \<le> maxvar e. n > 0"
  have "0\<le>maxvar e" by simp
  with A have "0>0" by blast
  hence False by auto
  thus ?thesis ..
qed

(** Probably, you meant:
  \<forall> n \<le> maxvar e. n > 0 \<longrightarrow> s n = (execs (cmp e (n+1)) s) n

  As another indication you were wrong: regard the coloring of the variable
  n in jEdit's syntax highlighting: It should be green (bound variable) everywhere,
  but in the conclusion it's blue (free variable).
**)

(**
  apply(induction)
  apply(auto)
  done
*)

theorem "execs (cmp e (maxvar e + 1)) s 0 = val e (comp s Suc)"
proof(induction e)
  print_cases
  case C thus ?case by simp
next
  case V thus ?case by simp
next
  case A thus ?case
oops

(* Exercise 3.2 *)
datatype ab = a | b

inductive_set S :: "ab list set" where
  A: "w \<in> S \<Longrightarrow> [a] @ w \<in> S"
| B: "w \<in> S \<Longrightarrow> w @ [b] \<in> S"
| E: "[] \<in> S"

fun only_b :: "ab list \<Rightarrow> bool" where
  "only_b [] = True"
| "only_b (x#xs) = (if x = b then only_b xs else False)"

value "only_b [b,b,b,b,b,b,b,b,b,b,b,b]"
value "only_b []"
value "only_b [b,b,b,b,b,a,b,b,b,b,b]"

fun is_ab :: "ab list \<Rightarrow> bool" where
  "is_ab [] = True"
| "is_ab (x#xs) = (case x of
   a \<Rightarrow> (is_ab xs \<or> only_b xs) |
   b \<Rightarrow> only_b xs)"

value "is_ab [b,b,b,b,b,b,b,b,b,b,b,b]"
value "is_ab []"
value "is_ab [b,b,b,b,b,a,b,b,b,b,b]"
value "is_ab [a,a,a,a,a,a,b,b,b]"
value "is_ab [a,a,a,a,a,a]"
value "is_ab [b,a]"

(** This is the "culprit", it causes a loop in the simplifier, as
  the opposite rewrite rule is already in there.

lemma [simp]: "(a#w) = [a] @ w"
  apply(auto)
  done*)

lemma "w \<in> S \<Longrightarrow> is_ab w"
proof (induction w)
  print_cases
  case Nil thus ?case by simp
next
  case (Cons e w)
  thus ?case oops
  (** by (auto split: ab.split) ** Oops, this proof method does not
    terminate, so nothing has been proven!
qed*)

end


section \<open> British Imperial System (1824/1897) \<close>

theory BIS
  imports ISQ SI_Units CGS
begin

text \<open> The values in the British Imperial System (BIS) are derived from the UK Weights and Measures
  Act 1824. \<close>

subsection \<open> Preliminaries \<close>

typedef BIS = "UNIV :: unit set" ..
instance BIS :: unit_system
  by (rule unit_system_intro[of "Abs_BIS ()"],
      metis (full_types) Abs_BIS_cases UNIV_eq_I insert_iff old.unit.exhaust)
instance BIS :: time_second ..
abbreviation "BIS \<equiv> unit :: BIS"

subsection \<open> Base Units \<close>

abbreviation "yard     \<equiv> BUNIT(L, BIS)"
abbreviation "pound    \<equiv> BUNIT(M, BIS)"
abbreviation "rankine  \<equiv> BUNIT(\<Theta>, BIS)"

text \<open> We chose Rankine rather than Farenheit as this is more compatible with the SI system and
  avoids the need for having an offset in conversion functions. \<close>

subsection \<open> Derived Units \<close>

definition [si_eq]: "foot = 1/3 *\<^sub>Q yard"

definition [si_eq]: "inch = 1/12 *\<^sub>Q foot"

definition [si_eq]: "furlong = 220 *\<^sub>Q yard"

definition [si_eq]: "mile = 1760 *\<^sub>Q yard"

definition [si_eq]: "acre = 4840 *\<^sub>Q yard\<^sup>\<three>"

definition [si_eq]: "ounce = 1/12 *\<^sub>Q pound"

definition [si_eq]: "gallon = 277.421 *\<^sub>Q inch\<^sup>\<three>"

definition [si_eq]: "quart = 1/4 *\<^sub>Q gallon"

definition [si_eq]: "pint = 1/8 *\<^sub>Q gallon"

definition [si_eq]: "peck = 2 *\<^sub>Q gallon"

definition [si_eq]: "bushel = 8 *\<^sub>Q gallon"

definition [si_eq]: "minute = 60 *\<^sub>Q second"

definition [si_eq]: "hour = 60 *\<^sub>Q minute"

subsection \<open> Conversion to SI \<close>

instantiation BIS :: metrifiable
begin

lift_definition convschema_BIS :: "BIS itself \<Rightarrow> (BIS, SI) Conversion" is
"\<lambda> x. \<lparr> cLengthF = 0.9143993, cMassF = 0.453592338, cTimeF = 1
      , cCurrentF = 1, cTemperatureF = 5/9, cAmountF = 1, cIntensityF = 1 \<rparr>" by simp

instance ..
end

lemma BIS_SI_simps [simp]: "LengthF (convschema (a::BIS itself)) = 0.9143993"
                           "MassF (convschema a) = 0.453592338"
                           "TimeF (convschema a) = 1"
                           "CurrentF (convschema a) = 1"
                           "TemperatureF (convschema a) = 5/9"
  by (transfer, simp)+

subsection \<open> Conversion Examples \<close>

lemma "metrify (foot :: rat[L, BIS]) = 0.9143993 / 3 *\<^sub>Q metre"
  by (simp add: foot_def)

lemma "metrify ((70::rat) *\<^sub>Q mile \<^bold>/ hour) = (704087461 / 22500000) *\<^sub>Q (metre \<^bold>/ second)"
  by (si_simp)

lemma "QMC(CGS \<rightarrow> BIS) ((1::rat) *\<^sub>Q centimetre) = 100000 / 9143993 *\<^sub>Q yard"
  by simp

end