theory UnwindingResults
imports AuxiliaryLemmas
begin

context Unwinding
begin
theorem unwinding_theorem_BSD:
"\<lbrakk> lrf ur; osc ur \<rbrakk> \<Longrightarrow> BSD \<V> Tr\<^bsub>(induceES SES)\<^esub>"
proof -
  assume lrf_true: "lrf ur"
  assume osc_true: "osc ur"

  { (* show that the conclusion of the BSP follows from the assumptions *)
    fix \<alpha> \<beta> c
    assume c_in_C: "c \<in> C\<^bsub>\<V>\<^esub>"
    assume \<beta>c\<alpha>_in_Tr: "((\<beta> @ [c]) @ \<alpha>) \<in> Tr\<^bsub>(induceES SES)\<^esub>"
    assume \<alpha>_contains_no_c: "\<alpha> \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []"

    from state_from_induceES_trace[OF \<beta>c\<alpha>_in_Tr] obtain s1'
      where s1'_in_S: "s1' \<in> S\<^bsub>SES\<^esub>"
      and enabled_s1'_\<alpha>: "enabled SES s1' \<alpha>"
      and s0_\<beta>c_s1': "s0\<^bsub>SES\<^esub> (\<beta> @ [c])\<Longrightarrow>\<^bsub>SES\<^esub> s1'"
      and reachable_s1': "reachable SES s1'"
      by auto

    from path_split_single2[OF s0_\<beta>c_s1'] obtain s1
      where s1_in_S: "s1 \<in> S\<^bsub>SES\<^esub>"
      and s0_\<beta>_s1: "s0\<^bsub>SES\<^esub> \<beta>\<Longrightarrow>\<^bsub>SES\<^esub> s1"
      and s1_c_s1': "s1 c\<longrightarrow>\<^bsub>SES\<^esub> s1'"
      and reachable_s1: "reachable SES s1"
      by auto

    from s1_in_S s1'_in_S c_in_C reachable_s1 s1_c_s1' lrf_true
    have s1'_ur_s1: "((s1', s1) \<in> ur)"
      by (simp add: lrf_def, auto)

    from osc_property[OF osc_true s1_in_S s1'_in_S \<alpha>_contains_no_c reachable_s1
      reachable_s1' enabled_s1'_\<alpha> s1'_ur_s1]
    obtain \<alpha>'
      where \<alpha>'_contains_no_c: "\<alpha>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []"
      and \<alpha>'_V_is_\<alpha>_V: "\<alpha>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<alpha> \<upharpoonleft> V\<^bsub>\<V>\<^esub>"
      and enabled_s1_\<alpha>': "enabled SES s1 \<alpha>'"
      by auto

    have \<beta>\<alpha>'_in_Tr: "\<beta> @ \<alpha>' \<in> Tr\<^bsub>(induceES SES)\<^esub>"
    proof -
      note s0_\<beta>_s1
      moreover
      from enabled_s1_\<alpha>' obtain s2
        where "s1 \<alpha>'\<Longrightarrow>\<^bsub>SES\<^esub> s2"
        by (simp add: enabled_def, auto)
      ultimately have "s0\<^bsub>SES\<^esub> (\<beta> @ \<alpha>') \<Longrightarrow>\<^bsub>SES\<^esub> s2"
        by (rule path_trans)
      thus ?thesis
        by (simp add: induceES_def possible_traces_def enabled_def)
    qed

    from \<beta>\<alpha>'_in_Tr \<alpha>'_V_is_\<alpha>_V \<alpha>'_contains_no_c have
      "\<exists>\<alpha>'. ((\<beta> @ \<alpha>') \<in> (Tr\<^bsub>(induceES SES)\<^esub>) \<and> (\<alpha>' \<upharpoonleft> (V\<^bsub>\<V>\<^esub>)) = (\<alpha> \<upharpoonleft> V\<^bsub>\<V>\<^esub>) \<and> \<alpha>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = [])"
      by auto
  }
  thus ?thesis
    by (simp add: BSD_def)
qed

theorem unwinding_theorem_BSI:
"\<lbrakk> lrb ur; osc ur \<rbrakk> \<Longrightarrow> BSI \<V> Tr\<^bsub>(induceES SES)\<^esub>"
proof -
  assume lrb_true: "lrb ur"
  assume osc_true: "osc ur"

  {   (* show that the conclusion of the BSP follows from the assumptions *)
    fix \<alpha> \<beta> c
    assume c_in_C: "c \<in> C\<^bsub>\<V>\<^esub>"
    assume \<beta>\<alpha>_in_ind_Tr: "(\<beta> @ \<alpha>) \<in> Tr\<^bsub>(induceES SES)\<^esub>"
    assume \<alpha>_contains_no_c: "\<alpha> \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []"

    from state_from_induceES_trace[OF \<beta>\<alpha>_in_ind_Tr] obtain s1
      where s1_in_S : "s1 \<in> S\<^bsub>SES\<^esub>"
      and path_\<beta>_yields_s1:  "s0\<^bsub>SES\<^esub> \<beta>\<Longrightarrow>\<^bsub>SES\<^esub> s1"
      and enabled_s1_\<alpha>: "enabled SES s1 \<alpha>"
      and reachable_s1: "reachable SES s1"
      by auto

    from reachable_s1 s1_in_S c_in_C  lrb_true
    have "\<exists>s1'\<in> S\<^bsub>SES\<^esub>. s1 c\<longrightarrow>\<^bsub>SES\<^esub> s1' \<and> (s1, s1') \<in> ur"
      by(simp add: lrb_def)
    then obtain s1'
      where s1'_in_S: "s1' \<in> S\<^bsub>SES\<^esub>"
      and s1_trans_c_s1': "s1 c\<longrightarrow>\<^bsub>SES\<^esub> s1'"
      and s1_s1'_in_ur: "(s1, s1') \<in> ur"
      by auto

    have reachable_s1': "reachable SES s1'"
    proof -
      from path_\<beta>_yields_s1 s1_trans_c_s1' have "s0\<^bsub>SES\<^esub> (\<beta> @ [c])\<Longrightarrow>\<^bsub>SES\<^esub> s1'"
        by (rule path_trans_single)
      thus ?thesis by (simp add: reachable_def, auto)
    qed

    from osc_property[OF osc_true s1'_in_S s1_in_S \<alpha>_contains_no_c
      reachable_s1' reachable_s1 enabled_s1_\<alpha> s1_s1'_in_ur]
    obtain \<alpha>'
      where \<alpha>'_contains_no_c: "\<alpha>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []"
      and \<alpha>'_V_is_\<alpha>_V: "\<alpha>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<alpha> \<upharpoonleft> V\<^bsub>\<V>\<^esub>"
      and enabled_s1'_\<alpha>': "enabled SES s1' \<alpha>'"
      by auto

    have \<beta>c\<alpha>'_in_ind_Tr: "\<beta> @ [c] @ \<alpha>' \<in> Tr\<^bsub>(induceES SES)\<^esub>"
    proof -
      from path_\<beta>_yields_s1 s1_trans_c_s1' have "s0\<^bsub>SES\<^esub> (\<beta> @ [c])\<Longrightarrow>\<^bsub>SES\<^esub> s1'"
        by (rule path_trans_single)
      moreover
      from enabled_s1'_\<alpha>' obtain s2
        where "s1' \<alpha>'\<Longrightarrow>\<^bsub>SES\<^esub> s2"
        by (simp add: enabled_def, auto)
      ultimately have "s0\<^bsub>SES\<^esub> ((\<beta> @ [c]) @ \<alpha>')\<Longrightarrow>\<^bsub>SES\<^esub> s2"
        by (rule path_trans)
      thus ?thesis
        by (simp add: induceES_def possible_traces_def enabled_def)
    qed

    from \<beta>c\<alpha>'_in_ind_Tr \<alpha>'_V_is_\<alpha>_V \<alpha>'_contains_no_c
    have "\<exists>\<alpha>'. \<beta> @ c # \<alpha>' \<in> Tr\<^bsub>(induceES SES)\<^esub> \<and> \<alpha>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<alpha> \<upharpoonleft> V\<^bsub>\<V>\<^esub> \<and> \<alpha>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []"
      by auto
  }
  thus ?thesis
    by(simp add: BSI_def)
qed

(* unwinding theorem for BSP BSIA *)
theorem unwinding_theorem_BSIA:
"\<lbrakk> lrbe \<rho> ur; osc ur \<rbrakk> \<Longrightarrow> BSIA \<rho> \<V> Tr\<^bsub>(induceES SES)\<^esub>"
proof -
  assume lrbe_true: "lrbe \<rho> ur"
  assume osc_true: "osc ur"

  { (* show that the conclusion of the BSP follows from the assumptions *)
    fix \<alpha> \<beta> c
    assume c_in_C: "c \<in> C\<^bsub>\<V>\<^esub>"
    assume \<beta>\<alpha>_in_ind_Tr: "(\<beta> @ \<alpha>) \<in> Tr\<^bsub>(induceES SES)\<^esub>"
    assume \<alpha>_contains_no_c: "\<alpha> \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []"

    assume adm: "Adm \<V> \<rho> Tr\<^bsub>(induceES SES)\<^esub> \<beta> c"

    from state_from_induceES_trace[OF \<beta>\<alpha>_in_ind_Tr]
    obtain s1
      where s1_in_S : "s1 \<in> S\<^bsub>SES\<^esub>"
      and s0_\<beta>_s1:  "s0\<^bsub>SES\<^esub> \<beta>\<Longrightarrow>\<^bsub>SES\<^esub> s1"
      and enabled_s1_\<alpha>: "enabled SES s1 \<alpha>"
      and reachable_s1: "reachable SES s1"
      by auto

        (* case distinction whether En is true or not *)
    have "\<exists>\<alpha>'. \<beta> @ [c] @ \<alpha>' \<in> Tr\<^bsub>(induceES SES)\<^esub> \<and> \<alpha>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<alpha> \<upharpoonleft> V\<^bsub>\<V>\<^esub> \<and> \<alpha>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []"
    proof cases
      assume en: "En \<rho> s1 c" (*first case, en is true *)

      from reachable_s1 s1_in_S c_in_C en lrbe_true
      have "\<exists>s1'\<in> S\<^bsub>SES\<^esub>. s1 c\<longrightarrow>\<^bsub>SES\<^esub> s1' \<and> (s1, s1') \<in> ur"
        by(simp add: lrbe_def)
      then obtain s1'
        where s1'_in_S: "s1' \<in> S\<^bsub>SES\<^esub>"
        and s1_trans_c_s1': "s1 c\<longrightarrow>\<^bsub>SES\<^esub> s1'"
        and s1_s1'_in_ur: "(s1, s1') \<in> ur"
        by auto

      have reachable_s1': "reachable SES s1'"
      proof -
        from s0_\<beta>_s1 s1_trans_c_s1' have "s0\<^bsub>SES\<^esub> (\<beta> @ [c])\<Longrightarrow>\<^bsub>SES\<^esub> s1'"
          by (rule path_trans_single)
        thus ?thesis by (simp add: reachable_def, auto)
      qed

      from osc_property[OF osc_true s1'_in_S s1_in_S \<alpha>_contains_no_c
        reachable_s1' reachable_s1 enabled_s1_\<alpha> s1_s1'_in_ur]
      obtain \<alpha>'
        where \<alpha>'_contains_no_c: "\<alpha>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []"
        and \<alpha>'_V_is_\<alpha>_V: "\<alpha>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<alpha> \<upharpoonleft> V\<^bsub>\<V>\<^esub>"
        and enabled_s1'_\<alpha>': "enabled SES s1' \<alpha>'"
        by auto

      have \<beta>c\<alpha>'_in_ind_Tr: "\<beta> @ [c] @ \<alpha>' \<in> Tr\<^bsub>(induceES SES)\<^esub>"
      proof -
        from s0_\<beta>_s1 s1_trans_c_s1' have "s0\<^bsub>SES\<^esub> (\<beta> @ [c])\<Longrightarrow>\<^bsub>SES\<^esub> s1'"
          by (rule path_trans_single)
        moreover
        from enabled_s1'_\<alpha>' obtain s2
          where "s1' \<alpha>'\<Longrightarrow>\<^bsub>SES\<^esub> s2"
          by (simp add: enabled_def, auto)
        ultimately have "s0\<^bsub>SES\<^esub> ((\<beta> @ [c]) @ \<alpha>')\<Longrightarrow>\<^bsub>SES\<^esub> s2"
          by (rule path_trans)
        thus ?thesis
          by (simp add: induceES_def possible_traces_def enabled_def)
      qed

      from \<beta>c\<alpha>'_in_ind_Tr \<alpha>'_V_is_\<alpha>_V \<alpha>'_contains_no_c show ?thesis
        by auto
    next (* second case, en is false *)
      assume not_en: "\<not> En \<rho> s1 c"

      let ?A = "(Adm \<V> \<rho> (Tr\<^bsub>(induceES SES)\<^esub>) \<beta> c)"
      let ?E = "\<exists>s \<in> S\<^bsub>SES\<^esub>. (s0\<^bsub>SES\<^esub> \<beta>\<Longrightarrow>\<^bsub>SES\<^esub> s \<and> En \<rho> s c)"

      { (* show the contraposition of Adm_to_En *)
        assume adm: "?A"

        from s0_\<beta>_s1 have \<beta>_in_Tr: "\<beta> \<in> Tr\<^bsub>(induceES SES)\<^esub>"
          by (simp add: induceES_def possible_traces_def enabled_def)

        from  \<beta>_in_Tr adm have "?E"
          by (rule Adm_to_En)
      }
      hence Adm_to_En_contr: "\<not> ?E \<Longrightarrow> \<not> ?A"
        by blast
      with s1_in_S s0_\<beta>_s1 not_en have not_adm: "\<not> ?A"
        by auto
      with adm show ?thesis
        by auto
    qed
  }
  thus ?thesis
    by (simp add: BSIA_def)
