theory SumUpAutomat

imports automaton.dAutomaton_causal sumUpAutomat_inc

begin
(*SumUp automaton*)
fun dAsumUp_transition::"S_sumUp \<Rightarrow> (nat) \<Rightarrow> (S_sumUp \<times> nat)"where
"dAsumUp_transition (S n) (input) = (S (n+input),n+input)"

interpretation sumUp_sscanl:sscanlGen "dAsumUp_transition" "S 0" "buildSumUpinSBE" "buildSumUpoutSBE"
  by(unfold_locales)

abbreviation sumUpStep::"(S_sumUp \<Rightarrow> (inSumUp\<^sup>\<Omega> \<rightarrow> outSumUp\<^sup>\<Omega>))"where
"sumUpStep \<equiv> dawStateSem sumUp_sscanl.da"

definition sumUpSpf::"(inSumUp\<^sup>\<Omega> \<rightarrow> outSumUp\<^sup>\<Omega>)"where
"sumUpSpf = dawSem sumUp_sscanl.da"

lemma sumUpingetset_eq:"sumUpInSBE.getterSB\<cdot>(sumUpInSBE.setterSB\<cdot>s) = s"
  by(simp)

lemma sumUpoutgetset_eq:"sumUpOutSBE.getterSB\<cdot> (sumUpOutSBE.setterSB\<cdot>s) = s"
  by(simp)

lemma sumUpstep2sscanl:"sumUpOutSBE.getterSB\<cdot>(sumUpStep state\<cdot>(sumUpInSBE.setterSB\<cdot>input)) = sscanlAsnd dAsumUp_transition state\<cdot>input"
  by (simp add: sumUp_sscanl.daut2sscanl)

lemma sumUp_step_t1:"sscanlAsnd dAsumUp_transition (S n)\<cdot>(\<up>(a) \<bullet> s) = \<up>(n+a) \<bullet> sscanlAsnd dAsumUp_transition (S (n+a))\<cdot>(s)"
  by simp

lemma sumup_invariante:"snth n input \<le> snth n (sumUpOutSBE.getterSB\<cdot>(sumUpStep state\<cdot>(sumUpInSBE.setterSB\<cdot>input)))"
  apply(simp add: sumUpstep2sscanl)
proof(induction n arbitrary: input state)
case 0
  then show ?case
    by(subst scases[of input]; cases state;simp_all)
next
  case (Suc n)
  then show ?case
    by(subst scases[of input]; cases state;simp_all)
qed

end


theory Chapter8
imports "HOL-IMP.Compiler"
begin

text{*
\section*{Chapter 8}

For the following exercises copy and adjust theory @{short_theory "Compiler"}.
Intrepid readers only should attempt to adjust theory @{text Compiler2} too.

\begin{exercise}
A common programming idiom is @{text "IF b THEN c"}, i.e.,
the @{text ELSE}-branch is a @{term SKIP} command.
Look at how, for example, the command @{term "IF Less (V ''x'') (N 5) THEN ''y'' ::= N 3 ELSE SKIP"}
is compiled by @{const ccomp} and identify a possible compiler optimization.
Modify the definition of @{const ccomp} such that it generates fewer instructions
for commands of the form @{term "IF b THEN c ELSE SKIP"}.
Ideally the proof of theorem @{thm[source] ccomp_bigstep} should still work;
otherwise adapt it.
\end{exercise}

\begin{exercise}
Building on Exercise~\ref{exe:IMP:REPEAT}, extend the compiler @{const ccomp}
and its correctness theorem @{thm[source] ccomp_bigstep} to @{text REPEAT}
loops. Hint: the recursion pattern of the big-step semantics
and the compiler for @{text REPEAT} should match.
\end{exercise}

\begin{exercise}\label{exe:COMP:addresses}
Modify the machine language such that instead of variable names to values,
the machine state maps addresses (integers) to values. Adjust the compiler
and its proof accordingly.

In the simple version of this exercise, assume the existence of a globally
bijective function @{term "addr_of :: vname => int"} with @{term "bij addr_of"}
to adjust the compiler. Use the @{text find_theorems} search to find applicable
theorems for bijectivte functions.

For the more advanced version and a slightly larger project, only assume that
the function works on a finite set of variables: those that occur in the
program. For the other, unused variables, it should return a suitable default
address. In this version, you may want to split the work into two parts:
first, update the compiler and machine language, assuming the existence of
such a function and the (partial) inverse it provides. Second, separately
construct this function from the input program, having extracted the
properties needed for it in the first part. In the end, rearrange you theory
file to combine both into a final theorem.
\end{exercise}

\begin{exercise}
This is a slightly more challenging project. Based on
\autoref{exe:COMP:addresses}, and similarly to \autoref{exe:register-machine}
and \autoref{exe:accumulator}, define a second machine language that does not
possess a built-in stack, but instead, in addition to the program counter, a
stack pointer register. Operations that previously worked on the stack now
work on memory, accessing locations based on the stack pointer.

For instance, let @{term "(pc, s, sp)"} be a configuration of this new machine consisting of
program counter, store, and stack pointer. Then the configuration after an @{const ADD} instruction
is \mbox{@{term "(pc + 1::int, s(sp + 1 := s (sp + 1::int) + s sp), sp + 1)"}}, that is, @{const ADD} dereferences
the memory at @{term "sp + 1::int"} and @{term sp}, adds these two values and stores them at
@{term "sp + 1::int"}, updating the values on the stack. It also increases the stack pointer by one
to pop one value from the stack and leave the result at the top of the stack. This means the stack grows downwards.

Modify the compiler from \autoref{exe:COMP:addresses} to work on this new machine language. Reformulate and reprove the easy direction of compiler correctness.

\emph{Hint:} Let the stack start below @{text 0}, growing downwards, and use type @{typ nat} for addressing variable in @{const LOAD} and @{const STORE} instructions, so that it is clear by type that these instructions do not interfere with the stack.

\emph{Hint:} When the new machine pops a value from the stack, this now unused value is left behind in the store. This means, even after executing a purely arithmetic expression, the values in initial and final stores are not all equal. But: they are equal above a given address. Define an abbreviation for this concept and use it to express the intermediate correctness statements.

\end{exercise}

*}
end


