theory Simple_Network_Language_Certificate_Code
  imports
    Simple_Network_Language_Certificate
    Simple_Network_Language_Certificate_Checking
begin

paragraph \<open>Optimized code equations\<close>

lemmas [code_unfold] = imp_for_imp_for'

definition dbm_subset'_impl'_int
  :: "nat \<Rightarrow> int DBMEntry Heap.array \<Rightarrow> int DBMEntry Heap.array \<Rightarrow> bool Heap"
  where [symmetric, int_folds]:
    "dbm_subset'_impl'_int = dbm_subset'_impl'"

lemma less_eq_dbm_le_int[int_folds]:
  "(\<le>) = dbm_le_int"
  unfolding dbm_le_dbm_le_int less_eq ..

schematic_goal dbm_subset'_impl'_int_code[code]:
  "dbm_subset'_impl'_int \<equiv> \<lambda>m a b.
    do {
    imp_for 0 ((m + 1) * (m + 1)) Heap_Monad.return
      (\<lambda>i _. do {
        x \<leftarrow> Array.nth a i; y \<leftarrow> Array.nth b i; Heap_Monad.return (dbm_le_int x y)
      })
      True
    }
"
  unfolding dbm_subset'_impl'_int_def[symmetric] dbm_subset'_impl'_def int_folds .

definition dbm_subset_impl_int
  :: "nat \<Rightarrow> int DBMEntry Heap.array \<Rightarrow> int DBMEntry Heap.array \<Rightarrow> bool Heap"
  where [symmetric, int_folds]:
    "dbm_subset_impl_int = dbm_subset_impl"

schematic_goal dbm_subset_impl_int_code[code]:
  "dbm_subset_impl_int \<equiv> ?i"
  unfolding dbm_subset_impl_int_def[symmetric] dbm_subset_impl_def
  unfolding int_folds
  .

lemmas [code_unfold] = int_folds

export_code state_space in SML module_name Test

hide_const Parser_Combinator.return
hide_const Error_Monad.return

definition
  "show_lit = String.implode o show"

