theory GabrielaLimonta
imports "~~/src/HOL/IMP/Star" Complex_Main
begin

text {* We build on @{theory Complex_Main} instead of @{theory Main} to access
the real numbers. *}

subsection "Arithmetic Expressions"

type_synonym val = real

type_synonym vname = string
type_synonym state = "vname \<Rightarrow> val"

text_raw{*\snip{aexptDef}{0}{2}{% *}
datatype aexp = Rc real | V vname | Plus aexp aexp | Div aexp aexp
text_raw{*}%endsnip*}

inductive taval :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
"taval (Rc r) s r" |
"taval (V x) s (s x)" |
"taval a1 s r1 \<Longrightarrow> taval a2 s r2
  \<Longrightarrow> taval (Plus a1 a2) s (r1+r2)" |
"taval a1 s r1 \<Longrightarrow> taval a2 s r2
  \<Longrightarrow> taval (Div a1 a2) s (r1 / r2)"

inductive_cases [elim!]:
  "taval (Rc i) s v"
  "taval (V x) s v"
  "taval (Plus a1 a2) s v"
  "taval (Div a1 a2) s v"

subsection "Boolean Expressions"

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

inductive tbval :: "bexp \<Rightarrow> state \<Rightarrow> bool \<Rightarrow> bool" where
"tbval (Bc v) s v" |
"tbval b s bv \<Longrightarrow> tbval (Not b) s (\<not> bv)" |
"tbval b1 s bv1 \<Longrightarrow> tbval b2 s bv2 \<Longrightarrow> tbval (And b1 b2) s (bv1 & bv2)" |
"taval a1 s r1 \<Longrightarrow> taval a2 s r2 \<Longrightarrow> tbval (Less a1 a2) s (r1 < r2)"

subsection "Syntax of Commands"
(* a copy of Com.thy - keep in sync! *)

datatype
  com = SKIP
      | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
      | Seq    com  com         ("_;; _"  [60, 61] 60)
      | If     bexp com com     ("IF _ THEN _ ELSE _"  [0, 0, 61] 61)
      | While  bexp com         ("WHILE _ DO _"  [0, 61] 61)

subsection "Small-Step Semantics of Commands"

inductive
  small_step :: "(com \<times> state) \<Rightarrow> (com \<times> state) \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "taval a s v \<Longrightarrow> (x ::= a, s) \<rightarrow> (SKIP, s(x := v))" |

Seq1:   "(SKIP;;c,s) \<rightarrow> (c,s)" |
Seq2:   "(c1,s) \<rightarrow> (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow> (c1';;c2,s')" |

IfTrue:  "tbval b s True \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c1,s)" |
IfFalse: "tbval b s False \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP,s)"

lemmas small_step_induct = small_step.induct[split_format(complete)]

subsection "The Type System"

datatype ty = Neg | Pos | Zero | Any

definition ty_of_c :: "real \<Rightarrow> ty" where
  "ty_of_c r = (if r = 0 then Zero else (if r > 0 then Pos else Neg))"

fun ty_of_plus :: "ty \<Rightarrow> ty \<Rightarrow> ty" where
  "ty_of_plus Neg Neg = Neg" |
  "ty_of_plus Pos Pos = Pos" |
  "ty_of_plus Neg Pos = Any" |
  "ty_of_plus Pos Neg = Any" |
  "ty_of_plus Any _ = Any" |
  "ty_of_plus _ Any = Any" |
  "ty_of_plus Zero a = a" |
  "ty_of_plus a Zero = a"

fun ty_of_div :: "ty \<Rightarrow> ty \<Rightarrow> ty option" where
  "ty_of_div Neg Neg = Some Pos" |
  "ty_of_div Pos Pos = Some Pos" |
  "ty_of_div Neg Pos = Some Neg" |
  "ty_of_div Pos Neg = Some Neg" |
  "ty_of_div a Zero = None" |
  "ty_of_div Zero a = Some Zero" |
  "ty_of_div Any Pos = Some Any" |
  "ty_of_div Any Neg = Some Any" |
  "ty_of_div _ Any = None"

type_synonym tyenv = "vname \<Rightarrow> ty"

inductive atyping :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty \<Rightarrow> bool"
  ("(1_/ \<turnstile>/ (_ :/ _))" [50,0,50] 50)
where
Rc_ty: "\<Gamma> \<turnstile> Rc r : ty_of_c r" |
V_ty: "\<Gamma> \<turnstile> V x : \<Gamma> x" |
Plus_ty: "\<Gamma> \<turnstile> a1 : \<tau>1 \<Longrightarrow> \<Gamma> \<turnstile> a2 : \<tau>2 \<Longrightarrow>  \<Gamma> \<turnstile> Plus a1 a2 : ty_of_plus \<tau>1 \<tau>2" |
Div_ty: "\<Gamma> \<turnstile> a1 : \<tau>1 \<Longrightarrow> \<Gamma> \<turnstile> a2 : \<tau>2 \<Longrightarrow> ty_of_div \<tau>1 \<tau>2 = Some \<tau> \<Longrightarrow> \<Gamma> \<turnstile> Div a1 a2 : \<tau>"

fun values_of_type :: "ty \<Rightarrow> real set" where
  "values_of_type Neg = {x. x<0}" |
  "values_of_type Pos = {x. x>0}" |
  "values_of_type Zero = {0}" |
  "values_of_type Any = {x. x<0 \<or> x\<ge>0}"

declare atyping.intros [intro!]
inductive_cases [elim!]:
  "\<Gamma> \<turnstile> V x : \<tau>" "\<Gamma> \<turnstile> Rc r : \<tau>" "\<Gamma> \<turnstile> Plus a1 a2 : \<tau>" "\<Gamma> \<turnstile> Div a1 a2 : \<tau>"

text{* Warning: the ``:'' notation leads to syntactic ambiguities,
i.e. multiple parse trees, because ``:'' also stands for set membership.
In most situations Isabelle's type system will reject all but one parse tree,
but will still inform you of the potential ambiguity. *}

inductive btyping :: "tyenv \<Rightarrow> bexp \<Rightarrow> bool" (infix "\<turnstile>" 50)
where
B_ty: "\<Gamma> \<turnstile> Bc v" |
Not_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> Not b" |
And_ty: "\<Gamma> \<turnstile> b1 \<Longrightarrow> \<Gamma> \<turnstile> b2 \<Longrightarrow> \<Gamma> \<turnstile> And b1 b2" |
Less_ty: "\<Gamma> \<turnstile> a1 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> a2 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> Less a1 a2"

declare btyping.intros [intro!]
inductive_cases [elim!]: "\<Gamma> \<turnstile> Not b" "\<Gamma> \<turnstile> And b1 b2" "\<Gamma> \<turnstile> Less a1 a2"

inductive ctyping :: "tyenv \<Rightarrow> com \<Rightarrow> bool" (infix "\<turnstile>" 50) where
Skip_ty: "\<Gamma> \<turnstile> SKIP" |
Assign_ty: "\<Gamma> \<turnstile> a : \<Gamma>(x) \<Longrightarrow> \<Gamma> \<turnstile> x ::= a" |
Seq_ty: "\<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> c1;;c2" |
If_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> IF b THEN c1 ELSE c2" |
While_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> WHILE b DO c"

declare ctyping.intros [intro!]
inductive_cases [elim!]:
  "\<Gamma> \<turnstile> x ::= a"  "\<Gamma> \<turnstile> c1;;c2"
  "\<Gamma> \<turnstile> IF b THEN c1 ELSE c2"
  "\<Gamma> \<turnstile> WHILE b DO c"

subsection "Well-typed Programs Do Not Get Stuck"
(*
fun type :: "val \<Rightarrow> ty" where
"type (Iv i) = Ity" |
"type (Rv r) = Rty"

lemma type_eq_Rty[simp]: "type v = Rty \<longleftrightarrow> (\<exists>r. v = Rv r)"
by (cases v) simp_all
*)

definition styping :: "tyenv \<Rightarrow> state \<Rightarrow> bool" (infix "\<turnstile>" 50)
where "\<Gamma> \<turnstile> s  \<longleftrightarrow>  (\<forall>x. s x \<in> values_of_type (\<Gamma> x))"

lemma apreservation:
  "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> taval a s v \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> v \<in> (values_of_type \<tau>)"
proof (induction arbitrary: v rule: atyping.induct)
  print_cases
  case (Rc_ty \<Gamma> r)
    thus ?case using ty_of_c_def by fastforce
  next
  case (V_ty \<Gamma> x)
    thus ?case
    proof -
      have "s x = v" using V_ty.prems(1) by force
      thus "v \<in> values_of_type   (\<Gamma> x)" using V_ty.prems(2) styping_def by blast
    qed
  next
  case (Plus_ty \<Gamma> a1 \<tau>1 a2 \<tau>2)
    thus ?case sorry
  next
  case (Div_ty \<Gamma> a1 \<tau>1 a2 \<tau>2 \<tau>)
    thus ?case using taval.intros(4)[of a1 s r1 a2 r2] sorry
qed

(*
apply(induction arbitrary: v rule: atyping.induct)
apply (fastforce simp: styping_def)+
done*)

lemma aprogress: "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. taval a s v"
proof(induction rule: atyping.induct)
  print_cases
  case (Plus_ty \<Gamma> a1 \<tau>1 a2 \<tau>2)
  then obtain v1 v2 where v: "taval a1 s v1" "taval a2 s v2" by blast
  show ?case using Plus_ty taval.intros by blast
qed (auto intro: taval.intros)

lemma bprogress: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. tbval b s v"
proof(induction rule: btyping.induct)
print_cases
  case (Less_ty \<Gamma> a1 t a2)
  then obtain v1 v2 where v: "taval a1 s v1" "taval a2 s v2"
    by (metis aprogress)
  show ?case using tbval.intros v(1) v(2) by blast
qed (auto intro: tbval.intros)

theorem progress:
  "\<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c \<noteq> SKIP \<Longrightarrow> \<exists>cs'. (c,s) \<rightarrow> cs'"
proof(induction rule: ctyping.induct)
  case Skip_ty thus ?case by simp
next
  case Assign_ty
  thus ?case by (metis Assign aprogress)
next
  case Seq_ty thus ?case by simp (metis Seq1 Seq2)
next
  case (If_ty \<Gamma> b c1 c2)
  then obtain bv where "tbval b s bv" by (metis bprogress)
  show ?case
  proof(cases bv)
    assume "bv"
    with `tbval b s bv` show ?case by simp (metis IfTrue)
  next
    assume "\<not>bv"
    with `tbval b s bv` show ?case by simp (metis IfFalse)
  qed
next
  case While_ty show ?case by (metis While)
qed

theorem styping_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<Gamma> \<turnstile> s'"
proof(induction rule: small_step_induct)
  case Assign thus ?case
    by (auto simp: styping_def) (metis Assign(1,3) apreservation)
qed auto

theorem ctyping_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> c'"
by (induct rule: small_step_induct) (auto simp: ctyping.intros)

abbreviation small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

theorem type_sound:
  "(c,s) \<rightarrow>* (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c' \<noteq> SKIP
   \<Longrightarrow> \<exists>cs''. (c',s') \<rightarrow> cs''"
apply(induction rule:star_induct)
apply (metis progress)
by (metis styping_preservation ctyping_preservation)

end


(*  Title:      HOL/Corec_Examples/Tests/Small_Concrete.thy
    Author:     Aymeric Bouzy, Ecole polytechnique
    Author:     Jasmin Blanchette, Inria, LORIA, MPII
    Copyright   2015, 2016

Small concrete examples.
*)

section \<open>Small Concrete Examples\<close>

theory Small_Concrete
imports "HOL-Library.BNF_Corec"
begin

subsection \<open>Streams of Natural Numbers\<close>

codatatype natstream = S (head: nat) (tail: natstream)

corec (friend) incr_all where
  "incr_all s = S (head s + 1) (incr_all (tail s))"

corec all_numbers where
  "all_numbers = S 0 (incr_all all_numbers)"

corec all_numbers_efficient where
  "all_numbers_efficient n = S n (all_numbers_efficient (n + 1))"

corec remove_multiples where
  "remove_multiples n s =
    (if (head s) mod n = 0 then
      S (head (tail s)) (remove_multiples n (tail (tail s)))
    else
      S (head s) (remove_multiples n (tail s)))"

corec prime_numbers where
  "prime_numbers known_primes =
    (let next_prime = head (fold (%n s. remove_multiples n s) known_primes (tail (tail all_numbers))) in
      S next_prime (prime_numbers (next_prime # known_primes)))"

term "prime_numbers []"

corec prime_numbers_more_efficient where
  "prime_numbers_more_efficient n remaining_numbers =
    (let remaining_numbers = remove_multiples n remaining_numbers in
      S (head remaining_numbers) (prime_numbers_more_efficient (head remaining_numbers) remaining_numbers))"

term "prime_numbers_more_efficient 0 (tail (tail all_numbers))"

corec (friend) alternate where
  "alternate s1 s2 = S (head s1) (S (head s2) (alternate (tail s1) (tail s2)))"

corec (friend) all_sums where
  "all_sums s1 s2 = S (head s1 + head s2) (alternate (all_sums s1 (tail s2)) (all_sums (tail s1) s2))"

corec app_list where
  "app_list s l = (case l of
    [] \<Rightarrow> s
  | a # r \<Rightarrow> S a (app_list s r))"

friend_of_corec app_list where
  "app_list s l = (case l of
    [] \<Rightarrow> (case s of S a b \<Rightarrow> S a b)
  | a # r \<Rightarrow> S a (app_list s r))"
  sorry

corec expand_with where
  "expand_with f s = (let l = f (head s) in S (hd l) (app_list (expand_with f (tail s)) (tl l)))"

friend_of_corec expand_with where
  "expand_with f s = (let l = f (head s) in S (hd l) (app_list (expand_with f (tail s)) (tl l)))"
  sorry

corec iterations where
  "iterations f a = S a (iterations f (f a))"

corec exponential_iterations where
  "exponential_iterations f a = S (f a) (exponential_iterations (f o f) a)"

corec (friend) alternate_list where
  "alternate_list l = (let heads = (map head l) in S (hd heads) (app_list (alternate_list (map tail l)) (tl heads)))"

corec switch_one_two0 where
  "switch_one_two0 f a s = (case s of
    S b r \<Rightarrow> S b (S a (f r)))"

corec switch_one_two where
  "switch_one_two s = (case s of
    S a (S b r) \<Rightarrow> S b (S a (switch_one_two r)))"

corec fibonacci where
  "fibonacci n m = S m (fibonacci (n + m) n)"

corec sequence2 where
  "sequence2 f u1 u0 = S u0 (sequence2 f (f u1 u0) u1)"

corec (friend) alternate_with_function where
  "alternate_with_function f s =
    (let f_head_s = f (head s) in S (head f_head_s) (alternate (tail f_head_s) (alternate_with_function f (tail s))))"

corec h where
  "h l s = (case l of
    [] \<Rightarrow> s
  | (S a s') # r \<Rightarrow> S a (alternate s (h r s')))"

