theory InductiveTickCount

imports "../TeslDenotationalOperators"

begin

text {*
  inductive predicate for tick_count
*}
inductive tick_count_is :: "('a, 'b)\<H> \<Rightarrow> hamlet \<Rightarrow> instant \<Rightarrow> nat \<Rightarrow> bool"
where
  "\<not>ticks clk (hmt 0) \<Longrightarrow> tick_count_is clk hmt 0 0"
| "ticks clk (hmt 0) \<Longrightarrow> tick_count_is clk hmt 0 1"
| "\<lbrakk>tick_count_is clk hmt k n; \<not>ticks clk (hmt (Suc k))\<rbrakk> \<Longrightarrow> tick_count_is clk hmt (Suc k) n"
| "\<lbrakk>tick_count_is clk hmt k n; ticks clk (hmt (Suc k))\<rbrakk> \<Longrightarrow> tick_count_is clk hmt (Suc k) (Suc n)"

inductive_cases tick_count_00[elim!]:"tick_count_is clk hmt 0 0"
inductive_cases tick_count_01[elim!]:"tick_count_is clk hmt 0 1"
inductive_cases tick_count_sn[elim!]:"tick_count_is clk hmt (Suc k) n"
inductive_cases tick_count_ss[elim!]:"tick_count_is clk hmt (Suc k) (Suc n)"
thm tick_count_ss

text {*
  Soundness of the definition of the tick_count_is predicate and the tick_count_fun function.
*}
lemma tick_count_cons: "tick_count_is clk hmt k (tick_count_fun clk hmt k)"
proof (induction k)
  case 0 thus ?case
    by (metis tick_count_fun.simps(1) tick_count_is.simps)
