theory Incredible_Deduction
imports
  Main
  "HOL-Library.FSet"
  "HOL-Library.Stream"
  Incredible_Signatures
  "HOL-Eisbach.Eisbach"
begin

text \<open>This theory contains the definition for actual proof graphs, and their various possible
properties.\<close>

text \<open>The following locale first defines graphs, without edges.\<close>

locale Vertex_Graph =
  Port_Graph_Signature nodes inPorts outPorts
    for nodes :: "'node stream"
    and inPorts :: "'node \<Rightarrow> 'inPort fset"
    and outPorts :: "'node \<Rightarrow> 'outPort fset" +
  fixes vertices :: "'v fset"
  fixes nodeOf :: "'v \<Rightarrow> 'node"
begin
  fun valid_out_port where "valid_out_port (v,p) \<longleftrightarrow> v |\<in>| vertices \<and> p |\<in>| outPorts (nodeOf v)"
  fun valid_in_port  where "valid_in_port (v,p) \<longleftrightarrow> v |\<in>| vertices \<and> p |\<in>| inPorts (nodeOf v)"

  fun terminal_node where
    "terminal_node n \<longleftrightarrow> outPorts n = {||}"
  fun terminal_vertex where
    "terminal_vertex v \<longleftrightarrow> v |\<in>| vertices \<and> terminal_node (nodeOf v)"
end

text \<open>And now we add the edges. This allows us to define paths and scopes.\<close>