qed

theorem unwinding_theorem_FCD:
"\<lbrakk> fcrf \<Gamma> ur; osc ur \<rbrakk> \<Longrightarrow> FCD \<Gamma> \<V> Tr\<^bsub>(induceES SES)\<^esub>"
proof -
  assume fcrf: "fcrf \<Gamma> ur"
  assume osc: "osc ur"

  { (* show that the conclusion of the BSP follows from the assumptions *)
    fix \<alpha> \<beta> c v

    assume c_in_C_inter_Y: "c \<in> (C\<^bsub>\<V>\<^esub> \<inter> \<Upsilon>\<^bsub>\<Gamma>\<^esub>)"
    assume v_in_V_inter_Nabla: "v \<in> (V\<^bsub>\<V>\<^esub> \<inter> \<nabla>\<^bsub>\<Gamma>\<^esub>)"
    assume \<beta>cv\<alpha>_in_Tr: "((\<beta> @ [c] @ [v]) @ \<alpha>) \<in> Tr\<^bsub>(induceES SES)\<^esub>"
    assume \<alpha>_contains_no_c: "\<alpha> \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []"

    from state_from_induceES_trace[OF \<beta>cv\<alpha>_in_Tr] obtain s1'
      where s1'_in_S: "s1' \<in> S\<^bsub>SES\<^esub>"
      and s0_\<beta>cv_s1': "s0\<^bsub>SES\<^esub> (\<beta> @ ([c] @ [v]))\<Longrightarrow>\<^bsub>SES\<^esub> s1'"
      and enabled_s1'_\<alpha>: "enabled SES s1' \<alpha>"
      and reachable_s1': "reachable SES s1'"
      by auto

    from path_split2[OF s0_\<beta>cv_s1'] obtain s1
      where s1_in_S: "s1 \<in> S\<^bsub>SES\<^esub>"
      and s0_\<beta>_s1: "s0\<^bsub>SES\<^esub> \<beta>\<Longrightarrow>\<^bsub>SES\<^esub> s1"
      and s1_cv_s1': "s1 ([c] @ [v])\<Longrightarrow>\<^bsub>SES\<^esub> s1'"
      and reachable_s1: "reachable SES s1"
      by (auto)

    from c_in_C_inter_Y v_in_V_inter_Nabla s1_in_S s1'_in_S reachable_s1 s1_cv_s1' fcrf
    have "\<exists>s1'' \<in> S\<^bsub>SES\<^esub>. \<exists>\<delta>. (\<forall>d \<in> (set \<delta>). d \<in> (N\<^bsub>\<V>\<^esub> \<inter> \<Delta>\<^bsub>\<Gamma>\<^esub>)) \<and>
      s1 (\<delta> @ [v])\<Longrightarrow>\<^bsub>SES\<^esub> s1'' \<and> (s1', s1'') \<in> ur"
      by (simp add: fcrf_def)
    then obtain s1'' \<delta>
      where s1''_in_S: "s1'' \<in> S\<^bsub>SES\<^esub>"
      and \<delta>_in_N_inter_Delta_star: "(\<forall>d \<in> (set \<delta>). d \<in> (N\<^bsub>\<V>\<^esub> \<inter> \<Delta>\<^bsub>\<Gamma>\<^esub>))"
      and s1_\<delta>v_s1'': "s1 (\<delta> @ [v])\<Longrightarrow>\<^bsub>SES\<^esub> s1''"
      and s1'_ur_s1'': "(s1', s1'') \<in> ur"
      by auto

    have reachable_s1'': "reachable SES s1''"
    proof -
      from s0_\<beta>_s1 s1_\<delta>v_s1'' have "s0\<^bsub>SES\<^esub> (\<beta> @ (\<delta> @ [v]))\<Longrightarrow>\<^bsub>SES\<^esub> s1''"
        by (rule path_trans)
      thus ?thesis
        by (simp add: reachable_def, auto)
    qed

    from osc_property[OF  osc s1''_in_S s1'_in_S \<alpha>_contains_no_c
      reachable_s1'' reachable_s1' enabled_s1'_\<alpha> s1'_ur_s1'']
    obtain \<alpha>'
      where  \<alpha>'_contains_no_c: "\<alpha>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []"
      and \<alpha>'_V_is_\<alpha>_V: "\<alpha>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<alpha> \<upharpoonleft> V\<^bsub>\<V>\<^esub>"
      and enabled_s1''_\<alpha>': "enabled SES s1'' \<alpha>'"
      by auto

    have \<beta>\<delta>v\<alpha>'_in_Tr: "\<beta> @ \<delta> @ [v] @ \<alpha>' \<in> Tr\<^bsub>(induceES SES)\<^esub>"
      proof -
        from s0_\<beta>_s1 s1_\<delta>v_s1'' have "s0\<^bsub>SES\<^esub> (\<beta> @ \<delta> @ [v])\<Longrightarrow>\<^bsub>SES\<^esub> s1''"
          by (rule path_trans)
        moreover
        from enabled_s1''_\<alpha>' obtain s2
          where "s1'' \<alpha>'\<Longrightarrow>\<^bsub>SES\<^esub> s2"
          by (simp add: enabled_def, auto)
        ultimately have "s0\<^bsub>SES\<^esub> ((\<beta> @ \<delta> @ [v]) @ \<alpha>')\<Longrightarrow>\<^bsub>SES\<^esub> s2"
          by (rule path_trans)
        thus ?thesis
          by (simp add: induceES_def possible_traces_def enabled_def)
      qed

      from \<delta>_in_N_inter_Delta_star \<beta>\<delta>v\<alpha>'_in_Tr \<alpha>'_V_is_\<alpha>_V \<alpha>'_contains_no_c
      have "\<exists>\<alpha>'. \<exists>\<delta>'. set \<delta>' \<subseteq> (N\<^bsub>\<V>\<^esub> \<inter> \<Delta>\<^bsub>\<Gamma>\<^esub>) \<and> \<beta> @ \<delta>' @ [v] @ \<alpha>' \<in> Tr\<^bsub>(induceES SES)\<^esub>
        \<and> \<alpha>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<alpha> \<upharpoonleft> V\<^bsub>\<V>\<^esub> \<and> \<alpha>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []"
        by auto
  }
  thus ?thesis
    by (simp add: FCD_def)
qed

theorem unwinding_theorem_FCI:
"\<lbrakk> fcrb \<Gamma> ur; osc ur \<rbrakk> \<Longrightarrow> FCI \<Gamma> \<V> Tr\<^bsub>(induceES SES)\<^esub>"
proof -
  assume fcrb: "fcrb \<Gamma> ur"
  assume osc: "osc ur"

  { (* show that the conclusion of the BSP follows from the assumptions *)
    fix \<alpha> \<beta> c v

    assume c_in_C_inter_Y: "c \<in> (C\<^bsub>\<V>\<^esub> \<inter> \<Upsilon>\<^bsub>\<Gamma>\<^esub>)"
    assume v_in_V_inter_Nabla: "v \<in> (V\<^bsub>\<V>\<^esub> \<inter> \<nabla>\<^bsub>\<Gamma>\<^esub>)"
    assume \<beta>v\<alpha>_in_Tr: "((\<beta> @ [v]) @ \<alpha>) \<in> Tr\<^bsub>(induceES SES)\<^esub>"
    assume \<alpha>_contains_no_c: "\<alpha> \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []"

    from state_from_induceES_trace[OF \<beta>v\<alpha>_in_Tr] obtain s1''
      where s1''_in_S: "s1'' \<in> S\<^bsub>SES\<^esub>"
      and s0_\<beta>v_s1'': "s0\<^bsub>SES\<^esub> (\<beta> @ [v]) \<Longrightarrow>\<^bsub>SES\<^esub> s1''"
      and enabled_s1''_\<alpha>: "enabled SES s1'' \<alpha>"
      and reachable_s1'': "reachable SES s1''"
      by auto

    from path_split_single2[OF s0_\<beta>v_s1''] obtain s1
      where s1_in_S: "s1 \<in> S\<^bsub>SES\<^esub>"
      and s0_\<beta>_s1: "s0\<^bsub>SES\<^esub> \<beta>\<Longrightarrow>\<^bsub>SES\<^esub> s1"
      and s1_v_s1'': "s1 v\<longrightarrow>\<^bsub>SES\<^esub> s1''"
      and reachable_s1: "reachable SES s1"
      by (auto)

    from c_in_C_inter_Y v_in_V_inter_Nabla s1_in_S
      s1''_in_S reachable_s1 s1_v_s1'' fcrb
    have "\<exists>s1' \<in> S\<^bsub>SES\<^esub>. \<exists>\<delta>. (\<forall>d \<in> (set \<delta>). d \<in> (N\<^bsub>\<V>\<^esub> \<inter> \<Delta>\<^bsub>\<Gamma>\<^esub>))
      \<and> s1 ([c] @ \<delta> @ [v])\<Longrightarrow>\<^bsub>SES\<^esub> s1'
      \<and> (s1'', s1') \<in> ur"
      by (simp add: fcrb_def)
    then obtain s1' \<delta>
      where s1'_in_S: "s1' \<in> S\<^bsub>SES\<^esub>"
      and \<delta>_in_N_inter_Delta_star: "(\<forall>d \<in> (set \<delta>). d \<in> (N\<^bsub>\<V>\<^esub> \<inter> \<Delta>\<^bsub>\<Gamma>\<^esub>))"
      and s1_c\<delta>v_s1': "s1 ([c] @ \<delta> @ [v])\<Longrightarrow>\<^bsub>SES\<^esub> s1'"
      and s1''_ur_s1': "(s1'', s1') \<in> ur"
      by auto

    have reachable_s1': "reachable SES s1'"
    proof -
      from s0_\<beta>_s1 s1_c\<delta>v_s1' have "s0\<^bsub>SES\<^esub> (\<beta> @ ([c] @ \<delta> @ [v]))\<Longrightarrow>\<^bsub>SES\<^esub> s1'"
        by (rule path_trans)
      thus ?thesis
        by (simp add: reachable_def, auto)
    qed

    from osc_property[OF osc s1'_in_S s1''_in_S \<alpha>_contains_no_c
      reachable_s1' reachable_s1'' enabled_s1''_\<alpha> s1''_ur_s1']
    obtain \<alpha>'
      where  \<alpha>'_contains_no_c: "\<alpha>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []"
      and \<alpha>'_V_is_\<alpha>_V: "\<alpha>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<alpha> \<upharpoonleft> V\<^bsub>\<V>\<^esub>"
      and enabled_s1'_\<alpha>': "enabled SES s1' \<alpha>'"
      by auto

    have \<beta>c\<delta>v\<alpha>'_in_Tr: "\<beta> @ [c] @ \<delta> @ [v] @ \<alpha>' \<in> Tr\<^bsub>(induceES SES)\<^esub>"
    proof -
      let ?l1 = "\<beta> @ [c] @ \<delta> @ [v]"
      let ?l2 = "\<alpha>'"
      from s0_\<beta>_s1 s1_c\<delta>v_s1' have "s0\<^bsub>SES\<^esub> (?l1)\<Longrightarrow>\<^bsub>SES\<^esub> s1'"
        by (rule path_trans)
      moreover
      from enabled_s1'_\<alpha>' obtain s1337 where "s1' ?l2 \<Longrightarrow>\<^bsub>SES\<^esub> s1337"
        by (simp add: enabled_def, auto)
      ultimately have "s0\<^bsub>SES\<^esub> (?l1 @ ?l2)\<Longrightarrow>\<^bsub>SES\<^esub> s1337"
        by (rule path_trans)
      thus ?thesis
        by (simp add: induceES_def possible_traces_def enabled_def)
    qed

from \<delta>_in_N_inter_Delta_star \<beta>c\<delta>v\<alpha>'_in_Tr \<alpha>'_V_is_\<alpha>_V \<alpha>'_contains_no_c
    have "\<exists>\<alpha>' \<delta>'.
      set \<delta>' \<subseteq> (N\<^bsub>\<V>\<^esub> \<inter> \<Delta>\<^bsub>\<Gamma>\<^esub>) \<and> \<beta> @ [c] @ \<delta>' @ [v] @ \<alpha>' \<in> Tr\<^bsub>(induceES SES)\<^esub>
      \<and> \<alpha>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<alpha> \<upharpoonleft> V\<^bsub>\<V>\<^esub> \<and> \<alpha>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []"
      by auto
  }
  thus ?thesis
    by(simp add: FCI_def)
qed

theorem unwinding_theorem_FCIA:
"\<lbrakk> fcrbe \<Gamma> \<rho> ur; osc ur \<rbrakk> \<Longrightarrow> FCIA \<rho> \<Gamma> \<V> Tr\<^bsub>(induceES SES)\<^esub>"
proof -
  assume fcrbe: "fcrbe \<Gamma> \<rho> ur"
  assume osc: "osc ur"

  { (* show that the conclusion of the BSP follows from the assumptions *)
    fix \<alpha> \<beta> c v

    assume c_in_C_inter_Y: "c \<in> (C\<^bsub>\<V>\<^esub> \<inter> \<Upsilon>\<^bsub>\<Gamma>\<^esub>)"
    assume v_in_V_inter_Nabla: "v \<in> (V\<^bsub>\<V>\<^esub> \<inter> \<nabla>\<^bsub>\<Gamma>\<^esub>)"
    assume \<beta>v\<alpha>_in_Tr: "((\<beta> @ [v]) @ \<alpha>) \<in> Tr\<^bsub>(induceES SES)\<^esub>"
    assume \<alpha>_contains_no_c: "\<alpha> \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []"
    assume adm: "Adm \<V> \<rho> Tr\<^bsub>(induceES SES)\<^esub> \<beta> c"

    from state_from_induceES_trace[OF \<beta>v\<alpha>_in_Tr] obtain s1''
      where s1''_in_S: "s1'' \<in> S\<^bsub>SES\<^esub>"
      and s0_\<beta>v_s1'': "s0\<^bsub>SES\<^esub> (\<beta> @ [v])\<Longrightarrow>\<^bsub>SES\<^esub> s1''"
      and enabled_s1''_\<alpha>: "enabled SES s1'' \<alpha>"
      and reachable_s1'': "reachable SES s1''"
      by auto

    from path_split_single2[OF s0_\<beta>v_s1''] obtain s1
      where s1_in_S: "s1 \<in> S\<^bsub>SES\<^esub>"
      and s0_\<beta>_s1: "s0\<^bsub>SES\<^esub> \<beta>\<Longrightarrow>\<^bsub>SES\<^esub> s1"
      and s1_v_s1'': "s1 v\<longrightarrow>\<^bsub>SES\<^esub> s1''"
      and reachable_s1: "reachable SES s1"
      by (auto)

    have "\<exists>\<alpha>' \<delta>'.(set \<delta>' \<subseteq> (N\<^bsub>\<V>\<^esub> \<inter> \<Delta>\<^bsub>\<Gamma>\<^esub>) \<and> \<beta> @ [c] @ \<delta>' @ [v] @ \<alpha>' \<in> Tr\<^bsub>(induceES SES)\<^esub>
      \<and> \<alpha>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<alpha> \<upharpoonleft> V\<^bsub>\<V>\<^esub> \<and> \<alpha>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = [])"
    proof (cases)
      assume en: "En \<rho> s1 c"

      from c_in_C_inter_Y v_in_V_inter_Nabla s1_in_S s1''_in_S reachable_s1 s1_v_s1'' en fcrbe
      have "\<exists>s1' \<in> S\<^bsub>SES\<^esub>. \<exists>\<delta>. (\<forall>d \<in> (set \<delta>). d \<in> (N\<^bsub>\<V>\<^esub> \<inter> \<Delta>\<^bsub>\<Gamma>\<^esub>))
        \<and> s1 ([c] @ \<delta> @ [v]) \<Longrightarrow>\<^bsub>SES\<^esub> s1'
        \<and> (s1'', s1') \<in> ur"
        by (simp add: fcrbe_def)
      then  obtain s1' \<delta>
        where s1'_in_S: "s1' \<in> S\<^bsub>SES\<^esub>"
        and \<delta>_in_N_inter_Delta_star: "(\<forall>d \<in> (set \<delta>). d \<in> (N\<^bsub>\<V>\<^esub> \<inter> \<Delta>\<^bsub>\<Gamma>\<^esub>))"
        and s1_c\<delta>v_s1': "s1 ([c] @ \<delta> @ [v]) \<Longrightarrow>\<^bsub>SES\<^esub> s1'"
        and s1''_ur_s1': "(s1'', s1') \<in> ur"
        by (auto)

      have reachable_s1': "reachable SES s1'"
      proof -
        from s0_\<beta>_s1 s1_c\<delta>v_s1' have "s0\<^bsub>SES\<^esub> (\<beta> @ ([c] @ \<delta> @ [v]))\<Longrightarrow>\<^bsub>SES\<^esub> s1'"
          by (rule path_trans)
        thus ?thesis
          by (simp add: reachable_def, auto)
      qed

      from osc_property[OF osc s1'_in_S s1''_in_S \<alpha>_contains_no_c reachable_s1'
        reachable_s1'' enabled_s1''_\<alpha> s1''_ur_s1']
      obtain \<alpha>'
        where  \<alpha>'_contains_no_c: "\<alpha>' \<upharpoonleft> C\<^bsub>\<V>\<^esub> = []"
        and \<alpha>'_V_is_\<alpha>_V: "\<alpha>' \<upharpoonleft> V\<^bsub>\<V>\<^esub> = \<alpha> \<upharpoonleft> V\<^bsub>\<V>\<^esub>"
        and enabled_s1'_\<alpha>': "enabled SES s1' \<alpha>'"
        by auto

      have \<beta>c\<delta>v\<alpha>'_in_Tr: "\<beta> @ [c] @ \<delta> @ [v] @ \<alpha>' \<in> Tr\<^bsub>(induceES SES)\<^esub>"
      proof -
        let ?l1 = "\<beta> @ [c] @ \<delta> @ [v]"
        let ?l2 = "\<alpha>'"
        from s0_\<beta>_s1 s1_c\<delta>v_s1' have "s0\<^bsub>SES\<^esub> (?l1)\<Longrightarrow>\<^bsub>SES\<^esub> s1'"
          by (rule path_trans)
        moreover
        from enabled_s1'_\<alpha>' obtain s1337 where "s1' ?l2\<Longrightarrow>\<^bsub>SES\<^esub> s1337"
          by (simp add: enabled_def, auto)
        ultimately have "s0\<^bsub>SES\<^esub> (?l1 @ ?l2)\<Longrightarrow>\<^bsub>SES\<^esub> s1337"
          by (rule path_trans)
        thus ?thesis
          by (simp add: induceES_def possible_traces_def enabled_def)
      qed

      from \<delta>_in_N_inter_Delta_star \<beta>c\<delta>v\<alpha>'_in_Tr \<alpha>'_V_is_\<alpha>_V \<alpha>'_contains_no_c
      show ?thesis
        by auto
    next
      assume not_en: "\<not> En \<rho> s1 c"

      let ?A = "(Adm \<V> \<rho> Tr\<^bsub>(induceES SES)\<^esub> \<beta> c)"
      let ?E = "\<exists>s \<in> S\<^bsub>SES\<^esub>. (s0\<^bsub>SES\<^esub> \<beta>\<Longrightarrow>\<^bsub>SES\<^esub> s \<and> En \<rho> s c)"

      { (* show the contraposition of Adm_to_En *)
        assume adm: "?A"

        from s0_\<beta>_s1 have \<beta>_in_Tr: "\<beta> \<in> Tr\<^bsub>(induceES SES)\<^esub>"
          by (simp add: induceES_def possible_traces_def enabled_def)

        from  \<beta>_in_Tr adm have "?E"
          by (rule Adm_to_En)
      }
      hence Adm_to_En_contr: "\<not> ?E \<Longrightarrow> \<not> ?A"
        by blast
      with s1_in_S s0_\<beta>_s1 not_en have not_adm: "\<not> ?A"
        by auto
      with adm show ?thesis
        by auto
    qed
  }
  thus ?thesis
    by (simp add: FCIA_def)
qed

theorem unwinding_theorem_SD:
"\<lbrakk> \<V>' = \<lparr> V = (V\<^bsub>\<V>\<^esub> \<union> N\<^bsub>\<V>\<^esub>), N = {}, C = C\<^bsub>\<V>\<^esub> \<rparr>;
  Unwinding.lrf SES \<V>' ur; Unwinding.osc SES \<V>' ur \<rbrakk>
  \<Longrightarrow> SD \<V> Tr\<^bsub>(induceES SES)\<^esub>"
proof -
  assume view'_def : "\<V>' = \<lparr>V = (V\<^bsub>\<V>\<^esub> \<union> N\<^bsub>\<V>\<^esub>), N = {}, C = C\<^bsub>\<V>\<^esub>\<rparr>"
  assume lrf_view' : "Unwinding.lrf SES \<V>' ur"
  assume osc_view' : "Unwinding.osc SES \<V>' ur"

  interpret modified_view: Unwinding "SES" "\<V>'"
    by (unfold_locales, rule validSES, simp add: view'_def modified_view_valid)

  from lrf_view' osc_view' have BSD_view' : "BSD \<V>' Tr\<^bsub>(induceES SES)\<^esub>"
     by (rule_tac ur="ur" in modified_view.unwinding_theorem_BSD)
  with view'_def BSD_implies_SD_for_modified_view show ?thesis
    by auto
qed

theorem unwinding_theorem_SI:
"\<lbrakk> \<V>' = \<lparr> V = (V\<^bsub>\<V>\<^esub> \<union> N\<^bsub>\<V>\<^esub>), N = {}, C = C\<^bsub>\<V>\<^esub> \<rparr>;
  Unwinding.lrb SES \<V>' ur; Unwinding.osc SES \<V>' ur \<rbrakk>
  \<Longrightarrow> SI \<V> Tr\<^bsub>(induceES SES)\<^esub>"
proof -
  assume view'_def : "\<V>' = \<lparr>V = V\<^bsub>\<V>\<^esub> \<union> N\<^bsub>\<V>\<^esub>, N = {}, C = C\<^bsub>\<V>\<^esub>\<rparr>"
  assume lrb_view' : "Unwinding.lrb SES \<V>' ur"
  assume osc_view' : "Unwinding.osc SES \<V>' ur"

  interpret modified_view: Unwinding "SES" "\<V>'"
    by (unfold_locales, rule validSES, simp add: view'_def modified_view_valid)

  from lrb_view' osc_view' have BSI_view' : "BSI \<V>' Tr\<^bsub>(induceES SES)\<^esub>"
     by (rule_tac ur="ur" in modified_view.unwinding_theorem_BSI)
  with view'_def BSI_implies_SI_for_modified_view show ?thesis
    by auto
qed

  interpret modified_view: Unwinding "SES" "\<V>'"
    by (unfold_locales, rule validSES, simp add: view'_def modified_view_valid)

  from lrbe_view' osc_view' have BSIA_view' : "BSIA \<rho> \<V>' Tr\<^bsub>(induceES SES)\<^esub>"
     by (rule_tac ur="ur" in modified_view.unwinding_theorem_BSIA)
  with view'_def BSIA_implies_SIA_for_modified_view \<rho>_eq show ?thesis
    by auto
qed

theorem unwinding_theorem_SR:
"\<lbrakk> \<V>' = \<lparr> V = (V\<^bsub>\<V>\<^esub> \<union> N\<^bsub>\<V>\<^esub>), N = {}, C = C\<^bsub>\<V>\<^esub> \<rparr>;
  Unwinding.lrf SES \<V>' ur; Unwinding.osc SES \<V>' ur \<rbrakk>
  \<Longrightarrow> SR \<V> Tr\<^bsub>(induceES SES)\<^esub>"
proof -
  assume view'_def : "\<V>' = \<lparr>V = V\<^bsub>\<V>\<^esub> \<union> N\<^bsub>\<V>\<^esub>, N = {}, C = C\<^bsub>\<V>\<^esub>\<rparr>"
  assume lrf_view' : "Unwinding.lrf SES \<V>' ur"
  assume osc_view' : "Unwinding.osc SES \<V>' ur"

  from lrf_view' osc_view' view'_def have S_view : "SD \<V> Tr\<^bsub>(induceES SES)\<^esub>"
     by (rule_tac ur="ur" in  unwinding_theorem_SD, auto)
  with SD_implies_SR show ?thesis
    by auto
qed

theorem unwinding_theorem_D:
"\<lbrakk> lrf ur; osc ur \<rbrakk> \<Longrightarrow> D \<V> Tr\<^bsub>(induceES SES)\<^esub>"
proof -
  assume "lrf ur"
  and "osc ur"
  hence "BSD \<V> Tr\<^bsub>(induceES SES)\<^esub>"
    by (rule unwinding_theorem_BSD)
  thus ?thesis
    by (rule BSD_implies_D)
qed

theorem unwinding_theorem_I:
"\<lbrakk> lrb ur; osc ur \<rbrakk> \<Longrightarrow> I \<V> Tr\<^bsub>(induceES SES)\<^esub>"
proof -
  assume "lrb ur"
  and "osc ur"
  hence "BSI \<V> Tr\<^bsub>(induceES SES)\<^esub>"
    by (rule unwinding_theorem_BSI)
  thus ?thesis
    by (rule BSI_implies_I)
qed

theorem unwinding_theorem_IA:
"\<lbrakk> lrbe \<rho> ur; osc ur \<rbrakk> \<Longrightarrow> IA \<rho> \<V> Tr\<^bsub>(induceES SES)\<^esub>"
proof -
  assume "lrbe \<rho> ur"
  and "osc ur"
  hence "BSIA \<rho> \<V> Tr\<^bsub>(induceES SES)\<^esub>"
    by (rule unwinding_theorem_BSIA)
  thus ?thesis
    by (rule BSIA_implies_IA)
qed

theorem unwinding_theorem_R:
"\<lbrakk> lrf ur; osc ur \<rbrakk> \<Longrightarrow> R \<V> (Tr\<^bsub>(induceES SES)\<^esub>)"
proof -
  assume "lrf ur"
  and "osc ur"
  hence "BSD \<V> Tr\<^bsub>(induceES SES)\<^esub>"
    by (rule unwinding_theorem_BSD)
  hence "D \<V> Tr\<^bsub>(induceES SES)\<^esub>"
    by (rule BSD_implies_D)
  thus ?thesis
    by (rule D_implies_R)
qed

end

end


chapter {* Generated by Lem from list.lem. *}

theory "Lem_list"

imports
 	 Main
	 "Lem_bool"
	 "Lem_maybe"
	 "Lem_basic_classes"
	 "Lem_function"
	 "Lem_tuple"
	 "Lem_num"
	 "Lem"

begin

(*open import Bool Maybe Basic_classes Function Tuple Num*)

(*open import {coq} `Coq.Lists.List`*)
(*open import {isabelle} `$LIB_DIR/Lem`*)
(*open import {hol} `lemTheory` `listTheory` `rich_listTheory` `sortingTheory`*)

(* ========================================================================== *)
(* Basic list functions                                                       *)
(* ========================================================================== *)

(* The type of lists as well as list literals like [], [1;2], ... are hardcoded.
   Thus, we can directly dive into derived definitions. *)

(* ----------------------- *)
(* cons                    *)
(* ----------------------- *)

(*val :: : forall 'a. 'a -> list 'a -> list 'a*)

(* ----------------------- *)
(* Emptyness check         *)
(* ----------------------- *)

(*val null : forall 'a. list 'a -> bool*)
(*let null l=  match l with [] -> true | _ -> false end*)

(* ----------------------- *)
(* Length                  *)
(* ----------------------- *)

(*val length : forall 'a. list 'a -> nat*)
(*let rec length l=
  match l with
    | [] -> 0
    | x :: xs -> (Instance_Num_NumAdd_nat.+) (length xs) 1
  end*)

(* ----------------------- *)
(* Equality                *)
(* ----------------------- *)

(*val listEqual : forall 'a. Eq 'a => list 'a -> list 'a -> bool*)
(*val listEqualBy : forall 'a. ('a -> 'a -> bool) -> list 'a -> list 'a -> bool*)

fun  listEqualBy  :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool "  where
     " listEqualBy eq ([]) ([]) = ( True )"
|" listEqualBy eq ([]) (_ # _) = ( False )"
|" listEqualBy eq (_ # _) ([]) = ( False )"
|" listEqualBy eq (x # xs) (y # ys) = ( (eq x y \<and> listEqualBy eq xs ys))"
declare listEqualBy.simps [simp del]

(* ----------------------- *)
(* compare                 *)
(* ----------------------- *)

(*val lexicographicCompare : forall 'a. Ord 'a => list 'a -> list 'a -> ordering*)
(*val lexicographicCompareBy : forall 'a. ('a -> 'a -> ordering) -> list 'a -> list 'a -> ordering*)

fun  lexicographicCompareBy  :: "('a \<Rightarrow> 'a \<Rightarrow> ordering)\<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> ordering "  where
     " lexicographicCompareBy cmp ([]) ([]) = ( EQ )"
|" lexicographicCompareBy cmp ([]) (_ # _) = ( LT )"
|" lexicographicCompareBy cmp (_ # _) ([]) = ( GT )"
|" lexicographicCompareBy cmp (x # xs) (y # ys) = ( (
      (case  cmp x y of
          LT => LT
        | GT => GT
        | EQ => lexicographicCompareBy cmp xs ys
      )
    ))"
declare lexicographicCompareBy.simps [simp del]

(*val lexicographicLess : forall 'a. Ord 'a => list 'a -> list 'a -> bool*)
(*val lexicographicLessBy : forall 'a. ('a -> 'a -> bool) -> ('a -> 'a -> bool) -> list 'a -> list 'a -> bool*)
fun  lexicographicLessBy  :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow>('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool "  where
     " lexicographicLessBy less1 less_eq1 ([]) ([]) = ( False )"
|" lexicographicLessBy less1 less_eq1 ([]) (_ # _) = ( True )"
|" lexicographicLessBy less1 less_eq1 (_ # _) ([]) = ( False )"
|" lexicographicLessBy less1 less_eq1 (x # xs) (y # ys) = ( ((less1 x y) \<or> ((less_eq1 x y) \<and> (lexicographicLessBy less1 less_eq1 xs ys))))"
declare lexicographicLessBy.simps [simp del]

(*val lexicographicLessEq : forall 'a. Ord 'a => list 'a -> list 'a -> bool*)
(*val lexicographicLessEqBy : forall 'a. ('a -> 'a -> bool) -> ('a -> 'a -> bool) -> list 'a -> list 'a -> bool*)
fun  lexicographicLessEqBy  :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow>('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool "  where
     " lexicographicLessEqBy less1 less_eq1 ([]) ([]) = ( True )"
|" lexicographicLessEqBy less1 less_eq1 ([]) (_ # _) = ( True )"
|" lexicographicLessEqBy less1 less_eq1 (_ # _) ([]) = ( False )"
|" lexicographicLessEqBy less1 less_eq1 (x # xs) (y # ys) = ( (less1 x y \<or> (less_eq1 x y \<and> lexicographicLessEqBy less1 less_eq1 xs ys)))"
declare lexicographicLessEqBy.simps [simp del]

definition instance_Basic_classes_Ord_list_dict  :: " 'a Ord_class \<Rightarrow>('a list)Ord_class "  where
     " instance_Basic_classes_Ord_list_dict dict_Basic_classes_Ord_a = ((|

  compare_method = (lexicographicCompareBy
  (compare_method   dict_Basic_classes_Ord_a)),

  isLess_method = (lexicographicLessBy
  (isLess_method   dict_Basic_classes_Ord_a) (isLessEqual_method   dict_Basic_classes_Ord_a)),

  isLessEqual_method = (lexicographicLessEqBy
  (isLess_method   dict_Basic_classes_Ord_a) (isLessEqual_method   dict_Basic_classes_Ord_a)),

  isGreater_method = (\<lambda> x y. (lexicographicLessBy
  (isLess_method   dict_Basic_classes_Ord_a) (isLessEqual_method   dict_Basic_classes_Ord_a) y x)),

  isGreaterEqual_method = (\<lambda> x y. (lexicographicLessEqBy
  (isLess_method   dict_Basic_classes_Ord_a) (isLessEqual_method   dict_Basic_classes_Ord_a) y x))|) )"

(* ----------------------- *)
(* Append                  *)
(* ----------------------- *)

(*val ++ : forall 'a. list 'a -> list 'a -> list 'a*) (* originally append *)
(*let rec ++ xs ys=  match xs with
                     | [] -> ys
                     | x :: xs' -> x :: (xs' ++ ys)
                   end*)

(* ----------------------- *)
(* snoc                    *)
(* ----------------------- *)

(*val snoc : forall 'a. 'a -> list 'a -> list 'a*)
(*let snoc e l=  l ++ [e]*)

(* ----------------------- *)
(* Reverse                 *)
(* ----------------------- *)

(* First lets define the function [reverse_append], which is
   closely related to reverse. [reverse_append l1 l2] appends the list [l2] to the reverse of [l1].
   This can be implemented more efficienctly than appending and is
   used to implement reverse. *)

(*val reverseAppend : forall 'a. list 'a -> list 'a -> list 'a*) (* originally named rev_append *)
(*let rec reverseAppend l1 l2=  match l1 with
                                | [] -> l2
                                | x :: xs -> reverseAppend xs (x :: l2)
                               end*)

(* Reversing a list *)
(*val reverse : forall 'a. list 'a -> list 'a*) (* originally named rev *)
(*let reverse l=  reverseAppend l []*)

(* ----------------------- *)
(* Map                     *)
(* ----------------------- *)

(*val map_tr : forall 'a 'b. list 'b -> ('a -> 'b) -> list 'a -> list 'b*)
function (sequential,domintros)  map_tr  :: " 'b list \<Rightarrow>('a \<Rightarrow> 'b)\<Rightarrow> 'a list \<Rightarrow> 'b list "  where
     " map_tr rev_acc f ([]) = ( List.rev rev_acc )"
|" map_tr rev_acc f (x # xs) = ( map_tr ((f x) # rev_acc) f xs )"
by pat_completeness auto

(* taken from: https://blogs.janestreet.com/optimizing-list-map/ *)
(*val count_map : forall 'a 'b. ('a -> 'b) -> list 'a -> nat -> list 'b*)
function (sequential,domintros)  count_map  :: "('a \<Rightarrow> 'b)\<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> 'b list "  where
     " count_map f ([]) ctr = ( [])"
|" count_map f (hd1 # tl1) ctr = ( f hd1 #
    (if ctr <( 5000 :: nat) then count_map f tl1 (ctr +( 1 :: nat))
    else map_tr [] f tl1))"
by pat_completeness auto

(*val map : forall 'a 'b. ('a -> 'b) -> list 'a -> list 'b*)
(*let map f l=  count_map f l 0*)

(* ----------------------- *)
(* Reverse Map             *)
(* ----------------------- *)

(*val reverseMap : forall 'a 'b. ('a -> 'b) -> list 'a -> list 'b*)

(* ========================================================================== *)
(* Folding                                                                    *)
(* ========================================================================== *)

(* ----------------------- *)
(* fold left               *)
(* ----------------------- *)

(*val foldl : forall 'a 'b. ('a -> 'b -> 'a) -> 'a -> list 'b -> 'a*) (* originally foldl *)

(*let rec foldl f b l=  match l with
  | []      -> b
  | x :: xs -> foldl f (f b x) xs
end*)

(* ----------------------- *)
(* fold right              *)
(* ----------------------- *)

(*val foldr : forall 'a 'b. ('a -> 'b -> 'b) -> 'b -> list 'a -> 'b*) (* originally foldr with different argument order *)
(*let rec foldr f b l=  match l with
  | []      -> b
  | x :: xs -> f x (foldr f b xs)
end*)

(* ----------------------- *)
(* concatenating lists     *)
(* ----------------------- *)

(*val concat : forall 'a. list (list 'a) -> list 'a*) (* before also called flatten *)
(*let concat=  foldr (++) []*)

(* -------------------------- *)
(* concatenating with mapping *)
(* -------------------------- *)

(*val concatMap : forall 'a 'b. ('a -> list 'b) -> list 'a -> list 'b*)

(* ------------------------- *)
(* universal qualification   *)
(* ------------------------- *)

(*val all : forall 'a. ('a -> bool) -> list 'a -> bool*) (* originally for_all *)
(*let all P l=  foldl (fun r e -> P e && r) true l*)

(* ------------------------- *)
(* existential qualification *)
(* ------------------------- *)

(*val any : forall 'a. ('a -> bool) -> list 'a -> bool*) (* originally exist *)
(*let any P l=  foldl (fun r e -> P e || r) false l*)

(* ------------------------- *)
(* dest_init                 *)
(* ------------------------- *)

(* get the initial part and the last element of the list in a safe way *)

(*val dest_init : forall 'a. list 'a -> maybe (list 'a * 'a)*)

fun  dest_init_aux  :: " 'a list \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list*'a "  where
     " dest_init_aux rev_init last_elem_seen ([]) = ( (List.rev rev_init, last_elem_seen))"
|" dest_init_aux rev_init last_elem_seen (x # xs) = ( dest_init_aux (last_elem_seen # rev_init) x xs )"
declare dest_init_aux.simps [simp del]

fun dest_init  :: " 'a list \<Rightarrow>('a list*'a)option "  where
     " dest_init ([]) = ( None )"
|" dest_init (x # xs) = ( Some (dest_init_aux [] x xs))"
declare dest_init.simps [simp del]

(* ========================================================================== *)
(* Indexing lists                                                             *)
(* ========================================================================== *)

(* ------------------------- *)
(* index / nth with maybe   *)
(* ------------------------- *)

(*val index : forall 'a. list 'a -> nat -> maybe 'a*)

(*let rec index l n=  match l with
  | []      -> Nothing
  | x :: xs -> if (Instance_Basic_classes_Eq_nat.=) n 0 then Just x else index xs ((Instance_Num_NumMinus_nat.-)n 1)
end*)

(* ------------------------- *)
(* findIndices               *)
(* ------------------------- *)

(* [findIndices P l] returns the indices of all elements of list [l] that satisfy predicate [P].
   Counting starts with 0, the result list is sorted ascendingly *)
(*val findIndices : forall 'a. ('a -> bool) -> list 'a -> list nat*)

fun  findIndices_aux  :: " nat \<Rightarrow>('a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow>(nat)list "  where
     " findIndices_aux (i::nat) P ([]) = ( [])"
|" findIndices_aux (i::nat) P (x # xs) = ( if P x then i # findIndices_aux (i +( 1 :: nat)) P xs else findIndices_aux (i +( 1 :: nat)) P xs )"
declare findIndices_aux.simps [simp del]

(*let findIndices P l=  findIndices_aux 0 P l*)

(* ------------------------- *)
(* findIndex                 *)
(* ------------------------- *)

(* findIndex returns the first index of a list that satisfies a given predicate. *)
(*val findIndex : forall 'a. ('a -> bool) -> list 'a -> maybe nat*)
(*let findIndex P l=  match findIndices P l with
  | [] -> Nothing
  | x :: _ -> Just x
end*)

(* ------------------------- *)
(* elemIndices               *)
(* ------------------------- *)

(*val elemIndices : forall 'a. Eq 'a => 'a -> list 'a -> list nat*)

(* ------------------------- *)
(* elemIndex                 *)
(* ------------------------- *)

(*val elemIndex : forall 'a. Eq 'a => 'a -> list 'a -> maybe nat*)

(* ========================================================================== *)
(* Creating lists                                                             *)
(* ========================================================================== *)

(* ------------------------- *)
(* genlist                   *)
(* ------------------------- *)

(* [genlist f n] generates the list [f 0; f 1; ... (f (n-1))] *)
(*val genlist : forall 'a. (nat -> 'a) -> nat -> list 'a*)

(*let rec genlist f n=
  match n with
    | 0 -> []
    | n' + 1 -> snoc (f n') (genlist f n')
  end*)

(* ------------------------- *)
(* replicate                 *)
(* ------------------------- *)

(*val replicate : forall 'a. nat -> 'a -> list 'a*)
(*let rec replicate n x=
  match n with
    | 0 -> []
    | n' + 1 -> x :: replicate n' x
  end*)

(* ========================================================================== *)
(* Sublists                                                                   *)
(* ========================================================================== *)

(* ------------------------- *)
(* splitAt                   *)
(* ------------------------- *)

(* [splitAt n xs] returns a tuple (xs1, xs2), with append xs1 xs2 = xs and
   length xs1 = n. If there are not enough elements
   in [xs], the original list and the empty one are returned. *)
(*val splitAtAcc : forall 'a. list 'a -> nat -> list 'a -> (list 'a * list 'a)*)
function (sequential,domintros)  splitAtAcc  :: " 'a list \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list*'a list "  where
     " splitAtAcc revAcc n l = (
  (case  l of
      []    => (List.rev revAcc, [])
    | x # xs => if n \<le>( 0 :: nat) then (List.rev revAcc, l) else splitAtAcc (x # revAcc) (n-( 1 :: nat)) xs
  ))"
by pat_completeness auto

(*val splitAt : forall 'a. nat -> list 'a -> (list 'a * list 'a)*)
(*let rec splitAt n l=
   splitAtAcc [] n l*)

(* ------------------------- *)
(* take                      *)
(* ------------------------- *)

(* take n xs returns the prefix of xs of length n, or xs itself if n > length xs *)
(*val take : forall 'a. nat -> list 'a -> list 'a*)
(*let take n l=  fst (splitAt n l)*)

(* ------------------------- *)
(* drop                      *)
(* ------------------------- *)

(* [drop n xs] drops the first [n] elements of [xs]. It returns the empty list, if [n] > [length xs]. *)
(*val drop : forall 'a. nat -> list 'a -> list 'a*)
(*let drop n l=  snd (splitAt n l)*)

(* ------------------------- *)
(* dropWhile                 *)
(* ------------------------- *)

(* [dropWhile p xs] drops the first elements of [xs] that satisfy [p]. *)
(*val dropWhile : forall 'a. ('a -> bool) -> list 'a -> list 'a*)
fun  dropWhile  :: "('a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list "  where
     " dropWhile p l = ( (case  l of
    [] => []
  | x # xs => if p x then dropWhile p xs else l
))"
declare dropWhile.simps [simp del]

(* ------------------------- *)
(* takeWhile                 *)
(* ------------------------- *)

(* [takeWhile p xs] takes the first elements of [xs] that satisfy [p]. *)
(*val takeWhile : forall 'a. ('a -> bool) -> list 'a -> list 'a*)
fun  takeWhile  :: "('a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list "  where
     " takeWhile p ([]) = ( [])"
|" takeWhile p (x # xs) = ( if p x then x # takeWhile p xs else [])"
declare takeWhile.simps [simp del]

(* ------------------------- *)
(* splitWhile                *)
(* ------------------------- *)

(*val splitWhile : forall 'a. ('a -> bool) -> list 'a -> (list 'a * list 'a)*)
definition splitWhile  :: "('a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list*'a list "  where
     " splitWhile p xs = ( (takeWhile p xs, dropWhile p xs))"

(* ------------------------- *)
(* isPrefixOf                *)
(* ------------------------- *)

(*val isPrefixOf : forall 'a. Eq 'a => list 'a -> list 'a -> bool*)
fun  isPrefixOf  :: " 'a list \<Rightarrow> 'a list \<Rightarrow> bool "  where
     " isPrefixOf ([]) _ = ( True )"
|" isPrefixOf (_ # _) ([]) = ( False )"
|" isPrefixOf (x # xs) (y # ys) = ( (x = y) \<and> isPrefixOf xs ys )"
declare isPrefixOf.simps [simp del]

(* ------------------------- *)
(* update                    *)
(* ------------------------- *)
(*val update : forall 'a. list 'a -> nat -> 'a -> list 'a*)
(*let rec update l n e=
  match l with
    | []      -> []
    | x :: xs -> if (Instance_Basic_classes_Eq_nat.=) n 0 then e :: xs else x :: (update xs ((Instance_Num_NumMinus_nat.-) n 1) e)
end*)

(* ========================================================================== *)
(* Searching lists                                                            *)
(* ========================================================================== *)

(* ------------------------- *)
(* Membership test           *)
(* ------------------------- *)

(* The membership test, one of the basic list functions, is actually tricky for
   Lem, because it is tricky, which equality to use. From Lem`s point of
   perspective, we want to use the equality provided by the equality type - class.
   This allows for example to check whether a set is in a list of sets.

   However, in order to use the equality type class, elem essentially becomes
   existential quantification over lists. For types, which implement semantic
   equality (=) with syntactic equality, this is overly complicated. In
   our theorem prover backend, we would end up with overly complicated, harder
   to read definitions and some of the automation would be harder to apply.
   Moreover, nearly all the old Lem generated code would change and require
   (hopefully minor) adaptions of proofs.

   For now, we ignore this problem and just demand, that all instances of
   the equality type class do the right thing for the theorem prover backends.
*)

(*val elem : forall 'a. Eq 'a => 'a -> list 'a -> bool*)
(*val elemBy : forall 'a. ('a -> 'a -> bool) -> 'a -> list 'a -> bool*)

definition elemBy  :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> bool "  where
     " elemBy eq e l = ( ((\<exists> x \<in> (set l).  (eq e) x)))"

(*let elem=  elemBy (=)*)

(* ------------------------- *)
(* Find                      *)
(* ------------------------- *)
(*val find : forall 'a. ('a -> bool) -> list 'a -> maybe 'a*) (* previously not of maybe type *)
(*let rec find P l=  match l with
  | []      -> Nothing
  | x :: xs -> if P x then Just x else find P xs
end*)

(* ----------------------------- *)
(* Lookup in an associative list *)
(* ----------------------------- *)
(*val lookup   : forall 'a 'b. Eq 'a              => 'a -> list ('a * 'b) -> maybe 'b*)
(*val lookupBy : forall 'a 'b. ('a -> 'a -> bool) -> 'a -> list ('a * 'b) -> maybe 'b*)

(* DPM: eta-expansion for Coq backend type-inference. *)
definition lookupBy  :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a \<Rightarrow>('a*'b)list \<Rightarrow> 'b option "  where
     " lookupBy eq k m = ( map_option (\<lambda> x .  snd x) (List.find (\<lambda> (k', _) .  eq k k') m))"

(* ------------------------- *)
(* filter                    *)
(* ------------------------- *)
(*val filter : forall 'a. ('a -> bool) -> list 'a -> list 'a*)
(*let rec filter P l=  match l with
                       | [] -> []
                       | x :: xs -> if (P x) then x :: (filter P xs) else filter P xs
                     end*)

(* ------------------------- *)
(* partition                 *)
(* ------------------------- *)
(*val partition : forall 'a. ('a -> bool) -> list 'a -> list 'a * list 'a*)
(*let partition P l=  (filter P l, filter (fun x -> not (P x)) l)*)

(*val reversePartition : forall 'a. ('a -> bool) -> list 'a -> list 'a * list 'a*)
definition reversePartition  :: "('a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> 'a list*'a list "  where
     " reversePartition P l = ( List.partition P (List.rev l))"

(* ------------------------- *)
(* delete first element      *)
(* with certain property     *)
(* ------------------------- *)

(*val deleteFirst : forall 'a. ('a -> bool) -> list 'a -> maybe (list 'a)*)
(*let rec deleteFirst P l=  match l with
                            | [] -> Nothing
                            | x :: xs -> if (P x) then Just xs else Maybe.map (fun xs' -> x :: xs') (deleteFirst P xs)
                          end*)

(*val delete : forall 'a. Eq 'a => 'a -> list 'a -> list 'a*)
(*val deleteBy : forall 'a. ('a -> 'a -> bool) -> 'a -> list 'a -> list 'a*)

definition deleteBy  :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list "  where
     " deleteBy eq x l = ( case_option l id (delete_first (eq x) l))"

(* ========================================================================== *)
(* Zipping and unzipping lists                                                *)
(* ========================================================================== *)

(* ------------------------- *)
(* zip                       *)
(* ------------------------- *)

(* zip takes two lists and returns a list of corresponding pairs. If one input list is short, excess elements of the longer list are discarded. *)
(*val zip : forall 'a 'b. list 'a -> list 'b -> list ('a * 'b)*) (* before combine *)
(*let rec zip l1 l2=  match (l1, l2) with
  | (x :: xs, y :: ys) -> (x, y) :: zip xs ys
  | _ -> []
end*)

(* ------------------------- *)
(* unzip                     *)
(* ------------------------- *)

(*val unzip: forall 'a 'b. list ('a * 'b) -> (list 'a * list 'b)*)
(*let rec unzip l=  match l with
  | [] -> ([], [])
  | (x, y) :: xys -> let (xs, ys) = unzip xys in (x :: xs, y :: ys)
end*)

(* ------------------------- *)
(* distinct elements         *)
(* ------------------------- *)

(*val allDistinct : forall 'a. Eq 'a => list 'a -> bool*)
fun  allDistinct  :: " 'a list \<Rightarrow> bool "  where
     " allDistinct ([]) = ( True )"
|" allDistinct (x # l') = ( \<not> (Set.member x (set l')) \<and> allDistinct l' )"
declare allDistinct.simps [simp del]

(* some more useful functions *)
(*val mapMaybe : forall 'a 'b. ('a -> maybe 'b) -> list 'a -> list 'b*)
function (sequential,domintros)  mapMaybe  :: "('a \<Rightarrow> 'b option)\<Rightarrow> 'a list \<Rightarrow> 'b list "  where
     " mapMaybe f ([]) = ( [])"
|" mapMaybe f (x # xs) = (
      (case  f x of
        None => mapMaybe f xs
      | Some y => y # (mapMaybe f xs)
      ))"
by pat_completeness auto

(*val mapi : forall 'a 'b. (nat -> 'a -> 'b) -> list 'a -> list 'b*)
function (sequential,domintros)  mapiAux  :: "(nat \<Rightarrow> 'b \<Rightarrow> 'a)\<Rightarrow> nat \<Rightarrow> 'b list \<Rightarrow> 'a list "  where
     " mapiAux f (n :: nat) ([]) = ( [])"
|" mapiAux f (n :: nat) (x # xs) = ( (f n x) # mapiAux f (n +( 1 :: nat)) xs )"
by pat_completeness auto

definition mapi  :: "(nat \<Rightarrow> 'a \<Rightarrow> 'b)\<Rightarrow> 'a list \<Rightarrow> 'b list "  where
     " mapi f l = ( mapiAux f(( 0 :: nat)) l )"

(*val deletes: forall 'a. Eq 'a => list 'a -> list 'a -> list 'a*)
definition deletes  :: " 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list "  where
     " deletes xs ys = (
  List.foldl ((\<lambda> x y. remove1 y x)) xs ys )"

(* ========================================================================== *)
(* Comments (not clean yet, please ignore the rest of the file)               *)
(* ========================================================================== *)

(* ----------------------- *)
(* skipped from Haskell Lib*)
(* -----------------------

intersperse :: a -> [a] -> [a]
intercalate :: [a] -> [[a]] -> [a]
transpose :: [[a]] -> [[a]]
subsequences :: [a] -> [[a]]
permutations :: [a] -> [[a]]
foldl` :: (a -> b -> a) -> a -> [b] -> aSource
foldl1` :: (a -> a -> a) -> [a] -> aSource

and
or
sum
product
maximum
minimum
scanl
scanr
scanl1
scanr1
Accumulating maps

mapAccumL :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])Source
mapAccumR :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])Source

iterate :: (a -> a) -> a -> [a]
repeat :: a -> [a]
cycle :: [a] -> [a]
unfoldr

takeWhile :: (a -> Bool) -> [a] -> [a]Source
dropWhile :: (a -> Bool) -> [a] -> [a]Source
dropWhileEnd :: (a -> Bool) -> [a] -> [a]Source
span :: (a -> Bool) -> [a] -> ([a], [a])Source
break :: (a -> Bool) -> [a] -> ([a], [a])Source
break p is equivalent to span (not . p).
stripPrefix :: Eq a => [a] -> [a] -> Maybe [a]Source
group :: Eq a => [a] -> [[a]]Source
inits :: [a] -> [[a]]Source
tails :: [a] -> [[a]]Source

isPrefixOf :: Eq a => [a] -> [a] -> BoolSource
isSuffixOf :: Eq a => [a] -> [a] -> BoolSource
isInfixOf :: Eq a => [a] -> [a] -> BoolSource

notElem :: Eq a => a -> [a] -> BoolSource

zip3 :: [a] -> [b] -> [c] -> [(a, b, c)]Source
zip4 :: [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]Source
zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a, b, c, d, e)]Source
zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a, b, c, d, e, f)]Source
zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [(a, b, c, d, e, f, g)]Source

zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]Source
zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]Source
zipWith4 :: (a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]Source
zipWith5 :: (a -> b -> c -> d -> e -> f) -> [a] -> [b] -> [c] -> [d] -> [e] -> [f]Source
zipWith6 :: (a -> b -> c -> d -> e -> f -> g) -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g]Source
zipWith7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [h]Source

unzip3 :: [(a, b, c)] -> ([a], [b], [c])Source
unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d])Source
unzip5 :: [(a, b, c, d, e)] -> ([a], [b], [c], [d], [e])Source
unzip6 :: [(a, b, c, d, e, f)] -> ([a], [b], [c], [d], [e], [f])Source
unzip7 :: [(a, b, c, d, e, f, g)] -> ([a], [b], [c], [d], [e], [f], [g])Source

lines :: String -> [String]Source
words :: String -> [String]Source
unlines :: [String] -> StringSource
unwords :: [String] -> StringSource
nub :: Eq a => [a] -> [a]Source
delete :: Eq a => a -> [a] -> [a]Source

() :: Eq a => [a] -> [a] -> [a]Source
union :: Eq a => [a] -> [a] -> [a]Source
intersect :: Eq a => [a] -> [a] -> [a]Source
sort :: Ord a => [a] -> [a]Source
insert :: Ord a => a -> [a] -> [a]Source

nubBy :: (a -> a -> Bool) -> [a] -> [a]Source
deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a]Source
deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]Source
unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]Source
intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]Source
groupBy :: (a -> a -> Bool) -> [a] -> [[a]]Source
sortBy :: (a -> a -> Ordering) -> [a] -> [a]Source
insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a]Source
maximumBy :: (a -> a -> Ordering) -> [a] -> aSource
minimumBy :: (a -> a -> Ordering) -> [a] -> aSource
genericLength :: Num i => [b] -> iSource
genericTake :: Integral i => i -> [a] -> [a]Source
genericDrop :: Integral i => i -> [a] -> [a]Source
genericSplitAt :: Integral i => i -> [b] -> ([b], [b])Source
genericIndex :: Integral a => [b] -> a -> bSource
genericReplicate :: Integral i => i -> a -> [a]Source

*)

(* ----------------------- *)
(* skipped from Lem Lib    *)
(* -----------------------

val for_all2 : forall 'a 'b. ('a -> 'b -> bool) -> list 'a -> list 'b -> bool
val exists2 : forall 'a 'b. ('a -> 'b -> bool) -> list 'a -> list 'b -> bool
val map2 : forall 'a 'b 'c. ('a -> 'b -> 'c) -> list 'a -> list 'b -> list 'c
val rev_map2 : forall 'a 'b 'c. ('a -> 'b -> 'c) -> list 'a -> list 'b -> list 'c
val fold_left2 : forall 'a 'b 'c. ('a -> 'b -> 'c -> 'a) -> 'a -> list 'b -> list 'c -> 'a
val fold_right2 : forall 'a 'b 'c. ('a -> 'b -> 'c -> 'c) -> list 'a -> list 'b -> 'c -> 'c

(* now maybe result and called lookup *)
val assoc : forall 'a 'b. 'a -> list ('a * 'b) -> 'b
let inline {ocaml} assoc = Ocaml.List.assoc

val mem_assoc : forall 'a 'b. 'a -> list ('a * 'b) -> bool
val remove_assoc : forall 'a 'b. 'a -> list ('a * 'b) -> list ('a * 'b)

val stable_sort : forall 'a. ('a -> 'a -> num) -> list 'a -> list 'a
val fast_sort : forall 'a. ('a -> 'a -> num) -> list 'a -> list 'a

val merge : forall 'a. ('a -> 'a -> num) -> list 'a -> list 'a -> list 'a
val intersect : forall 'a. list 'a -> list 'a -> list 'a

*)

(*val     catMaybes : forall 'a. list (maybe 'a) -> list 'a*)
function (sequential,domintros)  catMaybes  :: "('a option)list \<Rightarrow> 'a list "  where
     " catMaybes ([]) = (
        [])"
|" catMaybes (None # xs') = (
        catMaybes xs' )"
|" catMaybes (Some x # xs') = (
        x # catMaybes xs' )"
by pat_completeness auto

end


section \<open>\<open>Cblinfun_Code\<close> -- Support for code generation\<close>

text \<open>This theory provides support for code generation involving on complex vector spaces and
  bounded operators (e.g., types \<open>cblinfun\<close> and \<open>ell2\<close>).
  To fully support code generation, in addition to importing this theory,
  one need to activate support for code generation (import theory \<open>Jordan_Normal_Form.Matrix_Impl\<close>)
  and for real and complex numbers (import theory \<open>Real_Impl.Real_Impl\<close> for support of reals of the
  form \<open>a + b * sqrt c\<close> or \<open>Algebraic_Numbers.Real_Factorization\<close> (much slower) for support of algebraic reals;
  support of complex numbers comes "for free").

  The builtin support for real and complex numbers (in \<open>Complex_Main\<close>) is not sufficient because it
  does not support the computation of square-roots which are used in the setup below.

  It is also recommended to import \<open>HOL-Library.Code_Target_Numeral\<close> for faster support of nats
  and integers.\<close>

theory Cblinfun_Code
  imports
    Cblinfun_Matrix Containers.Set_Impl Jordan_Normal_Form.Matrix_Kernel
begin

no_notation "Lattice.meet" (infixl "\<sqinter>\<index>" 70)
no_notation "Lattice.join" (infixl "\<squnion>\<index>" 65)
hide_const (open) Coset.kernel
hide_const (open) Matrix_Kernel.kernel
hide_const (open) Order.bottom Order.top

unbundle lattice_syntax
unbundle jnf_notation
unbundle cblinfun_notation

subsection \<open>Code equations for cblinfun operators\<close>

text \<open>In this subsection, we define the code for all operations involving only
  operators (no combinations of operators/vectors/subspaces)\<close>

text \<open>The following lemma registers cblinfun as an abstract datatype with
  constructor \<^const>\<open>cblinfun_of_mat\<close>.
  That means that in generated code, all cblinfun operators will be represented
  as \<^term>\<open>cblinfun_of_mat X\<close> where X is a matrix.
  In code equations for operations involving operators (e.g., +), we
  can then write the equation directly in terms of matrices
  by writing, e.g., \<^term>\<open>mat_of_cblinfun (A+B)\<close> in the lhs,
  and in the rhs we define the matrix that corresponds to the sum of A,B.
  In the rhs, we can access the matrices corresponding to A,B by
  writing \<^term>\<open>mat_of_cblinfun B\<close>.
  (See, e.g., lemma \<open>cblinfun_of_mat_plusOp\<close> below).

  See \<^cite>\<open>"code-generation-tutorial"\<close> for more information on
  @{theory_text \<open>[code abstype]\<close>}.\<close>

declare mat_of_cblinfun_inverse [code abstype]

text \<open>This lemma defines addition. By writing \<^term>\<open>mat_of_cblinfun (M + N)\<close>
on the left hand side, we get access to the\<close>

declare mat_of_cblinfun_plus[code]
  \<comment> \<open>Code equation for addition of cblinfuns\<close>

declare mat_of_cblinfun_id[code]
  \<comment> \<open>Code equation for computing the identity operator\<close>

declare mat_of_cblinfun_1[code]
  \<comment> \<open>Code equation for computing the one-dimensional identity\<close>

declare mat_of_cblinfun_zero[code]
  \<comment> \<open>Code equation for computing the zero operator\<close>

declare mat_of_cblinfun_uminus[code]
  \<comment> \<open>Code equation for computing the unary minus on cblinfun's\<close>

declare mat_of_cblinfun_minus[code]
  \<comment> \<open>Code equation for computing the difference of cblinfun's\<close>

declare mat_of_cblinfun_classical_operator[code]
  \<comment> \<open>Code equation for computing the "classical operator"\<close>

declare mat_of_cblinfun_compose[code]
  \<comment> \<open>Code equation for computing the composition/product of cblinfun's\<close>

declare mat_of_cblinfun_scaleC[code]
  \<comment> \<open>Code equation for multiplication with complex scalar\<close>

declare mat_of_cblinfun_scaleR[code]
  \<comment> \<open>Code equation for multiplication with real scalar\<close>

declare mat_of_cblinfun_adj[code]
  \<comment> \<open>Code equation for computing the adj\<close>

text \<open>This instantiation defines a code equation for equality tests for cblinfun.\<close>
instantiation cblinfun :: (onb_enum,onb_enum) equal begin
definition [code]: "equal_cblinfun M N \<longleftrightarrow> mat_of_cblinfun M = mat_of_cblinfun N"
  for M N :: "'a \<Rightarrow>\<^sub>C\<^sub>L 'b"
instance
  apply intro_classes
  unfolding equal_cblinfun_def
  using mat_of_cblinfun_inj injD by fastforce
end

subsection \<open>Vectors\<close>

text \<open>In this section, we define code for operations on vectors. As with operators above,
  we do this by using an isomorphism between finite vectors
  (i.e., types T of sort \<open>complex_vector\<close>) and the type \<^typ>\<open>complex vec\<close> from
  \<^session>\<open>Jordan_Normal_Form\<close>. We have developed such an isomorphism in
  theory \<open>Cblinfun_Matrix\<close> for
  any type T of sort \<open>onb_enum\<close> (i.e., any type with a finite canonical orthonormal basis)
  as was done above for bounded operators.
  Unfortunately, we cannot declare code equations for a type class,
  code equations must be related to a specific type constructor.
  So we give code definition only for vectors of type \<^typ>\<open>'a ell2\<close> (where \<^typ>\<open>'a\<close>
  must be of sort \<open>enum\<close> to make make sure that \<^typ>\<open>'a ell2\<close> is finite dimensional).

  The isomorphism between \<^typ>\<open>'a ell2\<close> is given by the constants \<open>ell2_of_vec\<close>
  and \<open>vec_of_ell2\<close> which are copies of the more general \<^const>\<open>basis_enum_of_vec\<close>
  and \<^const>\<open>vec_of_basis_enum\<close> but with a more restricted type to be usable in our code equations.
\<close>

definition ell2_of_vec :: "complex vec \<Rightarrow> 'a::enum ell2" where "ell2_of_vec = basis_enum_of_vec"
definition vec_of_ell2 :: "'a::enum ell2 \<Rightarrow> complex vec" where "vec_of_ell2 = vec_of_basis_enum"

text \<open>The following theorem registers the isomorphism \<open>ell2_of_vec\<close>/\<open>vec_of_ell2\<close>
  for code generation. From now on,
  code for operations on \<^typ>\<open>_ ell2\<close> can be expressed by declarations such
  as \<^term>\<open>vec_of_ell2 (f a b) = g (vec_of_ell2 a) (vec_of_ell2 b)\<close>
  if the operation f on \<^typ>\<open>_ ell2\<close> corresponds to the operation g on
  \<^typ>\<open>complex vec\<close>.\<close>

lemma vec_of_ell2_inverse [code abstype]:
  "ell2_of_vec (vec_of_ell2 B) = B"
  unfolding ell2_of_vec_def vec_of_ell2_def
  by (rule vec_of_basis_enum_inverse)

text \<open>This instantiation defines a code equation for equality tests for ell2.\<close>
instantiation ell2 :: (enum) equal begin
definition [code]: "equal_ell2 M N \<longleftrightarrow> vec_of_ell2 M = vec_of_ell2 N"
  for M N :: "'a::enum ell2"
instance
  apply intro_classes
  unfolding equal_ell2_def
  by (metis vec_of_ell2_inverse)
end

lemma vec_of_ell2_zero[code]:
  \<comment> \<open>Code equation for computing the zero vector\<close>
  "vec_of_ell2 (0::'a::enum ell2) = zero_vec (CARD('a))"
  by (simp add: vec_of_ell2_def vec_of_basis_enum_zero)

lemma vec_of_ell2_ket[code]:
  \<comment> \<open>Code equation for computing a standard basis vector\<close>
  "vec_of_ell2 (ket i) = unit_vec (CARD('a)) (enum_idx i)"
  for i::"'a::enum"
  using vec_of_ell2_def vec_of_basis_enum_ket by metis

lemma vec_of_ell2_timesScalarVec[code]:
  \<comment> \<open>Code equation for multiplying a vector with a complex scalar\<close>
  "vec_of_ell2 (scaleC a \<psi>) = smult_vec a (vec_of_ell2 \<psi>)"
  for \<psi> :: "'a::enum ell2"
  by (simp add: vec_of_ell2_def vec_of_basis_enum_scaleC)

lemma vec_of_ell2_scaleR[code]:
  \<comment> \<open>Code equation for multiplying a vector with a real scalar\<close>
  "vec_of_ell2 (scaleR a \<psi>) = smult_vec (complex_of_real a) (vec_of_ell2 \<psi>)"
  for \<psi> :: "'a::enum ell2"
  by (simp add: vec_of_ell2_def vec_of_basis_enum_scaleR)

lemma ell2_of_vec_plus[code]:
  \<comment> \<open>Code equation for adding vectors\<close>
  "vec_of_ell2 (x + y) =  (vec_of_ell2 x) + (vec_of_ell2 y)" for x y :: "'a::enum ell2"
  by (simp add: vec_of_ell2_def vec_of_basis_enum_add)

lemma ell2_of_vec_minus[code]:
  \<comment> \<open>Code equation for subtracting vectors\<close>
  "vec_of_ell2 (x - y) =  (vec_of_ell2 x) - (vec_of_ell2 y)" for x y :: "'a::enum ell2"
  by (simp add: vec_of_ell2_def vec_of_basis_enum_minus)

lemma ell2_of_vec_uminus[code]:
  \<comment> \<open>Code equation for negating a vector\<close>
  "vec_of_ell2 (- y) =  - (vec_of_ell2 y)" for y :: "'a::enum ell2"
  by (simp add: vec_of_ell2_def vec_of_basis_enum_uminus)

lemma cinner_ell2_code' [code]: "cinner \<psi> \<phi> = cscalar_prod (vec_of_ell2 \<phi>) (vec_of_ell2 \<psi>)"
  \<comment> \<open>Code equation for the inner product of vectors\<close>
  by (simp add: cscalar_prod_vec_of_basis_enum vec_of_ell2_def)

lemma norm_ell2_code [code]:
  \<comment> \<open>Code equation for the norm of a vector\<close>
  "norm \<psi> = (let \<psi>' = vec_of_ell2 \<psi> in
    sqrt (\<Sum> i \<in> {0 ..< dim_vec \<psi>'}. let z = vec_index \<psi>' i in (Re z)\<^sup>2 + (Im z)\<^sup>2))"
  by (simp add: norm_ell2_vec_of_basis_enum vec_of_ell2_def)

lemma times_ell2_code'[code]:
  \<comment> \<open>Code equation for the product in the algebra of one-dimensional vectors\<close>
  fixes \<psi> \<phi> :: "'a::{CARD_1,enum} ell2"
  shows "vec_of_ell2 (\<psi> * \<phi>)
   = vec_of_list [vec_index (vec_of_ell2 \<psi>) 0 * vec_index (vec_of_ell2 \<phi>) 0]"
  by (simp add: vec_of_ell2_def vec_of_basis_enum_times)

lemma divide_ell2_code'[code]:
  \<comment> \<open>Code equation for the product in the algebra of one-dimensional vectors\<close>
  fixes \<psi> \<phi> :: "'a::{CARD_1,enum} ell2"
  shows "vec_of_ell2 (\<psi> / \<phi>)
   = vec_of_list [vec_index (vec_of_ell2 \<psi>) 0 / vec_index (vec_of_ell2 \<phi>) 0]"
  by (simp add: vec_of_ell2_def vec_of_basis_enum_divide)

lemma inverse_ell2_code'[code]:
  \<comment> \<open>Code equation for the product in the algebra of one-dimensional vectors\<close>
  fixes \<psi> :: "'a::{CARD_1,enum} ell2"
  shows "vec_of_ell2 (inverse \<psi>)
   = vec_of_list [inverse (vec_index (vec_of_ell2 \<psi>) 0)]"
  by (simp add: vec_of_ell2_def vec_of_basis_enum_to_inverse)

lemma one_ell2_code'[code]:
  \<comment> \<open>Code equation for the unit in the algebra of one-dimensional vectors\<close>
  "vec_of_ell2 (1 :: 'a::{CARD_1,enum} ell2) = vec_of_list [1]"
  by (simp add: vec_of_ell2_def vec_of_basis_enum_1)

subsection \<open>Vector/Matrix\<close>

text \<open>We proceed to give code equations for operations involving both
  operators (cblinfun) and vectors. As explained above, we have to restrict
  the equations to vectors of type \<^typ>\<open>'a ell2\<close> even though the theory is available
  for any type of class \<^class>\<open>onb_enum\<close>. As a consequence, we run into an
  addition technicality now. For example, to define a code equation for applying
  an operator to a vector, we might try to give the following lemma:

\<^theory_text>\<open>lemma cblinfun_apply_code[code]:
  "vec_of_ell2 (M *\<^sub>V x) = (mult_mat_vec (mat_of_cblinfun M) (vec_of_ell2 x))"
  by (simp add: mat_of_cblinfun_cblinfun_apply vec_of_ell2_def)\<close>

  Unfortunately, this does not work, Isabelle produces the warning
  "Projection as head in equation", most likely due to the fact that
  the type of \<^term>\<open>(*\<^sub>V)\<close> in the equation is less general than the type of
  \<^term>\<open>(*\<^sub>V)\<close> (it is restricted to @{type ell2}). We overcome this problem
  by defining a constant \<open>cblinfun_apply_code\<close> which is equal to \<^term>\<open>(*\<^sub>V)\<close>
  but has a more restricted type. We then instruct the code generation
  to replace occurrences of \<^term>\<open>(*\<^sub>V)\<close> by \<open>cblinfun_apply_code\<close> (where possible),
  and we add code generation for \<open>cblinfun_apply_code\<close> instead of \<^term>\<open>(*\<^sub>V)\<close>.
\<close>

definition cblinfun_apply_code :: "'a ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b ell2 \<Rightarrow> 'a ell2 \<Rightarrow> 'b ell2"
  where [code del, code_abbrev]: "cblinfun_apply_code = (*\<^sub>V)"
    \<comment> \<open>@{attribute code_abbrev} instructs the code generation to replace the
     rhs \<^term>\<open>(*\<^sub>V)\<close> by the lhs \<^term>\<open>cblinfun_apply_code\<close> before starting
     the actual code generation.\<close>

lemma cblinfun_apply_code[code]:
  \<comment> \<open>Code equation for \<^term>\<open>cblinfun_apply_code\<close>, i.e., for applying an operator
     to an \<^type>\<open>ell2\<close> vector\<close>
  "vec_of_ell2 (cblinfun_apply_code M x) = (mult_mat_vec (mat_of_cblinfun M) (vec_of_ell2 x))"
  by (simp add: cblinfun_apply_code_def mat_of_cblinfun_cblinfun_apply vec_of_ell2_def)

text \<open>For the constant \<^term>\<open>vector_to_cblinfun\<close> (canonical isomorphism from
  vectors to operators), we have the same problem and define a constant
  \<open>vector_to_cblinfun_code\<close> with more restricted type\<close>

definition vector_to_cblinfun_code :: "'a ell2 \<Rightarrow> 'b::one_dim \<Rightarrow>\<^sub>C\<^sub>L 'a ell2" where
  [code del,code_abbrev]: "vector_to_cblinfun_code = vector_to_cblinfun"
  \<comment> \<open>@{attribute code_abbrev} instructs the code generation to replace the
     rhs \<^term>\<open>vector_to_cblinfun\<close> by the lhs \<^term>\<open>vector_to_cblinfun_code\<close>
     before starting the actual code generation.\<close>

lemma vector_to_cblinfun_code[code]:
  \<comment> \<open>Code equation for translating a vector into an operation (single-column matrix)\<close>
  "mat_of_cblinfun (vector_to_cblinfun_code \<psi>) = mat_of_cols (CARD('a)) [vec_of_ell2 \<psi>]"
  for \<psi>::"'a::enum ell2"
  by (simp add: mat_of_cblinfun_vector_to_cblinfun  vec_of_ell2_def vector_to_cblinfun_code_def)

subsection \<open>Subspaces\<close>

text \<open>In this section, we define code equations for handling subspaces, i.e.,
values of type \<^typ>\<open>'a ccsubspace\<close>. We choose to computationally represent
a subspace by a list of vectors that span the subspace. That is,
if \<^term>\<open>vecs\<close> are vectors (type \<^typ>\<open>complex vec\<close>), \<open>SPAN vecs\<close> is defined to be their
span. Then the code generation can simply represent all subspaces in this form, and
we need to define the operations on subspaces in terms of list of vectors
(e.g., the closed union of two subspaces would be computed as the concatenation
of the two lists, to give one of the simplest examples).

To support this, \<open>SPAN\<close> is declared as a "\<open>code_datatype\<close>".
(Not as an abstract datatype like \<^term>\<open>cblinfun_of_mat\<close>/\<^term>\<open>mat_of_cblinfun\<close>
because that would require \<open>SPAN\<close> to be injective.)

Then all code equations for different operations need to be formulated as
functions of values of the form \<open>SPAN x\<close>. (E.g., \<open>SPAN x + SPAN y = SPAN (\<dots>)\<close>.)\<close>

definition [code del]: "SPAN x = (let n = length (canonical_basis :: 'a::onb_enum list) in
    ccspan (basis_enum_of_vec ` Set.filter (\<lambda>v. dim_vec v = n) (set x)) :: 'a ccsubspace)"
  \<comment> \<open>The SPAN of vectors x, as a \<^type>\<open>ccsubspace\<close>.
      We filter out vectors of the wrong dimension because \<open>SPAN\<close> needs to have
      well-defined behavior even in cases that would not actually occur in an execution.\<close>
code_datatype SPAN

text \<open>We first declare code equations for \<^term>\<open>Proj\<close>, i.e., for
turning a subspace into a projector. This means, we would need a code equation
of the form \<open>mat_of_cblinfun (Proj (SPAN S)) = \<dots>\<close>. However, this equation is
not accepted by the code generation for reasons we do not understand. But
if we define an auxiliary constant \<open>mat_of_cblinfun_Proj_code\<close> that stands for
\<open>mat_of_cblinfun (Proj _)\<close>, define a code equation for \<open>mat_of_cblinfun_Proj_code\<close>,
and then define a code equation for \<open>mat_of_cblinfun (Proj S)\<close> in terms of
\<open>mat_of_cblinfun_Proj_code\<close>, Isabelle accepts the code equations.\<close>

definition "mat_of_cblinfun_Proj_code S = mat_of_cblinfun (Proj S)"
declare mat_of_cblinfun_Proj_code_def[symmetric, code]

lemma mat_of_cblinfun_Proj_code_code[code]:
  \<comment> \<open>Code equation for computing a projector onto a set S of vectors.
     We first make the vectors S into an orthonormal basis using
     the Gram-Schmidt procedure and then compute the projector
     as the sum of the "butterflies" \<open>x * x*\<close> of the vectors \<open>x\<in>S\<close>
     (done by \<^term>\<open>mk_projector_orthog\<close>).\<close>
  "mat_of_cblinfun_Proj_code (SPAN S :: 'a::onb_enum ccsubspace) =
    (let d = length (canonical_basis :: 'a list) in mk_projector_orthog d
              (gram_schmidt0 d (filter (\<lambda>v. dim_vec v = d) S)))"
proof -
  have *: "map_option vec_of_basis_enum (if dim_vec x = length (canonical_basis :: 'a list) then Some (basis_enum_of_vec x :: 'a) else None)
      = (if dim_vec x = length (canonical_basis :: 'a list) then Some x else None)" for x
    by auto
  show ?thesis
    unfolding SPAN_def mat_of_cblinfun_Proj_code_def
    using mat_of_cblinfun_Proj_ccspan[where S =
        "map basis_enum_of_vec (filter (\<lambda>v. dim_vec v = (length (canonical_basis :: 'a list))) S) :: 'a list"]
    apply (simp only: Let_def map_filter_map_filter filter_set image_set map_map_filter o_def)
    unfolding *
    by (simp add: map_filter_map_filter[symmetric])
qed

lemma top_ccsubspace_code[code]:
  \<comment> \<open>Code equation for \<^term>\<open>top\<close>, the subspace containing everything.
      Top is represented as the span of the standard basis vectors.\<close>
  "(top::'a ccsubspace) =
      (let n = length (canonical_basis :: 'a::onb_enum list) in SPAN (unit_vecs n))"
  unfolding SPAN_def
  apply (simp only: index_unit_vec Let_def map_filter_map_filter filter_set image_set map_map_filter
      map_filter_map o_def unit_vecs_def)
  apply (simp add: basis_enum_of_vec_unit_vec)
  apply (subst nth_image)
  by auto

lemma bot_as_span[code]:
  \<comment> \<open>Code equation for \<^term>\<open>bot\<close>, the subspace containing everything.
      Top is represented as the span of the standard basis vectors.\<close>
  "(bot::'a::onb_enum ccsubspace) = SPAN []"
  unfolding SPAN_def by (auto simp: Set.filter_def)

lemma sup_spans[code]:
  \<comment> \<open>Code equation for the join (lub) of two subspaces (union of the generating lists)\<close>
  "SPAN A \<squnion> SPAN B = SPAN (A @ B)"
  unfolding SPAN_def
  by (auto simp: ccspan_union image_Un filter_Un Let_def)

text \<open>We do not need an equation for \<^term>\<open>(+)\<close> because \<^term>\<open>(+)\<close>
is defined in terms of \<^term>\<open>(\<squnion>)\<close> (for \<^type>\<open>ccsubspace\<close>), thus the code generation automatically
computes \<^term>\<open>(+)\<close> in terms of the code for \<^term>\<open>(\<squnion>)\<close>\<close>

definition [code del,code_abbrev]: "Span_code (S::'a::enum ell2 set) = (ccspan S)"
  \<comment> \<open>A copy of \<^term>\<open>ccspan\<close> with restricted type. For analogous reasons as
     \<^term>\<open>cblinfun_apply_code\<close>, see there for explanations\<close>

lemma span_Set_Monad[code]: "Span_code (Set_Monad l) = (SPAN (map vec_of_ell2 l))"
  \<comment> \<open>Code equation for the span of a finite set. (\<^term>\<open>Set_Monad\<close> is a datatype
     constructor that represents sets as lists in the computation.)\<close>
  apply (simp add: Span_code_def SPAN_def Let_def)
  apply (subst Set_filter_unchanged)
   apply (auto simp add: vec_of_ell2_def)[1]
  by (metis (no_types, lifting) ell2_of_vec_def image_image map_idI set_map vec_of_ell2_inverse)

text \<open>This instantiation defines a code equation for equality tests for \<^type>\<open>ccsubspace\<close>.
      The actual code for equality tests is given below (lemma \<open>equal_ccsubspace_code\<close>).\<close>
instantiation ccsubspace :: (onb_enum) equal begin
definition [code del]: "equal_ccsubspace (A::'a ccsubspace) B = (A=B)"
instance apply intro_classes unfolding equal_ccsubspace_def by simp
end

lemma leq_ccsubspace_code[code]:
  \<comment> \<open>Code equation for deciding inclusion of one space in another.
     Uses the constant \<^term>\<open>is_subspace_of_vec_list\<close> which implements the actual
     computation by checking for each generator of A whether it is in the
     span of B (by orthogonal projection onto an orthonormal basis of B
     which is computed using Gram-Schmidt).\<close>
  "SPAN A \<le> (SPAN B :: 'a::onb_enum ccsubspace)
      \<longleftrightarrow> (let d = length (canonical_basis :: 'a list) in
          is_subspace_of_vec_list d
          (filter (\<lambda>v. dim_vec v = d) A)
          (filter (\<lambda>v. dim_vec v = d) B))"
proof -
  define d A' B' where "d = length (canonical_basis :: 'a list)"
    and "A' = filter (\<lambda>v. dim_vec v = d) A"
    and "B' = filter (\<lambda>v. dim_vec v = d) B"

  show ?thesis
    unfolding SPAN_def d_def[symmetric] filter_set Let_def
      A'_def[symmetric] B'_def[symmetric] image_set
    apply (subst ccspan_leq_using_vec)
    unfolding d_def[symmetric] map_map o_def
    apply (subst map_cong[where xs=A', OF refl])
     apply (rule basis_enum_of_vec_inverse)
     apply (simp add: A'_def d_def)
    apply (subst map_cong[where xs=B', OF refl])
     apply (rule basis_enum_of_vec_inverse)
    by (simp_all add: B'_def d_def)
qed

lemma equal_ccsubspace_code[code]:
  \<comment> \<open>Code equation for equality test. By checking mutual inclusion
      (for which we have code by the preceding code equation).\<close>
  "HOL.equal (A::_ ccsubspace) B = (A\<le>B \<and> B\<le>A)"
  unfolding equal_ccsubspace_def by auto

lemma apply_cblinfun_code[code]:
  \<comment> \<open>Code equation for applying an operator \<^term>\<open>A\<close> to a subspace.
      Simply by multiplying each generator with \<^term>\<open>A\<close>\<close>
  "A *\<^sub>S SPAN S = (let d = length (canonical_basis :: 'a list) in
         SPAN (map (mult_mat_vec (mat_of_cblinfun A))
               (filter (\<lambda>v. dim_vec v = d) S)))"
  for A::"'a::onb_enum \<Rightarrow>\<^sub>C\<^sub>L'b::onb_enum"
proof -
  define dA dB S'
    where "dA = length (canonical_basis :: 'a list)"
      and "dB = length (canonical_basis :: 'b list)"
      and "S' = filter (\<lambda>v. dim_vec v = dA) S"

  have "cblinfun_image A (SPAN S) = A *\<^sub>S ccspan (set (map basis_enum_of_vec S'))"
    unfolding SPAN_def dA_def[symmetric] Let_def S'_def filter_set
    by simp
  also have "\<dots> = ccspan ((\<lambda>x. basis_enum_of_vec
            (mat_of_cblinfun A *\<^sub>v vec_of_basis_enum (basis_enum_of_vec x :: 'a))) ` set S')"
    apply (subst cblinfun_apply_ccspan_using_vec)
    by (simp add: image_image)
  also have "\<dots> = ccspan ((\<lambda>x. basis_enum_of_vec (mat_of_cblinfun A *\<^sub>v x)) ` set S')"
    apply (subst image_cong[OF refl])
     apply (subst basis_enum_of_vec_inverse)
    by (auto simp add: S'_def dA_def)
  also have "\<dots> = SPAN (map (mult_mat_vec (mat_of_cblinfun A)) S')"
    unfolding SPAN_def dB_def[symmetric] Let_def filter_set
    apply (subst filter_True)
    by (simp_all add: dB_def mat_of_cblinfun_def image_image)

  finally show ?thesis
    unfolding dA_def[symmetric] S'_def[symmetric] Let_def
    by simp
qed

definition [code del, code_abbrev]: "range_cblinfun_code A = A *\<^sub>S top"
  \<comment> \<open>A new constant for the special case of applying an operator to the subspace \<^term>\<open>top\<close>
  (i.e., for computing the range of the operator). We do this to be able to give
  more specialized code for this specific situation. (The generic code for
  \<^term>\<open>(*\<^sub>S)\<close> would work but is less efficient because it involves repeated matrix
  multiplications. @{attribute code_abbrev} makes sure occurrences of \<^term>\<open>A *\<^sub>S top\<close>
  are replaced before starting the actual code generation.\<close>

lemma range_cblinfun_code[code]:
  \<comment> \<open>Code equation for computing the range of an operator \<^term>\<open>A\<close>.
      Returns the columns of the matrix representation of \<^term>\<open>A\<close>.\<close>
  fixes A :: "'a::onb_enum \<Rightarrow>\<^sub>C\<^sub>L 'b::onb_enum"
  shows "range_cblinfun_code A = SPAN (cols (mat_of_cblinfun A))"
proof -
  define dA dB
    where "dA = length (canonical_basis :: 'a list)"
      and "dB = length (canonical_basis :: 'b list)"
  have carrier_A: "mat_of_cblinfun A \<in> carrier_mat dB dA"
    unfolding mat_of_cblinfun_def dA_def dB_def by simp

  have "range_cblinfun_code A = A *\<^sub>S SPAN (unit_vecs dA)"
    unfolding range_cblinfun_code_def
    by (metis dA_def top_ccsubspace_code)
  also have "\<dots> = SPAN (map (\<lambda>i. mat_of_cblinfun A *\<^sub>v unit_vec dA i) [0..<dA])"
    unfolding apply_cblinfun_code dA_def[symmetric] Let_def
    apply (subst filter_True)
     apply (meson carrier_vecD subset_code(1) unit_vecs_carrier)
    by (simp add: unit_vecs_def o_def)
  also have "\<dots> = SPAN (map (\<lambda>x. mat_of_cblinfun A *\<^sub>v col (1\<^sub>m dA) x) [0..<dA])"
    apply (subst map_cong[OF refl])
    by auto
  also have "\<dots> = SPAN (map (col (mat_of_cblinfun A * 1\<^sub>m dA)) [0..<dA])"
    apply (subst map_cong[OF refl])
     apply (subst col_mult2[symmetric])
        apply (rule carrier_A)
    by auto
  also have "\<dots> = SPAN (cols (mat_of_cblinfun A))"
    unfolding cols_def dA_def[symmetric]
    apply (subst right_mult_one_mat[OF carrier_A])
    using carrier_A by blast
  finally show ?thesis
    by -
qed

lemma uminus_Span_code[code]: "- X = range_cblinfun_code (id_cblinfun - Proj X)"
  \<comment> \<open>Code equation for the orthogonal complement of a subspace \<^term>\<open>X\<close>.
      Computed as the range of one minus the projector on \<^term>\<open>X\<close>\<close>
  unfolding range_cblinfun_code_def
  by (metis Proj_ortho_compl Proj_range)

lemma kernel_code[code]:
  \<comment> \<open>Computes the kernel of an operator \<^term>\<open>A\<close>.
      This is implemented using the existing functions
      for transforming a matrix into row echelon form (\<^term>\<open>gauss_jordan_single\<close>)
      and for computing a basis of the kernel of such a matrix
      (\<^term>\<open>find_base_vectors\<close>)\<close>
  "kernel A = SPAN (find_base_vectors (gauss_jordan_single (mat_of_cblinfun A)))"
  for A::"('a::onb_enum,'b::onb_enum) cblinfun"
proof -
  define dA dB Am Ag base
    where "dA = length (canonical_basis :: 'a list)"
      and "dB = length (canonical_basis :: 'b list)"
      and "Am = mat_of_cblinfun A"
      and "Ag = gauss_jordan_single Am"
      and "base = find_base_vectors Ag"

  interpret complex_vec_space dA.

  have Am_carrier: "Am \<in> carrier_mat dB dA"
    unfolding Am_def mat_of_cblinfun_def dA_def dB_def by simp

  have row_echelon: "row_echelon_form Ag"
    unfolding Ag_def
    using Am_carrier refl by (rule gauss_jordan_single)

  have Ag_carrier: "Ag \<in> carrier_mat dB dA"
    unfolding Ag_def
    using Am_carrier refl by (rule gauss_jordan_single(2))

  have base_carrier: "set base \<subseteq> carrier_vec dA"
    unfolding base_def
    using find_base_vectors(1)[OF row_echelon Ag_carrier]
    using Ag_carrier mat_kernel_def by blast

  interpret k: kernel dB dA Ag
    apply standard using Ag_carrier by simp

  have basis_base: "kernel.basis dA Ag (set base)"
    using row_echelon Ag_carrier unfolding base_def
    by (rule find_base_vectors(3))

  have "space_as_set (SPAN base)
       = space_as_set (ccspan (basis_enum_of_vec ` set base :: 'a set))"
    unfolding SPAN_def dA_def[symmetric] Let_def filter_set
    apply (subst filter_True)
    using base_carrier by auto

  also have "\<dots> = cspan (basis_enum_of_vec ` set base)"
    apply transfer apply (subst closure_finite_cspan)
    by simp_all

  also have "\<dots> = basis_enum_of_vec ` span (set base)"
    apply (subst basis_enum_of_vec_span)
    using base_carrier dA_def by auto

  also have "\<dots> = basis_enum_of_vec ` mat_kernel Ag"
    using basis_base k.Ker.basis_def k.span_same by auto

  also have "\<dots> = basis_enum_of_vec ` {v \<in> carrier_vec dA. Ag *\<^sub>v v = 0\<^sub>v dB}"
    apply (rule arg_cong[where f="\<lambda>x. basis_enum_of_vec ` x"])
    unfolding mat_kernel_def using Ag_carrier
    by simp

  also have "\<dots> = basis_enum_of_vec ` {v \<in> carrier_vec dA. Am *\<^sub>v v = 0\<^sub>v dB}"
    using gauss_jordan_single(1)[OF Am_carrier Ag_def[symmetric]]
    by auto

  also have "\<dots> = {w. A *\<^sub>V w = 0}"
  proof -
    have "basis_enum_of_vec ` {v \<in> carrier_vec dA. Am *\<^sub>v v = 0\<^sub>v dB}
        = basis_enum_of_vec ` {v \<in> carrier_vec dA. A *\<^sub>V basis_enum_of_vec v = 0}"
      apply (rule arg_cong[where f="\<lambda>t. basis_enum_of_vec ` t"])
      apply (rule Collect_cong)
      apply (simp add: Am_def)
      by (metis Am_carrier Am_def carrier_matD(2) carrier_vecD dB_def mat_carrier
          mat_of_cblinfun_def mat_of_cblinfun_cblinfun_apply vec_of_basis_enum_inverse
          basis_enum_of_vec_inverse vec_of_basis_enum_zero)
    also have "\<dots> = {w \<in> basis_enum_of_vec ` carrier_vec dA. A *\<^sub>V w = 0}"
      apply (subst Compr_image_eq[symmetric])
      by simp
    also have "\<dots> = {w. A *\<^sub>V w = 0}"
      apply auto
      by (metis (no_types, lifting) Am_carrier Am_def carrier_matD(2) carrier_vec_dim_vec dim_vec_of_basis_enum' image_iff mat_carrier mat_of_cblinfun_def vec_of_basis_enum_inverse)
    finally show ?thesis
      by -
  qed

  also have "\<dots> = space_as_set (kernel A)"
    apply transfer by auto

  finally have "SPAN base = kernel A"
    by (simp add: space_as_set_inject)
  then show ?thesis
    by (simp add: base_def Ag_def Am_def)
qed

lemma inf_ccsubspace_code[code]:
  \<comment> \<open>Code equation for intersection of subspaces.
     Reduced to orthogonal complement and sum of subspaces
     for which we already have code equations.\<close>
  "(A::'a::onb_enum ccsubspace) \<sqinter> B = - (- A \<squnion> - B)"
  by (subst ortho_involution[symmetric], subst compl_inf, simp)

lemma Sup_ccsubspace_code[code]:
  \<comment> \<open>Supremum (sum) of a set of subspaces. Implemented
     by repeated pairwise sum.\<close>
  "Sup (Set_Monad l :: 'a::onb_enum ccsubspace set) = fold sup l bot"
  unfolding Set_Monad_def
  by (simp add: Sup_set_fold)

lemma Inf_ccsubspace_code[code]:
  \<comment> \<open>Infimum (intersection) of a set of subspaces.
      Implemented by the orthogonal complement of the supremum.\<close>
  "Inf (Set_Monad l :: 'a::onb_enum ccsubspace set)
  = - Sup (Set_Monad (map uminus l))"
  unfolding Set_Monad_def
  apply (induction l)
  by auto

subsection \<open>Miscellanea\<close>

text \<open>This is a hack to circumvent a bug in the code generation. The automatically
  generated code for the class \<^class>\<open>uniformity\<close> has a type that is different from
  what the generated code later assumes, leading to compilation errors (in ML at least)
  in any expression involving \<^typ>\<open>_ ell2\<close> (even if the constant \<^const>\<open>uniformity\<close> is
  not actually used).

  The fragment below circumvents this by forcing Isabelle to use the right type.
  (The logically useless fragment "\<open>let x = ((=)::'a\<Rightarrow>_\<Rightarrow>_)\<close>" achieves this.)\<close>
lemma uniformity_ell2_code[code]: "(uniformity :: ('a ell2 * _) filter) = Filter.abstract_filter (%_.
    Code.abort STR ''no uniformity'' (%_.
    let x = ((=)::'a\<Rightarrow>_\<Rightarrow>_) in uniformity))"
  by simp

text \<open>Code equation for \<^term>\<open>UNIV\<close>.
  It is now implemented via type class \<^class>\<open>enum\<close>
  (which provides a list of all values).\<close>
declare [[code drop: UNIV]]
declare enum_class.UNIV_enum[code]

text \<open>Setup for code generation involving sets of \<^type>\<open>ell2\<close>/\<^type>\<open>ccsubspace\<close>.
  This configures to use lists for representing sets in code.\<close>
derive (eq) ceq ccsubspace
derive (no) ccompare ccsubspace
derive (monad) set_impl ccsubspace
derive (eq) ceq ell2
derive (no) ccompare ell2
derive (monad) set_impl ell2

unbundle no_lattice_syntax
unbundle no_jnf_notation
unbundle no_cblinfun_notation

end