theory Test_SeLFiE
imports Main SeLFiE
begin

lemma "zip xs ys = zip xs ys"
  sem_ind
  oops

lemma "length xs = length ys \<Longrightarrow> True"
  sem_ind
  oops

lemma "List.list.list_all2 f xs ys \<Longrightarrow> xs = ys"
  sem_ind
  apply(induct xs ys rule:list_all2_induct)
  oops

lemma "f x \<Longrightarrow> g y \<Longrightarrow> h z"
  sem_ind
  assert_SeLFiE_true  test_is_a_meta_premise    [on["f x"], arb[],rule[]]
  assert_SeLFiE_false test_is_a_meta_premise    [on["h z"], arb[],rule[]]
  assert_SeLFiE_true  test_is_a_meta_conclusion [on["h z"], arb[],rule[]]
  assert_SeLFiE_true  test_is_a_meta_premise_or_below    [on["x"], arb[],rule[]]
  assert_SeLFiE_false test_is_a_meta_premise_or_below    [on["z"], arb[],rule[]]
  assert_SeLFiE_true  test_is_a_meta_conclusion_or_below [on["z"], arb[],rule[]]
  assert_SeLFiE_false test_is_a_meta_conclusion_or_below [on["x"], arb[],rule[]]
  assert_SeLFiE_true test_is_more_than [on["zs"], arb[],rule[]]
  assert_SeLFiE_false test_Is_If_Then_Else [on["zs"], arb[],rule[]]
  assert_SeLFiE_false test_Is_If_Then_Else [on["x"], arb[],rule[]]
  assert_SeLFiE_false test_Is_Case_Distinct_Of_Trm_With_A_Case [on["zs"], arb[],rule[]]
  oops

lemma "if x then True else False"
  sem_ind
  assert_SeLFiE_true  test_Is_If_Then_Else [on["x"], arb[],rule[]]
  oops

lemma "case x of [y] \<Rightarrow> y | _ \<Rightarrow> False"
  assert_SeLFiE_true  test_Is_Case_Distinct_Of_Trm_With_A_Case [on["zs"], arb[],rule[]]
  assert_SeLFiE_false test_Is_Let_X_Be_Y_In_X [on["zs"], arb[],rule[]]
  oops

lemma "let (x1, x2) = y in z < x1"
  assert_SeLFiE_true test_Is_Let_X_Be_Y_In_X [on["zs"], arb[],rule[]]
  oops

 primrec rev1 :: "'a list \<Rightarrow> 'a list" where
  "rev1 []       = []" |
  "rev1 (x # xs) = rev1 xs @ [x]"

 fun rev2 :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "rev2 []     ys = ys" |
  "rev2 (x#xs) ys = rev2 xs (x#ys)"

 lemma "rev2 xs ys = rev1 xs @ ys"
  apply(induct xs arbitrary: ys)

  sem_ind
  all_induction_heuristic      [on[], arb[],rule["List.list_induct2'"]]
  all_induction_heuristic      [on["xs"], arb["ys"],rule[]]
  all_generalization_heuristic [on["xs"], arb["ys"],rule[]]
  all_induction_heuristic [on["xs","ys"], arb[],rule["rev2.induct"]]
(*
  assert_SeLFiE_true  generalize_arguments_used_in_recursion_deep [on["xs"], arb["ys"], rule[]]
  assert_SeLFiE_true  generalize_arguments_used_in_recursion_deep [on["xs"], arb[    ], rule[]](*Not great, but does not harm much.*)
*)
  assert_SeLFiE_true  generalize_arguments_used_in_recursion [on["xs"], arb["ys"],rule[]](*It used to take 1.196s elapsed time*)
  assert_SeLFiE_false generalize_arguments_used_in_recursion [on["xs"], arb["xs"],rule[]](*It used to take 2.467s elapsed time*)
  assert_SeLFiE_false generalize_arguments_used_in_recursion [on["xs"], arb[    ],rule[]](*It used to take 0.864s elapsed time*)
  assert_SeLFiE_true  for_all_arbs_there_should_be_a_change  [on["xs"], arb["ys"],rule[]]
  assert_SeLFiE_true  for_all_arbs_there_should_be_a_change_simplified_for_presentation [on["xs"], arb["ys"],rule[]]
  assert_SeLFiE_false for_all_arbs_there_should_be_a_change_simplified_for_presentation [on["xs"], arb["xs"],rule[]]
  assert_SeLFiE_true  for_all_arbs_there_should_be_a_change  [on["xs"], arb[],rule[]](*unfortunate result due to the universal quantifier.*)
  assert_SeLFiE_true  is_defined_recursively_on_nth  [on["xs"], arb["ys"],rule[]](*It used to take 0.703s elapsed time*)
  assert_SeLFiE_false is_defined_recursively_on_nth  [on["ys"], arb[],rule[]](*It used to take 1.647s elapsed time*)
  assert_SeLFiE_true heuristic_1  [on["xs"], arb["ys"],rule[]]
  assert_SeLFiE_true heuristic_2  [on["xs"], arb["ys"],rule[]]
  assert_SeLFiE_true heuristic_3  [on["xs"], arb["ys"],rule[]]
  assert_SeLFiE_true heuristic_4  [on["xs"], arb["ys"],rule["itrev.induct"]]
  assert_SeLFiE_true heuristic_5  [on["xs"], arb["ys"],rule[]]
  assert_SeLFiE_true heuristic_6  [on["xs"], arb["ys"],rule[]]
  assert_SeLFiE_true heuristic_7  [on["xs"], arb["ys"],rule[]]
  assert_SeLFiE_true heuristic_8  [on["xs"], arb["ys"],rule[]]
  assert_SeLFiE_true heuristic_9  [on["xs"], arb["ys"],rule[]]
  assert_SeLFiE_true heuristic_10 [on["xs"], arb["ys"],rule[]]
