(*  Title:       POSIX Lexing with Derivatives of Regular Expressions
    Authors:     Fahad Ausaf <fahad.ausaf at icloud.com>, 2016
                 Roy Dyckhoff <roy.dyckhoff at st-andrews.ac.uk>, 2016
                 Christian Urban <christian.urban at kcl.ac.uk>, 2016
    Maintainer:  Christian Urban <christian.urban at kcl.ac.uk>
*) 

theory Lexer
  imports "Regular-Sets.Derivatives"
begin

section ‹Values›

datatype 'a val = 
  Void
| Atm 'a
| Seq "'a val" "'a val"
| Right "'a val"
| Left "'a val"
| Stars "('a val) list"


section ‹The string behind a value›

fun 
  flat :: "'a val → 'a list"
where
  "flat (Void) = []"
| "flat (Atm c) = [c]"
| "flat (Left v) = flat v"
| "flat (Right v) = flat v"
| "flat (Seq v1 v2) = (flat v1) @ (flat v2)"
| "flat (Stars []) = []"
| "flat (Stars (v#vs)) = (flat v) @ (flat (Stars vs))" 

abbreviation
  "flats vs ≡ concat (map flat vs)"

lemma flat_Stars [simp]:
 "flat (Stars vs) = concat (map flat vs)"
by (induct vs) (auto)

section ‹Relation between values and regular expressions›

inductive 
  Prf :: "'a val → 'a rexp → bool" (‹⊨ _ : _› [100, 100] 100)
where
 "[⊨ v1 : r1; ⊨ v2 : r2] ==> ⊨ Seq v1 v2 : Times r1 r2"
| "⊨ v1 : r1 ==> ⊨ Left v1 : Plus r1 r2"
| "⊨ v2 : r2 ==> ⊨ Right v2 : Plus r1 r2"
| "⊨ Void : One"
| "⊨ Atm c : Atom c"
| "[∀v ∈ set vs. ⊨ v : r ∧ flat v ≠ []] ==> ⊨ Stars vs : Star r"

inductive_cases Prf_elims:
  "⊨ v : Zero"
  "⊨ v : Times r1 r2"
  "⊨ v : Plus r1 r2"
  "⊨ v : One"
  "⊨ v : Atom c"
  "⊨ vs : Star r"

lemma Prf_flat_lang:
  assumes "⊨ v : r" shows "flat v ∈ lang r"
using assms
  by (induct v r rule: Prf.induct) 
     (auto simp add: concat_in_star subset_eq)
  

lemma Star_string:
  assumes "s ∈ star A"
  shows "∃ss. concat ss = s ∧ (∀s ∈ set ss. s ∈ A)"
using assms
by (metis in_star_iff_concat subsetD)

lemma Star_val:
  assumes "∀s∈set ss. ∃v. s = flat v ∧ ⊨ v : r"
  shows "∃vs. flats vs = concat ss ∧ (∀v∈set vs. ⊨ v : r ∧ flat v ≠ [])"
using assms
apply(induct ss)
apply(auto)
apply (metis empty_iff list.set(1))
by (metis append.simps(1) flat.simps(7) flat_Stars set_ConsD)

lemma L_flat_Prf1:
  assumes "⊨ v : r" shows "flat v ∈ lang r"
using assms
  apply (induct) 
  apply(auto)
  by (metis Prf.intros(6) Prf_flat_lang flat_Stars lang.simps(6)) 
  

lemma L_flat_Prf2:
  assumes "s ∈ lang r" shows "∃v. ⊨ v : r ∧ flat v = s"
using assms
apply(induct r arbitrary: s)
apply(auto intro: Prf.intros)
using Prf.intros(2) flat.simps(3) apply blast
using Prf.intros(3) flat.simps(4) apply blast
apply (metis Prf.intros(1) concE flat.simps(5))
apply(subgoal_tac "∃vs::('a val) list. concat (map flat vs) = s ∧ (∀v ∈ set vs. ⊨ v : r ∧ flat v ≠ [])")
apply(auto)[1]
apply(rule_tac x="Stars vs" in exI)
apply(simp)
apply(drule Star_string)
apply(auto)
using Prf.intros(6) apply blast
by (smt (verit) Star_val in_star_iff_concat subset_iff)

