theory regShiftFifoModi imports paraGste1
begin
abbreviation rst::"expType" where
"rst \<equiv> IVar (Ident ''rst'')"

abbreviation push::"expType" where
"push \<equiv> IVar (Ident ''push'')"

abbreviation pop::"expType" where
"pop \<equiv> IVar (Ident ''pop'')"

abbreviation dataIn::"expType" where
"dataIn \<equiv> IVar (Ident ''dataIn'' )"

abbreviation LOW::"expType" where
"LOW \<equiv> Const (boolV False)"
abbreviation HIGH::"expType" where
" HIGH \<equiv> Const (boolV True)"

abbreviation emptyFifo::"expType" where
" emptyFifo \<equiv> IVar (Ident ''empty'' ) "

abbreviation tail::"expType" where
" tail \<equiv> IVar (Ident ''tail'' ) "

abbreviation head::"expType" where
" head \<equiv> IVar (Ident ''head'' ) "

abbreviation full::"expType" where
" full \<equiv> IVar (Ident ''full'' ) "

definition fullForm::"nat\<Rightarrow>formula" where [simp]:
" fullForm DEPTH\<equiv> eqn tail (Const (index DEPTH)) "

abbreviation mem::"nat \<Rightarrow> expType" where
"mem i \<equiv> IVar (Para (Ident ''mem'') i)"

type_synonym paraExpType="nat \<Rightarrow>expType"

abbreviation dataOut::"nat\<Rightarrow>expType" where
"dataOut DEPTH \<equiv> read (Ident ''mem'') DEPTH (IVar (Ident ''tail'' ))"

abbreviation rstForm::"formula" where
"rstForm  \<equiv>  (eqn rst HIGH)"

abbreviation emptyForm::"formula" where
"emptyForm  \<equiv>  (eqn emptyFifo HIGH)"

abbreviation pushForm::"formula" where
"pushForm \<equiv> andForm (andForm (eqn rst LOW) (eqn push HIGH)) (eqn pop LOW)"

abbreviation popForm::"formula" where
"popForm \<equiv> andForm (andForm (eqn rst LOW) (eqn push LOW)) (eqn pop HIGH)"

abbreviation nPushPopForm::"formula" where
"nPushPopForm \<equiv> andForm (andForm (eqn rst LOW) (eqn push LOW)) (eqn pop LOW)"

abbreviation pushDataForm::"nat \<Rightarrow>formula" where
" pushDataForm D \<equiv>andForm pushForm  (eqn dataIn (Const (index D)))"

abbreviation popDataForm::"nat\<Rightarrow>nat \<Rightarrow>formula" where
" popDataForm DEPTH D \<equiv>  (eqn (dataOut DEPTH) (Const (index D)))"

abbreviation nFullForm::"nat \<Rightarrow>formula" where
"nFullForm  DEPTH\<equiv>  neg (fullForm DEPTH)"

abbreviation nEmptyForm::"formula" where
"nEmptyForm \<equiv> neg emptyForm "

definition  vertexI::"node" where [simp]:
"vertexI \<equiv>Vertex  0"

(*DEPTH=LAST + 1*)
definition  vertexL::"nat \<Rightarrow> node list" where [simp]:
"vertexL LAST  \<equiv>  vertexI # (map (%i. Vertex  i) (down LAST))"

definition edgeL::"nat \<Rightarrow> edge list" where [simp]:
 "edgeL LAST \<equiv> [Edge vertexI ( Vertex 1)]
    @ [Edge  ( Vertex 1) ( Vertex 3)]
    @ [Edge  ( Vertex 1) ( Vertex 4)]

		@(map (%i.  ( Edge (Vertex ( 2*i+1 ))  (Vertex (  2*i+1 ))) ) (upt 0  (LAST+2) ))  (* self-loop*)
	  @(map (%i.  ( Edge (Vertex ( 2*i+2 ))  (Vertex (  2*i+2 ))) ) (upt 1  (LAST+2) ))  (* self-loop*)

		@(map (%i.   ( Edge (Vertex (2 * i + 1))  (Vertex (2 * i + 3))) ) ( upt 1 (LAST+1)))
		@(map (%i.   ( Edge (Vertex (2 * i + 1))  (Vertex (2 * i + 4))) ) ( upt 1 (LAST+1)))

		@(map (%i.   ( Edge (Vertex (2 * i + 3))  (Vertex (2 * i + 1))) ) (  upt 0 (LAST+1) ))
		@(map (%i.   ( Edge (Vertex (2 * i + 4))  (Vertex (2 * i + 2))) ) (  upt 1 (LAST+1) ))
		@[Edge  ( Vertex 4) ( Vertex 1)]
	 "

primrec node2Nat::"node \<Rightarrow> nat" where
"node2Nat (Vertex n) = n"

definition antOfRbFifo::"nat\<Rightarrow>edge\<Rightarrow>formula" where [simp]:
"antOfRbFifo  D  edge\<equiv>
  (let from=node2Nat (source edge) in
   let to=node2Nat (sink edge) in
   if (from = 0) then rstForm	else
   if (from=to) then nPushPopForm else
      (if ((from mod 2) =1) then
        (
          if ((from + 2)=to) then ( pushForm ) else
          if (from=(to + 2)) then popForm else
          pushDataForm D )
       else popForm))"

definition consOfRbFifo::"nat\<Rightarrow>nat\<Rightarrow>edge \<Rightarrow>formula" where  [simp]:
"consOfRbFifo   D LAST edge \<equiv>
(let from=node2Nat (source edge) in
 let to=node2Nat (sink edge) in
 if 	(((from mod 2) = 1) \<and> ((to mod 2) = 1)) then
    (if  from =1 then (andForm  emptyForm (nFullForm LAST))
     else if    (from = (2*LAST+3)) then (andForm nEmptyForm (fullForm LAST))
     else andForm nEmptyForm (nFullForm LAST))
 else if (from=4 \<and> to = 1) then popDataForm LAST D
 else if (from = (2*LAST+4)) then (andForm nEmptyForm (fullForm LAST))
 else if (from =1 )  then (andForm emptyForm (nFullForm LAST))
 else if (from \<noteq>0)   then (andForm nEmptyForm (nFullForm LAST))
 else chaos)"

definition rbFifoGsteSpec::" nat\<Rightarrow>nat\<Rightarrow>gsteSpec" where  [simp]:
"rbFifoGsteSpec LAST  data\<equiv>Graph  vertexI (edgeL  LAST ) (antOfRbFifo data )  (consOfRbFifo data  LAST)"

primrec applyPlusN::"expType\<Rightarrow>nat \<Rightarrow>expType" where
"applyPlusN e 0=e" |
"applyPlusN e (Suc N) = uif ''+'' [applyPlusN e N, Const (index 1)]"

definition tagFunOfRegShiftFifo:: " nat\<Rightarrow>nodeTagFuncList" where [simp]:
"tagFunOfRegShiftFifo DATA  n \<equiv>
  (let x=node2Nat n in
   let DataE=(Const (index DATA)) in
   if (x = 0) then [] else
    (if ((x mod 2) = 1) then
      (if (x =1) then
        [eqn tail (Const (index 0)), eqn  emptyFifo (Const (boolV True))]
       else [eqn tail (Const (index (x div 2 - 1 ))), eqn  emptyFifo (Const (boolV False))] )
    else
    (if (x = 2) then [] else
     [eqn tail (Const (index (x div 2 - 2 ))), eqn  emptyFifo (Const (boolV False)),
     eqn (IVar (Para (Ident ''mem'') 0)) DataE ]) )
     )

 "

 abbreviation branch1::"generalizeStatement" where
"branch1 \<equiv>
  (let S1=assign (Ident ''tail'',(Const (index 0))) in
   let S2=assign (Ident ''empty'',HIGH) in
   Parallel [S1,S2])"

abbreviation branch2::"nat\<Rightarrow>generalizeStatement" where
"branch2 LAST \<equiv>
  (let S1=map (\<lambda>i. assign ((Para (Ident ''mem'') i),
    iteForm (eqn (Const (index i)) (Const (index 0))) dataIn
    (read (Ident ''mem'')  LAST  (uif ''-'' [(Const (index i)), (Const (index 1))])))) (down LAST ) in
   let tailPlus=uif ''+'' [tail, (Const (index 1))] in
   let S2=assign (Ident ''tail'',iteForm (neg (eqn  emptyFifo HIGH)) tailPlus tail) in
   let S3=assign (Ident ''empty'',LOW) in
   Parallel ([S2,S3]@S1))"

abbreviation branch3::"generalizeStatement" where
"branch3 \<equiv>
  (let S1=Parallel [assign (Ident ''empty'',HIGH)] in
   let S2=Parallel [ assign (Ident ''tail'', uif ''-'' [tail, (Const (index 1))])] in
    If (eqn tail (Const (index 0))) S1 S2)"

definition tagFunOfRbfifio:: "nat \<Rightarrow> nat\<Rightarrow>nodeTagFuncList" where [simp]:
" tagFunOfRbfifio depth DATA  n \<equiv>
  (let x=node2Nat n in
   let DataE=(Const (index DATA)) in
   if (x = 0) then [] else
    (if ((x mod 2) = 1) then
      (if (x=1) then
        [eqn tail (Const (index 0)), eqn  emptyFifo (Const (boolV True))]
       else [eqn tail (applyPlusN head (x div 2 )), eqn  emptyFifo (Const (boolV False))] )
   else
   (if (x = (2)) then [] else
   [eqn tail (applyPlusN head ((x div 2) - 1)), eqn ( read (Ident ''mem'') depth tail) DataE ]) ))
 "
abbreviation shiftRegfifo::" nat\<Rightarrow>generalizeStatement" where
"shiftRegfifo  LAST\<equiv>
  caseStatement
     [(eqn rst HIGH, branch1),
      (andForm (eqn push HIGH) (neg (eqn tail (Const (index LAST)))), branch2 LAST),
      (andForm (eqn pop HIGH) (eqn emptyFifo LOW), branch3)]
   "

consts J::" interpretFunType"

axiomatization where axiomOnIAdd [simp,intro]:
"  J  ''+'' [index m, index (Suc 0)] = index (m + 1)"

axiomatization where axiomOnISub [simp,intro ]: "  J  ''-'' [index m, index 1] = index (m - 1)"

