theory Ipassmt
imports Common_Primitive_Syntax
        "../Semantics_Ternary/Primitive_Normalization"
        Simple_Firewall.Iface
        Simple_Firewall.IP_Addr_WordInterval_toString (*for debug pretty-printing*)
        Automatic_Refinement.Misc (*dependnecy!*)
begin
  hide_const Misc.uncurry
  hide_fact Misc.uncurry_def

  text\<open>A mapping from an interface to its assigned ip addresses in CIDR notation\<close>
  type_synonym 'i ipassignment="iface \<rightharpoonup> ('i word \<times> nat) list" (*technically, a set*)

subsection\<open>Sanity checking for an @{typ "'i ipassignment"}.\<close>

  text\<open>warning if interface map has wildcards\<close>
  definition ipassmt_sanity_nowildcards :: "'i ipassignment \<Rightarrow> bool" where
    "ipassmt_sanity_nowildcards ipassmt \<equiv> \<forall> iface \<in> dom ipassmt. \<not> iface_is_wildcard iface"

    text\<open>Executable of the @{typ "'i ipassignment"} is given as a list.\<close>

  (* use this in all exported code*)
  (*TODO: generate useful error message in exported code*)
  definition map_of_ipassmt :: "(iface \<times> ('i word \<times> nat) list) list \<Rightarrow> iface \<rightharpoonup> ('i word \<times> nat) list" where
    "map_of_ipassmt ipassmt = (
      if
        distinct (map fst ipassmt) \<and> ipassmt_sanity_nowildcards (map_of ipassmt)
      then
        map_of ipassmt
      else undefined \<^cancel>\<open>undefined_ipassmt_must_be_distinct_and_dont_have_wildcard_interfaces\<close>)"

  text\<open>some additional (optional) sanity checks\<close>

  text\<open>sanity check that there are no zone-spanning interfaces\<close>
  definition ipassmt_sanity_disjoint :: "'i::len ipassignment \<Rightarrow> bool" where
    "ipassmt_sanity_disjoint ipassmt \<equiv> \<forall> i1 \<in> dom ipassmt. \<forall> i2 \<in> dom ipassmt. i1 \<noteq> i2 \<longrightarrow>
          ipcidr_union_set (set (the (ipassmt i1))) \<inter> ipcidr_union_set (set (the (ipassmt i2))) = {}"

  lemma[code_unfold]: "ipassmt_sanity_disjoint (map_of ipassmt) \<longleftrightarrow>
    (let Is = fst` set ipassmt in
      (\<forall> i1 \<in> Is. \<forall> i2 \<in> Is. i1 \<noteq> i2 \<longrightarrow> wordinterval_empty (wordinterval_intersection (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i1))))  (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i2)))))))"
    apply(simp add: ipassmt_sanity_disjoint_def Map.dom_map_of_conv_image_fst)
    apply(simp add: ipcidr_union_set_def)
    apply(simp add: l2wi)
    apply(simp add: ipcidr_to_interval_def)
    using ipset_from_cidr_ipcidr_to_interval by blast

  text\<open>Checking that the ipassmt covers the complete ipv4 address space.\<close>
  definition ipassmt_sanity_complete :: "(iface \<times> ('i::len word \<times> nat) list) list \<Rightarrow> bool" where
    "ipassmt_sanity_complete ipassmt \<equiv> distinct (map fst ipassmt) \<and> (\<Union>(ipcidr_union_set ` set ` (ran (map_of ipassmt)))) = UNIV"

    lemma[code_unfold]: "ipassmt_sanity_complete ipassmt \<longleftrightarrow> distinct (map fst ipassmt) \<and> (let range = map snd ipassmt in
        wordinterval_eq (wordinterval_Union (map (l2wi \<circ> (map ipcidr_to_interval)) range)) wordinterval_UNIV
        )"
     apply(cases "distinct (map fst ipassmt)")
      apply(simp add: ipassmt_sanity_complete_def)
      apply(simp add: Map.ran_distinct)
      apply(simp add: wordinterval_eq_set_eq wordinterval_Union)
      apply(simp add: l2wi)
      apply(simp add: ipcidr_to_interval_def)
      apply(simp add: ipcidr_union_set_def ipset_from_cidr_ipcidr_to_interval; fail)
     apply(simp add: ipassmt_sanity_complete_def)
     done

    value[code] "ipassmt_sanity_nowildcards (map_of [(Iface ''eth1.1017'', [(ipv4addr_of_dotdecimal (131,159,14,240), 28)])])"

  fun collect_ifaces' :: "'i::len common_primitive rule list \<Rightarrow> iface list" where
    "collect_ifaces' [] = []" |
    "collect_ifaces' ((Rule m a)#rs) = filter (\<lambda>iface. iface \<noteq> ifaceAny) (
                                      (map (\<lambda>x. case x of Pos i \<Rightarrow> i | Neg i \<Rightarrow> i) (fst (primitive_extractor (is_Iiface, iiface_sel) m))) @
                                      (map (\<lambda>x. case x of Pos i \<Rightarrow> i | Neg i \<Rightarrow> i) (fst (primitive_extractor (is_Oiface, oiface_sel) m))) @ collect_ifaces' rs)"

  definition collect_ifaces :: "'i::len common_primitive rule list \<Rightarrow> iface list" where
    "collect_ifaces rs \<equiv> mergesort_remdups (collect_ifaces' rs)"
  lemma "set (collect_ifaces rs) = set (collect_ifaces' rs)"
    by(simp add: collect_ifaces_def mergesort_remdups_correct)

  text\<open>sanity check that all interfaces mentioned in the ruleset are also listed in the ipassmt. May fail for wildcard interfaces in the ruleset.\<close>

  (*primitive_extractor requires normalized_nnf_primitives*)
  definition ipassmt_sanity_defined :: "'i::len common_primitive rule list \<Rightarrow> 'i ipassignment \<Rightarrow> bool" where
    "ipassmt_sanity_defined rs ipassmt \<equiv> \<forall> iface \<in> set (collect_ifaces rs). iface \<in> dom ipassmt"

    lemma[code]: "ipassmt_sanity_defined rs ipassmt \<longleftrightarrow> (\<forall> iface \<in> set (collect_ifaces rs). ipassmt iface \<noteq> None)"
      by(simp add: ipassmt_sanity_defined_def Map.domIff)

    lemma "ipassmt_sanity_defined [
         Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (Match (IIface (Iface ''eth1.1017'')))) action.Accept,
         Rule (MatchAnd (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192,168,0,0)) 24))) (Match (IIface (ifaceAny)))) action.Accept,
         Rule MatchAny action.Drop]
             (map_of [(Iface ''eth1.1017'', [(ipv4addr_of_dotdecimal (131,159,14,240), 28)])])" by eval

  (*TODO: use and add code equation*)
  definition ipassmt_ignore_wildcard :: "'i::len ipassignment \<Rightarrow> 'i ipassignment" where
    "ipassmt_ignore_wildcard ipassmt \<equiv> \<lambda>k. case ipassmt k of None \<Rightarrow> None
                                                           | Some ips \<Rightarrow> if ipcidr_union_set (set ips) = UNIV then None else Some ips"

  lemma ipassmt_ignore_wildcard_le: "ipassmt_ignore_wildcard ipassmt \<subseteq>\<^sub>m ipassmt"
    apply(simp add: ipassmt_ignore_wildcard_def map_le_def)
    apply(clarify)
    apply(simp split: option.split_asm if_split_asm)
    done

  definition ipassmt_ignore_wildcard_list:: "(iface \<times> ('i::len word \<times> nat) list) list \<Rightarrow> (iface \<times> ('i word \<times> nat) list) list" where
    "ipassmt_ignore_wildcard_list ipassmt = filter (\<lambda>(_,ips).  \<not> wordinterval_eq (l2wi (map ipcidr_to_interval ips)) wordinterval_UNIV) ipassmt"

  (*distinct fst ipassmt notwendig?*)
  lemma "distinct (map fst ipassmt) \<Longrightarrow>
    map_of (ipassmt_ignore_wildcard_list ipassmt) = ipassmt_ignore_wildcard (map_of ipassmt)"
      apply(simp add: ipassmt_ignore_wildcard_list_def ipassmt_ignore_wildcard_def)
      apply(simp add: wordinterval_eq_set_eq)
      apply(simp add: l2wi)
      apply(simp add: ipcidr_to_interval_def)
      apply(simp add: fun_eq_iff)
      apply(clarify)
      apply(induction ipassmt)
       apply(simp; fail)
      apply(simp)
      apply(simp split:option.split option.split_asm)
      apply(simp add: ipcidr_union_set_def ipset_from_cidr_ipcidr_to_interval)
      apply(simp add: case_prod_unfold)
      by blast
      (*apply(safe)
                       apply(simp_all)
      by (simp add: rev_image_eqI)*)

  text\<open>Debug algorithm with human-readable output\<close>
  definition debug_ipassmt_generic
    :: "('i::len wordinterval \<Rightarrow> string) \<Rightarrow>
          (iface \<times> ('i word \<times> nat) list) list \<Rightarrow> 'i common_primitive rule list \<Rightarrow> string list" where
    "debug_ipassmt_generic toStr ipassmt rs \<equiv> let ifaces = (map fst ipassmt) in [
      ''distinct: '' @ (if distinct ifaces then ''passed'' else ''FAIL!'')
      , ''ipassmt_sanity_nowildcards: '' @
          (if ipassmt_sanity_nowildcards (map_of ipassmt)
           then ''passed'' else ''fail: ''@list_toString iface_sel (filter iface_is_wildcard ifaces))
      , ''ipassmt_sanity_defined (interfaces defined in the ruleset are also in ipassmt): '' @
          (if ipassmt_sanity_defined rs (map_of ipassmt)
           then ''passed'' else ''fail: ''@list_toString iface_sel [i \<leftarrow> (collect_ifaces rs). i \<notin> set ifaces])
      , ''ipassmt_sanity_disjoint (no zone-spanning interfaces): '' @
          (if ipassmt_sanity_disjoint (map_of ipassmt)
           then ''passed'' else ''fail: ''@list_toString (\<lambda>(i1,i2). ''('' @ iface_sel i1 @ '','' @ iface_sel i2 @ '')'')
               [(i1,i2) \<leftarrow> List.product ifaces ifaces. i1 \<noteq> i2 \<and>
                \<not> wordinterval_empty (wordinterval_intersection
                                        (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i1))))
                                        (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i2)))))
          ])
      , ''ipassmt_sanity_disjoint excluding UNIV interfaces: '' @
          (let ipassmt = ipassmt_ignore_wildcard_list ipassmt;
               ifaces = (map fst ipassmt)
           in
          (if ipassmt_sanity_disjoint (map_of ipassmt)
           then ''passed'' else ''fail: ''@list_toString (\<lambda>(i1,i2). ''('' @ iface_sel i1 @ '','' @ iface_sel i2 @ '')'')
               [(i1,i2) \<leftarrow> List.product ifaces ifaces. i1 \<noteq> i2 \<and>
                \<not> wordinterval_empty (wordinterval_intersection
                                        (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i1))))
                                        (l2wi (map ipcidr_to_interval (the ((map_of ipassmt) i2)))))
          ]))
       , ''ipassmt_sanity_complete: '' @
          (if ipassmt_sanity_complete ipassmt
           then ''passed''
           else ''the following is not covered: '' @
            toStr (wordinterval_setminus wordinterval_UNIV (wordinterval_Union (map (l2wi \<circ> (map ipcidr_to_interval)) (map snd ipassmt)))))
      , ''ipassmt_sanity_complete excluding UNIV interfaces: '' @
          (let ipassmt = ipassmt_ignore_wildcard_list ipassmt
           in
          (if ipassmt_sanity_complete ipassmt
           then ''passed''
           else ''the following is not covered: '' @
            toStr (wordinterval_setminus wordinterval_UNIV (wordinterval_Union (map (l2wi \<circ> (map ipcidr_to_interval)) (map snd ipassmt))))))
      ]"

  definition "debug_ipassmt_ipv4 \<equiv> debug_ipassmt_generic ipv4addr_wordinterval_toString"
  definition "debug_ipassmt_ipv6 \<equiv> debug_ipassmt_generic ipv6addr_wordinterval_toString"

  lemma dom_ipassmt_ignore_wildcard:
    "i\<in>dom (ipassmt_ignore_wildcard ipassmt) \<longleftrightarrow> i \<in> dom ipassmt \<and> ipcidr_union_set (set (the (ipassmt i))) \<noteq> UNIV"
    apply(simp add: ipassmt_ignore_wildcard_def)
    apply(rule)
     apply(clarify)
     apply(simp split: option.split_asm if_split_asm)
     apply blast
    apply(clarify)
    apply(simp)
    done

  lemma ipassmt_ignore_wildcard_the:
    "ipassmt i = Some ips \<Longrightarrow> ipcidr_union_set (set ips) \<noteq> UNIV \<Longrightarrow> (the (ipassmt_ignore_wildcard ipassmt i)) = ips"
    "ipassmt_ignore_wildcard ipassmt i = Some ips \<Longrightarrow> the (ipassmt i) = ips"
    "ipassmt_ignore_wildcard ipassmt i = Some ips \<Longrightarrow> ipcidr_union_set (set ips) \<noteq> UNIV"
    by (simp_all add: ipassmt_ignore_wildcard_def split: option.split_asm if_split_asm)

  lemma ipassmt_sanity_disjoint_ignore_wildcards:
        "ipassmt_sanity_disjoint (ipassmt_ignore_wildcard ipassmt) \<longleftrightarrow>
         (\<forall>i1\<in>dom ipassmt.
          \<forall>i2\<in>dom ipassmt.
            ipcidr_union_set (set (the (ipassmt i1))) \<noteq> UNIV \<and>
            ipcidr_union_set (set (the (ipassmt i2))) \<noteq> UNIV \<and>
            i1 \<noteq> i2
            \<longrightarrow> ipcidr_union_set (set (the (ipassmt i1))) \<inter> ipcidr_union_set (set (the (ipassmt i2))) = {})"
    apply(simp add: ipassmt_sanity_disjoint_def)
    apply(rule)
     apply(clarify)
     apply(simp)
     subgoal for i1 i2 ips1 ips2
     apply(erule_tac x=i1 in ballE)
      prefer 2
      using dom_ipassmt_ignore_wildcard  apply (metis domI option.sel)
     apply(erule_tac x=i2 in ballE)
      prefer 2
      using dom_ipassmt_ignore_wildcard apply (metis domI domIff option.sel)
     by(simp add: ipassmt_ignore_wildcard_the; fail)
    apply(clarify)
    apply(simp)
    subgoal for i1 i2 ips1 ips2
    apply(erule_tac x=i1 in ballE)
     prefer 2
     using dom_ipassmt_ignore_wildcard apply auto[1]
    apply(erule_tac x=i2 in ballE)
     prefer 2
     using dom_ipassmt_ignore_wildcard apply auto[1]
    by(simp add: ipassmt_ignore_wildcard_the)
   done

  text\<open>Confusing names: @{const ipassmt_sanity_nowildcards} refers to wildcard interfaces.
       @{const ipassmt_ignore_wildcard} refers to the UNIV ip range.
\<close>
  lemma ipassmt_sanity_nowildcards_ignore_wildcardD:
    "ipassmt_sanity_nowildcards ipassmt \<Longrightarrow> ipassmt_sanity_nowildcards (ipassmt_ignore_wildcard ipassmt)"
    by (simp add: dom_ipassmt_ignore_wildcard ipassmt_sanity_nowildcards_def)

 lemma ipassmt_disjoint_nonempty_inj:
     assumes ipassmt_disjoint: "ipassmt_sanity_disjoint ipassmt"
        and ifce: "ipassmt ifce = Some i_ips"
        and a: "ipcidr_union_set (set i_ips) \<noteq> {}"
        and k: "ipassmt k = Some i_ips"
     shows "k = ifce"
     proof(rule ccontr)
       assume "k \<noteq> ifce"
       with ifce k ipassmt_disjoint have "ipcidr_union_set (set (the (ipassmt k))) \<inter> ipcidr_union_set (set (the (ipassmt ifce))) = {}"
         unfolding ipassmt_sanity_disjoint_def by fastforce
       thus False using a ifce k by auto
     qed

  lemma ipassmt_ignore_wildcard_None_Some:
    "ipassmt_ignore_wildcard ipassmt ifce = None \<Longrightarrow> ipassmt ifce = Some ips \<Longrightarrow> ipcidr_union_set (set ips) = UNIV"
    by (metis domI domIff dom_ipassmt_ignore_wildcard option.sel)

 (*can this lemma be somehow useful?
   maybe when rewriting, we can try to rewrite in the ignore_wildcard space and just constrain the the other area?*)
 lemma ipassmt_disjoint_ignore_wildcard_nonempty_inj:
     assumes ipassmt_disjoint: "ipassmt_sanity_disjoint (ipassmt_ignore_wildcard ipassmt)"
        and ifce: "ipassmt ifce = Some i_ips"
        and a: "ipcidr_union_set (set i_ips) \<noteq> {}"
        and k: "(ipassmt_ignore_wildcard ipassmt) k = Some i_ips"
     shows "k = ifce"
     proof(rule ccontr)
       assume "k \<noteq> ifce"
       show False
       proof(cases "(ipassmt_ignore_wildcard ipassmt) ifce")
       case (Some i_ips') (*proofs mainly by sledgehammer*)
         hence "i_ips' = i_ips" using ifce ipassmt_ignore_wildcard_the(2) by fastforce
         hence "(ipassmt_ignore_wildcard ipassmt) k = Some i_ips" using Some ifce ipassmt_ignore_wildcard_def k by auto
         thus False using Some \<open>i_ips' = i_ips\<close> \<open>k \<noteq> ifce\<close> a ipassmt_disjoint ipassmt_disjoint_nonempty_inj by blast
       next
       case None
         with ipassmt_ignore_wildcard_None_Some have "ipcidr_union_set (set i_ips) = UNIV" using ifce by auto
         thus False using ipassmt_ignore_wildcard_the(3) k by blast
       qed
     qed

 lemma ipassmt_disjoint_inj_k:
     assumes ipassmt_disjoint: "ipassmt_sanity_disjoint ipassmt"
        and ifce: "ipassmt ifce = Some ips"
        and k: "ipassmt k = Some ips'"
        and a: "p \<in> ipcidr_union_set (set ips)"
        and b: "p \<in> ipcidr_union_set (set ips')"
     shows "k = ifce"
     proof(rule ccontr)
       assume "k \<noteq> ifce"
       with ipassmt_disjoint have
          "ipcidr_union_set (set (the (ipassmt k))) \<inter> ipcidr_union_set (set (the (ipassmt ifce))) = {}"
         unfolding ipassmt_sanity_disjoint_def using ifce k by blast
       hence "ipcidr_union_set (set ips') \<inter> ipcidr_union_set (set ips) = {}" by(simp add: k ifce)
       thus False using a b by blast
     qed

 (*might also work when we ignore UNIVs in the ipassmt? (not tested)*)
 lemma ipassmt_disjoint_matcheq_iifce_srcip:
        assumes ipassmt_nowild: "ipassmt_sanity_nowildcards ipassmt"
            and ipassmt_disjoint: "ipassmt_sanity_disjoint ipassmt"
            and ifce: "ipassmt ifce = Some i_ips"
            and p_ifce: "ipassmt (Iface (p_iiface p)) = Some p_ips \<and> p_src p \<in> ipcidr_union_set (set p_ips)"
        shows   "match_iface ifce (p_iiface p) \<longleftrightarrow> p_src p \<in> ipcidr_union_set (set i_ips)"
    proof
     assume "match_iface ifce (p_iiface p)"
     thus "p_src p \<in> ipcidr_union_set (set i_ips)"
       apply(cases "ifce = Iface (p_iiface p)")
        using ifce p_ifce apply force
       by (metis domI iface.sel iface_is_wildcard_def ifce ipassmt_nowild ipassmt_sanity_nowildcards_def match_iface.elims(2) match_iface_case_nowildcard)
   next
     assume a: "p_src p \<in> ipcidr_union_set (set i_ips)"
     \<comment> \<open>basically, we need to reverse the map @{term ipassmt}\<close>

     from ipassmt_disjoint_nonempty_inj[OF ipassmt_disjoint ifce] a have ipassmt_inj: "\<forall>k. ipassmt k = Some i_ips \<longrightarrow> k = ifce" by blast

     from ipassmt_disjoint_inj_k[OF ipassmt_disjoint ifce _ a] have ipassmt_inj_k:
      "\<And>k ips'. ipassmt k = Some ips' \<Longrightarrow> p_src p \<in> ipcidr_union_set (set ips') \<Longrightarrow> k = ifce" by simp

     have ipassmt_inj_p: "\<forall>ips'. p_src p \<in> ipcidr_union_set (set ips') \<and> (\<exists>k. ipassmt k = Some ips') \<longrightarrow> ips' = i_ips"
       apply(clarify)
       apply(rename_tac ips' k)
       apply(subgoal_tac "k = ifce")
        using ifce apply simp
       using ipassmt_inj_k by simp

     from p_ifce have "(Iface (p_iiface p)) = ifce" using ipassmt_inj_p ipassmt_inj by blast

     thus "match_iface ifce (p_iiface p)" using match_iface_refl by blast
   qed

  definition ipassmt_generic_ipv4 :: "(iface \<times> (32 word \<times> nat) list) list" where
    "ipassmt_generic_ipv4 = [(Iface ''lo'', [(ipv4addr_of_dotdecimal (127,0,0,0),8)])]"

  definition ipassmt_generic_ipv6 :: "(iface \<times> (128 word \<times> nat) list) list" where
    "ipassmt_generic_ipv6 = [(Iface ''lo'', [(1,128)])]" (*::1/128*)

subsection\<open>IP Assignment difference\<close>
  text\<open>Compare two ipassmts. Returns a list of tuples
    First entry of the tuple: things which are in the left ipassmt but not in the right.
    Second entry of the tupls: things which are in the right ipassmt but not in the left.\<close>
  definition ipassmt_diff
    :: "(iface \<times> ('i::len word \<times> nat) list) list \<Rightarrow> (iface \<times> ('i::len word \<times> nat) list) list
        \<Rightarrow> (iface \<times> ('i word \<times> nat) list \<times> ('i word \<times> nat) list) list"
  where
  "ipassmt_diff a b \<equiv> let
      t = \<lambda>s. (case s of None \<Rightarrow> Empty_WordInterval
                       | Some s \<Rightarrow> wordinterval_Union (map ipcidr_tuple_to_wordinterval s));
      k = \<lambda>x y d. cidr_split (wordinterval_setminus (t (map_of x d)) (t (map_of y d)))
    in
      [(d, (k a b d, k b a d)). d \<leftarrow> remdups (map fst (a @ b))]"

  text\<open>If an interface is defined in both ipassignments and there is no difference
       then the two ipassignements describe the same IP range for this interface.\<close>
  lemma ipassmt_diff_ifce_equal: "(ifce, [], []) \<in> set (ipassmt_diff ipassmt1 ipassmt2)  \<Longrightarrow>
         ifce \<in> dom (map_of ipassmt1) \<Longrightarrow> ifce \<in> dom (map_of ipassmt2) \<Longrightarrow>
           ipcidr_union_set (set (the ((map_of ipassmt1) ifce))) =
           ipcidr_union_set (set (the ((map_of ipassmt2) ifce)))"
    proof -
    have cidr_empty: "[] = cidr_split r \<Longrightarrow> wordinterval_to_set r = {}" for r :: "'a wordinterval"
      apply(subst cidr_split_prefix[symmetric])
      by(simp)
    show "(ifce, [], []) \<in> set (ipassmt_diff ipassmt1 ipassmt2)  \<Longrightarrow>
         ifce \<in> dom (map_of ipassmt1) \<Longrightarrow> ifce \<in> dom (map_of ipassmt2) \<Longrightarrow>
           ipcidr_union_set (set (the ((map_of ipassmt1) ifce))) =
           ipcidr_union_set (set (the ((map_of ipassmt2) ifce)))"
    apply(simp add: ipassmt_diff_def Let_def ipcidr_union_set_uncurry)
    apply(simp add: Set.image_iff)
    apply(elim conjE)
    apply(drule cidr_empty)+
    apply(simp)
    apply(simp add: domIff)
    apply(elim exE)
    apply(simp add: wordinterval_Union wordinterval_to_set_ipcidr_tuple_to_wordinterval_uncurry)
    done
  qed

  lemma ipcidr_union_cidr_split[simp]: "ipcidr_union_set (set (cidr_split a)) = wordinterval_to_set a"
    by(simp add: ipcidr_union_set_uncurry cidr_split_prefix)

  lemma
    defines "assmt as ifce \<equiv> ipcidr_union_set (set (the ((map_of as ifce))))"
    assumes diffs: "(ifce, d1, d2) \<in> set (ipassmt_diff ipassmt1 ipassmt2)"
        and  doms: "ifce \<in> dom (map_of ipassmt1)" "ifce \<in> dom (map_of ipassmt2)"
    shows "ipcidr_union_set (set d1) = assmt ipassmt1 ifce - assmt ipassmt2 ifce"
          "ipcidr_union_set (set d2) = assmt ipassmt2 ifce - assmt ipassmt1 ifce"
    using assms by (clarsimp simp add: ipassmt_diff_def Let_def assmt_def wordinterval_Union; simp add: ipcidr_union_set_uncurry uncurry_def wordinterval_to_set_ipcidr_tuple_to_wordinterval_uncurry)+

  text\<open>Explanation for interface @{term "Iface ''a''"}:
          Left ipassmt: The IP range 4/30 contains the addresses 4,5,6,7
          Diff: right ipassmt contains 6/32, so 4,5,7 is only in the left ipassmt.
          IP addresses 4,5 correspond to subnet 4/30.\<close>
  lemma "ipassmt_diff (ipassmt_generic_ipv4 @ [(Iface ''a'', [(4,30)])])
                       (ipassmt_generic_ipv4 @ [(Iface ''a'', [(6,32), (0,30)]), (Iface ''b'', [(42,32)])]) =
    [(Iface ''lo'', [], []),
     (Iface ''a'', [(4, 31),(7, 32)],
                   [(0, 30)]
     ),
     (Iface ''b'', [], [(42, 32)])]" by eval

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)
 *)

(* Author: Thomas Sewell *)

section "Enumeration Instances for Words"

theory Word_Enum
imports Enumeration Word_Lib
begin

instantiation word :: (len) enum
begin

definition
  "(enum_class.enum :: ('a :: len) word list) \<equiv> map of_nat [0 ..< 2 ^ LENGTH('a)]"

definition
  "enum_class.enum_all (P :: ('a :: len) word \<Rightarrow> bool) \<longleftrightarrow> Ball UNIV P"

definition
  "enum_class.enum_ex (P :: ('a :: len) word \<Rightarrow> bool) \<longleftrightarrow> Bex UNIV P"

instance
  apply (intro_classes)
     apply (force simp: enum_word_def)
    apply (simp add: distinct_map enum_word_def)
    apply (rule subset_inj_on, rule word_unat.Abs_inj_on)
    apply (clarsimp simp add: unats_def)
   apply (simp add: enum_all_word_def)
  apply (simp add: enum_ex_word_def)
  done

end

lemma fromEnum_unat[simp]: "fromEnum (x :: 'a::len word) = unat x"
proof -
  have "enum ! the_index enum x = x" by (auto intro: nth_the_index)
  moreover
  have "the_index enum x < length (enum::'a::len word list)" by (auto intro: the_index_bounded)
  moreover
  { fix y assume "of_nat y = x"
    moreover assume "y < 2 ^ LENGTH('a)"
    ultimately have "y = unat x" using of_nat_inverse by fastforce
  }
  ultimately
  show ?thesis by (simp add: fromEnum_def enum_word_def)
qed

lemma length_word_enum: "length (enum :: ('a :: len) word list) = 2 ^ LENGTH('a)"
  by (simp add: enum_word_def)

lemma toEnum_of_nat[simp]: "n < 2 ^ LENGTH('a) \<Longrightarrow> ((toEnum n) :: ('a :: len) word) = of_nat n"
  by (simp add: toEnum_def length_word_enum enum_word_def)

declare of_nat_diff [simp]

instantiation word :: (len) enumeration_both
begin

definition
  enum_alt_word_def: "enum_alt \<equiv> alt_from_ord (enum :: ('a :: len) word list)"

instance
  by (intro_classes, simp add: enum_alt_word_def)

end

definition
  upto_enum_step :: "('a :: len) word \<Rightarrow> 'a word \<Rightarrow> 'a word \<Rightarrow> 'a word list" ("[_ , _ .e. _]")
where
  "upto_enum_step a b c \<equiv>
      if c < a then [] else map (\<lambda>x. a + x * (b - a)) [0 .e. (c - a) div (b - a)]"
  (* in the wraparound case, bad things happen. *)

lemma maxBound_word:
  "(maxBound::'a::len word) = -1"
  by (simp add: maxBound_def enum_word_def last_map)

lemma minBound_word:
  "(minBound::'a::len word) = 0"
  by (simp add: minBound_def enum_word_def upt_conv_Cons)

lemma maxBound_max_word:
  "(maxBound::'a::len word) = max_word"
  by (simp add: maxBound_word max_word_minus [symmetric])

end


theory Lift_Fst_Snd imports Lift_Fst Lift_Snd
begin

locale fst_l_snd_l_ortho' =
  fixes l1 :: "('a, 'b1, 'c1 :: Pordb) lifting"
  fixes S1 :: "'a \<Rightarrow> 'c1 set"
  fixes l2 :: "('a, 'b2, 'c2 :: Pordb) lifting"
  fixes S2 :: "'a \<Rightarrow> 'c2 set"

locale fst_l_snd_l_ortho = fst_l_snd_l_ortho' +
  in1 : lifting_valid_base_ext l1 S1 +
  in2 : lifting_valid_base_ext l2 S2

sublocale fst_l_snd_l_ortho \<subseteq> out : l_ortho "fst_l l1" "fst_l_S S1" "snd_l l2" "snd_l_S S2"
proof
  fix s
  show "LBase (fst_l l1) s = LBase (snd_l l2) s"
    using in1.base in2.base
    by(auto simp add: fst_l_def snd_l_def)
next
  fix b :: "'c * 'e"
  fix s :: 'a
  fix a1 :: 'b
  fix a2 :: 'd

  obtain b1 b2 where B: "b = (b1, b2)"
    by(cases b; auto)

  then show "LUpd (fst_l l1) s a1 (LUpd (snd_l l2) s a2 b) = LUpd (snd_l l2) s a2 (LUpd (fst_l l1) s a1 b)"
    by(auto simp add: fst_l_def snd_l_def)

next

  fix b :: "'c * 'e"
  fix s :: 'a
  fix a1

  obtain b1 b2 where B: "b = (b1, b2)"
    by(cases b; auto)

  then show "LOut (snd_l l2) s (LUpd (fst_l l1) s a1 b) = LOut (snd_l l2) s b"
    by(auto simp add: fst_l_def snd_l_def)
next

  fix b :: "'c * 'e"
  fix s :: 'a
  fix a2 :: 'd

  obtain b1 b2 where B: "b = (b1, b2)"
    by(cases b; auto)

  then show "LOut (fst_l l1) s (LUpd (snd_l l2) s a2 b) = LOut (fst_l l1) s b"
    by(cases b; auto simp add: fst_l_def snd_l_def)

next
  fix b :: "'c * 'e"
  fix s :: 'a
  fix a1 :: 'b

  assume Bin : "b \<in> snd_l_S S2 s"

  obtain b1 b2 where B: "b = (b1, b2)"
    by(cases b; auto)

  then show " LUpd (fst_l l1) s a1 b \<in> snd_l_S S2 s" using Bin
    by(auto simp add: fst_l_def snd_l_S_def)
next
  fix b :: "'c * 'e"
  fix s :: 'a
  fix a2 :: 'd

  assume Bin: "b \<in> fst_l_S S1 s"
  obtain b1 b2 where B: "b = (b1, b2)"
    by(cases b; auto)

  then show "LUpd (snd_l l2) s a2 b \<in> fst_l_S S1 s" using Bin
    by(auto simp add: snd_l_def fst_l_S_def)
qed

lemma (in fst_l_snd_l_ortho) ax :
  shows "l_ortho (fst_l l1) (fst_l_S S1) (snd_l l2) (snd_l_S S2)"
  using out.l_ortho_axioms
  by auto

lemma (in fst_l_snd_l_ortho) ax_g :
  assumes H1 : "\<And> x . S'1 x = fst_l_S S1 x"
  assumes H2 : "\<And> x . S'2 x = snd_l_S S2 x"
  shows "l_ortho (fst_l l1) S'1 (snd_l l2) S'2"
proof-
  have H1' : "S'1 = fst_l_S S1"
    using H1 by auto
  have H2' : "S'2 = snd_l_S S2"
    using H2 by auto
  then show ?thesis using ax unfolding H1' H2'
    by auto
qed

(* commutative *)
lemma (in fst_l_snd_l_ortho) ax_comm :
  shows "l_ortho (snd_l l2) (snd_l_S S2) (fst_l l1) (fst_l_S S1)"
  using out.comm.l_ortho_axioms
  by auto

lemma (in fst_l_snd_l_ortho) ax_g_comm :
  assumes H1 : "\<And> x . S'2 x = snd_l_S S2 x"
  assumes H2 : "\<And> x . S'1 x = fst_l_S S1 x"
  shows "l_ortho (snd_l l2) S'2 (fst_l l1) S'1"
proof-
  have H1' : "S'2 = snd_l_S S2"
    using H1 by auto
  have H2' : "S'1 = fst_l_S S1"
    using H2 by auto
  then show ?thesis using ax_comm unfolding H1' H2'
    by auto
qed

locale fst_l_snd_l_ortho_ok_ext =
  fixes l1 :: "('a, 'b1, 'c1 :: {Pord_Weakb, Okay}) lifting"
  fixes l2 :: "('a, 'b2, 'c2 :: {Pord_Weakb, Okay}) lifting"

sublocale fst_l_snd_l_ortho_ok_ext \<subseteq> out : l_ortho_ok_ext "fst_l l1" "snd_l l2" .

locale fst_l_snd_l_ortho_base_ext =
  fst_l_snd_l_ortho' +
  in1 : lifting_valid_weak_base l1 S1 +
  in2 : lifting_valid_weak_base l2 S2

sublocale fst_l_snd_l_ortho_base_ext \<subseteq> out : l_ortho_base_ext "fst_l l1" "snd_l l2"
proof
  fix s
  show "LBase (fst_l l1) s = \<bottom>"
    using in1.base
    by(auto simp add: fst_l_def prod_bot)
next
  fix s
  show "LBase (snd_l l2) s = \<bottom>"
    using in2.base
    by(auto simp add: snd_l_def prod_bot)
qed

lemma (in fst_l_snd_l_ortho_base_ext) ax :
  shows "l_ortho_base_ext (fst_l l1) (snd_l l2)"
  using out.l_ortho_base_ext_axioms
  by auto

lemma (in fst_l_snd_l_ortho_base_ext) ax_comm :
  shows "l_ortho_base_ext (snd_l l2) (fst_l l1)"
  using out.comm.l_ortho_base_ext_axioms
  by auto

(*
(* TODO: this was originally lifting_valid_weak_pres, but i think we actually need strength
 * to make this work *)
locale fst_l_snd_l_ortho_pres =
  fst_l_snd_l_ortho +
  in1 : lifting_valid_pres l1 S1 +
  in2 : lifting_valid_pres l2 S2

sublocale fst_l_snd_l_ortho_pres \<subseteq> out : l_ortho_pres "fst_l l1" "fst_l_S S1" "snd_l l2" "snd_l_S S2"
proof
  fix a1 a2 s
  fix x :: "('c * 'e)"

  obtain x1 x2 where X: "x = (x1, x2)"
    by(cases x; auto)

  have Leq1 : "x1 <[ LUpd l1 s a1 x1"
    using in1.get_put by auto

  have Leq2 : "x2 <[ LUpd l2 s a2 x2"
    using in2.get_put by auto

  show "is_sup {LUpd (fst_l l1) s a1 x, LUpd (snd_l l2) s a2 x} (LUpd (fst_l l1) s a1 (LUpd (snd_l l2) s a2 x))"
  proof(rule is_supI)
    fix w

    assume W: "w \<in> {LUpd (fst_l l1) s a1 x, LUpd (snd_l l2) s a2 x}"

    obtain w1 w2 where "w = (w1, w2)"
      by(cases w; auto)

    show "w <[ LUpd (fst_l l1) s a1 (LUpd (snd_l l2) s a2 x)"
      using W X Leq1 Leq2
      by(auto simp add: fst_l_def snd_l_def prod_pleq leq_refl)
  next
    fix x'
    assume Ub : "is_ub {LUpd (fst_l l1) s a1 x, LUpd (snd_l l2) s a2 x} x'"

    obtain x'1 x'2 where X': "x' = (x'1, x'2)"
      by(cases x'; auto)

    have Leq1 : "LUpd (fst_l l1) s a1 x <[ x'"
      using is_ubE[OF Ub]
      by auto

    have Leq2 : "LUpd (snd_l l2) s a2 x <[ x'"
      using is_ubE[OF Ub]
      by auto

    show "LUpd (fst_l l1) s a1 (LUpd (snd_l l2) s a2 x) <[ x'"
      using X' X Leq1 Leq2
      by(auto simp add: fst_l_def snd_l_def prod_pleq)
  qed
qed
*)

end


(* Author: Alexander Maletzky *)

section \<open>Ordered Associative Lists for Polynomials\<close>

theory OAlist_Poly_Mapping
  imports PP_Type MPoly_Type_Class_Ordered OAlist
begin

text \<open>We introduce a dedicated type for ordered associative lists (oalists) representing polynomials.
  To that end, we require the order relation the oalists are sorted wrt. to be admissible term orders,
  and furthermore sort the lists @{emph \<open>descending\<close>} rather than @{emph \<open>ascending\<close>}, because this
  allows to implement various operations more efficiently.
  For technical reasons, we must restrict the type of terms to types embeddable into
  @{typ "(nat, nat) pp \<times> nat"}, though. All types we are interested in meet this requirement.\<close>

lemma comparator_lexicographic:
  fixes f::"'a \<Rightarrow> 'b" and g::"'a \<Rightarrow> 'c"
  assumes "comparator c1" and "comparator c2" and "\<And>x y. f x = f y \<Longrightarrow> g x = g y \<Longrightarrow> x = y"
  shows "comparator (\<lambda>x y. case c1 (f x) (f y) of Eq \<Rightarrow> c2 (g x) (g y) | val \<Rightarrow> val)"
          (is "comparator ?c3")
proof -
  from assms(1) interpret c1: comparator c1 .
  from assms(2) interpret c2: comparator c2 .
  show ?thesis
  proof
    fix x y :: 'a
    show "invert_order (?c3 x y) = ?c3 y x"
      by (simp add: c1.eq c2.eq split: order.split,
          metis invert_order.simps(1) invert_order.simps(2) c1.sym c2.sym order.distinct(5))
  next
    fix x y :: 'a
    assume "?c3 x y = Eq"
    hence "f x = f y" and "g x = g y" by (simp_all add: c1.eq c2.eq split: order.splits if_split_asm)
    thus "x = y" by (rule assms(3))
  next
    fix x y z :: 'a
    assume "?c3 x y = Lt"
    hence d1: "c1 (f x) (f y) = Lt \<or> (c1 (f x) (f y) = Eq \<and> c2 (g x) (g y) = Lt)"
      by (simp split: order.splits)
    assume "?c3 y z = Lt"
    hence d2: "c1 (f y) (f z) = Lt \<or> (c1 (f y) (f z) = Eq \<and> c2 (g y) (g z) = Lt)"
      by (simp split: order.splits)
    from d1 show "?c3 x z = Lt"
    proof
      assume 1: "c1 (f x) (f y) = Lt"
      from d2 show ?thesis
      proof
        assume "c1 (f y) (f z) = Lt"
        with 1 have "c1 (f x) (f z) = Lt" by (rule c1.trans)
        thus ?thesis by simp
      next
        assume "c1 (f y) (f z) = Eq \<and> c2 (g y) (g z) = Lt"
        hence "f z = f y" and "c2 (g y) (g z) = Lt" by (simp_all add: c1.eq)
        with 1 show ?thesis by simp
      qed
    next
      assume "c1 (f x) (f y) = Eq \<and> c2 (g x) (g y) = Lt"
      hence 1: "f x = f y" and 2: "c2 (g x) (g y) = Lt" by (simp_all add: c1.eq)
      from d2 show ?thesis
      proof
        assume "c1 (f y) (f z) = Lt"
        thus ?thesis by (simp add: 1)
      next
        assume "c1 (f y) (f z) = Eq \<and> c2 (g y) (g z) = Lt"
        hence 3: "f y = f z" and "c2 (g y) (g z) = Lt" by (simp_all add: c1.eq)
        from 2 this(2) have "c2 (g x) (g z) = Lt" by (rule c2.trans)
        thus ?thesis by (simp add: 1 3)
      qed
    qed
  qed
qed

class nat_term =
  fixes rep_nat_term :: "'a \<Rightarrow> ((nat, nat) pp \<times> nat)"
    and splus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes rep_nat_term_inj: "rep_nat_term x = rep_nat_term y \<Longrightarrow> x = y"
    and full_component: "snd (rep_nat_term x) = i \<Longrightarrow> (\<exists>y. rep_nat_term y = (t, i))"
    and splus_term: "rep_nat_term (splus x y) = pprod.splus (fst (rep_nat_term x)) (rep_nat_term y)"
begin

definition "lex_comp_aux = (\<lambda>x y. case comp_of_ord lex_pp (fst (rep_nat_term x)) (fst (rep_nat_term y)) of
                                      Eq \<Rightarrow> comparator_of (snd (rep_nat_term x)) (snd (rep_nat_term y)) | val \<Rightarrow> val)"

lemma full_componentE:
  assumes "snd (rep_nat_term x) = i"
  obtains y where "rep_nat_term y = (t, i)"
proof -
  from assms have "\<exists>y. rep_nat_term y = (t, i)" by (rule full_component)
  then obtain y where "rep_nat_term y = (t, i)" ..
  thus ?thesis ..
qed

end

class nat_pp_term = nat_term + zero + plus +
  assumes rep_nat_term_zero: "rep_nat_term 0 = (0, 0)"
    and splus_pp_term: "splus = (+)"

definition nat_term_comp :: "'a::nat_term comparator \<Rightarrow> bool"
  where "nat_term_comp cmp \<longleftrightarrow>
              (\<forall>u v. snd (rep_nat_term u) = snd (rep_nat_term v) \<longrightarrow> fst (rep_nat_term u) = 0 \<longrightarrow> cmp u v \<noteq> Gt) \<and>
              (\<forall>u v. fst (rep_nat_term u) = fst (rep_nat_term v) \<longrightarrow> snd (rep_nat_term u) < snd (rep_nat_term v) \<longrightarrow> cmp u v = Lt) \<and>
              (\<forall>t u v. cmp u v = Lt \<longrightarrow> cmp (splus t u) (splus t v) = Lt) \<and>
              (\<forall>u v a b. fst (rep_nat_term u) = fst (rep_nat_term a) \<longrightarrow> fst (rep_nat_term v) = fst (rep_nat_term b) \<longrightarrow>
                  snd (rep_nat_term u) = snd (rep_nat_term v) \<longrightarrow> snd (rep_nat_term a) = snd (rep_nat_term b) \<longrightarrow>
                  cmp a b = Lt \<longrightarrow> cmp u v = Lt)"

lemma nat_term_compI:
  assumes "\<And>u v. snd (rep_nat_term u) = snd (rep_nat_term v) \<Longrightarrow> fst (rep_nat_term u) = 0 \<Longrightarrow> cmp u v \<noteq> Gt"
    and "\<And>u v. fst (rep_nat_term u) = fst (rep_nat_term v) \<Longrightarrow> snd (rep_nat_term u) < snd (rep_nat_term v) \<Longrightarrow> cmp u v = Lt"
    and "\<And>t u v. cmp u v = Lt \<Longrightarrow> cmp (splus t u) (splus t v) = Lt"
    and "\<And>u v a b. fst (rep_nat_term u) = fst (rep_nat_term a) \<Longrightarrow> fst (rep_nat_term v) = fst (rep_nat_term b) \<Longrightarrow>
                  snd (rep_nat_term u) = snd (rep_nat_term v) \<Longrightarrow> snd (rep_nat_term a) = snd (rep_nat_term b) \<Longrightarrow>
                  cmp a b = Lt \<Longrightarrow> cmp u v = Lt"
  shows "nat_term_comp cmp"
  unfolding nat_term_comp_def fst_conv snd_conv using assms by blast

lemma nat_term_compD1:
  assumes "nat_term_comp cmp" and "snd (rep_nat_term u) = snd (rep_nat_term v)" and "fst (rep_nat_term u) = 0"
  shows "cmp u v \<noteq> Gt"
  using assms unfolding nat_term_comp_def fst_conv by blast

lemma nat_term_compD2:
  assumes "nat_term_comp cmp" and "fst (rep_nat_term u) = fst (rep_nat_term v)" and "snd (rep_nat_term u) < snd (rep_nat_term v)"
  shows "cmp u v = Lt"
  using assms unfolding nat_term_comp_def fst_conv snd_conv by blast

lemma nat_term_compD3:
  assumes "nat_term_comp cmp" and "cmp u v = Lt"
  shows "cmp (splus t u) (splus t v) = Lt"
  using assms unfolding nat_term_comp_def snd_conv by blast

lemma nat_term_compD4:
  assumes "nat_term_comp cmp" and "fst (rep_nat_term u) = fst (rep_nat_term a)"
    and "fst (rep_nat_term v) = fst (rep_nat_term b)" and "snd (rep_nat_term u) = snd (rep_nat_term v)"
    and "snd (rep_nat_term a) = snd (rep_nat_term b)" and "cmp a b = Lt"
  shows "cmp u v = Lt"
  using assms unfolding nat_term_comp_def snd_conv by blast

lemma nat_term_compD1':
  assumes "comparator cmp" and "nat_term_comp cmp" and "snd (rep_nat_term u) \<le> snd (rep_nat_term v)"
    and "fst (rep_nat_term u) = 0"
  shows "cmp u v \<noteq> Gt"
proof (cases "snd (rep_nat_term u) = snd (rep_nat_term v)")
  case True
  with assms(2) show ?thesis using assms(4) by (rule nat_term_compD1)
next
  from assms(1) interpret cmp: comparator cmp .
  case False
  with assms(3) have a: "snd (rep_nat_term u) < snd (rep_nat_term v)" by simp
  from refl obtain w::'a where eq: "rep_nat_term w = (0, snd (rep_nat_term v))" by (rule full_componentE)
  have "cmp u w = Lt" by (rule nat_term_compD2, fact assms(2), simp_all add: eq assms(4) a)
  moreover have "cmp w v \<noteq> Gt" by (rule nat_term_compD1, fact assms(2), simp_all add: eq)
  ultimately show "cmp u v \<noteq> Gt" by (simp add: cmp.nGt_le_conv cmp.Lt_lt_conv)
qed

lemma nat_term_compD4':
  assumes "comparator cmp" and "nat_term_comp cmp" and "fst (rep_nat_term u) = fst (rep_nat_term a)"
    and "fst (rep_nat_term v) = fst (rep_nat_term b)" and "snd (rep_nat_term u) = snd (rep_nat_term v)"
    and "snd (rep_nat_term a) = snd (rep_nat_term b)"
  shows "cmp u v = cmp a b"
proof -
  from assms(1) interpret cmp: comparator cmp .
  show ?thesis
  proof (cases "cmp a b")
    case Eq
    hence "fst (rep_nat_term u) = fst (rep_nat_term v)" by (simp add: cmp.eq assms(3, 4))
    hence "rep_nat_term u = rep_nat_term v" using assms(5) by (rule prod_eqI)
    hence "u = v" by (rule rep_nat_term_inj)
    thus ?thesis by (simp add: Eq)
  next
    case Lt
    with assms(2, 3, 4, 5, 6) have "cmp u v = Lt" by (rule nat_term_compD4)
    thus ?thesis by (simp add: Lt)
  next
    case Gt
    hence "cmp b a = Lt" by (simp only: cmp.Gt_lt_conv cmp.Lt_lt_conv)
    with assms(2, 4, 3) assms(5, 6)[symmetric] have "cmp v u = Lt" by (rule nat_term_compD4)
    hence "cmp u v = Gt" by (simp only: cmp.Gt_lt_conv cmp.Lt_lt_conv)
    thus ?thesis by (simp add: Gt)
  qed
qed

lemma nat_term_compD4'':
  assumes "comparator cmp" and "nat_term_comp cmp" and "fst (rep_nat_term u) = fst (rep_nat_term a)"
    and "fst (rep_nat_term v) = fst (rep_nat_term b)" and "snd (rep_nat_term u) \<le> snd (rep_nat_term v)"
    and "snd (rep_nat_term a) = snd (rep_nat_term b)" and "cmp a b \<noteq> Gt"
  shows "cmp u v \<noteq> Gt"
proof (cases "snd (rep_nat_term u) = snd (rep_nat_term v)")
  case True
  with assms(1, 2, 3, 4) have "cmp u v = cmp a b" using assms(6) by (rule nat_term_compD4')
  thus ?thesis using assms(7) by simp
next
  case False
  from assms(1) interpret cmp: comparator cmp .
  from refl obtain w::'a where w: "rep_nat_term w = (fst (rep_nat_term u), snd (rep_nat_term v))"
    by (rule full_componentE)
  have 1: "fst (rep_nat_term w) = fst (rep_nat_term a)" and 2: "snd (rep_nat_term w) = snd (rep_nat_term v)"
    by (simp_all add: w assms(3))
  from False assms(5) have *: "snd (rep_nat_term u) < snd (rep_nat_term v)" by simp
  have "cmp u w = Lt" by (rule nat_term_compD2, fact assms(2), simp_all add: * w)
  moreover from assms(1, 2) 1 assms(4) 2 assms(6) have "cmp w v = cmp a b" by (rule nat_term_compD4')
  ultimately show ?thesis using assms(7) by (metis cmp.nGt_le_conv cmp.nLt_le_conv cmp.trans)
qed

lemma comparator_lex_comp_aux: "comparator (lex_comp_aux::'a::nat_term comparator)"
  unfolding lex_comp_aux_def
proof (rule comparator_composition)
  from lex_pp_antisym have as: "antisymp lex_pp" by (rule antisympI)
  have "comparator (comp_of_ord (lex_pp::(nat, nat) pp \<Rightarrow> _))"
    unfolding comp_of_ord_eq_comp_of_ords[OF as]
    by (rule comp_of_ords, unfold_locales,
        auto simp: lex_pp_refl intro: lex_pp_trans lex_pp_lin' elim!: lex_pp_antisym)
  thus "comparator (\<lambda>x y::((nat, nat) pp \<times> nat). case comp_of_ord lex_pp (fst x) (fst y) of
                                          Eq \<Rightarrow> comparator_of (snd x) (snd y) | val \<Rightarrow> val)"
    using comparator_of prod_eqI by (rule comparator_lexicographic)
next
  from rep_nat_term_inj show "inj rep_nat_term" by (rule injI)
qed

lemma nat_term_comp_lex_comp_aux: "nat_term_comp (lex_comp_aux::'a::nat_term comparator)"
proof -
  from lex_pp_antisym have as: "antisymp lex_pp" by (rule antisympI)
  interpret lex: comparator "comp_of_ord (lex_pp::(nat, nat) pp \<Rightarrow> _)"
    unfolding comp_of_ord_eq_comp_of_ords[OF as]
    by (rule comp_of_ords, unfold_locales,
        auto simp: lex_pp_refl intro: lex_pp_trans lex_pp_lin' elim!: lex_pp_antisym)
  show ?thesis
  proof (rule nat_term_compI)
    fix u v :: 'a
    assume 1: "snd (rep_nat_term u) = snd (rep_nat_term v)" and 2: "fst (rep_nat_term u) = 0"
    show "lex_comp_aux u v \<noteq> Gt"
      by (simp add: lex_comp_aux_def 1 2 split: order.split, simp add: comp_of_ord_def lex_pp_zero_min)
  next
    fix u v :: 'a
    assume 1: "fst (rep_nat_term u) = fst (rep_nat_term v)" and 2: "snd (rep_nat_term u) < snd (rep_nat_term v)"
    show "lex_comp_aux u v = Lt"
      by (simp add: lex_comp_aux_def 1 split: order.split, simp add: comparator_of_def 2)
  next
    fix t u v :: 'a
    show "lex_comp_aux u v = Lt \<Longrightarrow> lex_comp_aux (splus t u) (splus t v) = Lt"
      by (auto simp: lex_comp_aux_def splus_term pprod.splus_def comp_of_ord_def lex_pp_refl
          split: order.splits if_splits intro: lex_pp_plus_monotone')
  next
    fix u v a b :: 'a
    assume "fst (rep_nat_term u) = fst (rep_nat_term a)" and "fst (rep_nat_term v) = fst (rep_nat_term b)"
      and "snd (rep_nat_term a) = snd (rep_nat_term b)" and "lex_comp_aux a b = Lt"
    thus "lex_comp_aux u v = Lt" by (simp add: lex_comp_aux_def split: order.splits)
  qed
qed

typedef (overloaded) 'a nat_term_order =
  "{cmp::'a::nat_term comparator. comparator cmp \<and> nat_term_comp cmp}"
  morphisms nat_term_compare Abs_nat_term_order
proof (rule, simp)
  from comparator_lex_comp_aux nat_term_comp_lex_comp_aux
  show "comparator lex_comp_aux \<and> nat_term_comp lex_comp_aux" ..
qed

lemma nat_term_compare_Abs_nat_term_order_id:
  assumes "comparator cmp" and "nat_term_comp cmp"
  shows "nat_term_compare (Abs_nat_term_order cmp) = cmp"
  by (rule Abs_nat_term_order_inverse, simp add: assms)

instantiation nat_term_order :: (type) equal
begin

definition equal_nat_term_order :: "'a nat_term_order \<Rightarrow> 'a nat_term_order \<Rightarrow> bool" where "equal_nat_term_order = (=)"

instance by (standard, simp add: equal_nat_term_order_def)

end

definition nat_term_compare_inv :: "'a nat_term_order \<Rightarrow> 'a::nat_term comparator"
  where "nat_term_compare_inv to = (\<lambda>x y. nat_term_compare to y x)"

definition key_order_of_nat_term_order :: "'a nat_term_order \<Rightarrow> 'a::nat_term key_order"
  where key_order_of_nat_term_order_def [code del]:
    "key_order_of_nat_term_order to = Abs_key_order (nat_term_compare to)"

definition key_order_of_nat_term_order_inv :: "'a nat_term_order \<Rightarrow> 'a::nat_term key_order"
  where key_order_of_nat_term_order_inv_def [code del]:
    "key_order_of_nat_term_order_inv to = Abs_key_order (nat_term_compare_inv to)"

definition le_of_nat_term_order :: "'a nat_term_order \<Rightarrow> 'a \<Rightarrow> 'a::nat_term \<Rightarrow> bool"
  where "le_of_nat_term_order to = le_of_key_order (key_order_of_nat_term_order to)"

definition lt_of_nat_term_order :: "'a nat_term_order \<Rightarrow> 'a \<Rightarrow> 'a::nat_term \<Rightarrow> bool"
  where "lt_of_nat_term_order to = lt_of_key_order (key_order_of_nat_term_order to)"

definition nat_term_order_of_le :: "'a::{linorder,nat_term} nat_term_order"
  where "nat_term_order_of_le = Abs_nat_term_order (comparator_of)"

lemma comparator_nat_term_compare: "comparator (nat_term_compare to)"
  using nat_term_compare by blast

lemma nat_term_comp_nat_term_compare: "nat_term_comp (nat_term_compare to)"
  using nat_term_compare by blast

lemma nat_term_compare_conv: "nat_term_compare to = key_compare (key_order_of_nat_term_order to)"
  unfolding key_order_of_nat_term_order_def
  by (rule sym, rule Abs_key_order_inverse, simp add: comparator_nat_term_compare)

lemma comparator_nat_term_compare_inv: "comparator (nat_term_compare_inv to)"
  unfolding nat_term_compare_inv_def using comparator_nat_term_compare by (rule comparator_converse)

lemma nat_term_compare_inv_conv: "nat_term_compare_inv to = key_compare (key_order_of_nat_term_order_inv to)"
  unfolding key_order_of_nat_term_order_inv_def
  by (rule sym, rule Abs_key_order_inverse, simp add: comparator_nat_term_compare_inv)

lemma nat_term_compare_inv_alt [code_unfold]: "nat_term_compare_inv to x y = nat_term_compare to y x"
  by (simp only: nat_term_compare_inv_def)

lemma le_of_nat_term_order [code]: "le_of_nat_term_order to x y = (nat_term_compare to x y \<noteq> Gt)"
  by (simp add: le_of_key_order_alt le_of_nat_term_order_def nat_term_compare_conv)

lemma lt_of_nat_term_order [code]: "lt_of_nat_term_order to x y = (nat_term_compare to x y = Lt)"
  by (simp add: lt_of_key_order_alt lt_of_nat_term_order_def nat_term_compare_conv)

lemma le_of_nat_term_order_alt:
  "le_of_nat_term_order to = (\<lambda>u v. ko.le (key_order_of_nat_term_order_inv to) v u)"
  by (intro ext, simp add: le_of_comp_def nat_term_compare_inv_conv[symmetric] le_of_nat_term_order_def
      le_of_key_order_def nat_term_compare_conv[symmetric] nat_term_compare_inv_alt)

lemma lt_of_nat_term_order_alt:
  "lt_of_nat_term_order to = (\<lambda>u v. ko.lt (key_order_of_nat_term_order_inv to) v u)"
  by (intro ext, simp add: lt_of_comp_def nat_term_compare_inv_conv[symmetric] lt_of_nat_term_order_def
      lt_of_key_order_def nat_term_compare_conv[symmetric] nat_term_compare_inv_alt)

lemma linorder_le_of_nat_term_order: "class.linorder (le_of_nat_term_order to) (lt_of_nat_term_order to)"
  unfolding le_of_nat_term_order_alt lt_of_nat_term_order_alt using ko.linorder
  by (rule linorder.dual_linorder)

lemma le_of_nat_term_order_zero_min: "le_of_nat_term_order to 0 (t::'a::nat_pp_term)"
  unfolding le_of_nat_term_order
  by (rule nat_term_compD1', fact comparator_nat_term_compare, fact nat_term_comp_nat_term_compare, simp_all add: rep_nat_term_zero)

global_interpretation ko_ntm: comparator "nat_term_compare_inv ko"
  defines lookup_pair_ko_ntm = ko_ntm.lookup_pair
  and update_by_pair_ko_ntm = ko_ntm.update_by_pair
  and update_by_fun_pair_ko_ntm = ko_ntm.update_by_fun_pair
  and update_by_fun_gr_pair_ko_ntm = ko_ntm.update_by_fun_gr_pair
  and map2_val_pair_ko_ntm = ko_ntm.map2_val_pair
  and lex_ord_pair_ko_ntm = ko_ntm.lex_ord_pair
  and prod_ord_pair_ko_ntm = ko_ntm.prod_ord_pair
  and sort_oalist_ko_ntm' = ko_ntm.sort_oalist
  by (fact comparator_nat_term_compare_inv)

lemma ko_ntm_le: "ko_ntm.le to = (\<lambda>x y. le_of_nat_term_order to y x)"
  by (intro ext, simp add: le_of_comp_def le_of_nat_term_order nat_term_compare_inv_def split: order.split)

global_interpretation ko_ntm: oalist_raw key_order_of_nat_term_order_inv
  rewrites "comparator.lookup_pair (key_compare (key_order_of_nat_term_order_inv ko)) = lookup_pair_ko_ntm ko"
  and "comparator.update_by_pair (key_compare (key_order_of_nat_term_order_inv ko)) = update_by_pair_ko_ntm ko"
  and "comparator.update_by_fun_pair (key_compare (key_order_of_nat_term_order_inv ko)) = update_by_fun_pair_ko_ntm ko"
  and "comparator.update_by_fun_gr_pair (key_compare (key_order_of_nat_term_order_inv ko)) = update_by_fun_gr_pair_ko_ntm ko"
  and "comparator.map2_val_pair (key_compare (key_order_of_nat_term_order_inv ko)) = map2_val_pair_ko_ntm ko"
  and "comparator.lex_ord_pair (key_compare (key_order_of_nat_term_order_inv ko)) = lex_ord_pair_ko_ntm ko"
  and "comparator.prod_ord_pair (key_compare (key_order_of_nat_term_order_inv ko)) = prod_ord_pair_ko_ntm ko"
  and "comparator.sort_oalist (key_compare (key_order_of_nat_term_order_inv ko)) = sort_oalist_ko_ntm' ko"
  defines sort_oalist_aux_ko_ntm = ko_ntm.sort_oalist_aux
  and lookup_ko_ntm = ko_ntm.lookup_raw
  and sorted_domain_ko_ntm = ko_ntm.sorted_domain_raw
  and tl_ko_ntm = ko_ntm.tl_raw
  and min_key_val_ko_ntm = ko_ntm.min_key_val_raw
  and update_by_ko_ntm = ko_ntm.update_by_raw
  and update_by_fun_ko_ntm = ko_ntm.update_by_fun_raw
  and update_by_fun_gr_ko_ntm = ko_ntm.update_by_fun_gr_raw
  and map2_val_ko_ntm = ko_ntm.map2_val_raw
  and lex_ord_ko_ntm = ko_ntm.lex_ord_raw
  and prod_ord_ko_ntm = ko_ntm.prod_ord_raw
  and oalist_eq_ko_ntm = ko_ntm.oalist_eq_raw
  and sort_oalist_ko_ntm = ko_ntm.sort_oalist_raw
  subgoal by (simp only: lookup_pair_ko_ntm_def nat_term_compare_inv_conv)
  subgoal by (simp only: update_by_pair_ko_ntm_def nat_term_compare_inv_conv)
  subgoal by (simp only: update_by_fun_pair_ko_ntm_def nat_term_compare_inv_conv)
  subgoal by (simp only: update_by_fun_gr_pair_ko_ntm_def nat_term_compare_inv_conv)
  subgoal by (simp only: map2_val_pair_ko_ntm_def nat_term_compare_inv_conv)
  subgoal by (simp only: lex_ord_pair_ko_ntm_def nat_term_compare_inv_conv)
  subgoal by (simp only: prod_ord_pair_ko_ntm_def nat_term_compare_inv_conv)
  subgoal by (simp only: sort_oalist_ko_ntm'_def nat_term_compare_inv_conv)
  done

typedef (overloaded) ('a, 'b) oalist_ntm =
    "{xs::('a, 'b::zero, 'a::nat_term nat_term_order) oalist_raw. ko_ntm.oalist_inv xs}"
  morphisms list_of_oalist_ntm Abs_oalist_ntm
  by (auto simp: ko_ntm.oalist_inv_def intro: ko.oalist_inv_raw_Nil)

lemma oalist_ntm_eq_iff: "xs = ys \<longleftrightarrow> list_of_oalist_ntm xs = list_of_oalist_ntm ys"
  by (simp add: list_of_oalist_ntm_inject)

lemma oalist_ntm_eqI: "list_of_oalist_ntm xs = list_of_oalist_ntm ys \<Longrightarrow> xs = ys"
  by (simp add: oalist_ntm_eq_iff)

text \<open>Formal, totalized constructor for @{typ "('a, 'b) oalist_ntm"}:\<close>

definition OAlist_ntm :: "('a \<times> 'b) list \<times> 'a nat_term_order \<Rightarrow> ('a::nat_term, 'b::zero) oalist_ntm"
  where "OAlist_ntm xs = Abs_oalist_ntm (sort_oalist_ko_ntm xs)"

definition "oalist_of_list_ntm = OAlist_ntm"

lemma oalist_inv_list_of_oalist_ntm: "ko_ntm.oalist_inv (list_of_oalist_ntm xs)"
  using list_of_oalist_ntm[of xs] by simp

lemma list_of_oalist_OAlist_ntm: "list_of_oalist_ntm (OAlist_ntm xs) = sort_oalist_ko_ntm xs"
proof -
  obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
  have "ko_ntm.oalist_inv (sort_oalist_ko_ntm' ox xs', ox)"
    using ko_ntm.oalist_inv_sort_oalist_raw by fastforce
  thus ?thesis by (simp add: xs OAlist_ntm_def Abs_oalist_ntm_inverse)
qed

lemma OAlist_list_of_oalist_ntm [simp, code abstype]: "OAlist_ntm (list_of_oalist_ntm xs) = xs"
proof -
  obtain xs' ox where xs: "list_of_oalist_ntm xs = (xs', ox)" by fastforce
  have "ko_ntm.oalist_inv_raw ox xs'"
    by (simp add: xs[symmetric] ko_ntm.oalist_inv_alt[symmetric] nat_term_compare_inv_conv oalist_inv_list_of_oalist_ntm)
  thus ?thesis by (simp add: xs OAlist_ntm_def ko_ntm.sort_oalist_id, simp add: list_of_oalist_ntm_inverse xs[symmetric])
qed

lemma [code abstract]: "list_of_oalist_ntm (oalist_of_list_ntm xs) = sort_oalist_ko_ntm xs"
  by (simp add: list_of_oalist_OAlist_ntm oalist_of_list_ntm_def)

global_interpretation oa_ntm: oalist_abstract key_order_of_nat_term_order_inv list_of_oalist_ntm OAlist_ntm
  defines OAlist_lookup_ntm = oa_ntm.lookup
  and OAlist_sorted_domain_ntm = oa_ntm.sorted_domain
  and OAlist_empty_ntm = oa_ntm.empty
  and OAlist_reorder_ntm = oa_ntm.reorder
  and OAlist_tl_ntm = oa_ntm.tl
  and OAlist_hd_ntm = oa_ntm.hd
  and OAlist_except_min_ntm = oa_ntm.except_min
  and OAlist_min_key_val_ntm = oa_ntm.min_key_val
  and OAlist_insert_ntm = oa_ntm.insert
  and OAlist_update_by_fun_ntm = oa_ntm.update_by_fun
  and OAlist_update_by_fun_gr_ntm = oa_ntm.update_by_fun_gr
  and OAlist_filter_ntm = oa_ntm.filter
  and OAlist_map2_val_neutr_ntm = oa_ntm.map2_val_neutr
  and OAlist_eq_ntm = oa_ntm.oalist_eq
  apply unfold_locales
  subgoal by (fact oalist_inv_list_of_oalist_ntm)
  subgoal by (simp only: list_of_oalist_OAlist_ntm sort_oalist_ko_ntm_def)
  subgoal by (fact OAlist_list_of_oalist_ntm)
  done

global_interpretation oa_ntm: oalist_abstract3 key_order_of_nat_term_order_inv
    "list_of_oalist_ntm::('a, 'b) oalist_ntm \<Rightarrow> ('a, 'b::zero, 'a::nat_term nat_term_order) oalist_raw" OAlist_ntm
    "list_of_oalist_ntm::('a, 'c) oalist_ntm \<Rightarrow> ('a, 'c::zero, 'a nat_term_order) oalist_raw" OAlist_ntm
    "list_of_oalist_ntm::('a, 'd) oalist_ntm \<Rightarrow> ('a, 'd::zero, 'a nat_term_order) oalist_raw" OAlist_ntm
  defines OAlist_map_val_ntm = oa_ntm.map_val
  and OAlist_map2_val_ntm = oa_ntm.map2_val
  and OAlist_map2_val_rneutr_ntm = oa_ntm.map2_val_rneutr
  and OAlist_lex_ord_ntm = oa_ntm.lex_ord
  and OAlist_prod_ord_ntm = oa_ntm.prod_ord ..

lemmas OAlist_lookup_ntm_single = oa_ntm.lookup_oalist_of_list_single[folded oalist_of_list_ntm_def]

end (* theory *)


(* Title: CTR/Tests/CTR_Tests.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

A test suite for the sub-framework CTR.
*)

section\<open>A test suite for CTR\<close>
theory CTR_Tests
  imports
    "../CTR"
    "../../IML_UT/IML_UT"
    Complex_Main
  keywords "ctr_test" :: thy_defn
begin

subsection\<open>Background\<close>

ML\<open>

type ctr_test_data =
  {
    ctr_type : string,
    synthesis : (string * thm list option) option,
    elems: (string, string, Facts.ref) Element.ctxt list,
    type_specs : (string * string) list,
    thm_specs : ((binding option * thm) * mixfix) list
  };

structure CTRTestData = Generic_Data
  (
    type T = ctr_test_data Symtab.table
    val empty = Symtab.empty
    val merge = Symtab.merge (K true)
  );

val get_ctr_test_data_generic = CTRTestData.get;
val get_ctr_test_data_proof = Context.Proof #> get_ctr_test_data_generic;
val get_ctr_test_data_global = Context.Theory #> get_ctr_test_data_generic;
fun test_data_of_generic context = context
  |> get_ctr_test_data_generic
  |> Symtab.lookup;
val ctr_test_data_of_proof = Context.Proof #> test_data_of_generic;

(*oversimplified: to be used with care*)
fun update_ctr_test_data k ctr_test_data =
  Local_Theory.declaration
    {pervasive=true, syntax=false}
    (fn _ => (k, ctr_test_data) |> Symtab.update |> CTRTestData.map);

fun process_ctr_test_data (k, args) (lthy : local_theory) =
  let
    fun preprocess_thm_specs lthy =
      map (apfst (apsnd (singleton (Attrib.eval_thms lthy))))
    fun process_ctrs_impl (CTR.ALG_PP _) (lthy : local_theory) = lthy
      | process_ctrs_impl
          (CTR.ALG_RP (((synthesis, elems), type_specs), thm_specs))
          (lthy : local_theory) =
          let
            val thm_specs' = preprocess_thm_specs lthy thm_specs
            val synthesis' = Option.map
              (apsnd (Option.map ((single #> Attrib.eval_thms lthy))))
              synthesis
            val data : ctr_test_data =
              {
                ctr_type = "relativization",
                synthesis = synthesis',
                elems = elems,
                type_specs = type_specs,
                thm_specs = thm_specs'
              }
          in update_ctr_test_data k data lthy end
  in process_ctrs_impl args lthy end;

val ctr_test_parser = Parse.string -- CTR.ctr_parser;

val _ =
  Outer_Syntax.local_theory
    \<^command_keyword>\<open>ctr_test\<close>
    "test setup for the command ctr"
    (ctr_test_parser >> process_ctr_test_data);

\<close>

definition mono where
  "mono f \<longleftrightarrow> (\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y)"

ud \<open>mono\<close>

definition mono_ow ::
  "'a set \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
  where "mono_ow UB leb lea f \<equiv> \<forall>x\<in>UB. \<forall>y\<in>UB. lea x y \<longrightarrow> leb (f x) (f y)"

typedef 'a K = \<open>{xs::'a list. length xs = 2}\<close>
  by (simp add: Ex_list_of_length)

definition KK :: "'a K \<Rightarrow> 'a K \<Rightarrow> bool"
  where "KK k1 k2 \<equiv> k1 = k2"

typedef 'a L = \<open>{xs::'a list. length xs = 2}\<close>
  by (simp add: Ex_list_of_length)

definition LL :: "'a L \<Rightarrow> 'a L \<Rightarrow> bool"
  where "LL k1 k2 \<equiv> k1 = k2"

definition rel_L ::
  "('a::group_add \<Rightarrow> 'b::group_add \<Rightarrow> bool) \<Rightarrow>
  'a::group_add L \<Rightarrow>
  'b::group_add L \<Rightarrow>
  bool"
  where "rel_L A b c = True"

ctr_relator rel_L

definition not_binders_binrelT ::
  "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
  where "not_binders_binrelT R1 R2 a b = True"

definition no_dup_binrelT ::
  "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
  where "no_dup_binrelT R1 R2 a b = True"

definition not_binders_binrelT_ftv_stv ::
  "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> (nat \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
  where "not_binders_binrelT_ftv_stv R1 R2 a b = True"

definition not_type_constructor_lhs ::
  "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a K \<Rightarrow> bool"
  where "not_type_constructor_lhs R1 R2 a b = True"

definition not_type_constructor_rhs ::
  "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> 'a K \<Rightarrow> 'e \<Rightarrow> bool"
  where "not_type_constructor_rhs R1 R2 a b = True"

definition not_identical_type_constructors ::
  "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> 'a K \<Rightarrow> 'e L \<Rightarrow> bool"
  where "not_identical_type_constructors R1 R2 a b = True"

definition not_identical_type_constructors_lhs ::
  "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> 'a K \<Rightarrow> 'b K \<Rightarrow> bool"
  where "not_identical_type_constructors_lhs R1 R2 a b = True"

definition not_identical_type_constructors_rhs ::
  "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a K \<Rightarrow> 'c K \<Rightarrow> bool"
  where "not_identical_type_constructors_rhs R1 a b = True"

subsection\<open>Test data\<close>

lemma mono_ow_transfer':
  includes lifting_syntax
  assumes [transfer_domain_rule, transfer_rule]: "Domainp B = (\<lambda>x. x \<in> UB)"
    and [transfer_rule]: "right_total B"
  shows
    "((A ===> A ===> (=)) ===> (B ===> B ===> (=)) ===> (B ===> A) ===> (=))
      (mono_ow UB) mono.with"
  unfolding mono_ow_def mono.with_def
  by (transfer_prover_start, transfer_step+) simp

ctr_test "mono_with" relativization
  synthesis ctr_simps_Collect_mem_eq
  assumes [transfer_domain_rule, transfer_rule]:
    "Domainp (B::'c\<Rightarrow>'d\<Rightarrow>bool) = (\<lambda>x. x \<in> UB)"
    and [transfer_rule]: "right_total B"
  trp (?'b \<open>A::'a\<Rightarrow>'b\<Rightarrow>bool\<close>) and (?'a B)
  in mono_ow': mono.with_def

ctr_test "exI" relativization
  in mono_ow'': exI

ctr_test "binrel" relativization
  synthesis ctr_simps_Collect_mem_eq
  assumes [transfer_domain_rule, transfer_rule]:
    "Domainp (B::'c\<Rightarrow>'d\<Rightarrow>bool) = (\<lambda>x. x \<in> UB)"
    and [transfer_rule]: "right_total B"
  trp (?'b A) and (?'a B)
  in mono_ow': mono.with_def

ctr_test "binrel_ftv" relativization
  synthesis ctr_simps_Collect_mem_eq
  assumes [transfer_domain_rule, transfer_rule]:
    "Domainp (B::'c\<Rightarrow>'d\<Rightarrow>bool) = (\<lambda>x. x \<in> UB)"
    and [transfer_rule]: "right_total B"
  trp (?'b \<open>A::nat\<Rightarrow>'b\<Rightarrow>bool\<close>) and (?'a B)
  in mono_ow': mono.with_def

ctr_test "dup_stvs" relativization
  synthesis ctr_simps_Collect_mem_eq
  assumes [transfer_domain_rule, transfer_rule]:
    "Domainp (B::'c\<Rightarrow>'d\<Rightarrow>bool) = (\<lambda>x. x \<in> UB)"
    and [transfer_rule]: "right_total B"
  trp (?'b \<open>A::'a\<Rightarrow>'b\<Rightarrow>bool\<close>) and (?'b B)
  in mono_ow': mono.with_def

ctr_test "dup_binrel_ftvs" relativization
  synthesis ctr_simps_Collect_mem_eq
  assumes [transfer_domain_rule, transfer_rule]:
    "Domainp (B::'c\<Rightarrow>'d\<Rightarrow>bool) = (\<lambda>x. x \<in> UB)"
    and [transfer_rule]: "right_total B"
  trp (?'b \<open>A::'a\<Rightarrow>'d\<Rightarrow>bool\<close>) and (?'a B)
  in mono_ow': mono.with_def

ctr_test "no_relator" relativization
  synthesis ctr_simps_Collect_mem_eq
  assumes [transfer_domain_rule, transfer_rule]:
    "Domainp (B::'c\<Rightarrow>'d\<Rightarrow>bool) = (\<lambda>x. x \<in> UB)"
    and [transfer_rule]: "right_total B"
  trp (?'b \<open>A::'a\<Rightarrow>'b\<Rightarrow>bool\<close>) and (?'a B)
  in KK_def

ctr_test "invalid_relator" relativization
  synthesis ctr_simps_Collect_mem_eq
  assumes [transfer_domain_rule, transfer_rule]:
    "Domainp (B::'c\<Rightarrow>'d\<Rightarrow>bool) = (\<lambda>x. x \<in> UB)"
    and [transfer_rule]: "right_total B"
  trp (?'b \<open>A::'a\<Rightarrow>'b\<Rightarrow>bool\<close>) and (?'a B)
  in LL_def

subsection\<open>Tests\<close>

subsubsection\<open>\<open>process_relativization\<close>\<close>

ML_file\<open>CTR_TEST_PROCESS_RELATIVIZATION.ML\<close>

context
  includes lifting_syntax
begin
ML\<open>
Lecker.test_group @{context} () [ctr_test_process_relativization.test_suite]
\<close>
end

subsubsection\<open>\<open>process_ctr_relator\<close>\<close>

ML_file\<open>CTR_TEST_PROCESS_CTR_RELATOR.ML\<close>

context
  includes lifting_syntax
begin
ML\<open>
Lecker.test_group @{context} () [ctr_test_process_ctr_relator.test_suite]
\<close>
end

end


section \<open>Imperative Implementation of Dijkstra's Shortest Paths Algorithm\<close>
theory Sepref_Dijkstra
imports
  "../IICF/IICF"
  "../Sepref_ICF_Bindings"
  Dijkstra_Shortest_Path.Dijkstra
  Dijkstra_Shortest_Path.Test
  "HOL-Library.Code_Target_Numeral"
  (*"../../../DFS_Framework/Misc/DFS_Framework_Refine_Aux"*)
  Sepref_WGraph
begin

(* Setup for Infty *)

instantiation infty :: (heap) heap
begin
  instance
    apply standard
    apply (rule_tac x="\<lambda>Infty \<Rightarrow> 0 | Num a \<Rightarrow> to_nat a + 1" in exI)
    apply (rule injI)
    apply (auto split: infty.splits)
    done
end

fun infty_assn where
  "infty_assn A (Num x) (Num y) = A x y"
| "infty_assn A Infty Infty = emp"
| "infty_assn _ _ _ = false"

text \<open>Connection with \<open>infty_rel\<close>\<close>
lemma infty_assn_pure_conv: "infty_assn (pure A) = pure (\<langle>A\<rangle>infty_rel)"
  apply (intro ext)
  subgoal for x y by (cases x; cases y; simp add: pure_def)
  done

lemmas [sepref_import_rewrite, fcomp_norm_unfold, sepref_frame_normrel_eqs] =
  infty_assn_pure_conv[symmetric]
lemmas [constraint_simps] = infty_assn_pure_conv

lemma infty_assn_pure[safe_constraint_rules]: "is_pure A \<Longrightarrow> is_pure (infty_assn A)"
  by (auto simp: is_pure_conv infty_assn_pure_conv)

lemma infty_assn_id[simp]: "infty_assn id_assn = id_assn"
  by (simp add: infty_assn_pure_conv)

lemma [safe_constraint_rules]: "IS_BELOW_ID R \<Longrightarrow> IS_BELOW_ID (\<langle>R\<rangle>infty_rel)"
  by (auto simp: infty_rel_def IS_BELOW_ID_def)

sepref_register Num Infty

lemma Num_hnr[sepref_fr_rules]: "(return o Num,RETURN o Num)\<in>A\<^sup>d \<rightarrow>\<^sub>a infty_assn A"
  by sepref_to_hoare sep_auto

lemma Infty_hnr[sepref_fr_rules]: "(uncurry0 (return Infty),uncurry0 (RETURN Infty))\<in>unit_assn\<^sup>k \<rightarrow>\<^sub>a infty_assn A"
  by sepref_to_hoare sep_auto

sepref_register case_infty
lemma [sepref_monadify_arity]: "case_infty \<equiv> \<lambda>\<^sub>2f1 f2 x. SP case_infty$f1$(\<lambda>\<^sub>2x. f2$x)$x"
  by simp
lemma [sepref_monadify_comb]: "case_infty$f1$f2$x \<equiv> (\<bind>)$(EVAL$x)$(\<lambda>\<^sub>2x. SP case_infty$f1$f2$x)" by simp
lemma [sepref_monadify_comb]: "EVAL$(case_infty$f1$(\<lambda>\<^sub>2x. f2 x)$x)
  \<equiv> (\<bind>)$(EVAL$x)$(\<lambda>\<^sub>2x. SP case_infty$(EVAL $ f1)$(\<lambda>\<^sub>2x. EVAL $ f2 x)$x)"
  apply (rule eq_reflection)
  by (simp split: infty.splits)

lemma infty_assn_ctxt: "infty_assn A x y = z \<Longrightarrow> hn_ctxt (infty_assn A) x y = z"
  by (simp add: hn_ctxt_def)

lemma infty_cases_hnr[sepref_prep_comb_rule, sepref_comb_rules]:
  fixes A e e'
  defines [simp]: "INVe \<equiv> hn_invalid (infty_assn A) e e'"
  assumes FR: "\<Gamma> \<Longrightarrow>\<^sub>t hn_ctxt (infty_assn A) e e' * F"
  assumes Infty: "\<lbrakk>e = Infty; e' = Infty\<rbrakk> \<Longrightarrow> hn_refine (hn_ctxt (infty_assn A) e e' * F) f1' (hn_ctxt XX1 e e' * \<Gamma>1') R f1"
  assumes Num: "\<And>x1 x1a. \<lbrakk>e = Num x1; e' = Num x1a\<rbrakk> \<Longrightarrow> hn_refine (hn_ctxt A x1 x1a * INVe * F) (f2' x1a) (hn_ctxt A' x1 x1a * hn_ctxt XX2 e e' * \<Gamma>2') R (f2 x1)"
  assumes MERGE2[unfolded hn_ctxt_def]: "\<Gamma>1' \<or>\<^sub>A \<Gamma>2' \<Longrightarrow>\<^sub>t \<Gamma>'"
  shows "hn_refine \<Gamma> (case_infty f1' f2' e') (hn_ctxt (infty_assn A') e e' * \<Gamma>') R (case_infty$f1$(\<lambda>\<^sub>2x. f2 x)$e)"
  apply (rule hn_refine_cons_pre[OF FR])
  apply1 extract_hnr_invalids
  apply (cases e; cases e'; simp add: infty_assn.simps[THEN infty_assn_ctxt])
  subgoal
    apply (rule hn_refine_cons[OF _ Infty _ entt_refl]; assumption?)
    applyS (simp add: hn_ctxt_def)
    apply (subst mult.commute, rule entt_fr_drop)
    apply (rule entt_trans[OF _ MERGE2])
    apply (simp add:)
  done
  subgoal
    apply (rule hn_refine_cons[OF _ Num _ entt_refl]; assumption?)
    applyS (simp add: hn_ctxt_def)
    apply (rule entt_star_mono)
    apply1 (rule entt_fr_drop)
    applyS (simp add: hn_ctxt_def)
    apply1 (rule entt_trans[OF _ MERGE2])
    applyS (simp add:)
  done
  done

lemma hnr_val[sepref_fr_rules]: "(return o Weight.val,RETURN o Weight.val) \<in> [\<lambda>x. x\<noteq>Infty]\<^sub>a (infty_assn A)\<^sup>d \<rightarrow> A"
  apply sepref_to_hoare
  subgoal for x y by (cases x; cases y; sep_auto)
  done

context
  fixes A :: "'a::weight \<Rightarrow> 'b \<Rightarrow> assn"
  fixes plusi
  assumes GA[unfolded GEN_ALGO_def, sepref_fr_rules]: "GEN_ALGO plusi (\<lambda>f. (uncurry f,uncurry (RETURN oo (+)))\<in>A\<^sup>k*\<^sub>aA\<^sup>k \<rightarrow>\<^sub>a A)"
begin
  sepref_thm infty_plus_impl is "uncurry (RETURN oo (+))" :: "((infty_assn A)\<^sup>k *\<^sub>a (infty_assn A)\<^sup>k \<rightarrow>\<^sub>a infty_assn A)"
    unfolding infty_plus_eq_plus[symmetric] infty_plus_def[abs_def]
    by sepref
end
concrete_definition infty_plus_impl uses infty_plus_impl.refine_raw is "(uncurry ?impl,_)\<in>_"
lemmas [sepref_fr_rules] = infty_plus_impl.refine

definition infty_less where
  "infty_less lt a b \<equiv> case (a,b) of (Num a, Num b) \<Rightarrow> lt a b | (Num _, Infty) \<Rightarrow> True | _ \<Rightarrow> False"

lemma infty_less_param[param]:
  "(infty_less,infty_less) \<in> (R\<rightarrow>R\<rightarrow>bool_rel) \<rightarrow> \<langle>R\<rangle>infty_rel \<rightarrow> \<langle>R\<rangle>infty_rel \<rightarrow> bool_rel"
  unfolding infty_less_def[abs_def]
  by parametricity

lemma infty_less_eq_less: "infty_less (<) = (<)"
  unfolding infty_less_def[abs_def]
  apply (clarsimp intro!: ext)
  subgoal for a b by (cases a; cases b; auto)
  done

context
  fixes A :: "'a::weight \<Rightarrow> 'b \<Rightarrow> assn"
  fixes lessi
  assumes GA[unfolded GEN_ALGO_def, sepref_fr_rules]: "GEN_ALGO lessi (\<lambda>f. (uncurry f,uncurry (RETURN oo (<)))\<in>A\<^sup>k*\<^sub>aA\<^sup>k \<rightarrow>\<^sub>a bool_assn)"
begin
  sepref_thm infty_less_impl is "uncurry (RETURN oo (<))" :: "((infty_assn A)\<^sup>k *\<^sub>a (infty_assn A)\<^sup>k \<rightarrow>\<^sub>a bool_assn)"
    unfolding infty_less_eq_less[symmetric] infty_less_def[abs_def]
    by sepref
end
concrete_definition infty_less_impl uses infty_less_impl.refine_raw is "(uncurry ?impl,_)\<in>_"
lemmas [sepref_fr_rules] = infty_less_impl.refine

lemma param_mpath': "(mpath',mpath')
  \<in> \<langle>\<langle>A\<times>\<^sub>r B \<times>\<^sub>r A\<rangle>list_rel \<times>\<^sub>r B\<rangle>option_rel \<rightarrow> \<langle>\<langle>A\<times>\<^sub>r B \<times>\<^sub>r A\<rangle>list_rel\<rangle>option_rel"
proof -
  have 1: "mpath' = map_option fst"
    apply (intro ext, rename_tac x)
    apply (case_tac x)
    apply simp
    apply (rename_tac a)
    apply (case_tac a)
    apply simp
    done
  show ?thesis
    unfolding 1
    by parametricity
qed
lemmas (in -) [sepref_import_param] = param_mpath'

lemma param_mpath_weight':
  "(mpath_weight', mpath_weight') \<in> \<langle>\<langle>A\<times>\<^sub>rB\<times>\<^sub>rA\<rangle>list_rel \<times>\<^sub>r B\<rangle>option_rel \<rightarrow> \<langle>B\<rangle>infty_rel"
  by (auto elim!: option_relE simp: infty_rel_def top_infty_def)

lemmas [sepref_import_param] = param_mpath_weight'

context Dijkstra begin
  lemmas impl_aux = mdijkstra_def[unfolded mdinit_def mpop_min_def mupdate_def]

  lemma mdijkstra_correct:
    "(mdijkstra, SPEC (is_shortest_path_map v0)) \<in> \<langle>br \<alpha>r res_invarm\<rangle>nres_rel"
  proof -
    note mdijkstra_refines
    also note dijkstra'_refines
    also note dijkstra_correct
    finally show ?thesis
      by (rule nres_relI)
  qed

end

locale Dijkstra_Impl = fixes w_dummy :: "'W::{weight,heap}"
begin
  text \<open>Weights\<close>
  sepref_register "0::'W"
  lemmas [sepref_import_param] =
    IdI[of "0::'W"]

  abbreviation "weight_assn \<equiv> id_assn :: 'W \<Rightarrow> _"

  lemma w_plus_param: "((+), (+)::'W\<Rightarrow>_) \<in> Id \<rightarrow> Id \<rightarrow> Id" by simp
  lemma w_less_param: "((<), (<)::'W\<Rightarrow>_) \<in> Id \<rightarrow> Id \<rightarrow> Id" by simp
  lemmas [sepref_import_param] = w_plus_param w_less_param
  lemma [sepref_gen_algo_rules]:
    "GEN_ALGO (return oo (+)) (\<lambda>f. (uncurry f, uncurry (RETURN \<circ>\<circ> (+))) \<in> id_assn\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow>\<^sub>a id_assn)"
    "GEN_ALGO (return oo (<)) (\<lambda>f. (uncurry f, uncurry (RETURN \<circ>\<circ> (<))) \<in> id_assn\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow>\<^sub>a id_assn)"
    by (sep_auto simp: GEN_ALGO_def pure_def intro!: hfrefI hn_refineI)+

  lemma conv_prio_pop_min: "prio_pop_min m = do {
      ASSERT (dom m \<noteq> {});
      ((k,v),m) \<leftarrow> mop_pm_pop_min id m;
      RETURN (k,v,m)
    }"
    unfolding prio_pop_min_def mop_pm_pop_min_def
    by (auto simp: pw_eq_iff refine_pw_simps ran_def)
end

context fixes N :: nat and w_dummy::"'W::{heap,weight}" begin

  interpretation Dijkstra_Impl w_dummy .

  definition "drmap_assn2 \<equiv> IICF_Sepl_Binding.iam.assn
    (pure (node_rel N))
    (prod_assn
      (list_assn (prod_assn (pure (node_rel N)) (prod_assn weight_assn (pure (node_rel N)))))
      weight_assn)
    "

  concrete_definition mdijkstra' uses Dijkstra.impl_aux

  sepref_definition dijkstra_imp is "uncurry mdijkstra'"
    :: "(is_graph N (Id::('W\<times>'W) set))\<^sup>k *\<^sub>a (pure (node_rel N))\<^sup>k \<rightarrow>\<^sub>a drmap_assn2"
    unfolding mdijkstra'_def
    apply (subst conv_prio_pop_min)
    apply (rewrite in "RETURN (_,\<hole>)" iam.fold_custom_empty)
    apply (rewrite hm_fold_custom_empty_sz[of N])
    apply (rewrite in "_(_ \<mapsto> (\<hole>,0))" HOL_list.fold_custom_empty)
    unfolding drmap_assn2_def
    using [[id_debug, goals_limit = 1]]
    by sepref
  export_code dijkstra_imp checking SML_imp
end

text \<open>The main correctness theorem\<close>

thm Dijkstra.mdijkstra_correct

lemma mdijkstra'_aref: "(uncurry mdijkstra',uncurry (SPEC oo weighted_graph.is_shortest_path_map))
  \<in> [\<lambda>(G,v0). Dijkstra G v0]\<^sub>f Id\<times>\<^sub>rId \<rightarrow> \<langle>br Dijkstra.\<alpha>r Dijkstra.res_invarm\<rangle>nres_rel"
  using Dijkstra.mdijkstra_correct
  by (fastforce intro!: frefI simp: mdijkstra'.refine[symmetric])

definition "drmap_assn N \<equiv> hr_comp (drmap_assn2 N) (br Dijkstra.\<alpha>r Dijkstra.res_invarm)"

context notes [fcomp_norm_unfold] = drmap_assn_def[symmetric] begin

theorem dijkstra_imp_correct: "(uncurry (dijkstra_imp N), uncurry (SPEC \<circ>\<circ> weighted_graph.is_shortest_path_map))
  \<in> [\<lambda>(G, v0). v0 \<in> nodes G \<and> (\<forall>(v, w, v') \<in> edges G. 0 \<le> w)]\<^sub>a (is_graph N Id)\<^sup>k *\<^sub>a (node_assn N)\<^sup>k \<rightarrow> drmap_assn N"
  apply (rule hfref_weaken_pre'[OF _ dijkstra_imp.refine[FCOMP mdijkstra'_aref]])
proof clarsimp
  fix G :: "(nat,'w::{weight,heap}) graph" and v0
  assume v0_is_node: "v0 \<in> nodes G"
    and nonneg_weights: "\<forall>(v, w, v') \<in> edges G. 0 \<le> w"
    and "v0<N"
    and RDOM: "rdomp (is_graph N Id) G"

  from RDOM interpret valid_graph G unfolding is_graph_def rdomp_def by auto

  from RDOM have [simp]: "finite V" unfolding is_graph_def rdomp_def by auto

  from RDOM have "\<forall>v\<in>V. {(w, v'). (v, w, v') \<in> E} \<in>
    Range (\<langle>Id \<times>\<^sub>r node_rel N\<rangle>list_set_rel)"
    by (auto simp: succ_def is_graph_def rdomp_def)
  hence "\<forall>v\<in>V. finite {(w, v'). (v, w, v') \<in> E}"
    unfolding list_set_rel_range by simp
  hence "finite (Sigma V (\<lambda>v. {(w, v'). (v, w, v') \<in> E}))"
    by auto
  also have "E \<subseteq> (Sigma V (\<lambda>v. {(w, v'). (v, w, v') \<in> E}))"
    using E_valid
    by auto
  finally (finite_subset[rotated]) have [simp]: "finite E" .

  show "Dijkstra G v0"
    apply (unfold_locales)
    unfolding is_graph_def using v0_is_node nonneg_weights
    by auto
qed

end

corollary dijkstra_imp_rule: "
  <is_graph n Id G Gi * \<up>(v0 \<in> nodes G \<and> (\<forall>(v, w, v') \<in> edges G. 0 \<le> w))>
    dijkstra_imp n Gi v0
  <\<lambda>mi. (is_graph n Id) G Gi
      * (\<exists>\<^sub>Am. drmap_assn n m mi * \<up>(weighted_graph.is_shortest_path_map G v0 m)) >\<^sub>t"
  using dijkstra_imp_correct[to_hnr, of v0 G n v0 Gi]
  unfolding hn_refine_def
  apply (clarsimp)
  apply (erule cons_rule[rotated -1])
  apply (sep_auto simp: hn_ctxt_def pure_def is_graph_def)
  apply (sep_auto simp: hn_ctxt_def)
  done

end


theory CheckerExe
  imports TheoryExe ProofTerm
begin

abbreviation "exetyp_ok \<Theta> \<equiv> exetyp_ok_sig (exesig \<Theta>)"

lemma typ_ok_code:
  assumes "exe_wf_theory' \<Theta>"
  shows "typ_ok (translate_theory \<Theta>) ty = exetyp_ok \<Theta> ty"
  using assms typ_ok_sig_code
  by (metis exe_sig_conds_def exe_wf_theory.simps exe_wf_theory_code exesignature.exhaust
      exetheory.sel(1) sig.simps translate_theory.elims typ_ok_def wf_type_iff_typ_ok_sig)

definition [simp]: "execlass_leq cs c1 c2 = List.member cs (c1,c2)"
lemma execlass_leq_code: "class_leq (set cs) c1 c2 = execlass_leq cs c1 c2"
  by (simp add: class_leq_def class_les_def member_def)

definition "exesort_leq sub s1 s2 = (\<forall>c\<^sub>2 \<in> s2 . \<exists>c\<^sub>1 \<in> s1. execlass_leq sub c\<^sub>1 c\<^sub>2)"
lemma exesort_les_code: "sort_leq (set cs) c1 c2 = exesort_leq cs c1 c2"
  by (simp add: execlass_leq_code exesort_leq_def sort_leq_def)

fun exehas_sort :: "exeosig \<Rightarrow> typ \<Rightarrow> sort \<Rightarrow> bool" where
"exehas_sort oss (Tv _ S) S' = exesort_leq (execlasses oss) S S'" |
"exehas_sort oss (Ty a Ts) S =
  (case lookup (\<lambda>k. k=a) (exetcsigs oss) of
  None \<Rightarrow> False |
  Some mgd \<Rightarrow> (\<forall>C \<in> S.
    case lookup (\<lambda>k. k=C) mgd of
        None \<Rightarrow> False
      | Some Ss \<Rightarrow> list_all2 (exehas_sort oss) Ts Ss))"

(* cleanup *)
lemma exehas_sort_imp_has_sort:
  assumes "exe_osig_conds (sub, tcs)"
  shows "exehas_sort (sub, tcs) T S \<Longrightarrow> has_sort (translate_osig (sub, tcs)) T S"
proof (induction T arbitrary: S)
  case (Ty n Ts)
  obtain sub' tcs' where sub'_tcs': "translate_osig (sub, tcs) = (sub', tcs')" by fastforce
  obtain mgd where mgd: "tcs' n = Some mgd"
    using Ty.prems sub'_tcs' apply (simp split: option.splits)
    by (metis assms exe_ars_conds_def exe_osig_conds_def in_alist_imp_in_map_of lookup_eq_map_of_ap
        map_of_SomeD snd_conv)
  show ?case
  proof (subst sub'_tcs', rule has_sort_Ty[of tcs', OF mgd], rule ballI)
    fix c assume asm: "c\<in>S"

    have l: "lookup (\<lambda>k. k=n) (map (apsnd map_of) tcs) = Some mgd"
      by (metis assms lookup_eq_map_of_ap mgd snd_conv sub'_tcs' translate_ars.simps translate_osig.simps)
    hence "\<exists>x. (lookup (\<lambda>k. k=n) tcs) = Some x"
      by (induction tcs) auto
    from this obtain pre_mgd where pre_mgd: "(lookup (\<lambda>k. k=n) tcs) = Some pre_mgd"
      by blast
    have pre_mgd_mgd: "map_of pre_mgd = mgd"
      by (metis l assms exe_ars_conds_def
          exe_osig_conds_def in_alist_imp_in_map_of lookup_eq_map_of_ap map_of_SomeD
          option.sel pre_mgd snd_conv translate_ars.simps)

    obtain Ss where Ss: "lookup (\<lambda>k. k=c) pre_mgd = Some Ss"
      using Ty.prems asm by (auto simp add: pre_mgd split: option.splits)
    hence cond: "list_all2 (exehas_sort (sub,tcs)) Ts Ss"
      using \<open>exehas_sort (sub, tcs) (Ty n Ts) S\<close>asm pre_mgd by (auto split: option.splits)

    from Ss have "mgd c = Some Ss"
      by (simp add: lookup_eq_map_of_ap pre_mgd_mgd)
    then show "\<exists>Ss. mgd c = Some Ss \<and> list_all2 (has_sort (sub', tcs')) Ts Ss"
      using cond Ty.IH list.rel_mono_strong sub'_tcs' by force
  qed
next
  case (Tv n S)
  then show ?case
    by (metis assms exehas_sort.simps(1) exesort_les_code has_sort_Tv prod.collapse translate_osig.simps)
qed

lemma has_sort_imp_exehas_sort:
  assumes "exe_osig_conds (sub, tcs)"
  shows "has_sort (translate_osig (sub, tcs)) T S \<Longrightarrow> exehas_sort (sub, tcs) T S"
proof (induction T arbitrary: S)
  case (Ty n Ts)
  obtain sub' tcs' where sub'_tcs': "translate_osig (sub, tcs) = (sub', tcs')" by fastforce
  obtain mgd where mgd: "tcs' n = Some mgd"
    using Ty.prems sub'_tcs' has_sort.simps by (auto split: option.splits)
  hence "lookup (\<lambda>k. k=n) (map (apsnd map_of) tcs) = Some mgd"
    by (metis assms lookup_eq_map_of_ap prod.inject sub'_tcs' translate_ars.simps translate_osig.simps)
  have l: "lookup (\<lambda>k. k=n) (map (apsnd map_of) tcs) = Some mgd"
    by (metis assms lookup_eq_map_of_ap mgd snd_conv sub'_tcs'
        translate_ars.simps translate_osig.simps)
  hence "\<exists>x. (lookup (\<lambda>k. k=n) tcs) = Some x"
    by (induction tcs) auto
  from this obtain pre_mgd where pre_mgd: "(lookup (\<lambda>k. k=n) tcs) = Some pre_mgd"
    by blast
  have pre_mgd_mgd: "map_of pre_mgd = mgd"
    by (metis l assms exe_ars_conds_def
        exe_osig_conds_def in_alist_imp_in_map_of lookup_eq_map_of_ap map_of_SomeD option.sel
        pre_mgd snd_conv translate_ars.simps)

  {
    fix c assume asm: "c\<in>S"

    obtain Ss where Ss: "lookup (\<lambda>k. k=c) pre_mgd = Some Ss"
      using \<open>c \<in> S\<close> \<open>map_of pre_mgd = mgd\<close> sub'_tcs' mgd assms Ty.prems has_sort.simps
      by (auto simp add: dom_map_of_conv_image_fst domIff eq_fst_iff exe_ars_conds_def
          map_of_eq_None_iff classes_translate lookup_eq_map_of_ap split: typ.splits
          dest!: domD intro!: domI)
    have l: "length Ts = length Ss"
      using asm mgd pre_mgd Ty.prems assms sub'_tcs' Ss list_all2_lengthD pre_mgd_mgd
      by (fastforce simp add: has_sort.simps lookup_eq_map_of_ap)

    have 1: "\<forall>c \<in> S. \<exists>Ss . mgd c = Some Ss \<and> list_all2 (has_sort (sub', tcs')) Ts Ss"
      using mgd Ty.prems has_sort.simps sub'_tcs' by auto

    have cond: "list_all2 (exehas_sort (sub,tcs)) Ts Ss"
      apply (rule list_all2_all_nthI)
      using l apply simp
      subgoal premises p for m
        apply (rule Ty.IH)
        using p apply simp
        using p Ty.prems assms 1
        by (metis Ss asm list_all2_conv_all_nth lookup_eq_map_of_ap option.sel pre_mgd_mgd sub'_tcs')
      done
    have "(\<forall>C \<in> S.
    case lookup (\<lambda>k. k=C) pre_mgd of
        None \<Rightarrow> False
      | Some Ss \<Rightarrow> list_all2 (exehas_sort (sub,tcs)) Ts Ss)"
      by (metis "1" Ty.IH list_all2_conv_all_nth lookup_eq_map_of_ap nth_mem option.simps(5)
        pre_mgd_mgd sub'_tcs')
  }

  then show ?case
    using pre_mgd by simp
next
  case (Tv n S)
  then show ?case
    using assms exesort_les_code has_sort_Tv_imp_sort_leq by fastforce
qed

lemma has_sort_code:
  assumes "exe_osig_conds oss"
  shows "has_sort (translate_osig oss) T S = exehas_sort oss T S"
  by (metis assms exehas_sort_imp_has_sort has_sort_imp_exehas_sort prod.collapse)

lemma has_sort_code':
  assumes "exe_wf_theory' \<Theta>"
  shows "has_sort (osig (sig (translate_theory \<Theta>))) T S
    = exehas_sort (exesorts (exesig \<Theta>)) T S"
  apply (cases \<Theta> rule: exetheory_full_exhaust) using assms has_sort_code by auto

abbreviation "exeinst_ok \<Theta> insts \<equiv>
    distinct (map fst insts)
  \<and> list_all (exetyp_ok \<Theta>) (map snd insts)
  \<and> list_all (\<lambda>((idn, S), T) . exehas_sort (exesorts (exesig \<Theta>)) T S) insts"

lemma inst_ok_code1:
  assumes "exe_wf_theory' \<Theta>"
  shows "list_all (exetyp_ok \<Theta>) (map snd insts) = list_all (typ_ok (translate_theory \<Theta>)) (map snd insts)"
  using assms typ_ok_code by (auto simp add: list_all_iff)

lemma inst_ok_code2:
  assumes "exe_wf_theory' \<Theta>"
  shows "list_all (\<lambda>((idn, S), T) . has_sort (osig (sig (translate_theory \<Theta>))) T S) insts
    = list_all (\<lambda>((idn, S), T) . exehas_sort (exesorts (exesig \<Theta>)) T S) insts"
  using has_sort_code' assms by auto

lemma inst_ok_code:
  assumes "exe_wf_theory' \<Theta>"
  shows "inst_ok (translate_theory \<Theta>) insts = exeinst_ok \<Theta> insts"
  using inst_ok_code1 inst_ok_code2 assms by auto

definition [simp]: "exeterm_ok \<Theta> t \<equiv> exeterm_ok' (exesig \<Theta>) t \<and> typ_of t \<noteq> None"
lemma term_ok_code:
  assumes "exe_wf_theory' \<Theta>"
  shows "term_ok (translate_theory \<Theta>) t = exeterm_ok \<Theta> t"
  using assms apply (cases \<Theta> rule: exetheory_full_exhaust)
  by (metis exe_sig_conds_def exe_wf_theory'.simps exeterm_ok_def exetheory.sel(1)
      sig.simps term_okD1 term_okD2 term_okI wt_term_code translate_theory.simps)

fun exereplay' :: "exetheory \<Rightarrow> (variable \<times> typ) list \<Rightarrow> variable set
  \<Rightarrow> term list \<Rightarrow> proofterm \<Rightarrow> term option" where
  "exereplay' thy _ _ Hs (PAxm t Tis) = (if exeinst_ok thy Tis \<and> exeterm_ok thy t
    then if t \<in> set (exeaxioms_of thy)
      then Some (forall_intro_vars (subst_typ' Tis t) [])
    else None else None)"
| "exereplay' thy _ _ Hs (PBound n) = partial_nth Hs n"
| "exereplay' thy vs ns Hs (Abst T p) = (if exetyp_ok thy T
    then (let (s',ns') = variant_variable (Free STR ''default'') ns in
      map_option (mk_all s' T) (exereplay' thy ((s', T) # vs) ns' Hs p))
    else None)"
| "exereplay' thy vs ns Hs (Appt p t) =
    (let rep = exereplay' thy vs ns Hs p in
    let t' = subst_bvs (map (\<lambda>(x,y) . Fv x y) vs) t in
      case (rep, typ_of t') of
        (Some (Ct s (Ty fun1 [Ty fun2 [\<tau>, Ty propT1 Nil], Ty propT2 Nil]) $ b), Some \<tau>') \<Rightarrow>
          if s = STR ''Pure.all'' \<and> fun1 = STR ''fun'' \<and> fun2 = STR ''fun''
            \<and> propT1 = STR ''prop'' \<and> propT2 = STR ''prop''
             \<and> \<tau>=\<tau>' \<and> exeterm_ok thy t'
            then Some (b \<bullet> t') else None
      | _ \<Rightarrow> None)"
| "exereplay' thy vs ns Hs (AbsP t p) =
    (let t' = subst_bvs (map (\<lambda>(x,y) . Fv x y) vs) t in
    let rep = exereplay' thy vs ns (t'#Hs) p in
      (if typ_of t' = Some propT \<and> exeterm_ok thy t' then map_option (mk_imp t') rep else None))"
| "exereplay' thy vs ns Hs (AppP p1 p2) =
    (let rep1 = Option.bind (exereplay' thy vs ns Hs p1) beta_eta_norm in
    let rep2 = Option.bind (exereplay' thy vs ns Hs p2) beta_eta_norm in
      (case (rep1, rep2) of (
        Some (Ct imp (Ty fn1 [Ty prp1 [], Ty fn2 [Ty prp2 [], Ty prp3 []]]) $ A $ B),
        Some A') \<Rightarrow>
          if imp = STR ''Pure.imp'' \<and> fn1 = STR ''fun'' \<and> fn2 = STR ''fun''
            \<and> prp1 = STR ''prop'' \<and> prp2 = STR ''prop'' \<and> prp3 = STR ''prop'' \<and> A=A'
          then Some B else None
        | _ \<Rightarrow> None))"
| "exereplay' thy vs ns Hs (OfClass ty c) = (if exehas_sort (exesorts (exesig thy)) ty {c}
    \<and> exetyp_ok thy ty
    then (case lookup (\<lambda>k. k=const_of_class c) (execonst_type_of (exesig thy)) of
      Some (Ty fun [Ty it [ity], Ty prop []]) \<Rightarrow>
        if ity = tvariable STR '''a'' \<and> fun = STR ''fun'' \<and> prop = STR ''prop'' \<and> it = STR ''itself''
          then Some (mk_of_class ty c) else None | _ \<Rightarrow> None) else None)"
| "exereplay' thy vs ns Hs (Hyp t) = (if t\<in>set Hs then Some t else None)"

lemma of_class_code1:
  assumes "exe_wf_theory' thy"
  shows "(has_sort (osig (sig (translate_theory thy))) ty {c} \<and> typ_ok (translate_theory thy) ty)
    = (exehas_sort (exesorts (exesig thy)) ty {c} \<and> exetyp_ok thy ty)"
proof-
  have "has_sort (osig (sig (translate_theory thy))) ty {c}
    = exehas_sort (exesorts (exesig thy)) ty {c}"
    using has_sort_code' assms by simp
  moreover have "typ_ok (translate_theory thy) ty = exetyp_ok thy ty"
    using typ_ok_code assms by simp
  ultimately show ?thesis
    by auto
qed

lemma of_class_code2:
  assumes "exe_wf_theory' thy"
  shows "const_type (sig (translate_theory thy)) (const_of_class c)
    = lookup (\<lambda>k. k=const_of_class c) (execonst_type_of (exesig thy))"
  by (metis assms const_type_of_lookup_code exe_wf_theory_code
      exe_wf_theory_translate_imp_wf_theory exetheory.sel(1) illformed_theory_not_wf_theory
      sig.simps translate_theory.elims)

lemma replay'_code:
  assumes "exe_wf_theory' thy"
  shows "replay' (translate_theory thy) vs ns Hs P = exereplay' thy vs ns Hs P"
proof (induction P arbitrary: vs ns Hs)
  case (PAxm ax tys)
  have wf: "wf_theory (translate_theory thy)"
    by (simp add: assms exe_wf_theory_code exe_wf_theory_translate_imp_wf_theory)
  moreover have inst: "inst_ok (translate_theory thy) tys \<longleftrightarrow> exeinst_ok thy tys"
    by (simp add: assms inst_ok_code1 inst_ok_code2)
  moreover have tok: "term_ok (translate_theory thy) ax \<longleftrightarrow> exeterm_ok thy ax"
    using assms term_ok_code by blast
  moreover have ax: "ax \<in> axioms (translate_theory thy) \<longleftrightarrow> ax \<in> set (exeaxioms_of thy)"
    by (metis axioms.simps wf exetheory.sel(2) illformed_theory_not_wf_theory translate_theory.elims)
  ultimately show ?case
    by simp
qed (use assms term_ok_code typ_ok_code of_class_code1 of_class_code2
      in \<open>auto simp only: replay'.simps exereplay'.simps split: if_splits\<close>)

abbreviation "exereplay'' thy vs ns Hs P \<equiv> Option.bind (exereplay' thy vs ns Hs P) beta_eta_norm"
lemma replay''_code:
  assumes "exe_wf_theory' thy"
  shows "replay'' (translate_theory thy) vs ns Hs P = exereplay'' thy vs ns Hs P"
  by (simp add: assms replay'_code)

definition [simp]: "exereplay thy P \<equiv>
  (if \<forall>x\<in>set (hyps P) . exeterm_ok thy x \<and> typ_of x = Some propT then
  exereplay'' thy [] (fst ` (fv_Proof P \<union> FV (set (hyps P)))) (hyps P) P else None)"

lemma replay_code:
  assumes "exe_wf_theory' thy"
  shows "replay (translate_theory thy) P = exereplay thy P"
  using assms replay''_code term_ok_code by auto

definition "exe_replay' e P = exereplay'' e [] (fst ` fv_Proof P) [] P"

definition "exe_check_proof e P res \<equiv>
  exe_wf_theory' e \<and> exereplay e P = Some res"

lemma exe_check_proof_iff_check_proof:
  "exe_check_proof e P res \<longleftrightarrow> check_proof (translate_theory e) P res"
  using check_proof_def exe_check_proof_def wf_theory_translate_iff_exe_wf_theory
  by (metis exe_wf_theory_code replay_code)

lemma check_proof_sound:
  shows "exe_check_proof e P res \<Longrightarrow> translate_theory e, set (hyps P) \<turnstile> res"
  by (simp add: check_proof_sound exe_check_proof_iff_check_proof)

lemma check_proof_really_sound:
  shows "exe_check_proof e P res \<Longrightarrow> translate_theory e, set (hyps P) \<tturnstile> res"
  by (simp add: check_proof_really_sound exe_check_proof_iff_check_proof)

end