friend_of_corec h where
  "h l s = (case l of
    [] \<Rightarrow> (case s of S a b \<Rightarrow> S a b)
  | (S a s') # r \<Rightarrow> S a (alternate s (h r s')))"
  sorry

corec z where
  "z = S 0 (S 0 z)"

lemma "\<And>x. x = S 0 (S 0 x) \<Longrightarrow> x = z"
  apply corec_unique
  apply (rule z.code)
  done

corec enum where
  "enum m = S m (enum (m + 1))"

lemma "(\<And>m. f m = S m (f (m + 1))) \<Longrightarrow> f m = enum m"
  apply corec_unique
  apply (rule enum.code)
  done

lemma "(\<forall>m. f m = S m (f (m + 1))) \<Longrightarrow> f m = enum m"
  apply corec_unique
  apply (rule enum.code)
  done

subsection \<open>Lazy Lists of Natural Numbers\<close>

codatatype llist = LNil | LCons nat llist

corec h1 where
  "h1 x = (if x = 1 then
    LNil
  else
    let x = if x mod 2 = 0 then x div 2 else 3 * x + 1 in
    LCons x (h1 x))"

corec h3 where
  "h3 s = (case s of
    LNil \<Rightarrow> LNil
  | LCons x r \<Rightarrow> LCons x (h3 r))"

corec fold_map where
  "fold_map f a s = (let v = f a (head s) in S v (fold_map f v (tail s)))"

friend_of_corec fold_map where
  "fold_map f a s = (let v = f a (head s) in S v (fold_map f v (tail s)))"
   apply (rule fold_map.code)
  sorry

subsection \<open>Coinductive Natural Numbers\<close>

codatatype conat = CoZero | CoSuc conat

corec sum where
  "sum x y = (case x of
      CoZero \<Rightarrow> y
    | CoSuc x \<Rightarrow> CoSuc (sum x y))"

friend_of_corec sum where
  "sum x y = (case x of
      CoZero \<Rightarrow> (case y of CoZero \<Rightarrow> CoZero | CoSuc y \<Rightarrow> CoSuc y)
    | CoSuc x \<Rightarrow> CoSuc (sum x y))"
  sorry

corec (friend) prod where
  "prod x y = (case (x, y) of
      (CoZero, _) \<Rightarrow> CoZero
    | (_, CoZero) \<Rightarrow> CoZero
    | (CoSuc x, CoSuc y) \<Rightarrow> CoSuc (sum (prod x y) (sum x y)))"

end


theory concrete_03
  imports Main

begin

(*3.1 Arithmetic Expressions*)
type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp

value "N 5"
value "V ''x''"
value "Plus (V ''x'') (V ''y'')"
value "Plus (N 2) (Plus (V ''z'') (N 3))"

type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a1 a2) s = aval a1 s + aval a2 s"

(*The \<lambda>x.0 here means a state: x \<Rightarrow> 0*)
value "aval (Plus (N 3) (V ''x'')) (\<lambda>x.0)"
(*the same: f(a := b) = (\<lambda>x. if x = a then b else f x)*)
value "aval (Plus (N 3)(V ''x'')) (f(''x'' := 0))"

(*x + y + z + w, let x = 7, y = 3, others = 0*)
value "aval (Plus (V ''x'') (Plus (V ''y'') (Plus (V ''z'') (V ''w'')))) (((\<lambda>x. 0)(''x'':=7))(''y'':=3))"
(*the same: error \<rightarrow> how to use <''x'':=7, ''y'':=3>*)
(*value "aval (Plus (V ''x'') (Plus (V ''y'') (Plus (V ''z'') (V ''w'')))) <''x'':=7, ''y'':=3>"*)

fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a1 a2) =
  (case (asimp_const a1, asimp_const a2) of
    (N n1, N n2) \<Rightarrow> N (n1 + n2) |
     (b1, b2) \<Rightarrow> Plus b1 b2
  )
"

lemma "aval (asimp_const a) s = aval a s"
  apply(induction a)
    (*Why the split is wrote with auto not above?*)
    (*\<rightarrow> The split modifier is the hint to auto to perform a case split whenever it sees a case expression over aexp.*)
    apply(auto split: aexp.split)
  done

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i1) (N i2) = N (i1 + i2)" |
"plus (N i) a = (if i=0 then a else (Plus (N i) a))" |
"plus a (N i) = (if i=0 then a else (Plus a (N i)))" |
"plus a1 a2 = Plus a1 a2"

lemma aval_plus[simp]: "aval (plus a1 a2) s = aval a1 s + aval a2 s"
  apply(induction a1 a2 rule: plus.induct)
  apply(auto)
  done

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a1 a2) = plus (asimp a1) (asimp a2)"

lemma "aval (asimp a) s = aval a s"
  apply(induction a)
    apply(auto)
(*it's so sad... I don't know where is wrong.*)
(*it's ok after rewriting the done of aval_plus...*)
  done

(*3.2 Boolean Expressions*)
datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc v) s = v" |
"bval (Not b) s = (\<not> bval b s)" |
"bval (And b1 b2) s = (bval b1 s \<and> bval b2 s)" |
"bval (Less a1 a2) s = (aval a1 s < aval a2 s)"

(*The following is some optimizing versions of the constructors.*)
fun not :: "bexp \<Rightarrow> bexp" where
"not (Bc True) = Bc False" |
"not (Bc False) = Bc True" |
"not b = Not b"

fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
(*why this and has parentheses? collision with the keyword and?*)
"and (Bc True) b = b" |
"and b (Bc True) = b" |
"and (Bc False) b = Bc False" |
"and b (Bc False) = Bc False" |
"and b1 b2 = And b1 b2"

fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"less (N n1) (N n2) = Bc (n1 < n2)" |
"less a1 a2 = Less a1 a2"

fun bsimp :: "bexp \<Rightarrow> bexp" where
"bsimp (Bc v) = Bc v" |
"bsimp (Not b) = not (bsimp b)" |
"bsimp (And b1 b2) = and (bsimp b1) (bsimp b2)" |
"bsimp (Less a1 a2) = less (asimp a1) (asimp a2)"
(*Note that in the Less case we must switch from bsimp to asimp \<rightarrow> Why?*)

(*3.3 Stack Machine and Compilation*)
datatype instr = LOADI val | LOAD vname | ADD
type_synonym stack = "val list"

abbreviation "hd2 xs \<equiv> hd (tl xs)"
abbreviation "tl2 xs \<equiv> tl (tl xs)"

(*It's tooooo hard for me now. Saaaaad... /TAT\*)
fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec1 (LOADI n) _ stk = n # stk" |
"exec1 (LOAD x) s stk = s(x) # stk" |
"exec1 ADD _ stk = (hd2 stk + hd stk) # tl2 stk"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec [] _ stk = stk" |
"exec (i # is) s stk = exec is s (exec1 i s stk)"

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e1 e2) = comp e1 @ comp e2 @ [ADD]"

lemma pre_exec_1: "exec (is1 @ is2) s stk = exec is2 s (exec is1 s stk)"
  apply(induction is1)
  apply(auto)
(*where is wrong again?*)

lemma "exec (comp a) s stk = aval a s # stk"
  apply(induction a)
    apply(auto)

end


theory UteDefs
imports "../HOModel"
begin

section {* Verification of the \ute{} Consensus Algorithm *}

text {*
  Algorithm \ute{} is presented in~\cite{biely:tolerating}. It is an
  uncoordinated algorithm that tolerates value (a.k.a.\ Byzantine) faults,
  and can be understood as a variant of \emph{UniformVoting}. The parameters
  $T$, $E$, and $\alpha$ appear as thresholds of the algorithm and in the
  communication predicates. Their values can be chosen within certain bounds
  in order to adapt the algorithm to the characteristics of different systems.

  We formalize in Isabelle the correctness proof of the algorithm that
  appears in~\cite{biely:tolerating}, using the framework of theory
  @{text HOModel}.
*}

subsection {* Model of the Algorithm *}

text {*
  We begin by introducing an anonymous type of processes of finite
  cardinality that will instantiate the type variable @{text "'proc"}
  of the generic HO model.
*}

typedecl Proc -- {* the set of processes *}
axiomatization where Proc_finite: "OFCLASS(Proc, finite_class)"
instance Proc :: finite by (rule Proc_finite)

abbreviation
  "N \<equiv> card (UNIV::Proc set)"   -- {* number of processes *}

text {*
  The algorithm proceeds in \emph{phases} of $2$ rounds each (we call
  \emph{steps} the individual rounds that constitute a phase).
  The following utility functions compute the phase and step of a round,
  given the round number.
*}

abbreviation
 "nSteps \<equiv> 2"
definition phase where "phase (r::nat) \<equiv> r div nSteps"
definition step where "step (r::nat) \<equiv> r mod nSteps"

lemma phase_zero [simp]: "phase 0 = 0"
by (simp add: phase_def)

lemma step_zero [simp]: "step 0 = 0"
by (simp add: step_def)

lemma phase_step: "(phase r * nSteps) + step r = r"
  by (auto simp add: phase_def step_def)

text {* The following record models the local state of a process. *}

record 'val pstate =
  x :: 'val                -- {* current value held by process *}
  vote :: "'val option"    -- {* value the process voted for, if any *}
  decide :: "'val option"  -- {* value the process has decided on, if any *}

text {* Possible messages sent during the execution of the algorithm. *}

datatype 'val msg =
   Val "'val"
 | Vote "'val option"

text {*
  The @{text x} field of the initial state is unconstrained, all other
  fields are initialized appropriately.
*}

definition Ute_initState where
  "Ute_initState p st \<equiv>
   (vote st = None) \<and> (decide st = None)"

text {*
  The following locale introduces the parameters used for the \ute{}
  algorithm and their constraints~\cite{biely:tolerating}.
*}

locale ute_parameters =
  fixes \<alpha>::nat and T::nat and E::nat
  assumes majE: "2*E \<ge> N + 2*\<alpha>"
      and majT: "2*T \<ge> N + 2*\<alpha>"
      and EltN: "E < N"
      and TltN: "T < N"
begin

text {* Simple consequences of the above parameter constraints. *}

lemma alpha_lt_N: "\<alpha> < N"
using EltN majE by auto

lemma alpha_lt_T: "\<alpha> < T"
using majT alpha_lt_N by auto

lemma alpha_lt_E: "\<alpha> < E"
using majE alpha_lt_N by auto

text {*
  We separately define the transition predicates and the send functions
  for each step and later combine them to define the overall next-state relation.
*}

text {*
  In step 0, each process sends its current @{text x}.
  If it receives the value $v$ more than $T$ times, it votes for $v$,
  otherwise it doesn't vote.
*}

definition
  send0 :: "nat \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> 'val msg"
where
  "send0 r p q st \<equiv> Val (x st)"

definition
  next0 :: "nat \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> (Proc \<Rightarrow> 'val msg option)
                \<Rightarrow> 'val pstate \<Rightarrow> bool"