definition "rename_state_space \<equiv> \<lambda>dc ids_to_names (broadcast, automata, bounds) L\<^sub>0 s\<^sub>0 formula.
  let _ = println (STR ''Make renaming'') in
  do {
    (m, num_states, num_actions, renum_acts, renum_vars, renum_clocks, renum_states,
      inv_renum_states, inv_renum_vars, inv_renum_clocks)
      \<leftarrow> make_renaming broadcast automata bounds;
    let _ = println (STR ''Renaming'');
    let (broadcast', automata', bounds') = rename_network
      broadcast bounds automata renum_acts renum_vars renum_clocks renum_states;
    let _ = println (STR ''Calculating ceiling'');
    let k = Simple_Network_Impl_nat_defs.local_ceiling broadcast' bounds' automata' m num_states;
    let _ = println (STR ''Running model checker'');
    let inv_renum_states' = (\<lambda>i. ids_to_names i o inv_renum_states i);
    let f = (\<lambda>show_clock
      show_state broadcast bounds' automata m num_states num_actions k L\<^sub>0 s\<^sub>0 formula.
      state_space broadcast bounds' automata m num_states num_actions k L\<^sub>0 s\<^sub>0 formula
        show_clock show_state ()
    );
    let r = do_rename_mc f dc broadcast bounds automata k STR ''_urge'' L\<^sub>0 s\<^sub>0 formula
      m num_states num_actions renum_acts renum_vars renum_clocks renum_states
      inv_renum_states' inv_renum_vars inv_renum_clocks;
    let show_clock = show o inv_renum_clocks;
    let show_state = (show_state :: _ \<Rightarrow> _ \<Rightarrow> _ \<times> int list \<Rightarrow> _) inv_renum_states inv_renum_vars;
    let renamings =
      (m, num_states, num_actions, renum_acts, renum_vars, renum_clocks, renum_states,
       inv_renum_states, inv_renum_vars, inv_renum_clocks
      );
    Result (r, show_clock, show_state, renamings, k)
  }"

definition
  "check_subsumed n xs (i :: int) M \<equiv>
  do {
    (_, b) \<leftarrow> imp_nfoldli xs (\<lambda>(_, b). return (\<not> b)) (\<lambda>M' (j, b).
      if i = j then return (j + 1, b) else do {
        b \<leftarrow> dbm_subset'_impl n M M';
        if b then return (j, True) else return (j + 1, False)
      }
    ) (0, False);
    return b
  }
"

definition
  "imp_filter_index P xs = do {
  (_, xs) \<leftarrow> imp_nfoldli xs (\<lambda>_. return True) (\<lambda>x (i :: nat, xs).
    do {
      b \<leftarrow> P i x;
      return (i + 1, if b then (x # xs) else xs)
    }
  ) (0, []);
  return (rev xs)
  }"

definition
  "filter_dbm_list n xs =
    imp_filter_index (\<lambda>i M. do {b \<leftarrow> check_subsumed n xs i M; return (\<not> b)}) xs"

partial_function (heap) imp_map :: "('a \<Rightarrow> 'b Heap) \<Rightarrow> 'a list \<Rightarrow> 'b list Heap" where
  "imp_map f xs =
  (if xs = [] then return [] else do {y \<leftarrow> f (hd xs); ys \<leftarrow> imp_map f (tl xs); return (y # ys)})"

lemma imp_map_simps[code, simp]:
  "imp_map f [] = return []"
  "imp_map f (x # xs) = do {y \<leftarrow> f x; ys \<leftarrow> imp_map f xs; return (y # ys)}"
  by (simp add: imp_map.simps)+

definition trace_state where
  "trace_state n show_clock show_state \<equiv>
  \<lambda> (l, M). do {
      let st = show_state l;
      m \<leftarrow> show_dbm_impl n show_clock show M;
      let s = ''(''  @ st @ '', ['' @ m @ ''])'';
      let s = String.implode s;
      let _ = println s;
      return ()
  }
" for show_clock show_state

definition
  "show_str = String.implode o show"

definition parse_convert_run_print where
  "parse_convert_run_print dc s \<equiv>
   case parse json s \<bind> convert of
     Error es \<Rightarrow> do {let _ = map println es; return ()}
   | Result (ids_to_names, _, broadcast, automata, bounds, formula, L\<^sub>0, s\<^sub>0) \<Rightarrow> do {
      let r = rename_state_space dc ids_to_names (broadcast, automata, bounds) L\<^sub>0 s\<^sub>0 formula;
      case r of
        Error es \<Rightarrow> do {let _ = map println es; return ()}
      | Result (r, show_clk, show_st, renamings, k) \<Rightarrow>
        case r of None \<Rightarrow> return () | Some r \<Rightarrow>
        do {
          r \<leftarrow> r;
          let _ = STR ''Number of discrete states: '' + (length r |> show_str) |> println;
          let _ =
            STR ''Size of passed list: '' + show_str (sum_list (map (length o snd) r)) |> println;
          let n = Simple_Network_Impl.clk_set' automata |> list_of_set |> length;
          r \<leftarrow> imp_map (\<lambda> (a, b). do {
              b \<leftarrow> imp_map (return o snd) b; b \<leftarrow> filter_dbm_list n b; return (a, b)
            }) r;
          let _ = STR ''Number of discrete states: '' + show_str (length r) |> println;
          let _ = STR ''Size of passed list after removing subsumed states: ''
            + show_str (sum_list (map (length o snd) r)) |> println;
          let show_dbm = (\<lambda>M. do {
            s \<leftarrow> show_dbm_impl_all n show_clk show M;
            return (''<'' @ s @ ''>'')
          });
          _ \<leftarrow> imp_map (\<lambda> (s, xs).
          do {
            let s = show_st s;
            xs \<leftarrow> imp_map show_dbm xs;
            let _ = s @ '': '' @ show xs |> String.implode |> println;
            return ()
          }
          ) r;
          return ()
        }
  }"

ML \<open>
structure Timing : sig
  val start_timer: unit -> unit
  val save_time: string -> unit
  val get_timings: unit -> (string * Time.time) list
end = struct
  val t = Unsynchronized.ref Time.zeroTime;
  val timings = Unsynchronized.ref [];
  fun start_timer () = (t := Time.now ());
  fun get_elapsed () = Time.- (Time.now (), !t);
  fun save_time s = (timings := ((s, get_elapsed ()) :: !timings));
  fun get_timings () = !timings;
end
\<close>

ML \<open>
fun print_timings () =
  let
    val tab = Timing.get_timings ();
    fun print_time (s, t) = writeln(s ^ ": " ^ Time.toString t);
  in map print_time tab end;
\<close>

code_printing
  constant "Show_State_Defs.tracei" \<rightharpoonup>
      (SML)   "(fn n => fn show_state => fn show_clock => fn typ => fn x => ()) _ _ _"
  and (OCaml) "(fun n show_state show_clock ty x -> ()) _ _ _"

datatype mode = Impl1 | Impl2 | Impl3 | Buechi | Debug

definition
  "distr xs \<equiv>
  let (m, d) =
  fold
    (\<lambda>x (m, d). case m x of None \<Rightarrow> (m(x \<mapsto> 1:: nat), x # d) | Some y \<Rightarrow> (m(x \<mapsto> (y + 1)), d))
    xs (Map.empty, [])
  in map (\<lambda>x. (x, the (m x))) (sort d)"

definition split_k'' :: "nat \<Rightarrow> ('a \<times> 'b list) list \<Rightarrow> ('a \<times> 'b list) list list" where
  "split_k'' k xs \<equiv> let
    width = sum_list (map (length o snd) xs) div k;
    width = (if length xs mod k = 0 then width else width + 1)
  in split_size (length o snd) width 0 [] xs"

definition
  "print_errors es = do {Heap_Monad.fold_map print_line_impl es; return ()}"

definition parse_convert_run_check where
  "parse_convert_run_check mode num_split dc s \<equiv>
   case parse json s \<bind> convert of
     Error es \<Rightarrow> print_errors es
   | Result (ids_to_names, _, broadcast, automata, bounds, formula, L\<^sub>0, s\<^sub>0) \<Rightarrow> do {
      let r = rename_state_space dc ids_to_names (broadcast, automata, bounds) L\<^sub>0 s\<^sub>0 formula;
      case r of
        Error es \<Rightarrow> print_errors es
      | Result (r, show_clk, show_st, renamings, k) \<Rightarrow>
        case r of None \<Rightarrow> return () | Some r \<Rightarrow> do {
        let t = now ();
        r \<leftarrow> r;
        let t = now () - t;
        print_line_impl
          (STR ''Time for model checking + certificate extraction: '' + time_to_string t);
        let (m,num_states,num_actions,renum_acts,renum_vars,renum_clocks,renum_states,
          inv_renum_states, inv_renum_vars, inv_renum_clocks
        ) = renamings;
        let _ = start_timer ();
        state_space \<leftarrow> Heap_Monad.fold_map (\<lambda>(s, xs).
          do {
            let xs = map snd xs;
            xs \<leftarrow> Heap_Monad.fold_map (dbm_to_list_impl m) xs;
            return (s, xs)
          }
        ) r;
        let _ = save_time STR ''Time for converting DBMs in certificate'';
        print_line_impl
          (STR ''Number of discrete states of state space: '' + show_lit (length state_space));
        let _ = STR ''Size of passed list: ''  + show_str (sum_list (map (length o snd) r))
          |> println;
        STR ''DBM list length distribution: '' + show_str (distr (map (length o snd) state_space))
          |> print_line_impl;
        let split =
          (if mode = Impl3 then split_k'' num_split state_space else split_k num_split state_space);
        let split_distr = map (sum_list o map (length o snd)) split;
        STR ''Size of passed list distribution after split: '' + show_str split_distr
          |> print_line_impl;
        let t = now ();
        check \<leftarrow> case mode of
          Debug \<Rightarrow> rename_check_dbg num_split dc broadcast bounds automata k L\<^sub>0 s\<^sub>0 formula
            m num_states num_actions renum_acts renum_vars renum_clocks renum_states
            inv_renum_states inv_renum_vars inv_renum_clocks
            state_space
        | Impl1 \<Rightarrow> rename_check num_split dc broadcast bounds automata k L\<^sub>0 s\<^sub>0 formula
            m num_states num_actions renum_acts renum_vars renum_clocks renum_states
            state_space
        | Impl2 \<Rightarrow> rename_check2 num_split dc broadcast bounds automata k L\<^sub>0 s\<^sub>0 formula
            m num_states num_actions renum_acts renum_vars renum_clocks renum_states
            state_space |> return
        | Impl3 \<Rightarrow> rename_check3 num_split dc broadcast bounds automata k L\<^sub>0 s\<^sub>0 formula
            m num_states num_actions renum_acts renum_vars renum_clocks renum_states
            state_space |> return;
        let t = now () - t;
        print_line_impl (STR ''Time for certificate checking: '' + time_to_string t);
        case check of
          Renaming_Failed \<Rightarrow> print_line_impl (STR ''Renaming failed'')
        | Preconds_Unsat \<Rightarrow> print_line_impl (STR ''Preconditions were not met'')
        | Sat \<Rightarrow> print_line_impl (STR ''Certificate was accepted'')
        | Unsat \<Rightarrow> print_line_impl (STR ''Certificate was rejected'')
        }
    }"

ML \<open>
  fun do_test dc file =
  let
    val s = file_to_string file;
  in
    @{code parse_convert_run_print} dc s end
\<close>

ML_val \<open>
  do_test true "/Users/wimmers/Formalizations/Timed_Automata/benchmarks/HDDI_02.muntax" ()
\<close>

ML_val \<open>
  do_test true "/Users/wimmers/Formalizations/Timed_Automata/benchmarks/HDDI_02_test.muntax" ()
\<close>

ML_val \<open>
  do_test true "/Users/wimmers/Formalizations/Timed_Automata/benchmarks/simple.muntax" ()
\<close>

ML_val \<open>
  do_test true "/Users/wimmers/Formalizations/Timed_Automata/benchmarks/light_switch.muntax" ()
\<close>

ML_val \<open>
  do_test true "/Users/wimmers/Formalizations/Timed_Automata/benchmarks/PM_test.muntax" ()
\<close>

ML_val \<open>
  do_test true "/Users/wimmers/Formalizations/Timed_Automata/benchmarks/bridge.muntax" ()
\<close>

ML_val \<open>
  do_test true "/Users/wimmers/Formalizations/Timed_Automata/benchmarks/PM_mod1.muntax" ()
\<close>

code_printing
  constant "parallel_fold_map" \<rightharpoonup>
      (SML)   "(fn f => fn xs => fn () => Par'_List.map (fn x => f x ()) xs) _ _"

definition
  "num_split \<equiv> 4 :: nat"

ML \<open>
  fun do_check dc file =
  let
    val s = file_to_string file;
  in
    @{code parse_convert_run_check} @{code Impl3} @{code num_split} dc s end
\<close>

(*
ML_val \<open>
  do_check false "/Users/wimmers/Formalizations/Timed_Automata/benchmarks/HDDI_02.muntax" ()
\<close>

ML_val \<open>
  do_check true "/Users/wimmers/Formalizations/Timed_Automata/benchmarks/HDDI_02.muntax" ()
\<close>

ML_val \<open>
  do_check true "/Users/wimmers/Formalizations/Timed_Automata/benchmarks/simple.muntax" ()
\<close>

ML_val \<open>
  do_check true "/Users/wimmers/Formalizations/Timed_Automata/benchmarks/light_switch.muntax" ()
\<close>

ML_val \<open>
  do_check false "/Users/wimmers/Formalizations/Timed_Automata/benchmarks/PM_test.muntax" ()
\<close>

ML_val \<open>
  do_check true "/Users/wimmers/Formalizations/Timed_Automata/benchmarks/PM_test.muntax" ()
\<close>

ML_val \<open>
  do_check true "/Users/wimmers/Formalizations/Timed_Automata/benchmarks/bridge.muntax" ()
\<close>
*)

ML_val \<open>
  do_check false "/Users/wimmers/Formalizations/Timed_Automata/benchmarks/PM_all_3.muntax" ()
\<close>

(*
ML_val \<open>
  do_check true "/Users/wimmers/Formalizations/Timed_Automata/benchmarks/PM_all_3.muntax" ()
\<close>
*)

text \<open>Executing \<open>Heap_Monad.fold_map\<close> in parallel in Isabelle/ML\<close>

definition
  \<open>Test \<equiv> Heap_Monad.fold_map (\<lambda>x. do {let _ = println STR ''x''; return x}) ([1,2,3] :: nat list)\<close>

ML_val \<open>@{code Test} ()\<close>

paragraph \<open>Checking external certificates\<close>

definition
  "list_of_json_object obj \<equiv>
  case obj of
    Object m \<Rightarrow> Result m
  | _ \<Rightarrow> Error [STR ''Not an object'']
"

definition
  "map_of_debug prefix m \<equiv>
    let m = map_of m in
    (\<lambda>x.
      case m x of
        None \<Rightarrow> let _ = println (STR ''Key error('' + prefix + STR ''): '' + show_lit x) in None
      | Some v \<Rightarrow> Some v)" for prefix

definition
  "renaming_of_json' opt prefix json \<equiv> do {
    vars \<leftarrow> list_of_json_object json;
    vars \<leftarrow> combine_map (\<lambda> (a, b). do {b \<leftarrow> of_nat b; Result (String.implode a, b)}) vars;
    let vars = vars @ (case opt of Some x \<Rightarrow> [(x, fold max (map snd vars) 0 + 1)] | _ \<Rightarrow> []);
    Result (the o map_of_debug prefix vars, the o map_of_debug prefix (map prod.swap vars))
  }
  " for json prefix

definition "renaming_of_json \<equiv> renaming_of_json' None"

definition
  "nat_renaming_of_json prefix max_id json \<equiv> do {
    vars \<leftarrow> list_of_json_object json;
    vars \<leftarrow> combine_map (\<lambda>(a, b). do {
      a \<leftarrow> parse lx_nat (String.implode a);
      b \<leftarrow> of_nat b;
      Result (a, b)
    }) vars;
    let ids = fst ` set vars;
    let missing = filter (\<lambda>i. i \<notin> ids) [0..<max_id];
    let m = the o map_of_debug prefix vars;
    let m = extend_domain m missing (length vars);
    Result (m, the o map_of_debug prefix (map prod.swap vars))
  }
  " for json prefix

definition convert_renaming ::
  "(nat \<Rightarrow> nat \<Rightarrow> String.literal) \<Rightarrow> (String.literal \<Rightarrow> nat) \<Rightarrow> JSON \<Rightarrow> _" where
  "convert_renaming ids_to_names process_names_to_index json \<equiv> do {
    json \<leftarrow> of_object json;
    vars \<leftarrow> get json ''vars'';
    (var_renaming, var_inv) \<leftarrow> renaming_of_json STR ''var renaming'' vars;
    clocks \<leftarrow> get json ''clocks'';
    (clock_renaming, clock_inv)
      \<leftarrow> renaming_of_json' (Some STR ''_urge'') STR ''clock renaming'' clocks;
    processes \<leftarrow> get json ''processes'';
    (process_renaming, process_inv) \<leftarrow> renaming_of_json STR ''process renaming'' processes;
    locations \<leftarrow> get json ''locations'';
    locations \<leftarrow> list_of_json_object locations; \<comment>\<open>process name \<rightarrow> json\<close>
    locations \<leftarrow> combine_map (\<lambda>(name, renaming). do {
        let p_num = process_names_to_index (String.implode name);
        assert
          (process_renaming (String.implode name) = p_num)
          (STR ''Process renamings do not agree on '' + String.implode name);
        let max_id = 1000;
        renaming \<leftarrow> nat_renaming_of_json (STR ''process'' + show_str p_num) max_id renaming;
          \<comment>\<open>location id \<rightarrow> nat\<close>
        Result (p_num, renaming)
      }
      ) locations;
    \<comment>\<open>process id \<rightarrow> location id \<rightarrow> nat\<close>
    let location_renaming = the o map_of_debug STR ''location'' (map (\<lambda>(i, f, _). (i, f)) locations);
    let location_inv = the o map_of_debug STR ''location inv''  (map (\<lambda>(i, _, f). (i, f)) locations);
    Result (var_renaming, clock_renaming, location_renaming, var_inv, clock_inv, location_inv)
  }
  "
  for json

definition
  "load_renaming dc model renaming \<equiv>
  case
  do {
    model \<leftarrow> parse json model;
    renaming \<leftarrow> parse json renaming;
    (ids_to_names, process_names_to_index, broadcast, automata, bounds, formula, L\<^sub>0, s\<^sub>0)
      \<leftarrow> convert model;
    convert_renaming ids_to_names process_names_to_index renaming
  }
  of
    Error e \<Rightarrow> return (Error e)
  | Result r \<Rightarrow> do {
    let (var_renaming, clock_renaming, location_renaming, _, _, _) = r;
    let _ = map (\<lambda>p. map (\<lambda>n. location_renaming p n |> show_lit |> println) [0..<8]) [0..<6];
    return (Result ())
  }
"

ML \<open>
  fun do_check dc model_file renaming_file =
  let
    val model = file_to_string model_file;
    val renaming = file_to_string renaming_file;
  in
    @{code load_renaming} dc model renaming end
\<close>

ML_val \<open>
  do_check
    true
    "/Users/wimmers/Code/mlunta/benchmarks/resources/csma_R_6.muntax"
    "/Users/wimmers/Scratch/certificates/csma.renaming"
    ()
\<close>

definition parse_compute where
  "parse_compute model renaming \<equiv>
   do {
    model \<leftarrow> parse json model;
    (ids_to_names, process_names_to_index, broadcast, automata, bounds, formula, L\<^sub>0, s\<^sub>0)
      \<leftarrow> convert model;
    renaming \<leftarrow> parse json renaming;
    (var_renaming, clock_renaming, location_renaming,
     inv_renum_vars, inv_renum_clocks, inv_renum_states)
      \<leftarrow> convert_renaming ids_to_names process_names_to_index renaming;
    (m, num_states, num_actions, renum_acts, renum_vars, renum_clocks, renum_states, _, _, _)
      \<leftarrow> make_renaming broadcast automata bounds;
    assert (renum_clocks STR ''_urge'' = m) STR ''Computed renaming: _urge is not last clock!'';
    let renum_vars = var_renaming;
    let renum_clocks = clock_renaming;
    let renum_states = location_renaming;
    assert (renum_clocks STR ''_urge'' = m) STR ''Given renaming: _urge is not last clock!'';
    let _ = println (STR ''Renaming'');
    let (broadcast', automata', bounds') = rename_network
      broadcast bounds automata renum_acts renum_vars renum_clocks renum_states;
    let _ = println (STR ''Calculating ceiling'');
    let k = Simple_Network_Impl_nat_defs.local_ceiling broadcast' bounds' automata' m num_states;
    let urgent_locations = map (\<lambda>(_, urgent, _, _). urgent) automata';
    Result (broadcast, bounds, automata, urgent_locations, k, L\<^sub>0, s\<^sub>0, formula,
          m, num_states, num_actions, renum_acts, renum_vars, renum_clocks, renum_states,
          inv_renum_states, inv_renum_vars, inv_renum_clocks)
   }" for num_split

datatype 'l state_space =
    Reachable_Set (reach_of: "(('l list \<times> int list) \<times> int DBMEntry list list) list")
  | Buechi_Set    (buechi_of: "(('l list \<times> int list) \<times> (int DBMEntry list \<times> nat) list) list")

definition normalize_dbm :: "nat \<Rightarrow> int DBMEntry list \<Rightarrow> int DBMEntry list" where
  "normalize_dbm m xs = do {
    dbm \<leftarrow> Array.of_list xs;
    dbm \<leftarrow> fw_impl_int m dbm;
    Array.freeze dbm
  } |> run_heap
  "

definition insert_every_nth :: "nat \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "insert_every_nth n a xs \<equiv>
    fold (\<lambda>x (i, xs). if i = n then (1, a # x # xs) else (i + 1, x # xs)) xs (1, []) |> snd |> rev"

definition convert_dbm where
  "convert_dbm urge m dbm =
    take m dbm @ Le 0 #
    insert_every_nth m DBMEntry.INF (drop m dbm)
    @ (if urge then Le 0 else DBMEntry.INF) # replicate (m - 1) DBMEntry.INF @ [Le 0]
  |> normalize_dbm m"

fun convert_state_space :: "_ \<Rightarrow> _ \<Rightarrow> int state_space \<Rightarrow> nat state_space" where
  "convert_state_space m is_urgent (Reachable_Set xs) = Reachable_Set (
    map (\<lambda>((locs, vars), dbms).
      ((map nat locs, vars), map (convert_dbm (is_urgent (locs, vars)) m) dbms))
    xs)"
| "convert_state_space m is_urgent (Buechi_Set xs) = Buechi_Set (
    map (\<lambda>((locs, vars), dbms).
      ((map nat locs, vars), map (\<lambda>(dbm, i). (convert_dbm (is_urgent (locs, vars)) m dbm, i)) dbms))
    xs)"

fun len_of_state_space where
  "len_of_state_space (Reachable_Set xs) = length xs"
| "len_of_state_space (Buechi_Set xs) = length xs"

context
  fixes num_clocks :: nat
  fixes inv_renum_states :: "nat \<Rightarrow> nat \<Rightarrow> nat"
    and inv_renum_vars   :: "nat \<Rightarrow> String.literal"
    and inv_renum_clocks :: "nat \<Rightarrow> String.literal"
begin

private definition show_st where
  "show_st = show_state inv_renum_states inv_renum_vars"

private definition show_dbm :: "int DBMEntry list \<Rightarrow> char list" where
  "show_dbm = dbm_list_to_string num_clocks (show_clock inv_renum_clocks) show"

fun show_state_space where
  "show_state_space (Reachable_Set xs) =
    map (\<lambda>(l, xs).
      map (\<lambda>x. ''('' @ show_st l @ '', <'' @ show_dbm x @ ''>)'' |> String.implode |> println) xs)
    xs"
| "show_state_space (Buechi_Set xs) =
    map (\<lambda>(l, xs).
      map (\<lambda>(x, i). show i @ '': ('' @ show_st l @ '', <'' @ show_dbm x @ ''>)''
            |> String.implode |> println)
      xs)
    xs"

end

definition
  "print_sep \<equiv> \<lambda>(). println (String.implode (replicate 100 CHR ''-''))"

definition parse_convert_check where
  "parse_convert_check mode num_split dc model renaming state_space show_cert \<equiv>
   let
     r = parse_compute model renaming
   in case r of Error es \<Rightarrow> do {let _ = map println es; return ()}
   | Result r \<Rightarrow> do {
      let (broadcast, bounds, automata, urgent_locations, k, L\<^sub>0, s\<^sub>0, formula,
        m, num_states, num_actions, renum_acts, renum_vars, renum_clocks, renum_states,
        inv_renum_states, inv_renum_vars, inv_renum_clocks) = r;
      let is_urgent = (\<lambda>(L, _). list_ex (\<lambda>(l, urgent). l \<in> set urgent) (zip L urgent_locations));
      let inv_renum_clocks = (\<lambda>i. if i = m then STR ''_urge'' else inv_renum_clocks i);
      let t = now ();
      let state_space = convert_state_space m is_urgent state_space;
      let t = now () - t;
      let _ = println (STR ''Time for converting state space: '' + time_to_string t);
      let _ = start_timer ();
      \<comment> \<open>XXX: What is going on here?\<close>
      let _ = save_time STR ''Time for converting DBMs in certificate'';
      let _ =
        println (STR ''Number of discrete states: ''+ show_lit (len_of_state_space state_space));
      let _ = do {
        if show_cert then do {
          let _ = print_sep ();
          let _ = println (STR ''Certificate'');
          let _ = print_sep ();
          let _ = show_state_space m inv_renum_states inv_renum_vars inv_renum_clocks state_space;
          let _ = print_sep ();
          return ()}
        else return ()
      };
      let t = now ();
      check \<leftarrow> case mode of
        Debug \<Rightarrow> rename_check_dbg num_split dc broadcast bounds automata k L\<^sub>0 s\<^sub>0 formula
            m num_states num_actions renum_acts renum_vars renum_clocks renum_states
            inv_renum_states inv_renum_vars inv_renum_clocks
            (reach_of state_space)
      | Impl1 \<Rightarrow> rename_check num_split dc broadcast bounds automata k L\<^sub>0 s\<^sub>0 formula
          m num_states num_actions renum_acts renum_vars renum_clocks renum_states
          (reach_of state_space)
      | Impl2 \<Rightarrow> rename_check2 num_split dc broadcast bounds automata k L\<^sub>0 s\<^sub>0 formula
          m num_states num_actions renum_acts renum_vars renum_clocks renum_states
          (reach_of state_space) |> return
      | Impl3 \<Rightarrow> rename_check3 num_split dc broadcast bounds automata k L\<^sub>0 s\<^sub>0 formula
          m num_states num_actions renum_acts renum_vars renum_clocks renum_states
          (reach_of state_space) |> return
      | Buechi \<Rightarrow> rename_check_buechi num_split broadcast bounds automata k L\<^sub>0 s\<^sub>0 formula
          m num_states num_actions renum_acts renum_vars renum_clocks renum_states
          (buechi_of state_space) |> return;
      let t = now () - t;
      let _ = println (STR ''Time for certificate checking: '' + time_to_string t);
      case check of
        Renaming_Failed \<Rightarrow> do {let _ = println STR ''Renaming failed''; return ()}
      | Preconds_Unsat \<Rightarrow> do {let _ = println STR ''Preconditions were not met''; return ()}
      | Sat \<Rightarrow> do {let _ = println STR ''Certificate was accepted''; return ()}
      | Unsat \<Rightarrow> do {let _ = println STR ''Certificate was rejected''; return ()}
    }
" for num_split and state_space :: "int state_space"

(* XXX This is a bug fix. Fix in Isabelle distribution *)
code_printing
  constant IArray.length' \<rightharpoonup> (SML) "(IntInf.fromInt o Vector.length)"

code_printing
  constant Parallel.map \<rightharpoonup> (SML) "Par'_List.map"

code_printing code_module "Timing" \<rightharpoonup> (SML)
\<open>
structure Timing : sig
  val start_timer: unit -> unit
  val save_time: string -> unit
  val get_timings: unit -> (string * Time.time) list
  val set_cpu: bool -> unit
end = struct

  open Timer;

  val is_cpu = Unsynchronized.ref false;
  fun set_cpu b = is_cpu := b;

  val cpu_timer: cpu_timer option Unsynchronized.ref = Unsynchronized.ref NONE;
  val real_timer: real_timer option Unsynchronized.ref = Unsynchronized.ref NONE;

  val timings = Unsynchronized.ref [];
  fun start_timer () = (
    if !is_cpu then
      cpu_timer := SOME (startCPUTimer ())
    else
      real_timer := SOME (startRealTimer ()));
  fun get_elapsed () = (
    if !is_cpu then
      #usr (!cpu_timer |> the |> checkCPUTimer)
    else
      (!real_timer |> the |> checkRealTimer));
  fun save_time s = (timings := ((s, get_elapsed ()) :: !timings));
  fun get_timings () = !timings;
end
\<close>

paragraph \<open>Optimized code printings\<close>

definition
  "array_freeze' = array_freeze"

lemma [code]: "array_freeze a = array_freeze' a"
  unfolding array_freeze'_def ..

definition
  "array_unfreeze' = array_unfreeze"

lemma [code]: "array_unfreeze a = array_unfreeze' a"
  unfolding array_unfreeze'_def ..

definition
  "array_copy' = array_copy"

lemma [code]: "array_copy a = array_copy' a"
  unfolding array_copy'_def ..

code_printing constant array_freeze' \<rightharpoonup> (SML) "(fn () => Array.vector _)"

code_printing constant array_unfreeze' \<rightharpoonup> (SML)
  "(fn a => fn () => Array.tabulate (Vector.length a, fn i => Vector.sub (a, i))) _"

code_printing constant array_copy' \<rightharpoonup> (SML)
  "(fn a => fn () => Array.tabulate (Array.length a, fn i => Array.sub (a, i))) _"

text \<open>According to microbenchmarks, these versions are nearly two times faster.\<close>

code_printing constant array_unfreeze' \<rightharpoonup> (SML)
"(fn a => fn () =>
  if Vector.length a = 0
  then Array.fromList []
  else
    let
      val x = Vector.sub(a, 0)
      val n = Array.array (Vector.length a, x)
      val '_ = Array.copyVec {src=a,dst=n,di=0}
    in n end
) _"

code_printing constant array_copy' \<rightharpoonup> (SML)
"(fn a => fn () =>
  if Array.length a = 0
  then Array.fromList []
  else
    let
      val x = Array.sub(a, 0)
      val n = Array.array (Array.length a, x)
      val '_ = Array.copy {src=a,dst=n,di=0}
    in n end
) _"

partial_function (heap) imp_for_int_inner ::
  "integer \<Rightarrow> integer \<Rightarrow> ('a \<Rightarrow> bool Heap) \<Rightarrow> (integer \<Rightarrow> 'a \<Rightarrow> 'a Heap) \<Rightarrow> 'a \<Rightarrow> 'a Heap" where
  "imp_for_int_inner i u c f s = (if i \<ge> u then return s else
    do {ctn <- c s; if ctn then f i s \<bind> imp_for_int_inner (i + 1) u c f else return s})"

lemma integer_of_nat_le_simp:
  "integer_of_nat i \<le> integer_of_nat u \<longleftrightarrow> i \<le> u"
  unfolding integer_of_nat_eq_of_nat by simp

lemma imp_for_imp_for_int_inner[code_unfold]:
  "imp_for i u c f s
  = imp_for_int_inner (integer_of_nat i) (integer_of_nat u) c (f o nat_of_integer) s"
  apply (induction "u - i" arbitrary: i u s)
   apply (simp add: integer_of_nat_le_simp imp_for_int_inner.simps; fail)
  apply (subst imp_for_int_inner.simps, simp add: integer_of_nat_le_simp)
  apply auto
  apply (fo_rule arg_cong, rule ext)
  apply clarsimp
  apply (fo_rule arg_cong)
  apply (auto simp: algebra_simps integer_of_nat_eq_of_nat)
  done

definition
  "imp_for_int i u c f s \<equiv>
  imp_for_int_inner (integer_of_nat i) (integer_of_nat u) c (f o nat_of_integer) s"

lemma imp_for_imp_for_int[code_unfold]:
  "imp_for = imp_for_int"
  by (intro ext, unfold imp_for_int_def imp_for_imp_for_int_inner, rule HOL.refl)

partial_function (heap) imp_for'_int_inner ::
  "integer \<Rightarrow> integer \<Rightarrow> (integer \<Rightarrow> 'a \<Rightarrow> 'a Heap) \<Rightarrow> 'a \<Rightarrow> 'a Heap" where
  "imp_for'_int_inner i u f s =
    (if i \<ge> u then return s else f i s \<bind> imp_for'_int_inner (i + 1) u f)"

lemma imp_for'_imp_for_int_inner:
  "imp_for' i u f s \<equiv>
  imp_for'_int_inner (integer_of_nat i) (integer_of_nat u) (f o nat_of_integer) s"
  apply (induction "u - i" arbitrary: i u s)
   apply (simp add: integer_of_nat_le_simp imp_for'_int_inner.simps; fail)
  apply (subst imp_for'_int_inner.simps, simp add: integer_of_nat_le_simp)
  apply auto
  apply (fo_rule arg_cong, rule ext)
  apply (auto simp: algebra_simps integer_of_nat_eq_of_nat)
  done

lemma imp_for'_int_cong:
  "imp_for' l u f a = imp_for' l u g a"
  if "\<And> i x. l \<le> i \<Longrightarrow> i < u \<Longrightarrow> f i x = g i x"
  using that
  apply (induction "u - l" arbitrary: l u a)
   apply (simp add: imp_for'.simps; fail)
  apply (subst imp_for'.simps, simp add: integer_of_nat_le_simp)
  apply safe
  apply clarsimp
  apply (fo_rule arg_cong)
  apply auto
  done

definition
  "imp_for'_int i u f s \<equiv>
  imp_for'_int_inner (integer_of_nat i) (integer_of_nat u) (f o nat_of_integer) s"

lemma imp_for'_imp_for_int[code_unfold, int_folds]:
  "imp_for' = imp_for'_int"
  by (intro ext, unfold imp_for'_int_def imp_for'_imp_for_int_inner, rule HOL.refl)

code_printing code_module "Iterators" \<rightharpoonup> (SML)
\<open>
fun imp_for_inner i u c f s =
  let
    fun imp_for1 i u f s =
      if IntInf.<= (u, i) then (fn () => s)
      else if c s () then imp_for1 (i + 1) u f (f i s ())
      else (fn () => s)
  in imp_for1 i u f s end;

fun imp_fora_inner i u f s =
  let
    fun imp_for1 i u f s =
      if IntInf.<= (u, i) then (fn () => s)
      else imp_for1 (i + 1) u f (f i s ())
  in imp_for1 i u f s end;
\<close>

code_reserved SML imp_for_inner imp_fora_inner
(* XXX How much do we gain from this? *)
(*
code_printing
  constant imp_for_int_inner \<rightharpoonup> (SML) "imp'_for'_inner"
| constant imp_for'_int_inner \<rightharpoonup> (SML) "imp'_fora'_inner"
*)

definition
  "nth_integer a n = Array.nth a (nat_of_integer n)"

definition
  "upd_integer n x a = Array.upd (nat_of_integer n) x a"

code_printing
  constant upd_integer \<rightharpoonup> (SML) "(fn a => fn () => (Array.update (a, IntInf.toInt _, _); a)) _"
| constant nth_integer \<rightharpoonup> (SML) "(fn () => Array.sub (_, IntInf.toInt _))"

definition
  "fw_upd_impl_integer n a k i j = do {
  let n = n + 1;
  let i' = i * n + j;
  y \<leftarrow> nth_integer a (i * n + k);
  z \<leftarrow> nth_integer a (k * n + j);
  x \<leftarrow> nth_integer a i';
  let m = dbm_add_int y z;
  if dbm_lt_int m x then upd_integer i' m a else return a
}
"

lemma nat_of_integer_add:
  "nat_of_integer i + nat_of_integer j = nat_of_integer (i + j)" if "i \<ge> 0" "j \<ge> 0"
proof -
  have *: "nat a + nat b = nat (a + b)" if "a \<ge> 0" "b \<ge> 0" for a b
    using that by simp
  show ?thesis
    unfolding nat_of_integer.rep_eq
    apply (simp add: *)
    apply (subst *)
    subgoal
      using zero_integer.rep_eq less_eq_integer.rep_eq that by metis
    subgoal
      using zero_integer.rep_eq less_eq_integer.rep_eq that by metis
    ..
qed

lemma nat_of_integer_mult:
  "nat_of_integer i * nat_of_integer j = nat_of_integer (i * j)" if "i \<ge> 0" "j \<ge> 0"
  using that
proof -
  have *: "nat a * nat b = nat (a * b)" if "a \<ge> 0" "b \<ge> 0" for a b
    using that by (simp add: nat_mult_distrib)
  show ?thesis
    unfolding nat_of_integer.rep_eq
    apply simp
    apply (subst *)
    subgoal
      using zero_integer.rep_eq less_eq_integer.rep_eq that by metis
    subgoal
      using zero_integer.rep_eq less_eq_integer.rep_eq that by metis
    ..
qed

lemma fw_upd_impl_int_fw_upd_impl_integer:
  "fw_upd_impl_int (nat_of_integer n) a (nat_of_integer k) (nat_of_integer i) (nat_of_integer j)
= fw_upd_impl_integer n a k i j"
  if "i \<ge> 0" "j \<ge> 0" "k \<ge> 0" "n \<ge> 0"
  unfolding
    fw_upd_impl_integer_def fw_upd_impl_int_def[symmetric] fw_upd_impl_def mtx_get_def mtx_set_def
  unfolding int_folds less
  unfolding nth_integer_def upd_integer_def fst_conv snd_conv
  using that
  apply (simp add: nat_of_integer_add nat_of_integer_mult algebra_simps)
  apply (fo_rule arg_cong | rule ext)+
  apply (simp add: nat_of_integer_add nat_of_integer_mult algebra_simps)
  done

lemma integer_of_nat_nat_of_integer:
  "integer_of_nat (nat_of_integer n) = n" if "n \<ge> 0"
  using that by (simp add: integer_of_nat_eq_of_nat max_def)

lemma integer_of_nat_aux:
  "integer_of_nat (nat_of_integer n + 1) = n + 1" if "n \<ge> 0"
proof -
  have "nat_of_integer n + 1 = nat_of_integer n + nat_of_integer 1"
    by simp
  also have "\<dots> = nat_of_integer (n + 1)"
    using that by (subst nat_of_integer_add; simp)
  finally show ?thesis
    using that by (simp add: integer_of_nat_nat_of_integer)
qed

definition
  "fwi_impl_integer n a k = fwi_impl_int (nat_of_integer n) a (nat_of_integer k)"

lemma fwi_impl_int_eq1:
  "fwi_impl_int n a k \<equiv> fwi_impl_integer (integer_of_nat n) a (integer_of_nat k)"
  unfolding fwi_impl_integer_def fwi_impl_int_def by simp

partial_function (heap) imp_for'_int_int ::
  "int \<Rightarrow> int \<Rightarrow> (int \<Rightarrow> 'a \<Rightarrow> 'a Heap) \<Rightarrow> 'a \<Rightarrow> 'a Heap" where
  "imp_for'_int_int i u f s =
    (if i \<ge> u then return s else f i s \<bind> imp_for'_int_int (i + 1) u f)"

lemma int_bounds_up_induct:
  assumes "\<And>l. u \<le> (l :: int) \<Longrightarrow> P l u"
      and "\<And>l. P (l + 1) u \<Longrightarrow> l < u \<Longrightarrow> P l u"
  shows "P l u"
  by (induction "nat (u - l)" arbitrary: l) (auto intro: assms)

lemma imp_for'_int_int_cong:
  "imp_for'_int_int l u f a = imp_for'_int_int l u g a"
  if "\<And> i x. l \<le> i \<Longrightarrow> i < u \<Longrightarrow> f i x = g i x"
  using that
  apply (induction arbitrary: a rule: int_bounds_up_induct)
   apply (simp add: imp_for'_int_int.simps; fail)
  apply (subst (2) imp_for'_int_int.simps)
  apply (subst imp_for'_int_int.simps)
  apply simp
  apply (fo_rule arg_cong, rule ext)
  .

lemma plus_int_int_of_integer_aux:
  "(plus_int (int_of_integer l) 1) = int_of_integer (l + 1)"
  by simp

lemma imp_for'_int_inner_imp_for'_int_int:
  "imp_for'_int_inner l u f a
= imp_for'_int_int (int_of_integer l) (int_of_integer u) (f o integer_of_int) a"
  apply (induction "int_of_integer l" "int_of_integer u" arbitrary: a l u rule: int_bounds_up_induct)
   apply (simp add: imp_for'_int_int.simps imp_for'_int_inner.simps less_eq_integer.rep_eq; fail)
  apply (subst imp_for'_int_int.simps)
  apply (subst imp_for'_int_inner.simps)
  apply (simp add: less_eq_integer.rep_eq)
  apply (fo_rule arg_cong, rule ext)
  apply (subst plus_int_int_of_integer_aux)
  apply rprems
  using plus_int_int_of_integer_aux by metis+

lemma imp_for'_int_inner_cong:
  "imp_for'_int_inner l u f a = imp_for'_int_inner l u g a"
  if "\<And> i x. l \<le> i \<Longrightarrow> i < u \<Longrightarrow> f i x = g i x"
  unfolding imp_for'_int_inner_imp_for'_int_int
  by (rule imp_for'_int_int_cong)(auto simp: less_eq_integer.rep_eq less_integer.rep_eq intro: that)

schematic_goal fwi_impl_int_unfold1:
  "fwi_impl_int (nat_of_integer n) a (nat_of_integer k) = ?i" if "0 \<le> k" "0 \<le> n"
  unfolding fwi_impl_int_def[symmetric] fwi_impl_def
  unfolding int_folds
  unfolding imp_for'_int_def
  unfolding comp_def integer_of_nat_0
  apply (rule imp_for'_int_inner_cong)
  apply (rule imp_for'_int_inner_cong)
  apply (rule fw_upd_impl_int_fw_upd_impl_integer)
  by (assumption | rule that)+

lemma integer_of_nat_add:
  "integer_of_nat (x + y) = integer_of_nat x + integer_of_nat y"
  by (simp add: integer_of_nat_eq_of_nat)

schematic_goal fwi_impl_int_code [code]:
  "fwi_impl_int n a k \<equiv> ?x"
  unfolding fwi_impl_int_eq1
  unfolding fwi_impl_integer_def
  apply (subst fwi_impl_int_unfold1)
    apply (simp add: integer_of_nat_eq_of_nat; fail)
   apply (simp add: integer_of_nat_eq_of_nat; fail)
  unfolding nat_of_integer_integer_of_nat
  unfolding integer_of_nat_add integer_of_nat_1
  apply (abstract_let "integer_of_nat n + 1" n_plus_1)
  apply (abstract_let "integer_of_nat n" n)
  .

code_printing code_module "Integer" \<rightharpoonup> (Eval)
\<open>
structure Integer: sig
  val div_mod: int -> int -> int * int
end = struct
  fun div_mod i j = (i div j, i mod j)
end
\<close>

text \<open>Delete ``junk''\<close>
code_printing code_module Bits_Integer \<rightharpoonup> (SML) \<open>\<close>

text \<open>For agreement with SML\<close>
code_printing
  type_constructor Typerep.typerep \<rightharpoonup> (Eval)
| constant Typerep.Typerep \<rightharpoonup> (Eval)
(*
code_printing
  type_constructor Typerep.typerep \<rightharpoonup> (Eval) "typerepa"
| constant Typerep.Typerep \<rightharpoonup> (Eval) "Typerep/ (_, _)"
*)

(* datatype typerepa = Typerep of string * typerepa list; *)

(* Speedup for Poly *)
(*
definition
  "fw_upd_impl_integer' = fw_upd_impl_integer"

lemma [code]:
  "fw_upd_impl_integer = fw_upd_impl_integer'"
  unfolding fw_upd_impl_integer'_def ..

code_printing
  constant fw_upd_impl_integer' \<rightharpoonup> (SML) "(fn n => fn a => fn k => fn i => fn j =>
  let
    val na = IntInf.+ (n, (1 : IntInf.int));
    val ia = IntInf.+ (IntInf.* (i, na), j);
    val x = Array.sub (a, IntInf.toInt ia);
    val y = Array.sub (a, IntInf.toInt (IntInf.+ (IntInf.* (i, na), k)));
    val z = Array.sub (a, IntInf.toInt (IntInf.+ (IntInf.* (k, na), j)));
    val m = dbm'_add'_int y z;
  in
    if dbm'_lt'_int m x
    then (fn () => (Array.update (a, IntInf.toInt ia, m); a))
    else (fn () => a)
  end) _ _ _ _ _"
*)

lemmas [code] = imp_for'_int_inner.simps imp_for_int_inner.simps

export_code parse_convert_check parse_convert_run_print parse_convert_run_check Result Error
  nat_of_integer int_of_integer DBMEntry.Le DBMEntry.Lt DBMEntry.INF
  Impl1 Impl2 Impl3 Buechi Debug Reachable_Set Buechi_Set
  E_op_impl
  in Eval module_name Model_Checker file "../ML/Certificate.ML"

export_code parse_convert_check parse_convert_run_print parse_convert_run_check Result Error
  nat_of_integer int_of_integer DBMEntry.Le DBMEntry.Lt DBMEntry.INF
  Impl1 Impl2 Impl3 Buechi Reachable_Set Buechi_Set
  E_op_impl
  in SML module_name Model_Checker file "../ML/Certificate.sml"

code_printing code_module "Printing" \<rightharpoonup> (Haskell)
\<open>
import qualified Debug.Trace;

print s = Debug.Trace.trace s ();

printM s = Debug.Trace.traceM s;
\<close>

code_printing
  constant Printing.print \<rightharpoonup> (Haskell) "Printing.print _"
(*
code_printing code_module "Timing" \<rightharpoonup> (Haskell)
\<open>
import Data.Time.Clock.System;

now = systemToTAITime . Prelude.unsafePerformIO getSystemTime;
\<close>
 *)

code_printing
  constant print_line_impl \<rightharpoonup> (Haskell) "Printing.printM _"

(* code_printing
  constant "now" \<rightharpoonup> (Haskell) "Prelude.const (Time (Int'_of'_integer 0)) _"

code_printing
  constant "time_to_string" \<rightharpoonup> (Haskell) "Prelude.show _"

code_printing
  constant "(-) :: time \<Rightarrow> time \<Rightarrow> time" \<rightharpoonup> (Haskell)
    "(case _ of Time a -> case _ of Time b -> Time (b - a))" *)

code_printing
  type_constructor time \<rightharpoonup> (Haskell) "Integer"
  | constant "now" \<rightharpoonup> (Haskell) "Prelude.const 0"
  | constant "time_to_string" \<rightharpoonup> (Haskell) "Prelude.show _"
  | constant "(-) :: time \<Rightarrow> time \<Rightarrow> time" \<rightharpoonup> (Haskell) "(-)"

code_printing
  constant list_of_set' \<rightharpoonup> (Haskell) "(case _ of Set xs -> xs)"

export_code parse_convert_check parse_convert_run_print parse_convert_run_check Result Error
  nat_of_integer int_of_integer DBMEntry.Le DBMEntry.Lt DBMEntry.INF
  Impl1 Impl2 Impl3 Buechi Reachable_Set Buechi_Set
  in Haskell module_name Model_Checker file "../Haskell/"

end


(*  Title:      HOL/HOLCF/Representable.thy
    Author:     Brian Huffman
*)

section \<open>Representable domains\<close>

theory Representable
imports Algebraic Map_Functions "~~/src/HOL/Library/Countable"
begin

default_sort cpo

subsection \<open>Class of representable domains\<close>

text \<open>
  We define a ``domain'' as a pcpo that is isomorphic to some
  algebraic deflation over the universal domain; this is equivalent
  to being omega-bifinite.

  A predomain is a cpo that, when lifted, becomes a domain.
  Predomains are represented by deflations over a lifted universal
  domain type.
\<close>

class predomain_syn = cpo +
  fixes liftemb :: "'a\<^sub>\<bottom> \<rightarrow> udom\<^sub>\<bottom>"
  fixes liftprj :: "udom\<^sub>\<bottom> \<rightarrow> 'a\<^sub>\<bottom>"
  fixes liftdefl :: "'a itself \<Rightarrow> udom u defl"

class predomain = predomain_syn +
  assumes predomain_ep: "ep_pair liftemb liftprj"
  assumes cast_liftdefl: "cast\<cdot>(liftdefl TYPE('a)) = liftemb oo liftprj"

syntax "_LIFTDEFL" :: "type \<Rightarrow> logic"  ("(1LIFTDEFL/(1'(_')))")
translations "LIFTDEFL('t)" \<rightleftharpoons> "CONST liftdefl TYPE('t)"

definition liftdefl_of :: "udom defl \<rightarrow> udom u defl"
  where "liftdefl_of = defl_fun1 ID ID u_map"

lemma cast_liftdefl_of: "cast\<cdot>(liftdefl_of\<cdot>t) = u_map\<cdot>(cast\<cdot>t)"
by (simp add: liftdefl_of_def cast_defl_fun1 ep_pair_def finite_deflation_u_map)

class "domain" = predomain_syn + pcpo +
  fixes emb :: "'a \<rightarrow> udom"
  fixes prj :: "udom \<rightarrow> 'a"
  fixes defl :: "'a itself \<Rightarrow> udom defl"
  assumes ep_pair_emb_prj: "ep_pair emb prj"
  assumes cast_DEFL: "cast\<cdot>(defl TYPE('a)) = emb oo prj"
  assumes liftemb_eq: "liftemb = u_map\<cdot>emb"
  assumes liftprj_eq: "liftprj = u_map\<cdot>prj"
  assumes liftdefl_eq: "liftdefl TYPE('a) = liftdefl_of\<cdot>(defl TYPE('a))"

syntax "_DEFL" :: "type \<Rightarrow> logic"  ("(1DEFL/(1'(_')))")
translations "DEFL('t)" \<rightleftharpoons> "CONST defl TYPE('t)"

instance "domain" \<subseteq> predomain
proof
  show "ep_pair liftemb (liftprj::udom\<^sub>\<bottom> \<rightarrow> 'a\<^sub>\<bottom>)"
    unfolding liftemb_eq liftprj_eq
    by (intro ep_pair_u_map ep_pair_emb_prj)
  show "cast\<cdot>LIFTDEFL('a) = liftemb oo (liftprj::udom\<^sub>\<bottom> \<rightarrow> 'a\<^sub>\<bottom>)"
    unfolding liftemb_eq liftprj_eq liftdefl_eq
    by (simp add: cast_liftdefl_of cast_DEFL u_map_oo)
qed

text \<open>
  Constants @{const liftemb} and @{const liftprj} imply class predomain.
\<close>

setup \<open>
  fold Sign.add_const_constraint
  [(@{const_name liftemb}, SOME @{typ "'a::predomain u \<rightarrow> udom u"}),
   (@{const_name liftprj}, SOME @{typ "udom u \<rightarrow> 'a::predomain u"}),
   (@{const_name liftdefl}, SOME @{typ "'a::predomain itself \<Rightarrow> udom u defl"})]
\<close>

interpretation predomain: pcpo_ep_pair liftemb liftprj
  unfolding pcpo_ep_pair_def by (rule predomain_ep)

interpretation "domain": pcpo_ep_pair emb prj
  unfolding pcpo_ep_pair_def by (rule ep_pair_emb_prj)

lemmas emb_inverse = domain.e_inverse
lemmas emb_prj_below = domain.e_p_below
lemmas emb_eq_iff = domain.e_eq_iff
lemmas emb_strict = domain.e_strict
lemmas prj_strict = domain.p_strict

subsection \<open>Domains are bifinite\<close>

lemma approx_chain_ep_cast:
  assumes ep: "ep_pair (e::'a::pcpo \<rightarrow> 'b::bifinite) (p::'b \<rightarrow> 'a)"
  assumes cast_t: "cast\<cdot>t = e oo p"
  shows "\<exists>(a::nat \<Rightarrow> 'a::pcpo \<rightarrow> 'a). approx_chain a"
proof -
  interpret ep_pair e p by fact
  obtain Y where Y: "\<forall>i. Y i \<sqsubseteq> Y (Suc i)"
  and t: "t = (\<Squnion>i. defl_principal (Y i))"
    by (rule defl.obtain_principal_chain)
  define approx where "approx i = (p oo cast\<cdot>(defl_principal (Y i)) oo e)" for i
  have "approx_chain approx"
  proof (rule approx_chain.intro)
    show "chain (\<lambda>i. approx i)"
      unfolding approx_def by (simp add: Y)
    show "(\<Squnion>i. approx i) = ID"
      unfolding approx_def
      by (simp add: lub_distribs Y t [symmetric] cast_t cfun_eq_iff)
    show "\<And>i. finite_deflation (approx i)"
      unfolding approx_def
      apply (rule finite_deflation_p_d_e)
      apply (rule finite_deflation_cast)
      apply (rule defl.compact_principal)
      apply (rule below_trans [OF monofun_cfun_fun])
      apply (rule is_ub_thelub, simp add: Y)
      apply (simp add: lub_distribs Y t [symmetric] cast_t)
      done
  qed
  thus "\<exists>(a::nat \<Rightarrow> 'a \<rightarrow> 'a). approx_chain a" by - (rule exI)
qed

instance "domain" \<subseteq> bifinite
by standard (rule approx_chain_ep_cast [OF ep_pair_emb_prj cast_DEFL])

instance predomain \<subseteq> profinite
by standard (rule approx_chain_ep_cast [OF predomain_ep cast_liftdefl])

subsection \<open>Universal domain ep-pairs\<close>

definition "u_emb = udom_emb (\<lambda>i. u_map\<cdot>(udom_approx i))"
definition "u_prj = udom_prj (\<lambda>i. u_map\<cdot>(udom_approx i))"

definition "prod_emb = udom_emb (\<lambda>i. prod_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
definition "prod_prj = udom_prj (\<lambda>i. prod_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"

definition "sprod_emb = udom_emb (\<lambda>i. sprod_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
definition "sprod_prj = udom_prj (\<lambda>i. sprod_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"

definition "ssum_emb = udom_emb (\<lambda>i. ssum_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
definition "ssum_prj = udom_prj (\<lambda>i. ssum_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"

definition "sfun_emb = udom_emb (\<lambda>i. sfun_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"
definition "sfun_prj = udom_prj (\<lambda>i. sfun_map\<cdot>(udom_approx i)\<cdot>(udom_approx i))"

lemma ep_pair_u: "ep_pair u_emb u_prj"
  unfolding u_emb_def u_prj_def
  by (simp add: ep_pair_udom approx_chain_u_map)

lemma ep_pair_prod: "ep_pair prod_emb prod_prj"
  unfolding prod_emb_def prod_prj_def
  by (simp add: ep_pair_udom approx_chain_prod_map)

lemma ep_pair_sprod: "ep_pair sprod_emb sprod_prj"
  unfolding sprod_emb_def sprod_prj_def
  by (simp add: ep_pair_udom approx_chain_sprod_map)

lemma ep_pair_ssum: "ep_pair ssum_emb ssum_prj"
  unfolding ssum_emb_def ssum_prj_def
  by (simp add: ep_pair_udom approx_chain_ssum_map)

lemma ep_pair_sfun: "ep_pair sfun_emb sfun_prj"
  unfolding sfun_emb_def sfun_prj_def
  by (simp add: ep_pair_udom approx_chain_sfun_map)

subsection \<open>Type combinators\<close>

definition u_defl :: "udom defl \<rightarrow> udom defl"
  where "u_defl = defl_fun1 u_emb u_prj u_map"

definition prod_defl :: "udom defl \<rightarrow> udom defl \<rightarrow> udom defl"
  where "prod_defl = defl_fun2 prod_emb prod_prj prod_map"

definition sprod_defl :: "udom defl \<rightarrow> udom defl \<rightarrow> udom defl"
  where "sprod_defl = defl_fun2 sprod_emb sprod_prj sprod_map"

definition ssum_defl :: "udom defl \<rightarrow> udom defl \<rightarrow> udom defl"
where "ssum_defl = defl_fun2 ssum_emb ssum_prj ssum_map"

definition sfun_defl :: "udom defl \<rightarrow> udom defl \<rightarrow> udom defl"
  where "sfun_defl = defl_fun2 sfun_emb sfun_prj sfun_map"

lemma cast_u_defl:
  "cast\<cdot>(u_defl\<cdot>A) = u_emb oo u_map\<cdot>(cast\<cdot>A) oo u_prj"
using ep_pair_u finite_deflation_u_map
unfolding u_defl_def by (rule cast_defl_fun1)

lemma cast_prod_defl:
  "cast\<cdot>(prod_defl\<cdot>A\<cdot>B) =
    prod_emb oo prod_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo prod_prj"
using ep_pair_prod finite_deflation_prod_map
unfolding prod_defl_def by (rule cast_defl_fun2)

lemma cast_sprod_defl:
  "cast\<cdot>(sprod_defl\<cdot>A\<cdot>B) =
    sprod_emb oo sprod_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo sprod_prj"
using ep_pair_sprod finite_deflation_sprod_map
unfolding sprod_defl_def by (rule cast_defl_fun2)

lemma cast_ssum_defl:
  "cast\<cdot>(ssum_defl\<cdot>A\<cdot>B) =
    ssum_emb oo ssum_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo ssum_prj"
using ep_pair_ssum finite_deflation_ssum_map
unfolding ssum_defl_def by (rule cast_defl_fun2)

lemma cast_sfun_defl:
  "cast\<cdot>(sfun_defl\<cdot>A\<cdot>B) =
    sfun_emb oo sfun_map\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo sfun_prj"
using ep_pair_sfun finite_deflation_sfun_map
unfolding sfun_defl_def by (rule cast_defl_fun2)

text \<open>Special deflation combinator for unpointed types.\<close>

definition u_liftdefl :: "udom u defl \<rightarrow> udom defl"
  where "u_liftdefl = defl_fun1 u_emb u_prj ID"

lemma cast_u_liftdefl:
  "cast\<cdot>(u_liftdefl\<cdot>A) = u_emb oo cast\<cdot>A oo u_prj"
unfolding u_liftdefl_def by (simp add: cast_defl_fun1 ep_pair_u)

lemma u_liftdefl_liftdefl_of:
  "u_liftdefl\<cdot>(liftdefl_of\<cdot>A) = u_defl\<cdot>A"
by (rule cast_eq_imp_eq)
   (simp add: cast_u_liftdefl cast_liftdefl_of cast_u_defl)

subsection \<open>Class instance proofs\<close>

subsubsection \<open>Universal domain\<close>

instantiation udom :: "domain"
begin

definition [simp]:
  "emb = (ID :: udom \<rightarrow> udom)"

definition [simp]:
  "prj = (ID :: udom \<rightarrow> udom)"

definition
  "defl (t::udom itself) = (\<Squnion>i. defl_principal (Abs_fin_defl (udom_approx i)))"

definition
  "(liftemb :: udom u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> udom u) = u_map\<cdot>prj"

definition
  "liftdefl (t::udom itself) = liftdefl_of\<cdot>DEFL(udom)"

instance proof
  show "ep_pair emb (prj :: udom \<rightarrow> udom)"
    by (simp add: ep_pair.intro)
  show "cast\<cdot>DEFL(udom) = emb oo (prj :: udom \<rightarrow> udom)"
    unfolding defl_udom_def
    apply (subst contlub_cfun_arg)
    apply (rule chainI)
    apply (rule defl.principal_mono)
    apply (simp add: below_fin_defl_def)
    apply (simp add: Abs_fin_defl_inverse finite_deflation_udom_approx)
    apply (rule chainE)
    apply (rule chain_udom_approx)
    apply (subst cast_defl_principal)
    apply (simp add: Abs_fin_defl_inverse finite_deflation_udom_approx)
    done
qed (fact liftemb_udom_def liftprj_udom_def liftdefl_udom_def)+

end

subsubsection \<open>Lifted cpo\<close>

instantiation u :: (predomain) "domain"
begin

definition
  "emb = u_emb oo liftemb"

definition
  "prj = liftprj oo u_prj"

definition
  "defl (t::'a u itself) = u_liftdefl\<cdot>LIFTDEFL('a)"

definition
  "(liftemb :: 'a u u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a u u) = u_map\<cdot>prj"

definition
  "liftdefl (t::'a u itself) = liftdefl_of\<cdot>DEFL('a u)"

instance proof
  show "ep_pair emb (prj :: udom \<rightarrow> 'a u)"
    unfolding emb_u_def prj_u_def
    by (intro ep_pair_comp ep_pair_u predomain_ep)
  show "cast\<cdot>DEFL('a u) = emb oo (prj :: udom \<rightarrow> 'a u)"
    unfolding emb_u_def prj_u_def defl_u_def
    by (simp add: cast_u_liftdefl cast_liftdefl assoc_oo)
qed (fact liftemb_u_def liftprj_u_def liftdefl_u_def)+

end

lemma DEFL_u: "DEFL('a::predomain u) = u_liftdefl\<cdot>LIFTDEFL('a)"
by (rule defl_u_def)

subsubsection \<open>Strict function space\<close>

instantiation sfun :: ("domain", "domain") "domain"
begin

definition
  "emb = sfun_emb oo sfun_map\<cdot>prj\<cdot>emb"

definition
  "prj = sfun_map\<cdot>emb\<cdot>prj oo sfun_prj"

definition
  "defl (t::('a \<rightarrow>! 'b) itself) = sfun_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"

definition
  "(liftemb :: ('a \<rightarrow>! 'b) u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> ('a \<rightarrow>! 'b) u) = u_map\<cdot>prj"

definition
  "liftdefl (t::('a \<rightarrow>! 'b) itself) = liftdefl_of\<cdot>DEFL('a \<rightarrow>! 'b)"

instance proof
  show "ep_pair emb (prj :: udom \<rightarrow> 'a \<rightarrow>! 'b)"
    unfolding emb_sfun_def prj_sfun_def
    by (intro ep_pair_comp ep_pair_sfun ep_pair_sfun_map ep_pair_emb_prj)
  show "cast\<cdot>DEFL('a \<rightarrow>! 'b) = emb oo (prj :: udom \<rightarrow> 'a \<rightarrow>! 'b)"
    unfolding emb_sfun_def prj_sfun_def defl_sfun_def cast_sfun_defl
    by (simp add: cast_DEFL oo_def sfun_eq_iff sfun_map_map)
qed (fact liftemb_sfun_def liftprj_sfun_def liftdefl_sfun_def)+

end

lemma DEFL_sfun:
  "DEFL('a::domain \<rightarrow>! 'b::domain) = sfun_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
by (rule defl_sfun_def)

subsubsection \<open>Continuous function space\<close>

instantiation cfun :: (predomain, "domain") "domain"
begin

definition
  "emb = emb oo encode_cfun"

definition
  "prj = decode_cfun oo prj"

definition
  "defl (t::('a \<rightarrow> 'b) itself) = DEFL('a u \<rightarrow>! 'b)"

definition
  "(liftemb :: ('a \<rightarrow> 'b) u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> ('a \<rightarrow> 'b) u) = u_map\<cdot>prj"

definition
  "liftdefl (t::('a \<rightarrow> 'b) itself) = liftdefl_of\<cdot>DEFL('a \<rightarrow> 'b)"

instance proof
  have "ep_pair encode_cfun decode_cfun"
    by (rule ep_pair.intro, simp_all)
  thus "ep_pair emb (prj :: udom \<rightarrow> 'a \<rightarrow> 'b)"
    unfolding emb_cfun_def prj_cfun_def
    using ep_pair_emb_prj by (rule ep_pair_comp)
  show "cast\<cdot>DEFL('a \<rightarrow> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<rightarrow> 'b)"
    unfolding emb_cfun_def prj_cfun_def defl_cfun_def
    by (simp add: cast_DEFL cfcomp1)
qed (fact liftemb_cfun_def liftprj_cfun_def liftdefl_cfun_def)+

end

lemma DEFL_cfun:
  "DEFL('a::predomain \<rightarrow> 'b::domain) = DEFL('a u \<rightarrow>! 'b)"
by (rule defl_cfun_def)

subsubsection \<open>Strict product\<close>

instantiation sprod :: ("domain", "domain") "domain"
begin

definition
  "emb = sprod_emb oo sprod_map\<cdot>emb\<cdot>emb"

definition
  "prj = sprod_map\<cdot>prj\<cdot>prj oo sprod_prj"

definition
  "defl (t::('a \<otimes> 'b) itself) = sprod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"

definition
  "(liftemb :: ('a \<otimes> 'b) u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> ('a \<otimes> 'b) u) = u_map\<cdot>prj"

definition
  "liftdefl (t::('a \<otimes> 'b) itself) = liftdefl_of\<cdot>DEFL('a \<otimes> 'b)"

instance proof
  show "ep_pair emb (prj :: udom \<rightarrow> 'a \<otimes> 'b)"
    unfolding emb_sprod_def prj_sprod_def
    by (intro ep_pair_comp ep_pair_sprod ep_pair_sprod_map ep_pair_emb_prj)
  show "cast\<cdot>DEFL('a \<otimes> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<otimes> 'b)"
    unfolding emb_sprod_def prj_sprod_def defl_sprod_def cast_sprod_defl
    by (simp add: cast_DEFL oo_def cfun_eq_iff sprod_map_map)
qed (fact liftemb_sprod_def liftprj_sprod_def liftdefl_sprod_def)+

end

lemma DEFL_sprod:
  "DEFL('a::domain \<otimes> 'b::domain) = sprod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
by (rule defl_sprod_def)

subsubsection \<open>Cartesian product\<close>

definition prod_liftdefl :: "udom u defl \<rightarrow> udom u defl \<rightarrow> udom u defl"
  where "prod_liftdefl = defl_fun2 (u_map\<cdot>prod_emb oo decode_prod_u)
    (encode_prod_u oo u_map\<cdot>prod_prj) sprod_map"

lemma cast_prod_liftdefl:
  "cast\<cdot>(prod_liftdefl\<cdot>a\<cdot>b) =
    (u_map\<cdot>prod_emb oo decode_prod_u) oo sprod_map\<cdot>(cast\<cdot>a)\<cdot>(cast\<cdot>b) oo
      (encode_prod_u oo u_map\<cdot>prod_prj)"
unfolding prod_liftdefl_def
apply (rule cast_defl_fun2)
apply (intro ep_pair_comp ep_pair_u_map ep_pair_prod)
apply (simp add: ep_pair.intro)
apply (erule (1) finite_deflation_sprod_map)
done

instantiation prod :: (predomain, predomain) predomain
begin

definition
  "liftemb = (u_map\<cdot>prod_emb oo decode_prod_u) oo
    (sprod_map\<cdot>liftemb\<cdot>liftemb oo encode_prod_u)"

definition
  "liftprj = (decode_prod_u oo sprod_map\<cdot>liftprj\<cdot>liftprj) oo
    (encode_prod_u oo u_map\<cdot>prod_prj)"

definition
  "liftdefl (t::('a \<times> 'b) itself) = prod_liftdefl\<cdot>LIFTDEFL('a)\<cdot>LIFTDEFL('b)"

instance proof
  show "ep_pair liftemb (liftprj :: udom u \<rightarrow> ('a \<times> 'b) u)"
    unfolding liftemb_prod_def liftprj_prod_def
    by (intro ep_pair_comp ep_pair_sprod_map ep_pair_u_map
       ep_pair_prod predomain_ep, simp_all add: ep_pair.intro)
  show "cast\<cdot>LIFTDEFL('a \<times> 'b) = liftemb oo (liftprj :: udom u \<rightarrow> ('a \<times> 'b) u)"
    unfolding liftemb_prod_def liftprj_prod_def liftdefl_prod_def
    by (simp add: cast_prod_liftdefl cast_liftdefl cfcomp1 sprod_map_map)
qed

end

instantiation prod :: ("domain", "domain") "domain"
begin

definition
  "emb = prod_emb oo prod_map\<cdot>emb\<cdot>emb"

definition
  "prj = prod_map\<cdot>prj\<cdot>prj oo prod_prj"

definition
  "defl (t::('a \<times> 'b) itself) = prod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"

instance proof
  show 1: "ep_pair emb (prj :: udom \<rightarrow> 'a \<times> 'b)"
    unfolding emb_prod_def prj_prod_def
    by (intro ep_pair_comp ep_pair_prod ep_pair_prod_map ep_pair_emb_prj)
  show 2: "cast\<cdot>DEFL('a \<times> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<times> 'b)"
    unfolding emb_prod_def prj_prod_def defl_prod_def cast_prod_defl
    by (simp add: cast_DEFL oo_def cfun_eq_iff prod_map_map)
  show 3: "liftemb = u_map\<cdot>(emb :: 'a \<times> 'b \<rightarrow> udom)"
    unfolding emb_prod_def liftemb_prod_def liftemb_eq
    unfolding encode_prod_u_def decode_prod_u_def
    by (rule cfun_eqI, case_tac x, simp, clarsimp)
  show 4: "liftprj = u_map\<cdot>(prj :: udom \<rightarrow> 'a \<times> 'b)"
    unfolding prj_prod_def liftprj_prod_def liftprj_eq
    unfolding encode_prod_u_def decode_prod_u_def
    apply (rule cfun_eqI, case_tac x, simp)
    apply (rename_tac y, case_tac "prod_prj\<cdot>y", simp)
    done
  show 5: "LIFTDEFL('a \<times> 'b) = liftdefl_of\<cdot>DEFL('a \<times> 'b)"
    by (rule cast_eq_imp_eq)
      (simp add: cast_liftdefl cast_liftdefl_of cast_DEFL 2 3 4 u_map_oo)
qed

end

lemma DEFL_prod:
  "DEFL('a::domain \<times> 'b::domain) = prod_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
by (rule defl_prod_def)

lemma LIFTDEFL_prod:
  "LIFTDEFL('a::predomain \<times> 'b::predomain) =
    prod_liftdefl\<cdot>LIFTDEFL('a)\<cdot>LIFTDEFL('b)"
by (rule liftdefl_prod_def)

subsubsection \<open>Unit type\<close>

instantiation unit :: "domain"
begin

definition
  "emb = (\<bottom> :: unit \<rightarrow> udom)"

definition
  "prj = (\<bottom> :: udom \<rightarrow> unit)"

definition
  "defl (t::unit itself) = \<bottom>"

definition
  "(liftemb :: unit u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> unit u) = u_map\<cdot>prj"

definition
  "liftdefl (t::unit itself) = liftdefl_of\<cdot>DEFL(unit)"

instance proof
  show "ep_pair emb (prj :: udom \<rightarrow> unit)"
    unfolding emb_unit_def prj_unit_def
    by (simp add: ep_pair.intro)
  show "cast\<cdot>DEFL(unit) = emb oo (prj :: udom \<rightarrow> unit)"
    unfolding emb_unit_def prj_unit_def defl_unit_def by simp
qed (fact liftemb_unit_def liftprj_unit_def liftdefl_unit_def)+

end

subsubsection \<open>Discrete cpo\<close>

instantiation discr :: (countable) predomain
begin

definition
  "(liftemb :: 'a discr u \<rightarrow> udom u) = strictify\<cdot>up oo udom_emb discr_approx"

definition
  "(liftprj :: udom u \<rightarrow> 'a discr u) = udom_prj discr_approx oo fup\<cdot>ID"

definition
  "liftdefl (t::'a discr itself) =
    (\<Squnion>i. defl_principal (Abs_fin_defl (liftemb oo discr_approx i oo (liftprj::udom u \<rightarrow> 'a discr u))))"

instance proof
  show 1: "ep_pair liftemb (liftprj :: udom u \<rightarrow> 'a discr u)"
    unfolding liftemb_discr_def liftprj_discr_def
    apply (intro ep_pair_comp ep_pair_udom [OF discr_approx])
    apply (rule ep_pair.intro)
    apply (simp add: strictify_conv_if)
    apply (case_tac y, simp, simp add: strictify_conv_if)
    done
  show "cast\<cdot>LIFTDEFL('a discr) = liftemb oo (liftprj :: udom u \<rightarrow> 'a discr u)"
    unfolding liftdefl_discr_def
    apply (subst contlub_cfun_arg)
    apply (rule chainI)
    apply (rule defl.principal_mono)
    apply (simp add: below_fin_defl_def)
    apply (simp add: Abs_fin_defl_inverse
        ep_pair.finite_deflation_e_d_p [OF 1]
        approx_chain.finite_deflation_approx [OF discr_approx])
    apply (intro monofun_cfun below_refl)
    apply (rule chainE)
    apply (rule chain_discr_approx)
    apply (subst cast_defl_principal)
    apply (simp add: Abs_fin_defl_inverse
        ep_pair.finite_deflation_e_d_p [OF 1]
        approx_chain.finite_deflation_approx [OF discr_approx])
    apply (simp add: lub_distribs)
    done
qed

end

subsubsection \<open>Strict sum\<close>

instantiation ssum :: ("domain", "domain") "domain"
begin

definition
  "emb = ssum_emb oo ssum_map\<cdot>emb\<cdot>emb"

definition
  "prj = ssum_map\<cdot>prj\<cdot>prj oo ssum_prj"

definition
  "defl (t::('a \<oplus> 'b) itself) = ssum_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"

definition
  "(liftemb :: ('a \<oplus> 'b) u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> ('a \<oplus> 'b) u) = u_map\<cdot>prj"

definition
  "liftdefl (t::('a \<oplus> 'b) itself) = liftdefl_of\<cdot>DEFL('a \<oplus> 'b)"

instance proof
  show "ep_pair emb (prj :: udom \<rightarrow> 'a \<oplus> 'b)"
    unfolding emb_ssum_def prj_ssum_def
    by (intro ep_pair_comp ep_pair_ssum ep_pair_ssum_map ep_pair_emb_prj)
  show "cast\<cdot>DEFL('a \<oplus> 'b) = emb oo (prj :: udom \<rightarrow> 'a \<oplus> 'b)"
    unfolding emb_ssum_def prj_ssum_def defl_ssum_def cast_ssum_defl
    by (simp add: cast_DEFL oo_def cfun_eq_iff ssum_map_map)
qed (fact liftemb_ssum_def liftprj_ssum_def liftdefl_ssum_def)+

end

lemma DEFL_ssum:
  "DEFL('a::domain \<oplus> 'b::domain) = ssum_defl\<cdot>DEFL('a)\<cdot>DEFL('b)"
by (rule defl_ssum_def)

subsubsection \<open>Lifted HOL type\<close>

instantiation lift :: (countable) "domain"
begin

definition
  "emb = emb oo (\<Lambda> x. Rep_lift x)"

definition
  "prj = (\<Lambda> y. Abs_lift y) oo prj"

definition
  "defl (t::'a lift itself) = DEFL('a discr u)"

definition
  "(liftemb :: 'a lift u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a lift u) = u_map\<cdot>prj"

definition
  "liftdefl (t::'a lift itself) = liftdefl_of\<cdot>DEFL('a lift)"

instance proof
  note [simp] = cont_Rep_lift cont_Abs_lift Rep_lift_inverse Abs_lift_inverse
  have "ep_pair (\<Lambda>(x::'a lift). Rep_lift x) (\<Lambda> y. Abs_lift y)"
    by (simp add: ep_pair_def)
  thus "ep_pair emb (prj :: udom \<rightarrow> 'a lift)"
    unfolding emb_lift_def prj_lift_def
    using ep_pair_emb_prj by (rule ep_pair_comp)
  show "cast\<cdot>DEFL('a lift) = emb oo (prj :: udom \<rightarrow> 'a lift)"
    unfolding emb_lift_def prj_lift_def defl_lift_def cast_DEFL
    by (simp add: cfcomp1)
qed (fact liftemb_lift_def liftprj_lift_def liftdefl_lift_def)+

end

end


(*  Title:       Integration of IsaFoR Terms
    Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2014
    Author:      Anders Schlichtkrull <andschl at dtu.dk>, 2017
    Maintainer:  Anders Schlichtkrull <andschl at dtu.dk>
*)

section \<open>Integration of \textsf{IsaFoR} Terms\<close>

text \<open>
This theory implements the abstract interface for atoms and substitutions using
the \textsf{IsaFoR} library (part of the AFP entry \<open>First_Order_Terms\<close>).
\<close>

theory IsaFoR_Term
  imports
    Deriving.Derive
    Ordered_Resolution_Prover.Abstract_Substitution
    First_Order_Terms.Unification
    First_Order_Terms.Subsumption
    "HOL-Cardinals.Wellorder_Extension"
    Open_Induction.Restricted_Predicates
begin

hide_const (open) mgu

abbreviation subst_apply_literal ::
  "('f, 'v) term literal \<Rightarrow> ('f, 'v, 'w) gsubst \<Rightarrow> ('f, 'w) term literal" (infixl "\<cdot>lit" 60) where
  "L \<cdot>lit \<sigma> \<equiv> map_literal (\<lambda>A. A \<cdot> \<sigma>) L"

definition subst_apply_clause ::
  "('f, 'v) term clause \<Rightarrow> ('f, 'v, 'w) gsubst \<Rightarrow> ('f, 'w) term clause" (infixl "\<cdot>cls" 60) where
  "C \<cdot>cls \<sigma> = image_mset (\<lambda>L. L \<cdot>lit \<sigma>) C"

abbreviation vars_lit :: "('f, 'v) term literal \<Rightarrow> 'v set" where
  "vars_lit L \<equiv> vars_term (atm_of L)"

definition vars_clause :: "('f, 'v) term clause \<Rightarrow> 'v set" where
  "vars_clause C = Union (set_mset (image_mset vars_lit C))"

definition vars_clause_list :: "('f, 'v) term clause list \<Rightarrow> 'v set" where
  "vars_clause_list Cs = Union (vars_clause ` set Cs) "

definition vars_partitioned :: "('f,'v) term clause list \<Rightarrow> bool" where
  "vars_partitioned Cs \<longleftrightarrow>
   (\<forall>i < length Cs. \<forall>j < length Cs. i \<noteq> j \<longrightarrow> (vars_clause (Cs ! i) \<inter> vars_clause (Cs ! j)) = {})"

lemma vars_clause_mono: "S \<subseteq># C \<Longrightarrow> vars_clause S \<subseteq> vars_clause C"
  unfolding vars_clause_def by auto

interpretation substitution_ops "(\<cdot>)" Var "(\<circ>\<^sub>s)" .

lemma is_ground_atm_is_ground_on_var:
  assumes "is_ground_atm (A \<cdot> \<sigma>)" and "v \<in> vars_term A"
  shows "is_ground_atm (\<sigma> v)"
using assms proof (induction A)
  case (Var x)
  then show ?case by auto
next
  case (Fun f ts)
  then show ?case unfolding is_ground_atm_def
    by auto
qed

lemma is_ground_lit_is_ground_on_var:
  assumes ground_lit: "is_ground_lit (subst_lit L \<sigma>)" and v_in_L: "v \<in> vars_lit L"
  shows "is_ground_atm (\<sigma> v)"
proof -
  let ?A = "atm_of L"
  from v_in_L have A_p: "v \<in> vars_term ?A"
    by auto
  then have "is_ground_atm (?A \<cdot> \<sigma>)"
    using ground_lit unfolding is_ground_lit_def by auto
  then show ?thesis
    using A_p is_ground_atm_is_ground_on_var by metis
qed

lemma is_ground_cls_is_ground_on_var:
  assumes
    ground_clause: "is_ground_cls (subst_cls C \<sigma>)" and
    v_in_C: "v \<in> vars_clause C"
  shows "is_ground_atm (\<sigma> v)"
proof -
  from v_in_C obtain L where L_p: "L \<in># C" "v \<in> vars_lit L"
    unfolding vars_clause_def by auto
  then have "is_ground_lit (subst_lit L \<sigma>)"
    using ground_clause unfolding is_ground_cls_def subst_cls_def by auto
  then show ?thesis
    using L_p is_ground_lit_is_ground_on_var by metis
qed

lemma is_ground_cls_list_is_ground_on_var:
  assumes ground_list: "is_ground_cls_list (subst_cls_list Cs \<sigma>)"
    and v_in_Cs: "v \<in> vars_clause_list Cs"
  shows "is_ground_atm (\<sigma> v)"
proof -
  from v_in_Cs obtain C where C_p: "C \<in> set Cs" "v \<in> vars_clause C"
    unfolding vars_clause_list_def by auto
  then have "is_ground_cls (subst_cls C \<sigma>)"
    using ground_list unfolding is_ground_cls_list_def subst_cls_list_def by auto
  then show ?thesis
    using C_p is_ground_cls_is_ground_on_var by metis
qed

lemma same_on_vars_lit:
  assumes "\<forall>v \<in> vars_lit L. \<sigma> v = \<tau> v"
  shows "subst_lit L \<sigma> = subst_lit L \<tau>"
  using assms
proof (induction L)
  case (Pos x)
  then have "\<forall>v \<in> vars_term x. \<sigma> v = \<tau> v \<Longrightarrow> subst_atm_abbrev x \<sigma> = subst_atm_abbrev x \<tau>"
    using term_subst_eq by metis+
  then show ?case
    unfolding subst_lit_def using Pos by auto
next
  case (Neg x)
  then have "\<forall>v \<in> vars_term x. \<sigma> v = \<tau> v \<Longrightarrow> subst_atm_abbrev x \<sigma> = subst_atm_abbrev x \<tau>"
    using term_subst_eq by metis+
  then show ?case
    unfolding subst_lit_def using Neg by auto
qed

lemma in_list_of_mset_in_S:
  assumes "i < length (list_of_mset S)"
  shows "list_of_mset S ! i \<in># S"
proof -
  from assms have "list_of_mset S ! i \<in> set (list_of_mset S)"
    by auto
  then have "list_of_mset S ! i \<in># mset (list_of_mset S)"
    by (meson in_multiset_in_set)
  then show ?thesis
    by auto
qed

lemma same_on_vars_clause:
  assumes "\<forall>v \<in> vars_clause S. \<sigma> v = \<tau> v"
  shows "subst_cls S \<sigma> = subst_cls S \<tau>"
  by (smt assms image_eqI image_mset_cong2 mem_simps(9) same_on_vars_lit set_image_mset
      subst_cls_def vars_clause_def)

lemma vars_partitioned_var_disjoint:
  assumes "vars_partitioned Cs"
  shows "var_disjoint Cs"
  unfolding var_disjoint_def
proof (intro allI impI)
  fix \<sigma>s :: \<open>('b \<Rightarrow> ('a, 'b) term) list\<close>
  assume "length \<sigma>s = length Cs"
  with assms[unfolded vars_partitioned_def] Fun_More.fun_merge[of "map vars_clause Cs" "nth \<sigma>s"]
  obtain \<sigma> where
    \<sigma>_p: "\<forall>i < length (map vars_clause Cs). \<forall>x \<in> map vars_clause Cs ! i. \<sigma> x = (\<sigma>s ! i) x"
    by auto
  have "\<forall>i < length Cs. \<forall>S. S \<subseteq># Cs ! i \<longrightarrow> subst_cls S (\<sigma>s ! i) = subst_cls S \<sigma>"
  proof (rule, rule, rule, rule)
    fix i :: nat and S :: "('a, 'b) term literal multiset"
    assume
      "i < length Cs" and
      "S \<subseteq># Cs ! i"
    then have "\<forall>v \<in> vars_clause S. (\<sigma>s ! i) v = \<sigma> v"
      using vars_clause_mono[of S "Cs ! i"] \<sigma>_p by auto
    then show "subst_cls S (\<sigma>s ! i) = subst_cls S \<sigma>"
      using same_on_vars_clause by auto
  qed
  then show "\<exists>\<tau>. \<forall>i<length Cs. \<forall>S. S \<subseteq># Cs ! i \<longrightarrow> subst_cls S (\<sigma>s ! i) = subst_cls S \<tau>"
    by auto
qed

lemma vars_in_instance_in_range_term:
  "vars_term (subst_atm_abbrev A \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
  by (induction A) auto

lemma vars_in_instance_in_range_lit: "vars_lit (subst_lit L \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
proof (induction L)
  case (Pos A)
  have "vars_term (A \<cdot> \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
    using vars_in_instance_in_range_term[of A \<sigma>] by blast
  then show ?case by auto
next
  case (Neg A)
  have "vars_term (A \<cdot> \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
    using vars_in_instance_in_range_term[of A \<sigma>] by blast
  then show ?case by auto
qed

lemma vars_in_instance_in_range_cls:
  "vars_clause (subst_cls C \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
  unfolding vars_clause_def subst_cls_def using vars_in_instance_in_range_lit[of _ \<sigma>] by auto

primrec renamings_apart :: "('f, nat) term clause list \<Rightarrow> (('f, nat) subst) list" where
  "renamings_apart [] = []"
| "renamings_apart (C # Cs) =
   (let \<sigma>s = renamings_apart Cs in
      (\<lambda>v. Var (v + Max (vars_clause_list (subst_cls_lists Cs \<sigma>s) \<union> {0}) + 1)) # \<sigma>s)"

definition var_map_of_subst :: "('f, nat) subst \<Rightarrow> nat \<Rightarrow> nat" where
  "var_map_of_subst \<sigma> v = the_Var (\<sigma> v)"

lemma len_renamings_apart: "length (renamings_apart Cs) = length Cs"
  by (induction Cs) (auto simp: Let_def)

lemma renamings_apart_is_Var: "\<forall>\<sigma> \<in> set (renamings_apart Cs). \<forall>x. is_Var (\<sigma> x)"
  by (induction Cs) (auto simp: Let_def)

lemma renamings_apart_inj: "\<forall>\<sigma> \<in> set (renamings_apart Cs). inj \<sigma>"
proof (induction Cs)
  case (Cons a Cs)
  then have "inj (\<lambda>v. Var (Suc (v + Max (vars_clause_list
               (subst_cls_lists Cs (renamings_apart Cs)) \<union> {0}))))"
    by (meson add_right_imp_eq injI nat.inject term.inject(1))
  then show ?case
    using Cons by (auto simp: Let_def)
qed auto

lemma finite_vars_clause[simp]: "finite (vars_clause x)"
  unfolding vars_clause_def by auto

lemma finite_vars_clause_list[simp]: "finite (vars_clause_list Cs)"
  unfolding vars_clause_list_def by (induction Cs) auto

lemma Suc_Max_notin_set: "finite X \<Longrightarrow> Suc (v + Max (insert 0 X)) \<notin> X"
  by (metis Max.boundedE Suc_n_not_le_n empty_iff finite.insertI le_add2 vimageE vimageI
      vimage_Suc_insert_0)

lemma vars_partitioned_Nil[simp]: "vars_partitioned []"
  unfolding vars_partitioned_def by auto

lemma subst_cls_lists_Nil[simp]: "subst_cls_lists Cs [] = []"
  unfolding subst_cls_lists_def by auto

lemma vars_clause_hd_partitioned_from_tl:
  assumes "Cs \<noteq>[]"
  shows "vars_clause (hd (subst_cls_lists Cs (renamings_apart Cs)))
    \<inter> vars_clause_list (tl (subst_cls_lists Cs (renamings_apart Cs))) = {}"
  using assms
proof (induction Cs)
  case (Cons C Cs)
  define \<sigma>' :: "nat \<Rightarrow> nat"
    where "\<sigma>' = (\<lambda>v. (Suc (v + Max ((vars_clause_list (subst_cls_lists Cs
                        (renamings_apart Cs))) \<union> {0}))))"
  define \<sigma> :: "nat \<Rightarrow> ('a, nat) term"
    where "\<sigma> = (\<lambda>v. Var (\<sigma>' v))"

  have "vars_clause (subst_cls C \<sigma>) \<subseteq> \<Union> (vars_term ` range \<sigma>)"
    using vars_in_instance_in_range_cls[of C "hd (renamings_apart (C # Cs))"] \<sigma>_def \<sigma>'_def
    by (auto simp: Let_def)
  moreover have "\<Union> (vars_term ` range \<sigma>)
    \<inter> vars_clause_list (subst_cls_lists Cs (renamings_apart Cs)) = {}"
  proof -
    have "range \<sigma>' \<inter> vars_clause_list (subst_cls_lists Cs (renamings_apart Cs)) = {}"
      unfolding \<sigma>'_def using Suc_Max_notin_set by auto
    then show ?thesis
      unfolding \<sigma>_def \<sigma>'_def by auto
  qed
  ultimately have "vars_clause (subst_cls C \<sigma>)
     \<inter> vars_clause_list (subst_cls_lists Cs (renamings_apart Cs)) = {}"
    by auto
  then show ?case
    unfolding \<sigma>_def \<sigma>'_def unfolding subst_cls_lists_def
    by (simp add: Let_def subst_cls_lists_def)