lemma L_flat_Prf:
  "lang r = {flat v | v. ⊨ v : r}"
using L_flat_Prf1 L_flat_Prf2 by blast


section ‹Sulzmann and Lu functions›

fun 
  mkeps :: "'a rexp → 'a val"
where
  "mkeps(One) = Void"
| "mkeps(Times r1 r2) = Seq (mkeps r1) (mkeps r2)"
| "mkeps(Plus r1 r2) = (if nullable(r1) then Left (mkeps r1) else Right (mkeps r2))"
| "mkeps(Star r) = Stars []"

fun injval :: "'a rexp → 'a → 'a val → 'a val"
where
  "injval (Atom d) c Void = Atm c"
| "injval (Plus r1 r2) c (Left v1) = Left(injval r1 c v1)"
| "injval (Plus r1 r2) c (Right v2) = Right(injval r2 c v2)"
| "injval (Times r1 r2) c (Seq v1 v2) = Seq (injval r1 c v1) v2"
| "injval (Times r1 r2) c (Left (Seq v1 v2)) = Seq (injval r1 c v1) v2"
| "injval (Times r1 r2) c (Right v2) = Seq (mkeps r1) (injval r2 c v2)"
| "injval (Star r) c (Seq v (Stars vs)) = Stars ((injval r c v) # vs)" 


section ‹Mkeps, injval›

lemma mkeps_nullable:
  assumes "nullable r" 
  shows "⊨ mkeps r : r"
using assms
by (induct r) 
   (auto intro: Prf.intros)

lemma mkeps_flat:
  assumes "nullable r" 
  shows "flat (mkeps r) = []"
using assms
by (induct r) (auto)

lemma Prf_injval_flat:
  assumes "⊨ v : deriv c r" 
  shows "flat (injval r c v) = c # (flat v)"
using assms
apply(induct c r arbitrary: v rule: deriv.induct)
apply(auto elim!: Prf_elims intro: mkeps_flat split: if_splits)
done

lemma Prf_injval:
  assumes "⊨ v : deriv c r" 
  shows "⊨ (injval r c v) : r"
using assms
apply(induct r arbitrary: c v rule: rexp.induct)
apply(auto intro!: Prf.intros mkeps_nullable elim!: Prf_elims split: if_splits)
(* Star *)
by (simp add: Prf_injval_flat)


section ‹Our Alternative Posix definition›

inductive 
  Posix :: "'a list → 'a rexp → 'a val → bool" (‹_ ∈ _ → _› [100, 100, 100] 100)
where
  Posix_One: "[] ∈ One → Void"
| Posix_Atom: "[c] ∈ (Atom c) → (Atm c)"
| Posix_Plus1: "s ∈ r1 → v ==> s ∈ (Plus r1 r2) → (Left v)"
| Posix_Plus2: "[s ∈ r2 → v; s ∉ lang r1] ==> s ∈ (Plus r1 r2) → (Right v)"
| Posix_Times: "[s1 ∈ r1 → v1; s2 ∈ r2 → v2;
    ¬(∃s₃ s₄. s₃ ≠ [] ∧ s₃ @ s₄ = s2 ∧ (s1 @ s₃) ∈ lang r1 ∧ s₄ ∈ lang r2)] ==>
    (s1 @ s2) ∈ (Times r1 r2) → (Seq v1 v2)"
