theory AssemblyToMachine
imports LinearAssemblyLanguage "../Machine/MachineLanguage" "../Utilities/Iterate"
begin

primrec machine_length :: "assembly \<Rightarrow> nat" where
  "machine_length (AAssm x) = 1"
| "machine_length (CAssm dst cmp) = 1"
| "machine_length (JAssm jmp s) = 2"
| "machine_length PAssm = 1"

primrec converted_length :: "assembly list \<Rightarrow> nat" where
  "converted_length [] = 0"
| "converted_length (\<iota> # \<pi>) = machine_length \<iota> + converted_length \<pi>"

fun build_symbol_table :: "l_assembly_program \<Rightarrow> code_label\<^sub>2 \<rightharpoonup> nat" where
  "build_symbol_table [] s = None"
| "build_symbol_table ((s', \<pi>) # \<Pi>) s = (
    if s' = s then Some 0
    else map_option (op + (converted_length \<pi>)) (build_symbol_table \<Pi> s))"

definition get_block_addr :: "(code_label\<^sub>2 \<rightharpoonup> nat) \<Rightarrow> code_label\<^sub>2 \<Rightarrow> int" where
  "get_block_addr \<rho> s = int (the (\<rho> s))"

primrec instruction_conv :: "(code_label\<^sub>2 \<rightharpoonup> nat) \<Rightarrow> assembly \<Rightarrow> machine_program" where
  "instruction_conv \<rho> (AAssm x) = [AInstr x]"
| "instruction_conv \<rho> (CAssm dst cmp) = [CInstr dst cmp {}]"
| "instruction_conv \<rho> (JAssm jmp s) = [AInstr (get_block_addr \<rho> s), CInstr {} (Reg D) jmp]"
| "instruction_conv \<rho> PAssm = [PInstr]"

definition get_assembly :: "l_assembly_program \<Rightarrow> assembly list" where
  "get_assembly \<Pi> = concat (map snd \<Pi>)"

definition program_convert :: "l_assembly_program \<Rightarrow> machine_program" where
  "program_convert \<Pi> = concat (map (instruction_conv (build_symbol_table \<Pi>)) (get_assembly \<Pi>))"