(*
  assert_SeLFiE_true heuristic_11 [on["xs"], arb["ys"],rule[]]
*)
  assert_SeLFiE_true heuristic_12 [on["xs"], arb["ys"],rule["itrev.induct"]]
  assert_SeLFiE_true heuristic_13 [on["xs"], arb["ys"],rule["itrev.induct"]]
  assert_SeLFiE_true heuristic_14 [on["xs"], arb["ys"],rule["itrev.induct"]]
  assert_SeLFiE_true test_dive_in  [on["xs"], arb["ys"],rule["itrev.induct"]]
  assert_SeLFiE_true print_all_outer_prints [on["xs"], arb["ys"],rule["itrev.induct"]]
  assert_SeLFiE_true print_all_inner_prints [on["xs"], arb["ys"],rule["itrev.induct"]]
  assert_SeLFiE_true print_all_unodes       [on["xs"], arb["ys"],rule["itrev.induct"]]
  assert_SeLFiE_true print_outer_path_root  [on["xs"], arb["ys"],rule["itrev.induct"]]
  assert_SeLFiE_true lifter_4  [on["xs"], arb["ys"], rule[]]
  assert_SeLFiE_true lifter_5  [on["xs","ys"], arb[], rule["rev2.induct"]]
  assert_SeLFiE_true lifter_6  [on["xs"], arb["ys"], rule[]]
  assert_SeLFiE_true lifter_7  [on["xs"], arb["ys"], rule[]]
  assert_SeLFiE_true lifter_8  [on["xs"], arb["ys"], rule[]]
  assert_SeLFiE_true lifter_9  [on["xs"], arb["ys"], rule[]]
  assert_SeLFiE_true lifter_10  [on["xs"], arb["ys"], rule[]]
  assert_SeLFiE_true lifter_11  [on["xs","ys"], arb[], rule["rev2.induct"]]
  assert_SeLFiE_true lifter_12  [on["xs"], arb["ys"], rule["rev2.induct"]]
  assert_SeLFiE_true lifter_15  [on["xs"], arb["ys"], rule["rev.induct"]]
  assert_SeLFiE_true lifter_13  [on["xs"], arb["ys"], rule["rev2.induct"]]
  assert_SeLFiE_true lifter_14  [on["xs"], arb["ys"], rule["rev2.induct"]]
  assert_SeLFiE_true print_fst_params_of_fun_const [on["xs"], arb["ys"],rule["rev2.induct"]]
  assert_SeLFiE_true print_inner_roots      [on["xs"], arb["ys"],rule["rev2.induct"]]
  assert_SeLFiE_true print_all_inner_lhss   [on["xs"], arb["ys"],rule["rev2.induct"]]
  assert_SeLFiE_true lifter_1  [on["xs"], arb["ys"],rule["rev2.induct"]]
  assert_SeLFiE_true lifter_1b [on["xs"], arb["ys"],rule["rev2.induct"]]
  assert_SeLFiE_true lifter_2  [on["xs"], arb["ys"],rule["rev2.induct"]]
  assert_SeLFiE_true lifter_3  [on["xs"], arb["ys"],rule["rev2.induct"]]
  assert_SeLFiE_true  test_Is_Subprint_Of_true  [on["xs"], arb["ys"],rule["rev2.induct"]]
  assert_SeLFiE_false test_Is_Subprint_Of_false  [on["xs"], arb["ys"],rule["rev2.induct"]]
  assert_SeLFiE_false rule_inversion_using_the_deepest_const [on["xs", "ys"], arb[],rule["rev2.induct"]]
  apply(induct xs arbitrary: ys) apply auto done