section \<open>Generic Algorithms for Graphs\<close>
theory GraphGA
imports
  GraphSpec
begin

  definition gga_from_list ::
    "('V,'W,'G) graph_empty \<Rightarrow> ('V,'W,'G) graph_add_node
      \<Rightarrow> ('V,'W,'G) graph_add_edge
    \<Rightarrow> ('V,'W,'G) graph_from_list"
    where
    "gga_from_list e a u l \<equiv>
      let (nl,el) = l;
        g1 = foldl (\<lambda>g v. a v g) (e ()) nl
      in foldl (\<lambda>g (v,e,v'). u v e v' g) g1 el"

  lemma gga_from_list_correct:
    fixes \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    assumes "graph_empty \<alpha> invar e"
    assumes "graph_add_node \<alpha> invar a"
    assumes "graph_add_edge \<alpha> invar u"
    shows "graph_from_list \<alpha> invar (gga_from_list e a u)"
  proof -
    interpret
      graph_empty \<alpha> invar e +
      graph_add_node \<alpha> invar a +
      graph_add_edge \<alpha> invar u
      by fact+

    {
      fix nl el
      define g1 where "g1 = foldl (\<lambda>g v. a v g) (e ()) nl"
      define g2 where "g2 = foldl (\<lambda>g (v,e,v'). u v e v' g) g1 el"
      have "invar g1 \<and> \<alpha> g1 = \<lparr> nodes = set nl, edges = {} \<rparr>"
        unfolding g1_def
        by (induct nl rule: rev_induct)
           (auto simp: empty_correct add_node_correct empty_def add_node_def)
      hence "invar g2
        \<and> \<alpha> g2 = \<lparr> nodes = set nl \<union> fst`set el \<union> snd`snd`set el,
                    edges = set el \<rparr>"
        unfolding g2_def
        by (induct el rule: rev_induct) (auto simp: add_edge_correct add_edge_def)
      hence "invar g2 \<and> adjl_\<alpha> (nl,el) = \<alpha> g2"
        unfolding adjl_\<alpha>_def by auto
    }
    thus ?thesis
      unfolding gga_from_list_def [abs_def]
      apply unfold_locales
      apply auto
      done
  qed

  term map_iterator_product

  locale gga_edges_it_defs =
    graph_nodes_it_defs nodes_list_it +
    graph_succ_it_defs succ_list_it
    for nodes_list_it :: "('V,'W,'V list,'G) graph_nodes_it"
    and succ_list_it :: "('V,'W,('W\<times>'V) list,'G) graph_succ_it"
  begin
    definition gga_edges_list_it ::
      "('V,'W,('V\<times>'W\<times>'V) list,'G) graph_edges_it"
      where "gga_edges_list_it G \<equiv> set_iterator_product
        (nodes_it G) (succ_it G)"
    local_setup \<open>Locale_Code.lc_decl_del @{term gga_edges_list_it}\<close>
  end
  setup \<open>
    (Record_Intf.add_unf_thms_global @{thms
      gga_edges_it_defs.gga_edges_list_it_def[abs_def]
    })
\<close>

  locale gga_edges_it = gga_edges_it_defs nodes_list_it succ_list_it
    + graph \<alpha> invar
    + graph_nodes_it \<alpha> invar nodes_list_it
    + graph_succ_it \<alpha> invar succ_list_it
    for \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    and invar
    and nodes_list_it :: "('V,'W,'V list,'G) graph_nodes_it"
    and succ_list_it :: "('V,'W,('W\<times>'V) list,'G) graph_succ_it"
  begin
    lemma gga_edges_list_it_impl:
      shows "graph_edges_it \<alpha> invar gga_edges_list_it"
    proof
      fix g
      assume INV: "invar g"

      from set_iterator_product_correct[OF
        nodes_it_correct[OF INV] succ_it_correct[OF INV]]
      have "set_iterator (set_iterator_product (nodes_it g) (\<lambda>v. succ_it g v))
        (SIGMA v:nodes (\<alpha> g). succ (\<alpha> g) v)
        " .
      also have "(SIGMA v:nodes (\<alpha> g). succ (\<alpha> g) v) = edges (\<alpha> g)"
        unfolding succ_def
        by (auto dest: valid_graph.E_validD[OF valid[OF INV]])

      finally show "set_iterator (gga_edges_list_it g) (edges (\<alpha> g))"
        unfolding gga_edges_list_it_def .
    qed
  end

  locale gga_to_list_defs_loc =
    graph_nodes_it_defs nodes_list_it
    + graph_edges_it_defs edges_list_it
    for nodes_list_it :: "('V,'W,'V list,'G) graph_nodes_it"
    and edges_list_it :: "('V,'W,('V\<times>'W\<times>'V) list,'G) graph_edges_it"
  begin
    definition gga_to_list ::
      "('V,'W,'G) graph_to_list"
      where
      "gga_to_list g \<equiv>
        (nodes_it g (\<lambda>_. True) (#) [], edges_it g (\<lambda>_. True) (#) [])
      "
  end

  locale gga_to_list_loc = gga_to_list_defs_loc nodes_list_it edges_list_it +
    graph \<alpha> invar
    + graph_nodes_it \<alpha> invar nodes_list_it
    + graph_edges_it \<alpha> invar edges_list_it
    for \<alpha> :: "'G \<Rightarrow> ('V,'W) graph" and invar
    and nodes_list_it :: "('V,'W,'V list,'G) graph_nodes_it"
    and edges_list_it :: "('V,'W,('V\<times>'W\<times>'V) list,'G) graph_edges_it"
  begin

    lemma gga_to_list_correct:
      shows "graph_to_list \<alpha> invar gga_to_list"
    proof
      fix g
      assume [simp, intro!]: "invar g"
      then interpret valid_graph "\<alpha> g" by (rule valid)

      have "set (nodes_it g (\<lambda>_. True) (#) []) = V"
        apply (rule_tac I="\<lambda>it \<sigma>. set \<sigma> = V - it"
          in set_iterator_rule_P[OF nodes_it_correct])
        by auto
      moreover have "set (edges_it g (\<lambda>_. True) (#) []) = E"
        apply (rule_tac I="\<lambda>it \<sigma>. set \<sigma> = E - it"
          in set_iterator_rule_P[OF edges_it_correct])
        by auto
      ultimately show "adjl_\<alpha> (gga_to_list g) = \<alpha> g"
        unfolding adjl_\<alpha>_def gga_to_list_def
        apply simp
        apply (rule graph.equality)
        apply (auto intro: E_validD)
        done
    qed

  end

end


section {* Backwards Compatibility for Version 1 *}
theory CollectionsV1
imports Collections
begin
  text {*
    This theory defines some stuff to establish (partial) backwards
    compatibility with ICF Version 1.
  *}

  (*
    TODO: Dirty hack to workaround a problem that occurs with sublocale here:
      When declaring

  sublocale poly_map_iteratei < v1_iteratei: map_iteratei \<alpha> invar iteratei
    by (rule v1_iteratei_impl)

      Any further

  interpretation StdMap hm_ops

    will fail with
*** exception TYPE raised (line 414 of "type.ML"):
*** Type variable "?'a" has two distinct sorts
*** ?'a::type
*** ?'a::hashable

  The problem seems difficult to track down, as it, e.g., does not iccur for
  sets.
*)

  attribute_setup locale_witness_add = {*
    Scan.succeed (Locale.witness_add)
    *} "Add witness for locale instantiation. HACK, use
      sublocale or interpretation whereever possible!"

  subsection {* Iterators *}
  text {* We define all the monomorphic iterator locales *}
  subsubsection "Set"
locale set_iteratei = finite_set \<alpha> invar for \<alpha> :: "'s \<Rightarrow> 'x set" and invar +
  fixes iteratei :: "'s \<Rightarrow> ('x, '\<sigma>) set_iterator"

  assumes iteratei_rule: "invar S \<Longrightarrow> set_iterator (iteratei S) (\<alpha> S)"
begin
  lemma iteratei_rule_P:
    "\<lbrakk>
      invar S;
      I (\<alpha> S) \<sigma>0;
      !!x it \<sigma>. \<lbrakk> c \<sigma>; x \<in> it; it \<subseteq> \<alpha> S; I it \<sigma> \<rbrakk> \<Longrightarrow> I (it - {x}) (f x \<sigma>);
      !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
      !!\<sigma> it. \<lbrakk> it \<subseteq> \<alpha> S; it \<noteq> {}; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei S c f \<sigma>0)"
   apply (rule set_iterator_rule_P [OF iteratei_rule, of S I \<sigma>0 c f P])
   apply simp_all
  done

  lemma iteratei_rule_insert_P:
    "\<lbrakk>
      invar S;
      I {} \<sigma>0;
      !!x it \<sigma>. \<lbrakk> c \<sigma>; x \<in> \<alpha> S - it; it \<subseteq> \<alpha> S; I it \<sigma> \<rbrakk> \<Longrightarrow> I (insert x it) (f x \<sigma>);
      !!\<sigma>. I (\<alpha> S) \<sigma> \<Longrightarrow> P \<sigma>;
      !!\<sigma> it. \<lbrakk> it \<subseteq> \<alpha> S; it \<noteq> \<alpha> S; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei S c f \<sigma>0)"
    apply (rule set_iterator_rule_insert_P [OF iteratei_rule, of S I \<sigma>0 c f P])
    apply simp_all
  done

  text {* Versions without break condition. *}
  lemma iterate_rule_P:
    "\<lbrakk>
      invar S;
      I (\<alpha> S) \<sigma>0;
      !!x it \<sigma>. \<lbrakk> x \<in> it; it \<subseteq> \<alpha> S; I it \<sigma> \<rbrakk> \<Longrightarrow> I (it - {x}) (f x \<sigma>);
      !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei S (\<lambda>_. True) f \<sigma>0)"
   apply (rule set_iterator_no_cond_rule_P [OF iteratei_rule, of S I \<sigma>0 f P])
   apply simp_all
  done

  lemma iterate_rule_insert_P:
    "\<lbrakk>
      invar S;
      I {} \<sigma>0;
      !!x it \<sigma>. \<lbrakk> x \<in> \<alpha> S - it; it \<subseteq> \<alpha> S; I it \<sigma> \<rbrakk> \<Longrightarrow> I (insert x it) (f x \<sigma>);
      !!\<sigma>. I (\<alpha> S) \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei S (\<lambda>_. True) f \<sigma>0)"
    apply (rule set_iterator_no_cond_rule_insert_P [OF iteratei_rule, of S I \<sigma>0 f P])
    apply simp_all
  done
end

lemma set_iteratei_I :
assumes "\<And>s. invar s \<Longrightarrow> set_iterator (iti s) (\<alpha> s)"
shows "set_iteratei \<alpha> invar iti"
proof
  fix s
  assume invar_s: "invar s"
  from assms(1)[OF invar_s] show it_OK: "set_iterator (iti s) (\<alpha> s)" .

  from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_def]]
  show "finite (\<alpha> s)" .
qed

  locale set_iterateoi = ordered_finite_set \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) set" and invar
    +
    fixes iterateoi :: "'s \<Rightarrow> ('u,'\<sigma>) set_iterator"
    assumes iterateoi_rule:
      "invar s \<Longrightarrow> set_iterator_linord (iterateoi s) (\<alpha> s)"
  begin
    lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I (\<alpha> m) \<sigma>0"
      assumes IP: "!!k it \<sigma>. \<lbrakk>
        c \<sigma>;
        k \<in> it;
        \<forall>j\<in>it. k\<le>j;
        \<forall>j\<in>\<alpha> m - it. j\<le>k;
        it \<subseteq> \<alpha> m;
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f k \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      assumes II: "!!\<sigma> it. \<lbrakk>
        it \<subseteq> \<alpha> m;
        it \<noteq> {};
        \<not> c \<sigma>;
        I it \<sigma>;
        \<forall>k\<in>it. \<forall>j\<in>\<alpha> m - it. j\<le>k
      \<rbrakk> \<Longrightarrow> P \<sigma>"
      shows "P (iterateoi m c f \<sigma>0)"
    using set_iterator_linord_rule_P [OF iterateoi_rule, OF MINV, of I \<sigma>0 c f P,
       OF I0 _ IF] IP II
    by simp

    lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
      assumes MINV: "invar m"
      assumes I0: "I ((\<alpha> m)) \<sigma>0"
      assumes IP: "!!k it \<sigma>. \<lbrakk> k \<in> it; \<forall>j\<in>it. k\<le>j; \<forall>j\<in>(\<alpha> m) - it. j\<le>k; it \<subseteq> (\<alpha> m); I it \<sigma> \<rbrakk>
                  \<Longrightarrow> I (it - {k}) (f k \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    shows "P (iterateoi m (\<lambda>_. True) f \<sigma>0)"
      apply (rule iterateoi_rule_P [where I = I])
      apply (simp_all add: assms)
    done
  end

  lemma set_iterateoi_I :
  assumes "\<And>s. invar s \<Longrightarrow> set_iterator_linord (itoi s) (\<alpha> s)"
  shows "set_iterateoi \<alpha> invar itoi"
  proof
    fix s
    assume invar_s: "invar s"
    from assms(1)[OF invar_s] show it_OK: "set_iterator_linord (itoi s) (\<alpha> s)" .

    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_linord_def]]
    show "finite (\<alpha> s)" by simp
  qed

  (* Deprecated *)
  locale set_reverse_iterateoi = ordered_finite_set \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) set" and invar
    +
    fixes reverse_iterateoi :: "'s \<Rightarrow> ('u,'\<sigma>) set_iterator"
    assumes reverse_iterateoi_rule: "
      invar m \<Longrightarrow> set_iterator_rev_linord (reverse_iterateoi m) (\<alpha> m)"
  begin
    lemma reverse_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I ((\<alpha> m)) \<sigma>0"
      assumes IP: "!!k it \<sigma>. \<lbrakk>
        c \<sigma>;
        k \<in> it;
        \<forall>j\<in>it. k\<ge>j;
        \<forall>j\<in>(\<alpha> m) - it. j\<ge>k;
        it \<subseteq> (\<alpha> m);
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f k \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      assumes II: "!!\<sigma> it. \<lbrakk>
        it \<subseteq> (\<alpha> m);
        it \<noteq> {};
        \<not> c \<sigma>;
        I it \<sigma>;
        \<forall>k\<in>it. \<forall>j\<in>(\<alpha> m) - it. j\<ge>k
      \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (reverse_iterateoi m c f \<sigma>0)"
    using set_iterator_rev_linord_rule_P [OF reverse_iterateoi_rule, OF MINV, of I \<sigma>0 c f P,
       OF I0 _ IF] IP II
    by simp

    lemma reverse_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
      assumes MINV: "invar m"
      assumes I0: "I ((\<alpha> m)) \<sigma>0"
      assumes IP: "!!k it \<sigma>. \<lbrakk>
        k \<in> it;
        \<forall>j\<in>it. k\<ge>j;
        \<forall>j\<in> (\<alpha> m) - it. j\<ge>k;
        it \<subseteq> (\<alpha> m);
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f k \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    shows "P (reverse_iterateoi m (\<lambda>_. True) f \<sigma>0)"
      apply (rule reverse_iterateoi_rule_P [where I = I])
      apply (simp_all add: assms)
    done
  end

  lemma set_reverse_iterateoi_I :
  assumes "\<And>s. invar s \<Longrightarrow> set_iterator_rev_linord (itoi s) (\<alpha> s)"
  shows "set_reverse_iterateoi \<alpha> invar itoi"
  proof
    fix s
    assume invar_s: "invar s"
    from assms(1)[OF invar_s] show it_OK: "set_iterator_rev_linord (itoi s) (\<alpha> s)" .

    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_rev_linord_def]]
    show "finite (\<alpha> s)" by simp
  qed

  lemma (in poly_set_iteratei) v1_iteratei_impl:
    "set_iteratei \<alpha> invar iteratei"
    by unfold_locales (rule iteratei_correct)
  lemma (in poly_set_iterateoi) v1_iterateoi_impl:
    "set_iterateoi \<alpha> invar iterateoi"
    by unfold_locales (rule iterateoi_correct)
  lemma (in poly_set_rev_iterateoi) v1_reverse_iterateoi_impl:
    "set_reverse_iterateoi \<alpha> invar rev_iterateoi"
    by unfold_locales (rule rev_iterateoi_correct)

  declare (in poly_set_iteratei) v1_iteratei_impl[locale_witness_add]
  declare (in poly_set_iterateoi) v1_iterateoi_impl[locale_witness_add]
  declare (in poly_set_rev_iterateoi)
    v1_reverse_iterateoi_impl[locale_witness_add]

  (* Commented out, as it causes strange errors of the kind:
    Type variable "?'a" has two distinct sorts

  sublocale poly_set_iteratei < v1_iteratei: set_iteratei \<alpha> invar iteratei
    by (rule v1_iteratei_impl)
  sublocale poly_set_iterateoi < v1_iteratei: set_iterateoi \<alpha> invar iterateoi
    by (rule v1_iterateoi_impl)
  sublocale poly_set_rev_iterateoi
    < v1_iteratei!: set_reverse_iterateoi \<alpha> invar rev_iterateoi
    by (rule v1_reverse_iterateoi_impl)
    *)

subsubsection "Map"
locale map_iteratei = finite_map \<alpha> invar for \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v" and invar +
  fixes iteratei :: "'s \<Rightarrow> ('u \<times> 'v,'\<sigma>) set_iterator"

  assumes iteratei_rule: "invar m \<Longrightarrow> map_iterator (iteratei m) (\<alpha> m)"
begin

  lemma iteratei_rule_P:
    assumes "invar m"
        and I0: "I (dom (\<alpha> m)) \<sigma>0"
        and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                    \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
        and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
        and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom (\<alpha> m); it \<noteq> {}; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iteratei m c f \<sigma>0)"
    using map_iterator_rule_P [OF iteratei_rule, of m I \<sigma>0 c f P]
    by (simp_all add: assms)

  lemma iteratei_rule_insert_P:
    assumes
      "invar m"
      "I {} \<sigma>0"
      "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> (dom (\<alpha> m) - it); \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
          \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
      "!!\<sigma>. I (dom (\<alpha> m)) \<sigma> \<Longrightarrow> P \<sigma>"
      "!!\<sigma> it. \<lbrakk> it \<subseteq> dom (\<alpha> m); it \<noteq> dom (\<alpha> m);
               \<not> (c \<sigma>);
               I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iteratei m c f \<sigma>0)"
    using map_iterator_rule_insert_P [OF iteratei_rule, of m I \<sigma>0 c f P]
    by (simp_all add: assms)

  lemma iterate_rule_P:
    "\<lbrakk>
      invar m;
      I (dom (\<alpha> m)) \<sigma>0;
      !!k v it \<sigma>. \<lbrakk> k \<in> it; \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                  \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>);
      !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei m (\<lambda>_. True) f \<sigma>0)"
    using iteratei_rule_P [of m I \<sigma>0 "\<lambda>_. True" f P]
    by fast

  lemma iterate_rule_insert_P:
    "\<lbrakk>
      invar m;
      I {} \<sigma>0;
      !!k v it \<sigma>. \<lbrakk> k \<in> (dom (\<alpha> m) - it); \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                  \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>);
      !!\<sigma>. I (dom (\<alpha> m)) \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei m (\<lambda>_. True) f \<sigma>0)"
    using iteratei_rule_insert_P [of m I \<sigma>0 "\<lambda>_. True" f P]
    by fast
end

lemma map_iteratei_I :
  assumes "\<And>m. invar m \<Longrightarrow> map_iterator (iti m) (\<alpha> m)"
  shows "map_iteratei \<alpha> invar iti"
proof
  fix m
  assume invar_m: "invar m"
  from assms(1)[OF invar_m] show it_OK: "map_iterator (iti m) (\<alpha> m)" .

  from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_def]]
  show "finite (dom (\<alpha> m))" by (simp add: finite_map_to_set)
qed

  locale map_iterateoi = ordered_finite_map \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) \<rightharpoonup> 'v" and invar
    +
    fixes iterateoi :: "'s \<Rightarrow> ('u \<times> 'v,'\<sigma>) set_iterator"
    assumes iterateoi_rule: "
      invar m \<Longrightarrow> map_iterator_linord (iterateoi m) (\<alpha> m)"
  begin
    lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
      assumes IP: "!!k v it \<sigma>. \<lbrakk>
        c \<sigma>;
        k \<in> it;
        \<forall>j\<in>it. k\<le>j;
        \<forall>j\<in>dom (\<alpha> m) - it. j\<le>k;
        \<alpha> m k = Some v;
        it \<subseteq> dom (\<alpha> m);
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      assumes II: "!!\<sigma> it. \<lbrakk>
        it \<subseteq> dom (\<alpha> m);
        it \<noteq> {};
        \<not> c \<sigma>;
        I it \<sigma>;
        \<forall>k\<in>it. \<forall>j\<in>dom (\<alpha> m) - it. j\<le>k
      \<rbrakk> \<Longrightarrow> P \<sigma>"
      shows "P (iterateoi m c f \<sigma>0)"
    using map_iterator_linord_rule_P [OF iterateoi_rule, of m I \<sigma>0 c f P] assms
    by simp

    lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
      assumes IP: "!!k v it \<sigma>. \<lbrakk> k \<in> it; \<forall>j\<in>it. k\<le>j; \<forall>j\<in>dom (\<alpha> m) - it. j\<le>k; \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                  \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      shows "P (iterateoi m (\<lambda>_. True) f \<sigma>0)"
    using map_iterator_linord_rule_P [OF iterateoi_rule, of m I \<sigma>0 "\<lambda>_. True" f P] assms
    by simp
  end

  lemma map_iterateoi_I :
  assumes "\<And>m. invar m \<Longrightarrow> map_iterator_linord (itoi m) (\<alpha> m)"
  shows "map_iterateoi \<alpha> invar itoi"
  proof
    fix m
    assume invar_m: "invar m"
    from assms(1)[OF invar_m] show it_OK: "map_iterator_linord (itoi m) (\<alpha> m)" .

    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_map_linord_def]]
    show "finite (dom (\<alpha> m))" by (simp add: finite_map_to_set)
  qed

  locale map_reverse_iterateoi = ordered_finite_map \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) \<rightharpoonup> 'v" and invar
    +
    fixes reverse_iterateoi :: "'s \<Rightarrow> ('u \<times> 'v,'\<sigma>) set_iterator"
    assumes reverse_iterateoi_rule: "
      invar m \<Longrightarrow> map_iterator_rev_linord (reverse_iterateoi m) (\<alpha> m)"
  begin
    lemma reverse_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
      assumes IP: "!!k v it \<sigma>. \<lbrakk>
        c \<sigma>;
        k \<in> it;
        \<forall>j\<in>it. k\<ge>j;
        \<forall>j\<in>dom (\<alpha> m) - it. j\<ge>k;
        \<alpha> m k = Some v;
        it \<subseteq> dom (\<alpha> m);
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      assumes II: "!!\<sigma> it. \<lbrakk>
        it \<subseteq> dom (\<alpha> m);
        it \<noteq> {};
        \<not> c \<sigma>;
        I it \<sigma>;
        \<forall>k\<in>it. \<forall>j\<in>dom (\<alpha> m) - it. j\<ge>k
      \<rbrakk> \<Longrightarrow> P \<sigma>"
      shows "P (reverse_iterateoi m c f \<sigma>0)"
    using map_iterator_rev_linord_rule_P [OF reverse_iterateoi_rule, of m I \<sigma>0 c f P] assms
    by simp

    lemma reverse_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
      assumes IP: "!!k v it \<sigma>. \<lbrakk>
        k \<in> it;
        \<forall>j\<in>it. k\<ge>j;
        \<forall>j\<in>dom (\<alpha> m) - it. j\<ge>k;
        \<alpha> m k = Some v;
        it \<subseteq> dom (\<alpha> m);
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      shows "P (reverse_iterateoi m (\<lambda>_. True) f \<sigma>0)"
    using map_iterator_rev_linord_rule_P[OF reverse_iterateoi_rule, of m I \<sigma>0 "\<lambda>_. True" f P] assms
    by simp
  end

  lemma map_reverse_iterateoi_I :
  assumes "\<And>m. invar m \<Longrightarrow> map_iterator_rev_linord (ritoi m) (\<alpha> m)"
  shows "map_reverse_iterateoi \<alpha> invar ritoi"
  proof
    fix m
    assume invar_m: "invar m"
    from assms(1)[OF invar_m] show it_OK: "map_iterator_rev_linord (ritoi m) (\<alpha> m)" .

    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_map_rev_linord_def]]
    show "finite (dom (\<alpha> m))" by (simp add: finite_map_to_set)
  qed

  lemma (in poly_map_iteratei) v1_iteratei_impl:
    "map_iteratei \<alpha> invar iteratei"
    by unfold_locales (rule iteratei_correct)
  lemma (in poly_map_iterateoi) v1_iterateoi_impl:
    "map_iterateoi \<alpha> invar iterateoi"
    by unfold_locales (rule iterateoi_correct)
  lemma (in poly_map_rev_iterateoi) v1_reverse_iterateoi_impl:
    "map_reverse_iterateoi \<alpha> invar rev_iterateoi"
    by unfold_locales (rule rev_iterateoi_correct)

  declare (in poly_map_iteratei) v1_iteratei_impl[locale_witness_add]
  declare (in poly_map_iterateoi) v1_iterateoi_impl[locale_witness_add]
  declare (in poly_map_rev_iterateoi)
    v1_reverse_iterateoi_impl[locale_witness_add]

  (*
  sublocale poly_map_iteratei < v1_iteratei: map_iteratei \<alpha> invar iteratei
    by (rule v1_iteratei_impl)
  sublocale poly_map_iterateoi < v1_iteratei: map_iterateoi \<alpha> invar iterateoi
    by (rule v1_iterateoi_impl)
  sublocale poly_map_rev_iterateoi
    < v1_iteratei!: map_reverse_iterateoi \<alpha> invar rev_iterateoi
    by (rule v1_reverse_iterateoi_impl)
    *)

  subsection {* Concrete Operation Names *}
  text {* We define abbreviations to recover the @{text "xx_op"}-names *}

  (* TODO: This may take long, as Local_Theory.abbrev seems to be really slow *)
  local_setup {* let
    val thy = @{theory}
    val ctxt = Proof_Context.init_global thy;
    val pats = [
    "hs","hm",
    "rs","rm",
    "ls","lm","lsi","lmi","lsnd","lss",
    "ts","tm",
    "ias","iam",
    "ahs","ahm",
    "bino",
    "fifo",
    "ft",
    "alprioi",
    "aluprioi",
    "skew"
    ];

    val {const_space, constants, ...} = Sign.consts_of thy |> Consts.dest
    val clist = Name_Space.extern_entries true ctxt const_space constants |> map (apfst #1)

    fun abbrevs_for pat = clist
    |> map_filter (fn (n,_) => case Long_Name.explode n of
        [_,prefix,opname] =>
          if prefix = pat then let
              val aname = prefix ^ "_" ^ opname
              val rhs = Proof_Context.read_term_abbrev ctxt n
            in SOME (aname,rhs) end
          else NONE
      | _ => NONE);

    fun do_abbrevs pat lthy = let
      val abbrevs = abbrevs_for pat;
    in
      case abbrevs of [] => (warning ("No stuff found for "^pat); lthy)
      | _ => let
        (*val _ = tracing ("Defining " ^ pat ^ "_xxx ...");*)
        val lthy = fold (fn (name,rhs) =>
          Local_Theory.abbrev
            Syntax.mode_input
            ((Binding.name name,Mixfix.NoSyn),rhs) #> #2
        ) abbrevs lthy
        (*val _ = tracing "Done";*)
      in lthy end
    end
  in
    fold do_abbrevs pats
  end

    *}

lemmas hs_correct = hs.correct
lemmas hm_correct = hm.correct
lemmas rs_correct = rs.correct
lemmas rm_correct = rm.correct
lemmas ls_correct = ls.correct
lemmas lm_correct = lm.correct
lemmas lsi_correct = lsi.correct
lemmas lmi_correct = lmi.correct
lemmas lsnd_correct = lsnd.correct
lemmas lss_correct = lss.correct
lemmas ts_correct = ts.correct
lemmas tm_correct = tm.correct
lemmas ias_correct = ias.correct
lemmas iam_correct = iam.correct
lemmas ahs_correct = ahs.correct
lemmas ahm_correct = ahm.correct
lemmas bino_correct = bino.correct
lemmas fifo_correct = fifo.correct
lemmas ft_correct = ft.correct
lemmas alprioi_correct = alprioi.correct
lemmas aluprioi_correct = aluprioi.correct
lemmas skew_correct = skew.correct

locale list_enqueue = list_appendr
locale list_dequeue = list_removel

locale list_push = list_appendl
locale list_pop = list_remover
locale list_top = list_leftmost
locale list_bot = list_rightmost

instantiation rbt :: ("{equal,linorder}",equal) equal
begin
  (*definition equal_rbt :: "('a,'b) RBT.rbt \<Rightarrow> _" where "equal_rbt \<equiv> op ="*)

  definition "equal_class.equal (r :: ('a, 'b) rbt) r'
    == RBT.impl_of r = RBT.impl_of r'"

  instance
    apply intro_classes
    apply (simp add: equal_rbt_def RBT.impl_of_inject)
    done
end

end


(*
    Title:      Code_Set.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section "Code set"

theory Code_Set
imports
  "HOL-Library.Cardinality"
begin

text\<open>The following setup could help to get code generation for List.coset,
  but it neither works correctly it complains that code
  equations for remove are missed, even when List.coset should be rewritten
  to an enum:\<close>

declare minus_coset_filter [code del]
declare remove_code(2) [code del]
declare insert_code(2) [code del]
declare inter_coset_fold [code del]
declare compl_coset[code del]
declare Cardinality.card'_code(2)[code del]

code_datatype set

text\<open>The following code equation could be useful to avoid the problem of
  code generation for List.coset []:\<close>

text\<open>Now the following examples work:\<close>

value "UNIV::bool set"
value "List.coset ([]::bool list)"
value "UNIV::Enum.finite_2 set"
value "List.coset ([]::Enum.finite_2 list)"
value "List.coset ([]::Enum.finite_5 list)"

end