lemma consistencyOfRbfifo:
  assumes a:"0 < LAST "
  shows "consistent' (shiftRegfifo LAST ) (J ) (rbFifoGsteSpec LAST  data) (tagFunOfRegShiftFifo  data)"
  proof(unfold consistent'_def,rule allI,rule impI)
    fix e
    let ?G=" (rbFifoGsteSpec LAST  data)"
    let ?M="( shiftRegfifo  LAST )"
    let ?tag="(tagFunOfRegShiftFifo  data)"
    let ?P ="\<lambda>e.
    (let f=andListForm (?tag (sink e)) in
    let f'=andListForm (?tag (source e)) in
    tautlogy (implyForm (andForm f' (antOf ?G e)) (preCond1  f  ( ?M))) (J ))"
    assume a1:"e \<in> edgesOf (rbFifoGsteSpec LAST  data)"

    have "e=Edge vertexI ( Vertex 1) |
          e=Edge  ( Vertex 1) ( Vertex 3) |
          e=Edge  ( Vertex 1) ( Vertex 4)|
           (\<exists>i. 0\<le>i \<and> i\<le> LAST+1 \<and>  e=( Edge (Vertex ( 2*i+1 ))  (Vertex (  2*i+1 ))) )   |
            (\<exists>i. 1\<le>i \<and> i\<le> LAST +1\<and>  e=( Edge (Vertex ( 2*i+2 ))  (Vertex (  2*i+2 ))) ) |

           (\<exists>i. 1\<le>i \<and> i\<le> LAST  \<and> e=( Edge (Vertex (2 * i + 1))  (Vertex (2 * i + 3))) ) |
           (\<exists>i. 1\<le>i \<and> i\<le> LAST  \<and> e=( Edge (Vertex (2 * i + 1))  (Vertex (2 * i + 4))) )  |

           (\<exists>i. 0\<le>i \<and> i\<le> LAST  \<and>  e= ( Edge (Vertex (2 * i + 3))  (Vertex (2 * i + 1))) ) |
           (\<exists>i. 1\<le>i \<and> i\<le> LAST   \<and> e=( Edge (Vertex(2 * i + 4))  (Vertex(2 * i+2)))) |
            e=( Edge (Vertex 4) (Vertex 1))"
      apply(cut_tac a a1,auto)  done

    moreover
    {assume b1:"e=Edge vertexI ( Vertex 1)"
     have "?P e"
     apply(cut_tac b1, simp add:antOfRbFifo_def) done
     }
    moreover
    {assume b1:" (\<exists>i. 0\<le>i \<and> i\<le> LAST+1  \<and>  e=( Edge (Vertex (2* i + 1))  (Vertex (  2*i + 1))) )  " (is "\<exists>i. ?asm i")
     from b1 obtain i where b2:"?asm i" by auto
      have "?P e"
       apply(cut_tac b2, simp add:antOfRbFifo_def substNIl) done
    }
    moreover
    {assume b1:" (\<exists>i. 1\<le>i \<and> i\<le> LAST+1  \<and>  e=( Edge (Vertex (2* i + 2))  (Vertex (  2*i + 2))) )  " (is "\<exists>i. ?asm i")
     from b1 obtain i where b2:"?asm i" by auto
      have "?P e"
       apply(cut_tac b2, simp add:antOfRbFifo_def substNIl) done
    }
     moreover
    {assume b1:" e=Edge  ( Vertex 1) ( Vertex 3) "
       have "?P e"
        apply(cut_tac a b1,auto ) done
    }

     moreover
    {assume b1:" e=Edge  ( Vertex 1) ( Vertex 4) "
      let ?f="andForm (neg (eqn rst HIGH)) (andForm (eqn push HIGH) (neg (eqn tail (Const (index LAST )))) ) "

       have "?P e "
        apply(cut_tac a b1 ,auto) done
    }

    moreover
    {assume b1:" \<exists>i. 1\<le>i \<and> i\<le> LAST \<and> e=Edge  ( Vertex (2*i + 1)) ( Vertex (2*i + 3))"     (is "\<exists>i. ?Q i")
      from b1 obtain i where b1:"?Q i" by blast
      have b2:"i - 1 < LAST" by(cut_tac a b1,auto)
      have "?P e "
        apply(cut_tac  a b1 b2 ,auto simp add: antOfRbFifo_def assms ) done
     }

    moreover
    {assume b1:" \<exists>i. 1\<le>i \<and> i\<le> LAST \<and> e=Edge  ( Vertex (2*i + 1)) ( Vertex (2*i+4))    "(is "\<exists>i. ?Q i")
      from b1 obtain i where b1:"?Q i" by blast
      have b2:"i - 1 < LAST" by(cut_tac a b1,auto)
      have "?P e "
        by(cut_tac a b1 b2 ,auto simp add: antOfRbFifo_def assms)
     }

     moreover
    {assume b1:"\<exists>i. 0\<le>i \<and> i\<le> LAST \<and>  e=Edge  ( Vertex (2*i + 3)) ( Vertex (2*i + 1))   " (is "\<exists>i. ?Q i")
       from b1 obtain i where b1:"?Q i" by blast
       have "?P e "
       using  axiomOnISub  by(cut_tac  a b1 ,auto simp add: antOfRbFifo_def assms )
     }

     moreover
    {assume b1:"\<exists>i.  1\<le>i \<and> i\<le> LAST \<and> e=Edge  ( Vertex (2*i + 4)) ( Vertex (2*i +2))   " (is "\<exists>i. ?Q i")
      from b1 obtain i where b1:"?Q i" by blast

      have "?P e "
       using  axiomOnISub   apply(cut_tac  a b1  ,auto simp add: antOfRbFifo_def assms )
        done
     }
    moreover
    {assume b1:"e=Edge (Vertex 4) ( Vertex 1)"
     have "?P e"
     apply(cut_tac a b1,auto simp add:antOfRbFifo_def Let_def) done
     }
    ultimately show "?P e" by satx
  qed

lemma testAux[simp]:

shows "(expEval I e s =index i \<longrightarrow>
i \<le> LAST\<longrightarrow>expEval I (caseExp ((map (\<lambda>i. (eqn e (Const (index i)), mem i)) (down LAST)@S))) s
=expEval  I  (mem i) s) \<and>
(expEval I e s =index i \<longrightarrow>
 LAST < i\<longrightarrow>expEval I (caseExp ((map (\<lambda>i. (eqn e (Const (index i)), mem i)) (down LAST)@S))) s
=expEval  I  (caseExp S) s)"  (is "?P LAST")
proof(induct_tac LAST,auto )qed

lemma test[simp]:
shows "(expEval I e s =index i \<longrightarrow>
i \<le> LAST\<longrightarrow>expEval I (caseExp ((map (\<lambda>i. (eqn e (Const (index i)), mem i)) (down LAST)))) s
=expEval  I  (mem i) s)"
proof -
have a:"(expEval I e s =index i \<longrightarrow>
i \<le> LAST\<longrightarrow>expEval I (caseExp ((map (\<lambda>i. (eqn e (Const (index i)), mem i)) (down LAST)@[]))) s
=expEval  I  (mem i) s)"
apply(cut_tac testAux  [where S="[]"],blast)done
then show ?thesis by auto
qed

lemma instImply:
assumes a:"G=(rbFifoGsteSpec LAST  data)" and b:"0 < LAST "  and c:"tag=tagFunOfRegShiftFifo  data"
shows
"\<forall> e. e \<in>edgesOf G\<longrightarrow>
tautlogy (implyForm (andForm (antOf G e) (andListForm (tag (source e)))) (consOf G e)) I"
proof(rule allI,rule impI,simp,rule allI,rule impI)
  fix e s
  assume a1:"e \<in> edgesOf G " and a2:"
           formEval I (antOf G e) s \<and> formEval I (andListForm (tag (source e))) s"
  let ?P ="\<lambda>e. formEval I (consOf G e) s"
  have "e=Edge vertexI ( Vertex 1) |
          e=Edge  ( Vertex 1) ( Vertex 3) |
          e=Edge  ( Vertex 1) ( Vertex 4)|
           (\<exists>i. 0\<le>i \<and> i\<le> LAST+1 \<and>  e=( Edge (Vertex ( 2*i+1 ))  (Vertex (  2*i+1 ))) )   |
            (\<exists>i. 1\<le>i \<and> i\<le> LAST+1 \<and>  e=( Edge (Vertex ( 2*i+2 ))  (Vertex (  2*i+2 ))) ) |

           (\<exists>i. 1\<le>i \<and> i\<le> LAST  \<and> e=( Edge (Vertex (2 * i + 1))  (Vertex (2 * i + 3))) ) |
           (\<exists>i. 1\<le>i \<and> i\<le> LAST  \<and> e=( Edge (Vertex (2 * i + 1))  (Vertex (2 * i + 4))) )  |

           (\<exists>i. 0\<le>i \<and> i\<le> LAST  \<and>  e= ( Edge (Vertex (2 * i + 3))  (Vertex (2 * i + 1))) ) |
           (\<exists>i. 1\<le>i \<and> i\<le> LAST   \<and> e=( Edge (Vertex(2 * i + 4))  (Vertex(2 * i+2)))) |
            e=( Edge (Vertex 4) (Vertex 1))"
      apply(cut_tac a a1,auto)  done

    moreover
    {assume b1:"e=Edge vertexI ( Vertex 1)"
     have "?P e"
     apply(cut_tac a b1, auto simp add:antOfRbFifo_def)
 done
     }
    moreover
    {assume b1:" (\<exists>i. 0\<le>i \<and> i\<le> LAST+1  \<and>  e=( Edge (Vertex (2* i + 1))  (Vertex (  2*i + 1))) )  " (is "\<exists>i. ?asm i")
     from b1 obtain i where b2:"?asm i" by auto
      have "?P e"
       apply(cut_tac a b c a2 b2, auto) done
    }
    moreover
    {assume b1:" (\<exists>i. 1\<le>i \<and> i\<le> LAST+1  \<and>  e=( Edge (Vertex (2* i + 2))  (Vertex (  2*i + 2))) )  " (is "\<exists>i. ?asm i")
     from b1 obtain i where b2:"?asm i" by auto
      have "?P e"
       apply(cut_tac  a b c a2 b2,auto) done
    }
     moreover
    {assume b1:" e=Edge  ( Vertex 1) ( Vertex 3) "

       have "?P e"
        apply(cut_tac a b c a2 b1,auto ) done
    }

     moreover
    {assume b1:" e=Edge  ( Vertex 1) ( Vertex 4) "
       have "?P e "
        apply(cut_tac a b b1 c a2,auto simp add: antOfRbFifo_def ) done
    }

    moreover
    {assume b1:" \<exists>i. 1\<le>i \<and> i\<le> LAST \<and> e=Edge  ( Vertex (2*i + 1)) ( Vertex (2*i + 3))"     (is "\<exists>i. ?Q i")
      from b1 obtain i where b1:"?Q i" by blast
      have "?P e "
        by(cut_tac  a b c a2 b1 ,auto simp add: antOfRbFifo_def assms )
     }

    moreover
    {assume b1:" \<exists>i. 1\<le>i \<and> i\<le> LAST \<and> e=Edge  ( Vertex (2*i + 1)) ( Vertex (2*i+4))    "(is "\<exists>i. ?Q i")
      from b1 obtain i where b1:"?Q i" by blast
      have "?P e "
        by(cut_tac  a b c a2 b1 ,auto simp add: antOfRbFifo_def assms)
     }

     moreover
    {assume b1:"\<exists>i. 0\<le>i \<and> i\<le> LAST \<and>  e=Edge  ( Vertex (2*i + 3)) ( Vertex (2*i + 1))   " (is "\<exists>i. ?Q i")
       from b1 obtain i where b1:"?Q i" by blast
       have "?P e "
        by(cut_tac   a b c a2 b1 ,auto simp add: antOfRbFifo_def assms )
     }

     moreover
    {assume b1:"\<exists>i.  1\<le>i \<and> i\<le> LAST \<and> e=Edge  ( Vertex (2*i + 4)) ( Vertex (2*i+2 ))   " (is "\<exists>i. ?Q i")
      from b1 obtain i where b1:"?Q i" by blast
      have "?P e "
      by(cut_tac  a b c a2 b1 ,auto simp add: antOfRbFifo_def Let_def assms)

     }
    moreover
    {assume b1:"e=Edge (Vertex 4) ( Vertex 1)"
     have "?P e"
     apply(cut_tac  a b c a2 b1 ,auto) done
     }
    ultimately show "?P e" by satx
 qed

lemma main:
assumes a:"G=(rbFifoGsteSpec LAST  data)" and b:"0 < LAST "
and c:"tag=tagFunOfRegShiftFifo  data" and
d:"M=(shiftRegfifo LAST )"
shows " circuitSatGsteSpec M G J "
proof(rule mainLemma)
have a1:"consistent' (shiftRegfifo LAST ) (J ) (rbFifoGsteSpec LAST  data) (tagFunOfRegShiftFifo  data)"
   using b by (rule   consistencyOfRbfifo)
from a c d this show "consistent' M   (J ) G tag"
  by simp
next
from a b c show "\<forall>e. e \<in> edgesOf G \<longrightarrow>
        tautlogy (implyForm (andForm (antOf G e) (andListForm (tag (source e)))) (consOf G e)) (J )"
apply(rule instImply) done
next
from a c show "tag (initOf G) = []"
apply auto done
qed
end


(*  Title:       Lambda-Free Higher-Order Terms
    Author:      Jasmin Blanchette <jasmin.blanchette at inria.fr>, 2016
    Maintainer:  Jasmin Blanchette <jasmin.blanchette at inria.fr>
*)

section \<open>Lambda-Free Higher-Order Terms\<close>

theory Lambda_Free_Term
imports Lambda_Free_Util
abbrevs ">s" = ">\<^sub>s"
  and ">h" = ">\<^sub>h\<^sub>d"
  and "\<le>\<ge>h" = "\<le>\<ge>\<^sub>h\<^sub>d"
begin

text \<open>
This theory defines \<open>\<lambda>\<close>-free higher-order terms and related locales.
\<close>

subsection \<open>Precedence on Symbols\<close>

locale gt_sym =
  fixes
    gt_sym :: "'s \<Rightarrow> 's \<Rightarrow> bool" (infix ">\<^sub>s" 50)
  assumes
    gt_sym_irrefl: "\<not> f >\<^sub>s f" and
    gt_sym_trans: "h >\<^sub>s g \<Longrightarrow> g >\<^sub>s f \<Longrightarrow> h >\<^sub>s f" and
    gt_sym_total: "f >\<^sub>s g \<or> g >\<^sub>s f \<or> g = f" and
    gt_sym_wf: "wfP (\<lambda>f g. g >\<^sub>s f)"
begin

lemma gt_sym_antisym: "f >\<^sub>s g \<Longrightarrow> \<not> g >\<^sub>s f"
  by (metis gt_sym_irrefl gt_sym_trans)

end

subsection \<open>Heads\<close>

datatype (plugins del: size) (syms_hd: 's, vars_hd: 'v) hd =
  is_Var: Var (var: 'v)
| Sym (sym: 's)

abbreviation is_Sym :: "('s, 'v) hd \<Rightarrow> bool" where
  "is_Sym \<zeta> \<equiv> \<not> is_Var \<zeta>"

lemma finite_vars_hd[simp]: "finite (vars_hd \<zeta>)"
  by (cases \<zeta>) auto

lemma finite_syms_hd[simp]: "finite (syms_hd \<zeta>)"
  by (cases \<zeta>) auto

subsection \<open>Terms\<close>

consts head0 :: 'a

datatype (syms: 's, vars: 'v) tm =
  is_Hd: Hd (head: "('s, 'v) hd")
| App ("fun": "('s, 'v) tm") (arg: "('s, 'v) tm")
where
  "head (App s _) = head0 s"
| "fun (Hd \<zeta>) = Hd \<zeta>"
| "arg (Hd \<zeta>) = Hd \<zeta>"

overloading head0 \<equiv> "head0 :: ('s, 'v) tm \<Rightarrow> ('s, 'v) hd"
begin

primrec head0 :: "('s, 'v) tm \<Rightarrow> ('s, 'v) hd" where
  "head0 (Hd \<zeta>) = \<zeta>"
| "head0 (App s _) = head0 s"

end

lemma head_App[simp]: "head (App s t) = head s"
  by (cases s) auto

declare tm.sel(2)[simp del]

lemma head_fun[simp]: "head (fun s) = head s"
  by (cases s) auto

abbreviation ground :: "('s, 'v) tm \<Rightarrow> bool" where
  "ground t \<equiv> vars t = {}"

abbreviation is_App :: "('s, 'v) tm \<Rightarrow> bool" where
  "is_App s \<equiv> \<not> is_Hd s"

lemma
  size_fun_lt: "is_App s \<Longrightarrow> size (fun s) < size s" and
  size_arg_lt: "is_App s \<Longrightarrow> size (arg s) < size s"
  by (cases s; simp)+

lemma
  finite_vars[simp]: "finite (vars s)" and
  finite_syms[simp]: "finite (syms s)"
  by (induct s) auto

lemma
  vars_head_subseteq: "vars_hd (head s) \<subseteq> vars s" and
  syms_head_subseteq: "syms_hd (head s) \<subseteq> syms s"
  by (induct s) auto

fun args :: "('s, 'v) tm \<Rightarrow> ('s, 'v) tm list" where
  "args (Hd _) = []"
| "args (App s t) = args s @ [t]"

lemma set_args_fun: "set (args (fun s)) \<subseteq> set (args s)"
  by (cases s) auto

lemma arg_in_args: "is_App s \<Longrightarrow> arg s \<in> set (args s)"
  by (cases s rule: tm.exhaust) auto

lemma
  vars_args_subseteq: "si \<in> set (args s) \<Longrightarrow> vars si \<subseteq> vars s" and
  syms_args_subseteq: "si \<in> set (args s) \<Longrightarrow> syms si \<subseteq> syms s"
  by (induct s) auto

lemma args_Nil_iff_is_Hd: "args s = [] \<longleftrightarrow> is_Hd s"
  by (cases s) auto

abbreviation num_args :: "('s, 'v) tm \<Rightarrow> nat" where
  "num_args s \<equiv> length (args s)"

lemma size_ge_num_args: "size s \<ge> num_args s"
  by (induct s) auto

lemma Hd_head_id: "num_args s = 0 \<Longrightarrow> Hd (head s) = s"
  by (metis args.cases args.simps(2) length_0_conv snoc_eq_iff_butlast tm.collapse(1) tm.disc(1))

lemma one_arg_imp_Hd: "num_args s = 1 \<Longrightarrow> s = App t u \<Longrightarrow> t = Hd (head t)"
  by (simp add: Hd_head_id)

lemma size_in_args: "s \<in> set (args t) \<Longrightarrow> size s < size t"
  by (induct t) auto

primrec apps :: "('s, 'v) tm \<Rightarrow> ('s, 'v) tm list \<Rightarrow> ('s, 'v) tm" where
  "apps s [] = s"
| "apps s (t # ts) = apps (App s t) ts"

lemma
  vars_apps[simp]: "vars (apps s ss) = vars s \<union> (\<Union>s \<in> set ss. vars s)" and
  syms_apps[simp]: "syms (apps s ss) = syms s \<union> (\<Union>s \<in> set ss. syms s)" and
  head_apps[simp]: "head (apps s ss) = head s" and
  args_apps[simp]: "args (apps s ss) = args s @ ss" and
  is_App_apps[simp]: "is_App (apps s ss) \<longleftrightarrow> args (apps s ss) \<noteq> []" and
  fun_apps_Nil[simp]: "fun (apps s []) = fun s" and
  fun_apps_Cons[simp]: "fun (apps (App s sa) ss) = apps s (butlast (sa # ss))" and
  arg_apps_Nil[simp]: "arg (apps s []) = arg s" and
  arg_apps_Cons[simp]: "arg (apps (App s sa) ss) = last (sa # ss)"
  by (induct ss arbitrary: s sa) (auto simp: args_Nil_iff_is_Hd)

lemma apps_append[simp]: "apps s (ss @ ts) = apps (apps s ss) ts"
  by (induct ss arbitrary: s ts) auto

lemma App_apps: "App (apps s ts) t = apps s (ts @ [t])"
  by simp

lemma tm_inject_apps[iff, induct_simp]: "apps (Hd \<zeta>) ss = apps (Hd \<xi>) ts \<longleftrightarrow> \<zeta> = \<xi> \<and> ss = ts"
  by (metis args_apps head_apps same_append_eq tm.sel(1))

lemma tm_collapse_apps[simp]: "apps (Hd (head s)) (args s) = s"
  by (induct s) auto

lemma tm_expand_apps: "head s = head t \<Longrightarrow> args s = args t \<Longrightarrow> s = t"
  by (metis tm_collapse_apps)

lemma tm_exhaust_apps_sel[case_names apps]: "(s = apps (Hd (head s)) (args s) \<Longrightarrow> P) \<Longrightarrow> P"
  by (atomize_elim, induct s) auto

lemma tm_induct_apps[case_names apps]:
  assumes "\<And>\<zeta> ss. (\<And>s. s \<in> set ss \<Longrightarrow> P s) \<Longrightarrow> P (apps (Hd \<zeta>) ss)"
  shows "P s"
  using assms
  by (induct s taking: size rule: measure_induct_rule) (metis size_in_args tm_collapse_apps)

lemma
  ground_fun: "ground s \<Longrightarrow> ground (fun s)" and
  ground_arg: "ground s \<Longrightarrow> ground (arg s)"
  by (induct s) auto

lemma ground_head: "ground s \<Longrightarrow> is_Sym (head s)"
  by (cases s rule: tm_exhaust_apps) (auto simp: is_Var_def)

lemma ground_args: "t \<in> set (args s) \<Longrightarrow> ground s \<Longrightarrow> ground t"
  by (induct s rule: tm_induct_apps) auto

primrec vars_mset :: "('s, 'v) tm \<Rightarrow> 'v multiset" where
  "vars_mset (Hd \<zeta>) = mset_set (vars_hd \<zeta>)"
| "vars_mset (App s t) = vars_mset s + vars_mset t"

lemma set_vars_mset[simp]: "set_mset (vars_mset t) = vars t"
  by (induct t) auto

lemma vars_mset_empty_iff[iff]: "vars_mset s = {#} \<longleftrightarrow> ground s"
  by (induct s) (auto simp: mset_set_empty_iff)

lemma vars_mset_fun[intro]: "vars_mset (fun t) \<subseteq># vars_mset t"
  by (cases t) auto

lemma vars_mset_arg[intro]: "vars_mset (arg t) \<subseteq># vars_mset t"
  by (cases t) auto

subsection \<open>hsize\<close>

text \<open>The hsize of a term is the number of heads (Syms or Vars) in the term.\<close>

primrec hsize :: "('s, 'v) tm \<Rightarrow> nat" where
  "hsize (Hd \<zeta>) = 1"
| "hsize (App s t) = hsize s + hsize t"

lemma hsize_size: "hsize t * 2 = size t + 1"
  by (induct t) auto

lemma hsize_pos[simp]: "hsize t > 0"
  by (induction t; simp)

lemma hsize_fun_lt: "is_App s \<Longrightarrow> hsize (fun s) < hsize s"
  by (cases s; simp)

lemma hsize_arg_lt: "is_App s \<Longrightarrow> hsize (arg s) < hsize s"
  by (cases s; simp)

lemma hsize_ge_num_args: "hsize s \<ge> hsize s"
  by (induct s) auto

lemma hsize_in_args: "s \<in> set (args t) \<Longrightarrow> hsize s < hsize t"
  by (induct t) auto

lemma hsize_apps: "hsize (apps t ts) = hsize t + sum_list (map hsize ts)"
  by (induct ts arbitrary:t; simp)

lemma hsize_args: "1 + sum_list (map hsize (args t)) = hsize t"
  by (metis hsize.simps(1) hsize_apps tm_collapse_apps)

subsection \<open>Substitutions\<close>

primrec subst :: "('v \<Rightarrow> ('s, 'v) tm) \<Rightarrow> ('s, 'v) tm \<Rightarrow> ('s, 'v) tm" where
  "subst \<rho> (Hd \<zeta>) = (case \<zeta> of Var x \<Rightarrow> \<rho> x | Sym f \<Rightarrow> Hd (Sym f))"
| "subst \<rho> (App s t) = App (subst \<rho> s) (subst \<rho> t)"

lemma subst_apps[simp]: "subst \<rho> (apps s ts) = apps (subst \<rho> s) (map (subst \<rho>) ts)"
  by (induct ts arbitrary: s) auto

lemma head_subst[simp]: "head (subst \<rho> s) = head (subst \<rho> (Hd (head s)))"
  by (cases s rule: tm_exhaust_apps) (auto split: hd.split)

lemma ground_imp_subst_iden: "ground s \<Longrightarrow> subst \<rho> s = s"
  by (induct s) (auto split: hd.split)

lemma vars_mset_subst[simp]: "vars_mset (subst \<rho> s) = (\<Union># {#vars_mset (\<rho> x). x \<in># vars_mset s#})"
proof (induct s)
  case (Hd \<zeta>)
  show ?case
    by (cases \<zeta>) auto
qed auto

lemma vars_mset_subst_subseteq:
  "vars_mset t \<supseteq># vars_mset s \<Longrightarrow> vars_mset (subst \<rho> t) \<supseteq># vars_mset (subst \<rho> s)"
  unfolding vars_mset_subst
  by (metis (no_types) add_diff_cancel_right' diff_subset_eq_self image_mset_union sum_mset.union
    subset_mset.add_diff_inverse)

lemma vars_subst_subseteq: "vars t \<supseteq> vars s \<Longrightarrow> vars (subst \<rho> t) \<supseteq> vars (subst \<rho> s)"
  unfolding set_vars_mset[symmetric] vars_mset_subst by auto

subsection \<open>Subterms\<close>

inductive sub :: "('s, 'v) tm \<Rightarrow> ('s, 'v) tm \<Rightarrow> bool" where
  sub_refl: "sub s s"
| sub_fun: "sub s t \<Longrightarrow> sub s (App u t)"
| sub_arg: "sub s t \<Longrightarrow> sub s (App t u)"

inductive_cases sub_HdE[simplified, elim]: "sub s (Hd \<xi>)"
inductive_cases sub_AppE[simplified, elim]: "sub s (App t u)"
inductive_cases sub_Hd_HdE[simplified, elim]: "sub (Hd \<zeta>) (Hd \<xi>)"
inductive_cases sub_Hd_AppE[simplified, elim]: "sub (Hd \<zeta>) (App t u)"

lemma in_vars_imp_sub: "x \<in> vars s \<longleftrightarrow> sub (Hd (Var x)) s"
  by induct (auto intro: sub.intros elim: hd.set_cases(2))

lemma sub_args: "s \<in> set (args t) \<Longrightarrow> sub s t"
  by (induct t) (auto intro: sub.intros)

lemma sub_size: "sub s t \<Longrightarrow> size s \<le> size t"
  by induct auto

lemma sub_subst: "sub s t \<Longrightarrow> sub (subst \<rho> s) (subst \<rho> t)"
proof (induct t)
  case (Hd \<zeta>)
  thus ?case
    by (cases \<zeta>; blast intro: sub.intros)
qed (auto intro: sub.intros del: sub_AppE elim!: sub_AppE)

abbreviation proper_sub :: "('s, 'v) tm \<Rightarrow> ('s, 'v) tm \<Rightarrow> bool" where
  "proper_sub s t \<equiv> sub s t \<and> s \<noteq> t"

lemma proper_sub_Hd[simp]: "\<not> proper_sub s (Hd \<zeta>)"
  using sub.cases by blast

lemma proper_sub_subst:
  assumes psub: "proper_sub s t"
  shows "proper_sub (subst \<rho> s) (subst \<rho> t)"
proof (cases t)
  case Hd
  thus ?thesis
    using psub by simp
next
  case t: (App t1 t2)
  have "sub s t1 \<or> sub s t2"
    using t psub by blast
  hence "sub (subst \<rho> s) (subst \<rho> t1) \<or> sub (subst \<rho> s) (subst \<rho> t2)"
    using sub_subst by blast
  thus ?thesis
    unfolding t by (auto intro: sub.intros dest: sub_size)
qed

subsection \<open>Maximum Arities\<close>

locale arity =
  fixes
    arity_sym :: "'s \<Rightarrow> enat" and
    arity_var :: "'v \<Rightarrow> enat"
begin

primrec arity_hd :: "('s, 'v) hd \<Rightarrow> enat" where
  "arity_hd (Var x) = arity_var x"
| "arity_hd (Sym f) = arity_sym f"

definition arity :: "('s, 'v) tm \<Rightarrow> enat" where
  "arity s = arity_hd (head s) - num_args s"

lemma arity_simps[simp]:
  "arity (Hd \<zeta>) = arity_hd \<zeta>"
  "arity (App s t) = arity s - 1"
  by (auto simp: arity_def enat_diff_diff_eq add.commute eSuc_enat plus_1_eSuc(1))

lemma arity_apps[simp]: "arity (apps s ts) = arity s - length ts"
proof (induct ts arbitrary: s)
  case (Cons t ts)
  thus ?case
    by (case_tac "arity s"; simp add: one_enat_def)
qed simp

inductive wary :: "('s, 'v) tm \<Rightarrow> bool" where
  wary_Hd[intro]: "wary (Hd \<zeta>)"
| wary_App[intro]: "wary s \<Longrightarrow> wary t \<Longrightarrow> num_args s < arity_hd (head s) \<Longrightarrow> wary (App s t)"

inductive_cases wary_HdE: "wary (Hd \<zeta>)"
inductive_cases wary_AppE: "wary (App s t)"
inductive_cases wary_binaryE[simplified]: "wary (App (App s t) u)"

lemma wary_fun[intro]: "wary t \<Longrightarrow> wary (fun t)"
  by (cases t) (auto elim: wary.cases)

lemma wary_arg[intro]: "wary t \<Longrightarrow> wary (arg t)"
  by (cases t) (auto elim: wary.cases)

lemma wary_args: "s \<in> set (args t) \<Longrightarrow> wary t \<Longrightarrow> wary s"
  by (induct t arbitrary: s, simp)
   (metis Un_iff args.simps(2) wary.cases insert_iff length_pos_if_in_set
      less_numeral_extra(3) list.set(2) list.size(3) set_append tm.distinct(1) tm.inject(2))

lemma wary_inf_ary: "(\<And>\<zeta>. arity_hd \<zeta> = \<infinity>) \<Longrightarrow> wary s"
  by induct auto

lemma wary_num_args_le_arity_head: "wary s \<Longrightarrow> num_args s \<le> arity_hd (head s)"
  by (induct rule: wary.induct) (auto simp: zero_enat_def[symmetric] Suc_ile_eq)

lemma wary_apps:
  "wary s \<Longrightarrow> (\<And>sa. sa \<in> set ss \<Longrightarrow> wary sa) \<Longrightarrow> length ss \<le> arity s \<Longrightarrow> wary (apps s ss)"
proof (induct ss arbitrary: s)
  case (Cons sa ss)
  note ih = this(1) and wary_s = this(2) and wary_ss = this(3) and nargs_s_sa_ss = this(4)
  show ?case
    unfolding apps.simps
  proof (rule ih)
    have "wary sa"
      using wary_ss by simp
    moreover have " enat (num_args s) < arity_hd (head s)"
      by (metis (mono_tags) One_nat_def add.comm_neutral arity_def diff_add_zero enat_ord_simps(1)
        idiff_enat_enat less_one list.size(4) nargs_s_sa_ss not_add_less2
        order.not_eq_order_implies_strict wary_num_args_le_arity_head wary_s)
    ultimately show "wary (App s sa)"
      by (rule wary_App[OF wary_s])
  next
    show "\<And>sa. sa \<in> set ss \<Longrightarrow> wary sa"
      using wary_ss by simp
  next
    show "length ss \<le> arity (App s sa)"
    proof (cases "arity s")
      case enat
      thus ?thesis
        using nargs_s_sa_ss by (simp add: one_enat_def)
    qed simp
  qed
qed simp

lemma wary_cases_apps[consumes 1, case_names apps]:
  assumes
    wary_t: "wary t" and
    apps: "\<And>\<zeta> ss. t = apps (Hd \<zeta>) ss \<Longrightarrow> (\<And>sa. sa \<in> set ss \<Longrightarrow> wary sa) \<Longrightarrow> length ss \<le> arity_hd \<zeta> \<Longrightarrow> P"
  shows P
  using apps
proof (atomize_elim, cases t rule: tm_exhaust_apps)
  case t: (apps \<zeta> ss)
  show "\<exists>\<zeta> ss. t = apps (Hd \<zeta>) ss \<and> (\<forall>sa. sa \<in> set ss \<longrightarrow> wary sa) \<and> enat (length ss) \<le> arity_hd \<zeta>"
    by (rule exI[of _ \<zeta>], rule exI[of _ ss])
      (auto simp: t wary_args[OF _ wary_t] wary_num_args_le_arity_head[OF wary_t, unfolded t, simplified])
qed

lemma arity_hd_head: "wary s \<Longrightarrow> arity_hd (head s) = arity s + num_args s"
  by (simp add: arity_def enat_sub_add_same wary_num_args_le_arity_head)

lemma arity_head_ge: "arity_hd (head s) \<ge> arity s"
  by (induct s) (auto intro: enat_le_imp_minus_le)

inductive wary_fo :: "('s, 'v) tm \<Rightarrow> bool" where
  wary_foI[intro]: "is_Hd s \<or> is_Sym (head s) \<Longrightarrow> length (args s) = arity_hd (head s) \<Longrightarrow>
    (\<forall>t \<in> set (args s). wary_fo t) \<Longrightarrow> wary_fo s"

lemma wary_fo_args: "s \<in> set (args t) \<Longrightarrow> wary_fo t \<Longrightarrow> wary_fo s"
  by (induct t arbitrary: s rule: tm_induct_apps, simp)
    (metis args.simps(1) args_apps self_append_conv2 wary_fo.cases)

lemma wary_fo_arg: "wary_fo (App s t) \<Longrightarrow> wary_fo t"
  by (erule wary_fo.cases) auto

end

subsection \<open>Potential Heads of Ground Instances of Variables\<close>

locale ground_heads = gt_sym "(>\<^sub>s)" + arity arity_sym arity_var
    for
      gt_sym :: "'s \<Rightarrow> 's \<Rightarrow> bool" (infix ">\<^sub>s" 50) and
      arity_sym :: "'s \<Rightarrow> enat" and
      arity_var :: "'v \<Rightarrow> enat" +
  fixes
    ground_heads_var :: "'v \<Rightarrow> 's set"
  assumes
    ground_heads_var_arity: "f \<in> ground_heads_var x \<Longrightarrow> arity_sym f \<ge> arity_var x" and
    ground_heads_var_nonempty: "ground_heads_var x \<noteq> {}"
begin

primrec ground_heads :: "('s, 'v) hd \<Rightarrow> 's set" where
  "ground_heads (Var x) = ground_heads_var x"
| "ground_heads (Sym f) = {f}"

lemma ground_heads_nonempty[simp]: "ground_heads \<zeta> \<noteq> {}"
  by (cases \<zeta>) (auto simp: ground_heads_var_nonempty)

lemma sym_in_ground_heads: "is_Sym \<zeta> \<Longrightarrow> sym \<zeta> \<in> ground_heads \<zeta>"
  by (metis ground_heads.simps(2) hd.collapse(2) hd.set_sel(1) hd.simps(16))

lemma some_ground_head_arity: "arity_sym (SOME f. f \<in> ground_heads (Var x)) \<ge> arity_var x"
  by (simp add: ground_heads_var_arity ground_heads_var_nonempty some_in_eq)

definition wary_subst :: "('v \<Rightarrow> ('s, 'v) tm) \<Rightarrow> bool" where
  "wary_subst \<rho> \<longleftrightarrow>
   (\<forall>x. wary (\<rho> x) \<and> arity (\<rho> x) \<ge> arity_var x \<and> ground_heads (head (\<rho> x)) \<subseteq> ground_heads_var x)"

definition strict_wary_subst :: "('v \<Rightarrow> ('s, 'v) tm) \<Rightarrow> bool" where
  "strict_wary_subst \<rho> \<longleftrightarrow>
   (\<forall>x. wary (\<rho> x) \<and> arity (\<rho> x) \<in> {arity_var x, \<infinity>}
    \<and> ground_heads (head (\<rho> x)) \<subseteq> ground_heads_var x)"

lemma strict_imp_wary_subst: "strict_wary_subst \<rho> \<Longrightarrow> wary_subst \<rho>"
  unfolding strict_wary_subst_def wary_subst_def using eq_iff by force

lemma wary_subst_wary:
  assumes wary_\<rho>: "wary_subst \<rho>" and wary_s: "wary s"
  shows "wary (subst \<rho> s)"
  using wary_s
proof (induct s rule: tm.induct)
  case (App s t)
  note wary_st = this(3)
  from wary_st have wary_s: "wary s"
    by (rule wary_AppE)
  from wary_st have wary_t: "wary t"
    by (rule wary_AppE)
  from wary_st have nargs_s_lt: "num_args s < arity_hd (head s)"
    by (rule wary_AppE)

  note wary_\<rho>s = App(1)[OF wary_s]
  note wary_\<rho>t = App(2)[OF wary_t]

  note wary_\<rho>x = wary_\<rho>[unfolded wary_subst_def, rule_format, THEN conjunct1]
  note ary_\<rho>x = wary_\<rho>[unfolded wary_subst_def, rule_format, THEN conjunct2]

  have "num_args (\<rho> x) + num_args s < arity_hd (head (\<rho> x))" if hd_s: "head s = Var x" for x
  proof -
    have ary_hd_s: "arity_hd (head s) = arity_var x"
      using hd_s arity_hd.simps(1) by presburger
    hence "num_args s \<le> arity (\<rho> x)"
      by (metis (no_types) wary_num_args_le_arity_head ary_\<rho>x dual_order.trans wary_s)
    hence "num_args s + num_args (\<rho> x) \<le> arity_hd (head (\<rho> x))"
      by (metis (no_types) arity_hd_head[OF wary_\<rho>x] add_right_mono plus_enat_simps(1))
    thus ?thesis
      using ary_hd_s by (metis (no_types) add.commute add_diff_cancel_left' ary_\<rho>x arity_def
        idiff_enat_enat leD nargs_s_lt order.not_eq_order_implies_strict)
  qed
  hence nargs_\<rho>s: "num_args (subst \<rho> s) < arity_hd (head (subst \<rho> s))"
    using nargs_s_lt by (auto split: hd.split)

  show ?case
    by simp (rule wary_App[OF wary_\<rho>s wary_\<rho>t nargs_\<rho>s])
qed (auto simp: wary_\<rho>[unfolded wary_subst_def] split: hd.split)

lemmas strict_wary_subst_wary = wary_subst_wary[OF strict_imp_wary_subst]

lemma wary_subst_ground_heads:
  assumes wary_\<rho>: "wary_subst \<rho>"
  shows "ground_heads (head (subst \<rho> s)) \<subseteq> ground_heads (head s)"
proof (induct s rule: tm_induct_apps)
  case (apps \<zeta> ss)
  show ?case
  proof (cases \<zeta>)
    case x: (Var x)
    thus ?thesis
      using wary_\<rho> wary_subst_def x by auto
  qed auto
qed

lemmas strict_wary_subst_ground_heads = wary_subst_ground_heads[OF strict_imp_wary_subst]

definition grounding_\<rho> :: "'v \<Rightarrow> ('s, 'v) tm" where
  "grounding_\<rho> x = (let s = Hd (Sym (SOME f. f \<in> ground_heads_var x)) in
     apps s (replicate (the_enat (arity s - arity_var x)) s))"

lemma ground_grounding_\<rho>: "ground (subst grounding_\<rho> s)"
  by (induct s) (auto simp: Let_def grounding_\<rho>_def elim: hd.set_cases(2) split: hd.split)

lemma strict_wary_grounding_\<rho>: "strict_wary_subst grounding_\<rho>"
  unfolding strict_wary_subst_def
proof (intro allI conjI)
  fix x

  define f where "f = (SOME f. f \<in> ground_heads_var x)"
  define s :: "('s, 'v) tm" where "s = Hd (Sym f)"

  have wary_s: "wary s"
    unfolding s_def by (rule wary_Hd)
  have ary_s_ge_x: "arity s \<ge> arity_var x"
    unfolding s_def f_def using some_ground_head_arity by simp
  have gr\<rho>_x: "grounding_\<rho> x = apps s (replicate (the_enat (arity s - arity_var x)) s)"
    unfolding grounding_\<rho>_def Let_def f_def[symmetric] s_def[symmetric] by (rule refl)

  show "wary (grounding_\<rho> x)"
    unfolding gr\<rho>_x by (auto intro!: wary_s wary_apps[OF wary_s] enat_the_enat_minus_le)
  show "arity (grounding_\<rho> x) \<in> {arity_var x, \<infinity>}"
    unfolding gr\<rho>_x using ary_s_ge_x by (cases "arity s"; cases "arity_var x"; simp)
  show "ground_heads (head (grounding_\<rho> x)) \<subseteq> ground_heads_var x"
    unfolding gr\<rho>_x s_def f_def by (simp add: some_in_eq ground_heads_var_nonempty)
qed

lemmas wary_grounding_\<rho> = strict_wary_grounding_\<rho>[THEN strict_imp_wary_subst]

definition gt_hd :: "('s, 'v) hd \<Rightarrow> ('s, 'v) hd \<Rightarrow> bool" (infix ">\<^sub>h\<^sub>d" 50) where
  "\<xi> >\<^sub>h\<^sub>d \<zeta> \<longleftrightarrow> (\<forall>g \<in> ground_heads \<xi>. \<forall>f \<in> ground_heads \<zeta>. g >\<^sub>s f)"

definition comp_hd :: "('s, 'v) hd \<Rightarrow> ('s, 'v) hd \<Rightarrow> bool" (infix "\<le>\<ge>\<^sub>h\<^sub>d" 50) where
  "\<xi> \<le>\<ge>\<^sub>h\<^sub>d \<zeta> \<longleftrightarrow> \<xi> = \<zeta> \<or> \<xi> >\<^sub>h\<^sub>d \<zeta> \<or> \<zeta> >\<^sub>h\<^sub>d \<xi>"

lemma gt_hd_irrefl: "\<not> \<zeta> >\<^sub>h\<^sub>d \<zeta>"
  unfolding gt_hd_def using gt_sym_irrefl by (meson ex_in_conv ground_heads_nonempty)

lemma gt_hd_trans: "\<chi> >\<^sub>h\<^sub>d \<xi> \<Longrightarrow> \<xi> >\<^sub>h\<^sub>d \<zeta> \<Longrightarrow> \<chi> >\<^sub>h\<^sub>d \<zeta>"
  unfolding gt_hd_def using gt_sym_trans by (meson ex_in_conv ground_heads_nonempty)

lemma gt_sym_imp_hd: "g >\<^sub>s f \<Longrightarrow> Sym g >\<^sub>h\<^sub>d Sym f"
  unfolding gt_hd_def by simp

lemma not_comp_hd_imp_Var: "\<not> \<xi> \<le>\<ge>\<^sub>h\<^sub>d \<zeta> \<Longrightarrow> is_Var \<zeta> \<or> is_Var \<xi>"
  using gt_sym_total by (cases \<zeta>; cases \<xi>; auto simp: comp_hd_def gt_hd_def)

end

end


(*
    Author:      Salomon Sickert
    License:     BSD
*)

section \<open>Executable Translation from Mojmir to Rabin Automata\<close>

theory Mojmir_Rabin_Impl
  imports Main "../Mojmir_Rabin"
begin

\<comment> \<open>Ranking functions are stored as lists sorted ascending by the state rank\<close>

fun init :: "'a \<Rightarrow> 'a list"
where
  "init q\<^sub>0 = [q\<^sub>0]"

fun nxt :: "'b set \<Rightarrow> ('a, 'b) DTS \<Rightarrow> 'a \<Rightarrow> ('a list, 'b) DTS"
where
  "nxt \<Sigma> \<delta> q\<^sub>0 = (\<lambda>qs \<nu>. remdups_fwd ((filter (\<lambda>q. \<not>semi_mojmir_def.sink \<Sigma> \<delta> q\<^sub>0 q) (map (\<lambda>q. \<delta> q \<nu>) qs)) @ [q\<^sub>0]))"

\<comment> \<open>Recompute the rank from the list\<close>

fun rk :: "'a list \<Rightarrow> 'a \<Rightarrow> nat option"
where
  "rk qs q = (let i = index qs q in if i \<noteq> length qs then Some i else None)"

\<comment> \<open>Instead of computing the whole sets for fail, merge, and succeed, we define filters (a.k.a. characteristic functions)\<close>

fun fail_filt :: "'b set \<Rightarrow> ('a, 'b) DTS \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a list, 'b) transition \<Rightarrow> bool"
where
  "fail_filt \<Sigma> \<delta> q\<^sub>0 F (r, \<nu>, _) = (\<exists>q \<in> set r. let q' = \<delta> q \<nu> in (\<not>F q') \<and> semi_mojmir_def.sink \<Sigma> \<delta> q\<^sub>0 q')"

fun merge_filt :: "('a, 'b) DTS \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> ('a list, 'b) transition \<Rightarrow> bool"
where
  "merge_filt \<delta> q\<^sub>0 F i (r, \<nu>, _) = (\<exists>q \<in> set r. let q' = \<delta> q \<nu> in the (rk r q) < i \<and> \<not>F q' \<and> ((\<exists>q'' \<in> set r. q'' \<noteq> q \<and> \<delta> q'' \<nu> = q') \<or> q' = q\<^sub>0))"

fun succeed_filt :: "('a, 'b) DTS \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> ('a list, 'b) transition \<Rightarrow> bool"
where
  "succeed_filt \<delta> q\<^sub>0 F i (r, \<nu>, _) = (\<exists>q \<in> set r. let q' = \<delta> q \<nu> in rk r q = Some i  \<and> (\<not>F q \<or> q = q\<^sub>0) \<and> F q')"

subsubsection \<open>nxt Properties\<close>

lemma nxt_run_distinct:
  "distinct (run (nxt \<Sigma> \<Delta> q\<^sub>0) (init q\<^sub>0) w n)"
  by (cases n; simp del: remdups_fwd.simps; metis (no_types) remdups_fwd_distinct)

lemma nxt_run_reverse_step:
  fixes \<Sigma> \<delta> q\<^sub>0 w
  defines "r \<equiv> run (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0) w"
  assumes "q \<in> set (r (Suc n))"
  assumes "q \<noteq> q\<^sub>0"
  shows "\<exists>q' \<in> set (r n). \<delta> q' (w n) = q"
  using assms(2-3) unfolding r_def run.simps nxt.simps remdups_fwd_set by auto

lemma nxt_run_sink_free:
  "q \<in> set (run (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0) w n) \<Longrightarrow> \<not>semi_mojmir_def.sink \<Sigma> \<delta> q\<^sub>0 q"
  by (induction n) (simp_all add: semi_mojmir_def.sink_def del: remdups_fwd.simps, blast)

subsubsection \<open>rk Properties\<close>

lemma rk_bounded:
  "rk xs x = Some i \<Longrightarrow> i < length xs"
  by (simp add: Let_def) (metis index_conv_size_if_notin index_less_size_conv option.distinct(1) option.inject)

lemma rk_facts:
  "x \<in> set xs \<longleftrightarrow> rk xs x \<noteq> None"
  "x \<in> set xs \<longleftrightarrow> (\<exists>i. rk xs x = Some i)"
  using rk_bounded by (simp add: index_size_conv)+

lemma rk_split:
  "y \<notin> set xs \<Longrightarrow> rk (xs @ y # zs) y = Some (length xs)"
  by (induction xs) auto

lemma rk_split_card:
  "y \<notin> set xs \<Longrightarrow> distinct xs \<Longrightarrow> rk (xs @ y # zs) y = Some (card (set xs))"
  using rk_split by (metis length_remdups_card_conv remdups_id_iff_distinct)

lemma rk_split_card_takeWhile:
  assumes "x \<in> set xs"
  assumes "distinct xs"
  shows "rk xs x = Some (card (set (takeWhile (\<lambda>y. y \<noteq> x) xs)))"
proof -
  obtain ys zs where "xs = ys @ x # zs" and "x \<notin> set ys"
    using assms by (blast dest: split_list_first)
  moreover
  hence "distinct ys" and "ys = takeWhile (\<lambda>y. y \<noteq> x) xs"
    using takeWhile_foo assms by (simp, fast)
  ultimately
  show ?thesis
    using rk_split_card by metis
qed

lemma take_rk:
  assumes "distinct xs"
  shows "set (take i xs) = {q. \<exists>j < i. rk xs q = Some j}"
  (is "?rhs = ?lhs")
  using assms
proof (induction i arbitrary: xs)
  case (Suc i)
    thus ?case
    proof (induction xs)
      case (Cons x xs)
        have "set (take (Suc i) (x # xs)) = {x} \<union> set (take i xs)"
          by simp
        also
        have "\<dots> = {x} \<union> {q. \<exists>j < i. rk xs q = Some j}"
          using Cons by simp
        finally
        show ?case
          by force
    qed simp
qed simp

lemma drop_rk:
  assumes "distinct xs"
  shows "set (drop i xs) = {q. \<exists>j \<ge> i. rk xs q = Some j}"
proof -
  have "set xs = {q. \<exists>j. rk xs q = Some j}" (is "_ = ?U")
    using rk_facts(2)[of _ xs] by blast
  moreover
  have "?U = {q. \<exists>j \<ge> i. rk xs q = Some j} \<union> {q. \<exists>j < i. rk xs q = Some j}"
    and "{} = {q. \<exists>j \<ge> i. rk xs q = Some j} \<inter> {q. \<exists>j < i. rk xs q = Some j}"
    by auto
  moreover
  have "set xs = set (drop i xs) \<union> set (take i xs)"
    and "{} = set (drop i xs) \<inter> set (take i xs)"
    by (metis assms append_take_drop_id inf_sup_aci(1,5) distinct_append set_append)+
  ultimately
  show ?thesis
    using take_rk[OF assms] by blast
qed

subsubsection \<open>Relation to (Semi) Mojmir Automata\<close>

lemma (in semi_mojmir) nxt_run_configuration:
  defines "r \<equiv> run (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0) w"
  shows "q \<in> set (r n) \<longleftrightarrow> \<not>sink q \<and> configuration q n \<noteq> {}"
proof (induction n arbitrary: q)
  case (Suc n)
    thus ?case
    proof (cases "q \<noteq> q\<^sub>0")
      case True
        {
          assume "q \<in> set (r (Suc n))"
          hence "\<not> sink q"
            using r_def nxt_run_sink_free by metis
          moreover
          obtain q' where "q' \<in> set (r n)" and "\<delta> q' (w n) = q"
            using \<open>q \<in> set (r (Suc n))\<close> nxt_run_reverse_step[OF _ \<open>q \<noteq> q\<^sub>0\<close>] unfolding r_def by blast
          hence "configuration q (Suc n) \<noteq> {}" and "\<not> sink q"
            unfolding configuration_step_eq[OF True] Suc using True \<open>\<not> sink q\<close> by auto
        }
        moreover
        {
          assume "\<not>sink q" and "configuration q (Suc n) \<noteq> {}"
          then obtain q' where "configuration q' n \<noteq> {}" and "\<delta> q' (w n) = q"
            unfolding configuration_step_eq[OF True] by blast
          moreover
          hence "\<not>sink q'"
            using \<open>\<not>sink q\<close> sink_rev_step assms by blast
          ultimately
          have "q' \<in> set (r n)"
            unfolding Suc by blast
          hence "q \<in> set (r (Suc n))"
            using \<open>\<delta> q' (w n) = q\<close> \<open>\<not>sink q\<close>
            unfolding r_def run.simps set_filter comp_def remdups_fwd_set set_map set_append image_def
            unfolding r_def[symmetric] by auto
        }
        ultimately
        show ?thesis
          by blast
    qed (insert assms, auto simp add: r_def sink_def)
qed (insert assms, auto simp add: r_def sink_def)

lemma (in semi_mojmir) nxt_run_sorted:
  defines "r \<equiv> run (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0) w"
  shows "sorted (map (\<lambda>q. the (oldest_token q n)) (r n))"
proof (induction n)
  case (Suc n)
    let ?f_n = "\<lambda>q. the (oldest_token q n)"
    let ?f_Suc_n = "\<lambda>q. the (oldest_token q (Suc n))"
    let ?step = "filter (\<lambda>q. \<not>sink q) ((map (\<lambda>q. \<delta> q (w n)) (r n)) @ [q\<^sub>0])"

    have "\<And>q p qs ps. remdups_fwd ?step = qs @ q # p # ps \<Longrightarrow> ?f_Suc_n q \<le> ?f_Suc_n p"
    proof -
      fix q qs p ps
      assume "remdups_fwd ?step = qs @ q # p # ps"
      then obtain zs zs' zs'' where step_def: "?step = zs @ q # zs' @ p # zs''"
        and "remdups_fwd zs = qs"
        and "remdups_fwd_acc (set qs \<union> {q}) zs' = []"
        and "remdups_fwd_acc (set qs \<union> {q, p}) zs'' = ps"
        and "q \<notin> set zs"
        and "p \<notin> set zs \<union> {q}"
        unfolding remdups_fwd.simps remdups_fwd_split_exact_iff remdups_fwd_split_exact_iff[where ?ys = "[]", simplified] insert_commute
        by auto
      hence  "p \<notin> set zs \<union> set zs' \<union> {q}"
        and "q \<noteq> p" unfolding remdups_fwd_acc_empty[symmetric] by auto
      hence  "p \<notin> set zs \<union> set zs' \<union> set [q]"
        by simp
      hence "{q, p} \<subseteq> set ?step"
        using step_def by simp
      hence "\<not> sink q" and "\<not> sink p"
        unfolding set_map set_filter by blast+

      show "?f_Suc_n q \<le> ?f_Suc_n p"
      proof (cases "zs'' = []")
        case True
          hence "p = q\<^sub>0" and q_def: "filter (\<lambda>q. \<not>sink q) (map (\<lambda>q. \<delta> q (w n)) (r n)) = zs @ [q] @ zs'"
            using step_def unfolding sink_def by simp+
          hence "q\<^sub>0 \<notin> set (filter (\<lambda>q. \<not>sink q) (map (\<lambda>q. \<delta> q (w n)) (r n)))"
            using \<open>p \<notin> set zs \<union> set zs' \<union> {q}\<close>  unfolding \<open>p = q\<^sub>0\<close> sink_def by simp
          hence "q\<^sub>0 \<notin> (\<lambda>q. \<delta> q (w n)) ` {q'. configuration q' n \<noteq> {}}"
            using nxt_run_configuration bounded_w unfolding set_map set_filter r_def sink_def init.simps by blast
          hence "configuration p (Suc n) = {Suc n}" using assms
            unfolding \<open>p = q\<^sub>0\<close> using configuration_step_eq_q\<^sub>0 by blast
          hence "?f_Suc_n p = Suc n"
           using assms  by force
          moreover
          have "q \<in> (\<lambda>q. \<delta> q (w n)) ` set (r n)"
            using  \<open>p \<notin> set zs \<union> set zs' \<union> {q}\<close> image_set unfolding filter_map_split_iff[of "(\<lambda>q. \<not> sink q)" "\<lambda>q. \<delta> q (w n)"]
            by (metis (no_types, lifting) Un_insert_right \<open>p = q\<^sub>0\<close>  \<open>{q, p} \<subseteq> set [q\<leftarrow>map (\<lambda>q. \<delta> q (w n)) (r n) @ [q\<^sub>0] . \<not> sink q]\<close> append_Nil2 insert_iff insert_subset list.simps(15) mem_Collect_eq set_append set_filter)
          hence "q \<in> (\<lambda>q. \<delta> q (w n)) ` {q'. configuration q' n \<noteq> {}}"
            using nxt_run_configuration unfolding r_def by auto
          hence "configuration q (Suc n) \<noteq> {}"
            using configuration_step assms by blast
          hence "?f_Suc_n q \<le> Suc n"
            using assms oldest_token_bounded[of q "Suc n"]
            by (simp del: configuration.simps)
          ultimately
          show "?f_Suc_n q \<le> ?f_Suc_n p"
            by presburger
      next
        case False
          hence X: "filter (\<lambda>q. \<not>sink q) (map (\<lambda>q. \<delta> q (w n)) (r n)) = zs @ [q] @ zs' @ [p] @ butlast zs''"
            using step_def unfolding map_append filter_append sink_def apply simp
            by (metis (no_types, lifting) butlast.simps(2) list.distinct(1) butlast_append append_is_Nil_conv butlast_snoc) (* Slow *)
          obtain qs' sq' sp' ps' ps'' where r_def': "r n = qs' @ sq' @ ps' @ sp' @ ps''"
            and 1: "filter (\<lambda>q. \<not>sink q) (map (\<lambda>q. \<delta> q (w n)) qs') = zs"
            and 2: "filter (\<lambda>q. \<not>sink q) (map (\<lambda>q. \<delta> q (w n)) sq') = [q]"
            and 3: "filter (\<lambda>q. \<not>sink q) (map (\<lambda>q. \<delta> q (w n)) ps') = zs'"
            and "filter (\<lambda>q. \<not>sink q) (map (\<lambda>q. \<delta> q (w n)) sp') = [p]"
            and "filter (\<lambda>q. \<not>sink q) (map (\<lambda>q. \<delta> q (w n)) ps'') = butlast zs''"
            using X  unfolding filter_map_split_iff by (blast)
          hence 21: "Set.filter (\<lambda>q. \<not>sink q) ((\<lambda>q. \<delta> q (w n)) ` set sq') = {q}"
            and 41: "Set.filter (\<lambda>q. \<not>sink q) ((\<lambda>q. \<delta> q (w n)) ` set sp') = {p}"
            by (metis filter_set image_set list.set(1) list.simps(15))+
          from 21 obtain q' where "q' \<in> set sq'" and "\<not> sink q'" and "q = \<delta> q' (w n)"
            using sink_rev_step(2)[OF \<open>\<not> sink q\<close>, of _ n] by fastforce
          from 41 obtain p' where "p' \<in> set sp'" and "\<not> sink p'" and "p = \<delta> p' (w n)"
            using sink_rev_step(2)[OF \<open>\<not> sink p\<close>, of _ n] by fastforce
          from Suc have "?f_n q' \<le> ?f_n p'"
            unfolding r_def' map_append sorted_append set_append set_map using \<open>q' \<in> set sq'\<close> \<open>p' \<in> set sp'\<close> by auto
          moreover
          {
            have "oldest_token q' n \<noteq> None"
              using nxt_run_configuration option.distinct(1) r_def r_def'  \<open>q' \<in> set sq'\<close> \<open>p' \<in> set sp'\<close> set_append
              unfolding init.simps oldest_token.simps by (metis UnCI)
            moreover
            hence "oldest_token q (Suc n) \<noteq> None"
              using \<open>q = \<delta> q' (w n)\<close> by (metis oldest_token.simps option.distinct(1) configuration_step_non_empty)
            ultimately
            obtain x y where x_def: "oldest_token q' n = Some x"
              and y_def: "oldest_token q (Suc n) = Some y"
              by blast
            moreover
            hence "x \<le> n" and "token_run x n = q'"
              using oldest_token_bounded push_down_oldest_token_token_run assms by blast+
            moreover
            hence "token_run x (Suc n) = q"
              using \<open>q = \<delta> q' (w n)\<close> by (rule token_run_step)
            ultimately
            have "x \<ge> y"
              using oldest_token_monotonic_Suc assms by blast
            moreover
            {
              have "\<And>q''. q = \<delta> q'' (w n) \<Longrightarrow> q'' \<notin> set qs'"
                 using \<open>q \<notin> set zs\<close> unfolding \<open>filter (\<lambda>q. \<not>sink q) (map (\<lambda>q. \<delta> q (w n)) qs') = zs\<close>[symmetric] set_map set_filter apply simp using \<open>\<not> sink q\<close> by blast
              moreover
              {
                obtain us vs where 1: "map (\<lambda>q. \<delta> q (w n)) sq' = us @ [q] @ vs" and "\<forall>u\<in>set us. sink u" and "[] = [q\<leftarrow>vs . \<not> sink q]"
                   using \<open>filter (\<lambda>q. \<not>sink q) (map (\<lambda>q. \<delta> q (w n)) sq') = [q]\<close>   unfolding filter_eq_Cons_iff by auto
                moreover
                hence "\<And>q''. q'' \<in> (set us) \<union> (set vs) \<Longrightarrow> sink q''"
                  by (metis UnE filter_empty_conv)
                hence "q \<notin> (set us) \<union> (set vs)"
                  using \<open>\<not> sink q\<close> by blast
                ultimately
                have "\<And>q''. q'' \<in> (set sq' - {q'}) \<Longrightarrow> \<delta> q'' (w n) \<noteq> q"
                  using 1 \<open>q = \<delta> q' (w n)\<close> \<open>q' \<in> set sq'\<close> by (fastforce dest: split_list elim: map_splitE)
              }
              ultimately
              have "\<And>q''. q = \<delta> q'' (w n) \<Longrightarrow> configuration q'' n \<noteq> {} \<Longrightarrow> q'' \<in> set (ps' @ sp' @ ps'') \<or> q'' = q'"
                using nxt_run_configuration[of _ n] \<open>\<not> sink q\<close> sink_rev_step
                unfolding r_def'[unfolded r_def] set_append
                by blast
              moreover
              have "\<And>q''. q'' \<in> set (ps' @ sp' @ ps'') \<Longrightarrow> x \<le> ?f_n q''"
                using x_def using Suc unfolding r_def' map_append sorted_append set_append set_map  using \<open>q' \<in> set sq'\<close> \<open>p' \<in> set sp'\<close>
                apply (simp del: oldest_token.simps) by fastforce
              moreover
              have "\<And>q''. q'' = q' \<Longrightarrow> x \<le> ?f_n q''"
                using x_def by simp
              moreover
              have "\<And>q'' x. x \<in> configuration q'' n \<Longrightarrow> the (oldest_token q'' n) \<le> x"
               using assms by auto
              ultimately
              have "\<And>z. z \<in> \<Union>{configuration q' n |q'. q = \<delta> q' (w n)} \<Longrightarrow> x \<le> z"
                by fastforce
            }
            hence "\<And>z. z \<in> configuration q (Suc n) \<Longrightarrow> x \<le> z"
              unfolding configuration_step_eq_unified using \<open>x \<le> n\<close>
              by (cases "q = q\<^sub>0"; auto)
            hence "x \<le> y"
              using y_def Min.boundedI configuration_finite using push_down_oldest_token_configuration by presburger
            ultimately
            have "?f_n q' = ?f_Suc_n q"
              using x_def y_def by fastforce
          }
          moreover
          {
            have "oldest_token p' n \<noteq> None"
              using nxt_run_configuration oldest_token.simps option.distinct(1) r_def r_def'  \<open>q' \<in> set sq'\<close> \<open>p' \<in> set sp'\<close> set_append
              unfolding init.simps by (metis UnCI)
            moreover
            hence "oldest_token p (Suc n) \<noteq> None"
              using \<open>p = \<delta> p' (w n)\<close> by (metis oldest_token.simps option.distinct(1) configuration_step_non_empty)
            ultimately
            obtain x y where x_def: "oldest_token p' n = Some x"
              and y_def: "oldest_token p (Suc n) = Some y"
              by blast
            moreover
            hence "x \<le> n" and "token_run x n = p'"
              using oldest_token_bounded push_down_oldest_token_token_run assms by blast+
            moreover
            hence "token_run x (Suc n) = p"
              using \<open>p = \<delta> p' (w n)\<close> assms token_run_step by simp
            ultimately
            have "x \<ge> y"
              using oldest_token_monotonic_Suc assms by blast
            moreover
            {
              have "\<And>q''. p = \<delta> q'' (w n) \<Longrightarrow> q'' \<notin> set qs' \<union> set sq' \<union> set ps'"
                 using \<open>p \<notin> set zs \<union> set zs' \<union> set [q]\<close> \<open>\<not> sink p\<close> unfolding 1[symmetric] 2[symmetric] 3[symmetric] set_map set_filter by blast
              moreover
              {
                obtain us vs where 1: "map (\<lambda>q. \<delta> q (w n)) sp' = us @ [p] @ vs" and "\<forall>u\<in>set us. sink u" and "[] = [q\<leftarrow>vs . \<not> sink q]"
                   using \<open>filter (\<lambda>q. \<not>sink q) (map (\<lambda>q. \<delta> q (w n)) sp') = [p]\<close> unfolding filter_eq_Cons_iff by auto
                moreover
                hence "\<And>q''. q'' \<in> (set us) \<union> (set vs) \<Longrightarrow> sink q''"
                  by (metis UnE filter_empty_conv)
                hence "p \<notin> (set us) \<union> (set vs)"
                  using \<open>\<not> sink p\<close> by blast
                ultimately
                have "\<And>q''. q'' \<in> (set sp' - {p'}) \<Longrightarrow> \<delta> q'' (w n) \<noteq> p"
                  using 1 \<open>p = \<delta> p' (w n)\<close> \<open>p' \<in> set sp'\<close> by (fastforce dest: split_list elim: map_splitE)
              }
              ultimately
              have "\<And>q''. p = \<delta> q'' (w n) \<Longrightarrow> configuration q'' n \<noteq> {} \<Longrightarrow> q'' \<in> set ps'' \<or> q'' = p'"
                using nxt_run_configuration[of _ n]  \<open>\<not> sink p\<close>[THEN sink_rev_step(2)] unfolding r_def'[unfolded r_def] set_append
                by blast
              moreover
              have "\<And>q''. q'' \<in> set ps'' \<Longrightarrow> x \<le> ?f_n q''"
                using x_def using Suc unfolding r_def' map_append sorted_append set_append set_map  using \<open>q' \<in> set sq'\<close> \<open>p' \<in> set sp'\<close>
                apply (simp del: oldest_token.simps)  by fastforce
              moreover
              have "\<And>q''. q'' = p' \<Longrightarrow> x \<le> ?f_n q''"
                using x_def by simp
              moreover
              have "\<And>q'' x. x \<in> configuration q'' n \<Longrightarrow> the (oldest_token q'' n) \<le> x"
                using assms  by auto
              ultimately
              have "\<And>z. z \<in> \<Union>{configuration p' n |p'. p = \<delta> p' (w n)} \<Longrightarrow> x \<le> z"
                by fastforce
            }
            hence "\<And>z. z \<in> configuration p (Suc n) \<Longrightarrow> x \<le> z"
              unfolding configuration_step_eq_unified using \<open>x \<le> n\<close>
              by (cases "p = q\<^sub>0"; auto)
            hence "x \<le> y"
              using y_def Min.boundedI configuration_finite using push_down_oldest_token_configuration  by presburger
            ultimately
            have "?f_n p' = ?f_Suc_n p"
              using x_def y_def by fastforce
          }
          ultimately
          show ?thesis
            by presburger
       qed
    qed
    hence "\<And>x y xs ys. map ?f_Suc_n (remdups_fwd ?step) = xs @ [x, y] @ ys \<Longrightarrow> x \<le> y"
      by (auto elim: map_splitE simp del: remdups_fwd.simps)
    hence "sorted (map ?f_Suc_n (remdups_fwd (?step)))"
      using sorted_pre by metis
    thus ?case
      by (simp add: r_def sink_def)
qed (simp add: r_def)

lemma (in semi_mojmir) nxt_run_senior_states:
  defines "r \<equiv> run (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0) w"
  assumes "\<not>sink q"
  assumes "configuration q n \<noteq> {}"
  shows "senior_states q n = set (takeWhile (\<lambda>q'. q' \<noteq> q) (r n))"
  (is "?lhs = ?rhs")
proof (rule set_eqI, rule)
  fix q' assume q'_def: "q' \<in> senior_states q n"
  then obtain x y where "oldest_token q' n = Some y" and "oldest_token q n = Some x" and "y < x"
    using senior_states.simps using assms by blast
  hence "the (oldest_token q' n) < the (oldest_token q n)"
    by fastforce
  moreover
  hence "\<not>sink q'" and "configuration q' n \<noteq> {}"
    using q'_def option.distinct(1) \<open>oldest_token q' n = Some y\<close>
     oldest_token.simps using assms by (force, metis)
  hence "q' \<in> set (r n)" and "q \<in> set (r n)"
    using nxt_run_configuration assms by blast+
  moreover
  have "distinct (r n)"
    unfolding r_def using nxt_run_distinct by fast
  ultimately
  obtain r' r'' r''' where r_alt_def: "r n = r' @ q' # r'' @ q # r'''"
    using sorted_list[OF _ _ nxt_run_sorted] assms unfolding r_def by presburger
  hence "q' \<in> set (r' @ q' # r'')"
    by simp
  thus "q' \<in> set (takeWhile (\<lambda>q'. q' \<noteq> q) (r n))"
    using \<open>distinct (r n)\<close> takeWhile_distinct[of "r' @ q' # r''" q r''' q'] unfolding r_alt_def by simp
next
  fix q' assume q'_def: "q' \<in> set (takeWhile (\<lambda>q'. q' \<noteq> q) (r n))"
  moreover
  hence "q' \<in> set (r n)"
    by (blast dest: set_takeWhileD)+
  hence 5: "\<not> sink q'"
    using nxt_run_configuration assms by simp
  have "q \<in> set (r n)"
    using nxt_run_configuration assms by blast+
  ultimately
  obtain  r' r'' r''' where r_alt_def: "r n = r' @ q' # r'' @ q # r'''"
    using takeWhile_split by metis
  have "distinct (r n)"
     unfolding r_def using nxt_run_distinct by fast
  have 1: "the (oldest_token q' n) \<le> the (oldest_token q n)"
    using nxt_run_sorted[of n, unfolded r_def[symmetric]] assms
    unfolding r_alt_def map_append list.map
    unfolding sorted_append by (simp del: oldest_token.simps)
  have "q \<noteq> q'"
    using \<open>distinct (r n)\<close> r_alt_def by auto
  moreover
  have 2: "oldest_token q' n \<noteq> None" and 3: "oldest_token q n \<noteq> None"
    using assms \<open>q' \<in> set (r n)\<close> nxt_run_configuration by force+
  ultimately
  have 4: "the (oldest_token q' n) \<noteq> the (oldest_token q n)"
    by (metis oldest_token_equal option.collapse)

  show "q' \<in> senior_states q n"
    using 1 2 3 4 5 assms by fastforce
qed

lemma (in semi_mojmir) nxt_run_state_rank:
  "state_rank q n = rk (run (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0) w n) q"
  by (cases "\<not>sink q \<and> configuration q n \<noteq> {}", unfold state_rank.simps)
     (metis nxt_run_senior_states rk_split_card_takeWhile nxt_run_distinct nxt_run_configuration, metis nxt_run_configuration rk_facts(1))

lemma (in semi_mojmir) nxt_foldl_state_rank:
  "state_rank q n = rk (foldl (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0) (map w [0..<n])) q"
  unfolding nxt_run_state_rank run_foldl ..

lemma (in semi_mojmir) nxt_run_step_run:
  "run step initial w = rk o (run (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0) w)"
  using nxt_run_state_rank state_rank_step_foldl[unfolded run_foldl[symmetric]] unfolding comp_def by presburger

definition (in semi_mojmir_def) Q\<^sub>E
where
  "Q\<^sub>E \<equiv> reach \<Sigma> (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0)"

lemma (in semi_mojmir) finite_Q:
  "finite Q\<^sub>E"
proof -
  {
    fix i fix w :: "nat \<Rightarrow> 'a"
    assume "range w \<subseteq> \<Sigma>"
    then interpret \<HH>: semi_mojmir \<Sigma> \<delta> q\<^sub>0 w
      using finite_reach finite_\<Sigma> by (unfold_locales, blast)
    have "set (run (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0) w i) \<subseteq> {\<HH>.token_run j i | j. j \<le> i}" (is "?S1 \<subseteq> _")
      using \<HH>.nxt_run_configuration by auto
    also
    have "\<dots> \<subseteq> reach \<Sigma> \<delta> q\<^sub>0" (is "_ \<subseteq> ?S2")
      unfolding reach_def token_run.simps using \<open>range w \<subseteq> \<Sigma>\<close> by fastforce
    finally
    have "?S1 \<subseteq> ?S2" .
  }
  hence "set ` Q\<^sub>E \<subseteq> Pow (reach \<Sigma> \<delta> q\<^sub>0)"
    unfolding Q\<^sub>E_def reach_def by blast
  hence "finite (set ` Q\<^sub>E)"
    using finite_reach by (blast dest: finite_subset)
  moreover
  have "\<And>xs. xs \<in> Q\<^sub>E \<Longrightarrow> distinct xs"
    unfolding Q\<^sub>E_def reach_def using nxt_run_distinct by fastforce
  ultimately
  show "finite Q\<^sub>E"
    using set_list by auto
qed

lemma (in mojmir_to_rabin_def) filt_equiv:
  "(rk x, \<nu>, y) \<in> fail\<^sub>R \<longleftrightarrow> fail_filt \<Sigma> \<delta> q\<^sub>0 (\<lambda>x. x \<in> F) (x, \<nu>, y')"
  "(rk x, \<nu>, y) \<in> succeed\<^sub>R i \<longleftrightarrow> succeed_filt \<delta> q\<^sub>0 (\<lambda>x. x \<in> F) i (x, \<nu>, y')"
  "(rk x, \<nu>, y) \<in> merge\<^sub>R i \<longleftrightarrow> merge_filt \<delta> q\<^sub>0 (\<lambda>x. x \<in> F) i (x, \<nu>, y')"
  by (simp add: fail\<^sub>R_def succeed\<^sub>R_def merge\<^sub>R_def del: rk.simps; metis (no_types, lifting) option.sel rk_facts(2))+

lemma fail_filt_eq:
  "fail_filt \<Sigma> \<delta> q\<^sub>0 P (x, \<nu>, y) \<longleftrightarrow> (rk x, \<nu>, y') \<in> mojmir_to_rabin_def.fail\<^sub>R \<Sigma> \<delta> q\<^sub>0 {x. P x}"
  unfolding mojmir_to_rabin_def.filt_equiv(1)[where y' = y] by simp

lemma merge_filt_eq:
  "merge_filt \<delta> q\<^sub>0 P i (x, \<nu>, y) \<longleftrightarrow> (rk x, \<nu>, y') \<in> mojmir_to_rabin_def.merge\<^sub>R \<delta> q\<^sub>0 {x. P x} i"
  unfolding mojmir_to_rabin_def.filt_equiv(3)[where y' = y] by simp

lemma succeed_filt_eq:
  "succeed_filt \<delta> q\<^sub>0 P i (x, \<nu>, y) \<longleftrightarrow> (rk x, \<nu>, y') \<in> mojmir_to_rabin_def.succeed\<^sub>R \<delta> q\<^sub>0 {x. P x} i"
  unfolding mojmir_to_rabin_def.filt_equiv(2)[where y' = y] by simp

theorem (in mojmir_to_rabin) rabin_accept_iff_rabin_list_accept_rank:
  "accepting_pair\<^sub>R \<delta>\<^sub>\<R> q\<^sub>\<R> (Acc\<^sub>\<R> i) w \<longleftrightarrow> accepting_pair\<^sub>R (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0) ({t. fail_filt \<Sigma> \<delta> q\<^sub>0 (\<lambda>x. x \<in> F) t} \<union> {t. merge_filt \<delta> q\<^sub>0 (\<lambda>x. x \<in> F) i t}, {t. succeed_filt \<delta> q\<^sub>0 (\<lambda>x. x \<in> F) i t}) w"
  (is "accepting_pair\<^sub>R \<delta>\<^sub>\<R> q\<^sub>\<R> (?F, ?I) w \<longleftrightarrow> accepting_pair\<^sub>R (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0) (?F', ?I') w")
proof -
  have "finite (reach\<^sub>t \<Sigma> \<delta>\<^sub>\<R> q\<^sub>\<R>)"
    using wellformed_\<R> finite_\<Sigma> finite_reach\<^sub>t by fast
  moreover
  have "finite (reach\<^sub>t \<Sigma> (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0))"
    using finite_Q finite_\<Sigma> finite_reach\<^sub>t by (auto simp add: Q\<^sub>E_def)
  moreover
  have "run\<^sub>t step initial w = (\<lambda>(x, \<nu>, y). (rk x, \<nu>, rk y)) o (run\<^sub>t (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0) w)"
    using nxt_run_step_run by auto
  moreover
  note bounded_w filt_equiv
  ultimately
  show ?thesis
    by (intro accepting_pair\<^sub>R_abstract) auto
qed

subsection \<open>Compute Rabin Automata List Representation\<close>

fun mojmir_to_rabin_exec
where
  "mojmir_to_rabin_exec \<Sigma> \<delta> q\<^sub>0 F = (
    let
      q\<^sub>0' = init q\<^sub>0;
      \<delta>' = \<delta>\<^sub>L \<Sigma> (nxt (set \<Sigma>) \<delta> q\<^sub>0) q\<^sub>0';
      max_rank = card (Set.filter (Not o semi_mojmir_def.sink (set \<Sigma>) \<delta> q\<^sub>0) (Q\<^sub>L \<Sigma> \<delta> q\<^sub>0));
      fail = Set.filter (fail_filt (set \<Sigma>) \<delta> q\<^sub>0 F) \<delta>';
      merge = (\<lambda>i. Set.filter (merge_filt \<delta> q\<^sub>0 F i) \<delta>');
      succeed = (\<lambda>i. Set.filter (succeed_filt \<delta> q\<^sub>0 F i) \<delta>')
    in
      (\<delta>', q\<^sub>0', (\<lambda>i. (fail \<union> (merge i), succeed i)) ` {0..<max_rank}))"

subsection \<open>Code Generation\<close>

\<comment> \<open>Setup missing equations for code generator\<close>
declare semi_mojmir_def.sink_def [code]

\<comment> \<open>Drop computation of length by different code equation\<close>
fun index_option ::  "nat \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> nat option"
where
  "index_option n [] y = None"
| "index_option n (x # xs) y = (if x = y then Some n else index_option (Suc n) xs y)"

declare rk.simps [code del]

lemma rk_eq_index_option [code]:
  "rk xs x = index_option 0 xs x"
proof -
  have A: "\<And>n. x \<in> set xs \<Longrightarrow> index xs x + n = the (index_option n xs x)"
   and B: "\<And>n. x \<notin> set xs \<longleftrightarrow> index_option n xs x = None"
   by (induction xs) (auto, metis add_Suc_right)
  thus ?thesis
  proof (cases "x \<in> set xs")
    case True
      moreover
      hence "index xs x = the (index_option 0 xs x)"
        using A[OF True, of 0] by simp
      ultimately
      show ?thesis
        unfolding rk.simps by (metis (mono_tags, lifting) B True index_less_size_conv less_irrefl option.collapse)
  qed simp
qed

\<comment> \<open>Check Code Export\<close>
export_code init nxt fail_filt succeed_filt merge_filt mojmir_to_rabin_exec checking

lemma (in mojmir) max_rank_card:
  assumes "\<Sigma> = set \<Sigma>'"
  shows "max_rank = card (Set.filter (Not o semi_mojmir_def.sink (set \<Sigma>') \<delta> q\<^sub>0) (Q\<^sub>L \<Sigma>' \<delta> q\<^sub>0))"
  unfolding max_rank_def Q\<^sub>L_reach[OF finite_reach[unfolded \<open>\<Sigma> = set \<Sigma>'\<close>]]
  by (simp add: Set.filter_def set_diff_eq assms(1))

theorem (in mojmir_to_rabin) exec_correct:
  assumes "\<Sigma> = set \<Sigma>'"
  shows "accept \<longleftrightarrow> accept\<^sub>R_LTS (mojmir_to_rabin_exec \<Sigma>' \<delta> q\<^sub>0 (\<lambda>x. x \<in> F)) w" (is "?lhs \<longleftrightarrow> ?rhs")
proof -
 have F1: "finite (reach \<Sigma> (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0))"
    using finite_Q by (simp add: Q\<^sub>E_def)
  hence F2: "finite (reach\<^sub>t \<Sigma> (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0))"
    using finite_\<Sigma> by (rule finite_reach\<^sub>t)

  let ?\<delta>' = "\<delta>\<^sub>L \<Sigma>' (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0)"
  have \<delta>'_Def: "?\<delta>' = reach\<^sub>t \<Sigma> (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0)"
    using \<delta>\<^sub>L_reach[OF F2[unfolded assms]] unfolding  assms  by simp

  have 3: "snd (snd ((mojmir_to_rabin_exec \<Sigma>' \<delta> q\<^sub>0 (\<lambda>x. x \<in> F))))
    = {(({t. fail_filt \<Sigma> \<delta> q\<^sub>0 (\<lambda>x. x \<in> F) t} \<union> {t. merge_filt \<delta> q\<^sub>0 (\<lambda>x. x \<in> F) i t}) \<inter> reach\<^sub>t \<Sigma> (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0),
        {t. succeed_filt \<delta> q\<^sub>0 (\<lambda>x. x \<in> F) i t}  \<inter> reach\<^sub>t \<Sigma> (nxt \<Sigma> \<delta> q\<^sub>0) (init q\<^sub>0)) | i. i < max_rank}"
    unfolding assms mojmir_to_rabin_exec.simps Let_def fst_conv snd_conv set_map \<delta>'_Def[unfolded assms] max_rank_card[OF assms, symmetric]
    unfolding assms[symmetric] Set.filter_def by auto

  have "?lhs \<longleftrightarrow> accept\<^sub>R (\<delta>\<^sub>\<R>, q\<^sub>\<R>, {(Acc\<^sub>\<R> i) | i. i < max_rank}) w"
    using mojmir_accept_iff_rabin_accept by blast

  moreover

  have "\<dots> \<longleftrightarrow> accept\<^sub>R (nxt \<Sigma> \<delta> q\<^sub>0, init q\<^sub>0, {({t. fail_filt \<Sigma> \<delta> q\<^sub>0 (\<lambda>x. x \<in> F) t} \<union> {t. merge_filt \<delta> q\<^sub>0 (\<lambda>x. x \<in> F) i t}, {t. succeed_filt \<delta> q\<^sub>0 (\<lambda>x. x \<in> F) i t}) | i. i < max_rank}) w"
    unfolding accept\<^sub>R_def fst_conv snd_conv using rabin_accept_iff_rabin_list_accept_rank by blast

  moreover

  have "\<dots> \<longleftrightarrow> ?rhs"
    apply (subst accept\<^sub>R_restrict[OF bounded_w])
    unfolding 3[unfolded mojmir_to_rabin_exec.simps Let_def snd_conv, symmetric] assms[symmetric] mojmir_to_rabin_exec.simps Let_def unfolding assms \<delta>'_Def[unfolded assms]
    unfolding accept\<^sub>R_LTS[OF bounded_w[unfolded assms], symmetric, unfolded assms] by simp

  ultimately

  show ?thesis
    by blast
qed

end


(*  Title:      HOL/Proofs/Extraction/Higman.thy
    Author:     Stefan Berghofer, TU Muenchen
    Author:     Monika Seisenberger, LMU Muenchen
*)

section \<open>Higman's lemma\<close>

theory Higman
imports Old_Datatype
begin

text \<open>
  Formalization by Stefan Berghofer and Monika Seisenberger,
  based on Coquand and Fridlender @{cite Coquand93}.
\<close>

datatype letter = A | B

inductive emb :: "letter list \<Rightarrow> letter list \<Rightarrow> bool"
where
  emb0 [Pure.intro]: "emb [] bs"
| emb1 [Pure.intro]: "emb as bs \<Longrightarrow> emb as (b # bs)"
| emb2 [Pure.intro]: "emb as bs \<Longrightarrow> emb (a # as) (a # bs)"

inductive L :: "letter list \<Rightarrow> letter list list \<Rightarrow> bool"
  for v :: "letter list"
where
  L0 [Pure.intro]: "emb w v \<Longrightarrow> L v (w # ws)"
| L1 [Pure.intro]: "L v ws \<Longrightarrow> L v (w # ws)"

inductive good :: "letter list list \<Rightarrow> bool"
where
  good0 [Pure.intro]: "L w ws \<Longrightarrow> good (w # ws)"
| good1 [Pure.intro]: "good ws \<Longrightarrow> good (w # ws)"

inductive R :: "letter \<Rightarrow> letter list list \<Rightarrow> letter list list \<Rightarrow> bool"
  for a :: letter
where
  R0 [Pure.intro]: "R a [] []"
| R1 [Pure.intro]: "R a vs ws \<Longrightarrow> R a (w # vs) ((a # w) # ws)"

inductive T :: "letter \<Rightarrow> letter list list \<Rightarrow> letter list list \<Rightarrow> bool"
  for a :: letter
where
  T0 [Pure.intro]: "a \<noteq> b \<Longrightarrow> R b ws zs \<Longrightarrow> T a (w # zs) ((a # w) # zs)"
| T1 [Pure.intro]: "T a ws zs \<Longrightarrow> T a (w # ws) ((a # w) # zs)"
| T2 [Pure.intro]: "a \<noteq> b \<Longrightarrow> T a ws zs \<Longrightarrow> T a ws ((b # w) # zs)"

inductive bar :: "letter list list \<Rightarrow> bool"
where
  bar1 [Pure.intro]: "good ws \<Longrightarrow> bar ws"
| bar2 [Pure.intro]: "(\<And>w. bar (w # ws)) \<Longrightarrow> bar ws"

theorem prop1: "bar ([] # ws)"
  by iprover

theorem lemma1: "L as ws \<Longrightarrow> L (a # as) ws"
  by (erule L.induct) iprover+

lemma lemma2': "R a vs ws \<Longrightarrow> L as vs \<Longrightarrow> L (a # as) ws"
  apply (induct set: R)
  apply (erule L.cases)
  apply simp+
  apply (erule L.cases)
  apply simp_all
  apply (rule L0)
  apply (erule emb2)
  apply (erule L1)
  done

lemma lemma2: "R a vs ws \<Longrightarrow> good vs \<Longrightarrow> good ws"
  apply (induct set: R)
  apply iprover
  apply (erule good.cases)
  apply simp_all
  apply (rule good0)
  apply (erule lemma2')
  apply assumption
  apply (erule good1)
  done

lemma lemma3': "T a vs ws \<Longrightarrow> L as vs \<Longrightarrow> L (a # as) ws"
  apply (induct set: T)
  apply (erule L.cases)
  apply simp_all
  apply (rule L0)
  apply (erule emb2)
  apply (rule L1)
  apply (erule lemma1)
  apply (erule L.cases)
  apply simp_all
  apply iprover+
  done

lemma lemma3: "T a ws zs \<Longrightarrow> good ws \<Longrightarrow> good zs"
  apply (induct set: T)
  apply (erule good.cases)
  apply simp_all
  apply (rule good0)
  apply (erule lemma1)
  apply (erule good1)
  apply (erule good.cases)
  apply simp_all
  apply (rule good0)
  apply (erule lemma3')
  apply iprover+
  done

lemma lemma4: "R a ws zs \<Longrightarrow> ws \<noteq> [] \<Longrightarrow> T a ws zs"
  apply (induct set: R)
  apply iprover
  apply (case_tac vs)
  apply (erule R.cases)
  apply simp
  apply (case_tac a)
  apply (rule_tac b=B in T0)
  apply simp
  apply (rule R0)
  apply (rule_tac b=A in T0)
  apply simp
  apply (rule R0)
  apply simp
  apply (rule T1)
  apply simp
  done

lemma letter_neq: "a \<noteq> b \<Longrightarrow> c \<noteq> a \<Longrightarrow> c = b" for a b c :: letter
  apply (case_tac a)
  apply (case_tac b)
  apply (case_tac c, simp, simp)
  apply (case_tac c, simp, simp)
  apply (case_tac b)
  apply (case_tac c, simp, simp)
  apply (case_tac c, simp, simp)
  done

lemma letter_eq_dec: "a = b \<or> a \<noteq> b" for a b :: letter
  apply (case_tac a)
  apply (case_tac b)
  apply simp
  apply simp
  apply (case_tac b)
  apply simp
  apply simp
  done

theorem prop2:
  assumes ab: "a \<noteq> b" and bar: "bar xs"
  shows "\<And>ys zs. bar ys \<Longrightarrow> T a xs zs \<Longrightarrow> T b ys zs \<Longrightarrow> bar zs"
  using bar
proof induct
  fix xs zs
  assume "T a xs zs" and "good xs"
  then have "good zs" by (rule lemma3)
  then show "bar zs" by (rule bar1)
next
  fix xs ys
  assume I: "\<And>w ys zs. bar ys \<Longrightarrow> T a (w # xs) zs \<Longrightarrow> T b ys zs \<Longrightarrow> bar zs"
  assume "bar ys"
  then show "\<And>zs. T a xs zs \<Longrightarrow> T b ys zs \<Longrightarrow> bar zs"
  proof induct
    fix ys zs
    assume "T b ys zs" and "good ys"
    then have "good zs" by (rule lemma3)
    then show "bar zs" by (rule bar1)
  next
    fix ys zs
    assume I': "\<And>w zs. T a xs zs \<Longrightarrow> T b (w # ys) zs \<Longrightarrow> bar zs"
      and ys: "\<And>w. bar (w # ys)" and Ta: "T a xs zs" and Tb: "T b ys zs"
    show "bar zs"
    proof (rule bar2)
      fix w
      show "bar (w # zs)"
      proof (cases w)
        case Nil
        then show ?thesis by simp (rule prop1)
      next
        case (Cons c cs)
        from letter_eq_dec show ?thesis
        proof
          assume ca: "c = a"
          from ab have "bar ((a # cs) # zs)" by (iprover intro: I ys Ta Tb)
          then show ?thesis by (simp add: Cons ca)
        next
          assume "c \<noteq> a"
          with ab have cb: "c = b" by (rule letter_neq)
          from ab have "bar ((b # cs) # zs)" by (iprover intro: I' Ta Tb)
          then show ?thesis by (simp add: Cons cb)
        qed
      qed
    qed
  qed
qed

theorem prop3:
  assumes bar: "bar xs"
  shows "\<And>zs. xs \<noteq> [] \<Longrightarrow> R a xs zs \<Longrightarrow> bar zs"
  using bar
proof induct
  fix xs zs
  assume "R a xs zs" and "good xs"
  then have "good zs" by (rule lemma2)
  then show "bar zs" by (rule bar1)
next
  fix xs zs
  assume I: "\<And>w zs. w # xs \<noteq> [] \<Longrightarrow> R a (w # xs) zs \<Longrightarrow> bar zs"
    and xsb: "\<And>w. bar (w # xs)" and xsn: "xs \<noteq> []" and R: "R a xs zs"
  show "bar zs"
  proof (rule bar2)
    fix w
    show "bar (w # zs)"
    proof (induct w)
      case Nil
      show ?case by (rule prop1)
    next
      case (Cons c cs)
      from letter_eq_dec show ?case
      proof
        assume "c = a"
        then show ?thesis by (iprover intro: I [simplified] R)
      next
        from R xsn have T: "T a xs zs" by (rule lemma4)
        assume "c \<noteq> a"
        then show ?thesis by (iprover intro: prop2 Cons xsb xsn R T)
      qed
    qed
  qed
qed

theorem higman: "bar []"
proof (rule bar2)
  fix w
  show "bar [w]"
  proof (induct w)
    show "bar [[]]" by (rule prop1)
  next
    fix c cs assume "bar [cs]"
    then show "bar [c # cs]" by (rule prop3) (simp, iprover)
  qed
qed

primrec is_prefix :: "'a list \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool"
where
  "is_prefix [] f = True"
| "is_prefix (x # xs) f = (x = f (length xs) \<and> is_prefix xs f)"

theorem L_idx:
  assumes L: "L w ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>i. emb (f i) w \<and> i < length ws"
  using L
proof induct
  case (L0 v ws)
  then have "emb (f (length ws)) w" by simp
  moreover have "length ws < length (v # ws)" by simp
  ultimately show ?case by iprover
next
  case (L1 ws v)
  then obtain i where emb: "emb (f i) w" and "i < length ws"
    by simp iprover
  then have "i < length (v # ws)" by simp
  with emb show ?case by iprover
qed

theorem good_idx:
  assumes good: "good ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>i j. emb (f i) (f j) \<and> i < j"
  using good
proof induct
  case (good0 w ws)
  then have "w = f (length ws)" and "is_prefix ws f" by simp_all
  with good0 show ?case by (iprover dest: L_idx)
next
  case (good1 ws w)
  then show ?case by simp
qed

theorem bar_idx:
  assumes bar: "bar ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>i j. emb (f i) (f j) \<and> i < j"
  using bar
proof induct
  case (bar1 ws)
  then show ?case by (rule good_idx)
next
  case (bar2 ws)
  then have "is_prefix (f (length ws) # ws) f" by simp
  then show ?case by (rule bar2)
qed

text \<open>
  Strong version: yields indices of words that can be embedded into each other.
\<close>

theorem higman_idx: "\<exists>(i::nat) j. emb (f i) (f j) \<and> i < j"
proof (rule bar_idx)
  show "bar []" by (rule higman)
  show "is_prefix [] f" by simp
qed

text \<open>
  Weak version: only yield sequence containing words
  that can be embedded into each other.
\<close>

theorem good_prefix_lemma:
  assumes bar: "bar ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>vs. is_prefix vs f \<and> good vs"
  using bar
proof induct
  case bar1
  then show ?case by iprover
next
  case (bar2 ws)
  from bar2.prems have "is_prefix (f (length ws) # ws) f" by simp
  then show ?case by (iprover intro: bar2)
qed

theorem good_prefix: "\<exists>vs. is_prefix vs f \<and> good vs"
  using higman
  by (rule good_prefix_lemma) simp+

end