definition "list_reversal_eq xs ys \<equiv> rev2 xs ys = rev1 xs @ ys"
print_theorems

lemma "list_reversal_eq xs ys"
  sem_ind
(*
  assert_SeLFiE_true  generalize_arguments_used_in_recursion_deep [on["xs"], arb["ys"], rule[]](*good*)
  assert_SeLFiE_false generalize_arguments_used_in_recursion_deep [on["xs"], arb[    ], rule[]](*Great*)
*)
  sem_ind
  apply(induct xs arbitrary: ys)
   apply(auto simp: list_reversal_eq_def)
  done

(* auxiliary stuff *)
ML\<open>
@{term "let x = 1 in x"};
(*
  Const ("HOL.Let", "'a \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a")
$ Const ("Groups.one_class.one", "'a")
$ Abs   ("x", "'a", Bound 0): term
*)

@{term "let x = 1 + y in x"};
(*
  Const ("HOL.Let", "'a \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a")
$(  Const ("Groups.plus_class.plus", "'a \<Rightarrow> 'a \<Rightarrow> 'a")
  $ Const ("Groups.one_class.one", "'a")
  $ Free ("y", "'a")
 )
$ Abs   ("x", "'a", Bound 0)
*)

@{term "\<lambda>x. x + 1"};
@{term "case x of [] => y | _ \<Rightarrow> z"};
(*
  Const ("List.list.case_list", "'a \<Rightarrow> ('b \<Rightarrow> 'b list \<Rightarrow> 'a) \<Rightarrow> 'b list \<Rightarrow> 'a")
$ Free  ("y", "'a")
$ Abs   ("a", "'b", Abs ("list", "'b list", Free ("z", "'a")))
$ Free  ("x", "'b list")
*)

@{term "case x of [] => y | w#ws \<Rightarrow> z"};
(*
  Const ("List.list.case_list", "'a \<Rightarrow> ('b \<Rightarrow> 'b list \<Rightarrow> 'a) \<Rightarrow> 'b list \<Rightarrow> 'a")
$ Free  ("y", "'a")
$ Abs   ("w", "'b", Abs ("ws", "'b list", Free ("z", "'a")))
$ Free  ("x", "'b list"):
*)

@{term "case x of [] => y | w#ws \<Rightarrow> w"};
(*
  Const ("List.list.case_list", "'a \<Rightarrow> ('a \<Rightarrow> 'a list \<Rightarrow> 'a) \<Rightarrow> 'a list \<Rightarrow> 'a")
$ Free  ("y", "'a")
$ Abs   ("w", "'a", Abs ("ws", "'a list", Bound 1))
$ Free  ("x", "'a list")
*)

@{term "case x of True => y | _ \<Rightarrow> z"}
(*
  Const ("Product_Type.bool.case_bool", "'a \<Rightarrow> 'a \<Rightarrow> bool \<Rightarrow> 'a")
$ Free  ("y", "'a")
$ Free  ("z", "'a")
$ Free  ("x", "bool")
*)

(*
Is_Case = name has a string "case" as its sub-string
  and it it takes n arguments, (n-1)th argument's type name is part of the constant name..;
Is_Maybe_Bound_Of_Case;
*)
\<close>
find_consts name:"case_list"
find_consts name:"Product_Type.bool.case_bool"
find_theorems name:"case" name:"bool"
find_theorems name:"List.list"
thm List.list.case
(*
datatype alpha = A | B | C | D
ML\<open>
@{term "case x of A \<Rightarrow> True | B \<Rightarrow> False"};
(*
   Const ("SeLFiE.alpha.case_alpha", "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> alpha \<Rightarrow> bool")
 $ Const ("HOL.True", "bool")
 $ Const ("HOL.False", "bool")
 $ Const ("HOL.undefined", "bool")
 $ Const ("HOL.undefined", "bool")
 $ Free ("x", "alpha"):
 term

  Const ("LiFtEr.alpha.case_alpha", "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> alpha \<Rightarrow> 'a")
$ Free  ("a", "'a")
$ Free  ("b", "'a")
$ Const ("HOL.undefined", "'a")
$ Const ("HOL.undefined", "'a")
$ Free  ("x", "alpha")
*)
\<close>
*)
ML\<open>
(*
@{term "case x of B \<Rightarrow> False | A \<Rightarrow> True "};
*)
(*
  Const ("SeLFiE.alpha.case_alpha", "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> alpha \<Rightarrow> bool")
$ Const ("HOL.True", "bool")
$ Const ("HOL.False", "bool")
$ Const ("HOL.undefined", "bool")
$ Const ("HOL.undefined", "bool")
$ Free ("x", "alpha")
: term
*)
\<close>
declare[[ML_print_depth=100]]
ML\<open>
@{term "case x of [x] \<Rightarrow> False | [] \<Rightarrow> True | x#xs \<Rightarrow> True"};
(*
  Const ("List.list.case_list", "bool \<Rightarrow> ('a \<Rightarrow> 'a list \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool")
$ Const ("HOL.True", "bool")
$ Abs ("x", "'a",
    Abs ("xs",
         "'a list",
           Const ("List.list.case_list", "bool \<Rightarrow> ('a \<Rightarrow> 'a list \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool")
         $ Const ("HOL.False", "bool")
         $ Abs ("a", "'a",
             Abs ("list", "'a list",
               Const ("HOL.True", "bool")
             )
           )
         $ Bound 0
    )
  )
$ Free ("x", "'a list")
: term
*)
\<close>

