theory flash34Bra  imports flash34Rev

  begin
lemma onInv34:

   assumes  a1:"iInv1 \<le> N" and

     b1:"r \<in> rules N" and b2:"invf=inv34  iInv1 "
   shows  "invHoldForRule' s invf r (invariants   N)"
   proof -
have c1:"ex1P N (% iRule1 .  r=NI_Local_GetX_PutX1 N  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_GetX  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Replace  iRule1 )\<or>ex0P N (  r=NI_ShWb N )\<or>ex0P N (  r=PI_Local_GetX_GetX2 )\<or>ex0P N (  r=NI_Local_PutXAcksDone )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX7 N  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_Get_Nak2  iRule1 )\<or>ex0P N (  r=NI_ReplaceHomeShrVld )\<or>ex1P N (% iRule1 .  r=NI_Remote_Put  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX5 N  iRule1 )\<or>ex0P N (  r=NI_Wb )\<or>ex1P N (% iRule1 .  r=NI_Local_Get_Get  iRule1 )\<or>ex0P N (  r=PI_Local_Replace )\<or>ex1P N (% iRule1 .  r=NI_ReplaceShrVld  iRule1 )\<or>ex2P N (% iRule1  iRule2 .  r=NI_Local_GetX_PutX8 N  iRule1  iRule2 )\<or>ex1P N (% iRule1 .  r=NI_InvAck_2 N  iRule1 )\<or>ex2P N (% iRule1  iRule2 .  r=NI_Remote_Get_Nak2  iRule1  iRule2 )\<or>ex1P N (% iRule1 .  r=PI_Remote_Replace  iRule1 )\<or>ex0P N (  r=NI_Nak_Home )\<or>ex1P N (% iRule1 .  r=NI_Local_Get_Put2  iRule1 )\<or>ex2P N (% iRule1  iRule2 .  r=NI_InvAck_1  iRule1  iRule2 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX11 N  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX6 N  iRule1 )\<or>ex2P N (% iRule1  iRule2 .  r=NI_Remote_Get_Put2  iRule1  iRule2 )\<or>ex0P N (  r=PI_Local_Get_Put )\<or>ex0P N (  r=PI_Local_GetX_PutX1 N )\<or>ex1P N (% iRule1 .  r=NI_InvAck_1_Home  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Remote_Get_Nak1  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_Get_Nak1  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_Nak2  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX10_home N  iRule1 )\<or>ex1P N (% iRule1 .  r=PI_Remote_Get  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_Nak3  iRule1 )\<or>ex2P N (% iRule1  iRule2 .  r=NI_Local_GetX_PutX10 N  iRule1  iRule2 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX2 N  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Remote_Get_Put1  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Remote_PutX  iRule1 )\<or>ex1P N (% iRule1 .  r=Store  iRule1 )\<or>ex0P N (  r=NI_FAck )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX3 N  iRule1 )\<or>ex0P N (  r=PI_Local_GetX_PutX3 )\<or>ex2P N (% iRule1  iRule2 .  r=NI_Remote_GetX_PutX  iRule1  iRule2 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX8_home N  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_Get_Put1 N  iRule1 )\<or>ex0P N (  r=PI_Local_GetX_GetX1 )\<or>ex0P N (  r=StoreHome )\<or>ex2P N (% iRule1  iRule2 .  r=NI_Remote_GetX_Nak  iRule1  iRule2 )\<or>ex1P N (% iRule1 .  r=NI_Inv  iRule1 )\<or>ex1P N (% iRule1 .  r=PI_Remote_PutX  iRule1 )\<or>ex0P N (  r=PI_Local_GetX_PutX4 )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX4 N  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Nak  iRule1 )\<or>ex0P N (  r=PI_Local_GetX_PutX2 N )\<or>ex0P N (  r=NI_Local_Put )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_Nak1  iRule1 )\<or>ex0P N (  r=NI_Nak_Clear )\<or>ex0P N (  r=PI_Local_PutX )\<or>ex1P N (% iRule1 .  r=NI_Local_Get_Nak3  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Remote_GetX_Nak_Home  iRule1 )\<or>ex0P N (  r=PI_Local_Get_Get )\<or>ex1P N (% iRule1 .  r=NI_Local_GetX_PutX9 N  iRule1 )\<or>ex1P N (% iRule1 .  r=PI_Remote_GetX  iRule1 )\<or>ex0P N (  r=NI_ReplaceHome )\<or>ex1P N (% iRule1 .  r=NI_Remote_GetX_PutX_Home  iRule1 )\<or>ex1P N (% iRule1 .  r=NI_Local_Get_Put3  iRule1 )"

        apply(cut_tac  b1)
        apply auto
        done      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX1 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX1 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_GetX_PutX1 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_GetX_PutX1VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_GetX  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_GetX  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_GetX_GetX  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_GetX_GetXVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Replace  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Replace  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Replace  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_ReplaceVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= NI_ShWb N )
"

         from c1 have c2:" r= NI_ShWb N "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_ShWb N ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis NI_ShWbVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex0P N (  r= PI_Local_GetX_GetX2 )
"

         from c1 have c2:" r= PI_Local_GetX_GetX2 "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (PI_Local_GetX_GetX2 ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis PI_Local_GetX_GetX2VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex0P N (  r= NI_Local_PutXAcksDone )
"

         from c1 have c2:" r= NI_Local_PutXAcksDone "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_PutXAcksDone ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis NI_Local_PutXAcksDoneVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX7 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX7 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_GetX_PutX7 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_GetX_PutX7VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_Get_Nak2  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_Get_Nak2  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_Get_Nak2  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_Get_Nak2VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= NI_ReplaceHomeShrVld )
"

         from c1 have c2:" r= NI_ReplaceHomeShrVld "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_ReplaceHomeShrVld ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis NI_ReplaceHomeShrVldVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Remote_Put  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Remote_Put  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Remote_Put  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Remote_PutVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX5 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX5 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_GetX_PutX5 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_GetX_PutX5VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= NI_Wb )
"

         from c1 have c2:" r= NI_Wb "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Wb ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis NI_WbVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_Get_Get  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_Get_Get  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_Get_Get  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_Get_GetVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= PI_Local_Replace )
