theory YulSemantics imports "YulSemanticsCommon"
begin

datatype YulSwitchCanonical =
  YulSwitchCanonical
    (YulSwitchCanonicalExpression: YulExpression)
    (YulSwitchCanonicalCases: "YulSwitchCase list")
    (YulSwitchCanonicalDefault : "YulStatement list")

(* idea: reorganize the switch statement so that
   - if there is no default, we add an empty one
   - pick out the default case specially either way *)
(* TODO: if we are willing to complicate the state representation, we could
   avoid having to do this as a pre-pass. *)
fun canonicalizeSwitch ::
  "YulExpression \<Rightarrow> YulSwitchCase list \<Rightarrow> YulStatement list option \<Rightarrow> YulSwitchCanonical option"
  where
"canonicalizeSwitch e [] None =
  Some (YulSwitchCanonical e [] [])"
| "canonicalizeSwitch e [] (Some d) =
  Some (YulSwitchCanonical e [] d)"

(* fill in default case *)
| "canonicalizeSwitch e ((YulSwitchCase None dfl)#ct) None =
   canonicalizeSwitch e ct (Some dfl)"
(* 2 default cases = invalid *)
| "canonicalizeSwitch e ((YulSwitchCase None dfl)#ct) (Some _) =
   None"

| "canonicalizeSwitch e ((YulSwitchCase (Some x) body)#ct) d =
   (case canonicalizeSwitch e ct d of
    None \<Rightarrow> None
    | Some (YulSwitchCanonical e cs' d') \<Rightarrow>
           Some (YulSwitchCanonical e ((YulSwitchCase (Some x) body)#cs') d'))"

(* measures for Yul programs (used for semantics termination) *)
function yulStatementMeasure :: "YulStatement \<Rightarrow> nat"
and yulStatementsMeasure :: "YulStatement list \<Rightarrow> nat"
and yulExpressionMeasure :: "YulExpression \<Rightarrow> nat"
and yulExpressionsMeasure :: "YulExpression list \<Rightarrow> nat"
and yulCaseMeasure :: "YulSwitchCase \<Rightarrow> nat"
and yulCasesMeasure :: "YulSwitchCase list \<Rightarrow> nat"
 where
"yulStatementMeasure (YulFunctionCallStatement fc) =
  (case fc of (YulFunctionCall _ args) \<Rightarrow> 1 + yulExpressionsMeasure args)"
| "yulStatementMeasure (YulAssignmentStatement a) =
  (case a of (YulAssignment _ expr) \<Rightarrow> 1 + yulExpressionMeasure expr)"
| "yulStatementMeasure (YulVariableDeclarationStatement vd) =
  (case vd of (YulVariableDeclaration _ oexpr) \<Rightarrow>
   (case oexpr of
    None \<Rightarrow> 1
    | Some expr \<Rightarrow> 1 + yulExpressionMeasure expr))"
| "yulStatementMeasure (YulFunctionDefinitionStatement _) = 1"
| "yulStatementMeasure (YulIf cond body) =
   1 + yulExpressionMeasure cond + yulStatementsMeasure body"
| "yulStatementMeasure (YulSwitch cond cases) =
   1 + yulExpressionMeasure cond +
      yulCasesMeasure cases"
| "yulStatementMeasure (YulForLoop pre cond post body) =
   1 + yulStatementsMeasure pre +
       yulExpressionMeasure cond +
       yulStatementsMeasure post +
       yulStatementsMeasure body"
| "yulStatementMeasure (YulBlock sts) =
   1 + yulStatementsMeasure sts"
| "yulStatementMeasure (YulBreak) = 1"
| "yulStatementMeasure (YulLeave) = 1"
| "yulStatementMeasure (YulContinue) = 1"

| "yulExpressionMeasure (YulFunctionCallExpression  fc) =
  (case fc of (YulFunctionCall _ args) \<Rightarrow>  1 + yulExpressionsMeasure args)"
| "yulExpressionMeasure (YulIdentifier _) = 1"
| "yulExpressionMeasure (YulLiteralExpression _) = 1"

| "yulCaseMeasure (YulSwitchCase _ body) =
   1 + yulStatementsMeasure body"

| "yulStatementsMeasure [] = 1"
| "yulStatementsMeasure (h#t) = 1 + yulStatementMeasure h + yulStatementsMeasure t"

| "yulExpressionsMeasure [] = 1"
| "yulExpressionsMeasure (h#t) = 1 + yulExpressionMeasure h + yulExpressionsMeasure t"

| "yulCasesMeasure [] = 1"
| "yulCasesMeasure (h#t) = 1 + yulCaseMeasure h + yulCasesMeasure t"

  by pat_completeness auto

(* I am not sure why size_change is needed here.
   It seems like this function is rather trivially
   structurally recursive. *)
termination by size_change

lemma yul_canonical_switch_expr :
  assumes H : "canonicalizeSwitch expr cases dfl =
               Some (YulSwitchCanonical expr2 cases2 dfl2)"
  shows "expr = expr2" using assms
proof(induction cases arbitrary: expr expr2 cases2 dfl dfl2)
  case Nil
  then show ?case by(cases dfl; auto)
next
  case (Cons a cases)
  obtain cond body where A : "a = YulSwitchCase cond body" by(cases a; auto)
  then show ?case
  proof(cases cond)
    case None
    then show ?thesis
      using Cons.prems Cons.IH A None by(cases dfl; auto)
  next
    case (Some cond')
    then show ?thesis
    proof(cases dfl)
      case None' : None
      then show ?thesis
        using Cons.prems Cons.IH A Some by(auto split:option.splits YulSwitchCanonical.splits)
    next
      case Some' : (Some dfl')
      then show ?thesis
        using Cons.prems Cons.IH A Some by(auto split:option.splits YulSwitchCanonical.splits)
    qed
  qed
qed

fun yulSwitchCanonicalMeasure :: "YulSwitchCanonical \<Rightarrow> nat" where
"yulSwitchCanonicalMeasure (YulSwitchCanonical expr' cases' dfl2) =
  yulExpressionMeasure expr' +
  yulCasesMeasure cases' +
  yulStatementsMeasure dfl2"

lemma yul_canonical_switch_size :
  assumes H : "canonicalizeSwitch expr cases dfl =
               Some (YulSwitchCanonical expr' cases' dfl2)"
  shows "(case dfl of None \<Rightarrow> 0
          | Some dfl' \<Rightarrow> yulStatementsMeasure dfl') +
         yulStatementMeasure (YulSwitch expr cases) \<ge>
         yulSwitchCanonicalMeasure (YulSwitchCanonical expr' cases' dfl2)" using H
proof(induction cases arbitrary: expr dfl expr' cases' dfl2)
  case Nil
  then show ?case
    by(cases dfl; auto)
next
  case (Cons a cases)
  then obtain lit body where
    A : "a = (YulSwitchCase lit body)" by(cases a; auto)
  show ?case
  proof(cases dfl)
    case None
    show ?thesis
    proof(cases lit)
      case None' : None
      then show ?thesis using Cons.prems Cons.IH[of expr "Some body" expr' cases' dfl2] A None
        by(auto)
    next
      case Some' : (Some a')

      then obtain cases'tl where Cases' : "cases' = YulSwitchCase (Some a') body # cases'tl"
        using Cons.prems None A Some' by(auto split:option.splits YulSwitchCanonical.splits)
      then show ?thesis using Cons.prems Cons.IH[of expr None expr' cases'tl dfl2] A None Some'
        by(auto simp add: yul_canonical_switch_expr
                split:option.splits YulSwitchCanonical.splits)
    qed
  next
    case (Some dfl')
    then show ?thesis
    proof(cases lit)
      case None' : None
      then show ?thesis using Cons.prems Cons.IH A Some
        by(auto)
    next
      case Some' : (Some a')

      then obtain cases'tl where Cases' : "cases' = YulSwitchCase (Some a') body # cases'tl"
        using Cons.prems Some A Some' by(auto split:option.splits YulSwitchCanonical.splits)
      then show ?thesis using Cons.prems Cons.IH[of expr "(Some dfl')" expr' cases'tl dfl2]
                              A Some Some'
        by(auto simp add: yul_canonical_switch_expr
                split:option.splits YulSwitchCanonical.splits)
    qed
  qed
qed

(* executable semantics for Yul programs *)
(* parameters:
   - global state
   - local state (variable map)
   - function identifiers
   - statement
   - return *)

(* TODO: do we need to maintain the typing environment at runtime?
   I don't think we should. *)

(* locale for fixing global state, value types *)
locale YulSem =
  fixes local_var :: "'v itself"
  fixes local_type :: "'t itself"
  fixes global_state :: "'g itself"
  fixes parseType :: "String.literal \<Rightarrow> 't option"
  fixes parseLiteral :: "String.literal \<Rightarrow> 'v option"

fixes isTruthy :: "'v \<Rightarrow> bool"

fixes defaultValue :: "'v"
(* global starting state *)
fixes G0 :: "'g"

(* starting function bindings - i.e., pre-defined *)
fixes F0 :: "function_sig locals"

begin

(* gas checks will happen on statement *)
(* TODO: consider not using the same "result" state type, this may end up giving us an
   implementation that is too similar to the small step at some points. *)
(* TODO: consider changing the nat type for fuel to int, in order to bring this in line
   with the small-step version *)
(* TODO: make sure mode is getting reset to Regular correctly when alternating between
   statement and expression evaluation *)
function
yul_eval_statement ::
  "YulStatement \<Rightarrow> nat \<Rightarrow> ('g, 'v) YulResult \<Rightarrow> ('g, 'v) YulResult"
and yul_eval_statements ::
  "YulStatement list \<Rightarrow> nat \<Rightarrow> ('g, 'v) YulResult \<Rightarrow> ('g, 'v) YulResult"
and yul_eval_block ::
  "YulStatement list \<Rightarrow> nat \<Rightarrow> ('g, 'v) YulResult \<Rightarrow> ('g, 'v) YulResult"
and yul_eval_expression ::
  "YulExpression \<Rightarrow> nat \<Rightarrow> ('g, 'v) YulResult \<Rightarrow> ('g, 'v) YulResult"
and yul_eval_expressions ::
   "YulExpression list \<Rightarrow> nat \<Rightarrow> ('g, 'v) YulResult \<Rightarrow> ('g, 'v) YulResult"
and yul_eval_canonical_switch ::
  "YulSwitchCanonical \<Rightarrow> nat \<Rightarrow> ('g, 'v) YulResult \<Rightarrow> ('g, 'v) YulResult"
  where

(*
 * helper: expression
 *)
(* identifier *)
"yul_eval_expression (YulIdentifier i) n (YulResult r) =
 (case (locals r) of
    [] \<Rightarrow> ErrorResult (STR ''No variable context'')
    | Lh#Lt \<Rightarrow>
     (case (Lh i) of
      None \<Rightarrow> (ErrorResult (STR ''Undefined variable '' @@ i))
      | Some v \<Rightarrow>
        (case (vals r) of
          None \<Rightarrow> YulResult (r \<lparr> locals := (Lh#Lt), vals := (Some ([v]))\<rparr>)
          | Some vs \<Rightarrow> YulResult (r \<lparr> locals := (Lh#Lt), vals := (Some (vs @ [v]))\<rparr>))))"
(* literal *)
| "yul_eval_expression (YulLiteralExpression (YulLiteral value type)) n
                       (YulResult r) =
  (case parseLiteral value of
    None \<Rightarrow> (ErrorResult (STR ''Bad literal '' @@ value))
    | Some v \<Rightarrow>
      (case (vals r) of
        None \<Rightarrow> YulResult (r \<lparr> vals := (Some [v])\<rparr>)
        | Some vs \<Rightarrow> YulResult (r \<lparr> vals := Some (vs @ [v])\<rparr>)))"

(* function call *)
(* function calls consume fuel *)
| "yul_eval_expression (YulFunctionCallExpression (YulFunctionCall name args)) 0 r =
    r"

(* TODO: double check details around threading of function context and mode *)
| "yul_eval_expression (YulFunctionCallExpression (YulFunctionCall name args)) (Suc n)
                       (YulResult r) =
   (case yul_eval_expressions args n (YulResult r) of
    ErrorResult s \<Rightarrow> ErrorResult s
    | YulResult r1 \<Rightarrow>
      (case funs r of [] \<Rightarrow> ErrorResult (STR ''No function context'')
       | F1h#F1t \<Rightarrow>
        (case locals r of [] \<Rightarrow> ErrorResult (STR ''No local context'')
        | L1h#L1t \<Rightarrow>
          (case F1h name of
            None \<Rightarrow> (ErrorResult (STR ''Undefined function '' @@ name))
            | (Some (YulFunctionSig argSig retSig body)) \<Rightarrow>
              (case vals r of
                None \<Rightarrow> ErrorResult (STR ''invalid eval context (YulFunctionCallExpression)'')
                | Some vs \<Rightarrow>
                  (case put_values L1h (strip_id_types argSig) vs of
                    None \<Rightarrow> (ErrorResult (STR ''Argument arity mismatch for '' @@ name))
                    | Some Lsub \<Rightarrow>
                      (case put_values Lsub (strip_id_types retSig)
                                            (List.replicate (length retSig) defaultValue) of
                        None \<Rightarrow> (ErrorResult (STR ''Should be dead code''))
                        | Some Lsub1 \<Rightarrow>
                          (case yul_eval_statement (YulBlock body) n
                                                   (YulResult (r1 \<lparr> locals := (Lsub1#L1h#L1t)\<rparr>)) of
                            ErrorResult r \<Rightarrow> ErrorResult r
                            | YulResult r2 \<Rightarrow>
                              (case locals r2 of
                                [] \<Rightarrow> ErrorResult (STR ''No local context after call'')
                                | Lsub2#_ \<Rightarrow>
                                  (case get_values Lsub2 (strip_id_types retSig) of
                                    None \<Rightarrow> ErrorResult (STR ''Return arity mismatch for '' @@ name)
                                    | Some retVals \<Rightarrow>
                                      YulResult (r2 \<lparr> locals := L1h#L1t
                                                    , mode := None
                                                    , vals := (Some retVals)\<rparr> )))))))))))"
| "yul_eval_expression _ _ (ErrorResult e) = ErrorResult e"

(*
 * helper: "canonicalized" switch
 *)
| "yul_eval_canonical_switch (YulSwitchCanonical e [] dfl) n (YulResult r) =
    (yul_eval_statements dfl n (YulResult r))"
(* canonicalization guarantees no defaults remain in cases list *)
| "yul_eval_canonical_switch (YulSwitchCanonical e (YulSwitchCase None _ # _) _) _ _ =
    (ErrorResult (STR ''Non canonical switch statement''))"
| "yul_eval_canonical_switch
    (YulSwitchCanonical e (YulSwitchCase (Some (YulLiteral hdValue _)) hdBody # rest) dfl) n
      (YulResult r) =
    (case vals r of
      Some [condValue] \<Rightarrow>
        (case parseLiteral hdValue of
          None \<Rightarrow> ErrorResult (STR ''Bad literal '' @@ hdValue)
          | Some v \<Rightarrow>
            (if v = condValue
             then yul_eval_statements hdBody n (YulResult r)
             else yul_eval_canonical_switch (YulSwitchCanonical e rest dfl) n (YulResult r)))
      | _ \<Rightarrow> ErrorResult (STR ''Bad switch condition''))"
| "yul_eval_canonical_switch _ _ (ErrorResult s) = ErrorResult s"

(*
 * helper: statement list
 *)
| "yul_eval_statements [] n (YulResult r) = (YulResult (r \<lparr> mode := Some Regular \<rparr>))"
| "yul_eval_statements (sh#st) n (YulResult r) =
   (case yul_eval_statement sh n (YulResult r) of
    YulResult r1 \<Rightarrow>
      (if mode r1 = Some Regular
       then yul_eval_statements st n (YulResult r1)
       else YulResult r1)
    | ErrorResult s \<Rightarrow> ErrorResult s)"
| "yul_eval_statements _ _ (ErrorResult s) = ErrorResult s"

(* helper: blocks
   (handle scoping, function gathering *)

(* blocks *)

| "yul_eval_statement (YulBlock sl) n (YulResult r) =
   yul_eval_block sl n (YulResult r)"

(* function definitions - TODO this needs to be a separate pass *)
(*
| "yul_eval_statement G L F
    (YulFunctionDefinitionStatement (YulFunctionDefinition name args rets body)) =
   (G, L, (put_value F name (YulFunctionSig args rets body)), Regular)"
*)

(* function call statement *)
| "yul_eval_statement (YulFunctionCallStatement fc) n (YulResult r) =
    (case yul_eval_expression (YulFunctionCallExpression fc) n (YulResult r) of
      YulResult r1 \<Rightarrow> YulResult (r1 \<lparr> mode := Some Regular, vals := None \<rparr>)
      | ErrorResult s \<Rightarrow> ErrorResult s)"

(* variable declarations without definition *)
| "yul_eval_statement (YulVariableDeclarationStatement (YulVariableDeclaration names None)) n
    (YulResult r) =
  (case locals r of
    [] \<Rightarrow> ErrorResult (STR ''Empty list of local var contexts'')
    | (Lh#Lt) \<Rightarrow>
      (case put_values Lh (strip_id_types names)
                          (List.replicate (length names) defaultValue) of
        None \<Rightarrow> (ErrorResult (STR ''Arity mismatch in variable declaration - should be dead code''))
        | Some L1 \<Rightarrow> YulResult (r \<lparr> locals := L1#Lt \<rparr>)))"

(* variable declaration + definition *)
| "yul_eval_statement (YulVariableDeclarationStatement (YulVariableDeclaration names (Some expr))) n
                      (YulResult r) =
   yul_eval_statement (YulAssignmentStatement (YulAssignment (strip_id_types names) expr)) n
                      (YulResult r)"

(* assignments *)
| "yul_eval_statement (YulAssignmentStatement (YulAssignment ids expr)) n (YulResult r) =
    (case yul_eval_expression expr n (YulResult r) of
      ErrorResult s \<Rightarrow> ErrorResult s
      | YulResult r1 \<Rightarrow>
        (case locals r1 of
          [] \<Rightarrow> ErrorResult (STR ''Empty list of local var contexts'')
          | (Lh#Lt) \<Rightarrow>
            (case vals r1 of
              None \<Rightarrow> ErrorResult (STR ''Invalid returned expression state'')
              | Some v1 \<Rightarrow>
                (case put_values Lh ids v1 of
                  None \<Rightarrow> ErrorResult (STR ''Arity mismatch in assignment'')
                  | Some L2 \<Rightarrow>
                    (YulResult (r1 \<lparr> locals := L2#Lt, mode := Some Regular, vals := None \<rparr>))))))"

(* if statement *)
| "yul_eval_statement (YulIf cond body) n (YulResult r) =
   (case yul_eval_expression cond n (YulResult r) of
    ErrorResult s \<Rightarrow> ErrorResult s
    | YulResult r1 \<Rightarrow>
      (case vals r1 of
        Some [v] \<Rightarrow>
          (if isTruthy v then yul_eval_statements body n
                              (YulResult (r1 \<lparr> mode := Some Regular, vals := None \<rparr>))
           else (YulResult (r1 \<lparr> mode := Some Regular, vals := None \<rparr>)))
        | _ \<Rightarrow> (ErrorResult (STR ''Expression doesn't have 1 value (if condition)''))))"

(* for loops *)

(* for loops consume fuel *)
| "yul_eval_statement (YulForLoop _ _ _ _) 0 (YulResult r) = YulResult r"

(* process for-loop without pre-statements *)
| "yul_eval_statement (YulForLoop [] cond post body) (Suc n) (YulResult r) =
   (case yul_eval_expression cond (Suc n) (YulResult r) of
    ErrorResult s \<Rightarrow> ErrorResult s
    | YulResult r1 \<Rightarrow>
      (case vals r1 of
        Some [v] \<Rightarrow>
          (if isTruthy v then
            (case yul_eval_statements body (Suc n) (YulResult r1) of
              ErrorResult s \<Rightarrow> ErrorResult s
              | YulResult r2 \<Rightarrow>
                (case mode r2 of
                  None \<Rightarrow> ErrorResult (STR ''Invalid state after loop body'')
                  | Some Break \<Rightarrow> YulResult (r2 \<lparr> mode := Some Regular \<rparr>)
                  | Some Leave \<Rightarrow> YulResult r2
                  | Some _ \<Rightarrow> yul_eval_statement (YulForLoop [] cond post body) n (YulResult r2)))
            else YulResult (r1 \<lparr> mode := Some Regular, vals := None \<rparr>))
        | _ \<Rightarrow> ErrorResult (STR ''Expression doesn't have 1 value (loop condition)'')))"

(* process pre-statements for for-loop *)
| "yul_eval_statement (YulForLoop (preh#pret) cond post body) n (YulResult r) =
   (case yul_eval_statements (preh#pret) n (YulResult r) of
      ErrorResult s \<Rightarrow> ErrorResult s
      | YulResult r1 \<Rightarrow>
          \<comment> \<open>mode will be either Regular or Leave here\<close>
          (case mode r1 of
            None \<Rightarrow> ErrorResult (STR ''Invalid state after loop init'')
            | Some Leave \<Rightarrow>
              (case (locals r1, locals r) of
                (L1h#L1t, Lh#Lt) \<Rightarrow>
                  \<comment> \<open> L1t and Lt should be equal here \<close>
                  YulResult (r1 \<lparr> locals := (restrict L1h Lh)#Lt \<rparr>)
                | _ \<Rightarrow> ErrorResult (STR ''Invalid local contexts on loop init exit''))
            | Some _ \<Rightarrow>
              (case yul_eval_statement (YulForLoop [] cond post body) n
                                       (YulResult r1) of
                ErrorResult s \<Rightarrow> ErrorResult s
                | YulResult r2 \<Rightarrow>
                  (case (locals r2, locals r) of
                    (L2h#L2t, Lh#Lt) \<Rightarrow>
                      \<comment> \<open> L2t and Lt should be equal here \<close>
                      YulResult (r2 \<lparr> locals := (restrict L2h Lh)#Lt \<rparr>)))))"

(* switch statement *)

| "yul_eval_statement (YulSwitch e cl) n (YulResult r) =
    (case yul_eval_expression e n (YulResult r) of
      ErrorResult s \<Rightarrow> ErrorResult s
      | YulResult r1 \<Rightarrow>
        (case canonicalizeSwitch e cl None of
          Some canonical \<Rightarrow> yul_eval_canonical_switch canonical n (YulResult r1)
          | None \<Rightarrow> ErrorResult (STR ''Invalid switch statement'')))"

(* break *)
| "yul_eval_statement YulBreak n (YulResult r) =
    YulResult (r \<lparr> mode := Some Break \<rparr>)"

(* continue *)
| "yul_eval_statement YulContinue n (YulResult r) =
    YulResult (r \<lparr> mode := Some Continue \<rparr>)"

(* leave *)
| "yul_eval_statement YulLeave n (YulResult r) =
    YulResult (r \<lparr> mode := Some Leave \<rparr>)"

(* on errors, halt *)
| "yul_eval_statement _ _ (ErrorResult s) =
    ErrorResult s"

(* big-step inductive semantics for Yul programs *)
(* parameters:
   - global state
   - local state (variable map)
   - function identifiers
   - statement
   - return *)
(* NB official Yul interpreter appears to be
registering functions at the block level, rather than
as they appear syntactically.
*)
  by pat_completeness auto

(* measure for yul_eval function - based on gas *)
(* however we are also going to need a notion of how far in the syntax tree we are.
   then we should only need to use gas for the for loop piece *)
termination sorry (* TODO *)

end

end


theory ProofFormat
  imports Main McKayPiperno
begin

type_synonym node = "nat list"
type_synonym vertex = nat
type_synonym cell = "vertex set"
type_synonym orbit = "vertex set"

datatype fact =
      ColoringEqual node coloring
   |  ColoringFiner node coloring
   |  IsTargetCell node cell
   |  InvariantsEqual node node
   |  Orbit node orbit
   |  Pruned node
   |  OnPath node
   |  Canonical coloring
   |  IsNode node

datatype rule =
     ColoringAxiom
   | Individualize node vertex coloring
   | SplitColoring node coloring
   | Equitable node coloring
   | TargetCell node coloring
   | InvariantAxiom node
   | InvariantsEqualSym node node
   | InvariantsEqualStep node vertex coloring node vertex coloring
   | OrbitsAxiom node vertex
   | MergeOrbits node orbit orbit perm vertex vertex
   | PruneInvariant node vertex coloring node vertex coloring
   | PathAxiom
   | ExtendPath node cell vertex
   | CanonicalLeaf node coloring
   | PruneParent node cell
   | PruneLeaf node coloring node coloring
   | PruneAutomorphism node node perm
   | PruneOrbits node orbit vertex vertex

record fact_database =
  graph :: colored_graph
  facts :: "fact set"

definition add_fact :: "fact_database \<Rightarrow> fact \<Rightarrow> fact_database" where
  "add_fact db f = db \<lparr> facts := (facts db) \<union> {f}  \<rparr>"

context McKayPiperno
begin

primrec valid_fact :: "colored_graph \<Rightarrow> fact \<Rightarrow> bool" where
  "valid_fact G (ColoringEqual \<nu> \<pi>) \<longleftrightarrow>
    \<nu> \<in> nodes (tree G) \<and>
    \<R>' G \<nu> = \<pi>"
| "valid_fact G (ColoringFiner \<nu> \<pi>) \<longleftrightarrow>
    \<nu> \<in> nodes (tree G) \<and>
    length \<pi> = num_vertices G \<and>
    \<R>' G \<nu> = colors (\<F>' (recolor G \<pi>))"
| "valid_fact G (IsTargetCell \<nu> W) \<longleftrightarrow>
    \<nu> \<in> nodes (tree G) \<and>
    finite W \<and> W \<noteq> {} \<and>
    fset (\<T>' G \<nu>) = W"
| "valid_fact G (InvariantsEqual \<nu>1 \<nu>2) \<longleftrightarrow>
   \<nu>1 \<in> nodes (tree G) \<and>
   \<nu>2 \<in> nodes (tree G) \<and>
   List.length \<nu>1 = List.length \<nu>2 \<and>
   \<Phi>_lex' G \<nu>1 = \<Phi>_lex' G \<nu>2"
| "valid_fact G (Orbit \<nu> \<Omega>) \<longleftrightarrow>
   \<nu> \<in> nodes (tree G) \<and>
   (\<forall> v \<in> \<Omega>. vertex G v) \<and>
   is_orbit_subset (automorphisms (recolor G (\<R>' G \<nu>))) \<Omega>"
| "valid_fact G (Pruned \<nu>) \<longleftrightarrow>
   \<nu> \<in> nodes (tree G) \<and>
   the_max_leaf G (tree G) \<notin> leaves G (expand_tree G \<nu>)"
| "valid_fact G (OnPath \<nu>) \<longleftrightarrow>
   \<nu> \<in> nodes (tree G) \<and>
   the_max_leaf G (tree G) \<in> leaves G (expand_tree G \<nu>)"
| "valid_fact G (Canonical \<pi>) \<longleftrightarrow>
   discrete \<pi> \<and> length \<pi> = num_vertices G \<and>
   canon_form G = perm_graph (discrete_coloring_perm \<pi>) G"
| "valid_fact G (IsNode \<nu>) \<longleftrightarrow>
   \<nu> \<in> nodes (tree G)"

definition valid_fact_database :: "fact_database \<Rightarrow> bool" where
  "valid_fact_database db \<longleftrightarrow> (\<forall> f \<in> facts db. valid_fact (graph db) f)"

primrec check_rule :: "rule \<Rightarrow> fact_database \<Rightarrow> fact_database option" where
  "check_rule ColoringAxiom db =
      Some (add_fact (add_fact db (IsNode [])) (ColoringFiner [] (colors (graph db))))"
| "check_rule (Individualize \<nu> v \<pi>) db = (
      if IsNode (v # \<nu>) \<in> facts db \<and>
         ColoringEqual \<nu> \<pi> \<in> facts db
      then Some (add_fact db (ColoringFiner (v # \<nu>) (individualize \<pi> v)))
      else None
  )"
| "check_rule (SplitColoring \<nu> \<pi>) db = (
      let k  = Coloring.num_colors \<pi>;
          Ws = { j \<in> {0..<k} . split (recolor (graph db) \<pi>) j \<prec> \<pi> }
       in if ColoringFiner \<nu> \<pi> \<in> facts db \<and>
             card Ws > 0
          then Some (add_fact db (ColoringFiner \<nu> (split (recolor (graph db) \<pi>) (Min Ws))))
          else None
  )"
| "check_rule (Equitable \<nu> \<pi>) db = (
      let k = Coloring.num_colors \<pi>
       in if ColoringFiner \<nu> \<pi> \<in> facts db \<and>
             (\<forall> c \<in> {0..<k}. split (recolor (graph db) \<pi>) c = \<pi>)
          then Some (add_fact db (ColoringEqual \<nu> \<pi>))
          else None
  )"
| "check_rule (TargetCell \<nu> \<pi>) db = (
      if ColoringEqual \<nu> \<pi> \<in> facts db \<and>
         \<T>'_color \<pi> \<noteq> None
      then let c = the (\<T>'_color \<pi>)
            in Some (fold (\<lambda>v db'. add_fact db' (IsNode (v # \<nu>))) (sorted_list_of_set (cell \<pi> c))
                                  (add_fact db  (IsTargetCell \<nu> (cell \<pi> c))))
      else None
  )"
| "check_rule (InvariantAxiom \<nu>) db = (
      if IsNode \<nu> \<in> facts db
      then Some (add_fact db (InvariantsEqual \<nu> \<nu>))
      else None
  )"
| "check_rule (InvariantsEqualSym \<nu>1 \<nu>2) db = (
      if InvariantsEqual \<nu>1 \<nu>2 \<in> facts db
      then Some (add_fact db (InvariantsEqual \<nu>2 \<nu>1))
      else None
  )"
| "check_rule (InvariantsEqualStep \<nu>1 v1 \<pi>1 \<nu>2 v2 \<pi>2) db = (
      if InvariantsEqual \<nu>1 \<nu>2 \<in> facts db \<and>
         ColoringEqual (v1 # \<nu>1) \<pi>1 \<in> facts db \<and>
         ColoringEqual (v2 # \<nu>2) \<pi>2 \<in> facts db \<and>
         \<f>_hash (\<f> (graph db) \<pi>1) = \<f>_hash (\<f> (graph db) \<pi>2)
      then Some (add_fact db (InvariantsEqual (v1 # \<nu>1) (v2 # \<nu>2)))
      else None
  )"
| "check_rule (OrbitsAxiom \<nu> v) db = (
      if IsNode \<nu> \<in> facts db \<and>
         vertex (graph db) v
      then Some (add_fact db (Orbit \<nu> {v}))
      else None)"
| "check_rule (MergeOrbits \<nu> \<Omega>1 \<Omega>2 \<sigma> v1 v2) db = (
      if Orbit \<nu> \<Omega>1 \<in> facts db \<and>
         Orbit \<nu> \<Omega>2 \<in> facts db \<and>
         is_automorphism (graph db) \<sigma> \<and>
         \<nu> = perm_fun_list \<sigma> \<nu> \<and>
         v1 \<in> \<Omega>1 \<and> v2 \<in> \<Omega>2 \<and>
         v2 = perm_fun \<sigma> v1
      then Some (add_fact db (Orbit \<nu> (\<Omega>1 \<union> \<Omega>2)))
      else None
  )"
| "check_rule (PruneInvariant \<nu>1 v1 \<pi>1 \<nu>2 v2 \<pi>2) db = (
      if InvariantsEqual \<nu>1 \<nu>2 \<in> facts db \<and>
         ColoringEqual (v1 # \<nu>1) \<pi>1 \<in> facts db \<and>
         ColoringEqual (v2 # \<nu>2) \<pi>2 \<in> facts db \<and>
         \<f>_hash (\<f> (graph db) \<pi>1) > \<f>_hash (\<f> (graph db) \<pi>2)
      then Some (add_fact db (Pruned (v2 # \<nu>2)))
      else None
  )"
| "check_rule PathAxiom db =
      Some (add_fact db (OnPath []))"
| "check_rule (ExtendPath \<nu> W v) db = (
      if OnPath \<nu> \<in> facts db \<and>
         IsTargetCell \<nu> W \<in> facts db \<and>
         (\<forall> w \<in> W - {v}. Pruned (w # \<nu>) \<in> facts db) \<and>
         v \<in> W
      then Some (add_fact db (OnPath (v # \<nu>)))
      else None
   )"
| "check_rule (CanonicalLeaf \<nu> \<pi>) db = (
      if OnPath \<nu> \<in> facts db \<and>
         ColoringEqual \<nu> \<pi> \<in> facts db \<and>
         discrete \<pi>
      then Some (add_fact db (Canonical \<pi>))
      else None
  )"
| "check_rule (PruneParent \<nu> W) db = (
      if IsTargetCell \<nu> W \<in> facts db \<and>
         (\<forall> v \<in> W. Pruned (v # \<nu>) \<in> facts db)
      then Some (add_fact db (Pruned \<nu>))
      else None
  )"
| "check_rule (PruneLeaf \<nu>1 \<pi>1 \<nu>2 \<pi>2) db = (
      if ColoringEqual \<nu>1 \<pi>1 \<in> facts db \<and>
         ColoringEqual \<nu>2 \<pi>2 \<in> facts db \<and>
         InvariantsEqual \<nu>1 \<nu>2 \<in> facts db \<and>
         discrete \<pi>2 \<and> (\<not> discrete \<pi>1 \<or> \<g> (num_vertices (graph db)) (perm_edges (discrete_coloring_perm \<pi>1) (edges (graph db))) >
                                         \<g> (num_vertices (graph db)) (perm_edges (discrete_coloring_perm \<pi>2) (edges (graph db))))
      then Some (add_fact db (Pruned \<nu>2))
      else None
  )"
| "check_rule (PruneAutomorphism \<nu>1 \<nu>2 \<sigma>) db = (
      if IsNode \<nu>1 \<in> facts db \<and> IsNode \<nu>2 \<in> facts db \<and>
         rev \<nu>1 < rev \<nu>2 \<and>
         is_automorphism (graph db) \<sigma> \<and>
         perm_fun_list \<sigma> \<nu>1 = \<nu>2
      then Some (add_fact db (Pruned \<nu>2))
      else None
  )"
| "check_rule (PruneOrbits \<nu> \<Omega> v1 v2) db = (
      if IsNode (v1 # \<nu>) \<in> facts db \<and> IsNode (v2 # \<nu>) \<in> facts db \<and>
         Orbit \<nu> \<Omega> \<in> facts db \<and>
         v1 \<in> \<Omega> \<and> v2 \<in> \<Omega> \<and> v1 < v2
      then Some (add_fact db (Pruned (v2 # \<nu>)))
      else None
  )"

lemma valid_coloring_equal_length:
  assumes "valid_fact G (ColoringEqual \<nu> \<pi>)"
  shows "length \<pi> = num_vertices G"
  using assms
  by auto

lemma valid_coloring_finer_length:
  assumes "valid_fact G (ColoringFiner \<nu> \<pi>)"
  shows "length \<pi> = num_vertices G"
  using assms
  by auto

lemma length_split_Min [simp]:
  assumes "length \<pi> = num_vertices G" "{j. j < Coloring.num_colors \<pi> \<and> split (recolor G \<pi>) j \<prec> \<pi>} \<noteq> {}"
  shows "length (split (recolor G \<pi>) (Min {j. j < Coloring.num_colors \<pi> \<and> split (recolor G \<pi>) j \<prec> \<pi>})) = num_vertices G"
  using assms Min_in[of "{j. j < Coloring.num_colors \<pi> \<and> split (recolor G \<pi>) j \<prec> \<pi>}"]
  by auto

lemma split_rule:
  assumes "\<R>' G \<nu> = colors (\<F>' (recolor G \<pi>))"
          "length \<pi> = num_vertices G"
          "{j \<in> {0..<num_colors (recolor G \<pi>)}. split (recolor G \<pi>) j \<prec> ColoredGraph.colors (recolor G \<pi>)} \<noteq> {}"
  shows "\<R>' G \<nu> = colors (\<F>' (recolor G (split (recolor G \<pi>) (Min {j \<in> {0..<num_colors (recolor G \<pi>)}. split (recolor G \<pi>) j \<prec> ColoredGraph.colors (recolor G \<pi>)}))))"
  using assms \<F>'.simps[of "recolor G \<pi>"]
  unfolding Let_def split_graph_def
  by (auto simp add: Let_def split_graph_def)

lemma equitable_rule:
  assumes "{j. j < Coloring.num_colors \<pi> \<and> split (recolor G \<pi>) j \<prec> \<pi>} = {}"
          "length \<pi> = num_vertices G"
          "\<R>' G \<nu> = colors (\<F>' (recolor G \<pi>))"
  shows "\<R>' G \<nu> = \<pi>"
  using assms \<F>'.simps[of "recolor G \<pi>"]
  by (auto simp add: Let_def)

lemma target_cell_rule:
  assumes "\<R>' G \<nu> = \<pi>" "\<T>'_color \<pi> = Some c"
  shows "fset (\<T>' G \<nu>) = cell \<pi> c" "fset (\<T>' G \<nu>) \<noteq> {}"
  using assms cell_non_empty[of c \<pi>] \<T>'_color_in_colors[of \<pi> c] \<T>'_color_cell_gt1[of \<pi> c] \<T>'_is_cell[of G \<nu> c]
  by auto

lemma target_cell_expand_rule:
  assumes "\<R>' G \<nu> = \<pi>" "\<T>'_color \<pi> = Some c" "\<nu> \<in> nodes (tree G)" "v \<in> cell \<pi> c"
  shows "v # \<nu> \<in> nodes (tree G)"
  by (simp add: \<T>'_is_cell assms(1) assms(2) assms(3) assms(4) nodes_extend)

lemma invariants_equal_step_rule:
  assumes "(v1 # \<nu>1) \<in> nodes (tree G)" "(v2 # \<nu>2) \<in> nodes (tree G)"
    "\<Phi>_lex' G \<nu>1 = \<Phi>_lex' G \<nu>2" "\<f>h G (v1 # \<nu>1) = \<f>h G (v2 # \<nu>2)"
  shows "\<Phi>_lex' G (v1 # \<nu>1) = \<Phi>_lex' G (v2 # \<nu>2)"
  using assms
  unfolding \<Phi>_lex'_def
  by auto

lemma orbits_axiom_rule [simp]:
  assumes "vertex G v"
  shows "is_orbit_subset (automorphisms G) {v}"
  using assms id_automorphism perm_fun_perm_id
  unfolding is_orbit_subset_def
  by blast

lemma merge_orbits_rule:
  assumes "\<nu> \<in> nodes (tree G)"
          "is_orbit_subset (automorphisms (recolor G (\<R>' G \<nu>))) \<Omega>1"
          "is_orbit_subset (automorphisms (recolor G (\<R>' G \<nu>))) \<Omega>2"
          "\<forall> v \<in> \<Omega>1. vertex G v" "\<forall> v \<in> \<Omega>2. vertex G v"
          "is_automorphism G \<sigma>" "\<nu> = perm_fun_list \<sigma> \<nu>"
          "v1 \<in> \<Omega>1" "v2 \<in> \<Omega>2" "vertex G v1" "vertex G v2" "perm_fun \<sigma> v1 = v2"
  shows "is_orbit_subset (automorphisms (recolor G (\<R>' G \<nu>))) (\<Omega>1 \<union> \<Omega>2)"
proof-
  have "is_vertex_list G \<nu>"
    using assms(1) nodes_is_vertex_list
    by simp

  let ?A = "automorphisms (recolor G (\<R>' G \<nu>))"
  {
    fix u1 u2 \<Omega>1 \<Omega>2 v1 v2 \<sigma>
    assume "is_orbit_subset ?A \<Omega>1"
           "is_orbit_subset ?A \<Omega>2"
           "\<forall> v \<in> \<Omega>1. vertex G v" "\<forall> v \<in> \<Omega>2. vertex G v"
           "is_automorphism G \<sigma>" "\<nu> = perm_fun_list \<sigma> \<nu>"
           "u1 \<in> \<Omega>1" "u2 \<in> \<Omega>2" "v1 \<in> \<Omega>1" "v2 \<in> \<Omega>2" "vertex G v1" "vertex G v2" "perm_fun \<sigma> v1 = v2"
    have "\<exists>p\<in>?A. perm_fun p u1 = u2"
    proof-
      obtain \<sigma>1 \<sigma>2 where "\<sigma>1 \<in> ?A" "perm_fun \<sigma>1 v1 = u1" "\<sigma>2 \<in> ?A" "perm_fun \<sigma>2 v2 = u2"
        using `u1 \<in> \<Omega>1` `v1 \<in> \<Omega>1` `is_orbit_subset ?A \<Omega>1`
        using `u2 \<in> \<Omega>2` `v2 \<in> \<Omega>2` `is_orbit_subset ?A \<Omega>2`
        unfolding is_orbit_subset_def
        by meson
      have "vertex G u1" "vertex G u2"
        using \<open>\<forall>v\<in>\<Omega>1. vertex G v\<close> \<open>u1 \<in> \<Omega>1\<close> \<open>\<forall>v\<in>\<Omega>2. vertex G v\<close> \<open>u2 \<in> \<Omega>2\<close>
        by auto
      have "\<sigma> \<in> ?A"
      proof-
        have "perm_graph \<sigma> (recolor G (\<R>' G \<nu>)) = recolor G (\<R>' G \<nu>)"
        proof-
          have "perm_coloring \<sigma> (\<R>' G \<nu>) = (\<R>' G \<nu>)"
            using \<R>_perm \<open>\<nu> = perm_fun_list \<sigma> \<nu>\<close> \<open>is_automorphism G \<sigma>\<close> `is_vertex_list G \<nu>` is_automorphism_def is_isomorphism_def
            by fastforce
          then show ?thesis
            by (smt (verit, best) \<R>_length' \<open>is_automorphism G \<sigma>\<close> `is_vertex_list G \<nu>` is_automorphism_def is_isomorphism_def recolor_perm)
        qed
        then show ?thesis
          using `is_vertex_list G \<nu>` `is_automorphism G \<sigma>`
          unfolding automorphisms_def is_automorphism_def  is_isomorphism_def
          by auto
      qed
      let ?\<sigma> = "perm_comp (perm_comp \<sigma>2 \<sigma>) (perm_inv \<sigma>1)"
      show ?thesis
      proof (rule_tac x="?\<sigma>" in bexI)
        show "perm_fun ?\<sigma> u1 = u2"
        proof-
          have "perm_dom \<sigma>1 = num_vertices G" "perm_dom \<sigma>2 = num_vertices G" "perm_dom \<sigma> = num_vertices G"
            using `\<sigma>1 \<in> ?A` `\<sigma>2 \<in> ?A` `\<sigma> \<in> ?A` `is_vertex_list G \<nu>`
            by (auto simp add: automorphisms_def is_automorphism_def is_isomorphism_def)
          then show ?thesis
            using `vertex G u1` `vertex G u2` \<open>vertex G v1\<close> `perm_fun \<sigma> v1 = v2` `perm_fun \<sigma>1 v1 = u1` `perm_fun \<sigma>2 v2 = u2`
            by fastforce
        qed
      next
        show "?\<sigma> \<in> ?A"
          using \<open>\<sigma> \<in> ?A\<close> \<open>\<sigma>1 \<in> ?A\<close> \<open>\<sigma>2 \<in> ?A\<close> automorphisms_def
          by auto
      qed
    qed
  } note * = this
  show ?thesis
  unfolding is_orbit_subset_def
  proof safe
    fix u1 u2
    assume "u1 \<in> \<Omega>1" "u2 \<in> \<Omega>1"
    then show "\<exists>p\<in>automorphisms (recolor G (\<R>' G \<nu>)). perm_fun p u1 = u2"
      using assms
      by (simp add: is_orbit_subset_def)
  next
    fix u1 u2
    assume "u1 \<in> \<Omega>2" "u2 \<in> \<Omega>2"
    then show "\<exists>p\<in>automorphisms (recolor G (\<R>' G \<nu>)). perm_fun p u1 = u2"
      using assms
      by (simp add: is_orbit_subset_def)
  next
    fix u1 u2
    assume "u1 \<in> \<Omega>1" "u2 \<in> \<Omega>2"
    then show "\<exists>p\<in>automorphisms (recolor G (\<R>' G \<nu>)). perm_fun p u1 = u2"
      using assms *
      by simp
  next
    fix u1 u2
    assume "u1 \<in> \<Omega>2" "u2 \<in> \<Omega>1"
    moreover have "is_automorphism G (perm_inv \<sigma>)"
      using assms
      by auto
    moreover have  "\<nu> = perm_fun_list (perm_inv \<sigma>) \<nu>"
      using `is_vertex_list G \<nu>` assms
      by (metis is_automorphism_def is_isomorphism_def is_vertex_list_def perm_fun_list_perm_inv)
    moreover have "perm_fun (perm_inv \<sigma>) v2 = v1"
      using assms
      using is_automorphism_def is_isomorphism_def perm_fun_perm_inv2
      by blast
    ultimately show "\<exists>p\<in>automorphisms (recolor G (\<R>' G \<nu>)). perm_fun p u1 = u2"
      using assms *[of \<Omega>2 \<Omega>1 "perm_inv \<sigma>" u1 u2 v2 v1]
      by simp
  qed
qed

lemma prune_invariant_rule:
  assumes  "v1 # \<nu>1 \<in> nodes (tree G)" "v2 # \<nu>2 \<in> nodes (tree G)"
          "List.length \<nu>1 = List.length \<nu>2"
          "\<Phi>_lex' G \<nu>1 = \<Phi>_lex' G \<nu>2" "\<R>' G (v1 # \<nu>1) = \<pi>1" "\<R>' G (v2 # \<nu>2) = \<pi>2"
          "\<f>_hash (\<f> G \<pi>1) > \<f>_hash (\<f> G \<pi>2)"
   shows "the_max_leaf G (tree G) \<notin> leaves G (expand_tree G (v2 # \<nu>2))"
proof (rule pruneA_max_leaf)
  show "pruneA G (v1 # \<nu>1) (v2 # \<nu>2)"
    unfolding pruneA_def
  proof safe
    show "List.length (v1 # \<nu>1) = List.length (v2 # \<nu>2)"
      using assms
      by simp
    show "\<Phi>' G (v2 # \<nu>2) < \<Phi>' G (v1 # \<nu>1)"
    proof-
      have *: "\<Phi>_lex' G (v1 # \<nu>1) > \<Phi>_lex' G (v2 # \<nu>2)"
        using assms using is_vertex_list_cons(1) nodes_is_vertex_list
        by (subst \<Phi>_lex'_gt) blast+
      then show ?thesis
        unfolding \<Phi>'_def
        by auto
    qed
    show "v1 # \<nu>1 \<in> nodes (tree G)" "v2 # \<nu>2 \<in> nodes (tree G)"
      by fact+
  qed
qed

lemma extend_path_rule:
  assumes "\<nu> \<in> nodes (tree G)" "fset (\<T>' G \<nu>) \<noteq> {}" "the_max_leaf G (tree G) \<in> leaves G (expand_tree G \<nu>)"
          "\<forall> w \<in> fset (\<T>' G \<nu>) - {v}. the_max_leaf G (tree G) \<notin> leaves G (expand_tree G (w # \<nu>))"
        shows "the_max_leaf G (tree G) \<in> leaves G (expand_tree G (v # \<nu>))"
  using assms leaf_in_some_expand_tree[OF assms(1-3)]
  by auto

lemma prune_parent_rule:
  assumes "\<nu> \<in> nodes (tree G)" "\<forall> w \<in> fset (\<T>' G \<nu>). the_max_leaf G (tree G) \<notin> leaves G (expand_tree G (w # \<nu>))" "fset (\<T>' G \<nu>) \<noteq> {}"
  shows "the_max_leaf G (tree G) \<notin> leaves G (expand_tree G \<nu>)"
  using assms leaf_in_some_expand_tree[OF assms(1), of "the_max_leaf G (tree G)"]
  by auto

lemma canonical_leaf_rule:
  assumes "is_vertex_list G \<nu>" "the_max_leaf G (tree G) \<in> leaves G (expand_tree G \<nu>)" "\<R>' G \<nu> = \<pi>" "discrete \<pi>"
  shows "canon_form G = perm_graph (discrete_coloring_perm \<pi>) G"
proof-
  have "\<T>' G \<nu> = {||}"
    using `\<R>' G \<nu> = \<pi>` `discrete \<pi>` \<T>'_discrete[of G \<nu>]
    by (metis bot_fset_def fset_inverse)

  then have "the_max_leaf G (tree G) = \<nu>"
    using assms expand_tree.psimps[of G \<nu>] leaves.simps[of G \<nu> "{||}"] expand_tree_dom[OF assms(1)]
    by auto
  then show ?thesis
    using assms
    unfolding the_canon_form Let_def leaf_perm_def
    by auto
qed

lemma prune_leaf_rule_1:
  assumes "\<nu>1 \<in> nodes (tree G)" "\<nu>2 \<in> nodes (tree G)" "List.length \<nu>1 = List.length \<nu>2"
          "\<R>' G \<nu>1 = \<pi>1" "\<R>' G \<nu>2 = \<pi>2" "discrete \<pi>2" "\<not> discrete \<pi>1"
          "\<Phi>_lex' G \<nu>1 = \<Phi>_lex' G \<nu>2"
   shows "the_max_leaf G (tree G) \<notin> leaves G (expand_tree G \<nu>2)"
proof (rule ccontr)
  let ?\<nu> = "the_max_leaf G (tree G)"
  have "is_vertex_list G \<nu>1" "is_vertex_list G \<nu>2"
    using assms(1-2) nodes_is_vertex_list by blast+

  assume "\<not> ?thesis"
  then have "?\<nu> = \<nu>2"
    by (simp add: \<T>_discrete assms(2) assms(5) assms(6) expand_tree.psimps expand_tree_dom[OF `is_vertex_list G \<nu>2`])

  obtain \<nu>' where *: "\<nu>' \<in> leaves G (expand_tree G \<nu>1)" "\<nu>' \<noteq> \<nu>1"
    by (metis all_not_in_conv assms(1) assms(4) assms(7) leaves_expand_tree_iff_discrete_nodes_expand_tree leaves_expand_tree_not_empty nodes_is_vertex_list)

  have "\<Phi>_lex' G ?\<nu> < \<Phi>_lex' G \<nu>'"
    using \<Phi>_lex_extend_nodes[OF assms(1) *] `?\<nu> = \<nu>2` \<open>\<Phi>_lex' G \<nu>1 = \<Phi>_lex' G \<nu>2\<close>
    by simp
  then have "\<Phi>' G ?\<nu> < \<Phi>' G \<nu>'"
    unfolding \<Phi>'_def
    by auto
  then show False
    using the_max_leaf_is_max[of \<nu>' G] "*"(1) assms(1) leaves_of_node tree_def
    by auto
qed

lemma prune_leaf_rule_2:
  assumes "\<nu>1 \<in> nodes (tree G)" "\<nu>2 \<in> nodes (tree G)" "List.length \<nu>1 = List.length \<nu>2"
          "\<R>' G \<nu>1 = \<pi>1" "\<R>' G \<nu>2 = \<pi>2" "discrete \<pi>2" "discrete \<pi>1"
          "\<g> (num_vertices G) (perm_edges (discrete_coloring_perm \<pi>1) (edges G)) >
           \<g> (num_vertices G) (perm_edges (discrete_coloring_perm \<pi>2) (edges G))"
          "\<Phi>_lex' G \<nu>1 = \<Phi>_lex' G \<nu>2"
   shows "the_max_leaf G (tree G) \<notin> leaves G (expand_tree G \<nu>2)"
proof (rule ccontr)
  have "is_vertex_list G \<nu>1" "is_vertex_list G \<nu>2"
    using assms(1-2) nodes_is_vertex_list by blast+
  let ?\<nu> = "the_max_leaf G (tree G)"
  assume "\<not> ?thesis"
  then have "?\<nu> = \<nu>2"
    by (simp add: \<T>_discrete assms(2) assms(5) assms(6) expand_tree.psimps expand_tree_dom[OF `is_vertex_list G \<nu>2`])
  moreover
  have "\<Phi>' G \<nu>1 > \<Phi>' G \<nu>2"
    using assms
    unfolding \<Phi>'_def
    by (auto simp add: leaf_perm_def less_option_def less_eq_option_def)
  ultimately
  show False
    using the_max_leaf_is_max[of \<nu>1 G]
    using assms(1) assms(4) assms(7) leaves_iff_discrete_nodes
    by auto
qed

lemma prune_automorphism_rule:
  assumes "\<nu>1 \<in> nodes (tree G)" "\<nu>2 \<in> nodes (tree G)"
          "rev \<nu>1 < rev \<nu>2" "is_automorphism G \<sigma>" "perm_fun_list \<sigma> \<nu>1 = \<nu>2"
  shows "the_max_leaf G (tree G) \<notin> leaves G (expand_tree G \<nu>2)"
proof (rule pruneC_max_leaf)
  show "pruneC G \<nu>1 \<nu>2"
    using assms
    unfolding automorphisms_def pruneC_def
    by auto
qed

lemma prune_orbits_rule':
  assumes "\<nu> \<in> nodes (tree G)" "is_orbit_subset (automorphisms (recolor G (\<R>' G \<nu>))) \<Omega>" "w1 \<in> \<Omega>" "w2 \<in> \<Omega>" "w1 < w2"
  shows "\<exists> \<sigma> \<in> automorphisms G. perm_fun_list \<sigma> (w1 # \<nu>) = (w2 # \<nu>)"
proof-
  obtain \<sigma> where "\<sigma> \<in> automorphisms (recolor G (\<R>' G \<nu>))" "perm_fun \<sigma> w1 = w2"
    using assms
    unfolding is_orbit_subset_def
    by auto
  then have "perm_coloring \<sigma> (\<R>' G \<nu>) = (\<R>' G \<nu>)"
    unfolding automorphisms_def is_automorphism_def is_isomorphism_def
    by (smt (verit, del_insts) \<R>'_length assms(1) colors_perm_graph colors_recolor mem_Collect_eq nodes_is_vertex_list)
  then have "perm_coloring \<sigma> (colors G) = colors G"
    using perm_coloring_finer
    by (metis \<R>_finer \<R>_length' \<open>\<sigma> \<in> automorphisms (recolor G (\<R>' G \<nu>))\<close> assms(1) automorphisms_def is_automorphism_def is_isomorphism_def length_colors_num_vertices mem_Collect_eq nodes_is_vertex_list num_vertices_recolor)
  then have "\<sigma> \<in> automorphisms G"
    using `\<sigma> \<in> automorphisms (recolor G (\<R>' G \<nu>))`
    by (smt (verit, ccfv_threshold) \<R>'_length assms(1) automorphisms_def is_automorphism_def is_isomorphism_def length_colors_num_vertices mem_Collect_eq nodes_is_vertex_list num_vertices_recolor recolor_id recolor_perm recolor_recolor)
  moreover have "perm_fun_list \<sigma> (w1 # \<nu>) = (w2 # \<nu>)"
  proof-
    have "\<forall> v \<in> set \<nu>. perm_fun \<sigma> v = v"
      using pointwise_stabilizer[of G \<nu> \<sigma>] `\<sigma> \<in> automorphisms (recolor G (\<R>' G \<nu>))` `\<sigma> \<in> automorphisms G` assms(1)
      by (simp add: automorphisms_def)
    then show ?thesis
      using `perm_fun \<sigma> w1 = w2`
      unfolding perm_fun_list_def
      by (simp add: list.map_ident_strong)
  qed
  ultimately show ?thesis
    by auto
qed

lemma prune_orbits_rule:
  assumes "\<nu> \<in> nodes (tree G)" "w1 # \<nu> \<in> nodes (tree G)" "w2 # \<nu> \<in> nodes (tree G)"
          "is_orbit_subset (automorphisms (recolor G (\<R>' G \<nu>))) \<Omega>"
          "w1 \<in> \<Omega>" "w2 \<in> \<Omega>" "w1 < w2"
        shows "the_max_leaf G (tree G) \<notin> leaves G (expand_tree G (w2 # \<nu>))"
proof-
  have "rev (w1 # \<nu>) < rev (w2 # \<nu>)"
    using `w1 < w2`
    by (simp add: less_list_code(2) less_list_code(3) lexordp_append_left_rightI lexordp_induct)
  then show ?thesis
    using assms(2-3)
    using prune_orbits_rule'[of \<nu> G, OF _ assms(4-7)]
    using prune_automorphism_rule[OF assms(2-3)] assms(1)
    using automorphisms_def
    by blast
qed

lemma target_cell_graph [simp]:
  shows "graph (fold (\<lambda>v db'. add_fact db' (IsNode (v # \<nu>))) xs db) = graph db"
  by (induction xs rule: rev_induct) (auto simp add: add_fact_def)

lemma check_rule:
  assumes "valid_fact_database db" "check_rule rule db = Some db'"
  shows "valid_fact_database db'"
proof (cases rule)
  case ColoringAxiom
  then show ?thesis
    using assms
    unfolding valid_fact_database_def
    by (auto simp add: add_fact_def finer_refl)
next
  case (Individualize \<nu> v \<pi>)
  with assms have "(v # \<nu>) \<in> nodes (tree (graph db)) \<and> vertex (graph db) v" "\<R>' (graph db) \<nu> = \<pi>" "length \<pi> = num_vertices (graph db)"
    using nodes_extend[of \<nu> "graph db" v]
    using is_vertex_list_cons(3)[of "graph db" v \<nu>] nodes_is_vertex_list
    unfolding valid_fact_database_def
    by (force split: if_split_asm)+
  then show ?thesis
    using assms Individualize
    unfolding valid_fact_database_def
    by (auto simp add: add_fact_def split: if_split_asm)
next
  case (SplitColoring \<nu> \<pi>)
  then show ?thesis
    using assms
    using split_rule[of "graph db" \<nu> \<pi>]
    unfolding valid_fact_database_def
    apply (auto simp add: Let_def add_fact_def split: if_split_asm)
    apply force
    apply (metis (mono_tags) card.empty length_split_Min neq0_conv valid_coloring_finer_length)
    apply (metis (mono_tags, lifting) Min_in card_0_eq card_ge_0_finite mem_Collect_eq neq0_conv valid_fact.simps(2))
    done
next
  case (Equitable \<nu> \<pi>)
  then show ?thesis
    using assms equitable_rule[of \<pi> "graph db" \<nu>]
    unfolding valid_fact_database_def
    by (force split: if_split_asm simp add: add_fact_def finer_strict_def)
next
  case (TargetCell \<nu> \<pi>)
  show ?thesis
    unfolding valid_fact_database_def
  proof safe
    fix x
    assume "x \<in> facts db'"

    { fix db xs
      assume "x \<in> facts (fold (\<lambda>v db'. add_fact db' (IsNode (v # \<nu>))) xs db)"
      then have "x \<in> facts db \<or> (\<exists> v \<in> set xs. x = IsNode (v # \<nu>))"
        by (induction xs rule: rev_induct) (auto simp add: add_fact_def)
    }
    note * = this

    let ?c = "the (\<T>'_color \<pi>)"

    have "ColoringEqual \<nu> \<pi> \<in> facts db" "\<T>'_color \<pi> = Some ?c"
         "x \<in> facts db \<or> x = IsTargetCell \<nu> (cell \<pi> ?c) \<or> (\<exists> v \<in> cell \<pi> ?c. x = IsNode (v # \<nu>))"
         "graph db' = graph db"
      using assms(2) `x \<in> facts db'` TargetCell
      using *[of "sorted_list_of_set (cell \<pi> ?c)"
                 "add_fact db (IsTargetCell \<nu> (cell \<pi> ?c))"] target_cell_graph
      by (auto split: if_split_asm simp add: add_fact_def)
    then show "valid_fact (graph db') x"
      using assms(1) target_cell_rule[of "graph db" \<nu> \<pi> ?c] target_cell_expand_rule
      unfolding valid_fact_database_def
      by auto
  qed
next
  case (InvariantAxiom \<nu>)
  then show ?thesis
    using assms
    unfolding valid_fact_database_def
    by (force simp add: add_fact_def split: if_split_asm)
next
  case (InvariantsEqualSym \<nu>1 \<nu>2)
  then show ?thesis
    using assms
    unfolding valid_fact_database_def
    by (force simp add: add_fact_def split: if_split_asm)
next
  case (InvariantsEqualStep \<nu>1 v1 \<pi>1 \<nu>2 v2 \<pi>2)
  then have "\<Phi>_lex' (graph db) (v1 # \<nu>1) = \<Phi>_lex' (graph db) (v2 # \<nu>2)"
    using assms invariants_equal_step_rule[of v1 \<nu>1 "graph db" v2 \<nu>2]
    unfolding valid_fact_database_def
    by (smt (verit) check_rule.simps(8) option.simps(3) valid_fact.simps(1) valid_fact.simps(4))
  then show ?thesis
    using assms InvariantsEqualStep
    unfolding valid_fact_database_def
    by (force simp add: add_fact_def split: if_split_asm)
next
  case (OrbitsAxiom \<nu> v)
  then show ?thesis
    using assms
    unfolding valid_fact_database_def
    by (force simp add: add_fact_def split: if_split_asm)
next
  case (MergeOrbits \<nu> \<Omega>1 \<Omega>2 \<sigma> v1 v2)
  then have "is_orbit_subset (automorphisms (recolor (graph db) (\<R>' (graph db) \<nu>))) (\<Omega>1 \<union> \<Omega>2)"
    using assms
    unfolding valid_fact_database_def
    by (subst merge_orbits_rule) (auto split: if_split_asm)
  then show ?thesis
    using MergeOrbits assms
    unfolding valid_fact_database_def
    by (force simp add: add_fact_def split: if_split_asm)
next
  case (PruneInvariant \<nu>1 v1 \<pi>1 \<nu>2 v2 \<pi>2)
  then show ?thesis
    using assms prune_invariant_rule[of v1 \<nu>1 "graph db" v2 \<nu>2 \<pi>1 \<pi>2]
    unfolding valid_fact_database_def
    by (force simp add: add_fact_def split: if_split_asm)
next
  case (PathAxiom)
  then show ?thesis
    using assms the_max_leaf_is_leaf
    unfolding valid_fact_database_def
    by (auto simp add: add_fact_def tree_def split: if_split_asm)
next
  case (ExtendPath \<nu> W v)
  then have "v # \<nu> \<in> nodes (tree (graph db))"
    using assms nodes_extend
    unfolding valid_fact_database_def
    by (auto simp add: add_fact_def split: if_split_asm)
  moreover
  have "the_max_leaf (graph db) (tree (graph db)) \<in> leaves (graph db) (expand_tree (graph db) (v # \<nu>))"
    using assms ExtendPath extend_path_rule
    unfolding valid_fact_database_def
    by (smt (verit) check_rule.simps(13) option.simps(3) valid_fact.simps(3) valid_fact.simps(6) valid_fact.simps(7))
  ultimately show ?thesis
    using assms ExtendPath
    unfolding valid_fact_database_def
    by (auto simp add: add_fact_def split: if_split_asm)
next
  case (CanonicalLeaf \<nu> \<pi>)
  then show ?thesis
    using assms
    using canonical_leaf_rule[of "graph db" \<nu> \<pi>]
    unfolding valid_fact_database_def
    by (force simp add: add_fact_def split: if_split_asm)
next
  case (PruneParent \<nu> W)
  then have "the_max_leaf (graph db) (tree (graph db)) \<notin> leaves (graph db) (expand_tree (graph db) \<nu>)"
    using assms
    using prune_parent_rule[of \<nu> "graph db"]
    unfolding valid_fact_database_def
    by (metis (no_types, lifting) check_rule.simps(15) option.simps(3) valid_fact.simps(3) valid_fact.simps(6))
  then show ?thesis
    using assms PruneParent
    unfolding valid_fact_database_def
    by (force simp add: add_fact_def split: if_split_asm)
next
  case (PruneLeaf \<nu>1 \<pi>1 \<nu>2 \<pi>2)
  then show ?thesis
    using assms
    unfolding valid_fact_database_def
    using prune_leaf_rule_1[of \<nu>1 "graph db" \<nu>2 \<pi>1 \<pi>2]
    using prune_leaf_rule_2[of \<nu>1 "graph db" \<nu>2 \<pi>1 \<pi>2]
    by (force simp add: add_fact_def split: if_split_asm)
next
  case (PruneAutomorphism \<nu>1 \<nu>2 \<sigma>)
  then show ?thesis
    using assms
    using prune_automorphism_rule[of \<nu>1 "graph db" \<nu>2 \<sigma>]
    unfolding valid_fact_database_def
    by (force simp add: add_fact_def split: if_split_asm)
next
  case (PruneOrbits \<nu> \<Omega> v1 v2)
  then show ?thesis
    using assms
    using prune_orbits_rule[of \<nu> "graph db" v1 v2 \<Omega>]
    unfolding valid_fact_database_def
    by (force simp add: add_fact_def split: if_split_asm)
qed

fun check_rule_option :: "rule \<Rightarrow> fact_database option \<Rightarrow> fact_database option" where
  "check_rule_option r None = None"
| "check_rule_option r (Some db) = check_rule r db"

lemma check_rule_option:
  assumes "valid_fact_database db" "check_rule_option rule (Some db) = Some db'"
  shows "valid_fact_database db'"
  using assms check_rule
  by auto

type_synonym graph_proof = "rule list"

definition check_proof :: "colored_graph \<Rightarrow> graph_proof \<Rightarrow> fact_database option" where
  "check_proof G pf = (
     let initial_db = Some \<lparr> graph = G, facts = {} \<rparr>
      in fold check_rule_option pf initial_db)"

lemma check_proof_step:
  assumes "valid_fact_database db" "fold check_rule_option pf (Some db) = Some db'"
  shows "valid_fact_database db'"
  using assms
proof (induction pf arbitrary: db' rule: rev_induct)
  case Nil
  then show ?case
  by simp
next
  case (snoc r rs)
  let ?dbo'' = "fold check_rule_option rs (Some db)"
  have *: "check_rule_option r ?dbo'' = Some db'"
    using snoc
    by auto
  then obtain db'' where "?dbo'' = Some db''"
    by (cases ?dbo'', auto)
  then have "valid_fact_database db''"
    using snoc
    by auto
  then show ?case
    using * `?dbo'' = Some db''` check_rule_option
    by auto
qed

lemma check_rule_graph [simp]:
  assumes "check_rule r db = Some db'"
  shows "graph db' = graph db"
  using assms target_cell_graph
  by (cases r) (auto simp add: add_fact_def Let_def split: if_split_asm)

lemma check_rule_option_graph [simp]:
  assumes "check_rule_option r (Some db) = Some db'"
  shows "graph db' = graph db"
  using assms
  by simp

lemma check_proof_graph_step:
  assumes "fold check_rule_option pf (Some db) = Some db'"
  shows "graph db' = graph db"
  using assms
proof (induction pf arbitrary: db' rule: rev_induct)
  case Nil
  then show ?case
  by simp
next
  case (snoc r rs)
  let ?dbo'' = "fold check_rule_option rs (Some db)"
  have *: "check_rule_option r ?dbo'' = Some db'"
    using snoc
    by auto
  then obtain db'' where "?dbo'' = Some db''"
    by (cases ?dbo'', auto)
  then show ?case
    using snoc *
    by auto
qed

lemma check_proof:
  assumes "check_proof G pf = Some db"
  shows "valid_fact_database db"
proof-
  have "valid_fact_database \<lparr> graph = G, facts = {} \<rparr>"
    by (simp add: valid_fact_database_def)
  then show ?thesis
    using assms check_proof_step
    unfolding check_proof_def
    by auto
qed

lemma check_proof_graph:
  assumes "check_proof G pf = Some db"
  shows "graph db = G"
  using assms check_proof_graph_step
  unfolding check_proof_def
  by auto

theorem soundness:
  assumes "check_proof G pf = Some db"
  assumes "Canonical \<pi> \<in> facts db"
  shows "discrete \<pi>" "length \<pi> = num_vertices G"
        "canon_form G = perm_graph (discrete_coloring_perm \<pi>) G"
proof-
  have "valid_fact G (Canonical \<pi>)"
    using check_proof[OF assms(1)] assms(2) check_proof_graph[OF assms(1)]
    unfolding valid_fact_database_def
    by auto
  then show "discrete \<pi>" "length \<pi> = num_vertices G"
            "canon_form G = perm_graph (discrete_coloring_perm \<pi>) G"
    by simp_all
qed

end
end


(*  Title:      HOL/Code_Numeral.thy
    Author:     Florian Haftmann, TU Muenchen
*)

section \<open>Numeric types for code generation onto target language numerals only\<close>

theory Code_Numeral
imports Divides Lifting
begin

subsection \<open>Type of target language integers\<close>

typedef integer = "UNIV :: int set"
  morphisms int_of_integer integer_of_int ..

setup_lifting type_definition_integer

lemma integer_eq_iff:
  "k = l \<longleftrightarrow> int_of_integer k = int_of_integer l"
  by transfer rule

lemma integer_eqI:
  "int_of_integer k = int_of_integer l \<Longrightarrow> k = l"
  using integer_eq_iff [of k l] by simp

lemma int_of_integer_integer_of_int [simp]:
  "int_of_integer (integer_of_int k) = k"
  by transfer rule

lemma integer_of_int_int_of_integer [simp]:
  "integer_of_int (int_of_integer k) = k"
  by transfer rule

instantiation integer :: ring_1
begin

lift_definition zero_integer :: integer
  is "0 :: int"
  .

declare zero_integer.rep_eq [simp]

lift_definition one_integer :: integer
  is "1 :: int"
  .

declare one_integer.rep_eq [simp]

lift_definition plus_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer"
  is "plus :: int \<Rightarrow> int \<Rightarrow> int"
  .

declare plus_integer.rep_eq [simp]

lift_definition uminus_integer :: "integer \<Rightarrow> integer"
  is "uminus :: int \<Rightarrow> int"
  .

declare uminus_integer.rep_eq [simp]

lift_definition minus_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer"
  is "minus :: int \<Rightarrow> int \<Rightarrow> int"
  .

declare minus_integer.rep_eq [simp]

lift_definition times_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer"
  is "times :: int \<Rightarrow> int \<Rightarrow> int"
  .

declare times_integer.rep_eq [simp]

instance proof
qed (transfer, simp add: algebra_simps)+

end

instance integer :: Rings.dvd ..

context
  includes lifting_syntax
  notes transfer_rule_numeral [transfer_rule]
begin

lemma [transfer_rule]:
  "((\<longleftrightarrow>) ===> pcr_integer) of_bool of_bool"
  by (unfold of_bool_def) transfer_prover

lemma [transfer_rule]:
  "((=) ===> pcr_integer) int of_nat"
  by (rule transfer_rule_of_nat) transfer_prover+

lemma [transfer_rule]:
  "((=) ===> pcr_integer) (\<lambda>k. k) of_int"
proof -
  have "((=) ===> pcr_integer) of_int of_int"
    by (rule transfer_rule_of_int) transfer_prover+
  then show ?thesis by (simp add: id_def)
qed

lemma [transfer_rule]:
  "((=) ===> pcr_integer) numeral numeral"
  by transfer_prover

lemma [transfer_rule]:
  "((=) ===> (=) ===> pcr_integer) Num.sub Num.sub"
  by (unfold Num.sub_def) transfer_prover

lemma [transfer_rule]:
  "(pcr_integer ===> (=) ===> pcr_integer) (^) (^)"
  by (unfold power_def) transfer_prover

end

lemma int_of_integer_of_nat [simp]:
  "int_of_integer (of_nat n) = of_nat n"
  by transfer rule

lift_definition integer_of_nat :: "nat \<Rightarrow> integer"
  is "of_nat :: nat \<Rightarrow> int"
  .

lemma integer_of_nat_eq_of_nat [code]:
  "integer_of_nat = of_nat"
  by transfer rule

lemma int_of_integer_integer_of_nat [simp]:
  "int_of_integer (integer_of_nat n) = of_nat n"
  by transfer rule

lift_definition nat_of_integer :: "integer \<Rightarrow> nat"
  is Int.nat
  .

lemma nat_of_integer_of_nat [simp]:
  "nat_of_integer (of_nat n) = n"
  by transfer simp

lemma int_of_integer_of_int [simp]:
  "int_of_integer (of_int k) = k"
  by transfer simp

lemma nat_of_integer_integer_of_nat [simp]:
  "nat_of_integer (integer_of_nat n) = n"
  by transfer simp

lemma integer_of_int_eq_of_int [simp, code_abbrev]:
  "integer_of_int = of_int"
  by transfer (simp add: fun_eq_iff)

lemma of_int_integer_of [simp]:
  "of_int (int_of_integer k) = (k :: integer)"
  by transfer rule

lemma int_of_integer_numeral [simp]:
  "int_of_integer (numeral k) = numeral k"
  by transfer rule

lemma int_of_integer_sub [simp]:
  "int_of_integer (Num.sub k l) = Num.sub k l"
  by transfer rule

definition integer_of_num :: "num \<Rightarrow> integer"
  where [simp]: "integer_of_num = numeral"

lemma integer_of_num [code]:
  "integer_of_num Num.One = 1"
  "integer_of_num (Num.Bit0 n) = (let k = integer_of_num n in k + k)"
  "integer_of_num (Num.Bit1 n) = (let k = integer_of_num n in k + k + 1)"
  by (simp_all only: integer_of_num_def numeral.simps Let_def)

lemma integer_of_num_triv:
  "integer_of_num Num.One = 1"
  "integer_of_num (Num.Bit0 Num.One) = 2"
  by simp_all

instantiation integer :: "{linordered_idom, equal}"
begin

lift_definition abs_integer :: "integer \<Rightarrow> integer"
  is "abs :: int \<Rightarrow> int"
  .

declare abs_integer.rep_eq [simp]

lift_definition sgn_integer :: "integer \<Rightarrow> integer"
  is "sgn :: int \<Rightarrow> int"
  .

declare sgn_integer.rep_eq [simp]

lift_definition less_eq_integer :: "integer \<Rightarrow> integer \<Rightarrow> bool"
  is "less_eq :: int \<Rightarrow> int \<Rightarrow> bool"
  .

lemma integer_less_eq_iff:
  "k \<le> l \<longleftrightarrow> int_of_integer k \<le> int_of_integer l"
  by (fact less_eq_integer.rep_eq)

lift_definition less_integer :: "integer \<Rightarrow> integer \<Rightarrow> bool"
  is "less :: int \<Rightarrow> int \<Rightarrow> bool"
  .

lemma integer_less_iff:
  "k < l \<longleftrightarrow> int_of_integer k < int_of_integer l"
  by (fact less_integer.rep_eq)

lift_definition equal_integer :: "integer \<Rightarrow> integer \<Rightarrow> bool"
  is "HOL.equal :: int \<Rightarrow> int \<Rightarrow> bool"
  .

instance
  by standard (transfer, simp add: algebra_simps equal less_le_not_le [symmetric] mult_strict_right_mono linear)+

end

context
  includes lifting_syntax
begin

lemma [transfer_rule]:
  \<open>(pcr_integer ===> pcr_integer ===> pcr_integer) min min\<close>
  by (unfold min_def) transfer_prover

lemma [transfer_rule]:
  \<open>(pcr_integer ===> pcr_integer ===> pcr_integer) max max\<close>
  by (unfold max_def) transfer_prover

end

lemma int_of_integer_min [simp]:
  "int_of_integer (min k l) = min (int_of_integer k) (int_of_integer l)"
  by transfer rule

lemma int_of_integer_max [simp]:
  "int_of_integer (max k l) = max (int_of_integer k) (int_of_integer l)"
  by transfer rule

lemma nat_of_integer_non_positive [simp]:
  "k \<le> 0 \<Longrightarrow> nat_of_integer k = 0"
  by transfer simp

lemma of_nat_of_integer [simp]:
  "of_nat (nat_of_integer k) = max 0 k"
  by transfer auto

instantiation integer :: unique_euclidean_ring
begin

lift_definition divide_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer"
  is "divide :: int \<Rightarrow> int \<Rightarrow> int"
  .

declare divide_integer.rep_eq [simp]

lift_definition modulo_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer"
  is "modulo :: int \<Rightarrow> int \<Rightarrow> int"
  .

declare modulo_integer.rep_eq [simp]

lift_definition euclidean_size_integer :: "integer \<Rightarrow> nat"
  is "euclidean_size :: int \<Rightarrow> nat"
  .

declare euclidean_size_integer.rep_eq [simp]

lift_definition division_segment_integer :: "integer \<Rightarrow> integer"
  is "division_segment :: int \<Rightarrow> int"
  .

declare division_segment_integer.rep_eq [simp]

instance
  by (standard; transfer)
    (use mult_le_mono2 [of 1] in \<open>auto simp add: sgn_mult_abs abs_mult sgn_mult abs_mod_less sgn_mod nat_mult_distrib
     division_segment_mult division_segment_mod intro: div_eqI\<close>)

end

lemma [code]:
  "division_segment (k :: integer) = (if k \<ge> 0 then 1 else - 1)"
  by transfer (simp add: division_segment_int_def)

instance integer :: unique_euclidean_ring_with_nat
  by (standard; transfer) (simp_all add: of_nat_div division_segment_int_def)

instantiation integer :: semiring_bit_shifts
begin

lift_definition push_bit_integer :: \<open>nat \<Rightarrow> integer \<Rightarrow> integer\<close>
  is \<open>push_bit\<close> .

lift_definition drop_bit_integer :: \<open>nat \<Rightarrow> integer \<Rightarrow> integer\<close>
  is \<open>drop_bit\<close> .

instance by (standard; transfer)
  (fact bit_eq_rec bits_induct push_bit_eq_mult drop_bit_eq_div
    bits_div_0 bits_div_by_1 bits_mod_div_trivial even_succ_div_2
    exp_div_exp_eq div_exp_eq mod_exp_eq mult_exp_mod_exp_eq div_exp_mod_exp_eq
    even_mask_div_iff even_mult_exp_div_exp_iff)+

end

context
  includes lifting_syntax
begin

lemma [transfer_rule]:
  \<open>(pcr_integer ===> (=) ===> (\<longleftrightarrow>)) bit bit\<close>
  by (unfold bit_def) transfer_prover

lemma [transfer_rule]:
  \<open>((=) ===> pcr_integer ===> pcr_integer) take_bit take_bit\<close>
  by (unfold take_bit_eq_mod) transfer_prover

end

instance integer :: unique_euclidean_semiring_with_bit_shifts ..

lemma [code]:
  \<open>push_bit n k = k * 2 ^ n\<close>
  \<open>drop_bit n k = k div 2 ^ n\<close> for k :: integer
  by (fact push_bit_eq_mult drop_bit_eq_div)+

instantiation integer :: unique_euclidean_semiring_numeral
begin

definition divmod_integer :: "num \<Rightarrow> num \<Rightarrow> integer \<times> integer"
where
  divmod_integer'_def: "divmod_integer m n = (numeral m div numeral n, numeral m mod numeral n)"

definition divmod_step_integer :: "num \<Rightarrow> integer \<times> integer \<Rightarrow> integer \<times> integer"
where
  "divmod_step_integer l qr = (let (q, r) = qr
    in if r \<ge> numeral l then (2 * q + 1, r - numeral l)
    else (2 * q, r))"

instance proof
  show "divmod m n = (numeral m div numeral n :: integer, numeral m mod numeral n)"
    for m n by (fact divmod_integer'_def)
  show "divmod_step l qr = (let (q, r) = qr
    in if r \<ge> numeral l then (2 * q + 1, r - numeral l)
    else (2 * q, r))" for l and qr :: "integer \<times> integer"
    by (fact divmod_step_integer_def)
qed (transfer,
  fact le_add_diff_inverse2
  unique_euclidean_semiring_numeral_class.div_less
  unique_euclidean_semiring_numeral_class.mod_less
  unique_euclidean_semiring_numeral_class.div_positive
  unique_euclidean_semiring_numeral_class.mod_less_eq_dividend
  unique_euclidean_semiring_numeral_class.pos_mod_bound
  unique_euclidean_semiring_numeral_class.pos_mod_sign
  unique_euclidean_semiring_numeral_class.mod_mult2_eq
  unique_euclidean_semiring_numeral_class.div_mult2_eq
  unique_euclidean_semiring_numeral_class.discrete)+

end

declare divmod_algorithm_code [where ?'a = integer,
  folded integer_of_num_def, unfolded integer_of_num_triv,
  code]

lemma integer_of_nat_0: "integer_of_nat 0 = 0"
by transfer simp

lemma integer_of_nat_1: "integer_of_nat 1 = 1"
by transfer simp

lemma integer_of_nat_numeral:
  "integer_of_nat (numeral n) = numeral n"
by transfer simp

subsection \<open>Code theorems for target language integers\<close>

text \<open>Constructors\<close>

definition Pos :: "num \<Rightarrow> integer"
where
  [simp, code_post]: "Pos = numeral"

context
  includes lifting_syntax
begin

lemma [transfer_rule]:
  \<open>((=) ===> pcr_integer) numeral Pos\<close>
  by simp transfer_prover

end

lemma Pos_fold [code_unfold]:
  "numeral Num.One = Pos Num.One"
  "numeral (Num.Bit0 k) = Pos (Num.Bit0 k)"
  "numeral (Num.Bit1 k) = Pos (Num.Bit1 k)"
  by simp_all

definition Neg :: "num \<Rightarrow> integer"
where
  [simp, code_abbrev]: "Neg n = - Pos n"

context
  includes lifting_syntax
begin

lemma [transfer_rule]:
  \<open>((=) ===> pcr_integer) (\<lambda>n. - numeral n) Neg\<close>
  by (unfold Neg_def) transfer_prover

end

code_datatype "0::integer" Pos Neg

text \<open>A further pair of constructors for generated computations\<close>

context
begin

qualified definition positive :: "num \<Rightarrow> integer"
  where [simp]: "positive = numeral"

qualified definition negative :: "num \<Rightarrow> integer"
  where [simp]: "negative = uminus \<circ> numeral"

lemma [code_computation_unfold]:
  "numeral = positive"
  "Pos = positive"
  "Neg = negative"
  by (simp_all add: fun_eq_iff)

end

text \<open>Auxiliary operations\<close>

lift_definition dup :: "integer \<Rightarrow> integer"
  is "\<lambda>k::int. k + k"
  .

lemma dup_code [code]:
  "dup 0 = 0"
  "dup (Pos n) = Pos (Num.Bit0 n)"
  "dup (Neg n) = Neg (Num.Bit0 n)"
  by (transfer, simp only: numeral_Bit0 minus_add_distrib)+

lift_definition sub :: "num \<Rightarrow> num \<Rightarrow> integer"
  is "\<lambda>m n. numeral m - numeral n :: int"
  .

lemma sub_code [code]:
  "sub Num.One Num.One = 0"
  "sub (Num.Bit0 m) Num.One = Pos (Num.BitM m)"
  "sub (Num.Bit1 m) Num.One = Pos (Num.Bit0 m)"
  "sub Num.One (Num.Bit0 n) = Neg (Num.BitM n)"
  "sub Num.One (Num.Bit1 n) = Neg (Num.Bit0 n)"
  "sub (Num.Bit0 m) (Num.Bit0 n) = dup (sub m n)"
  "sub (Num.Bit1 m) (Num.Bit1 n) = dup (sub m n)"
  "sub (Num.Bit1 m) (Num.Bit0 n) = dup (sub m n) + 1"
  "sub (Num.Bit0 m) (Num.Bit1 n) = dup (sub m n) - 1"
  by (transfer, simp add: dbl_def dbl_inc_def dbl_dec_def)+

text \<open>Implementations\<close>

lemma one_integer_code [code, code_unfold]:
  "1 = Pos Num.One"
  by simp

lemma plus_integer_code [code]:
  "k + 0 = (k::integer)"
  "0 + l = (l::integer)"
  "Pos m + Pos n = Pos (m + n)"
  "Pos m + Neg n = sub m n"
  "Neg m + Pos n = sub n m"
  "Neg m + Neg n = Neg (m + n)"
  by (transfer, simp)+

lemma uminus_integer_code [code]:
  "uminus 0 = (0::integer)"
  "uminus (Pos m) = Neg m"
  "uminus (Neg m) = Pos m"
  by simp_all

lemma minus_integer_code [code]:
  "k - 0 = (k::integer)"
  "0 - l = uminus (l::integer)"
  "Pos m - Pos n = sub m n"
  "Pos m - Neg n = Pos (m + n)"
  "Neg m - Pos n = Neg (m + n)"
  "Neg m - Neg n = sub n m"
  by (transfer, simp)+

lemma abs_integer_code [code]:
  "\<bar>k\<bar> = (if (k::integer) < 0 then - k else k)"
  by simp

lemma sgn_integer_code [code]:
  "sgn k = (if k = 0 then 0 else if (k::integer) < 0 then - 1 else 1)"
  by simp

lemma times_integer_code [code]:
  "k * 0 = (0::integer)"
  "0 * l = (0::integer)"
  "Pos m * Pos n = Pos (m * n)"
  "Pos m * Neg n = Neg (m * n)"
  "Neg m * Pos n = Neg (m * n)"
  "Neg m * Neg n = Pos (m * n)"
  by simp_all

definition divmod_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer \<times> integer"
where
  "divmod_integer k l = (k div l, k mod l)"

lemma fst_divmod_integer [simp]:
  "fst (divmod_integer k l) = k div l"
  by (simp add: divmod_integer_def)

lemma snd_divmod_integer [simp]:
  "snd (divmod_integer k l) = k mod l"
  by (simp add: divmod_integer_def)

definition divmod_abs :: "integer \<Rightarrow> integer \<Rightarrow> integer \<times> integer"
where
  "divmod_abs k l = (\<bar>k\<bar> div \<bar>l\<bar>, \<bar>k\<bar> mod \<bar>l\<bar>)"

lemma fst_divmod_abs [simp]:
  "fst (divmod_abs k l) = \<bar>k\<bar> div \<bar>l\<bar>"
  by (simp add: divmod_abs_def)

lemma snd_divmod_abs [simp]:
  "snd (divmod_abs k l) = \<bar>k\<bar> mod \<bar>l\<bar>"
  by (simp add: divmod_abs_def)

lemma divmod_abs_code [code]:
  "divmod_abs (Pos k) (Pos l) = divmod k l"
  "divmod_abs (Neg k) (Neg l) = divmod k l"
  "divmod_abs (Neg k) (Pos l) = divmod k l"
  "divmod_abs (Pos k) (Neg l) = divmod k l"
  "divmod_abs j 0 = (0, \<bar>j\<bar>)"
  "divmod_abs 0 j = (0, 0)"
  by (simp_all add: prod_eq_iff)

lemma divmod_integer_eq_cases:
  "divmod_integer k l =
    (if k = 0 then (0, 0) else if l = 0 then (0, k) else
    (apsnd \<circ> times \<circ> sgn) l (if sgn k = sgn l
      then divmod_abs k l
      else (let (r, s) = divmod_abs k l in
        if s = 0 then (- r, 0) else (- r - 1, \<bar>l\<bar> - s))))"
proof -
  have *: "sgn k = sgn l \<longleftrightarrow> k = 0 \<and> l = 0 \<or> 0 < l \<and> 0 < k \<or> l < 0 \<and> k < 0" for k l :: int
    by (auto simp add: sgn_if)
  have **: "- k = l * q \<longleftrightarrow> k = - (l * q)" for k l q :: int
    by auto
  show ?thesis
    by (simp add: divmod_integer_def divmod_abs_def)
      (transfer, auto simp add: * ** not_less zdiv_zminus1_eq_if zmod_zminus1_eq_if div_minus_right mod_minus_right)
qed

lemma divmod_integer_code [code]: \<^marker>\<open>contributor \<open>René Thiemann\<close>\<close> \<^marker>\<open>contributor \<open>Akihisa Yamada\<close>\<close>
  "divmod_integer k l =
   (if k = 0 then (0, 0)
    else if l > 0 then
            (if k > 0 then Code_Numeral.divmod_abs k l
             else case Code_Numeral.divmod_abs k l of (r, s) \<Rightarrow>
                  if s = 0 then (- r, 0) else (- r - 1, l - s))
    else if l = 0 then (0, k)
    else apsnd uminus
            (if k < 0 then Code_Numeral.divmod_abs k l
             else case Code_Numeral.divmod_abs k l of (r, s) \<Rightarrow>
                  if s = 0 then (- r, 0) else (- r - 1, - l - s)))"
  by (cases l "0 :: integer" rule: linorder_cases)
    (auto split: prod.splits simp add: divmod_integer_eq_cases)

lemma div_integer_code [code]:
  "k div l = fst (divmod_integer k l)"
  by simp

lemma mod_integer_code [code]:
  "k mod l = snd (divmod_integer k l)"
  by simp

definition bit_cut_integer :: "integer \<Rightarrow> integer \<times> bool"
  where "bit_cut_integer k = (k div 2, odd k)"

lemma bit_cut_integer_code [code]:
  "bit_cut_integer k = (if k = 0 then (0, False)
     else let (r, s) = Code_Numeral.divmod_abs k 2
       in (if k > 0 then r else - r - s, s = 1))"
proof -
  have "bit_cut_integer k = (let (r, s) = divmod_integer k 2 in (r, s = 1))"
    by (simp add: divmod_integer_def bit_cut_integer_def odd_iff_mod_2_eq_one)
  then show ?thesis
    by (simp add: divmod_integer_code) (auto simp add: split_def)
qed

lemma equal_integer_code [code]:
  "HOL.equal 0 (0::integer) \<longleftrightarrow> True"
  "HOL.equal 0 (Pos l) \<longleftrightarrow> False"
  "HOL.equal 0 (Neg l) \<longleftrightarrow> False"
  "HOL.equal (Pos k) 0 \<longleftrightarrow> False"
  "HOL.equal (Pos k) (Pos l) \<longleftrightarrow> HOL.equal k l"
  "HOL.equal (Pos k) (Neg l) \<longleftrightarrow> False"
  "HOL.equal (Neg k) 0 \<longleftrightarrow> False"
  "HOL.equal (Neg k) (Pos l) \<longleftrightarrow> False"
  "HOL.equal (Neg k) (Neg l) \<longleftrightarrow> HOL.equal k l"
  by (simp_all add: equal)

lemma equal_integer_refl [code nbe]:
  "HOL.equal (k::integer) k \<longleftrightarrow> True"
  by (fact equal_refl)

lemma less_eq_integer_code [code]:
  "0 \<le> (0::integer) \<longleftrightarrow> True"
  "0 \<le> Pos l \<longleftrightarrow> True"
  "0 \<le> Neg l \<longleftrightarrow> False"
  "Pos k \<le> 0 \<longleftrightarrow> False"
  "Pos k \<le> Pos l \<longleftrightarrow> k \<le> l"
  "Pos k \<le> Neg l \<longleftrightarrow> False"
  "Neg k \<le> 0 \<longleftrightarrow> True"
  "Neg k \<le> Pos l \<longleftrightarrow> True"
  "Neg k \<le> Neg l \<longleftrightarrow> l \<le> k"
  by simp_all

lemma less_integer_code [code]:
  "0 < (0::integer) \<longleftrightarrow> False"
  "0 < Pos l \<longleftrightarrow> True"
  "0 < Neg l \<longleftrightarrow> False"
  "Pos k < 0 \<longleftrightarrow> False"
  "Pos k < Pos l \<longleftrightarrow> k < l"
  "Pos k < Neg l \<longleftrightarrow> False"
  "Neg k < 0 \<longleftrightarrow> True"
  "Neg k < Pos l \<longleftrightarrow> True"
  "Neg k < Neg l \<longleftrightarrow> l < k"
  by simp_all

lift_definition num_of_integer :: "integer \<Rightarrow> num"
  is "num_of_nat \<circ> nat"
  .

lemma num_of_integer_code [code]:
  "num_of_integer k = (if k \<le> 1 then Num.One
     else let
       (l, j) = divmod_integer k 2;
       l' = num_of_integer l;
       l'' = l' + l'
     in if j = 0 then l'' else l'' + Num.One)"
proof -
  {
    assume "int_of_integer k mod 2 = 1"
    then have "nat (int_of_integer k mod 2) = nat 1" by simp
    moreover assume *: "1 < int_of_integer k"
    ultimately have **: "nat (int_of_integer k) mod 2 = 1" by (simp add: nat_mod_distrib)
    have "num_of_nat (nat (int_of_integer k)) =
      num_of_nat (2 * (nat (int_of_integer k) div 2) + nat (int_of_integer k) mod 2)"
      by simp
    then have "num_of_nat (nat (int_of_integer k)) =
      num_of_nat (nat (int_of_integer k) div 2 + nat (int_of_integer k) div 2 + nat (int_of_integer k) mod 2)"
      by (simp add: mult_2)
    with ** have "num_of_nat (nat (int_of_integer k)) =
      num_of_nat (nat (int_of_integer k) div 2 + nat (int_of_integer k) div 2 + 1)"
      by simp
  }
  note aux = this
  show ?thesis
    by (auto simp add: num_of_integer_def nat_of_integer_def Let_def case_prod_beta
      not_le integer_eq_iff less_eq_integer_def
      nat_mult_distrib nat_div_distrib num_of_nat_One num_of_nat_plus_distrib
       mult_2 [where 'a=nat] aux add_One)
qed

lemma nat_of_integer_code [code]:
  "nat_of_integer k = (if k \<le> 0 then 0
     else let
       (l, j) = divmod_integer k 2;
       l' = nat_of_integer l;
       l'' = l' + l'
     in if j = 0 then l'' else l'' + 1)"
proof -
  obtain j where k: "k = integer_of_int j"
  proof
    show "k = integer_of_int (int_of_integer k)" by simp
  qed
  have *: "nat j mod 2 = nat_of_integer (of_int j mod 2)" if "j \<ge> 0"
    using that by transfer (simp add: nat_mod_distrib)
  from k show ?thesis
    by (auto simp add: split_def Let_def nat_of_integer_def nat_div_distrib mult_2 [symmetric]
      minus_mod_eq_mult_div [symmetric] *)
qed

lemma int_of_integer_code [code]:
  "int_of_integer k = (if k < 0 then - (int_of_integer (- k))
     else if k = 0 then 0
     else let
       (l, j) = divmod_integer k 2;
       l' = 2 * int_of_integer l
     in if j = 0 then l' else l' + 1)"
  by (auto simp add: split_def Let_def integer_eq_iff minus_mod_eq_mult_div [symmetric])

lemma integer_of_int_code [code]:
  "integer_of_int k = (if k < 0 then - (integer_of_int (- k))
     else if k = 0 then 0
     else let
       l = 2 * integer_of_int (k div 2);
       j = k mod 2
     in if j = 0 then l else l + 1)"
  by (auto simp add: split_def Let_def integer_eq_iff minus_mod_eq_mult_div [symmetric])

hide_const (open) Pos Neg sub dup divmod_abs

subsection \<open>Serializer setup for target language integers\<close>

code_reserved Eval int Integer abs

code_printing
  type_constructor integer \<rightharpoonup>
    (SML) "IntInf.int"
    and (OCaml) "Z.t"
    and (Haskell) "Integer"
    and (Scala) "BigInt"
    and (Eval) "int"
| class_instance integer :: equal \<rightharpoonup>
    (Haskell) -

code_printing
  constant "0::integer" \<rightharpoonup>
    (SML) "!(0/ :/ IntInf.int)"
    and (OCaml) "Z.zero"
    and (Haskell) "!(0/ ::/ Integer)"
    and (Scala) "BigInt(0)"

setup \<open>
  fold (fn target =>
    Numeral.add_code \<^const_name>\<open>Code_Numeral.Pos\<close> I Code_Printer.literal_numeral target
    #> Numeral.add_code \<^const_name>\<open>Code_Numeral.Neg\<close> (~) Code_Printer.literal_numeral target)
    ["SML", "OCaml", "Haskell", "Scala"]
\<close>

code_printing
  constant "plus :: integer \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
    (SML) "IntInf.+ ((_), (_))"
    and (OCaml) "Z.add"
    and (Haskell) infixl 6 "+"
    and (Scala) infixl 7 "+"
    and (Eval) infixl 8 "+"
| constant "uminus :: integer \<Rightarrow> _" \<rightharpoonup>
    (SML) "IntInf.~"
    and (OCaml) "Z.neg"
    and (Haskell) "negate"
    and (Scala) "!(- _)"
    and (Eval) "~/ _"
| constant "minus :: integer \<Rightarrow> _" \<rightharpoonup>
    (SML) "IntInf.- ((_), (_))"
    and (OCaml) "Z.sub"
    and (Haskell) infixl 6 "-"
    and (Scala) infixl 7 "-"
    and (Eval) infixl 8 "-"
| constant Code_Numeral.dup \<rightharpoonup>
    (SML) "IntInf.*/ (2,/ (_))"
    and (OCaml) "Z.shift'_left/ _/ 1"
    and (Haskell) "!(2 * _)"
    and (Scala) "!(2 * _)"
    and (Eval) "!(2 * _)"
| constant Code_Numeral.sub \<rightharpoonup>
    (SML) "!(raise/ Fail/ \"sub\")"
    and (OCaml) "failwith/ \"sub\""
    and (Haskell) "error/ \"sub\""
    and (Scala) "!sys.error(\"sub\")"
| constant "times :: integer \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
    (SML) "IntInf.* ((_), (_))"
    and (OCaml) "Z.mul"
    and (Haskell) infixl 7 "*"
    and (Scala) infixl 8 "*"
    and (Eval) infixl 9 "*"
| constant Code_Numeral.divmod_abs \<rightharpoonup>
    (SML) "IntInf.divMod/ (IntInf.abs _,/ IntInf.abs _)"
    and (OCaml) "!(fun k l ->/ if Z.equal Z.zero l then/ (Z.zero, l) else/ Z.div'_rem/ (Z.abs k)/ (Z.abs l))"
    and (Haskell) "divMod/ (abs _)/ (abs _)"
    and (Scala) "!((k: BigInt) => (l: BigInt) =>/ if (l == 0)/ (BigInt(0), k) else/ (k.abs '/% l.abs))"
    and (Eval) "Integer.div'_mod/ (abs _)/ (abs _)"
| constant "HOL.equal :: integer \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
    (SML) "!((_ : IntInf.int) = _)"
    and (OCaml) "Z.equal"
    and (Haskell) infix 4 "=="
    and (Scala) infixl 5 "=="
    and (Eval) infixl 6 "="
| constant "less_eq :: integer \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
    (SML) "IntInf.<= ((_), (_))"
    and (OCaml) "Z.leq"
    and (Haskell) infix 4 "<="
    and (Scala) infixl 4 "<="
    and (Eval) infixl 6 "<="
| constant "less :: integer \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
    (SML) "IntInf.< ((_), (_))"
    and (OCaml) "Z.lt"
    and (Haskell) infix 4 "<"
    and (Scala) infixl 4 "<"
    and (Eval) infixl 6 "<"
| constant "abs :: integer \<Rightarrow> _" \<rightharpoonup>
    (SML) "IntInf.abs"
    and (OCaml) "Z.abs"
    and (Haskell) "Prelude.abs"
    and (Scala) "_.abs"
    and (Eval) "abs"

code_identifier
  code_module Code_Numeral \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith

subsection \<open>Type of target language naturals\<close>

typedef natural = "UNIV :: nat set"
  morphisms nat_of_natural natural_of_nat ..

setup_lifting type_definition_natural

lemma natural_eq_iff [termination_simp]:
  "m = n \<longleftrightarrow> nat_of_natural m = nat_of_natural n"
  by transfer rule

lemma natural_eqI:
  "nat_of_natural m = nat_of_natural n \<Longrightarrow> m = n"
  using natural_eq_iff [of m n] by simp

lemma nat_of_natural_of_nat_inverse [simp]:
  "nat_of_natural (natural_of_nat n) = n"
  by transfer rule

lemma natural_of_nat_of_natural_inverse [simp]:
  "natural_of_nat (nat_of_natural n) = n"
  by transfer rule

instantiation natural :: "{comm_monoid_diff, semiring_1}"
begin

lift_definition zero_natural :: natural
  is "0 :: nat"
  .

declare zero_natural.rep_eq [simp]

lift_definition one_natural :: natural
  is "1 :: nat"
  .

declare one_natural.rep_eq [simp]

lift_definition plus_natural :: "natural \<Rightarrow> natural \<Rightarrow> natural"
  is "plus :: nat \<Rightarrow> nat \<Rightarrow> nat"
  .

declare plus_natural.rep_eq [simp]

lift_definition minus_natural :: "natural \<Rightarrow> natural \<Rightarrow> natural"
  is "minus :: nat \<Rightarrow> nat \<Rightarrow> nat"
  .

declare minus_natural.rep_eq [simp]

lift_definition times_natural :: "natural \<Rightarrow> natural \<Rightarrow> natural"
  is "times :: nat \<Rightarrow> nat \<Rightarrow> nat"
  .

declare times_natural.rep_eq [simp]

instance proof
qed (transfer, simp add: algebra_simps)+

end

instance natural :: Rings.dvd ..

context
  includes lifting_syntax
begin

lemma [transfer_rule]:
  \<open>(pcr_natural ===> pcr_natural ===> (\<longleftrightarrow>)) (dvd) (dvd)\<close>
  by (unfold dvd_def) transfer_prover

lemma [transfer_rule]:
  \<open>((\<longleftrightarrow>) ===> pcr_natural) of_bool of_bool\<close>
  by (unfold of_bool_def) transfer_prover

lemma [transfer_rule]:
  \<open>((=) ===> pcr_natural) (\<lambda>n. n) of_nat\<close>
proof -
  have "rel_fun HOL.eq pcr_natural (of_nat :: nat \<Rightarrow> nat) (of_nat :: nat \<Rightarrow> natural)"
    by (unfold of_nat_def) transfer_prover
  then show ?thesis by (simp add: id_def)
qed

lemma [transfer_rule]:
  \<open>((=) ===> pcr_natural) numeral numeral\<close>
proof -
  have \<open>((=) ===> pcr_natural) numeral (\<lambda>n. of_nat (numeral n))\<close>
    by transfer_prover
  then show ?thesis by simp
qed

lemma [transfer_rule]:
  \<open>(pcr_natural ===> (=) ===> pcr_natural) (^) (^)\<close>
  by (unfold power_def) transfer_prover

end

lemma nat_of_natural_of_nat [simp]:
  "nat_of_natural (of_nat n) = n"
  by transfer rule

lemma natural_of_nat_of_nat [simp, code_abbrev]:
  "natural_of_nat = of_nat"
  by transfer rule

lemma of_nat_of_natural [simp]:
  "of_nat (nat_of_natural n) = n"
  by transfer rule

lemma nat_of_natural_numeral [simp]:
  "nat_of_natural (numeral k) = numeral k"
  by transfer rule

instantiation natural :: "{linordered_semiring, equal}"
begin

lift_definition less_eq_natural :: "natural \<Rightarrow> natural \<Rightarrow> bool"
  is "less_eq :: nat \<Rightarrow> nat \<Rightarrow> bool"
  .

declare less_eq_natural.rep_eq [termination_simp]

lift_definition less_natural :: "natural \<Rightarrow> natural \<Rightarrow> bool"
  is "less :: nat \<Rightarrow> nat \<Rightarrow> bool"
  .

declare less_natural.rep_eq [termination_simp]

lift_definition equal_natural :: "natural \<Rightarrow> natural \<Rightarrow> bool"
  is "HOL.equal :: nat \<Rightarrow> nat \<Rightarrow> bool"
  .

instance proof
qed (transfer, simp add: algebra_simps equal less_le_not_le [symmetric] linear)+

end

context
  includes lifting_syntax
begin

lemma [transfer_rule]:
  \<open>(pcr_natural ===> pcr_natural ===> pcr_natural) min min\<close>
  by (unfold min_def) transfer_prover

lemma [transfer_rule]:
  \<open>(pcr_natural ===> pcr_natural ===> pcr_natural) max max\<close>
  by (unfold max_def) transfer_prover

end

lemma nat_of_natural_min [simp]:
  "nat_of_natural (min k l) = min (nat_of_natural k) (nat_of_natural l)"
  by transfer rule

lemma nat_of_natural_max [simp]:
  "nat_of_natural (max k l) = max (nat_of_natural k) (nat_of_natural l)"
  by transfer rule

instantiation natural :: unique_euclidean_semiring
begin

lift_definition divide_natural :: "natural \<Rightarrow> natural \<Rightarrow> natural"
  is "divide :: nat \<Rightarrow> nat \<Rightarrow> nat"
  .

declare divide_natural.rep_eq [simp]

lift_definition modulo_natural :: "natural \<Rightarrow> natural \<Rightarrow> natural"
  is "modulo :: nat \<Rightarrow> nat \<Rightarrow> nat"
  .

declare modulo_natural.rep_eq [simp]

lift_definition euclidean_size_natural :: "natural \<Rightarrow> nat"
  is "euclidean_size :: nat \<Rightarrow> nat"
  .

declare euclidean_size_natural.rep_eq [simp]

lift_definition division_segment_natural :: "natural \<Rightarrow> natural"
  is "division_segment :: nat \<Rightarrow> nat"
  .

declare division_segment_natural.rep_eq [simp]

instance
  by (standard; transfer)
    (auto simp add: algebra_simps unit_factor_nat_def gr0_conv_Suc)

end

lemma [code]:
  "euclidean_size = nat_of_natural"
  by (simp add: fun_eq_iff)

lemma [code]:
  "division_segment (n::natural) = 1"
  by (simp add: natural_eq_iff)

instance natural :: linordered_semidom
  by (standard; transfer) simp_all

instance natural :: unique_euclidean_semiring_with_nat
  by (standard; transfer) simp_all

instantiation natural :: semiring_bit_shifts
begin

lift_definition push_bit_natural :: \<open>nat \<Rightarrow> natural \<Rightarrow> natural\<close>
  is \<open>push_bit\<close> .

lift_definition drop_bit_natural :: \<open>nat \<Rightarrow> natural \<Rightarrow> natural\<close>
  is \<open>drop_bit\<close> .

instance by (standard; transfer)
  (fact bit_eq_rec bits_induct push_bit_eq_mult drop_bit_eq_div
    bits_div_0 bits_div_by_1 bits_mod_div_trivial even_succ_div_2
    exp_div_exp_eq div_exp_eq mod_exp_eq mult_exp_mod_exp_eq div_exp_mod_exp_eq
    even_mask_div_iff even_mult_exp_div_exp_iff)+

end

context
  includes lifting_syntax
begin

lemma [transfer_rule]:
  \<open>(pcr_natural ===> (=) ===> (\<longleftrightarrow>)) bit bit\<close>
  by (unfold bit_def) transfer_prover

lemma [transfer_rule]:
  \<open>((=) ===> pcr_natural ===> pcr_natural) take_bit take_bit\<close>
  by (unfold take_bit_eq_mod) transfer_prover

end

instance natural :: unique_euclidean_semiring_with_bit_shifts ..

lemma [code]:
  \<open>push_bit n m = m * 2 ^ n\<close>
  \<open>drop_bit n m = m div 2 ^ n\<close> for m :: natural
  by (fact push_bit_eq_mult drop_bit_eq_div)+

lift_definition natural_of_integer :: "integer \<Rightarrow> natural"
  is "nat :: int \<Rightarrow> nat"
  .

lift_definition integer_of_natural :: "natural \<Rightarrow> integer"
  is "of_nat :: nat \<Rightarrow> int"
  .

lemma natural_of_integer_of_natural [simp]:
  "natural_of_integer (integer_of_natural n) = n"
  by transfer simp

lemma integer_of_natural_of_integer [simp]:
  "integer_of_natural (natural_of_integer k) = max 0 k"
  by transfer auto

lemma int_of_integer_of_natural [simp]:
  "int_of_integer (integer_of_natural n) = of_nat (nat_of_natural n)"
  by transfer rule

lemma integer_of_natural_of_nat [simp]:
  "integer_of_natural (of_nat n) = of_nat n"
  by transfer rule

lemma [measure_function]:
  "is_measure nat_of_natural"
  by (rule is_measure_trivial)

subsection \<open>Inductive representation of target language naturals\<close>

lift_definition Suc :: "natural \<Rightarrow> natural"
  is Nat.Suc
  .

declare Suc.rep_eq [simp]

old_rep_datatype "0::natural" Suc
  by (transfer, fact nat.induct nat.inject nat.distinct)+

lemma natural_cases [case_names nat, cases type: natural]:
  fixes m :: natural
  assumes "\<And>n. m = of_nat n \<Longrightarrow> P"
  shows P
  using assms by transfer blast

instantiation natural :: size
begin

definition size_nat where [simp, code]: "size_nat = nat_of_natural"

instance ..

end

lemma natural_decr [termination_simp]:
  "n \<noteq> 0 \<Longrightarrow> nat_of_natural n - Nat.Suc 0 < nat_of_natural n"
  by transfer simp

lemma natural_zero_minus_one: "(0::natural) - 1 = 0"
  by (rule zero_diff)

lemma Suc_natural_minus_one: "Suc n - 1 = n"
  by transfer simp

hide_const (open) Suc

subsection \<open>Code refinement for target language naturals\<close>

lift_definition Nat :: "integer \<Rightarrow> natural"
  is nat
  .

lemma [code_post]:
  "Nat 0 = 0"
  "Nat 1 = 1"
  "Nat (numeral k) = numeral k"
  by (transfer, simp)+

lemma [code abstype]:
  "Nat (integer_of_natural n) = n"
  by transfer simp

lemma [code]:
  "natural_of_nat n = natural_of_integer (integer_of_nat n)"
  by transfer simp

lemma [code abstract]:
  "integer_of_natural (natural_of_integer k) = max 0 k"
  by simp

lemma [code_abbrev]:
  "natural_of_integer (Code_Numeral.Pos k) = numeral k"
  by transfer simp

lemma [code abstract]:
  "integer_of_natural 0 = 0"
  by transfer simp

lemma [code abstract]:
  "integer_of_natural 1 = 1"
  by transfer simp

lemma [code abstract]:
  "integer_of_natural (Code_Numeral.Suc n) = integer_of_natural n + 1"
  by transfer simp

lemma [code]:
  "nat_of_natural = nat_of_integer \<circ> integer_of_natural"
  by transfer (simp add: fun_eq_iff)

lemma [code, code_unfold]:
  "case_natural f g n = (if n = 0 then f else g (n - 1))"
  by (cases n rule: natural.exhaust) (simp_all, simp add: Suc_def)

declare natural.rec [code del]

lemma [code abstract]:
  "integer_of_natural (m + n) = integer_of_natural m + integer_of_natural n"
  by transfer simp

lemma [code abstract]:
  "integer_of_natural (m - n) = max 0 (integer_of_natural m - integer_of_natural n)"
  by transfer simp

lemma [code abstract]:
  "integer_of_natural (m * n) = integer_of_natural m * integer_of_natural n"
  by transfer simp

lemma [code abstract]:
  "integer_of_natural (m div n) = integer_of_natural m div integer_of_natural n"
  by transfer (simp add: zdiv_int)

lemma [code abstract]:
  "integer_of_natural (m mod n) = integer_of_natural m mod integer_of_natural n"
  by transfer (simp add: zmod_int)

lemma [code]:
  "HOL.equal m n \<longleftrightarrow> HOL.equal (integer_of_natural m) (integer_of_natural n)"
  by transfer (simp add: equal)

lemma [code nbe]: "HOL.equal n (n::natural) \<longleftrightarrow> True"
  by (rule equal_class.equal_refl)

lemma [code]: "m \<le> n \<longleftrightarrow> integer_of_natural m \<le> integer_of_natural n"
  by transfer simp

lemma [code]: "m < n \<longleftrightarrow> integer_of_natural m < integer_of_natural n"
  by transfer simp

hide_const (open) Nat

lifting_update integer.lifting
lifting_forget integer.lifting

lifting_update natural.lifting
lifting_forget natural.lifting

code_reflect Code_Numeral
  datatypes natural
  functions "Code_Numeral.Suc" "0 :: natural" "1 :: natural"
    "plus :: natural \<Rightarrow> _" "minus :: natural \<Rightarrow> _"
    "times :: natural \<Rightarrow> _" "divide :: natural \<Rightarrow> _"
    "modulo :: natural \<Rightarrow> _"
    integer_of_natural natural_of_integer

end


(*****************************************************************************
 * ESPL --- an embedded security protocol logic
 *          http://people.inf.ethz.ch/meiersi/espl/
 *
 *   Copyright (c) 2009-2011, Simon Meier, ETH Zurich, Switzerland
 *
 * All rights reserved. See file LICENCE for more information.
 ******************************************************************************)
theory DistinctList
imports Main
begin

chapter{* Preliminaries *}

section{* Splitting Lists *}

fun splits :: "'a list \<Rightarrow> ('a list \<times> 'a list) list"
where
  "splits [] = [([],[])]"
| "splits (x#xs) = ([],x#xs) # map (\<lambda>(pre,suf). (x#pre,suf)) (splits xs)"

lemma in_set_splits_conv:
  "((ys,zs) \<in> set (splits xs)) = (xs = ys @ zs)"
by(induct xs arbitrary: ys zs) (auto simp: Cons_eq_append_conv)

section{* Distinct Lists *}

lemma distinct_in_set_decomp:
  assumes "x \<in> set xs" and "distinct xs"
  shows "\<exists> ys zs. xs = ys@ x # zs \<and>
            x \<notin> set ys \<and> x \<notin> set zs \<and> set ys \<inter> set zs = {}"
        (is "\<exists> ys zs. ?split xs ys zs")
using assms
proof(induct xs)
  case (Cons a xs)
    hence "x = a \<or> x \<in> set xs" (is "?hd \<or> ?tl") by simp
    moreover
    { assume ?hd
      hence "?split (a#xs) [] xs" using Cons by auto
      hence ?case by fast
    }
    moreover
    { assume ?tl then
      obtain ys zs where "?split xs ys zs" using Cons by auto
      with Cons have "?split (a#xs) (a#ys) zs" by auto
      hence ?case by fast
    }
    ultimately show ?case by fast
  next
qed simp

subsection{* Direct Predecessors *}

fun "nextRel" :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "nextRel []       a b = False"
| "nextRel [x]      a b = False"
| "nextRel (x#y#xs) a b = ((a = x \<and> b = y) \<or> (nextRel (y#xs) a b))"

lemma nextRelI: "xs = ys@x#y#zs \<Longrightarrow> nextRel xs x y"
  by (induct xs x y arbitrary: ys rule: nextRel.induct)
     (auto simp: Cons_eq_append_conv)

lemma nextRelD:
  "nextRel xs x y \<Longrightarrow> (\<exists> ys zs. xs = ys@x#y#zs)"
  by (induct xs x y arbitrary: ys rule: nextRel.induct)
     (auto simp: Cons_eq_append_conv)

lemma nextRel_conv:
  "(nextRel xs x y) = (\<exists> ys zs. xs = ys@x#y#zs)"
  by(auto intro: nextRelI nextRelD)

lemma in_set_nextRel1: "nextRel xs x y \<Longrightarrow> x \<in> set xs"
  by(auto simp: nextRel_conv)

lemma in_set_nextRel2: "nextRel xs x y \<Longrightarrow> y \<in> set xs"
  by(auto simp: nextRel_conv)

lemma nextRel_rev:
  "nextRel (rev xs) x y = nextRel xs y x"
unfolding nextRel_conv
proof
  assume "\<exists>ys zs. xs = ys @ y # x # zs" then
  obtain ys zs where "xs = ys @ y # x # zs" by fast
  then have "rev xs = rev (ys @ y # x # zs)" by (rule arg_cong)
  then show "\<exists>ys zs. rev xs = ys @ x # y # zs" by auto
next
  assume "\<exists>ys zs. rev xs = ys @ x # y # zs" then
  obtain ys zs where "rev xs = ys @ x # y # zs" by fast
  then have "rev (rev xs) = rev (ys @ x # y # zs)" by (rule arg_cong)
  then show "\<exists>ys zs. xs = ys @ y # x # zs" by auto
qed

text{* Specialized instances of @{text "nextRel_rev"} for Snoc appends *}
lemma nextRel_Snoc_simps:
  "nextRel (xs@[a])   x y = nextRel (a#rev xs)   y x"
  "nextRel (xs@[a,b]) x y = nextRel (b#a#rev xs) y x"
  by(subst nextRel_rev[symmetric], simp)+

lemma nextRel_Cons_simps:
  "x \<noteq> y \<Longrightarrow> nextRel (x#xs) y z = nextRel xs y z"
  "x' \<noteq> z \<Longrightarrow> nextRel (x#x'#xs) y z = nextRel (x'#xs) y z"
  by (cases xs) simp+

lemmas nextRel_simps [simp] =
  nextRel_rev nextRel_Snoc_simps nextRel_Cons_simps

lemma nextRelI_direct [simp,intro!]: "nextRel (xs@x#y#ys) x y"
  by(auto simp: nextRel_conv)

lemma nextRel_appendI1:
  "nextRel xs x y \<Longrightarrow> nextRel (xs@ys) x y"
  by(induct xs x y rule: nextRel.induct) auto

subsection{* Predecessors *}

fun listOrd :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "listOrd []     a b = False"
| "listOrd (x#xs) a b = ((a = x \<and> b \<in> set xs) \<or> listOrd xs a b)"

lemma in_set_listOrd1: "listOrd xs x y \<Longrightarrow> x \<in> set xs"
  by(induct xs, auto)

lemma in_set_listOrd2: "listOrd xs x y \<Longrightarrow> y \<in> set xs"
  by(induct xs, auto)

lemma listOrd_append [simp]:
  "listOrd (xs@ys) a b =
   (listOrd xs a b \<or> listOrd ys a b \<or> (a \<in> set xs \<and> b \<in> set ys))"
  by(induct xs, auto)

lemma listOrd_rev [simp]: "listOrd (rev xs) x y = listOrd xs y x"
  by(induct xs, auto)

lemma nextRel_imp_listOrd: "nextRel xs x y \<Longrightarrow> listOrd xs x y"
  by(induct xs x y rule: nextRel.induct) auto

lemma listOrd_filter: "listOrd (filter p xs) x y \<Longrightarrow> listOrd xs x y"
  by(induct xs) (auto split: if_splits)

lemma listOrd_takeWhile: "listOrd (takeWhile p xs) x y \<Longrightarrow> listOrd xs x y"
proof(induct xs)
case Nil
  thus ?case by auto
next
case (Cons a xs)
  thus ?case by(auto split: if_splits dest: set_takeWhileD)
qed

lemma list_Ord_singleton[simp]: "listOrd [a] x y \<Longrightarrow> False"
  by auto

lemma listOrd_distinct_irr [simp]: "distinct xs \<Longrightarrow> \<not>listOrd xs x x"
  by(induct xs, auto)

lemma listOrd_distinct_trans:
  "\<lbrakk> listOrd xs x y; listOrd xs y z; distinct xs \<rbrakk>
   \<Longrightarrow> listOrd xs x z"
  by (induct xs) (auto dest: in_set_listOrd1 in_set_listOrd2)

lemma listOrd_distinct_asymD:
  "\<lbrakk> listOrd xs x y; distinct xs \<rbrakk> \<Longrightarrow> \<not> listOrd xs y x"
  by (induct xs) (auto dest: in_set_listOrd1 in_set_listOrd2)

lemma listOrd_distinct_cases:
  "\<lbrakk> x \<in> set xs; y \<in> set xs; distinct xs \<rbrakk>
   \<Longrightarrow> x = y \<or> listOrd xs x y \<or> listOrd xs y x"
  by(induct xs, auto)

definition listEqOrd :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
  where "listEqOrd xs x y \<equiv> (x = y) \<or> listOrd xs x y"

subsection{* List Order *}

locale distinct_list =
  fixes   xs :: "'a list"
  assumes distinct [simp,intro!]: "distinct xs"
begin
  abbreviation "next" (infixl "\<prec>\<^sub>1" 50) where "next \<equiv> nextRel xs"
  abbreviation pred (infixl "\<prec>" 50) where "pred \<equiv> listOrd xs"
  abbreviation predEq (infixl "\<preceq>" 50) where "predEq \<equiv> listEqOrd xs"
end

text{* Aquiring the order properties *}

sublocale distinct_list \<subseteq> order "predEq" "pred"
  by unfold_locales
     (auto simp: listEqOrd_def
           dest: listOrd_distinct_asymD
          intro: listOrd_distinct_trans)

text{* Relating @{term next} to the order *}

context distinct_list begin

lemma next_imp_less: "x \<prec>\<^sub>1 y \<Longrightarrow> x \<prec> y"
  by(auto simp: listEqOrd_def
         dest!: nextRel_imp_listOrd)

lemma next_imp_le: "x \<prec>\<^sub>1 y \<Longrightarrow> x \<preceq> y"
  by(auto dest: next_imp_less)

lemma in_set_less1: "x \<prec> y \<Longrightarrow> x \<in> set xs"
  by(simp add: in_set_listOrd1)

lemma in_set_less2: "x \<prec> y \<Longrightarrow> y \<in> set xs"
  by(simp add: in_set_listOrd2)

lemmas in_set_next1 = in_set_less1[OF next_imp_less, rule_format]
lemmas in_set_next2 = in_set_less2[OF next_imp_less, rule_format]

end

end