ML\<open>
@{term "case x of [] \<Rightarrow> True | x#xs \<Rightarrow> False"};
(*
  Const ("List.list.case_list", "bool \<Rightarrow> ('a \<Rightarrow> 'a list \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool")
$ Const ("HOL.True", "bool")
$ Abs ("x", "'a", Abs ("xs", "'a list", Const ("HOL.False", "bool")))
$ Free ("x", "'a list")
: term
*)
\<close>

ML\<open>
@{term "List.list.case_list"};
Isabelle_Utils.count_numb_of_args_of_fun_typ;

fun count_numb_of_args_of_fun_typ' (fun_typ:typ) (acc:int) = case try dest_funT fun_typ of
  NONE => acc
| SOME (_(*domain_typ*), range_typ) => count_numb_of_args_of_fun_typ' range_typ (acc + 1);

fun count_numb_of_args_of_fun_typ (typ:typ) = count_numb_of_args_of_fun_typ' typ 0;

@{term "List.null"};
dest_Const @{term "List.null"} |> snd |> dest_funT;

@{term "List.nth"};
dest_Const @{term "List.nth"} |> snd |> dest_funT |> snd |> dest_funT;

local

fun get_fist_type (fun_typ:typ) =
    let
      val (first_typ, _) = dest_funT fun_typ;
    in
      first_typ
    end;

fun remove_first_n_minus_one_typs (fun_typ:typ) (0:int) = fun_typ
  | remove_first_n_minus_one_typs (fun_typ:typ) (n:int) =
    let
      val (_, tail_fun_typ) = dest_funT fun_typ;
    in
      remove_first_n_minus_one_typs tail_fun_typ (n - 1)
    end;

in

fun fun_typ_to_typ_of_nth_arg (fun_typ:typ) (n:int) = (get_fist_type oo remove_first_n_minus_one_typs) fun_typ n;

end;

fun_typ_to_typ_of_nth_arg ((snd o dest_Const) @{term "List.list.case_list"}) 1
\<close>

ML\<open>
@{term "case x of x#xs \<Rightarrow> False | [] \<Rightarrow> True"};
(*
  Const ("List.list.case_list", "bool \<Rightarrow> ('a \<Rightarrow> 'a list \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool")
$ Const ("HOL.True", "bool")
$ Abs ("x", "'a", Abs ("xs", "'a list", Const ("HOL.False", "bool")))
$ Free ("x", "'a list")
: term
*)
\<close>

ML\<open>
@{term "case [] of x#xs \<Rightarrow> False | [] \<Rightarrow> True"};
(*
  Const ("List.list.case_list", "bool \<Rightarrow> ('a \<Rightarrow> 'a list \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool")
$ Const ("HOL.True", "bool")
$ Abs ("x", "'a", Abs ("xs", "'a list", Const ("HOL.False", "bool")))
$ Const ("List.list.Nil", "'a list"): term
*)
\<close>

ML\<open>
@{term "case f x of x#xs \<Rightarrow> False | [] \<Rightarrow> True"};
(*
  Const ("List.list.case_list", "bool \<Rightarrow> ('a \<Rightarrow> 'a list \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool")
$ Const ("HOL.True", "bool")
$ Abs ("x", "'a", Abs ("xs", "'a list", Const ("HOL.False", "bool")))
$ (Free ("f", "'b \<Rightarrow> 'a list") $ Free ("x", "'b")): term
*);
\<close>

