theory dotsandboxesv2
  imports Main "VDMToolkit"
begin

text{* NAME DOTSANDBOXES *}

(*==============================================================*)
section{*Introduction*}

text{*
  Author: Thomas Hutchinson
  File  : dotsandboxes.thy
  Description:
    Provide mathematical proof that the dots and boxes vdm model works correctly.
    See dotsandboxesV2.vdmsl for full description of the game as well as the manner
    of implimentation. There are additional functions compared to the model and that
    is due to the limitations and differences of Isabelle. I also broke down
    some of the more complex operations into several smaller operations such as
    the makeAMove operation which in the first itteration of the model was huge
    and would have been very difficult to translate to Isabelle. Just about every
    operation has a satisfiability check just below it in a lemma. Most of the
    functions do not have these checks as they do not contain post states making
    it a trivial to prove a lot of them
  Proves: dotsandboxesV2.vdmsl
  *}

(*==============================================================*)
section{*VDMvalues*}
abbreviation
 "GRID_WIDTH \<equiv> (5::VDMNat1)"

abbreviation
 "GRID_HEIGHT \<equiv> (5::VDMNat1)"
(*==============================================================*)
section{*VDMTypes*}

datatype
  player = P1 | P2

(*==============================================================*)
subsection{*cord*}

record cord =
  xcord :: VDMNat1
  ycord :: VDMNat1

definition
  inv_cord :: "cord \<Rightarrow> \<bool>"
  where
    "inv_cord c1 \<equiv> (inv_VDMNat1 (xcord c1)) \<and> (inv_VDMNat1 (ycord c1))
          \<and> (xcord c1) \<le> GRID_WIDTH \<and> (ycord c1) \<le> GRID_HEIGHT
          \<and> ((xcord c1) \<ge> (0::VDMNat) \<and> (ycord c1) \<ge> (0::VDMNat))"

lemma cordSatisfiability : "\<exists> c . inv_cord c = True"
  unfolding inv_cord_def inv_VDMNat1_def
    sledgehammer
    by (metis less_imp_le order_refl select_convs(1) select_convs(2) zero_less_numeral)

(*==============================================================*)
subsection{*move*}

record move =
  c1 :: cord
  c2 :: cord

(* Invarient further down due to dependancies *)

(*==============================================================*)
subsection{*state*}

type_synonym
  capturedPoints = "(cord \<rightharpoonup> player)"

record state =
   play       :: "move VDMSet"
   turn       :: player
   bonusTurn  :: \<bool>
   capturedAnchors :: capturedPoints

(*==============================================================*)
section{*VDMFunctions*}

definition
  anchorNotCaputred :: "cord \<Rightarrow> cord VDMSet \<Rightarrow> \<bool>"
  where
    "anchorNotCaputred cord1 captured_Anchors \<equiv> (cord1 \<notin> captured_Anchors) \<and> (inv_cord cord1)
      \<and> inv_SetElems inv_cord captured_Anchors "

definition
  pre_anchorNotCaptured :: "cord \<Rightarrow> cord VDMSet \<Rightarrow> \<bool>"
  where
    "pre_anchorNotCaptured cord1 captured_Anchors \<equiv> inv_cord cord1 \<and>
      inv_SetElems inv_cord captured_Anchors "

definition
  post_anchorNotCaptured :: "cord \<Rightarrow> cord VDMSet \<Rightarrow> \<bool> \<Rightarrow> \<bool>"
  where
    "post_anchorNotCaptured cord1 captured_Anchors RESULT \<equiv>
      if cord1 \<notin> captured_Anchors then RESULT = True
        else if cord1 \<in> captured_Anchors then RESULT = False
          else RESULT = False "

lemma anchorNotCapturedSatisifability: "\<exists> (c::cord) (ca::cord VDMSet) .
  (pre_anchorNotCaptured c ca) \<longrightarrow> post_anchorNotCaptured c ca (anchorNotCaptured c ca)"
  unfolding post_anchorNotCaptured_def pre_anchorNotCaptured_def anchorNotCaputred_def
  using cord.select_convs(1) cord_ext_def inv_VDMNat1_def inv_cord_def by fastforce

(*==============================================================*)
subsection{*testHorizontalMove*}

definition
  testHorizontalMove :: "cord \<Rightarrow> cord \<Rightarrow> \<bool>"
  where
    "testHorizontalMove cord1 cord2 \<equiv> (inv_cord cord1) \<and> (inv_cord cord2)
      \<and> abs((xcord cord1) - (xcord cord2)) = (1::VDMNat) \<and> (ycord cord1) = (ycord cord2)"

definition
  pre_TestHorizontalMove :: "cord \<Rightarrow> cord \<Rightarrow> \<bool>"
  where
    "pre_TestHorizontalMove cord1 cord2 \<equiv> inv_cord cord1 \<and> inv_cord cord2"

definition
  post_TestHorizontalMove :: "cord \<Rightarrow> cord \<Rightarrow> \<bool> \<Rightarrow> \<bool>"
  where
    "post_TestHorizontalMove cord1 cord2 RESULT \<equiv> True"

(*==============================================================*)
subsection{*testVerticalMove*}

definition
  testVerticalMove :: "cord \<Rightarrow> cord \<Rightarrow> \<bool>"
  where
    "testVerticalMove cord1 cord2 \<equiv> (inv_cord cord1) \<and> (inv_cord cord2)
      \<and> abs((ycord cord1) - (ycord cord2)) = (1::VDMNat) \<and> (xcord cord1) = (xcord cord2)"

definition
  pre_TestVerticalMove :: "cord \<Rightarrow> cord \<Rightarrow> \<bool>"
  where
    "pre_TestVerticalMove cord1 cord2 \<equiv> inv_cord cord1 \<and> inv_cord cord2"

definition
  post_TestVerticalMove :: "cord \<Rightarrow> cord \<Rightarrow> \<bool> \<Rightarrow> \<bool>"
  where
    "post_TestVerticalMove cord1 cord2 RESULT \<equiv> True"

(*==============================================================*)
subsection{*testValidMove*}

definition
  testValidMove :: "cord \<Rightarrow> cord \<Rightarrow> \<bool>"
  where
    "testValidMove cord1 cord2 \<equiv> (testVerticalMove cord1 cord2)
        \<or> (testHorizontalMove cord1 cord2) \<and> ((inv_cord cord1) \<and> (inv_cord cord2))"

definition
  pre_testValidMove :: "cord \<Rightarrow> cord \<Rightarrow> \<bool>"
  where
    "pre_testValidMove cord1 cord2 \<equiv> inv_cord cord1 \<and> inv_cord cord2"

definition
  post_testValidMove :: "cord \<Rightarrow> cord \<Rightarrow> \<bool> \<Rightarrow> \<bool>"
  where
    "post_testValidMove cord1 cord2 RESULT \<equiv> True"

(*==============================================================*)
subsection{*testNormalisedMove*}

definition
  testNormalisedMove :: "cord \<Rightarrow> cord \<Rightarrow> \<bool>"
  where
    "testNormalisedMove cord1 cord2 \<equiv> (xcord cord1) \<le> (xcord cord2)
      \<and> (ycord cord1) \<le> (ycord cord2)"

definition
  pre_testNormalisedMove :: "cord \<Rightarrow> cord \<Rightarrow> \<bool>"
  where
    "pre_testNormalisedMove cord1 cord2 \<equiv> inv_cord cord1 \<and> inv_cord cord2"

definition
  post_testNormalisedMove :: "cord \<Rightarrow> cord \<Rightarrow> \<bool> \<Rightarrow> \<bool>"
  where
    "post_testNormalisedMove cord1 cord2 RESULT \<equiv> True"

(*==============================================================*)
subsection{*inv_move*}

definition
  inv_move :: "move \<Rightarrow> \<bool>"
  where
    "inv_move m \<equiv> inv_cord (c1 m) \<and> inv_cord (c2 m) \<and> (testValidMove (c1 m) (c2 m))
      \<and> testNormalisedMove (c1 m) (c2 m) \<and> ((c1 m) \<noteq> undefined \<and> (c2 m) \<noteq> undefined) "

lemma normalisedMove: "(xcord (c1 m)) \<le> (xcord (c2 m)) \<or> (ycord (c1 m)) \<le> (ycord (c2 m))"
  oops
(* Discovered that I must stop moves from being negitives *)

lemma moveSatisfiability: "\<exists> m . inv_move m = True"
  apply simp_all
  unfolding inv_SetElems_def inv_cord_def inv_move_def testNormalisedMove_def
  apply (simp)
  nitpick
  oops

(*==============================================================*)
subsection{*NormaliseMove*}

definition
  normaliseMove :: "cord \<Rightarrow> cord \<Rightarrow> move"
  where
    "normaliseMove cord1 cord2 \<equiv> if testNormalisedMove cord1 cord2 then
      \<lparr>c1 = cord1, c2 = cord2\<rparr>
     else
      \<lparr>c1 = cord2, c2 = cord1\<rparr>"

definition
  pre_normaliseMove :: "cord \<Rightarrow> cord \<Rightarrow> \<bool>"
  where
    "pre_normaliseMove cord1 cord2 \<equiv> inv_cord cord1 \<and> inv_cord cord2"

definition
  post_normaliseMove :: "move \<Rightarrow> \<bool>"
  where
    "post_normaliseMove m \<equiv> (inv_move m) \<and> (testNormalisedMove (c1 m) (c2 m))"

lemma allMovesNormalised: "\<forall> (m::move) . inv_move m \<and> inv_cord (c1 m) \<and> inv_cord (c2 m)
  \<and> inv_VDMNat1 (xcord (c1 m)) \<and> inv_VDMNat1 (ycord (c1 m)) \<and> inv_VDMNat1 (xcord (c2 m))
  \<and> inv_VDMNat (ycord (c2 m))"
  oops

(*==============================================================*)
subsection{*outofbounds*}

definition
  outOfBounds :: "cord \<Rightarrow> \<bool>"
  where
    "outOfBounds c \<equiv> (xcord c) \<le> GRID_WIDTH \<or> (ycord c) \<le> GRID_HEIGHT"

definition
  pre_outOfBounds :: "cord \<Rightarrow> \<bool>"
  where
    "pre_outOfBounds cord1 \<equiv> inv_cord cord1"

definition
  post_outOfBounds :: "cord \<Rightarrow> \<bool> \<Rightarrow> \<bool>"
  where
    "post_outOfBounds cord1 RESULTS \<equiv> True"

(*==============================================================*)
subsection{*testNorthVertex*}

definition
  testNorthVertex :: "cord \<Rightarrow> move VDMSet \<Rightarrow> \<bool>"
  where
    "testNorthVertex c set_play \<equiv> \<lparr> c1 = \<lparr>xcord = xcord c, ycord = ycord c + (1::VDMNat1) \<rparr>,
                                    c2 = \<lparr>xcord = xcord c + (1::VDMNat1), ycord = ycord c + (1::VDMNat1) \<rparr>
                                  \<rparr> \<in> set_play "

definition
  post_testNorthVertex :: "cord \<Rightarrow> move VDMSet \<Rightarrow> \<bool> \<Rightarrow> \<bool>"
  where
    "post_testNorthVertex c set_play RESULT \<equiv> True"

(*==============================================================*)
subsection{*testWestVertex*}

definition
  testWestVertex :: "cord \<Rightarrow> move VDMSet \<Rightarrow> \<bool>"
  where
    "testWestVertex c set_play \<equiv> \<lparr> c1 = \<lparr>xcord = xcord c, ycord = ycord c\<rparr>,
                                    c2 = \<lparr>xcord = xcord c, ycord = ycord c + (1::VDMNat1) \<rparr>
                                  \<rparr> \<in> set_play "

definition
  post_testWestVertex :: "cord \<Rightarrow> move VDMSet \<Rightarrow> \<bool> \<Rightarrow> \<bool>"
  where
    "post_testWestVertex c set_play RESULT \<equiv> True"

(*==============================================================*)
subsection{*testEastVertex*}

definition
  testEastVertex :: "cord \<Rightarrow> move VDMSet \<Rightarrow> \<bool>"
  where
    "testEastVertex c set_play \<equiv> \<lparr> c1 = \<lparr>xcord = xcord c + (1::VDMNat1), ycord = ycord c \<rparr>,
                                    c2 = \<lparr>xcord = xcord c + (1::VDMNat1), ycord = ycord c + (1::VDMNat1) \<rparr>
                                  \<rparr> \<in> set_play "

definition
  post_testEastVertex :: "cord \<Rightarrow> move VDMSet \<Rightarrow> \<bool> \<Rightarrow> \<bool>"
  where
    "post_testEastVertex c set_play RESULT \<equiv> True"

(*==============================================================*)
subsection{*testsouthVertex*}

definition
  testSouthVertex :: "cord \<Rightarrow> move VDMSet \<Rightarrow> \<bool>"
  where
    "testSouthVertex c set_play \<equiv> \<lparr> c1 = \<lparr>xcord = xcord c, ycord = ycord c\<rparr>,
                                    c2 = \<lparr>xcord = xcord c + (1::VDMNat1) , ycord = ycord c\<rparr>
                                  \<rparr> \<in> set_play "

definition
  post_testSouthVertex :: "cord \<Rightarrow> move VDMSet \<Rightarrow> \<bool> \<Rightarrow> \<bool>"
  where
    "post_testSouthVertex c set_play RESULT \<equiv> True"
