section \<open>Implementation of Nondeterministic Büchi Automata\<close>

theory NBA_Implement
imports
  "NBA_Refine"
  "../../Basic/Implement"
begin

  consts i_nba_scheme :: "interface \<Rightarrow> interface \<Rightarrow> interface"

  context
  begin

    interpretation autoref_syn by this

    lemma nba_scheme_itype[autoref_itype]:
      "nba ::\<^sub>i \<langle>L\<rangle>\<^sub>i i_set \<rightarrow>\<^sub>i \<langle>S\<rangle>\<^sub>i i_set \<rightarrow>\<^sub>i (L \<rightarrow>\<^sub>i S \<rightarrow>\<^sub>i \<langle>S\<rangle>\<^sub>i i_set) \<rightarrow>\<^sub>i \<langle>S\<rangle>\<^sub>i i_set \<rightarrow>\<^sub>i
        \<langle>L, S\<rangle>\<^sub>i i_nba_scheme"
      "alphabet ::\<^sub>i \<langle>L, S\<rangle>\<^sub>i i_nba_scheme \<rightarrow>\<^sub>i \<langle>L\<rangle>\<^sub>i i_set"
      "initial ::\<^sub>i \<langle>L, S\<rangle>\<^sub>i i_nba_scheme \<rightarrow>\<^sub>i \<langle>S\<rangle>\<^sub>i i_set"
      "transition ::\<^sub>i \<langle>L, S\<rangle>\<^sub>i i_nba_scheme \<rightarrow>\<^sub>i L \<rightarrow>\<^sub>i S \<rightarrow>\<^sub>i \<langle>S\<rangle>\<^sub>i i_set"
      "accepting ::\<^sub>i \<langle>L, S\<rangle>\<^sub>i i_nba_scheme \<rightarrow>\<^sub>i \<langle>S\<rangle>\<^sub>i i_set"
      by auto

  end

  datatype ('label, 'state) nbai = nbai
    (alphabeti: "'label list")
    (initiali: "'state list")
    (transitioni: "'label \<Rightarrow> 'state \<Rightarrow> 'state list")
    (acceptingi: "'state \<Rightarrow> bool")

  definition nbai_rel :: "('label\<^sub>1 \<times> 'label\<^sub>2) set \<Rightarrow> ('state\<^sub>1 \<times> 'state\<^sub>2) set \<Rightarrow>
    (('label\<^sub>1, 'state\<^sub>1) nbai \<times> ('label\<^sub>2, 'state\<^sub>2) nbai) set" where
    [to_relAPP]: "nbai_rel L S \<equiv> {(A\<^sub>1, A\<^sub>2).
      (alphabeti A\<^sub>1, alphabeti A\<^sub>2) \<in> \<langle>L\<rangle> list_rel \<and>
      (initiali A\<^sub>1, initiali A\<^sub>2) \<in> \<langle>S\<rangle> list_rel \<and>
      (transitioni A\<^sub>1, transitioni A\<^sub>2) \<in> L \<rightarrow> S \<rightarrow> \<langle>S\<rangle> list_rel \<and>
      (acceptingi A\<^sub>1, acceptingi A\<^sub>2) \<in> S \<rightarrow> bool_rel}"

  lemma nbai_param[param, autoref_rules]:
    "(nbai, nbai) \<in> \<langle>L\<rangle> list_rel \<rightarrow> \<langle>S\<rangle> list_rel \<rightarrow> (L \<rightarrow> S \<rightarrow> \<langle>S\<rangle> list_rel) \<rightarrow>
      (S \<rightarrow> bool_rel) \<rightarrow> \<langle>L, S\<rangle> nbai_rel"
    "(alphabeti, alphabeti) \<in> \<langle>L, S\<rangle> nbai_rel \<rightarrow> \<langle>L\<rangle> list_rel"
    "(initiali, initiali) \<in> \<langle>L, S\<rangle> nbai_rel \<rightarrow> \<langle>S\<rangle> list_rel"
    "(transitioni, transitioni) \<in> \<langle>L, S\<rangle> nbai_rel \<rightarrow> L \<rightarrow> S \<rightarrow> \<langle>S\<rangle> list_rel"
    "(acceptingi, acceptingi) \<in> \<langle>L, S\<rangle> nbai_rel \<rightarrow> (S \<rightarrow> bool_rel)"
    unfolding nbai_rel_def fun_rel_def by auto

  definition nbai_nba_rel :: "('label\<^sub>1 \<times> 'label\<^sub>2) set \<Rightarrow> ('state\<^sub>1 \<times> 'state\<^sub>2) set \<Rightarrow>
    (('label\<^sub>1, 'state\<^sub>1) nbai \<times> ('label\<^sub>2, 'state\<^sub>2) nba) set" where
    [to_relAPP]: "nbai_nba_rel L S \<equiv> {(A\<^sub>1, A\<^sub>2).
      (alphabeti A\<^sub>1, alphabet A\<^sub>2) \<in> \<langle>L\<rangle> list_set_rel \<and>
      (initiali A\<^sub>1, initial A\<^sub>2) \<in> \<langle>S\<rangle> list_set_rel \<and>
      (transitioni A\<^sub>1, transition A\<^sub>2) \<in> L \<rightarrow> S \<rightarrow> \<langle>S\<rangle> list_set_rel \<and>
      (acceptingi A\<^sub>1, accepting A\<^sub>2) \<in> S \<rightarrow> bool_rel}"

  lemmas [autoref_rel_intf] = REL_INTFI[of nbai_nba_rel i_nba_scheme]

  (* TODO: why is there a warning? *)
  lemma nbai_nba_param[param, autoref_rules]:
    "(nbai, nba) \<in> \<langle>L\<rangle> list_set_rel \<rightarrow> \<langle>S\<rangle> list_set_rel \<rightarrow> (L \<rightarrow> S \<rightarrow> \<langle>S\<rangle> list_set_rel) \<rightarrow>
      (S \<rightarrow> bool_rel) \<rightarrow> \<langle>L, S\<rangle> nbai_nba_rel"
    "(alphabeti, alphabet) \<in> \<langle>L, S\<rangle> nbai_nba_rel \<rightarrow> \<langle>L\<rangle> list_set_rel"
    "(initiali, initial) \<in> \<langle>L, S\<rangle> nbai_nba_rel \<rightarrow> \<langle>S\<rangle> list_set_rel"
    "(transitioni, transition) \<in> \<langle>L, S\<rangle> nbai_nba_rel \<rightarrow> L \<rightarrow> S \<rightarrow> \<langle>S\<rangle> list_set_rel"
    "(acceptingi, accepting) \<in> \<langle>L, S\<rangle> nbai_nba_rel \<rightarrow> S \<rightarrow> bool_rel"
    unfolding nbai_nba_rel_def fun_rel_def by auto

  definition nbai_nba :: "('label, 'state) nbai \<Rightarrow> ('label, 'state) nba" where
    "nbai_nba A \<equiv> nba (set (alphabeti A)) (set (initiali A)) (\<lambda> a p. set (transitioni A a p)) (acceptingi A)"
  definition nbai_invar :: "('label, 'state) nbai \<Rightarrow> bool" where
    "nbai_invar A \<equiv> distinct (alphabeti A) \<and> distinct (initiali A) \<and> (\<forall> a p. distinct (transitioni A a p))"

  lemma nbai_nba_id_param[param]: "(nbai_nba, id) \<in> \<langle>L, S\<rangle> nbai_nba_rel \<rightarrow> \<langle>L, S\<rangle> nba_rel"
  proof
    fix Ai A
    assume 1: "(Ai, A) \<in> \<langle>L, S\<rangle> nbai_nba_rel"
    have 2: "nbai_nba Ai = nba (set (alphabeti Ai)) (set (initiali Ai))
      (\<lambda> a p. set (transitioni Ai a p)) (acceptingi Ai)" unfolding nbai_nba_def by rule
    have 3: "id A = nba (id (alphabet A)) (id (initial A))
      (\<lambda> a p. id (transition A a p)) (accepting A)" by simp
    show "(nbai_nba Ai, id A) \<in> \<langle>L, S\<rangle> nba_rel" unfolding 2 3 using 1 by parametricity
  qed

  lemma nbai_nba_br: "\<langle>Id, Id\<rangle> nbai_nba_rel = br nbai_nba nbai_invar"
  proof safe
    show "(A, B) \<in> \<langle>Id, Id\<rangle> nbai_nba_rel" if "(A, B) \<in> br nbai_nba nbai_invar"
      for A and B :: "('a, 'b) nba"
      using that unfolding nbai_nba_rel_def nbai_nba_def nbai_invar_def
      by (auto simp: in_br_conv list_set_rel_def)
    show "(A, B) \<in> br nbai_nba nbai_invar" if "(A, B) \<in> \<langle>Id, Id\<rangle> nbai_nba_rel"
      for A and B :: "('a, 'b) nba"
    proof -
      have 1: "(nbai_nba A, id B) \<in> \<langle>Id, Id\<rangle> nba_rel" using that by parametricity
      have 2: "nbai_invar A"
        using nbai_nba_param(2 - 5)[param_fo, OF that]
        by (auto simp: in_br_conv list_set_rel_def nbai_invar_def)
      show ?thesis using 1 2 unfolding in_br_conv by auto
    qed
  qed

end


theory Extended_Assertion_Exceptions
  imports
    Abstract_Rbt
    Assertion_Tree_Lookup
    Utilities_Ext
begin

context rbt_impl
begin

lemma rbt_less_value_ex_eq_2 [simp]:
  "rbt_of t |\<guillemotleft> kn \<Longrightarrow> rbt_assn_ext t (ex - {kn}) ti = rbt_assn_ext t ex ti"
proof (induction t arbitrary: ti)
  case ATEmpty
  show ?case by simp
next
  case (ATBranch c k v ci li ki vi ri l r)

  hence "kn \<noteq> k" by auto

  with ATBranch show ?case
    unfolding rbt_assn_ext_unfold
    apply simp
    done
qed

lemma rbt_less_value_ex_eq_1 [simp]:
  "rbt_of t |\<guillemotleft> kn \<Longrightarrow> rbt_assn_ext t (Set.insert kn ex) ti = rbt_assn_ext t ex ti"
  apply (subst rbt_less_value_ex_eq_2[symmetric]) by simp+

lemma rbt_greater_value_ex_eq_2 [simp]:
  "kn \<guillemotleft>| rbt_of t \<Longrightarrow> rbt_assn_ext t (ex - {kn}) ti = rbt_assn_ext t ex ti"
proof (induction t arbitrary: ti)
  case ATEmpty
  show ?case by simp
next
  case (ATBranch c k v ci li ki vi ri l r)

  hence "kn \<noteq> k" by auto

  with ATBranch show ?case
    unfolding rbt_assn_ext_unfold
    apply simp
    done
qed

lemma rbt_greater_value_ex_eq_1 [simp]:
  "kn \<guillemotleft>| rbt_of t \<Longrightarrow> rbt_assn_ext t (Set.insert kn ex) ti = rbt_assn_ext t ex ti"
  apply (subst rbt_greater_value_ex_eq_2[symmetric]) by simp+