type_synonym ('v, 'outPort, 'inPort) edge = "(('v \<times> 'outPort) \<times> ('v \<times> 'inPort))"

locale Pre_Port_Graph =
  Vertex_Graph nodes inPorts outPorts vertices nodeOf
    for nodes :: "'node stream"
    and inPorts :: "'node \<Rightarrow> 'inPort fset"
    and outPorts :: "'node \<Rightarrow> 'outPort fset"
    and vertices :: "'v fset"
    and nodeOf :: "'v \<Rightarrow> 'node" +
  fixes edges :: "('v, 'outPort, 'inPort) edge set"
begin
  fun edge_begin :: "(('v \<times> 'outPort) \<times> ('v \<times> 'inPort)) \<Rightarrow> 'v" where
    "edge_begin ((v1,p1),(v2,p2)) = v1"
  fun edge_end :: "(('v \<times> 'outPort) \<times> ('v \<times> 'inPort)) \<Rightarrow> 'v" where
    "edge_end ((v1,p1),(v2,p2)) = v2"

  lemma edge_begin_tup: "edge_begin x = fst (fst x)" by (metis edge_begin.simps prod.collapse)
  lemma edge_end_tup: "edge_end x = fst (snd x)" by (metis edge_end.simps prod.collapse)

  inductive path :: "'v \<Rightarrow> 'v \<Rightarrow> ('v, 'outPort, 'inPort) edge list \<Rightarrow> bool"   where
    path_empty: "path v v []" |
    path_cons: "e \<in> edges \<Longrightarrow> path (edge_end e) v' pth \<Longrightarrow> path (edge_begin e) v' (e#pth)"

  inductive_simps path_cons_simp': "path v v' (e#pth)"
  inductive_simps path_empty_simp[simp]: "path v v' []"
  lemma path_cons_simp: "path v v' (e # pth) \<longleftrightarrow> fst (fst e) = v \<and> e \<in> edges \<and> path (fst (snd e)) v' pth"
    by(auto simp add: path_cons_simp', metis prod.collapse)

  lemma path_appendI: "path v v' pth1 \<Longrightarrow> path v' v'' pth2 \<Longrightarrow> path v v'' (pth1@pth2)"
    by (induction pth1 arbitrary: v) (auto simp add: path_cons_simp )

  lemma path_split: "path v v' (pth1@[e]@pth2) \<longleftrightarrow> path v (edge_end e) (pth1@[e]) \<and> path (edge_end e) v' pth2"
    by (induction pth1 arbitrary: v) (auto simp add: path_cons_simp edge_end_tup intro: path_empty)

  lemma path_split2: "path v v' (pth1@(e#pth2)) \<longleftrightarrow> path v (edge_begin e) pth1 \<and> path (edge_begin e) v' (e#pth2)"
    by (induction pth1 arbitrary: v) (auto simp add: path_cons_simp edge_begin_tup intro: path_empty)

  lemma path_snoc: "path v v' (pth1@[e]) \<longleftrightarrow> e \<in> edges \<and> path v (edge_begin e) pth1 \<and> edge_end e = v'"
    by (auto simp add: path_split2 path_cons_simp edge_end_tup edge_begin_tup)

  inductive_set scope :: "'v \<times> 'inPort \<Rightarrow> 'v set" for ps where
    "v |\<in>| vertices \<Longrightarrow> (\<And> pth v'.  path v v' pth \<Longrightarrow> terminal_vertex v' \<Longrightarrow> ps \<in> snd ` set pth)
    \<Longrightarrow> v \<in> scope ps"

  lemma scope_find:
    assumes "v \<in> scope ps"
    assumes "terminal_vertex v'"
    assumes "path v v' pth"
    shows "ps \<in> snd ` set pth"
  using assms by (auto simp add: scope.simps)

  lemma snd_set_split:
    assumes "ps \<in> snd ` set pth"
    obtains pth1 pth2 e  where "pth = pth1@[e]@pth2" and "snd e = ps" and "ps \<notin> snd ` set pth1"
    using assms
    proof (atomize_elim, induction pth)
      case Nil thus ?case by simp
    next
      case (Cons e pth)
      show ?case
      proof(cases "snd e = ps")
        case True
        hence "e # pth = [] @ [e] @ pth \<and> snd e = ps \<and> ps \<notin> snd ` set []" by auto
        thus ?thesis by (intro exI)
      next
        case False
        with Cons(2)
        have "ps \<in> snd ` set pth" by auto
        from Cons.IH[OF this this]
        obtain pth1 e' pth2 where "pth = pth1 @ [e'] @ pth2 \<and> snd e' = ps \<and> ps \<notin> snd ` set pth1" by auto
        with False
        have "e#pth = (e# pth1) @ [e'] @ pth2 \<and> snd e' = ps \<and> ps \<notin> snd ` set (e#pth1)" by auto
        thus ?thesis by blast
      qed
    qed

  lemma scope_split:
    assumes "v \<in> scope ps"
    assumes "path v v' pth"
    assumes "terminal_vertex v'"
    obtains pth1 e pth2
    where "pth = (pth1@[e])@pth2" and "path v (fst ps) (pth1@[e])" and "path (fst ps) v' pth2" and "snd e = ps" and "ps \<notin> snd ` set pth1"
  proof-
    from assms
    have "ps \<in> snd ` set pth" by (auto simp add: scope.simps)
    then obtain pth1 pth2 e  where "pth = pth1@[e]@pth2" and "snd e = ps" and "ps \<notin> snd ` set pth1" by (rule snd_set_split)

    from \<open>path _ _ _\<close> and \<open>pth = pth1@[e]@pth2\<close>
    have "path v (edge_end e) (pth1@[e])" and "path (edge_end e) v' pth2" by (metis path_split)+
    show thesis
    proof(rule that)
      show "pth = (pth1@[e])@pth2" using \<open>pth= _\<close> by simp
      show "path v (fst ps) (pth1@[e])" using \<open>path v (edge_end e) (pth1@[e])\<close>  \<open>snd e = ps\<close> by (simp add: edge_end_tup)
      show "path (fst ps) v' pth2" using \<open>path (edge_end e) v' pth2\<close>  \<open>snd e = ps\<close> by (simp add: edge_end_tup)
      show "ps \<notin> snd ` set pth1" by fact
      show "snd e = ps" by fact
    qed
  qed
end

text \<open>This adds well-formedness conditions to the edges and vertices.\<close>

locale Port_Graph = Pre_Port_Graph +
  assumes valid_nodes: "nodeOf ` fset vertices  \<subseteq> sset nodes"
  assumes valid_edges: "\<forall> (ps1,ps2) \<in> edges. valid_out_port ps1 \<and> valid_in_port ps2"
begin
  lemma snd_set_path_verties: "path v v' pth \<Longrightarrow> fst ` snd ` set pth \<subseteq> fset vertices"
    apply (induction rule: path.induct)
    apply auto
    apply (metis valid_in_port.elims(2) edge_end.simps notin_fset case_prodD valid_edges)
    done

  lemma fst_set_path_verties: "path v v' pth \<Longrightarrow> fst ` fst ` set pth \<subseteq> fset vertices"
    apply (induction rule: path.induct)
    apply auto
    apply (metis valid_out_port.elims(2) edge_begin.simps notin_fset case_prodD valid_edges)
    done
end

text \<open>A pruned graph is one where every node has a path to a terminal node (which will be the conclusions).\<close>

locale Pruned_Port_Graph = Port_Graph +
  assumes pruned: "\<And>v.  v |\<in>| vertices \<Longrightarrow> (\<exists>pth v'. path v v' pth \<and> terminal_vertex v')"
begin
  lemma scopes_not_refl:
    assumes "v |\<in>| vertices"
    shows "v \<notin> scope (v,p)"
  proof(rule notI)
    assume "v \<in> scope (v,p)"

    from pruned[OF assms]
    obtain pth t where "terminal_vertex t" and "path v t pth" and least: "\<forall> pth'. path v t pth' \<longrightarrow> length pth \<le> length pth'"
      by atomize_elim (auto simp del: terminal_vertex.simps elim: ex_has_least_nat)

    from scope_split[OF \<open>v \<in> scope (v,p)\<close> \<open>path v t pth\<close> \<open>terminal_vertex t\<close>]
    obtain pth1 e pth2 where "pth = (pth1 @ [e]) @ pth2" "path v t pth2" by (metis fst_conv)

    from this(2) least
    have "length pth \<le> length pth2" by auto
    with \<open>pth = _\<close>
    show False by auto
  qed

  text \<open>This lemma can be found in \cite{incredible}, but it is otherwise inconsequential.\<close>
  lemma scopes_nest:
    fixes ps1 ps2
    shows "scope ps1 \<subseteq> scope ps2 \<or> scope ps2 \<subseteq> scope ps1 \<or> scope ps1 \<inter> scope ps2 = {}"
  proof(cases "ps1 = ps2")
    assume "ps1 \<noteq> ps2"
    {
    fix v
    assume "v \<in> scope ps1 \<inter> scope ps2"
    hence "v |\<in>| vertices" using scope.simps by auto
    then obtain pth t where "path v t pth" and "terminal_vertex t" using pruned by blast

    from \<open>path v t pth\<close> and \<open>terminal_vertex t\<close> and \<open>v \<in> scope ps1 \<inter> scope ps2\<close>
    obtain pth1a e1 pth1b  where "pth = (pth1a@[e1])@pth1b" and "path v (fst ps1) (pth1a@[e1])" and "snd e1 = ps1" and "ps1 \<notin> snd ` set pth1a"
      by (auto elim: scope_split)

    from \<open>path v t pth\<close> and \<open>terminal_vertex t\<close> and \<open>v \<in> scope ps1 \<inter> scope ps2\<close>
    obtain pth2a e2 pth2b  where "pth = (pth2a@[e2])@pth2b" and "path v (fst ps2) (pth2a@[e2])" and "snd e2 = ps2" and "ps2 \<notin> snd ` set pth2a"
      by (auto elim: scope_split)

    from \<open>pth = (pth1a@[e1])@pth1b\<close> \<open>pth = (pth2a@[e2])@pth2b\<close>
    have "set pth1a \<subseteq> set pth2a \<or> set pth2a \<subseteq> set pth1a" by (auto simp add: append_eq_append_conv2)
    hence "scope ps1 \<subseteq> scope ps2 \<or> scope ps2 \<subseteq> scope ps1"
    proof
      assume "set pth1a \<subseteq> set pth2a" with \<open>ps2 \<notin> _\<close>
      have "ps2 \<notin> snd ` set (pth1a@[e1])" using \<open>ps1 \<noteq> ps2\<close> \<open>snd e1 = ps1\<close> by auto

      have "scope ps1 \<subseteq> scope ps2"
      proof
        fix v'
        assume "v' \<in> scope ps1"
        hence "v' |\<in>| vertices" using scope.simps by auto
        thus "v' \<in> scope ps2"
        proof(rule scope.intros)
          fix pth' t'
          assume "path v' t' pth'" and "terminal_vertex t'"
          with \<open>v' \<in> scope ps1\<close>
          obtain pth3a e3 pth3b where "pth' = (pth3a@[e3])@pth3b" and "path (fst ps1) t' pth3b"
            by (auto elim: scope_split)

          have "path v t' ((pth1a@[e1]) @ pth3b)" using \<open>path v (fst ps1) (pth1a@[e1])\<close> and \<open>path (fst ps1) t' pth3b\<close>
            by (rule path_appendI)
          with \<open>terminal_vertex t'\<close> \<open>v \<in> _\<close>
          have "ps2 \<in> snd ` set ((pth1a@[e1]) @ pth3b)" by (meson IntD2 scope.cases)
          hence "ps2 \<in> snd ` set pth3b" using \<open>ps2 \<notin> snd ` set (pth1a@[e1])\<close> by auto
          thus "ps2 \<in> snd ` set pth'" using \<open>pth'=_\<close> by auto
        qed
      qed
      thus ?thesis by simp
    next
      assume "set pth2a \<subseteq> set pth1a" with \<open>ps1 \<notin> _\<close>
      have "ps1 \<notin> snd ` set (pth2a@[e2])" using \<open>ps1 \<noteq> ps2\<close> \<open>snd e2 = ps2\<close> by auto

      have "scope ps2 \<subseteq> scope ps1"
      proof
        fix v'
        assume "v' \<in> scope ps2"
        hence "v' |\<in>| vertices" using scope.simps by auto
        thus "v' \<in> scope ps1"
        proof(rule scope.intros)
          fix pth' t'
          assume "path v' t' pth'" and "terminal_vertex t'"
          with \<open>v' \<in> scope ps2\<close>
          obtain pth3a e3 pth3b where "pth' = (pth3a@[e3])@pth3b" and "path (fst ps2) t' pth3b"
            by (auto elim: scope_split)

          have "path v t' ((pth2a@[e2]) @ pth3b)" using \<open>path v (fst ps2) (pth2a@[e2])\<close> and \<open>path (fst ps2) t' pth3b\<close>
            by (rule path_appendI)
          with \<open>terminal_vertex t'\<close> \<open>v \<in> _\<close>
          have "ps1 \<in> snd ` set ((pth2a@[e2]) @ pth3b)" by (meson IntD1 scope.cases)
          hence "ps1 \<in> snd ` set pth3b" using \<open>ps1 \<notin> snd ` set (pth2a@[e2])\<close> by auto
          thus "ps1 \<in> snd ` set pth'" using \<open>pth'=_\<close> by auto
        qed
      qed
      thus ?thesis by simp
    qed
    }
    thus ?thesis by blast
  qed simp
end

text \<open>A well-scoped graph is one where a port marked to be a local hypothesis is only connected to
the corresponding input port, either directly or via a path. It must not be, however, that there is
a a path from such a hypothesis to a terminal node that does not pass by the dedicated input port;
this is expressed via scopes.
\<close>

locale Scoped_Graph = Port_Graph + Port_Graph_Signature_Scoped
locale Well_Scoped_Graph = Scoped_Graph +
  assumes well_scoped: "((v\<^sub>1,p\<^sub>1),(v\<^sub>2,p\<^sub>2)) \<in> edges \<Longrightarrow> hyps (nodeOf v\<^sub>1) p\<^sub>1 = Some p' \<Longrightarrow> (v\<^sub>2,p\<^sub>2) = (v\<^sub>1,p') \<or> v\<^sub>2 \<in> scope (v\<^sub>1,p')"

context Scoped_Graph
begin

definition hyps_free where
  "hyps_free pth = (\<forall> v\<^sub>1 p\<^sub>1 v\<^sub>2 p\<^sub>2. ((v\<^sub>1,p\<^sub>1),(v\<^sub>2,p\<^sub>2)) \<in> set pth \<longrightarrow> hyps (nodeOf v\<^sub>1) p\<^sub>1 = None)"

lemma hyps_free_Nil[simp]: "hyps_free []" by (simp add: hyps_free_def)

lemma hyps_free_Cons[simp]: "hyps_free (e#pth) \<longleftrightarrow> hyps_free pth \<and> hyps (nodeOf (fst (fst e))) (snd (fst e)) = None"
  by (auto simp add: hyps_free_def) (metis prod.collapse)

lemma path_vertices_shift:
  assumes "path v v' pth"
  shows "map fst (map fst pth)@[v'] = v#map fst (map snd pth)"
using assms by induction auto

inductive terminal_path where
    terminal_path_empty: "terminal_vertex v \<Longrightarrow> terminal_path v v []" |
    terminal_path_cons: "((v\<^sub>1,p\<^sub>1),(v\<^sub>2,p\<^sub>2)) \<in> edges \<Longrightarrow> terminal_path v\<^sub>2 v' pth \<Longrightarrow> hyps (nodeOf v\<^sub>1) p\<^sub>1 = None \<Longrightarrow> terminal_path v\<^sub>1 v' (((v\<^sub>1,p\<^sub>1),(v\<^sub>2,p\<^sub>2))#pth)"

lemma terminal_path_is_path:
  assumes "terminal_path v v' pth"
  shows "path v v' pth"
using assms by induction (auto simp add: path_cons_simp)

lemma terminal_path_is_hyps_free:
  assumes "terminal_path v v' pth"
  shows "hyps_free pth"
using assms by induction (auto simp add: hyps_free_def)

lemma terminal_path_end_is_terminal:
  assumes "terminal_path v v' pth"
  shows "terminal_vertex v'"
using assms by induction

lemma terminal_pathI:
  assumes "path v v' pth"
  assumes "hyps_free pth"
  assumes "terminal_vertex v'"
  shows "terminal_path v v' pth"
using assms
by induction (auto intro: terminal_path.intros)
end

text \<open>An acyclic graph is one where there are no non-trivial cyclic paths (disregarding
edges that are local hypotheses -- these are naturally and benignly cyclic).\<close>

locale Acyclic_Graph = Scoped_Graph +
  assumes hyps_free_acyclic: "path v v pth \<Longrightarrow> hyps_free pth \<Longrightarrow> pth = []"
begin
lemma hyps_free_vertices_distinct:
  assumes "terminal_path v v' pth"
  shows "distinct (map fst (map fst pth)@[v'])"
using assms
proof(induction v v' pth)
  case terminal_path_empty
  show ?case by simp
next
  case (terminal_path_cons v\<^sub>1 p\<^sub>1 v\<^sub>2 p\<^sub>2 v' pth)
  note terminal_path_cons.IH
  moreover
  have "v\<^sub>1 \<notin> fst ` fst ` set pth"
  proof
    assume "v\<^sub>1 \<in> fst ` fst ` set pth"
    then obtain pth1 e' pth2 where "pth = pth1@[e']@pth2" and "v\<^sub>1 = fst (fst e')"
      apply (atomize_elim)
      apply (induction pth)
      apply (solves simp)
      apply (auto)
      apply (solves \<open>rule exI[where x = "[]"]; simp\<close>)
      apply (metis Cons_eq_appendI image_eqI prod.sel(1))
      done
    with terminal_path_is_path[OF \<open>terminal_path v\<^sub>2 v' pth\<close>]
    have "path v\<^sub>2 v\<^sub>1 pth1" by (simp add:  path_split2 edge_begin_tup)
    with \<open>((v\<^sub>1, p\<^sub>1), (v\<^sub>2, p\<^sub>2)) \<in> _\<close>
    have "path v\<^sub>1 v\<^sub>1 (((v\<^sub>1, p\<^sub>1), (v\<^sub>2, p\<^sub>2)) # pth1)" by (simp add: path_cons_simp)
    moreover
    from terminal_path_is_hyps_free[OF \<open>terminal_path v\<^sub>2 v' pth\<close>]
         \<open>hyps (nodeOf v\<^sub>1) p\<^sub>1 = None\<close>
         \<open>pth = pth1@[e']@pth2\<close>
    have "hyps_free(((v\<^sub>1, p\<^sub>1), (v\<^sub>2, p\<^sub>2)) # pth1)"
      by (auto simp add: hyps_free_def)
    ultimately
    show False  using hyps_free_acyclic by blast
  qed
  moreover
  have "v\<^sub>1 \<noteq> v'"
    using hyps_free_acyclic path_cons terminal_path_cons.hyps(1) terminal_path_cons.hyps(2) terminal_path_cons.hyps(3) terminal_path_is_hyps_free terminal_path_is_path by fastforce
  ultimately
  show ?case by (auto simp add: comp_def)
qed

lemma hyps_free_vertices_distinct':
  assumes "terminal_path v v' pth"
  shows "distinct (v # map fst (map snd pth))"
  using hyps_free_vertices_distinct[OF assms]
  unfolding path_vertices_shift[OF terminal_path_is_path[OF assms]]
  .

lemma hyps_free_limited:
  assumes "terminal_path v v' pth"
  shows "length pth \<le> fcard vertices"
proof-
  have "length pth = length (map fst (map fst pth))" by simp
  also
  from hyps_free_vertices_distinct[OF assms]
  have "distinct (map fst (map fst pth))" by simp
  hence "length (map fst (map fst pth)) = card (set (map fst (map fst pth)))"
    by (rule distinct_card[symmetric])
  also have "\<dots> \<le> card (fset vertices)"
  proof (rule card_mono[OF finite_fset])
    from assms(1)
    show "set (map fst (map fst pth)) \<subseteq> fset vertices"
      by (induction v v' pth) (auto, metis valid_edges notin_fset case_prodD valid_out_port.simps)
  qed
  also have "\<dots> = fcard vertices" by (simp add: fcard.rep_eq)
  finally show ?thesis.
qed

lemma hyps_free_path_not_in_scope:
  assumes "terminal_path v t pth"
  assumes "(v',p') \<in> snd ` set pth"
  shows   "v' \<notin> scope (v, p)"
proof
  assume "v' \<in> scope (v,p)"

  from \<open>(v',p') \<in> snd ` set pth\<close>
  obtain pth1 pth2 e  where "pth = pth1@[e]@pth2" and "snd e = (v',p')" by (rule snd_set_split)
  from terminal_path_is_path[OF assms(1), unfolded \<open>pth = _ \<close>] \<open>snd e = _\<close>
  have "path v v' (pth1@[e])" and "path v' t pth2" unfolding path_split by (auto simp add: edge_end_tup)

  from \<open>v' \<in> scope (v,p)\<close> terminal_path_end_is_terminal[OF assms(1)] \<open>path v' t pth2\<close>
  have "(v,p) \<in> snd ` set pth2" by (rule scope_find)
  then obtain pth2a e' pth2b  where "pth2 = pth2a@[e']@pth2b" and "snd e' = (v,p)"  by (rule snd_set_split)
  from \<open>path v' t pth2\<close>[unfolded \<open>pth2 = _ \<close>] \<open>snd e' = _\<close>
  have "path v' v (pth2a@[e'])" and "path v t pth2b" unfolding path_split by (auto simp add: edge_end_tup)

  from \<open>path v v' (pth1@[e])\<close> \<open>path v' v (pth2a@[e'])\<close>
  have "path v v ((pth1@[e])@(pth2a@[e']))" by (rule path_appendI)
  moreover
  from terminal_path_is_hyps_free[OF assms(1)] \<open>pth = _\<close> \<open>pth2 = _\<close>
  have "hyps_free ((pth1@[e])@(pth2a@[e']))" by (auto simp add: hyps_free_def)
  ultimately
  have "((pth1@[e])@(pth2a@[e'])) = []" by (rule hyps_free_acyclic)
  thus False by simp
qed

end

text \<open>A saturated graph is one where every input port is incident to an edge.\<close>

locale Saturated_Graph = Port_Graph +
  assumes saturated: "valid_in_port (v,p) \<Longrightarrow> \<exists> e \<in> edges . snd e = (v,p)"

text \<open>These four conditions make up a well-shaped graph.\<close>

locale Well_Shaped_Graph =  Well_Scoped_Graph + Acyclic_Graph + Saturated_Graph + Pruned_Port_Graph

text \<open>Next we demand an instantiation. This consists of a unique natural number per vertex,
in order to rename the local constants apart, and furthermore a substitution per block
which instantiates the schematic formulas given in @{term Labeled_Signature}.\<close>

locale Instantiation =
  Vertex_Graph nodes _ _ vertices _ +
  Labeled_Signature nodes  _ _ _ labelsIn labelsOut +
  Abstract_Formulas freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP
  for nodes :: "'node stream" and edges :: "('vertex, 'outPort, 'inPort) edge set" and vertices :: "'vertex fset" and labelsIn :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'form" and labelsOut :: "'node \<Rightarrow> 'outPort \<Rightarrow> 'form"
  and  freshenLC :: "nat \<Rightarrow> 'var \<Rightarrow> 'var"
    and renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> 'form \<Rightarrow> 'form"
    and lconsts :: "'form \<Rightarrow> 'var set"
    and closed :: "'form \<Rightarrow> bool"
    and subst :: "'subst \<Rightarrow> 'form \<Rightarrow> 'form"
    and subst_lconsts :: "'subst \<Rightarrow> 'var set"
    and subst_renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> ('subst \<Rightarrow> 'subst)"
    and anyP :: "'form" +
  fixes vidx :: "'vertex \<Rightarrow> nat"
    and inst :: "'vertex \<Rightarrow> 'subst"
  assumes vidx_inj: "inj_on vidx (fset vertices)"
begin
  definition labelAtIn :: "'vertex \<Rightarrow> 'inPort \<Rightarrow> 'form"  where
    "labelAtIn v p = subst (inst v) (freshen (vidx v) (labelsIn (nodeOf v) p))"
  definition labelAtOut :: "'vertex \<Rightarrow> 'outPort \<Rightarrow> 'form"  where
    "labelAtOut v p = subst (inst v) (freshen (vidx v) (labelsOut (nodeOf v) p))"
end

text \<open>A solution is an instantiation where on every edge, both incident ports are labeld with
the same formula.\<close>

locale Solution =
  Instantiation _ _ _ _ _ edges for edges :: "(('vertex \<times> 'outPort) \<times> 'vertex \<times> 'inPort) set" +
  assumes solved: "((v\<^sub>1,p\<^sub>1),(v\<^sub>2,p\<^sub>2)) \<in> edges \<Longrightarrow> labelAtOut v\<^sub>1 p\<^sub>1 = labelAtIn v\<^sub>2 p\<^sub>2"

locale Proof_Graph =  Well_Shaped_Graph + Solution

text \<open>If we have locally scoped constants, we demand that only blocks in the scope of the
corresponding input port may mention such a locally scoped variable in its substitution.\<close>

locale Well_Scoped_Instantiation =
   Pre_Port_Graph  nodes inPorts outPorts vertices nodeOf edges +
   Instantiation  inPorts outPorts nodeOf hyps nodes edges  vertices labelsIn labelsOut freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP vidx inst +
   Port_Graph_Signature_Scoped_Vars nodes inPorts outPorts freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP local_vars
   for freshenLC :: "nat \<Rightarrow> 'var \<Rightarrow> 'var"
    and renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> 'form \<Rightarrow> 'form"
    and lconsts :: "'form \<Rightarrow> 'var set"
    and closed :: "'form \<Rightarrow> bool"
    and subst :: "'subst \<Rightarrow> 'form \<Rightarrow> 'form"
    and subst_lconsts :: "'subst \<Rightarrow> 'var set"
    and subst_renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> ('subst \<Rightarrow> 'subst)"
    and anyP :: "'form"
    and inPorts :: "'node \<Rightarrow> 'inPort fset"
    and outPorts :: "'node \<Rightarrow> 'outPort fset"
    and nodeOf :: "'vertex \<Rightarrow> 'node"
    and hyps :: "'node \<Rightarrow> 'outPort \<Rightarrow> 'inPort option"
    and nodes :: "'node stream"
    and vertices :: "'vertex fset"
    and labelsIn :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'form"
    and labelsOut :: "'node \<Rightarrow> 'outPort \<Rightarrow> 'form"
    and vidx :: "'vertex \<Rightarrow> nat"
    and inst :: "'vertex \<Rightarrow> 'subst"
    and edges :: "('vertex, 'outPort, 'inPort) edge set"
    and local_vars :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'var set" +
  assumes well_scoped_inst:
    "valid_in_port (v,p) \<Longrightarrow>
     var \<in> local_vars (nodeOf v) p \<Longrightarrow>
     v' |\<in>| vertices \<Longrightarrow>
     freshenLC (vidx v) var \<in> subst_lconsts (inst v') \<Longrightarrow>
     v' \<in> scope (v,p)"
begin
  lemma out_of_scope: "valid_in_port (v,p) \<Longrightarrow> v' |\<in>| vertices \<Longrightarrow> v' \<notin> scope (v,p) \<Longrightarrow> freshenLC (vidx v) ` local_vars (nodeOf v) p \<inter> subst_lconsts (inst v') = {}"
    using well_scoped_inst by auto
end

text \<open>The following locale assembles all these conditions.\<close>

locale Scoped_Proof_Graph =
  Instantiation  inPorts outPorts nodeOf hyps nodes edges  vertices labelsIn labelsOut freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP vidx inst +
  Well_Shaped_Graph  nodes inPorts outPorts vertices nodeOf edges hyps  +
  Solution inPorts outPorts nodeOf hyps nodes vertices  labelsIn labelsOut freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP vidx inst edges +
  Well_Scoped_Instantiation  freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP inPorts outPorts nodeOf hyps  nodes vertices labelsIn labelsOut vidx inst edges local_vars
   for freshenLC :: "nat \<Rightarrow> 'var \<Rightarrow> 'var"
    and renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> 'form \<Rightarrow> 'form"
    and lconsts :: "'form \<Rightarrow> 'var set"
    and closed :: "'form \<Rightarrow> bool"
    and subst :: "'subst \<Rightarrow> 'form \<Rightarrow> 'form"
    and subst_lconsts :: "'subst \<Rightarrow> 'var set"
    and subst_renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> ('subst \<Rightarrow> 'subst)"
    and anyP :: "'form"
    and inPorts :: "'node \<Rightarrow> 'inPort fset"
    and outPorts :: "'node \<Rightarrow> 'outPort fset"
    and nodeOf :: "'vertex \<Rightarrow> 'node"
    and hyps :: "'node \<Rightarrow> 'outPort \<Rightarrow> 'inPort option"
    and nodes :: "'node stream"
    and vertices :: "'vertex fset"
    and labelsIn :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'form"
    and labelsOut :: "'node \<Rightarrow> 'outPort \<Rightarrow> 'form"
    and vidx :: "'vertex \<Rightarrow> nat"
    and inst :: "'vertex \<Rightarrow> 'subst"
    and edges :: "('vertex, 'outPort, 'inPort) edge  set"
    and local_vars :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'var set"

end


subsection \<open> Oblivious transfer constructed from ETPs \<close>

text\<open>Here we construct the OT protocol based on ETPs given in \cite{DBLP:books/sp/17/Lindell17} (Chapter 4) and prove
semi honest security for both parties. We show information theoretic security for Party 1 and reduce the security of
Party 2 to the HCP assumption.\<close>

theory ETP_OT imports
  "HOL-Number_Theory.Cong"
  ETP
  OT_Functionalities
  Semi_Honest
begin

fun valid_bool_inputs_ot12 :: "bool inputs_ot12 list \<Rightarrow> bool"
  where "valid_bool_inputs_ot12 [M2 (b0, b1), C1 \<sigma>] = True"

type_synonym 'range viewP1 = "('range \<times> 'range) spmf"
type_synonym 'range dist1 = "(bool inputs_ot12 \<times> 'range \<times> 'range) \<Rightarrow> bool spmf"
type_synonym 'index viewP2 = "('index \<times> (bool \<times> bool)) spmf"
type_synonym 'index dist2 = "(bool inputs_ot12 \<times> 'index \<times> bool \<times> bool) \<Rightarrow> bool spmf"
type_synonym ('index, 'range) advP2 = "'index dist2 \<Rightarrow> 'index \<Rightarrow> bool inputs_ot12 \<Rightarrow> bool outputs_ot12 \<Rightarrow> 'range \<Rightarrow> bool spmf"

lemma if_False_True: "(if x then False else \<not> False) \<longleftrightarrow> (if x then False else True)"
  by simp

lemma if_then_True [simp]: "(if b then True else x) \<longleftrightarrow> (\<not> b \<longrightarrow> x)"
  by simp

lemma if_else_True [simp]: "(if b then x else True) \<longleftrightarrow> (b \<longrightarrow> x)"
  by simp

lemma inj_on_Not [simp]: "inj_on Not A"
  by(auto simp add: inj_on_def)

locale ETP_ot12_base = etp: etp I domain range F F\<^sub>i\<^sub>n\<^sub>v B
  for I :: "('index \<times> 'trap) spmf" \<comment> \<open>samples index and trapdoor\<close>
    and domain :: "'index \<Rightarrow> 'range set"
    and range :: "'index \<Rightarrow> 'range set"
    and B :: "'index \<Rightarrow> 'range \<Rightarrow> bool" \<comment> \<open>hard core predicate\<close>
    and F :: "'index \<Rightarrow> 'range \<Rightarrow> 'range"
    and F\<^sub>i\<^sub>n\<^sub>v :: "'index \<Rightarrow> 'trap \<Rightarrow> 'range \<Rightarrow> 'range"
begin

text\<open>The probabilistic program that defines the protocol.\<close>

fun protocol :: "bool inputs_ot12 list \<Rightarrow> (bool outputs_ot12 list) spmf"
  where "protocol [M2 (b\<^sub>\<sigma>, b\<^sub>\<sigma>'), C1 \<sigma>] = do {
    (\<alpha> :: 'index, \<tau> :: 'trap) \<leftarrow> I;
    x\<^sub>\<sigma> :: 'range \<leftarrow> etp.S \<alpha>;
    y\<^sub>\<sigma>' :: 'range \<leftarrow> etp.S \<alpha>;
    let (y\<^sub>\<sigma> :: 'range) = F \<alpha> x\<^sub>\<sigma>;
    let (x\<^sub>\<sigma> :: 'range) = F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>;
    let (x\<^sub>\<sigma>' :: 'range) = F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>';
    let (\<beta>\<^sub>\<sigma> :: bool) = xor (B \<alpha> x\<^sub>\<sigma>) b\<^sub>\<sigma>;
    let (\<beta>\<^sub>\<sigma>' :: bool) = xor (B \<alpha> x\<^sub>\<sigma>') b\<^sub>\<sigma>';
    return_spmf ([U_ot12 (), if \<sigma> then (P_ot12 (xor (B \<alpha> x\<^sub>\<sigma>') \<beta>\<^sub>\<sigma>')) else (P_ot12 (xor (B \<alpha> x\<^sub>\<sigma>) \<beta>\<^sub>\<sigma>))])}"

lemma correctness: "protocol [M2 (m0,m1), C1 c] = return_spmf (f_ot12 [M2 (m0,m1), C1 c])"
proof-
  have "(B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>') = (B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>') = m1)) = m1"
    for \<alpha> \<tau> y\<^sub>\<sigma>'  by auto
  then show ?thesis
    by(auto simp add: Let_def etp.B_F_inv_rewrite bind_spmf_const etp.lossless_S local.etp.lossless_I lossless_weight_spmfD split_def cong: bind_spmf_cong)
qed

sublocale ot12_correct: semi_honest_det_correctness f_ot12 protocol valid_bool_inputs_ot12 .

text \<open> Party 1 views \<close>

fun R1 :: "bool inputs_ot12 list \<Rightarrow> 'range viewP1"
  where "R1 [M2 (b\<^sub>0, b\<^sub>1), C1 \<sigma>] = do {
    (\<alpha>, \<tau>) \<leftarrow> I;
    x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
    y\<^sub>\<sigma>' \<leftarrow> etp.S \<alpha>;
    let y\<^sub>\<sigma> = F \<alpha> x\<^sub>\<sigma>;
    return_spmf (if \<sigma> then y\<^sub>\<sigma>' else y\<^sub>\<sigma>, if \<sigma> then y\<^sub>\<sigma> else y\<^sub>\<sigma>')}"

fun S1 :: "bool inputs_ot12 \<Rightarrow> bool outputs_ot12 \<Rightarrow> 'range viewP1"
  where "S1 (M2 (b\<^sub>0, b\<^sub>1)) (U_ot12 ()) = do {
    (\<alpha>, \<tau>) \<leftarrow> I;
    y\<^sub>0 :: 'range \<leftarrow> etp.S \<alpha>;
    y\<^sub>1 \<leftarrow> etp.S \<alpha>;
    return_spmf (y\<^sub>0, y\<^sub>1)}"

lemma lossless_S1: "lossless_spmf (S1 (M2 (b\<^sub>0, b\<^sub>1)) (U_ot12 ()))"
  by(simp add: local.etp.lossless_I split_def etp.lossless_S)

text \<open> Party 2 views \<close>

fun R2 :: "bool inputs_ot12 list \<Rightarrow> 'index viewP2"
  where "R2 [M2 (b0, b1), C1 \<sigma>] = do {
    (\<alpha>, \<tau>) \<leftarrow> I;
    x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
    y\<^sub>\<sigma>' \<leftarrow> etp.S \<alpha>;
    let y\<^sub>\<sigma> = F \<alpha> x\<^sub>\<sigma>;
    let x\<^sub>\<sigma> = F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>;
    let x\<^sub>\<sigma>' = F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>';
    let \<beta>\<^sub>\<sigma> = (B \<alpha> x\<^sub>\<sigma>) \<oplus> (if \<sigma> then b1 else b0);
    let \<beta>\<^sub>\<sigma>' = (B \<alpha> x\<^sub>\<sigma>') \<oplus> (if \<sigma> then b0 else b1);
    return_spmf (\<alpha>,(\<beta>\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>'))}"

lemma lossless_R2: "lossless_spmf (R2 [M2 (b0, b1), C1 \<sigma>])"
  by(simp add: Let_def split_def local.etp.lossless_I etp.lossless_S)

fun S2 :: "bool inputs_ot12 \<Rightarrow> bool outputs_ot12 \<Rightarrow> 'index viewP2"
  where "S2 (C1 \<sigma>) (P_ot12 b\<^sub>\<sigma>) = do {
    (\<alpha>, \<tau>) \<leftarrow> I;
    x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
    y\<^sub>\<sigma>' \<leftarrow> etp.S \<alpha>;
    let x\<^sub>\<sigma>' = F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>';
    let \<beta>\<^sub>\<sigma> = (B \<alpha> x\<^sub>\<sigma>) \<oplus> b\<^sub>\<sigma>;
    let \<beta>\<^sub>\<sigma>' = B \<alpha> x\<^sub>\<sigma>';
    return_spmf (\<alpha>, (\<beta>\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>'))}"

lemma lossless_S2: "lossless_spmf (S2 (C1 \<sigma>) (P_ot12 b\<^sub>\<sigma>))"
  by(simp add: local.etp.lossless_I etp.lossless_S split_def)

text \<open> Security for Party 1 \<close>

text\<open>We have information theoretic security for Party 1.\<close>

lemma P1_security:
  shows "R1 [M2 (b0, b1), C1 \<sigma>] = return_spmf (f_ot12 [M2 (b0, b1), C1 \<sigma>]) \<bind> (\<lambda> outputs_ot12. S1 (nth [M2 (b0, b1), C1 \<sigma>] 0) (nth outputs_ot12 0))"
  including monad_normalisation
proof-
  have "R1 [M2(b0, b1), C1 \<sigma>] =  do {
    (\<alpha>, \<tau>) \<leftarrow> I;
    y\<^sub>\<sigma>' :: 'range \<leftarrow> etp.S \<alpha>;
    y\<^sub>\<sigma> \<leftarrow> map_spmf (\<lambda> x\<^sub>\<sigma>. F \<alpha> x\<^sub>\<sigma>) (etp.S \<alpha>);
    return_spmf (if \<sigma> then y\<^sub>\<sigma>' else y\<^sub>\<sigma>, if \<sigma> then y\<^sub>\<sigma> else y\<^sub>\<sigma>')}"
    by(simp add: bind_map_spmf o_def Let_def)
  also have "... = do {
    (\<alpha>, \<tau>) \<leftarrow> I;
    y\<^sub>\<sigma>' :: 'range \<leftarrow> etp.S \<alpha>;
    y\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
    return_spmf (if \<sigma> then y\<^sub>\<sigma>' else y\<^sub>\<sigma>, if \<sigma> then y\<^sub>\<sigma> else y\<^sub>\<sigma>')}"
    by(simp add: etp.uni_set_samp Let_def split_def cong: bind_spmf_cong)
  also have "... = return_spmf (f_ot12 [M2 (b0, b1), C1 \<sigma>])
                    \<bind> (\<lambda> outputs_ot12 :: bool outputs_ot12 list. S1 (M2 (b0,b1)) (U_ot12 (() :: unit)))"
    by(cases \<sigma>; simp add: Let_def)
  ultimately show ?thesis by auto
qed

text \<open> The adversary used in proof of security for party 2 \<close>

fun \<A> :: "('index, 'range) advP2"
  where "\<A> D' \<alpha> (C1 \<sigma>) (P_ot12 b\<^sub>\<sigma>) x = do {
    \<beta>\<^sub>\<sigma>' \<leftarrow> coin_spmf;
    x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
    let \<beta>\<^sub>\<sigma> = (B \<alpha> x\<^sub>\<sigma>) \<oplus> b\<^sub>\<sigma>;
    d \<leftarrow> D'(C1 \<sigma>, \<alpha>, \<beta>\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>');
    return_spmf(if d then (\<beta>\<^sub>\<sigma>') else (\<not> \<beta>\<^sub>\<sigma>'))}"

lemma assm_bound_f_ot12:
  assumes "etp.HCP_adv \<A> (C1 \<sigma>) (if \<sigma> then (P_ot12 b1) else (P_ot12 b0)) D \<le> HCP_ad"
  shows "\<bar>spmf (return_spmf (f_ot12 [M2 (b0, b1), C1 \<sigma>]) \<bind> (\<lambda> outputs_ot12.
              etp.HCP_game \<A> (C1 \<sigma>) (nth outputs_ot12 1) D)) True - 1/2\<bar> \<le> HCP_ad"
(is "?lhs \<le> HCP_ad")
proof-
  have "?lhs = \<bar>spmf (etp.HCP_game \<A> (C1 \<sigma>) (if \<sigma> then (P_ot12 b1) else (P_ot12 b0)) D) True - 1/2\<bar>"
    by simp
  thus ?thesis
    using assms
    by (simp add: local.etp.HCP_adv_def)+
qed

lemma assm_bound_f_ot12_collapse:
  assumes "\<forall> b\<^sub>\<sigma>. etp.HCP_adv \<A> (C1 \<sigma>) (P_ot12 b\<^sub>\<sigma>) D \<le> HCP_ad"
  shows "\<bar>spmf (return_spmf (f_ot12 [M2 (b0, b1), C1 \<sigma>]) \<bind> (\<lambda> outputs_ot12. etp.HCP_game \<A> (C1 \<sigma>) (nth outputs_ot12 1) D)) True - 1/2\<bar> \<le> HCP_ad"
proof -
  have "\<bar>spmf (return_spmf (f_ot12 [M2 (b0, b1), C1 \<sigma>]) \<bind> (\<lambda>zs. local.etp.HCP_game \<A> (C1 \<sigma>) (zs ! 1) D)) True - 1 / 2\<bar> \<le> HCP_ad \<or> local.etp.HCP_adv \<A> (C1 \<sigma>) (if \<sigma> then P_ot12 b1 else P_ot12 b0) D \<le> HCP_ad"
    using assms by presburger
  then show ?thesis
    using assm_bound_f_ot12 by blast
qed

text \<open> To prove security for party 2 we split the proof on the cases on party 2's input \<close>

sublocale ot12_party2: semi_honest_det_security f_ot12 protocol valid_bool_inputs_ot12 1 R2 S2 .

lemma R2_S2_False:
  assumes "((if \<sigma> then b0 else b1) = False)"
  shows "spmf (ot12_party2.real_view [M2 (b0, b1), C1 \<sigma>] \<bind> (D2::(bool inputs_ot12 \<times> 'index \<times> (bool \<times> bool)) \<Rightarrow> bool spmf)) True
                = spmf (return_spmf (f_ot12 [M2 (b0, b1), C1 \<sigma>]) \<bind> (\<lambda> outputs_ot12. ot12_party2.ideal_view (C1 \<sigma>) (nth outputs_ot12 1) \<bind> D2)) True"
proof-
  have "\<sigma> \<Longrightarrow> \<not> b0" using assms by simp
  moreover have "\<not> \<sigma> \<Longrightarrow> \<not> b1" using assms by simp
  ultimately show ?thesis
    unfolding ot12_party2.real_view_def ot12_party2.ideal_view_def
    by(auto simp add: split_def local.etp.F_f_inv assms cong: bind_spmf_cong_simp)
qed

lemma R2_S2_True:
  assumes "((if \<sigma> then b0 else b1) = True)"
    and lossless_D2: "\<forall> view. lossless_spmf (D2 view)"
  shows "\<bar>(spmf (bind_spmf (ot12_party2.real_view [M2 (b0, b1), C1 \<sigma>]) (D2::(bool inputs_ot12 \<times> 'index \<times> (bool \<times> bool)) \<Rightarrow> bool spmf)) True)
                - spmf (return_spmf (f_ot12 [M2 (b0, b1), C1 \<sigma>]) \<bind> (\<lambda>outputs. ot12_party2.ideal_view (C1 \<sigma>) (nth outputs 1) \<bind> (\<lambda> view. D2 view))) True\<bar>
                         = \<bar>2*((spmf (etp.HCP_game \<A> (C1 \<sigma>) (if \<sigma> then (P_ot12 b1) else (P_ot12 b0)) D2) True) - 1/2)\<bar>"
proof-
  have  "(spmf (return_spmf (f_ot12 [M2 (b0, b1), C1 \<sigma>]) \<bind> (\<lambda> outputs_ot12. ot12_party2.ideal_view (C1 \<sigma>) (nth outputs_ot12 1) \<bind> D2)) True
              - spmf (bind_spmf (ot12_party2.real_view [M2 (b0, b1), C1 \<sigma>]) D2) True)
                    = 2 * ((spmf (etp.HCP_game \<A> (C1 \<sigma>) (if \<sigma> then (P_ot12 b1) else (P_ot12 b0)) D2) True) - 1/2)"
  proof-
    have  "((spmf (etp.HCP_game \<A> (C1 \<sigma>) (if \<sigma> then (P_ot12 b1) else (P_ot12 b0)) D2) True) - 1/2)  =
                  1/2*(spmf (bind_spmf (ot12_party2.ideal_view (C1 \<sigma>) (if \<sigma> then (P_ot12 b1) else (P_ot12 b0))) D2) True
                        - spmf (bind_spmf (ot12_party2.real_view [M2 (b0, b1), C1 \<sigma>]) D2) True)"
      including monad_normalisation
    proof-
      have \<sigma>_true_b0_true: "\<sigma> \<Longrightarrow> b0 = True" using assms(1) by simp
      have \<sigma>_false_b1_true: "\<not> \<sigma> \<Longrightarrow> b1" using assms(1) by simp
      have return_True_False: "spmf (return_spmf (\<not> d)) True = spmf (return_spmf d) False"
        for d by(cases d; simp)
      define HCP_game_true where "HCP_game_true == \<lambda> \<sigma> b\<^sub>\<sigma>. do {
      (\<alpha>, \<tau>) \<leftarrow> I;
      x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
      x \<leftarrow> (etp.S \<alpha>);
      let \<beta>\<^sub>\<sigma> = (B \<alpha> x\<^sub>\<sigma>) \<oplus> b\<^sub>\<sigma>;
      let \<beta>\<^sub>\<sigma>' = B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x);
      d \<leftarrow> D2(\<sigma>, \<alpha>, \<beta>\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>');
      let b' = (if d then \<beta>\<^sub>\<sigma>' else \<not> \<beta>\<^sub>\<sigma>');
      let b = B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x);
      return_spmf (b = b')}"
      define HCP_game_false where "HCP_game_false == \<lambda> \<sigma> b\<^sub>\<sigma>. do {
      (\<alpha>, \<tau>) \<leftarrow> I;
      x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
      x \<leftarrow> (etp.S \<alpha>);
      let \<beta>\<^sub>\<sigma> = (B \<alpha> x\<^sub>\<sigma>) \<oplus> b\<^sub>\<sigma>;
      let \<beta>\<^sub>\<sigma>' = \<not> B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x);
      d \<leftarrow> D2(\<sigma>, \<alpha>, \<beta>\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>');
      let b' = (if d then \<beta>\<^sub>\<sigma>' else \<not> \<beta>\<^sub>\<sigma>');
      let b = B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x);
      return_spmf (b = b')}"
      define HCP_game_\<A> where "HCP_game_\<A> == \<lambda> \<sigma> b\<^sub>\<sigma>. do {
      \<beta>\<^sub>\<sigma>' \<leftarrow> coin_spmf;
      (\<alpha>, \<tau>) \<leftarrow> I;
      x \<leftarrow> etp.S \<alpha>;
      x' \<leftarrow> etp.S \<alpha>;
      d \<leftarrow> D2(\<sigma>, \<alpha>, (B \<alpha> x) \<oplus> b\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>');
      let b' = (if d then  \<beta>\<^sub>\<sigma>' else \<not> \<beta>\<^sub>\<sigma>');
      return_spmf (B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x') = b')}"
      define S2D where "S2D == \<lambda> \<sigma> b\<^sub>\<sigma> . do {
      (\<alpha>, \<tau>) \<leftarrow> I;
      x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
      y\<^sub>\<sigma>' \<leftarrow> etp.S \<alpha>;
      let x\<^sub>\<sigma>' = F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>';
      let \<beta>\<^sub>\<sigma> = (B \<alpha> x\<^sub>\<sigma>) \<oplus> b\<^sub>\<sigma>;
      let \<beta>\<^sub>\<sigma>' = B \<alpha> x\<^sub>\<sigma>';
      d :: bool \<leftarrow> D2(\<sigma>, \<alpha>, \<beta>\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>');
      return_spmf d}"
      define R2D where "R2D == \<lambda> msgs \<sigma>.  do {
      let (b0,b1) = msgs;
      (\<alpha>, \<tau>) \<leftarrow> I;
      x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
      y\<^sub>\<sigma>' \<leftarrow> etp.S \<alpha>;
      let y\<^sub>\<sigma> = F \<alpha> x\<^sub>\<sigma>;
      let x\<^sub>\<sigma> = F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>;
      let x\<^sub>\<sigma>' = F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>';
      let \<beta>\<^sub>\<sigma> = (B \<alpha> x\<^sub>\<sigma>) \<oplus> (if \<sigma> then b1 else b0) ;
      let \<beta>\<^sub>\<sigma>' = (B \<alpha> x\<^sub>\<sigma>') \<oplus> (if \<sigma> then b0 else b1);
      b :: bool \<leftarrow> D2((C1 \<sigma>), \<alpha>,(\<beta>\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>'));
      return_spmf b}"
      define D_true where "D_true  == \<lambda>\<sigma> b\<^sub>\<sigma>. do {
      (\<alpha>, \<tau>) \<leftarrow> I;
      x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
      x \<leftarrow> (etp.S \<alpha>);
      let \<beta>\<^sub>\<sigma> = (B \<alpha> x\<^sub>\<sigma>) \<oplus> b\<^sub>\<sigma>;
      let \<beta>\<^sub>\<sigma>' = B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x);
      d :: bool \<leftarrow> D2(\<sigma>, \<alpha>, \<beta>\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>');
      return_spmf d}"
      define D_false where "D_false == \<lambda> \<sigma> b\<^sub>\<sigma>. do {
      (\<alpha>, \<tau>) \<leftarrow> I;
      x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
      x \<leftarrow> etp.S \<alpha>;
      let \<beta>\<^sub>\<sigma> = (B \<alpha> x\<^sub>\<sigma>) \<oplus> b\<^sub>\<sigma>;
      let \<beta>\<^sub>\<sigma>' = \<not> B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x);
      d :: bool \<leftarrow> D2(\<sigma>, \<alpha>, \<beta>\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>');
      return_spmf d}"
      have lossless_D_false: "lossless_spmf (D_false a b)"
        for a b by(auto simp add: D_false_def lossless_D2 split_def etp.lossless_I etp.lossless_S)
      have "spmf (etp.HCP_game \<A> (C1 \<sigma>) (if \<sigma> then (P_ot12 b1) else (P_ot12 b0)) D2) True =  spmf (HCP_game_\<A> (C1 \<sigma>) (if \<sigma> then b1 else b0)) True"
        apply(simp add: etp.HCP_game_def HCP_game_\<A>_def split_def etp.F_f_inv)
        by(rewrite bind_commute_spmf[where q = "coin_spmf"]; rewrite bind_commute_spmf[where q = "coin_spmf"]; rewrite bind_commute_spmf[where q = "coin_spmf"]; auto)+
      also have "... = spmf (bind_spmf (map_spmf Not coin_spmf) (\<lambda>b. if b then HCP_game_true (C1 \<sigma>) (if \<sigma> then b1 else b0) else HCP_game_false (C1 \<sigma>) (if \<sigma> then b1 else b0))) True"
        unfolding HCP_game_\<A>_def HCP_game_true_def HCP_game_false_def Let_def
        apply(simp add: split_def cong: if_cong)
        supply [[simproc del: monad_normalisation]]
        apply(subst if_distrib[where f = "bind_spmf _" for f, symmetric]; simp cong: bind_spmf_cong add: if_distribR )+
        apply(rewrite in "_ = \<hole>" bind_commute_spmf)
        apply(rewrite in "bind_spmf _ \<hole>"  in "_ = \<hole>" bind_commute_spmf)
        apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
        apply(rewrite in "\<hole> = _" bind_commute_spmf)
        apply(rewrite in "bind_spmf _ \<hole>" in "\<hole> = _" bind_commute_spmf)
        apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "\<hole> = _" bind_commute_spmf)
        apply(fold map_spmf_conv_bind_spmf)
        apply(rule conjI; rule impI; simp)
         apply(simp only: spmf_bind)
         apply(rule Bochner_Integration.integral_cong[OF refl])+
         apply clarify
        subgoal for r r\<^sub>\<sigma> \<alpha> \<tau>
          apply(simp only: UNIV_bool spmf_of_set integral_spmf_of_set)
          apply(simp cong: if_cong split del: if_split)
          apply(cases "B r (F\<^sub>i\<^sub>n\<^sub>v r r\<^sub>\<sigma> \<tau>)")
          by auto
        apply(rewrite in "_ = \<hole>" bind_commute_spmf)
        apply(rewrite in "bind_spmf _ \<hole>"  in "_ = \<hole>" bind_commute_spmf)
        apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
        apply(rewrite in "\<hole> = _" bind_commute_spmf)
        apply(rewrite in "bind_spmf _ \<hole>" in "\<hole> = _" bind_commute_spmf)
        apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "\<hole> = _" bind_commute_spmf)
        apply(simp only: spmf_bind)
        apply(rule Bochner_Integration.integral_cong[OF refl])+
        apply clarify
        subgoal for r r\<^sub>\<sigma> \<alpha> \<tau>
          apply(simp only: UNIV_bool spmf_of_set integral_spmf_of_set)
          apply(simp cong: if_cong split del: if_split)
          apply(cases " B r (F\<^sub>i\<^sub>n\<^sub>v r r\<^sub>\<sigma> \<tau>)")
          by auto
        done
      also have "... = 1/2*(spmf (HCP_game_true (C1 \<sigma>) (if \<sigma> then b1 else b0)) True) + 1/2*(spmf (HCP_game_false (C1 \<sigma>) (if \<sigma> then b1 else b0)) True)"
        by(simp add: spmf_bind UNIV_bool spmf_of_set integral_spmf_of_set)
      also have "... = 1/2*(spmf (D_true (C1 \<sigma>) (if \<sigma> then b1 else b0)) True) + 1/2*(spmf (D_false (C1 \<sigma>) (if \<sigma> then b1 else b0)) False)"
      proof-
        have "spmf (I \<bind> (\<lambda>(\<alpha>, \<tau>). etp.S \<alpha> \<bind> (\<lambda>x\<^sub>\<sigma>. etp.S \<alpha> \<bind> (\<lambda>x. D2((C1 \<sigma>), \<alpha>, B \<alpha> x\<^sub>\<sigma> = (\<not> (if \<sigma> then b1 else b0)), \<not> B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x)) \<bind> (\<lambda>d. return_spmf (\<not> d)))))) True
                = spmf (I \<bind> (\<lambda>(\<alpha>, \<tau>). etp.S \<alpha> \<bind> (\<lambda>x\<^sub>\<sigma>. etp.S \<alpha> \<bind> (\<lambda>x. D2((C1 \<sigma>), \<alpha>, B \<alpha> x\<^sub>\<sigma> = (\<not> (if \<sigma> then b1 else b0)), \<not> B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x)))))) False"
          (is "?lhs = ?rhs")
        proof-
          have "?lhs = spmf (I \<bind> (\<lambda>(\<alpha>, \<tau>). etp.S \<alpha> \<bind> (\<lambda>x\<^sub>\<sigma>. etp.S \<alpha> \<bind> (\<lambda>x. D2((C1 \<sigma>), \<alpha>, B \<alpha> x\<^sub>\<sigma> = (\<not> (if \<sigma> then b1 else b0)), \<not> B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x)) \<bind> (\<lambda>d. return_spmf (d)))))) False"
            by(simp only: split_def return_True_False spmf_bind)
          then show ?thesis by simp
        qed
        then show ?thesis  by(simp add: HCP_game_true_def HCP_game_false_def Let_def D_true_def D_false_def if_distrib[where f="(=) _"] cong: if_cong)
      qed
      also have "... =  1/2*((spmf (D_true (C1 \<sigma>) (if \<sigma> then b1 else b0)) True) + (1 - spmf (D_false (C1 \<sigma>) (if \<sigma> then b1 else b0)) True))"
        by(simp add: spmf_False_conv_True lossless_D_false)
      also have "... = 1/2 + 1/2* (spmf (D_true (C1 \<sigma>) (if \<sigma> then b1 else b0)) True) - 1/2*(spmf (D_false (C1 \<sigma>) (if \<sigma> then b1 else b0)) True)"
        by(simp)
      also have "... =  1/2 + 1/2* (spmf (S2D (C1 \<sigma>) (if \<sigma> then b1 else b0)) True) - 1/2*(spmf (R2D (b0,b1) \<sigma> ) True)"
        apply(auto  simp add: local.etp.F_f_inv S2D_def R2D_def D_true_def D_false_def  assms split_def cong: bind_spmf_cong_simp)
         apply(simp add: \<sigma>_true_b0_true)
        by(simp add: \<sigma>_false_b1_true)
      ultimately show ?thesis unfolding  ot12_party2.ideal_view_def ot12_party2.real_view_def
        by(auto simp add:  S2D_def R2D_def split_def)
    qed
    then show ?thesis by auto
  qed
  thus ?thesis by simp
qed

lemma P2_adv_bound_unfold:
  assumes lossless_D2: "\<forall> view. lossless_spmf (D2 view)"
  shows "\<bar>(spmf (bind_spmf (ot12_party2.real_view [M2 (b0, b1), C1 \<sigma>]) D2) True) - spmf (return_spmf (f_ot12 [M2 (b0, b1), C1 \<sigma>]) \<bind> (\<lambda> outputs_ot12. ot12_party2.ideal_view (C1 \<sigma>) (nth outputs_ot12 1) \<bind> (\<lambda> view. D2 view))) True\<bar>
                         \<le> \<bar>2*((spmf (etp.HCP_game \<A> (C1 \<sigma>) (if \<sigma> then (P_ot12 b1) else (P_ot12 b0)) D2) True) - 1/2)\<bar>"
  apply(cases "(if \<sigma> then (b0) else (b1))")
  using R2_S2_True R2_S2_False assms by auto

sublocale ot12_party1: semi_honest_det_security f_ot12 protocol valid_bool_inputs_ot12 0 R1 S1 .

lemma perfect_security_P1: "ot12_party1.perfect_security [M2 (b0, b1), C1 \<sigma>]"
  unfolding ot12_party1.perfect_security_def ot12_party1.real_view_def ot12_party1.ideal_view_def
  using P1_security by(auto simp add: P1_security Let_def)

lemma correct: "ot12_correct.correctness [M2 (b0, b1), C1 \<sigma>]"
  unfolding ot12_correct.correctness_def
  using correctness by simp

lemma P2_adv_bound:
  assumes lossless_D2: "\<forall> view. lossless_spmf (D2 view)"
  shows "ot12_party2.advantage [M2 (b0, b1), C1 \<sigma>] D2
            \<le> \<bar>2*((spmf (etp.HCP_game \<A> (C1 \<sigma>) (if \<sigma> then (P_ot12 b1) else (P_ot12 b0)) D2) True) - 1/2)\<bar>"
  using P2_adv_bound_unfold assms unfolding ot12_party2.advantage_def
  by(auto simp add: split_def)

lemma P2_security:
  assumes "etp.HCP_adv \<A> (C1 \<sigma>) (if \<sigma> then (P_ot12 b1) else (P_ot12 b0)) D2 \<le> HCP_ad"
    and lossless_D2: "\<forall> view. lossless_spmf (D2 view)"
  shows "ot12_party2.advantage [M2 (b0, b1), C1 \<sigma>] D2 \<le> 2 * HCP_ad"
proof-
  have *: "\<bar>2 * (spmf (return_spmf (f_ot12 [M2 (b0, b1), C1 \<sigma>]) \<bind> (\<lambda> outputs_ot12. etp.HCP_game \<A> (C1 \<sigma>) (nth outputs_ot12 1) D2)) True - 1/2)\<bar>
                = \<bar>2 * (spmf (etp.HCP_game \<A> (C1 \<sigma>) (if \<sigma> then (P_ot12 b1) else (P_ot12 b0)) D2) True - 1/2)\<bar>"
    by simp
  hence "ot12_party2.advantage [M2 (b0, b1), C1 \<sigma>] D2 \<le> \<bar>2*((spmf (return_spmf (f_ot12 [M2 (b0, b1), C1 \<sigma>]) \<bind> (\<lambda> outputs_ot12. etp.HCP_game \<A> (C1 \<sigma>) (nth outputs_ot12 1) D2)) True) - 1/2)\<bar>"
    using P2_adv_bound assms by auto
  moreover with * have "\<bar>2*((spmf (return_spmf (f_ot12 [M2 (b0, b1), C1 \<sigma>]) \<bind> (\<lambda> outputs_ot12. etp.HCP_game \<A> (C1 \<sigma>) (nth outputs_ot12 1) D2)) True) - 1/2)\<bar> \<le> \<bar>2*HCP_ad\<bar>"
    using assms
    by (simp add: local.etp.HCP_adv_def)+
  moreover have "HCP_ad \<ge> 0"
    using assms by (simp add: local.etp.HCP_adv_def)+
  ultimately show ?thesis by argo
qed

end

text \<open> We also consider the asymptotic case for security proofs \<close>

locale ETP_sec_para =
  fixes I :: "nat \<Rightarrow> ('index \<times> 'trap) spmf"
    and domain ::  "'index \<Rightarrow> 'range set"
    and range ::  "'index \<Rightarrow> 'range set"
    and F :: "'index \<Rightarrow> 'range \<Rightarrow> 'range"
    and F\<^sub>i\<^sub>n\<^sub>v :: "'index \<Rightarrow> 'trap \<Rightarrow> 'range \<Rightarrow> 'range"
    and B :: "'index \<Rightarrow> 'range \<Rightarrow> bool"
  assumes ETP_base: "\<And> n. ETP_ot12_base (I n) domain range F F\<^sub>i\<^sub>n\<^sub>v"
begin

sublocale ETP_ot12_base "(I n)" domain range
  using ETP_base  by simp

lemma P1_sec_asym: "ot12_party1.perfect_security n [M2 (b0, b1), C1 \<sigma>]"
  using perfect_security_P1 by simp

lemma P2_sec_asym:
  assumes HCP_adv_neg: "negligible (\<lambda> n. etp_advantage n)"
    and etp_adv_bound: "\<forall> n. etp.HCP_adv n \<A> (C1 \<sigma>) (if \<sigma> then (P_ot12 b1) else (P_ot12 b0)) D2 \<le> etp_advantage n"
    and lossless_D2: "\<forall> view. lossless_spmf (D2 view)"
  shows "negligible (\<lambda> n. ot12_party2.advantage n [M2 (b0, b1), C1 \<sigma>] D2)"
proof-
  have "negligible (\<lambda> n. 2 * etp_advantage n)" using HCP_adv_neg
    by (simp add: negligible_cmultI)
  moreover have "\<bar>ot12_party2.advantage n [M2 (b0, b1), C1 \<sigma>] D2\<bar> = ot12_party2.advantage n [M2 (b0, b1), C1 \<sigma>] D2"
    for n unfolding ot12_party2.advantage_def by simp
  moreover have  "ot12_party2.advantage n [M2 (b0, b1), C1 \<sigma>] D2 \<le> 2 * etp_advantage n"
    for n
    using P2_security assms
    by blast
  ultimately show ?thesis
    using assms negligible_le HCP_adv_neg P2_security by presburger
qed

end

end


(* Attempting to discover laws form Hinze's stream calculus using Hipster *)
theory Hinze_Streams
  imports Main "$HIPSTER_HOME/IsaHipster"
    "types/Stream" "types/Twople"
    Smap
    Szip
    "~~/src/HOL/Library/BNF_Corec"
begin
setup Tactic_Data.set_coinduct_sledgehammer
setup Misc_Data.set_noisy

(* Lifting *)
primcorec spure :: "'a \<Rightarrow> 'a Stream" where
  "shd (spure x) = x"
| "stl (spure x) = spure x"

(* Sequential application *)
primcorec sapp :: " ('a \<Rightarrow> 'b) Stream \<Rightarrow> 'a Stream \<Rightarrow> 'b Stream" where
  "shd (sapp fs xs) = (shd fs) (shd xs)"
| "stl (sapp fs xs) = sapp (stl fs) (stl xs)"

(* Trying to discover idiom laws *)

(*cohipster sapp spure*)
(*Discovers nothing interesting*)
(*cohipster sapp spure Fun.id*)
(*Discovers nothing interesting*)
(*cohipster sapp spure Fun.comp*)
(* crashes with following message:
Warning: generated term of untestable type Stream (X1 -> X2)
  3. sapp (spure f) z = sapp (spure f) z
  4. sapp (spure f) (spure y) = spure (f y)
tip-spec: src/QuickSpec/Eval.hs, line 361: Untestable instance spure (X1 . X2) of testable schema spure (X1 . X1)
*)
primcorec smap2 :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Stream \<Rightarrow> 'b Stream" where
  "smap2 f xs = sapp (spure f) xs"

(*cohipster smap2*)
(* ca 45 seconds *)
lemma lemma_ac [thy_expl]: "smap2 y (spure z) = spure (y z)"
  by(coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
    (metis sapp.simps(1) sapp.simps(2) smap2.code spure.simps(1) spure.simps(2))

lemma lemma_ad [thy_expl]: "stl (smap2 y z) = smap2 y (stl z)"
  by(coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
    simp

lemma lemma_ae [thy_expl]: "SCons (y z) (smap2 y x2) = smap2 y (SCons z x2)"
  by(coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
    (metis Stream.sel(1) Stream.sel(2) lemma_ad sapp.simps(1) smap2.simps(1) spure.simps(1))

lemma lemma_af [thy_expl]: "smap2 z (SCons y (spure x2)) = SCons (z y) (spure (z x2))"
  by(coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
    (metis lemma_ac lemma_ae)

lemma lemma_ag [thy_expl]: "sapp (SCons y (spure z)) (spure x2) = SCons (y x2) (spure (z x2))"
  by(coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
    (metis Hinze_Streams.lemma_ac Stream.sel(1) Stream.sel(2) sapp.simps(1) sapp.simps(2) smap2.code spure.simps(1) spure.simps(2))

(* Trying to discover functor laws *)
(*cohipster smap2 Fun.id*)
(*crashes with:
Warning: generated term of untestable type Stream (X1 -> X1)
  2. smap2 id2 x = x
tip-spec: src/QuickSpec/Eval.hs, line 361: Untestable instance spure id2 of testable schema spure id2*)
(*cohipster smap2 Fun.comp*)
(* crashes with Warning: generated term of untestable type Stream (X1 -> X2)
  1. smap2 (f . g) y = smap2 f (smap2 g y)
tip-spec: src/QuickSpec/Eval.hs, line 361: Untestable instance spure (X1 . X2) of testable schema spure (X1 . X1)
*)

(* Prove our definition of smap is equivalent to Hinze's *)
(*cohipster smap smap2*)
(* Discovered in ca 45 seconds *)
lemma lemma_ah [thy_expl]: "smap2 z x2 = smap z x2"
proof(coinduction arbitrary: x2 z rule: Stream.Stream.coinduct_strong)
  case Eq_Stream thus ?case
    using lemma_ad
    by (force simp add: lemma_ad)
qed

lemma lemma_ai [thy_expl]: "smap y (spure z) = spure (y z)"
  by(coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
    auto

lemma lemma_aj [thy_expl]: "smap z (SCons y (spure x2)) = SCons (z y) (spure (z x2))"
proof(coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
  case Eq_Stream thus ?case
    using lemma_ai
    by (force simp add: lemma_ai)
qed

(* We have already discovered functor laws for the alternative def of smap,
   see Smap.thy *)

primcorec szip2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a Stream \<Rightarrow> 'b Stream \<Rightarrow> 'c Stream" where
  "szip2 g s t = sapp (sapp (spure g) s) t"

primcorec spair :: "'a Stream => 'b Stream => ('a, 'b) Twople Stream" where
  "spair xs ys = szip2 Pair2 xs ys"
(*cohipster spair*)
(* This fails with "couls not deduce typeable",
if we add typeable constraints to all function contexts
it takes 10 minutes and doesn't find anything very interesting,
we still can't find the properties we want for spair,
and all quickspec calls run much slower *)
(*cohipster spair smap fst2 snd2*)

(* Proof that our def of szip is equivalent to Hinze's *)
lemma "szip xs ys = spair xs ys"
  apply (coinduction arbitrary: xs ys rule: Stream.coinduct_strong)
  apply auto
  by (metis Stream.expand spair.code szip2.simps(1) szip2.simps(2))

(* trying to discover properties of lifted pairing *)
(*cohipster szip smap fst2 snd2*)
(* ca 45 seconds, discovers some trivial things but not what we were
   looking for*)
primcorec sinterleave :: "'a Stream \<Rightarrow> 'a Stream \<Rightarrow> 'a Stream" where
  "sinterleave s t = SCons (shd s) (sinterleave t (stl s))"

(* trying to discover properties for interleave *)
(*cohipster sinterleave spure*)
(* ca 35 seconds *)
lemma lemma_ak [thy_expl]: "sinterleave (SCons y x2) z = SCons y (sinterleave z x2)"
  by(coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
    simp

(* Interleave 1 property *)
lemma lemma_al [thy_expl]: "sinterleave (spure y) (spure y) = spure y"
  by(coinduction arbitrary: y rule: Stream.Stream.coinduct_strong)
    auto

lemma lemma_am [thy_expl]: "SCons y (sinterleave z (spure y)) = sinterleave (spure y) z"
  by(coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
    simp

lemma lemma_an [thy_expl]: "sinterleave (spure z) (SCons y (spure z)) = SCons z (SCons y (spure z))"
  by(coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
    (simp add: lemma_ak lemma_al)

(*cohipster sinterleave sapp*)
(* Nothing interesting found *)

primcorec stabulate :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a Stream" where
  "stabulate f = SCons (f 0) (stabulate (f \<circ> (\<lambda>x. x + 1)))"

fun slookup :: "'a Stream \<Rightarrow> (nat \<Rightarrow> 'a)" where
  "slookup s 0 = shd s" |
  "slookup s (Suc n) = slookup (stl s) n"

(*cohipster stabulate smap Fun.comp*)
(* ca 1 minute *)

(* Naturality of tabulate *)
lemma lemma_ao [thy_expl]: "stabulate (y \<circ> z) = smap y (stabulate z)"
proof(coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
  case Eq_Stream thus ?case
    using stabulate.simps(1)
    by fastforce
qed

(* Trying to find naturality of lookup *)
(*cohipster slookup smap Fun.comp*)
(* Finds nothing interesting*)

primcorec siterate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a Stream" where
  "siterate f a = SCons a (siterate f (f a))"
(*cohipster smap siterate*)
(* ca 30 seconds *)
(* map-iterate property *)
lemma lemma_ap [thy_expl]: "smap y (siterate y z) = siterate y (y z)"
  by(coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
    auto

lemma lemma_aq [thy_expl]: "smap z (SCons y (siterate z x2)) = SCons (z y) (siterate z (z x2))"
proof(coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
  case Eq_Stream thus ?case
    using lemma_ap
    by (force simp add: lemma_ap)
qed
(* Searching for iterate fusion law *)
(*cohipster smap siterate Fun.comp*)
(* ca 45 seconds*)

(* Special case of fusion law *)
lemma lemma_ar [thy_expl]: "smap z (siterate (y \<circ> z) x2) = siterate (z \<circ> y) (z x2)"
  by(coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
    auto

(*Our previous map function is not friendly so we use this one
  to define recurse *)
primcorec monomap :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a Stream \<Rightarrow> 'a Stream" where
  "monomap f xs = SCons (f (shd xs)) (monomap f (stl xs))"
friend_of_corec monomap where
   "monomap f xs = SCons (f (shd xs)) (monomap f (stl xs))"
  by (auto intro: monomap.code)

corec srecurse :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a Stream" where
  "srecurse f a = SCons a (monomap f (srecurse f a))"

(*cohipster srecurse*)
(* after ca 20 seconds
   proof loop crashes with "no matching coinduction rule found" when
   proving shd (srecurse y z) = z *)
(*cohipster siterate srecurse*)
(* after ca 30 seconds
   proof loop crashes with "no matching coinduction rule found" when
   proving shd (srecurse y z) = z
but srecurse f y = siterate f y is discovered *)
(* see a working proof of this lemma in Srecurse_siterate.thy*)

primcorec sunfold :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'b Stream" where
  "sunfold g f a = SCons (g a) (sunfold g f (f a))"

(* Trying to find fusion law for unfold*)
(*cohipster sunfold Fun.comp*)
(* ca 20 seconds *)
(* Special case of fusion law *)
lemma lemma_as [thy_expl]: "sunfold (z \<circ> x2) x2 x3 = sunfold z x2 (x2 x3)"
  by(coinduction arbitrary: x2 x3 z rule: Stream.Stream.coinduct_strong)
    auto
(* Trying to find functor fusion for unfold*)
(*cohipster smap sunfold Fun.comp*)
(* ca 45 seconds *)
lemma lemma_at [thy_expl]: "smap y (sunfold z z x2) = sunfold y z (z x2)"
  by(coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
  auto
(*Functor fusion*)
lemma lemma_au [thy_expl]: "sunfold (y \<circ> z) x2 x3 = smap y (sunfold z x2 x3)"
  by(coinduction arbitrary: x2 x3 y z rule: Stream.Stream.coinduct_strong)
  auto

(* Trying to discover unfold reflection *)
(*cohipster sunfold shd stl Fun.id*)
lemma lemma_av [thy_expl]: "sunfold id y (y z) = sunfold y y z"
  by(coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
    auto

lemma lemma_aw [thy_expl]: "sunfold id id (y z) = sunfold y id z"
  by(coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
    auto

lemma lemma_ax [thy_expl]: "SCons z (sunfold y y z) = sunfold id y z"
  by(coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
    (simp add: lemma_av)

lemma lemma_ay [thy_expl]: "SCons (y z) (sunfold y id z) = sunfold y id z"
  by(coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
    simp

end


theory Unification
  imports Substitution
begin

function unify' :: "(uexpr \<times> uexpr) list \<rightharpoonup> subst" where
  "unify' [] = Some Map.empty"
| "unify' ((Ctor k\<^sub>1 es\<^sub>1, Ctor k\<^sub>2 es\<^sub>2) # ess) = (
    if k\<^sub>1 = k\<^sub>2 \<and> length es\<^sub>1 = length es\<^sub>2 then unify' (zip es\<^sub>1 es\<^sub>2 @ ess)
    else None)"
| "unify' ((Ctor k es, Var x) # ess) = unify' ((Var x, Ctor k es) # ess)"
| "unify' ((Var x, e) # ess) = (
    if e = Var x then unify' ess
    else if x \<notin> vars e then map_option (extend_subst x e) (unify' (list_subst x e ess))
    else None)"
  by pat_completeness auto
termination
  by (relation "measures [card \<circ> list_vars, list_ctor_count, length]")
     (simp_all add: card_insert_if)

lemma unify'_induct [case_names Nil CtorCtorYes CtorCtorNo CtorVar VarSame Occurs VarNo VarYes]: "
    P [] \<Longrightarrow>
    (\<And>k es\<^sub>1 es\<^sub>2 ess. length es\<^sub>1 = length es\<^sub>2 \<Longrightarrow> P (zip es\<^sub>1 es\<^sub>2 @ ess) \<Longrightarrow>
      P ((Ctor k es\<^sub>1, Ctor k es\<^sub>2) # ess)) \<Longrightarrow>
    (\<And>k\<^sub>1 k\<^sub>2 es\<^sub>1 es\<^sub>2 ess. k\<^sub>1 \<noteq> k\<^sub>2 \<or> length es\<^sub>1 \<noteq> length es\<^sub>2 \<Longrightarrow>
      P ((Ctor k\<^sub>1 es\<^sub>1, Ctor k\<^sub>2 es\<^sub>2) # ess)) \<Longrightarrow>
    (\<And>x es k ess. P ((Var x, Ctor k es) # ess) \<Longrightarrow> P ((Ctor k es, Var x) # ess)) \<Longrightarrow>
    (\<And>x ess. P ess \<Longrightarrow> P ((Var x, Var x) # ess)) \<Longrightarrow>
    (\<And>x e ess. e \<noteq> Var x \<Longrightarrow> x \<in> vars e \<Longrightarrow> P ((Var x, e) # ess)) \<Longrightarrow>
    (\<And>x e ess. e \<noteq> Var x \<Longrightarrow> x \<notin> vars e \<Longrightarrow> P (list_subst x e ess) \<Longrightarrow>
      unify' (list_subst x e ess) = None \<Longrightarrow> P ((Var x, e) # ess)) \<Longrightarrow>
    (\<And>x e ess s'. e \<noteq> Var x \<Longrightarrow> x \<notin> vars e \<Longrightarrow> P (list_subst x e ess) \<Longrightarrow>
      unify' (list_subst x e ess) = Some s' \<Longrightarrow> P ((Var x, e) # ess)) \<Longrightarrow>
    P ts"
proof (induction ts rule: unify'.induct)
  case (2 k\<^sub>1 es\<^sub>1 k\<^sub>2 es\<^sub>2 ess)
  thus ?case by (cases "k\<^sub>1 = k\<^sub>2 \<and> length es\<^sub>1 = length es\<^sub>2") simp_all
next
  case (4 x e ess)
  thus ?case
    by (cases "e \<noteq> Var x") (cases "x \<notin> vars e", cases "unify' (list_subst x e ess)", simp_all)
qed simp_all

definition unify :: "uexpr \<Rightarrow> uexpr \<rightharpoonup> subst" where
  "unify e\<^sub>1 e\<^sub>2 = unify' [(e\<^sub>1, e\<^sub>2)]"

definition fail :: "(uexpr \<times> uexpr) list" where
  "fail = [(Ctor ''a'' [], Ctor ''b'' [])]"

lemma unify_dom [simp]: "unify' ess = Some s \<Longrightarrow> dom s \<subseteq> list_vars ess"
proof (induction ess arbitrary: s rule: unify'_induct)
  case (VarYes x e ess s')
  hence "dom s' \<subseteq> list_vars (list_subst x e ess)" by simp
  hence "dom (extend_subst x e s') \<subseteq> insert x (vars e \<union> list_vars ess)" by (auto split: if_splits)
  with VarYes show ?case by simp
qed auto

lemma unify_ran [simp]: "unify' ess = Some s \<Longrightarrow> subst_vars s \<subseteq> list_vars ess"
proof (induction ess arbitrary: s rule: unify'_induct)
  case (VarYes x e ess s')
  hence X: "subst_vars s' \<subseteq> list_vars (list_subst x e ess)" by simp
  from VarYes have "dom s' \<subseteq> list_vars (list_subst x e ess)" by (metis unify_dom)
  with VarYes have "x \<notin> dom s'" by (auto simp del: list_subst_no_var split: if_splits)
  hence D: "subst_vars (extend_subst x e s') = vars (subst s' e) \<union> subst_vars s'" by simp
  from X have "vars e - dom s' \<union> subst_vars s' \<subseteq> insert x (vars e \<union> list_vars ess)"
    by (auto split: if_splits)
  moreover have "vars (subst s' e) \<subseteq> vars e - dom s' \<union> subst_vars s'" by simp
  ultimately have Y: "vars (subst s' e) \<subseteq> insert x (vars e \<union> list_vars ess)" by blast
  from X have "subst_vars s' \<subseteq> insert x (vars e \<union> list_vars ess)" by (auto split: if_splits)
  with VarYes D Y show ?case by simp
qed auto

lemma [simp]: "unify e\<^sub>1 e\<^sub>2 = Some s \<Longrightarrow> ordered_subst s"
  by (simp add: unify_def)

lemma unify_none [simp]: "unify' ess = None \<Longrightarrow> \<nexists>s'. s' unifies\<^sub>l ess"
proof (induction ess rule: unify'_induct)
  case (Occurs x e ess)
  hence "\<And>s'. \<not> s' unifies Var x and e" by (metis occurs_check)
  thus ?case by simp
next
  case (VarNo x e ess)
  have "\<And>s. s unifies Var x and e \<Longrightarrow> \<not> s unifies\<^sub>l ess"
  proof -
    fix s
    assume U: "s unifies Var x and e"
    show "?thesis s"
    proof (cases "s x")
      case None
      with U have "subst s e = Var x" by simp
      with VarNo obtain y where Y: "e = Var y \<and> s y = Some (Var x)" by auto
      with VarNo have "\<not> extend_subst x (Var y) s unifies\<^sub>l ess" by simp
      with None Y show ?thesis by simp
    next
      case (Some e')
      hence S: "s(x \<mapsto> e') = s" by auto
      from VarNo have "\<not> extend_subst x e (s(x := None)) unifies\<^sub>l ess" by simp
      with VarNo(2) U Some S show ?thesis by auto
    qed
  qed
  thus ?case by simp
qed simp_all

lemma [simp]: "unify e\<^sub>1 e\<^sub>2 = None \<Longrightarrow> \<nexists>s. s unifies e\<^sub>1 and e\<^sub>2"
proof (unfold unify_def)
  assume "unify' [(e\<^sub>1, e\<^sub>2)] = None"
  hence "\<nexists>s'. s' unifies\<^sub>l [(e\<^sub>1, e\<^sub>2)]" by (metis unify_none)
  thus "\<nexists>s. s unifies e\<^sub>1 and e\<^sub>2" by simp
qed

lemma unify_some [simp]: "unify' ess = Some s \<Longrightarrow> s unifies\<^sub>l ess"
  by (induction ess arbitrary: s rule: unify'_induct) auto

lemma [simp]: "unify e\<^sub>1 e\<^sub>2 = Some s \<Longrightarrow> s unifies e\<^sub>1 and e\<^sub>2"
proof (unfold unify_def)
  assume "unify' [(e\<^sub>1, e\<^sub>2)] = Some s"
  hence "s unifies\<^sub>l [(e\<^sub>1, e\<^sub>2)]" by (metis unify_some)
  thus "s unifies e\<^sub>1 and e\<^sub>2" by simp
qed

lemma [simp]: "unify' ess = Some s \<Longrightarrow> t unifies\<^sub>l ess \<Longrightarrow> ordered_subst t \<Longrightarrow>
  \<exists>u. subst t = subst u \<circ> subst s \<and> ordered_subst u"
proof (induction ess arbitrary: s t rule: unify'_induct)
  case Nil
  thus ?case by auto
next
  case (VarYes x e ess s')
  hence "dom s' \<subseteq> list_vars (list_subst x e ess)" by (metis unify_dom)
  with VarYes have D: "x \<notin> dom s'" by (auto simp del: list_subst_no_var split: if_splits)
  from VarYes have "subst_vars s' \<subseteq> list_vars (list_subst x e ess)" by (metis unify_ran)
  with VarYes have R: "x \<notin> subst_vars s'" by (auto simp del: list_subst_no_var split: if_splits)
  thus ?case
  proof (cases "t x")
    case None
    with VarYes have T: "subst t e = Var x \<and> t unifies\<^sub>l ess" by simp
    with VarYes obtain y where Y: "e = Var y \<and> t y = Some (Var x)" by fastforce
    with None T have "t unifies\<^sub>l list_subst x (Var y) ess" by simp
    with VarYes Y obtain u where U: "subst t = subst u \<circ> subst s' \<and> ordered_subst u" by fastforce
    from None have "x \<notin> dom t" by auto
    with D U have X: "x \<notin> dom u" by (metis split_not_in_domain)
    from T Y U have "(subst u \<circ> subst s') (Var y) = Var x" by simp
    thus ?thesis
    proof (induction rule: subst_subst_var)
      case Eq
      with VarYes Y show ?case by simp
    next
      case FstOnly
      have "subst u \<circ> subst s' = subst u \<circ> subst [x \<mapsto> Var x] \<circ> subst s'" by simp
      with D R Y U FstOnly have "subst t = subst u \<circ> subst s' \<circ> subst [x \<mapsto> e] \<and> ordered_subst u"
        using comp_assoc by blast
      with VarYes show ?case by auto
    next
      case SndOnly
      with X have "subst u \<circ> subst s' = subst u \<circ> subst [y \<mapsto> Var x] \<circ> subst s'" by simp
      hence "subst u \<circ> subst s' = subst (extend_subst y (Var x) u) \<circ> subst [x \<mapsto> Var y] \<circ> subst s'"
        by (simp add: expand_extend_subst comp_assoc)
      with D R Y U SndOnly have S: "subst t =
        subst (extend_subst y (Var x) u) \<circ> subst s' \<circ> subst [x \<mapsto> e]" by (simp add: comp_assoc)
      from SndOnly X have "u y = Some (case u x of None \<Rightarrow> Var x | Some e \<Rightarrow> e)"
        by (auto split: option.splits)
      with VarYes U have "ordered_subst (extend_subst y (Var x) u)" by simp
      with VarYes S show ?case by auto
    next
      case (Both z)
      with X have "subst u \<circ> subst s' = subst (extend_subst x (Var z) u) \<circ> subst s'" by auto
      hence Z: "subst u \<circ> subst s' = subst u \<circ> subst [x \<mapsto> Var z] \<circ> subst s'"
        by (simp add: expand_extend_subst)
      from D R Both have "subst s' \<circ> subst [x \<mapsto> Var y] = subst [x \<mapsto> Var z] \<circ> subst s'" by simp
      with U Z have "subst t = subst u \<circ> subst s' \<circ> subst [x \<mapsto> Var y]" by (metis comp_assoc)
      with Y have S: "subst t = subst u \<circ> subst s' \<circ> subst [x \<mapsto> e]" by simp
      from U have "ordered_subst u" by simp
      with VarYes S show ?case by auto
  qed
  next
    case (Some e')
    with VarYes have "e' = subst t e \<and> t unifies\<^sub>l ess" by simp
    with VarYes Some obtain t' where T: "t = extend_subst x e t' \<and> t' unifies\<^sub>l list_subst x e ess \<and>
      ordered_subst t'" by (metis dissect_subst)
    with VarYes obtain u where "subst t' = subst u \<circ> subst s' \<and> ordered_subst u" by fastforce
    with VarYes T show ?thesis by (auto simp add: expand_extend_subst)
  qed
qed simp_all

lemma [simp]: "unify e\<^sub>1 e\<^sub>2 = Some s \<Longrightarrow> t unifies e\<^sub>1 and e\<^sub>2 \<Longrightarrow> ordered_subst t \<Longrightarrow> t extends s"
proof (unfold unify_def)
  assume "t unifies e\<^sub>1 and e\<^sub>2"
  hence "t unifies\<^sub>l [(e\<^sub>1, e\<^sub>2)]" by simp
  moreover assume "unify' [(e\<^sub>1, e\<^sub>2)] = Some s"
  moreover assume "ordered_subst t"
  ultimately have "\<exists>u. subst t = subst u \<circ> subst s \<and> ordered_subst u" by simp
  thus ?thesis by (auto simp add: subst_extends_def)
qed

lemma unify_append_fst [simp]: "unify' (ess\<^sub>1 @ ess\<^sub>2) = Some s \<Longrightarrow>
    \<exists>s\<^sub>1. unify' ess\<^sub>1 = Some s\<^sub>1 \<and> s extends s\<^sub>1"
  by (induction ess\<^sub>1 arbitrary: ess\<^sub>2 s rule: unify'_induct) auto

lemma [simp]: "unify' ess\<^sub>1 = None \<Longrightarrow> unify' (ess\<^sub>1 @ ess\<^sub>2) = None"
  by (induction ess\<^sub>1 arbitrary: ess\<^sub>2 rule: unify'_induct) auto

lemma [simp]: "unify' ((e, e) # ess) = unify' ess"
  and [simp]: "unify' (zip es es @ ess) = unify' ess"
  by (induction e and es arbitrary: ess and ess rule: vars_varss.induct)  simp_all

lemma unify_occurs' [simp]: "e \<noteq> Var x \<Longrightarrow> x \<in> vars e \<Longrightarrow>
  unify' ((e', subst [x \<mapsto> e'] e) # ess) = None"
proof (cases "unify' ((e', subst [x \<mapsto> e'] e) # ess)")
  case (Some s)
  moreover assume "e \<noteq> Var x" and "x \<in> vars e"
  ultimately show ?thesis by (metis unify_some list_unifier.simps(2) occurs_check2)
qed simp_all

lemma unify_occurs: "unify' ((e, Ctor k (map (subst [x \<mapsto> e]) es)) # ess) = Some s \<Longrightarrow> x \<notin> varss es"
proof
  assume "x \<in> varss es"
  hence "unify' ((e, subst [x \<mapsto> e] (Ctor k es)) # ess) = None" using unify_occurs' by fastforce
  moreover assume "unify' ((e, Ctor k (map (subst [x \<mapsto> e]) es)) # ess) = Some s"
  ultimately show False by simp
qed

lemma [simp]: "length es\<^sub>1 = length es\<^sub>2 \<Longrightarrow>
    unify' (ess\<^sub>1 @ (Ctor k es\<^sub>1, Ctor k es\<^sub>2) # ess\<^sub>2) = unify' (ess\<^sub>1 @ zip es\<^sub>1 es\<^sub>2 @ ess\<^sub>2)"
  by (induction ess\<^sub>1 arbitrary: es\<^sub>1 es\<^sub>2 ess\<^sub>2 rule: unify'_induct) auto

lemma [simp]: "length es\<^sub>1 = length es\<^sub>2 \<Longrightarrow>
  unify' (ess\<^sub>1 # (Ctor k es\<^sub>1, Ctor k es\<^sub>2) # ess\<^sub>2) = unify' (ess\<^sub>1 # zip es\<^sub>1 es\<^sub>2 @ ess\<^sub>2)"
proof -
  assume "length es\<^sub>1 = length es\<^sub>2"
  hence "unify' ([ess\<^sub>1] @ (Ctor k es\<^sub>1, Ctor k es\<^sub>2) # ess\<^sub>2) = unify' ([ess\<^sub>1] @ zip es\<^sub>1 es\<^sub>2 @ ess\<^sub>2)"
    by (simp del: append.simps)
  thus ?thesis by simp
qed

lemma [simp]: "unify' (ess\<^sub>1 @ (e, e) # ess\<^sub>2) = unify' (ess\<^sub>1 @ ess\<^sub>2)"
  by (induction ess\<^sub>1 arbitrary: e ess\<^sub>2 rule: unify'_induct) auto

lemma [simp]: "unify' (es # (e, e) # ess) = unify' (es # ess)"
proof -
  have "unify' ([es] @ (e, e) # ess) = unify' ([es] @ ess)" by (simp del: append.simps)
  thus ?thesis by simp
qed

lemma [simp]: "k\<^sub>1 \<noteq> k\<^sub>2 \<Longrightarrow> unify' (ess\<^sub>1 @ (Ctor k\<^sub>1 es\<^sub>1, Ctor k\<^sub>2 es\<^sub>2) # ess\<^sub>2) = None"
  by (induction ess\<^sub>1 arbitrary: es\<^sub>1 es\<^sub>2 ess\<^sub>2 rule: unify'_induct) auto

lemma [simp]: "k\<^sub>1 \<noteq> k\<^sub>2 \<Longrightarrow> unify' (es # (Ctor k\<^sub>1 es\<^sub>1, Ctor k\<^sub>2 es\<^sub>2) # ess\<^sub>2) = None"
proof -
  assume "k\<^sub>1 \<noteq> k\<^sub>2"
  hence "unify' ([es] @ (Ctor k\<^sub>1 es\<^sub>1, Ctor k\<^sub>2 es\<^sub>2) # ess\<^sub>2) = None" by (simp del: append.simps)
  thus ?thesis by simp
qed

lemma [simp]: "length es\<^sub>1 \<noteq> length es\<^sub>2 \<Longrightarrow> unify' (ess\<^sub>1 @ (Ctor k\<^sub>1 es\<^sub>1, Ctor k\<^sub>2 es\<^sub>2) # ess\<^sub>2) = None"
  by (induction ess\<^sub>1 arbitrary: es\<^sub>1 es\<^sub>2 ess\<^sub>2 rule: unify'_induct) auto

lemma [simp]: "length es\<^sub>1 \<noteq> length es\<^sub>2 \<Longrightarrow> unify' (es # (Ctor k\<^sub>1 es\<^sub>1, Ctor k\<^sub>2 es\<^sub>2) # ess\<^sub>2) = None"
proof -
  assume "length es\<^sub>1 \<noteq> length es\<^sub>2"
  hence "unify' ([es] @ (Ctor k\<^sub>1 es\<^sub>1, Ctor k\<^sub>2 es\<^sub>2) # ess\<^sub>2) = None" by (simp del: append.simps)
  thus ?thesis by simp
qed

lemma [simp]: "unify' ess = None \<Longrightarrow> unify' (list_subst x e' ess) = None"
proof -
  assume "unify' ess = None"
  hence "\<nexists>s'. s' unifies\<^sub>l ess" by simp
  hence "\<exists>s. unify' (list_subst x e' ess) = Some s \<Longrightarrow> False"
  proof -
    assume "\<exists>s. unify' (list_subst x e' ess) = Some s"
    then obtain s where "unify' (list_subst x e' ess) = Some s" by fastforce
    hence "s unifies\<^sub>l list_subst x e' ess" by (metis unify_some)
    moreover assume "\<nexists>s'. s' unifies\<^sub>l ess"
    ultimately show False by simp
  qed
  thus ?thesis by fastforce
qed

lemma [simp]: "s unifies\<^sub>l ess \<Longrightarrow> ordered_subst s \<Longrightarrow> \<exists>s'. unify' ess = Some s' \<and> s extends s'"
proof (cases "unify' ess")
  case None
  moreover assume "s unifies\<^sub>l ess"
  ultimately show ?thesis by (metis unify_none)
next
  case (Some s')
  assume "s unifies\<^sub>l ess" and "ordered_subst s"
  with Some obtain u where "subst s = subst u \<circ> subst s' \<and> ordered_subst u" by fastforce
  hence "s extends s'" by (auto simp add: subst_extends_def)
  with Some show ?thesis by fastforce
qed

lemma [simp]: "unify' (list_subst x e' ess) = Some s \<Longrightarrow> x \<notin> vars e' \<Longrightarrow>
  \<exists>s\<^sub>2. unify' ess = Some s\<^sub>2 \<and> extend_subst x e' s extends s\<^sub>2"
proof -
  assume U: "unify' (list_subst x e' ess) = Some s"
  hence L: "s unifies\<^sub>l list_subst x e' ess" and O: "ordered_subst s" by (metis unify_some, simp)
  assume X: "x \<notin> vars e'"
  hence "x \<notin> list_vars ess - {x} \<union> (if x \<in> list_vars ess then vars e' else {})" by simp
  moreover from U have "dom s \<subseteq> list_vars (list_subst x e' ess)" by (metis unify_dom)
  moreover from U have "subst_vars s \<subseteq> list_vars (list_subst x e' ess)" by (metis unify_ran)
  ultimately have "x \<notin> dom s" and "x \<notin> subst_vars s" by auto
  with O X L show ?thesis by simp
qed

lemma unify_append_snd [simp]: "unify' (ess\<^sub>1 @ ess\<^sub>2) = Some s \<Longrightarrow>
    \<exists>s\<^sub>2. unify' ess\<^sub>2 = Some s\<^sub>2 \<and> s extends s\<^sub>2"
proof (induction ess\<^sub>1 arbitrary: ess\<^sub>2 s rule: unify'_induct)
  case (VarYes x e ess s')
  then obtain t where T: "unify' (list_subst x e ess @ list_subst x e ess\<^sub>2) = Some t \<and>
    extend_subst x e t = s" by fastforce
  with VarYes obtain u where "unify' (list_subst x e ess\<^sub>2) = Some u \<and> t extends u" by fastforce
  moreover with VarYes obtain s\<^sub>2 where "unify' ess\<^sub>2 = Some s\<^sub>2 \<and> extend_subst x e u extends s\<^sub>2"
    by fastforce
  ultimately have "unify' ess\<^sub>2 = Some s\<^sub>2 \<and> extend_subst x e t extends s\<^sub>2" by fastforce
  with T show ?case by fastforce
qed (simp_all split: if_splits)

lemma unify_append_none [simp]: "unify' (ess\<^sub>1 @ ess\<^sub>2) = None \<Longrightarrow> unify' ess\<^sub>1 = None \<or>
  (\<exists>s. unify' ess\<^sub>1 = Some s \<and> unify' (map (pair_subst s) ess\<^sub>2) = None)"
proof (induction ess\<^sub>1 arbitrary: ess\<^sub>2 rule: unify'_induct)
  case (VarYes x e ess s')
  hence "unify' (list_subst x e ess @ list_subst x e ess\<^sub>2) = None" by simp
  with VarYes have "unify' (list_subst x e ess) = None \<or> (\<exists>s. unify' (list_subst x e ess) = Some s \<and>
    unify' (map (pair_subst s) (list_subst x e ess\<^sub>2)) = None)" by blast
  with VarYes show ?case by simp
qed auto

lemma unify'_props: "unify' ess = Some s \<Longrightarrow> structural P \<Longrightarrow>
  list_all (\<lambda>(e\<^sub>1, e\<^sub>2). P e\<^sub>1 \<and> P e\<^sub>2) ess \<Longrightarrow> \<forall>x\<in>ran s. P x"
proof (induction ess arbitrary: s rule: unify'_induct)
  case (CtorCtorYes k es\<^sub>1 es\<^sub>2 ess)
  from CtorCtorYes(1, 3) have X: "unify' (zip es\<^sub>1 es\<^sub>2 @ ess) = Some s" by simp
  from CtorCtorYes(1) have "length es\<^sub>1 = length es\<^sub>2" by simp
  moreover from CtorCtorYes(5) have "list_all (\<lambda>(e\<^sub>1, e\<^sub>2). P e\<^sub>1 \<and> P e\<^sub>2) ess" by simp
  moreover from CtorCtorYes(4, 5) have "list_all P es\<^sub>1" by (auto simp add: structural_def)
  moreover from CtorCtorYes(4, 5) have "list_all P es\<^sub>2" by (auto simp add: structural_def)
  ultimately have "list_all (\<lambda>(e\<^sub>1, e\<^sub>2). P e\<^sub>1 \<and> P e\<^sub>2) (zip es\<^sub>1 es\<^sub>2 @ ess)" by simp
  with CtorCtorYes(2, 4) X show ?case by blast
next
  case (CtorVar x es k ess)
  from CtorVar(2) have X: "unify' ((Var x, Ctor k es) # ess) = Some s" by simp
  from CtorVar(4) have "list_all (\<lambda>(e\<^sub>1, e\<^sub>2). P e\<^sub>1 \<and> P e\<^sub>2) ((Var x, Ctor k es) # ess)" by simp
  with CtorVar(1, 3) X show ?case by blast
next
  case (VarSame x ess)
  from VarSame(2) have X: "unify' ess = Some s" by simp
  from VarSame(4) have "list_all (\<lambda>(e\<^sub>1, e\<^sub>2). P e\<^sub>1 \<and> P e\<^sub>2) ess" by simp
  with VarSame(1, 3) X show ?case by blast
next
  case (VarYes x e ess s')
  from VarYes(6, 7) have "list_all (\<lambda>(e\<^sub>1, e\<^sub>2). P e\<^sub>1 \<and> P e\<^sub>2) (list_subst x e ess)" by simp
  with VarYes(3, 4, 6) have S: "\<forall>a\<in>ran s'. P a" by blast
  hence "\<forall>x\<in>ran (s'(x := None)). P x" by (auto simp add: ran_def)
  with S VarYes(1, 2, 3, 5, 6, 7) S show ?case by auto
qed fastforce+

lemma unify_props: "unify e\<^sub>1 e\<^sub>2 = Some s \<Longrightarrow> P e\<^sub>1 \<Longrightarrow> P e\<^sub>2 \<Longrightarrow> structural P \<Longrightarrow> \<forall>x \<in> ran s. P x"
proof (unfold unify_def)
  assume "P e\<^sub>1" and "P e\<^sub>2"
  hence "list_all (\<lambda>(e\<^sub>1, e\<^sub>2). P e\<^sub>1 \<and> P e\<^sub>2) [(e\<^sub>1, e\<^sub>2)]" by simp
  moreover assume "unify' [(e\<^sub>1, e\<^sub>2)] = Some s" and "structural P"
  ultimately show "\<forall>x\<in>ran s. P x" by (metis unify'_props)
qed

lemma [simp]: "unify' fail = None"
  by (simp add: fail_def)

lemma [simp]: "list_vars fail = {}"
  by (simp add: fail_def)

lemma [simp]: "list_subst x e fail = fail"
  by (simp add: fail_def)

end


(*  Title:      HOL/Proofs/Extraction/Higman.thy
    Author:     Stefan Berghofer, TU Muenchen
    Author:     Monika Seisenberger, LMU Muenchen
*)

section {* Higman's lemma *}

theory Higman
imports Old_Datatype
begin

text {*
  Formalization by Stefan Berghofer and Monika Seisenberger,
  based on Coquand and Fridlender @{cite Coquand93}.
*}

datatype letter = A | B

inductive emb :: "letter list \<Rightarrow> letter list \<Rightarrow> bool"
where
   emb0 [Pure.intro]: "emb [] bs"
 | emb1 [Pure.intro]: "emb as bs \<Longrightarrow> emb as (b # bs)"
 | emb2 [Pure.intro]: "emb as bs \<Longrightarrow> emb (a # as) (a # bs)"

inductive L :: "letter list \<Rightarrow> letter list list \<Rightarrow> bool"
  for v :: "letter list"
where
   L0 [Pure.intro]: "emb w v \<Longrightarrow> L v (w # ws)"
 | L1 [Pure.intro]: "L v ws \<Longrightarrow> L v (w # ws)"

inductive good :: "letter list list \<Rightarrow> bool"
where
    good0 [Pure.intro]: "L w ws \<Longrightarrow> good (w # ws)"
  | good1 [Pure.intro]: "good ws \<Longrightarrow> good (w # ws)"

inductive R :: "letter \<Rightarrow> letter list list \<Rightarrow> letter list list \<Rightarrow> bool"
  for a :: letter
where
    R0 [Pure.intro]: "R a [] []"
  | R1 [Pure.intro]: "R a vs ws \<Longrightarrow> R a (w # vs) ((a # w) # ws)"

inductive T :: "letter \<Rightarrow> letter list list \<Rightarrow> letter list list \<Rightarrow> bool"
  for a :: letter
where
    T0 [Pure.intro]: "a \<noteq> b \<Longrightarrow> R b ws zs \<Longrightarrow> T a (w # zs) ((a # w) # zs)"
  | T1 [Pure.intro]: "T a ws zs \<Longrightarrow> T a (w # ws) ((a # w) # zs)"
  | T2 [Pure.intro]: "a \<noteq> b \<Longrightarrow> T a ws zs \<Longrightarrow> T a ws ((b # w) # zs)"

inductive bar :: "letter list list \<Rightarrow> bool"
where
    bar1 [Pure.intro]: "good ws \<Longrightarrow> bar ws"
  | bar2 [Pure.intro]: "(\<And>w. bar (w # ws)) \<Longrightarrow> bar ws"

theorem prop1: "bar ([] # ws)" by iprover

theorem lemma1: "L as ws \<Longrightarrow> L (a # as) ws"
  by (erule L.induct, iprover+)

lemma lemma2': "R a vs ws \<Longrightarrow> L as vs \<Longrightarrow> L (a # as) ws"
  apply (induct set: R)
  apply (erule L.cases)
  apply simp+
  apply (erule L.cases)
  apply simp_all
  apply (rule L0)
  apply (erule emb2)
  apply (erule L1)
  done

lemma lemma2: "R a vs ws \<Longrightarrow> good vs \<Longrightarrow> good ws"
  apply (induct set: R)
  apply iprover
  apply (erule good.cases)
  apply simp_all
  apply (rule good0)
  apply (erule lemma2')
  apply assumption
  apply (erule good1)
  done

lemma lemma3': "T a vs ws \<Longrightarrow> L as vs \<Longrightarrow> L (a # as) ws"
  apply (induct set: T)
  apply (erule L.cases)
  apply simp_all
  apply (rule L0)
  apply (erule emb2)
  apply (rule L1)
  apply (erule lemma1)
  apply (erule L.cases)
  apply simp_all
  apply iprover+
  done

lemma lemma3: "T a ws zs \<Longrightarrow> good ws \<Longrightarrow> good zs"
  apply (induct set: T)
  apply (erule good.cases)
  apply simp_all
  apply (rule good0)
  apply (erule lemma1)
  apply (erule good1)
  apply (erule good.cases)
  apply simp_all
  apply (rule good0)
  apply (erule lemma3')
  apply iprover+
  done

lemma lemma4: "R a ws zs \<Longrightarrow> ws \<noteq> [] \<Longrightarrow> T a ws zs"
  apply (induct set: R)
  apply iprover
  apply (case_tac vs)
  apply (erule R.cases)
  apply simp
  apply (case_tac a)
  apply (rule_tac b=B in T0)
  apply simp
  apply (rule R0)
  apply (rule_tac b=A in T0)
  apply simp
  apply (rule R0)
  apply simp
  apply (rule T1)
  apply simp
  done

lemma letter_neq: "(a::letter) \<noteq> b \<Longrightarrow> c \<noteq> a \<Longrightarrow> c = b"
  apply (case_tac a)
  apply (case_tac b)
  apply (case_tac c, simp, simp)
  apply (case_tac c, simp, simp)
  apply (case_tac b)
  apply (case_tac c, simp, simp)
  apply (case_tac c, simp, simp)
  done

lemma letter_eq_dec: "(a::letter) = b \<or> a \<noteq> b"
  apply (case_tac a)
  apply (case_tac b)
  apply simp
  apply simp
  apply (case_tac b)
  apply simp
  apply simp
  done

theorem prop2:
  assumes ab: "a \<noteq> b" and bar: "bar xs"
  shows "\<And>ys zs. bar ys \<Longrightarrow> T a xs zs \<Longrightarrow> T b ys zs \<Longrightarrow> bar zs" using bar
proof induct
  fix xs zs assume "T a xs zs" and "good xs"
  hence "good zs" by (rule lemma3)
  then show "bar zs" by (rule bar1)
next
  fix xs ys
  assume I: "\<And>w ys zs. bar ys \<Longrightarrow> T a (w # xs) zs \<Longrightarrow> T b ys zs \<Longrightarrow> bar zs"
  assume "bar ys"
  thus "\<And>zs. T a xs zs \<Longrightarrow> T b ys zs \<Longrightarrow> bar zs"
  proof induct
    fix ys zs assume "T b ys zs" and "good ys"
    then have "good zs" by (rule lemma3)
    then show "bar zs" by (rule bar1)
  next
    fix ys zs assume I': "\<And>w zs. T a xs zs \<Longrightarrow> T b (w # ys) zs \<Longrightarrow> bar zs"
    and ys: "\<And>w. bar (w # ys)" and Ta: "T a xs zs" and Tb: "T b ys zs"
    show "bar zs"
    proof (rule bar2)
      fix w
      show "bar (w # zs)"
      proof (cases w)
        case Nil
        thus ?thesis by simp (rule prop1)
      next
        case (Cons c cs)
        from letter_eq_dec show ?thesis
        proof
          assume ca: "c = a"
          from ab have "bar ((a # cs) # zs)" by (iprover intro: I ys Ta Tb)
          thus ?thesis by (simp add: Cons ca)
        next
          assume "c \<noteq> a"
          with ab have cb: "c = b" by (rule letter_neq)
          from ab have "bar ((b # cs) # zs)" by (iprover intro: I' Ta Tb)
          thus ?thesis by (simp add: Cons cb)
        qed
      qed
    qed
  qed
qed

theorem prop3:
  assumes bar: "bar xs"
  shows "\<And>zs. xs \<noteq> [] \<Longrightarrow> R a xs zs \<Longrightarrow> bar zs" using bar
proof induct
  fix xs zs
  assume "R a xs zs" and "good xs"
  then have "good zs" by (rule lemma2)
  then show "bar zs" by (rule bar1)
next
  fix xs zs
  assume I: "\<And>w zs. w # xs \<noteq> [] \<Longrightarrow> R a (w # xs) zs \<Longrightarrow> bar zs"
  and xsb: "\<And>w. bar (w # xs)" and xsn: "xs \<noteq> []" and R: "R a xs zs"
  show "bar zs"
  proof (rule bar2)
    fix w
    show "bar (w # zs)"
    proof (induct w)
      case Nil
      show ?case by (rule prop1)
    next
      case (Cons c cs)
      from letter_eq_dec show ?case
      proof
        assume "c = a"
        thus ?thesis by (iprover intro: I [simplified] R)
      next
        from R xsn have T: "T a xs zs" by (rule lemma4)
        assume "c \<noteq> a"
        thus ?thesis by (iprover intro: prop2 Cons xsb xsn R T)
      qed
    qed
  qed
qed

theorem higman: "bar []"
proof (rule bar2)
  fix w
  show "bar [w]"
  proof (induct w)
    show "bar [[]]" by (rule prop1)
  next
    fix c cs assume "bar [cs]"
    thus "bar [c # cs]" by (rule prop3) (simp, iprover)
  qed
qed

primrec
  is_prefix :: "'a list \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool"
where
    "is_prefix [] f = True"
  | "is_prefix (x # xs) f = (x = f (length xs) \<and> is_prefix xs f)"

theorem L_idx:
  assumes L: "L w ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>i. emb (f i) w \<and> i < length ws" using L
proof induct
  case (L0 v ws)
  hence "emb (f (length ws)) w" by simp
  moreover have "length ws < length (v # ws)" by simp
  ultimately show ?case by iprover
next
  case (L1 ws v)
  then obtain i where emb: "emb (f i) w" and "i < length ws"
    by simp iprover
  hence "i < length (v # ws)" by simp
  with emb show ?case by iprover
qed

theorem good_idx:
  assumes good: "good ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>i j. emb (f i) (f j) \<and> i < j" using good
proof induct
  case (good0 w ws)
  hence "w = f (length ws)" and "is_prefix ws f" by simp_all
  with good0 show ?case by (iprover dest: L_idx)
next
  case (good1 ws w)
  thus ?case by simp
qed

theorem bar_idx:
  assumes bar: "bar ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>i j. emb (f i) (f j) \<and> i < j" using bar
proof induct
  case (bar1 ws)
  thus ?case by (rule good_idx)
next
  case (bar2 ws)
  hence "is_prefix (f (length ws) # ws) f" by simp
  thus ?case by (rule bar2)
qed

text {*
Strong version: yields indices of words that can be embedded into each other.
*}

theorem higman_idx: "\<exists>(i::nat) j. emb (f i) (f j) \<and> i < j"
proof (rule bar_idx)
  show "bar []" by (rule higman)
  show "is_prefix [] f" by simp
qed

text {*
Weak version: only yield sequence containing words
that can be embedded into each other.
*}

theorem good_prefix_lemma:
  assumes bar: "bar ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>vs. is_prefix vs f \<and> good vs" using bar
proof induct
  case bar1
  thus ?case by iprover
next
  case (bar2 ws)
  from bar2.prems have "is_prefix (f (length ws) # ws) f" by simp
  thus ?case by (iprover intro: bar2)
qed

theorem good_prefix: "\<exists>vs. is_prefix vs f \<and> good vs"
  using higman
  by (rule good_prefix_lemma) simp+

(*<*)
end
(*>*)