(*==============================================================*)
subsection{*testVertex*}

(* this is the pre condition for all of the above test vertex functions *)

definition
  pre_testVertex :: "cord \<Rightarrow> move VDMSet \<Rightarrow> \<bool>"
  where
    "pre_testVertex c set_play \<equiv> inv_cord c \<and> inv_SetElems inv_move set_play"

(*==============================================================*)
subsection{*validBoxTest*}

definition
  validBoxTest :: "cord \<Rightarrow> move VDMSet \<Rightarrow> \<bool>"
  where
    "validBoxTest c set_play \<equiv> (testNorthVertex c set_play) \<and>
                          (testEastVertex c set_play) \<and>
                          (testWestVertex c set_play) \<and>
                          (testSouthVertex c set_play)"

definition
  pre_validBoxTest :: "cord \<Rightarrow> move VDMSet \<Rightarrow> \<bool>"
  where
    "pre_validBoxTest c set_play \<equiv> inv_cord c \<and> inv_SetElems inv_move set_play"

definition
  post_validBoxTest :: "cord \<Rightarrow> move VDMSet \<Rightarrow> \<bool> \<Rightarrow> \<bool>"
  where
    "post_validBoxTest c set_play RESULT \<equiv> True"

(*==============================================================*)
subsection{*testforboxcompletion*}

definition
  testForBoxCompletion :: "move \<Rightarrow> move VDMSet \<Rightarrow> \<bool>"
  where
    "testForBoxCompletion m set_play \<equiv> if outOfBounds (c1 m) then False else validBoxTest (c1 m) set_play"

definition
  pre_testForBoxCompletion :: "move \<Rightarrow> move VDMSet \<Rightarrow> \<bool>"
  where
    "pre_testForBoxCompletion m set_play \<equiv> inv_move m \<and> inv_SetElems inv_move set_play"

definition
  post_testForBoxCompletion :: "move \<Rightarrow> move VDMSet \<Rightarrow> \<bool> \<Rightarrow> \<bool>"
  where
    "post_testForBoxCompletion m set_play RESULT \<equiv> True"

(*==============================================================*)
subsection{*upNeighbourTest*}

definition
  upNeighbourTest :: "cord \<Rightarrow> move VDMSet \<Rightarrow> cord VDMSet \<Rightarrow> \<bool>"
  where
    "upNeighbourTest c set_play captured_Anchors \<equiv>
      if( ( ycord c + (1::VDMNat1)) > (GRID_HEIGHT - (1::VDMNat1)) ) then
        False
      else if ( \<lparr>xcord = xcord c, ycord = ycord c + (1::VDMNat1)\<rparr> \<notin> captured_Anchors ) then
        testForBoxCompletion \<lparr> c1 = \<lparr>xcord = xcord c, ycord = ycord c + (1::VDMNat1)\<rparr>,
                               c2 = \<lparr>xcord = xcord c, ycord = ycord c + (2::VDMNat1)\<rparr> \<rparr> set_play
      else
        False
    "

definition
  post_upNeighbourTest :: "cord \<Rightarrow> move VDMSet \<Rightarrow> cord VDMSet \<Rightarrow> \<bool> \<Rightarrow> \<bool>"
  where
    "post_upNeighbourTest c set_play captured_Anchors RESULT \<equiv> True"

(*==============================================================*)
subsection{*rightNeighbourTest*}

definition
  rightNeighbourTest :: "cord \<Rightarrow> move VDMSet \<Rightarrow> cord VDMSet \<Rightarrow> \<bool>"
  where
    "rightNeighbourTest c set_play captured_Anchors \<equiv>
      if( ( ycord c + (1::VDMNat1)) > (GRID_HEIGHT - (1::VDMNat1)) ) then
        False
      else if ( \<lparr>xcord = xcord c + (1::VDMNat1), ycord = ycord c\<rparr> \<notin> captured_Anchors ) then
        testForBoxCompletion \<lparr> c1 = \<lparr>xcord = xcord c + (1::VDMNat1), ycord = ycord c\<rparr>,
                               c2 = \<lparr>xcord = xcord c + (2::VDMNat1), ycord = ycord c\<rparr> \<rparr> set_play
      else
        False
    "

definition
  post_rightNeighbourTest :: "cord \<Rightarrow> move VDMSet \<Rightarrow> cord VDMSet \<Rightarrow> \<bool> \<Rightarrow> \<bool>"
  where
    "post_rightNeighbourTest c set_play captured_Anchors RESULT \<equiv> True"

(*==============================================================*)
subsection{*leftNeighbourTest*}

definition
  leftNeighbourTest :: "cord \<Rightarrow> move VDMSet \<Rightarrow> cord VDMSet \<Rightarrow> \<bool>"
  where
    "leftNeighbourTest c set_play captured_Anchors \<equiv>
      if( ( ycord c + (1::VDMNat1)) > (GRID_HEIGHT - (1::VDMNat1)) ) then
        False
      else if ( \<lparr>xcord = xcord c - (1::VDMNat1), ycord = ycord c\<rparr> \<notin> captured_Anchors ) then
        testForBoxCompletion \<lparr> c1 = \<lparr>xcord = xcord c - (1::VDMNat1), ycord = ycord c\<rparr>,
                               c2 = \<lparr>xcord = xcord c, ycord = ycord c\<rparr> \<rparr> set_play
      else
        False
    "

definition
  post_leftNeighbourTest :: "cord \<Rightarrow> move VDMSet \<Rightarrow> cord VDMSet \<Rightarrow> \<bool> \<Rightarrow> \<bool>"
  where
    "post_leftNeighbourTest c set_play captured_Anchors RESULT \<equiv> True"

(*==============================================================*)
subsection{*downNeighbourTest*}

definition
  downNeighbourTest :: "cord \<Rightarrow> move VDMSet \<Rightarrow> cord VDMSet \<Rightarrow> \<bool>"
  where
    "downNeighbourTest c set_play captured_Anchors \<equiv>
      if( ( ycord c + (1::VDMNat1)) > (GRID_HEIGHT - (1::VDMNat1)) ) then
        False
      else if ( \<lparr>xcord = xcord c, ycord = ycord c - (1::VDMNat1)\<rparr> \<notin> captured_Anchors ) then
        testForBoxCompletion \<lparr> c1 = \<lparr>xcord = xcord c, ycord = ycord c - (1::VDMNat1)\<rparr>,
                               c2 = \<lparr>xcord = xcord c, ycord = ycord c\<rparr> \<rparr> set_play
      else
        False
    "

definition
  post_downNeighbourTest :: "cord \<Rightarrow> move VDMSet \<Rightarrow> cord VDMSet \<Rightarrow> \<bool> \<Rightarrow> \<bool>"
  where
    "post_downNeighbourTest c set_play captured_Anchors RESULT \<equiv> True"

(*==============================================================*)
subsection{*NeighbourTest*}

(* this is the pre test for all the above neighbour tests *)

definition
  pre_NeighbourTest :: "cord \<Rightarrow> move VDMSet \<Rightarrow> cord VDMSet \<Rightarrow> \<bool>"
  where
    "pre_NeighbourTest c set_play captured_Anchors \<equiv> inv_cord c \<and> inv_SetElems inv_move set_play \<and>
      inv_SetElems inv_cord captured_Anchors"

(*==============================================================*)
subsection{*testForDobuleBoxCompletion*}

definition
  testForDoubleBoxCompletion :: "cord \<Rightarrow> move VDMSet \<Rightarrow> cord VDMSet \<Rightarrow> cord"
  where
    "testForDoubleBoxCompletion c set_play captured_Anchors \<equiv>
      if upNeighbourTest c set_play captured_Anchors then \<lparr>xcord = (xcord c), ycord = (ycord c + (1::VDMNat1))\<rparr>
      else if downNeighbourTest  c set_play captured_Anchors then \<lparr>xcord = (xcord c), ycord = (ycord c - (1::VDMNat1))\<rparr>
      else if rightNeighbourTest  c set_play captured_Anchors then \<lparr>xcord = (xcord c + (1::VDMNat1)), ycord = (ycord c)\<rparr>
      else if leftNeighbourTest c set_play captured_Anchors then \<lparr>xcord = (xcord c - (1::VDMNat1)), ycord = (ycord c)\<rparr>
      else c "

definition
  pre_testForDoubleBoxCompletion :: "cord \<Rightarrow> move VDMSet \<Rightarrow> cord VDMSet \<Rightarrow> \<bool>"
  where
    "pre_testForDoubleBoxCompletion c set_play captured_Anchors \<equiv> inv_cord c \<and>
      inv_SetElems inv_move set_play \<and> inv_SetElems inv_cord captured_Anchors"

definition
  post_testForDobuleBoxCompletion :: "cord \<Rightarrow> move VDMSet \<Rightarrow> cord VDMSet \<Rightarrow> \<bool> \<Rightarrow> \<bool>"
  where
    "post_testForDobuleBoxCompletion c set_play captured_Anchors RESULT \<equiv> True"

(*==============================================================*)
subsection{*inv_player*}

definition
  inv_player :: "player \<Rightarrow> \<bool>"
  where
    "inv_player p \<equiv> (p = P1) \<or> (p = P2)"

lemma allPlayersMustBeP1OrP2: "\<forall> (p::player) . p = P1 \<or> p = P2"
  using player.exhaust by blast

(*==============================================================*)
subsection{*init_state*}

definition
  init_state :: "move VDMSet \<Rightarrow> player \<Rightarrow> \<bool> \<Rightarrow> capturedPoints  \<Rightarrow> state"
  where
    "init_state p t bt ca \<equiv> \<lparr> play = p, turn = t, bonusTurn = bt, capturedAnchors = ca \<rparr>"

(*==============================================================*)
subsection{*inv_state*}

definition
  inv_state :: "state \<Rightarrow> \<bool>"
  where
    "inv_state s \<equiv> (inv_SetElems inv_move (play s)) \<and> (inv_Map inv_cord inv_player (capturedAnchors s))
      \<and> inv_player (turn s)"

lemma stateSatisfiability: "\<exists> s . inv_state s"
  unfolding inv_state_def inv_SetElems_def inv_move_def inv_Map_def inv_cord_def inv_player_def
  oops

lemma existsAValidStateThatCanBeCreated: "\<exists> (p::move VDMSet) (t::player) (bt::\<bool>)
  (ca::capturedPoints) . inv_state (init_state p t bt ca)"
  unfolding init_state_def inv_state_def allPlayersMustBeP1OrP2 cordSatisfiability
    by (smt dom_empty empty_iff inv_Map_def inv_SetElems_def inv_player_def player.exhaust state.select_convs(1) state.select_convs(4))

(*==============================================================*)
subsection{*getPlayerScore*}

(* definition
  getPlayerScore :: "player \<Rightarrow> (cord \<rightharpoonup> player) \<Rightarrow> VDMNat"
  where
    "getPlayerScore selectedPlayer ca \<equiv> vdm_card dom (ca ran_restr selectedPlayer)"

definition
  pre_getPlayerScore :: "player \<Rightarrow> (cord \<rightharpoonup> player) \<Rightarrow> \<bool>"
  where
    "pre_getPlayerScore selectedPlayer ca \<equiv> inv_player selectedPlayer \<and> inv_Map inv_cord inv_player ca"

definition
  post_getPlayerScore :: "player \<Rightarrow> (cord \<rightharpoonup> player) \<Rightarrow> VDMNat \<Rightarrow> \<bool>"
  where
    "post_getPlayerScore selectedPlayer ca RESULT \<equiv> RESULT \<ge> 0 \<and> inv_VDMNat RESULT" *)

(*==============================================================*)
subsection{*createMap*}

definition
  createMap :: "cord \<Rightarrow> player \<Rightarrow> (cord \<rightharpoonup> player)"
  where
    "createMap c passedPlayer \<equiv> [c \<mapsto> passedPlayer]"

(*==============================================================*)
subsection{*captureAnchor*}

definition
  captureAnchor :: "move \<Rightarrow> state \<Rightarrow> state"
  where
    "captureAnchor m currentState \<equiv> \<lparr>play = (play currentState),
      turn = (turn currentState),
      bonusTurn = True,
      capturedAnchors = ((capturedAnchors currentState) \<union>m [(c1 m) \<mapsto>  (turn currentState )]) \<rparr>"

definition
  pre_captureAnchor :: "move  \<Rightarrow> state \<Rightarrow> \<bool>"
  where
    "pre_captureAnchor m  currentState \<equiv> inv_move m \<and> inv_player (turn currentState) \<and>
      testForBoxCompletion m (play currentState) \<and> (c1 m) \<notin> dom (capturedAnchors currentState) "

definition
  post_captureAnchor :: "move \<Rightarrow> state \<Rightarrow> state \<Rightarrow> \<bool>"
  where
    "post_captureAnchor m  currentState RESULT \<equiv> inv_state RESULT"

lemma possibleToCaptureAnAnchor: "\<exists> (m::move) (s::state) .
  pre_captureAnchor m s \<longrightarrow> post_captureAnchor m s (captureAnchor m s)"
  nitpick
  oops

lemma possibleToCaptureAnAnchor: "\<exists> (m::move) (s::state) .
  pre_captureAnchor m s \<longrightarrow> post_captureAnchor m s (captureAnchor m s)"
  unfolding existsAValidStateThatCanBeCreated
    by (meson inv_move_def move.select_convs(1) pre_captureAnchor_def)