lemma [simp]:
  "kn < k \<Longrightarrow> value_of_key (ATBranch c k v ci li ki vi ri l r) kn = value_of_key l kn"
  unfolding value_of_key_def apply (simp add: value_of_key'.simps)
  unfolding value_of_key'.simps[symmetric]
  using value_of_key'_value_of_key_eq by metis

lemma [simp]:
  "k < kn \<Longrightarrow> value_of_key (ATBranch c k v ci li ki vi ri l r) kn = value_of_key r kn"
  unfolding value_of_key_def apply (auto simp add: value_of_key'.simps)
  unfolding value_of_key'.simps[symmetric]
  using value_of_key'_value_of_key_eq by metis

lemma [simp]:
  "value_of_key (ATBranch c k v ci li ki vi ri l r) k = Some vi"
  unfolding value_of_key_def apply (auto simp add: value_of_key'.simps)
  done

lemma value_ex_split_ent:
  assumes
    "value_of_key t kn = Some vi" and
    "kn \<notin> ex" and
    "rbt_sorted (rbt_of t)"
  shows
    "
      rbt_assn_ext t ex ti \<turnstile> rbt_assn_ext t ({kn} \<union> ex) ti ** \<upharpoonleft>value_assn (the (rbt_lookup (rbt_of t) kn)) vi
    "
  using assms
proof(induction t arbitrary: ti)
  case ATEmpty
  then show ?case by simp
next
  case (ATBranch c k v ci li ki vi ri l r)
  then show ?case
      proof(cases kn k rule: linorder_cases)
        case less

        note ATBranch(1)[isep_dest]

        from less have "k \<noteq> kn" by simp
        moreover from less ATBranch(5) have "kn \<guillemotleft>| rbt_of r"
          using rbt_greater_trans by auto

        ultimately show ?thesis using less ATBranch(3-5)
          unfolding rbt_assn_ext_unfold
          apply simp
          apply (sepwith simp)
          apply simp
          done
      next
        case equal
        with ATBranch show ?thesis
          unfolding rbt_assn_ext_unfold
          apply -
          apply (sepEwith \<open>auto intro: rbt_less_trans rbt_greater_trans\<close>)
          apply simp
          apply sep
          done
      next
        case greater

        note ATBranch(2)[isep_dest]

        from greater have "k \<noteq> kn" by simp
        moreover from greater ATBranch(5) have "rbt_of l |\<guillemotleft> kn"
          using rbt_less_trans by auto

        ultimately show ?thesis using greater ATBranch(3-5)
          unfolding rbt_assn_ext_unfold
          apply auto[]
          apply (sepwith \<open>simp add: order_less_not_sym\<close>)
          apply simp
          done
      qed
qed

lemma value_ex_split_red:
  assumes
    "value_of_key t kn = Some vi" and
    "kn \<notin> ex" and
    "rbt_sorted (rbt_of t)"
  shows
    "
      is_sep_red (rbt_assn_ext t (ex \<union> {kn}) ti) \<box> (rbt_assn_ext t ex ti) (\<upharpoonleft>value_assn (the (rbt_lookup (rbt_of t) kn)) vi)
    "
  apply (rule is_sep_redI)
  subgoal premises prems
    apply (sep isep_dest: value_ex_split_ent)
    using assms apply auto
    apply (sep isep_dest: prems[simplified])
    done
  done

lemma value_ex_join_ent':
  assumes
    "value_of_key t kn = Some vi" and
    "kn \<in> ex" and
    "rbt_sorted (rbt_of t)"
  shows
    "
    rbt_assn_ext t ex ti ** \<upharpoonleft>value_assn v vi \<turnstile>
    (EXS t_res.
      rbt_assn_ext t_res (ex - {kn}) ti **
      \<up>(rbt_of t_res = rbt_update kn v (rbt_of t)) **
      ctx(rbt_sorted (rbt_of t_res)) **
      \<up>(ptr_of_key t_res ti = ptr_of_key t ti) **
      \<up>(value_of_key t_res = value_of_key t)
    )
    "
  using assms
proof (induction t arbitrary: ti)
  case ATEmpty
  then show ?case by simp
next
  case (ATBranch c k v ci li ki vi ri l r)
  show ?case
  proof(cases kn k rule: linorder_cases)
    case less
    note ATBranch(2)[isep_dest]

    from less have "kn \<noteq> k" by simp
    moreover from ATBranch(5) rbt_greater_trans less have "kn \<guillemotleft>| rbt_of r" by auto

    ultimately show ?thesis using ATBranch(3-5) less
      apply -
      unfolding rbt_assn_ext_unfold
      apply (isep_drule drule: ATBranch(1))
      apply (auto)[3]

      apply (sepEwith \<open>(solves auto)?\<close>)
       apply (simp add: rbt_map_entry_rbt_less rbt_map_entry_rbt_sorted)

      apply (sepEwith \<open>solves pok_solver | solves vok_solver\<close>)
      apply simp
      apply sep
      done
  next
    case equal
    with ATBranch(3-5) show ?thesis
      unfolding rbt_assn_ext_unfold
      apply -
      apply (sepEwith \<open>solves pok_solver | solves vok_solver\<close>)
      apply simp
      apply sep
      done
  next
    case greater
    note ATBranch(2)[isep_dest]

    from greater have "\<not>kn < k" by simp
    moreover from greater have "kn \<noteq> k" by simp
    moreover from ATBranch(5) rbt_less_trans greater have "rbt_of l |\<guillemotleft> kn" by auto

    ultimately show ?thesis using ATBranch(3-5) greater
      apply -
      unfolding rbt_assn_ext_unfold
      apply (isep_drule drule: ATBranch(2))
      apply (auto)[3]

      apply (sepEwith \<open>(solves auto)?\<close>)
       apply (simp add: rbt_map_entry_rbt_greater rbt_map_entry_rbt_sorted)

      apply (sepEwith \<open>solves pok_solver | solves vok_solver\<close>)
      apply simp
      apply sep
      done
  qed
qed

lemmas value_ex_join_ent = value_ex_join_ent'[simplified ctx_def]

lemma value_ex_join_red:
  "rbt_sorted (rbt_of t1) \<Longrightarrow> k \<in> ex \<Longrightarrow> k \<notin> ex' \<Longrightarrow> value_of_key t1 k = Some vi \<Longrightarrow>
  is_sep_red
  (EXS t2. rbt_assn_ext t2 (ex - {k}) ti ** \<up>(rbt_of t2 = rbt_update k v (rbt_of t1)))
  (EXS t3. rbt_assn_ext t3 ex' ti)
  (rbt_assn_ext t1 ex ti ** \<upharpoonleft>value_assn v vi)
  (EXS t3. rbt_assn_ext t3 ex' ti)
  "
  apply (rule is_sep_redI)
  subgoal premises prems for Ps Qs
  apply (rule entails_trans[OF _ prems(5)])
    apply (isep_drule drule: value_ex_join_ent)
    using prems(1-4) apply auto[3]
    apply sepE
    done
  done

end

end


theory VendingMachine = Main:

use tactics

method_setup circular_coinduction = "build_tactic (circular_coinduction_fun)" "all"
method_setup coinduction = "build_tactic (coinduction_fun)" "rule_tac R=?Rzero in ga_cogenerated, instantiate_tac Rzero %s1.?R,step"
method_setup init = "build_tactic (init_fun)" "(simp|(solve,blast))?,init2_fun?"
method_setup breakup = "build_tactic (breakup_fun)" "simp,((exE|conjE)+)?,disjE"
method_setup solve= "build_tactic (solve_fun 1)" "((exE|conjE|conjI)+)?,(simp)?,((exE|conjE|conjI)+)?,(simp)?"
method_setup step = "build_tactic (step_fun)" "((disjI2)+)?,inst r (rcs union (trans r))"
method_setup close= "build_tactic (close_fun)" "((disjI1|disjI2)+)?,((exE|conjE)+)?,force_solve|solve,disji1+,blast"
method_setup close_or_step= "build_tactic (close_or_step_fun)" "close|(solve,(close|(step,solve?,disjI2?,solve?,xy_exi?,solve,close?),((disjI1+)?,blast,close)?))"
method_setup force_finish = "build_tactic (force_finish_fun)" "inst r false,solve1"

typedecl "VendingMachine"
datatype Nat = zero | succ "Nat"
consts

"initial" :: "VendingMachine"
"quarter" :: "VendingMachine => VendingMachine"
"dollar" :: "VendingMachine => VendingMachine"
"tea" :: "VendingMachine => VendingMachine"
"coffee" :: "VendingMachine => VendingMachine"
"get_current" :: "VendingMachine => Nat"
"zero" :: "Nat"
"succ" :: "Nat => Nat"
"add" :: "Nat => Nat => Nat"
"double" :: "Nat => Nat"

consts
  BinRelImage :: "('a => 'b) => ('a => 'a => bool) => ('b => 'b => bool)"
  Trans_VendingMachine :: "('a => 'a => bool) => ('b => 'b => bool)"
  union :: "('a => 'a => bool)  => ('a => 'a => bool) => ('a => 'a => bool)" (infixl 20)
defs
  BinRelImage_def [simp] : "BinRelImage f R == %x y . EX u v . R u v & x = f u & y = f v"
  Trans_VendingMachine_def [simp] : "Trans_VendingMachine R == (BinRelImage quarter R) union
                                                               (BinRelImage dollar R) union
                                                               (BinRelImage tea R) union
                                                               (BinRelImage coffee R)"
  union_def [simp] : "R union S == % x y . R x y | S x y"

axioms
ga_generated_Nat: "True"

initial_def [simp] : "get_current initial = zero"
quarter_gc [simp] : "!! v :: VendingMachine . get_current (quarter v) = succ (get_current v)"
dollar_gc [simp] : "!! v :: VendingMachine . get_current (dollar v) = succ (succ (succ (succ (get_current v))))"
tea_gc [simp] : "!! n :: Nat . !! v :: VendingMachine . get_current v = succ (succ (succ (succ n))) ==> get_current (tea v) = n"
tea_q1 [simp] : "!! v :: VendingMachine . tea (quarter (quarter (quarter (quarter v)))) = v"
tea_q2 [simp] : "!! v :: VendingMachine . tea (dollar v) = v"
coffee_gc [simp] : "!! n :: Nat . !! v :: VendingMachine . get_current v = succ (succ (succ (succ (succ (succ n))))) ==> get_current (coffee v) = n"
coffee_q1 [simp] : "!! v :: VendingMachine . coffee (quarter (quarter (quarter (quarter (quarter (quarter v)))))) = v"
coffee_q2 [simp] : "!! v :: VendingMachine . coffee (quarter (quarter (dollar v))) = v"
coffee_q3 [simp] : "!! v :: VendingMachine . coffee (dollar (dollar v)) = quarter (quarter v)"
coffee_init1 [simp] : "coffee (dollar initial) = dollar initial"
coffee_init2 [simp] : "coffee (quarter (dollar initial)) = quarter (dollar initial)"
coffee_init3 [simp] : "coffee (quarter (quarter (quarter (quarter initial)))) = quarter (quarter (quarter (quarter initial)))"
coffee_init4 [simp] : "coffee (quarter (quarter (quarter (quarter (quarter initial))))) = quarter (quarter (quarter (quarter (quarter initial))))"

quarter_dollar [simp] : "!! v . quarter(dollar v)=dollar(quarter v)"

Nat1 [simp] : "!! n1 :: Nat . add zero n1 = n1"
Nat2 [simp]: "!! n1 :: Nat . !! n2 :: Nat . add (succ n1) n2 = (succ (add n1 n2))"
NatCom: "!! n1 :: Nat . !! n2 :: Nat . add n1 n2 = add n2 n1"
double1 [simp] : "double zero = zero"
double2 [simp] : "!! n1 :: Nat . double (succ n1) = (add (succ n1) (succ n1))"
AddDouble [simp]: "!! n1 :: Nat . (add n1 n1) = (double n1) "

ga_cogenerated_VendingMachine: "!! R :: VendingMachine => VendingMachine => bool . !! u :: VendingMachine . !! v :: VendingMachine . ! x :: VendingMachine . ! y :: VendingMachine . ((R x) y) --> ((get_current x) = (get_current y) & ((R (quarter x)) (quarter y)) & ((R (dollar x)) (dollar y)) & ((R (tea x)) (tea y)) & ((R (coffee x)) (coffee y)))  ==> ((R u) v) ==> u = v"

theorem qqqqd: "!! v :: VendingMachine .  quarter (quarter (quarter (quarter v))) = dollar v"
apply(coinduction)
apply(init)
ML"set show_types"
ML"reset trace_simp"
apply(simp (no_asm_use))
(*apply(breakup)*)
apply(erule disjE)
apply(simp)
apply(erule disjE)
apply(erule exE)

apply(rule conjI)
apply(simp)
apply(rule conjI)
apply(rule disjI2)
apply(rule disjI1)
apply(rule_tac x="quarter v" in exI)
apply(simp)

apply(rule conjI)
apply(rule disjI2)
apply(rule disjI1)
apply(rule_tac x="dollar v" in exI)
apply(simp)

apply(rule conjI)
apply(rule disjI1)
apply(simp)

apply(rule disjI1)
apply(simp)
apply(case_tac v)

apply(erule exE)
ML"set trace_simp";
apply(simp)

apply(rule conjI)
apply(rule disjI1)
apply(erule exE)
apply(rule_tac x="quarter v" in exI)
apply(simp)

apply(rule conjI)
apply(rule disjI1)
apply(erule exE)
apply(rule_tac x="dollar v" in exI)
apply(simp)

apply(rule conjI)
apply(rule disjI1)
apply(erule exE)
apply(rule_tac x="tea v" in exI)
apply(simp)
apply(rule conjI)


(*  Title:      statecharts/DataSpace/Update.thy

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

section \<open>Update-Functions on Data Spaces\<close>
theory Update
imports Data
begin

subsection \<open>Total update-functions\<close>

definition
  Update :: "(('d data) => ('d data)) => bool" where
  "Update U = (\<forall> d. Data.DataSpace d = DataSpace (U d))"

lemma Update_EmptySet:
 "(% d. d) \<in> { L | L. Update L}"
by (unfold Update_def, auto)

definition
  "update = { L | (L::(('d data) => ('d data))). Update L}"

typedef 'd update = "update :: ('d data => 'd data) set"
  unfolding update_def
  apply (rule exI)
  apply (rule Update_EmptySet)
  done

definition
 UpdateApply :: "['d update, 'd data] => 'd data" ("(_ !!!/ _)" [10,11]10) where
 "UpdateApply U D == Rep_update U D"

definition
  DefaultUpdate :: "('d update)" where
 "DefaultUpdate ==  Abs_update (\<lambda> D. D)"

subsubsection \<open>Basic lemmas\<close>

lemma Update_select:
   "Update (Rep_update U)"
apply (cut_tac x=U in Rep_update)
apply (unfold update_def)
apply auto
done

lemma DataSpace_DataSpace_Update [simp]:
   "Data.DataSpace (Rep_update U DP) = Data.DataSpace DP"
apply (cut_tac U=U in Update_select)
apply (unfold Update_def)
apply auto
done

subsubsection \<open>\<open>DefaultUpdate\<close>\<close>

lemma Update_DefaultUpdate [simp]:
   "Update (\<lambda> D. D)"
by (unfold Update_def, auto)

lemma update_DefaultUpdate [simp]:
   "(\<lambda> D. D) \<in> update"
by (unfold update_def, auto)

lemma DataSpace_UpdateApply [simp]:
   "Data.DataSpace (U !!! D) = Data.DataSpace D"
by (unfold UpdateApply_def, auto)

subsection \<open>Partial update-functions\<close>

definition
  PUpdate :: "(('d data) => ('d pdata)) => bool" where
  "PUpdate U = (\<forall> d. Data.DataSpace d = PDataSpace (U d))"

lemma PUpdate_EmptySet:
 "(% d. Data2PData d) \<in> { L | L. PUpdate L}"
by (unfold PUpdate_def, auto)

definition "pupdate = { L | (L::(('d data) => ('d pdata))). PUpdate L}"

typedef 'd pupdate = "pupdate :: ('d data => 'd pdata) set"
  unfolding pupdate_def
  apply (rule exI)
  apply (rule PUpdate_EmptySet)
  done

definition
 PUpdateApply :: "['d pupdate, 'd data] => 'd pdata" ("(_ !!/ _)" [10,11]10) where
 "PUpdateApply U D = Rep_pupdate U D"

definition
  DefaultPUpdate :: "('d pupdate)" where
 "DefaultPUpdate = Abs_pupdate (\<lambda> D. DefaultPData (Data.DataSpace D))"

subsubsection \<open>Basic lemmas\<close>

lemma PUpdate_select:
   "PUpdate (Rep_pupdate U)"
apply (cut_tac x=U in Rep_pupdate)
apply (unfold pupdate_def)
apply auto
done

lemma DataSpace_PDataSpace_PUpdate [simp]:
   "PDataSpace (Rep_pupdate U DP) = Data.DataSpace DP"
apply (cut_tac U=U in PUpdate_select)
apply (unfold PUpdate_def)
apply auto
done

subsubsection \<open>\<open>Data2PData\<close>\<close>

lemma  PUpdate_Data2PData [simp]:
   "PUpdate Data2PData"
by (unfold PUpdate_def, auto)

lemma pupdate_Data2PData  [simp]:
   "Data2PData \<in> pupdate"
by (unfold pupdate_def, auto)

subsubsection \<open>\<open>PUpdate\<close>\<close>

lemma PUpdate_DefaultPUpdate [simp]:
   "PUpdate (\<lambda> D. DefaultPData (Data.DataSpace D))"
apply (unfold PUpdate_def)
apply auto
done

lemma pupdate_DefaultPUpdate [simp]:
   "(\<lambda> D. DefaultPData (Data.DataSpace D)) \<in> pupdate"
apply (unfold pupdate_def)
apply auto
done

lemma DefaultPUpdate_None [simp]:
    "(DefaultPUpdate !! D) = DefaultPData (DataSpace D)"
apply (unfold DefaultPUpdate_def PUpdateApply_def)
apply (subst Abs_pupdate_inverse)
apply auto
done

subsubsection \<open>\<open>SequentialRacing\<close>\<close>

definition
 UpdateOverride :: "['d pupdate, 'd update] =>
                     'd update" ("(_ [U+]/ _)" [10,11]10) where
 "UpdateOverride U P = Abs_update (\<lambda> DA . (U !! DA) [D+] (P !!! DA))"

(* -------------------------------------------------------------- *)
(* We use our own FoldSet operator simular to the definition      *)
(* of Isabelle 2002. Note, it is different to the definition      *)
(* in Isabelle 2009. Basically we express "f (g x)" by "h x"      *)
(* -------------------------------------------------------------- *)

inductive
  FoldSet :: "('b => 'a => 'a) => 'a => 'b set => 'a => bool"
  for h ::  "'b => 'a => 'a"
  and z :: 'a
where
  emptyI [intro]: "FoldSet h z {} z"
| insertI [intro]:
     "\<lbrakk> x \<notin> A; FoldSet h z A y \<rbrakk>
      \<Longrightarrow> FoldSet h z (insert x A) (h x y)"

definition
SequentialRacing :: "('d pupdate set) => ('d update set)" where
 "SequentialRacing U =
     {u. FoldSet UpdateOverride DefaultUpdate U u}"

lemma FoldSet_imp_finite:
  "FoldSet h z A x \<Longrightarrow> finite A"
by (induct set: FoldSet) auto

lemma finite_imp_FoldSet:
  "finite A \<Longrightarrow> \<exists> x. FoldSet h z A x"
by (induct set: finite) auto

lemma finite_SequentialRacing:
   "finite US \<Longrightarrow> (SOME u. u \<in> SequentialRacing US) \<in> SequentialRacing US"
apply (unfold SequentialRacing_def)
apply auto
apply (drule_tac h=UpdateOverride and z=DefaultUpdate in finite_imp_FoldSet)
apply auto
apply (rule someI)
apply auto
done

end


(*  Title:      HOL/Proofs/Lambda/StrongNorm.thy
    Author:     Stefan Berghofer
    Copyright   2000 TU Muenchen
*)

section \<open>Strong normalization for simply-typed lambda calculus\<close>

theory StrongNorm imports LambdaType InductTermi begin

text \<open>
Formalization by Stefan Berghofer. Partly based on a paper proof by
Felix Joachimski and Ralph Matthes \<^cite>\<open>"Matthes-Joachimski-AML"\<close>.
\<close>

subsection \<open>Properties of \<open>IT\<close>\<close>

lemma lift_IT [intro!]: "IT t \<Longrightarrow> IT (lift t i)"
  apply (induct arbitrary: i set: IT)
    apply (simp (no_asm))
    apply (rule conjI)
     apply
      (rule impI,
       rule IT.Var,
       erule listsp.induct,
       simp (no_asm),
       simp (no_asm),
       rule listsp.Cons,
       blast,
       assumption)+
     apply auto
   done

lemma lifts_IT: "listsp IT ts \<Longrightarrow> listsp IT (map (\<lambda>t. lift t 0) ts)"
  by (induct ts) auto

lemma subst_Var_IT: "IT r \<Longrightarrow> IT (r[Var i/j])"
  apply (induct arbitrary: i j set: IT)
    txt \<open>Case \<^term>\<open>Var\<close>:\<close>
    apply (simp (no_asm) add: subst_Var)
    apply
    ((rule conjI impI)+,
      rule IT.Var,
      erule listsp.induct,
      simp (no_asm),
      simp (no_asm),
      rule listsp.Cons,
      fast,
      assumption)+
   txt \<open>Case \<^term>\<open>Lambda\<close>:\<close>
   apply atomize
   apply simp
   apply (rule IT.Lambda)
   apply fast
  txt \<open>Case \<^term>\<open>Beta\<close>:\<close>
  apply atomize
  apply (simp (no_asm_use) add: subst_subst [symmetric])
  apply (rule IT.Beta)
   apply auto
  done

lemma Var_IT: "IT (Var n)"
  apply (subgoal_tac "IT (Var n \<degree>\<degree> [])")
   apply simp
  apply (rule IT.Var)
  apply (rule listsp.Nil)
  done

lemma app_Var_IT: "IT t \<Longrightarrow> IT (t \<degree> Var i)"
  apply (induct set: IT)
    apply (subst app_last)
    apply (rule IT.Var)
    apply simp
    apply (rule listsp.Cons)
     apply (rule Var_IT)
    apply (rule listsp.Nil)
   apply (rule IT.Beta [where ?ss = "[]", unfolded foldl_Nil [THEN eq_reflection]])
    apply (erule subst_Var_IT)
   apply (rule Var_IT)
  apply (subst app_last)
  apply (rule IT.Beta)
   apply (subst app_last [symmetric])
   apply assumption
  apply assumption
  done

subsection \<open>Well-typed substitution preserves termination\<close>

lemma subst_type_IT:
  "\<And>t e T u i. IT t \<Longrightarrow> e\<langle>i:U\<rangle> \<turnstile> t : T \<Longrightarrow>
    IT u \<Longrightarrow> e \<turnstile> u : U \<Longrightarrow> IT (t[u/i])"
  (is "PROP ?P U" is "\<And>t e T u i. _ \<Longrightarrow> PROP ?Q t e T u i U")
proof (induct U)
  fix T t
  assume MI1: "\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> PROP ?P T1"
  assume MI2: "\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> PROP ?P T2"
  assume "IT t"
  thus "\<And>e T' u i. PROP ?Q t e T' u i T"
  proof induct
    fix e T' u i
    assume uIT: "IT u"
    assume uT: "e \<turnstile> u : T"
    {
      case (Var rs n e1 T'1 u1 i1)
      assume nT: "e\<langle>i:T\<rangle> \<turnstile> Var n \<degree>\<degree> rs : T'"
      let ?ty = "\<lambda>t. \<exists>T'. e\<langle>i:T\<rangle> \<turnstile> t : T'"
      let ?R = "\<lambda>t. \<forall>e T' u i.
        e\<langle>i:T\<rangle> \<turnstile> t : T' \<longrightarrow> IT u \<longrightarrow> e \<turnstile> u : T \<longrightarrow> IT (t[u/i])"
      show "IT ((Var n \<degree>\<degree> rs)[u/i])"
      proof (cases "n = i")
        case True
        show ?thesis
        proof (cases rs)
          case Nil
          with uIT True show ?thesis by simp
        next
          case (Cons a as)
          with nT have "e\<langle>i:T\<rangle> \<turnstile> Var n \<degree> a \<degree>\<degree> as : T'" by simp
          then obtain Ts
              where headT: "e\<langle>i:T\<rangle> \<turnstile> Var n \<degree> a : Ts \<Rrightarrow> T'"
              and argsT: "e\<langle>i:T\<rangle> \<tturnstile> as : Ts"
            by (rule list_app_typeE)
          from headT obtain T''
              where varT: "e\<langle>i:T\<rangle> \<turnstile> Var n : T'' \<Rightarrow> Ts \<Rrightarrow> T'"
              and argT: "e\<langle>i:T\<rangle> \<turnstile> a : T''"
            by cases simp_all
          from varT True have T: "T = T'' \<Rightarrow> Ts \<Rrightarrow> T'"
            by cases auto
          with uT have uT': "e \<turnstile> u : T'' \<Rightarrow> Ts \<Rrightarrow> T'" by simp
          from T have "IT ((Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0)
            (map (\<lambda>t. t[u/i]) as))[(u \<degree> a[u/i])/0])"
          proof (rule MI2)
            from T have "IT ((lift u 0 \<degree> Var 0)[a[u/i]/0])"
            proof (rule MI1)
              have "IT (lift u 0)" by (rule lift_IT [OF uIT])
              thus "IT (lift u 0 \<degree> Var 0)" by (rule app_Var_IT)
              show "e\<langle>0:T''\<rangle> \<turnstile> lift u 0 \<degree> Var 0 : Ts \<Rrightarrow> T'"
              proof (rule typing.App)
                show "e\<langle>0:T''\<rangle> \<turnstile> lift u 0 : T'' \<Rightarrow> Ts \<Rrightarrow> T'"
                  by (rule lift_type) (rule uT')
                show "e\<langle>0:T''\<rangle> \<turnstile> Var 0 : T''"
                  by (rule typing.Var) simp
              qed
              from Var have "?R a" by cases (simp_all add: Cons)
              with argT uIT uT show "IT (a[u/i])" by simp
              from argT uT show "e \<turnstile> a[u/i] : T''"
                by (rule subst_lemma) simp
            qed
            thus "IT (u \<degree> a[u/i])" by simp
            from Var have "listsp ?R as"
              by cases (simp_all add: Cons)
            moreover from argsT have "listsp ?ty as"
              by (rule lists_typings)
            ultimately have "listsp (\<lambda>t. ?R t \<and> ?ty t) as"
              by simp
            hence "listsp IT (map (\<lambda>t. lift t 0) (map (\<lambda>t. t[u/i]) as))"
              (is "listsp IT (?ls as)")
            proof induct
              case Nil
              show ?case by fastforce
            next
              case (Cons b bs)
              hence I: "?R b" by simp
              from Cons obtain U where "e\<langle>i:T\<rangle> \<turnstile> b : U" by fast
              with uT uIT I have "IT (b[u/i])" by simp
              hence "IT (lift (b[u/i]) 0)" by (rule lift_IT)
              hence "listsp IT (lift (b[u/i]) 0 # ?ls bs)"
                by (rule listsp.Cons) (rule Cons)
              thus ?case by simp
            qed
            thus "IT (Var 0 \<degree>\<degree> ?ls as)" by (rule IT.Var)
            have "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<turnstile> Var 0 : Ts \<Rrightarrow> T'"
              by (rule typing.Var) simp
            moreover from uT argsT have "e \<tturnstile> map (\<lambda>t. t[u/i]) as : Ts"
              by (rule substs_lemma)
            hence "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<tturnstile> ?ls as : Ts"
              by (rule lift_types)
            ultimately show "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<turnstile> Var 0 \<degree>\<degree> ?ls as : T'"
              by (rule list_app_typeI)
            from argT uT have "e \<turnstile> a[u/i] : T''"
              by (rule subst_lemma) (rule refl)
            with uT' show "e \<turnstile> u \<degree> a[u/i] : Ts \<Rrightarrow> T'"
              by (rule typing.App)
          qed
          with Cons True show ?thesis
            by (simp add: comp_def)
        qed
      next
        case False
        from Var have "listsp ?R rs" by simp
        moreover from nT obtain Ts where "e\<langle>i:T\<rangle> \<tturnstile> rs : Ts"
          by (rule list_app_typeE)
        hence "listsp ?ty rs" by (rule lists_typings)
        ultimately have "listsp (\<lambda>t. ?R t \<and> ?ty t) rs"
          by simp
        hence "listsp IT (map (\<lambda>x. x[u/i]) rs)"
        proof induct
          case Nil
          show ?case by fastforce
        next
          case (Cons a as)
          hence I: "?R a" by simp
          from Cons obtain U where "e\<langle>i:T\<rangle> \<turnstile> a : U" by fast
          with uT uIT I have "IT (a[u/i])" by simp
          hence "listsp IT (a[u/i] # map (\<lambda>t. t[u/i]) as)"
            by (rule listsp.Cons) (rule Cons)
          thus ?case by simp
        qed
        with False show ?thesis by (auto simp add: subst_Var)
      qed
    next
      case (Lambda r e1 T'1 u1 i1)
      assume "e\<langle>i:T\<rangle> \<turnstile> Abs r : T'"
        and "\<And>e T' u i. PROP ?Q r e T' u i T"
      with uIT uT show "IT (Abs r[u/i])"
        by fastforce
    next
      case (Beta r a as e1 T'1 u1 i1)
      assume T: "e\<langle>i:T\<rangle> \<turnstile> Abs r \<degree> a \<degree>\<degree> as : T'"
      assume SI1: "\<And>e T' u i. PROP ?Q (r[a/0] \<degree>\<degree> as) e T' u i T"
      assume SI2: "\<And>e T' u i. PROP ?Q a e T' u i T"
      have "IT (Abs (r[lift u 0/Suc i]) \<degree> a[u/i] \<degree>\<degree> map (\<lambda>t. t[u/i]) as)"
      proof (rule IT.Beta)
        have "Abs r \<degree> a \<degree>\<degree> as \<rightarrow>\<^sub>\<beta> r[a/0] \<degree>\<degree> as"
          by (rule apps_preserves_beta) (rule beta.beta)
        with T have "e\<langle>i:T\<rangle> \<turnstile> r[a/0] \<degree>\<degree> as : T'"
          by (rule subject_reduction)
        hence "IT ((r[a/0] \<degree>\<degree> as)[u/i])"
          using uIT uT by (rule SI1)
        thus "IT (r[lift u 0/Suc i][a[u/i]/0] \<degree>\<degree> map (\<lambda>t. t[u/i]) as)"
          by (simp del: subst_map add: subst_subst subst_map [symmetric])
        from T obtain U where "e\<langle>i:T\<rangle> \<turnstile> Abs r \<degree> a : U"
          by (rule list_app_typeE) fast
        then obtain T'' where "e\<langle>i:T\<rangle> \<turnstile> a : T''" by cases simp_all
        thus "IT (a[u/i])" using uIT uT by (rule SI2)
      qed
      thus "IT ((Abs r \<degree> a \<degree>\<degree> as)[u/i])" by simp
    }
  qed
qed

subsection \<open>Well-typed terms are strongly normalizing\<close>

lemma type_implies_IT:
  assumes "e \<turnstile> t : T"
  shows "IT t"
  using assms
proof induct
  case Var
  show ?case by (rule Var_IT)
next
  case Abs
  show ?case by (rule IT.Lambda) (rule Abs)
next
  case (App e s T U t)
  have "IT ((Var 0 \<degree> lift t 0)[s/0])"
  proof (rule subst_type_IT)
    have "IT (lift t 0)" using \<open>IT t\<close> by (rule lift_IT)
    hence "listsp IT [lift t 0]" by (rule listsp.Cons) (rule listsp.Nil)
    hence "IT (Var 0 \<degree>\<degree> [lift t 0])" by (rule IT.Var)
    also have "Var 0 \<degree>\<degree> [lift t 0] = Var 0 \<degree> lift t 0" by simp
    finally show "IT \<dots>" .
    have "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> Var 0 : T \<Rightarrow> U"
      by (rule typing.Var) simp
    moreover have "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> lift t 0 : T"
      by (rule lift_type) (rule App.hyps)
    ultimately show "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> Var 0 \<degree> lift t 0 : U"
      by (rule typing.App)
    show "IT s" by fact
    show "e \<turnstile> s : T \<Rightarrow> U" by fact
  qed
  thus ?case by simp
qed

theorem type_implies_termi: "e \<turnstile> t : T \<Longrightarrow> termip beta t"
proof -
  assume "e \<turnstile> t : T"
  hence "IT t" by (rule type_implies_IT)
  thus ?thesis by (rule IT_implies_termi)
qed

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*
   Decompose a meta-conjunction as a proper fact (list of theorems)
*)

theory Conjuncts
imports Main
begin

ML\<open>

structure Conjuncts =
struct

local

  structure Data = Generic_Data
  (
    type T = thm;
    val empty: T = Drule.dummy_thm;
    val extend = I;
    val merge : T * T -> T = (K Drule.dummy_thm);
  );

  fun elim_conjuncts thm =
    case try Conjunction.elim thm of
    SOME (thm', thm'') => elim_conjuncts thm' @ elim_conjuncts thm''
    | NONE => if Thm.prop_of thm = Thm.prop_of (Drule.dummy_thm) then [] else [thm]

  in

  val _ = Context.>> (Context.map_theory (
    (Attrib.setup @{binding "conjuncts"}
      (Scan.lift (Args.mode "accumulate") >> (fn acc =>
        if acc then
        Thm.declaration_attribute (Data.map o (fn x => fn y => Conjunction.intr y x))
        else
        Thm.declaration_attribute Data.put))
      "add meta_conjuncts to \"conjuncts\" named theorem") #>
    Global_Theory.add_thms_dynamic (@{binding "conjuncts"}, elim_conjuncts o Data.get)))

end

end

\<close>

notepad begin

  fix A B C D
  assume ABC[conjuncts]: "(A &&& B) &&& (B &&& C)"
  note ABC' = conjuncts

  have "A" by (rule ABC')
  have "B" by (rule \<open>B\<close>)
  have "C" by (rule ABC'(4))

  (* Disclaimer: only the last declared lemma is stored *)
  assume ABCD[conjuncts]: "A &&& B" "C &&& D"
  note CD = conjuncts

  have "A" by ((rule CD)?,rule ABC')
  have "C" by (rule CD)

  note ABCD(1)[conjuncts]
  note AB = conjuncts

  note ABCD(2)[conjuncts]
  note CD = conjuncts

  (* We can accumulate multi-thms, we just need to clear conjuncts first *)
  note [[conjuncts]]

  note ABCD[conjuncts (accumulate)]
  note ABCD' = conjuncts

end

end


(* Victor B. F. Gomes, University of Cambridge
   Martin Kleppmann, University of Cambridge
   Dominic P. Mulligan, University of Cambridge
   Alastair R. Beresford, University of Cambridge
*)

subsection\<open>Network\<close>

theory
  RGA
imports
  Network
  Ordered_List
begin

datatype ('id, 'v) operation =
  Insert "('id, 'v) elt" "'id option" |
  Delete "'id"

fun interpret_opers :: "('id::linorder, 'v) operation \<Rightarrow> ('id, 'v) elt list \<rightharpoonup> ('id, 'v) elt list" ("\<langle>_\<rangle>" [0] 1000) where
  "interpret_opers (Insert e n) xs  = insert xs e n" |
  "interpret_opers (Delete n)   xs  = delete xs n"

definition element_ids :: "('id, 'v) elt list \<Rightarrow> 'id set" where
 "element_ids list \<equiv> set (map fst list)"

definition valid_rga_msg :: "('id, 'v) elt list \<Rightarrow> 'id \<times> ('id::linorder, 'v) operation \<Rightarrow> bool" where
 "valid_rga_msg list msg \<equiv> case msg of
    (i, Insert e  None     ) \<Rightarrow> fst e = i |
    (i, Insert e (Some pos)) \<Rightarrow> fst e = i \<and> pos \<in> element_ids list |
    (i, Delete         pos ) \<Rightarrow> pos \<in> element_ids list"

(* Replicated Growable Array Network *)
locale rga = network_with_constrained_ops _ interpret_opers "[]" valid_rga_msg

definition indices :: "('id \<times> ('id, 'v) operation) event list \<Rightarrow> 'id list" where
  "indices xs \<equiv>
     List.map_filter (\<lambda>x. case x of Deliver (i, Insert e n) \<Rightarrow> Some (fst e) | _ \<Rightarrow> None) xs"

lemma indices_Nil [simp]:
  shows "indices [] = []"
by(auto simp: indices_def map_filter_def)

lemma indices_append [simp]:
  shows "indices (xs@ys) = indices xs @ indices ys"
by(auto simp: indices_def map_filter_def)

lemma indices_Broadcast_singleton [simp]:
  shows "indices [Broadcast b] = []"
by(auto simp: indices_def map_filter_def)

lemma indices_Deliver_Insert [simp]:
  shows "indices [Deliver (i, Insert e n)] = [fst e]"
by(auto simp: indices_def map_filter_def)

lemma indices_Deliver_Delete [simp]:
  shows "indices [Deliver (i, Delete n)] = []"
by(auto simp: indices_def map_filter_def)

lemma (in rga) idx_in_elem_inserted [intro]:
  assumes "Deliver (i, Insert e n) \<in> set xs"
  shows   "fst e \<in> set (indices xs)"
using assms by(induction xs, auto simp add: indices_def map_filter_def)

lemma (in rga) apply_opers_idx_elems:
  assumes "es prefix of i"
      and "apply_operations es = Some xs"
    shows "element_ids xs = set (indices es)"
using assms unfolding element_ids_def
proof(induction es arbitrary: xs rule: rev_induct, clarsimp)
  case (snoc x xs) thus ?case
  proof (cases x, clarsimp, blast)
    case (Deliver e)
    moreover obtain a b where "e = (a, b)" by force
    ultimately show ?thesis
      using snoc assms apply (cases b; clarsimp split: bind_splits simp add: interp_msg_def)
       apply (metis Un_insert_right append.right_neutral insert_preserve_indices' list.set(1)
              option.sel prefix_of_appendD prod.sel(1) set_append)
      by (metis delete_preserve_indices prefix_of_appendD)
  qed
qed

lemma (in rga) delete_does_not_change_element_ids:
  assumes "es @ [Deliver (i, Delete n)] prefix of j"
  and "apply_operations es = Some xs1"
  and "apply_operations (es @ [Deliver (i, Delete n)]) = Some xs2"
  shows "element_ids xs1 = element_ids xs2"
proof -
  have "indices es = indices (es @ [Deliver (i, Delete n)])"
    by simp
  then show ?thesis
    by (metis (no_types) assms prefix_of_appendD rga.apply_opers_idx_elems rga_axioms)
qed

lemma (in rga) someone_inserted_id:
  assumes "es @ [Deliver (i, Insert (k, v, f) n)] prefix of j"
  and "apply_operations es = Some xs1"
  and "apply_operations (es @ [Deliver (i, Insert (k, v, f) n)]) = Some xs2"
  and "a \<in> element_ids xs2"
  and "a \<noteq> k"
  shows "a \<in> element_ids xs1"
using assms apply_opers_idx_elems by auto

lemma (in rga) deliver_insert_exists:
  assumes "es prefix of j"
      and "apply_operations es = Some xs"
      and "a \<in> element_ids xs"
    shows "\<exists>i v f n. Deliver (i, Insert (a, v, f) n) \<in> set es"
using assms unfolding element_ids_def
proof(induction es arbitrary: xs rule: rev_induct, clarsimp)
  case (snoc x xs ys) thus ?case
  proof (cases x)
    case (Broadcast e) thus ?thesis
      using snoc by(clarsimp, metis image_eqI prefix_of_appendD prod.sel(1))
  next
    case (Deliver e)
    moreover then obtain xs' where *: "apply_operations xs = Some xs'"
        using snoc by fastforce
    moreover obtain k v where **: "e = (k, v)" by force
    ultimately show ?thesis
      using assms snoc proof (cases v)
      case (Insert el _) thus ?thesis
        using snoc Deliver * **
        apply (cases el; cases "fst el = a"; clarsimp)
        apply (blast, metis (no_types, lifting) element_ids_def prefix_of_appendD set_map snoc.prems(2)
                      snoc.prems(3) someone_inserted_id)
        done
      next
      case (Delete _) thus ?thesis
        using snoc Deliver ** apply clarsimp
        apply(drule prefix_of_appendD, clarsimp simp add: bind_eq_Some_conv interp_msg_def)
        apply(metis delete_preserve_indices image_eqI prod.sel(1))
        done
    qed
  qed
qed

lemma (in rga) insert_in_apply_set:
  assumes "es @ [Deliver (i, Insert e (Some a))] prefix of j"
      and "Deliver (i', Insert e' n) \<in> set es"
      and "apply_operations es = Some s"
    shows "fst e' \<in> element_ids s"
using assms apply_opers_idx_elems idx_in_elem_inserted prefix_of_appendD by blast

lemma (in rga) insert_msg_id:
  assumes "Broadcast (i, Insert e n) \<in> set (history j)"
  shows "fst e = i"
proof -
  obtain state where 1: "valid_rga_msg state (i, Insert e n)"
    using assms broadcast_is_valid by blast
  thus "fst e = i"
    by(clarsimp simp add: valid_rga_msg_def split: option.split_asm)
qed

lemma (in rga) allowed_insert:
  assumes "Broadcast (i, Insert e n) \<in> set (history j)"
  shows "n = None \<or> (\<exists>i' e' n'. n = Some (fst e') \<and> Deliver (i', Insert e' n') \<sqsubset>\<^sup>j Broadcast (i, Insert e n))"
proof -
  obtain pre where 1: "pre @ [Broadcast (i, Insert e n)] prefix of j"
    using assms events_before_exist by blast
  from this obtain state where 2: "apply_operations pre = Some state" and 3: "valid_rga_msg state (i, Insert e n)"
    using broadcast_only_valid_msgs by blast
  show "n = None \<or> (\<exists>i' e' n'. n = Some (fst e') \<and> Deliver (i', Insert e' n') \<sqsubset>\<^sup>j Broadcast (i, Insert e n))"
  proof(cases n)
    fix a
    assume 4: "n = Some a"
    hence "a \<in> element_ids state" and 5: "fst e = i"
      using 3 by(clarsimp simp add: valid_rga_msg_def)+
    from this have "\<exists>i' v' f' n'. Deliver (i', Insert (a, v', f') n') \<in> set pre"
      using deliver_insert_exists 2 1 by blast
    thus "n = None \<or> (\<exists>i' e' n'. n = Some (fst e') \<and> Deliver (i', Insert e' n') \<sqsubset>\<^sup>j Broadcast (i, Insert e n))"
      using events_in_local_order 1 4 5 by(metis fst_conv)
  qed simp
qed

lemma (in rga) insert_id_unique:
  assumes "fst e1 = fst e2"
  and "Broadcast (i1, Insert e1 n1) \<in> set (history i)"
  and "Broadcast (i2, Insert e2 n2) \<in> set (history j)"
  shows "Insert e1 n1 = Insert e2 n2"
using assms insert_msg_id msg_id_unique Pair_inject fst_conv by metis

lemma (in rga) allowed_delete_deliver:
  assumes "Deliver (i, Delete x) \<in> set (history j)"
    shows "\<exists>i' n' v b. Deliver (i', Insert (x, v, b) n') \<sqsubset>\<^sup>j Deliver (i, Delete x)"
  using assms by (meson allowed_delete bot_least causal_broadcast delivery_has_a_cause insert_subset)

lemma (in rga) allowed_delete_deliver_in_set:
  assumes "(es@[Deliver (i, Delete m)]) prefix of j"
  shows   "\<exists>i' n v b. Deliver (i', Insert (m, v, b) n) \<in> set es"
by(metis (no_types, lifting) Un_insert_right insert_iff list.simps(15) assms
    local_order_prefix_closed_last rga.allowed_delete_deliver rga_axioms set_append subsetCE prefix_to_carriers)

lemma (in rga) allowed_insert_deliver:
  assumes "Deliver (i, Insert e n) \<in> set (history j)"
  shows   "n = None \<or> (\<exists>i' n' n'' v b. n = Some n' \<and> Deliver (i', Insert (n', v, b) n'') \<sqsubset>\<^sup>j Deliver (i, Insert e n))"
proof -
  obtain ja where 1: "Broadcast (i, Insert e n) \<in> set (history ja)"
    using assms delivery_has_a_cause by blast
  show "n = None \<or> (\<exists>i' n' n'' v b. n = Some n' \<and> Deliver (i', Insert (n', v, b) n'') \<sqsubset>\<^sup>j Deliver (i, Insert e n))"
  proof(cases n)
    fix a
    assume 3: "n = Some a"
    from this obtain i' e' n' where 4: "Some a = Some (fst e')" and
        2: "Deliver (i', Insert e' n') \<sqsubset>\<^sup>ja Broadcast (i, Insert e (Some a))"
      using allowed_insert 1 by blast
    hence "Deliver (i', Insert e' n') \<in> set (history ja)" and "Broadcast (i, Insert e (Some a)) \<in> set (history ja)"
      using local_order_carrier_closed by simp+
    from this obtain jaa where "Broadcast (i, Insert e (Some a)) \<in> set (history jaa)"
      using delivery_has_a_cause by simp
    have "\<exists>i' n' n'' v b. n = Some n' \<and> Deliver (i', Insert (n', v, b) n'') \<sqsubset>\<^sup>j Deliver (i, Insert e n)"
      using 2 3 4 by(metis assms causal_broadcast prod.collapse)
    thus "n = None \<or> (\<exists>i' n' n'' v b. n = Some n' \<and> Deliver (i', Insert (n', v, b) n'') \<sqsubset>\<^sup>j Deliver (i, Insert e n))"
      by auto
  qed simp
qed

lemma (in rga) allowed_insert_deliver_in_set:
  assumes "(es@[Deliver (i, Insert e m)]) prefix of j"
  shows   "m = None \<or> (\<exists>i' m' n v b. m = Some m' \<and> Deliver (i', Insert (m', v, b) n) \<in> set es)"
by(metis assms Un_insert_right insert_subset list.simps(15) set_append prefix_to_carriers
    allowed_insert_deliver local_order_prefix_closed_last)

lemma (in rga) Insert_no_failure:
  assumes "es @ [Deliver (i, Insert e n)] prefix of j"
      and "apply_operations es = Some s"
    shows "\<exists>ys. insert s e n = Some ys"
by(metis (no_types, lifting) element_ids_def allowed_insert_deliver_in_set assms fst_conv
    insert_in_apply_set insert_no_failure set_map)

lemma (in rga) delete_no_failure:
  assumes "es @ [Deliver (i, Delete n)] prefix of j"
      and "apply_operations es = Some s"
    shows "\<exists>ys. delete s n = Some ys"
proof -
  obtain i' na v b where 1: "Deliver (i', Insert (n, v, b) na) \<in> set es"
    using assms allowed_delete_deliver_in_set by blast
  also have "fst (n, v, b) \<in> set (indices es)"
    using assms idx_in_elem_inserted calculation by blast
  from this assms and 1 show "\<exists>ys. delete s n = Some ys"
    apply -
    apply(rule delete_no_failure)
    apply(metis apply_opers_idx_elems element_ids_def prefix_of_appendD prod.sel(1) set_map)
    done
qed

lemma (in rga) Insert_equal:
  assumes "fst e1 = fst e2"
      and "Broadcast (i1, Insert e1 n1) \<in> set (history i)"
      and "Broadcast (i2, Insert e2 n2) \<in> set (history j)"
    shows "Insert e1 n1 = Insert e2 n2"
using insert_id_unique assms by simp

lemma (in rga) same_insert:
  assumes "fst e1 = fst e2"
      and "xs prefix of i"
      and "(i1, Insert e1 n1) \<in> set (node_deliver_messages xs)"
      and "(i2, Insert e2 n2) \<in> set (node_deliver_messages xs)"
    shows "Insert e1 n1 = Insert e2 n2"
proof -
  have "Deliver (i1, Insert e1 n1) \<in> set (history i)"
    using assms by(auto simp add: node_deliver_messages_def prefix_msg_in_history)
  from this obtain j where 1: "Broadcast (i1, Insert e1 n1) \<in> set (history j)"
    using delivery_has_a_cause by blast
  have "Deliver (i2, Insert e2 n2) \<in> set (history i)"
    using assms by(auto simp add: node_deliver_messages_def prefix_msg_in_history)
  from this obtain k where 2: "Broadcast (i2, Insert e2 n2) \<in> set (history k)"
    using delivery_has_a_cause by blast
  show "Insert e1 n1 = Insert e2 n2"
    by(rule Insert_equal; force simp add: assms intro: 1 2)
qed

lemma (in rga) insert_commute_assms:
  assumes "{Deliver (i, Insert e n), Deliver (i', Insert e' n')} \<subseteq> set (history j)"
      and "hb.concurrent (i, Insert e n) (i', Insert e' n')"
    shows "n = None \<or> n \<noteq> Some (fst e')"
using assms
  apply(clarsimp simp: hb.concurrent_def)
  apply(cases e')
  apply clarsimp
  apply(frule delivery_has_a_cause)
  apply(frule delivery_has_a_cause, clarsimp)
  apply(frule allowed_insert)
  apply clarsimp
  apply(metis Insert_equal delivery_has_a_cause fst_conv hb.intros(2) insert_subset
    local_order_carrier_closed insert_msg_id)
done

lemma subset_reorder:
  assumes "{a, b} \<subseteq> c"
  shows "{b, a} \<subseteq> c"
using assms by simp

lemma (in rga) Insert_Insert_concurrent:
  assumes "{Deliver (i, Insert e k), Deliver (i', Insert e' (Some m))} \<subseteq> set (history j)"
      and "hb.concurrent (i, Insert e k) (i', Insert e' (Some m))"
    shows "fst e \<noteq> m"
  by(metis assms subset_reorder hb.concurrent_comm insert_commute_assms option.simps(3))

lemma (in rga) insert_valid_assms:
 assumes "Deliver (i, Insert e n) \<in> set (history j)"
   shows "n = None \<or> n \<noteq> Some (fst e)"
  using assms by(meson allowed_insert_deliver hb.concurrent_def hb.less_asym insert_subset
      local_order_carrier_closed rga.insert_commute_assms rga_axioms)

lemma (in rga) Insert_Delete_concurrent:
  assumes "{Deliver (i, Insert e n), Deliver (i', Delete n')} \<subseteq> set (history j)"
      and "hb.concurrent (i, Insert e n) (i', Delete n')"
    shows "n' \<noteq> fst e"
by (metis assms Insert_equal allowed_delete delivery_has_a_cause fst_conv hb.concurrent_def
  hb.intros(2) insert_subset local_order_carrier_closed rga.insert_msg_id rga_axioms)

lemma (in rga) concurrent_operations_commute:
  assumes "xs prefix of i"
  shows "hb.concurrent_ops_commute (node_deliver_messages xs)"
proof -
  have "\<And>x y. {x, y} \<subseteq> set (node_deliver_messages xs) \<Longrightarrow> hb.concurrent x y \<Longrightarrow> interp_msg x \<rhd> interp_msg y = interp_msg y \<rhd> interp_msg x"
  proof
    fix x y ii
    assume "{x, y} \<subseteq> set (node_deliver_messages xs)"
      and C: "hb.concurrent x y"
    hence X: "x \<in> set (node_deliver_messages xs)" and Y: "y \<in> set (node_deliver_messages xs)"
      by auto
    obtain x1 x2 y1 y2 where 1: "x = (x1, x2)" and 2: "y = (y1, y2)"
      by fastforce
    have "(interp_msg (x1, x2) \<rhd> interp_msg (y1, y2)) ii = (interp_msg (y1, y2) \<rhd> interp_msg (x1, x2)) ii"
    proof(cases x2; cases y2)
      fix ix1 ix2 iy1 iy2
      assume X2: "x2 = Insert ix1 ix2" and Y2: "y2 = Insert iy1 iy2"
      show "(interp_msg (x1, x2) \<rhd> interp_msg (y1, y2)) ii = (interp_msg (y1, y2) \<rhd> interp_msg (x1, x2)) ii"
      proof(cases "fst ix1 = fst iy1")
        assume "fst ix1 = fst iy1"
        hence "Insert ix1 ix2 = Insert iy1 iy2"
          apply(rule same_insert)
          using 1 2 X Y X2 Y2 assms apply auto
          done
        hence "ix1 = iy1" and "ix2 = iy2"
          by auto
        from this and X2 Y2 show "(interp_msg (x1, x2) \<rhd> interp_msg (y1, y2)) ii = (interp_msg (y1, y2) \<rhd> interp_msg (x1, x2)) ii"
          by(clarsimp simp add: kleisli_def interp_msg_def)
      next
        assume NEQ: "fst ix1 \<noteq> fst iy1"
        have "ix2 = None \<or> ix2 \<noteq> Some (fst iy1)"
          apply(rule insert_commute_assms)
          using prefix_msg_in_history[OF assms] X Y X2 Y2 1 2
           apply(clarsimp, blast)
          using C 1 2 X2 Y2 apply blast
          done
        also have "iy2 = None \<or> iy2 \<noteq> Some (fst ix1)"
          apply(rule insert_commute_assms)
          using prefix_msg_in_history[OF assms] X Y X2 Y2 1 2
           apply(clarsimp, blast)
          using "1" "2" C X2 Y2 apply blast
          done
        ultimately have "insert ii ix1 ix2 \<bind> (\<lambda>x. insert x iy1 iy2) = insert ii iy1 iy2 \<bind> (\<lambda>x. insert x ix1 ix2)"
          using NEQ insert_commutes by blast
        thus "(interp_msg (x1, x2) \<rhd> interp_msg (y1, y2)) ii = (interp_msg (y1, y2) \<rhd> interp_msg (x1, x2)) ii"
          by(clarsimp simp add: interp_msg_def X2 Y2 kleisli_def)
      qed
    next
      fix ix1 ix2 yd
      assume X2: "x2 = Insert ix1 ix2" and Y2: "y2 = Delete yd"
      have "hb.concurrent (x1, Insert ix1 ix2) (y1, Delete yd)"
        using C X2 Y2 1 2 by simp
      also have "{Deliver (x1, Insert ix1 ix2), Deliver (y1, Delete yd)} \<subseteq> set (history i)"
        using prefix_msg_in_history assms X2 Y2 X Y 1 2 by blast
      ultimately have "yd \<noteq> fst ix1"
        apply -
        apply(rule Insert_Delete_concurrent; force)
        done
      hence "insert ii ix1 ix2 \<bind> (\<lambda>x. delete x yd) = delete ii yd \<bind> (\<lambda>x. insert x ix1 ix2)"
        by(rule insert_delete_commute)
      thus "(interp_msg (x1, x2) \<rhd> interp_msg (y1, y2)) ii = (interp_msg (y1, y2) \<rhd> interp_msg (x1, x2)) ii"
        by(clarsimp simp add: interp_msg_def kleisli_def X2 Y2)
    next
      fix xd iy1 iy2
      assume X2: "x2 = Delete xd" and Y2: "y2 = Insert iy1 iy2"
      have "hb.concurrent (x1, Delete xd) (y1, Insert iy1 iy2)"
        using C X2 Y2 1 2 by simp
      also have "{Deliver (x1, Delete xd), Deliver (y1, Insert iy1 iy2)} \<subseteq> set (history i)"
        using prefix_msg_in_history assms X2 Y2 X Y 1 2 by blast
      ultimately have "xd \<noteq> fst iy1"
        apply -
        apply(rule Insert_Delete_concurrent; force)
        done
      hence "delete ii xd \<bind> (\<lambda>x. insert x iy1 iy2) = insert ii iy1 iy2 \<bind> (\<lambda>x. delete x xd)"
        by(rule insert_delete_commute[symmetric])
      thus "(interp_msg (x1, x2) \<rhd> interp_msg (y1, y2)) ii = (interp_msg (y1, y2) \<rhd> interp_msg (x1, x2)) ii"
        by(clarsimp simp add: interp_msg_def kleisli_def X2 Y2)
    next
      fix xd yd
      assume X2: "x2 = Delete xd" and Y2: "y2 = Delete yd"
      have "delete ii xd \<bind> (\<lambda>x. delete x yd) = delete ii yd \<bind> (\<lambda>x. delete x xd)"
        by(rule delete_commutes)
      thus "(interp_msg (x1, x2) \<rhd> interp_msg (y1, y2)) ii = (interp_msg (y1, y2) \<rhd> interp_msg (x1, x2)) ii"
        by(clarsimp simp add: interp_msg_def kleisli_def X2 Y2)
    qed
    thus "(interp_msg x \<rhd> interp_msg y) ii = (interp_msg y \<rhd> interp_msg x) ii"
      using 1 2 by auto
  qed
  thus "hb.concurrent_ops_commute (node_deliver_messages xs)"
    by(auto simp add: hb.concurrent_ops_commute_def)
qed

corollary (in rga) concurrent_operations_commute':
  shows "hb.concurrent_ops_commute (node_deliver_messages (history i))"
by (meson concurrent_operations_commute append.right_neutral prefix_of_node_history_def)

lemma (in rga) apply_operations_never_fails:
  assumes "xs prefix of i"
  shows "apply_operations xs \<noteq> None"
using assms proof(induction xs rule: rev_induct)
  show "apply_operations [] \<noteq> None"
    by clarsimp
next
  fix x xs
  assume 1: "xs prefix of i \<Longrightarrow> apply_operations xs \<noteq> None"
    and 2: "xs @ [x] prefix of i"
  hence 3: "xs prefix of i"
    by auto
  show "apply_operations (xs @ [x]) \<noteq> None"
  proof(cases x)
    fix b
    assume "x = Broadcast b"
    thus "apply_operations (xs @ [x]) \<noteq> None"
      using 1 3 by clarsimp
  next
    fix d
    assume 4: "x = Deliver d"
    thus "apply_operations (xs @ [x]) \<noteq> None"
    proof(cases d; clarify)
      fix a b
      assume 5: "x = Deliver (a, b)"
      show "\<exists>y. apply_operations (xs @ [Deliver (a, b)]) = Some y"
      proof(cases b; clarify)
        fix aa aaa ba x12
        assume 6: "b = Insert (aa, aaa, ba) x12"
        show "\<exists>y. apply_operations (xs @ [Deliver (a, Insert (aa, aaa, ba) x12)]) = Some y"
          apply(clarsimp simp add: 1 interp_msg_def split!: bind_splits)
           apply(simp add: "1" "3")
          apply(rule rga.Insert_no_failure, rule rga_axioms)
          using 4 5 6 2 apply force+
          done
      next
        fix x2
        assume 6: "b = Delete x2"
        show "\<exists>y. apply_operations (xs @ [Deliver (a, Delete x2)]) = Some y"
          apply(clarsimp simp add: interp_msg_def split!: bind_splits)
           apply(simp add: 1 3)
          apply(rule delete_no_failure)
          using 4 5 6 2 apply force+
          done
      qed
    qed
  qed
qed

lemma (in rga) apply_operations_never_fails':
  shows "apply_operations (history i) \<noteq> None"
by(meson apply_operations_never_fails append.right_neutral prefix_of_node_history_def)

corollary (in rga) rga_convergence:
  assumes "set (node_deliver_messages xs) = set (node_deliver_messages ys)"
      and "xs prefix of i"
      and "ys prefix of j"
    shows "apply_operations xs = apply_operations ys"
  using assms by(auto simp add: apply_operations_def intro: hb.convergence_ext
      concurrent_operations_commute node_deliver_messages_distinct hb_consistent_prefix)

subsection\<open>Strong eventual consistency\<close>

context rga begin

sublocale sec: strong_eventual_consistency weak_hb hb interp_msg
  "\<lambda>ops.\<exists>xs i. xs prefix of i \<and> node_deliver_messages xs = ops" "[]"
proof(standard; clarsimp)
  fix xsa i
  assume "xsa prefix of i"
  thus "hb.hb_consistent (node_deliver_messages xsa)"
    by(auto simp add: hb_consistent_prefix)
next
  fix xsa i
  assume "xsa prefix of i"
  thus "distinct (node_deliver_messages xsa)"
    by(auto simp add: node_deliver_messages_distinct)
next
  fix xsa i
  assume "xsa prefix of i"
  thus "hb.concurrent_ops_commute (node_deliver_messages xsa)"
    by(auto simp add: concurrent_operations_commute)
next
  fix xs a b state xsa x
  assume "hb.apply_operations xs [] = Some state"
    and "node_deliver_messages xsa = xs @ [(a, b)]"
    and "xsa prefix of x"
  thus "\<exists>y. interp_msg (a, b) state = Some y"
   by(metis (no_types, lifting) apply_operations_def bind.bind_lunit not_None_eq
       hb.apply_operations_Snoc kleisli_def apply_operations_never_fails interp_msg_def)
next
  fix xs a b xsa x
  assume "node_deliver_messages xsa = xs @ [(a, b)]"
    and "xsa prefix of x"
  thus "\<exists>xsa. (\<exists>x. xsa prefix of x) \<and> node_deliver_messages xsa = xs"
    using drop_last_message by blast
qed

end

interpretation trivial_rga_implementation: rga "\<lambda>x. []"
  by(standard, auto simp add: trivial_node_histories.history_order_def
      trivial_node_histories.prefix_of_node_history_def)

end


(* Title: Stream_Fusion_LList
  Author: Andreas Lochbihler, ETH Zurich *)

section \<open>Stream fusion for coinductive lists\<close>

theory Stream_Fusion_LList imports
  Stream_Fusion_List
  Coinductive.Coinductive_List
begin

text \<open>
  There are two choices of how many @{const Skip}s may occur consecutively.
  \begin{itemize}
  \item A generator for @{typ "'a llist"} may return only finitely many @{const Skip}s before
    it has to decide on a @{const Done} or @{const Yield}. Then, we can define stream versions
    for all functions that can be defined by corecursion up-to. This in particular excludes
    @{const lfilter}. Moreover, we have to prove that every generator satisfies this
    restriction.
  \item A generator for @{typ "'a llist"} may return infinitely many @{const Skip}s in a row.
    Then, the \<open>lunstream\<close> function suffers from the same difficulties as @{const lfilter} with
    definitions, but we can define it using the least fixpoint approach described in
    \cite{LochbihlerHoelzl2014ITP}. Consequently, we can only fuse transformers that are monotone and
    continuous with respect to the ccpo ordering. This in particular excludes @{const lappend}.
  \end{itemize}
  Here, we take the both approaches where we consider the first preferable to the second.
  Consequently, we define producers such that they produce generators of the first kind, if possible.
  There will be multiple equations for transformers and consumers that deal with all the different
  combinations for their parameter generators. Transformers should yield generators of the first
  kind whenever possible. Consumers can be defined using \<open>lunstream\<close> and refined with custom
  code equations, i.e., they can operate with infinitely many \<open>Skip\<close>s in a row. We just
  have to lift the fusion equation to the first kind, too.
\<close>

type_synonym ('a, 's) lgenerator = "'s \<Rightarrow> ('a, 's) step"

inductive_set productive_on :: "('a, 's) lgenerator \<Rightarrow> 's set"
for g :: "('a, 's) lgenerator"
where
  Done: "g s = Done \<Longrightarrow> s \<in> productive_on g"
| Skip: "\<lbrakk> g s = Skip s'; s' \<in> productive_on g \<rbrakk> \<Longrightarrow> s \<in> productive_on g"
| Yield: "g s = Yield x s' \<Longrightarrow> s \<in> productive_on g"

definition productive :: "('a, 's) lgenerator \<Rightarrow> bool"
where "productive g \<longleftrightarrow> productive_on g = UNIV"

lemma productiveI [intro?]:
  "(\<And>s. s \<in> productive_on g) \<Longrightarrow> productive g"
by(auto simp add: productive_def)

lemma productive_onI [dest?]: "productive g \<Longrightarrow> s \<in> productive_on g"
by(simp add: productive_def)

text \<open>A type of generators that eventually will yield something else than a skip.\<close>

typedef ('a, 's) lgenerator' = "{g :: ('a, 's) lgenerator. productive g}"
  morphisms lgenerator Abs_lgenerator'
proof
  show "(\<lambda>_. Done) \<in> ?lgenerator'" by(auto intro: productive_on.intros productiveI)
qed

setup_lifting type_definition_lgenerator'

subsection \<open>Conversions to @{typ "'a llist"}\<close>

subsubsection \<open>Infinitely many consecutive @{term Skip}s\<close>

context fixes g :: "('a, 's) lgenerator"
  notes [[function_internals]]
begin

partial_function (llist) lunstream :: "'s \<Rightarrow> 'a llist"
where
  "lunstream s = (case g s of
     Done \<Rightarrow> LNil | Skip s' \<Rightarrow> lunstream s' | Yield x s' \<Rightarrow> LCons x (lunstream s'))"

declare lunstream.simps[code]

lemma lunstream_simps:
  "g s = Done \<Longrightarrow> lunstream s = LNil"
  "g s = Skip s' \<Longrightarrow> lunstream s = lunstream s'"
  "g s = Yield x s' \<Longrightarrow> lunstream s = LCons x (lunstream s')"
by(simp_all add: lunstream.simps)

lemma lunstream_sels:
  shows lnull_lunstream: "lnull (lunstream s) \<longleftrightarrow>
  (case g s of Done \<Rightarrow> True | Skip s' \<Rightarrow> lnull (lunstream s') | Yield _ _ \<Rightarrow> False)"
  and lhd_lunstream: "lhd (lunstream s) =
  (case g s of Skip s' \<Rightarrow> lhd (lunstream s') | Yield x _ \<Rightarrow> x)"
  and ltl_lunstream: "ltl (lunstream s) =
  (case g s of Done \<Rightarrow> LNil | Skip s' \<Rightarrow> ltl (lunstream s') | Yield _ s' \<Rightarrow> lunstream s')"
by(simp_all add: lhd_def lunstream_simps split: step.split)

end

subsubsection \<open>Finitely many consecutive @{term Skip}s\<close>

lift_definition lunstream' :: "('a, 's) lgenerator' \<Rightarrow> 's \<Rightarrow> 'a llist"
is lunstream .

lemma lunstream'_simps:
  "lgenerator g s = Done \<Longrightarrow> lunstream' g s = LNil"
  "lgenerator g s = Skip s' \<Longrightarrow> lunstream' g s = lunstream' g s'"
  "lgenerator g s = Yield x s' \<Longrightarrow> lunstream' g s = LCons x (lunstream' g s')"
by(transfer, simp add: lunstream_simps)+

lemma lunstream'_sels:
  shows lnull_lunstream': "lnull (lunstream' g s) \<longleftrightarrow>
  (case lgenerator g s of Done \<Rightarrow> True | Skip s' \<Rightarrow> lnull (lunstream' g s') | Yield _ _ \<Rightarrow> False)"
  and lhd_lunstream': "lhd (lunstream' g s) =
  (case lgenerator g s of Skip s' \<Rightarrow> lhd (lunstream' g s') | Yield x _ \<Rightarrow> x)"
  and ltl_lunstream': "ltl (lunstream' g s) =
  (case lgenerator g s of Done \<Rightarrow> LNil | Skip s' \<Rightarrow> ltl (lunstream' g s') | Yield _ s' \<Rightarrow> lunstream' g s')"
by(transfer, simp add: lunstream_sels)+

setup \<open>Context.theory_map (fold
  Stream_Fusion.add_unstream [@{const_name lunstream}, @{const_name lunstream'}])\<close>

subsection \<open>Producers\<close>

subsubsection \<open>Conversion to streams\<close>

fun lstream :: "('a, 'a llist) lgenerator"
where
  "lstream LNil = Done"
| "lstream (LCons x xs) = Yield x xs"

lemma case_lstream_conv_case_llist:
  "(case lstream xs of Done \<Rightarrow> done | Skip xs' \<Rightarrow> skip xs' | Yield x xs' \<Rightarrow> yield x xs') =
   (case xs of LNil \<Rightarrow> done | LCons x xs' \<Rightarrow> yield x xs')"
by(simp split: llist.split)

lemma mcont2mcont_lunstream[THEN llist.mcont2mcont, simp, cont_intro]:
  shows mcont_lunstream: "mcont lSup lprefix lSup lprefix (lunstream lstream)"
by(rule llist.fixp_preserves_mcont1[OF lunstream.mono lunstream_def])(simp add: case_lstream_conv_case_llist)

lemma lunstream_lstream: "lunstream lstream xs = xs"
by(induction xs)(simp_all add: lunstream_simps)

lift_definition lstream' :: "('a, 'a llist) lgenerator'"
is lstream
proof
  fix s :: "'a llist"
  show "s \<in> productive_on lstream" by(cases s)(auto intro: productive_on.intros)
qed

lemma lunstream'_lstream: "lunstream' lstream' xs = xs"
by(transfer)(rule lunstream_lstream)

subsubsection \<open>@{const iterates}\<close>

definition iterates_raw :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a, 'a) lgenerator"
where "iterates_raw f s = Yield s (f s)"

lemma lunstream_iterates_raw: "lunstream (iterates_raw f) x = iterates f x"
by(coinduction arbitrary: x)(auto simp add: iterates_raw_def lunstream_sels)

lift_definition iterates_prod :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a, 'a) lgenerator'" is iterates_raw
by(auto 4 3 intro: productiveI productive_on.intros simp add: iterates_raw_def)

lemma lunstream'_iterates_prod [stream_fusion]: "lunstream' (iterates_prod f) x = iterates f x"
by transfer(rule lunstream_iterates_raw)

subsubsection \<open>@{const unfold_llist}\<close>

definition unfold_llist_raw :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('b, 'a) lgenerator"
where
  "unfold_llist_raw stop head tail s = (if stop s then Done else Yield (head s) (tail s))"

lemma lunstream_unfold_llist_raw:
  "lunstream (unfold_llist_raw stop head tail) s = unfold_llist stop head tail s"
by(coinduction arbitrary: s)(auto simp add: lunstream_sels unfold_llist_raw_def)

lift_definition unfold_llist_prod :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('b, 'a) lgenerator'"
is unfold_llist_raw
proof(rule productiveI)
  fix stop and head :: "'a \<Rightarrow> 'b" and tail s
  show "s \<in> productive_on (unfold_llist_raw stop head tail)"
    by(cases "stop s")(auto intro: productive_on.intros simp add: unfold_llist_raw_def)
qed

lemma lunstream'_unfold_llist_prod [stream_fusion]:
  "lunstream' (unfold_llist_prod stop head tail) s = unfold_llist stop head tail s"
by transfer(rule lunstream_unfold_llist_raw)

subsubsection \<open>@{const inf_llist}\<close>

definition inf_llist_raw :: "(nat \<Rightarrow> 'a) \<Rightarrow> ('a, nat) lgenerator"
where "inf_llist_raw f n = Yield (f n) (Suc n)"

lemma lunstream_inf_llist_raw: "lunstream (inf_llist_raw f) n = ldropn n (inf_llist f)"
by(coinduction arbitrary: n)(auto simp add: lunstream_sels inf_llist_raw_def)

lift_definition inf_llist_prod :: "(nat \<Rightarrow> 'a) \<Rightarrow> ('a, nat) lgenerator'" is inf_llist_raw
by(auto 4 3 intro: productiveI productive_on.intros simp add: inf_llist_raw_def)

subsection \<open>Consumers\<close>

subsubsection \<open>@{const lhd}\<close>

context fixes g :: "('a, 's) lgenerator" begin

definition lhd_cons :: "'s \<Rightarrow> 'a"
where [stream_fusion]: "lhd_cons s = lhd (lunstream g s)"

lemma lhd_cons_code[code]:
  "lhd_cons s = (case g s of Done \<Rightarrow> undefined | Skip s' \<Rightarrow> lhd_cons s' | Yield x _ \<Rightarrow> x)"
by(simp add: lhd_cons_def lunstream_simps lhd_def split: step.split)

end

lemma lhd_cons_fusion2 [stream_fusion]:
  "lhd_cons (lgenerator g) s = lhd (lunstream' g s)"
by transfer(rule lhd_cons_def)

subsubsection \<open>@{const llength}\<close>

context fixes g :: "('a, 's) lgenerator" begin

definition gen_llength_cons :: "enat \<Rightarrow> 's \<Rightarrow> enat"
where "gen_llength_cons n s = n + llength (lunstream g s)"

lemma gen_llength_cons_code [code]:
  "gen_llength_cons n s = (case g s of
    Done \<Rightarrow> n | Skip s' \<Rightarrow> gen_llength_cons n s' | Yield _ s' \<Rightarrow> gen_llength_cons (eSuc n) s')"
by(simp add: gen_llength_cons_def lunstream_simps iadd_Suc_right iadd_Suc split: step.split)

lemma gen_llength_cons_fusion [stream_fusion]:
  "gen_llength_cons 0 s = llength (lunstream g s)"
by(simp add: gen_llength_cons_def)

end

context fixes g :: "('a, 's) lgenerator'" begin

definition gen_llength_cons' :: "enat \<Rightarrow> 's \<Rightarrow> enat"
where "gen_llength_cons' = gen_llength_cons (lgenerator g)"

lemma gen_llength_cons'_code [code]:
  "gen_llength_cons' n s = (case lgenerator g s of
    Done \<Rightarrow> n | Skip s' \<Rightarrow> gen_llength_cons' n s' | Yield _ s' \<Rightarrow> gen_llength_cons' (eSuc n) s')"
by(simp add: gen_llength_cons'_def cong: step.case_cong)(rule gen_llength_cons_code)

lemma gen_llength_cons'_fusion [stream_fusion]:
  "gen_llength_cons' 0 s = llength (lunstream' g s)"
by(simp add: gen_llength_cons'_def gen_llength_cons_fusion lunstream'.rep_eq)

end

subsubsection \<open>@{const lnull}\<close>

context fixes g :: "('a, 's) lgenerator" begin

definition lnull_cons :: "'s \<Rightarrow> bool"
where [stream_fusion]: "lnull_cons s \<longleftrightarrow> lnull (lunstream g s)"

lemma lnull_cons_code [code]:
  "lnull_cons s \<longleftrightarrow> (case g s of
    Done \<Rightarrow> True | Skip s' \<Rightarrow> lnull_cons s' | Yield _ _ \<Rightarrow> False)"
by(simp add: lnull_cons_def lunstream_simps split: step.split)

end

context fixes g :: "('a, 's) lgenerator'" begin

definition lnull_cons' :: "'s \<Rightarrow> bool"
where "lnull_cons' = lnull_cons (lgenerator g)"

lemma lnull_cons'_code [code]:
  "lnull_cons' s \<longleftrightarrow> (case lgenerator g s of
    Done \<Rightarrow> True | Skip s' \<Rightarrow> lnull_cons' s' | Yield _ _ \<Rightarrow> False)"
by(simp add: lnull_cons'_def cong: step.case_cong)(rule lnull_cons_code)

lemma lnull_cons'_fusion [stream_fusion]:
  "lnull_cons' s \<longleftrightarrow> lnull (lunstream' g s)"
by(simp add: lnull_cons'_def lnull_cons_def lunstream'.rep_eq)

end

subsubsection \<open>@{const llist_all2}\<close>

context
  fixes g :: "('a, 'sg) lgenerator"
  and h :: "('b, 'sh) lgenerator"
  and P :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
begin

definition llist_all2_cons :: "'sg \<Rightarrow> 'sh \<Rightarrow> bool"
where [stream_fusion]: "llist_all2_cons sg sh \<longleftrightarrow> llist_all2 P (lunstream g sg) (lunstream h sh)"

definition llist_all2_cons1 :: "'a \<Rightarrow> 'sg \<Rightarrow> 'sh \<Rightarrow> bool"
where "llist_all2_cons1 x sg' sh = llist_all2 P (LCons x (lunstream g sg')) (lunstream h sh)"

lemma llist_all2_cons_code [code]:
  "llist_all2_cons sg sh =
  (case g sg of
     Done \<Rightarrow> lnull_cons h sh
   | Skip sg' \<Rightarrow> llist_all2_cons sg' sh
   | Yield a sg' \<Rightarrow> llist_all2_cons1 a sg' sh)"
by(simp split: step.split add: llist_all2_cons_def lnull_cons_def llist_all2_cons1_def lunstream_simps lnull_def)

lemma llist_all2_cons1_code [code]:
  "llist_all2_cons1 x sg' sh =
  (case h sh of
     Done \<Rightarrow> False
   | Skip sh' \<Rightarrow> llist_all2_cons1 x sg' sh'
   | Yield y sh' \<Rightarrow> P x y \<and> llist_all2_cons sg' sh')"
by(simp split: step.split add: llist_all2_cons_def lnull_cons_def lnull_def llist_all2_cons1_def lunstream_simps)

end

lemma llist_all2_cons_fusion2 [stream_fusion]:
  "llist_all2_cons (lgenerator g) (lgenerator h) P sg sh \<longleftrightarrow> llist_all2 P (lunstream' g sg) (lunstream' h sh)"
by transfer(rule llist_all2_cons_def)

lemma llist_all2_cons_fusion3 [stream_fusion]:
  "llist_all2_cons g (lgenerator h) P sg sh \<longleftrightarrow> llist_all2 P (lunstream g sg) (lunstream' h sh)"
by transfer(rule llist_all2_cons_def)

lemma llist_all2_cons_fusion4 [stream_fusion]:
  "llist_all2_cons (lgenerator g) h P sg sh \<longleftrightarrow> llist_all2 P (lunstream' g sg) (lunstream h sh)"
by transfer(rule llist_all2_cons_def)

subsubsection \<open>@{const lnth}\<close>

context fixes g :: "('a, 's) lgenerator" begin

definition lnth_cons :: "nat \<Rightarrow> 's \<Rightarrow> 'a"
where [stream_fusion]: "lnth_cons n s = lnth (lunstream g s) n"

lemma lnth_cons_code [code]:
  "lnth_cons n s = (case g s of
    Done \<Rightarrow> undefined n
  | Skip s' \<Rightarrow> lnth_cons n s'
  | Yield x s' \<Rightarrow> (if n = 0 then x else lnth_cons (n - 1) s'))"
by(cases n)(simp_all add: lnth_cons_def lunstream_simps lnth_LNil split: step.split)

end

subsubsection \<open>@{const lprefix}\<close>

context
  fixes g :: "('a, 'sg) lgenerator"
  and h :: "('a, 'sh) lgenerator"
begin

definition lprefix_cons :: "'sg \<Rightarrow> 'sh \<Rightarrow> bool"
where [stream_fusion]: "lprefix_cons sg sh \<longleftrightarrow> lprefix (lunstream g sg) (lunstream h sh)"

definition lprefix_cons1 :: "'a \<Rightarrow> 'sg \<Rightarrow> 'sh \<Rightarrow> bool"
where "lprefix_cons1 x sg' sh \<longleftrightarrow> lprefix (LCons x (lunstream g sg')) (lunstream h sh)"

lemma lprefix_cons_code [code]:
  "lprefix_cons sg sh \<longleftrightarrow> (case g sg of
     Done \<Rightarrow> True | Skip sg' \<Rightarrow> lprefix_cons sg' sh | Yield x sg' \<Rightarrow> lprefix_cons1 x sg' sh)"
by(simp add: lprefix_cons_def lprefix_cons1_def lunstream_simps split: step.split)

lemma lprefix_cons1_code [code]:
  "lprefix_cons1 x sg' sh \<longleftrightarrow> (case h sh of
     Done \<Rightarrow> False | Skip sh' \<Rightarrow> lprefix_cons1 x sg' sh'
   | Yield y sh' \<Rightarrow> x = y \<and> lprefix_cons sg' sh')"
by(simp add: lprefix_cons_def lprefix_cons1_def lunstream_simps split: step.split)

end

lemma lprefix_cons_fusion2 [stream_fusion]:
  "lprefix_cons (lgenerator g) (lgenerator h) sg sh \<longleftrightarrow> lprefix (lunstream' g sg) (lunstream' h sh)"
by transfer(rule lprefix_cons_def)

lemma lprefix_cons_fusion3 [stream_fusion]:
  "lprefix_cons g (lgenerator h) sg sh \<longleftrightarrow> lprefix (lunstream g sg) (lunstream' h sh)"
by transfer(rule lprefix_cons_def)

lemma lprefix_cons_fusion4 [stream_fusion]:
  "lprefix_cons (lgenerator g) h sg sh \<longleftrightarrow> lprefix (lunstream' g sg) (lunstream h sh)"
by transfer(rule lprefix_cons_def)

subsection \<open>Transformers\<close>

subsubsection \<open>@{const lmap}\<close>

definition lmap_trans :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, 's) lgenerator \<Rightarrow> ('b, 's) lgenerator"
where "lmap_trans = map_raw"

lemma lunstream_lmap_trans [stream_fusion]: fixes f g s
  defines [simp]: "g' \<equiv> lmap_trans f g"
  shows "lunstream g' s = lmap f (lunstream g s)" (is "?lhs = ?rhs")
proof(rule lprefix_antisym)
  show "lprefix ?lhs ?rhs"
  proof(induction g' arbitrary: s rule: lunstream.fixp_induct)
    case (3 lunstream_g')
    then show ?case
      by(cases "g s")(simp_all add: lmap_trans_def map_raw_def lunstream_simps)
  qed simp_all
next
  note [cont_intro] = ccpo.admissible_leI[OF llist_ccpo]
  show "lprefix ?rhs ?lhs"
  proof(induction g arbitrary: s rule: lunstream.fixp_induct)
    case (3 lunstream_g)
    thus ?case by(cases "g s")(simp_all add: lmap_trans_def map_raw_def lunstream_simps)
  qed simp_all
qed

lift_definition lmap_trans' :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, 's) lgenerator' \<Rightarrow> ('b, 's) lgenerator'"
is lmap_trans
proof
  fix f :: "'a \<Rightarrow> 'b" and g :: "('a, 's) lgenerator" and s
  assume "productive g"
  hence "s \<in> productive_on g" ..
  thus "s \<in> productive_on (lmap_trans f g)"
    by induction(auto simp add: lmap_trans_def map_raw_def intro: productive_on.intros)
qed

lemma lunstream'_lmap_trans' [stream_fusion]:
  "lunstream' (lmap_trans' f g) s = lmap f (lunstream' g s)"
by transfer(rule lunstream_lmap_trans)

subsubsection \<open>@{const ltake}\<close>

fun ltake_trans :: "('a, 's) lgenerator \<Rightarrow> ('a, (enat \<times> 's)) lgenerator"
where
  "ltake_trans g (n, s) =
  (if n = 0 then Done else case g s of
    Done \<Rightarrow> Done | Skip s' \<Rightarrow> Skip (n, s') | Yield a s' \<Rightarrow> Yield a (epred n, s'))"

lemma ltake_trans_fusion [stream_fusion]:
  fixes g' g
  defines [simp]: "g' \<equiv> ltake_trans g"
  shows "lunstream g' (n, s) = ltake n (lunstream g s)" (is "?lhs = ?rhs")
proof(rule lprefix_antisym)
  show "lprefix ?lhs ?rhs"
  proof(induction g' arbitrary: n s rule: lunstream.fixp_induct)
    case (3 lunstream_g')
    thus ?case
      by(cases "g s")(auto simp add: lunstream_simps neq_zero_conv_eSuc)
  qed simp_all
  show "lprefix ?rhs ?lhs"
  proof(induction g arbitrary: s n rule: lunstream.fixp_induct)
    case (3 lunstream_g)
    thus ?case by(cases "g s" n rule: step.exhaust[case_product enat_coexhaust])(auto simp add: lunstream_simps)
  qed simp_all
qed

lift_definition ltake_trans' :: "('a, 's) lgenerator' \<Rightarrow> ('a, (enat \<times> 's)) lgenerator'"
is "ltake_trans"
proof
  fix g :: "('a, 's) lgenerator" and s :: "enat \<times> 's"
  obtain n sg where s: "s = (n, sg)" by(cases s)
  assume "productive g"
  hence "sg \<in> productive_on g" ..
  then show "s \<in> productive_on (ltake_trans g)" unfolding \<open>s = (n, sg)\<close>
    apply(induction arbitrary: n)
    apply(case_tac [!] n rule: enat_coexhaust)
    apply(auto intro: productive_on.intros)
    done
qed

lemma ltake_trans'_fusion [stream_fusion]:
  "lunstream' (ltake_trans' g) (n, s) = ltake n (lunstream' g s)"
by transfer(rule ltake_trans_fusion)

subsubsection \<open>@{const ldropn}\<close>

abbreviation (input) ldropn_trans :: "('b, 'a) lgenerator \<Rightarrow> ('b, nat \<times> 'a) lgenerator"
where "ldropn_trans \<equiv> drop_raw"

lemma ldropn_trans_fusion [stream_fusion]:
  fixes g defines [simp]: "g' \<equiv> ldropn_trans g"
  shows "lunstream g' (n, s) = ldropn n (lunstream g s)" (is "?lhs = ?rhs")
proof(rule lprefix_antisym)
  show "lprefix ?lhs ?rhs"
  proof(induction g' arbitrary: n s rule: lunstream.fixp_induct)
    case (3 lunstream_g')
    thus ?case
      by(cases "g s" n rule: step.exhaust[case_product nat.exhaust])
        (auto simp add: lunstream_simps elim: meta_allE[where x=0])
  qed simp_all
  note [cont_intro] = ccpo.admissible_leI[OF llist_ccpo]
  show "lprefix ?rhs ?lhs"
  proof(induction g arbitrary: n s rule: lunstream.fixp_induct)
    case (3 lunstream_g)
    thus ?case by(cases n)(auto split: step.split simp add: lunstream_simps elim: meta_allE[where x=0])
  qed simp_all
qed

lift_definition ldropn_trans' :: "('a, 's) lgenerator' \<Rightarrow> ('a, nat \<times> 's) lgenerator'"
is ldropn_trans
proof
  fix g :: "('a, 's) lgenerator" and ns :: "nat \<times> 's"
  obtain n s where ns: "ns = (n, s)" by(cases ns)
  assume g: "productive g"
  show "ns \<in> productive_on (ldropn_trans g)" unfolding ns
  proof(induction n arbitrary: s)
    case 0
    from g have "s \<in> productive_on g" ..
    thus ?case by induction(auto intro: productive_on.intros)
  next
    case (Suc n)
    from g have "s \<in> productive_on g" ..
    thus ?case by induction(auto intro: productive_on.intros Suc.IH)
  qed
qed

lemma ldropn_trans'_fusion [stream_fusion]:
  "lunstream' (ldropn_trans' g) (n, s) = ldropn n (lunstream' g s)"
by transfer(rule ldropn_trans_fusion)

subsubsection \<open>@{const ldrop}\<close>

fun ldrop_trans :: "('a, 's) lgenerator \<Rightarrow> ('a, enat \<times> 's) lgenerator"
where
  "ldrop_trans g (n, s) = (case g s of
    Done \<Rightarrow> Done | Skip s' \<Rightarrow> Skip (n, s')
  | Yield x s' \<Rightarrow> (if n = 0 then Yield x (n, s') else Skip (epred n, s')))"

lemma ldrop_trans_fusion [stream_fusion]:
  fixes g g' defines [simp]: "g' \<equiv> ldrop_trans g"
  shows "lunstream g' (n, s) = ldrop n (lunstream g s)" (is "?lhs = ?rhs")
proof(rule lprefix_antisym)
  show "lprefix ?lhs ?rhs"
    by(induction g' arbitrary: n s rule: lunstream.fixp_induct)
      (auto simp add: lunstream_simps neq_zero_conv_eSuc elim: meta_allE[where x=0] split: step.split)
  show "lprefix ?rhs ?lhs"
  proof(induction g arbitrary: n s rule: lunstream.fixp_induct)
    case (3 lunstream_g)
    thus ?case
      by(cases n rule: enat_coexhaust)(auto simp add: lunstream_simps split: step.split elim: meta_allE[where x=0])
  qed simp_all
qed

lemma ldrop_trans_fusion2 [stream_fusion]:
  "lunstream (ldrop_trans (lgenerator g)) (n, s) = ldrop n (lunstream' g s)"
by transfer (rule ldrop_trans_fusion)

subsubsection \<open>@{const ltakeWhile}\<close>

abbreviation (input) ltakeWhile_trans :: "('a \<Rightarrow> bool) \<Rightarrow> ('a, 's) lgenerator \<Rightarrow> ('a, 's) lgenerator"
where "ltakeWhile_trans \<equiv> takeWhile_raw"

lemma ltakeWhile_trans_fusion [stream_fusion]:
  fixes P g g' defines [simp]: "g' \<equiv> ltakeWhile_trans P g"
  shows "lunstream g' s = ltakeWhile P (lunstream g s)" (is "?lhs = ?rhs")
proof(rule lprefix_antisym)
  show "lprefix ?lhs ?rhs"
    by(induction g' arbitrary: s rule: lunstream.fixp_induct)(auto simp add: lunstream_simps takeWhile_raw_def split: step.split)
  show "lprefix ?rhs ?lhs"
    by(induction g arbitrary: s rule: lunstream.fixp_induct)(auto split: step.split simp add: lunstream_simps takeWhile_raw_def)
qed

lift_definition ltakeWhile_trans' :: "('a \<Rightarrow> bool) \<Rightarrow> ('a, 's) lgenerator' \<Rightarrow> ('a, 's) lgenerator'"
is ltakeWhile_trans
proof
  fix P and g :: "('a, 's) lgenerator" and s
  assume "productive g"
  hence "s \<in> productive_on g" ..
  thus "s \<in> productive_on (ltakeWhile_trans P g)"
    apply(induction)
    apply(case_tac [3] "P x")
    apply(auto intro: productive_on.intros simp add: takeWhile_raw_def)
    done
qed

lemma ltakeWhile_trans'_fusion [stream_fusion]:
  "lunstream' (ltakeWhile_trans' P g) s = ltakeWhile P (lunstream' g s)"
by transfer(rule ltakeWhile_trans_fusion)

subsubsection \<open>@{const ldropWhile}\<close>

abbreviation (input) ldropWhile_trans :: "('a \<Rightarrow> bool) \<Rightarrow> ('a, 'b) lgenerator \<Rightarrow> ('a, bool \<times> 'b) lgenerator"
where "ldropWhile_trans \<equiv> dropWhile_raw"

lemma ldropWhile_trans_fusion [stream_fusion]:
  fixes P g g' defines [simp]: "g' \<equiv> ldropWhile_trans P g"
  shows "lunstream g' (True, s) = ldropWhile P (lunstream g s)" (is "?lhs = ?rhs")
proof -
  have "lprefix ?lhs ?rhs" "lprefix (lunstream g' (False, s)) (lunstream g s)"
    by(induction g' arbitrary: s rule: lunstream.fixp_induct)(simp_all add: lunstream_simps split: step.split)
  moreover have "lprefix ?rhs ?lhs" "lprefix (lunstream g s) (lunstream g' (False, s))"
    by(induction g arbitrary: s rule: lunstream.fixp_induct)(simp_all add: lunstream_simps split: step.split)
  ultimately show ?thesis by(blast intro: lprefix_antisym)
qed

lemma ldropWhile_trans_fusion2 [stream_fusion]:
  "lunstream (ldropWhile_trans P (lgenerator g)) (True, s) = ldropWhile P (lunstream' g s)"
by transfer(rule ldropWhile_trans_fusion)

subsubsection \<open>@{const lzip}\<close>

abbreviation (input) lzip_trans :: "('a, 's1) lgenerator \<Rightarrow> ('b, 's2) lgenerator \<Rightarrow> ('a \<times> 'b, 's1 \<times> 's2 \<times> 'a option) lgenerator"
where "lzip_trans \<equiv> zip_raw"

lemma lzip_trans_fusion [stream_fusion]:
  fixes g h gh defines [simp]: "gh \<equiv> lzip_trans g h"
  shows "lunstream gh (sg, sh, None) = lzip (lunstream g sg) (lunstream h sh)"
  (is "?lhs = ?rhs")
proof -
  have "lprefix ?lhs ?rhs"
    and "\<And>x. lprefix (lunstream gh (sg, sh, Some x)) (lzip (LCons x (lunstream g sg)) (lunstream h sh))"
  proof(induction gh arbitrary: sg sh rule: lunstream.fixp_induct)
    case (3 lunstream)
    { case 1 show ?case using 3
        by(cases "g sg")(simp_all add: lunstream_simps) }
    { case 2 show ?case using 3
        by(cases "h sh")(simp_all add: lunstream_simps) }
  qed simp_all
  moreover
  note [cont_intro] = ccpo.admissible_leI[OF llist_ccpo]
  have "lprefix ?rhs ?lhs"
    and "\<And>x. lprefix (lzip (LCons x (lunstream g sg)) (lunstream h sh)) (lunstream gh (sg, sh, Some x))"
  proof(induction g arbitrary: sg sh rule: lunstream.fixp_induct)
    case (3 lunstream_g)
    note IH = "3.IH"
    { case 1 show ?case using 3
        by(cases "g sg")(simp_all add: lunstream_simps fun_ord_def) }
    { case 2 show ?case
      proof(induction h arbitrary: sh sg x rule: lunstream.fixp_induct)
        case (3 unstream_h)
        thus ?case
        proof(cases "h sh")
          case (Yield y sh')
          thus ?thesis using "3.prems" IH "3.hyps"
            by(cases "g sg")(auto 4 3 simp add: lunstream_simps fun_ord_def intro: monotone_lzip2[THEN monotoneD] lprefix_trans)
        qed(simp_all add: lunstream_simps)
      qed simp_all }
  next
    case 2 case 2
    show ?case
      by(induction h arbitrary: sh rule: lunstream.fixp_induct)(simp_all add: lunstream_simps split: step.split)
  qed simp_all
  ultimately show ?thesis by(blast intro: lprefix_antisym)
qed

lemma lzip_trans_fusion2 [stream_fusion]:
  "lunstream (lzip_trans (lgenerator g) h) (sg, sh, None) = lzip (lunstream' g sg) (lunstream h sh)"
by transfer(rule lzip_trans_fusion)

lemma lzip_trans_fusion3 [stream_fusion]:
  "lunstream (lzip_trans g (lgenerator h)) (sg, sh, None) = lzip (lunstream g sg) (lunstream' h sh)"
by transfer(rule lzip_trans_fusion)

lift_definition lzip_trans' :: "('a, 's1) lgenerator' \<Rightarrow> ('b, 's2) lgenerator' \<Rightarrow> ('a \<times> 'b, 's1 \<times> 's2 \<times> 'a option) lgenerator'"
is "lzip_trans"
proof
  fix g :: "('a, 's1) lgenerator" and h :: "('b, 's2) lgenerator" and s :: "'s1 \<times> 's2 \<times> 'a option"
  assume "productive g" and "productive h"
  obtain sg sh mx where s: "s = (sg, sh, mx)" by(cases s)
  { fix x sg
    from \<open>productive h\<close> have "sh \<in> productive_on h" ..
    hence "(sg, sh, Some x) \<in> productive_on (lzip_trans g h)"
      by(induction)(auto simp add: intro: productive_on.intros) }
  moreover
  from \<open>productive g\<close> have "sg \<in> productive_on g" ..
  then have "(sg, sh, None) \<in> productive_on (lzip_trans g h)"
    by induction(auto intro: productive_on.intros calculation)
  ultimately show "s \<in> productive_on (lzip_trans g h)" unfolding s
    by(cases mx) auto
qed

lemma lzip_trans'_fusion [stream_fusion]:
  "lunstream' (lzip_trans' g h) (sg, sh, None) = lzip (lunstream' g sg) (lunstream' h sh)"
by transfer(rule lzip_trans_fusion)

subsubsection \<open>@{const lappend}\<close>

lift_definition lappend_trans :: "('a, 'sg) lgenerator' \<Rightarrow> ('a, 'sh) lgenerator \<Rightarrow> 'sh \<Rightarrow> ('a, 'sg + 'sh) lgenerator"
is append_raw .

lemma lunstream_append_raw:
  fixes g h sh gh defines [simp]: "gh \<equiv> append_raw g h sh"
  assumes "productive g"
  shows "lunstream gh (Inl sg) = lappend (lunstream g sg) (lunstream h sh)"
proof(coinduction arbitrary: sg rule: llist.coinduct_strong)
  case (Eq_llist sg)
  { fix sh'
    have "lprefix (lunstream gh (Inr sh')) (lunstream h sh')"
      by(induction gh arbitrary: sh' rule: lunstream.fixp_induct)(simp_all add: lunstream_simps split: step.split)
    moreover have "lprefix (lunstream h sh') (lunstream gh (Inr sh'))"
      by(induction h arbitrary: sh' rule: lunstream.fixp_induct)(simp_all add: lunstream_simps split: step.split)
    ultimately have "lunstream gh (Inr sh') = lunstream h sh'"
      by(blast intro: lprefix_antisym) }
  note Inr = this[unfolded gh_def]
  from \<open>productive g\<close> have sg: "sg \<in> productive_on g" ..
  then show ?case by induction(auto simp add: lunstream_sels Inr)
qed

lemma lappend_trans_fusion [stream_fusion]:
  "lunstream (lappend_trans g h sh) (Inl sg) = lappend (lunstream' g sg) (lunstream h sh)"
by transfer(rule lunstream_append_raw)

lift_definition lappend_trans' :: "('a, 'sg) lgenerator' \<Rightarrow> ('a, 'sh) lgenerator' \<Rightarrow> 'sh \<Rightarrow> ('a, 'sg + 'sh) lgenerator'"
is append_raw
proof
  fix g :: "('a, 'sg) lgenerator" and h :: "('a, 'sh) lgenerator" and sh s
  assume "productive g" "productive h"
  { fix sh'
    from \<open>productive h\<close> have "sh' \<in> productive_on h" ..
    then have "Inr sh' \<in> productive_on (append_raw g h sh)"
      by induction (auto intro: productive_on.intros)
  } moreover {
    fix sg
    from \<open>productive g\<close> have "sg \<in> productive_on g" ..
    then have "Inl sg \<in> productive_on (append_raw g h sh)"
      by induction(auto intro: productive_on.intros calculation) }
  ultimately show "s \<in> productive_on (append_raw g h sh)" by(cases s) auto
qed

lemma lappend_trans'_fusion [stream_fusion]:
  "lunstream' (lappend_trans' g h sh) (Inl sg) = lappend (lunstream' g sg) (lunstream' h sh)"
by transfer(rule lunstream_append_raw)

subsubsection \<open>@{const lfilter}\<close>

definition lfilter_trans :: "('a \<Rightarrow> bool) \<Rightarrow> ('a, 's) lgenerator \<Rightarrow> ('a, 's) lgenerator"
where "lfilter_trans = filter_raw"

lemma lunstream_lfilter_trans [stream_fusion]:
  fixes P g g' defines [simp]: "g' \<equiv> lfilter_trans P g"
  shows "lunstream g' s = lfilter P (lunstream g s)" (is "?lhs = ?rhs")
proof(rule lprefix_antisym)
  show "lprefix ?lhs ?rhs"
    by(induction g' arbitrary: s rule: lunstream.fixp_induct)
      (simp_all add: lfilter_trans_def filter_raw_def lunstream_simps split: step.split)
  show "lprefix ?rhs ?lhs"
  by(induction g arbitrary: s rule: lunstream.fixp_induct)
    (simp_all add: lfilter_trans_def filter_raw_def lunstream_simps split: step.split)
qed

lemma lunstream_lfilter_trans2 [stream_fusion]:
  "lunstream (lfilter_trans P (lgenerator g)) s = lfilter P (lunstream' g s)"
by transfer(rule lunstream_lfilter_trans)

subsubsection \<open>@{const llist_of}\<close>

lift_definition llist_of_trans :: "('a, 's) generator \<Rightarrow> ('a, 's) lgenerator'"
is "\<lambda>x. x"
proof
  fix g :: "('a, 's) raw_generator" and s
  assume "terminates g"
  hence "s \<in> terminates_on g" by(simp add: terminates_def)
  then show "s \<in> productive_on g"
    by(induction)(auto intro: productive_on.intros)
qed

lemma lunstream_llist_of_trans [stream_fusion]:
  "lunstream' (llist_of_trans g) s = llist_of (unstream g s)"
apply(induction s taking: g rule: unstream.induct)
apply(rule llist.expand)
apply(auto intro: llist.expand simp add: llist_of_trans.rep_eq lunstream_sels lunstream'.rep_eq split: step.split)
done

text \<open>We cannot define a stream version of @{const list_of} because we would have to test
  for finiteness first and therefore traverse the list twice.\<close>

end