| Posix_Star1: "[s1 ∈ r → v; s2 ∈ Star r → Stars vs; flat v ≠ [];
    ¬(∃s₃ s₄. s₃ ≠ [] ∧ s₃ @ s₄ = s2 ∧ (s1 @ s₃) ∈ lang r ∧ s₄ ∈ lang (Star r))]
    ==> (s1 @ s2) ∈ Star r → Stars (v # vs)"
| Posix_Star2: "[] ∈ Star r → Stars []"

inductive_cases Posix_elims:
  "s ∈ Zero → v"
  "s ∈ One → v"
  "s ∈ Atom c → v"
  "s ∈ Plus r1 r2 → v"
  "s ∈ Times r1 r2 → v"
  "s ∈ Star r → v"

lemma Posix1:
  assumes "s ∈ r → v"
  shows "s ∈ lang r" "flat v = s"
using assms
by (induct s r v rule: Posix.induct) (auto)


lemma Posix1a:
  assumes "s ∈ r → v"
  shows "⊨ v : r"
using assms
  apply(induct s r v rule: Posix.induct)
  apply(auto intro: Prf.intros)
  by (metis Prf.intros(6) Prf_elims(6) set_ConsD val.inject(5))
  

lemma Posix_mkeps:
  assumes "nullable r"
  shows "[] ∈ r → mkeps r"
using assms
apply(induct r)
apply(auto intro: Posix.intros simp add: nullable_iff)
apply(subst append.simps(1)[symmetric])
apply(rule Posix.intros)
apply(auto)
done


lemma Posix_determ:
  assumes "s ∈ r → v1" "s ∈ r → v2"
  shows "v1 = v2"
using assms
proof (induct s r v1 arbitrary: v2 rule: Posix.induct)
  case (Posix_One v2)
  have "[] ∈ One → v2" by fact
  then show "Void = v2" by cases auto
next 
  case (Posix_Atom c v2)
  have "[c] ∈ Atom c → v2" by fact
  then show "Atm c = v2" by cases auto
next 
  case (Posix_Plus1 s r1 v r2 v2)
  have "s ∈ Plus r1 r2 → v2" by fact
  moreover
  have "s ∈ r1 → v" by fact
  then have "s ∈ lang r1" by (simp add: Posix1)
  ultimately obtain v' where eq: "v2 = Left v'" "s ∈ r1 → v'" by cases auto 
  moreover
  have IH: "∧v2. s ∈ r1 → v2 ==> v = v2" by fact
  ultimately have "v = v'" by simp
  then show "Left v = v2" using eq by simp
next 
  case (Posix_Plus2 s r2 v r1 v2)
  have "s ∈ Plus r1 r2 → v2" by fact
  moreover
  have "s ∉ lang r1" by fact
  ultimately obtain v' where eq: "v2 = Right v'" "s ∈ r2 → v'" 
    by cases (auto simp add: Posix1) 
  moreover
  have IH: "∧v2. s ∈ r2 → v2 ==> v = v2" by fact
  ultimately have "v = v'" by simp
  then show "Right v = v2" using eq by simp
next
  case (Posix_Times s1 r1 v1 s2 r2 v2 v')
  have "(s1 @ s2) ∈ Times r1 r2 → v'" 
       "s1 ∈ r1 → v1" "s2 ∈ r2 → v2"
       "¬ (∃s₃ s₄. s₃ ≠ [] ∧ s₃ @ s₄ = s2 ∧ s1 @ s₃ ∈ lang r1 ∧ s₄ ∈ lang r2)" by fact+
  then obtain v1' v2' where "v' = Seq v1' v2'" "s1 ∈ r1 → v1'" "s2 ∈ r2 → v2'"
  apply(cases) apply (auto simp add: append_eq_append_conv2)
  using Posix1(1) by fastforce+
  moreover
  have IHs: "∧v1'. s1 ∈ r1 → v1' ==> v1 = v1'"
            "∧v2'. s2 ∈ r2 → v2' ==> v2 = v2'" by fact+
  ultimately show "Seq v1 v2 = v'" by simp
next
  case (Posix_Star1 s1 r v s2 vs v2)
  have "(s1 @ s2) ∈ Star r → v2" 
       "s1 ∈ r → v" "s2 ∈ Star r → Stars vs" "flat v ≠ []"
       "¬ (∃s₃ s₄. s₃ ≠ [] ∧ s₃ @ s₄ = s2 ∧ s1 @ s₃ ∈ lang r ∧ s₄ ∈ lang (Star r))" by fact+
  then obtain v' vs' where "v2 = Stars (v' # vs')" "s1 ∈ r → v'" "s2 ∈ (Star r) → (Stars vs')"
  apply(cases) apply (auto simp add: append_eq_append_conv2)
  using Posix1(1) apply fastforce
  apply (metis Posix1(1) Posix_Star1.hyps(6) append_Nil append_Nil2)
  using Posix1(2) by blast
  moreover
  have IHs: "∧v2. s1 ∈ r → v2 ==> v = v2"
            "∧v2. s2 ∈ Star r → v2 ==> Stars vs = v2" by fact+
  ultimately show "Stars (v # vs) = v2" by auto
next
  case (Posix_Star2 r v2)
  have "[] ∈ Star r → v2" by fact
  then show "Stars [] = v2" by cases (auto simp add: Posix1)
qed


lemma Posix_injval:
  assumes "s ∈ (deriv c r) → v"
  shows "(c # s) ∈ r → (injval r c v)"
using assms
proof(induct r arbitrary: s v rule: rexp.induct)
  case Zero
  have "s ∈ deriv c Zero → v" by fact
  then have "s ∈ Zero → v" by simp
  then have "False" by cases
  then show "(c # s) ∈ Zero → (injval Zero c v)" by simp
next
  case One
  have "s ∈ deriv c One → v" by fact
  then have "s ∈ Zero → v" by simp
  then have "False" by cases
  then show "(c # s) ∈ One → (injval One c v)" by simp
next 
  case (Atom d)
  consider (eq) "c = d" | (ineq) "c ≠ d" by blast
  then show "(c # s) ∈ (Atom d) → (injval (Atom d) c v)"
  proof (cases)
    case eq
    have "s ∈ deriv c (Atom d) → v" by fact
    then have "s ∈ One → v" using eq by simp
    then have eqs: "s = [] ∧ v = Void" by cases simp
    show "(c # s) ∈ Atom d → injval (Atom d) c v" using eq eqs 
    by (auto intro: Posix.intros)
  next
    case ineq
    have "s ∈ deriv c (Atom d) → v" by fact
    then have "s ∈ Zero → v" using ineq by simp
    then have "False" by cases
    then show "(c # s) ∈ Atom d → injval (Atom d) c v" by simp
  qed
next
  case (Plus r1 r2)
  have IH1: "∧s v. s ∈ deriv c r1 → v ==> (c # s) ∈ r1 → injval r1 c v" by fact
  have IH2: "∧s v. s ∈ deriv c r2 → v ==> (c # s) ∈ r2 → injval r2 c v" by fact
  have "s ∈ deriv c (Plus r1 r2) → v" by fact
  then have "s ∈ Plus (deriv c r1) (deriv c r2) → v" by simp
  then consider (left) v' where "v = Left v'" "s ∈ deriv c r1 → v'" 
              | (right) v' where "v = Right v'" "s ∉ lang (deriv c r1)" "s ∈ deriv c r2 → v'" 
              by cases auto
  then show "(c # s) ∈ Plus r1 r2 → injval (Plus r1 r2) c v"
  proof (cases)
    case left
    have "s ∈ deriv c r1 → v'" by fact
    then have "(c # s) ∈ r1 → injval r1 c v'" using IH1 by simp
    then have "(c # s) ∈ Plus r1 r2 → injval (Plus r1 r2) c (Left v')" by (auto intro: Posix.intros)
    then show "(c # s) ∈ Plus r1 r2 → injval (Plus r1 r2) c v" using left by simp
  next 
    case right
    have "s ∉ lang (deriv c r1)" by fact
    then have "c # s ∉ lang r1" by (simp add: lang_deriv Deriv_def)
    moreover 
    have "s ∈ deriv c r2 → v'" by fact
    then have "(c # s) ∈ r2 → injval r2 c v'" using IH2 by simp
    ultimately have "(c # s) ∈ Plus r1 r2 → injval (Plus r1 r2) c (Right v')" 
      by (auto intro: Posix.intros)
    then show "(c # s) ∈ Plus r1 r2 → injval (Plus r1 r2) c v" using right by simp
  qed
next
  case (Times r1 r2)
  have IH1: "∧s v. s ∈ deriv c r1 → v ==> (c # s) ∈ r1 → injval r1 c v" by fact
  have IH2: "∧s v. s ∈ deriv c r2 → v ==> (c # s) ∈ r2 → injval r2 c v" by fact
  have "s ∈ deriv c (Times r1 r2) → v" by fact
  then consider 
        (left_nullable) v1 v2 s1 s2 where 
        "v = Left (Seq v1 v2)"  "s = s1 @ s2" 
        "s1 ∈ deriv c r1 → v1" "s2 ∈ r2 → v2" "nullable r1" 
        "¬ (∃s₃ s₄. s₃ ≠ [] ∧ s₃ @ s₄ = s2 ∧ s1 @ s₃ ∈ lang (deriv c r1) ∧ s₄ ∈ lang r2)"
      | (right_nullable) v1 s1 s2 where 
        "v = Right v1" "s = s1 @ s2"  
        "s ∈ deriv c r2 → v1" "nullable r1" "s1 @ s2 ∉ lang (Times (deriv c r1) r2)"
      | (not_nullable) v1 v2 s1 s2 where
        "v = Seq v1 v2" "s = s1 @ s2" 
        "s1 ∈ deriv c r1 → v1" "s2 ∈ r2 → v2" "¬nullable r1" 
        "¬ (∃s₃ s₄. s₃ ≠ [] ∧ s₃ @ s₄ = s2 ∧ s1 @ s₃ ∈ lang (deriv c r1) ∧ s₄ ∈ lang r2)"
        by (force split: if_splits elim!: Posix_elims simp add: lang_deriv Deriv_def)   
  then show "(c # s) ∈ Times r1 r2 → injval (Times r1 r2) c v" 
    proof (cases)
      case left_nullable
      have "s1 ∈ deriv c r1 → v1" by fact
      then have "(c # s1) ∈ r1 → injval r1 c v1" using IH1 by simp
      moreover
      have "¬ (∃s₃ s₄. s₃ ≠ [] ∧ s₃ @ s₄ = s2 ∧ s1 @ s₃ ∈ lang (deriv c r1) ∧ s₄ ∈ lang r2)" by fact
      then have "¬ (∃s₃ s₄. s₃ ≠ [] ∧ s₃ @ s₄ = s2 ∧ (c # s1) @ s₃ ∈ lang r1 ∧ s₄ ∈ lang r2)" 
         by (simp add: lang_deriv Deriv_def)
      ultimately have "((c # s1) @ s2) ∈ Times r1 r2 → Seq (injval r1 c v1) v2" using left_nullable by (rule_tac Posix.intros)
      then show "(c # s) ∈ Times r1 r2 → injval (Times r1 r2) c v" using left_nullable by simp
    next
      case right_nullable
      have "nullable r1" by fact
      then have "[] ∈ r1 → (mkeps r1)" by (rule Posix_mkeps)
      moreover
      have "s ∈ deriv c r2 → v1" by fact
      then have "(c # s) ∈ r2 → (injval r2 c v1)" using IH2 by simp
      moreover
      have "s1 @ s2 ∉ lang (Times (deriv c r1) r2)" by fact
      then have "¬ (∃s₃ s₄. s₃ ≠ [] ∧ s₃ @ s₄ = c # s ∧ [] @ s₃ ∈ lang r1 ∧ s₄ ∈ lang r2)" 
        using right_nullable 
        apply (auto simp add: lang_deriv Deriv_def append_eq_Cons_conv)
        by (metis concI mem_Collect_eq)
      ultimately have "([] @ (c # s)) ∈ Times r1 r2 → Seq (mkeps r1) (injval r2 c v1)"
      by(rule Posix.intros)
      then show "(c # s) ∈ Times r1 r2 → injval (Times r1 r2) c v" using right_nullable by simp
    next
      case not_nullable
      have "s1 ∈ deriv c r1 → v1" by fact
      then have "(c # s1) ∈ r1 → injval r1 c v1" using IH1 by simp
      moreover
      have "¬ (∃s₃ s₄. s₃ ≠ [] ∧ s₃ @ s₄ = s2 ∧ s1 @ s₃ ∈ lang (deriv c r1) ∧ s₄ ∈ lang r2)" by fact
      then have "¬ (∃s₃ s₄. s₃ ≠ [] ∧ s₃ @ s₄ = s2 ∧ (c # s1) @ s₃ ∈ lang r1 ∧ s₄ ∈ lang r2)" by (simp add: lang_deriv Deriv_def)
      ultimately have "((c # s1) @ s2) ∈ Times r1 r2 → Seq (injval r1 c v1) v2" using not_nullable 
        by (rule_tac Posix.intros) (simp_all) 
      then show "(c # s) ∈ Times r1 r2 → injval (Times r1 r2) c v" using not_nullable by simp
    qed
next
  case (Star r)
  have IH: "∧s v. s ∈ deriv c r → v ==> (c # s) ∈ r → injval r c v" by fact
  have "s ∈ deriv c (Star r) → v" by fact
  then consider
      (cons) v1 vs s1 s2 where 
        "v = Seq v1 (Stars vs)" "s = s1 @ s2" 
        "s1 ∈ deriv c r → v1" "s2 ∈ (Star r) → (Stars vs)"
        "¬ (∃s₃ s₄. s₃ ≠ [] ∧ s₃ @ s₄ = s2 ∧ s1 @ s₃ ∈ lang (deriv c r) ∧ s₄ ∈ lang (Star r))" 
        apply(auto elim!: Posix_elims(1-5) simp add: lang_deriv Deriv_def intro: Posix.intros)
        apply(rotate_tac 3)
        apply(erule_tac Posix_elims(6))
        apply (simp add: Posix.intros(6))
        using Posix.intros(7) by blast
    then show "(c # s) ∈ Star r → injval (Star r) c v" 
    proof (cases)
      case cons
          have "s1 ∈ deriv c r → v1" by fact
          then have "(c # s1) ∈ r → injval r c v1" using IH by simp
        moreover
          have "s2 ∈ Star r → Stars vs" by fact
        moreover 
          have "(c # s1) ∈ r → injval r c v1" by fact 
          then have "flat (injval r c v1) = (c # s1)" by (rule Posix1)
          then have "flat (injval r c v1) ≠ []" by simp
        moreover 
          have "¬ (∃s₃ s₄. s₃ ≠ [] ∧ s₃ @ s₄ = s2 ∧ s1 @ s₃ ∈ lang (deriv c r) ∧ s₄ ∈ lang (Star r))" by fact
          then have "¬ (∃s₃ s₄. s₃ ≠ [] ∧ s₃ @ s₄ = s2 ∧ (c # s1) @ s₃ ∈ lang r ∧ s₄ ∈ lang (Star r))" 
            by (simp add: lang_deriv Deriv_def)
        ultimately 
        have "((c # s1) @ s2) ∈ Star r → Stars (injval r c v1 # vs)" by (rule Posix.intros)
        then show "(c # s) ∈ Star r → injval (Star r) c v" using cons by(simp)
    qed
qed


section ‹The Lexer by Sulzmann and Lu›

fun 
  lexer :: "'a rexp → 'a list → ('a val) option"
where
  "lexer r [] = (if nullable r then Some(mkeps r) else None)"
| "lexer r (c#s) = (case (lexer (deriv c r) s) of
                    None → None
                  | Some(v) → Some(injval r c v))"


lemma lexer_correct_None:
  shows "s ∉ lang r ⟷ lexer r s = None"
apply(induct s arbitrary: r)
apply(simp add: nullable_iff)
apply(drule_tac x="deriv a r" in meta_spec)
apply(auto simp add: lang_deriv Deriv_def)
done

lemma lexer_correct_Some:
  shows "s ∈ lang r ⟷ (∃v. lexer r s = Some(v) ∧ s ∈ r → v)"
apply(induct s arbitrary: r)
apply(auto simp add: Posix_mkeps nullable_iff)[1]
apply(drule_tac x="deriv a r" in meta_spec)
apply(simp add: lang_deriv Deriv_def)
apply(rule iffI)
apply(auto intro: Posix_injval simp add: Posix1(1))
done 

lemma lexer_correctness:
  shows "(lexer r s = Some v) ⟷ s ∈ r → v"
  and   "(lexer r s = None) ⟷ ¬(∃v. s ∈ r → v)"
apply(auto)
using lexer_correct_None lexer_correct_Some apply fastforce
using Posix1(1) Posix_determ lexer_correct_Some apply blast
using Posix1(1) lexer_correct_None apply blast
using lexer_correct_None lexer_correct_Some by blast




end