(*  Title:      statecharts/HA/HA.thy

    Author:     Steffen Helke, Software Engineering Group
    Copyright   2010 Technische Universitaet Berlin
*)

header {* Syntax of Hierarchical Automata *}
theory HA
imports "SA"
begin

subsection {* Definitions *}

(* unique root automaton *)

definition
  RootEx :: "[(('s,'e,'d)seqauto) set,
              's ~=>  ('s,'e,'d) seqauto set] => bool" where
  "RootEx F G = (\<exists>! A. A \<in> F \<and> A \<notin> \<Union> (ran G))"

definition
  Root :: "[(('s,'e,'d)seqauto) set,
            's ~=> ('s,'e,'d) seqauto set]
           => ('s,'e,'d) seqauto" where
  "Root F G = (@ A. A \<in> F \<and>  A \<notin> \<Union> (ran G))"

(* mutually distinct state spaces *)

definition
  MutuallyDistinct :: "(('s,'e,'d)seqauto) set => bool" where
  "MutuallyDistinct F =
        (\<forall> a \<in> F. \<forall> b \<in> F. a \<noteq> b \<longrightarrow> (States a) \<inter> (States b) = {})"

(* exactly one ancestor for every non root automaton *)

definition
 OneAncestor :: "[(('s,'e,'d)seqauto) set,
                   's ~=> ('s,'e,'d) seqauto set] => bool" where
 "OneAncestor F G =
                (\<forall> A \<in> F - {Root F G} .
                    \<exists>! s. s \<in> (\<Union> A' \<in> F - {A} . States A') \<and>
                         A \<in> the (G s))"

(* composition function contains no cycles *)

definition
  NoCycles :: "[(('s,'e,'d)seqauto) set,
                   's ~=> ('s,'e,'d) seqauto set] => bool" where
  "NoCycles F G =
       (\<forall> S \<in> Pow (\<Union> A \<in> F. States A).
           S \<noteq> {} \<longrightarrow>  (\<exists> s \<in> S. S \<inter> (\<Union> A \<in> the (G s). States A) = {}))"

(* properties of composition functions *)

definition
  IsCompFun :: "[(('s,'e,'d)seqauto) set,
                    's ~=> ('s,'e,'d) seqauto set] => bool" where
  "IsCompFun F G = ((dom G = (\<Union> A \<in> F. States A)) \<and>
                    (\<Union> (ran G) = (F - {Root F G})) \<and>
                    (RootEx F G) \<and>
                    (OneAncestor F G) \<and>
                    (NoCycles F G))"

subsubsection {* Well-formedness for the syntax of HA *}

definition
  HierAuto :: "['d data,
                 (('s,'e,'d)seqauto) set,
                'e set,
                's ~=> (('s,'e,'d)seqauto) set]
                => bool" where
  "HierAuto D F E G = ((\<Union> A \<in> F. SAEvents A) \<subseteq> E \<and>
                       MutuallyDistinct F \<and>
                       finite F \<and>
                       IsCompFun F G)"

lemma HierAuto_EmptySet:
 "((@x. True),{Abs_seqauto ({@x. True}, (@x. True), {}, {})}, {},
  empty ( @x. True \<mapsto> {})) \<in> {(D,F,E,G) | D F E G. HierAuto D F E G}"
apply (unfold HierAuto_def IsCompFun_def Root_def RootEx_def MutuallyDistinct_def
           OneAncestor_def NoCycles_def)
apply auto
done