ML\<open>
@{term "let ((x1,  x2),  x3) = (y1, y2) in (y1, x3)"};
(*
val it =
   Const ("HOL.Let", "'a \<times> 'b \<times> 'c \<Rightarrow> ('a \<times> 'b \<times> 'c \<Rightarrow> 'a \<times> 'c) \<Rightarrow> 'a \<times> 'c")
$ (Const ("Product_Type.Pair", "'a \<Rightarrow> 'b \<times> 'c \<Rightarrow> 'a \<times> 'b \<times> 'c")
  $ Free ("y1", "'a")
  $ Free ("y2", "'b \<times> 'c"))
$ (Const ("Product_Type.prod.case_prod", "('a \<Rightarrow> 'b \<times> 'c \<Rightarrow> 'a \<times> 'c) \<Rightarrow> 'a \<times> 'b \<times> 'c \<Rightarrow> 'a \<times> 'c")
  $ Abs ("x1", "'a",
      Const ("Product_Type.prod.case_prod", "('b \<Rightarrow> 'c \<Rightarrow> 'a \<times> 'c) \<Rightarrow> 'b \<times> 'c \<Rightarrow> 'a \<times> 'c")
     $ Abs ("x2", "'b",
         Abs ("x3", "'c",
           Const ("Product_Type.Pair", "'a \<Rightarrow> 'c \<Rightarrow> 'a \<times> 'c")
          $ Free ("y1", "'a")
          $ Bound 0
         )
       )
    )
  )

: term
Is_Let_X_Be_Y_In_Z.
Again, we have to count the number of Abs.
X_Is_Let_Z_Be_Y_In_Z.
*)
@{term "Product_Type.Pair"};
dest_funT;
\<close>

ML\<open>
@{term "let x = y in z"};
@{term "(x = y)"};
Name.skolem;
Variable.names_of;
Variable.add_fixes;
type asdf = term;
\<close>

schematic_goal "?x = ?x"
  apply(tactic \<open>fn x => (
let
  val fst_subg = try (hd o Thm.prems_of) x: term option;
  val _        = if length (Thm.prems_of x) = 0 then tracing "empty" else tracing "no empty";

  val _ = Option.map (tracing o Isabelle_Utils.trm_to_string @{context}) (fst_subg);

  val _ = if Utils.is_some_true (Option.map (exists_subterm (is_Var)) fst_subg)
          then tracing "Yes Var!"
          else tracing "No Var!"
  val _ = if Utils.is_some_true (Option.map (exists_subterm (is_Bound)) fst_subg)
          then tracing "Yes Bound!"
          else tracing "No Bound!"

in
  Seq.single x
end) \<close>)
  oops

lemma helper: "rev2 xs ys = rev1 xs @ ys"
  apply (induct xs arbitrary: ys)
  by auto

lemma equivalence: "rev2 xs [] = rev1 xs"
  by (simp add: helper)

ML\<open>
(*
 Try.tool_setup (nitpickN, (50, \<^system_option>\<open>auto_nitpick\<close>, try_nitpick))
*)
 Try.tool_setup;

Term.add_free_names @{term "f (x z) y"} [] |> rev  |> distinct (op =)
\<close>

lemma "rev2 xs ys = rev1 xs @ ys"
  apply(induct xs)
   apply auto
  apply(subgoal_tac "\<And>xs. \<forall>ys. rev2 xs ys = rev1 xs @ ys")
  apply fastforce
  apply(induct_tac xsa)
   apply auto
  done

end


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

section "Signed Words"

theory Signed_Words
imports "~~/src/HOL/Word/Word"
begin

text \<open>Signed words as separate (isomorphic) word length class. Useful for tagging words in C.\<close>