definition get_pc :: "l_assembly_program \<Rightarrow> assembly list \<Rightarrow> nat set" where
  "get_pc \<Pi> \<pi> =
    { the (build_symbol_table \<Pi> s) + converted_length \<pi>' | s \<pi>'. lookup \<Pi> s = Some (\<pi>' @ \<pi>) }"

fun state_convert :: "l_assembly_program \<Rightarrow> l_assembly_state \<Rightarrow> machine_state set" where
  "state_convert \<Pi> (\<mu>, Some a, d, \<pi>, \<omega>) = {(\<mu>, a, d, pc, \<omega>) | pc. pc \<in> get_pc \<Pi> \<pi>}"
| "state_convert \<Pi> (\<mu>, None, d, \<pi>, \<omega>) = {(\<mu>, a, d, pc, \<omega>) | a pc. pc \<in> get_pc \<Pi> \<pi>}"

(* conversion correctness *)

lemma [simp]: "lookup \<Pi> s = Some \<pi> \<Longrightarrow> nat (get_block_addr (build_symbol_table \<Pi>) s) \<in> get_pc \<Pi> \<pi>"
  by (induction \<Pi> s rule: lookup.induct) (auto simp add: get_block_addr_def get_pc_def)

lemma instr_conv_len [simp]: "length (instruction_conv \<rho> \<iota>) = machine_length \<iota>"
  by (induction \<iota>) simp_all

lemma convert_expands [simp]: "length \<pi> \<le> converted_length \<pi>"
  proof (induction \<pi>)
  case Nil
    thus ?case by simp
  case (Cons \<iota> \<pi>)
    thus ?case by (induction \<iota>) simp_all
  qed

lemma [simp]: "length (concat (map (instruction_conv \<rho>) \<pi>)) = converted_length \<pi>"
  by (induction \<pi>) simp_all

lemma [simp]: "converted_length (\<pi> @ \<pi>') = converted_length \<pi> + converted_length \<pi>'"
  by (induction \<pi>) simp_all

lemma pc_within: "pc \<in> get_pc \<Pi> (\<iota> # \<pi>) \<Longrightarrow>
    i < length (instruction_conv (build_symbol_table \<Pi>) \<iota>) \<Longrightarrow> i + pc < length (program_convert \<Pi>)"
  proof -
    assume "pc \<in> get_pc \<Pi> (\<iota> # \<pi>)"
    then obtain s \<pi>' where P: "pc = the (build_symbol_table \<Pi> s) + converted_length \<pi>'"
      and L: "lookup \<Pi> s = Some (\<pi>' @ \<iota> # \<pi>)" by (auto simp add: get_pc_def)
    assume "i < length (instruction_conv (build_symbol_table \<Pi>) \<iota>)"
    hence "i < machine_length \<iota>" by simp
    with L have "i + the (build_symbol_table \<Pi> s) + converted_length \<pi>' <
        length (program_convert \<Pi>)"
      proof (induction \<Pi> s rule: build_symbol_table.induct)
      case 1
        thus ?case by simp
      next case (2 s' \<pi>'' \<Pi> s)
        thus ?case
          proof (cases "s' = s")
          case True
            with 2 show ?thesis by (simp add: program_convert_def get_assembly_def)
          next case False
            with 2 show ?thesis
              by (cases "build_symbol_table \<Pi> s")
                 (simp_all add: program_convert_def get_assembly_def)
          qed
      qed
    with P show ?thesis by simp
  qed

lemma [simp]: "pc \<in> get_pc \<Pi> (\<iota> # \<pi>) \<Longrightarrow> pc < length (program_convert \<Pi>)"
  using pc_within by (induction \<iota>) fastforce+

lemma [simp]: "pc \<in> get_pc \<Pi> (JAssm jmp s # \<pi>) \<Longrightarrow> Suc pc < length (program_convert \<Pi>)"
  using pc_within by fastforce

lemma [simp]: "i < machine_length \<iota> \<Longrightarrow> (instruction_conv \<rho> \<iota> @ \<pi>) ! i = instruction_conv \<rho> \<iota> ! i"
  by (induction \<iota>) (simp_all, induction i, simp_all)

lemma lookup_convert': "i < machine_length \<iota> \<Longrightarrow>
  concat (map (instruction_conv \<rho>) (\<pi> @ \<iota> # \<pi>')) ! (converted_length \<pi> + i) =
    instruction_conv \<rho> \<iota> ! i"
  proof (induction \<pi>)
  case Nil
    thus ?case by simp
  next case (Cons \<iota>' \<pi>)
    hence "(instruction_conv \<rho> \<iota>' @ concat (map (instruction_conv \<rho>) (\<pi> @ \<iota> # \<pi>'))) !
        (length (instruction_conv \<rho> \<iota>') + converted_length \<pi> + i) = instruction_conv \<rho> \<iota> ! i"
      by (simp add: add.assoc del: instr_conv_len)
    thus ?case by simp
  qed

lemma symtab_conversion: "domain_distinct ((s', \<pi>) # \<Pi>) \<Longrightarrow> \<forall>s \<in> insert s' (dom (lookup \<Pi>)).
  \<rho> s = map_option (op + n) (build_symbol_table ((s', \<pi>) # \<Pi>) s) \<Longrightarrow>
    \<forall>s \<in> dom (lookup \<Pi>). \<rho> s = map_option (op + (n + converted_length \<pi>)) (build_symbol_table \<Pi> s)"
  proof
    fix s
    assume "domain_distinct ((s', \<pi>) # \<Pi>)"
    moreover assume "s \<in> dom (lookup \<Pi>)"
    moreover then obtain m where "build_symbol_table \<Pi> s = Some m" by fastforce
    moreover assume "\<forall>x \<in> insert s' (dom (lookup \<Pi>)).
      \<rho> x = map_option (op + n) (build_symbol_table ((s', \<pi>) # \<Pi>) x)"
    ultimately show "\<rho> s = map_option (op + (n + converted_length \<pi>)) (build_symbol_table \<Pi> s)"
      by auto
  qed

lemma lookup_convert'': "domain_distinct \<Pi> \<Longrightarrow> lookup \<Pi> s = Some \<pi> \<Longrightarrow> i < converted_length \<pi> \<Longrightarrow>
  \<forall>x \<in> dom (lookup \<Pi>). \<rho> x = map_option (op + n) (build_symbol_table \<Pi> x) \<Longrightarrow>
    concat (map (instruction_conv \<rho>) (get_assembly \<Pi>)) ! (the (\<rho> s) - n + i) =
      concat (map (instruction_conv \<rho>) \<pi>) ! i"
  proof (induction \<Pi> s arbitrary: n rule: lookup.induct)
  case 1
    thus ?case by simp
  next case (2 s' \<pi>' \<Pi> s)
    thus ?case
      proof (cases "s' = s")
      case True
        with 2 have "\<rho> s = Some n" by force
        with 2 True show ?thesis by (simp add: get_assembly_def nth_append)
      next case False
        let ?xs = "concat (map (instruction_conv \<rho>) \<pi>')"
        let ?ys = "concat (map (instruction_conv \<rho>) (get_assembly \<Pi>))"
        let ?n = "the (\<rho> s) - n + i"
        from False 2 obtain m where M: "build_symbol_table \<Pi> s = Some m" by fastforce
        from 2 have "\<forall>x\<in>dom (lookup ((s', \<pi>') # \<Pi>)).
          \<rho> x = map_option (op + n) (build_symbol_table ((s', \<pi>') # \<Pi>) x)" by blast
        hence "\<forall>x\<in>insert s' (dom (lookup \<Pi>)).
          \<rho> x = map_option (op + n) (build_symbol_table ((s', \<pi>') # \<Pi>) x)" by fastforce
        with 2 symtab_conversion have H: "\<forall>x \<in> dom (lookup \<Pi>).
          \<rho> x = map_option (op + (n + converted_length \<pi>')) (build_symbol_table \<Pi> x)" by blast
        with 2 False M have "\<rho> s = Some (n + converted_length \<pi>' + m)" by force
        hence "(if ?n < converted_length \<pi>' then ?xs ! ?n else ?ys ! (?n - converted_length \<pi>')) =
          ?ys ! (the (\<rho> s) - n - converted_length \<pi>' + i)" by simp
        with 2 False H show ?thesis by (auto simp add: get_assembly_def nth_append)
      qed
  qed

lemma [simp]: "domain_distinct \<Pi> \<Longrightarrow> lookup \<Pi> s = Some \<pi> \<Longrightarrow> i < converted_length \<pi> \<Longrightarrow>
  program_convert \<Pi> ! (the (build_symbol_table \<Pi> s) + i) =
    concat (map (instruction_conv (build_symbol_table \<Pi>)) \<pi>) ! i"
  proof -
    assume "domain_distinct \<Pi>"
       and "lookup \<Pi> s = Some \<pi>"
       and "i < converted_length \<pi>"
    moreover have "\<forall>x. build_symbol_table \<Pi> x = map_option (op + 0) (build_symbol_table \<Pi> x)"
      proof
        fix x
        show "build_symbol_table \<Pi> x = map_option (op + 0) (build_symbol_table \<Pi> x)"
          by (cases "build_symbol_table \<Pi> x") simp_all
      qed
    ultimately have "program_convert \<Pi> ! (the (build_symbol_table \<Pi> s) - 0 + i) =
        concat (map (instruction_conv (build_symbol_table \<Pi>)) \<pi>) ! i"
      by (metis lookup_convert'' program_convert_def)
    thus ?thesis by simp
  qed

lemma lookup_convert: "domain_distinct \<Pi> \<Longrightarrow> pc \<in> get_pc \<Pi> (\<iota> # \<pi>) \<Longrightarrow> i < machine_length \<iota> \<Longrightarrow>
    program_convert \<Pi> ! (pc + i) = instruction_conv (build_symbol_table \<Pi>) \<iota> ! i"
  proof -
    assume D: "domain_distinct \<Pi>"
    assume L: "i < machine_length \<iota>"
    assume "pc \<in> get_pc \<Pi> (\<iota> # \<pi>)"
    then obtain s \<pi>' where P: "pc = the (build_symbol_table \<Pi> s) + converted_length \<pi>' \<and>
      lookup \<Pi> s = Some (\<pi>' @ \<iota> # \<pi>)" by (auto simp add: get_pc_def)
    from D L lookup_convert' P show ?thesis by (simp add: add.assoc)
  qed

lemma next_pc: "pc \<in> get_pc \<Pi> (\<iota> # \<pi>) \<Longrightarrow> machine_length \<iota> + pc \<in> get_pc \<Pi> \<pi>"
  proof (induction \<iota>)
  case (AAssm x)
    then obtain s \<pi>' where P: "pc = the (build_symbol_table \<Pi> s) + converted_length \<pi>' \<and>
      lookup \<Pi> s = Some (\<pi>' @ AAssm x # \<pi>)" by (auto simp add: get_pc_def)
    with P have "Suc pc = the (build_symbol_table \<Pi> s) + converted_length (\<pi>' @ [AAssm x])" by simp
    with P get_pc_def show ?case by fastforce
  next case (CAssm dst cmp)
    then obtain s \<pi>' where P: "pc = the (build_symbol_table \<Pi> s) + converted_length \<pi>' \<and>
      lookup \<Pi> s = Some (\<pi>' @ CAssm dst cmp # \<pi>)" by (auto simp add: get_pc_def)
    with P have "Suc pc = the (build_symbol_table \<Pi> s) + converted_length (\<pi>' @ [CAssm dst cmp])"
      by simp
    with P get_pc_def show ?case by fastforce
  next case (JAssm jmp s)
    then obtain s' \<pi>' where P: "pc = the (build_symbol_table \<Pi> s') + converted_length \<pi>' \<and>
      lookup \<Pi> s' = Some (\<pi>' @ JAssm jmp s # \<pi>)" by (auto simp add: get_pc_def)
    with P have "Suc (Suc pc) =
      the (build_symbol_table \<Pi> s') + converted_length (\<pi>' @ [JAssm jmp s])" by simp
    with P get_pc_def show ?case by fastforce
  next case PAssm
    then obtain s \<pi>' where P: "pc = the (build_symbol_table \<Pi> s) + converted_length \<pi>' \<and>
      lookup \<Pi> s = Some (\<pi>' @ PAssm # \<pi>)" by (auto simp add: get_pc_def)
    with P have "Suc pc = the (build_symbol_table \<Pi> s) + converted_length (\<pi>' @ [PAssm])" by simp
    with P get_pc_def show ?case by fastforce
  qed

lemma [simp]: "\<Sigma> \<in> state_convert \<Pi> (\<mu>, a, d, \<pi>, \<omega>) \<Longrightarrow>
    \<exists>aa pc. \<Sigma> = (\<mu>, aa, d, pc, \<omega>) \<and> pc \<in> get_pc \<Pi> \<pi>"
  by (cases a) auto

lemma [simp]: "\<Sigma>\<^sub>M \<in> state_convert \<Pi> \<Sigma>\<^sub>A \<Longrightarrow> machine_output \<Sigma>\<^sub>M = l_assembly_output \<Sigma>\<^sub>A"
  by (induction \<Pi> \<Sigma>\<^sub>A rule: state_convert.induct) (induction \<Sigma>\<^sub>M rule: machine_output.induct, simp)+

lemma eval_assembly_conv [simp]: "domain_distinct \<Pi> \<Longrightarrow> eval_l_assembly \<Pi> \<Sigma>\<^sub>A = Some \<Sigma>\<^sub>A' \<Longrightarrow>
  \<Sigma>\<^sub>M \<in> state_convert \<Pi> \<Sigma>\<^sub>A \<Longrightarrow>
    \<exists>\<Sigma>\<^sub>M'. \<Sigma>\<^sub>M' \<in> state_convert \<Pi> \<Sigma>\<^sub>A' \<and> iterate (eval_machine (program_convert \<Pi>)) \<Sigma>\<^sub>M \<Sigma>\<^sub>M'"
  proof (induction \<Pi> \<Sigma>\<^sub>A rule: eval_l_assembly.induct)
  case 1
    thus ?case by simp
  next case (2 \<Pi> \<mu> a d x \<pi> \<omega>)
    from 2 have S: "\<Sigma>\<^sub>A' = (\<mu>, Some x, d, \<pi>, \<omega>)" by simp
    from 2 obtain pc aa where P: "\<Sigma>\<^sub>M = (\<mu>, aa, d, pc, \<omega>) \<and> pc \<in> get_pc \<Pi> (AAssm x # \<pi>)"
      by fastforce
    with next_pc have X: "(\<mu>, x, d, Suc pc, \<omega>) \<in> state_convert \<Pi> (\<mu>, Some x, d, \<pi>, \<omega>)" by fastforce
    from 2 P lookup_convert have "eval_machine (program_convert \<Pi>) (\<mu>, aa, d, pc, \<omega>) =
      Some (\<mu>, x, d, Suc pc, \<omega>)" by fastforce
    with X S P iter_one show ?case by fast
  next case (3 \<Pi> \<mu> a d dst cmp \<pi> \<omega>)
    let ?n = "compute cmp (\<mu> (nat a)) a d"
    let ?\<mu> = "if M \<in> dst then \<mu>(nat a := ?n) else \<mu>"
    let ?a = "if A \<in> dst then ?n else a"
    let ?d = "if D \<in> dst then ?n else d"
    from 3 have S: "\<Sigma>\<^sub>A' = (?\<mu>, Some ?a, ?d, \<pi>, \<omega>)" by (simp add: Let_def)
    from 3 obtain pc where P: "\<Sigma>\<^sub>M = (\<mu>, a, d, pc, \<omega>) \<and> pc \<in> get_pc \<Pi> (CAssm dst cmp # \<pi>)"
      by fastforce
    with next_pc have X: "(?\<mu>, ?a, ?d, Suc pc, \<omega>) \<in> state_convert \<Pi> (?\<mu>, Some ?a, ?d, \<pi>, \<omega>)"
      by fastforce
    have "eval_instruction (CInstr dst cmp {}) (\<mu>, a, d, pc, \<omega>) = (?\<mu>, ?a, ?d, Suc pc, \<omega>)"
      by (simp add: Let_def)
    with 3 P lookup_convert have "eval_machine (program_convert \<Pi>) (\<mu>, a, d, pc, \<omega>) =
      Some (?\<mu>, ?a, ?d, Suc pc, \<omega>)" by fastforce
    with X S P iter_one show ?case by fast
  next case 4
    thus ?case by simp
  next case (5 \<Pi> \<mu> a d jmp s \<pi> \<omega>)
    then obtain pc aa where P: "\<Sigma>\<^sub>M = (\<mu>, aa, d, pc, \<omega>) \<and> pc \<in> get_pc \<Pi> (JAssm jmp s # \<pi>)"
      by fastforce
    let ?s = "get_block_addr (build_symbol_table \<Pi>) s"
    from 5 P lookup_convert have first_step: "eval_machine (program_convert \<Pi>) (\<mu>, aa, d, pc, \<omega>) =
      Some (\<mu>, ?s, d, Suc pc, \<omega>)" by fastforce
    show ?case
      proof (cases "compare d jmp")
      case True
        thus ?thesis
          proof (cases "lookup \<Pi> s")
          case (Some \<pi>')
            with 5 True have S: "\<Sigma>\<^sub>A' = (\<mu>, None, d, \<pi>', \<omega>)" by simp
            from Some have X: "(\<mu>, ?s, d, nat ?s, \<omega>) \<in> state_convert \<Pi> (\<mu>, None, d, \<pi>', \<omega>)" by simp
            have "1 < machine_length (JAssm jmp s)" by simp
            with 5 P lookup_convert True have
              "eval_machine (program_convert \<Pi>) (\<mu>, ?s, d, Suc pc, \<omega>) =
                Some (\<mu>, ?s, d, nat ?s, \<omega>)" by fastforce
            with first_step X P S iter_two show ?thesis by fast
          next case None
            with 5 True show ?thesis by simp
          qed
      next case False
        from 5 False have S: "\<Sigma>\<^sub>A' = (\<mu>, None, d, \<pi>, \<omega>)" by auto
        from P next_pc have X: "(\<mu>, ?s, d, Suc (Suc pc), \<omega>) \<in> state_convert \<Pi> (\<mu>, None, d, \<pi>, \<omega>)"
          by fastforce
        from False have Y: "eval_instruction (CInstr {} (Reg D) jmp) (\<mu>, ?s, d, Suc pc, \<omega>) =
          (\<mu>, ?s, d, Suc (Suc pc), \<omega>)" by auto
        have "1 < machine_length (JAssm jmp s)" by simp
        with 5 P Y lookup_convert have "eval_machine (program_convert \<Pi>) (\<mu>, ?s, d, Suc pc, \<omega>) =
          Some (\<mu>, ?s, d, Suc (Suc pc), \<omega>)" by fastforce
        with first_step X P S iter_two show ?thesis by fast
      qed
  next case (6 \<Pi> \<mu> a d \<pi> \<omega>)
    thus ?case
      proof (cases a)
      case (Some aa)
        from 6 Some have S: "\<Sigma>\<^sub>A' = (\<mu>, Some aa, d, \<pi>, d # \<omega>)" by simp
        from 6 Some obtain pc where P: "\<Sigma>\<^sub>M = (\<mu>, aa, d, pc, \<omega>) \<and> pc \<in> get_pc \<Pi> (PAssm # \<pi>)"
          by fastforce
        with next_pc have X: "(\<mu>, aa, d, Suc pc, d # \<omega>) \<in> state_convert \<Pi> (\<mu>, Some aa, d, \<pi>, d # \<omega>)"
          by fastforce
        from 6 P lookup_convert have "eval_machine (program_convert \<Pi>) (\<mu>, aa, d, pc, \<omega>) =
          Some (\<mu>, aa, d, Suc pc, d # \<omega>)" by fastforce
        with X S P iter_one show ?thesis by fast
      next case None
        from 6 None have S: "\<Sigma>\<^sub>A' = (\<mu>, None, d, \<pi>, d # \<omega>)" by simp
        from 6 obtain pc aa where P: "\<Sigma>\<^sub>M = (\<mu>, aa, d, pc, \<omega>) \<and> pc \<in> get_pc \<Pi> (PAssm # \<pi>)"
          by fastforce
        with next_pc have X: "(\<mu>, aa, d, Suc pc, d # \<omega>) \<in> state_convert \<Pi> (\<mu>, None, d, \<pi>, d # \<omega>)"
          by fastforce
        from 6 P lookup_convert have "eval_machine (program_convert \<Pi>) (\<mu>, aa, d, pc, \<omega>) =
          Some (\<mu>, aa, d, Suc pc, d # \<omega>)" by fastforce
        with X S P iter_one show ?thesis by fast
      qed
  qed

theorem assembly_to_machine_correct [simp]: "iterate (eval_l_assembly \<Pi>) \<Sigma>\<^sub>A \<Sigma>\<^sub>A' \<Longrightarrow>
  \<Sigma>\<^sub>M \<in> state_convert \<Pi> \<Sigma>\<^sub>A \<Longrightarrow> domain_distinct \<Pi> \<Longrightarrow>
    \<exists>\<Sigma>\<^sub>M'. \<Sigma>\<^sub>M' \<in> state_convert \<Pi> \<Sigma>\<^sub>A' \<and> iterate (eval_machine (program_convert \<Pi>)) \<Sigma>\<^sub>M \<Sigma>\<^sub>M'"
  proof (induction "eval_l_assembly \<Pi>" \<Sigma>\<^sub>A \<Sigma>\<^sub>A' arbitrary: \<Sigma>\<^sub>M rule: iterate.induct)
  case iter_refl
    thus ?case by fastforce
  next case (iter_step \<Sigma>\<^sub>A \<Sigma>\<^sub>A' \<Sigma>\<^sub>A'')
    then obtain \<Sigma>\<^sub>M' where S: "\<Sigma>\<^sub>M' \<in> state_convert \<Pi> \<Sigma>\<^sub>A' \<and>
      iterate (eval_machine (program_convert \<Pi>)) \<Sigma>\<^sub>M \<Sigma>\<^sub>M'" by blast
    with iter_step eval_assembly_conv obtain \<Sigma>\<^sub>M'' where
      "\<Sigma>\<^sub>M'' \<in> state_convert \<Pi> \<Sigma>\<^sub>A'' \<and> iterate (eval_machine (program_convert \<Pi>)) \<Sigma>\<^sub>M' \<Sigma>\<^sub>M''" by blast
    with S have "\<Sigma>\<^sub>M'' \<in> state_convert \<Pi> \<Sigma>\<^sub>A'' \<and> iterate (eval_machine (program_convert \<Pi>)) \<Sigma>\<^sub>M \<Sigma>\<^sub>M''"
      by fastforce
    thus ?case by blast
  qed

end


theory ModalUltrafilter imports IHOML
begin
(**Some abbreviations for operations on \<delta>/\<gamma>-sets in modal context**)
  abbreviation elem_delta::"\<delta>\<Rightarrow>(\<delta>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" (infixr"\<^bold>\<in>\<^sup>\<delta>"99) where "x\<^bold>\<in>\<^sup>\<delta>S \<equiv> S x"
  abbreviation elem_gamma::"\<gamma>\<Rightarrow>(\<gamma>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" (infixr"\<^bold>\<in>\<^sup>\<gamma>"99) where "x\<^bold>\<in>\<^sup>\<gamma>S \<equiv> S x"
  abbreviation emptySet_delta::\<delta> ("\<^bold>\<emptyset>\<^sup>\<delta>") where "\<^bold>\<emptyset>\<^sup>\<delta> \<equiv> \<lambda>x. False"
  abbreviation emptySet_gamma::\<gamma> ("\<^bold>\<emptyset>\<^sup>\<gamma>") where "\<^bold>\<emptyset>\<^sup>\<gamma> \<equiv> \<lambda>x. \<^bold>\<bottom>"
  abbreviation fullSet_delta::\<delta> ("\<^bold>U\<^sup>\<delta>") where "\<^bold>U\<^sup>\<delta> \<equiv> \<lambda>x. True"
  abbreviation fullSet_gamma::\<gamma> ("\<^bold>U\<^sup>\<gamma>") where "\<^bold>U\<^sup>\<gamma> \<equiv> \<lambda>x. \<^bold>\<top>"
  abbreviation entails_delta::"\<delta>\<Rightarrow>\<delta>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<subseteq>\<^sup>\<delta>"51) where "\<phi>\<^bold>\<subseteq>\<^sup>\<delta>\<psi> \<equiv> \<lambda>w. \<forall>x. \<phi> x \<longrightarrow> \<psi> x"
  abbreviation entails_gamma::"\<gamma>\<Rightarrow>\<gamma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<subseteq>\<^sup>\<gamma>"51) where "\<phi>\<^bold>\<subseteq>\<^sup>\<gamma>\<psi> \<equiv> \<^bold>\<forall>x. \<phi> x \<^bold>\<rightarrow> \<psi> x"
  abbreviation andPred_delta::"\<delta>\<Rightarrow>\<delta>\<Rightarrow>\<delta>" (infixr"\<^bold>\<sqinter>\<^sup>\<delta>"51) where "\<phi>\<^bold>\<sqinter>\<^sup>\<delta>\<psi> \<equiv> \<lambda>x. \<phi> x \<and> \<psi> x"
  abbreviation andPred_gamma::"\<gamma>\<Rightarrow>\<gamma>\<Rightarrow>\<gamma>" (infixr"\<^bold>\<sqinter>\<^sup>\<gamma>"51) where "\<phi>\<^bold>\<sqinter>\<^sup>\<gamma>\<psi> \<equiv> \<lambda>x. \<phi> x \<^bold>\<and> \<psi> x"
  abbreviation negpred_delta::"\<delta>\<Rightarrow>\<delta>" ("\<inverse>\<^sup>\<delta>_"[52]53) where "\<inverse>\<^sup>\<delta>\<psi> \<equiv> \<lambda>x. \<not>(\<psi> x)"
  abbreviation negpred_gamma::"\<gamma>\<Rightarrow>\<gamma>" ("\<inverse>\<^sup>\<gamma>_"[52]53) where "\<inverse>\<^sup>\<gamma>\<psi> \<equiv> \<lambda>x. \<^bold>\<not>(\<psi> x)"
(**Definition of \<delta>/\<gamma>-Filter in modal context**)
  abbreviation filter_delta::"(\<delta>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("\<delta>-Filter") where "\<delta>-Filter \<Phi> \<equiv>
     \<^bold>U\<^sup>\<delta>\<^bold>\<in>\<^sup>\<delta>\<Phi> \<^bold>\<and> \<^bold>\<not>\<^bold>\<emptyset>\<^sup>\<delta>\<^bold>\<in>\<^sup>\<delta>\<Phi> \<^bold>\<and> (\<^bold>\<forall>\<phi> \<psi>.(\<phi>\<^bold>\<in>\<^sup>\<delta>\<Phi> \<^bold>\<and> \<phi>\<^bold>\<subseteq>\<^sup>\<delta>\<psi>) \<^bold>\<rightarrow> \<psi>\<^bold>\<in>\<^sup>\<delta>\<Phi>) \<^bold>\<and> (\<^bold>\<forall>\<phi> \<psi>.(\<phi>\<^bold>\<in>\<^sup>\<delta>\<Phi> \<^bold>\<and> \<psi>\<^bold>\<in>\<^sup>\<delta>\<Phi>) \<^bold>\<rightarrow> ((\<phi>\<^bold>\<sqinter>\<^sup>\<delta>\<psi>)\<^bold>\<in>\<^sup>\<delta>\<Phi>))"
  abbreviation filter_gamma::"(\<gamma>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("\<gamma>-Filter") where "\<gamma>-Filter \<Phi> \<equiv>
     \<^bold>U\<^sup>\<gamma>\<^bold>\<in>\<^sup>\<gamma>\<Phi> \<^bold>\<and> \<^bold>\<not>\<^bold>\<emptyset>\<^sup>\<gamma>\<^bold>\<in>\<^sup>\<gamma>\<Phi> \<^bold>\<and> (\<^bold>\<forall>\<phi> \<psi>.(\<phi>\<^bold>\<in>\<^sup>\<gamma>\<Phi> \<^bold>\<and> \<phi>\<^bold>\<subseteq>\<^sup>\<gamma>\<psi>) \<^bold>\<rightarrow> \<psi>\<^bold>\<in>\<^sup>\<gamma>\<Phi>) \<^bold>\<and> (\<^bold>\<forall>\<phi> \<psi>.(\<phi>\<^bold>\<in>\<^sup>\<gamma>\<Phi> \<^bold>\<and> \<psi>\<^bold>\<in>\<^sup>\<gamma>\<Phi>) \<^bold>\<rightarrow> ((\<phi>\<^bold>\<sqinter>\<^sup>\<gamma>\<psi>)\<^bold>\<in>\<^sup>\<gamma>\<Phi>))"
(**\<delta>/\<gamma>-Filter are consistent**)
  lemma cons_delta: "\<lfloor>\<^bold>\<forall>\<Phi> \<phi>. \<delta>-Filter \<Phi> \<^bold>\<rightarrow> \<^bold>\<not>(\<phi>\<^bold>\<in>\<^sup>\<delta>\<Phi> \<^bold>\<and> (\<inverse>\<^sup>\<delta>\<phi>)\<^bold>\<in>\<^sup>\<delta>\<Phi>)\<rfloor>" by fastforce
  lemma cons_gamma: "\<lfloor>\<^bold>\<forall>\<Phi> \<phi>. \<gamma>-Filter \<Phi> \<^bold>\<rightarrow> \<^bold>\<not>(\<phi>\<^bold>\<in>\<^sup>\<gamma>\<Phi> \<^bold>\<and> (\<inverse>\<^sup>\<gamma>\<phi>)\<^bold>\<in>\<^sup>\<gamma>\<Phi>)\<rfloor>" by fastforce
(**Definition of \<delta>/\<gamma>-Ultrafilter in modal context**)
  abbreviation ultrafilter_delta::"(\<delta>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("\<delta>-Ultrafilter") where
    "\<delta>-Ultrafilter \<Phi> \<equiv> \<delta>-Filter \<Phi> \<^bold>\<and> (\<^bold>\<forall>\<phi>. \<phi>\<^bold>\<in>\<^sup>\<delta>\<Phi> \<^bold>\<or> (\<inverse>\<^sup>\<delta>\<phi>)\<^bold>\<in>\<^sup>\<delta>\<Phi>)"
  abbreviation ultrafilter_gamma::"(\<gamma>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" ("\<gamma>-Ultrafilter") where
    "\<gamma>-Ultrafilter \<Phi> \<equiv> \<gamma>-Filter \<Phi> \<^bold>\<and> (\<^bold>\<forall>\<phi>. \<phi>\<^bold>\<in>\<^sup>\<gamma>\<Phi> \<^bold>\<or> (\<inverse>\<^sup>\<gamma>\<phi>)\<^bold>\<in>\<^sup>\<gamma>\<Phi>)"
end


header {* Euler Method on Affine Forms: Code *}
theory Euler_Affine_Code
imports
  Print
  "~~/src/HOL/Library/Monad_Syntax"
  "~~/src/HOL/Library/While_Combinator"
  "../Numerics/Runge_Kutta"
  "../../Affine_Arithmetic/Affine_Arithmetic"
begin

text{*\label{sec:euleraformcode}*}

record ('a, 'b, 'c) options =
  precision :: nat
  tolerance :: real
  stepsize :: real
  min_stepsize :: real
  iterations :: nat
  halve_stepsizes :: nat
  widening_mod :: nat
  max_tdev_thres :: real
  presplit_summary_tolerance :: real
  collect_mod :: nat
  collect_granularity :: real
  override_section :: "'a \<Rightarrow> real \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a * real"
  global_section :: "'b \<Rightarrow> ('a * real) option"
  stop_iteration :: "'b \<Rightarrow> bool"
  printing_fun :: "nat \<Rightarrow> real \<Rightarrow> 'b \<Rightarrow> unit"
  result_fun :: "nat * real * 'b * (real * 'b * real * 'b) list \<Rightarrow> 'c"

locale approximate_sets0 =
  fixes appr_of_ivl::"'a::{ordered_euclidean_space, executable_euclidean_space} \<Rightarrow> 'a \<Rightarrow> 'b"
  fixes msum_appr::"'b \<Rightarrow> 'b \<Rightarrow> 'b"
  fixes set_of_appr::"'b \<Rightarrow> 'a set"
  fixes set_of_apprs::"'b list \<Rightarrow> 'a list set"
  fixes inf_of_appr::"'b \<Rightarrow> 'a"
  fixes sup_of_appr::"'b \<Rightarrow> 'a"
  fixes add_appr::"('a, 'b, 'c) options \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b list \<Rightarrow> 'b option"
  fixes scale_appr::"('a, 'b, 'c) options \<Rightarrow> real \<Rightarrow> 'b \<Rightarrow> 'b list \<Rightarrow> 'b option"
  fixes scale_appr_ivl::"('a, 'b, 'c) options \<Rightarrow> real \<Rightarrow> real \<Rightarrow> 'b \<Rightarrow> 'b list \<Rightarrow> 'b option"
  fixes split_appr::"('a, 'b, 'c) options \<Rightarrow> 'b \<Rightarrow> 'b list"
  fixes disjoint_apprs::"'b \<Rightarrow> 'b \<Rightarrow> bool"
  fixes inter_appr_plane::"'b \<Rightarrow> 'a \<Rightarrow> real \<Rightarrow> 'b"
begin

text {* TODO: more conceptual refinement?! *}

definition ivl_appr_of_appr::"'b \<Rightarrow> 'b" where
  "ivl_appr_of_appr x = (appr_of_ivl (inf_of_appr x) (sup_of_appr x))"

end

declare approximate_sets0.ivl_appr_of_appr_def[code]

type_synonym 'a enclosure = "nat * real * 'a * (real * 'a * real * 'a) list"

locale approximate_ivp0 = approximate_sets0
  appr_of_ivl msum_appr set_of_appr set_of_apprs inf_of_appr sup_of_appr add_appr scale_appr scale_appr_ivl
  split_appr disjoint_apprs inter_appr_plane
for appr_of_ivl msum_appr set_of_appr set_of_apprs inf_of_appr
  and sup_of_appr::"'b \<Rightarrow> 'a::{ordered_euclidean_space, executable_euclidean_space}"
  and add_appr:: "('a, 'b, 'c) options \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b list \<Rightarrow> 'b option"
  and scale_appr scale_appr_ivl split_appr disjoint_apprs inter_appr_plane +
  fixes ode_approx::"('a, 'b, 'c) options \<Rightarrow> 'b \<Rightarrow> 'b option"
  fixes ode_d_approx:: "('a, 'b, 'c) options \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b option"
begin

abbreviation "extend_appr \<equiv> \<lambda>x l u. msum_appr x (appr_of_ivl l u)"

definition P_appr::"('a, 'b, 'c) options \<Rightarrow> 'b \<Rightarrow> real \<Rightarrow> 'b \<Rightarrow> 'b option" where
  "P_appr optns X0 h X = map_option (\<lambda>Y.
    extend_appr X0 (inf 0 (h *\<^sub>R inf_of_appr Y))
                   (sup  0 (h *\<^sub>R sup_of_appr Y)))
    (ode_approx optns X)"

fun P_iter::"('a, 'b, 'c) options \<Rightarrow> 'b \<Rightarrow> real \<Rightarrow> nat \<Rightarrow> 'b \<Rightarrow> 'b option" where
  "P_iter optns X0 h 0 X =
    (let _ = print (STR ''=P_iter failed: '');
      _ = print_eucl (inf_of_appr X);
      _ = print (STR '' - '');
      _ = print_eucl (sup_of_appr X);
      _ = println (STR '''') in None)"
| "P_iter optns X0 h (Suc i) X =
    bind_err (STR ''=P_appr failed'') (P_appr optns X0 h X) (\<lambda>X'.
      let (l', u') = (inf_of_appr X', sup_of_appr X') in
      let (l, u) = (inf_of_appr X, sup_of_appr X) in
      if l \<le> l' \<and> u' \<le> u then Some X
      else P_iter optns X0 h i (appr_of_ivl (inf l' l - (if i mod (widening_mod optns) = 0 then abs (l' - l) else 0)) (sup u' u + (if i mod widening_mod optns = 0 then abs (u' - u) else 0))))"

fun cert_stepsize::"('a, 'b, 'c) options \<Rightarrow> 'b \<Rightarrow> real \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (real * 'b) option" where
  "cert_stepsize optns X0 h n 0 = (let _ = println (STR ''=cert_stepsize failed'') in None)"
| "cert_stepsize optns X0 h n (Suc i) =
    (case P_iter optns (ivl_appr_of_appr X0) h n (ivl_appr_of_appr X0) of
      Some X' \<Rightarrow> Some (h, X')
    | None \<Rightarrow>
      let
        _ = print (STR ''=cert_stepsize failed on: '');
        _ = print_eucl (inf_of_appr X0);
        _ = print (STR '' - '');
        _ = print_eucl (sup_of_appr X0);
        _ = println (STR '''')
      in cert_stepsize optns X0 (h / 2) n i)"

lemma cert_stepsize_pos: "cert_stepsize optns X0 h n i = Some (h', cx) \<Longrightarrow> h > 0 \<Longrightarrow> h' > 0"
  by (induct i arbitrary: h h') (auto split: option.split_asm)

definition "euler_step optns X0 =
  bind_err (STR ''=certify stepsize failed'') (cert_stepsize optns X0 (stepsize optns) (iterations optns) (halve_stepsizes optns))
  (\<lambda>(h, CX).
      bind_err (STR ''=ode_approx X0 failed'') (ode_approx optns X0)
      (\<lambda>X0'.
        bind_err (STR ''=ode_approx CX failed'') (ode_approx optns CX)
        (\<lambda>F.
          bind_err (STR ''=ode_d_approx failed'') (ode_d_approx optns CX F)
          (\<lambda>D.
            bind_err (STR ''=scale_appr err failed'') (scale_appr optns ((h*h)/2) (ivl_appr_of_appr D) [])
            (\<lambda>ERR.
                bind_err (STR ''=scale_appr euler failed'') (scale_appr optns h X0' [X0])
                (\<lambda>S.
                  bind_err (STR ''=scale_appr_ivl euler failed'') (scale_appr_ivl optns 0 h X0' [X0])
                  (\<lambda>S'.
                    bind_err (STR ''=add_appr euler failed'') (add_appr optns X0 S [])
                    (\<lambda>X1.
                      bind_err (STR ''=add_appr euler_ivl failed'') (add_appr optns X0 S' [])
                      (\<lambda>CX1.
                        let
                          res = msum_appr X1 (ivl_appr_of_appr ERR);
                          res_ivl = msum_appr CX1 (appr_of_ivl (inf 0 (inf_of_appr ERR)) (sup 0 (sup_of_appr ERR)))
                        in
                        Some (h, res_ivl, res))))))))))"

fun advance_euler::"('a, 'b, 'c) options \<Rightarrow> 'b enclosure option \<Rightarrow> 'b enclosure option"
where
  "advance_euler optns None = None"
| "advance_euler optns (Some (i, t, X, XS)) =
    (case euler_step optns X of
      Some (h, CX, X1) \<Rightarrow>
        let _ = printing_fun optns i (t + h) X1
        in Some (Suc i, t + h, X1, (t, CX, t + h, X1)#XS)
    | None \<Rightarrow> None)"

primrec euler_series where
  "euler_series optns t0 X0 0 = Some (0, t0, X0, [])"
| "euler_series optns t0 X0 (Suc i) = advance_euler optns (euler_series optns t0 X0 i)"

subsection {* Checkpoint: Partition *}
text {* TODO: partitioning really needed when we do cancelling? *}

definition width_appr::"'b \<Rightarrow> real"
  where "width_appr x = infnorm (sup_of_appr x - inf_of_appr x)"

primrec split_appr_fp_iter where
  "split_appr_fp_iter optns XS 0 = XS"
| "split_appr_fp_iter optns XS (Suc i) =
    (let
      YS = concat (map (\<lambda>x.
        if width_appr x > max_tdev_thres optns
        then split_appr optns x
        else [x]) XS)
    in
      if length XS = length YS
      then YS
      else split_appr_fp_iter optns YS i)"

definition "split_appr_fp optns X = split_appr_fp_iter optns [X] 100"

primrec ivl_of_apprs::"'b list \<Rightarrow> 'b"
  where
  "ivl_of_apprs (x#xs) = (let
      i = fold (\<lambda>a b. inf (inf_of_appr a) b) xs (inf_of_appr x);
      s = fold (\<lambda>a b. sup (sup_of_appr a) b) xs (sup_of_appr x)
    in appr_of_ivl i s)"

definition partition
  where
 "partition optns r xs =
    (let
      rs = split_appr_fp (optns\<lparr>max_tdev_thres := collect_granularity optns\<rparr>) r;
      red_rs = map (\<lambda>r.
        case (filter (\<lambda>a. \<not> disjoint_apprs a r) xs) of [] \<Rightarrow> None
          | ds \<Rightarrow> let d = ivl_of_apprs ds
          in Some (appr_of_ivl (sup (inf_of_appr r) (inf_of_appr d)) (inf (sup_of_appr r) (sup_of_appr d)))) rs
    in map the (filter (-Option.is_none) red_rs))"

definition collect_apprs::"_ \<Rightarrow> 'b \<Rightarrow> 'b list \<Rightarrow> 'b list"
  where "collect_apprs optns r XS =
    (let
      _ = print (STR ''= Collecting: '');
      _ = print (int_to_string (length XS));
      _ = print (STR ''aforms ... '');
      YS = partition optns r XS;
      _ = print (STR ''= Collected to  '');
      _ = print (int_to_string (length YS));
      _ = println (STR '' aforms!'')
    in YS)"

definition collect_cancel_apprs::"('a, 'b, 'c) options \<Rightarrow> nat \<Rightarrow> 'b list \<Rightarrow> 'b list"
  where
  "collect_cancel_apprs optns i xs =
    (if i mod collect_mod optns = 0
    then let
      _ = println (STR ''Collect_cancelling:'');
      r = ivl_of_apprs xs;
      checkpoint_grid = collect_apprs optns r xs;
      _ = println (STR ''checkpoint grid:'');
      _ = map (\<lambda>x. printing_fun optns i 0 x) checkpoint_grid;
      steps = map (\<lambda>x. snd (snd (the (euler_step optns x)))) checkpoint_grid;
      _ = println (STR ''steps:'');
      _ = map (\<lambda>x. printing_fun optns i 0 x) steps;
      outside_checkpoint =
        filter (\<lambda>x. \<not> (inf_of_appr r \<le> inf_of_appr x \<and> sup_of_appr x \<le> sup_of_appr r)) steps;
      _ = println (STR ''outside_checkpoint:'');
      _ = map (\<lambda>x. printing_fun optns i 0 x) outside_checkpoint;
      inside_checkpoint =
        filter (\<lambda>x. (inf_of_appr r \<le> inf_of_appr x \<and> sup_of_appr x \<le> sup_of_appr r)) steps;
      _ = println (STR ''inside_checkpoint:'');
      _ = map (\<lambda>x. printing_fun optns i 0 x) inside_checkpoint;
      steps_grid = collect_apprs optns r steps;
      _ = println (STR ''steps_grid'');
      _ = map (\<lambda>x. printing_fun optns i 0 x) steps_grid;
      sg_not_cp_covered = fold (\<lambda>x xs. removeAll x xs) checkpoint_grid steps_grid;
      _ = println (STR ''sg_not_cp_covered'');
      _ = map (\<lambda>x. printing_fun optns i 0 x) sg_not_cp_covered;
      s_not_covered = filter (\<lambda>x. list_ex (- disjoint_apprs x) sg_not_cp_covered) steps;
      _ = println (STR ''s_not_covered'');
      _ = map (\<lambda>x. printing_fun optns i 0 x) s_not_covered
    in remdups (outside_checkpoint @ s_not_covered)
    else xs)"

text {* TODO: certify common stepsize first, and establish a common history of disjunctions of
  zonotopes *}

fun map_enclosure_option::
  "(nat \<Rightarrow> real \<Rightarrow> 'b \<Rightarrow> 'b list) \<Rightarrow> 'b enclosure option list \<Rightarrow> 'b enclosure option list"
  where
  "map_enclosure_option f [] = []"
| "map_enclosure_option f (None#xs) = (None # map_enclosure_option f xs)"
| "map_enclosure_option f (Some (i, t, X, XS)#xs) = map (\<lambda>X. Some (i, t, X, XS)) (f i t X) @ map_enclosure_option f xs"

definition "euler_lists optns t0 X0 t1 =
  while_option (list_ex (\<lambda>x. case x of Some (i, t, X, XS) \<Rightarrow> t < t1 | None \<Rightarrow> False))
    ((\<lambda>x. let _ = print (STR ''Affine Forms: ''); _ = println (int_to_string (length x)) in x) o
      (map_enclosure_option (\<lambda>i t x. split_appr_fp optns x)) o
      (\<lambda>x. case x of Some (i, t, X, XS)#_ \<Rightarrow> map (\<lambda>x. Some (i, t, x, XS)) (collect_cancel_apprs optns i (map (fst o snd o snd o the) x))
        | None#_ \<Rightarrow> []) o
      map (advance_euler optns)) [Some (0, t0, X0, [])]"

definition "euler_lists_result optns t0 X0 t1 =
  map_option (map (map_option (result_fun optns))) (euler_lists optns t0 X0 t1)"

definition euler_series_result::
  "('a, 'b, 'c) options \<Rightarrow> real \<Rightarrow> 'b \<Rightarrow> nat \<Rightarrow> 'c option"
  where [simp]: "euler_series_result optns t0 X0 i =
    map_option (result_fun optns) (euler_series optns t0 X0 i)"

lemma euler_series_print:
  "euler_series optns t0 X0 i =
    fold (\<lambda>a b.
      case b of
        None \<Rightarrow> None
      | Some (a', t0', X0', ress) \<Rightarrow>
        (case euler_step optns X0' of
          None \<Rightarrow> None
        | Some (h, CX, X1) \<Rightarrow>
          let
            _ = printing_fun optns a (t0' + h) X1
          in Some (Suc a', t0' + h, X1, (t0', CX, t0' + h, X1)#ress))) [0..<i] (Some (0, t0, X0, []))"
  unfolding Let_def
  by (induct i) (auto split: option.split)

definition "project_rect X b y =
  (let i = inf_of_appr X; s = sup_of_appr X in
  appr_of_ivl (i + (y - i \<bullet> b) *\<^sub>R b) (s + (y - s \<bullet> b) *\<^sub>R b))"

definition "sup_abs_appr X = sup (abs (inf_of_appr X)) (abs(sup_of_appr X))"

definition "intersects X b y \<longleftrightarrow> (inf_of_appr X \<bullet> b \<le> y \<and> sup_of_appr X \<bullet> b \<ge> y)"

text {* Precondition: X does not intersect b, but euler-step does! *}

primrec intersect'
  where
  "intersect' optns X b y h 0 = None"
| "intersect' optns X b y h (Suc i) =
    (let
      (h, CX, X1) = the (euler_step (optns\<lparr>stepsize:=h\<rparr>) X)
    in if intersects X1 b y then intersect' optns X b y (h*2) i else Some (inter_appr_plane CX b y))"

definition "intersect optns X b y = intersect' optns X b y (stepsize optns) 10"

definition "poincares2_step optns X0 b y =
  (let
    (h, CX, X1) = the (euler_step optns X0)
  in
    if intersects CX b y
    then the (intersect optns X0 b y)
    else X1
  )"

definition "strongest_direction optns f =
  (let
    af = sup_abs_appr f;
    (b, _) = fold (\<lambda>b (b', d'). if d' \<le> af \<bullet> b then (b, af \<bullet> b) else (b', d')) (Basis_list::'a list) 0;
    res = (if inf_of_appr f \<bullet> b < 0 \<and> sup_of_appr f \<bullet> b < 0 then (b, inf_of_appr f \<bullet> b)
      else if inf_of_appr f \<bullet> b > 0 \<and> sup_of_appr f \<bullet> b > 0 then (b, ((sup_of_appr f \<bullet> b)))
      else let _ = println (STR ''== ERROR finding next direction!'') in (0, 0))
  in res)"

definition "next_sections optns d Xs =
  (let
    set_dir_alist = map (\<lambda>X. (X, apsnd sgn (strongest_direction optns (the (ode_approx optns X))))) Xs;
    dirs = remdups (map snd set_dir_alist);
    dir_set_alist = map (\<lambda>bs. (bs, map fst (filter (\<lambda>(X, b, s). (b, s) = bs) set_dir_alist))) dirs;
    sctns = map (\<lambda>((b, s), Xs). if s = -1 then (Xs, (b, inf_of_appr (ivl_of_apprs Xs) \<bullet> b - d))
      else (Xs, (-b, - (sup_of_appr (ivl_of_apprs Xs) \<bullet> b + d))) ) dir_set_alist
  in
    map (\<lambda>(Xs, (b, s)). (Xs, override_section optns b s (inf_of_appr (ivl_of_apprs Xs)) (sup_of_appr (ivl_of_apprs Xs)))) sctns)"

definition "poincares2_iter optns X0 b y =
  while (list_ex (\<lambda>(X, b, y). \<not>stop_iteration optns X))
    (concat o (map (\<lambda>(X, b, y).
      let
        F = the (ode_approx optns X);
        (bs, fs) = strongest_direction optns F;
        (b, y) = (if bs = b then (b, y)
          else if fs \<le> 0 \<and> fs * 3 \<le> 4 * ((inf_of_appr F) \<bullet> b) then (bs, inf_of_appr X \<bullet> b)
          else if fs \<ge> 0 \<and> 4 * ((sup_of_appr F) \<bullet> b) \<le> fs * 3 then (bs, sup_of_appr X \<bullet> b)
          else (b, y));
        (b, y) = (case global_section optns X of None \<Rightarrow> (b, y)
          | Some (b, y) \<Rightarrow> (b, y));
        X1 = poincares2_step optns X b y;
        X1s = split_appr_fp optns X1
      in map (\<lambda>X. (X, b, y)) X1s)))"

definition "poincares optns X0s b y =
  while (\<lambda>(XS, PS, RS). XS \<noteq> [])
    (\<lambda>(XS, PS, RS).
      let
        _ = print (STR ''=XS: '');
        _ = print (int_to_string (length XS));
        _ = print (STR '' PS: '');
        _ = print (int_to_string (length PS));
        _ = print (STR '' RS: '');
        _ = print (int_to_string (length RS));
        _ = print (STR '' Flowing towards: '');
        _ = print_eucl b;
        _ = print (STR '' -- '');
        _ = print_real y;
        _ = println (STR '''');
        XS = concat (map (\<lambda>(h, X). map (Pair h) (split_appr_fp optns X)) XS);
        XS = filter (\<lambda>(h, X). inf_of_appr X \<bullet> b \<ge> y \<or> sup_of_appr X \<bullet> b \<ge> y) XS;
        _ = print (STR ''=XS above: '');
        _ = println (int_to_string (length XS));
        _ = map (printing_fun optns 0 0 o snd) XS;
        YS = map (\<lambda>(h, X). case (euler_step (optns\<lparr>stepsize:=h\<rparr>) X) of Some res \<Rightarrow> (h, X, res) | None \<Rightarrow> undefined) XS;
        (IS, NIS) = List.partition (\<lambda>(h, X0, t, CX, X). (inf_of_appr X \<bullet> b \<le> y \<or> sup_of_appr X \<bullet> b \<le> y)) YS;
        (RS', NIS) = List.partition (\<lambda>(_, _, _, _, X).
          list_ex (\<lambda>b'. b \<noteq> b' \<and>
              (let sa = sup_abs_appr (the (ode_approx optns X)) in abs (sa \<bullet> b) * 4 \<le> 3 * abs (sa \<bullet> b')))
            Basis_list) NIS;
        XS' = ''concat (map (%X. split_appr_fp (optns(|max_tdev_thres:=collect_granularity optns|)) X) (map fst IS)'';
        (IS1, IS2) = List.partition (\<lambda>(h, X0, t, CX, X). h \<le> min_stepsize optns) IS;
        IS2' = (map (\<lambda>(h, X0, t, CX, X). (h / 2, X0)) IS2);
        QS = map (\<lambda>(h, X0, t, CX, X). project_rect CX b y) IS1
      in (map (\<lambda>(h, X0, t, CX, X). (h, X)) (NIS @ IS1) @ IS2', PS@QS, RS @ map (snd o snd o snd o snd)RS')
    )
    (map (\<lambda>X. (stepsize optns, X)) X0s, [], [])" --{* Verbindung mit Euler, parametrisiert mit h! *}

definition "poincares_collected optns X0s b y =
  (case snd (poincares optns X0s b y) of ([], RS) \<Rightarrow> ([], RS)
    | (PS, RS) \<Rightarrow> (collect_apprs optns (ivl_of_apprs PS) PS, RS))"

definition "print_poincares optns X0s b y =
  (let (qs, rs) = poincares_collected optns X0s b y;
    _ = map (printing_fun optns 0 0) qs
   in (qs, rs))"

definition "poincare_distance_d optns X0s =
  while (list_ex (\<lambda>(XS, b, y). b \<noteq> 0))
    (\<lambda>groups. let _ = print (STR ''= Groups: ''); _ = println (int_to_string (length groups)) in concat (map (\<lambda>(Xs, b, y).
      if b = 0 then [(Xs, b, y)] else
      let
        (Ys, Rs) = print_poincares optns Xs b y;
        Yss = next_sections optns 2 Ys;
        Rss = next_sections optns 0 Rs;
        _ = print (STR ''= Ys: '');
        _ = print (int_to_string (length Yss));
        _ = print (STR '' Rss: '');
        _ = print (int_to_string (length Rss))
      in
        Yss@Rss) groups)
    ) (next_sections optns 2 X0s)"

definition "poincare_distance_d_print optns X0s =
  (let
    res = poincare_distance_d optns X0s;
    _ = print (STR ''= Returning: '');
    _ = print (int_to_string (length res));
    _ = println (STR '''');
    _ = map (printing_fun optns 0 0) (concat (map fst res))
  in res)"

end

declare approximate_ivp0.strongest_direction_def[code]
declare approximate_ivp0.poincares2_iter_def[code]
declare approximate_ivp0.poincares2_step_def[code]
declare approximate_ivp0.intersect_def[code]
declare approximate_ivp0.intersect'.simps[code]
declare approximate_ivp0.intersects_def[code]
declare approximate_ivp0.sup_abs_appr_def[code]
declare approximate_ivp0.project_rect_def[code]
declare approximate_ivp0.poincares_def[code]
declare approximate_ivp0.poincare_distance_d_def[code]
declare approximate_ivp0.poincare_distance_d_print_def[code]
declare approximate_ivp0.next_sections_def[code]
declare approximate_ivp0.poincares_collected_def[code]
declare approximate_ivp0.print_poincares_def[code]
declare approximate_ivp0.P_appr_def[code]
declare approximate_ivp0.P_iter.simps[code]
declare approximate_ivp0.cert_stepsize.simps[code]
declare approximate_ivp0.euler_step_def[code]
declare approximate_ivp0.advance_euler.simps[code]
declare approximate_ivp0.collect_cancel_apprs_def[code]
declare approximate_ivp0.euler_series_result_def[code]
declare approximate_ivp0.map_enclosure_option.simps[code]
declare approximate_ivp0.euler_lists_def[code]
declare approximate_ivp0.euler_lists_result_def[code]
declare approximate_ivp0.euler_series_print[code]
declare approximate_ivp0.collect_apprs_def[code]
declare approximate_ivp0.ivl_of_apprs.simps[code]
declare approximate_ivp0.partition_def[code]
declare approximate_ivp0.split_appr_fp_iter.simps[code]
declare approximate_ivp0.split_appr_fp_def[code]
declare approximate_ivp0.width_appr_def[code]

abbreviation "msum_aform' \<equiv> \<lambda>X. msum_aform (degree_aform X) X"

abbreviation "uncurry_options \<equiv> \<lambda>f x. f (precision x) (tolerance x)"

definition "split_aform_largest_uncond X =
    (let (i, x) = max_pdev (snd X) in split_aform X i)"

definition "split_aform_largest optns X =
  (let (a, b) =
      split_aform_largest_uncond (fst X,
        summarize_threshold (precision optns) (presplit_summary_tolerance optns)
          (degree_aform X) (snd X))
    in [a, b])"

text {* intersection with plane *}

definition inter_aform_plane where
  "inter_aform_plane X b y = X"

locale aform_approximate_sets0 =
  approximate_sets0
    aform_of_ivl msum_aform' Affine Joints
    Inf_aform Sup_aform
    "uncurry_options add_aform_componentwise::('a, 'a::executable_euclidean_space aform, (real \<times> ((real \<times> 'a \<times> 'a \<times> real \<times> 'a \<times> 'a) list))) options \<Rightarrow> _"
    "uncurry_options scaleR_aform_componentwise"
    "uncurry_options scaleR_aform_ivl"
    split_aform_largest
    disjoint_aforms
    inter_aform_plane

interpretation aform_approximate_sets0 .

locale aform_approximate_ivp0 =
  approximate_ivp0
    aform_of_ivl msum_aform' Affine Joints
    Inf_aform Sup_aform
    "uncurry_options add_aform_componentwise::('a, 'a::executable_euclidean_space aform, (real \<times> ((real \<times> 'a \<times> 'a \<times> real \<times> 'a \<times> 'a) list))) options \<Rightarrow> _"
    "uncurry_options scaleR_aform_componentwise"
    "uncurry_options scaleR_aform_ivl"
    split_aform_largest
    disjoint_aforms
    inter_aform_plane

interpretation aform_approximate_ivp0 x y for x y .

definition print_rectangle
  where
  "print_rectangle m i t0 X =
    (let
      _ = print (int_to_string i);
      _ = print (STR '': '');
      _ = print_real t0
    in
      if i mod m = 0 then
        let
          R = Radius X;
          _ = print (STR '': '');
          _ = print_eucl (fst X - R);
          _ = print (STR '' - '');
          _ = print_eucl (fst X + R);
          _ = print (STR ''; devs: '');
          _ = print (int_to_string (length (list_of_pdevs (snd X))));
          _ = print (STR ''; width: '');
          _ = print_real (infnorm R);
          _ = print (STR ''; tdev: '');
          _ = print_eucl R;
          _ = print (STR ''; maxdev: '');
          _ = print_eucl (snd (max_pdev (snd X)));
          _ = println (STR '''')
        in ()
      else println (STR ''''))"

definition print_aform::"'a::executable_euclidean_space aform \<Rightarrow> unit"
  where
  "print_aform X =
    (let
      _ = print (STR ''aform('');
      _ = print (int_to_string (length (Basis_list::'a list)));
      _ = print (STR ''): '');
      _ = print_eucl (fst X);
      _ = print (STR '' -- '');
      _ = map (\<lambda>(i, x). print_eucl x) (list_of_pdevs (snd X));
      _ = println (STR '''')
    in ())"

definition "ivls_of_aforms p ress = map (\<lambda>(t0, CX, t1, X).
    (t0, eucl_truncate_down p (Inf_aform CX), eucl_truncate_up p (Sup_aform CX), t1,
      eucl_truncate_down p (Inf_aform X), eucl_truncate_up p (Sup_aform X))) ress"

primrec summarize_ivls where
  "summarize_ivls [] = None"
| "summarize_ivls (x#xs) = (case summarize_ivls xs of
      None \<Rightarrow> Some x
    | Some (t0', cl', cu', t1', xl', xu') \<Rightarrow>
      case x of (t0, cl, cu, t1, xl, xu) \<Rightarrow>
      if t0 = t1' then
        Some (min t0 t0', inf cl cl', sup cu cu', max t1 t1',
          if t1 \<le> t1' then xl' else xl, if t1 \<le> t1' then xu' else xu)
      else None)"

fun "set_res_of_ivl_res"
where "set_res_of_ivl_res (t0, CXl, CXu, t1 ,Xl, Xu) = (t0, {CXl .. CXu}, t1, {Xl .. Xu})"

fun parts::"nat\<Rightarrow>'a list\<Rightarrow>'a list list"
where
  "parts n [] = []"
| "parts 0 xs = [xs]"
| "parts n xs = take n xs # parts n (drop n xs)"

definition summarize_enclosure
where "summarize_enclosure p m xs =
  map the (filter (-Option.is_none) (map summarize_ivls (parts m (ivls_of_aforms p xs))))"

definition "ivls_result p m = (apsnd (summarize_enclosure p m o snd)) o snd"

definition "default_optns =
    \<lparr>
    precision = 53,
    tolerance = FloatR 1 (- 8),
    stepsize  = FloatR 1 (- 8),
    min_stepsize = FloatR 1 (- 8),
    iterations = 40,
    halve_stepsizes = 10,
    widening_mod = 40,
    max_tdev_thres = FloatR 1 100,
    presplit_summary_tolerance = FloatR 1 0,
    collect_mod = 0,
    collect_granularity = FloatR 1 100,
    override_section = (\<lambda>_ _ _ _. (0, 0)),
    global_section = (\<lambda>_. None),
    stop_iteration = (\<lambda>_. False),
    printing_fun = (\<lambda>_ _. print_aform),
    result_fun = ivls_result 23 1
  \<rparr>"

end


theory Basic_Utils
  imports Term_Context
begin

primrec is_Inl where
  "is_Inl (Inl q) \<longleftrightarrow> True"
| "is_Inl (Inr q) \<longleftrightarrow> False"

primrec is_Inr where
  "is_Inr (Inr q) \<longleftrightarrow> True"
| "is_Inr (Inl q) \<longleftrightarrow> False"

fun remove_sum where
  "remove_sum (Inl q) = q"
| "remove_sum (Inr q) = q"

text \<open>List operations\<close>

definition filter_rev_nth where
  "filter_rev_nth P xs i = length (filter P (take (Suc i) xs)) - 1"

lemma filter_rev_nth_butlast:
  "\<not> P (last xs) \<Longrightarrow> filter_rev_nth P xs i = filter_rev_nth P (butlast xs) i"
  unfolding filter_rev_nth_def
  by (induct xs arbitrary: i rule: rev_induct) (auto simp add: take_Cons')

lemma filter_rev_nth_idx:
  assumes "i < length xs" "P (xs ! i)" "ys = filter P xs"
  shows "xs ! i = ys ! (filter_rev_nth P xs i) \<and> filter_rev_nth P xs i < length ys"
  using assms unfolding filter_rev_nth_def
proof (induct xs arbitrary: ys i)
  case (Cons x xs) show ?case
  proof (cases "P x")
    case True
    then obtain ys' where *:"ys = x # ys'" using Cons(4) by auto
    show ?thesis using True Cons(1)[of "i - 1" ys'] Cons(2-)
      unfolding *
      by (cases i) (auto simp: nth_Cons' take_Suc_conv_app_nth)
  next
    case False
    then show ?thesis using Cons(1)[of "i - 1" ys] Cons(2-)
      by (auto simp: nth_Cons')
  qed
qed auto

(*replace list_of_permutation_n with n_lists *)

primrec add_elem_list_lists :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
  "add_elem_list_lists x [] = [[x]]"
| "add_elem_list_lists x (y # ys) = (x # y # ys) # (map ((#) y) (add_elem_list_lists x ys))"

lemma length_add_elem_list_lists:
  "ys \<in> set (add_elem_list_lists x xs) \<Longrightarrow> length ys = Suc (length xs)"
  by (induct xs arbitrary: ys) auto

lemma add_elem_list_listsE:
  assumes "ys \<in> set (add_elem_list_lists x xs)"
  shows "\<exists> n \<le> length xs. ys = take n xs @ x # drop n xs" using assms
proof(induct xs arbitrary: ys)
  case (Cons a xs)
  then show ?case
    by auto fastforce
qed auto

lemma add_elem_list_listsI:
  assumes "n \<le> length xs" "ys = take n xs @ x # drop n xs"
  shows "ys \<in> set (add_elem_list_lists x xs)" using assms
proof  (induct xs arbitrary: ys n)
  case (Cons a xs)
  then show ?case
    by (cases n) (auto simp: image_iff)
qed auto

lemma add_elem_list_lists_def':
  "set (add_elem_list_lists x xs) = {ys | ys n. n \<le> length xs \<and> ys = take n xs @ x # drop n xs}"
  using add_elem_list_listsI add_elem_list_listsE
  by fastforce

fun list_of_permutation_element_n :: "'a \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
  "list_of_permutation_element_n x 0 L = [[]]"
|  "list_of_permutation_element_n x (Suc n) L = concat (map (add_elem_list_lists x) (List.n_lists n L))"

lemma list_of_permutation_element_n_conv:
  assumes "n \<noteq> 0"
  shows "set (list_of_permutation_element_n x n L) =
    {xs | xs i. i < length xs \<and> (\<forall> j < length xs. j \<noteq> i \<longrightarrow> xs ! j \<in> set L) \<and> length xs = n \<and> xs ! i = x}" (is "?Ls = ?Rs")
proof (intro equalityI)
  from assms obtain j where [simp]: "n = Suc j" using assms by (cases n) auto
  {fix ys assume "ys \<in> ?Ls"
    then obtain xs i where wit: "xs \<in> set (List.n_lists j L)" "i \<le> length xs"
      "ys = take i xs @ x # drop i xs"
      by (auto dest: add_elem_list_listsE)
    then have "i < length ys" "length ys = Suc (length xs)" "ys ! i = x"
      by (auto simp: nth_append)
    moreover have "\<forall> j < length ys. j \<noteq> i \<longrightarrow> ys ! j \<in> set L" using wit(1, 2)
      by (auto simp: wit(3) min_def nth_append set_n_lists)
    ultimately have "ys \<in> ?Rs" using wit(1) unfolding set_n_lists
      by auto}
  then show "?Ls \<subseteq> ?Rs" by blast
next
  {fix xs assume "xs \<in> ?Rs"
    then obtain i where wit: "i < length xs" "\<forall> j < length xs. j \<noteq> i \<longrightarrow> xs ! j \<in> set L"
      "length xs = n" "xs ! i = x"
      by blast
    then have *: "xs \<in> set (add_elem_list_lists (xs ! i) (take i xs @ drop (Suc i) xs))"
      unfolding add_elem_list_lists_def'
      by (auto simp: min_def intro!: nth_equalityI)
         (metis Cons_nth_drop_Suc Suc_pred append_Nil append_take_drop_id assms diff_le_self diff_self_eq_0 drop_take less_Suc_eq_le nat_less_le take0)
    have [simp]: "x \<in> set (take i xs) \<Longrightarrow> x \<in> set L"
      "x \<in> set (drop (Suc i) xs) \<Longrightarrow> x \<in> set L" for x using wit(2)
      by (auto simp: set_conv_nth)
    have "xs \<in> ?Ls" using wit
      by (cases "length xs")
         (auto simp: set_n_lists nth_append * min_def
               intro!: exI[of _ "take i xs @ drop (Suc i) xs"])}
  then show "?Rs \<subseteq> ?Ls" by blast
qed

lemma list_of_permutation_element_n_iff:
  "set (list_of_permutation_element_n x n L) =
    (if n = 0 then {[]} else {xs | xs i. i < length xs \<and> (\<forall> j < length xs. j \<noteq> i \<longrightarrow> xs ! j \<in> set L) \<and> length xs = n \<and> xs ! i = x})"
proof (cases n)
  case (Suc nat)
  then have [simp]: "Suc nat \<noteq> 0" by auto
  then show ?thesis
    by (auto simp: list_of_permutation_element_n_conv)
qed auto

lemma list_of_permutation_element_n_conv':
  assumes "x \<in> set L" "0 < n"
  shows "set (list_of_permutation_element_n x n L) =
      {xs. set xs \<subseteq> insert x (set L) \<and> length xs = n \<and> x \<in> set xs}"
proof -
  from assms(2) have *: "n \<noteq> 0" by simp
  show ?thesis using assms
    unfolding list_of_permutation_element_n_conv[OF *]
    by (auto simp: in_set_conv_nth)
       (metis in_set_conv_nth insert_absorb subsetD)+
qed

text \<open>Misc\<close>

lemma in_set_idx:
  "x \<in> set xs \<Longrightarrow> \<exists> i < length xs. xs ! i = x"
  by (induct xs) force+

lemma set_list_subset_eq_nth_conv:
  "set xs \<subseteq> A \<longleftrightarrow> (\<forall> i < length xs. xs ! i \<in> A)"
  by (metis in_set_conv_nth subset_code(1))

lemma map_eq_nth_conv:
  "map f xs = map g ys \<longleftrightarrow> length xs = length ys \<and> (\<forall> i < length ys. f (xs ! i) = g (ys ! i))"
  using map_eq_imp_length_eq[of f xs g ys]
  by (auto intro: nth_equalityI) (metis nth_map)

lemma nth_append_Cons: "(xs @ y # zs) ! i =
  (if i < length xs then xs ! i else if i = length xs then y else zs ! (i - Suc (length xs)))"
  by (cases i "length xs" rule: linorder_cases, auto simp: nth_append)

lemma map_prod_times:
  "f ` A \<times> g ` B = map_prod f g ` (A \<times> B)"
  by auto

lemma trancl_full_on: "(X \<times> X)\<^sup>+ = X \<times> X"
  using trancl_unfold_left[of "X \<times> X"] trancl_unfold_right[of "X \<times> X"] by auto

lemma trancl_map:
  assumes simu: "\<And>x y. (x, y) \<in> r \<Longrightarrow> (f x, f y) \<in> s"
    and steps: "(x, y) \<in> r\<^sup>+"
  shows "(f x, f y) \<in> s\<^sup>+" using steps
proof (induct)
  case (step y z) show ?case using step(3) simu[OF step(2)]
    by auto
qed (auto simp: simu)

lemma trancl_map_prod_mono:
  "map_both f ` R\<^sup>+ \<subseteq> (map_both f ` R)\<^sup>+"
proof -
  have "(f x, f y) \<in> (map_both f ` R)\<^sup>+" if "(x, y) \<in> R\<^sup>+" for x y using that
    by (induct) (auto intro: trancl_into_trancl)
  then show ?thesis by auto
qed

lemma trancl_map_both_Restr:
  assumes "inj_on f X"
  shows "(map_both f ` Restr R X)\<^sup>+ = map_both f ` (Restr R X)\<^sup>+"
proof -
  have [simp]:
    "map_prod (inv_into X f \<circ> f) (inv_into X f \<circ> f) ` Restr R X = Restr R X"
    using inv_into_f_f[OF assms]
    by (intro equalityI subrelI)
       (force simp: comp_def map_prod_def image_def split: prod.splits)+
  have [simp]:
    "map_prod (f \<circ> inv_into X f) (f \<circ> inv_into X f) ` (map_both f ` Restr R X)\<^sup>+ = (map_both f ` Restr R X)\<^sup>+"
    using f_inv_into_f[of _ f X] subsetD[OF trancl_mono_set[OF image_mono[of "Restr R X" "X \<times> X" "map_both f"]]]
    by (intro equalityI subrelI) (auto simp: map_prod_surj_on trancl_full_on comp_def rev_image_eqI)
  show ?thesis using assms trancl_map_prod_mono[of f "Restr R X"]
      image_mono[OF trancl_map_prod_mono[of "inv_into X f" "map_both f ` Restr R X"], of "map_both f"]
    by (intro equalityI) (simp_all add: image_comp map_prod.comp)
qed

lemma inj_on_trancl_map_both:
  assumes "inj_on f (fst ` R \<union> snd ` R)"
  shows "(map_both f ` R)\<^sup>+ = map_both f ` R\<^sup>+"
proof -
  have [simp]: "Restr R (fst ` R \<union> snd ` R) = R"
    by (force simp: image_def)
  then show ?thesis using assms
    using trancl_map_both_Restr[of f "fst ` R \<union> snd ` R" R]
    by simp
qed

lemma kleene_induct:
  "A \<subseteq> X \<Longrightarrow> B O X \<subseteq> X \<Longrightarrow> X O C \<subseteq> X \<Longrightarrow> B\<^sup>* O A O C\<^sup>* \<subseteq> X"
  using relcomp_mono[OF compat_tr_compat[of B X] subset_refl, of "C\<^sup>*"] compat_tr_compat[of "C\<inverse>" "X\<inverse>"]
    relcomp_mono[OF relcomp_mono, OF subset_refl _ subset_refl, of A X "B\<^sup>*" "C\<^sup>*"]
  unfolding rtrancl_converse converse_relcomp[symmetric] converse_mono by blast

lemma kleene_trancl_induct:
  "A \<subseteq> X \<Longrightarrow> B O X \<subseteq> X \<Longrightarrow> X O C \<subseteq> X \<Longrightarrow> B\<^sup>+ O A O C\<^sup>+ \<subseteq> X"
  using kleene_induct[of A X B C]
  by (auto simp: rtrancl_eq_or_trancl)
     (meson relcomp.relcompI subsetD trancl_into_rtrancl)

lemma rtrancl_Un2_separatorE:
  "B O A = {} \<Longrightarrow> (A \<union> B)\<^sup>* = A\<^sup>* \<union> A\<^sup>* O B\<^sup>*"
  by (metis R_O_Id empty_subsetI relcomp_distrib rtrancl_U_push rtrancl_reflcl_absorb sup_commute)

lemma trancl_Un2_separatorE:
  assumes "B O A = {}"
  shows "(A \<union> B)\<^sup>+ = A\<^sup>+ \<union> A\<^sup>+ O B\<^sup>+ \<union> B\<^sup>+" (is "?Ls = ?Rs")
proof -
  {fix x y assume "(x, y) \<in> ?Ls"
    then have "(x, y) \<in> ?Rs" using assms
    proof (induct)
      case (step y z)
      then show ?case
        by (auto simp add: trancl_into_trancl relcomp_unfold dest: tranclD2)
    qed auto}
  then show ?thesis
    by (auto simp add: trancl_mono)
       (meson sup_ge1 sup_ge2 trancl_mono trancl_trans)
qed

text \<open>Sum types where both components have the same type (to create copies)\<close>

lemma is_InrE:
  assumes "is_Inr q"
  obtains p where "q = Inr p"
  using assms by (cases q) auto

lemma is_InlE:
  assumes "is_Inl q"
  obtains p where "q = Inl p"
  using assms by (cases q) auto

lemma not_is_Inr_is_Inl [simp]:
  "\<not> is_Inl t \<longleftrightarrow> is_Inr t"
  "\<not> is_Inr t \<longleftrightarrow> is_Inl t"
  by (cases t, auto)+

abbreviation CInl :: "'q \<Rightarrow> 'q + 'q" where "CInl \<equiv> Inl"
abbreviation CInr :: "'q \<Rightarrow> 'q + 'q" where "CInr \<equiv> Inr"

lemma inj_CInl: "inj CInl" "inj CInr" using inj_Inl inj_Inr by blast+

lemma map_prod_simp': "map_prod f g G = (f (fst G), g (snd G))"
  by (auto simp add: map_prod_def split!: prod.splits)

end


section\<open>Sets\<close>
text\<open>While the default code generator setup for sets works fine, it does not make for particularly
readable code. The reason for this is that the default setup needs to work with potentially infinite
sets. All of the sets we need to use here are finite so we present an alternative setup for the
basic set operations which generates much cleaner code.\<close>

theory Code_Target_Set
  imports "HOL-Library.Cardinality"
begin

code_datatype set
declare List.union_coset_filter [code del]
declare insert_code [code del]
declare remove_code [code del]
declare card_coset_error [code del]
declare coset_subseteq_set_code [code del]
declare eq_set_code(1) [code del]
declare eq_set_code(2) [code del]
declare eq_set_code(4) [code del]
declare List.subset_code [code del]
declare inter_coset_fold [code del]
declare Cardinality.subset'_code [code del]

declare subset_eq [code]

(* Get rid of that one unnamed lemma *)
lemma [code del]:
  "x \<in> List.coset xs \<longleftrightarrow> \<not> List.member xs x"
  by (simp add: member_def)

lemma sup_set_append[code]: "(set x) \<union> (set y) = set (x @ y)"
  by simp

declare product_concat_map [code]

lemma [code]:
  "Cardinality.subset' (set l1) (set l2) = ((list_all (\<lambda>x. List.member l2 x)) l1)"
  by (meson in_set_member list.pred_set subset'_code(2))

end


theory Dev
imports "$HIPSTER_HOME/IsaHipster"

begin

setup Tactic_Data.set_induct_simp

datatype 'a Tree =
  Leaf 'a
  | Node "'a Tree""'a Tree"

ML\<open>

Sledgehammer.run_sledgehammer;
Toplevel.proof_of;

fun my_sledgehammer state minimiser =
  let
  (* val state = Toplevel.proof_of @{Isar.state} *)
  val thy =  Proof.theory_of state
  in
  Sledgehammer.run_sledgehammer
    (Sledgehammer_Commands.default_params thy [])
    Sledgehammer_Prover.Try
    NONE
    1
    Sledgehammer_Fact.no_fact_override
    minimiser
    state
  end;
\<close>
fun mirror :: "'a Tree => 'a Tree"
where
  "mirror (Leaf x) = Leaf x"
| "mirror (Node l r) = Node (mirror r) (mirror l)"

fun tmap :: "('a => 'b) => 'a Tree => 'b Tree"
where
  "tmap f (Leaf x) = Leaf (f x)"
| "tmap f (Node l r) = Node (tmap f l) (tmap f r)"

(* First call to Hipster: Explore tmap and mirror *)
(* hipster tmap mirror *)
lemma lemma_a [thy_expl]: "mirror (tmap x2 y2) = tmap x2 (mirror y2)"
apply (induct y2)
apply @{tactic }
done

lemma lemma_aa [thy_expl]: "mirror (mirror x2) = x2"
by hipster_induct_simp

end