next
  case (Suc k') thus ?case
    by (simp add: tick_count_is.intros(3) tick_count_is.intros(4) tick_count_is_fun)
qed

text {*
  Proof that the tick_count_is predicate behaves as a function.
*}
lemma tick_count_ind_is_fun: "\<lbrakk>tick_count_is clk hmt k n; tick_count_is clk hmt k n'\<rbrakk> \<Longrightarrow> n = n'"
proof (induction k arbitrary: n n')
  case 0 print_facts
    note k0 = this
    show ?case
    proof (cases n)
      case 0 thus ?thesis using k0
        by (metis less_Suc_eq_0_disj less_numeral_extra(3) tick_count_is.simps)
    next
      case Suc thus ?thesis using k0
        by (metis nat.distinct(1) tick_count_is.simps)
    qed
next
  case (Suc k')
    show ?case
    proof (cases "ticks clk (hmt (Suc k'))")
      case True
        hence "\<exists>m. (n = Suc m) \<and> tick_count_is clk hmt k' m" using Suc by auto
        from this obtain m where hm:"(n = Suc m) \<and> tick_count_is clk hmt k' m" by blast
        from True have "\<exists>m'. (n' = Suc m') \<and> tick_count_is clk hmt k' m'" using Suc by auto
        from this obtain m' where hm':"(n' = Suc m') \<and> tick_count_is clk hmt k' m'" by blast
        with hm hm' have "m = m'" using Suc.IH by simp
        thus ?thesis using hm hm' by simp
    next
      case False thus ?thesis using Suc.IH Suc.prems by blast
    qed
qed

text {*
  Proof of the equivalence of the inductive and the functional definitions of tick_count.
*}
lemma tick_count_eq: "tick_count_is clk hmt k n = (tick_count clk hmt k = n)"
using tick_count_cons tick_count_ind_is_fun by (metis tick_count_is_fun)

end


theory TopoS_Interface
imports Main "Lib/FiniteGraph" TopoS_Vertices "Lib/TopoS_Util"
begin

section {* Security Invariants *}
  text{*
    A good documentation of this formalization is available in \cite{diekmann2014forte}.
  *}

  text{*
    We define security invariants over a graph.
    The graph corresponds to the network's access control structure.
  *}

  (*TODO: make datatype!*)
  -- {*@{typ "'v"} is the type of the nodes in the graph (hosts in the network).
     @{typ "'a"} is the type of the host attributes.*}
  record ('v::vertex, 'a) TopoS_Params =
    node_properties :: "'v::vertex \<Rightarrow> 'a option"

text{*
A Security Invariant is defined as locale.

We successively define more and more locales with more and more assumptions.
This clearly depicts which assumptions are necessary to use certain features of a Security Invariant.
In addition, it makes instance proofs of Security Invariants easier, since the lemmas obtained by an (easy, few assumptions) instance proof
can be used for the complicated (more assumptions) instance proofs.

A security Invariant consists of one function: @{text "sinvar"}.
Essentially, it is a predicate over the policy (depicted as graph @{text "G"} and a host attribute mapping (@{text "nP"})).
*}

text {* A Security Invariant where the offending flows (flows that invalidate the policy) can be defined and calculated.
No assumptions are necessary for this step.
*}
  locale SecurityInvariant_withOffendingFlows =
    fixes sinvar::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> bool" --{* policy @{text "\<Rightarrow>"} host attribute mapping @{text "\<Rightarrow>"} bool*}
   begin
    -- "Offending Flows definitions:"
    definition is_offending_flows::"('v \<times> 'v) set \<Rightarrow> 'v graph \<Rightarrow> ('v \<Rightarrow> 'a) \<Rightarrow> bool" where
      "is_offending_flows f G nP \<equiv> \<not> sinvar G nP \<and> sinvar (delete_edges G f) nP"

    -- "Above definition is not minimal: "
    definition is_offending_flows_min_set::"('v \<times> 'v) set \<Rightarrow> 'v graph \<Rightarrow> ('v \<Rightarrow> 'a) \<Rightarrow> bool" where
      "is_offending_flows_min_set f G nP \<equiv> is_offending_flows f G nP \<and>
        (\<forall> (e1, e2) \<in> f. \<not> sinvar (add_edge e1 e2 (delete_edges G f)) nP)"

    -- "The set of all offending flows."
    definition set_offending_flows::"'v graph \<Rightarrow> ('v \<Rightarrow> 'a) \<Rightarrow> ('v \<times> 'v) set set" where
      "set_offending_flows G  nP = {F. F \<subseteq> (edges G) \<and> is_offending_flows_min_set F G nP}"

    text {*Some of the @{const set_offending_flows} definition*}
    lemma offending_not_empty: "\<lbrakk> F \<in> set_offending_flows G nP \<rbrakk> \<Longrightarrow> F \<noteq> {}"
     by(auto simp add: set_offending_flows_def is_offending_flows_def is_offending_flows_min_set_def)
    lemma empty_offending_contra:
       "\<lbrakk> F \<in> set_offending_flows G nP; F = {}\<rbrakk> \<Longrightarrow> False"
     by(simp add: set_offending_flows_def is_offending_flows_def is_offending_flows_min_set_def)
    lemma offending_notevalD: "F \<in> set_offending_flows G nP \<Longrightarrow> \<not> sinvar G nP"
     by(simp add: set_offending_flows_def is_offending_flows_def is_offending_flows_min_set_def)
    lemma sinvar_no_offending: "sinvar G nP \<Longrightarrow> set_offending_flows G nP = {}"
      by(simp add: set_offending_flows_def is_offending_flows_def is_offending_flows_min_set_def)
    theorem removing_offending_flows_makes_invariant_hold:
      "\<forall>F \<in> set_offending_flows G nP. sinvar (delete_edges G F) nP"
      proof(cases "sinvar G nP")
       case True
        hence no_offending: "set_offending_flows G nP = {}" using sinvar_no_offending by simp
        thus "\<forall>F\<in>set_offending_flows G nP. sinvar (delete_edges G F) nP" using empty_iff by simp
       next
       case False thus "\<forall>F\<in>set_offending_flows G nP. sinvar (delete_edges G F) nP"
        by(simp add: set_offending_flows_def is_offending_flows_def is_offending_flows_min_set_def graph_ops)
      qed
  corollary valid_without_offending_flows:
  "\<lbrakk> F \<in> set_offending_flows G nP \<rbrakk> \<Longrightarrow> sinvar (delete_edges G F) nP"
    by(simp add: removing_offending_flows_makes_invariant_hold)

  lemma set_offending_flows_simp:
    "\<lbrakk> wf_graph G \<rbrakk> \<Longrightarrow>
      set_offending_flows G nP = {F. F \<subseteq> edges G \<and>
        (\<not> sinvar G nP \<and> sinvar \<lparr>nodes = nodes G, edges = edges G - F\<rparr> nP) \<and>
        (\<forall>(e1, e2)\<in>F. \<not> sinvar \<lparr>nodes = nodes G, edges = {(e1, e2)} \<union> (edges G - F)\<rparr> nP)}"
    apply(simp only: set_offending_flows_def is_offending_flows_min_set_def
      is_offending_flows_def delete_edges_simp2 add_edge_def graph.select_convs)
    apply(subgoal_tac "\<And>F e1 e2. F \<subseteq> edges G \<Longrightarrow> (e1, e2) \<in> F \<Longrightarrow> nodes G \<union> {e1, e2} = nodes G")
     apply fastforce
    apply(simp add: wf_graph_def)
    by (metis fst_conv imageI in_mono insert_absorb snd_conv)

   end

print_locale! SecurityInvariant_withOffendingFlows

text{*
The locale @{text SecurityInvariant_withOffendingFlows} has no assumptions about the security invariant @{text sinvar}.
Undesirable things may happen:
The offending flows can be empty, even for a violated invariant.

We provide an example, the security invariant @{term "(\<lambda>_ _. False)"}.
As host attributes, we simply use the identity function @{const id}.
*}
lemma "SecurityInvariant_withOffendingFlows.set_offending_flows (\<lambda>_ _. False) \<lparr> nodes = {''v1''}, edges={} \<rparr> id = {}"
by %invisible (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
  SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def SecurityInvariant_withOffendingFlows.is_offending_flows_def)
lemma "SecurityInvariant_withOffendingFlows.set_offending_flows (\<lambda>_ _. False)
  \<lparr> nodes = {''v1'', ''v2''}, edges = {(''v1'', ''v2'')} \<rparr> id = {}"
by %invisible (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
  SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def SecurityInvariant_withOffendingFlows.is_offending_flows_def)

text {*In general, there exists a @{term sinvar} such that the invariant does not hold and no offending flows exits.*}
  lemma "\<exists>sinvar. \<not> sinvar G nP \<and> SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G nP = {}"
  apply(simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
    SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply(rule_tac x="(\<lambda>_ _. False)" in exI)
  apply(simp)
  done

text{*Thus, we introduce usefulness properties that prohibits such useless invariants.*}
text{*We summarize them in an invariant.
It requires the following:
\begin{enumerate}
  \item The offending flows are always defined.
  \item The invariant is monotonic, i.e. prohibiting more is more secure.
  \item And, the (non-minimal) offending flows are monotonic, i.e. prohibiting more solves more security issues.
\end{enumerate}

Later, we will show that is suffices to show that the invariant is monotonic. The other two properties can be derived.
*}

  locale SecurityInvariant_preliminaries = SecurityInvariant_withOffendingFlows sinvar
    for sinvar
    +
    assumes
      defined_offending:
      "\<lbrakk> wf_graph G; \<not> sinvar G nP \<rbrakk> \<Longrightarrow> set_offending_flows G nP \<noteq> {}"
    and
      mono_sinvar:
      "\<lbrakk> wf_graph \<lparr> nodes = N, edges = E \<rparr>; E' \<subseteq> E; sinvar \<lparr> nodes = N, edges = E \<rparr> nP \<rbrakk> \<Longrightarrow>
        sinvar \<lparr> nodes = N, edges = E' \<rparr> nP"
    and mono_offending:
      "\<lbrakk> wf_graph G; is_offending_flows ff G nP \<rbrakk> \<Longrightarrow> is_offending_flows (ff \<union> f') G nP"
  begin

  text {*
    \begin{small}
    To instantiate a @{const SecurityInvariant_preliminaries}, here are some hints:
    Have a look at the @{text "TopoS_withOffendingFlows.thy"} file.
    There is a definition of @{prop sinvar_mono}. It impplies @{prop mono_sinvar} and @{prop mono_offending}
    @{text "apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_sinvar_mono[OF sinvar_mono])
    apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])"}

    In addition, @{text "SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono]"} gives a nice proof rule for
    @{prop defined_offending}

    Basically, @{text "sinvar_mono."} implies almost all assumptions here and is equal to @{prop mono_sinvar}.
    \end{small}
  *}
  end

subsection{*Security Invariants with secure auto-completion of host attribute mappings*}

text{*
We will now add a new artifact to the Security Invariant.
It is a secure default host attribute, we will use the symbol @{text "\<bottom>"}.

The newly introduced Boolean @{text "receiver_violation"} tells whether a security violation happens at the sender's or the receiver's side.

The details can be looked up in \cite{diekmann2014forte}.
*}

  -- {* Some notes about the notation:
          @{term "fst ` F"} means to apply the function @{const "fst"} to the set @{term "F"} element-wise.
          Example: If @{term "F"} is a set of directed edges,
          @{term "F \<subseteq> edges G"}, then @{term "fst ` F"}
          is the set of senders and @{term "snd ` f"} the set of receivers.*}

  locale SecurityInvariant = SecurityInvariant_preliminaries sinvar
    for sinvar::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> bool"
    +
    fixes default_node_properties :: "'a" ("\<bottom>")
    and receiver_violation :: "bool"
    assumes
      -- "default value can never fix a security violation."
      -- {*Idea: Assume there is a violation, then there is some offending flow.
        @{text receiver_violation} defines whether the violation happens at the sender's or the receiver's side.
        We call the place of the violation the \emph{offending host}.
        We replace the host attribute of the offending host with the default attribute.
        Giving an offending host, a \emph{secure} default attribute does not change whether the invariant holds.
        I.e.\ this reconfiguration does not remove information, thus preserves all security critical information.
        Thought experiment preliminaries: Can a default configuration ever solve an existing security violation? NO!
        Thought experiment 1: admin forgot to configure host, hence it is handled by default configuration value ...
        Thought experiment 2: new node (attacker) is added to the network. What is its default configuration value ...*}
      default_secure:
      "\<lbrakk> wf_graph G; \<not> sinvar G nP; F \<in> set_offending_flows G nP \<rbrakk> \<Longrightarrow>
        (\<not> receiver_violation \<longrightarrow> i \<in> fst ` F \<longrightarrow> \<not> sinvar G (nP(i := \<bottom>))) \<and>
        (receiver_violation \<longrightarrow> i \<in> snd ` F \<longrightarrow> \<not> sinvar G (nP(i := \<bottom>)))"
      and
      default_unique:
      "otherbot \<noteq> \<bottom> \<Longrightarrow>
        \<exists> (G::('v::vertex) graph) nP i F. wf_graph G \<and> \<not> sinvar G nP \<and> F \<in> set_offending_flows G nP \<and>
         sinvar (delete_edges G F) nP \<and>
         (\<not> receiver_violation \<longrightarrow> i \<in> fst ` F \<and> sinvar G (nP(i := otherbot))) \<and>
         (receiver_violation \<longrightarrow> i \<in> snd ` F \<and> sinvar G (nP(i := otherbot))) "
   begin
    -- "Removes option type, replaces with default host attribute"
    fun node_props :: "('v, 'a) TopoS_Params \<Rightarrow> ('v \<Rightarrow> 'a)" where
    "node_props P = (\<lambda> i. (case (node_properties P) i of Some property \<Rightarrow> property | None \<Rightarrow> \<bottom>))"

    definition node_props_formaldef :: "('v, 'a) TopoS_Params \<Rightarrow> ('v \<Rightarrow> 'a)" where
    "node_props_formaldef P \<equiv>
    (\<lambda> i. (if i \<in> dom (node_properties P) then the (node_properties P i) else \<bottom>))"

    lemma node_props_eq_node_props_formaldef: "node_props_formaldef = node_props"
     by(simp add: fun_eq_iff node_props_formaldef_def option.case_eq_if domIff)

    text{*
      Checking whether a security invariant holds.
      \begin{enumerate}
        \item check that the policy @{term G} is syntactically valid
        \item check the security invariant @{term sinvar}
      \end{enumerate}
    *}
    definition eval::"'v graph \<Rightarrow> ('v, 'a) TopoS_Params \<Rightarrow> bool" where
    "eval G P \<equiv> wf_graph G \<and> sinvar G (node_props P)"

    lemma unique_common_math_notation:
    assumes "\<forall>G nP i F. wf_graph (G::('v::vertex) graph) \<and> \<not> sinvar G nP \<and> F \<in> set_offending_flows G nP \<and>
         sinvar (delete_edges G F) nP \<and>
         (\<not> receiver_violation \<longrightarrow> i \<in> fst ` F \<longrightarrow> \<not> sinvar G (nP(i := otherbot))) \<and>
         (receiver_violation \<longrightarrow> i \<in> snd ` F \<longrightarrow> \<not> sinvar G (nP(i := otherbot)))"
    shows "otherbot = \<bottom>"
    apply(rule ccontr)
    apply(drule default_unique)
    using assms by blast
   end

print_locale! SecurityInvariant

subsection{*Information Flow Security and Access Control*}
text{*

@{term receiver_violation} defines the offending host. Thus, it defines when the violation happens.

We found that this coincides with the invariant's security strategy.

\begin{description}
\item[ACS] If the violation happens at the sender, we have an access control strategy (\emph{ACS}).
I.e.\ the sender does not have the appropriate rights to initiate the connection.

\item[IFS] If the violation happens at the receiver, we have an information flow security strategy (\emph{IFS})
I.e.\ the receiver lacks the appropriate security level to retrieve the (confidential) information.
The violations happens only when the receiver reads the data.
\end{description}

We refine our @{term SecurityInvariant} locale.
*}

subsection {*Information Flow Security Strategy (IFS)*}
  locale SecurityInvariant_IFS = SecurityInvariant_preliminaries sinvar
      for sinvar::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> bool"
      +
      fixes default_node_properties :: "'a" ("\<bottom>")
      assumes  default_secure_IFS:
        "\<lbrakk> wf_graph G; f \<in> set_offending_flows G nP \<rbrakk> \<Longrightarrow>
          \<forall>i \<in> snd` f. \<not> sinvar G (nP(i := \<bottom>))"
      and
      --{* If some otherbot fulfills @{text default_secure}, it must be @{term "\<bottom>"}
             Hence, @{term "\<bottom>"} is uniquely defined *}
      default_unique_IFS:
      "(\<forall>G f nP i. wf_graph G \<and> f \<in> set_offending_flows G nP \<and> i \<in> snd` f
                \<longrightarrow> \<not> sinvar G (nP(i := otherbot))) \<Longrightarrow> otherbot = \<bottom>"
      begin
        lemma default_unique_EX_notation: "otherbot \<noteq> \<bottom> \<Longrightarrow>
          \<exists> G nP i f. wf_graph G \<and> \<not> sinvar G nP \<and> f \<in> set_offending_flows G nP \<and>
           sinvar (delete_edges G f) nP \<and>
           (i \<in> snd` f \<and> sinvar G (nP(i := otherbot)))"
          apply(erule contrapos_pp)
          apply(simp)
          using default_unique_IFS SecurityInvariant_withOffendingFlows.valid_without_offending_flows offending_notevalD
          by metis
      end

  sublocale SecurityInvariant_IFS \<subseteq> SecurityInvariant where receiver_violation=True
  apply(unfold_locales)
   apply(simp add: default_secure_IFS)
  apply(simp only: HOL.simp_thms)
  apply(drule default_unique_EX_notation)
  apply(assumption)
  done

  (*other direction*)
  locale SecurityInvariant_IFS_otherDirectrion = SecurityInvariant where receiver_violation=True
  sublocale SecurityInvariant_IFS_otherDirectrion \<subseteq> SecurityInvariant_IFS
  apply(unfold_locales)
   apply (metis default_secure offending_notevalD)
  apply(erule contrapos_pp)
  apply(simp)
  apply(drule default_unique)
  apply(simp)
  apply(blast)
  done

lemma default_uniqueness_by_counterexample_IFS:
  assumes "(\<forall>G F nP i. wf_graph G \<and> F \<in> SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G nP \<and> i \<in> snd` F
                \<longrightarrow> \<not> sinvar G (nP(i := otherbot)))"
  and "otherbot \<noteq> default_value \<Longrightarrow>
    \<exists>G nP i F. wf_graph G \<and> \<not> sinvar G nP \<and> F \<in> (SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G nP) \<and>
       sinvar (delete_edges G F) nP \<and>
        i \<in> snd ` F \<and> sinvar G (nP(i := otherbot)) "
   shows "otherbot = default_value"
   using assms by blast

subsection {*Access Control Strategy (ACS)*}
  locale SecurityInvariant_ACS = SecurityInvariant_preliminaries sinvar
      for sinvar::"('v::vertex) graph \<Rightarrow> ('v::vertex \<Rightarrow> 'a) \<Rightarrow> bool"
      +
      fixes default_node_properties :: "'a" ("\<bottom>")
      assumes  default_secure_ACS:
        "\<lbrakk> wf_graph G; f \<in> set_offending_flows G nP \<rbrakk> \<Longrightarrow>
          \<forall>i \<in> fst` f. \<not> sinvar G (nP(i := \<bottom>))"
      and
      default_unique_ACS:
      "(\<forall>G f nP i. wf_graph G \<and> f \<in> set_offending_flows G nP \<and> i \<in> fst` f
                \<longrightarrow> \<not> sinvar G (nP(i := otherbot))) \<Longrightarrow> otherbot = \<bottom>"
      begin
        lemma default_unique_EX_notation: "otherbot \<noteq> \<bottom> \<Longrightarrow>
          \<exists> G nP i f. wf_graph G \<and> \<not> sinvar G nP \<and> f \<in> set_offending_flows G nP \<and>
           sinvar (delete_edges G f) nP \<and>
           (i \<in> fst` f \<and> sinvar G (nP(i := otherbot)))"
          apply(erule contrapos_pp)
          apply(simp)
          using default_unique_ACS SecurityInvariant_withOffendingFlows.valid_without_offending_flows offending_notevalD
          by metis
      end

  sublocale SecurityInvariant_ACS \<subseteq> SecurityInvariant where receiver_violation=False
  apply(unfold_locales)
   apply(simp add: default_secure_ACS)
  apply(simp only: HOL.simp_thms)
  apply(drule default_unique_EX_notation)
  apply(assumption)
  done

  (*other direction*)
  locale SecurityInvariant_ACS_otherDirectrion = SecurityInvariant where receiver_violation=False
  sublocale SecurityInvariant_ACS_otherDirectrion \<subseteq> SecurityInvariant_ACS
  apply(unfold_locales)
   apply (metis default_secure offending_notevalD)
  apply(erule contrapos_pp)
  apply(simp)
  apply(drule default_unique)
  apply(simp)
  apply(blast)
  done

lemma default_uniqueness_by_counterexample_ACS:
  assumes "(\<forall>G F nP i. wf_graph G \<and> F \<in> SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G nP \<and> i \<in> fst ` F
                \<longrightarrow> \<not> sinvar G (nP(i := otherbot)))"
  and "otherbot \<noteq> default_value \<Longrightarrow>
    \<exists>G nP i F. wf_graph G \<and> \<not> sinvar G nP \<and> F \<in> (SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G nP) \<and>
       sinvar (delete_edges G F) nP \<and>
        i \<in> fst ` F \<and> sinvar G (nP(i := otherbot))"
  shows "otherbot = default_value"
  using assms by blast

text{* The sublocale relationships tell that the simplified @{const SecurityInvariant_ACS} and @{const SecurityInvariant_IFS}
  assumptions suffice to do tho generic SecurityInvariant assumptions. *}

end


(*
  Title:    Preference_Profiles_Cmd.thy
  Author:   Manuel Eberl, TU München

  Provides the preference_profile command that defines preference profiles,
  proves well-formedness, and provides some useful lemmas for them.
*)

section \<open>Automatic definition of Preference Profiles\<close>

theory Preference_Profile_Cmd
imports
  Complex_Main
  "../Social_Decision_Schemes"
  "../Preference_Profiles"
  "../Missing_Permutations"
  QSOpt_Exact
keywords
  "preference_profile" :: thy_goal
begin

ML_file "preference_profiles.ML"

context election
begin

lemma preferred_alts_prefs_from_table:
  assumes "prefs_from_table_wf agents alts xs" "i \<in> set (map fst xs)"
  shows   "preferred_alts (prefs_from_table xs i) x =
             of_weak_ranking_Collect_ge (rev (the (map_of xs i))) x"
proof -
  interpret pref_profile_wf agents alts "prefs_from_table xs"
    by (intro pref_profile_from_tableI assms)
  from assms have [simp]: "i \<in> agents" by (auto simp: prefs_from_table_wf_def)
  have "of_weak_ranking_Collect_ge (rev (the (map_of xs i))) x =
          Collect (of_weak_ranking (the (map_of xs i)) x)"
    by (rule eval_Collect_of_weak_ranking [symmetric])
  also from assms(2) have "the (map_of xs i) \<in> set (map snd xs)"
    by (cases "map_of xs i") (force simp: map_of_eq_None_iff dest: map_of_SomeD)+
  from prefs_from_table_wfD(5)[OF assms(1) this]
    have "Collect (of_weak_ranking (the (map_of xs i)) x) =
            {y\<in>alts. of_weak_ranking (the (map_of xs i)) x y}"
    by safe (force elim!: of_weak_ranking.cases)
  also from assms
    have "of_weak_ranking (the (map_of xs i)) = prefs_from_table xs i"
    by (subst prefs_from_table_map_of[OF assms(1)])
       (auto simp: prefs_from_table_wf_def)
  finally show ?thesis by (simp add: of_weak_ranking_Collect_ge_def preferred_alts_altdef)
qed

lemma favorites_prefs_from_table:
  assumes wf: "prefs_from_table_wf agents alts xs" and i: "i \<in> agents"
  shows   "favorites (prefs_from_table xs) i = hd (the (map_of xs i))"
proof (cases "map_of xs i")
  case None
  with assms show ?thesis
    by (auto simp: map_of_eq_None_iff prefs_from_table_wf_def)
next
  case (Some y)
  with assms have "is_finite_weak_ranking y" "y \<noteq> []"
    by (auto simp: prefs_from_table_wf_def)
  with Some show ?thesis
    unfolding favorites_def using assms
    by (simp add: prefs_from_table_def is_finite_weak_ranking_def
                  Max_wrt_of_weak_ranking prefs_from_table_wfD)
qed

lemma has_unique_favorites_prefs_from_table:
  assumes wf: "prefs_from_table_wf agents alts xs"
  shows   "has_unique_favorites (prefs_from_table xs) =
             list_all (\<lambda>z. is_singleton (hd (snd z))) xs"
proof -
  interpret pref_profile_wf agents alts "prefs_from_table xs"
    by (intro pref_profile_from_tableI assms)
  from wf have "agents = set (map fst xs)" "distinct (map fst xs)"
    by (auto simp: prefs_from_table_wf_def)
  thus ?thesis
    unfolding has_unique_favorites_altdef using assms
    by (auto simp: favorites_prefs_from_table list_all_iff)
qed

end

subsection \<open>Automatic definition of preference profiles from tables\<close>

function favorites_prefs_from_table where
  "i = j \<Longrightarrow> favorites_prefs_from_table ((j,x)#xs) i = hd x"
| "i \<noteq> j \<Longrightarrow> favorites_prefs_from_table ((j,x)#xs) i =
               favorites_prefs_from_table xs i"
| "favorites_prefs_from_table [] i = {}"
  by (metis list.exhaust old.prod.exhaust) auto
termination by lexicographic_order

lemma (in election) eval_favorites_prefs_from_table:
  assumes "prefs_from_table_wf agents alts xs"
  shows   "favorites_prefs_from_table xs i =
             favorites (prefs_from_table xs) i"
proof (cases "i \<in> agents")
  assume i: "i \<in> agents"
  with assms have "favorites (prefs_from_table xs) i = hd (the (map_of xs i))"
    by (simp add: favorites_prefs_from_table)
  also from assms i have "i \<in> set (map fst xs)"
    by (auto simp: prefs_from_table_wf_def)
  hence "hd (the (map_of xs i)) = favorites_prefs_from_table xs i"
    by (induction xs i rule: favorites_prefs_from_table.induct) simp_all
  finally show ?thesis ..
next
  assume i: "i \<notin> agents"
  with assms have i': "i \<notin> set (map fst xs)"
    by (simp add: prefs_from_table_wf_def)
  hence "map_of xs i = None"
    by (simp add: map_of_eq_None_iff)
  hence "prefs_from_table xs i = (\<lambda>_ _. False)"
    by (intro ext) (auto simp: prefs_from_table_def)
  hence "favorites (prefs_from_table xs) i = {}"
    by (simp add: favorites_def Max_wrt_altdef)
  also from i' have "\<dots> = favorites_prefs_from_table xs i"
    by (induction xs i rule: favorites_prefs_from_table.induct) simp_all
  finally show ?thesis ..
qed

lemma eval_prefs_from_table_aux:
  assumes "R \<equiv> prefs_from_table xs" "prefs_from_table_wf agents alts xs"
  shows   "R i a b \<longleftrightarrow> prefs_from_table xs i a b"
          "a \<prec>[R i] b \<longleftrightarrow> prefs_from_table xs i a b \<and> \<not>prefs_from_table xs i b a"
          "anonymous_profile R = mset (map snd xs)"
          "election agents alts \<Longrightarrow> i \<in> set (map fst xs) \<Longrightarrow>
             preferred_alts (R i) x =
             of_weak_ranking_Collect_ge (rev (the (map_of xs i))) x"
          "election agents alts \<Longrightarrow> i \<in> set (map fst xs) \<Longrightarrow>
             favorites R i = favorites_prefs_from_table xs i"
          "election agents alts \<Longrightarrow> i \<in> set (map fst xs) \<Longrightarrow>
             favorite R i = the_elem (favorites_prefs_from_table xs i)"
          "election agents alts \<Longrightarrow>
             has_unique_favorites R \<longleftrightarrow> list_all (\<lambda>z. is_singleton (hd (snd z))) xs"
  using assms prefs_from_table_wfD[OF assms(2)]
  by (simp_all add: strongly_preferred_def favorite_def anonymise_prefs_from_table
        election.preferred_alts_prefs_from_table election.eval_favorites_prefs_from_table
        election.has_unique_favorites_prefs_from_table)

lemma pref_profile_from_tableI':
  assumes "R1 \<equiv> prefs_from_table xss" "prefs_from_table_wf agents alts xss"
  shows   "pref_profile_wf agents alts R1"
  using assms by (simp add: pref_profile_from_tableI)

subsection \<open>Automorphisms\<close>

lemma an_sds_automorphism_aux:
  assumes wf: "prefs_from_table_wf agents alts yss" "R \<equiv> prefs_from_table yss"
  assumes an: "an_sds agents alts sds"
  assumes eq: "mset (map ((map (op ` (permutation_of_list xs))) \<circ> snd) yss) = mset (map snd yss)"
  assumes perm: "set (map fst xs) \<subseteq> alts" "set (map snd xs) = set (map fst xs)"
                "distinct (map fst xs)"
      and x: "x \<in> alts" "y = permutation_of_list xs x"
  shows   "pmf (sds R) x = pmf (sds R) y"