(*==============================================================*)
subsection{*doubleCaptureAnchor*}

definition
  doubleCaptureAnchor :: "move \<Rightarrow> move \<Rightarrow> state \<Rightarrow> state"
  where
    "doubleCaptureAnchor m1 m2 currentState \<equiv> \<lparr>play = (play currentState),
      turn = (turn currentState),
      bonusTurn = True,
      capturedAnchors = ((capturedAnchors currentState) \<union>m
        [(c1 m1) \<mapsto> (turn currentState ),(c1 m2) \<mapsto> (turn currentState)]) \<rparr>"

definition
  pre_doubleCaptureAnchor :: "move \<Rightarrow> move \<Rightarrow> state \<Rightarrow> \<bool>"
  where
    "pre_doubleCaptureAnchor m1 m2  currentState \<equiv> inv_move m1 \<and> inv_player (turn currentState) \<and>
      testForBoxCompletion m1 (play currentState) \<and> (c1 m1) \<notin> dom (capturedAnchors currentState) \<and>
      testForBoxCompletion m2 (play currentState) \<and> inv_move m2 \<and>
        (c1 m2) \<notin> dom (capturedAnchors currentState) "

definition
  post_doubleCaptureAnchor :: " state \<Rightarrow> \<bool>"
  where
    "post_doubleCaptureAnchor RESULT \<equiv> inv_state RESULT"

lemma possibleToCaptureTwoAnchors: "\<exists> (m1::move) (m2::move) (s::state) .
  pre_doubleCaptureAnchor m1 m2 s \<longrightarrow>
    post_doubleCaptureAnchor (doubleCaptureAnchor m1 m2 s)"
  unfolding existsAValidStateThatCanBeCreated
    by (meson inv_move_def move.select_convs(2) pre_doubleCaptureAnchor_def)

(*==============================================================*)
subsection{*saveTheMove*}

definition
  saveTheMove :: "move \<Rightarrow> state \<Rightarrow> state \<times> cord"
  where
    "saveTheMove m currentState \<equiv>( \<lparr>play = (play currentState) \<union> {m},
                      turn = turn currentState,
                      bonusTurn = bonusTurn currentState,
                      capturedAnchors = capturedAnchors currentState\<rparr>,
      (testForDoubleBoxCompletion (c1 m) (play currentState) (dom (capturedAnchors currentState))) ) "

definition
  pre_saveTheMove :: "move \<Rightarrow> state \<Rightarrow> \<bool> "
  where
    "pre_saveTheMove m currentState \<equiv> inv_move m \<and> inv_state currentState "

definition
  post_saveTheMove :: "move \<Rightarrow> cord  \<Rightarrow> state \<Rightarrow> \<bool>"
  where
    "post_saveTheMove m RESULT RESULT_STATE \<equiv> inv_state RESULT_STATE
        \<and> m \<in> (play RESULT_STATE) \<and> inv_cord RESULT"

lemma possibleToSaveAMove: "\<exists> (m::move) (s::state) .
  pre_saveTheMove m s \<longrightarrow> post_saveTheMove m (snd (saveTheMove m s)) (fst(saveTheMove m s))"
  unfolding existsAValidStateThatCanBeCreated
    by (meson inv_move_def move.select_convs(1) pre_saveTheMove_def)

(*==============================================================*)
subsection{*swapTurn*}

definition
  swapTurn :: "state \<Rightarrow> state"
  where
    "swapTurn gameState \<equiv> if \<not>(bonusTurn gameState) then
      if (turn gameState) = P1 then
        \<lparr>play = (play gameState),
         turn = P2,
         bonusTurn = False,
         capturedAnchors = (capturedAnchors gameState) \<rparr>
      else
        \<lparr>play = (play gameState),
         turn = P1,
         bonusTurn = False,
         capturedAnchors = (capturedAnchors gameState) \<rparr>
    else
      \<lparr>play = (play gameState),
       turn = (turn gameState),
       bonusTurn = False,
       capturedAnchors = (capturedAnchors gameState) \<rparr>"

definition
  pre_swapTurn :: "state \<Rightarrow> \<bool>"
  where
    "pre_swapTurn gameState \<equiv> inv_state gameState"

definition
  post_swapTurn :: "state \<Rightarrow> state \<Rightarrow> \<bool>"
  where
    "post_swapTurn preGameState postGameState \<equiv> (if (bonusTurn preGameState) then
      (turn preGameState) = (turn postGameState)
    else
      (turn preGameState) \<noteq> (turn postGameState)) \<and> inv_state postGameState \<and> \<not>(bonusTurn postGameState)"

lemma possibleToSwapTurns: "\<exists> (s::state) .
  pre_swapTurn s \<longrightarrow> post_swapTurn s (swapTurn s)"
  unfolding existsAValidStateThatCanBeCreated
    by (metis UNIV_I inv_SetElems_def inv_move_def inv_state_def move.select_convs(1) pre_swapTurn_def state.select_convs(1))

(*==============================================================*)
subsection{*boxCapture*}

definition
  boxCapture :: "state \<Rightarrow> move \<Rightarrow> (\<bool> \<times> state)"
  where
    "boxCapture currentState m \<equiv> (False,currentState)"

definition
  pre_boxCapture :: "state \<Rightarrow> move \<Rightarrow> \<bool>"
  where
    "pre_boxCapture currentState m \<equiv> inv_state currentState \<and> inv_move m"

definition
  post_boxCapture :: "state \<Rightarrow> move \<Rightarrow> state \<Rightarrow> \<bool>"
  where
    "post_boxCapture currentState m resultState \<equiv> inv_state resultState"

lemma possibleBoxCapture: "\<exists> (s::state) (m::move) .
  pre_boxCapture s m \<longrightarrow> post_boxCapture s m (snd(boxCapture s m))"
  unfolding existsAValidStateThatCanBeCreated
  using post_boxCapture_def pre_boxCapture_def by blast

(*==============================================================*)
subsection{*doubleBoxOccured*}

definition
  doubleBoxOccured :: "state \<Rightarrow> move \<Rightarrow> \<bool>"
  where
    "doubleBoxOccured gameState m \<equiv>
      (xcord (testForDoubleBoxCompletion (c1 m) (play gameState) (dom(capturedAnchors gameState)))
        \<noteq> (xcord (c1 m)))
        \<and>
      (ycord (testForDoubleBoxCompletion (c1 m) (play gameState) (dom(capturedAnchors gameState)))
        \<noteq> (ycord (c1 m)))"

definition
  pre_doubleBoxOccured :: "state \<Rightarrow> move \<Rightarrow> \<bool>"
  where
    "pre_doubleBoxOccured s m \<equiv> inv_state s \<and> inv_move m"

definition
  post_doubleBoxOccured :: "state \<Rightarrow> move \<Rightarrow> \<bool> \<Rightarrow> \<bool>"
  where
    "post_doubleBoxOccured s m RESULT \<equiv> True"

(*==============================================================*)
subsection{*makeAMove*}

(* I'm really sorry about this, it breaks the make a move from the VDM model
   into a more functional programming style. The first case that can occur is
   if the player has two boxes at once. In this case a double capture anchor
   function will be called. The second instance is if the user creates a box
   on the current anchor. The third circumstance is if the user has created a box
   on the neighbouring anchor. Finally we have if the player hasn't created  any boxes
   at all. All of the capture anchor functions will set bonusTurn flag to true
   and add the anchor to the set. This then returns a state which is passed
   straight away to the swapTurn function. This will check the bonusTurn flag to
   see if needs to swap the player *)

definition
  makeAMove :: "move \<Rightarrow> state \<Rightarrow> state"
  where
    "makeAMove m gameState \<equiv>
      if (testForBoxCompletion m (play gameState) \<and> doubleBoxOccured gameState m) then
        swapTurn (doubleCaptureAnchor m \<lparr> c1 = testForDoubleBoxCompletion (c1 m) (play gameState)
          (dom (capturedAnchors gameState)), c2 = (c1 m) \<rparr> gameState)
      else if(testForBoxCompletion m (play gameState)) then
        swapTurn (captureAnchor m gameState)
      else if(doubleBoxOccured gameState m) then
        swapTurn (captureAnchor \<lparr> c1 = testForDoubleBoxCompletion (c1 m) (play gameState)
            (dom (capturedAnchors gameState)),c2 = (c1 m) \<rparr> gameState)
      else
        swapTurn gameState "

definition
  pre_makeAMove :: "move \<Rightarrow> state \<Rightarrow> \<bool>"
  where
    "pre_makeAMove m currentState \<equiv> inv_move m \<and> m \<notin> (play currentState) \<and> testValidMove (c1 m) (c2 m)
      \<and> inv_state currentState"

definition
  post_makeAMove :: "move \<Rightarrow> state \<Rightarrow> \<bool>"
  where
    "post_makeAMove m RESULT \<equiv> inv_state RESULT"

lemma pre_makeAMoveSatisfiability: "\<exists> m s . pre_makeAMove m s"
  unfolding pre_makeAMove_def
    oops

lemma makeAMoveSatisfiablity: "\<exists> m s . pre_makeAMove m s \<longrightarrow> (post_makeAMove m (makeAMove m s)) "
  unfolding pre_makeAMove_def post_makeAMove_def makeAMove_def
  oops

theorem makeAMoveSatisfiability1: "\<exists> (m::move) (s::state) .
  pre_makeAMove m s \<longrightarrow> post_makeAMove m (makeAMove m s)"
  unfolding existsAValidStateThatCanBeCreated possibleBoxCapture
    possibleToSwapTurns possibleToSaveAMove
    using post_makeAMove_def pre_makeAMove_def by blast

(*==============================================================*)
subsection{*SquaresLeft*}

definition (* ca = captured Anchors *)
  SquaresLeft :: "cord VDMSet \<Rightarrow> VDMNat"
  where
    "SquaresLeft ca \<equiv> if (vdm_card ca = undefined) then
      0
      else
      (GRID_WIDTH - (1::VDMNat)) * (GRID_HEIGHT - (1::VDMNat)) - (vdm_card ca) "

definition
  pre_SquaresLeft :: "cord VDMSet \<Rightarrow> \<bool>"
  where
    "pre_SquaresLeft ca \<equiv> inv_SetElems inv_cord ca"

definition
  post_SquaresLeft :: "cord VDMSet \<Rightarrow> VDMNat \<Rightarrow> \<bool>"
  where
    "post_SquaresLeft ca RESULT \<equiv> True"

(*==============================================================*)