definition
  "hierauto =
    {(D,F,E,G) |
        (D::'d data)
        (F::(('s,'e,'d) seqauto) set)
        (E::('e set))
        (G::('s ~=> (('s,'e,'d) seqauto) set)).
                                HierAuto D F E G}"

typedef ('s,'e,'d) hierauto =
    "hierauto :: ('d data * ('s,'e,'d) seqauto set * 'e set * ('s ~=> ('s,'e,'d) seqauto set)) set"
  unfolding hierauto_def
  apply (rule exI)
  apply (rule HierAuto_EmptySet)
  done

definition
  SAs :: "(('s,'e,'d) hierauto)  => (('s,'e,'d) seqauto) set" where
  "SAs = fst o snd o Rep_hierauto"

definition
  HAEvents :: "(('s,'e,'d) hierauto) => ('e set)" where
  "HAEvents = fst o snd o snd o Rep_hierauto"

definition
  CompFun :: "(('s,'e,'d) hierauto) => ('s ~=> ('s,'e,'d) seqauto set)" where
  "CompFun = (snd o snd o snd o Rep_hierauto)"

definition
  HAStates :: "(('s,'e,'d) hierauto) => ('s set)" where
  "HAStates HA = (\<Union>  A \<in> (SAs HA). States A)"

definition
  HADelta :: "(('s,'e,'d) hierauto) => (('s,'e,'d)trans)set" where
  "HADelta HA = (\<Union> F \<in> (SAs HA). Delta F)"

definition
  HAInitValue :: "(('s,'e,'d) hierauto) => 'd data" where
  "HAInitValue == fst o Rep_hierauto"

definition
  HAInitStates :: "(('s,'e,'d) hierauto) => 's set" where
  "HAInitStates HA == \<Union> A \<in> (SAs HA). { InitState A }"

definition
  HARoot :: "(('s,'e,'d) hierauto) => ('s,'e,'d)seqauto" where
  "HARoot HA == Root (SAs HA) (CompFun HA)"

definition
  HAInitState :: "(('s,'e,'d) hierauto) => 's" where
  "HAInitState HA == InitState (HARoot HA)"

subsubsection {* State successor function *}

(* state successor function Chi *)

definition
  Chi   :: "('s,'e,'d)hierauto => 's => 's set" where
  "Chi A ==  (\<lambda>  S \<in>  (HAStates A) .
                 {S'. \<exists> SA \<in> (SAs A) . SA \<in> the ((CompFun A) S) \<and> S' \<in> States SA })"

(* direct state successor relation ChiRel *)

definition
  ChiRel :: "('s,'e,'d)hierauto => ('s *'s) set" where
  "ChiRel A == { (S,S'). S \<in> HAStates A \<and> S' \<in> HAStates A \<and> S' \<in> (Chi A) S }"

(* indirect state successor relation ChiPlus *)

definition
  ChiPlus :: "('s,'e,'d)hierauto => ('s *'s) set" where
  "ChiPlus A == (ChiRel A) ^+"

definition
  ChiStar :: "('s,'e,'d)hierauto => ('s *'s) set" where
  "ChiStar A == (ChiRel A) ^*"

(* priority on transitions that are successors *)

definition
  HigherPriority :: "[('s,'e,'d)hierauto,
                      ('s,'e,'d)trans * ('s,'e,'d)trans] => bool" where
  "HigherPriority A ==
             \<lambda> (t,t') \<in> (HADelta A) \<times> (HADelta A).
                          (source t',source t) \<in>  ChiPlus A"

subsubsection {* Configurations *}

(* initial configuration *)

definition
  InitConf :: "('s,'e,'d)hierauto => 's set" where
  "InitConf A == (((((HAInitStates A) \<times> (HAInitStates A)) \<inter> (ChiRel A))^* )
                     `` {HAInitState A})"

(*  -------------------------------------------------------------- *)
(*  First, the original definition calculating a step on           *)
(*  configurations given by                                        *)
(*                                                                 *)
(*  E. Mikk, Y. Lakhnech, and M. Siegel. Hierarchical automata as  *)
(*  model for statecharts. In Asian Computing Science Conference   *)
(*  (ASIAN~97), Springer LNCS, 1345, 1997.                         *)
(*
    "StepConf A C TS ==
       (C - ((ChiStar A) `` (Source TS))) \<union>
        (Target TS) \<union> (((ChiPlus A) `` (Target TS))
                    \<inter> (HAInitStates A))"
                                                                   *)
(*                                                                 *)
(* Note, that this semantic definition not preserves the           *)
(* well-formedness of a Statecharts. Hence we use our definition.  *)
(*  -------------------------------------------------------------- *)

(* step on configurations *)

definition
  StepConf  :: "[('s,'e,'d)hierauto, 's set,
                 ('s,'e,'d)trans set] => 's set" where

  "StepConf A C TS ==
               (C - ((ChiStar A) `` (Source TS))) \<union>
               (Target TS) \<union>
               ((ChiRel A) `` (Target TS)) \<inter> (HAInitStates A) \<union>
               ((((ChiRel A) \<inter> ((HAInitStates A) \<times> (HAInitStates A)))\<^sup>+)
                   `` (((ChiRel A)`` (Target TS)) \<inter> (HAInitStates A)))"

subsection {* Lemmas *}

lemma Rep_hierauto_tuple:
"Rep_hierauto HA = (HAInitValue HA, SAs HA, HAEvents HA, CompFun HA)"
by (unfold SAs_def HAEvents_def CompFun_def HAInitValue_def, simp)

lemma Rep_hierauto_select:
  "(HAInitValue HA, SAs HA, HAEvents HA, CompFun HA): hierauto";
by (rule Rep_hierauto_tuple [THEN subst], rule Rep_hierauto)

lemma HierAuto_select [simp]:
  "HierAuto (HAInitValue HA) (SAs HA) (HAEvents HA) (CompFun HA)"
by (cut_tac Rep_hierauto_select, unfold hierauto_def, simp)

subsubsection {* @{text "HAStates"} *}

lemma finite_HAStates [simp]:
  "finite (HAStates HA)"
apply (cut_tac Rep_hierauto_select)
apply (unfold hierauto_def HierAuto_def)
apply auto
apply (simp add: HAStates_def)
apply (rule finite_UN_I)
apply fast
apply (rule finite_States)
done

lemma HAStates_SA_mem:
 "\<lbrakk> SA \<in> SAs A; S \<in> States SA \<rbrakk> \<Longrightarrow> S \<in> HAStates A"
by (unfold HAStates_def, auto)

lemma ChiRel_HAStates [simp]:
 "(a,b) \<in> ChiRel A \<Longrightarrow> a \<in> HAStates A"
apply (unfold ChiRel_def)
apply auto
done

lemma ChiRel_HAStates2 [simp]:
 "(a,b) \<in>  ChiRel A \<Longrightarrow> b \<in> HAStates A"
apply (unfold ChiRel_def)
apply auto
done

subsubsection {* @{text "HAEvents"} *}

lemma HAEvents_SAEvents_SAs:
  "UNION (SAs HA) SAEvents \<subseteq> HAEvents HA"
apply (cut_tac Rep_hierauto_select)
apply (unfold hierauto_def HierAuto_def)
apply fast
done

subsubsection {* @{text "NoCycles"} *}

lemma NoCycles_EmptySet [simp]:
  "NoCycles {} S"
by (unfold NoCycles_def, auto)

lemma NoCycles_HA [simp]:
  "NoCycles (SAs HA) (CompFun HA)"
apply (cut_tac Rep_hierauto_select)
apply (unfold hierauto_def HierAuto_def IsCompFun_def)
apply auto
done

subsubsection {* @{text "OneAncestor"} *}

lemma OneAncestor_HA [simp]:
  "OneAncestor (SAs HA) (CompFun HA)"
apply (cut_tac Rep_hierauto_select)
apply (unfold hierauto_def HierAuto_def IsCompFun_def)
apply auto
done

subsubsection {* @{text "MutuallyDistinct"} *}

lemma MutuallyDistinct_Single [simp]:
  "MutuallyDistinct {SA}";
by (unfold MutuallyDistinct_def, auto)

lemma MutuallyDistinct_EmptySet [simp]:
  "MutuallyDistinct {}"
by (unfold MutuallyDistinct_def, auto)

lemma MutuallyDistinct_Insert:
  "\<lbrakk> MutuallyDistinct S; (States A) \<inter>  (\<Union> B \<in> S. States B) = {} \<rbrakk>
  \<Longrightarrow> MutuallyDistinct (insert A S)";
by (unfold MutuallyDistinct_def, safe, fast+)

lemma MutuallyDistinct_Union:
  "\<lbrakk> MutuallyDistinct A; MutuallyDistinct B;
  (\<Union> C \<in> A. States C) \<inter> (\<Union> C \<in> B. States C) = {} \<rbrakk>
  \<Longrightarrow> MutuallyDistinct (A \<union> B)";
by (unfold MutuallyDistinct_def, safe, blast+)

lemma MutuallyDistinct_HA [simp]:
  "MutuallyDistinct (SAs HA)"
apply (cut_tac Rep_hierauto_select)
apply (unfold hierauto_def HierAuto_def IsCompFun_def)
apply auto
done

subsubsection {* @{text "RootEx"} *}

lemma RootEx_Root [simp]:
  "RootEx F G \<Longrightarrow> Root F G \<in> F";
apply (unfold RootEx_def Root_def)
apply (erule ex1E)
apply (erule conjE)
apply (rule someI2)
apply blast+
done

lemma RootEx_Root_ran [simp]:
  "RootEx F G \<Longrightarrow> Root F G \<notin> \<Union> (ran G)"
apply (unfold RootEx_def Root_def)
apply (erule ex1E)
apply (erule conjE)
apply (rule someI2)
apply blast+
done

lemma RootEx_States_Subset [simp]:
  "(RootEx F G) \<Longrightarrow> States (Root F G) \<subseteq> (\<Union> x \<in> F . States x)"
apply (unfold RootEx_def Root_def)
apply (erule ex1E)
apply (erule conjE)
apply (rule someI2)
apply fast
apply (unfold UNION_eq)
apply (simp add: subset_eq)
apply auto
done

lemma RootEx_States_notdisjunct [simp]:
  "RootEx F G \<Longrightarrow> States (Root F G) \<inter> (\<Union> x \<in> F . States x) \<noteq> {}"
apply (frule RootEx_States_Subset)
apply (case_tac "States (Root F G)={}")
prefer 2
apply fast
apply simp
done

lemma Root_neq_SA [simp]:
  "\<lbrakk> RootEx F G; (\<Union> x \<in> F . States x) \<inter> States SA = {} \<rbrakk> \<Longrightarrow> Root F G \<noteq> SA"
apply (rule  SA_States_disjunct)
apply (frule RootEx_States_Subset)
apply fast
done

lemma RootEx_HA [simp]:
  "RootEx (SAs HA) (CompFun HA)"
apply (cut_tac Rep_hierauto_select)
apply (unfold hierauto_def HierAuto_def IsCompFun_def)
apply fast
done

subsubsection {* @{text "HARoot"} *}

lemma HARoot_SAs [simp]:
  "(HARoot HA) \<in> SAs HA"
apply (unfold HARoot_def)
apply (cut_tac Rep_hierauto_select)
apply (unfold hierauto_def HierAuto_def)
apply auto
done

lemma States_HARoot_HAStates:
  "States (HARoot HA) \<subseteq>  HAStates HA"
apply (unfold HAStates_def)
apply auto
apply (rule_tac x="HARoot HA" in bexI)
apply auto
done

lemma SAEvents_HARoot_HAEvents:
  "SAEvents (HARoot HA) \<subseteq> HAEvents HA"
apply (cut_tac Rep_hierauto_select)
apply (unfold hierauto_def HierAuto_def)
apply auto
apply (rename_tac S)
apply (unfold UNION_eq)
apply (simp add: subset_eq)
apply (erule_tac x=S in allE)
apply auto
done

lemma HARoot_ran_CompFun:
  "HARoot HA \<notin> Union (ran (CompFun HA))"
apply (unfold HARoot_def)
apply (cut_tac Rep_hierauto_select)
apply (unfold IsCompFun_def hierauto_def HierAuto_def)
apply fast
done

lemma HARoot_ran_CompFun2:
  "S \<in> ran (CompFun HA) \<longrightarrow> HARoot HA \<notin> S"
apply (unfold HARoot_def)
apply (cut_tac Rep_hierauto_select)
apply (unfold IsCompFun_def hierauto_def HierAuto_def)
apply fast
done

subsubsection {* @{text "CompFun"} *}

lemma IsCompFun_HA [simp]:
  "IsCompFun (SAs HA) (CompFun HA)"
apply (cut_tac Rep_hierauto_select)
apply (unfold hierauto_def HierAuto_def)
apply auto
done

lemma dom_CompFun [simp]:
  "dom (CompFun HA) = HAStates HA"
apply (cut_tac HA=HA in IsCompFun_HA)
apply (unfold IsCompFun_def HAStates_def)
apply auto
done

lemma ran_CompFun [simp]:
  "Union (ran (CompFun HA)) = ((SAs HA) - {Root  (SAs HA)(CompFun HA)})"
apply (cut_tac HA=HA in IsCompFun_HA)
apply (unfold IsCompFun_def)
apply fast
done

lemma ran_CompFun_subseteq:
  "Union (ran (CompFun HA)) \<subseteq> (SAs HA)"
apply (cut_tac HA=HA in IsCompFun_HA)
apply (unfold IsCompFun_def)
apply fast
done

lemma ran_CompFun_is_not_SA:
  "\<not> Sas \<subseteq> (SAs HA) \<Longrightarrow> Sas \<notin> (ran (CompFun HA))"
apply (cut_tac HA=HA in IsCompFun_HA)
apply (unfold IsCompFun_def)
apply fast
done

lemma HAStates_HARoot_CompFun [simp]:
  "S \<in> HAStates HA \<Longrightarrow> HARoot HA \<notin> the (CompFun HA S)"
apply (rule ran_dom_the)
back
apply (simp add: HARoot_ran_CompFun2 HARoot_def HAStates_def)+
done

lemma HAStates_CompFun_SAs:
 "S \<in> HAStates A \<Longrightarrow> the (CompFun A S) \<subseteq> SAs A"
apply auto
apply (rename_tac T)
apply (cut_tac HA=A in ran_CompFun)
apply (erule equalityE)
apply (erule_tac c=T in subsetCE)
apply (drule ran_dom_the)
apply auto
done

lemma HAStates_CompFun_notmem [simp]:
  "\<lbrakk> S \<in> HAStates A; SA \<in> the (CompFun A S) \<rbrakk> \<Longrightarrow> S \<notin> States SA"
apply (unfold HAStates_def)
apply auto
apply (rename_tac T)
apply (cut_tac HA=A in MutuallyDistinct_HA)
apply (unfold MutuallyDistinct_def)
apply (erule_tac x=SA in ballE)
apply (erule_tac x=T in ballE)
apply auto
prefer 2
apply (cut_tac A=A and S=S in  HAStates_CompFun_SAs)
apply (unfold HAStates_def)
apply simp
apply fast
apply fast
apply (cut_tac HA=A in NoCycles_HA)
apply (unfold NoCycles_def)
apply (erule_tac x="{S}" in ballE)
apply auto
done

lemma CompFun_Int_disjoint:
  "\<lbrakk> S \<noteq> T; S \<in>  HAStates A; T \<in>  HAStates A \<rbrakk> \<Longrightarrow> the (CompFun A T) \<inter> the (CompFun A S) = {}"
apply auto
apply (rename_tac U)
apply (cut_tac HA=A in OneAncestor_HA)
apply (unfold OneAncestor_def)
apply (erule_tac x=U in ballE)
prefer 2
apply simp
apply (fold HARoot_def)
apply (frule HAStates_HARoot_CompFun)
apply simp
apply (frule HAStates_CompFun_SAs)
apply auto
apply (erule_tac x=S in allE)
apply (erule_tac x=T in allE)
apply auto
apply (cut_tac HA=A in NoCycles_HA)
apply (unfold NoCycles_def)
apply (simp only: HAStates_def)
apply safe
apply (erule_tac x="{S}" in ballE)
apply simp
apply fast
apply simp
apply (cut_tac HA=A in NoCycles_HA)
apply (unfold NoCycles_def)
apply (simp only: HAStates_def)
apply safe
apply (erule_tac x="{T}" in ballE)
apply simp
apply fast
apply simp
done

subsubsection {* @{text "SAs"} *}

lemma finite_SAs [simp]:
  "finite (SAs HA)"
apply (cut_tac Rep_hierauto_select)
apply (unfold hierauto_def HierAuto_def)
apply fast
done

lemma HAStates_SAs_disjunct:
  "HAStates HA1 \<inter> HAStates HA2 = {} \<Longrightarrow> SAs HA1 \<inter> SAs HA2 = {}"
apply (unfold UNION_eq HAStates_def Int_def)
apply auto
apply (rename_tac SA)
apply (cut_tac SA=SA in EX_State_SA)
apply (erule exE)
apply auto
done

lemma HAStates_CompFun_SAs_mem [simp]:
 "\<lbrakk> S \<in> HAStates A; T \<in> the (CompFun A S) \<rbrakk> \<Longrightarrow> T \<in> SAs A"
apply (cut_tac A=A and S=S in HAStates_CompFun_SAs)
apply auto
done

lemma SAs_States_HAStates:
 "SA \<in> SAs A \<Longrightarrow> States SA \<subseteq> HAStates A"
by (unfold HAStates_def, auto)

subsubsection {* @{text "HAInitState"} *}

lemma HAInitState_HARoot [simp]:
  "HAInitState A \<in> States (HARoot A)"
by (unfold HAInitState_def, auto)

lemma HAInitState_HARoot2 [simp]:
  "HAInitState A \<in> States (Root (SAs A) (CompFun A))"
by (fold HARoot_def, simp)

lemma HAInitStates_HAStates [simp]:
  "HAInitStates A \<subseteq> HAStates A"
apply (unfold HAInitStates_def HAStates_def)
apply auto
done

lemma HAInitStates_HAStates2 [simp]:
  "S \<in> HAInitStates A \<Longrightarrow> S \<in> HAStates A"
apply (cut_tac A=A in HAInitStates_HAStates)
apply fast
done

lemma HAInitState_HAStates [simp]:
  "HAInitState A \<in> HAStates A"
apply (unfold HAStates_def)
apply auto
apply (rule_tac x="HARoot A" in bexI)
apply auto
done

lemma HAInitState_HAInitStates [simp]:
  "HAInitState A \<in> HAInitStates A";
by (unfold HAInitStates_def HAInitState_def, auto)

lemma CompFun_HAInitStates_HAStates [simp]:
 "\<lbrakk> S \<in> HAStates A; SA \<in> the (CompFun A S) \<rbrakk> \<Longrightarrow> (InitState SA) \<in> HAInitStates A";
apply (unfold HAInitStates_def)
apply auto
done

lemma CompFun_HAInitState_HAInitStates [simp]:
 "\<lbrakk> SA \<in> the (CompFun A (HAInitState A)) \<rbrakk> \<Longrightarrow> (InitState SA) \<in> HAInitStates A";
apply (unfold HAInitStates_def)
apply auto
apply (rule_tac x=SA in bexI)
apply auto
apply (cut_tac A=A and S="HAInitState A" in HAStates_CompFun_SAs)
apply auto
done

lemma HAInitState_notmem_States [simp]:
  "\<lbrakk> S \<in> HAStates A; SA \<in> the (CompFun A S) \<rbrakk> \<Longrightarrow> HAInitState A \<notin> States SA"
apply (cut_tac HA=A in MutuallyDistinct_HA)
apply (unfold MutuallyDistinct_def)
apply (erule_tac x=SA in ballE)
apply (erule_tac x="HARoot A" in ballE)
apply auto
done

lemma InitState_notmem_States [simp]:
  "\<lbrakk> S \<in> HAStates A; SA \<in> the (CompFun A S);
     T \<in> HAInitStates A; T \<noteq> InitState SA \<rbrakk>
    \<Longrightarrow>  T \<notin> States SA"
apply (unfold HAInitStates_def)
apply auto
apply (rename_tac SAA)
apply (cut_tac HA=A in MutuallyDistinct_HA)
apply (unfold MutuallyDistinct_def)
apply (erule_tac x=SA in ballE)
apply (erule_tac x=SAA in ballE)
apply auto
done

lemma InitState_States_notmem [simp]:
    "\<lbrakk> B \<in> SAs A; C \<in> SAs A; B \<noteq> C \<rbrakk> \<Longrightarrow> InitState B \<notin> States C"
apply auto
apply (cut_tac HA=A in MutuallyDistinct_HA)
apply (unfold MutuallyDistinct_def)
apply force
done

lemma OneHAInitState_SAStates:
   "\<lbrakk> S \<in> HAInitStates A; T \<in> HAInitStates A;
      S \<in> States SA; T \<in> States SA; SA \<in> SAs A \<rbrakk> \<Longrightarrow>
      S = T"
apply (unfold HAInitStates_def)
apply auto
apply (rename_tac AA AAA)
apply (case_tac "AA = SA")
apply auto
apply (case_tac "AAA = SA")
apply auto
done

subsubsection {* @{text "Chi"} *}

lemma HARootStates_notmem_Chi [simp]:
  "\<lbrakk> S \<in> HAStates A;  T \<in> States (HARoot A) \<rbrakk> \<Longrightarrow> T \<notin>  Chi A S"
apply (unfold Chi_def restrict_def, auto)
apply (rename_tac SA)
apply (cut_tac HA="A" in MutuallyDistinct_HA)
apply (unfold MutuallyDistinct_def)
apply (erule_tac x="HARoot A" in ballE)
apply (erule_tac x="SA" in ballE)
apply auto
done

lemma SAStates_notmem_Chi [simp]:
  "\<lbrakk> S \<in> States SA; T \<in> States SA;
     SA \<in> SAs A \<rbrakk> \<Longrightarrow> T \<notin> Chi A S"
apply (unfold Chi_def restrict_def, auto)
apply (rename_tac SAA)
apply (cut_tac HA="A" in MutuallyDistinct_HA)
apply (unfold MutuallyDistinct_def)
apply (erule_tac x="SAA" in ballE)
apply (erule_tac x="SA" in ballE)
apply auto
apply (unfold HAStates_def)
apply auto
done

lemma HAInitState_notmem_Chi [simp]:
  "S \<in> HAStates A \<Longrightarrow> HAInitState A \<notin> Chi A S"
by (unfold Chi_def restrict_def, auto)

lemma Chi_HAStates [simp]:
  "T \<in> HAStates A \<Longrightarrow> (Chi A T) \<subseteq> HAStates A"
apply (unfold Chi_def restrict_def)
apply (auto)
apply (cut_tac A=A and S=T in HAStates_CompFun_SAs)
apply (unfold HAStates_def)
apply auto
done

lemma Chi_HAStates_Self [simp]:
  "s \<in>  HAStates a \<Longrightarrow> s \<notin> (Chi a s)"
by (unfold Chi_def restrict_def, auto)

lemma ChiRel_HAStates_Self [simp]:
  "(s,s) \<notin> (ChiRel a)"
by( unfold ChiRel_def, auto)

lemma HAStates_Chi_NoCycles:
  "\<lbrakk> s \<in> HAStates a; t \<in> HAStates a; s \<in> Chi a t \<rbrakk> \<Longrightarrow> t \<notin> Chi a s";
apply (unfold Chi_def restrict_def)
apply auto
apply (cut_tac HA=a in NoCycles_HA)
apply (unfold NoCycles_def)
apply (erule_tac x="{s,t}" in ballE)
apply auto
done

lemma HAStates_Chi_NoCycles_trans:
 "\<lbrakk> s \<in> HAStates a; t \<in> HAStates a; u \<in> HAStates a;
    t \<in> Chi a s; u \<in> Chi a t \<rbrakk> \<Longrightarrow> s \<notin> Chi a u";
apply (unfold Chi_def restrict_def)
apply auto
apply (cut_tac HA=a in NoCycles_HA)
apply (unfold NoCycles_def)
apply (erule_tac x="{s,t,u}" in ballE)
prefer 2
apply simp
apply (unfold HAStates_def)
apply safe
apply fast+
done

lemma SAStates_Chi_trans [rule_format]:
  "\<lbrakk> U \<in> Chi A T; S \<in> Chi A U; T \<in> States SA;
     SA \<in> SAs A; U \<in> HAStates A \<rbrakk> \<Longrightarrow> S \<notin> States SA"
apply (frule HAStates_SA_mem)
apply auto
apply (unfold Chi_def restrict_def)
apply auto
apply (rename_tac SAA SAAA)
apply (cut_tac HA=A in NoCycles_HA)
apply (unfold NoCycles_def)
apply (erule_tac x="{U,T}" in ballE)
prefer 2
apply (simp only: HAStates_def)
apply auto
apply (cut_tac HA=A in MutuallyDistinct_HA)
apply (unfold MutuallyDistinct_def)
apply (rotate_tac -1)
apply (erule_tac x=SA in ballE)
apply (rotate_tac -1)
apply (erule_tac x=SAAA in ballE)
apply auto
done

subsubsection {* @{text "ChiRel"} *}

lemma finite_ChiRel [simp]:
  "finite (ChiRel A)"
apply (rule_tac B="HAStates A \<times> HAStates A" in finite_subset)
apply auto
done

lemma ChiRel_HAStates_subseteq [simp]:
  "(ChiRel A) \<subseteq> (HAStates A \<times> HAStates A)"
apply (unfold ChiRel_def Chi_def restrict_def)
apply auto
done

lemma ChiRel_CompFun:
  "s \<in> HAStates a \<Longrightarrow> ChiRel a `` {s} = (\<Union> x \<in> the (CompFun a s). States x)"
apply (unfold ChiRel_def Chi_def restrict_def Image_def)
apply simp
apply auto
apply (frule HAStates_CompFun_SAs_mem)
apply fast
apply (unfold HAStates_def)
apply fast
done

lemma ChiRel_HARoot:
 "\<lbrakk> (x,y) \<in> ChiRel A \<rbrakk> \<Longrightarrow> y \<notin> States (HARoot A)"
apply (unfold ChiRel_def Chi_def)
apply auto
apply (unfold restrict_def)
apply auto
apply (rename_tac SA)
apply (frule HAStates_HARoot_CompFun)
apply (cut_tac HA=A in MutuallyDistinct_HA)
apply (unfold MutuallyDistinct_def)
apply auto
apply (erule_tac x=SA in ballE)
apply (erule_tac x="HARoot A" in ballE)
apply auto
done

lemma HAStates_CompFun_States_ChiRel:
 "S \<in> HAStates A \<Longrightarrow> ((UNION (the (CompFun A S)) States) = (ChiRel A `` {S}))"
apply (unfold ChiRel_def Chi_def restrict_def)
apply auto
apply (drule HAStates_CompFun_SAs)
apply (subst HAStates_def)
apply fast
done

lemma HAInitState_notmem_Range_ChiRel [simp]:
  "HAInitState A \<notin> Range (ChiRel A)"
by (unfold ChiRel_def, auto)

lemma HAInitState_notmem_Range_ChiRel2 [simp]:
  "(S,HAInitState A) \<notin>  (ChiRel A)"
by (unfold ChiRel_def, auto)

lemma ChiRel_OneAncestor_notmem:
  "\<lbrakk> S \<noteq> T; (S,U) \<in> ChiRel A\<rbrakk> \<Longrightarrow> (T,U) \<notin> ChiRel A"
apply (unfold ChiRel_def)
apply auto
apply (simp only: Chi_range_disjoint)
done

lemma ChiRel_OneAncestor:
  "\<lbrakk> (S1,U) \<in> ChiRel A; (S2,U) \<in> ChiRel A \<rbrakk> \<Longrightarrow> S1 = S2"
apply (rule notnotD, rule notI)
apply (simp add: ChiRel_OneAncestor_notmem)
done

lemma CompFun_ChiRel:
  "\<lbrakk> S1 \<in> HAStates A; SA \<in> the (CompFun A S1);
     S2 \<in> States SA \<rbrakk> \<Longrightarrow> (S1,S2) \<in> ChiRel A"
apply (unfold ChiRel_def Chi_def restrict_def)
apply auto
apply (cut_tac A=A and S=S1 in HAStates_CompFun_SAs)
apply (unfold HAStates_def)
apply auto
done

lemma CompFun_ChiRel2:
 "\<lbrakk> (S,T) \<in> ChiRel A; T \<in> States SA; SA \<in> SAs A \<rbrakk> \<Longrightarrow> SA \<in> the (CompFun A S)"
apply (unfold ChiRel_def Chi_def restrict_def)
apply auto
apply (rename_tac SAA)
apply (cut_tac HA=A in MutuallyDistinct_HA)
apply (unfold MutuallyDistinct_def)
apply (erule_tac x=SA in ballE)
apply (rotate_tac -1)
apply (erule_tac x=SAA in ballE)
apply auto
done

lemma ChiRel_HAStates_NoCycles:
  "(s,t) \<in> (ChiRel a) \<Longrightarrow> (t,s) \<notin> (ChiRel a)"
apply (unfold ChiRel_def)
apply auto
apply (frule HAStates_Chi_NoCycles)
apply auto
done

lemma HAStates_ChiRel_NoCycles_trans:
  "\<lbrakk> (s,t) \<in> (ChiRel a); (t,u) \<in> (ChiRel a) \<rbrakk> \<Longrightarrow> (u,s) \<notin> (ChiRel a)"
apply (unfold ChiRel_def)
apply auto
apply (frule HAStates_Chi_NoCycles_trans)
apply fast
back
back
prefer 3
apply fast
apply auto
done

lemma SAStates_ChiRel:
  "\<lbrakk> S \<in> States SA; T \<in> States SA;
     SA \<in> SAs A \<rbrakk> \<Longrightarrow> (S,T) \<notin> (ChiRel A)"
by (unfold ChiRel_def, auto)

lemma ChiRel_SA_OneAncestor:
   "\<lbrakk> (S,T) \<in> ChiRel A; T \<in> States SA;
      U \<in> States SA; SA \<in> SAs A \<rbrakk> \<Longrightarrow>
      (S,U) \<in> ChiRel A"
apply (frule CompFun_ChiRel2)
apply auto
apply (rule CompFun_ChiRel)
apply auto
done

lemma ChiRel_OneAncestor2:
  "\<lbrakk> S \<in> HAStates A; S \<notin> States (HARoot A) \<rbrakk> \<Longrightarrow>
     \<exists>! T. (T,S) \<in> ChiRel A"
apply (unfold ChiRel_def)
apply auto
prefer 2
apply (rename_tac T U)
prefer 2
apply (unfold Chi_def restrict_def)
apply auto
prefer 2
apply (rename_tac SA SAA)
prefer 2
apply (cut_tac HA=A in OneAncestor_HA)
apply (unfold OneAncestor_def)
apply (fold HARoot_def)
apply auto
apply (simp cong: rev_conj_cong)
apply (unfold HAStates_def)
apply auto
apply (rename_tac SA)
apply (erule_tac x=SA in ballE)
apply auto
apply (case_tac "T = U")
apply auto
apply (frule CompFun_Int_disjoint)
apply (unfold HAStates_def)
apply auto
apply (case_tac "SA=SAA")
apply auto
apply (cut_tac HA=A in MutuallyDistinct_HA)
apply (unfold MutuallyDistinct_def)
apply (erule_tac x=SAA in ballE)
apply (erule_tac x=SA in ballE)
apply auto
apply (cut_tac S=T and A=A in HAStates_CompFun_SAs)
apply (unfold HAStates_def)
apply fast
apply fast
apply (cut_tac S=U and A=A in HAStates_CompFun_SAs)
apply (unfold HAStates_def)
apply fast
apply fast
done

lemma HARootStates_notmem_Range_ChiRel [simp]:
  "S \<in> States (HARoot A) \<Longrightarrow> S \<notin> Range (ChiRel A)"
by (unfold ChiRel_def, auto)

lemma ChiRel_int_disjoint:
  "S \<noteq> T \<Longrightarrow> (ChiRel A `` {S}) \<inter> (ChiRel A `` {T}) = {}"
apply (unfold ChiRel_def)
apply auto
apply (simp only: Chi_range_disjoint)
done

lemma SAStates_ChiRel_trans [rule_format]:
  "\<lbrakk> (S,U) \<in> (ChiRel A); (U,T) \<in> ChiRel A;
     S \<in> States SA; SA \<in> SAs A  \<rbrakk> \<Longrightarrow> T \<notin> States SA"
apply auto
apply (unfold ChiRel_def)
apply auto
apply (frule SAStates_Chi_trans)
back
apply fast+
done

lemma HAInitStates_InitState_trancl:
  " \<lbrakk> S \<in> HAInitStates (HA ST); A \<in> the (CompFun (HA ST) S) \<rbrakk> \<Longrightarrow>
       (S, InitState A) \<in> (ChiRel (HA ST) \<inter> HAInitStates (HA ST) \<times> HAInitStates (HA ST))\<^sup>+"
apply (case_tac "S \<in> HAStates (HA ST)")
apply (frule CompFun_ChiRel)
apply fast+
apply (rule InitState_States)
apply auto
apply (rule r_into_trancl')
apply auto
apply (rule CompFun_HAInitStates_HAStates)
apply auto
done

lemma HAInitStates_InitState_trancl2:
 "\<lbrakk> S \<in> HAStates (HA ST); A \<in> the (CompFun (HA ST) S);
   (x, S) \<in> (ChiRel (HA ST) \<inter> HAInitStates (HA ST) \<times> HAInitStates (HA ST))\<^sup>+ \<rbrakk>
  \<Longrightarrow> (x, InitState A) \<in> (ChiRel (HA ST) \<inter> HAInitStates (HA ST) \<times> HAInitStates (HA ST))\<^sup>+"
apply (rule_tac a="x" and b="S" and r="ChiRel (HA ST) \<inter> HAInitStates (HA ST) \<times> HAInitStates (HA ST)" in converse_trancl_induct)
apply auto
prefer 2
apply (rename_tac T U)
prefer 2
apply (case_tac "S \<in> HAStates (HA ST)")
apply (frule CompFun_ChiRel)
apply fast
apply (rule InitState_States)
apply simp
apply (rule trancl_trans [of _ S])
apply (rule r_into_trancl')
apply auto
apply (rule r_into_trancl')
apply auto
apply (rule CompFun_HAInitStates_HAStates)
prefer 2
apply fast
apply (cut_tac A="HA ST" in HAInitStates_HAStates, fast)
apply (rule_tac y = U in trancl_trans)
apply (rule r_into_trancl')
apply auto
done

subsubsection {* @{text "ChiPlus"} *}

lemma ChiPlus_ChiRel [simp]:
  "(S,T) \<in> ChiRel A \<Longrightarrow> (S,T) \<in> ChiPlus A"
apply (unfold ChiPlus_def)
apply (frule r_into_trancl)
apply auto
done

lemma ChiPlus_HAStates [simp]:
  "(ChiPlus A) \<subseteq> (HAStates A \<times> HAStates A)"
apply (unfold ChiPlus_def)
apply (rule trancl_subset_Sigma)
apply auto
done

lemma ChiPlus_subset_States:
  "ChiPlus a `` {t} \<subseteq>  UNION (SAs a) States"
apply (cut_tac A=a in ChiPlus_HAStates)
apply (unfold HAStates_def)
apply fast
done

lemma finite_ChiPlus [simp]:
  "finite (ChiPlus A)"
apply (rule_tac B="HAStates A \<times> HAStates A" in finite_subset)
apply auto
done

lemma ChiPlus_OneAncestor:
  "\<lbrakk> S \<in> HAStates A; S \<notin> States (HARoot A) \<rbrakk> \<Longrightarrow>
     \<exists> T. (T,S) \<in> ChiPlus A"
apply (unfold ChiPlus_def)
apply (frule ChiRel_OneAncestor2)
apply auto
done

lemma ChiPlus_HAStates_Left:
 "(S,T) \<in> ChiPlus A \<Longrightarrow> S \<in> HAStates A"
apply (cut_tac A=A in ChiPlus_HAStates)
apply (unfold HAStates_def)
apply auto
done

lemma ChiPlus_HAStates_Right:
 "(S,T) \<in> ChiPlus A \<Longrightarrow> T \<in>  HAStates A"
apply (cut_tac A=A in ChiPlus_HAStates)
apply (unfold HAStates_def)
apply auto
done

lemma ChiPlus_ChiRel_int [rule_format]:
  "\<lbrakk> (T,S) \<in> (ChiPlus A)\<rbrakk> \<Longrightarrow> (ChiPlus A `` {T}) \<inter> (ChiRel A `` {S}) = (ChiRel A `` {S})"
apply (unfold ChiPlus_def)
apply (rule_tac a="T" and b="S" and r="(ChiRel A)" in converse_trancl_induct)
apply auto
done

lemma ChiPlus_ChiPlus_int [rule_format]:
  "\<lbrakk> (T,S) \<in> (ChiPlus A)\<rbrakk> \<Longrightarrow> (ChiPlus A `` {T}) \<inter> (ChiPlus A `` {S}) = (ChiPlus A `` {S})"
apply (unfold ChiPlus_def)
apply (rule_tac a="T" and b="S" and r="(ChiRel A)" in converse_trancl_induct)
apply auto
done

lemma ChiPlus_ChiRel_NoCycle_2 [rule_format]:
 "\<lbrakk> (T,S) \<in> ChiPlus A\<rbrakk> \<Longrightarrow>  (S,T) \<in> (ChiRel A) \<longrightarrow>
   (insert S (insert T ({U. (T,U) \<in> ChiPlus A \<and> (U,S) \<in> ChiPlus A})))  \<inter> (ChiRel A `` {S}) \<noteq> {}"
apply (unfold ChiPlus_def)
apply (rule_tac a="T" and b="S" and r="(ChiRel A)" in converse_trancl_induct)
apply (unfold Image_def Int_def)
apply auto
done

lemma ChiPlus_ChiRel_NoCycle_3 [rule_format]:
 "\<lbrakk> (T,S) \<in> ChiPlus A\<rbrakk> \<Longrightarrow>  (S,T) \<in> (ChiRel A) \<longrightarrow> (T,U) \<in>  ChiPlus A \<longrightarrow> (U, S) \<in> ChiPlus A \<longrightarrow>
   (insert S (insert T ({U. (T,U) \<in> ChiPlus A \<and> (U,S) \<in> ChiPlus A})))  \<inter> (ChiRel A `` {U}) \<noteq> {}"
apply (unfold ChiPlus_def)
apply (rule_tac a="T" and b="S" and r="(ChiRel A)" in trancl_induct)
apply (unfold Image_def Int_def, simp)
apply (rename_tac V)
prefer 2
apply (rename_tac V W)
prefer 2
apply (simp, safe)
apply (simp only: ChiRel_HAStates_NoCycles)
apply simp
apply (case_tac "(U,W) \<in> (ChiRel A)", fast, rotate_tac 5, frule tranclD3, fast, blast intro: trancl_into_trancl)+
done

lemma ChiPlus_ChiRel_NoCycle_4 [rule_format]:
 "\<lbrakk> (T,S) \<in> ChiPlus A \<rbrakk> \<Longrightarrow> (S,T) \<in>  (ChiRel A) \<longrightarrow> ((ChiPlus A ``{T}) \<inter> (ChiRel A `` {S})) \<noteq> {}"
apply (unfold ChiPlus_def)
apply (rule_tac a="T" and b="S" and r="(ChiRel A)" in trancl_induct)
apply (unfold Image_def Int_def)
apply auto
apply (simp only: ChiRel_HAStates_NoCycles)
apply (rule_tac x=T in exI)
apply simp
apply (rule_tac x=T in exI)
apply simp
done

lemma ChiRel_ChiPlus_NoCycles:
 "(S,T) \<in> (ChiRel A) \<Longrightarrow> (T,S) \<notin> (ChiPlus A)"
apply (cut_tac HA=A in NoCycles_HA)
apply (unfold NoCycles_def)
apply (erule_tac x="insert S (insert T ({U. (T,U) \<in> ChiPlus A \<and> (U,S) \<in> ChiPlus A}))" in ballE)
prefer 2
apply (simp add: ChiPlus_subset_States)
apply (cut_tac A=A in ChiPlus_HAStates)
apply (unfold HAStates_def)
apply fast
apply safe
apply fast
apply (frule ChiPlus_ChiRel_NoCycle_2)
apply fast
apply (simp add:ChiRel_CompFun)
apply (frule ChiPlus_ChiRel_NoCycle_1)
apply (simp add:ChiRel_CompFun)
apply (frule ChiPlus_ChiRel_NoCycle_3)
apply fast
apply fast
back
apply fast
apply (rename_tac V)
apply (case_tac "V \<in> HAStates A")
apply (simp add: ChiRel_CompFun)
apply (simp only: ChiPlus_HAStates_Right)
apply fast
done

lemma ChiPlus_ChiPlus_NoCycles:
 "(S,T) \<in> (ChiPlus A) \<Longrightarrow> (T,S) \<notin> (ChiPlus A)"
apply (unfold ChiPlus_def)
apply (rule_tac a="S" and b="T" and r="(ChiRel A)" in trancl_induct)
apply fast
apply (frule ChiRel_ChiPlus_NoCycles)
apply (auto intro: trancl_into_trancl2 simp add:ChiPlus_def)
done

lemma ChiPlus_NoCycles [rule_format]:
 "(S,T) \<in> (ChiPlus A) \<Longrightarrow> S \<noteq> T"
apply (frule ChiPlus_ChiPlus_NoCycles)
apply auto
done

lemma ChiPlus_NoCycles_2 [simp]:
 "(S,S) \<notin> (ChiPlus A)"
apply (rule notI)
apply (frule ChiPlus_NoCycles)
apply fast
done

lemma ChiPlus_ChiPlus_NoCycles_2:
  "\<lbrakk> (S,U) \<in> ChiPlus A; (U,T) \<in> ChiPlus A \<rbrakk> \<Longrightarrow> (T,S) \<notin>  ChiPlus A"
apply (rule ChiPlus_ChiPlus_NoCycles)
apply (auto intro: trancl_trans simp add: ChiPlus_def)
done

lemma ChiRel_ChiPlus_trans:
   "\<lbrakk> (U,S) \<in> ChiPlus A; (S,T) \<in> ChiRel A\<rbrakk> \<Longrightarrow> (U,T) \<in> ChiPlus A"
apply (unfold ChiPlus_def)
apply auto
done

lemma ChiRel_ChiPlus_trans2:
   "\<lbrakk> (U,S) \<in> ChiRel A; (S,T) \<in> ChiPlus A \<rbrakk> \<Longrightarrow> (U,T) \<in> ChiPlus A"
apply (unfold ChiPlus_def)
apply auto
done

lemma ChiPlus_ChiRel_Ex [rule_format]:
  "\<lbrakk> (S,T) \<in> ChiPlus A \<rbrakk> \<Longrightarrow> (S,T) \<notin> ChiRel A \<longrightarrow>
    (\<exists> U. (S,U) \<in> ChiPlus A \<and> (U,T) \<in> ChiRel A)"
apply (unfold ChiPlus_def)
apply (rule_tac a="S" and b="T" and r="(ChiRel A)" in converse_trancl_induct)
apply auto
apply (rename_tac U)
apply (rule_tac x=U in exI)
apply auto
done

lemma ChiPlus_ChiRel_Ex2 [rule_format]:
  "\<lbrakk> (S,T) \<in> ChiPlus A \<rbrakk> \<Longrightarrow> (S,T) \<notin> ChiRel A \<longrightarrow>
    (\<exists> U. (S,U) \<in> ChiRel A \<and> (U,T) \<in> ChiPlus A)"
apply (unfold ChiPlus_def)
apply (rule_tac a="S" and b="T" and r="(ChiRel A)" in converse_trancl_induct)
apply auto
done

lemma HARootStates_Range_ChiPlus [simp]:
  "\<lbrakk> S \<in> States (HARoot A) \<rbrakk> \<Longrightarrow> S \<notin> Range (ChiPlus A)"
by (unfold ChiPlus_def, auto)

lemma SAStates_ChiPlus_ChiRel_NoCycle_2 [rule_format]:
 "\<lbrakk> (S,U) \<in>  ChiPlus A \<rbrakk> \<Longrightarrow>  (U,T) \<in> (ChiRel A) \<longrightarrow>
   (insert S (insert U ({V. (S,V) \<in> ChiPlus A \<and> (V,U) \<in> ChiPlus A})))  \<inter> (ChiRel A `` {S}) \<noteq> {}"
apply (unfold ChiPlus_def)
apply (rule_tac a="S" and b="U" and r="(ChiRel A)" in converse_trancl_induct)
apply (unfold Image_def Int_def)
apply auto
done

(* TO DO *)

lemma SAStates_ChiPlus_ChiRel_NoCycle_3 [rule_format]:
 "\<lbrakk> (S,U) \<in>  ChiPlus A \<rbrakk> \<Longrightarrow>  (U,T) \<in> (ChiRel A) \<longrightarrow> (S,s) \<in> ChiPlus A \<longrightarrow> (s,U) \<in> ChiPlus A \<longrightarrow>
   (insert S (insert U ({V. (S,V) \<in> ChiPlus A \<and> (V,U) \<in> ChiPlus A})))  \<inter> (ChiRel A `` {s}) \<noteq> {}"
apply (unfold ChiPlus_def)
apply (rule_tac a="S" and b="U" and r="(ChiRel A)" in trancl_induct)
apply fast
apply (rename_tac W)
prefer 2
apply (rename_tac W X)
prefer 2
apply (unfold Image_def Int_def)
apply (simp, safe)
apply (fold ChiPlus_def)
apply (case_tac "(s,W) \<in> ChiRel A")
apply fast
apply (frule_tac S=s and T=W in ChiPlus_ChiRel_Ex2)
apply simp
apply safe
apply (rename_tac X)
apply (rule_tac x=X in exI)
apply (fast intro: ChiRel_ChiPlus_trans)
apply simp
apply (case_tac "(s,X) \<in> ChiRel A")
apply force
apply (frule_tac S=s and T=X in ChiPlus_ChiRel_Ex2)
apply simp
apply safe
apply (rename_tac Y)
apply (erule_tac x=Y in allE)
apply simp
apply (fast intro: ChiRel_ChiPlus_trans)
apply simp
apply (case_tac "(s,X) \<in> ChiRel A")
apply force
apply (frule_tac S=s and T=X in ChiPlus_ChiRel_Ex2)
apply simp
apply safe
apply (rename_tac Y)
apply (erule_tac x=Y in allE)
apply simp
apply (fast intro: ChiRel_ChiPlus_trans)
apply fastforce
apply simp
apply (erule_tac x=W in allE)
apply simp
apply simp
apply (rename_tac Y)
apply (erule_tac x=Y in allE)
apply simp
apply (fast intro: ChiRel_ChiPlus_trans)
done

lemma SAStates_ChiPlus2 [rule_format]:
  "\<lbrakk> (S,T) \<in> ChiPlus A; SA \<in> SAs A  \<rbrakk> \<Longrightarrow> S \<in> States SA \<longrightarrow> T \<notin> States SA"
apply (unfold ChiPlus_def)
apply (rule_tac a="S" and b="T" and r="(ChiRel A)" in trancl_induct)
apply auto
apply (rename_tac U)
apply (frule_tac S=S and T=U in SAStates_ChiRel)
apply auto
apply (fold ChiPlus_def)
apply (simp only: SAStates_ChiPlus_ChiRel_trans)
done

lemma SAStates_ChiPlus [rule_format]:
 "\<lbrakk> S \<in> States SA; T \<in> States SA; SA \<in> SAs A \<rbrakk> \<Longrightarrow> (S,T) \<notin> ChiPlus A"
apply auto
apply (simp only: SAStates_ChiPlus2)
done

lemma SAStates_ChiPlus_ChiRel_OneAncestor [rule_format]:
  "\<lbrakk> T \<in> States SA; SA \<in> SAs A; (S,U) \<in> ChiPlus A\<rbrakk> \<Longrightarrow>  S \<noteq> T \<longrightarrow> S \<in> States SA \<longrightarrow> (T,U) \<notin> ChiRel A"
apply (unfold ChiPlus_def)
apply (rule_tac a="S" and b="U" and r="(ChiRel A)" in trancl_induct)
apply auto
apply (simp add: ChiRel_OneAncestor_notmem)
apply (rename_tac V W)
apply (fold ChiPlus_def)
apply (case_tac "V=T")
apply (simp add: ChiRel_OneAncestor_notmem SAStates_ChiPlus)+
done

lemma SAStates_ChiPlus_OneAncestor [rule_format]:
  "\<lbrakk> T \<in> States SA; SA \<in> SAs A; (S,U) \<in> ChiPlus A \<rbrakk> \<Longrightarrow>  S \<noteq> T \<longrightarrow>
     S \<in> States SA \<longrightarrow> (T,U) \<notin> ChiPlus A"
apply (unfold ChiPlus_def)
apply (rule_tac a="S" and b="U" and r="(ChiRel A)" in trancl_induct)
apply auto
apply (fold ChiPlus_def)
apply (rename_tac V)
apply (frule_tac T=S and S=T and U=V in SAStates_ChiPlus_ChiRel_OneAncestor)
apply auto
apply (rename_tac V W)
apply (frule_tac S=T and T=W in ChiPlus_ChiRel_Ex)
apply auto
apply (frule_tac T=T and S=S and U=W in SAStates_ChiPlus_ChiRel_OneAncestor)
apply auto
apply (rule ChiRel_ChiPlus_trans)
apply auto
apply (rename_tac X)
apply (case_tac "V=X")
apply simp
apply (simp add: ChiRel_OneAncestor_notmem)
done

lemma ChiRel_ChiPlus_OneAncestor [rule_format]:
  "\<lbrakk> (T,U) \<in> ChiPlus A \<rbrakk> \<Longrightarrow> T \<noteq> S \<longrightarrow> (S,U) \<in> ChiRel A \<longrightarrow> (T,S) \<in> ChiPlus A"
apply (unfold ChiPlus_def)
apply (rule_tac a="T" and b="U" and r="(ChiRel A)" in trancl_induct)
apply auto
apply (fast intro:ChiRel_OneAncestor)
apply (rename_tac V W)
apply (case_tac "S=V")
apply auto
apply (fast intro:ChiRel_OneAncestor)
done

lemma ChiPlus_SA_OneAncestor [rule_format]:
   "\<lbrakk> (S,T) \<in> ChiPlus A;
      U \<in> States SA; SA \<in> SAs A \<rbrakk> \<Longrightarrow> T \<in> States SA \<longrightarrow>
      (S,U) \<in> ChiPlus A"
apply (unfold ChiPlus_def)
apply (rule_tac a="S" and b="T" and r="(ChiRel A)" in converse_trancl_induct)
apply auto
apply (frule ChiRel_SA_OneAncestor)
apply fast+
done

subsubsection {* @{text "ChiStar"} *}

lemma ChiPlus_ChiStar [simp]:
  "\<lbrakk> (S,T) \<in> ChiPlus A  \<rbrakk> \<Longrightarrow> (S,T) \<in> ChiStar A"
by (unfold ChiPlus_def ChiStar_def, auto)

lemma HARootState_Range_ChiStar [simp]:
  "\<lbrakk> x \<noteq> S; S \<in> States (HARoot A) \<rbrakk> \<Longrightarrow> (x,S) \<notin> (ChiStar A)"
apply (unfold ChiStar_def)
apply (subst rtrancl_eq_or_trancl)
apply (fold ChiPlus_def)
apply auto
done

lemma ChiStar_Self [simp]:
 "(S,S) \<in> ChiStar A"
apply (unfold ChiStar_def)
apply simp
done

lemma ChiStar_Image [simp]:
  "S \<in> M \<Longrightarrow> S \<in> (ChiStar A `` M)"
apply (unfold Image_def)
apply (auto intro: ChiStar_Self)
done

lemma ChiStar_ChiPlus_noteq:
  "\<lbrakk> S \<noteq> T; (S,T) \<in> ChiStar A \<rbrakk> \<Longrightarrow> (S,T) \<in> ChiPlus A"
apply (unfold ChiPlus_def ChiStar_def)
apply (simp add: rtrancl_eq_or_trancl)
done

lemma ChiRel_ChiStar_trans:
  "\<lbrakk> (S,U) \<in> ChiStar A; (U,T) \<in> ChiRel A \<rbrakk> \<Longrightarrow> (S,T) \<in> ChiStar A"
apply (unfold ChiStar_def)
apply auto
done

subsubsection {* @{text "InitConf"} *}

lemma InitConf_HAStates [simp]:
  "InitConf A \<subseteq> HAStates A"
apply (unfold InitConf_def HAStates_def)
apply auto
apply (rule rtrancl_induct)
back
apply auto
apply (rule_tac x="HARoot A" in bexI)
apply auto
apply (unfold HAStates_def ChiRel_def)
apply auto
done

lemma InitConf_HAStates2 [simp]:
 "S \<in> InitConf A \<Longrightarrow> S \<in> HAStates A"
apply (cut_tac A=A in InitConf_HAStates)
apply fast
done

lemma HAInitState_InitConf [simp]:
  "HAInitState A \<in> InitConf A"
by (unfold HAInitState_def InitConf_def, auto)

lemma InitConf_HAInitState_HARoot:
 "[| S \<in> InitConf A; S \<noteq> HAInitState A |] ==> S \<notin> States (HARoot A)"
apply (unfold InitConf_def)
apply auto
apply (rule mp)
prefer 2
apply fast
back
apply (rule mp)
prefer 2
apply fast
back
back
apply (rule_tac b=S in rtrancl_induct)
apply auto
apply (simp add: ChiRel_HARoot)+
done

lemma InitConf_HARoot_HAInitState [simp]:
 "\<lbrakk> S \<in> InitConf A; S \<in> States (HARoot A) \<rbrakk> \<Longrightarrow> S = HAInitState A"
apply (subst not_not [THEN sym])
apply (rule notI)
apply (simp add:InitConf_HAInitState_HARoot)
done

lemma HAInitState_CompFun_InitConf [simp]:
 "[|SA \<in> the (CompFun A  (HAInitState A)) |] ==> (InitState SA) \<in> InitConf A";
apply (unfold InitConf_def HAStates_def)
apply auto
apply (rule rtrancl_Int)
apply auto
apply (cut_tac A=A and S="HAInitState A" in HAStates_CompFun_States_ChiRel)
apply auto
apply (rule Image_singleton_iff [THEN subst])
apply (rotate_tac -1)
apply (drule sym)
apply simp
apply (rule_tac x=SA in bexI)
apply auto
done

lemma InitConf_HAInitStates:
  "InitConf A \<subseteq> HAInitStates A"
apply (unfold InitConf_def)
apply (rule subsetI)
apply auto
apply (frule rtrancl_Int1)
apply (case_tac "x = HAInitState A")
apply simp
apply (rule rtrancl_mem_Sigma)
apply auto
done

lemma InitState_notmem_InitConf:
 "[| SA \<in> the (CompFun A S); S \<in> InitConf A; T \<in> States SA;
     T \<noteq> InitState SA |] ==>  T \<notin> InitConf A"
apply (frule InitConf_HAStates2)
apply (unfold InitConf_def)
apply auto
apply (rule mp)
prefer 2
apply fast
apply (rule mp)
prefer 2
apply fast
back
apply (rule mp)
prefer 2
apply fast
back
back
apply (rule mp)
prefer 2
apply fast
back
back
back
apply (rule mp)
prefer 2
apply fast
back
back
back
back
apply (rule mp)
prefer 2
apply fast
back
back
back
back
back
apply (rule_tac b=T in rtrancl_induct)
apply auto
done

lemma InitConf_CompFun_InitState [simp]:
 "\<lbrakk> SA \<in> the (CompFun A S); S \<in> InitConf A; T \<in> States SA;
    T \<in> InitConf A \<rbrakk> \<Longrightarrow> T = InitState SA"
apply (subst not_not [THEN sym])
apply (rule notI)
apply (frule InitState_notmem_InitConf)
apply auto
done

lemma InitConf_ChiRel_Ancestor:
  "\<lbrakk> T \<in> InitConf A; (S,T) \<in> ChiRel A \<rbrakk> \<Longrightarrow> S \<in> InitConf A"
apply (unfold InitConf_def)
apply auto
apply (erule rtranclE)
apply auto
apply (rename_tac U)
apply (cut_tac A=A  in HAInitState_notmem_Range_ChiRel)
apply auto
apply (case_tac "U = S")
apply (auto simp add: ChiRel_OneAncestor)
done

lemma InitConf_CompFun_Ancestor:
  "\<lbrakk> S \<in> HAStates A; SA \<in> the (CompFun A S); T \<in> InitConf A; T \<in> States SA \<rbrakk>
    \<Longrightarrow>  S \<in> InitConf A"
apply (rule InitConf_ChiRel_Ancestor)
apply auto
apply (rule CompFun_ChiRel)
apply auto
done

subsubsection {* @{text "StepConf"} *}

lemma StepConf_EmptySet [simp]:
  "StepConf A C {} = C"
by (unfold StepConf_def, auto)

end


(* 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_sort_nat_QSortCount
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) z = z"
| "plus (S z2) z = S (plus z2 z)"

fun lt :: "Nat => Nat => bool" where
  "lt y (Z) = False"
| "lt (Z) (S z2) = True"
| "lt (S n) (S z2) = lt n z2"

fun le :: "Nat => Nat => bool" where
  "le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun gt :: "Nat => Nat => bool" where
  "gt y z = lt z y"

fun filter :: "('a => bool) => 'a list => 'a list" where
  "filter q (nil2) = nil2"
| "filter q (cons2 z xs) =
     (if q z then cons2 z (filter q xs) else filter q xs)"

(*fun did not finish the proof*)
function qsort :: "Nat list => Nat list" where
  "qsort (nil2) = nil2"
| "qsort (cons2 z xs) =
     x (qsort (filter (% (z2 :: Nat) => le z2 z) xs))
       (x (cons2 z (nil2))
          (qsort (filter (% (x2 :: Nat) => gt x2 z) xs)))"
  by pat_completeness auto

fun count :: "'a => 'a list => Nat" where
  "count y (nil2) = Z"
| "count y (cons2 z2 ys) =
     (if (y = z2) then plus (S Z) (count y ys) else count y ys)"

theorem property0 :
  "((count y (qsort xs)) = (count y xs))"
  oops

end


(*  Title:      HOL/Hoare/Heap.thy
    Author:     Tobias Nipkow
    Copyright   2002 TUM

Pointers, heaps and heap abstractions.
See the paper by Mehta and Nipkow.
*)

theory Heap imports Main begin

subsection "References"

datatype 'a ref = Null | Ref 'a

lemma not_Null_eq [iff]: "(x ~= Null) = (EX y. x = Ref y)"
  by (induct x) auto

lemma not_Ref_eq [iff]: "(ALL y. x ~= Ref y) = (x = Null)"
  by (induct x) auto

primrec addr :: "'a ref \<Rightarrow> 'a" where
  "addr (Ref a) = a"

section "The heap"

subsection "Paths in the heap"

primrec Path :: "('a \<Rightarrow> 'a ref) \<Rightarrow> 'a ref \<Rightarrow> 'a list \<Rightarrow> 'a ref \<Rightarrow> bool" where
  "Path h x [] y \<longleftrightarrow> x = y"
| "Path h x (a#as) y \<longleftrightarrow> x = Ref a \<and> Path h (h a) as y"

lemma [simp]: "\<And>x. Path f x (as@bs) z = (\<exists>y. Path f x as y \<and> Path f y bs z)"
by(induct as, simp+)

lemma Path_upd[simp]:
 "\<And>x. u \<notin> set as \<Longrightarrow> Path (f(u := v)) x as y = Path f x as y"
by(induct as, simp, simp add:eq_sym_conv)

lemma Path_snoc:
 "Path (f(a := q)) p as (Ref a) \<Longrightarrow> Path (f(a := q)) p (as @ [a]) q"
by simp

subsection "Non-repeating paths"

definition distPath :: "('a \<Rightarrow> 'a ref) \<Rightarrow> 'a ref \<Rightarrow> 'a list \<Rightarrow> 'a ref \<Rightarrow> bool"
  where "distPath h x as y \<longleftrightarrow> Path h x as y \<and> distinct as"

text\<open>The term @{term"distPath h x as y"} expresses the fact that a
non-repeating path @{term as} connects location @{term x} to location
@{term y} by means of the @{term h} field. In the case where \<open>x
= y\<close>, and there is a cycle from @{term x} to itself, @{term as} can
be both @{term "[]"} and the non-repeating list of nodes in the
cycle.\<close>

lemma neq_dP: "p \<noteq> q \<Longrightarrow> Path h p Ps q \<Longrightarrow> distinct Ps \<Longrightarrow>
 EX a Qs. p = Ref a & Ps = a#Qs & a \<notin> set Qs"
by (case_tac Ps, auto)

lemma neq_dP_disp: "\<lbrakk> p \<noteq> q; distPath h p Ps q \<rbrakk> \<Longrightarrow>
 EX a Qs. p = Ref a \<and> Ps = a#Qs \<and> a \<notin> set Qs"
apply (simp only:distPath_def)
by (case_tac Ps, auto)

subsection "Lists on the heap"

subsubsection "Relational abstraction"

definition List :: "('a \<Rightarrow> 'a ref) \<Rightarrow> 'a ref \<Rightarrow> 'a list \<Rightarrow> bool"
  where "List h x as = Path h x as Null"

lemma [simp]: "List h x [] = (x = Null)"
by(simp add:List_def)

lemma [simp]: "List h x (a#as) = (x = Ref a \<and> List h (h a) as)"
by(simp add:List_def)

lemma [simp]: "List h Null as = (as = [])"
by(case_tac as, simp_all)

lemma List_Ref[simp]: "List h (Ref a) as = (\<exists>bs. as = a#bs \<and> List h (h a) bs)"
by(case_tac as, simp_all, fast)

lemma List_unique: "\<And>x bs. List h x as \<Longrightarrow> List h x bs \<Longrightarrow> as = bs"
by(induct as, simp, clarsimp)

lemma List_unique1: "List h p as \<Longrightarrow> \<exists>!as. List h p as"
by(blast intro:List_unique)

lemma List_app: "\<And>x. List h x (as@bs) = (\<exists>y. Path h x as y \<and> List h y bs)"
by(induct as, simp, clarsimp)

lemma List_hd_not_in_tl[simp]: "List h (h a) as \<Longrightarrow> a \<notin> set as"
apply (clarsimp simp add:in_set_conv_decomp)
apply(frule List_app[THEN iffD1])
apply(fastforce dest: List_unique)
done

lemma List_distinct[simp]: "\<And>x. List h x as \<Longrightarrow> distinct as"
apply(induct as, simp)
apply(fastforce dest:List_hd_not_in_tl)
done

lemma Path_is_List:
  "\<lbrakk>Path h b Ps (Ref a); a \<notin> set Ps\<rbrakk> \<Longrightarrow> List (h(a := Null)) b (Ps @ [a])"
apply (induct Ps arbitrary: b)
apply (auto simp add:fun_upd_apply)
done

subsection "Functional abstraction"

definition islist :: "('a \<Rightarrow> 'a ref) \<Rightarrow> 'a ref \<Rightarrow> bool"
  where "islist h p \<longleftrightarrow> (\<exists>as. List h p as)"

definition list :: "('a \<Rightarrow> 'a ref) \<Rightarrow> 'a ref \<Rightarrow> 'a list"
  where "list h p = (SOME as. List h p as)"

lemma List_conv_islist_list: "List h p as = (islist h p \<and> as = list h p)"
apply(simp add:islist_def list_def)
apply(rule iffI)
apply(rule conjI)
apply blast
apply(subst some1_equality)
  apply(erule List_unique1)
 apply assumption
apply(rule refl)
apply simp
apply(rule someI_ex)
apply fast
done

lemma [simp]: "islist h Null"
by(simp add:islist_def)

lemma [simp]: "islist h (Ref a) = islist h (h a)"
by(simp add:islist_def)

lemma [simp]: "list h Null = []"
by(simp add:list_def)

lemma list_Ref_conv[simp]:
 "islist h (h a) \<Longrightarrow> list h (Ref a) = a # list h (h a)"
apply(insert List_Ref[of h])
apply(fastforce simp:List_conv_islist_list)
done

lemma [simp]: "islist h (h a) \<Longrightarrow> a \<notin> set(list h (h a))"
apply(insert List_hd_not_in_tl[of h])
apply(simp add:List_conv_islist_list)
done

lemma list_upd_conv[simp]:
 "islist h p \<Longrightarrow> y \<notin> set(list h p) \<Longrightarrow> list (h(y := q)) p = list h p"
apply(drule notin_List_update[of _ _ h q p])
apply(simp add:List_conv_islist_list)
done

lemma islist_upd[simp]:
 "islist h p \<Longrightarrow> y \<notin> set(list h p) \<Longrightarrow> islist (h(y := q)) p"
apply(frule notin_List_update[of _ _ h q p])
apply(simp add:List_conv_islist_list)
done

end


(*  Title:      HOL/Groebner_Basis.thy
    Author:     Amine Chaieb, TU Muenchen
*)

section \<open>Groebner bases\<close>

theory Groebner_Basis
imports Semiring_Normalization Parity
begin

subsection \<open>Groebner Bases\<close>

lemmas bool_simps = simp_thms(1-34) \<comment> \<open>FIXME move to \<^theory>\<open>HOL.HOL\<close>\<close>

lemma nnf_simps: \<comment> \<open>FIXME shadows fact binding in \<^theory>\<open>HOL.HOL\<close>\<close>
  "(\<not>(P \<and> Q)) = (\<not>P \<or> \<not>Q)" "(\<not>(P \<or> Q)) = (\<not>P \<and> \<not>Q)"
  "(P \<longrightarrow> Q) = (\<not>P \<or> Q)"
  "(P = Q) = ((P \<and> Q) \<or> (\<not>P \<and> \<not> Q))" "(\<not> \<not>(P)) = P"
  by blast+

lemma dnf:
  "(P \<and> (Q \<or> R)) = ((P\<and>Q) \<or> (P\<and>R))"
  "((Q \<or> R) \<and> P) = ((Q\<and>P) \<or> (R\<and>P))"
  "(P \<and> Q) = (Q \<and> P)"
  "(P \<or> Q) = (Q \<or> P)"
  by blast+

lemmas weak_dnf_simps = dnf bool_simps

lemma PFalse:
    "P \<equiv> False \<Longrightarrow> \<not> P"
    "\<not> P \<Longrightarrow> (P \<equiv> False)"
  by auto

named_theorems algebra "pre-simplification rules for algebraic methods"
ML_file \<open>Tools/groebner.ML\<close>

method_setup algebra = \<open>
  let
    fun keyword k = Scan.lift (Args.$$$ k -- Args.colon) >> K ()
    val addN = "add"
    val delN = "del"
    val any_keyword = keyword addN || keyword delN
    val thms = Scan.repeats (Scan.unless any_keyword Attrib.multi_thm);
  in
    Scan.optional (keyword addN |-- thms) [] --
     Scan.optional (keyword delN |-- thms) [] >>
    (fn (add_ths, del_ths) => fn ctxt =>
      SIMPLE_METHOD' (Groebner.algebra_tac add_ths del_ths ctxt))
  end
\<close> "solve polynomial equations over (semi)rings and ideal membership problems using Groebner bases"

declare dvd_def[algebra]
declare mod_eq_0_iff_dvd[algebra]
declare mod_div_trivial[algebra]
declare mod_mod_trivial[algebra]
declare div_by_0[algebra]
declare mod_by_0[algebra]
declare mult_div_mod_eq[algebra]
declare div_minus_minus[algebra]
declare mod_minus_minus[algebra]
declare div_minus_right[algebra]
declare mod_minus_right[algebra]
declare div_0[algebra]
declare mod_0[algebra]
declare mod_by_1[algebra]
declare div_by_1[algebra]
declare mod_minus1_right[algebra]
declare div_minus1_right[algebra]
declare mod_mult_self2_is_0[algebra]
declare mod_mult_self1_is_0[algebra]

lemma zmod_eq_0_iff [algebra]:
  \<open>m mod d = 0 \<longleftrightarrow> (\<exists>q. m = d * q)\<close> for m d :: int
  by (auto simp add: mod_eq_0_iff_dvd)

declare dvd_0_left_iff[algebra]
declare zdvd1_eq[algebra]
declare mod_eq_dvd_iff[algebra]
declare nat_mod_eq_iff[algebra]

context semiring_parity
begin

declare even_mult_iff [algebra]
declare even_power [algebra]

end

context ring_parity
begin

declare even_minus [algebra]

end

declare even_Suc [algebra]
declare even_diff_nat [algebra]

end


(*
    Authors:    Maximilian Haslbeck
                René Thiemann
    License:    BSD
*)
subsection \<open>Bound on Number of Arithmetic Operations for Integer Implementation\<close>

text \<open>In this section we define a version of the LLL algorithm which explicitly returns the
  costs of running the algorithm. Its soundness is mainly proven by stating that
  projecting away yields the original result.

  The cost model counts the number of arithmetic operations that occur in vector-addition, scalar-products,
  and scalar multiplication and we prove a polynomial bound on this number.\<close>

theory LLL_Complexity
  imports
    LLL_Impl
    Cost
    "HOL-Library.Discrete"
begin

definition round_num_denom_cost :: "int \<Rightarrow> int \<Rightarrow> int cost" where
  "round_num_denom_cost n d = ((2 * n + d) div (2 * d), 4)" \<comment> \<open>4 arith. operations\<close>

lemma round_num_denom_cost:
  shows "result (round_num_denom_cost n d) = round_num_denom n d"
   "cost (round_num_denom_cost n d) \<le> 4"
  unfolding round_num_denom_cost_def round_num_denom_def by (auto simp: cost_simps)

context LLL_with_assms
begin

context
  assumes \<alpha>_gt: "\<alpha> > 4/3" and m0: "m \<noteq> 0"
begin

fun basis_reduction_add_rows_loop_cost where
  "basis_reduction_add_rows_loop_cost state i j [] = (state, 0)"
| "basis_reduction_add_rows_loop_cost state i sj (fj # fjs) = (
     let fi = fi_state state;
         dsj = d_state state sj;
         j = sj - 1;
         (c,cost1) = round_num_denom_cost (dmu_ij_state state i j) dsj;
         state' = (if c = 0 then state else upd_fi_mu_state state i (vec n (\<lambda> i. fi $ i - c * fj $ i)) \<comment> \<open>2n arith. operations\<close>
             (IArray.of_fun (\<lambda> jj. let mu = dmu_ij_state state i jj in \<comment> \<open>3 sj arith. operations\<close>
                  if jj < j then mu - c * dmu_ij_state state j jj else
                  if jj = j then mu - dsj * c else mu) i));
         local_cost = 2 * n + 3 * sj;
         (res,cost2) = basis_reduction_add_rows_loop_cost state' i j fjs
      in (res, cost1 + local_cost + cost2))"

lemma basis_reduction_add_rows_loop_cost: assumes "length fs = j"
  shows "result (basis_reduction_add_rows_loop_cost state i j fs) = LLL_Impl.basis_reduction_add_rows_loop n state i j fs"
   "cost (basis_reduction_add_rows_loop_cost state i j fs) \<le> sum (\<lambda> j. (2 * n + 4 + 3 * (Suc j))) {0..<j}"
  using assms
proof (atomize(full), induct fs arbitrary: state j)
  case (Cons fj fs state j)
  let ?dm_ij = "dmu_ij_state state i (j - 1)"
  let ?dj = "d_state state j"
  obtain c1 fc where flc: "round_num_denom_cost ?dm_ij ?dj = (fc, c1)" by force
  from result_costD[OF round_num_denom_cost flc]
  have fl: "round_num_denom ?dm_ij ?dj = fc" and c1: "c1 \<le> 4" by auto
  obtain st where st: "(if fc = 0 then state
             else upd_fi_mu_state state i (vec n (\<lambda> i. fi_state state $ i - fc * fj $ i))
                   (IArray.of_fun
                     (\<lambda>jj. if jj < j - 1 then dmu_ij_state state i jj - fc * dmu_ij_state state (j - 1) jj
                           else if jj = j - 1 then dmu_ij_state state i jj - d_state state j * fc else dmu_ij_state state i jj)
                     i)) = st"  by auto
  obtain res c2 where rec: "basis_reduction_add_rows_loop_cost st i (j - 1) fs = (res,c2)" (is "?x = _") by (cases ?x, auto)
  from Cons(2) have "length fs = j - 1" by auto
  from result_costD'[OF Cons(1)[OF this] rec]
  have res: "LLL_Impl.basis_reduction_add_rows_loop n st i (j - 1) fs = res"
    and c2: "c2 \<le> (\<Sum>j = 0..<j - 1. 2 * n + 4 + 3 * Suc j)" by auto
  show ?case unfolding basis_reduction_add_rows_loop_cost.simps Let_def flc split
      LLL_Impl.basis_reduction_add_rows_loop.simps fl st rec res cost_simps
  proof (intro conjI refl, goal_cases)
    case 1
    have "c1 + (2 * n + 3 * j) + c2 \<le> (\<Sum>j = 0..<j - 1. 2 * n + 4 + 3 * Suc j) + (2 * n + 4 + 3 * Suc (j - 1))"
      using c1 c2 by auto
    also have "\<dots> = (\<Sum>j = 0..<j. 2 * n + 4 + 3 * (Suc j))"
      by (subst (2) sum.remove[of _ "j - 1"], insert Cons(2), auto intro: sum.cong)
    finally show ?case .
  qed
qed (auto simp: cost_simps)

definition basis_reduction_add_rows_cost where
  "basis_reduction_add_rows_cost upw i state =
     (if upw then basis_reduction_add_rows_loop_cost state i i (small_fs_state state)
        else (state,0))"

lemma basis_reduction_add_rows_cost: assumes impl: "LLL_impl_inv state i fs" and inv: "LLL_invariant upw i fs"
  shows "result (basis_reduction_add_rows_cost upw i state) = LLL_Impl.basis_reduction_add_rows n upw i state"
   "cost (basis_reduction_add_rows_cost upw i state) \<le> (2 * n + 2 * i + 7) * i"
proof (atomize (full), goal_cases)
  case 1
  note d = basis_reduction_add_rows_cost_def LLL_Impl.basis_reduction_add_rows_def
  show ?case
  proof (cases upw)
    case False
    thus ?thesis by (auto simp: d cost_simps)
  next
    case True
    hence upw: "upw = True" by simp
    obtain f mu ds where state: "state = (f,mu,ds)" by (cases state, auto)
    from to_list_repr[OF impl inv state]
    have len: "length (small_fs_state state) = i"
      unfolding small_fs_state.simps state list_repr_def by auto
    let ?call = "basis_reduction_add_rows_cost upw i state"
    have res: "result ?call = LLL_Impl.basis_reduction_add_rows n upw i state"
      and cost: "cost ?call \<le> sum (\<lambda> j. (2 * n + 4 + 3 * (Suc j))) {0..<i}"
      unfolding d upw if_True using basis_reduction_add_rows_loop_cost[OF len, of state i] by auto
    note cost
    also have "sum (\<lambda> j. (2 * n + 4 + 3 * (Suc j))) {0..<i} = (2 * n + 7) * i + 3 * (\<Sum>j = 0..<i. j)"
      by (auto simp: algebra_simps  sum.distrib sum_distrib_right sum_distrib_left)
    also have "(\<Sum>j = 0..<i. j) = (i * (i - 1) div 2)"
    proof (induct i)
      case (Suc i)
      thus ?case by (cases i, auto)
    qed auto
    finally have "cost ?call \<le> (2 * n + 7) * i + 3 * (i * (i - 1) div 2)" .
    also have "\<dots> \<le> (2 * n + 7) * i + 2 * i * i"
    proof (rule add_left_mono)
      have "3 * (i * (i - 1) div 2) \<le> 2 * i * (i - 1)" by simp
      also have "\<dots> \<le> 2 * i * i" by (intro mult_mono, auto)
      finally show "3 * (i * (i - 1) div 2) \<le> 2 * i * i" .
    qed
    also have "\<dots> = (2 * n + 2 * i + 7) * i" by (simp add: algebra_simps)
    finally have cost: "cost ?call \<le> (2 * n + 2 * i + 7) * i" .
    show ?thesis using res cost by simp
  qed
qed

definition swap_mu_cost :: "int iarray iarray \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int iarray iarray cost" where
  "swap_mu_cost dmu i dmu_i_im1 dim1 di dsi = (let im1 = i - 1;
       res = IArray.of_fun (\<lambda> ii. if ii < im1 then dmu !! ii else
         if ii > i then let dmu_ii = dmu !! ii in
             IArray.of_fun (\<lambda> j. let dmu_ii_j = dmu_ii !! j in   \<comment> \<open>8 arith. operations for whole line\<close>
                 if j = i then (dsi * dmu_ii !! im1 - dmu_i_im1 * dmu_ii_j) div di \<comment> \<open>4 arith. operations for this entry\<close>
                 else if j = im1 then (dmu_i_im1 * dmu_ii_j + dmu_ii !! i * dim1) div di \<comment> \<open>4 arith. operations for this entry\<close>
                 else dmu_ii_j) ii else
         if ii = i then let mu_im1 = dmu !! im1 in
             IArray.of_fun (\<lambda> j. if j = im1 then dmu_i_im1 else mu_im1 !! j) ii
           else IArray.of_fun (\<lambda> j. dmu !! i !! j) ii) \<comment> \<open>ii = i - 1\<close>
         m; \<comment> \<open>in total, there are m - (i+1) many lines that require arithmetic operations: i + 1, ..., m - 1\<close>
       cost = 8 * (m - Suc i)
    in (res,cost))"

lemma swap_mu_cost:
   "result (swap_mu_cost dmu i dmu_i_im1 dim1 di dsi) = swap_mu m dmu i dmu_i_im1 dim1 di dsi"
   "cost (swap_mu_cost dmu i dmu_i_im1 dim1 di dsi) \<le> 8 * (m - Suc i)"
  by (auto simp: swap_mu_cost_def swap_mu_def Let_def cost_simps)

definition basis_reduction_swap_cost where
  "basis_reduction_swap_cost i state = (let
       di = d_state state i;
       dsi = d_state state (Suc i);
       dim1 = d_state state (i - 1);
       fi = fi_state state;
       fim1 = fim1_state state;
       dmu_i_im1 = dmu_ij_state state i (i - 1);
       fi' = fim1;
       fim1' = fi;
       di' = (dsi * dim1 + dmu_i_im1 * dmu_i_im1) div di; \<comment> \<open>4 arith. operations\<close>
       local_cost = 4
     in (case state of (f,dmus,djs) \<Rightarrow>
        case swap_mu_cost dmus i dmu_i_im1 dim1 di dsi of
          (swap_res, swap_cost) \<Rightarrow>
          let res = (False, i - 1,
                     (dec_i (update_im1 (update_i f fi') fim1'),
                      swap_res,
                      iarray_update djs i di'));
              cost = local_cost + swap_cost
         in (res, cost)))"

lemma basis_reduction_swap_cost:
   "result (basis_reduction_swap_cost i state) = LLL_Impl.basis_reduction_swap m i state"
   "cost (basis_reduction_swap_cost i state) \<le> 8 * (m - Suc i) + 4"
proof (atomize(full), goal_cases)
  case 1
  obtain f dmus djs where state: "state = (f,dmus,djs)" by (cases state, auto)
  let ?mu = "dmu_ij_state (f, dmus, djs) i (i - 1)"
  let ?di1 = "d_state (f, dmus, djs) (i - 1)"
  let ?di = "d_state (f, dmus, djs) i"
  let ?dsi = "d_state (f, dmus, djs) (Suc i)"
  show ?case unfolding basis_reduction_swap_cost_def LLL_Impl.basis_reduction_swap_def Let_def state split
    using swap_mu_cost[of dmus i ?mu ?di1 ?di ?dsi]
    by (cases "swap_mu_cost dmus i ?mu ?di1 ?di ?dsi", auto simp: cost_simps)
qed

definition basis_reduction_step_cost where
  "basis_reduction_step_cost upw i state = (if i = 0 then ((True, Suc i, inc_state state), 0)
     else let
       (state',cost_add) = basis_reduction_add_rows_cost upw i state;
       di = d_state state' i;
       dsi = d_state state' (Suc i);
       dim1 = d_state state' (i - 1);
       (num,denom) = quotient_of \<alpha>;
       cond = (di * di * denom \<le> num * dim1 * dsi); \<comment> \<open>5 arith. operations\<close>
       local_cost = 5
    in if cond then
          ((True, Suc i, inc_state state'), local_cost + cost_add)
        else case basis_reduction_swap_cost i state' of (res, cost_swap) \<Rightarrow> (res, local_cost + cost_swap + cost_add))"

definition "body_cost = 2 + (8 + 2 * n + 2 * m) * m"

lemma basis_reduction_step_cost: assumes
    impl: "LLL_impl_inv state i fs"
  and inv: "LLL_invariant upw i fs"
  and i: "i < m"
  shows "result (basis_reduction_step_cost upw i state) = LLL_Impl.basis_reduction_step \<alpha> n m upw i state" (is ?g1)
     "cost (basis_reduction_step_cost upw i state) \<le> body_cost" (is ?g2)
proof -
  obtain state' c_add where add: "basis_reduction_add_rows_cost upw i state = (state',c_add)"
    (is "?add = _") by (cases ?add, auto)
  obtain state'' c_swap where swapc: "basis_reduction_swap_cost i state' = (state'',c_swap)"
    (is "?swap = _") by (cases ?swap, auto)
  note res = basis_reduction_step_cost_def[of upw i state, unfolded add split swap]
  from result_costD[OF basis_reduction_add_rows_cost[OF impl inv] add]
  have add: "LLL_Impl.basis_reduction_add_rows n upw i state = state'"
    and c_add: "c_add \<le> (2 * n + 2 * i + 7) * i"
    by auto
  from result_costD[OF basis_reduction_swap_cost swapc]
  have swap: "LLL_Impl.basis_reduction_swap m i state' = state''"
    and c_swap: "c_swap \<le> 8 * (m - Suc i) + 4" by auto
  have "c_add + c_swap + 5 \<le> 8 * m + 2 + (2 * n + 2 * i) * i"
    using c_add c_swap i by (auto simp: field_simps)
  also have "\<dots> \<le> 8 * m + 2 + (2 * n + 2 * m) * m"
    by (intro add_left_mono mult_mono, insert i, auto)
  also have "\<dots> = 2 + (8 + 2 * n + 2 * m) * m" by (simp add: field_simps)
  finally have body: "c_add + c_swap + 5 \<le> body_cost" unfolding body_cost_def .
  obtain num denom where alpha: "quotient_of \<alpha> = (num,denom)" by force
  note res' = LLL_Impl.basis_reduction_step_def[of \<alpha> n m upw i state, unfolded add swap Let_def alpha split]
  note d = res res'
  show ?g1 unfolding d by (auto split: if_splits simp: cost_simps Let_def alpha swapc)
  show ?g2 unfolding d nat_distrib using body by (auto split: if_splits simp: cost_simps alpha Let_def swapc)
qed

partial_function (tailrec) basis_reduction_main_cost where
  "basis_reduction_main_cost upw i state c = (if i < m
     then let ((upw',i',state'), c_step) = basis_reduction_step_cost upw i state
       in basis_reduction_main_cost upw' i' state' (c + c_step)
     else (state, c))"

definition "num_loops = m + 2 * m * m * nat (ceiling (log base (real N)))"

lemma basis_reduction_main_cost: assumes impl: "LLL_impl_inv state i (fs_state state)"
  and inv: "LLL_invariant upw i (fs_state state)"
  and state: "state = initial_state m fs_init"
  and i: "i = 0"
  shows "result (basis_reduction_main_cost upw i state c) = LLL_Impl.basis_reduction_main \<alpha> n m upw i state" (is ?g1)
   "cost (basis_reduction_main_cost upw i state c) \<le> c + body_cost * num_loops" (is ?g2)
proof -
  have ?g1 and cost: "cost (basis_reduction_main_cost upw i state c) \<le> c + body_cost * LLL_measure i (fs_state state)"
    using assms(1-2)
  proof (atomize (full), induct "LLL_measure i (fs_state state)" arbitrary: upw i state c rule: less_induct)
    case (less i state upw c)
    note inv = less(3)
    note impl = less(2)
    obtain i' upw' state' c_step where step: "basis_reduction_step_cost upw i state = ((upw',i',state'),c_step)"
      (is "?step = _") by (cases ?step, auto)
    obtain state'' c_rec where rec: "basis_reduction_main_cost upw' i' state' (c + c_step) = (state'', c_rec)"
      (is "?rec = _") by (cases ?rec, auto)
    note step' = result_costD[OF basis_reduction_step_cost[OF impl inv] step]
    note d = basis_reduction_main_cost.simps[of upw] step split rec
        LLL_Impl.basis_reduction_main.simps[of _ _ _ upw]
    show ?case
    proof (cases "i < m")
      case i: True
      from step' i have step': "LLL_Impl.basis_reduction_step \<alpha> n m upw i state = (upw',i',state')"
         and c_step: "c_step \<le> body_cost"
        by auto
      note d = d step'
      from basis_reduction_step[OF impl inv step' i refl]
      have impl': "LLL_impl_inv state' i' (fs_state state')"
        and inv': "LLL_invariant upw' i' (fs_state state')"
        and meas: "LLL_measure i' (fs_state state') < LLL_measure i (fs_state state)"
        by auto
      from result_costD'[OF less(1)[OF meas impl' inv'] rec]
      have rec': "LLL_Impl.basis_reduction_main \<alpha> n m upw' i' state' = state''"
        and c_rec: "c_rec \<le> c + c_step + body_cost * LLL_measure i' (fs_state state')" by auto
      from c_step c_rec have "c_rec \<le> c + body_cost * Suc (LLL_measure i' (fs_state state'))"
        by auto
      also have "\<dots> \<le> c + body_cost * LLL_measure i (fs_state state)"
        using meas by (intro plus_right_mono mult_left_mono) auto
      finally show ?thesis using i inv impl by (auto simp: cost_simps d rec')
    next
      case False
      thus ?thesis unfolding d by (auto simp: cost_simps)
    qed
  qed
  show ?g1 by fact
  note cost also have "body_cost * LLL_measure i (fs_state state) \<le> body_cost * num_loops"
  proof (rule mult_left_mono; linarith?)
    define l where "l = log base (real N)"
    define k where "k = 2 * m * m"
    obtain f mu ds where init: "initial_state m fs_init = (f,mu,ds)" by (cases "initial_state m fs_init", auto)
    from initial_state
    have fs: "fs_state (initial_state m fs_init) = fs_init" by auto
    have "LLL_measure i (fs_state state) \<le> nat (ceiling (m + k * l))" unfolding l_def k_def
      using LLL_measure_approx_fs_init[OF LLL_inv_initial_state \<alpha>_gt m0] unfolding state fs i
      by linarith
    also have "\<dots> \<le> num_loops" unfolding num_loops_def l_def[symmetric] k_def[symmetric]
      by (simp add: of_nat_ceiling times_right_mono)
    finally show "LLL_measure i (fs_state state) \<le> num_loops" .
  qed
  finally show ?g2
    by auto
qed

context fixes
  fs :: "int vec iarray"
begin
fun sigma_array_cost where
  "sigma_array_cost dmus dmusi dmusj dll l = (if l = 0 then (dmusi !! l * dmusj !! l, 1)
      else let l1 = l - 1; dll1 = dmus !! l1 !! l1;
        (sig, cost_rec) = sigma_array_cost dmus dmusi dmusj dll1 l1;
        res = (dll * sig + dmusi !! l * dmusj !! l) div dll1; \<comment> \<open>4 arith. operations\<close>
        local_cost = (4 :: nat)
        in
      (res, local_cost + cost_rec))"

declare sigma_array_cost.simps[simp del]

lemma sigma_array_cost:
  "result (sigma_array_cost dmus dmusi dmusj dll l) = sigma_array dmus dmusi dmusj dll l"
  "cost (sigma_array_cost dmus dmusi dmusj dll l) \<le> 4 * l + 1"
proof (atomize(full), induct l arbitrary: dll)
  case 0
  show ?case unfolding sigma_array_cost.simps[of _ _ _ _ 0] sigma_array.simps[of _ _ _ _ 0]
    by (simp add: cost_simps)
next
  case (Suc l)
  let ?sl = "Suc l"
  let ?dll = "dmus !! (Suc l - 1) !! (Suc l - 1)"
  show ?case unfolding sigma_array_cost.simps[of _ _ _ _ ?sl] sigma_array.simps[of _ _ _ _ ?sl] Let_def
    using Suc[of ?dll]
    by (auto split: prod.splits simp: cost_simps)
qed

function dmu_array_row_main_cost where
  "dmu_array_row_main_cost fi i dmus j = (if j \<ge> i then (dmus, 0)
     else let sj = Suc j;
       dmus_i = dmus !! i;
       djj = dmus !! j !! j;
       (sigma, cost_sigma) = sigma_array_cost dmus dmus_i (dmus !! sj) djj j;
       dmu_ij = djj * (fi \<bullet> fs !! sj) - sigma; \<comment> \<open>2n + 2 arith. operations\<close>
       dmus' = iarray_update dmus i (iarray_append dmus_i dmu_ij);
       (res, cost_rec) = dmu_array_row_main_cost fi i dmus' sj;
       local_cost = 2 * n + 2
      in (res, cost_rec + cost_sigma + local_cost))"
  by pat_completeness auto

termination by (relation "measure (\<lambda> (fi,i,dmus,j). i - j)", auto)

declare dmu_array_row_main_cost.simps[simp del]

lemma dmu_array_row_main_cost: assumes "j \<le> i"
  shows "result (dmu_array_row_main_cost fi i dmus j) = dmu_array_row_main fs fi i dmus j"
  "cost (dmu_array_row_main_cost fi i dmus j) \<le> (\<Sum> jj \<in> {j ..< i}. 2 * n + 2 + 4 * jj + 1)"
  using assms
proof (atomize(full), induct "i - j" arbitrary: j dmus)
  case (0 j dmus)
  hence j: "j = i" by auto
  thus ?case unfolding dmu_array_row_main_cost.simps[of _ _ _ j]
    dmu_array_row_main.simps[of _ _ _ _ j]
    by (simp add: cost_simps)
next
  case (Suc l j dmus)
  from Suc(2) have id: "(i \<le> j) = False" "(j = i) = False" by auto
  let ?sl = "Suc l"
  let ?dll = "dmus !! (Suc l - 1) !! (Suc l - 1)"
  obtain sig c_sig where
    sig_c: "sigma_array_cost dmus (dmus !! i) (dmus !! Suc j) (dmus !! j !! j) j = (sig,c_sig)" by force
  from result_costD[OF sigma_array_cost sig_c]
  have sig: "sigma_array dmus (dmus !! i) (dmus !! Suc j) (dmus !! j !! j) j = sig"
    and c_sig: "c_sig \<le> 4 * j + 1" by auto
  obtain dmus' where
    dmus': "iarray_update dmus i (iarray_append (dmus !! i) (dmus !! j !! j * (fi \<bullet> fs !! Suc j) - sig)) = dmus'"
    by auto
  obtain res c_rec where rec_c: "dmu_array_row_main_cost fi i dmus' (Suc j) = (res, c_rec)" by force
  let ?c = "\<lambda> j. 2 * n + 2 + 4 * j + 1"
  from Suc(2-3) have "l = i - Suc j" "Suc j \<le> i" by auto
  from Suc(1)[OF this, of dmus', unfolded rec_c cost_simps]
  have rec: "dmu_array_row_main fs fi i dmus' (Suc j) = res"
   and c_rec: "c_rec \<le> (\<Sum>jj = Suc j..<i. ?c jj)" by auto
  have "c_rec + c_sig + 2 * n + 2 \<le> ?c j + (\<Sum>jj = Suc j..<i. ?c jj)"
    using c_rec c_sig by auto
  also have "\<dots> = (\<Sum>jj = j..<i. ?c jj)"
    by (subst (2) sum.remove[of _ j], insert Suc(2-), auto intro: sum.cong)
  finally have cost: "c_rec + c_sig + 2 * n + 2 \<le> (\<Sum>jj = j..<i. ?c jj)" by auto
  thus ?case unfolding dmu_array_row_main_cost.simps[of _ _ _ j] dmu_array_row_main.simps[of _ _ _ _ j] Let_def
    id if_False sig_c split sig dmus' rec rec_c cost_simps by auto
qed

definition dmu_array_row_cost where
  "dmu_array_row_cost dmus i = (let fi = fs !! i;
      sp = fi \<bullet> fs !! 0 \<comment> \<open>2n arith. operations\<close>;
      local_cost = 2 * n;
      (res, main_cost) = dmu_array_row_main_cost fi i (iarray_append dmus (IArray [sp])) 0 in
      (res, local_cost + main_cost))"

lemma dmu_array_row_cost:
   "result (dmu_array_row_cost dmus i) = dmu_array_row fs dmus i"
   "cost (dmu_array_row_cost dmus i) \<le> 2 * n + (2 * n + 1 + 2 * i) * i"
proof (atomize(full), goal_cases)
  case 1
  let ?fi = "fs !! i"
  let ?arr = "iarray_append dmus (IArray [?fi \<bullet> fs !! 0])"
  obtain res c_main where res_c: "dmu_array_row_main_cost ?fi i ?arr 0 = (res, c_main)" by force
  from result_costD[OF dmu_array_row_main_cost res_c]
  have res: "dmu_array_row_main fs ?fi i ?arr 0 = res"
    and c_main: "c_main \<le> (\<Sum>jj = 0..<i. 2 * n + 2 + 4 * jj + 1)" by auto
  have "2 * n + c_main \<le> 2 * n + (\<Sum>jj = 0..<i. 2 * n + 2 + 4 * jj + 1)" using c_main by auto
  also have "\<dots> = 2 * n + (2 * n + 3) * i + 2 * (\<Sum>jj < i. 2 * jj)"
    unfolding sum.distrib by (auto simp: sum_distrib_left field_simps intro: sum.cong)
  also have "(\<Sum>jj < i. 2 * jj) = i * (i - 1)"
    by (induct i, force, rename_tac i, case_tac i, auto)
  finally have "2 * n + c_main \<le> 2 * n + (2 * n + 3 + 2 * (i - 1)) * i" by (simp add: field_simps)
  also have "\<dots> = 2 * n + (2 * n + 1 + 2 * i) * i" by (cases i, auto simp: field_simps)
  finally have "2 * n + c_main \<le> 2 * n + (2 * n + 1 + 2 * i) * i" .
  thus ?case unfolding dmu_array_row_cost_def Let_def dmu_array_row_def res_c res split cost_simps
    by auto
qed

function dmu_array_cost where
  "dmu_array_cost dmus i = (if i \<ge> m then (dmus,0) else
    let (dmus', cost_row) = dmu_array_row_cost dmus i;
        (res, cost_rec) = dmu_array_cost dmus' (Suc i)
     in (res, cost_row + cost_rec))"
  by pat_completeness auto

termination by (relation "measure (\<lambda> (dmus, i). m - i)", auto)

declare dmu_array_cost.simps[simp del]

lemma dmu_array_cost: assumes "i \<le> m"
  shows "result (dmu_array_cost dmus i) = dmu_array fs m dmus i"
   "cost (dmu_array_cost dmus i) \<le> (\<Sum> ii \<in> {i ..< m}. 2 * n + (2 * n + 1 + 2 * ii) * ii)"
  using assms
proof (atomize(full), induct "m - i" arbitrary: i dmus)
  case (0 i dmus)
  hence i: "i = m" by auto
  thus ?case unfolding dmu_array_cost.simps[of _ i]
    dmu_array.simps[of _ _ _ i]
    by (simp add: cost_simps)
next
  case (Suc k i dmus)
  obtain dmus' c_row where row_c: "dmu_array_row_cost dmus i = (dmus',c_row)" by force
  from result_costD[OF dmu_array_row_cost row_c]
  have row: "dmu_array_row fs dmus i = dmus'"
    and c_row: "c_row \<le> 2 * n + (2 * n + 1 + 2 * i) * i" (is "_ \<le> ?c i") by auto
  from Suc have "k = m - Suc i" "Suc i \<le> m"
    and id: "(m \<le> i) = False" "(i = m) = False" by auto
  note IH = Suc(1)[OF this(1-2)]
  obtain res c_rec where rec_c: "dmu_array_cost dmus' (Suc i) = (res, c_rec)" by force
  from result_costD'[OF IH rec_c]
  have rec: "dmu_array fs m dmus' (Suc i) = res"
    and c_rec: "c_rec \<le> (\<Sum>ii = Suc i..<m. ?c ii)" by auto
  have "c_row + c_rec \<le> ?c i + (\<Sum>ii = Suc i..<m. ?c ii)"
    using c_rec c_row by auto
  also have "\<dots> = (\<Sum>ii = i..<m. ?c ii)"
    by (subst sum.atLeast_Suc_lessThan [of i]) (use Suc in auto)
  finally show ?case unfolding dmu_array_cost.simps[of _ i]
    dmu_array.simps[of _ _ _ i] id if_False Let_def rec_c row_c row rec split cost_simps by auto
qed
end (* fs *)

definition d\<mu>_impl_cost :: "int vec list \<Rightarrow> int iarray iarray cost" where
  "d\<mu>_impl_cost fs = dmu_array_cost (IArray fs) (IArray []) 0"

lemma d\<mu>_impl_cost: "result (d\<mu>_impl_cost fs_init) = d\<mu>_impl fs_init"
  "cost (d\<mu>_impl_cost fs_init) \<le> m * (m * (m + n + 2) + 2 * n + 1)"
proof (atomize(full), goal_cases)
  case 1
  let ?fs = "IArray fs_init"
  let ?dmus = "IArray []"
  obtain res cost where res_c: "dmu_array_cost ?fs ?dmus 0 = (res, cost)" by force
  from result_costD[OF dmu_array_cost res_c]
  have res: "dmu_array ?fs m ?dmus 0 = res"
    and cost: "cost \<le> (\<Sum>ii = 0..<m. 2 * n + (2 * n + 1 + 2 * ii) * ii) " by auto
  note cost
  also have "(\<Sum>ii = 0..<m. 2 * n + (2 * n + 1 + 2 * ii) * ii)
     = 2 * n * m + (2 * n + 1) * (\<Sum>ii = 0..<m.  ii) + 2 * (\<Sum>ii = 0..<m. ii * ii)"
    by (auto simp: field_simps sum.distrib sum_distrib_left intro: sum.cong)
  also have "\<dots> \<le> 2 * n * m + (2 * n + 2) * (\<Sum>ii = 0..<m.  ii) + 2 * (\<Sum>ii = 0..<m. ii * ii)"
    by auto
  also have "(2 * n + 2) * (\<Sum>ii = 0..<m.  ii) = (n + 1) * (2 * (\<Sum>ii = 0..<m.  ii))" by auto
  also have "2 * (\<Sum>ii = 0..<m.  ii) = m * (m - 1)"
    by (induct m, force, rename_tac i, case_tac i, auto)
  also have "2 * (\<Sum>ii = 0..<m.  ii * ii) = (6 * (\<Sum>ii = 0..<m.  ii * ii)) div 3" by simp
  also have "6 * (\<Sum>ii = 0..<m.  ii * ii) = 2 * (m - 1)*(m-1)*(m-1) + 3 * (m - 1) * (m - 1) + (m - 1)"
    by (induct m, simp, rename_tac i, case_tac i, auto simp: field_simps)
  finally have "cost \<le> 2 * n * m + (n + 1) * (m * (m - 1))
    + (2 * (m - 1) * (m - 1) * (m - 1) + 3 * (m - 1) * (m - 1) + (m - 1)) div 3" .
  also have "\<dots> \<le> 2 * n * m + (n + 1) * (m * m) + (3 * m * m * m + 3 * m * m + 3 * m) div 3"
    by (intro add_mono div_le_mono mult_mono, auto)
  also have "\<dots> = 2 * n * m + (n + 1) * (m * m) + (m * m * m + m * m + m)"
    by simp
  also have "\<dots> = m * (m * (m + n + 2) + 2 * n + 1)"
    by (simp add: algebra_simps)
  finally
  show ?case unfolding d\<mu>_impl_cost_def d\<mu>_impl_def len res res_c cost_simps by simp
qed

definition "initial_gso_cost = m * (m * (m + n + 2) + 2 * n + 1)"

definition "initial_state_cost fs = (let
  (dmus, cost) = d\<mu>_impl_cost fs;
  ds = IArray.of_fun (\<lambda> i. if i = 0 then 1 else let i1 = i - 1 in dmus !! i1 !! i1) (Suc m);
  dmus' = IArray.of_fun (\<lambda> i. let row_i = dmus !! i in
       IArray.of_fun (\<lambda> j. row_i !! j) i) m
  in ((([], fs), dmus', ds), cost) :: LLL_dmu_d_state cost)"

definition basis_reduction_cost :: "_ \<Rightarrow> LLL_dmu_d_state cost" where
  "basis_reduction_cost fs = (
    case initial_state_cost fs of (state1, c1) \<Rightarrow>
    case basis_reduction_main_cost True 0 state1 0 of (state2, c2) \<Rightarrow>
      (state2, c1 + c2))"

definition reduce_basis_cost :: "_ \<Rightarrow> int vec list cost" where
  "reduce_basis_cost fs = (case fs of Nil \<Rightarrow> (fs, 0) | Cons f _ \<Rightarrow>
    case basis_reduction_cost fs of (state,c) \<Rightarrow>
    (fs_state state, c))"

lemma initial_state_cost: "result (initial_state_cost fs_init) = initial_state m fs_init" (is ?g1)
  "cost (initial_state_cost fs_init) \<le> initial_gso_cost" (is ?g2)
proof -
  obtain st c where dmu: "d\<mu>_impl_cost fs_init = (st,c)" by force
  from d\<mu>_impl_cost[unfolded dmu cost_simps]
  have dmu': "d\<mu>_impl fs_init = st" and c: "c \<le> initial_gso_cost"
    unfolding initial_gso_cost_def by auto
  show ?g1 ?g2 using c unfolding initial_state_cost_def dmu dmu' split cost_simps
    initial_state_def Let_def by auto
qed

lemma basis_reduction_cost:
   "result (basis_reduction_cost fs_init) = basis_reduction \<alpha> n fs_init"  (is ?g1)
   "cost (basis_reduction_cost fs_init) \<le> initial_gso_cost + body_cost * num_loops" (is ?g2)
proof -
  obtain state1 c1 where init: "initial_state_cost fs_init = (state1, c1)" (is "?init = _") by (cases ?init, auto)
  obtain state2 c2 where main: "basis_reduction_main_cost True 0 state1 0 = (state2, c2)" (is "?main = _") by (cases ?main, auto)
  have res: "basis_reduction_cost fs_init = (state2, c1 + c2)"
    unfolding basis_reduction_cost_def init main split by simp
  from result_costD[OF initial_state_cost init]
  have c1: "c1 \<le> initial_gso_cost" and init: "initial_state m fs_init = state1" by auto
  note inv = LLL_inv_initial_state(1)
  note impl = initial_state
  have fs: "fs_state (initial_state m fs_init) = fs_init" by fact
  from basis_reduction_main_cost[of "initial_state m fs_init" _ _ 0, unfolded fs, OF impl(1) inv,
    unfolded init main cost_simps]
  have main: "LLL_Impl.basis_reduction_main \<alpha> n m True 0 state1 = state2" and c2: "c2 \<le> body_cost * num_loops"
    by auto
  have res': "basis_reduction \<alpha> n fs_init = state2" unfolding basis_reduction_def len init main Let_def ..
  show ?g1 unfolding res res' cost_simps ..
  show ?g2 unfolding res cost_simps using c1 c2 by auto
qed

text \<open>The lemma for the LLL algorithm with explicit cost annotations @{const reduce_basis_cost}
  shows that the termination measure
  indeed gives rise to an explicit cost bound. Moreover, the computed result is
  the same as in the non-cost counting @{const reduce_basis}.\<close>

lemma reduce_basis_cost:
   "result (reduce_basis_cost fs_init) = LLL_Impl.reduce_basis \<alpha> fs_init"  (is ?g1)
   "cost (reduce_basis_cost fs_init) \<le> initial_gso_cost + body_cost * num_loops" (is ?g2)
proof (atomize(full), goal_cases)
  case 1
  note d = reduce_basis_cost_def LLL_Impl.reduce_basis_def
  show ?case
  proof (cases fs_init)
    case Nil
    show ?thesis unfolding d unfolding Nil by (auto simp: cost_simps)
  next
    case (Cons f)
    obtain state c where b: "basis_reduction_cost fs_init = (state,c)" (is "?b = _") by (cases ?b, auto)
    from result_costD[OF basis_reduction_cost b]
    have bb: "basis_reduction \<alpha> n fs_init = state" and c: "c \<le> initial_gso_cost + body_cost * num_loops"
      by auto
    from fs_init[unfolded Cons] have dim: "dim_vec f = n" by auto
    show ?thesis unfolding d b split unfolding Cons list.simps unfolding Cons[symmetric] dim bb
      using c by (auto simp: cost_simps)
  qed
qed

lemma mn: "m \<le> n"
  unfolding len[symmetric] using lin_dep length_map unfolding gs.lin_indpt_list_def
  by (metis distinct_card gs.dim_is_n gs.fin_dim gs.li_le_dim(2))

text \<open>Theorem with expanded costs: $O(n\cdot m^3 \cdot \log (\mathit{maxnorm}\ F))$ arithmetic operations\<close>
lemma reduce_basis_cost_expanded:
  assumes "Lg \<ge> nat \<lceil>log (of_rat (4 * \<alpha> / (4 + \<alpha>))) N\<rceil>"
  shows "cost (reduce_basis_cost fs_init)
  \<le> 4 * Lg * m * m * m * n
    + 4 * Lg * m * m * m * m
    + 16 * Lg * m * m * m
    + 4 * Lg * m * m
    + 3 * m * m * m
    + 3 * m * m * n
    + 10 * m * m
    + 2 * n * m
    + 3 * m"
  (is "?cost \<le> ?exp Lg")
proof -
  define Log where "Log = nat \<lceil>log (of_rat (4 * \<alpha> / (4 + \<alpha>))) N\<rceil>"
  have Lg: "Log \<le> Lg" using assms unfolding Log_def .
  have "?cost \<le> ?exp Log"
    unfolding Log_def
    using reduce_basis_cost(2)[unfolded num_loops_def body_cost_def initial_gso_cost_def base_def]
    by (auto simp: algebra_simps)
  also have "\<dots> \<le> ?exp Lg"
    by (intro add_mono mult_mono Lg, auto)
  finally show ?thesis .
qed

lemma reduce_basis_cost_0: assumes "m = 0"
  shows "cost (reduce_basis_cost fs_init) = 0"
proof -
  from len assms have fs_init: "fs_init = []" by auto
  thus ?thesis unfolding reduce_basis_cost_def by (simp add: cost_simps)
qed

lemma reduce_basis_cost_N:
  assumes "Lg \<ge> nat \<lceil>log (of_rat (4 * \<alpha> / (4 + \<alpha>))) N\<rceil>"
  and 0: "Lg > 0"
  shows "cost (reduce_basis_cost fs_init) \<le> 49 * m ^ 3 * n * Lg"
proof (cases "m > 0")
  case True
  with mn 0 have 0: "0 < Lg" "0 < m" "0 < n" by auto
  note reduce_basis_cost_expanded[OF assms(1)]
  also have "4 * Lg * m * m * m * n = 4 * m ^ 3 * n * Lg"
    using 0 by (auto simp add: power3_eq_cube)
  also have "4 * Lg * m * m * m * m \<le> 4 * m ^ 3 * n * Lg"
    using 0 mn by (auto simp add: power3_eq_cube)
  also have "16 * Lg * m * m * m \<le> 16 * m ^ 3 * n * Lg"
    using 0 by (auto simp add: power3_eq_cube)
  also have "4 * Lg * m * m \<le> 4 *  m ^ 3 * n * Lg"
    using 0 by (auto simp add: power3_eq_cube)
  also have "3 * m * m * m \<le> 3 *  m ^ 3 * n * Lg"
    using 0 by (auto simp add: power3_eq_cube)
  also have "3 * m * m * n \<le> 3 * m ^ 3 * n * Lg"
    using 0 by (auto simp add: power3_eq_cube)
  also have "10 * m * m \<le> 10 * m ^ 3 * n * Lg"
    using 0 by (auto simp add: power3_eq_cube)
  also have "2 * n * m  \<le> 2 * m ^ 3 * n * Lg"
    using 0 by (auto simp add: power3_eq_cube)
  also have "3 * m \<le> 3 * m ^ 3 * n * Lg"
    using 0 by (auto simp add: power3_eq_cube)
  finally show ?thesis
    by (auto simp add: algebra_simps)
next
  case False
  with reduce_basis_cost_0 show ?thesis by simp
qed

lemma reduce_basis_cost_M:
  assumes "Lg \<ge> nat \<lceil>log (of_rat (4 * \<alpha> / (4 + \<alpha>))) (M * n)\<rceil>"
  and 0: "Lg > 0"
  shows "cost (reduce_basis_cost fs_init) \<le> 98 * m ^ 3 * n * Lg"
proof (cases "m > 0")
  case True
  let ?prod = "nat M * nat M * n"
  let ?p = "nat M * nat M * n * n"
  let ?lg = "real_of_int (M * n)"
  from 0 True have m0: "m \<noteq> 0" by simp
  from LLL_inv_N_pos[OF LLL_inv_initial_state g_bound_fs_init m0] have N0: "N > 0" .
  from N_le_MMn[OF m0] have N_prod: "N \<le> ?prod" by auto
  from N0 N_prod have M0: "M > 0" by (cases "M \<le> 0", auto)
  from N0 N_prod have prod0: "0 < ?prod" by linarith
  from prod0 have n0: "n > 0" by auto
  from n0 prod0 M0 have prod_p: "?prod \<le> ?p" by auto
  with N_prod prod0 have N_p: "N \<le> ?p" and p0: "0 < ?p" by linarith+
  let ?base = "real_of_rat (4 * \<alpha> / (4 + \<alpha>))"
  have base: "1 < ?base" using \<alpha>_gt by auto
  have Lg: "nat \<lceil>log ?base N\<rceil> \<le> nat \<lceil>log ?base ?p\<rceil>"
    by (intro nat_mono ceiling_mono log_mono, subst log_le_cancel_iff[OF base],
      insert M0 N_p N0 p0 n0, auto simp flip: of_int_mult of_nat_mult)
  also have "log ?base ?p = log ?base (?lg^2)"
    using M0 by (simp add: power2_eq_square ac_simps)
  also have "\<dots> = 2 * log ?base ?lg"
    by (subst log_nat_power, insert M0 n0, auto)
  finally have "nat \<lceil>log ?base N\<rceil> \<le> nat \<lceil>2 * log ?base ?lg\<rceil>" .
  also have "\<dots> \<le> 2 * Lg" using assms
    by linarith
  finally have Log: "nat \<lceil>log ?base N\<rceil> \<le> 2 * Lg" .
  from 0 have "0 < 2 * Lg" by simp
  from reduce_basis_cost_N[OF Log this]
  show ?thesis by simp
next
  case False
  with reduce_basis_cost_0 show ?thesis by simp
qed

end (* fixing arith_cost and assume \<alpha> > 4/3 *)
end (* LLL locale *)
end (* theory *)