proof -
  note perm = list_permutesI[OF perm]
  let ?\<sigma> = "permutation_of_list xs"
  note perm' = permutation_of_list_permutes [OF perm]
  from wf have wf': "pref_profile_wf agents alts R" by (simp add: pref_profile_from_tableI)
  then interpret R: pref_profile_wf agents alts R .
  from perm' interpret R': pref_profile_wf agents alts "permute_profile ?\<sigma> R"
    by (simp add: R.wf_permute_alts)
  from an interpret an_sds agents alts sds .

  from eq wf have eq': "image_mset (map (op ` ?\<sigma>)) (anonymous_profile R) = anonymous_profile R"
    by (simp add: anonymise_prefs_from_table mset_map multiset.map_comp)
  from perm' x have "pmf (sds R) x = pmf (map_pmf ?\<sigma> (sds R)) (?\<sigma> x)"
    by (simp add: pmf_map_inj' permutes_inj)
  also from eq' x wf' perm' have "map_pmf ?\<sigma> (sds R) = sds R"
    by (intro sds_automorphism)
       (simp_all add: R.anonymous_profile_permute pref_profile_from_tableI)
  finally show ?thesis using x by simp
qed

ML \<open>

signature PREFERENCE_PROFILES_CMD =
sig

type info

val pref_profileT : typ -> typ -> typ
val lotteryT : typ -> typ
val sdsT : typ -> typ -> typ

val preference_profile :
  (term * term) * ((binding * (term * term list list) list) list) -> Proof.context -> Proof.state

val preference_profile_cmd :
  (string * string) * ((binding * (string * string list list) list) list) ->
    Proof.context -> Proof.state

val get_info : term -> Proof.context -> info
val add_info : term -> info -> Context.generic -> Context.generic
val transform_info : info -> morphism -> info

end

structure Preference_Profiles_Cmd : PREFERENCE_PROFILES_CMD =
struct

open Preference_Profiles

type info =
  { term : term, def_thm : thm, wf_thm : thm, wf_raw_thm : thm, binding : binding,
    raw : (term * term list list) list, eval_thms : thm list }

fun transform_info ({term = t, binding, def_thm, wf_thm, wf_raw_thm, raw, eval_thms} : info) phi =
    let
      val thm = Morphism.thm phi
      val fact = Morphism.fact phi
      val term = Morphism.term phi
      val bdg = Morphism.binding phi
    in
      { term = term t, binding = bdg binding, def_thm = thm def_thm, wf_thm = thm wf_thm,
        wf_raw_thm = thm wf_raw_thm, raw = map (fn (a, bss) => (term a, map (map term) bss)) raw,
        eval_thms = fact eval_thms }
    end

structure Data = Generic_Data
(
  type T = (term * info) Item_Net.T
  val empty = Item_Net.init (op aconv o apply2 fst) (single o fst)
  val extend = I
  val merge = Item_Net.merge
);

fun get_info term lthy =
  Item_Net.retrieve (Data.get (Context.Proof lthy)) term |> the_single |> snd

fun add_info term info lthy =
  Data.map (Item_Net.update (term, info)) lthy

fun add_infos infos lthy =
  Data.map (fold Item_Net.update infos) lthy

fun pref_profileT agentT altT = agentT --> altT --> altT --> HOLogic.boolT
fun lotteryT altT = Type (@{type_name pmf}, [altT])
fun sdsT agentT altT = pref_profileT agentT altT --> lotteryT altT

fun preference_profile_aux agents alts (binding, args) lthy =
  let
    val dest_Type' = Term.dest_Type #> snd #> hd
    val (agentT, altT) = apply2 (dest_Type' o fastype_of) (agents, alts)
    val alt_setT = HOLogic.mk_setT altT
    fun define t =
      Local_Theory.define ((binding, NoSyn), ((Binding.suffix_name "_def" binding, []), t)) lthy
    val ty = HOLogic.mk_prodT (agentT, HOLogic.listT (HOLogic.mk_setT altT))
    val args' =
      args |> map (fn x => x ||> map (HOLogic.mk_set altT) ||> HOLogic.mk_list alt_setT)
    val t_raw =
      args'
        |> map HOLogic.mk_prod
        |> HOLogic.mk_list ty
    val t = Const (@{const_name prefs_from_table},
              HOLogic.listT ty --> pref_profileT agentT altT) $ t_raw
    val ((prefs, prefs_def), lthy) = define t
    val prefs_from_table_wf_const =
      Const (@{const_name prefs_from_table_wf}, HOLogic.mk_setT agentT --> HOLogic.mk_setT altT -->
          HOLogic.listT (HOLogic.mk_prodT (agentT, HOLogic.listT (HOLogic.mk_setT altT))) -->
          HOLogic.boolT)
    val wf_prop = (prefs_from_table_wf_const $ agents $ alts $ t_raw) |> HOLogic.mk_Trueprop

  in
    ((prefs, wf_prop, prefs_def), lthy)
  end

fun fold_accum f xs s =
  let
    fun fold_accum_aux _ [] s acc = (rev acc, s)
      | fold_accum_aux f (x::xs) s acc =
          case f x s of (y, s') => fold_accum_aux f xs s' (y::acc)
  in
    fold_accum_aux f xs s []
  end

fun preference_profile ((agents, alts), args) lthy =
  let
    fun qualify pref suff = Binding.qualify true (Binding.name_of pref) (Binding.name suff)
    val (results, lthy) = fold_accum (preference_profile_aux agents alts) args lthy
    val prefs_terms = map #1 results
    val wf_props = map #2 results
    val defs = map (snd o #3) results
    val raws = map snd args
    val bindings = map fst args

    fun tac lthy =
       let
         val lthy' = put_simpset HOL_ss lthy addsimps
           @{thms list.set Union_insert Un_insert_left insert_not_empty Int_empty_left Int_empty_right
              insert_commute Un_empty_left Un_empty_right insert_absorb2 Union_empty
              is_weak_ranking_Cons is_weak_ranking_Nil finite_insert finite.emptyI
              Set.singleton_iff Set.empty_iff Set.ball_simps}
        in
          Local_Defs.unfold_tac lthy defs
            THEN ALLGOALS (resolve_tac lthy [@{thm prefs_from_table_wfI}])
            THEN Local_Defs.unfold_tac lthy @{thms is_finite_weak_ranking_def list.set insert_iff
               empty_iff simp_thms list.map snd_conv fst_conv}
            THEN ALLGOALS (TRY o REPEAT_ALL_NEW (eresolve_tac lthy @{thms disjE}))
            THEN ALLGOALS (TRY o Hypsubst.hyp_subst_tac lthy)
            THEN ALLGOALS (Simplifier.asm_full_simp_tac lthy')
            THEN ALLGOALS (TRY o REPEAT_ALL_NEW (resolve_tac lthy @{thms conjI}))
            THEN distinct_subgoals_tac
        end

    fun after_qed [wf_thms_raw] lthy =
      let
        fun prep_thms attrs suffix (thms : thm list) binding =
          (((qualify binding suffix, attrs), [(thms,[])]))
        fun prep_thmss simp suffix thmss = map2 (prep_thms simp suffix) thmss bindings
        fun notes thmss suffix attrs lthy =
            Local_Theory.notes (prep_thmss attrs suffix thmss) lthy |> snd
        fun note thms suffix attrs lthy = notes (map single thms) suffix attrs lthy
        val eval_thmss = map2 (fn def => fn wf =>
          map (fn thm => thm OF [def, wf]) @{thms eval_prefs_from_table_aux})
          defs wf_thms_raw
        val wf_thms = map2 (fn def => fn wf =>
          @{thm pref_profile_from_tableI'} OF [def, wf]) defs wf_thms_raw
        val mk_infos =
          let
            fun aux acc (bdg::bdgs) (t::ts) (r::raws) (def::def_thms) (wf::wf_thms)
                   (wf_raw::wf_raw_thms) (evals::eval_thmss) =
              aux ((t, {binding = bdg, term = t, raw = r, def_thm = def, wf_thm = wf,
                 wf_raw_thm = wf_raw, eval_thms = evals}) :: acc)
                 bdgs ts raws def_thms wf_thms wf_raw_thms eval_thmss
            | aux acc [] _ _ _ _ _ _ = (acc : (term * info) list)
            | aux _ _ _ _ _ _ _ _ = raise Match
          in
            aux []
          end
        val infos = mk_infos bindings prefs_terms raws defs wf_thms wf_thms_raw eval_thmss
      in
        lthy
        |> note wf_thms_raw "wf_raw" []
        |> note wf_thms "wf" @{attributes [simp]}
        |> notes eval_thmss "eval" []
        |> Local_Theory.declaration {syntax = false, pervasive = false}
             (fn m => add_infos (map (fn (t,i) => (Morphism.term m t, transform_info i m)) infos))
      end
    | after_qed _ _ = raise Match

  in
    Proof.theorem NONE after_qed [map (fn prop => (prop, [])) wf_props] lthy
    |> Proof.refine_singleton (Method.Basic (SIMPLE_METHOD o tac))
  end

fun preference_profile_cmd ((agents, alts), argss) lthy =
  let
    val read = Syntax.read_term lthy
    val alts' = read alts
    fun read_pref_elem ts = map read ts
    fun read_prefs prefs = map read_pref_elem prefs
    fun prep (binding, args) =
      (binding, map (fn (agent, prefs) => (read agent, read_prefs prefs)) args)
  in
    preference_profile ((read agents, alts'), map prep argss) lthy
  end

val parse_prefs =
  let
    val parse_pref_elem =
      (Args.bracks (Parse.list1 Parse.term)) ||
      Parse.term >> single
  in
    Parse.list1 parse_pref_elem
  end

val parse_pref_profile =
  Parse.binding --| Args.$$$ "=" -- Scan.repeat1 (Parse.term --| Args.colon -- parse_prefs)

val _ =
  Outer_Syntax.local_theory_to_proof @{command_keyword preference_profile}
    "construct preference profiles from a table"
    (Args.$$$ "agents" |-- Args.colon |-- Parse.term --| Args.$$$ "alts" --| Args.colon
       -- Parse.term --| Args.$$$ "where" --
     Parse.and_list1 parse_pref_profile >> preference_profile_cmd);

end
\<close>

end


(*
    Authors:    René Thiemann
                BSD
*)

section \<open>Certification of External LLL Invocations\<close>

text \<open>Instead of using a fully verified algorithm, we also provide a technique to invoke
an external LLL solver. In order to check its result, we not only need the reduced basic,
but also the matrices which translate between the input basis and the reduced basis.
Then we can easily check whether the resulting lattices are indeed identical and just have
to start the verified algorithm on the already reduced basis.
This invocation will then usually just require one computation of Gram--Schmidt in order
to check that the basis is already reduced. Alternatively, one could also throw an error
message in case the basis is not reduced.\<close>

subsection \<open>Checking Results of External LLL Solvers\<close>

theory LLL_Certification
  imports
    LLL_Impl
    Jordan_Normal_Form.Show_Matrix
begin

definition "gauss_jordan_integer_inverse n A B I = (case gauss_jordan A B of
   (C,D) \<Rightarrow> C = I \<and> list_all is_int_rat (concat (mat_to_list D)))"

definition "integer_equivalent n fs gs = (let
  fs' = map_mat rat_of_int (mat_of_cols n fs);
  gs' = map_mat rat_of_int (mat_of_cols n gs);
  I = 1\<^sub>m n
  in gauss_jordan_integer_inverse n fs' gs' I \<and> gauss_jordan_integer_inverse n gs' fs' I)"

context vec_module
begin

lemma mat_mult_sub_lattice: assumes fs: "set fs \<subseteq> carrier_vec n"
  and gs: "set gs \<subseteq> carrier_vec n"
  and A: "A \<in> carrier_mat (length fs) (length gs)"
  and prod: "mat_of_rows n fs = map_mat of_int A * mat_of_rows n gs"
  shows "lattice_of fs \<subseteq> lattice_of gs"
proof
  let ?m = "length fs"
  let ?m' = "length gs"
  let ?i = "of_int :: int \<Rightarrow> 'a"
  let ?I = "map_mat ?i"
  let ?A = "?I A"
  have gsC: "mat_of_rows n gs \<in> carrier_mat ?m' n" by auto
  from A have A: "?A \<in> carrier_mat ?m ?m'" by auto
  from fs have fsi[simp]: "\<And> i. i < ?m \<Longrightarrow> fs ! i \<in> carrier_vec n" by auto
  hence fsi'[simp]: "\<And> i. i < ?m \<Longrightarrow> dim_vec (fs ! i) = n" by simp
  from gs have fsi[simp]: "\<And> i. i < ?m' \<Longrightarrow> gs ! i \<in> carrier_vec n" by auto
  hence gsi'[simp]: "\<And> i. i < ?m' \<Longrightarrow> dim_vec (gs ! i) = n" by simp
  fix v
  assume "v \<in> lattice_of fs"
  from in_latticeE[OF this]
  obtain c where v: "v = M.sumlist (map (\<lambda>i. ?i (c i) \<cdot>\<^sub>v fs ! i) [0..<?m])" by auto
  let ?c = "vec ?m (\<lambda> i. ?i (c i))"
  let ?d = "A\<^sup>T *\<^sub>v vec ?m c"
  note v
  also have "\<dots> = mat_of_cols n fs *\<^sub>v ?c"
    by (rule eq_vecI, auto intro!: dim_sumlist sum.cong
      simp: sumlist_nth scalar_prod_def mat_of_cols_def)
  also have "mat_of_cols n fs = (mat_of_rows n fs)\<^sup>T"
    by (simp add: transpose_mat_of_rows)
  also have "\<dots> = (?A * mat_of_rows n gs)\<^sup>T" unfolding prod ..
  also have "\<dots> = (mat_of_rows n gs)\<^sup>T * ?A\<^sup>T"
    by (rule transpose_mult[OF A gsC])
  also have "(mat_of_rows n gs)\<^sup>T = mat_of_cols n gs"
    by (simp add: transpose_mat_of_rows)
  finally have "v = (mat_of_cols n gs * ?A\<^sup>T) *\<^sub>v ?c" .
  also have "\<dots> = mat_of_cols n gs *\<^sub>v (?A\<^sup>T *\<^sub>v ?c)"
    by (rule assoc_mult_mat_vec, insert A, auto)
  also have "?A\<^sup>T = ?I (A\<^sup>T)" by fastforce
  also have "?c = map_vec ?i (vec ?m c)" by auto
  also have "?I (A\<^sup>T) *\<^sub>v \<dots> = map_vec ?i ?d"
    using A by (simp add: of_int_hom.mult_mat_vec_hom)
  finally have "v = mat_of_cols n gs *\<^sub>v map_vec ?i ?d" .
  define d where "d = ?d"
  have d: "d \<in> carrier_vec ?m'" unfolding d_def using A by auto
  have "v = mat_of_cols n gs *\<^sub>v map_vec ?i d" unfolding d_def by fact
  also have "\<dots> =  M.sumlist (map (\<lambda>i. ?i (d $ i) \<cdot>\<^sub>v gs ! i) [0..<?m'])"
    by (rule sym, rule eq_vecI, insert d, auto intro!: dim_sumlist sum.cong
      simp: sumlist_nth scalar_prod_def mat_of_cols_def)
  finally show "v \<in> lattice_of gs"
    by (intro in_latticeI, auto)
qed
end

context LLL_with_assms
begin

lemma mult_left_identity:
  defines "B \<equiv> (map_mat rat_of_int (mat_of_rows n fs_init))"
  assumes P_carrier[simp]: "P \<in> carrier_mat m m"
  and PB: "P * B = B"
shows "P = 1\<^sub>m m"
proof -
  let ?set_rows = "set (rows B)"
  let ?hom = "of_int_hom.vec_hom :: int vec \<Rightarrow> rat vec"
  have set_rows_carrier: "?set_rows \<subseteq> (carrier_vec n)" by (auto simp add: rows_def B_def)
  have set_rows_eq: "?set_rows = set (map of_int_hom.vec_hom fs_init)"
  proof -
    have "x \<in> of_int_hom.vec_hom ` set fs_init" if x: "x \<in> set (rows B)" for x
      using x unfolding B_def
      by (metis cof_vec_space.lin_indpt_list_def fs_init image_set
          lin_dep mat_of_rows_map rows_mat_of_rows)
    moreover have "of_int_hom.vec_hom xa \<in> set (rows B)" if xa: "xa \<in> set fs_init" for xa
    proof -
      obtain i where xa: "xa = fs_init ! i" and i: "i<m"
        by (metis in_set_conv_nth len xa)
      have "?hom (fs_init ! i) = row B i" unfolding B_def
        by (metis i cof_vec_space.lin_indpt_list_def fs_init index_map_mat(2) len lin_dep
            mat_of_rows_carrier(2) mat_of_rows_map nth_map nth_rows rows_mat_of_rows)
      thus ?thesis
        by (metis B_def xa i cof_vec_space.lin_indpt_list_def fs_init index_map_mat(2) len
            length_rows lin_dep mat_of_rows_map nth_map nth_mem rows_mat_of_rows)
    qed
    ultimately show ?thesis by auto
  qed
  have ind_set_rows: "gs.lin_indpt ?set_rows"
    using lin_dep set_rows_eq unfolding gs.lin_indpt_list_def by auto
  have inj_on_rowB: "inj_on (row B) {0..<m}"
  proof -
    have "x = y" if x: "x < m" and y: "y < m" and row_xy: "row B x = row B y" for x y
    proof (rule ccontr)
      assume xy: "x \<noteq> y"
      have 1: "?hom (fs_init ! x) = row B x" unfolding B_def
        by (metis fs_init index_map_mat(2) len local.set_rows_carrier mat_of_rows_carrier(2)
            mat_of_rows_map nth_map nth_rows rows_mat_of_rows set_rows_eq that(1))
      moreover have 2: "?hom (fs_init ! y) = row B y" unfolding B_def
        by (metis fs_init index_map_mat(2) len local.set_rows_carrier mat_of_rows_carrier(2)
            mat_of_rows_map nth_map nth_rows rows_mat_of_rows set_rows_eq that(2))
      ultimately have "?hom (fs_init ! x) = ?hom (fs_init ! y)" using row_xy by auto
      thus False using lin_dep x y row_xy unfolding gs.lin_indpt_list_def
        using xy x y len unfolding distinct_conv_nth by auto
    qed
    thus ?thesis unfolding inj_on_def by auto
  qed
  have the_x: "(THE k. k < m \<and> row B x = row B k) = x" if x: "x < m" for x
  proof (rule theI2)
    show "x < m \<and> row B x = row B x" using x by auto
    fix xa assume xa: "xa < m \<and> row B x = row B xa"
    show "xa = x" using xa inj_on_rowB x unfolding inj_on_def by auto
    thus "xa = x" .
  qed
  let ?h= "row B"
  show ?thesis
  proof (rule eq_matI, unfold one_mat_def, auto)
    fix j assume j: "j < m"
    let ?f = "(\<lambda>v. P $$ (j, THE k. k < m \<and> v = row B k))"
    let ?g = "\<lambda>v. if v = row B j then (?f v) - 1 else ?f v"
    have finsum_closed[simp]:
       "finsum_vec TYPE(rat) n (\<lambda>k. P $$ (j, k) \<cdot>\<^sub>v row B k) {0..<m} \<in> carrier_vec n"
      by (rule finsum_vec_closed, insert len B_def, auto)
    have B_carrier[simp]: "B \<in> carrier_mat m n" using len fs_init B_def by auto
    define v where "v \<equiv> row B j"
    have v_set_rows: "v \<in> set (rows B)" using nth_rows j unfolding v_def
      by (metis B_carrier carrier_matD(1) length_rows nth_mem)
    have [simp]: "mat_of_rows n fs_init \<in> carrier_mat m n" using len fs_init by auto
    have "B = P*B" using PB by auto
    also have "... = mat\<^sub>r m n (\<lambda>i. finsum_vec TYPE(rat) n (\<lambda>k. P $$ (i, k) \<cdot>\<^sub>v row B k) {0..<m})"
      by (rule mat_mul_finsum_alt, auto)
    also have "row (...) j = finsum_vec TYPE(rat) n (\<lambda>k. P $$ (j, k) \<cdot>\<^sub>v row B k) {0..<m}"
      by (rule row_mat_of_row_fun[OF j], simp)
    also have "... = finsum_vec TYPE(rat) n (\<lambda>v.  ?f v \<cdot>\<^sub>v v) ?set_rows"  (is "?lhs = ?rhs")
    proof (rule eq_vecI)
      have rhs_carrier: "?rhs \<in> carrier_vec n"
        by (rule finsum_vec_closed, insert set_rows_carrier, auto)
      have "dim_vec ?lhs = n" using vec_space.finsum_dim by simp
      also have dim_rhs: "... = dim_vec ?rhs" using rhs_carrier by auto
      finally show "dim_vec ?lhs = dim_vec ?rhs" .
      fix i assume i: "i < dim_vec ?rhs"
      have i_n: "i < n" using i dim_rhs by auto
      let ?g = "\<lambda>v. (?f v \<cdot>\<^sub>v v) $ i"
      have image_h: "?h `{0..<m} = ?set_rows" by (auto simp add: B_def len rows_def)
      have "?lhs $ i = (\<Sum>k\<in>{0..<m}. (P $$ (j, k) \<cdot>\<^sub>v row B k) $ i)"
        by (rule index_finsum_vec[OF _ i_n], auto)
      also have "... = sum (?g \<circ> ?h) {0..<m}" unfolding o_def
        by (rule sum.cong, insert the_x, auto)
      also have "... = sum (\<lambda>v. (?f v \<cdot>\<^sub>v v) $ i) (?h `{0..<m})"
        by (rule sum.reindex[symmetric, OF inj_on_rowB])
      also have "... =  (\<Sum>v\<in>?set_rows. (?f v \<cdot>\<^sub>v v) $ i)" using image_h by auto
      also have "... = ?rhs $ i"
        by (rule index_finsum_vec[symmetric, OF _ i_n], insert set_rows_carrier, auto)
      finally show "?lhs $ i = ?rhs $ i" by auto
    qed
    also have "... = (\<Oplus>\<^bsub>gs.V\<^esub>v\<in>?set_rows. ?f v \<cdot>\<^sub>v v)" unfolding vec_space.finsum_vec ..
    also have "... = gs.lincomb ?f ?set_rows" unfolding gs.lincomb_def by auto
    finally have lincomb_rowBj: "gs.lincomb ?f ?set_rows = row B j" ..
    have lincomb_0: "gs.lincomb ?g (?set_rows) = 0\<^sub>v n"
    proof -
      have v_closed[simp]: "v \<in> Rn" unfolding v_def using j by auto
      have lincomb_f_closed[simp]: "gs.lincomb ?f (?set_rows-{v}) \<in> Rn"
        by (rule gs.lincomb_closed, insert set_rows_carrier, auto)
      have fv_v_closed[simp]: "?f v \<cdot>\<^sub>v v \<in> Rn" by auto
      have lincomb_f: "gs.lincomb ?f ?set_rows = ?f v \<cdot>\<^sub>v v + gs.lincomb ?f (?set_rows-{v})"
        by (rule gs.lincomb_del2, insert set_rows_carrier v_set_rows, auto)
      have fvv_gvv: "?f v \<cdot>\<^sub>v v - v = ?g v \<cdot>\<^sub>v v" unfolding v_def
        by (rule eq_vecI, auto, simp add: left_diff_distrib)
      have lincomb_fg: "gs.lincomb ?f (?set_rows-{v}) = gs.lincomb ?g (?set_rows-{v})"
        (is "?lhs = ?rhs")
      proof (rule eq_vecI)
        show dim_vec_eq: "dim_vec ?lhs = dim_vec ?rhs"
          by (smt DiffE carrier_vecD gs.lincomb_closed local.set_rows_carrier subsetCE subsetI)
        fix i assume i: "i<dim_vec ?rhs"
        hence i_n: "i<n" using dim_vec_eq lincomb_f_closed by auto
        have "?lhs $ i =  (\<Sum>x\<in>(?set_rows-{v}). ?f x * x $ i)"
          by (rule gs.lincomb_index[OF i_n], insert set_rows_carrier, auto)
        also have "... = (\<Sum>x\<in>(?set_rows-{v}). ?g x * x $ i)"
          by (rule sum.cong, auto simp add: v_def)
        also have "... = ?rhs $ i"
          by (rule gs.lincomb_index[symmetric, OF i_n], insert set_rows_carrier, auto)
        finally show "?lhs $ i = ?rhs $ i" .
      qed
      have "0\<^sub>v n = gs.lincomb ?f ?set_rows - v" using lincomb_rowBj unfolding v_def B_def by auto
      also have "... = ?f v \<cdot>\<^sub>v v + gs.lincomb ?f (?set_rows-{v}) - v" using lincomb_f by auto
      also have "... = (gs.lincomb ?f (?set_rows-{v}) + ?f v \<cdot>\<^sub>v v) + - v"
        unfolding gs.M.a_comm[OF lincomb_f_closed fv_v_closed] by auto
      also have "... = gs.lincomb ?f (?set_rows-{v}) + (?f v \<cdot>\<^sub>v v + - v)"
        by (rule gs.M.a_assoc, auto)
      also have "... = gs.lincomb ?f (?set_rows-{v}) + (?f v \<cdot>\<^sub>v v - v)" by auto
      also have "... = gs.lincomb ?g (?set_rows-{v}) + (?g v \<cdot>\<^sub>v v)"
        unfolding lincomb_fg fvv_gvv by auto
      also have "... = (?g v \<cdot>\<^sub>v v) + gs.lincomb ?g (?set_rows-{v})"
        by (rule gs.M.a_comm, auto, rule gs.lincomb_closed, insert set_rows_carrier, auto)
      also have "... = gs.lincomb ?g (?set_rows)"
        by (rule gs.lincomb_del2[symmetric], insert v_set_rows set_rows_carrier, auto)
      finally show ?thesis ..
    qed
    have g0: "?g \<in> ?set_rows \<rightarrow> {0}"
      by (rule gs.not_lindepD[of ?set_rows, OF ind_set_rows _ _ _ lincomb_0], auto)
    hence "?g (row B j) = 0" using v_set_rows unfolding v_def Pi_def by blast
    hence "?f (row B j) - 1 = 0" by auto
    hence "P $$ (j,j) - 1 = 0" using the_x j by auto
    thus "P$$(j,j) = 1" by auto
    fix i assume i: "i < m" and ji: "j \<noteq> i"
    have row_ij: "row B i \<noteq> row B j" using inj_on_rowB ji i j unfolding inj_on_def by fastforce
    have "row B i \<in> ?set_rows" using nth_rows i
      by (metis B_carrier carrier_matD(1) length_rows nth_mem)
    hence "?g (row B i) = 0" using g0 unfolding Pi_def by blast
    hence "?f (row B i) = 0" using row_ij by auto
    thus "P $$ (j, i) = 0" using the_x i by auto
  next
     show "dim_row P = m" and "dim_col P = m" using P_carrier unfolding carrier_mat_def by auto
   qed
qed

text \<open>This is the key lemma. It permits to change from the initial basis
@{term fs_init} to an arbitrary @{term gs} that has been computed by some
external tool. Here, two change-of-basis matrices U1 and U2 are required
to certify the change via the conditions prod1 and prod2.\<close>

lemma LLL_change_basis: assumes gs: "set gs \<subseteq> carrier_vec n"
  and len': "length gs = m"
  and U1: "U1 \<in> carrier_mat m m"
  and U2: "U2 \<in> carrier_mat m m"
  and prod1: "mat_of_rows n fs_init = U1 * mat_of_rows n gs"
  and prod2: "mat_of_rows n gs = U2 * mat_of_rows n fs_init"
shows "lattice_of gs = lattice_of fs_init" "LLL_with_assms n m gs \<alpha>"
proof -
  let ?i = "of_int :: int \<Rightarrow> int"
  have "U1 = map_mat ?i U1" by (intro eq_matI, auto)
  with prod1 have prod1: "mat_of_rows n fs_init = map_mat ?i U1 * mat_of_rows n gs" by simp
  have "U2 = map_mat ?i U2" by (intro eq_matI, auto)
  with prod2 have prod2: "mat_of_rows n gs = map_mat ?i U2 * mat_of_rows n fs_init" by simp
  have "lattice_of gs \<subseteq> lattice_of fs_init"
    by (rule mat_mult_sub_lattice[OF gs fs_init _ prod2], auto simp: U2 len len')
  moreover have "lattice_of gs \<supseteq> lattice_of fs_init"
    by (rule mat_mult_sub_lattice[OF fs_init gs _ prod1], auto simp: U1 len len')
  ultimately show "lattice_of gs = lattice_of fs_init" by blast
  show "LLL_with_assms n m gs \<alpha>"
  proof
    show "4/3 \<le> \<alpha>" by (rule \<alpha>)
    show "length gs = m" by fact
    show "lin_indep gs"
    proof -
      let ?fs = "map_mat rat_of_int (mat_of_rows n fs_init)"
      let ?gs = "map_mat rat_of_int (mat_of_rows n gs)"
      let ?U1 = "map_mat rat_of_int U1"
      let ?U2 = "map_mat rat_of_int U2"
      let ?P = "?U1 * ?U2"
      have rows_gs_eq: "rows ?gs = map of_int_hom.vec_hom gs"
      proof (rule nth_equalityI)
        fix i assume i: "i < length (rows ?gs)"
        have "rows ?gs ! i = row ?gs i" by (rule nth_rows, insert i, auto)
        also have "... = of_int_hom.vec_hom (gs ! i)"
          by (metis (mono_tags, lifting) gs i index_map_mat(2) length_map length_rows map_carrier_vec
              mat_of_rows_map mat_of_rows_row nth_map nth_mem rows_mat_of_rows subset_code(1))
        also have "... = map of_int_hom.vec_hom gs ! i"
          by (rule nth_map[symmetric], insert i, auto)
        finally show "rows ?gs ! i = map of_int_hom.vec_hom gs ! i" .
      qed (simp)
      have fs_hom: "?fs \<in> carrier_mat m n" unfolding carrier_mat_def using len by auto
      have gs_hom: "?gs \<in> carrier_mat m n" unfolding carrier_mat_def using len' by auto
      have U1U2: "U1 * U2 \<in> carrier_mat m m" by (meson assms(3) assms(4) mult_carrier_mat)
      have U1_hom: "?U1 \<in> carrier_mat m m" by (simp add: U1)
      have U2_hom: "?U2 \<in> carrier_mat m m" by (simp add: U2)
      have U1U2_hom: "?U1 * ?U2 \<in> carrier_mat m m" using U1 U2 by auto
      have Gs_U2Fs: "?gs = ?U2 * ?fs" using prod2
        by (metis U2 assms(6) len mat_of_rows_carrier(1) of_int_hom.mat_hom_mult)
      have fs_hom_eq: "?fs = ?P * ?fs"
        by (smt U1 U1U2 U2 assms(5) assms(6) assoc_mult_mat fs_hom
            map_carrier_mat of_int_hom.mat_hom_mult)
      have P_id: "?P = 1\<^sub>m m" by (rule mult_left_identity[OF U1U2_hom fs_hom_eq[symmetric]])
      hence "det (?U1) * det (?U2) = 1" by (smt U1_hom U2_hom det_mult det_one of_int_hom.hom_det)
      hence det_U2: "det ?U2 \<noteq> 0" and det_U1: "det ?U1 \<noteq> 0" by auto
      from det_non_zero_imp_unit[OF U2_hom det_U2, unfolded Units_def, of "()"]
      have inv_U2: "invertible_mat ?U2"
        using U1_hom U2_hom
        unfolding invertible_mat_def inverts_mat_def by (auto simp: ring_mat_def)
      interpret Rs: vectorspace class_ring "(gs.vs (gs.row_space ?gs))"
        by (rule gs.vector_space_row_space[OF gs_hom])
      interpret RS_fs: vectorspace class_ring "(gs.vs (gs.row_space (?fs)))"
        by (rule gs.vector_space_row_space[OF fs_hom])
      have submoduleGS: "submodule class_ring (gs.row_space ?gs) gs.V"
        and submoduleFS: "submodule class_ring (gs.row_space ?fs) gs.V"
        by (metis gs.row_space_def gs.span_is_submodule index_map_mat(3)
            mat_of_rows_carrier(3) rows_carrier)+
      have set_rows_fs_in: "set (rows ?fs) \<subseteq> gs.row_space ?fs"
        and rows_gs_row_space: "set (rows ?gs) \<subseteq> gs.row_space ?gs"
        unfolding gs.row_space_def
        by (metis gs.in_own_span index_map_mat(3) mat_of_rows_carrier(3) rows_carrier)+
      have Rs_fs_dim: "RS_fs.dim = m"
      proof -
        have "RS_fs.dim = card (set (rows ?fs))"
        proof (rule RS_fs.dim_basis)
          have "RS_fs.span (set (rows ?fs)) = gs.span (set (rows ?fs))"
            by (rule gs.span_li_not_depend[OF _ submoduleFS], simp add: set_rows_fs_in)
          also have "... = carrier (gs.vs (gs.row_space ?fs))"
           unfolding gs.row_space_def unfolding gs.carrier_vs_is_self by auto
          finally have "RS_fs.gen_set (set (rows ?fs))" by auto
          moreover have "RS_fs.lin_indpt (set (rows ?fs))"
          proof -
            have "module.lin_dep class_ring (gs.vs (gs.row_space ?fs)) (set (rows ?fs))
              = gs.lin_dep (set (rows ?fs))"
              by (rule gs.span_li_not_depend[OF _ submoduleFS], simp add: set_rows_fs_in)
            thus ?thesis using lin_dep unfolding gs.lin_indpt_list_def
              by (metis fs_init mat_of_rows_map rows_mat_of_rows)
          qed
          moreover have "set (rows ?fs) \<subseteq> carrier (gs.vs (gs.row_space ?fs))"
            by (simp add: set_rows_fs_in)
          ultimately show "RS_fs.basis (set (rows ?fs))" unfolding RS_fs.basis_def by simp
        qed (simp)
        also have "... = m"
          by (metis cof_vec_space.lin_indpt_list_def distinct_card fs_init len
              length_map lin_dep mat_of_rows_map rows_mat_of_rows)
        finally show ?thesis .
      qed
      have "gs.row_space ?fs = gs.row_space (?U2*?fs)"
        by (rule gs.row_space_is_preserved[symmetric, OF inv_U2 U2_hom fs_hom])
      also have "... = gs.row_space ?gs" using Gs_U2Fs by auto
      finally have "gs.row_space ?fs = gs.row_space ?gs" by auto
      hence "vectorspace.dim class_ring (gs.vs (gs.row_space ?gs)) = m"
        using Rs_fs_dim fs_hom_eq by auto
      hence Rs_dim_is_m: "Rs.dim = m" by blast
      have card_set_rows: "card (set (rows ?gs)) \<le> m"
        by (metis assms(2) card_length length_map rows_gs_eq)
      have Rs_basis: "Rs.basis (set (rows ?gs))"
      proof (rule Rs.dim_gen_is_basis)
        show "card (set (rows ?gs)) \<le> Rs.dim" using card_set_rows Rs_dim_is_m by auto
        have "Rs.span (set (rows ?gs)) = gs.span (set (rows ?gs))"
          by (rule gs.span_li_not_depend[OF rows_gs_row_space submoduleGS])
        also have "... = carrier (gs.vs (gs.row_space ?gs))"
           unfolding gs.row_space_def unfolding gs.carrier_vs_is_self by auto
        finally show "Rs.gen_set (set (rows ?gs))" by auto
        show "set (rows ?gs) \<subseteq> carrier (gs.vs (gs.row_space ?gs))" using rows_gs_row_space by auto
      qed (simp)
      hence indpt_Rs: "Rs.lin_indpt (set (rows ?gs))" unfolding Rs.basis_def by auto
      have gs_lin_indpt_rows: "gs.lin_indpt (set (rows ?gs))"
        (*Is there any automatic way to prove this?*)
        (*TODO: via gs.span_li_not_depend*)
      proof
        define N where "N \<equiv> (gs.row_space ?gs)"
        assume "gs.lin_dep (set (rows ?gs))"
        from this obtain A f v where A1: "finite A" and A2: "A \<subseteq> set (rows ?gs)"
          and lc_gs: "gs.lincomb f A = 0\<^sub>v n" and v: "v \<in> A" and fv: "f v \<noteq> 0"
          unfolding gs.lin_dep_def by blast
        have "gs.lincomb f A = module.lincomb (gs.vs N) f A"
          by (rule gs.lincomb_not_depend, insert submoduleGS A1 A2 gs.row_space_def
              rows_gs_row_space, auto simp add: N_def gs.row_space_def)
        also have "... = Rs.lincomb f A" using N_def by blast
        finally have "Rs.lin_dep (set (rows ?gs))"
          unfolding Rs.lin_dep_def using A1 A2 v fv lc_gs by auto
        thus False using indpt_Rs by auto
      qed
      have "card (set (rows ?gs)) \<ge> Rs.dim"
        by (rule Rs.gen_ge_dim, insert rows_gs_row_space Rs_basis, auto simp add: Rs.basis_def)
      hence card_m: "card (set (rows ?gs)) = m" using card_set_rows Rs_dim_is_m by auto
      have "distinct (map (of_int_hom.vec_hom::int vec \<Rightarrow> rat vec) gs)"
        using rows_gs_eq assms(2) card_m card_distinct by force
      moreover have "set (map of_int_hom.vec_hom gs) \<subseteq> Rn" using gs by auto
      ultimately show "gs.lin_indpt_list (map of_int_hom.vec_hom gs)"
        using gs_lin_indpt_rows
        unfolding rows_gs_eq gs.lin_indpt_list_def
        by auto
    qed
  qed
qed

lemma gauss_jordan_integer_inverse: fixes fs gs :: "int vec list"
  assumes gs: "set gs \<subseteq> carrier_vec n"
  and len_gs: "length gs = n"
  and fs: "set fs \<subseteq> carrier_vec n"
  and len_fs: "length fs = n"
  and gauss: "gauss_jordan_integer_inverse n (map_mat rat_of_int (mat_of_cols n fs))
    (map_mat rat_of_int (mat_of_cols n gs)) (1\<^sub>m n)" (is "gauss_jordan_integer_inverse _ ?fs ?gs _")
shows "\<exists> U. U \<in> carrier_mat n n \<and> mat_of_rows n gs = U * mat_of_rows n fs"
proof -
  have fs': "?fs \<in> carrier_mat n n" using fs len_fs by auto
  have gs': "?gs \<in> carrier_mat n n" using gs len_gs by auto
  note gauss = gauss[unfolded gauss_jordan_integer_inverse_def]
  from gauss obtain A where gauss: "gauss_jordan ?fs ?gs = (1\<^sub>m n, A)"
   and int: "list_all is_int_rat (concat (mat_to_list A))" by auto
  note gauss = gauss_jordan[OF fs' gs' gauss]
  note A = gauss(4)
  let ?A = "map_mat int_of_rat A"
  from gauss(2)[OF A] A
  have id: "?fs * A = ?gs" by auto
  let ?U = "(map_mat int_of_rat A)\<^sup>T"
  from A have U: "?U \<in> carrier_mat n n" by auto
  have "A = map_mat of_int ?A" using int[unfolded list_all_iff] A
    by (intro eq_matI, auto simp: mat_to_list_def)
  with id have "?gs = ?fs * map_mat of_int ?A" by auto
  also have "\<dots> = map_mat of_int (mat_of_cols n fs * ?A)"
    by (rule of_int_hom.mat_hom_mult[symmetric], insert fs' A, auto)
  finally have "mat_of_cols n fs * ?A = mat_of_cols n gs"
    using of_int_hom.mat_hom_inj by fastforce
  hence "(mat_of_cols n gs)\<^sup>T = (mat_of_cols n fs * ?A)\<^sup>T" by simp
  also have "\<dots> = ?U * (mat_of_cols n fs)\<^sup>T"
    by (rule transpose_mult, insert fs' A, auto)
  also have "(mat_of_cols n fs)\<^sup>T = mat_of_rows n fs"
    using fs len_fs unfolding mat_of_rows_def mat_of_cols_def
    by (intro eq_matI, auto)
  also have "(mat_of_cols n gs)\<^sup>T = mat_of_rows n gs"
    using gs len_gs unfolding mat_of_rows_def mat_of_cols_def
    by (intro eq_matI, auto)
  finally show ?thesis using U by blast
qed

lemma LLL_change_basis_mat_inverse: assumes gs: "set gs \<subseteq> carrier_vec n"
  and len': "length gs = n"
  and "m = n"
  and eq: "integer_equivalent n fs_init gs"
shows "lattice_of gs = lattice_of fs_init" "LLL_with_assms n m gs \<alpha>"
proof -
  from eq[unfolded integer_equivalent_def Let_def]
  have 1: "gauss_jordan_integer_inverse n (of_int_hom.mat_hom (mat_of_cols n fs_init))
   (of_int_hom.mat_hom (mat_of_cols n gs)) (1\<^sub>m n)"
    and 2: "gauss_jordan_integer_inverse n (of_int_hom.mat_hom (mat_of_cols n gs))
     (of_int_hom.mat_hom (mat_of_cols n fs_init)) (1\<^sub>m n)"
    by auto
  note len = len[unfolded \<open>m = n\<close>]
  from gauss_jordan_integer_inverse[OF gs len' fs_init len 1] \<open>m = n\<close>
  obtain U where U: "U \<in> carrier_mat m m" "mat_of_rows n gs = U * mat_of_rows n fs_init" by auto
  from gauss_jordan_integer_inverse[OF fs_init len gs len' 2] \<open>m = n\<close>
  obtain V where V: "V \<in> carrier_mat m m" "mat_of_rows n fs_init = V * mat_of_rows n gs" by auto
  from LLL_change_basis[OF gs len'[folded \<open>m = n\<close>] V(1) U(1) V(2) U(2)]
  show "lattice_of gs = lattice_of fs_init" "LLL_with_assms n m gs \<alpha>" by blast+
qed

end

text \<open>External solvers must deliver a reduced basis and optionally two
  matrices to convert between the input and the reduced basis. These two
  matrices are mandatory if the input matrix is not a square matrix.\<close>
consts external_lll_solver :: "integer \<times> integer \<Rightarrow> integer list list \<Rightarrow>
  integer list list \<times> (integer list list \<times> integer list list)option"

definition reduce_basis_external :: "rat \<Rightarrow> int vec list \<Rightarrow> int vec list" where
  "reduce_basis_external \<alpha> fs = (case fs of Nil \<Rightarrow> [] | Cons f _ \<Rightarrow> (let
    rb = reduce_basis \<alpha>;
    fsi = map (map integer_of_int o list_of_vec) fs;
    n = dim_vec f;
    m = length fs in
  case external_lll_solver (map_prod integer_of_int integer_of_int (quotient_of \<alpha>)) fsi of
    (gsi, co) \<Rightarrow>
    let gs = (map (vec_of_list o map int_of_integer) gsi) in
    if \<not> (length gs = m \<and> (\<forall> gi \<in> set gs. dim_vec gi = n)) then
      Code.abort (STR ''error in external LLL invocation: dimensions of reduced basis do not fit\<newline>input to external solver: ''
        + String.implode (show fs) + STR ''\<newline>\<newline>'') (\<lambda> _. rb fs)
     else
       case co of Some (u1i, u2i) \<Rightarrow> (let
         u1 = mat_of_rows_list m (map (map int_of_integer) u1i);
         u2 = mat_of_rows_list m (map (map int_of_integer) u2i);
         gs = (map (vec_of_list o map int_of_integer) gsi);
         Fs = mat_of_rows n fs;
         Gs = mat_of_rows n gs in
         if (dim_row u1 = m \<and> dim_col u1 = m \<and> dim_row u2 = m \<and> dim_col u2 = m
             \<and> Fs = u1 * Gs \<and> Gs = u2 * Fs)
          then rb gs
          else Code.abort (STR ''error in external lll invocation\<newline>f,g,u1,u2 are as follows\<newline>''
            + String.implode (show Fs) + STR ''\<newline>\<newline>''
            + String.implode (show Gs) + STR ''\<newline>\<newline>''
            + String.implode (show u1) + STR ''\<newline>\<newline>''
            + String.implode (show u2) + STR ''\<newline>\<newline>''
            ) (\<lambda> _. rb fs))
   | None \<Rightarrow> (if (n = m \<and> integer_equivalent n fs gs) then
       rb gs
      else Code.abort (STR ''error in external LLL invocation:\<newline>'' +
        (if n = m then STR ''reduced matrix does not span same lattice'' else
          STR ''no certificate only allowed for square matrices'')) (\<lambda> _. rb fs))
    ))"

definition short_vector_external :: "rat \<Rightarrow> int vec list \<Rightarrow> int vec" where
  "short_vector_external \<alpha> fs = (hd (reduce_basis_external \<alpha> fs))"

instance bool :: prime_card
  by (standard, auto)

context LLL_with_assms
begin

lemma reduce_basis_external: assumes res: "reduce_basis_external \<alpha> fs_init = fs"
  shows "reduced fs m" "LLL_invariant True m fs"
  (* "lattice_of fs = lattice_of fs_init" is part of LLL_invariant *)
proof (atomize(full), goal_cases)
  case 1
  show ?case
  proof (cases "LLL_Impl.reduce_basis \<alpha> fs_init = fs")
    case True
    from reduce_basis[OF this] show ?thesis by simp
  next
    case False
    show ?thesis
    proof (cases fs_init)
      case Nil
      with res have "fs = []" unfolding reduce_basis_external_def by auto
      with False Nil have False by (simp add: LLL_Impl.reduce_basis_def)
      thus ?thesis ..
    next
      case (Cons f rest)
      from Cons fs_init len have dim_fs_n: "dim_vec f = n" by auto
      let ?ext = "external_lll_solver (map_prod integer_of_int integer_of_int (quotient_of \<alpha>))
        (map (map integer_of_int \<circ> list_of_vec) fs_init)"
      note res = res[unfolded reduce_basis_external_def Cons Let_def list.case Code.abort_def dim_fs_n,
          folded Cons]
      from res False obtain gsi co where ext: "?ext = (gsi, co)" by (cases ?ext, auto)
      define gs where "gs = map (vec_of_list o map int_of_integer) gsi"
      note res = res[unfolded ext option.simps split len dim_fs_n, folded gs_def]
      from res False have not: "(\<not> (length gs = m \<and> (\<forall>gi\<in>set gs. dim_vec gi = n))) = False"
        by (auto split: if_splits)
      note res = res[unfolded this if_False]
      from not have gs: "set gs \<subseteq> carrier_vec n"
         and len_gs: "length gs = m" by auto
      have "lattice_of gs = lattice_of fs_init \<and> LLL_with_assms n m gs \<alpha> \<and> LLL_Impl.reduce_basis \<alpha> gs = fs"
      proof (cases co)
        case (Some pair)
        from res Some obtain u1i u2i where co: "co = Some (u1i, u2i)" by (cases co, auto)
        define u1 where "u1 = mat_of_rows_list m (map (map int_of_integer) u1i)"
        define u2 where "u2 = mat_of_rows_list m (map (map int_of_integer) u2i)"
        note res = res[unfolded co option.simps split len dim_fs_n, folded u1_def u2_def gs_def]
        from res False
        have u1: "u1 \<in> carrier_mat m m"
          and u2: "u2 \<in> carrier_mat m m"
          and prod1: "mat_of_rows n fs_init = u1 * mat_of_rows n gs"
          and prod2: "mat_of_rows n gs = u2 * mat_of_rows n fs_init"
          and gs_v: "LLL_Impl.reduce_basis \<alpha> gs = fs"
          by (auto split: if_splits)
        from LLL_change_basis[OF gs len_gs u1 u2 prod1 prod2] gs_v
        show ?thesis by auto
      next
        case None
        from res[unfolded None option.simps] False
        have id: "fs = LLL_Impl.reduce_basis \<alpha> gs" and nm: "n = m"
          and equiv: "integer_equivalent n fs_init gs"
          by (auto split: if_splits)
        from LLL_change_basis_mat_inverse[OF gs len_gs[folded nm] nm[symmetric] equiv] id
        show ?thesis by auto
      qed
      hence id: "lattice_of gs = lattice_of fs_init"
         and assms: "LLL_with_assms n m gs \<alpha>"
         and gs_fs: "LLL_Impl.reduce_basis \<alpha> gs = fs"  by auto
      from LLL_with_assms.reduce_basis[OF assms gs_fs]
      have red: "reduced fs m" and inv: "LLL.LLL_invariant n m gs \<alpha> True m fs" by auto
      from inv[unfolded LLL.LLL_invariant_def LLL.L_def id]
      have lattice: "lattice_of fs = lattice_of fs_init" by auto
      show ?thesis
      proof (intro conjI red lattice)
        show "LLL_invariant True m fs" using inv unfolding LLL.LLL_invariant_def LLL.L_def id .
      qed
    qed
  qed
qed

lemma short_vector_external: assumes res: "short_vector_external \<alpha> fs_init = v"
  and m0: "m \<noteq> 0"
shows "v \<in> carrier_vec n"
  "v \<in> L - {0\<^sub>v n}"
  "h \<in> L - {0\<^sub>v n} \<Longrightarrow> rat_of_int (sq_norm v) \<le> \<alpha> ^ (m - 1) * rat_of_int (sq_norm h)"
  "v \<noteq> 0\<^sub>v j"
proof (atomize(full), goal_cases)
  case 1
  obtain fs where red: "reduce_basis_external \<alpha> fs_init = fs" by blast
  from res[unfolded short_vector_external_def red] have v: "v = hd fs" by auto
  from reduce_basis_external[OF red]
  have red: "reduced fs m" and inv: "LLL_invariant True m fs" by blast+
  from basis_reduction_short_vector[OF inv v m0]
  show ?case by blast
qed
end

text \<open>Unspecified constant to easily enable/disable external lll solver in generated code\<close>

consts enable_external_lll_solver :: bool

definition short_vector_hybrid :: "rat \<Rightarrow> int vec list \<Rightarrow> int vec" where
  "short_vector_hybrid = (if enable_external_lll_solver then short_vector_external else short_vector)"

definition reduce_basis_hybrid :: "rat \<Rightarrow> int vec list \<Rightarrow> int vec list" where
  "reduce_basis_hybrid = (if enable_external_lll_solver then reduce_basis_external else reduce_basis)"

context LLL_with_assms
begin
lemma short_vector_hybrid: assumes res: "short_vector_hybrid \<alpha> fs_init = v"
  and m0: "m \<noteq> 0"
shows "v \<in> carrier_vec n"
  "v \<in> L - {0\<^sub>v n}"
  "h \<in> L - {0\<^sub>v n} \<Longrightarrow> rat_of_int (sq_norm v) \<le> \<alpha> ^ (m - 1) * rat_of_int (sq_norm h)"
  "v \<noteq> 0\<^sub>v j"
  using short_vector[of v, OF _ m0] short_vector_external[of v, OF _ m0]
    res[unfolded short_vector_hybrid_def]
  by (auto split: if_splits)

lemma reduce_basis_hybrid: assumes res: "reduce_basis_hybrid \<alpha> fs_init = fs"
  shows "reduced fs m" "LLL_invariant True m fs"
  using reduce_basis_external[of fs] reduce_basis[of fs] res[unfolded reduce_basis_hybrid_def]
  by (auto split: if_splits)
end

lemma lll_oracle_default_code[code]:
  "external_lll_solver x = Code.abort (STR ''no implementation of external_lll_solver specified'') (\<lambda> _. external_lll_solver x)"
  by simp

text \<open>By default, external solvers are disabled.
  For enabling an external solver, load it via a separate theory like \<^file>\<open>FPLLL_Solver.thy\<close>\<close>

overloading enable_external_lll_solver \<equiv> enable_external_lll_solver
begin
  definition enable_external_lll_solver where "enable_external_lll_solver = False"
end

definition "short_vector_test_hybrid xs =
  (let ys = map (vec_of_list o map int_of_integer) xs
   in integer_of_int (sq_norm (short_vector_hybrid (3/2) ys)))"

(* export_code short_vector_test_hybrid in Haskell module_name LLL *)
end


theory prop_76
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun count :: "Nat => Nat list => Nat" where
  "count x (Nil2) = Z"
  | "count x (Cons2 z ys) =
       (if equal2 x z then S (count x ys) else count x ys)"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster equal2 count append *)
  theorem x0 :
    "(~ (equal2 n m)) ==>
       ((count n (append xs (Cons2 m (Nil2)))) = (count n xs))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory Llength_lappend
  imports Main "$HIPSTER_HOME/IsaHipster"
    "types/Llist"
    "types/ENat"
    "Llength"
    "Lappend"
    "Eplus"
begin
setup Tactic_Data.set_coinduct_sledgehammer
setup Misc_Data.set_noisy
(*cohipster llength lappend eplus*)
(*Finds and proves the following in ca. 75 seconds*)
lemma lemma_ak [thy_expl]: "eplus (llength y) (llength z) = llength (lappend y z)"
 by (coinduction arbitrary: y z rule: ENat.ENat.coinduct_strong)
    auto

lemma lemma_al [thy_expl]: "llength (ltl (lappend z y)) = llength (ltl (lappend y z))"
 by (coinduction arbitrary: y z rule: ENat.ENat.coinduct_strong)
    (smt Llist.case_eq_if lemma_ai lemma_ak llength.disc(1) llength.disc(2) llength.sel ltl_def)

lemma lemma_am [thy_expl]: "llength (lappend z (LCons y x2)) = ESuc (llength (lappend z x2))"
 by (coinduction arbitrary: x2 y z rule: ENat.ENat.coinduct_strong)
    (metis ENat.distinct(1) ENat.sel Llength.lemma_a is_zero_def lappend.disc_iff(1) lemma_af lemma_ak llength.disc_iff(1))

lemma lemma_an [thy_expl]: "eplus (ESuc (llength y)) (llength z) = ESuc (llength (lappend y z))"
  by (coinduction arbitrary: y z rule: ENat.ENat.coinduct_strong)
     (auto simp add: lemma_ak)

lemma lemma_ao [thy_expl]: "llength (lappend z y) = llength (lappend y z)"
 by (coinduction arbitrary: y z rule: ENat.ENat.coinduct_strong)
    (metis lappend.disc_iff(1) lemma_al llength.disc_iff(1) llength.sel)
end


theory T123
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=10,timeout=86400]
oops
end


theory T123
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end