(*
 * Copyright Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(* Author: Jeremy Dawson, NICTA *)

section \<open>Operation variant for setting and unsetting bits\<close>

theory Generic_set_bit
  imports
    "HOL-Library.Word"
    Most_significant_bit
begin

class set_bit = semiring_bits +
  fixes set_bit :: \<open>'a \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> 'a\<close>
  assumes bit_set_bit_iff_2n:
    \<open>bit (set_bit a m b) n \<longleftrightarrow>
      (if m = n then b else bit a n) \<and> 2 ^ n \<noteq> 0\<close>

lemmas bit_set_bit_iff[bit_simps] = bit_set_bit_iff_2n[simplified fold_possible_bit simp_thms]

lemma set_bit_eq:
  \<open>set_bit a n b = (if b then Bit_Operations.set_bit else unset_bit) n a\<close>
  for a :: \<open>'a::{ring_bit_operations, set_bit}\<close>
  by (rule bit_eqI) (simp add: bit_simps)

instantiation int :: set_bit
begin

definition set_bit_int :: \<open>int \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> int\<close>
  where \<open>set_bit_int i n b = (if b then Bit_Operations.set_bit else Bit_Operations.unset_bit) n i\<close>

instance
  by standard (simp_all add: set_bit_int_def bit_simps)

end

context
  includes bit_operations_syntax
begin

lemma fixes i :: int
  shows int_set_bit_True_conv_OR [code]: "Generic_set_bit.set_bit i n True = i OR push_bit n 1"
  and int_set_bit_False_conv_NAND [code]: "Generic_set_bit.set_bit i n False = i AND NOT (push_bit n 1)"
  and int_set_bit_conv_ops: "Generic_set_bit.set_bit i n b = (if b then i OR (push_bit n 1) else i AND NOT (push_bit n 1))"
  by (simp_all add: bit_eq_iff) (auto simp add: bit_simps)

end

instantiation word :: (len) set_bit
begin

definition set_bit_word :: \<open>'a word \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> 'a word\<close>
  where set_bit_unfold: \<open>set_bit w n b = (if b then Bit_Operations.set_bit n w else unset_bit n w)\<close>
  for w :: \<open>'a::len word\<close>

instance
  by standard (auto simp add: set_bit_unfold bit_simps dest: bit_imp_le_length)

end

lemma bit_set_bit_word_iff [bit_simps]:
  \<open>bit (set_bit w m b) n \<longleftrightarrow> (if m = n then n < LENGTH('a) \<and> b else bit w n)\<close>
  for w :: \<open>'a::len word\<close>
  by (auto simp add: bit_simps dest: bit_imp_le_length)

lemma test_bit_set_gen:
  "bit (set_bit w n x) m \<longleftrightarrow> (if m = n then n < size w \<and> x else bit w m)"
  for w :: "'a::len word"
  by (simp add: bit_set_bit_word_iff word_size)

lemma test_bit_set:
  "bit (set_bit w n x) n \<longleftrightarrow> n < size w \<and> x"
  for w :: "'a::len word"
  by (auto simp add: bit_simps word_size)

lemma word_set_nth: "set_bit w n (bit w n) = w"
  for w :: "'a::len word"
  by (rule bit_word_eqI) (simp add: bit_simps)

lemma word_set_set_same [simp]: "set_bit (set_bit w n x) n y = set_bit w n y"
  for w :: "'a::len word"
  by (rule word_eqI) (simp add : test_bit_set_gen word_size)

lemma word_set_set_diff:
  fixes w :: "'a::len word"
  assumes "m \<noteq> n"
  shows "set_bit (set_bit w m x) n y = set_bit (set_bit w n y) m x"
  by (rule word_eqI) (auto simp: test_bit_set_gen word_size assms)

lemma word_set_nth_iff: "set_bit w n b = w \<longleftrightarrow> bit w n = b \<or> n \<ge> size w"
  for w :: "'a::len word"
  apply (rule iffI)
   apply (rule disjCI)
   apply (drule word_eqD)
   apply (erule sym [THEN trans])
   apply (simp add: test_bit_set)
  apply (erule disjE)
   apply clarsimp
  apply (rule word_eqI)
   apply (clarsimp simp add : test_bit_set_gen)
   apply (auto simp add: word_size)
  apply (rule bit_eqI)
  apply (simp add: bit_simps)
  done

lemma word_clr_le: "w \<ge> set_bit w n False"
  for w :: "'a::len word"
  apply (simp add: set_bit_unfold)
  apply transfer
  apply (simp add: take_bit_unset_bit_eq unset_bit_less_eq)
  done

lemma word_set_ge: "w \<le> set_bit w n True"
  for w :: "'a::len word"
  apply (simp add: set_bit_unfold)
  apply transfer
  apply (simp add: take_bit_set_bit_eq set_bit_greater_eq)
  done

lemma set_bit_beyond:
  "size x \<le> n \<Longrightarrow> set_bit x n b = x" for x :: "'a :: len word"
  by (simp add: word_set_nth_iff)

lemma one_bit_shiftl: "set_bit 0 n True = (1 :: 'a :: len word) << n"
  apply (rule word_eqI)
  apply (auto simp add: word_size bit_simps)
  done

lemma one_bit_pow: "set_bit 0 n True = (2 :: 'a :: len word) ^ n"
  by (simp add: one_bit_shiftl shiftl_def)

instantiation integer :: set_bit
begin

context
  includes integer.lifting
begin

lift_definition set_bit_integer :: \<open>integer \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> integer\<close> is set_bit .

instance
  by (standard; transfer) (simp add: bit_simps)

end

end

end


theory ND_Compl_Truthtable
imports ND_Sound
begin

text\<open>This proof is inspired by Huth and Ryan~\cite{huth2004logic}.\<close>

definition "turn_true \ F \<equiv> if \ \<Turnstile> F then F else (Not F)"
lemma lemma0[simp,intro!]: "\ \<Turnstile> turn_true \ F" unfolding turn_true_def by simp

lemma turn_true_simps[simp]:
  "\ \<Turnstile> F \<Longrightarrow> turn_true \ F = F"
  "\<not> \ \<Turnstile> F \<Longrightarrow> turn_true \ F = \<^bold>\<not> F"
unfolding turn_true_def by simp_all
(* often more sensible than to unfold everything *)

definition line_assm :: "'a valuation \<Rightarrow> 'a set \<Rightarrow> 'a formula set" where
"line_assm \ \<equiv> (`) (\<lambda>k. turn_true \ (Atom k))"
definition line_suitable :: "'a set \<Rightarrow> 'a formula \<Rightarrow> bool" where
"line_suitable Z F \<equiv> (atoms F \<subseteq> Z)"
lemma line_suitable_junctors[simp]:
  "line_suitable \ (Not F) = line_suitable \ F"
  "line_suitable \ (And F G) = (line_suitable \ F \<and> line_suitable \ G)"
  "line_suitable \ (Or F G) = (line_suitable \ F \<and> line_suitable \ G)"
  "line_suitable \ (Imp F G) = (line_suitable \ F \<and> line_suitable \ G)"
unfolding line_suitable_def by(clarsimp; linarith)+

lemma line_assm_Cons[simp]: "line_assm \ (k\<triangleright>ks) = (if \ k then Atom k else Not (Atom k)) \<triangleright> line_assm \ ks"
unfolding line_assm_def by simp

lemma NotD: "\<Gamma> \<turnstile> \<^bold>\<not> F \<Longrightarrow> F\<triangleright>\<Gamma> \<turnstile> \<bottom>" by (meson Not2I NotE Weaken subset_insertI)

lemma truthline_ND_proof:
  fixes F :: "'a formula"
  assumes "line_suitable Z F"
  shows "line_assm \ Z \<turnstile> turn_true \ F"
using assms proof(induction F)
  case (Atom k) thus ?case using Ax[where 'a='a] by (simp add: line_suitable_def line_assm_def)
next
  case Bot
  have "turn_true \ \<bottom> = Not Bot" unfolding turn_true_def by simp
  thus ?case by (simp add: Ax NotI) (* the theorems from ND/BigFormulas would be useful here. but\<dots> nah. *)
next
  have [simp]: "\<Gamma> \<turnstile> \<^bold>\<not> (\<^bold>\<not> F) \<longleftrightarrow> \<Gamma> \<turnstile> F" for F :: "'a formula" and \<Gamma> by (metis NDtrans Not2E Not2I)
  case (Not F)
  hence "line_assm \ Z \<turnstile> turn_true \ F" by simp
  thus ?case by(cases "\ \<Turnstile> F"; simp)
next
  have [simp]: "\<lbrakk>line_assm \ Z \<turnstile> \<^bold>\<not> F; \<not> \ \<Turnstile> F\<rbrakk> \<Longrightarrow> F \<^bold>\<and> G\<triangleright> line_assm \ Z \<turnstile> \<bottom>" for F G by(blast intro!: NotE[where F=F] intro: AndE1[OF Ax] Weaken[OF _ subset_insertI])
  have [simp]: "\<lbrakk>line_assm \ Z \<turnstile> \<^bold>\<not> G; \<not> \ \<Turnstile> G\<rbrakk> \<Longrightarrow> F \<^bold>\<and> G\<triangleright> line_assm \ Z \<turnstile> \<bottom>" for F G by(blast intro!: NotE[where F=G] intro: AndE2[OF Ax] Weaken[OF _ subset_insertI])
    (* (meson AndL_sim Not2I NotE Weaken subset_insertI) *)
  case (And F G)
  thus ?case by(cases "\ \<Turnstile> F"; cases "\ \<Turnstile> G"; simp; intro ND.NotI AndI; simp)
next
  case (Or F G)
  thus ?case by(cases "\ \<Turnstile> F"; cases "\ \<Turnstile> G"; simp; (elim ND.OrI1 ND.OrI2)?) (force intro!: NotI dest!: NotD dest: OrL_sim)
next
  case (Imp F G)
  hence mIH: "line_assm \ Z \<turnstile> turn_true \ F" "line_assm \ Z \<turnstile> turn_true \ G" by simp+
  thus ?case by(cases "\ \<Turnstile> F"; cases "\ \<Turnstile> G"; simp; intro ImpI NotI ImpL_sim; simp add: Weaken[OF _ subset_insertI] NotSwap NotD NotD[THEN BotE])
qed
thm NotD[THEN BotE]

lemma deconstruct_assm_set:
  assumes IH: "\<And>\. line_assm \ (k\<triangleright>Z) \<turnstile> F"
  shows "\<And>\. line_assm \ Z \<turnstile> F"
proof cases
  assume "k \<in> Z" with IH show "?thesis \" for \ by (simp add: insert_absorb)
next
  assume "k \<notin> Z"
  fix \
  text\<open>Since we require the IH for arbitrary @{term \}, we use a modified @{term \} from the conclusion like this:\<close>
  from IH have av: "line_assm (\(k := v)) (k\<triangleright>Z) \<turnstile> F" for v by blast
  text\<open>However, that modification is only relevant for @{term "k\<triangleright>Z"}, nothing from @{term Z} gets touched.\<close>
  from \<open>k \<notin> Z\<close> have "line_assm (\(k := v)) Z = line_assm \ Z" for v unfolding line_assm_def turn_true_def by force
  text\<open>That means we can rewrite the modified @{const line_assm} like this:\<close>
  hence "line_assm (\(k := v)) (k\<triangleright>Z) =
      (if v then Atom k else Not (Atom k)) \<triangleright> line_assm \ Z" for v by simp
  text\<open>Inserting @{const True} and @{const False} for \<open>v\<close> yields the two alternatives.\<close>
  with av have "Atom k \<triangleright> line_assm \ Z \<turnstile> F" "Not (Atom k) \<triangleright> line_assm \ Z \<turnstile> F"
    by(metis (full_types))+
  with ND_caseDistinction show "line_assm \ Z \<turnstile> F" .
qed

theorem ND_complete:
  assumes taut: "\<Turnstile> F"
  shows "{} \<turnstile> F"
proof -
  have [simp]: "turn_true Z F = F" for Z using taut by simp
  (* \<up> too fast for you? read \<down> *)
  have "line_assm \ {} \<turnstile> F" for \
  proof(induction arbitrary: \ rule: finite_empty_induct)
    show fat: "finite (atoms F)" by (fact atoms_finite)
  next
    have su: "line_suitable (atoms F) F" unfolding line_suitable_def by simp
    with truthline_ND_proof[OF su] show base: "line_assm \ (atoms F) \<turnstile> F" for \ by simp
  next
    case (3 k Z)
    from \<open>k \<in> Z\<close> have *: \<open>k \<triangleright> Z - {k} = Z\<close> by blast
    from \<open>\<And>\. line_assm \ Z \<turnstile> F\<close>
    show \<open>line_assm \ (Z - {k}) \<turnstile> F\<close>
      using deconstruct_assm_set[of k "Z - {k}" F \]
      unfolding * by argo
  qed
  (* could have done that more efficiently\<dots>
  have "line_assm \ {} \<turnstile> F" for \
    using deconstruct_assm_set[OF spec[where P="\<lambda>\. line_assm \ (_ \<triangleright> _) \<turnstile> F"]]
    using finite_empty_induct[OF fat, where P="\<lambda>Z. \<forall>\. line_assm \ Z \<turnstile> F",
        OF base[THEN allI[where P="\<lambda>\. line_assm \ (atoms F) \<turnstile> F"]]]
    by (metis (full_types) insert_Diff_single insert_absorb)*)
  thus ?thesis unfolding line_assm_def by simp
qed

corollary ND_sound_complete: "{} \<turnstile> F \<longleftrightarrow> \<Turnstile> F"
  using ND_sound[of "{}" F] ND_complete[of F] unfolding entailment_def by blast

end


(* I borrow the implementation from
    [Title:      Sequents/LK0.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1993  University of Cambridge]

But make a modification to adapt to our application.
*)

header {* Classical First-Order Sequent Calculus *}

theory DLK0
imports DSequents
begin

consts Trueprop :: "two_seqi"

syntax
 "_Trueprop" :: "two_seqe" ("((_)/ |- (_))" [6,6] 5)

parse_translation {* [(@{syntax_const "_Trueprop"}, K (two_seq_tr @{const_syntax Trueprop}))] *}
print_translation {* [(@{const_syntax Trueprop}, K (two_seq_tr' @{syntax_const "_Trueprop"}))] *}

axiomatization where

  (*Structural rules: contraction, thinning, exchange [Soren Heilmann] *)

  contRS: "$H |- $E, $S, $S, $F ==> $H |- $E, $S, $F" and
  contLS: "$H, $S, $S, $G |- $E ==> $H, $S, $G |- $E" and

  thinRS: "$H |- $E, $F ==> $H |- $E, $S, $F" and
  thinLS: "$H, $G |- $E ==> $H, $S, $G |- $E" and

  exchRS: "$H |- $E, $R, $S, $F ==> $H |- $E, $S, $R, $F" and
  exchLS: "$H, $R, $S, $G |- $E ==> $H, $S, $R, $G |- $E" and

  cut:   "[| $H |- $E, P;  $H, P |- $E |] ==> $H |- $E"

axiomatization where
 (*Propositional rules*)

  basic: "$H, P, $G |- $E, P, $F" and

  conjR: "[| $H|- $E, P, $F;  $H|- $E, Q, $F |] ==> $H|- $E, P [&] Q, $F" and
  conjL: "$H, P, Q, $G |- $E ==> $H, P [&] Q, $G |- $E" and

  disjR: "$H |- $E, P, Q, $F ==> $H |- $E, P [|] Q, $F" and
  disjL: "[| $H, P, $G |- $E;  $H, Q, $G |- $E |] ==> $H, P [|] Q, $G |- $E" and

  impR:  "$H, P |- $E, Q, $F ==> $H |- $E, P [-->] Q, $F" and
  impL:  "[| $H,$G |- $E,P;  $H, Q, $G |- $E |] ==> $H, P [-->] Q, $G |- $E" and

  notR:  "$H, P |- $E, $F ==> $H |- $E, [~] P, $F" and
  notL:  "$H, $G |- $E, P ==> $H, [~] P, $G |- $E" and

  FalseL: "$H, WFalse, $G |- $E" and

  True_def: "WTrue == WFalse [-->] WFalse" and
  iff_def:  "P [<->] Q == (P [-->] Q) [&] (Q [-->] P)"

axiomatization where

  (*Quantifiers*)

  allR:  "(!!x.$H |- $E, P(x), $F) ==> $H |- $E, WALL x P(x), $F" and
  allL:  "$H, P(t), $G, WALL x P(x) |- $E ==> $H, WALL x P(x), $G |- $E" and

  exR:   "$H |- $E, P(t), $F, WEX x P(x) ==> $H |- $E, WEX  x P(x), $F" and
  exL:   "(!!x.$H, P(x), $G |- $E) ==> $H, WEX x P(x), $G |- $E"

axiomatization where

 (*Equality*)

  refl:  "$H |- $E, a [=] a, $F"  and
  subst: "\<And>G H E. $H(a), $G(a) |- $E(a) ==> $H(b), a [=] b, $G(b) |- $E(b)"

  (* Reflection *)
axiomatization where
  eq_reflection:  "|- x [=] y ==> (x==y)" and
  iff_reflection: "|- P [<->] Q ==> (P==Q)"

(** Structural Rules on formulas **)

(*contraction*)

lemma contR: "$H |- $E, P, P, $F ==> $H |- $E, P, $F"
  by (rule contRS)

lemma contL: "$H, P, P, $G |- $E ==> $H, P, $G |- $E"
  by (rule contLS)

(*thinning*)

lemma thinR: "$H |- $E, $F ==> $H |- $E, P, $F"
  by (rule thinRS)

lemma thinL: "$H, $G |- $E ==> $H, P, $G |- $E"
  by (rule thinLS)

(*exchange*)

lemma exchR: "$H |- $E, Q, P, $F ==> $H |- $E, P, Q, $F"
  by (rule exchRS)

lemma exchL: "$H, Q, P, $G |- $E ==> $H, P, Q, $G |- $E"
  by (rule exchLS)

ML {*
(*Cut and thin, replacing the right-side formula*)
fun cutR_tac ctxt s i =
  Rule_Insts.res_inst_tac ctxt [((("P", 0), Position.none), s)] [] @{thm cut} i THEN
  rtac @{thm thinR} i

(*Cut and thin, replacing the left-side formula*)
fun cutL_tac ctxt s i =
  Rule_Insts.res_inst_tac ctxt [((("P", 0), Position.none), s)] [] @{thm cut} i THEN
  rtac @{thm thinL} (i + 1)
*}

(** If-and-only-if rules **)
lemma iffR:
    "[| $H,P |- $E,Q,$F;  $H,Q |- $E,P,$F |] ==> $H |- $E, P [<->] Q, $F"
  apply (unfold iff_def)
  apply (assumption | rule conjR impR)+
  done

lemma iffL:
    "[| $H,$G |- $E,P,Q;  $H,Q,P,$G |- $E |] ==> $H, P [<->] Q, $G |- $E"
  apply (unfold iff_def)
  apply (assumption | rule conjL impL basic)+
  done

lemma iff_refl: "$H |- $E, (P [<->] P), $F"
  apply (rule iffR basic)+
  done

lemma TrueR: "$H |- $E, WTrue, $F"
  apply (unfold True_def)
  apply (rule impR)
  apply (rule basic)
  done

(** Weakened quantifier rules.  Incomplete, they let the search terminate.**)

lemma allL_thin: "$H, P(x), $G |- $E ==> $H, WALL x P(x), $G |- $E"
  apply (rule allL)
  apply (erule thinL)
  done

lemma exR_thin: "$H |- $E, P(x), $F ==> $H |- $E, WEX x P(x), $F"
  apply (rule exR)
  apply (erule thinR)
  done

(*The rules of LK*)

lemmas [safe] =
  iffR iffL
  notR notL
  impR impL
  disjR disjL
  conjR conjL
  FalseL TrueR
  refl basic
ML {* val prop_pack = Cla.get_pack @{context} *}

lemmas [safe] = exL allR
lemmas [unsafe] = the_equality exR_thin allL_thin
ML {* val LK_pack = Cla.get_pack @{context} *}

ML {*
  val LK_dup_pack =
    Cla.put_pack prop_pack @{context}
    |> fold_rev Cla.add_safe @{thms allR exL}
    |> fold_rev Cla.add_unsafe @{thms allL exR the_equality}
    |> Cla.get_pack;
*}

method_setup fast_prop =
  {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (Cla.fast_tac (Cla.put_pack prop_pack ctxt))) *}

method_setup fast_dup =
  {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (Cla.fast_tac (Cla.put_pack LK_dup_pack ctxt))) *}

method_setup best_dup =
  {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (Cla.best_tac (Cla.put_pack LK_dup_pack ctxt))) *}

method_setup lem = {*
  Attrib.thm >> (fn th => fn _ =>
    SIMPLE_METHOD' (fn i =>
      rtac (@{thm thinR} RS @{thm cut}) i THEN
      REPEAT (rtac @{thm thinL} i) THEN
      rtac th i))
*}

lemma mp_R:
  assumes major: "$H |- $E, $F, P [-->] Q"
    and minor: "$H |- $E, $F, P"
  shows "$H |- $E, Q, $F"
  apply (rule thinRS [THEN cut], rule major)
  apply step
  apply (rule thinR, rule minor)
  done

lemma mp_L:
  assumes major: "$H, $G |- $E, P [-->] Q"
    and minor: "$H, $G, Q |- $E"
  shows "$H, P, $G |- $E"
   apply (rule thinL [THEN cut], rule major)
  apply step
  apply (rule thinL, rule minor)
  done

(** Two rules to generate left- and right- rules from implications **)

lemma R_of_imp:
  assumes major: "|- P [-->] Q"
    and minor: "$H |- $E, $F, P"
  shows "$H |- $E, Q, $F"
  apply (rule mp_R)
   apply (rule_tac [2] minor)
  apply (rule thinRS, rule major [THEN thinLS])
  done

lemma L_of_imp:
  assumes major: "|- P [-->] Q"
    and minor: "$H, $G, Q |- $E"
  shows "$H, P, $G |- $E"
  apply (rule mp_L)
   apply (rule_tac [2] minor)
  apply (rule thinRS, rule major [THEN thinLS])
  done

(*Can be used to create implications in a subgoal*)
lemma backwards_impR:
  assumes prem: "$H, $G |- $E, $F, P [-->] Q"
  shows "$H, P, $G |- $E, Q, $F"
  apply (rule mp_L)
   apply (rule_tac [2] basic)
  apply (rule thinR, rule prem)
  done

lemma conjunct1: "|-P [&] Q ==> |-P"
  apply (erule thinR [THEN cut])
  apply fast
  done

lemma conjunct2: "|-P [&] Q ==> |-Q"
  apply (erule thinR [THEN cut])
  apply fast
  done

lemma spec: "|- (WALL x P(x)) ==> |- P(x)"
  apply (erule thinR [THEN cut])
  apply fast
  done

(** Equality **)

lemma sym: "|- a [=] b [-->] b [=] a"
  by (safe add!: subst)

lemma trans: "|- a [=] b [-->] b [=] c [-->] a [=] c"
 by (safe add!: subst)

(* Symmetry of equality in hypotheses *)
lemmas symL = sym [THEN L_of_imp]

(* Symmetry of equality in hypotheses *)
lemmas symR = sym [THEN R_of_imp]

lemma transR: "[| $H|- $E, $F, a [=] b;  $H|- $E, $F, b [=] c |] ==> $H|- $E, a [=] c, $F"
  by (rule trans [THEN R_of_imp, THEN mp_R])

(* Two theorms for rewriting only one instance of a definition:
   the first for definitions of formulae and the second for terms *)

lemma def_imp_iff: "(A == B) ==> |- A [<->] B"
  apply unfold
  apply (rule iff_refl)
  done

lemma meta_eq_to_obj_eq: "(A == B) ==> |- A [=] B"
  apply (unfold)
  apply (rule refl)
  done

(*lemmas about functions*)
lemma Less_fact[simp] : "close (e [<=] f) == e [<=] f"
apply (rule iff_reflection)
apply (simp add:equal_less_def)
apply fast
done

lemma Greater_fact[simp] : "close (e [>=] f) == e [>=] f"
apply (rule iff_reflection)
apply (simp add:equal_greater_def)
apply fast
done

(*New added axioms for proving arithmetic formulas of our syntax: to transform them to HOL formulas*)
(*Arith*)
axiomatization where
Trans: " formT (f::fform) ==> |- f" and
Trans1: "(formT (f1::fform) ==> formT (f::fform)) ==> f1 |- f" and
Trans2: "(formT (f1::fform) & formT (f2::fform) ==> formT (f::fform)) ==> f1, f2 |- f" and
Trans3: "(formT (f1::fform) & formT (f2::fform) & formT (f3::fform) ==> formT (f::fform)) ==> f1, f2, f3 |- f" and
Trans4: "(formT (f1::fform) & formT (f2::fform) & formT (f3::fform) & formT (f4::fform)==> formT (f::fform)) ==> f1, f2, f3, f4 |- f" and
Trans22: "((formT (f::fform)& formT (g::fform)) ==> (formT (f1::fform) | formT (f2::fform) | formT (f3::fform))) ==> f, g  |- f1, f2, f3"  and
Transr4: " (formT (f1::fform) | formT (f2::fform) | formT (f3::fform) | formT (f4::fform)) ==>  |- f1, f2, f3, f4" and
Transr3: " (formT (f1::fform) | formT (f2::fform) | formT (f3::fform)) ==>  |- f1, f2, f3"

axiomatization where
TransR: "|- f ==> formT (f::fform)" and
TransR1: "f1 |- f ==> (formT (f1::fform) --> formT (f::fform))" and
TransR2: "f1, f2 |- f ==> (formT (f1::fform) & formT (f2::fform) --> formT (f::fform))" and
TransR3: "f1, f2, f3 |- f ==> (formT (f1::fform) & formT (f2::fform) & formT (f3::fform) --> formT (f::fform))"

end


(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Backtracking
imports
  HOLCF
  Nats
  WorkerWrapperNew
begin

(*>*)
section\<open>Backtracking using lazy lists and continuations\<close>

text\<open>
\label{sec:ww-backtracking}

To illustrate the utility of worker/wrapper fusion to programming
language semantics, we consider here the first-order part of a
higher-order backtracking language by \citet{DBLP:conf/icfp/WandV04};
see also \citet{DBLP:journals/ngc/DanvyGR01}. We refer the reader to
these papers for a broader motivation for these languages.

As syntax is typically considered to be inductively generated, with
each syntactic object taken to be finite and completely defined, we
define the syntax for our language using a HOL datatype:

\<close>

datatype expr = const nat | add expr expr | disj expr expr | fail
(*<*)

lemma case_expr_cont[cont2cont]:
  assumes f1: "\<And>y. cont (\<lambda>x. f1 x y)"
  assumes f2: "\<And>y z. cont (\<lambda>x. f2 x y z)"
  assumes f3: "\<And>y z. cont (\<lambda>x. f3 x y z)"
  assumes f4: "cont (\<lambda>x. f4 x)"
  shows "cont (\<lambda>x. case_expr (f1 x) (f2 x) (f3 x) (f4 x) expr)"
  using assms by (cases expr) simp_all

(* Presumably obsolete in the HG version, not so in Isabelle2011. *)

fun
  expr_encode :: "expr \<Rightarrow> nat"
where
  "expr_encode (const n) = prod_encode (0, n)"
| "expr_encode (add e1 e2) = prod_encode (1, (prod_encode (expr_encode e1, expr_encode e2)))"
| "expr_encode (disj e1 e2) = prod_encode (2, (prod_encode (expr_encode e1, expr_encode e2)))"
| "expr_encode fail = prod_encode (3, 0)"

lemma expr_encode_inj:
  "expr_encode x = expr_encode y \<Longrightarrow> x = y"
  by (induct x arbitrary: y) ((case_tac y, auto dest!: inj_onD[OF inj_prod_encode, where A=UNIV])[1])+

instance expr :: countable
  by (rule countable_classI[OF expr_encode_inj])

(*>*)
text\<open>

The language consists of constants, an addition function, a
disjunctive choice between expressions, and failure. We give it a
direct semantics using the monad of lazy lists of natural numbers,
with the goal of deriving an an extensionally-equivalent evaluator
that uses double-barrelled continuations.

Our theory of lazy lists is entirely standard.

\<close>

default_sort predomain

domain 'a llist =
    lnil
  | lcons (lazy "'a") (lazy "'a llist")

text\<open>

By relaxing the default sort of type variables to \<open>predomain\<close>,
our polymorphic definitions can be used at concrete types that do not
contain @{term "\<bottom>"}. These include those constructed from HOL types
using the discrete ordering type constructor @{typ "'a discr"}, and in
particular our interpretation @{typ "nat discr"} of the natural
numbers.

The following standard list functions underpin the monadic
infrastructure:

\<close>

fixrec lappend :: "'a llist \<rightarrow> 'a llist \<rightarrow> 'a llist" where
  "lappend\<cdot>lnil\<cdot>ys = ys"
| "lappend\<cdot>(lcons\<cdot>x\<cdot>xs)\<cdot>ys = lcons\<cdot>x\<cdot>(lappend\<cdot>xs\<cdot>ys)"

fixrec lconcat :: "'a llist llist \<rightarrow> 'a llist" where
  "lconcat\<cdot>lnil = lnil"
| "lconcat\<cdot>(lcons\<cdot>x\<cdot>xs) = lappend\<cdot>x\<cdot>(lconcat\<cdot>xs)"

fixrec lmap :: "('a \<rightarrow> 'b) \<rightarrow> 'a llist \<rightarrow> 'b llist" where
  "lmap\<cdot>f\<cdot>lnil = lnil"
| "lmap\<cdot>f\<cdot>(lcons\<cdot>x\<cdot>xs) = lcons\<cdot>(f\<cdot>x)\<cdot>(lmap\<cdot>f\<cdot>xs)"
(*<*)

lemma lappend_strict'[simp]: "lappend\<cdot>\<bottom> = (\<Lambda> a. \<bottom>)"
  by fixrec_simp

lemma lconcat_strict[simp]: "lconcat\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp

lemma lmap_strict[simp]: "lmap\<cdot>f\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp

(*>*)
text\<open>

We define the lazy list monad \<open>S\<close> in the traditional fashion:

\<close>

type_synonym S = "nat discr llist"

definition returnS :: "nat discr \<rightarrow> S" where
  "returnS = (\<Lambda> x. lcons\<cdot>x\<cdot>lnil)"

definition bindS :: "S \<rightarrow> (nat discr \<rightarrow> S) \<rightarrow> S" where
  "bindS = (\<Lambda> x g. lconcat\<cdot>(lmap\<cdot>g\<cdot>x))"

text\<open>

Unfortunately the lack of higher-order polymorphism in HOL prevents us
from providing the general typing one would expect a monad to have in
Haskell.

The evaluator uses the following extra constants:

\<close>

definition addS :: "S \<rightarrow> S \<rightarrow> S" where
  "addS \<equiv> (\<Lambda> x y. bindS\<cdot>x\<cdot>(\<Lambda> xv. bindS\<cdot>y\<cdot>(\<Lambda> yv. returnS\<cdot>(xv + yv))))"

definition disjS :: "S \<rightarrow> S \<rightarrow> S" where
  "disjS \<equiv> lappend"

definition failS :: "S" where
  "failS \<equiv> lnil"

text\<open>

We interpret our language using these combinators in the obvious
way. The only complication is that, even though our evaluator is
primitive recursive, we must explicitly use the fixed point operator
as the worker/wrapper technique requires us to talk about the body of
the recursive definition.

\<close>

definition
  evalS_body :: "(expr discr \<rightarrow> nat discr llist)
              \<rightarrow> (expr discr \<rightarrow> nat discr llist)"
where
  "evalS_body \<equiv> \<Lambda> r e. case undiscr e of
     const n \<Rightarrow> returnS\<cdot>(Discr n)
   | add e1 e2 \<Rightarrow> addS\<cdot>(r\<cdot>(Discr e1))\<cdot>(r\<cdot>(Discr e2))
   | disj e1 e2 \<Rightarrow> disjS\<cdot>(r\<cdot>(Discr e1))\<cdot>(r\<cdot>(Discr e2))
   | fail \<Rightarrow> failS"

abbreviation evalS :: "expr discr \<rightarrow> nat discr llist" where
  "evalS \<equiv> fix\<cdot>evalS_body"

text\<open>

We aim to transform this evaluator into one using double-barrelled
continuations; one will serve as a "success" context, taking a natural
number into "the rest of the computation", and the other outright
failure.

In general we could work with an arbitrary observation type ala
\citet{DBLP:conf/icalp/Reynolds74}, but for convenience we use the
clearly adequate concrete type @{typ "nat discr llist"}.

\<close>

type_synonym Obs = "nat discr llist"
type_synonym Failure = "Obs"
type_synonym Success = "nat discr \<rightarrow> Failure \<rightarrow> Obs"
type_synonym K = "Success \<rightarrow> Failure \<rightarrow> Obs"

text\<open>

To ease our development we adopt what
\citet[\S5]{DBLP:conf/icfp/WandV04} call a "failure computation"
instead of a failure continuation, which would have the type @{typ
"unit \<rightarrow> Obs"}.

The monad over the continuation type @{typ "K"} is as follows:

\<close>

definition returnK :: "nat discr \<rightarrow> K" where
  "returnK \<equiv> (\<Lambda> x. \<Lambda> s f. s\<cdot>x\<cdot>f)"

definition bindK :: "K \<rightarrow> (nat discr \<rightarrow> K) \<rightarrow> K" where
  "bindK \<equiv> \<Lambda> x g. \<Lambda> s f. x\<cdot>(\<Lambda> xv f'. g\<cdot>xv\<cdot>s\<cdot>f')\<cdot>f"

text\<open>

Our extra constants are defined as follows:

\<close>

definition addK :: "K \<rightarrow> K \<rightarrow> K" where
  "addK \<equiv> (\<Lambda> x y. bindK\<cdot>x\<cdot>(\<Lambda> xv. bindK\<cdot>y\<cdot>(\<Lambda> yv. returnK\<cdot>(xv + yv))))"

definition disjK :: "K \<rightarrow> K \<rightarrow> K" where
  "disjK \<equiv> (\<Lambda> g h. \<Lambda> s f. g\<cdot>s\<cdot>(h\<cdot>s\<cdot>f))"

definition failK :: "K" where
  "failK \<equiv> \<Lambda> s f. f"

text\<open>

The continuation semantics is again straightforward:

\<close>

definition
  evalK_body :: "(expr discr \<rightarrow> K) \<rightarrow> (expr discr \<rightarrow> K)"
where
  "evalK_body \<equiv> \<Lambda> r e. case undiscr e of
     const n \<Rightarrow> returnK\<cdot>(Discr n)
   | add e1 e2 \<Rightarrow> addK\<cdot>(r\<cdot>(Discr e1))\<cdot>(r\<cdot>(Discr e2))
   | disj e1 e2 \<Rightarrow> disjK\<cdot>(r\<cdot>(Discr e1))\<cdot>(r\<cdot>(Discr e2))
   | fail \<Rightarrow> failK"

abbreviation evalK :: "expr discr \<rightarrow> K" where
  "evalK \<equiv> fix\<cdot>evalK_body"

text\<open>

We now set up a worker/wrapper relation between these two semantics.

The kernel of @{term "unwrap"} is the following function that converts
a lazy list into an equivalent continuation representation.

\<close>

fixrec SK :: "S \<rightarrow> K" where
  "SK\<cdot>lnil = failK"
| "SK\<cdot>(lcons\<cdot>x\<cdot>xs) = (\<Lambda> s f. s\<cdot>x\<cdot>(SK\<cdot>xs\<cdot>s\<cdot>f))"

definition
  unwrap :: "(expr discr \<rightarrow> nat discr llist) \<rightarrow> (expr discr \<rightarrow> K)"
where
  "unwrap \<equiv> \<Lambda> r e. SK\<cdot>(r\<cdot>e)"
(*<*)

lemma SK_strict[simp]: "SK\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp

lemma unwrap_strict[simp]: "unwrap\<cdot>\<bottom> = \<bottom>"
  unfolding unwrap_def by simp

(*>*)
text\<open>

Symmetrically @{term "wrap"} converts an evaluator using continuations
into one generating lazy lists by passing it the right continuations.

\<close>

definition KS :: "K \<rightarrow> S" where
  "KS \<equiv> (\<Lambda> k. k\<cdot>lcons\<cdot>lnil)"

definition wrap :: "(expr discr \<rightarrow> K) \<rightarrow> (expr discr \<rightarrow> nat discr llist)" where
  "wrap \<equiv> \<Lambda> r e. KS\<cdot>(r\<cdot>e)"
(*<*)

lemma KS_strict[simp]: "KS\<cdot>\<bottom> = \<bottom>"
  unfolding KS_def by simp

lemma wrap_strict[simp]: "wrap\<cdot>\<bottom> = \<bottom>"
  unfolding wrap_def by simp

(*>*)
text\<open>

The worker/wrapper condition follows directly from these definitions.

\<close>

lemma KS_SK_id:
  "KS\<cdot>(SK\<cdot>xs) = xs"
  by (induct xs) (simp_all add: KS_def failK_def)

lemma wrap_unwrap_id:
  "wrap oo unwrap = ID"
  unfolding wrap_def unwrap_def
  by (simp add: KS_SK_id cfun_eq_iff)

text\<open>

The worker/wrapper transformation is only non-trivial if @{term
"wrap"} and @{term "unwrap"} do not witness an isomorphism. In this
case we can show that we do not even have a Galois connection.

\<close>

lemma cfun_not_below:
  "f\<cdot>x \<notsqsubseteq> g\<cdot>x \<Longrightarrow> f \<notsqsubseteq> g"
  by (auto simp: cfun_below_iff)

lemma unwrap_wrap_not_under_id:
  "unwrap oo wrap \<notsqsubseteq> ID"
proof -
  let ?witness = "\<Lambda> e. (\<Lambda> s f. lnil :: K)"
  have "(unwrap oo wrap)\<cdot>?witness\<cdot>(Discr fail)\<cdot>\<bottom>\<cdot>(lcons\<cdot>0\<cdot>lnil)
       \<notsqsubseteq> ?witness\<cdot>(Discr fail)\<cdot>\<bottom>\<cdot>(lcons\<cdot>0\<cdot>lnil)"
    by (simp add: failK_def wrap_def unwrap_def KS_def)
  hence "(unwrap oo wrap)\<cdot>?witness \<notsqsubseteq> ?witness"
    by (fastforce intro!: cfun_not_below)
  thus ?thesis by (simp add: cfun_not_below)
qed

text\<open>

We now apply \texttt{worker\_wrapper\_id}:

\<close>

definition eval_work :: "expr discr \<rightarrow> K" where
  "eval_work \<equiv> fix\<cdot>(unwrap oo evalS_body oo wrap)"

definition eval_ww :: "expr discr \<rightarrow> nat discr llist" where
  "eval_ww \<equiv> wrap\<cdot>eval_work"

lemma "evalS = eval_ww"
  unfolding eval_ww_def eval_work_def
  using worker_wrapper_id[OF wrap_unwrap_id]
  by simp

text\<open>

We now show how the monadic operations correspond by showing that
@{term "SK"} witnesses a \emph{monad morphism}
\citep[\S6]{wadler92:_comprehending_monads}. As required by
\citet[Definition~2.1]{DBLP:journals/ngc/DanvyGR01}, the mapping needs
to hold for our specific operations in addition to the common monadic
scaffolding.

\<close>

lemma SK_returnS_returnK:
  "SK\<cdot>(returnS\<cdot>x) = returnK\<cdot>x"
  by (simp add: returnS_def returnK_def failK_def)

lemma SK_lappend_distrib:
 "SK\<cdot>(lappend\<cdot>xs\<cdot>ys)\<cdot>s\<cdot>f = SK\<cdot>xs\<cdot>s\<cdot>(SK\<cdot>ys\<cdot>s\<cdot>f)"
  by (induct xs) (simp_all add: failK_def)

lemma SK_bindS_bindK:
  "SK\<cdot>(bindS\<cdot>x\<cdot>g) = bindK\<cdot>(SK\<cdot>x)\<cdot>(SK oo g)"
  by (induct x)
     (simp_all add: cfun_eq_iff
                    bindS_def bindK_def failK_def
                    SK_lappend_distrib)

lemma SK_addS_distrib:
  "SK\<cdot>(addS\<cdot>x\<cdot>y) = addK\<cdot>(SK\<cdot>x)\<cdot>(SK\<cdot>y)"
  by (clarsimp simp: cfcomp1
                     addS_def addK_def failK_def
                     SK_bindS_bindK SK_returnS_returnK)

lemma SK_disjS_disjK:
 "SK\<cdot>(disjS\<cdot>xs\<cdot>ys) = disjK\<cdot>(SK\<cdot>xs)\<cdot>(SK\<cdot>ys)"
  by (simp add: cfun_eq_iff disjS_def disjK_def SK_lappend_distrib)

lemma SK_failS_failK:
  "SK\<cdot>failS = failK"
  unfolding failS_def by simp

text\<open>

These lemmas directly establish the precondition for our all-in-one
worker/wrapper and fusion rule:

\<close>

lemma evalS_body_evalK_body:
  "unwrap oo evalS_body oo wrap = evalK_body oo unwrap oo wrap"
proof(intro cfun_eqI)
  fix r e' s f
  obtain e :: "expr"
    where ee': "e' = Discr e" by (cases e')
  have "(unwrap oo evalS_body oo wrap)\<cdot>r\<cdot>(Discr e)\<cdot>s\<cdot>f
      = (evalK_body oo unwrap oo wrap)\<cdot>r\<cdot>(Discr e)\<cdot>s\<cdot>f"
    by (cases e)
       (simp_all add: evalS_body_def evalK_body_def unwrap_def
                      SK_returnS_returnK SK_addS_distrib
                      SK_disjS_disjK SK_failS_failK)
  with ee' show "(unwrap oo evalS_body oo wrap)\<cdot>r\<cdot>e'\<cdot>s\<cdot>f
                = (evalK_body oo unwrap oo wrap)\<cdot>r\<cdot>e'\<cdot>s\<cdot>f"
    by simp
qed

theorem evalS_evalK:
  "evalS = wrap\<cdot>evalK"
  using worker_wrapper_fusion_new[OF wrap_unwrap_id unwrap_strict]
        evalS_body_evalK_body
  by simp

text\<open>

This proof can be considered an instance of the approach of
\citet{DBLP:journals/jfp/HuttonJG10}, which uses the worker/wrapper
machinery to relate two algebras.

This result could be obtained by a structural induction over the
syntax of the language. However our goal here is to show how such a
transformation can be achieved by purely equational means; this has
the advantange that our proof can be locally extended, e.g. to the
full language of \citet{DBLP:journals/ngc/DanvyGR01} simply by proving
extra equations. In contrast the higher-order language of
\citet{DBLP:conf/icfp/WandV04} is beyond the reach of this approach.

\<close>
(*<*)

end
(*>*)


subsection \<open> Design Hoare Logic \<close>

theory utp_des_hoare
  imports utp_des_prog
begin

definition HoareD :: "'s upred \<Rightarrow> 's hrel_des \<Rightarrow> 's upred \<Rightarrow> bool" ("{_}_{_}\<^sub>D") where
[upred_defs, ndes_simp]: "HoareD p S q = ((p \<turnstile>\<^sub>n \<lceil>q\<rceil>\<^sub>>) \<sqsubseteq> S)"

lemma assigns_hoare_d [hoare_safe]: "`p \<Rightarrow> \<sigma> \<dagger> q` \<Longrightarrow> {p}\<langle>\<sigma>\<rangle>\<^sub>D{q}\<^sub>D"
  by rel_auto

lemma skip_hoare_d: "{p}II\<^sub>D{p}\<^sub>D"
  by (rel_auto)

lemma assigns_backward_hoare_d:
  "{\<sigma> \<dagger> p}\<langle>\<sigma>\<rangle>\<^sub>D{p}\<^sub>D"
  by rel_auto

lemma seq_hoare_d:
  assumes "C is \<^bold>N" "D is \<^bold>N" "{p}C{q}\<^sub>D" "{q}D{r}\<^sub>D"
  shows "{p}C ;; D{r}\<^sub>D"
proof -
  obtain c\<^sub>1 C\<^sub>2 where C: "C = c\<^sub>1 \<turnstile>\<^sub>n C\<^sub>2"
    by (metis assms(1) ndesign_form)
  obtain d\<^sub>1 D\<^sub>2 where D: "D = d\<^sub>1 \<turnstile>\<^sub>n D\<^sub>2"
    by (metis assms(2) ndesign_form)
  from assms(3-4) show ?thesis
    apply (simp add: C D)
    apply (ndes_simp)
    apply (simp add: ndesign_refinement)
    apply (rel_blast)
    done
qed

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009-2       |
            |                October 2010  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2020         |
            |                  April 2020  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory RS_pair
imports RS
begin

(*****************************************************************

         1. Pairs of RS are also RS.
         2.
         3.
         4.

 *****************************************************************)

(**********************************************************
              def: pair of restriction space
 **********************************************************)

instantiation prod :: (rs, rs) rs0
begin

definition
  pair_restriction_def :
    "(xc::('a::rs * 'b::rs)) .|. n
        == (((fst xc) .|. n) , ((snd xc) .|. n))"

  instance proof qed

end

definition
  pair_Limit :: "(('a::ms_rs * 'b::ms_rs) infinite_seq) => ('a::ms_rs * 'b::ms_rs)"
(*  pair_Limit :: "(('a::ms_rs * 'b::ms_rs) infinite_seq) => ('a::ms_rs * 'b::ms_rs)" *)
  where
  pair_Limit_def :
     "pair_Limit xcs == (Limit (fst o xcs) , Limit (snd o xcs))"

(************************************************************
                         Basics
 ************************************************************)

lemma rest_to_pair_rest:
    "[| (fst xc) .|. n = (fst yc) .|. n ;
        (snd xc) .|. n = (snd yc) .|. n |]
     ==> (xc::('a::rs * 'b::rs)) .|. n = yc .|. n"
by (simp add: pair_restriction_def)

(************************************************************
                   Pair RS ==> RS
 ************************************************************)

(*** pair_zero_eq_rs ***)

lemma pair_zero_eq_rs:
  "(xc::('a::rs * 'b::rs)) .|. 0 = yc .|. 0"
by (simp add: pair_restriction_def)

(*** pair_min_rs ***)

lemma pair_min_rs:
  "((xc::('a::rs * 'b::rs)) .|. m) .|. n = xc .|. (min m n)"
apply (simp add: pair_restriction_def)
by (simp add: min_rs)

(*** contra_pair_diff_rs ***)

lemma contra_pair_diff_rs:
  "(ALL n. (xc::('a::rs * 'b::rs)) .|. n = yc .|. n) ==> (xc = yc)"
apply (simp add: pair_restriction_def)

apply (insert contra_diff_rs[of "fst xc" "fst yc"])
apply (insert contra_diff_rs[of "snd xc" "snd yc"])
apply (simp add: prod_eq_iff)

done
(*** pair_diff_rs ***)

lemma pair_diff_rs:
  "((xc::('a::rs * 'b::rs)) ~= yc) ==> (EX n. xc .|. n ~= yc .|. n)"
apply (erule contrapos_pp)
apply (insert contra_pair_diff_rs[of xc yc])
by (simp)

(*****************************************
              Pair RS => RS
 *****************************************)

instance prod :: (rs,rs) rs
apply (intro_classes)
apply (simp add: pair_zero_eq_rs)
apply (simp add: pair_min_rs)
apply (simp add: pair_diff_rs)
done

(************************************************************
                     Pair RS ==> MS
 ************************************************************)

instantiation prod :: (rs,rs) ms0
begin

(*
fun pair_distance_def :: "(('a::rs * 'b::rs) * ('a::rs * 'b::rs)) => real"
where "distance xy = distance_rs xy"
*)

definition
  pair_distance_def: "distance (xy::('a::rs * 'b::rs) * ('a::rs * 'b::rs)) = distance_rs xy"

  instance proof qed
end

instance prod :: (rs,rs) ms
apply (intro_classes)
apply (simp_all add: pair_distance_def)
apply (simp add: diagonal_rs)
apply (simp add: pair_distance_def symmetry_rs)
apply (simp add: pair_distance_def triangle_inequality_rs)
done

(* isabelle 2009-1
instance * :: (rs,rs) ms
apply (intro_classes)
apply (simp)
apply (simp add: diagonal_rs)
apply (simp add: symmetry_rs)
apply (simp add: triangle_inequality_rs)
done
*)

(************************************************************
             i.e.  Pair RS ==> MS & RS
 ************************************************************)

instance prod :: (rs,rs) ms_rs
apply (intro_classes)
apply (simp add: pair_distance_def)
done

(************************************************************
                     Lemmas (distance)
 ************************************************************)

(* distance_nat *)

lemma pair_distance_nat_le_fst:
      "fst xc ~= fst yc
       ==> distance_nat ((xc::('a::rs * 'b::rs)), yc)
        <= distance_nat (fst xc, fst yc)"
apply (case_tac "xc = yc", simp)
apply (simp add: distance_nat_le_1[THEN sym])

apply (insert distance_nat_is[of xc yc], simp)
apply (simp add: isMAX_def)
apply (simp add: distance_nat_set_def)
by (simp add: pair_restriction_def)

lemma pair_distance_nat_le_snd:
      "snd xc ~= snd yc
       ==> distance_nat ((xc::('a::rs * 'b::rs)), yc)
        <= distance_nat (snd xc, snd yc)"
apply (case_tac "xc = yc", simp)
apply (simp add: distance_nat_le_1[THEN sym])

apply (insert distance_nat_is[of xc yc], simp)
apply (simp add: isMAX_def)
apply (simp add: distance_nat_set_def)
by (simp add: pair_restriction_def)

lemmas pair_distance_nat_le = pair_distance_nat_le_fst
                              pair_distance_nat_le_snd

(* distance *)

lemma pair_distance_def_le_fst:
   "distance (fst xc, fst yc) <= distance ((xc::('a::ms0_rs * 'b::ms0_rs)), yc)"
apply (case_tac "fst xc = fst yc", simp)
apply (case_tac "xc = yc", simp)
apply (simp_all add: to_distance_rs)
apply (case_tac "xc = yc", simp)
apply (simp add: distance_iff)
apply (simp add: pair_distance_nat_le_fst)  (* modified for Isabelle2020 *)
done

lemma pair_distance_def_le_fst_compo:
   "distance (a1, a2) <= distance ((a1::'a::ms0_rs, b1::'b::ms0_rs), (a2, b2))"
apply (insert pair_distance_def_le_fst[of "(a1,b1)" "(a2,b2)"])
by (simp)

lemma pair_distance_def_le_snd:
   "distance (snd xc, snd yc) <= distance ((xc::('a::ms0_rs * 'b::ms0_rs)), yc)"
apply (case_tac "snd xc = snd yc", simp)
apply (case_tac "xc = yc", simp)
apply (simp_all add: to_distance_rs)
apply (case_tac "xc = yc", simp)
apply (simp add: distance_iff)
(* apply (rule power_decreasing, simp_all)   modified for Isabelle2020 *)
by (simp add: pair_distance_nat_le_snd)

lemma pair_distance_def_le_snd_compo:
   "distance (b1, b2) <= distance ((a1::'a::ms0_rs, b1::'b::ms0_rs), (a2, b2))"
apply (insert pair_distance_def_le_snd[of "(a1,b1)" "(a2,b2)"])
by (simp)

lemmas pair_distance_def_le =
       pair_distance_def_le_fst pair_distance_def_le_snd

lemmas pair_distance_def_le_compo =
       pair_distance_def_le_fst_compo pair_distance_def_le_snd_compo

(*** pair_distance (max) ***)

lemma pair_distance_max:
  "distance ((xc::('a::ms_rs * 'b::ms_rs)), yc)
  = max (distance (fst xc, fst yc)) (distance (snd xc, snd yc))"
apply (case_tac "distance (fst xc, fst yc) <= distance (snd xc, snd yc)")
apply (simp add: max_is)
apply (rule order_antisym)
apply (simp_all add: pair_distance_def_le)

apply (case_tac "xc = yc", simp)
apply (case_tac "snd xc = snd yc", simp)
apply (case_tac "fst xc = fst yc", simp)
apply (simp add: pair_neq_decompo)
apply (erule contrapos_pp)
apply (simp add: linorder_not_le diff_pnt_pos_if)

 (* xc ~= yc; snd xc ~= snd yc *)
apply (simp add: to_distance_rs)
 apply (simp add: distance_iff)
 (* apply (rule power_decreasing, simp_all)  for 2020 *)
 apply (simp add: distance_nat_le_1[THEN sym])
 apply (simp add: pair_restriction_def)
 apply (simp add: distance_nat_rest)

 apply (case_tac "fst xc = fst yc", simp)
 apply (simp add: distance_iff)
 apply (rule rest_equal_preserve)
 apply (rule distance_nat_rest)
 apply (simp_all)
 (* apply (rule rev_power_decreasing, simp_all)     deleted for Isabelle2020 *)

      (* ~ distance (fst xc, fst yc) <= distance (snd xc, snd yc) *)

apply (simp add: max_is)
apply (rule order_antisym)
apply (simp_all add: pair_distance_def_le)

apply (case_tac "xc = yc", simp)
apply (case_tac "fst xc = fst yc", simp)

 (* xc ~= yc; fst xc ~= fst yc *)
 apply (simp add: to_distance_rs)
 apply (simp add: distance_iff)
 (* apply (rule power_decreasing, simp_all)     deleted for Isabelle2020 *)
 apply (simp add: distance_nat_le_1[THEN sym])
 apply (simp add: pair_restriction_def)
 apply (simp add: distance_nat_rest)

 apply (case_tac "snd xc = snd yc", simp)
 apply (simp add: distance_iff)
 apply (rule rest_equal_preserve)
 apply (rule distance_nat_rest)
 apply (simp_all)

apply (simp add: linorder_not_le)
(* apply (insert rev_power_decreasing[of "1/2"])    removed for Isabelle 2020 *)
done

lemma pair_distance_max_compo:
  "distance ((a1::('a::ms_rs), b1::('b::ms_rs)), (a2, b2))
  = max (distance (a1, a2)) (distance (b1, b2))"
apply (insert pair_distance_max[of "(a1, b1)" "(a2, b2)"])
by (simp)

lemma ALL_pair_distance_max:
  "ALL xc yc. distance ((xc::('a::ms_rs * 'b::ms_rs)), yc)
       = max (distance (fst xc, fst yc)) (distance (snd xc, snd yc))"
by (simp add: pair_distance_max)

(*****************************************
               pair maps
 *****************************************)

(*** fst ***)

lemma fst_non_expand: "non_expanding (fst::('a::ms_rs * 'b::ms_rs)=>'a)"
apply (simp add: non_expanding_def)
apply (simp add: map_alpha_def)
apply (simp add: pair_distance_def_le_compo)
done

(*** snd ***)

lemma snd_non_expand: "non_expanding (snd::('a::ms_rs * 'b::ms_rs)=>'b)"
apply (simp add: non_expanding_def)
apply (simp add: map_alpha_def)
apply (simp add: pair_distance_def_le_compo)
done

(*---------------------*
 |      map_alpha      |
 *---------------------*)

(* only_if *)

lemma pair_map_alpha_only_if:
  "map_alpha (fc::('a::ms_rs => ('b::ms_rs * 'c::ms_rs))) alpha
   ==> (map_alpha (fst o fc) alpha &
        map_alpha (snd o fc) alpha)"
by (simp add: compo_non_expand_map_alpha fst_non_expand snd_non_expand)

(* if *)

lemma pair_map_alpha_if:
  "[| map_alpha (fst o fc) alpha ; map_alpha (snd o fc) alpha |]
   ==> map_alpha (fc::('a::ms_rs => ('b::ms_rs * 'c::ms_rs))) alpha"
apply (simp add: map_alpha_def)
apply (intro allI)
apply (insert ALL_pair_distance_max)
apply (rotate_tac -1, drule_tac x="fc x" in spec)
apply (rotate_tac -1, drule_tac x="fc y" in spec)
by (simp)

(* iff *)

lemma pair_map_alpha:
  "map_alpha (fc::('a::ms_rs => ('b::ms_rs * 'c::ms_rs))) alpha
   = (map_alpha (fst o fc) alpha & map_alpha (snd o fc) alpha)"
apply (rule iffI)
apply (simp add: pair_map_alpha_only_if)
apply (simp add: pair_map_alpha_if)
done

lemma pair_map_alpha_compo:
  "map_alpha (f ** g) alpha
   = (map_alpha (f::('a::ms_rs => 'b::ms_rs)) alpha &
      map_alpha (g::('a::ms_rs => 'c::ms_rs)) alpha)"
apply (insert pair_map_alpha[of "f ** g"])
by (simp)

(*---------------------*
 |    non_expanding    |
 *---------------------*)

lemma pair_non_expand:
  "non_expanding (fc::('a::ms_rs => ('b::ms_rs * 'c::ms_rs)))
   = (non_expanding (fst o fc) & non_expanding (snd o fc))"
apply (simp add: non_expanding_def)
by (simp add: pair_map_alpha)

lemma pair_non_expand_compo:
  "non_expanding (f ** g)
   = (non_expanding (f::('a::ms_rs => 'b::ms_rs)) &
      non_expanding (g::('a::ms_rs => 'c::ms_rs)))"
apply (simp add: non_expanding_def)
by (simp add: pair_map_alpha_compo)

(*---------------------*
 |  alpha_contraction  |
 *---------------------*)

lemma pair_contra_alpha:
  "contraction_alpha (fc::('a::ms_rs => ('b::ms_rs * 'c::ms_rs))) alpha
   = (contraction_alpha (fst o fc) alpha & contraction_alpha (snd o fc) alpha)"
apply (simp add: contraction_alpha_def)
by (auto simp add: pair_map_alpha)

lemma pair_contra_alpha_compo:
  "contraction_alpha (f ** g) alpha
   = (contraction_alpha (f::('a::ms_rs => 'b::ms_rs)) alpha &
      contraction_alpha (g::('a::ms_rs => 'c::ms_rs)) alpha)"
apply (simp add: contraction_alpha_def)
by (auto simp add: pair_map_alpha_compo)

(************************************************************
                       Lemmas (Limit)
 ************************************************************)

(*****************************************
                  cauchy
 *****************************************)

lemma pair_cauchy_seq_fst:
  "cauchy (xcs::('a::ms_rs * 'b::ms_rs) infinite_seq)
   ==> cauchy (fst o xcs)"
apply (simp add: cauchy_def)
apply (intro allI impI)

apply (drule_tac x="delta" in spec)
apply (simp)
apply (erule exE)
apply (rule_tac x="n" in exI)
apply (intro allI impI)
apply (rename_tac delta N n m)
apply (drule_tac x="n" in spec)
apply (drule_tac x="m" in spec)
apply (simp add: pair_distance_max)
done

lemma pair_cauchy_seq_snd:
  "cauchy (xcs::('a::ms_rs * 'b::ms_rs) infinite_seq)
   ==> cauchy (snd o xcs)"
apply (simp add: cauchy_def)
apply (intro allI impI)

apply (drule_tac x="delta" in spec)
apply (simp)
apply (erule exE)
apply (rule_tac x="n" in exI)
apply (intro allI impI)
apply (rename_tac delta N n m)
apply (drule_tac x="n" in spec)
apply (drule_tac x="m" in spec)
apply (simp add: pair_distance_max)
done

lemmas pair_cauchy_seq = pair_cauchy_seq_fst pair_cauchy_seq_snd

lemma pair_cauchy_seq_fst_compo:
  "cauchy ((xc::'a::ms_rs infinite_seq) ** (yc::'a::ms_rs infinite_seq))
   ==> cauchy xc"
apply (insert pair_cauchy_seq_fst[of "xc ** yc"])
by (simp)

lemma pair_cauchy_seq_snd_compo:
  "cauchy ((xc::'a::ms_rs infinite_seq) ** (yc::'a::ms_rs infinite_seq))
   ==> cauchy yc"
apply (insert pair_cauchy_seq_snd[of "xc ** yc"])
by (simp)

lemmas pair_cauchy_seq_compo = pair_cauchy_seq_fst_compo pair_cauchy_seq_snd_compo

(*** normal ***)

lemma pair_normal_seq_fst:
  "normal (xcs::('a::ms_rs * 'b::ms_rs) infinite_seq)
   ==> normal (fst o xcs)"
apply (simp add: normal_def)
apply (intro allI)
apply (drule_tac x="n" in spec)
apply (drule_tac x="m" in spec)
by (simp add: pair_distance_max)

lemma pair_normal_seq_snd:
  "normal (xcs::('a::ms_rs * 'b::ms_rs) infinite_seq)
   ==> normal (snd o xcs)"
apply (simp add: normal_def)
apply (intro allI)
apply (drule_tac x="n" in spec)
apply (drule_tac x="m" in spec)
by (simp add: pair_distance_max)

lemmas pair_normal_seq = pair_normal_seq_fst pair_normal_seq_snd

lemma pair_normal_seq_fst_compo:
  "normal ((xc::'a::ms_rs infinite_seq) ** (yc::'a::ms_rs infinite_seq))
   ==> normal xc"
apply (insert pair_normal_seq_fst[of "xc ** yc"])
by (simp)

lemma pair_normal_seq_snd_compo:
  "normal ((xc::'a::ms_rs infinite_seq) ** (yc::'a::ms_rs infinite_seq))
   ==> normal yc"
apply (insert pair_normal_seq_snd[of "xc ** yc"])
by (simp)

lemmas pair_normal_seq_compo = pair_normal_seq_fst_compo pair_normal_seq_snd_compo

lemma pair_normal_seq_compo_only_if:
  "[| normal xc ; normal yc |] ==>
   normal ((xc::'a::ms_rs infinite_seq) ** (yc::'b::ms_rs infinite_seq))"
apply (simp add: normal_def)
apply (intro allI)
apply (drule_tac x="n" in spec)
apply (drule_tac x="n" in spec)
apply (drule_tac x="m" in spec)
apply (drule_tac x="m" in spec)
apply (simp add: pair_distance_max)
apply (simp add: pair_fun_def)
done

(* iff *)

lemma pair_normal_seq_compo_iff:
  "normal (xcs::('a::ms_rs * 'b::ms_rs) infinite_seq)
   = (normal (fst o xcs) & normal (snd o xcs))"
apply (rule)
apply (simp add: pair_normal_seq)
apply (insert pair_normal_seq_compo_only_if[of "(fst o xcs)" "(snd o xcs)"])
apply (simp add: pair_fun_def)
done

(*-----------------------*
 |     pairof Limits     |
 *-----------------------*)

(*** Limit (single <-- pair) ***)

lemma pair_convergeTo_fst_only_if:
  "(xcs::(('a::ms_rs * 'b::ms_rs) infinite_seq)) convergeTo yc
   ==> (fst o xcs) convergeTo (fst yc)"
apply (simp add: convergeTo_def)
apply (intro allI impI)

apply (drule_tac x="eps" in spec)
apply (simp)
apply (erule exE)
apply (rule_tac x="n" in exI)
apply (intro allI impI)
apply (rename_tac eps N n)
apply (drule_tac x="n" in spec)
apply (simp add: pair_distance_max)
done

lemma pair_convergeTo_snd_only_if:
  "(xcs::(('a::ms_rs * 'b::ms_rs) infinite_seq)) convergeTo yc
   ==> (snd o xcs) convergeTo (snd yc)"
apply (simp add: convergeTo_def)
apply (intro allI impI)

apply (drule_tac x="eps" in spec)
apply (simp)
apply (erule exE)
apply (rule_tac x="n" in exI)
apply (intro allI impI)
apply (rename_tac eps N n)
apply (drule_tac x="n" in spec)
apply (simp add: pair_distance_max)
done

(*** Limit (single --> pair) (note: ms_rs) ***)

lemma pair_convergeTo_if:
  "[| (fst o xcs) convergeTo (fst yc) ; (snd o xcs) convergeTo (snd yc) |]
   ==> (xcs::(('a::ms_rs * 'b::ms_rs) infinite_seq)) convergeTo yc"
apply (simp add: convergeTo_def)
apply (intro allI impI)

apply (drule_tac x="eps" in spec)
apply (drule_tac x="eps" in spec)
apply (simp)
apply (erule exE)+
apply (rename_tac eps N2 N1)

apply (rule_tac x="max N1 N2" in exI)
apply (simp add: pair_distance_max)
done

(*** iff ***)

lemma pair_convergeTo:
  "(xcs::(('a::ms_rs * 'b::ms_rs) infinite_seq)) convergeTo yc
   = ((fst o xcs) convergeTo (fst yc) & (snd o xcs) convergeTo (snd yc))"
apply (rule iffI)
apply (simp add: pair_convergeTo_fst_only_if pair_convergeTo_snd_only_if)
apply (simp add: pair_convergeTo_if)
done

lemma pair_convergeTo_compo:
  "((xs::('a::ms_rs infinite_seq)) ** (ys::('b::ms_rs infinite_seq)))
   convergeTo (x, y)
   = (xs convergeTo x & ys convergeTo y)"
apply (insert pair_convergeTo[of "xs ** ys" "(x,y)"])
by (simp)

(*****************************************
     Limit (cms and cauchy --> Limit)
 *****************************************)

lemma pair_cms_cauchy_Limit:
  "cauchy (xcs::(('a::cms_rs * 'b::cms_rs) infinite_seq))
   ==> xcs convergeTo (pair_Limit xcs)"
apply (simp add: pair_convergeTo)
by (simp add: pair_Limit_def pair_cauchy_seq Limit_is)

(*****************************************
     Pair Complete Metric Space (RS)
 *****************************************)

lemma pair_cms_rs:
  "cauchy (xcs::(('a::cms_rs * 'b::cms_rs) infinite_seq))
   ==> EX yc. xcs convergeTo yc"
apply (rule_tac x="pair_Limit xcs" in exI)
by (simp add: pair_cms_cauchy_Limit)

(************************************************************
                   Pair RS ==> CMS and RS
 ************************************************************)

instance prod :: (cms_rs,cms_rs) cms_rs
apply (intro_classes)
apply (intro allI impI)
by (rule pair_cms_rs, simp)

(*----------------------------------------------------------*
 |                                                          |
 |                Continuity on Metric space                |
 |                                                          |
 *----------------------------------------------------------*)

declare disj_not1 [simp del]

lemma pair_continuous_rs:
   "[| continuous_rs R1 ; continuous_rs R2 |]
     ==> continuous_rs (%xc. (R1 (fst xc) & R2 (snd xc)))"
apply (simp add: continuous_rs_def)
apply (intro allI)
apply (rule conjI)

apply (intro impI)
apply (drule_tac x="a" in spec)
apply (simp)
apply (erule exE)
apply (rule_tac x="n" in exI)
apply (intro allI impI)
apply (rotate_tac -1)
apply (drule_tac x="b" in spec)
apply (simp add: pair_restriction_def)

apply (intro impI)
apply (rotate_tac -1)
apply (drule_tac x="b" in spec)
apply (simp)
apply (erule exE)
apply (rule_tac x="n" in exI)
apply (intro allI impI)
apply (rotate_tac -2)
apply (drule_tac x="ba" in spec)
apply (simp add: pair_restriction_def)
done

(*----------------------------------------------------------*
 |                                                          |
 |      !!!     order and restriction space     !!!         |
 |                                                          |
 *----------------------------------------------------------*)

instance prod :: (ms_rs_order,ms_rs_order) ms_rs_order0
by (intro_classes)

instance prod :: (ms_rs_order,ms_rs_order) ms_rs_order
apply (intro_classes)
apply (simp add: order_pair_def pair_restriction_def)
apply (intro allI)
apply (rule iffI)
apply (rule conjI)
apply (insert rs_order_iff)
apply (drule_tac x="a" in spec)
apply (drule_tac x="aa" in spec)
apply (fast)
apply (drule_tac x="b" in spec)
apply (drule_tac x="ba" in spec)
apply (fast)

apply (intro allI)
apply (rule conjI)
apply (drule_tac x="a" in spec)
apply (drule_tac x="aa" in spec)
apply (fast)
apply (insert rs_order_iff)
apply (drule_tac x="b" in spec)
apply (drule_tac x="ba" in spec)
apply (fast)
done

(*** cms rs order ***)

instance prod :: (cms_rs_order,cms_rs_order) cms_rs_order
by (intro_classes)

(****************** to add it again ******************)

declare disj_not1 [simp]

end