qed auto

lemma vars_partitioned_renamings_apart: "vars_partitioned (subst_cls_lists Cs (renamings_apart Cs))"
proof (induction Cs)
  case (Cons C Cs)
  {
    fix i :: nat and j :: nat
    assume ij:
      "i < Suc (length Cs)"
      "j < i"
    have "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
        vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
        {}"
    proof (cases i; cases j)
      fix j' :: nat
      assume i'j':
        "i = 0"
        "j = Suc j'"
      then show "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
        vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
        {}"
        using ij by auto
    next
      fix i' :: nat
      assume i'j':
        "i = Suc i'"
        "j = 0"
      have disjoin_C_Cs: "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! 0) \<inter>
        vars_clause_list ((subst_cls_lists Cs (renamings_apart Cs))) = {}"
        using vars_clause_hd_partitioned_from_tl[of "C # Cs"]
        by (simp add: Let_def subst_cls_lists_def)
      {
        fix x
        assume asm: "x \<in> vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i')"
        then have "(subst_cls_lists Cs (renamings_apart Cs) ! i')
          \<in> set (subst_cls_lists Cs (renamings_apart Cs))"
          using i'j' ij unfolding subst_cls_lists_def
          by (metis Suc_less_SucD length_map len_renamings_apart length_zip min_less_iff_conj
              nth_mem)
        moreover from asm have
          "x \<in> vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i')"
          using i'j' ij
          unfolding subst_cls_lists_def by simp
        ultimately have "\<exists>D \<in> set (subst_cls_lists Cs (renamings_apart Cs)). x \<in> vars_clause D"
            by auto
      }
      then have "vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i')
        \<subseteq> Union (set (map vars_clause ((subst_cls_lists Cs (renamings_apart Cs)))))"
        by auto
      then have "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! 0) \<inter>
        vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i') =
        {}" using disjoin_C_Cs unfolding vars_clause_list_def by auto
      moreover
      have "subst_cls_lists Cs (renamings_apart Cs) ! i' =
        subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i"
        using i'j' ij unfolding subst_cls_lists_def by (simp add: Let_def)
      ultimately
      show "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
        vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
        {}"
        using i'j' by (simp add: Int_commute)
    next
      fix i' :: nat and j' :: nat
      assume i'j':
        "i = Suc i'"
        "j = Suc j'"
      have "i'<length (subst_cls_lists Cs (renamings_apart Cs))"
        using ij i'j' unfolding subst_cls_lists_def by (auto simp: len_renamings_apart)
      moreover
      have "j'<length (subst_cls_lists Cs (renamings_apart Cs))"
        using ij i'j' unfolding subst_cls_lists_def by (auto simp: len_renamings_apart)
      moreover
      have "i' \<noteq> j'"
        using \<open>i = Suc i'\<close> \<open>j = Suc j'\<close> ij by blast
      ultimately
      have "vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i') \<inter>
          vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! j') =
          {}"
        using Cons unfolding vars_partitioned_def by auto
      then show "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
        vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
        {}"
        unfolding i'j'
        by (simp add: subst_cls_lists_def Let_def)
    next
      assume
        \<open>i = 0\<close> and
        \<open>j = 0\<close>
      then show \<open>vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
        vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
        {}\<close> using ij by auto
    qed
  }
  then show ?case
    unfolding vars_partitioned_def
    by (metis (no_types, lifting) Int_commute Suc_lessI len_renamings_apart length_map
        length_nth_simps(2) length_zip min.idem nat.inject not_less_eq subst_cls_lists_def)