where
  "next0 r p st msgs st' \<equiv>
     (\<exists>v. card {q. msgs q = Some (Val v)} > T \<and> st' = st \<lparr> vote := Some v \<rparr>)
   \<or> \<not>(\<exists>v. card {q. msgs q = Some (Val v)} > T) \<and> st' = st \<lparr> vote := None \<rparr>"

text {*
  In step 1, each process sends its current @{text vote}.

  If it receives more than @{text "\<alpha>"} votes for a given value @{text v},
  it sets its @{text x} field to @{text v}, else it sets @{text x} to a
  default value.

  If the process receives more than @{text E} votes for @{text v}, it decides
  @{text v}, otherwise it leaves its decision unchanged.
*}

definition
  send1 :: "nat \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> 'val msg"
where
  "send1 r p q st \<equiv> Vote (vote st)"

definition
  next1 :: "nat \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> (Proc \<Rightarrow> 'val msg option)
                \<Rightarrow> 'val pstate \<Rightarrow> bool"
where
  "next1 r p st msgs st' \<equiv>
    ( (\<exists>v. card {q. msgs q = Some (Vote (Some v))} > \<alpha> \<and> x st' = v)
     \<or> \<not>(\<exists>v. card {q. msgs q = Some (Vote (Some v))} > \<alpha>)
         \<and> x st' = undefined  )
  \<and> ( (\<exists>v. card {q. msgs q = Some (Vote (Some v))} > E \<and> decide st' = Some v)
     \<or> \<not>(\<exists>v. card {q. msgs q = Some (Vote (Some v))} > E)
         \<and> decide st' = decide st )
  \<and> vote st' = None"

text {*
  The overall send function and next-state relation are simply obtained as
  the composition of the individual relations defined above.
*}

definition
  Ute_sendMsg :: "nat \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> 'val msg"
where
  "Ute_sendMsg (r::nat) \<equiv> if step r = 0 then send0 r else send1 r"

definition
  Ute_nextState :: "nat \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> (Proc \<Rightarrow> 'val msg option)
                        \<Rightarrow> 'val pstate \<Rightarrow> bool"
where
  "Ute_nextState r \<equiv> if step r = 0 then next0 r else next1 r"

subsection {* Communication Predicate for \ute{} *}

text {*
  Following~\cite{biely:tolerating}, we now define the communication predicate
  for the \ute{} algorithm to be correct.

  The round-by-round predicate stipulates the following conditions:
  \begin{itemize}
  \item no process may receive more than @{text "\<alpha>"} corrupted messages, and
  \item every process should receive more than @{text "max(T, N + 2*\<alpha> - E - 1)"}
    correct messages.
  \end{itemize}
  \cite{biely:tolerating} also requires that every process should receive more
  than @{text "\<alpha>"} correct messages, but this is implied, since @{text "T > \<alpha>"}
  (cf. lemma @{text alpha_lt_T}).
*}

definition Ute_commPerRd where
  "Ute_commPerRd HOrs SHOrs \<equiv>
   \<forall>p. card (HOrs p - SHOrs p) \<le> \<alpha>
     \<and> card (SHOrs p \<inter> HOrs p) > N + 2*\<alpha> - E - 1
     \<and> card (SHOrs p \<inter> HOrs p) > T"

text {*
  The global communication predicate requires there exists some phase
  @{text "\<Phi>"} such that:
  \begin{itemize}
  \item all HO and SHO sets of all processes are equal in the second step
    of phase @{text "\<Phi>"}, i.e.\ all processes receive messages from the
    same set of processes, and none of these messages is corrupted,
  \item every process receives more than @{text T} correct messages in
    the first step of phase @{text "\<Phi>+1"}, and
  \item every process receives more than @{text E} correct messages in the
    second step of phase @{text "\<Phi>+1"}.
  \end{itemize}
  The predicate in the article~\cite{biely:tolerating} requires infinitely
  many such phases, but one is clearly enough.
*}

definition Ute_commGlobal where
  "Ute_commGlobal HOs SHOs \<equiv>
    \<exists>\<Phi>. (let r = Suc (nSteps*\<Phi>)
         in  (\<exists>\<pi>. \<forall>p. \<pi> = HOs r p \<and> \<pi> = SHOs r p)
           \<and> (\<forall>p. card (SHOs (Suc r) p \<inter> HOs (Suc r) p) > T)
           \<and> (\<forall>p. card (SHOs (Suc (Suc r)) p \<inter> HOs (Suc (Suc r)) p) > E))"

subsection {* The \ute{} Heard-Of Machine *}

text {*
  We now define the coordinated HO machine for the \ute{} algorithm
  by assembling the algorithm definition and its communication-predicate.
*}

definition Ute_SHOMachine where
  "Ute_SHOMachine = \<lparr>
     CinitState =  (\<lambda> p st crd. Ute_initState p st),
     sendMsg =  Ute_sendMsg,
     CnextState = (\<lambda> r p st msgs crd st'. Ute_nextState r p st msgs st'),
     SHOcommPerRd = Ute_commPerRd,
     SHOcommGlobal = Ute_commGlobal
   \<rparr>"

abbreviation
  "Ute_M \<equiv> (Ute_SHOMachine::(Proc, 'val pstate, 'val msg) SHOMachine)"

end   -- {* locale @{text "ute_parameters"} *}

end   (* theory UteDefs *)


theory MU
  imports Main
begin

datatype Symbol = M | I | U

type_synonym word = "Symbol list"

inductive legit :: "word \<Rightarrow> bool" where
  start: "legit [M, I]"
| rule1: "\<lbrakk> legit (w @ [I]) \<rbrakk> \<Longrightarrow> legit (w @ [I, U])"
| rule2: "\<lbrakk> legit (M#x) \<rbrakk> \<Longrightarrow> legit ((M#x) @ x)"
| rule3: "\<lbrakk> legit (w @ [I,I,I] @ w') \<rbrakk> \<Longrightarrow> legit (w @ [U] @ w')"
| rule4: "\<lbrakk> legit (w @ [U,U] @ w') \<rbrakk> \<Longrightarrow> legit (w @ w')"

section \<open> Examples \<close>

lemma "legit [M,I,U] \<Longrightarrow> legit [M,I,U,I,U]"
  using rule2[of "[I,U]"] by simp

lemma "legit [M,U,M] \<Longrightarrow> legit [M,U,M,U,M]"
  using rule2[of "[U,M]"] by simp

lemma "legit [M,U] \<Longrightarrow> legit [M,U,U]"
  using rule2[of "[U]"] by simp

lemma "legit [U,M,I,I,I,M,U] \<Longrightarrow> legit [U,M,U,M,U]"
  using rule3[of "[U,M]" "[M,U]"] by simp

lemma "legit [M,I,I,I,I] \<Longrightarrow> legit [M,I,U]"
  using rule3[of "[M,I]" "[]"] by simp

lemma "legit [M,I,I,I,I] \<Longrightarrow>  legit [M,U,I]"
  using rule3[of "[M]" "[I]"] by simp

lemma "legit [U,U,U] \<Longrightarrow> legit [U]"
  using rule4[of "[U]" "[]"] by simp

lemma "legit [M,U,U,U,I,I,I] \<Longrightarrow> legit [M,U,I,I,I]"
  using rule4[of "[M,U]" "[I,I,I]"] by simp

lemma "legit [M,U,I,I,U]"
proof -
  have "legit [M,I]"                by (simp add: start)
  then have "legit [M,I,I]"         using rule2[of "[I]"] by simp
  then have "legit [M,I,I,I,I]"     using rule2[of "[I,I]"] by simp
  then have "legit [M,I,I,I,I,U]"   using rule1[of "[M,I,I,I]"] by simp
  then have "legit [M,U,I,U]"       using rule3[of "[M]" "[I,U]"] by simp
  then have "legit [M,U,I,U,U,I,U]" using rule2[of "[U,I,U]"] by simp
  then have "legit [M,U,I,I,U]"     using rule4[of "[M,U,I]" "[I,U]"] by simp
  then show ?thesis .
qed

section \<open> Meta-Theorems \<close>

lemma legit_starts_with_M: "legit w \<Longrightarrow> hd w = M"
  apply(induction rule: legit.induct)
  apply(simp_all)
  apply (metis hd_append list.sel(1))
  apply (metis Cons_eq_append_conv Symbol.distinct(2) hd_append2 list.sel(1))
  by (metis Symbol.distinct(4) append_eq_Cons_conv hd_append2 list.sel(1))

corollary "\<not> legit [U]"
  using legit_starts_with_M by force

fun number_of_I :: "word \<Rightarrow> nat" where
  "number_of_I [] = 0"
| "number_of_I (I#w) = 1 + number_of_I w"
| "number_of_I (_#w) = number_of_I w"

lemma number_of_I_append: "number_of_I (w @ v) = number_of_I w + number_of_I v"
  apply(induction w, simp_all)
  by (metis (full_types) Symbol.exhaust add_Suc number_of_I.simps(2) number_of_I.simps(3) number_of_I.simps(4) plus_1_eq_Suc)

lemma helper: "(n::nat) mod 3 \<noteq> 0 \<Longrightarrow> (2 * n) mod 3 \<noteq> 0"
proof(induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  have "(2 * (n + 1)) mod 3 = (((2 * n) mod 3) + 2) mod 3" using mod_Suc_Suc_eq by auto
  then show ?case
    by (metis Suc.prems Suc_1 Suc_eq_plus1 add.left_neutral eval_nat_numeral(3) mod_add_left_eq mod_mult_self2_is_0 mult.commute semiring_normalization_rules(2))
qed

lemma invariant: "legit w \<Longrightarrow> (number_of_I w) mod 3 \<noteq> 0"
proof(induction rule: legit.induct)
case start
  then show ?case by simp
next
  case (rule1 w)
  then show ?case by (simp add: number_of_I_append)
next
  case (rule2 x)
  have "number_of_I ((M # x) @ x) = 2 * number_of_I (M # x)" using number_of_I_append
    by simp
  then show ?case using helper rule2 by simp
next
  case (rule3 w w')
  have "number_of_I (w @ [I, I, I] @ w') = 3 + number_of_I w + number_of_I w'" by (simp add: number_of_I_append)
  then have "(number_of_I (w @ [I, I, I] @ w')) mod 3 = (number_of_I (w @ w')) mod 3"
    by (simp add: number_of_I_append)
  then show ?case using number_of_I_append rule3.IH by auto
next
  case (rule4 w w')
  then show ?case by (simp add: number_of_I_append)
qed

theorem "\<not> legit [M,U]"
proof -
  have "number_of_I [M,U] mod 3 = 0" by auto
  then show ?thesis
    using invariant by meson
qed

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_03
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun y :: "'a list => 'a list => 'a list" where
  "y (nil2) y2 = y2"
| "y (cons2 z2 xs) y2 = cons2 z2 (y xs y2)"

fun x :: "Nat => Nat => bool" where
  "x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y22) = x x2 y22"

fun count :: "Nat => Nat list => Nat" where
  "count z (nil2) = Z"
| "count z (cons2 z2 ys) =
     (if x z z2 then S (count z ys) else count z ys)"

fun t2 :: "Nat => Nat => bool" where
  "t2 (Z) y2 = True"
| "t2 (S z2) (Z) = False"
| "t2 (S z2) (S x2) = t2 z2 x2"

theorem property0 :
  "t2 (count n xs) (count n (y xs ys))"
  find_proof DInd
  (*Why induction on xs?
    Because the innermost recursively defined constant "y" is defined recursively on the
    first parameter, which is "xs" in this case.
    Because "t2" is defined recursively on the first parameter, which is "count n xs" here,
    and "count" is defined recursively on the second parameter ("xs" in this case).*)
  apply(induct xs)
  (*auto can discharge these sub-goals.*)
   apply(subst count.simps)
   apply(subst t2.simps)
   apply(rule TrueI)
  apply(subst y.simps)
  apply(subst count.simps)
  apply(simp del:t2.simps)
  apply(subst t2.simps)
  apply(rule impI)
  apply(thin_tac "x n x1")
  apply assumption
  done

theorem property0' :
  "t2 (count n xs) (count n (y xs ys))"
  (*"xs" is optional.
    Other generalizations also work:
    "arbitrary: n"
    "arbitrary: n ys"
    "arbitrary: ys"
    "arbitrary: ys n"
    *)
  apply (induct xs arbitrary: n rule: TIP_prop_03.count.induct)
  apply auto
  done

theorem property0'' :
  "t2 (count n xs) (count n (y xs ys))"
  apply(induct n)
  (*This is bad:
    The first sub-goal is identical to the original goal.
    Not really.
   *)
  oops

theorem property0''' :
  "t2 (count n xs) (count n (y xs ys))"
  apply(induct rule:y.induct)
   apply fastforce
  nitpick
  oops

end


theory P18 imports Main begin

datatype 'a tree =
  Leaf ("\<langle>\<rangle>") |
  Node "'a tree" ("value": 'a) "'a tree" ("(1\<langle>_,/ _,/ _\<rangle>)")
datatype_compat tree

fun preOrder :: "'a tree \<Rightarrow> 'a list" where
"preOrder \<langle>\<rangle> = []" |
"preOrder \<langle>l, x, r\<rangle> = x # preOrder l @ preOrder r"

fun postOrder :: "'a tree \<Rightarrow> 'a list" where
"postOrder \<langle>\<rangle> = []" |
"postOrder \<langle>l, x, r\<rangle> = postOrder l @ postOrder r @ [x]"

fun inOrder :: "'a tree \<Rightarrow> 'a list" where
"inOrder \<langle>\<rangle> = []" |
"inOrder \<langle>l, x, r\<rangle> = inOrder l @ [x] @ inOrder r"

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
"mirror \<langle>\<rangle> = \<langle>\<rangle>" |
"mirror \<langle>l, x, r\<rangle> = \<langle>mirror r, x, mirror l\<rangle>"

lemma "preOrder (mirror xt) = rev (preOrder xt)"
  nitpick
  oops

lemma "preOrder (mirror xt) = rev (postOrder xt)"
  apply (induct xt)
   apply auto
  done

lemma "preOrder (mirror xt) = rev (inOrder xt)"
  nitpick
  oops

lemma "postOrder (mirror xt) = rev (preOrder xt)"
  apply (induct xt)
   apply auto
  done

lemma "postOrder (mirror xt) = rev (postOrder xt)"
  nitpick
  oops

lemma "postOrder (mirror xt) = rev (inOrder xt)"
  nitpick
  oops

lemma "inOrder (mirror xt) = rev (preOrder xt)"
  nitpick
  oops

lemma "inOrder (mirror xt) = rev (postOrder xt)"
  nitpick
  oops

lemma "inOrder (mirror xt) = rev (inOrder xt)"
  apply (induct xt)
   apply auto
  done

fun root :: "'a tree \<Rightarrow> 'a" where
"root xt = (hd (preOrder xt))"

fun leftmost :: "'a tree \<Rightarrow> 'a" where
"leftmost xt = (hd (inOrder xt))"

fun rightmost :: "'a tree \<Rightarrow> 'a" where
"rightmost xt = (last (inOrder xt))"

theorem "last (inOrder xt) = rightmost xt"
  apply (induct xt)
   apply auto
  done

theorem "hd (inOrder xt) = leftmost xt"
  apply (induct xt)
   apply auto
  done

theorem "hd (preOrder xt) = last (postOrder xt)"
  nitpick
  oops

theorem "hd (preOrder xt) = root xt"
  apply (induct xt)
   apply auto
  done

theorem "hd (inOrder xt) = root xt"
  nitpick
  oops

theorem "last (postOrder xt) = root xt"
  nitpick
  oops

end


section {* Abstract syntax for Logic. *}

theory Syntax_SL_test
  imports  Main HOL.Real
begin

(*Constants*)
datatype val = Real real     ("Real _" 76)
             | String string ("String _" 76)
             | Bool bool     ("Bool _" 76)
| Err
(*Expressions of HCSP language.*)
datatype exp = Con val ("Con _" 75)
             | RVar string   ("RVar _" 75 )
             | SVar string   ("SVar _" 75)
             | BVar string   ("BVar _" 75)
             | Add exp exp   (infixr "[+]" 70)
             | Sub exp exp   (infixl  "[-]" 70)
             | Mul exp exp   (infixr "[*]" 71)
(*to complete all related to divide in  following functions.*)
             | Div exp exp   (infixr "[**]" 71)
ML {*
@{term "Real a"}
*}

ML{*
@{term "RVar a"}

*}

ML{*
@{term "a [+] b"}

*}

(*Type declarations to be used in {*proc*}*)
datatype typeid = R | S | B
(*States*)
type_synonym state = "string * typeid => val"

(*Evaluation of expressions*)
primrec evalE :: "exp \<Rightarrow> state => val" where
"evalE (Con y) f = y" |
"evalE (RVar (x)) f = f (x, R)" |
"evalE (SVar (x)) f = f (x, S)" |
"evalE (BVar (x)) f = f (x, B)" |
"evalE (e1 [+] e2) f = (case (evalE e1 f) of Real (x) =>
                                         (case (evalE e2 f) of Real (y) => Real (x + y) |
                                                                          _    => Err)|
                                                              _ => Err)" |
"evalE (e1 [-] e2) f = (case (evalE e1 f) of  Real (x) =>
                                         (case (evalE e2 f) of  Real (y) =>  Real (x - y) |
                                                                          _    => Err)|
                                                              _ => Err)" |
"evalE (e1 [*] e2) f = (case (evalE e1 f) of  Real (x) =>
                                         (case (evalE e2 f) of Real (y) =>  Real (x * y) |
                                                                          _    => Err)|
                                                              _ => Err)"

section{*FOL operators*}
type_synonym fform = "state  \<Rightarrow> bool"
definition fTrue:: "fform" where " fTrue == \<lambda> s. True"
definition fFalse:: "fform" where "fFalse == \<lambda> s. False"
definition fEqual :: "exp \<Rightarrow> exp \<Rightarrow> fform"  ("_[=]_" 69) where
"e [=] f == \<lambda> s. evalE e s = evalE f s"
definition fLess :: "exp \<Rightarrow> exp \<Rightarrow> fform"  ("_[<]_" 69) where
"e [<] f == \<lambda> s. (case (evalE e s) of Real c \<Rightarrow> (case (evalE f s) of Real d \<Rightarrow> (c<d)
                                                                    |  _ \<Rightarrow> False)
                                       |  _ \<Rightarrow> False )"

definition fAnd :: "fform \<Rightarrow> fform \<Rightarrow> fform"  (infixl "[&]"  65) where
"P [&] Q == \<lambda> s. P s \<and> Q s"
definition fOr :: "fform\<Rightarrow> fform \<Rightarrow> fform"  (infixl "[|]" 65) where
"P [|] Q == \<lambda> s. P s \<or> Q s"
definition fNot :: "fform \<Rightarrow> fform"  ("[\<not>]_" 67) where
"[\<not>]P == \<lambda> s. \<not> P s"
definition fImp :: "fform \<Rightarrow> fform \<Rightarrow> fform"  (infixl "[\<longrightarrow>]" 65) where
"P [\<longrightarrow>] Q == \<lambda> s. P s \<longrightarrow> Q s"

definition fLessEqual :: "exp \<Rightarrow> exp \<Rightarrow> fform"  ("_[\<le>]_" 69) where
"e [\<le>] f == (e [=] f) [|] (e [<] f)"
definition fGreaterEqual :: "exp \<Rightarrow> exp \<Rightarrow> fform"  ("_[\<ge>]_" 69) where
"e [\<ge>] f == [\<not>](e [<] f)"
definition fGreater :: "exp \<Rightarrow> exp \<Rightarrow> fform"  ("_[>]_" 69) where
"e [>] f == [\<not>](e [\<le>] f)"

(*For substitution*)
definition fSubForm :: "fform \<Rightarrow> exp \<Rightarrow> string \<Rightarrow> typeid \<Rightarrow> fform" ("_[_,_,_]" 70) where
"P [e, a, b] == (\<lambda>s. P (\<lambda> (x, r). (if (x = a \<and> r = b) then (evalE e s)
                                                            else (s (x, r)))))"

(*close() extends the formula with the boundary, used for continuous evolution.*)
consts close :: "fform \<Rightarrow> fform"

axiomatization where
Lessc[simp]: "close (e [<] f) = e [\<le>] f" and
Greatc[simp]: "close (e [>] f) = e [\<ge>] f" and
Equalc[simp]: "close (e [=] f) = e [=] f" and
GreatEqual[simp] : "close ( e [\<ge>] f) =  e [\<ge>] f" and
Andc[simp]: "close (P [&] Q) = close (P) [&] close (Q)" and
Orc[simp]: "close (P [|] Q) = close (P) [|] close (Q)"

lemma notLess : "close ([\<not>] e [<] f) = e [\<ge>] f"
apply (subgoal_tac "[\<not>] e [<] f == e [\<ge>] f", auto)
apply (simp add:fGreaterEqual_def fOr_def fNot_def fLess_def fEqual_def fGreater_def)
done

declare fTrue_def [simp]
declare fFalse_def [simp]

(*Types for defining HCSP*)
type_synonym cname = string
type_synonym time = real

(*Communication processes of HCSP*)
datatype comm
= Send "cname" "exp"         ("_!!_" [110,108] 100)
| Receive "cname" "exp"    ("_??_" [110,108] 100)

(*HCSP processes*)
datatype proc
= Cm comm
| "Skip"
| Ass "exp" "exp"          ("_ := _" [99, 95] 94)
| Seq "proc" "proc"                   ("_; _"        [91,90 ] 90)
| Cond "fform" "proc"                 ("IF _ _"   [95,94]93)
| CondG "fform" "proc" "proc"                 ("IFELSE _ _ _"   [95,94,94]93)
| Pref   "comm" "proc"                  ("_\<rightarrow>_"   [95,94]93)
| join "proc" "proc"                   (infixr "[[" 90)
| meet "proc" "proc"                  ("_<<_" [90,90] 90)
(*Repetition is annotated with invariant*)
| Rep    "proc" "fform"                              ("_*&&_"[91] 90)
| RepN  "proc" "nat"   ("_* NUM _"[91, 90] 90)
(*Continuous evolution is annotated with invariant.*)
| Cont  "(string * typeid) list" "exp list" "fform" "fform"               ("<_:_&&_&_>" [95,95,96]94)
| Interp   "proc" "proc" ("_[[>_"[95,94]94)

(*We assume parallel  composition only occurs in  the topmost level.*)
datatype procP = Par    "proc" "proc"                  (infixr "||" 89)

end


theory Freegroup_with_Basis
imports UniversalProperty  Word_Problem Generators Cancellation
begin

text \<open>In this file, we provide a formalisation of a 'freegroup with basis', which
is a group with a subset such that the group is isomorphic to a free group, and the
isomorphism carrier the subset to the generating set of the free group.
This distinction about carrying subsets, is useful to provide a neccessary and
sufficientcondition for a subgroup of a group to be free. This condition is formalised in
the lemma fg with basis eq cond, and is cruicial to the proof of Nielson Schreier.\<close>

definition fg_with_basis
  where
"fg_with_basis (G::('a,'b) monoid_scheme) A
    \<equiv> (\<exists>(S::(unit \<times> 'a) set) \<phi>. (\<phi> \<in> iso G (freegroup S))
              \<and> (\<langle>A\<rangle>\<^bsub>G\<^esub> = carrier G) \<and>(\<phi> ` A = (liftgen S)))"

lemma fg_with_basis_is_free:
  fixes G
  fixes A
  assumes "(fg_with_basis G A)"
  shows "is_freegroup G" using assms unfolding fg_with_basis_def is_iso_def
        is_freegroup_def by auto

lemma m_concat_in_span:
  assumes "group G"
  and  "\<forall>x \<in> set l. x \<in> S"
shows "monoid.m_concat G l \<in> \<langle>S\<rangle>\<^bsub>G\<^esub>" using assms
proof(induction l)
  case (Cons a l)
  have "monoid.m_concat G (a#l) = a \<otimes>\<^bsub>G\<^esub> (monoid.m_concat G l)" by auto
  hence "(monoid.m_concat G l) \<in> \<langle>S\<rangle>\<^bsub>G\<^esub>" using Cons by force
  moreover have "a \<in> \<langle>S\<rangle>\<^bsub>G\<^esub>" using Cons(3)
    by (simp add: gen_span.gen_gens)
  thus ?case
    by (simp add: calculation gen_span.gen_mult)
qed (simp)

text\<open>We define a non-empty word w in a monoid G with a subset A to be non reducible, if it
if the word w is obtained as a product of elements of A and their inverses,the word
 is either of length 1, or any successive elements from A occuring in the word are
 not inverses of each other. \<close>

definition non_reducible::"('a,'b) monoid_scheme \<Rightarrow> 'a set => 'a \<Rightarrow> bool"
  where
"non_reducible G A w \<equiv> (\<exists>l. w = monoid.m_concat G l \<and> (l \<noteq> [])
                          \<and> (\<forall>x \<in> set l. x \<in> A \<union> m_inv G ` A)
                          \<and> ((length l = 1) \<or> (\<forall>i \<le> (length l)-2 .
                            l!i \<noteq> inv\<^bsub>G\<^esub> (l!(i+1)))))"

lemma hom_preserves_m_concat:
  assumes "group G" and "group H"
 and  "\<phi> \<in> hom G H"
  and "w = monoid.m_concat G l"
  and "\<forall>x \<in> set l. x \<in> carrier G"
shows "\<phi> w = monoid.m_concat H (map \<phi> l)"
  using assms
proof(induction l arbitrary: w)
  case Nil
  then show ?case using hom_one by force
next
  case (Cons a l)
  let ?w = "monoid.m_concat G l"
  have x_in:"\<forall> x \<in> set l. x \<in> carrier G" using Cons(6) by simp
  hence w_in:"?w \<in> carrier G"
    by (simp add: assms(1) group.is_monoid monoid.m_concat_closed subsetI)
  moreover have "a \<in> carrier G" using Cons(6) by simp
  moreover have "w = a \<otimes>\<^bsub>G\<^esub> ?w"  using Cons(5) by simp
  ultimately have "\<phi> w = \<phi> a  \<otimes>\<^bsub>H\<^esub> (\<phi> ?w)" using w_in Cons(4) unfolding hom_def by blast
  moreover have " \<phi> ?w = foldr (\<otimes>\<^bsub>H\<^esub>) (map \<phi> l) \<one>\<^bsub>H\<^esub>" using  Cons(1)[OF Cons(2,3,4)] x_in
    by blast
  ultimately show ?case by simp
qed

lemma liftgen_subset:"liftgen S \<subseteq> carrier (freegroup S)"
  by (simp add: freegroup_def liftgen_subset_quotient)

definition liftgen_inv
  where
"liftgen_inv S = m_inv (freegroup S) ` (liftgen S)"

lemma liftgen_inv_in_carrier:
  "liftgen_inv S \<subseteq> carrier (freegroup S)"
  using liftgen_inv_def
  by (metis (no_types, lifting) freegroup_is_group group.inv_closed image_subset_iff liftgen_subset subset_iff)

lemma inj_on_invset:
  assumes "group G" "group H"
   and "\<phi> \<in> hom G H"
   and "A \<subseteq> carrier G"
   and "inj_on \<phi> A"
 shows "inj_on \<phi> (m_inv G ` A)"
proof
  fix x
  fix y
  assume x:"x \<in> m_inv G ` A"
  assume y:"y \<in>  m_inv G ` A"
  assume eq:"\<phi> x = \<phi> y"
  obtain x' where x':"x = inv\<^bsub>G\<^esub> x'" "x' \<in> A" using x by blast
  obtain y' where y':"y = inv\<^bsub>G\<^esub> y'" "y' \<in> A"  using y by blast
  from x' have "x \<in> carrier G" using x' assms(1,4) by auto
  moreover have "x' = inv\<^bsub>G\<^esub> x" using x' assms(1,4) by fastforce
  ultimately have map_x':"\<phi> (x') = inv\<^bsub>H\<^esub> \<phi> x" using  group_hom.hom_inv[of "G" "H" \<phi> x] assms(1-3)
     group_hom.intro group_hom_axioms.intro by blast
  from y' have "y \<in> carrier G" using assms(1,4)  by auto
  moreover have "y' = inv\<^bsub>G\<^esub> y" using y' assms(1,4) by fastforce
  ultimately have map_y':"\<phi> (y') = inv\<^bsub>H\<^esub> \<phi> y" using  group_hom.hom_inv[of "G" "H" \<phi> y] assms(1-3)
     group_hom.intro group_hom_axioms.intro by blast
  have "\<phi> x' = \<phi> y'" using map_x' eq assms(2)
    using map_y' by force
  hence "x' = y'" using x'(2) y'(2) assms(5) unfolding inj_on_def by blast
  thus "x = y" using x' y' by auto
qed

lemma bij_to_invset:
  assumes "\<phi> \<in> iso G H" "group G" "group H"
      and "A \<subseteq> carrier G"
      and "bij_betw \<phi> A Y"
    shows "bij_betw \<phi> (m_inv G ` A)  (m_inv H ` Y) "
proof-
  have " inj_on \<phi> (m_inv G ` A)" using assms unfolding bij_betw_def
    by (simp add: inj_on_invset iso_imp_homomorphism)
  moreover have "\<phi> ` (m_inv G ` A) = (m_inv H ` Y)"
  proof
    show "\<phi> ` m_inv G ` A \<subseteq> m_inv H ` Y"
    proof
      fix \<phi>_x
      assume "\<phi>_x \<in> \<phi> ` m_inv G ` A "
      then obtain x where x:"x \<in> A" "\<phi>_x = \<phi>  (m_inv G  x)" by blast
      have "\<phi>_x = m_inv H (\<phi> x)" using assms unfolding iso_def
        by (metis (no_types, lifting) \<open>\<phi>_x = \<phi> (inv\<^bsub>G\<^esub> x)\<close> \<open>x \<in> A\<close> assms(1) group_hom.hom_inv group_hom.intro group_hom_axioms.intro in_mono iso_imp_homomorphism)
      thus "\<phi>_x \<in> m_inv H ` Y" using assms(5) x(1) unfolding bij_betw_def by blast
    qed
  next
    show " m_inv H ` Y  \<subseteq> \<phi> ` m_inv G ` A"
    proof
      fix \<phi>_y
      assume "\<phi>_y \<in> m_inv H ` Y"
      then obtain y where y:"y \<in> Y" "\<phi>_y = m_inv H y" by blast
      then obtain x where x:"x \<in>  A" "\<phi> x = y" using assms
        by (meson bij_betw_apply bij_betw_the_inv_into f_the_inv_into_f_bij_betw)
      then have "\<phi>_y = \<phi> (m_inv G x)" using assms y
        by (metis (no_types, opaque_lifting) group_hom.hom_inv group_hom.intro group_hom_axioms.intro iso_imp_homomorphism subsetD)
      then show "\<phi>_y  \<in> \<phi> ` m_inv G ` A" using x(1) by fast
    qed
  qed
  ultimately show ?thesis  unfolding bij_betw_def by blast
qed

lemma in_map_of_union:
  assumes "\<forall>x \<in> S. x \<in> A \<union> B"
  shows "\<forall>x \<in> f ` S. x \<in> f ` A \<union> f ` B"
  using assms by blast

lemma(in group) exist_of_proj:
  assumes "\<forall>x \<in> set ls. x \<in> (liftgen S) \<union> (liftgen_inv S)"
  shows "\<exists>l. (\<forall> x \<in> set l. x \<in> S \<times> {True, False})
              \<and> (ls = map (\<lambda> x. (reln_tuple \<langle>S\<rangle> `` {[x]})) l)"
  using assms
proof(induction ls)
  case (Cons a ls)
  hence "\<forall>x\<in>set ls. x \<in> liftgen S \<union> liftgen_inv S" by simp
  then obtain l where l:"\<forall>x \<in> set l. x \<in> S \<times> {True, False}" "(ls = map (\<lambda> x. (reln_tuple \<langle>S\<rangle> `` {[x]})) l)"
    using Cons(1) by auto
  have a_in:"a \<in> liftgen S \<or> a \<in> liftgen_inv S" using Cons(2) by auto
  hence a_in_carrier:"a \<in> carrier (freegroup S)"
    using liftgen_inv_in_carrier liftgen_subset by blast
  then show ?case
  proof(cases "a \<in> liftgen S")
    case True
    then obtain s where s:"s \<in> S" "a = reln_tuple \<langle>S\<rangle> `` {\<iota> s}" unfolding liftgen_def by blast
    hence "\<forall>x \<in> set ((\<iota> s)@l). x \<in> S \<times> {True, False}"
      by (simp add: inclusion_def l(1))
    moreover have "(a#ls) =  map (\<lambda> x. (reln_tuple \<langle>S\<rangle> `` {[x]})) ((\<iota> s)@l)"
      using s(2) l(2)
      by (simp add: inclusion_def)
    ultimately show ?thesis by metis
  next
    case False
    hence "a \<in> liftgen_inv S" using a_in by simp
    then obtain b where b:"b \<in> liftgen S" "a = inv \<^bsub>freegroup S\<^esub> b" unfolding liftgen_inv_def
      by blast
    hence inv_a:"b = inv \<^bsub>freegroup S\<^esub> a"
      by (metis (no_types, lifting) freegroup_is_group group.inv_inv liftgen_subset subsetD)
    from b(1) have b_in_fg:"b \<in> carrier (freegroup S)"
      by (simp add: a_in_carrier freegroup_is_group inv_a)
    then obtain s' where s':"s' \<in> S" "b = reln_tuple \<langle>S\<rangle> `` {\<iota> s'}" using b unfolding liftgen_def
      by blast
    then have "wordinverse (\<iota> s') = [(s', False)]" unfolding inclusion_def by auto
    moreover have "a =  reln_tuple \<langle>S\<rangle> `` {wordinverse (\<iota> s')}" using inv_a
       wordinverse_inv[OF b_in_fg s'(2)]  b(2) by argo
    hence "a =   reln_tuple \<langle>S\<rangle> `` {[(s', False)]}" unfolding wordinverse_def inclusion_def by auto
    hence " a # ls = map (\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[x]}) ((s',False)#l)" using l(2) by auto
    moreover have "\<forall> x \<in> set ((s',False)#l). x \<in> S \<times> {True, False}" using l(1)
      by (simp add: s'(1))
    ultimately show ?thesis by metis
  qed
qed(simp)

lemma(in group) non_reduced_projection:
  assumes "\<forall>x \<in> set ls. x \<in> (liftgen S) \<union> (liftgen_inv S)"
    and "ls = map (\<lambda> x. (reln_tuple \<langle>S\<rangle> `` {[x]})) l"
    and "length ls > 1"
    and   "\<forall>i \<le> (length ls)-2 . ls!i \<noteq> inv\<^bsub>(freegroup S)\<^esub> (ls!(i+1))"
  shows "\<forall>i \<le> (length l)-2 . (l!i) \<noteq> inverse (l!(i+1))"
proof(rule ccontr)
  assume "\<not> (\<forall>i\<le>length l - 2. l ! i \<noteq> FreeGroupMain.inverse (l ! (i + 1)))"
  then obtain i where i:"i \<le> length l - 2" "l ! i = FreeGroupMain.inverse (l ! (i + 1))"
    by blast

  then have "[l!i] = wordinverse [l ! (i + 1)]" by auto
  hence word_inv:"wordinverse [l!i] = [l ! (i + 1)]"
    by (metis wordinverse_of_wordinverse)
  then have l_i_eq:" ls!i = (reln_tuple \<langle>S\<rangle> `` {[l!i]}) " using assms
    by (metis (mono_tags, lifting) One_nat_def add_lessD1 diff_less i(1) le_add_diff_inverse length_greater_0_conv length_map list.size(3) nat_1_add_1 not_add_less2 nth_map plus_1_eq_Suc zero_less_Suc)
  have len_eq:"length ls = length l" using assms(2) by simp
  hence "ls!i \<in> set ls" using i(1) assms(3) by simp
  hence ls_i:"ls!i \<in> carrier (freegroup S)" using assms(1) i(1) using
    liftgen_inv_in_carrier[of S] liftgen_subset[of S]
    by (meson Un_iff liftgen_subset subsetD)
  have " inv\<^bsub>freegroup S\<^esub> (ls!i) =  (reln_tuple \<langle>S\<rangle> `` {[l!(i + 1)]})"
    using wordinverse_inv[OF ls_i l_i_eq] word_inv by argo
  moreover have "(reln_tuple \<langle>S\<rangle> `` {[l!(i + 1)]}) = ls!(i+1)" using assms
    by (smt (z3) Nat.le_diff_conv2 \<open>length ls = length l\<close> add_lessD1 i(1) le_add_diff_inverse nat_add_left_cancel_less nat_less_le neq0_conv nth_map one_less_numeral_iff plus_1_eq_Suc semiring_norm(76) zero_less_diff)
  ultimately have "inv\<^bsub>freegroup S\<^esub>  (ls!i) = ls!(i+1)" by auto
  hence "ls!i = inv\<^bsub>freegroup S\<^esub>  (ls!(i+1))"
    by (metis freegroup_is_group group.inv_inv ls_i)
  thus False using i(1) len_eq assms(4) by auto
qed

lemma hom_to_subgp:
 assumes "h \<in> hom G H"
 and "h ` (carrier G) = H'"
shows "h \<in> hom G (H\<lparr>carrier := H'\<rparr>)"
  using assms unfolding hom_def by (simp, blast)

lemma non_reducible_imp_red:
  assumes "\<forall>i \<le> (length l)-2 . (l!i) \<noteq> inverse (l!(i+1))"
  shows "reduced l" using assms
proof(induction l)
  case (Cons a l)
  hence 1:"\<forall>i\<le>length l - 2. l ! i \<noteq> FreeGroupMain.inverse (l ! (i + 1)) \<Longrightarrow> reduced l" by auto
  from Cons have 2:"\<forall>i\<le>length (a # l) - 2. (a # l) ! i \<noteq> FreeGroupMain.inverse ((a # l) ! (i + 1))"
    by auto
  hence red:"reduced l"
    by (smt (z3) length_Cons Cons.IH Nat.le_diff_conv2 Suc_1 add.assoc add.commute add_diff_cancel_left' le_add1 nth_Cons_Suc plus_1_eq_Suc reduced.elims(3))
  then show ?case
  proof(cases l)
    case (Cons b ls)
    have "a \<noteq> inverse b" using 2 Cons by fastforce
    moreover have "reduced (b#ls)" using Cons red by auto
    ultimately show ?thesis unfolding Cons by simp
  qed(simp)
qed (simp)

lemma non_reducible_imp_non_trivial:
  assumes "\<forall>i \<le> (length l)-2 . (l!i) \<noteq> inverse (l!(i+1))" "l \<noteq> []"
  shows "\<not> (l ~ [])"
  using non_reducible_imp_red[OF assms(1)] assms(2)
  using reduced.simps(1) reduced_cancel_eq reln_imp_cancels by blast

lemma m_concat_singleton:
  assumes "x \<in> carrier (freegroup S)"
  shows   "monoid.m_concat (freegroup S) [x] = x"
  using assms
  by (simp add: freegroup_is_group group.is_monoid)

lemma list_in_span:
  assumes "\<forall>x \<in> set xs. x \<in> S \<times> {True, False}"
  shows "xs \<in> \<langle>S\<rangle>"
  using assms
proof(induction xs)
  case Nil
  then show ?case
    by (simp add: freewords_on_def words_on.empty)
next
  case (Cons a xs)
  then show ?case
    by (metis freewords_on_def invgen_def list.set_intros(1) list.set_intros(2) words_on.gen)
qed

lemma empty_int_implies_nid:
  assumes "group G"
    "A \<inter> (m_inv G ` A) = {}"
  shows "\<one>\<^bsub>G\<^esub> \<notin> A"
  using assms disjoint_iff group.is_monoid monoid.inv_one rev_image_eqI
  by (metis)

lemma assumes "\<not> (reduced ys)"
  shows "\<not> (reduced (xs@ys))"
  using assms
  using reduced_leftappend by blast

lemma inverse_in_reduced_lists:
  assumes "reduced l" "length l > 1"
  shows "\<forall>i \<le> length l - 2.  (l!i) \<noteq> inverse (l!(i+1))"
proof(rule ccontr)
  assume "\<not>(\<forall>i \<le> length l - 2.  (l!i) \<noteq> inverse (l!(i+1)))"
  then obtain i where i:"i \<le> length l - 2" "(l!i) = inverse (l!(i+1))" by blast
  hence "drop (i - 1) l = (l!i)#(l!(i+1))#(drop (i+1) l)"
    using assms
    by (metis Suc_leI add.right_neutral add_Suc_right add_less_le_mono inv_not_reduced inverse_of_inverse le_add_diff_inverse one_add_one plus_1_eq_Suc zero_less_one)
  hence "\<not> (reduced (drop (i - 1) l))" using i(2) by simp
  hence "\<not> (reduced l)" using i(1) assms
    by (metis append_take_drop_id reduced_leftappend)
  thus False using assms(1) by auto
qed

lemma inverse_in_reduced_embedlists:
  assumes "reduced l" "length l > 1"
  shows "\<forall>i \<le> length l - 2.  [(l!i)] \<noteq> wordinverse [ (l!(i+1))]"
  using inverse_in_reduced_lists assms by auto
lemma inv_in_freegp:
  assumes "[x] \<in> \<langle>S\<rangle>"
  shows "inv\<^bsub>freegroup S\<^esub> (reln_tuple \<langle>S\<rangle> `` {[x]})
        = reln_tuple \<langle>S\<rangle> `` {wordinverse [x]}"
  using assms unfolding freegroup_def
  by (metis freegroup_def freegroup_is_group group.wordinverse_inv partial_object.select_convs(1) quotientI)

lemma red_imp_no_cons_inv:
  assumes "reduced l" "length l > 1" "l \<in> \<langle>S\<rangle>"
  shows "\<forall>i \<le> length l - 2.  reln_tuple \<langle>S\<rangle> `` {[(l!i)]}
                \<noteq> inv\<^bsub>freegroup S\<^esub> (reln_tuple \<langle>S\<rangle> `` {[(l!(i+1))]})"
proof(rule ccontr)
  assume "\<not> (\<forall>i \<le> length l - 2.  reln_tuple \<langle>S\<rangle> `` {[(l!i)]} \<noteq> inv\<^bsub>freegroup S\<^esub> (reln_tuple \<langle>S\<rangle> `` {[(l!(i+1))]}))"
  then obtain i where i:"i \<le> length l - 2"
      "reln_tuple \<langle>S\<rangle> `` {[(l!i)]} = inv\<^bsub>freegroup S\<^esub> (reln_tuple \<langle>S\<rangle> `` {[(l!(i+1))]})" by blast
  hence l_i_in:"[(l!i)] \<in> \<langle>S\<rangle>" using assms
    by (metis Nat.le_diff_conv2 add.commute add_leD1 cons_span discrete freewords_on_def id_take_nth_drop one_add_one rightappend_span)
  with i have l_Si_in:"[(l!(i+1))] \<in> \<langle>S\<rangle>" using assms
    by (metis (no_types, lifting) Suc_leI add.right_neutral add_Suc_right add_less_le_mono cons_span freewords_on_def id_take_nth_drop le_add_diff_inverse one_add_one one_less_numeral_iff plus_1_eq_Suc rightappend_span semiring_norm(76))
  hence "inv\<^bsub>freegroup S\<^esub> (reln_tuple \<langle>S\<rangle> `` {[(l!(i+1))]})
        = reln_tuple \<langle>S\<rangle> `` {wordinverse [(l!(i+1))]}" using inv_in_freegp by blast
  with i(2) have "reln_tuple \<langle>S\<rangle> `` {[(l!i)]} = reln_tuple \<langle>S\<rangle> ``  {wordinverse [(l!(i+1))]}"
    by argo
  hence "[(l!i)] ~ wordinverse [(l!(i+1))]" using l_i_in l_Si_in  unfolding reln_tuple_def
    by (meson \<open>reln_tuple \<langle>S\<rangle> `` {[l ! i]} = reln_tuple \<langle>S\<rangle> `` {wordinverse [l ! (i + 1)]}\<close> span_wordinverse word_problem_not_eq)
  hence "(l!i) = inverse (l!(i+1))"
    by (metis append_Nil assms i(1) inverse_in_reduced_embedlists reduced.simps(2) reduced_cancel_eq reln_imp_cancels wordinverse.simps(1) wordinverse.simps(2))
  moreover have "drop (i - 1) l= (l!i)# inverse (l!(i+1))#(drop (i + 1) l)"
    using i(1)
    using assms(1) assms(2) calculation inverse_in_reduced_lists by blast
  hence "\<not> (reduced (drop (i - 1) l))"
    using assms(1) assms(2) calculation i(1) inverse_in_reduced_lists by blast
  hence "\<not> (reduced l)" using reduced_leftappend i(1)
    by (metis append_take_drop_id)
  thus False using assms(1) by auto
qed

lemma in_span_imp_invggen:
  assumes "x \<in> set l"
  "l \<in> \<langle>S\<rangle>"
shows "x \<in> S \<times> {True, False}" using assms
proof(induction l)
  case (Cons a l)
  then show ?case
  proof(cases "x \<in> set l")
    case True
    hence "l \<in> \<langle>S\<rangle>" using Cons(3)
      using freewords_on_def span_cons by blast
    then show ?thesis using Cons True by argo
  next
    case False
    hence "[a] \<in> \<langle>S\<rangle>" using cons_span Cons freewords_on_def
      by blast
    hence "a \<in> S \<times> {True, False}" using freewords_on_def
      by (metis gen_spanset invgen_def list.sel(1) list.simps(3))
    then show ?thesis using Cons False by simp
  qed
qed( auto)

lemma inv_in_freegrp_word:
  assumes"x \<in> S"
  shows " (reln_tuple \<langle>S\<rangle> `` {[(x, False)]}) = inv \<^bsub>freegroup S\<^esub> (reln_tuple \<langle>S\<rangle> `` {[(x, True)]})"
  using assms inv_in_freegp[of "(x,True)" S] wordinverse_def
  by (metis append.left_neutral image_subset_iff inclusion_def inclusion_subset_spanset inverse.simps(1) wordinverse.simps(1) wordinverse.simps(2))

lemma liftgen_inv_eq:
  "liftgen_inv S = (\<lambda> x. reln_tuple \<langle>S\<rangle> `` {[(x, False)]})  ` S"
   unfolding liftgen_inv_def
   liftgen_def inclusion_def using inv_in_freegrp_word by (blast)

lemma inv_liftgen_in_union:
  assumes "x \<in> (liftgen S) \<union> (liftgen_inv S)"
  shows "inv \<^bsub>freegroup S\<^esub> x \<in> (liftgen S) \<union> (liftgen_inv S)"
proof(cases "x \<in>  (liftgen S)")
  case True
  then show ?thesis unfolding liftgen_inv_def by simp
next
  case False
  hence "x \<in> (liftgen_inv S)" using assms by force
  hence "inv \<^bsub>freegroup S\<^esub> x \<in> (liftgen S)" unfolding liftgen_inv_def
    by (metis (no_types, lifting) freegroup_is_group group.inv_inv imageE liftgen_subset subset_iff)
  then show ?thesis by blast
qed

text \<open>The following lemma establishes that the group generated by a subset of a
group is free, if and only if every non reducible word in the span of the subset is
 not identity. This corresponds to the lemma 1.9 of Lyndon and Schupp.\<close>

lemma (in group)fg_with_basis_eq_cond:
  assumes " A \<inter> (m_inv G ` A) = {}" "A \<subseteq> carrier G"
  shows  "(fg_with_basis (G\<lparr>carrier := \<langle>A\<rangle>\<^bsub>G\<^esub>\<rparr>) A)
            \<longleftrightarrow> (\<forall>w \<in> \<langle>A\<rangle>\<^bsub>G\<^esub>. non_reducible G A w \<longrightarrow> w \<noteq> \<one>\<^bsub>G\<^esub>)"
proof
  assume fg:"fg_with_basis (G\<lparr>carrier := \<langle>A\<rangle>\<^bsub>G\<^esub>\<rparr>) A"
  have "\<one>\<^bsub>G\<^esub> \<notin> A" using assms(1) disjoint_iff group.is_monoid image_eqI monoid.inv_one
    by (metis is_group)
  define G_A where "G_A = (G\<lparr>carrier := \<langle>A\<rangle>\<^bsub>G\<^esub>\<rparr>)"
  hence carrier_eq:"\<langle>A\<rangle>\<^bsub>G_A\<^esub> = carrier (G_A)" using fg
    by (meson fg_with_basis_def)
  then obtain "\<phi>" "S" where \<phi>_S:"\<phi> \<in> iso G_A (freegroup (S:: (unit \<times> 'a) set))"
           "\<phi> ` A = (liftgen S)" using fg unfolding fg_with_basis_def G_A_def by auto
  hence bij_to_liftset:"bij_betw \<phi> A (liftgen S)" using \<phi>_S(1) carrier_eq  bij_betw_subset
    unfolding G_A_def
    by (metis (no_types, lifting) Group.iso_def  gen_span.gen_gens mem_Collect_eq subsetI)
  have subgp:" \<langle>A\<rangle>\<^bsub>G\<^esub> \<le> G" using assms(2) group.gen_subgroup_is_subgroup[of G A] is_group
    by blast
  have grp:"group (G_A)" using subgroup.subgroup_is_group[OF subgp is_group] unfolding
   G_A_def .
  have A_subset:"A \<subseteq> carrier G_A" using is_group unfolding G_A_def
    by (simp add: gen_span.gen_gens subset_eq)
  have m_inv_eq:"m_inv G ` A = m_inv G_A ` A"
  proof
    show " m_inv G ` A \<subseteq> m_inv G_A ` A"
    proof
      fix y
      assume "y \<in> m_inv G ` A"
      then obtain x where "x \<in> A" "y = m_inv G x" by blast
      then have "y \<in> carrier (G_A)" using A_subset is_group
        by (metis G_A_def  group.incl_subgroup group.subgroup_self grp subgp subgroup.m_inv_closed subsetD)
      then show "y \<in> m_inv G_A ` A " using is_group
        by (metis G_A_def \<open>x \<in> A\<close> \<open>y = inv\<^bsub>G\<^esub> x\<close>  gen_span.intros(2) group.m_inv_consistent image_iff subgp)
    qed
  next
    show " m_inv G_A ` A \<subseteq> m_inv G ` A"
    proof
      fix y
      assume "y \<in> m_inv G_A ` A"
      then obtain x where "x \<in> A" "y = m_inv G_A x" by blast
      then have "y \<in> carrier (G)" using A_subset carrier_eq G_A_def is_group
        by (metis G_A_def  gen_span.gen_gens group.inv_closed group.m_inv_consistent subgp subgroup.mem_carrier)
      then show "y \<in> m_inv G ` A "
        by (simp add: G_A_def \<open>x \<in> A\<close> \<open>y = inv\<^bsub>G_A\<^esub> x\<close> is_group gen_span.gen_gens group.m_inv_consistent subgp)
    qed
  qed
  show "\<forall>w\<in>\<langle>A\<rangle>\<^bsub>G\<^esub>. non_reducible G A w \<longrightarrow> w \<noteq> \<one>\<^bsub>G\<^esub>"
  proof(rule ccontr)
    assume "\<not> (\<forall>w\<in>\<langle>A\<rangle>\<^bsub>G\<^esub>. non_reducible G A w \<longrightarrow> w \<noteq> \<one>\<^bsub>G\<^esub>)"
    then obtain w where w:"w \<in> (\<langle>A\<rangle>\<^bsub>G\<^esub>)" "(non_reducible G A w)" "(w = \<one>\<^bsub>G\<^esub>)" by simp
    have  "\<exists> ls. \<phi> w = monoid.m_concat (freegroup S) ls \<and> ls \<noteq> [] \<and>
                         (\<forall>x \<in> set ls. x \<in> liftgen S \<union> (liftgen_inv S))
               \<and> ((length ls = 1) \<or> (\<forall>i \<le> (length ls)-2 . ls!i \<noteq> inv\<^bsub>(freegroup S)\<^esub> (ls!(i+1))))"
    proof-
      obtain l where l:"w = monoid.m_concat G l" "\<forall>x \<in> set l. x \<in> A \<union> (m_inv G ` A)" "l \<noteq> []"
        "length l = 1 \<or> (\<forall>i \<le> (length l)-2 . l!i \<noteq> inv\<^bsub>G\<^esub> (l!(i+1)))"
        using w(2) unfolding non_reducible_def by blast
      hence "w = monoid.m_concat  G_A l" using carrier_eq G_A_def by simp
      hence  mod_w:"w = foldr (\<otimes>\<^bsub>G_A\<^esub>) l \<one>\<^bsub>G_A\<^esub>" unfolding G_A_def by auto
      have l_set_in:"\<forall> x \<in> set l. x \<in> carrier (G\<lparr>carrier := \<langle>A\<rangle>\<^bsub>G\<^esub>\<rparr>)"
        using l(2) assms(2) is_group liftgen_inv_in_carrier  carrier_eq
        unfolding G_A_def using G_A_def
      proof-
         have "A \<subseteq> \<langle>A\<rangle>\<^bsub>G\<lparr>carrier := \<langle>A\<rangle>\<rparr>\<^esub>"
           using G_A_def A_subset carrier_eq by blast
         moreover have "m_inv G ` A \<subseteq> \<langle>A\<rangle>\<^bsub>G\<lparr>carrier := \<langle>A\<rangle>\<rparr>\<^esub>"
           by (metis G_A_def carrier_eq gen_span.gen_gens group.subgroup_self grp image_subsetI incl_subgroup subgp subgroupE(3))
         ultimately show ?thesis using l(2)
           by (metis G_A_def Un_subset_iff carrier_eq in_mono)
       qed
      let ?ls = "map \<phi> l"
      have ls_nonempty:"?ls \<noteq> []" using l(3) by blast
      have hom_phi:"\<phi> \<in> hom G_A (freegroup S)" using \<phi>_S(1) unfolding iso_def by blast
      have "\<phi> w = monoid.m_concat (freegroup S) ?ls"
        using hom_preserves_m_concat[OF grp freegroup_is_group[of S] hom_phi mod_w] l(2)
        using G_A_def l_set_in by fastforce
      have loc_eq:"set ?ls = \<phi> ` (set l)" by simp
       have ls_in:"\<forall>x \<in> set ?ls. x \<in> (liftgen S) \<union> (liftgen_inv S)"
       proof-
         have " \<phi> ` A = liftgen S" using bij_to_liftset unfolding bij_betw_def by argo
         moreover have "\<phi> ` m_inv G_A ` A = m_inv F\<^bsub>S\<^esub> ` liftgen S"
           using bij_to_invset[OF \<phi>_S(1) grp freegroup_is_group A_subset bij_to_liftset]
           unfolding bij_betw_def by argo
         ultimately show ?thesis  unfolding liftgen_inv_def
         using in_map_of_union[of "set l" "A" "m_inv G_A ` A" "\<phi>"] l(2) m_inv_eq unfolding loc_eq
         by simp
     qed
      moreover have "(length ?ls = 1) \<or> (\<forall>i \<le> (length ?ls)-2 . ?ls!i \<noteq> inv\<^bsub>(freegroup S)\<^esub> (?ls!(i+1)))"
      proof(cases "length ?ls = 1")
        case False
        have "(\<forall>i \<le> (length ?ls)-2 . ?ls!i \<noteq> inv\<^bsub>(freegroup S)\<^esub> (?ls!(i+1)))"
        proof(rule ccontr)
          assume "\<not> (\<forall>i\<le>length (map \<phi> l) - 2. map \<phi> l ! i \<noteq> inv\<^bsub>(freegroup S)\<^esub> (?ls!(i+1)))"
          then obtain i where i:"i \<le> length ?ls -2" "?ls!i = inv\<^bsub>(freegroup S)\<^esub> (?ls!(i+1))" by blast
          have "i+1 \<le> length ?ls - 1" using i(1) ls_nonempty False
            by (metis (no_types, lifting) One_nat_def Suc_1 Suc_eq_plus1 Suc_leI diff_diff_add le_neq_implies_less length_greater_0_conv ordered_cancel_comm_monoid_diff_class.le_diff_conv2)
          hence ls_iSi:"?ls!(i+1) \<in> set ?ls" by auto
          have "?ls!i \<in> set ?ls"  using i(1) nth_mem[of i "?ls"] l(3)
            by (metis (no_types, lifting) diff_less_mono2 diff_zero le_neq_implies_less length_greater_0_conv less_trans list.map_disc_iff nat_1_add_1 plus_1_eq_Suc zero_less_Suc)
          moreover have ls_i:"?ls!i \<in> carrier (freegroup S)" using ls_in  liftgen_subset[of S]
            using calculation
            by (meson Un_least liftgen_inv_in_carrier subset_iff)
          moreover have ls_Si:"?ls!(i+1) \<in> carrier (freegroup S)" using ls_in  liftgen_subset[of S]
            using calculation ls_in ls_iSi
            using liftgen_inv_in_carrier by blast
          ultimately have "(?ls!i) \<otimes>\<^bsub>(freegroup S)\<^esub> (?ls!(i+1)) =  \<one>\<^bsub>(freegroup S)\<^esub>"
            using ls_in freegroup_is_group i(2)
            by (metis group.l_inv)
          have li:"l ! i \<in> carrier (G_A)" using i ls_i \<phi>_S(1)
            by (metis G_A_def Suc_1 diff_less l(3) l_set_in le_neq_implies_less length_greater_0_conv length_map less_trans nth_mem zero_less_Suc)
          hence l_i_in:" l ! i \<in> \<langle>A\<rangle>\<^bsub>G\<^esub>" unfolding G_A_def by simp
          have lSi:"l ! (i+1) \<in> carrier (G_A)" using i(1) ls_Si \<phi>_S(1)
            by (metis G_A_def One_nat_def Suc_pred \<open>i + 1 \<le> length (map \<phi> l) - 1\<close> l_set_in le_imp_less_Suc length_map length_pos_if_in_set ls_iSi nth_mem)
          then have "\<phi> (l ! i) \<otimes>\<^bsub>(freegroup S)\<^esub> \<phi> (l ! (i+1)) =  \<one>\<^bsub>(freegroup S)\<^esub>"
            using i(1)
            by (metis (no_types, lifting) One_nat_def Suc_eq_plus1 Suc_pred \<open>i + 1 \<le> length (map \<phi> l) - 1\<close> \<open>map \<phi> l ! i \<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub> map \<phi> l ! (i + 1) = \<one>\<^bsub>F\<^bsub>S\<^esub>\<^esub>\<close> dual_order.refl le_imp_less_Suc length_map length_pos_if_in_set less_trans ls_iSi nth_map)
          then have "\<phi> (l ! i \<otimes>\<^bsub>G_A\<^esub> (l ! (i + 1))) = \<one>\<^bsub>(freegroup S)\<^esub>" using \<phi>_S(1)
            unfolding iso_def using hom_mult[of \<phi> G_A "F\<^bsub>S\<^esub>"] li lSi by blast
          then have "l ! i \<otimes>\<^bsub>G_A\<^esub> (l ! (i + 1)) =  \<one>\<^bsub>G_A\<^esub>"  using \<phi>_S(1)
            by (smt (verit) freegroup_is_group group.is_monoid group.iso_iff_group_isomorphisms group_isomorphisms_def grp hom_one lSi li monoid.m_closed)
          then have l_i_inv:"l ! i = inv\<^bsub>G_A\<^esub> (l ! (i + 1))"
            by (metis group.inv_equality grp lSi li)
          hence l_i_inv_G:"l ! i = inv\<^bsub>G\<^esub> (l ! (i + 1))" unfolding G_A_def
            using Group.group.m_inv_consistent[OF is_group subgp l_i_in]
            by (metis G_A_def is_group group.inv_inv grp lSi l_i_in subgp subgroup.mem_carrier)
          moreover have "length l = length (map \<phi> l)" by simp
          hence "i \<le> length l - 2"
            using i(1) by presburger
          ultimately have "\<exists> i \<le> length l - 2. l ! i  = inv\<^bsub>G_A\<^esub> l ! (i + 1)" using l_i_inv
            by blast
          then show False using l(4) l_i_inv_G
          using \<open>i \<le> length l - 2\<close>
          by (metis False \<open>length l = length (map \<phi> l)\<close>)
      qed
      then show ?thesis by blast
    qed (blast)
    then show ?thesis
      using \<open>\<phi> w = foldr (\<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub>) (map \<phi> l) \<one>\<^bsub>F\<^bsub>S\<^esub>\<^esub>\<close> ls_in ls_nonempty by blast
  qed
  then obtain ls where ls:"\<phi> w = monoid.m_concat (freegroup S) ls" "ls \<noteq> []"
                         "\<forall>x \<in> set ls. x \<in> liftgen S \<union> (liftgen_inv S)"
        "length ls = 1 \<or> (\<forall>i \<le> (length ls)-2 . ls!i \<noteq> inv\<^bsub>(freegroup S)\<^esub> (ls!(i+1)))"
    by auto
  define w' where "w' = \<phi> w"
  hence w':"\<phi> w = w'" by auto
  then have "\<phi> w \<noteq> \<one>\<^bsub>F\<^bsub>S\<^esub>\<^esub>"
  proof(cases "length ls = 1")
    case True
    then obtain x  where x:"x \<in> liftgen S \<or> x \<in> liftgen_inv S" "ls = [x]" using ls(3)
      by (metis One_nat_def Un_iff length_0_conv length_Suc_conv list.set_intros(1))
    then have \<phi>_w_is:"\<phi> w = x" using ls(1) m_concat_singleton
      using liftgen_inv_in_carrier liftgen_subset by blast
    then show ?thesis
    proof(cases "x \<in> liftgen S")
      case True
      then obtain s where s:"x = reln_tuple \<langle>S\<rangle> `` {\<iota> s}" "s \<in> S"  unfolding liftgen_def by blast
      then have i_s:"\<iota> s = [(s, True)]" unfolding inclusion_def by auto
      then have s_in: "\<iota> s \<in> \<langle>S\<rangle>"
        by (meson image_subset_iff inclusion_subset_spanset s(2))
      moreover have "reduced [(s, True)]" by simp
      hence "\<not>([(s, True)] ~ [])"
        using reduced.simps(1) reduced_cancel_eq reln_imp_cancels by blast
      hence "x \<noteq> \<one>\<^bsub>F\<^bsub>S\<^esub>\<^esub>" using  word_problem_not_eq_id[OF s_in] i_s unfolding s(1) by simp
      then show ?thesis  unfolding \<phi>_w_is .
    next
      case False
      then obtain y where y:"y \<in> liftgen S" "y = inv\<^bsub>freegroup S\<^esub> x" using x(1)
        by (metis (no_types, lifting) freegroup_is_group group.inv_inv imageE liftgen_inv_def liftgen_subset subsetD)
        then obtain s where s:"y = reln_tuple \<langle>S\<rangle> `` {\<iota> s}" "s \<in> S"  unfolding liftgen_def by blast
      then have i_s:"\<iota> s = [(s, True)]" unfolding inclusion_def by auto
      then have s_in: "\<iota> s \<in> \<langle>S\<rangle>"
        by (meson image_subset_iff inclusion_subset_spanset s(2))
      moreover have "reduced [(s, True)]" by simp
      hence "\<not>([(s, True)] ~ [])"
        using reduced.simps(1) reduced_cancel_eq reln_imp_cancels by blast
      hence "y \<noteq> \<one>\<^bsub>F\<^bsub>S\<^esub>\<^esub>" using  word_problem_not_eq_id[OF s_in] i_s unfolding s(1) by simp
      hence "x \<noteq> \<one>\<^bsub>F\<^bsub>S\<^esub>\<^esub>" using y(2)
        by (metis (no_types, lifting) freegroup_is_group gen_span.gen_one group.inv_eq_1_iff group.span_liftgen subset_eq)
      then show ?thesis unfolding \<phi>_w_is .
    qed
  next
    case False
    hence "\<forall>i \<le> (length ls)-2 . ls!i \<noteq> inv\<^bsub>(freegroup S)\<^esub> (ls!(i+1))" using ls(4) by auto
    then obtain l where l:"(\<forall> x \<in> set l. x \<in> S \<times> {True, False})"
    "(ls = map (\<lambda> x. (reln_tuple \<langle>S\<rangle> `` {[x]})) l)" using False ls(2) exist_of_proj[OF ls(3)] by auto
    from     non_reduced_projection[OF ls(3) l(2) ] ls(2,4) False
    have inv_cond:"\<forall>i\<le>length l - 2. l ! i \<noteq> FreeGroupMain.inverse (l ! (i + 1))"
      by (meson le_neq_implies_less length_0_conv less_one not_less)
    have l_in:"l \<in> \<langle>S\<rangle>" using list_in_span[OF l(1)] .
    hence "\<not> (l ~ [])" using non_reducible_imp_non_trivial[OF inv_cond] l(2) ls(2) by blast
    hence "reln_tuple \<langle>S\<rangle> `` {l} \<noteq> \<one>\<^bsub>F\<^bsub>S\<^esub>\<^esub>" using word_problem_not_eq_id[OF l_in]
      by argo
    moreover have "reln_tuple \<langle>S\<rangle> `` {l} = \<phi> w " using reln_tuple_eq[OF l_in] unfolding ls(1) l(2) .
    ultimately show ?thesis by argo
  qed
  then have "w \<noteq> \<one>\<^bsub>G_A\<^esub>" using \<phi>_S(1) unfolding iso_def
    by (meson \<phi>_S(1) freegroup_is_group grp hom_one iso_imp_homomorphism)
  then have "w \<noteq> \<one>\<^bsub>G\<^esub>" using subgp unfolding G_A_def by simp
  then show False using w(3) by argo
qed
next
  assume case_asm:"\<forall>w\<in>\<langle>A\<rangle>\<^bsub>G\<^esub>. non_reducible G A w \<longrightarrow> w \<noteq> \<one>\<^bsub>G\<^esub>"
  define S where "S = {()} \<times> A"
  define G_A where "G_A = (G\<lparr>carrier := \<langle>A\<rangle>\<^bsub>G\<^esub>\<rparr>)"
  hence carrier_eq:"carrier (G_A) = \<langle>A\<rangle>\<^bsub>G\<^esub>" by auto
  then have "(\<lambda>(x,y). y) \<in> S \<rightarrow> carrier G" using assms S_def by force
  then obtain h  where h:"h \<in> hom (freegroup S) G"
    "\<forall>x\<in>S. (\<lambda>(a,b). b)  x = h (reln_tuple \<langle>S\<rangle> `` {\<iota> x})"
    using exists_hom  by blast
  hence group_hom_G:"group_hom (freegroup S) G h"
    by (simp add: h(1) freegroup_is_group group_hom.intro group_hom_axioms_def)
  have subgp:" \<langle>A\<rangle>\<^bsub>G\<^esub> \<le> G" using assms(2) group.gen_subgroup_is_subgroup[of G A] is_group
    by blast
  have grp:"group (G_A)" using subgroup.subgroup_is_group[OF subgp is_group] unfolding
   G_A_def .
  have A_subset:"A \<subseteq> carrier G_A" unfolding G_A_def using is_group
    using subgp subgroup.subgroup_is_group
    by (simp add: gen_span.gen_gens subsetI)
  have "h ` (liftgen S) = A" using S_def h(2) unfolding liftgen_def by auto
  hence h_to:"h ` (carrier (freegroup S)) =  \<langle>A\<rangle>\<^bsub>G\<^esub>" using h(1) group_hom.hom_span[OF group_hom_G]
    by (metis liftgen_span liftgen_subset span_liftgen subset_antisym)
  hence h_in:"h \<in> hom (freegroup S) G_A" using carrier_eq hom_to_subgp[OF h(1)]
    unfolding G_A_def by presburger
  hence group_hom_G_A:"group_hom (freegroup S) G_A h"
    using  group_hom.intro[OF freegroup_is_group grp] group_hom_axioms_def by blast
  then have surj:"h ` (carrier (freegroup S)) = carrier (G_A)" using h_to unfolding G_A_def by simp
  have h_S_inv:"\<forall>x\<in>S. inv\<^bsub>G\<^esub> ((\<lambda>(a,b). b)  x) = h (reln_tuple \<langle>S\<rangle> `` {[(x, False)]})"
  proof
    fix x
    assume x:"x \<in> S"
    hence in_carr:"(reln_tuple \<langle>S\<rangle> `` {\<iota> x}) \<in> carrier (freegroup S)" unfolding freegroup_def
      by (metis image_subset_iff inclusion_subset_spanset partial_object.select_convs(1) proj_def proj_preserves)
    hence " (reln_tuple \<langle>S\<rangle> `` {[(x, False)]}) = inv \<^bsub>freegroup S \<^esub> (reln_tuple \<langle>S\<rangle> `` {\<iota> x})"
      using inv_in_freegrp_word[OF x] unfolding inclusion_def by argo
    moreover have "h (inv \<^bsub>freegroup S \<^esub> (reln_tuple \<langle>S\<rangle> `` {\<iota> x})) = inv\<^bsub>G\<^esub> ((\<lambda>(a,b). b)  x)"
      using x Group.group_hom.hom_inv[OF group_hom_G in_carr] h(2) by auto
    ultimately show "inv\<^bsub>G\<^esub> ((\<lambda>(a,b). b)  x) = h (reln_tuple \<langle>S\<rangle> `` {[(x, False)]})" by argo
  qed
  hence h_to:"\<forall>x \<in> S \<times> {True, False}. h (reln_tuple \<langle>S\<rangle> `` {[x]}) \<in> A \<union> (m_inv G ` A)"
    using h(2) unfolding S_def inclusion_def by simp
  have bij_liftgen_A:"bij_betw h (liftgen S) A"
  proof(rule bij_betwI)
    show "h \<in> liftgen S \<rightarrow> A" using h
      using \<open>h ` liftgen S = A\<close> by blast
  next
    define g where "g = (\<lambda> x. (reln_tuple \<langle>S\<rangle> `` {\<iota> ((),x)}))"
    hence "g ` A \<subseteq> liftgen S" unfolding S_def liftgen_def by blast
    thus "g \<in> A \<rightarrow> liftgen S" by auto
  next
    fix x
    assume "x \<in> liftgen S"
    then obtain y where y:"y \<in> S" "x = reln_tuple \<langle>S\<rangle> `` {\<iota> y}" unfolding liftgen_def
      by blast
    hence "h x = snd y" using h(2)
      by (simp add: snd_def)
    thus "reln_tuple \<langle>S\<rangle> `` {\<iota> ((), h x)} = x" using y unfolding S_def by auto
  next
    fix y
    assume "y \<in> A"
    hence "((),y) \<in> S" unfolding S_def by auto
    thus "h (reln_tuple \<langle>S\<rangle> `` {\<iota> ((), y)}) = y" using h(1) unfolding S_def
      using S_def h(2) by auto
  qed
  have bij_liftgen_inv_A:"bij_betw h (liftgen_inv S)  (m_inv G ` A)" unfolding liftgen_inv_eq
  proof(rule bij_betwI)
    show "h \<in> (\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[(x, False)]}) ` S \<rightarrow> m_inv G ` A"
      using h h_S_inv unfolding S_def by force
  next
    define g where "g \<equiv> \<lambda> x. (reln_tuple \<langle>S\<rangle> `` {[(((),(inv\<^bsub>G\<^esub> x)), False)]})"
    have "\<forall>y \<in> m_inv G ` A. inv\<^bsub>G\<^esub>  y \<in> A"
      using assms(2) by auto
    have "g ` (m_inv G) ` A \<subseteq>(\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[(x, False)]}) ` S"
    proof
      fix y
      assume y:"y \<in> g ` (m_inv G) ` A "
      then obtain x where x:"x \<in> A" "y = g (inv\<^bsub>G\<^esub> x)" by blast
      hence "g (inv\<^bsub>G\<^esub> x) =  reln_tuple \<langle>S\<rangle> `` {[(((),x), False)]}"
        using assms(2) g_def by auto
      moreover have "((),x) \<in> S" using x(1) unfolding S_def by blast
      ultimately show "y \<in>(\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[(x, False)]}) ` S"
        using x(2) by blast
    qed
    thus "g \<in> m_inv G ` A \<rightarrow> (\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[(x, False)]}) ` S" by fast
  next
    fix x
    assume "x \<in> (\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[(x, False)]}) ` S"
    then obtain y where y:"((),y) \<in> S" "reln_tuple \<langle>S\<rangle> `` {[(((),y), False)]} = x"
      using S_def  by blast
    hence "h x = inv y" using h_S_inv by force
    hence "y = inv (h x)"
      by (metis S_def assms(2) inv_inv mem_Sigma_iff subsetD y(1))
    thus "reln_tuple \<langle>S\<rangle> `` {[(((), inv h x), False)]} = x" using y(2) by argo
  next
    fix y
    assume "y \<in> m_inv G ` A "
    then obtain x where x:"x \<in> A" "y = inv x" by blast
    hence y_inv:"x = inv y"
      by (metis assms(2) inv_inv subsetD)
    hence "((),x) \<in> S" using x(1) S_def by force
    thus "h (reln_tuple \<langle>S\<rangle> `` {[(((), inv y), False)]}) = y" using h_S_inv y_inv
      using x(2) by fastforce
  qed
  have bij_h:"bij_betw h ((liftgen S) \<union> (liftgen_inv S)) (A \<union> (m_inv G ` A))"
    using  bij_betw_combine[OF bij_liftgen_A  bij_liftgen_inv_A assms(1)] .
  moreover have "\<forall>w \<in> carrier (freegroup S). w \<noteq> \<one>\<^bsub>freegroup S\<^esub> \<longrightarrow>  h w \<noteq> \<one>\<^bsub>G_A\<^esub>"
  proof-
    {fix w
    assume in_fgp:"w \<in> carrier (freegroup S)"
    assume neq_one:"w \<noteq>  \<one>\<^bsub>freegroup S\<^esub>"
    obtain ls where ls:"w = reln_tuple  \<langle>S\<rangle> `` {ls}" "ls \<in> \<langle>S\<rangle>" using in_fgp unfolding freegroup_def
      by (simp, meson quotientE)
    define l where "l = (reduce^^(length ls)) ls"
    have l_rel_ls:"l ~ ls"
      using cancels_imp_rel iter_cancels_to l_def reln.sym by blast
    moreover have l_not_rel:"\<not> (l ~ [])" using neq_one ls word_problem_notrel[OF ls(2) ] ls(1) unfolding l_def
      by fastforce
    moreover have red_l:"reduced l"
      by (simp add: l_def reduced_iter_length)
    hence "reduce l = l"
      by (simp add: reduced_reduce)
    hence iter_l:"(reduce^^(length l)) l = l"
      using cancels_imp_iter l_def l_rel_ls reln_imp_cancels by blast
    moreover have l_in_S:"l \<in> \<langle>S\<rangle>" using ls(2) l_def
      using cancels_to_preserves iter_cancels_to by blast
    moreover have w_is_l:"w = reln_tuple  \<langle>S\<rangle> `` {l}" using ls l_in_S iter_l l_def
      using word_problem_eq by blast
    hence w_decompose:"w = monoid.m_concat (freegroup S) (map (\<lambda>x.(reln_tuple \<langle>S\<rangle> `` {[x]})) l)"
      by (simp add: l_in_S reln_tuple_eq)
    have "h w \<noteq> \<one>\<^bsub>G_A\<^esub>"
    proof(cases "length l = 1")
      case True
      then obtain s where s:"l = [s]" "s \<in> S \<times> {True, False}"
        using l_in_S unfolding freewords_on_def invgen_def words_on_def
        by (metis (no_types, lifting) length_Cons add_cancel_right_left le_zero_eq length_0_conv mem_Collect_eq not_one_le_zero words_onp.cases)
      then obtain x where x:"x \<in> A" "fst s = ((), x)" unfolding S_def by auto
      then show ?thesis
      proof(cases "snd s")
        case True
        hence l_is_fst_s:"l = \<iota> (fst s)" unfolding inclusion_def using s by force
        hence  "w = (reln_tuple \<langle>S\<rangle> `` {l})" using w_decompose
          using w_is_l by blast
        hence "h w = x" using l_is_fst_s x s h(2)
          by fastforce
        moreover have "x \<noteq> \<one>\<^bsub>G\<^esub>" using empty_int_implies_nid[OF is_group assms(1)] x(1) by blast
        ultimately show ?thesis unfolding G_A_def by simp
      next
        case False
        hence l_is_fst_s:"l = wordinverse (\<iota> (fst s))" unfolding inclusion_def using s by force
        hence  w_is:"w = (reln_tuple \<langle>S\<rangle> `` {l})" using w_decompose
          using w_is_l by blast
        define w' where "w' = (reln_tuple \<langle>S\<rangle> `` {\<iota> (fst s)})"
        hence w_inv_w':"w = inv \<^bsub>freegroup S\<^esub> w'" using w_is wordinverse_inv unfolding l_is_fst_s
          by (metis freegroup_is_group group.inv_inv in_fgp wordinverse_of_wordinverse)
        hence "w' =  inv \<^bsub>freegroup S\<^esub> w"
          by (metis in_fgp l_is_fst_s w'_def w_is wordinverse_inv wordinverse_of_wordinverse)
        hence "w' \<in> carrier (freegroup S)"
          by (meson group.inv_closed group_hom.axioms(1) group_hom_G_A in_fgp)
        hence h_eq:"h w = inv\<^bsub>G\<^esub> (h w')" using h(1) in_fgp unfolding w_inv_w'
          by (meson group_hom.hom_inv group_hom_G)
        hence "h w' = x" unfolding w'_def using l_is_fst_s x s h(2)
          by fastforce
        moreover have "x \<noteq> \<one>\<^bsub>G\<^esub>" using empty_int_implies_nid[OF is_group assms(1)] x(1) by blast
        ultimately have "h w \<noteq> \<one>\<^bsub>G\<^esub>" using h_eq
          by (metis \<open>w' = inv\<^bsub>F\<^bsub>S\<^esub>\<^esub> w\<close> group_hom.hom_inv group_hom_G in_fgp inv_one)
        thus ?thesis unfolding G_A_def by simp
      qed
    next
      case False
      hence "length l> 1" using l_not_rel
        using nat_neq_iff by fastforce
      define ls0 where "ls0 = map (\<lambda>x. (reln_tuple \<langle>S\<rangle> `` {[x]})) l"
      have "w = monoid.m_concat (freegroup S) ls0" using w_decompose ls0_def by auto
      moreover have ls0i:"\<forall>i \<le> length ls0 - 2. (ls0!i) \<noteq> inv\<^bsub>freegroup S\<^esub> (ls0!(i+1))"
        using red_imp_no_cons_inv[OF red_l] False l_in_S unfolding ls0_def
        by (smt (verit, del_insts) One_nat_def \<open>1 < length l\<close> add.commute add_lessD1 diff_is_0_eq' le_add_diff_inverse2 le_neq_implies_less length_map nat_1_add_1 nat_add_left_cancel_less nat_le_linear not_add_less2 nth_map plus_1_eq_Suc zero_less_Suc)
      have helper:"(\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[x]}) ` (S \<times> {True, False})
                    =  (\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[(x, True)]}) ` S  \<union>  (\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[(x, False)]}) ` S"

        proof(rule equalityI, rule subsetI)
          fix x
          assume "x \<in>  (\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[x]}) ` (S \<times> {True, False})"
          then obtain y where y:"y \<in> S \<times> {True, False}" "x = reln_tuple \<langle>S\<rangle> `` {[y]}" by force
          hence "x = reln_tuple \<langle>S\<rangle> `` {[(fst y, True)]} \<or>  x = reln_tuple \<langle>S\<rangle> `` {[(fst y, False)]}"
            apply(cases "snd y") apply force by force
          thus "x \<in> (\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[(x, True)]}) ` S  \<union>  (\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[(x, False)]}) ` S"
            using y(1) by force
        next
          show " (\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[(x, True)]}) ` S \<union> (\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[(x, False)]}) ` S
                  \<subseteq> (\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[x]}) ` (S \<times> {True, False}) "
          proof(rule subsetI)
            fix x
            assume x:"x \<in> (\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[(x, True)]}) ` S \<union> (\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[(x, False)]}) ` S"
            then obtain y where y:"y \<in> S" "x = reln_tuple \<langle>S\<rangle> `` {[(y, True)]} \<or>  x = reln_tuple \<langle>S\<rangle> `` {[(y, False)]}"
              by blast
            show "x \<in>(\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[x]}) ` (S \<times> {True, False})"
            proof(cases "x  = reln_tuple \<langle>S\<rangle> `` {[(y, True)]}")
              case True
              hence "x = (\<lambda> x. reln_tuple \<langle>S\<rangle> `` {[x]}) (y,True)" using y by argo
              thus ?thesis using y(1) by auto
            next
              case False
              hence "x = (\<lambda> x. reln_tuple \<langle>S\<rangle> `` {[x]}) (y,False)" using y(2) by argo
              then show ?thesis using y(1) by auto
            qed
          qed
        qed
        have in_ls00:"\<forall>i \<le> length ls0 - 1. (ls0!i) \<in> (liftgen S) \<union> (liftgen_inv S)"
        proof-
          {fix j
          assume loc_j:"j \<le> length ls0 - 1"
          hence 1:"ls0!j = reln_tuple \<langle>S\<rangle> `` {[l!j]}" using ls0_def
            using \<open>1 < length l\<close> by auto
          moreover have l_j:"l!j \<in> S \<times> {True, False}" using l_in_S in_span_imp_invggen[of "ls!j" l S]
            using loc_j
            by (metis (mono_tags, lifting) One_nat_def Suc_pred \<open>1 < length l\<close> in_span_imp_invggen le_imp_less_Suc length_0_conv length_greater_0_conv length_map ls0_def not_add_less2 nth_mem plus_1_eq_Suc)
          ultimately have "reln_tuple \<langle>S\<rangle> `` {[l!j]} \<in> (\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[x]}) ` (S \<times> {True, False})"
            using loc_j by simp
          have " (\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[x]}) ` (S \<times> {True, False})
                    =  (\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[(x, True)]}) ` S  \<union>  (\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[(x, False)]}) ` S"
            using helper by auto
          moreover have "ls0!j \<in> (\<lambda>x. reln_tuple \<langle>S\<rangle> `` {[x]}) ` (S \<times> {True, False})"
            using 1 l_j by force
          ultimately have "ls0 ! j \<in> liftgen S \<union> liftgen_inv S"
                unfolding liftgen_inv_eq liftgen_def inclusion_def
                by auto
            }
           thus ?thesis by auto
         qed
      have len_ls0:"length ls0 > 1" using False ls0_def
        using \<open>1 < length l\<close> by force
      hence in_set_ls0:"\<forall>l \<in> set ls0. l \<in> (liftgen S) \<union> (liftgen_inv S)" using False ls0_def in_ls00
        by (smt (verit) One_nat_def Suc_pred diff_commute diff_diff_cancel diff_is_0_eq'
 in_set_conv_nth less_imp_le_nat nat_le_linear zero_less_diff)
      have non_cancel_in_ls0:"\<forall>i \<le> length ls0 - 2. (h (ls0!i)) \<noteq> inv\<^bsub>G\<^esub> (h (ls0!(i+1)))"
      proof-
        {fix i
        assume i_len:"i \<le> length ls0 - 2"
        hence "i \<le> length l - 2" using ls0_def by simp
        hence l_i_in_Sinvgen:"l!i \<in>  S\<^sup>\<plusminus>" using l_in_S in_span_imp_invggen[of "ls!i" l S]
          by (metis diff_less in_span_imp_invggen invgen_def l_not_rel le_neq_implies_less length_greater_0_conv less_trans nat_1_add_1 nth_mem plus_1_eq_Suc reln.refl zero_less_Suc)
        hence  l_Si_in_Sinvgen:"l!(i+1) \<in>  S\<^sup>\<plusminus>" using l_in_S in_span_imp_invggen[of "ls!(i+1)" l S]
          by (metis One_nat_def Suc_pred \<open>1 < length l\<close> \<open>i \<le> length l - 2\<close> diff_diff_left in_span_imp_invggen invgen_def le_imp_less_Suc less_diff_conv nat_1_add_1 nth_mem zero_less_diff)
        hence "h (ls0!i) \<in> A \<union> (m_inv G ` A)" unfolding ls0_def using h_to l_i_in_Sinvgen unfolding invgen_def
          by (metis (no_types, lifting) One_nat_def \<open>1 < length l\<close> \<open>i \<le> length l - 2\<close> diff_less le_neq_implies_less less_trans nat_1_add_1 nth_map plus_1_eq_Suc zero_less_Suc)
        hence a:"(ls0!i) \<in> (liftgen S) \<union> (liftgen_inv S)" using i_len in_ls00 by auto
        have b:"(ls0!(i+1)) \<in> (liftgen S) \<union> (liftgen_inv S)" using in_ls00 i_len
          using One_nat_def Suc_pred \<open>1 < length l\<close> add.commute add_le_cancel_left
                diff_diff_add length_map ls0_def one_add_one plus_1_eq_Suc zero_less_diff
          by (smt (z3))
        have "(h (ls0!i)) \<noteq> inv\<^bsub>G\<^esub> (h (ls0!(i+1)))"
        proof(rule ccontr)
          assume " \<not> h (ls0 ! i) \<noteq> inv h (ls0 ! (i + 1))"
          hence 1:"h (ls0 ! i) = inv h (ls0 ! (i + 1))" by simp
          have "h (inv\<^bsub>freegroup S\<^esub> (ls0 ! (i + 1))) = inv h (ls0 ! (i + 1))"
            using b Group.group_hom.hom_inv[OF group_hom_G]
            using liftgen_inv_in_carrier liftgen_subset by blast
          hence "h (ls0!i) = h (inv\<^bsub>freegroup S\<^esub> (ls0 ! (i + 1)))"
            using 1 by auto
          hence "ls0!i = inv\<^bsub>freegroup S\<^esub> (ls0 ! (i + 1))" using bij_h a inv_liftgen_in_union[OF b]
            unfolding bij_betw_def inj_on_def
            by meson
          thus False using ls0i i_len by simp
        qed
      }
      then show ?thesis by blast
    qed
    hence w_is:"w = monoid.m_concat (freegroup S) ls0" using w_decompose ls0_def by argo
    hence "h w = monoid.m_concat G (map h ls0)"
      using h(1) hom_preserves_m_concat[OF freegroup_is_group[of S] is_group h(1) w_is]
       in_set_ls0
      by (meson Un_iff liftgen_inv_in_carrier liftgen_subset subset_iff)
    moreover have "\<forall>x \<in> set (map h ls0). x \<in> A \<union> m_inv G ` A"
      using bij_h in_ls00 in_set_ls0
      using bij_betw_imp_surj_on by fastforce
    moreover have "\<forall>i \<le> (length (map h ls0))-2 . (map h ls0)!i \<noteq> inv\<^bsub>G\<^esub> ((map h ls0)!(i+1))"
      using non_cancel_in_ls0
      by (smt (verit) Nat.le_diff_conv2 add.commute add_2_eq_Suc' add_leD2 diff_is_0_eq' le_neq_implies_less le_numeral_extra(4) len_ls0 length_map less_numeral_extra(4) less_one less_trans nat_le_linear nth_map plus_1_eq_Suc)
    ultimately have "non_reducible G A (h w)" unfolding non_reducible_def using False len_ls0
      by (smt (verit, ccfv_threshold) add_lessD1 le0 le_Suc_ex len_ls0 length_greater_0_conv map_is_Nil_conv)
    hence "h w \<noteq> \<one>\<^bsub>G\<^esub>" using case_asm by auto
    then show ?thesis unfolding G_A_def by simp
  qed}
  thus ?thesis by auto
  qed
  hence h_iso:"h \<in> iso (freegroup S) G_A" using group_hom.group_hom_isoI[OF group_hom_G_A] surj
    by blast
  then obtain g where g:"group_isomorphisms G_A (freegroup S) g h"
    using group.iso_iff_group_isomorphisms[OF freegroup_is_group[of S]] h_iso
    using group_isomorphisms_sym by blast
  hence g_iso:"g \<in> iso G_A (freegroup S)"
    using group_isomorphisms_imp_iso by blast
  have g_map:"g  ` A = (liftgen S)"
   proof
    {fix y
      assume "y \<in> g ` A"
      hence "y \<in> g ` (h ` (liftgen S))" using bij_liftgen_A unfolding bij_betw_def by meson

      then obtain s where x:"y = g (h s)" "s \<in> liftgen S" by blast
      moreover then have "g (h s) = s" using liftgen_subset[of S] g
        unfolding group_isomorphisms_def by fast
      ultimately have "y \<in> liftgen S" by argo}
    thus "g ` A \<subseteq> liftgen S" by blast
  next
    {fix y
      assume y:"y \<in> liftgen S"
      hence "h y \<in> A" using bij_liftgen_A unfolding bij_betw_def by blast
      moreover then have "g (h y) = y" using g assms(2) unfolding group_isomorphisms_def G_A_def
        by (meson liftgen_subset subsetD y)
      ultimately have "y \<in> g ` A" using y by blast}
    thus "liftgen S \<subseteq> g ` A" by auto
  qed
  have "\<langle>A\<rangle>\<^bsub>G\<lparr>carrier := \<langle>A\<rangle>\<rparr>\<^esub> = carrier (G\<lparr>carrier := \<langle>A\<rangle>\<rparr>)"
  proof-
    have "\<langle>A\<rangle>\<^bsub>G\<lparr>carrier := \<langle>A\<rangle>\<rparr>\<^esub> = \<langle>A\<rangle>"
    proof
      show  "\<langle>A\<rangle>\<^bsub>G\<lparr>carrier := \<langle>A\<rangle>\<rparr>\<^esub> \<subseteq> \<langle>A\<rangle>"
        using G_A_def A_subset carrier_eq group.gen_span_closed grp by blast
    next
      show  "\<langle>A\<rangle> \<subseteq> \<langle>A\<rangle>\<^bsub>G\<lparr>carrier := \<langle>A\<rangle>\<rparr>\<^esub>"
      proof
        fix x
        assume "x \<in> \<langle>A\<rangle>"
        thus "x \<in> \<langle>A\<rangle>\<^bsub>G\<lparr>carrier := \<langle>A\<rangle>\<rparr>\<^esub>"
        proof(induction x rule:gen_span.induct)
          case gen_one
          then show ?case using assms(2) is_group
            by (metis G_A_def carrier_eq gen_span.gen_one group.gen_subgroup_is_subgroup group.l_cancel_one' grp subgroup.mem_carrier subgroup_mult_equality)
        next
          case (gen_gens x)
          then show ?case
            by (simp add: gen_span.gen_gens)
        next
          case (gen_inv x)
          then show ?case
            by (metis gen_span.gen_inv m_inv_consistent subgp)
        next
          case (gen_mult x y)
          then show ?case
            by (metis gen_span.gen_mult subgp subgroup_mult_equality)
        qed
      qed
    qed
    thus ?thesis using carrier_eq unfolding G_A_def by argo
  qed
  thus "fg_with_basis (G\<lparr>carrier := \<langle>A\<rangle>\<^bsub>G\<^esub>\<rparr>) A"  unfolding fg_with_basis_def
    using g_iso carrier_eq g_map unfolding G_A_def by blast
qed

end