typedef ('a::len0) signed = "UNIV :: 'a set" ..

lemma card_signed [simp]: "CARD (('a::len0) signed) = CARD('a)"
  unfolding type_definition.card [OF type_definition_signed]
  by simp

instantiation signed :: (len0) len0
begin

definition
  len_signed [simp]: "len_of (x::'a::len0 signed itself) = len_of TYPE('a)"

instance ..

end

instance signed :: (len) len
  by (intro_classes, simp)

type_synonym 'a sword = "'a signed word"
type_synonym  sword8 =  "8 sword"
type_synonym sword16 = "16 sword"
type_synonym sword32 = "32 sword"
type_synonym sword64 = "64 sword"

end


theory VertexCover4ToMetricTravelingSalesman_AdjList
  imports VertexCover4ToMetricTravelingSalesman_Specs GraphAdjList
begin

notation ugraph_adj_list.ugraph_adj_map_invar ("ugraph'_invar")
notation ugraph_adj_list.rep ("rep'_uedge")
notation ugraph_adj_list.neighborhood ("\<N>")

context ugraph_adj_map_by_linorder
begin

\<comment> \<open>Compute representatives for induced graph.\<close>
fun rep_prod :: "('v uedge \<times> 'v \<times> nat) uedge \<Rightarrow> ('v uedge \<times> 'v \<times> nat) uedge" where
  "rep_prod (uEdge (uEdge u\<^sub>1 v\<^sub>1,w\<^sub>1,i\<^sub>1) (uEdge u\<^sub>2 v\<^sub>2,w\<^sub>2,i\<^sub>2)) =
    (let e\<^sub>1 = (uEdge u\<^sub>1 v\<^sub>1,w\<^sub>1,i\<^sub>1); e\<^sub>2 = (uEdge u\<^sub>2 v\<^sub>2,w\<^sub>2,i\<^sub>2) in
    if u\<^sub>1 < u\<^sub>2 then uEdge e\<^sub>1 e\<^sub>2
    else if u\<^sub>2 < u\<^sub>1 then uEdge e\<^sub>2 e\<^sub>1
    else if v\<^sub>1 < v\<^sub>2 then uEdge e\<^sub>1 e\<^sub>2
    else if v\<^sub>2 < v\<^sub>1 then uEdge e\<^sub>2 e\<^sub>1
    else if w\<^sub>1 < w\<^sub>2 then uEdge e\<^sub>1 e\<^sub>2
    else if w\<^sub>2 < w\<^sub>1 then uEdge e\<^sub>2 e\<^sub>1
    else if i\<^sub>1 < i\<^sub>2 then uEdge e\<^sub>1 e\<^sub>2
    else if i\<^sub>2 < i\<^sub>1 then uEdge e\<^sub>2 e\<^sub>1
    else uEdge e\<^sub>1 e\<^sub>2)" (* TODO: is there a way of automizing this? *)

lemma rep_prod_is_rep_sym: "rep_prod (uEdge x y) = rep_prod (uEdge y x)"
proof (cases x; cases y)
  fix e\<^sub>1 w\<^sub>1 i\<^sub>1 e\<^sub>2 w\<^sub>2 i\<^sub>2
  assume [simp]: "x = (e\<^sub>1,w\<^sub>1,i\<^sub>1)" and [simp]: "y = (e\<^sub>2,w\<^sub>2,i\<^sub>2)"
  show ?thesis
    by (cases e\<^sub>1; cases e\<^sub>2) (auto simp add: Let_def)
qed

lemma rep_prod_is_rep_cases: "rep_prod (uEdge x y) = uEdge x y \<or> rep_prod (uEdge x y) = uEdge y x"
proof (cases x; cases y)
  fix e\<^sub>1 w\<^sub>1 i\<^sub>1 e\<^sub>2 w\<^sub>2 i\<^sub>2
  assume [simp]: "x = (e\<^sub>1,w\<^sub>1,i\<^sub>1)" and [simp]: "y = (e\<^sub>2,w\<^sub>2,i\<^sub>2)"
  show ?thesis
    by (cases e\<^sub>1; cases e\<^sub>2) (auto simp add: Let_def)
qed

lemmas rep_prod_is_rep = rep_prod_is_rep_sym rep_prod_is_rep_cases

end

notation ugraph_adj_list.rep_prod ("rep'_uedge'_prod")

abbreviation "uedge \<equiv> \<lambda>u v. rep_uedge (uEdge u v)"

lemma inj_rep_uedge_uv: "inj_on (uedge u) X"
  by rule (auto split: if_splits)

fun edges_from where "edges_from (u,Nu) = map (uedge u) (filter (\<lambda>v. uEdge u v = uedge u v) Nu)"

fun uedges where "uedges G = concat (map edges_from G)"

lemma distinct_edges_from: "distinct Nu \<Longrightarrow> distinct (edges_from (u,Nu))"
  using inj_rep_uedge_uv by (auto simp add: distinct_map)

lemma isin_edges_from_elim:
  assumes "x \<in> set (edges_from (u,Nu))"
  obtains v where "v \<in> set Nu" "x = uEdge u v" "x = uedge u v"
  using assms by fastforce

lemma isin_edges_from_intro:
  assumes "v \<in> set Nu" "x = uEdge u v" "x = uedge u v"
  shows "x \<in> set (edges_from (u,Nu))"
  using assms by fastforce

lemma disjoint_edges_from:
  assumes "ugraph_invar G" "(u,Nu) \<in> set G" "(v,Nv) \<in> set G" "(u,Nu) \<noteq> (v,Nv)"
  shows "set (edges_from (u,Nu)) \<inter> set (edges_from (v,Nv)) = {}"
proof (rule ccontr)
  assume "set (edges_from (u,Nu)) \<inter> set (edges_from (v,Nv)) \<noteq> {}"
  then obtain w\<^sub>1 w\<^sub>2 where "uEdge u w\<^sub>1 = uEdge v w\<^sub>2"
    by (auto elim: isin_edges_from_elim)
  moreover have "u \<noteq> v"
    using assms lmap_unique_assoc by fastforce
  ultimately show "False"
    by auto
qed

lemma distinct_uedges_adj_list:
  assumes "ugraph_invar G"
  shows "distinct (uedges G)"
  apply (subst uedges.simps)
  apply (rule distinct_concat_map)
proof -
  have "distinct (map fst G)"
    using assms by auto
  thus "distinct G"
    by (metis distinct_zipI1 zip_map_fst_snd)
  show "\<And>x. x \<in> set G \<Longrightarrow> distinct (edges_from x)"
  proof -
    fix x
    assume "x \<in> set G"
    moreover obtain u Nu where [simp]: "x = (u,Nu)"
      by (cases x)
    ultimately have "\<N> G u = Nu"
      using assms isin_lmap_neighborhood by auto
    hence "distinct Nu"
      using assms by auto
    thus "distinct (edges_from x)"
      by (simp del: edges_from.simps) (intro distinct_edges_from)
  qed
  show "\<And>x y. x \<in> set G \<Longrightarrow> y \<in> set G \<Longrightarrow> x \<noteq> y \<Longrightarrow> set (edges_from x) \<inter> set (edges_from y) = {}"
  proof -
    fix x y
    assume "x \<in> set G" "y \<in> set G" "x \<noteq> y"
    moreover obtain u Nu v Nv where [simp]: "x = (u,Nu)" and [simp]: "y = (v,Nv)"
      by (cases x; cases y)
    ultimately show "set (edges_from x) \<inter> set (edges_from y) = {}"
      apply (simp del: edges_from.simps)
      apply (intro disjoint_edges_from)
      using assms by auto
  qed
qed

lemma uedges_rep_idem: "map rep_uedge (uedges G) = (uedges G)"
  by (induction G) (auto simp add: ugraph_adj_list.rep_idem simp del: ugraph_adj_list.rep.simps)

lemma set_uedges:
  assumes "ugraph_invar G"
  shows "set (uedges G) = ugraph_adj_list.uedges G"
proof
  show "set (uedges G) \<subseteq> ugraph_adj_list.uedges G"
  proof
    fix x
    assume "x \<in> set (uedges G)"
    then obtain u Nu where "(u,Nu) \<in> set G" "x \<in> set (edges_from (u,Nu))"
      by auto
    moreover then obtain v where "v \<in> set Nu" and [simp]: "x = uedge u v"
      by (elim isin_edges_from_elim)
    moreover have [simp]: "\<N> G u = Nu"
      using assms calculation isin_lmap_neighborhood by auto
    ultimately have "lset_isin (\<N> G u) v"
      using assms by (auto simp add: lset_isin simp del: lset_isin.simps)
    thus "x \<in> ugraph_adj_list.uedges G"
      unfolding ugraph_adj_list.uedges_def2 by auto
  qed
next
  show "ugraph_adj_list.uedges G \<subseteq> set (uedges G)"
  proof
    fix x
    assume "x \<in> ugraph_adj_list.uedges G"
    then obtain u v where [simp]: "x = uedge u v" and v_isin_Nu: "lset_isin (\<N> G u) v" (is "lset_isin ?Nu v")
      unfolding ugraph_adj_list.uedges_def2 by auto
    moreover hence u_isin_Nv: "lset_isin (\<N> G v) u" (is "lset_isin ?Nv u")
      using assms by auto
    ultimately consider "x = uEdge u v" | "x = uEdge v u"
      using ugraph_adj_list.is_rep by auto
    thus "x \<in> set (uedges G)"
    proof cases
      assume "x = uEdge u v"
      moreover have "v \<in> lset_set (\<N> G u)"
        using assms v_isin_Nu lset_isin by metis
      ultimately have "x \<in> set (edges_from (u,?Nu))"
        by (intro isin_edges_from_intro) simp+
      moreover have "lmap_lookup G u = Some ?Nu"
        using v_isin_Nu by (intro ugraph_adj_list.lookup_non_empty_neighborhood)
      moreover hence "(u,?Nu) \<in> set G"
        using assms isin_lmap_lookup by metis
      ultimately show "x \<in> set (uedges G)"
        by force
    next
      assume "x = uEdge v u"
      moreover have "x = uedge v u"
        using ugraph_adj_list.is_rep by auto
      moreover have "u \<in> lset_set (\<N> G v)"
        using assms v_isin_Nu lset_isin by metis
      ultimately have "x \<in> set (edges_from (v,?Nv))"
        by (intro isin_edges_from_intro) simp+
      moreover have "lmap_lookup G v = Some ?Nv"
        using u_isin_Nv by (intro ugraph_adj_list.lookup_non_empty_neighborhood)
      moreover hence "(v,?Nv) \<in> set G"
        using assms isin_lmap_lookup by metis
      ultimately show "x \<in> set (uedges G)"
        by force
    qed
  qed
qed

fun fold_uedges where
  "fold_uedges f G = fold f (uedges G)"

lemma fold_uedges:
  assumes "ugraph_invar G"
  obtains es where "distinct es" "map rep_uedge es = es"
    "set es = ugraph_adj_list.uedges G" "fold_uedges f G a = fold f es a"
proof (rule that)
  let ?es="uedges G"
  show "distinct ?es"
    using assms by (intro distinct_uedges_adj_list)
  show "map rep_uedge ?es = ?es"
    using assms by (intro uedges_rep_idem)
  show "set ?es = ugraph_adj_list.uedges G"
    using assms by (intro set_uedges)
  show "fold_uedges f G a = fold f ?es a"
    by auto
qed

interpretation fold_uedges: ugraph_adj_map_fold_uedges
  lmap_empty lmap_update lmap_delete lmap_lookup lmap_invar lset_empty lset_insert lset_delete
  lset_isin lset_set lset_invar lset_union lset_inter lset_diff
  rep_uedge fold_uedges
  apply unfold_locales
  apply (elim fold_uedges)
  apply auto
  done

fun fold_vset where
  "fold_vset f X = fold f X"

lemma finite_lsets: "finite (lset_set X)"
  by auto

lemma fold_vset:
  assumes "lset_invar X"
  obtains xs where "distinct xs" "set xs = lset_set X" "fold_vset f X a = fold f xs a"
  using assms by auto

interpretation fold_vset: ugraph_adj_map_fold_vset
  lmap_empty lmap_update lmap_delete lmap_lookup lmap_invar lset_empty lset_insert lset_delete
  lset_isin lset_set lset_invar lset_union lset_inter lset_diff
  rep_uedge fold_vset
  apply unfold_locales
  using finite_lsets apply simp
  apply (elim fold_vset)
  apply auto
  done

interpretation lreduction: VC4_To_mTSP
  (* graph representation 1 *) lmap_empty lmap_update lmap_delete lmap_lookup lmap_invar lset_empty
  lset_insert lset_delete lset_isin lset_set lset_invar lset_union lset_inter lset_diff rep_uedge
  (* graph representation 2 *) lmap_empty lmap_update lmap_delete lmap_lookup lmap_invar lset_empty
  lset_insert lset_delete lset_isin lset_set lset_invar lset_union lset_inter lset_diff rep_uedge_prod
  fold_uedges fold_uedges fold_uedges fold_uedges fold_uedges
  fold_vset fold_vset fold_vset
  choose_edge
  apply unfold_locales
  apply (rule ugraph_adj_list.rep_prod_is_rep(1))
  apply (rule ugraph_adj_list.rep_prod_is_rep(2))
  apply (elim fold_uedges; blast)
  apply (elim fold_uedges; blast)
  apply (elim fold_uedges; blast)
  apply (elim fold_uedges; blast)
  using finite_lsets apply simp
  apply (elim fold_vset; blast)
  apply (elim fold_vset; blast)
  using finite_lsets apply simp
  apply (elim fold_vset; blast)
  apply (rule choose_edge)
  apply simp
  apply simp
  done

\<comment> \<open>Functions\<close>
thm lreduction.f.simps
thm lreduction.c.simps
thm lreduction.g.simps

fun f_adjlist where
  "f_adjlist G = (
    let V = fold_uedges (lset_union o lreduction.vertices_of_He) G lset_empty;
        n = \<lambda>x. (if lset_isin V x then lset_delete x V else lset_empty) in
    fold_vset (\<lambda>v. lmap_update v (n v)) V lmap_empty)"

lemma "f_adjlist = lreduction.f"
  unfolding f_adjlist.simps Let_def lreduction.f.simps lreduction.complete_graph.simps
    lreduction.graph_of_vertices.simps lreduction.vertices_of_H.simps
    lreduction.neighborhood_compl.simps by simp

\<comment> \<open>Feasibility\<close>
thm lreduction.f_is_complete
thm lreduction.c_tri_inequality
thm lreduction.g_is_vc

\<comment> \<open>Correctness\<close>
thm lreduction.l_reduction1
thm lreduction.l_reduction2

end