qed auto

interpretation substitution "(\<cdot>)" "Var :: _ \<Rightarrow> ('f, nat) term" "(\<circ>\<^sub>s)" renamings_apart "Fun undefined"
proof (standard)
  show "\<And>A. A \<cdot> Var = A"
    by auto
next
  show "\<And>A \<tau> \<sigma>. A \<cdot> \<tau> \<circ>\<^sub>s \<sigma> = A \<cdot> \<tau> \<cdot> \<sigma>"
    by auto
next
  show "\<And>\<sigma> \<tau>. (\<And>A. A \<cdot> \<sigma> = A \<cdot> \<tau>) \<Longrightarrow> \<sigma> = \<tau>"
    by (simp add: subst_term_eqI)
next
  fix C :: "('f, nat) term clause"
  fix \<sigma>
  assume "is_ground_cls (subst_cls C \<sigma>)"
  then have ground_atms_\<sigma>: "\<And>v. v \<in> vars_clause C \<Longrightarrow> is_ground_atm (\<sigma> v)"
    by (meson is_ground_cls_is_ground_on_var)

  define some_ground_trm :: "('f, nat) term" where "some_ground_trm = (Fun undefined [])"
  have ground_trm: "is_ground_atm some_ground_trm"
    unfolding is_ground_atm_def some_ground_trm_def by auto
  define \<tau> where "\<tau> = (\<lambda>v. if v \<in> vars_clause C then \<sigma> v else some_ground_trm)"
  then have \<tau>_\<sigma>: "\<forall>v \<in> vars_clause C. \<sigma> v = \<tau> v"
    unfolding \<tau>_def by auto

  have all_ground_\<tau>: "is_ground_atm (\<tau> v)" for v
  proof (cases "v \<in> vars_clause C")
    case True
    then show ?thesis
      using ground_atms_\<sigma> \<tau>_\<sigma> by auto
  next
    case False
    then show ?thesis
      unfolding \<tau>_def using ground_trm by auto
  qed
  have "is_ground_subst \<tau>"
    unfolding is_ground_subst_def
  proof
    fix A
    show "is_ground_atm (subst_atm_abbrev A \<tau>)"
    proof (induction A)
      case (Var v)
      then show ?case using all_ground_\<tau> by auto
    next
      case (Fun f As)
      then show ?case using all_ground_\<tau>
        by (simp add: is_ground_atm_def)
    qed
  qed
  moreover have "\<forall>v \<in> vars_clause C. \<sigma> v = \<tau> v"
    using \<tau>_\<sigma> unfolding vars_clause_list_def
    by blast
  then have "subst_cls C \<sigma> = subst_cls C \<tau>"
    using same_on_vars_clause by auto
  ultimately show "\<exists>\<tau>. is_ground_subst \<tau> \<and> subst_cls C \<tau> = subst_cls C \<sigma>"
    by auto