"

         from c1 have c2:" r= PI_Local_Replace "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (PI_Local_Replace ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis PI_Local_ReplaceVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_ReplaceShrVld  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_ReplaceShrVld  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_ReplaceShrVld  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_ReplaceShrVldVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex2P N (% iRule1  iRule2 .  r= NI_Local_GetX_PutX8 N  iRule1  iRule2 )
"

         from c1 obtain  iRule1  iRule2  where c2:"  iRule1~=iRule2    \<and>   iRule1 \<le> N \<and>   iRule2 \<le> N \<and>  r= NI_Local_GetX_PutX8 N  iRule1  iRule2 "
         by (auto simp add: ex2P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_GetX_PutX8 N  iRule1  iRule2 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_GetX_PutX8VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_InvAck_2 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_InvAck_2 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_InvAck_2 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_InvAck_2VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex2P N (% iRule1  iRule2 .  r= NI_Remote_Get_Nak2  iRule1  iRule2 )
"

         from c1 obtain  iRule1  iRule2  where c2:"  iRule1~=iRule2    \<and>   iRule1 \<le> N \<and>   iRule2 \<le> N \<and>  r= NI_Remote_Get_Nak2  iRule1  iRule2 "
         by (auto simp add: ex2P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Remote_Get_Nak2  iRule1  iRule2 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Remote_Get_Nak2VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= PI_Remote_Replace  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= PI_Remote_Replace  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (PI_Remote_Replace  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis PI_Remote_ReplaceVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= NI_Nak_Home )
"

         from c1 have c2:" r= NI_Nak_Home "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Nak_Home ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis NI_Nak_HomeVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_Get_Put2  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_Get_Put2  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_Get_Put2  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_Get_Put2VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex2P N (% iRule1  iRule2 .  r= NI_InvAck_1  iRule1  iRule2 )
"

         from c1 obtain  iRule1  iRule2  where c2:"  iRule1~=iRule2    \<and>   iRule1 \<le> N \<and>   iRule2 \<le> N \<and>  r= NI_InvAck_1  iRule1  iRule2 "
         by (auto simp add: ex2P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_InvAck_1  iRule1  iRule2 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_InvAck_1VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX11 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX11 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_GetX_PutX11 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_GetX_PutX11VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX6 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX6 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_GetX_PutX6 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_GetX_PutX6VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex2P N (% iRule1  iRule2 .  r= NI_Remote_Get_Put2  iRule1  iRule2 )
"

         from c1 obtain  iRule1  iRule2  where c2:"  iRule1~=iRule2    \<and>   iRule1 \<le> N \<and>   iRule2 \<le> N \<and>  r= NI_Remote_Get_Put2  iRule1  iRule2 "
         by (auto simp add: ex2P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Remote_Get_Put2  iRule1  iRule2 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Remote_Get_Put2VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= PI_Local_Get_Put )
"

         from c1 have c2:" r= PI_Local_Get_Put "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (PI_Local_Get_Put ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis PI_Local_Get_PutVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex0P N (  r= PI_Local_GetX_PutX1 N )
"

         from c1 have c2:" r= PI_Local_GetX_PutX1 N "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (PI_Local_GetX_PutX1 N ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis PI_Local_GetX_PutX1VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_InvAck_1_Home  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_InvAck_1_Home  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_InvAck_1_Home  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_InvAck_1_HomeVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Remote_Get_Nak1  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Remote_Get_Nak1  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Remote_Get_Nak1  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Remote_Get_Nak1VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_Get_Nak1  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_Get_Nak1  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_Get_Nak1  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_Get_Nak1VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_Nak2  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_Nak2  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_GetX_Nak2  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_GetX_Nak2VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX10_home N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX10_home N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_GetX_PutX10_home N  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_GetX_PutX10_homeVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= PI_Remote_Get  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= PI_Remote_Get  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (PI_Remote_Get  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis PI_Remote_GetVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_Nak3  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_Nak3  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_GetX_Nak3  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_GetX_Nak3VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex2P N (% iRule1  iRule2 .  r= NI_Local_GetX_PutX10 N  iRule1  iRule2 )
"

         from c1 obtain  iRule1  iRule2  where c2:"  iRule1~=iRule2    \<and>   iRule1 \<le> N \<and>   iRule2 \<le> N \<and>  r= NI_Local_GetX_PutX10 N  iRule1  iRule2 "
         by (auto simp add: ex2P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_GetX_PutX10 N  iRule1  iRule2 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_GetX_PutX10VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX2 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX2 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_GetX_PutX2 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_GetX_PutX2VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Remote_Get_Put1  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Remote_Get_Put1  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Remote_Get_Put1  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Remote_Get_Put1VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Remote_PutX  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Remote_PutX  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Remote_PutX  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Remote_PutXVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= Store  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= Store  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (Store  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis StoreVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= NI_FAck )
"

         from c1 have c2:" r= NI_FAck "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_FAck ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis NI_FAckVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX3 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX3 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_GetX_PutX3 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_GetX_PutX3VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= PI_Local_GetX_PutX3 )
"

         from c1 have c2:" r= PI_Local_GetX_PutX3 "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (PI_Local_GetX_PutX3 ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis PI_Local_GetX_PutX3VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex2P N (% iRule1  iRule2 .  r= NI_Remote_GetX_PutX  iRule1  iRule2 )
"

         from c1 obtain  iRule1  iRule2  where c2:"  iRule1~=iRule2    \<and>   iRule1 \<le> N \<and>   iRule2 \<le> N \<and>  r= NI_Remote_GetX_PutX  iRule1  iRule2 "
         by (auto simp add: ex2P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Remote_GetX_PutX  iRule1  iRule2 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Remote_GetX_PutXVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX8_home N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX8_home N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_GetX_PutX8_home N  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_GetX_PutX8_homeVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_Get_Put1 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_Get_Put1 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_Get_Put1 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_Get_Put1VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= PI_Local_GetX_GetX1 )
"

         from c1 have c2:" r= PI_Local_GetX_GetX1 "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (PI_Local_GetX_GetX1 ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis PI_Local_GetX_GetX1VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex0P N (  r= StoreHome )
"

         from c1 have c2:" r= StoreHome "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (StoreHome ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis StoreHomeVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex2P N (% iRule1  iRule2 .  r= NI_Remote_GetX_Nak  iRule1  iRule2 )
"

         from c1 obtain  iRule1  iRule2  where c2:"  iRule1~=iRule2    \<and>   iRule1 \<le> N \<and>   iRule2 \<le> N \<and>  r= NI_Remote_GetX_Nak  iRule1  iRule2 "
         by (auto simp add: ex2P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Remote_GetX_Nak  iRule1  iRule2 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Remote_GetX_NakVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Inv  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Inv  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Inv  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_InvVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= PI_Remote_PutX  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= PI_Remote_PutX  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (PI_Remote_PutX  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis PI_Remote_PutXVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= PI_Local_GetX_PutX4 )
"

         from c1 have c2:" r= PI_Local_GetX_PutX4 "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (PI_Local_GetX_PutX4 ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis PI_Local_GetX_PutX4VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX4 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX4 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_GetX_PutX4 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_GetX_PutX4VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Nak  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Nak  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Nak  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_NakVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= PI_Local_GetX_PutX2 N )
"

         from c1 have c2:" r= PI_Local_GetX_PutX2 N "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (PI_Local_GetX_PutX2 N ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis PI_Local_GetX_PutX2VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex0P N (  r= NI_Local_Put )
"

         from c1 have c2:" r= NI_Local_Put "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_Put ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis NI_Local_PutVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_Nak1  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_Nak1  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_GetX_Nak1  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_GetX_Nak1VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= NI_Nak_Clear )
"

         from c1 have c2:" r= NI_Nak_Clear "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Nak_Clear ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis NI_Nak_ClearVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex0P N (  r= PI_Local_PutX )
"

         from c1 have c2:" r= PI_Local_PutX "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (PI_Local_PutX ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis PI_Local_PutXVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_Get_Nak3  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_Get_Nak3  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_Get_Nak3  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_Get_Nak3VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Remote_GetX_Nak_Home  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Remote_GetX_Nak_Home  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Remote_GetX_Nak_Home  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Remote_GetX_Nak_HomeVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= PI_Local_Get_Get )
"

         from c1 have c2:" r= PI_Local_Get_Get "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (PI_Local_Get_Get ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis PI_Local_Get_GetVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_GetX_PutX9 N  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_GetX_PutX9 N  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_GetX_PutX9 N  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_GetX_PutX9VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= PI_Remote_GetX  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= PI_Remote_GetX  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (PI_Remote_GetX  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis PI_Remote_GetXVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex0P N (  r= NI_ReplaceHome )
"

         from c1 have c2:" r= NI_ReplaceHome "
         by (auto simp add: ex0P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_ReplaceHome ) (invariants N) "
            apply(cut_tac   a1   b2 c2 )
            by (metis NI_ReplaceHomeVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
	}      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Remote_GetX_PutX_Home  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Remote_GetX_PutX_Home  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Remote_GetX_PutX_Home  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Remote_GetX_PutX_HomeVsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }      moreover
        {assume c1: "ex1P N (% iRule1 .  r= NI_Local_Get_Put3  iRule1 )
"

         from c1 obtain  iRule1  where c2:"  iRule1 \<le> N \<and>  r= NI_Local_Get_Put3  iRule1 "
         by (auto simp add: ex1P_def)

         have "invHoldForRule' s (inv34  iInv1 ) (NI_Local_Get_Put3  iRule1 ) (invariants N) "
            apply(cut_tac  c2   a1 )
            by (metis NI_Local_Get_Put3VsInv34 )
          then have "invHoldForRule' s invf r (invariants N) "
            by(cut_tac c2 b2, metis)
        }ultimately show "invHoldForRule' s invf r (invariants N) "
          by blast
     qed
end


(*  Title:      HOL/Auth/Shared.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge

Theory of Shared Keys (common to all symmetric-key protocols)

Shared, long-term keys; initial states of agents
*)

theory Shared
imports Event All_Symmetric
begin

consts
  shrK    :: "agent \<Rightarrow> key"  (*symmetric keys*)

specification (shrK)
  inj_shrK: "inj shrK"
  \<comment> \<open>No two agents have the same long-term key\<close>
   apply (rule exI [of _ "case_agent 0 (\<lambda>n. n + 2) 1"])
   apply (simp add: inj_on_def split: agent.split)
   done

text\<open>Server knows all long-term keys; other agents know only their own\<close>

overloading
  initState \<equiv> initState
begin

primrec initState where
  initState_Server:  "initState Server     = Key ` range shrK"
| initState_Friend:  "initState (Friend i) = {Key (shrK (Friend i))}"
| initState_Spy:     "initState Spy        = Key`shrK`bad"

end

subsection\<open>Basic properties of shrK\<close>

(*Injectiveness: Agents' long-term keys are distinct.*)
lemmas shrK_injective = inj_shrK [THEN inj_eq]
declare shrK_injective [iff]

lemma invKey_K [simp]: "invKey K = K"
apply (insert isSym_keys)
apply (simp add: symKeys_def)
done

lemma analz_Decrypt' [dest]:
     "[| Crypt K X \<in> analz H;  Key K  \<in> analz H |] ==> X \<in> analz H"
by auto

text\<open>Now cancel the \<open>dest\<close> attribute given to
 \<open>analz.Decrypt\<close> in its declaration.\<close>
declare analz.Decrypt [rule del]

text\<open>Rewrites should not refer to  \<^term>\<open>initState(Friend i)\<close> because
  that expression is not in normal form.\<close>

lemma keysFor_parts_initState [simp]: "keysFor (parts (initState C)) = {}"
apply (unfold keysFor_def)
apply (induct_tac "C", auto)
done

(*Specialized to shared-key model: no @{term invKey}*)
lemma keysFor_parts_insert:
     "[| K \<in> keysFor (parts (insert X G));  X \<in> synth (analz H) |]
      ==> K \<in> keysFor (parts (G \<union> H)) | Key K \<in> parts H"
by (metis invKey_K keysFor_parts_insert)

lemma Crypt_imp_keysFor: "Crypt K X \<in> H ==> K \<in> keysFor H"
by (metis Crypt_imp_invKey_keysFor invKey_K)

subsection\<open>Function "knows"\<close>

(*Spy sees shared keys of agents!*)
lemma Spy_knows_Spy_bad [intro!]: "A \<in> bad \<Longrightarrow> Key (shrK A) \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) add: imageI knows_Cons split: event.split)
done

(*For case analysis on whether or not an agent is compromised*)
lemma Crypt_Spy_analz_bad: "[| Crypt (shrK A) X \<in> analz (knows Spy evs);  A \<in> bad |]
      ==> X \<in> analz (knows Spy evs)"
by (metis Spy_knows_Spy_bad analz.Inj analz_Decrypt')

(** Fresh keys never clash with long-term shared keys **)

(*Agents see their own shared keys!*)
lemma shrK_in_initState [iff]: "Key (shrK A) \<in> initState A"
by (induct_tac "A", auto)

lemma shrK_in_used [iff]: "Key (shrK A) \<in> used evs"
by (rule initState_into_used, blast)

(*Used in parts_induct_tac and analz_Fake_tac to distinguish session keys
  from long-term shared keys*)
lemma Key_not_used [simp]: "Key K \<notin> used evs ==> K \<notin> range shrK"
by blast

lemma shrK_neq [simp]: "Key K \<notin> used evs ==> shrK B \<noteq> K"
by blast

lemmas shrK_sym_neq = shrK_neq [THEN not_sym]
declare shrK_sym_neq [simp]

subsection\<open>Fresh nonces\<close>

lemma Nonce_notin_initState [iff]: "Nonce N \<notin> parts (initState B)"
by (induct_tac "B", auto)

lemma Nonce_notin_used_empty [simp]: "Nonce N \<notin> used []"
by (simp add: used_Nil)

subsection\<open>Supply fresh nonces for possibility theorems.\<close>

(*In any trace, there is an upper bound N on the greatest nonce in use.*)
lemma Nonce_supply_lemma: "\<exists>N. \<forall>n. N \<le> n \<longrightarrow> Nonce n \<notin> used evs"
apply (induct_tac "evs")
apply (rule_tac x = 0 in exI)
apply (simp_all (no_asm_simp) add: used_Cons split: event.split)
apply (metis le_sup_iff msg_Nonce_supply)
done

lemma Nonce_supply1: "\<exists>N. Nonce N \<notin> used evs"
by (metis Nonce_supply_lemma order_eq_iff)

lemma Nonce_supply2: "\<exists>N N'. Nonce N \<notin> used evs \<and> Nonce N' \<notin> used evs' \<and> N \<noteq> N'"
apply (cut_tac evs = evs in Nonce_supply_lemma)
apply (cut_tac evs = "evs'" in Nonce_supply_lemma, clarify)
apply (metis Suc_n_not_le_n nat_le_linear)
done

lemma Nonce_supply3: "\<exists>N N' N''. Nonce N \<notin> used evs \<and> Nonce N' \<notin> used evs' \<and>
                    Nonce N'' \<notin> used evs'' \<and> N \<noteq> N' \<and> N' \<noteq> N'' \<and> N \<noteq> N''"
apply (cut_tac evs = evs in Nonce_supply_lemma)
apply (cut_tac evs = "evs'" in Nonce_supply_lemma)
apply (cut_tac evs = "evs''" in Nonce_supply_lemma, clarify)
apply (rule_tac x = N in exI)
apply (rule_tac x = "Suc (N+Na)" in exI)
apply (rule_tac x = "Suc (Suc (N+Na+Nb))" in exI)
apply (simp (no_asm_simp) add: less_not_refl3 le_add1 le_add2 less_Suc_eq_le)
done

lemma Nonce_supply: "Nonce (SOME N. Nonce N \<notin> used evs) \<notin> used evs"
apply (rule Nonce_supply_lemma [THEN exE])
apply (rule someI, blast)
done

text\<open>Unlike the corresponding property of nonces, we cannot prove
    \<^term>\<open>finite KK ==> \<exists>K. K \<notin> KK \<and> Key K \<notin> used evs\<close>.
    We have infinitely many agents and there is nothing to stop their
    long-term keys from exhausting all the natural numbers.  Instead,
    possibility theorems must assume the existence of a few keys.\<close>

subsection\<open>Specialized Rewriting for Theorems About \<^term>\<open>analz\<close> and Image\<close>

lemma subset_Compl_range: "A \<subseteq> - (range shrK) \<Longrightarrow> shrK x \<notin> A"
by blast

lemma insert_Key_singleton: "insert (Key K) H = Key ` {K} \<union> H"
by blast

lemma insert_Key_image: "insert (Key K) (Key`KK \<union> C) = Key`(insert K KK) \<union> C"
by blast

(** Reverse the normal simplification of "image" to build up (not break down)
    the set of keys.  Use analz_insert_eq with (Un_upper2 RS analz_mono) to
    erase occurrences of forwarded message components (X). **)

lemmas analz_image_freshK_simps =
       simp_thms mem_simps \<comment> \<open>these two allow its use with \<open>only:\<close>\<close>
       disj_comms
       image_insert [THEN sym] image_Un [THEN sym] empty_subsetI insert_subset
       analz_insert_eq Un_upper2 [THEN analz_mono, THEN [2] rev_subsetD]
       insert_Key_singleton subset_Compl_range
       Key_not_used insert_Key_image Un_assoc [THEN sym]

(*Lemma for the trivial direction of the if-and-only-if*)
lemma analz_image_freshK_lemma:
     "(Key K \<in> analz (Key`nE \<union> H)) \<longrightarrow> (K \<in> nE | Key K \<in> analz H)  ==>
         (Key K \<in> analz (Key`nE \<union> H)) = (K \<in> nE | Key K \<in> analz H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

subsection\<open>Tactics for possibility theorems\<close>

ML
\<open>
structure Shared =
struct

(*Omitting used_Says makes the tactic much faster: it leaves expressions
    such as  Nonce ?N \<notin> used evs that match Nonce_supply*)
fun possibility_tac ctxt =
   (REPEAT
    (ALLGOALS (simp_tac (ctxt
          delsimps [@{thm used_Says}, @{thm used_Notes}, @{thm used_Gets}]
          setSolver safe_solver))
     THEN
     REPEAT_FIRST (eq_assume_tac ORELSE'
                   resolve_tac ctxt [refl, conjI, @{thm Nonce_supply}])))

(*For harder protocols (such as Recur) where we have to set up some
  nonces and keys initially*)
fun basic_possibility_tac ctxt =
    REPEAT
    (ALLGOALS (asm_simp_tac (ctxt setSolver safe_solver))
     THEN
     REPEAT_FIRST (resolve_tac ctxt [refl, conjI]))

val analz_image_freshK_ss =
  simpset_of
   (\<^context> delsimps [image_insert, image_Un]
      delsimps [@{thm imp_disjL}]    (*reduces blow-up*)
      addsimps @{thms analz_image_freshK_simps})

end
\<close>

(*Lets blast_tac perform this step without needing the simplifier*)
lemma invKey_shrK_iff [iff]:
     "(Key (invKey K) \<in> X) = (Key K \<in> X)"
by auto

(*Specialized methods*)

method_setup analz_freshK = \<open>
    Scan.succeed (fn ctxt =>
     (SIMPLE_METHOD
      (EVERY [REPEAT_FIRST (resolve_tac ctxt [allI, ballI, impI]),
          REPEAT_FIRST (resolve_tac ctxt @{thms analz_image_freshK_lemma}),
          ALLGOALS (asm_simp_tac (put_simpset Shared.analz_image_freshK_ss ctxt))])))\<close>
    "for proving the Session Key Compromise theorem"

method_setup possibility = \<open>
    Scan.succeed (fn ctxt => SIMPLE_METHOD (Shared.possibility_tac ctxt))\<close>
    "for proving possibility theorems"

method_setup basic_possibility = \<open>
    Scan.succeed (fn ctxt => SIMPLE_METHOD (Shared.basic_possibility_tac ctxt))\<close>
    "for proving possibility theorems"

lemma knows_subset_knows_Cons: "knows A evs \<subseteq> knows A (e # evs)"
by (cases e) (auto simp: knows_Cons)

end


theory NuLLReps
  imports NuSys "HOL-Library.Word"
  abbrevs "<own>" = "\<left_fish_tail>"
    and "<none>" = "\<down_fish_tail>"
    and "<object>" = "\<R_arr_tail>"
begin

text \<open>Semantic data representations\<close>

declare pair_forall[lrep_exps] pair_exists[lrep_exps]
(* declare llty_prod[\<nu>intro] *)

section \<open>Memory address\<close>

text \<open>The concept of the address space is one of the notions in the LLVM\<close>

consts segment_len :: "msegment \<Rightarrow> nat" \<comment> \<open>in unit of the number of elements\<close>
consts segment_llty :: "msegment \<Rightarrow> llty" \<comment> \<open>type of the element in the segment\<close>
consts size_of :: "llty \<Rightarrow> nat" \<comment> \<open>in unit of bytes\<close>
abbreviation "address_llty adr \<equiv> segment_llty (segment_of adr)"
abbreviation "address_len adr \<equiv> segment_len (segment_of adr)"
consts addrspace_capacity :: "nat" \<comment> \<open>in unit of bits\<close>
specification (addrspace_capacity) addrspace_capacity_L0: "0 < addrspace_capacity" by auto
specification (size_of)
  size_of_L0[simp]: "size_of x \<noteq> 0"
  by auto

specification (segment_len)
  segment_len_valid: "segment_len seg * size_of (segment_llty seg) < 2 ^ (addrspace_capacity - 1)"
proof show "\<forall>seg. (\<lambda>_.  0) seg * size_of (segment_llty seg) < 2 ^ (addrspace_capacity - 1)"
    using addrspace_capacity_L0 by auto qed

lemma segment_len_valid2: "segment_len seg * size_of (segment_llty seg) < 2 ^ addrspace_capacity"
  using segment_len_valid
  by (metis addrspace_capacity_L0 le_less_trans one_less_numeral_iff order_less_imp_le power_commutes
      power_less_power_Suc power_minus_mult semiring_norm(76))

typedef size_t = "UNIV :: nat set" ..
instantiation size_t :: len begin
definition len_of_size_t :: "size_t itself \<Rightarrow> nat" where [simp]: "len_of_size_t _ = addrspace_capacity"
instance apply standard using addrspace_capacity_L0 by auto
end

primrec addr_cap \<comment> \<open>The memory block starting at the address has length `len`\<close>
  where "addr_cap (seg |+ ofs) len \<longleftrightarrow> ofs = 0 \<and> segment_len seg = len"

definition "malloc h = (@x. \<forall>ofs. h (MemAddress (x |+ ofs)) = None)"

lemma malloc: "Heap h \<Longrightarrow> h (MemAddress (malloc h |+ ofs)) = None"
  unfolding Heap_def AvailableSegments_def malloc_def
  by (metis (mono_tags, lifting) not_finite_existsD tfl_some)

lemma malloc2: "Heap h \<Longrightarrow> MemAddress (malloc h |+ ofs) \<notin> dom h"
  using malloc by (simp add: domIff)

type_synonym raw_memaddr = "size_t word memaddr"
type_synonym logical_memaddr = "nat memaddr"

datatype memptr = memptr "raw_memaddr "  \<comment> \<open>'spc : address space\<close>

(* specification (segment_len) segment_len_max: "segment_len seg < (2::nat) ^ addrspace_capacity (segment_space seg)"
  proof show "\<forall>seg. (\<lambda>x. 0) seg < (2::nat) ^ addrspace_capacity (segment_space seg)" by auto qed *)
(* specification (segment_len) segment_len_max: "segment_len seg * size_of (segment_llty seg) < addrspace_capacity (segment_space seg)"
  proof show "\<forall>seg. (\<lambda>x. 0) seg * size_of (segment_llty seg) < addrspace_capacity (segment_space seg)" by auto qed *)

(* typedef ('b::len0) size_t = "UNIV :: nat set" ..
instantiation size_t :: (len0) len begin
definition len_of_size_t :: "'a size_t itself \<Rightarrow> nat" where [simp]: "len_of_size_t _ = 1 + addrspace_capacity LENGTH('a)"
  \<comment> \<open>it is plus 1 to enable the representation of `negative` offset of the address exorcising any ambiguity.
    In the complication implementation, it is interpreted as this that the size of a single segment can only be at most to half of the
    actual total capacity of the address space, 2^31 bytes in the 32 bits machine, so that the size_t in this case still equals
    to that in the actual physical machine. \<close>
instance by standard auto
end *)

lemma memptr_exisits[lrep_exps]: "Ex P \<longleftrightarrow> (\<exists>addr. P (memptr addr))" by (metis memptr.exhaust)
lemma memptr_forall[lrep_exps]: "All P \<longleftrightarrow> (\<forall>addr. P (memptr addr))" by (metis memptr.exhaust)

subsection \<open>Instantiations for memptr\<close>

instantiation memptr :: lrep begin
definition llty_memptr :: " memptr itself \<Rightarrow> llty" where "llty_memptr _ = llty_pointer"
definition deepize_memptr :: " memptr \<Rightarrow> value"
  where "deepize_memptr ptr = DM_pointer (case_memptr (map_memaddr unat) ptr)"
definition shallowize_memptr :: " value \<Rightarrow> memptr "
  where "shallowize_memptr dm = (case dm of DM_pointer addr \<Rightarrow> memptr (map_memaddr of_nat addr))"
instance apply standard subgoal for x apply (cases x) subgoal for xa apply (cases xa)
      by (auto simp add: shallowize_memptr_def deepize_memptr_def) done done
end

instantiation memptr :: field begin instance by standard end
instantiation memptr :: field_list begin instance by standard end

instantiation memptr :: zero begin
definition zero_memptr :: " memptr" where [simp]: "zero_memptr = memptr (undefined |+ 0)"
instance by standard
end

abbreviation valid_memaddr :: "nat memaddr \<Rightarrow> bool"
  where "valid_memaddr addr \<equiv> offset_of addr \<le> segment_len (segment_of addr)"
definition raw_offset_of :: " msegment \<Rightarrow> nat \<Rightarrow> size_t word"
  where "raw_offset_of seg i = of_nat (i * size_of (segment_llty seg))"
lemma [simp]: "raw_offset_of seg 0 = 0" unfolding raw_offset_of_def by auto
lemma [simp]: "raw_offset_of seg (ofs + unat delt) = raw_offset_of seg ofs + delt * word_of_nat (size_of (segment_llty seg))"
  unfolding raw_offset_of_def using distrib_right by auto
lemma raw_offset_of_inj:
  "valid_memaddr (seg |+ ofs1) \<Longrightarrow> valid_memaddr (seg |+ ofs2) \<Longrightarrow>
    raw_offset_of seg ofs1 = (raw_offset_of seg ofs2 :: size_t word) \<Longrightarrow> ofs1 = ofs2"
  unfolding raw_offset_of_def word_of_nat_eq_iff take_bit_nat_def apply simp subgoal premises prems proof -
    have "ofs1 * size_of (segment_llty seg) < 2 ^ addrspace_capacity"
      using prems segment_len_valid2 size_of_L0
      by (meson le_less_trans mult_le_mono1)
    moreover have "ofs2 * size_of (segment_llty seg) < 2 ^ addrspace_capacity"
      using prems segment_len_valid2 size_of_L0
      by (meson le_less_trans mult_le_mono1)
    ultimately show "ofs1 = ofs2" using prems size_of_L0 addrspace_capacity_L0 by auto
  qed done

definition same_addr_offset :: "msegment \<Rightarrow> size_t word \<Rightarrow> nat \<Rightarrow> bool"
  where "same_addr_offset seg ofsp ofsx \<longleftrightarrow> ofsx \<le> segment_len seg \<and> raw_offset_of seg ofsx = ofsp"
definition the_same_addr :: "raw_memaddr \<Rightarrow> nat memaddr \<Rightarrow> bool"
  where "the_same_addr addrp addrx \<equiv>
    segment_of addrp = segment_of addrx
    \<and> same_addr_offset (segment_of addrx)  (offset_of addrp) (offset_of addrx)"
lemma [simp]: "the_same_addr (base |+ ofs) (base' |+ ofs') \<longleftrightarrow> base = base' \<and> same_addr_offset base' ofs ofs'"
  unfolding the_same_addr_def by simp

lemma same_addr_offset_inj: "same_addr_offset seg p a1 \<and> same_addr_offset seg p a2 \<Longrightarrow> a1 = a2"
  by (auto simp add: same_addr_offset_def raw_offset_of_def raw_offset_of_inj)
lemma same_addr_offset_inj2: "same_addr_offset seg p1 a \<and> same_addr_offset seg p2 a \<Longrightarrow> p1 = p2"
  by (auto simp add: same_addr_offset_def raw_offset_of_def raw_offset_of_inj)

consts logical_offset_of :: "msegment \<Rightarrow> size_t word \<Rightarrow> nat"
specification (logical_offset_of)
  logical_offset_of[simp]: "same_addr_offset seg ofsp ofsx \<Longrightarrow> logical_offset_of seg ofsp = ofsx"
proof show "\<forall>ofsp ofsx seg. same_addr_offset seg ofsp ofsx \<longrightarrow>  (\<lambda>seg p. @x. same_addr_offset seg p x) seg ofsp = ofsx"
    using same_addr_offset_inj by blast qed

definition "logical_addr_of addrp = (case addrp of seg |+ ofsp \<Rightarrow> seg |+ logical_offset_of seg ofsp) "
lemma [simp]: "logical_addr_of (seg |+ ofsp) = seg |+ logical_offset_of seg ofsp"
  unfolding logical_addr_of_def by simp

(* definition addr'_allocated :: "heap \<Rightarrow> raw_memaddr \<Rightarrow> bool"
  where "addr'_allocated heap addr' \<longleftrightarrow> (\<exists>addr. the_same_addr addr' addr \<and> addr_allocated heap addr)" *)

(* instantiation memaddr :: ceq begin
definition ceqable_memaddr :: " heap \<Rightarrow> memaddr \<Rightarrow> memaddr \<Rightarrow> bool"
  where [simp]: "ceqable_memaddr heap x y = (addr_allocated heap x \<and> addr_allocated heap y)"
definition ceq_memaddr :: " memaddr \<Rightarrow> memaddr \<Rightarrow> bool" where [simp]: "ceq_memaddr = (=)"
instance by standard auto
end *)

instantiation memptr :: ceq begin
definition ceqable_memptr :: " heap \<Rightarrow> memptr \<Rightarrow> memptr \<Rightarrow> bool" where
  "ceqable_memptr heap x y = (case x of memptr a \<Rightarrow> case y of memptr b \<Rightarrow>
    (segment_of a = segment_of b))"
lemma [simp]:
  "ceqable heap (memptr a) (memptr b) \<longleftrightarrow> (segment_of a = segment_of b)"
  unfolding ceqable_memptr_def by simp
definition ceq_memptr :: " memptr \<Rightarrow> memptr \<Rightarrow> bool" where [simp]: "ceq_memptr = (=)"
instance proof
  fix x y z :: " memptr" and h :: "heap"
  show "ceqable h x y = ceqable h y x" by (cases x; cases y) auto
  show "ceqable h x x \<Longrightarrow> ceq x x" and "ceqable h x y \<Longrightarrow> ceq x y = ceq y x"
    and "ceqable h x y \<Longrightarrow> ceqable h y z \<Longrightarrow> ceqable h x z \<Longrightarrow> ceq x y \<Longrightarrow> ceq y z \<Longrightarrow> ceq x z" by auto+
qed
end

subsection \<open>\<nu>-abstraction\<close>

subsubsection \<open>Raw Pointer\<close>

definition RawPointer :: "(memptr, raw_memaddr) \<nu>"
  where "RawPointer x = { memptr i | i. i = x}"

lemma [nu_exps]: "memptr i \<nuLinkL> RawPointer \<nuLinkR> i' \<longleftrightarrow> (i = i')" unfolding Refining_def by (simp add: RawPointer_def nu_exps)
lemma [elim,\<nu>elim]: "addr \<ratio> RawPointer \<Longrightarrow> C \<Longrightarrow> C" unfolding Inhabited_def by (simp add: lrep_exps)
lemma [\<nu>reason on \<open>\<nu>Zero RawPointer ?x\<close>]:
  "\<nu>Zero RawPointer (undefined |+ 0)" unfolding \<nu>Zero_def by (simp add: nu_exps)
lemma [\<nu>reason on \<open>\<nu>Equal RawPointer ?c ?eq\<close>]:
  "\<nu>Equal RawPointer (\<lambda>x y. segment_of x = segment_of y) (=)" unfolding \<nu>Equal_def by (simp add: lrep_exps nu_exps)

subsubsection \<open>Pointer\<close>

definition Pointer :: "(memptr, nat memaddr) \<nu>"
  where "Pointer x = { memptr raw | raw. the_same_addr raw x}"

lemma [nu_exps]: "memptr raw \<nuLinkL> Pointer \<nuLinkR> addr \<longleftrightarrow> the_same_addr raw addr"
  unfolding Refining_def by (simp add: Pointer_def)
lemma [elim,\<nu>elim]: "addr \<ratio> Pointer \<Longrightarrow> C \<Longrightarrow> C" unfolding Inhabited_def by (simp add: lrep_exps)
lemma [\<nu>reason on \<open>\<nu>Equal Pointer ?c ?eq\<close>]:
    "\<nu>Equal Pointer (\<lambda>x y. segment_of x = segment_of y) (=)"
  unfolding \<nu>Equal_def using raw_offset_of_inj by (simp add: lrep_exps the_same_addr_def same_addr_offset_def nu_exps) blast
lemma [\<nu>reason on \<open>\<nu>Zero Pointer ?x\<close>]:
    "\<nu>Zero Pointer (undefined |+ 0)"
  unfolding \<nu>Zero_def by (simp add: nu_exps same_addr_offset_def)

subsubsection \<open>Casts\<close>

(* named_theorems fixtyp_\<nu>cast and freetyp_\<nu>cast

lemma [\<nu>intro, fixtyp_\<nu>cast]:
  "\<^bold>p\<^bold>r\<^bold>e\<^bold>m\<^bold>i\<^bold>s\<^bold>e address_llty addr = ty \<Longrightarrow>
    \<^bold>c\<^bold>a\<^bold>s\<^bold>t addr \<tycolon> Pointer['spc] \<longmapsto> addr \<tycolon> TypedPtr['spc::len0] ty"
  unfolding Cast_def by (cases addr) (auto simp add: lrep_exps split: memaddr.split)

lemma [\<nu>intro, freetyp_\<nu>cast]:
  "\<^bold>c\<^bold>a\<^bold>s\<^bold>t addr \<tycolon> TypedPtr['spc] ty \<longmapsto> addr \<tycolon> Pointer['spc::len0] \<^bold>w\<^bold>i\<^bold>t\<^bold>h address_llty addr = ty"
  unfolding Cast_def by (cases addr) (auto simp add: lrep_exps split: memaddr.split)
*)

section \<open>The integer data type\<close>

subsection \<open>Lrep instantiations\<close>

instantiation word :: (len) lrep begin
definition llty_word :: "'a word itself \<Rightarrow> llty" where [simp, \<nu>reason]: "llty_word _ = llty_int LENGTH('a)"
definition deepize_word :: " 'a word \<Rightarrow> value " where "deepize_word x = DM_int LENGTH('a) (unat x)"
definition shallowize_word :: " value \<Rightarrow> 'a word" where "shallowize_word x = (case x of DM_int _ n \<Rightarrow> of_nat n)"
instance apply standard using deepize_word_def shallowize_word_def by auto
end

instantiation word :: (len) ceq
begin
definition ceqable_word :: "heap \<Rightarrow> 'a word \<Rightarrow> 'a word \<Rightarrow> bool" where [simp]: "ceqable_word _ x y = True"
definition ceq_word :: "'a word \<Rightarrow>  'a word \<Rightarrow> bool" where [simp]: "ceq_word x y = (x = y)"
instance by standard (auto+)
end

instantiation word :: (len) field begin instance by standard end
instantiation word :: (len) field_list begin instance by standard end

subsection \<open>Basic \<nu>-abstractions based on integer type\<close>

subsubsection \<open>Natural number\<close>

definition NuNat :: "('a::len) itself \<Rightarrow> ('a word, nat) \<nu>" where "NuNat _ x = {p. unat p = x }"
syntax "_NuNat_" :: "type \<Rightarrow> logic" (\<open>\<nat>'[_']\<close>)
translations "\<nat>['x]" == "CONST NuNat (TYPE('x))"

lemma [nu_exps]: "p \<nuLinkL> NuNat b \<nuLinkR> x \<equiv> (unat p = x)" unfolding Refining_def by (simp add: NuNat_def)
lemma [elim!,\<nu>elim]: "x \<ratio> \<nat>['b::len] \<Longrightarrow> (x < 2^LENGTH('b) \<Longrightarrow> C) \<Longrightarrow> C" unfolding Inhabited_def by (auto simp add: nu_exps)

lemma [\<nu>reason on \<open>\<nu>Equal (NuNat ?b) ?c ?eq\<close>]:
  "\<nu>Equal (NuNat b) (\<lambda>x y. True) (=)"
  unfolding \<nu>Equal_def by (auto simp add: unsigned_word_eqI nu_exps)
lemma [\<nu>reason on \<open>\<nu>Zero (NuNat ?b) ?zero\<close>]:
  "\<nu>Zero (NuNat b) 0" unfolding \<nu>Zero_def by (simp add: nu_exps)

definition NuNatRound :: "('a::len) itself \<Rightarrow> ('a word, nat) \<nu>" where "NuNatRound _ x = {p. p = of_nat x}"
syntax "_NuNatRound_" :: "type \<Rightarrow> logic" (\<open>\<nat>\<^sup>r'[_']\<close>)
translations "\<nat>\<^sup>r['x]" == "CONST NuNatRound (TYPE('x))"

lemma [simp]: "p \<nuLinkL> NuNatRound b \<nuLinkR> x \<equiv> (p = of_nat x)" unfolding Refining_def  by (simp add: NuNatRound_def)
lemma [\<nu>reason on \<open>\<nu>Zero (NuNatRound ?b) ?z\<close>]:
    "\<nu>Zero (NuNatRound b) 0"
  unfolding \<nu>Zero_def by simp

\<nu>processor literal_number 9500\<open>\<^bold>c\<^bold>u\<^bold>r\<^bold>r\<^bold>e\<^bold>n\<^bold>t blk [H] \<^bold>r\<^bold>e\<^bold>s\<^bold>u\<^bold>l\<^bold>t\<^bold>s \<^bold>i\<^bold>n T\<close> \<open>fn ctx => fn meta => Parse.number >> (fn num => fn _ =>
  let open NuBasics
    val num = Syntax.parse_term ctx num
    fun mk term = mk_nuTy (num, term) |> Syntax.check_term ctx |> Thm.cterm_of ctx
    val term = (
        (dest_current_nu meta |> strip_separations |> hd |> dest_RepSet |> #2 |> mk)
      handle TERM _ => mk @{term \<open>\<nat>[32]\<close>}
        | ERROR _ => mk @{term \<open>\<nat>[32]\<close>})
  in (NuSys.auto_construct ctx term meta, ctx)  end)
\<close>

subsubsection \<open>Integer\<close>

definition NuInt :: "('a::len) itself \<Rightarrow> ('a word, int) \<nu>" where "NuInt _ x = {p. sint p = x}"
syntax "_NuInt_" :: "type \<Rightarrow> logic" (\<open>\<int>'[_']\<close>)
translations "\<int>['x]" == "CONST NuInt (TYPE('x))"

lemma [simp]: "p \<nuLinkL> NuInt b \<nuLinkR> x \<equiv> (sint p = x)" unfolding Refining_def by (simp add: NuInt_def)
lemma [elim,\<nu>elim]: " x \<ratio> \<int>['b::len] \<Longrightarrow> (x < 2^(LENGTH('b) - 1) \<Longrightarrow> -(2^(LENGTH('b)-1)) \<le> x \<Longrightarrow> C) \<Longrightarrow> C"
  unfolding Inhabited_def by (simp add: nu_exps) (metis One_nat_def sint_ge sint_lt)

lemma [\<nu>reason on \<open>\<nu>Equal (NuInt b) ?c ?eq\<close>]:
    "\<nu>Equal (NuInt b) (\<lambda>x y. True) (=)"
  unfolding \<nu>Equal_def by (auto simp add: signed_word_eqI)

lemma [\<nu>reason on \<open>\<nu>Zero (NuInt ?b) ?x\<close>]:
    "\<nu>Zero (NuInt b) 0"
  unfolding \<nu>Zero_def by simp

subsubsection \<open>Boolean\<close>

lemma [simp]: "(x \<noteq> 1) = (x = 0)" for x :: "1 word" proof -
  have "(UNIV:: 1 word set) = {0,1}" unfolding UNIV_word_eq_word_of_nat
  using less_2_cases apply auto apply force
  by (metis UNIV_I UNIV_word_eq_word_of_nat len_num1 power_one_right)
  then show ?thesis  by auto
qed

definition NuBool :: "(1 word, bool) \<nu>" ("\<bool>") where "NuBool x = {p. (p = 1) = x }"

lemma [simp]: " p \<nuLinkL> \<bool> \<nuLinkR> x \<longleftrightarrow> (p = 1) = x" unfolding Refining_def by (simp add: NuBool_def)
lemma [\<nu>reason on \<open>\<nu>Equal \<bool> ?c ?eq\<close>]: "\<nu>Equal \<bool> (\<lambda>x y. True)  (=)" unfolding \<nu>Equal_def by auto
lemma [\<nu>reason on \<open>\<nu>Zero NuBool ?z\<close>]: "\<nu>Zero NuBool False" unfolding \<nu>Zero_def by simp

section \<open>Fix-length Array\<close>

datatype ('a,'len::len) fixlen_array = fixlen_array (dest_fixlen_array: "('a::field) list")

lemma fixlen_array_forall: "(All P) = (\<forall>l. P (fixlen_array l))" by (metis fixlen_array.exhaust)
lemma fixlen_array_exists: "(Ex P) = (\<exists>l. P (fixlen_array l))" by (metis fixlen_array.exhaust)

lemma fixlen_array_All: "(\<And>(x::('a::field, 'b::len) fixlen_array). PROP P x) \<equiv> (\<And>l. PROP P (fixlen_array l))" proof
  fix l assume \<open>\<And>x. PROP P x\<close>  then show \<open>PROP P (fixlen_array l)\<close> .
next fix x :: "('a::field, 'b::len) fixlen_array" assume \<open>\<And>l. PROP P (fixlen_array l)\<close>
  from \<open>PROP P (fixlen_array (dest_fixlen_array x))\<close> show \<open>PROP P x\<close> by simp
qed

subsection \<open>Lrep instantiations\<close>

subsubsection \<open>lrep\<close>

instantiation fixlen_array :: (field,len) field begin

definition llty_fixlen_array :: "('a,'b) fixlen_array itself \<Rightarrow> llty "
  where [simp, \<nu>reason]: "llty_fixlen_array _ = llty_array (llty TYPE('a)) LENGTH('b)"
definition deepize_fixlen_array :: " ('a,'b) fixlen_array \<Rightarrow> value "
  where "deepize_fixlen_array x = DM_array (map deepize (dest_fixlen_array x))"
definition shallowize_fixlen_array :: " value \<Rightarrow> ('a,'b) fixlen_array "
  where "shallowize_fixlen_array x = (case x of DM_array l \<Rightarrow> fixlen_array (map shallowize l))"

instance apply standard unfolding fixlen_array_All shallowize_fixlen_array_def deepize_fixlen_array_def by simp
end

subsubsection \<open>zero\<close>

instantiation fixlen_array :: ("{zero,field}",len) zero begin
definition zero_fixlen_array :: " ('a,'b) fixlen_array "
  where [simp]: "zero_fixlen_array = fixlen_array (replicate LENGTH('b) 0)"
instance by standard
end

subsubsection \<open>ceq\<close>

instantiation fixlen_array :: ("{ceq,field}",len) ceq begin

definition ceqable_fixlen_array :: " heap \<Rightarrow> ('a,'b) fixlen_array \<Rightarrow> ('a,'b) fixlen_array \<Rightarrow> bool "
  where "ceqable_fixlen_array heap x y = list_all2 (ceqable heap) (dest_fixlen_array x) (dest_fixlen_array y)"
definition ceq_fixlen_array :: " ('a,'b) fixlen_array \<Rightarrow> ('a,'b) fixlen_array \<Rightarrow> bool "
  where "ceq_fixlen_array x y = list_all2 ceq (dest_fixlen_array x) (dest_fixlen_array y)"

lemma [simp]: "ceqable heap (fixlen_array a) (fixlen_array b) = list_all2 (ceqable heap) a b"
  unfolding ceqable_fixlen_array_def by simp
lemma [simp]: "ceq (fixlen_array a) (fixlen_array b) = list_all2 ceq a b"
  unfolding ceq_fixlen_array_def by simp

instance proof
  fix x y z :: "('a,'b) fixlen_array" and h :: "heap"
  note list_all2_conv_all_nth[simp]
  show "ceqable h x y = ceqable h y x" by (cases x; cases y; simp) metis
  show "ceqable h x x \<Longrightarrow> ceq x x" by (cases x; simp) blast
  show "ceqable h x y \<Longrightarrow> ceq x y = ceq y x" by (cases x; cases y; simp) (metis ceq_sym)
  show "ceqable h x y \<Longrightarrow> ceqable h y z \<Longrightarrow> ceqable h x z \<Longrightarrow> ceq x y \<Longrightarrow> ceq y z \<Longrightarrow> ceq x z"
    by (cases x, cases y, cases z; simp) (metis ceq_trans)
qed
end

section \<open>Tuple\<close>

datatype 'a tuple = Tuple (dest_tuple: "('a::field)")

lemma tuple_exists[lrep_exps]: "Ex P \<longleftrightarrow> (\<exists>x. P (Tuple x))" by (metis tuple.exhaust)
lemma tuple_forall[lrep_exps]: "All P \<longleftrightarrow> (\<forall>x. P (Tuple x))" by (metis tuple.exhaust)

subsection \<open>Lrep instantiations\<close>

subsubsection \<open>lrep\<close>

instantiation tuple :: (field) lrep begin
definition llty_tuple :: " 'a tuple itself \<Rightarrow> llty " where [simp, \<nu>reason]: "llty_tuple _ = llty_tup (llty TYPE('a))"
definition deepize_tuple :: " 'a tuple \<Rightarrow> value " where "deepize_tuple x = DM_record (deepize (case_tuple id x))"
definition shallowize_tuple :: " value \<Rightarrow> 'a tuple " where "shallowize_tuple x = (case x of DM_record y \<Rightarrow> Tuple (shallowize y))"
instance apply standard using shallowize_tuple_def deepize_tuple_def by (auto split: tuple.split)
end

subsubsection \<open>zero\<close>

instantiation tuple :: ("{zero,field}") zero begin
definition zero_tuple :: " 'a tuple " where [simp]: "zero_tuple = Tuple 0"
instance by standard
end

subsubsection \<open>ceq\<close>

instantiation tuple :: ("{ceq,field}") ceq begin
definition ceqable_tuple :: " heap \<Rightarrow> 'a tuple \<Rightarrow> 'a tuple \<Rightarrow> bool " where "ceqable_tuple heap = rel_tuple (ceqable heap)"
definition ceq_tuple :: " 'a tuple \<Rightarrow> 'a tuple \<Rightarrow> bool " where "ceq_tuple = rel_tuple ceq"
lemma [simp]: "ceqable heap (Tuple a) (Tuple b) = ceqable heap a b" unfolding ceqable_tuple_def by simp
lemma [simp]: "ceq (Tuple a) (Tuple b) = ceq a b" unfolding ceq_tuple_def by simp
instance proof
  fix x y z :: " 'a tuple" and h :: "heap"
  show "ceqable h x y = ceqable h y x" by (cases x; cases y) simp
  show "ceqable h x x \<Longrightarrow> ceq x x" by (cases x) auto
  show "ceqable h x y \<Longrightarrow> ceq x y = ceq y x" by (cases x; cases y) simp
  show "ceqable h x y \<Longrightarrow> ceqable h y z \<Longrightarrow> ceqable h x z \<Longrightarrow> ceq x y \<Longrightarrow> ceq y z \<Longrightarrow> ceq x z" by (cases x, cases y, cases z) (simp, blast intro: ceq_trans)
qed
end

subsubsection \<open>miscellaneous\<close>

instantiation tuple :: (field) field begin instance by standard end
instantiation tuple :: (field) field_list begin instance by standard end

subsection \<open>Nu abstraction - `NuTuple`\<close>

definition NuTuple :: "(('a::field), 'b) \<nu> \<Rightarrow> ('a tuple, 'b) \<nu>" ("\<lbrace> _ \<rbrace>") where "\<lbrace> N \<rbrace> x = { Tuple p | p. p \<nuLinkL> N \<nuLinkR> x}"

lemma [simp]: "Tuple p \<nuLinkL> \<lbrace> N \<rbrace> \<nuLinkR> x \<longleftrightarrow> p \<nuLinkL> N \<nuLinkR> x" by (simp add: lrep_exps NuTuple_def Refining_def)
lemma [elim,\<nu>elim]: "x \<ratio> \<lbrace> N \<rbrace> \<Longrightarrow> (x \<ratio> N \<Longrightarrow> C) \<Longrightarrow> C" unfolding Inhabited_def tuple_exists by (simp add: nu_exps)

lemma [\<nu>reason]: "\<nu>Equal N P eq \<Longrightarrow> \<nu>Equal \<lbrace> N \<rbrace> P eq" unfolding \<nu>Equal_def tuple_forall by simp
lemma [\<nu>reason]: "\<nu>Zero N z \<Longrightarrow> \<nu>Zero \<lbrace> N \<rbrace> z" unfolding \<nu>Zero_def by simp

subsubsection \<open>Index\<close>

definition index_tuple :: "('a,'b,'x,'y) index \<Rightarrow> ('a::field tuple, 'b::field_list tuple, 'x, 'y) index"
  where "index_tuple idx = (case idx of Index g m \<Rightarrow> Index (g o dest_tuple) (map_tuple o m))"

lemma [\<nu>reason]: "\<^bold>i\<^bold>n\<^bold>d\<^bold>e\<^bold>x idx \<blangle> X \<^bold>@ a \<tycolon> A \<brangle> \<Longrightarrow> \<^bold>i\<^bold>n\<^bold>d\<^bold>e\<^bold>x index_tuple idx \<blangle> X \<^bold>@ a \<tycolon> \<lbrace> A \<rbrace> \<brangle>"
  unfolding \<nu>index_def index_tuple_def tuple_forall by (cases idx) (simp add: nu_exps)

lemma [\<nu>reason]:
    "\<^bold>i\<^bold>n\<^bold>d\<^bold>e\<^bold>x idx \<blangle> X \<^bold>@ a \<tycolon> A \<longmapsto> Y \<^bold>@ b \<tycolon> B\<brangle> \<Longrightarrow> \<^bold>i\<^bold>n\<^bold>d\<^bold>e\<^bold>x index_tuple idx \<blangle> X \<^bold>@ a \<tycolon> \<lbrace> A \<rbrace> \<longmapsto> Y \<^bold>@ b \<tycolon> \<lbrace> B \<rbrace> \<brangle>"
  unfolding \<nu>index_def index_tuple_def tuple_forall by (cases idx) (simp add: nu_exps)

(*section \<open>Function Pointer\<close>

subsubsection \<open>lrep\<close>

instantiation fun_addr ::  lrep begin
definition llty_fun_addr :: " fun_addr itself \<Rightarrow> llty " where [simp, \<nu>reason]: "llty_fun_addr _ = Lty_fun_addr"
definition deepize_fun_addr :: " fun_addr \<Rightarrow> value " where "deepize_fun_addr = DM_fun_addr"
definition shallowize_fun_addr :: " value \<Rightarrow> fun_addr " where "shallowize_fun_addr x = (case x of DM_fun_addr y \<Rightarrow> y)"
instance apply standard using shallowize_fun_addr_def deepize_fun_addr_def by auto
end

subsubsection \<open>zero\<close>

instantiation fun_addr :: zero begin
definition zero_fun_addr :: " fun_addr " where "zero_fun_addr = fun_addr_NULL"
instance by standard
end

subsubsection \<open>ceq\<close>

instantiation fun_addr :: ceq begin
definition ceqable_fun_addr :: " heap \<Rightarrow> fun_addr \<Rightarrow> fun_addr \<Rightarrow> bool " where [simp]: "ceqable_fun_addr _ _ _ = True"
definition ceq_fun_addr :: " fun_addr \<Rightarrow> fun_addr \<Rightarrow> bool " where [simp]: "ceq_fun_addr = (=)"
instance by standard auto
end

subsubsection \<open>miscellaneous\<close>

instantiation fun_addr :: field begin instance by standard end
instantiation fun_addr :: field_list begin instance by standard end

subsubsection \<open>\<nu>-abstractor\<close>

definition op_func_pointer :: "('a \<longmapsto> 'b) \<Rightarrow> ('r :: stack) \<longmapsto> (fun_addr \<times> 'r)"
  where "op_func_pointer f = (\<lambda>(h,r).
    if (\<exists>a. fun_table a = Some f)
    then Success (h, (SOME a. fun_table a = Some f), r)
    else PartialCorrect
)"

definition FunPtr :: "(heap \<times> 'ap::lrep,'ax) \<nu> \<Rightarrow> (heap \<times> 'bp::lrep,'bx) \<nu> \<Rightarrow> (fun_addr, 'ax \<longmapsto> 'bx) \<nu>"
  where "FunPtr A B fx  = {faddr. (\<exists>fp. fun_table faddr = Some fp \<and> (\<forall>a b. \<^bold>p\<^bold>r\<^bold>o\<^bold>c fp \<blangle> a \<tycolon> A \<longmapsto> b \<tycolon> B \<brangle>))}" *)

end


section "Unique Ids in loop programs"

theory unique_ids_loops
  imports program_proof_rules_loops
begin

text "We show that programs using the loop language are well formed with respect to unique identifiers."

text_raw \<open>\DefineSnippet{invocations_cannot_guess_ids_io}{\<close>
lemma invocations_cannot_guess_ids_io:
  assumes proc_initial: "\<And>proc store localKnown cmd impl.
    procedure progr proc = ((store, localKnown, cmd), impl) \<Longrightarrow>
      impl = toImpl
      \<and> localKnown = uniqueIds proc"
shows "invocations_cannot_guess_ids progr"
text_raw \<open>}%EndSnippet\<close>
  unfolding invocations_cannot_guess_ids_def
proof
  fix i

  have always_toImpl: "impl = toImpl"
    if "initialState progr ~~ tr \<leadsto>* S"
      and "currentProc S i \<triangleq> impl"
    for tr S impl
    using that
  proof (induct rule: steps_induct)
    case initial
    then show ?case
      by (simp add: initialState_def)
  next
    case (step S' tr a S'')
    then show ?case
      by (auto simp add: step.simps proc_initial prog_initial steps_do_not_change_prog split: if_splits)
  qed

  have localKnownTi: "localKnown = trace_inputs tr i"
    if "initialState progr ~~ tr \<leadsto>* S"
      and "localState S i \<triangleq> (store, localKnown, cmd)"
    for tr S store localKnown cmd
    using that
  proof (induct  arbitrary: store localKnown cmd rule: steps_induct)
    case initial
    then show ?case
      by (simp add: initialState_def)
  next
    case (step S' tr a S'')

    show ?case
    proof (cases "currentProc S' i \<triangleq> toImpl")
      case False
      hence "currentProc S' i = None"
        using always_toImpl exists_optionI step.steps by blast

      with step
      show "localKnown = trace_inputs (tr @ [a]) i"
        using proc_initial
        by (auto simp add: step.simps proc_initial prog_initial steps_do_not_change_prog trace_inputs_append trace_inputs_cons trace_inputs_empty trace_inputs_if_no_op split: if_splits,
            use proc_initial in \<open>blast+\<close>)
    next
      case True

      from this
      obtain store1 localKnown1 cmd1
        where ls: "localState S' i \<triangleq> (store1, localKnown1, cmd1)"
        using wf_localState_currentProc_m
        by (metis (no_types, hide_lams) exists_optionI option.distinct(1) prod_cases3 state_wellFormed_init step.steps wf_localState_currentProc)

      have IH: "localKnown1 = trace_inputs tr i"
        by (simp add: ls step.IH)

      show "localKnown = trace_inputs (tr @ [a]) i"
      proof (cases "fst a = i")
        case False
        with step
        show ?thesis
          by (auto simp add: step.simps trace_inputs_append trace_inputs_cons trace_inputs_empty)
      next
        case True

        from `S' ~~ a \<leadsto> S''`
        have "S' ~~ (i, get_action a)  \<leadsto> S''"
          using True by auto

        from this
        have  "localKnown = localKnown1 \<union> action_inputs (get_action a)"
          using ls[simplified IH] `currentProc S' i \<triangleq> toImpl` `localState S'' i \<triangleq> (store, localKnown, cmd)` IH
          by (auto simp add: step.simps elim!: toImpl.elims split: if_splits prod.splits)

        thus "localKnown = trace_inputs (tr @ [a]) i"
          by (simp add: IH True trace_inputs_append trace_inputs_cons trace_inputs_empty)
      qed
    qed
  qed

  show "invocation_cannot_guess_ids {} i (initialState progr)"
  proof (rule show_invocation_cannot_guess_ids)
    fix x tr a S'
    assume a0: "initialState progr ~~ tr @ [(i, a)] \<leadsto>* S'"
      and a1: "x \<in> action_outputs a"
      and a2: "x \<notin> {}"

    from a0
    obtain S where "initialState progr ~~ tr \<leadsto>* S" and "S ~~ (i, a) \<leadsto> S'"
      using steps_appendBack by blast

    show "x \<in> trace_inputs tr i"
    proof (cases "localState S i")
      case None
      then show ?thesis
        using `S ~~ (i, a) \<leadsto> S'` `x \<in> action_outputs a`
        by (auto simp add: step.simps)
    next
      case (Some ls)
      from this
      obtain store1 cmd1
        where ls: "localState S i \<triangleq> (store1, trace_inputs tr i, cmd1)"
        using \<open>initialState progr ~~ tr \<leadsto>* S\<close> localKnownTi
        by (metis prod_cases3)

      hence "currentProc S i \<triangleq> toImpl"
        by (smt \<open>initialState progr ~~ tr \<leadsto>* S\<close> always_toImpl not_Some_eq state_wellFormed_init wf_localState_currentProc wf_localState_currentProc_m)

      from `S ~~ (i, a) \<leadsto> S'`
        and `localState S i \<triangleq> (store1, trace_inputs tr i, cmd1)`
        and `currentProc S i \<triangleq> toImpl`
        and `x \<in> action_outputs a`
      show ?thesis
        by (cases cmd1, auto simp add: step.simps split: prod.splits if_splits)
    qed
  qed
qed

end


theory Std_to_Inca_compiler
  imports Std_to_Inca_simulation
    "VeriComp.Compiler"
begin

fun compile_instr where
  "compile_instr (Std.IPush d) = Inca.IPush d" |
  "compile_instr Std.IPop = Inca.IPop" |
  "compile_instr (Std.IGet n) = Inca.IGet n" |
  "compile_instr (Std.ISet n) = Inca.ISet n" |
  "compile_instr (Std.ILoad x) = Inca.ILoad x" |
  "compile_instr (Std.IStore x) = Inca.IStore x" |
  "compile_instr (Std.IOp op) = Inca.IOp op" |
  "compile_instr (Std.ICJump l\<^sub>t l\<^sub>f) = Inca.ICJump l\<^sub>t l\<^sub>f" |
  "compile_instr (Std.ICall f) = Inca.ICall f" |
  "compile_instr Std.IReturn = Inca.IReturn"

fun compile_fundef where
  "compile_fundef (Fundef [] _ _ _) = None" |
  "compile_fundef (Fundef bblocks ar ret locals) =
    (if distinct (map fst bblocks) then
      Some (Fundef (map_ran (\<lambda>_. map compile_instr) bblocks) ar ret locals)
    else
      None)"

context std_inca_simulation begin

lemma lambda_eq_eq[simp]: "(\<lambda>x y. y = x) = (=)"
  apply (intro ext)
  by blast

lemma norm_compile_instr:
  "norm_instr (compile_instr instr) = instr"
by (cases instr) auto

lemma rel_compile_fundef:
  assumes "compile_fundef fd1 = Some fd2"
  shows "rel_fundef (=) norm_eq fd1 fd2"
  using assms
proof (cases rule: compile_fundef.elims)
  case (2 x xs ar)
  then show ?thesis
    by (auto intro: list.rel_refl
        simp: const_eq_if_conv list.rel_map norm_compile_instr map_ran_def case_prod_beta
          rel_prod_sel)
qed simp_all

lemma rel_fundef_imp_fundef_ok_iff:
  assumes "rel_fundef (=) norm_eq fd1 fd2"
  shows "wf_fundef fd1 \<longleftrightarrow> wf_fundef fd2"
  unfolding wf_fundef_def
  using assms
  by (auto simp: list_all2_rel_prod_conv list.rel_eq elim: fundef.rel_cases)

lemma rel_fundefs_imp_wf_fundefs_iff:
  assumes rel_f_g: "rel_fundefs f g"
  shows "wf_fundefs f \<longleftrightarrow> wf_fundefs g"
proof (rule iffI)
  assume "wf_fundefs f" show "wf_fundefs g"
  proof (rule wf_fundefsI)
    fix x fd
    assume "g x = Some fd" thus "wf_fundef fd"
      using \<open>wf_fundefs f\<close>
      by (meson rel_f_g rel_fundef_imp_fundef_ok_iff rel_fundefs_Some2 wf_fundefs_imp_wf_fundef)
  qed
next
  show "wf_fundefs g \<Longrightarrow> wf_fundefs f"
    using rel_f_g
    by (meson rel_fundef_imp_fundef_ok_iff rel_fundefs_Some1 wf_fundefs_imp_wf_fundef wf_fundefsI)
qed

lemma compile_fundef_wf:
  assumes "compile_fundef fd = Some fd'"
  shows "wf_fundef fd'"
  using assms
proof (cases rule: compile_fundef.elims)
  case (2 x xs ar)
  then show ?thesis
    by (simp add: const_eq_if_conv wf_fundef_def map_ran_Cons_sel)
qed simp_all

definition compile_env where
  "compile_env e \<equiv>
    Some Sinca.Fenv.from_list \<diamondop> ap_map_list (ap_map_prod Some compile_fundef) (Fstd_to_list e)"

lemma compile_env_imp_rel_option:
  assumes "compile_env F1 = Some F2"
  shows "rel_option (\<lambda>fd1 fd2. compile_fundef fd1 = Some fd2) (Fstd_get F1 f) (Finca_get F2 f)"
proof -
  from assms(1) obtain xs where
    ap_map_list_F1: "ap_map_list (ap_map_prod Some compile_fundef) (Fstd_to_list F1) = Some xs" and
    F2_def: "F2 = Sinca.Fenv.from_list xs"
    by (auto simp add: compile_env_def ap_option_eq_Some_conv)

  show ?thesis
    unfolding F2_def Sinca.Fenv.from_list_correct[symmetric]
    unfolding Sinca.Fenv.from_list_correct
    unfolding Sstd.Fenv.to_list_correct[symmetric]
    using ap_map_list_F1
    by (simp add: ap_map_list_ap_map_prod_imp_rel_option_map_of)
qed

lemma Finca_get_compile:
  assumes compile_F1: "compile_env F1 = Some F2"
  shows "Finca_get F2 f = Fstd_get F1 f \<bind> compile_fundef"
  using compile_env_imp_rel_option[OF assms(1), of f]
  by (auto elim!: option.rel_cases)

lemma compile_env_rel_fundefs:
  assumes "compile_env F1 = Some F2"
  shows "rel_fundefs (Fstd_get F1) (Finca_get F2)"
  unfolding rel_fundefs_def
proof (rule allI)
  fix f
  show "rel_option (rel_fundef (=) norm_eq) (Fstd_get F1 f) (Finca_get F2 f)"
    using compile_env_imp_rel_option[OF assms(1), of f]
    by (auto elim!: option.rel_cases intro: rel_compile_fundef)
qed

lemma compile_env_imp_wf_fundefs2:
  assumes "compile_env F1 = Some F2"
  shows "wf_fundefs (Finca_get F2)"
  unfolding Finca_get_compile[OF assms(1)]
  by (auto simp: bind_eq_Some_conv intro!: wf_fundefsI intro: compile_fundef_wf)

fun compile where
  "compile (Prog F1 H f) = Some Prog \<diamondop> compile_env F1 \<diamondop> Some H \<diamondop> Some f"

theorem compile_load:
  assumes
    compile_p1: "compile p1 = Some p2" and
    load: "Sinca.load p2 s2"
  shows "\<exists>s1. Sstd.load p1 s1 \<and> match s1 s2"
proof (cases p1)
  case (Prog F1 H main)
  with assms(1) obtain F2 where
    compile_F1: "compile_env F1 = Some F2" and
    p2_def: "p2 = Prog F2 H main"
    by (auto simp: ap_option_eq_Some_conv)

  show ?thesis
    using assms(2) unfolding p2_def Sinca.load_def
  proof (cases _ _ _ s2 rule: load.cases)
    case (1 fd2)
    from 1 obtain fd1 where
      F1_main: "Fstd_get F1 main = Some fd1" and compile_fd1: "compile_fundef fd1 = Some fd2"
      using Finca_get_compile[OF compile_F1] by (auto simp: bind_eq_Some_conv)

    note rel_fd1_fd2 = rel_compile_fundef[OF compile_fd1]
    hence first_label_fd1_fd2: "fst (hd (body fd1)) = fst (hd (body fd2))"
      using 1
      by (auto elim!: fundef.rel_cases dest: list_all2_rel_prod_fst_hd)

    have bodies_fd1_fd2: "body fd1 = [] \<longleftrightarrow> body fd2 = []"
      using rel_fundef_body_length[OF rel_fd1_fd2]
      by auto

    let ?s1 = "State F1 H [allocate_frame main fd1 [] uninitialized]"

    show ?thesis
    proof (intro exI conjI)
      show "Sstd.load p1 ?s1"
        unfolding Prog
        using 1 F1_main rel_fd1_fd2 bodies_fd1_fd2
        by (auto simp: rel_fundef_arities Sstd.load_def intro!: load.intros)
    next
      note rel_F1_F2 = compile_env_rel_fundefs[OF compile_F1]
      moreover have "wf_fundefs (Fstd_get F1)"
      proof (rule wf_fundefsI)
        fix f fd1
        assume "Fstd_get F1 f = Some fd1"
        then show "wf_fundef fd1"
          by (metis (mono_tags, lifting) Finca_get_compile bind.bind_lunit compile_F1
              rel_F1_F2 compile_fundef_wf rel_fundef_imp_fundef_ok_iff
              rel_fundefs_Some1)
      qed
      ultimately show "match ?s1 s2"
        unfolding 1
        using rel_fd1_fd2
        by (auto simp: allocate_frame_def first_label_fd1_fd2 rel_fundef_locals
            intro: match.intros)
    qed
  qed
qed

sublocale std_to_inca_compiler:
  compiler where
    step1 = Sstd.step and final1 = "final Fstd_get Std.IReturn" and load1 = "Sstd.load" and
    step2 = Sinca.step and final2 = "final Finca_get Inca.IReturn" and load2 = "Sinca.load" and
    order = "\<lambda>_ _. False" and match = "\<lambda>_. match" and compile = compile
  using compile_load
  by unfold_locales  auto

section \<open>Completeness of compilation\<close>

lemma compile_fundef_complete:
  assumes "wf_fundef fd1"
  shows "\<exists>fd2. compile_fundef fd1 = Some fd2"
proof (cases fd1)
  case (Fundef bbs ar)
  then obtain bb bbs' where bbs_def: "bbs = bb # bbs'"
    using assms(1) by (cases bbs; auto)
  show ?thesis
    using assms(1)[THEN wf_fundef_distinct_basic_blocksD]
    unfolding Fundef bbs_def
    by simp
qed

lemma compile_env_complete:
  assumes wf_F1: "wf_fundefs (Fstd_get F1)"
  shows "\<exists>F2. compile_env F1 = Some F2"
proof -
  show ?thesis
    using wf_F1
    by (auto simp: compile_env_def ap_option_eq_Some_conv ap_map_prod_eq_Some_conv
        intro!: ex_ap_map_list_eq_SomeI Sstd.Fenv.to_list_list_allI compile_fundef_complete
        intro: wf_fundefs_imp_wf_fundef)
qed

theorem compile_complete:
  assumes
    wf_p1: "wf_prog Fstd_get p1" and load_p1: "Sstd.load p1 s1"
  shows "\<exists>p2 s2. compile p1 = Some p2 \<and> Sinca.load p2 s2 \<and> match s1 s2"
proof -
  from load_p1 obtain F1 H main fd1 where
    p1_def: "p1 = Prog F1 H main" and
    s1_def: "s1 = Global.state.State F1 H [allocate_frame main fd1 [] uninitialized]" and
    F1_main: "Fstd_get F1 main = Some fd1" and
    arity_fd1: "arity fd1 = 0"
    by (auto simp: Sstd.load_def elim: load.cases)

  obtain F2 where compile_F1: "compile_env F1 = Some F2"
    using wf_p1[unfolded p1_def wf_prog_def, simplified]
    using compile_env_complete[of F1]
    by auto

  obtain fd2 where
    F2_main: "Finca_get F2 main = Some fd2" and compile_fd1: "compile_fundef fd1 = Some fd2"
    using compile_env_imp_rel_option[OF compile_F1, of main]
    unfolding F1_main option_rel_Some1
    by auto

  hence rel_fd1_fd2: "rel_fundef (=) norm_eq fd1 fd2"
    using rel_compile_fundef by auto

  note wf_fd2 = compile_fundef_wf[OF compile_fd1]

  let ?s2 = "State F2 H [allocate_frame main fd2 [] uninitialized]"

  show ?thesis
  proof (intro exI conjI)
    show "compile p1 = Some (Prog F2 H main)"
      by (simp add: p1_def compile_F1)
  next
    show "Sinca.load (Prog F2 H main) ?s2"
      using F2_main arity_fd1
      using rel_fundef_arities[OF rel_fd1_fd2]
      using compile_fundef_wf[OF compile_fd1]
      by (auto simp: wf_fundef_def Sinca.load_def intro: load.intros)
  next
    have "fst (hd (body fd1)) = fst (hd (body fd2))"
      using rel_fd1_fd2 wf_fd2
      by (auto simp add: fundef.rel_sel wf_fundef_def list_all2_rel_prod_fst_hd)
    moreover have "wf_fundefs (Fstd_get F1)"
      using compile_env_imp_wf_fundefs2[OF compile_F1]
      using compile_env_rel_fundefs[OF compile_F1, THEN rel_fundefs_imp_wf_fundefs_iff]
      by simp
    ultimately show "match s1 ?s2"
      unfolding s1_def
      using rel_fd1_fd2 compile_env_rel_fundefs[OF compile_F1]
      by (auto simp: allocate_frame_def rel_fundef_locals intro!: match.intros)
  qed
qed

end

end


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

section {* Domain package examples *}

theory Domain_ex
imports HOLCF
begin

text {* Domain constructors are strict by default. *}

domain d1 = d1a | d1b "d1" "d1"

lemma "d1b\<cdot>\<bottom>\<cdot>y = \<bottom>" by simp

text {* Constructors can be made lazy using the @{text "lazy"} keyword. *}

domain d2 = d2a | d2b (lazy "d2")

lemma "d2b\<cdot>x \<noteq> \<bottom>" by simp

text {* Strict and lazy arguments may be mixed arbitrarily. *}

domain d3 = d3a | d3b (lazy "d2") "d2"

lemma "P (d3b\<cdot>x\<cdot>y = \<bottom>) \<longleftrightarrow> P (y = \<bottom>)" by simp

text {* Selectors can be used with strict or lazy constructor arguments. *}

domain d4 = d4a | d4b (lazy d4b_left :: "d2") (d4b_right :: "d2")

lemma "y \<noteq> \<bottom> \<Longrightarrow> d4b_left\<cdot>(d4b\<cdot>x\<cdot>y) = x" by simp

text {* Mixfix declarations can be given for data constructors. *}

domain d5 = d5a | d5b (lazy "d5") "d5" (infixl ":#:" 70)

lemma "d5a \<noteq> x :#: y :#: z" by simp

text {* Mixfix declarations can also be given for type constructors. *}

domain ('a, 'b) lazypair (infixl ":*:" 25) =
  lpair (lazy lfst :: 'a) (lazy lsnd :: 'b) (infixl ":*:" 75)

lemma "\<forall>p::('a :*: 'b). p \<sqsubseteq> lfst\<cdot>p :*: lsnd\<cdot>p"
by (rule allI, case_tac p, simp_all)

text {* Non-recursive constructor arguments can have arbitrary types. *}

domain ('a, 'b) d6 = d6 "int lift" "'a \<oplus> 'b u" (lazy "('a :*: 'b) \<times> ('b \<rightarrow> 'a)")

text {*
  Indirect recusion is allowed for sums, products, lifting, and the
  continuous function space.  However, the domain package does not
  generate an induction rule in terms of the constructors.
*}

domain 'a d7 = d7a "'a d7 \<oplus> int lift" | d7b "'a \<otimes> 'a d7" | d7c (lazy "'a d7 \<rightarrow> 'a")
  -- "Indirect recursion detected, skipping proofs of (co)induction rules"

text {* Note that @{text d7.induct} is absent. *}

text {*
  Indirect recursion is also allowed using previously-defined datatypes.
*}

domain 'a slist = SNil | SCons 'a "'a slist"

domain 'a stree = STip | SBranch "'a stree slist"

text {* Mutually-recursive datatypes can be defined using the @{text "and"} keyword. *}

domain d8 = d8a | d8b "d9" and d9 = d9a | d9b (lazy "d8")

text {* Non-regular recursion is not allowed. *}
(*
domain ('a, 'b) altlist = ANil | ACons 'a "('b, 'a) altlist"
  -- "illegal direct recursion with different arguments"
domain 'a nest = Nest1 'a | Nest2 "'a nest nest"
  -- "illegal direct recursion with different arguments"
*)

text {*
  Mutually-recursive datatypes must have all the same type arguments,
  not necessarily in the same order.
*}

domain ('a, 'b) list1 = Nil1 | Cons1 'a "('b, 'a) list2"
   and ('b, 'a) list2 = Nil2 | Cons2 'b "('a, 'b) list1"

text {* Induction rules for flat datatypes have no admissibility side-condition. *}

domain 'a flattree = Tip | Branch "'a flattree" "'a flattree"

lemma "\<lbrakk>P \<bottom>; P Tip; \<And>x y. \<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>; P x; P y\<rbrakk> \<Longrightarrow> P (Branch\<cdot>x\<cdot>y)\<rbrakk> \<Longrightarrow> P x"
by (rule flattree.induct) -- "no admissibility requirement"

text {* Trivial datatypes will produce a warning message. *}

domain triv = Triv triv triv
  -- "domain @{text Domain_ex.triv} is empty!"

lemma "(x::triv) = \<bottom>" by (induct x, simp_all)

text {* Lazy constructor arguments may have unpointed types. *}

domain natlist = nnil | ncons (lazy "nat discr") natlist

text {* Class constraints may be given for type parameters on the LHS. *}

domain ('a::predomain) box = Box (lazy 'a)

domain ('a::countable) stream = snil | scons (lazy "'a discr") "'a stream"

subsection {* Generated constants and theorems *}

domain 'a tree = Leaf (lazy 'a) | Node (left :: "'a tree") (right :: "'a tree")

lemmas tree_abs_bottom_iff =
  iso.abs_bottom_iff [OF iso.intro [OF tree.abs_iso tree.rep_iso]]

text {* Rules about ismorphism *}
term tree_rep
term tree_abs
thm tree.rep_iso
thm tree.abs_iso
thm tree.iso_rews

text {* Rules about constructors *}
term Leaf
term Node
thm Leaf_def Node_def
thm tree.nchotomy
thm tree.exhaust
thm tree.compacts
thm tree.con_rews
thm tree.dist_les
thm tree.dist_eqs
thm tree.inverts
thm tree.injects

text {* Rules about case combinator *}
term tree_case
thm tree.tree_case_def
thm tree.case_rews

text {* Rules about selectors *}
term left
term right
thm tree.sel_rews

text {* Rules about discriminators *}
term is_Leaf
term is_Node
thm tree.dis_rews

text {* Rules about monadic pattern match combinators *}
term match_Leaf
term match_Node
thm tree.match_rews

text {* Rules about take function *}
term tree_take
thm tree.take_def
thm tree.take_0
thm tree.take_Suc
thm tree.take_rews
thm tree.chain_take
thm tree.take_take
thm tree.deflation_take
thm tree.take_below
thm tree.take_lemma
thm tree.lub_take
thm tree.reach
thm tree.finite_induct

text {* Rules about finiteness predicate *}
term tree_finite
thm tree.finite_def
thm tree.finite (* only generated for flat datatypes *)

text {* Rules about bisimulation predicate *}
term tree_bisim
thm tree.bisim_def
thm tree.coinduct

text {* Induction rule *}
thm tree.induct

subsection {* Known bugs *}

text {* Declaring a mixfix with spaces causes some strange parse errors. *}
(*
domain xx = xx ("x y")
  -- "Inner syntax error: unexpected end of input"
*)

end