next
  fix Cs :: "('f, nat) term clause list"
  show "length (renamings_apart Cs) = length Cs"
    using len_renamings_apart by auto
next
  fix Cs :: "('f, nat) term clause list"
  fix \<rho> ::  "nat \<Rightarrow> ('f, nat) Term.term"
  assume \<rho>_renaming: "\<rho> \<in> set (renamings_apart Cs)"
  {
    have inj_is_renaming:
      "\<And>\<sigma> :: ('f, nat) subst. (\<And>x. is_Var (\<sigma> x)) \<Longrightarrow> inj \<sigma> \<Longrightarrow> is_renaming \<sigma>"
    proof -
      fix \<sigma> :: "('f, nat) subst"
      fix x
      assume is_var_\<sigma>: "\<And>x. is_Var (\<sigma> x)"
      assume inj_\<sigma>: "inj \<sigma>"
      define \<sigma>' where "\<sigma>' = var_map_of_subst \<sigma>"
      have \<sigma>: "\<sigma> = Var \<circ> \<sigma>'"
        unfolding \<sigma>'_def var_map_of_subst_def using is_var_\<sigma> by auto

      from is_var_\<sigma> inj_\<sigma> have "inj \<sigma>'"
        unfolding is_renaming_def unfolding subst_domain_def inj_on_def \<sigma>'_def var_map_of_subst_def
         by (metis term.collapse(1))
      then have "inv \<sigma>' \<circ> \<sigma>' = id"
        using inv_o_cancel[of \<sigma>'] by simp
      then have "Var \<circ> (inv \<sigma>' \<circ> \<sigma>') = Var"
        by simp
      then have "\<forall>x. (Var \<circ> (inv \<sigma>' \<circ> \<sigma>')) x = Var x"
        by metis
      then have "\<forall>x. ((Var \<circ> \<sigma>') \<circ>\<^sub>s (Var \<circ> (inv \<sigma>'))) x = Var x"
        unfolding subst_compose_def by auto
      then have "\<sigma> \<circ>\<^sub>s (Var \<circ> (inv \<sigma>')) = Var"
        using \<sigma> by auto
      then show "is_renaming \<sigma>"
        unfolding is_renaming_def by blast
    qed
    then have "\<forall>\<sigma> \<in> (set (renamings_apart Cs)). is_renaming \<sigma>"
      using renamings_apart_is_Var renamings_apart_inj by blast
  }
  then show "is_renaming \<rho>"
    using \<rho>_renaming by auto
next
  fix Cs :: "('f, nat) term clause list"
  have "vars_partitioned (subst_cls_lists Cs (renamings_apart Cs))"
    using vars_partitioned_renamings_apart by auto
  then show "var_disjoint (subst_cls_lists Cs (renamings_apart Cs))"
    using vars_partitioned_var_disjoint by auto
next
  show "\<And>\<sigma> As Bs. Fun undefined As \<cdot> \<sigma> = Fun undefined Bs \<longleftrightarrow> map (\<lambda>A. A \<cdot> \<sigma>) As = Bs"
    by simp
next
  show "wfP (strictly_generalizes_atm :: ('f, 'v) term \<Rightarrow> _ \<Rightarrow> _)"
    unfolding wfP_def
    by (rule wf_subset[OF wf_subsumes])
      (auto simp: strictly_generalizes_atm_def generalizes_atm_def term_subsumable.subsumes_def
        subsumeseq_term.simps)
qed

fun pairs :: "'a list \<Rightarrow> ('a \<times> 'a) list" where
  "pairs (x # y # xs) = (x, y) # pairs (y # xs)" |
  "pairs _ = []"

derive compare "term"
derive compare "literal"

lemma class_linorder_compare: "class.linorder (le_of_comp compare) (lt_of_comp compare)"
  apply standard
      apply (simp_all add: lt_of_comp_def le_of_comp_def split: order.splits)
     apply (metis comparator.sym comparator_compare invert_order.simps(1) order.distinct(5))
    apply (metis comparator_compare comparator_def order.distinct(5))
   apply (metis comparator.sym comparator_compare invert_order.simps(1) order.distinct(5))
  by (metis comparator.sym comparator_compare invert_order.simps(2) order.distinct(5))

context begin
interpretation compare_linorder: linorder
  "le_of_comp compare"
  "lt_of_comp compare"
  by (rule class_linorder_compare)

definition Pairs where
  "Pairs AAA = concat (compare_linorder.sorted_list_of_set
     ((pairs \<circ> compare_linorder.sorted_list_of_set) ` AAA))"

lemma unifies_all_pairs_iff:
  "(\<forall>p \<in> set (pairs xs). fst p \<cdot> \<sigma> = snd p \<cdot> \<sigma>) \<longleftrightarrow> (\<forall>a \<in> set xs. \<forall>b \<in> set xs. a \<cdot> \<sigma> = b \<cdot> \<sigma>)"
proof (induct xs rule: pairs.induct)
  case (1 x y xs)
  then show ?case
    unfolding pairs.simps list.set ball_Un ball_simps simp_thms fst_conv snd_conv by metis
qed simp_all

lemma in_pair_in_set:
  assumes "(A,B) \<in> set ((pairs As))"
  shows "A \<in> set As \<and> B \<in> set As"
  using assms
proof (induction As)
  case (Cons A As)
  note Cons_outer = this
  show ?case
  proof (cases As)
    case Nil
    then show ?thesis
      using Cons_outer by auto
  next
    case (Cons B As')
    then show ?thesis using Cons_outer by auto
  qed
qed auto

lemma in_pairs_sorted_list_of_set_in_set:
  assumes
    "finite AAA"
    "\<forall>AA \<in> AAA. finite AA"
    "AB_pairs \<in> (pairs \<circ> compare_linorder.sorted_list_of_set) ` AAA" and
    "(A :: _ :: compare, B) \<in> set AB_pairs"
  shows "\<exists>AA. AA \<in> AAA \<and> A \<in> AA \<and> B \<in> AA"
proof -
  from assms have "AB_pairs \<in> (pairs \<circ> compare_linorder.sorted_list_of_set) ` AAA"
    by auto
  then obtain AA where
    AA_p: "AA \<in> AAA \<and> (pairs \<circ> compare_linorder.sorted_list_of_set) AA = AB_pairs"
    by auto
  have "(A, B) \<in> set (pairs (compare_linorder.sorted_list_of_set AA))"
    using AA_p[] assms(4) by auto
  then have "A \<in> set (compare_linorder.sorted_list_of_set AA)" and
    "B \<in> set (compare_linorder.sorted_list_of_set AA)"
    using in_pair_in_set[of A] by auto
  then show ?thesis
    using assms(2) AA_p by auto
qed

lemma unifiers_Pairs:
  assumes
    "finite AAA" and
    "\<forall>AA \<in> AAA. finite AA"
  shows "unifiers (set (Pairs AAA)) = {\<sigma>. is_unifiers \<sigma> AAA}"
proof (rule; rule)
  fix \<sigma> :: "('a, 'b) subst"
  assume asm: "\<sigma> \<in> unifiers (set (Pairs AAA))"
  have "\<And>AA. AA \<in> AAA \<Longrightarrow> card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<le> Suc 0"
  proof -
    fix AA :: "('a, 'b) term set"
    assume asm': "AA \<in> AAA"
    then have "\<forall>p \<in> set (pairs (compare_linorder.sorted_list_of_set AA)).
      subst_atm_abbrev (fst p) \<sigma> = subst_atm_abbrev (snd p) \<sigma>"
      using assms asm unfolding Pairs_def by auto
    then have "\<forall>A \<in> AA. \<forall>B \<in> AA. subst_atm_abbrev A \<sigma> = subst_atm_abbrev B \<sigma>"
      using assms asm' unfolding unifies_all_pairs_iff
      using compare_linorder.sorted_list_of_set by blast
    then show "card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<le> Suc 0"
      by (smt imageE card.empty card_Suc_eq card_mono finite.intros(1) finite_insert le_SucI
           singletonI subsetI)
  qed
  then show "\<sigma> \<in> {\<sigma>. is_unifiers \<sigma> AAA}"
    using assms by (auto simp: is_unifiers_def is_unifier_def subst_atms_def)
next
  fix \<sigma> :: "('a, 'b) subst"
  assume asm: "\<sigma> \<in> {\<sigma>. is_unifiers \<sigma> AAA}"

  {
    fix AB_pairs A B
    assume
      "AB_pairs \<in> set (compare_linorder.sorted_list_of_set
         ((pairs \<circ> compare_linorder.sorted_list_of_set) ` AAA))" and
      "(A, B) \<in> set AB_pairs"
    then have "\<exists>AA. AA \<in> AAA \<and> A \<in> AA \<and> B \<in> AA"
      using assms by (simp add: in_pairs_sorted_list_of_set_in_set)
    then obtain AA where
     a: "AA \<in> AAA" "A \<in> AA" "B \<in> AA"
      by blast
    from a assms asm have card_AA_\<sigma>: "card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<le> Suc 0"
      unfolding is_unifiers_def is_unifier_def subst_atms_def by auto
    have "subst_atm_abbrev A \<sigma> = subst_atm_abbrev B \<sigma>"
    proof (cases "card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) = Suc 0")
      case True
      moreover
      have "subst_atm_abbrev A \<sigma> \<in> AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>"
        using a assms asm card_AA_\<sigma> by auto
      moreover
      have "subst_atm_abbrev B \<sigma> \<in> AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>"
        using a assms asm card_AA_\<sigma> by auto
      ultimately
      show ?thesis
        using a assms asm card_AA_\<sigma> by (metis (no_types, lifting) card_Suc_eq singletonD)
    next
      case False
      then have "card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) = 0"
        using a assms asm card_AA_\<sigma>
        by arith
      then show ?thesis
        using a assms asm card_AA_\<sigma> by auto
    qed
  }
  then show "\<sigma> \<in> unifiers (set (Pairs AAA))"
    unfolding Pairs_def unifiers_def by auto
qed

end

definition "mgu_sets AAA = map_option subst_of (unify (Pairs AAA) [])"

interpretation mgu "(\<cdot>)" "Var :: _ \<Rightarrow> ('f :: compare, nat) term" "(\<circ>\<^sub>s)" "Fun undefined"
  renamings_apart mgu_sets
proof
  fix AAA :: "('a :: compare, nat) term set set" and \<sigma> :: "('a, nat) subst"
  assume fin: "finite AAA" "\<forall>AA \<in> AAA. finite AA" and "mgu_sets AAA = Some \<sigma>"
  then have "is_imgu \<sigma> (set (Pairs AAA))"
    using unify_sound unfolding mgu_sets_def by blast
  then show "is_mgu \<sigma> AAA"
    unfolding is_imgu_def is_mgu_def unifiers_Pairs[OF fin] by auto
next
  fix AAA :: "('a :: compare, nat) term set set" and \<sigma> :: "('a, nat) subst"
  assume fin: "finite AAA" "\<forall>AA \<in> AAA. finite AA" and "is_unifiers \<sigma> AAA"
  then have "\<sigma> \<in> unifiers (set (Pairs AAA))"
    unfolding is_mgu_def unifiers_Pairs[OF fin] by auto
  then show "\<exists>\<tau>. mgu_sets AAA = Some \<tau>"
    using unify_complete unfolding mgu_sets_def by blast
qed

derive linorder prod
derive linorder list

end


theory ValueOntology      (*** Benzmüller, Fuenmayor & Lomfeld, 2020 ***)
  imports PreferenceLogicBasics
begin (*** Lomfeld's value ontology is encoded ***)

(*two legal parties (there can be more in principle)*)
datatype c = p | d (*parties/contenders: plaintiff, defendant*)
fun other::"c\<Rightarrow>c" ("_\<inverse>") where "p\<inverse> = d" | "d\<inverse> = p"

consts For::"c\<Rightarrow>\<sigma>"    (*decision: find/rule for party*)
axiomatization where ForAx: "\<lfloor>For x \<^bold>\<leftrightarrow> (\<^bold>\<not>For x\<inverse>)\<rfloor>"

datatype (*ethico-legal upper values (wrt. a given party)*)
 't VAL = FREEDOM 't | UTILITY 't | SECURITY 't | EQUALITY 't
type_synonym v = "(c)VAL\<Rightarrow>bool" (*principles: sets of upper values*)
type_synonym cv = "c\<Rightarrow>v" (*principles are specified wrt. a given party*)

abbreviation vset1 ("\<lbrace>_\<rbrace>") where "\<lbrace>\<phi>\<rbrace> \<equiv> \<lambda>x::(c)VAL. x=\<phi>"
abbreviation vset2 ("\<lbrace>_,_\<rbrace>")   where "\<lbrace>\<alpha>,\<beta>\<rbrace> \<equiv> \<lambda>x::(c)VAL. x=\<alpha> \<or> x=\<beta>"

abbreviation utility::cv  ("UTILITY\<^sup>_")  where "UTILITY\<^sup>x  \<equiv> \<lbrace>UTILITY  x\<rbrace>"
abbreviation security::cv ("SECURITY\<^sup>_") where "SECURITY\<^sup>x \<equiv> \<lbrace>SECURITY x\<rbrace>"
abbreviation equality::cv ("EQUALITY\<^sup>_") where "EQUALITY\<^sup>x \<equiv> \<lbrace>EQUALITY x\<rbrace>"
abbreviation freedom::cv  ("FREEDOM\<^sup>_")  where "FREEDOM\<^sup>x  \<equiv> \<lbrace>FREEDOM  x\<rbrace>"
abbreviation stab::cv ("STAB\<^sup>_") where "STAB\<^sup>x \<equiv> \<lbrace>SECURITY x, UTILITY  x\<rbrace>"
abbreviation effi::cv ("EFFI\<^sup>_") where "EFFI\<^sup>x \<equiv> \<lbrace>UTILITY  x, SECURITY x\<rbrace>"
abbreviation gain::cv ("GAIN\<^sup>_") where "GAIN\<^sup>x \<equiv> \<lbrace>UTILITY  x, FREEDOM  x\<rbrace>"
abbreviation will::cv ("WILL\<^sup>_") where "WILL\<^sup>x \<equiv> \<lbrace>FREEDOM  x, UTILITY  x\<rbrace>"
abbreviation resp::cv ("RESP\<^sup>_") where "RESP\<^sup>x \<equiv> \<lbrace>FREEDOM  x, EQUALITY x\<rbrace>"
abbreviation fair::cv ("FAIR\<^sup>_") where "FAIR\<^sup>x \<equiv> \<lbrace>EQUALITY x, FREEDOM  x\<rbrace>"
abbreviation equi::cv ("EQUI\<^sup>_") where "EQUI\<^sup>x \<equiv> \<lbrace>EQUALITY x, SECURITY x\<rbrace>"
abbreviation reli::cv ("RELI\<^sup>_") where "RELI\<^sup>x \<equiv> \<lbrace>SECURITY x, EQUALITY x\<rbrace>"

(*derivation operators (cf. theory of "formal concept analysis") *)
consts Vrel::"i\<Rightarrow>(c)VAL\<Rightarrow>bool" ("\<I>") (*incidence relation worlds-values*)
abbreviation intension::"\<sigma>\<Rightarrow>v" ("_\<up>") where "W\<up> \<equiv> \<lambda>v. \<forall>x. W x \<longrightarrow> \<I> x v"
abbreviation extension::"v\<Rightarrow>\<sigma>" ("_\<down>") where "V\<down> \<equiv> \<lambda>w. \<forall>x. V x \<longrightarrow> \<I> w x"

(*shorthand notation for aggregating values*)
abbreviation agg (infixr "\<^bold>\<oplus>"80) where "v\<^sub>1\<^bold>\<oplus>v\<^sub>2 \<equiv> v\<^sub>1 \<^bold>\<sqinter> v\<^sub>2"
abbreviation agg1 ("[_]") where "[v] \<equiv> v\<down>"
abbreviation agg2 ("[_\<oplus>_]") where "[v\<^sub>1\<oplus>v\<^sub>2] \<equiv> (v\<^sub>1\<^bold>\<oplus>v\<^sub>2)\<down>"
abbreviation agg3 ("[_\<oplus>_\<oplus>_]") where "[v\<^sub>1\<oplus>v\<^sub>2\<oplus>v\<^sub>3] \<equiv> (v\<^sub>1\<^bold>\<oplus>v\<^sub>2\<^bold>\<oplus>v\<^sub>3)\<down>"
abbreviation agg4 ("[_\<oplus>_\<oplus>_\<oplus>_]") where "[v\<^sub>1\<oplus>v\<^sub>2\<oplus>v\<^sub>3\<oplus>v\<^sub>4] \<equiv> (v\<^sub>1\<^bold>\<oplus>v\<^sub>2\<^bold>\<oplus>v\<^sub>3\<^bold>\<oplus>v\<^sub>4)\<down>"

(*chosen variant for preference relation (cf. van Benthem et al. 2009*)
abbreviation relPref::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>"  ("_\<^bold>\<prec>_") where "\<phi> \<^bold>\<prec> \<psi> \<equiv> \<psi> \<^bold>\<succ>\<^sub>E\<^sub>A \<phi>"
abbreviation relPrefval::"v\<Rightarrow>v\<Rightarrow>\<sigma>" ("_\<^bold>\<prec>\<^sub>v_") where "\<phi> \<^bold>\<prec>\<^sub>v \<psi> \<equiv> \<psi>\<down> \<^bold>\<succ>\<^sub>E\<^sub>A \<phi>\<down>"

abbreviation incnst ("INCONS\<^sup>_") where (*inconsistency for value support*)
 "INCONS\<^sup>x \<equiv> [SECURITY\<^sup>x] \<^bold>\<and> [EQUALITY\<^sup>x] \<^bold>\<and> [FREEDOM\<^sup>x] \<^bold>\<and> [UTILITY\<^sup>x]"

lemma "True" nitpick[satisfy] oops (*verify consistency of this theory*)
end