(* (c) Copyright Microsoft Corporation and Inria.                       *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div fintype tuple.
Require Import tuple bigop prime finset fingroup morphism perm automorphism.
Require Import quotient action cyclic pgroup gseries sylow primitive_action.

(******************************************************************************)
(*  Definitions of the symmetric and alternate groups, and some properties.   *)
(*     'Sym_T == The symmetric group over type T (which must have a finType   *)
(*               structure).                                                  *)
(*            := [set: {perm T}]                                              *)
(*     'Alt_T == The alternating group over type T.                           *)
(******************************************************************************)

Unset Printing Implicit Defensive.
Set Implicit Arguments.
Unset Strict Implicit.

Import GroupScope.

Definition bool_groupMixin := FinGroup.Mixin addbA addFb addbb.
Canonical bool_baseGroup := Eval hnf in BaseFinGroupType bool bool_groupMixin.
Canonical boolGroup := Eval hnf in FinGroupType addbb.

Section SymAltDef.

Variable T : finType.
Implicit Types (s : {perm T}) (x y z : T).

(** Definitions of the alternate groups and some Properties **)
Definition Sym of phant T : {set {perm T}} := setT.

Canonical Sym_group phT := Eval hnf in [group of Sym phT].

Notation Local "'Sym_T" := (Sym (Phant T)) (at level 0).

Canonical sign_morph := @Morphism _ _ 'Sym_T _ (in2W (@odd_permM _)).

Definition Alt of phant T := 'ker (@odd_perm T).

Canonical Alt_group phT := Eval hnf in [group of Alt phT].

Notation Local "'Alt_T" := (Alt (Phant T)) (at level 0).

Lemma Alt_even p : (p \in 'Alt_T) = ~~ p.
Proof. by rewrite !inE /=; case: odd_perm. Qed.

Lemma Alt_subset : 'Alt_T \subset 'Sym_T.
Proof. exact: subsetT. Qed.

Lemma Alt_normal : 'Alt_T <| 'Sym_T.
Proof. exact: ker_normal. Qed.

Lemma Alt_norm : 'Sym_T \subset 'N('Alt_T).
Proof. by case/andP: Alt_normal. Qed.

Let n := #|T|.

Lemma Alt_index : 1 < n -> #|'Sym_T : 'Alt_T| = 2.
Proof.
move=> lt1n; rewrite -card_quotient ?Alt_norm //=.
have : ('Sym_T / 'Alt_T) \isog (@odd_perm T @* 'Sym_T) by apply: first_isog.
case/isogP=> g /injmP/card_in_imset <-.
rewrite /morphim setIid=> ->; rewrite -card_bool; apply: eq_card => b.
apply/imsetP; case: b => /=; last first.
  by exists (1 : {perm T}); [rewrite setIid inE | rewrite odd_perm1].
case: (pickP T) lt1n => [x1 _ | d0]; last by rewrite /n eq_card0.
rewrite /n (cardD1 x1) ltnS lt0n; case/existsP=> x2 /=.
by rewrite eq_sym andbT -odd_tperm; exists (tperm x1 x2); rewrite ?inE.
Qed.

Lemma card_Sym : #|'Sym_T| = n`!.
Proof.
rewrite -[n]cardsE -card_perm; apply: eq_card => p.
by apply/idP/subsetP=> [? ?|]; rewrite !inE.
Qed.

Lemma card_Alt : 1 < n -> (2 * #|'Alt_T|)%N = n`!.
Proof.
by move/Alt_index <-; rewrite mulnC (Lagrange Alt_subset) card_Sym.
Qed.

Lemma Sym_trans : [transitive^n 'Sym_T, on setT | 'P].
Proof.
apply/imsetP; pose t1 := [tuple of enum T].
have dt1: t1 \in n.-dtuple(setT) by rewrite inE enum_uniq; apply/subsetP.
exists t1 => //; apply/setP=> t; apply/idP/imsetP=> [|[a _ ->{t}]]; last first.
  by apply: n_act_dtuple => //; apply/astabsP=> x; rewrite !inE.
case/dtuple_onP=> injt _; have injf := inj_comp injt enum_rank_inj.
exists (perm injf); first by rewrite inE.
apply: eq_from_tnth => i; rewrite tnth_map /= [aperm _ _]permE; congr tnth.
by rewrite (tnth_nth (enum_default i)) enum_valK.
Qed.

Lemma Alt_trans : [transitive^n.-2 'Alt_T, on setT | 'P].
Proof.
case n_m2: n Sym_trans => [|[|m]] /= tr_m2; try exact: ntransitive0.
have tr_m := ntransitive_weak (leqW (leqnSn m)) tr_m2.
case/imsetP: tr_m2; case/tupleP=> x; case/tupleP=> y t.
rewrite !dtuple_on_add 2![x \in _]inE inE negb_or /= -!andbA.
case/and4P=> nxy ntx nty dt _; apply/imsetP; exists t => //; apply/setP=> u.
apply/idP/imsetP=> [|[a _ ->{u}]]; last first.
  by apply: n_act_dtuple => //; apply/astabsP=> z; rewrite !inE.
case/(atransP2 tr_m dt)=> /= a _ ->{u}.
case odd_a: (odd_perm a); last by exists a => //; rewrite !inE /= odd_a.
exists (tperm x y * a); first by rewrite !inE /= odd_permM odd_tperm nxy odd_a.
apply/val_inj/eq_in_map => z tz; rewrite actM /= /aperm; congr (a _).
by case: tpermP ntx nty => // <-; rewrite tz.
Qed.

Lemma aperm_faithful (A : {group {perm T}}) : [faithful A, on setT | 'P].
Proof.
by apply/faithfulP=> /= p _ np1; apply/eqP/perm_act1P=> y; rewrite np1 ?inE.
Qed.

End SymAltDef.

Notation "''Sym_' T" := (Sym (Phant T))
  (at level 8, T at level 2, format "''Sym_' T") : group_scope.
Notation "''Sym_' T" := (Sym_group (Phant T)) : Group_scope.

Notation "''Alt_' T" := (Alt (Phant T))
  (at level 8, T at level 2, format "''Alt_' T") : group_scope.
Notation "''Alt_' T" := (Alt_group (Phant T)) : Group_scope.

Lemma trivial_Alt_2 (T : finType) : #|T| <= 2 -> 'Alt_T = 1.
Proof.
rewrite leq_eqVlt => /predU1P[] oT.
  by apply: card_le1_trivg; rewrite -leq_double -mul2n card_Alt oT.
suffices Sym1: 'Sym_T = 1 by apply/trivgP; rewrite -Sym1 subsetT.
by apply: card1_trivg; rewrite card_Sym; case: #|T| oT; do 2?case.
Qed.

Lemma simple_Alt_3 (T : finType) : #|T| = 3 -> simple 'Alt_T.
Proof.
move=> T3; have{T3} oA: #|'Alt_T| = 3.
  by apply: double_inj; rewrite -mul2n card_Alt T3.
apply/simpleP; split=> [|K]; [by rewrite trivg_card1 oA | case/andP=> sKH _].
have:= cardSg sKH; rewrite oA dvdn_divisors // !inE orbC /= -oA.
case/pred2P=> eqK; [right | left]; apply/eqP.
  by rewrite eqEcard sKH eqK leqnn.
by rewrite eq_sym eqEcard sub1G eqK cards1.
Qed.

Lemma not_simple_Alt_4 (T : finType) : #|T| = 4 -> ~~ simple 'Alt_T.
Proof.
move=> oT; set A := 'Alt_T.
have oA: #|A| = 12 by apply: double_inj; rewrite -mul2n card_Alt oT.
suffices [p]: exists p, [/\ prime p, 1 < #|A|`_p < #|A| & #|'Syl_p(A)| == 1%N].
  case=> p_pr pA_int; rewrite /A; case/normal_sylowP=> P; case/pHallP.
  rewrite /= -/A => sPA pP nPA; apply/simpleP=> [] [_]; rewrite -pP in pA_int.
  by case/(_ P)=> // defP; rewrite defP oA ?cards1 in pA_int.
have: #|'Syl_3(A)| \in filter [pred d | d %% 3 == 1%N] (divisors 12).
  by rewrite mem_filter -dvdn_divisors //= -oA card_Syl_dvd ?card_Syl_mod.
rewrite /= oA mem_seq2 orbC.
case/predU1P=> [oQ3|]; [exists 2 | exists 3]; split; rewrite ?p_part //.
pose A3 := [set x : {perm T} | #[x] == 3]; suffices oA3: #|A :&: A3| = 8.
  have sQ2 P: P \in 'Syl_2(A) -> P :=: A :\: A3.
    rewrite inE pHallE oA p_part -natTrecE /= => /andP[sPA /eqP oP].
    apply/eqP; rewrite eqEcard -(leq_add2l 8) -{1}oA3 cardsID oA oP.
    rewrite andbT subsetD sPA; apply/existsP=> [[x]] /= /andP[Px].
    by rewrite inE => /eqP ox; have:= order_dvdG Px; rewrite oP ox.
  have [/= P sylP] := Sylow_exists 2 [group of A].
  rewrite -(([set P] =P 'Syl_2(A)) _) ?cards1 // eqEsubset sub1set inE sylP.
  by apply/subsetP=> Q sylQ; rewrite inE -val_eqE /= !sQ2 // inE.
rewrite -[8]/(4 * 2)%N -{}oQ3 -sum1_card -sum_nat_const.
rewrite (partition_big (fun x => <[x]>%G) (mem 'Syl_3(A))) => [|x]; last first.
  by case/setIP=> Ax; rewrite /= !inE pHallE p_part cycle_subG Ax oA.
apply: eq_bigr => Q; rewrite inE /= inE pHallE oA p_part -?natTrecE //=.
case/andP=> sQA /eqP oQ; have:= oQ.
rewrite (cardsD1 1) group1 -sum1_card => [[/= <-]]; apply: eq_bigl => x.
rewrite setIC -val_eqE /= 2!inE in_setD1 -andbA -{4}[x]expg1 -order_dvdn dvdn1.
apply/and3P/andP=> [[/eqP-> _ /eqP <-] | [ntx Qx]]; first by rewrite cycle_id.
have:= order_dvdG Qx; rewrite oQ dvdn_divisors // mem_seq2 (negPf ntx) /=.
by rewrite eqEcard cycle_subG Qx (subsetP sQA) // oQ /order => /eqP->.
Qed.

Lemma simple_Alt5_base (T : finType) : #|T| = 5 -> simple 'Alt_T.
Proof.
move=> oT.
have F1: #|'Alt_T| = 60 by apply: double_inj; rewrite -mul2n card_Alt oT.
have FF (H : {group {perm T}}): H <| 'Alt_T -> H :<>: 1 -> 20 %| #|H|.
- move=> Hh1 Hh3.
  have [x _]: exists x, x \in T by apply/existsP/eqP; rewrite oT.
  have F2 := Alt_trans T; rewrite oT /= in F2.
  have F3: [transitive 'Alt_T, on setT | 'P] by exact: ntransitive1 F2.
  have F4: [primitive 'Alt_T, on setT | 'P] by exact: ntransitive_primitive F2.
  case: (prim_trans_norm F4 Hh1) => F5.
    case: Hh3; apply/trivgP; exact: subset_trans F5 (aperm_faithful _).
  have F6: 5 %| #|H| by rewrite -oT -cardsT (atrans_dvd F5).
  have F7: 4 %| #|H|.
    have F7: #|[set~ x]| = 4 by rewrite cardsC1 oT.
    case: (pickP (mem [set~ x])) => [y Hy | ?]; last by rewrite eq_card0 in F7.
    pose K := 'C_H[x | 'P]%G.
    have F8 : K \subset H by apply: subsetIl.
    pose Gx := 'C_('Alt_T)[x | 'P]%G.
    have F9: [transitive^2 Gx, on [set~ x] | 'P].
      by rewrite -[[set~ x]]setTI -setDE stab_ntransitive ?inE.
    have F10: [transitive Gx, on [set~ x] | 'P].
      exact: ntransitive1 F9.
    have F11: [primitive Gx, on [set~ x] | 'P].
      exact: ntransitive_primitive F9.
    have F12: K \subset Gx by apply: setSI; exact: normal_sub.
    have F13: K <| Gx by rewrite /(K <| _) F12 normsIG // normal_norm.
    case: (prim_trans_norm F11 F13) => Ksub; last first.
      apply: dvdn_trans (cardSg F8); rewrite -F7; exact: atrans_dvd Ksub.
    have F14: [faithful Gx, on [set~ x] | 'P].
      apply/subsetP=> g; do 2![case/setIP] => Altg cgx cgx'.
      apply: (subsetP (aperm_faithful 'Alt_T)).
      rewrite inE Altg /=; apply/astabP=> z _.
      case: (z =P x) => [->|]; first exact: (astab1P cgx).
      by move/eqP=> nxz; rewrite (astabP cgx') ?inE //.
    have Hreg g (z : T): g \in H -> g z = z -> g = 1.
      have F15 h: h \in H -> h x = x -> h = 1.
        move=> Hh Hhx; have: h \in K by rewrite inE Hh; apply/astab1P.
        by rewrite (trivGP (subset_trans Ksub F14)) => /set1P.
      move=> Hg Hgz; have:= in_setT x; rewrite -(atransP F3 z) ?inE //.
      case/imsetP=> g1 Hg1 Hg2; apply: (conjg_inj g1); rewrite conj1g.
      apply: F15; last by rewrite Hg2 -permM mulKVg permM Hgz.
      by case/normalP: Hh1 => _ nH1; rewrite -(nH1 _ Hg1) memJ_conjg.
    clear K F8 F12 F13 Ksub F14.
    case: (Cauchy _ F6) => // h Hh /eqP Horder.
    have diff_hnx_x n: 0 < n -> n < 5 -> x != (h ^+ n) x.
      move=> Hn1 Hn2; rewrite eq_sym; apply/negP => HH.
      have: #[h ^+ n] = 5.
        rewrite orderXgcd // (eqP Horder).
        by move: Hn1 Hn2 {HH}; do 5 (case: n => [|n] //).
      have Hhd2: h ^+ n \in H by rewrite groupX.
      by rewrite (Hreg _ _ Hhd2 (eqP HH)) order1.
    pose S1 := [tuple x; h x; (h ^+ 3) x].
    have DnS1: S1 \in 3.-dtuple(setT).
      rewrite inE memtE subset_all /= !inE /= !negb_or -!andbA /= andbT.
      rewrite -{1}[h]expg1 !diff_hnx_x // expgSr permM.
      by rewrite (inj_eq (@perm_inj _ _)) diff_hnx_x.
    pose S2 := [tuple x; h x; (h ^+ 2) x].
    have DnS2:  S2 \in 3.-dtuple(setT).
      rewrite inE memtE subset_all /= !inE /= !negb_or -!andbA /= andbT.
      rewrite -{1}[h]expg1 !diff_hnx_x // expgSr permM.
      by rewrite (inj_eq (@perm_inj _ _)) diff_hnx_x.
    case: (atransP2 F2 DnS1 DnS2) => g Hg [/=].
    rewrite /aperm => Hgx Hghx Hgh3x.
    have h_g_com: h * g = g * h.
      suff HH: (g * h * g^-1) * h^-1 = 1 by rewrite -[h * g]mul1g -HH !gnorm.
      apply: (Hreg _ x); last first.
        by rewrite !permM -Hgx Hghx -!permM mulKVg mulgV perm1.
      rewrite groupM // ?groupV // (conjgCV g) mulgK -mem_conjg.
      by case/normalP: Hh1 => _ ->.
    have: (g * (h ^+ 2) * g ^-1) x = (h ^+ 3) x.
      rewrite !permM -Hgx.
      have ->: h (h x) = (h ^+ 2) x by rewrite /= permM.
      by rewrite {1}Hgh3x -!permM /= mulgV mulg1 -expgSr.
    rewrite commuteX // mulgK {1}[expgn]lock expgS permM -lock.
    by move/perm_inj=> eqxhx; case/eqP: (diff_hnx_x 1%N isT isT); rewrite expg1.
  by rewrite (@Gauss_dvd 4 5) // F7.
apply/simpleP; split => [|H Hnorm]; first by rewrite trivg_card1 F1.
case Hcard1: (#|H| == 1%N); move/eqP: Hcard1 => Hcard1.
  by left; apply: card1_trivg; rewrite Hcard1.
right; case Hcard60: (#|H| == 60%N); move/eqP: Hcard60 => Hcard60.
  by apply/eqP; rewrite eqEcard Hcard60 F1 andbT; case/andP: Hnorm.
have Hcard20: #|H| = 20; last clear Hcard1 Hcard60.
  have Hdiv: 20 %| #|H| by apply: FF => // HH; case Hcard1; rewrite HH cards1.
  case H20: (#|H| == 20); first by apply/eqP.
  case: Hcard60; case/andP: Hnorm; move/cardSg; rewrite F1 => Hdiv1 _.
  by case/dvdnP: Hdiv H20 Hdiv1 => n ->; move: n; do 4!case=> //.
have prime_5: prime 5 by [].
have nSyl5: #|'Syl_5(H)| = 1%N.
  move: (card_Syl_dvd 5 H) (card_Syl_mod H prime_5).
  rewrite Hcard20; case: (card _) => // n Hdiv.
  move: (dvdn_leq  (isT: (0 < 20)%N) Hdiv).
  by move: (n) Hdiv; do 20 (case => //).
case: (Sylow_exists 5 H) => S; case/pHallP=> sSH oS.
have{oS} oS: #|S| = 5 by rewrite oS p_part Hcard20.
suff: 20 %| #|S| by rewrite oS.
apply FF => [|S1]; last by rewrite S1 cards1 in oS.
apply: char_normal_trans Hnorm; apply: lone_subgroup_char => // Q sQH isoQS.
rewrite subEproper; apply/norP=> [[nQS _]]; move: nSyl5.
rewrite (cardsD1 S) (cardsD1 Q) 4!{1}inE nQS !pHallE sQH sSH Hcard20 p_part.
by rewrite (card_isog isoQS) oS.
Qed.

Section Restrict.

Variables (T : finType) (x : T).
Notation T' := {y | y != x}.

Lemma rfd_funP (p : {perm T}) (u : T') :
  let p1 := if p x == x then p else 1 in p1 (val u) != x.
Proof.
case: (p x =P x) => /= [pxx|_]; last by rewrite perm1 (valP u).
by rewrite -{2}pxx (inj_eq (@perm_inj _ p)); exact: (valP u).
Qed.

Definition rfd_fun p := [fun u => Sub ((_ : {perm T}) _) (rfd_funP p u) : T'].

Lemma rfdP p : injective (rfd_fun p).
Proof.
apply: can_inj (rfd_fun p^-1) _ => u; apply: val_inj => /=.
rewrite -(inj_eq (@perm_inj _ p)) permKV eq_sym.
by case: eqP => _; rewrite !(perm1, permK).
Qed.

Definition rfd p := perm (@rfdP p).

Hypothesis card_T : 2 < #|T|.

Lemma rfd_morph : {in 'C_('Sym_T)[x | 'P] &, {morph rfd : y z / y * z}}.
Proof.
move=> p q; rewrite !setIA !setIid; move/astab1P=> p_x; move/astab1P=> q_x.
apply/permP=> u; apply: val_inj.
by rewrite permE /= !permM !permE /= [p x]p_x [q x]q_x eqxx permM /=.
Qed.

Canonical rfd_morphism := Morphism rfd_morph.

Definition rgd_fun (p : {perm T'}) :=
  [fun x1 => if insub x1 is Some u then sval (p u) else x].

Lemma rgdP p : injective (rgd_fun p).
Proof.
apply: can_inj (rgd_fun p^-1) _ => y /=.
case: (insubP _ y) => [u _ val_u|]; first by rewrite valK permK.
by rewrite negbK; move/eqP->; rewrite insubF //= eqxx.
Qed.

Definition rgd p := perm (@rgdP p).

Lemma rfd_odd (p : {perm T}) : p x = x -> rfd p = p :> bool.
Proof.
have rfd1: rfd 1 = 1.
  by apply/permP => u; apply: val_inj; rewrite permE /= if_same !perm1.
have HP0 (t : {perm T}): #|[set x | t x != x]| = 0 -> rfd t = t :> bool.
- move=> Ht; suff ->: t = 1 by rewrite rfd1 !odd_perm1.
  apply/permP => z; rewrite perm1; apply/eqP/wlog_neg => nonfix_z.
  by rewrite (cardD1 z) inE nonfix_z in Ht.
elim: #|_| {-2}p (leqnn #|[set x | p x != x]|) => {p}[|n Hrec] p Hp Hpx.
  by apply: HP0; move: Hp; case: card.
case Ex: (pred0b (mem [set x | p x != x])); first by apply: HP0; move/eqnP: Ex.
case/pred0Pn: Ex => x1; rewrite /= inE => Hx1.
have nx1x: x1 != x by apply/eqP => HH; rewrite HH Hpx eqxx in Hx1.
have npxx1: p x != x1 by apply/eqP => HH; rewrite -HH !Hpx eqxx in Hx1.
have npx1x: p x1 != x.
  by apply/eqP; rewrite -Hpx; move/perm_inj => HH; case/eqP: nx1x.
pose p1 := p * tperm x1 (p x1).
have Hp1: p1 x = x.
  by rewrite /p1 permM; case tpermP => // [<-|]; [rewrite Hpx | move/perm_inj].
have Hcp1: #|[set x | p1 x != x]| <= n.
  have F1 y: p y = y -> p1 y = y.
    move=> Hy; rewrite /p1 permM Hy.
    case tpermP => //; first by move => <-.
    by move=> Hpx1; apply: (@perm_inj _ p); rewrite -Hpx1.
  have F2: p1 x1 = x1 by rewrite /p1 permM tpermR.
  have F3: [set x | p1 x != x] \subset [predD1 [set x | p x != x] & x1].
    apply/subsetP => z; rewrite !inE permM.
    case tpermP => HH1 HH2.
    - rewrite eq_sym HH1 andbb; apply/eqP=> dx1.
      by rewrite dx1 HH1 dx1 eqxx in HH2.
    - by rewrite (perm_inj HH1) eqxx in HH2.
    by move->; rewrite andbT; apply/eqP => HH3; rewrite HH3 in HH2.
  apply: (leq_trans (subset_leq_card F3)).
  by move: Hp; rewrite (cardD1 x1) inE Hx1.
have ->: p = p1 * tperm x1 (p x1) by rewrite -mulgA tperm2 mulg1.
rewrite odd_permM odd_tperm eq_sym Hx1 morphM; last 2 first.
- by rewrite 2!inE; exact/astab1P.
- by rewrite 2!inE; apply/astab1P; rewrite -{1}Hpx /= /aperm -permM.
rewrite odd_permM Hrec //=; congr (_ (+) _).
pose x2 : T' := Sub x1 nx1x; pose px2 : T' := Sub (p x1) npx1x.
suff ->: rfd (tperm x1 (p x1)) = tperm x2 px2.
  by rewrite odd_tperm -val_eqE eq_sym.
apply/permP => z; apply/val_eqP; rewrite permE /= tpermD // eqxx.
case: (tpermP x2) => [->|->|HH1 HH2]; rewrite /x2 ?tpermL ?tpermR 1?tpermD //.
  by apply/eqP=> HH3; case: HH1; apply: val_inj.
by apply/eqP => HH3; case: HH2; apply: val_inj.
Qed.

Lemma rfd_iso : 'C_('Alt_T)[x | 'P] \isog 'Alt_T'.
Proof.
have rgd_x p: rgd p x = x by rewrite permE /= insubF //= eqxx.
have rfd_rgd p: rfd (rgd p) = p.
  apply/permP => [[z Hz]]; apply/val_eqP; rewrite !permE.
  rewrite /= [rgd _ _]permE /= insubF eq_refl // permE /=.
  by rewrite (@insubT _ (xpredC1 x) _ _ Hz).
have sSd: 'C_('Alt_T)[x | 'P] \subset 'dom rfd.
  by apply/subsetP=> p; rewrite !inE /=; case/andP.
apply/isogP; exists [morphism of restrm sSd rfd] => /=; last first.
  rewrite morphim_restrm setIid; apply/setP=> z; apply/morphimP/idP=> [[p _]|].
    case/setIP; rewrite Alt_even => Hp; move/astab1P=> Hp1 ->.
    by rewrite Alt_even rfd_odd.
  have dz': rgd z x == x by rewrite rgd_x.
  move=> kz; exists (rgd z); last by rewrite /= rfd_rgd.
    by rewrite 2!inE (sameP astab1P eqP).
  rewrite 4!inE /= (sameP astab1P eqP) dz' -rfd_odd; last exact/eqP.
  by rewrite rfd_rgd mker // ?set11.
apply/injmP=> x1 y1 /=.
case/setIP=> Hax1; move/astab1P; rewrite /= /aperm => Hx1.
case/setIP=> Hay1; move/astab1P; rewrite /= /aperm => Hy1 Hr.
apply/permP => z.
case (z =P x) => [->|]; [by rewrite Hx1 | move/eqP => nzx].
move: (congr1 (fun q : {perm T'} => q (Sub z nzx)) Hr).
by rewrite !permE => [[]]; rewrite Hx1 Hy1 !eqxx.
Qed.

End Restrict.

Lemma simple_Alt5 (T : finType) : #|T| >= 5 -> simple 'Alt_T.
Proof.
suff F1 n: #|T| = n + 5 -> simple 'Alt_T by move/subnK/esym/F1.
elim: n T => [| n Hrec T Hde]; first exact: simple_Alt5_base.
have oT: 5 < #|T| by rewrite Hde addnC.
apply/simpleP; split=> [|H Hnorm]; last have [Hh1 nH] := andP Hnorm.
  rewrite trivg_card1 -[#|_|]half_double -mul2n card_Alt Hde addnC //.
  by rewrite addSn factS mulnC -(prednK (fact_gt0 _)).
case E1: (pred0b T); first by rewrite /pred0b in E1; rewrite (eqP E1) in oT.
case/pred0Pn: E1 => x _; have Hx := in_setT x.
have F2: [transitive^4 'Alt_T, on setT | 'P].
  by apply: ntransitive_weak (Alt_trans T); rewrite -(subnKC oT).
have F3 := ntransitive1 (isT: 0 < 4) F2.
have F4 := ntransitive_primitive (isT: 1 < 4) F2.
case Hcard1: (#|H| == 1%N); move/eqP: Hcard1 => Hcard1.
  by left; apply: card1_trivg; rewrite Hcard1.
right; case: (prim_trans_norm F4 Hnorm) => F5.
  by rewrite (trivGP (subset_trans F5 (aperm_faithful _))) cards1 in Hcard1.
case E1: (pred0b (predD1 T x)).
  rewrite /pred0b in E1; move: oT.
  by rewrite (cardD1 x) (eqP E1); case: (T x).
case/pred0Pn: E1 => y Hdy; case/andP: (Hdy) => diff_x_y Hy.
pose K := 'C_H[x | 'P]%G.
have F8: K \subset H by apply: subsetIl.
pose Gx := 'C_('Alt_T)[x | 'P].
have F9: [transitive^3 Gx, on [set~ x] | 'P].
  by rewrite -[[set~ x]]setTI -setDE stab_ntransitive ?inE.
have F10: [transitive Gx, on [set~ x] | 'P].
  by apply: ntransitive1 F9.
have F11: [primitive Gx, on [set~ x] | 'P].
  by apply: ntransitive_primitive F9.
have F12: K \subset Gx by rewrite setSI // normal_sub.
have F13: K <| Gx by apply/andP; rewrite normsIG.
have:= prim_trans_norm F11; case/(_ K) => //= => Ksub; last first.
  have F14: Gx * H = 'Alt_T by exact/subgroup_transitiveP.
  have: simple Gx.
    by rewrite (isog_simple (rfd_iso x)) Hrec //= card_sig cardC1 Hde.
  case/simpleP=> _ simGx; case/simGx: F13 => /= HH2.
    case Ez: (pred0b (predD1 (predD1 T x) y)).
      move: oT; rewrite /pred0b in Ez.
      by rewrite (cardD1 x) (cardD1 y) (eqP Ez) inE /= inE /= diff_x_y.
    case/pred0Pn: Ez => z; case/andP => diff_y_z Hdz.
    have [diff_x_z Hz] := andP Hdz.
    have: z \in [set~ x] by rewrite !inE.
    rewrite -(atransP Ksub y) ?inE //; case/imsetP => g.
    rewrite /= HH2 inE; move/eqP=> -> HH4.
    by case/negP: diff_y_z; rewrite HH4 act1.
  by rewrite /= -F14 -[Gx]HH2 (mulSGid F8).
have F14: [faithful Gx, on [set~ x] | 'P].
  apply: subset_trans (aperm_faithful 'Sym_T); rewrite subsetI subsetT.
  apply/subsetP=> g; do 2![case/setIP]=> _ cgx cgx'; apply/astabP=> z _ /=.
  case: (z =P x) => [->|]; first exact: (astab1P cgx).
  by move/eqP=> zx; rewrite [_ g](astabP cgx') ?inE.
have Hreg g z: g \in H -> g z = z -> g = 1.
  have F15 h: h \in H -> h x = x -> h = 1.
    move=> Hh Hhx; have: h \in K by rewrite inE Hh; apply/astab1P.
    by rewrite [K](trivGP (subset_trans Ksub F14)) => /set1P.
  move=> Hg Hgz; have:= in_setT x; rewrite -(atransP F3 z) ?inE //.
  case/imsetP=> g1 Hg1 Hg2; apply: (conjg_inj g1); rewrite conj1g.
  apply: F15; last by rewrite Hg2 -permM mulKVg permM Hgz.
  by rewrite memJ_norm ?(subsetP nH).
clear K F8 F12 F13 Ksub F14.
have Hcard: 5 < #|H|.
  apply: (leq_trans oT); apply dvdn_leq; first by exact: cardG_gt0.
  by rewrite -cardsT (atrans_dvd F5).
case Eh: (pred0b [predD1 H & 1]).
  by move: Hcard; rewrite /pred0b in Eh; rewrite (cardD1 1) group1 (eqP Eh).
case/pred0Pn: Eh => h; case/andP => diff_1_h /= Hh.
case Eg: (pred0b (predD1 (predD1 [predD1 H & 1] h) h^-1)).
  move: Hcard; rewrite ltnNge; case/negP.
  rewrite (cardD1 1) group1 (cardD1 h) (cardD1 h^-1) (eqnP Eg).
  by do 2!case: (_ \in _).
case/pred0Pn: Eg => g; case/andP => diff_h1_g; case/andP => diff_h_g.
case/andP => diff_1_g /= Hg.
case diff_hx_x: (h x == x).
by case/negP: diff_1_h; apply/eqP; apply: (Hreg _ _ Hh (eqP diff_hx_x)).
case diff_gx_x: (g x == x).
  case/negP: diff_1_g; apply/eqP; apply: (Hreg _ _ Hg (eqP diff_gx_x)).
case diff_gx_hx: (g x == h x).
  case/negP: diff_h_g; apply/eqP; symmetry; apply: (mulIg g^-1); rewrite gsimp.
  apply: (Hreg _ x); first by rewrite groupM // groupV.
  by rewrite permM -(eqP diff_gx_hx) -permM mulgV perm1.
case diff_hgx_x: ((h * g) x == x).
  case/negP: diff_h1_g; apply/eqP; apply: (mulgI h); rewrite !gsimp.
  by apply: (Hreg _ x); [exact: groupM | apply/eqP].
case diff_hgx_hx: ((h * g) x == h x).
  case/negP: diff_1_g; apply/eqP.
  by apply: (Hreg _ (h x)) => //; apply/eqP; rewrite -permM.
case diff_hgx_gx: ((h * g) x == g x).
  case/eqP: diff_hx_x; apply: (@perm_inj _ g) => //.
  by apply/eqP; rewrite -permM.
case Ez: (pred0b
            (predD1 (predD1 (predD1 (predD1 T x) (h x)) (g x)) ((h * g) x))).
- move: oT; rewrite /pred0b in Ez.
  rewrite (cardD1 x) (cardD1 (h x)) (cardD1 (g x)) (cardD1 ((h * g) x)).
  by rewrite (eqP Ez); do 3!case: (_ x \in _).
case/pred0Pn: Ez => z.
case/and5P=> diff_hgx_z diff_gx_z diff_hx_z diff_x_z /= Hz.
pose S1 := [tuple x; h x; g x; z].
have DnS1: S1 \in 4.-dtuple(setT).
  rewrite inE memtE subset_all -!andbA !negb_or /= !inE !andbT.
  rewrite -!(eq_sym z) diff_gx_z diff_x_z diff_hx_z.
  by rewrite !(eq_sym x) diff_hx_x diff_gx_x eq_sym diff_gx_hx.
pose S2 := [tuple x; h x; g x; (h * g) x].
have DnS2: S2 \in 4.-dtuple(setT).
  rewrite inE memtE subset_all -!andbA !negb_or /= !inE !andbT !(eq_sym x).
  rewrite diff_hx_x diff_gx_x diff_hgx_x.
  by rewrite !(eq_sym (h x)) diff_gx_hx diff_hgx_hx eq_sym diff_hgx_gx.
case: (atransP2 F2 DnS1 DnS2) => k Hk [/=].
rewrite /aperm => Hkx Hkhx Hkgx Hkhgx.
have h_k_com: h * k = k * h.
  suff HH: (k * h * k^-1) * h^-1 = 1 by rewrite -[h * k]mul1g -HH !gnorm.
  apply: (Hreg _ x); last first.
    by rewrite !permM -Hkx Hkhx -!permM mulKVg mulgV perm1.
  by rewrite groupM // ?groupV // (conjgCV k) mulgK -mem_conjg (normsP nH).
have g_k_com: g * k = k * g.
  suff HH: (k * g * k^-1) * g^-1 = 1 by rewrite -[g * k]mul1g -HH !gnorm.
  apply: (Hreg _ x); last first.
    by rewrite !permM -Hkx Hkgx -!permM mulKVg mulgV perm1.
  by rewrite groupM // ?groupV // (conjgCV k) mulgK -mem_conjg (normsP nH).
have HH: (k * (h * g) * k ^-1) x = z.
   by rewrite 2!permM -Hkx Hkhgx -permM mulgV perm1.
case/negP: diff_hgx_z.
rewrite -HH !mulgA -h_k_com -!mulgA [k * _]mulgA.
by rewrite -g_k_com -!mulgA mulgV mulg1.
Qed.


Require Export Undecidability.TM.Code.CodeTM Undecidability.TM.Code.ChangeAlphabet.
Require Export Undecidability.TM.Compound.TMTac.
Require Export Undecidability.TM.Basic.Mono Undecidability.TM.Compound.Multi.
(* the above imports sidestep the import of ProgrammingTools below to avoid the dependency on Hoare *)
(*From Undecidability.TM Require Import ProgrammingTools.*)
From Undecidability Require Import ArithPrelim.
Require Import Undecidability.Shared.FinTypeEquiv Undecidability.Shared.FinTypeForallExists.

Set Default Proof Using "Type".
Section fix_Sigma.

  Variable n : nat.

  Definition encode_sym (s : Fin.t n) : list bool :=
    let i := proj1_sig (Fin.to_nat s) in
    repeat false i ++ repeat true (n - i).

  Lemma length_encode_sym (s : Fin.t n) :
    length (encode_sym s) = n.
  Proof.
    unfold encode_sym. destruct Fin.to_nat as [i Hi].
    cbn. rewrite app_length, !repeat_length. lia.
  Qed.

  Fixpoint encode_string (s : list (Fin.t n)) :=
    match s with
    | [] => []
    | i :: l => false :: encode_sym i ++ true :: encode_string l
    end.

  Lemma encode_string_app s1 s2 :
    encode_string (s1 ++ s2) = encode_string s1 ++ encode_string s2.
  Proof.
    induction s1; cbn.
    - reflexivity.
    - rewrite <-app_assoc. cbn. now rewrite IHs1.
  Qed.

  Definition encode_tape (t : tape (Fin.t n)) :=
    match t with
    | niltape => niltape
    | midtape ls c_i rs => midtape (rev (encode_string (rev ls))) false (encode_sym c_i ++ true :: encode_string rs)
    | leftof c_i rs => leftof false (encode_sym c_i ++ true :: encode_string rs)
    | rightof c_i ls => rightof true (rev (encode_sym c_i) ++ false :: rev(encode_string (rev (ls))))
    end.

End fix_Sigma.

Fixpoint ReadB (n : nat) : pTM (FinType (EqType bool)) (option (Fin.t n)) 1.
Proof.
  destruct n as [ | n ].
  - exact (Return Nop None).
  - refine (Switch ReadChar (fun o : option bool =>
                              match o with None => Return Nop None | Some _ =>
                                Move Rmove ;; Switch ReadChar (fun o : option bool  =>
                                match o with
                                | None => Return (Move Lmove) None
                                | Some true => Return (Move Lmove) (Some Fin.F1)
                                | Some false => Switch (ReadB n) (fun o => Return (Move Lmove)
                                                                            (match o with
                                                                             | None => None
                                                                             | Some i => Some (Fin.R 1 i)
                                                                             end))
                                end)
                              end)).
Defined. (* because definition *)

Definition ReadB_rel' d n : Vector.t (tape bool) 1 -> option (Fin.t (d + n)) * Vector.t (tape bool) 1 -> Prop :=
  fun t '(l, t') =>
    forall t_sig : tape (Fin.t n), t = [| encode_tape t_sig |] -> t' = t /\ forall s, current t_sig = Some s -> l = Some (Fin.R d s).

Smpl Add eassumption : TM_Correct.

Fixpoint ReadB_canonical n :
  {Rel | ReadB n ⊨ Rel}.
Proof.
  destruct n; cbn.
  - eexists. TM_Correct.
  - eexists. eapply Switch_Realise. TM_Correct. cbn in *. intros [ | ].
    instantiate (1 := fun o => match o with None => _ | Some _ => _ end).
    eapply Seq_Realise. TM_Correct.
    eapply Switch_Realise. TM_Correct. cbn in *. intros [[] | ].
    instantiate (1 := fun o => match o with None => _ | Some true => _ | Some false => _ end). cbn in *.
    TM_Correct. eapply Switch_Realise. eapply (proj2_sig (ReadB_canonical n)).
    instantiate (1 := fun o => match o with None => _ | Some _ => _ end).
    intros []; TM_Correct. TM_Correct. cbn. TM_Correct.
Defined. (* because definition *)

Lemma ReadB_Realise n :
  ReadB n ⊨ fun t '(l, t') => forall t_sig : tape (Fin.t n), t = [| encode_tape t_sig |] -> t' = t /\ l = current t_sig.
Proof.
  eapply Realise_monotone. exact (proj2_sig (ReadB_canonical n)).
  pose (Rel := (fun n (t : Vector.t _ 1) '(l, t') =>
  match t with
  | [| midtape ls _ rs |] => forall rs' (c_i : Fin.t n), rs = encode_sym c_i ++ rs' ->
        t' = t /\ l = Some c_i
  | _ => t' = t /\ l = None
  end) : forall n, Vector.t (tape bool) 1 -> option (Fin.t n) * Vector.t (tape bool) 1 -> Prop).
  transitivity (Rel n).
  - induction n.
    + subst Rel. cbn. intros tp (l, t') (-> & [ _ ->]).
      eapply Vector.caseS' with (v := tp). clear tp. intros t nl.
      eapply Vector.case0 with (v := nl). clear nl. destruct t; eauto.
      intros rs' c_i ->. inv c_i.
    + intros t (l, t') (? & tright & (-> & ->) & H).
      destruct_tapes. cbn in *. rename h into t'. rename h0 into t.
      destruct t; cbn in *.
      * destruct H as (-> & [] & ->). eauto.
      * destruct H as (-> & [] & ->). eauto.
      * destruct H as (-> & [] & ->). eauto.
      * intros rs' c_i ->.
        destruct H as ([] & tps & ? & ? & tps' & [-> ->] & H0).
        destruct_tapes. cbn in *. subst. rename l0 into ls. cbn in *.
        revert H0. eapply Fin.caseS' with (p := c_i); clear c_i.
        -- cbn. intros (-> & [] & ->). eauto.
        -- intros c_i. change (Fin.FS c_i) with (Fin.R 1 c_i) in *.
           unfold encode_sym. cbn in *.
           pose proof (Fin.R_sanity 1 c_i) as E. cbn in E.
           rewrite E. clear E. cbn.
           intros (o & tout & ? & ?). eapply IHn in H. cbn in H.
           destruct (H _ _ eq_refl) as [-> ->].  cbn in *.
           destruct H0 as (-> & [] & ->). eauto.
  - intros t (l, t'). unfold Rel. intros H.
    destruct_tapes. rename h0 into t. rename h into t'. intros t_sig [= ->].
    destruct t_sig; cbn in *; eauto.
Qed.

Definition isTotal {Σ} {L} {n} (M : pTM Σ L n) := exists c, projT1 M ↓ fun t k => c <= k.

Ltac help :=
  intros;TMSimp; destruct_tapes; TMSimp; try lia;
  try match goal with
  [ |- ?L <= ?R ] => tryif (is_evar R) then (eapply le_plus_l) else (ring_simplify; shelve)
  | _ => idtac
  end.

Lemma ReadB_total n :
  isTotal (ReadB n).
Proof.
  induction n.
  - cbn. eexists. eapply TerminatesIn_monotone. TM_Correct.
    intros ? ? H. exact H.
  - destruct IHn as [c IH].
    eexists. eapply TerminatesIn_monotone. cbn.
    eapply Switch_TerminatesIn. TM_Correct. TM_Correct.
    intros []. instantiate (1 := fun f => if f then _ else _). cbn.
    instantiate (1 := ltac:(clear f; refine _)).
    eapply Seq_TerminatesIn. TM_Correct. TM_Correct.
    eapply Switch_TerminatesIn. TM_Correct. TM_Correct.
    intros []. instantiate (1 := fun f => match f with Some true => _ | Some false => _ | None => _ end). cbn.
    destruct b0 as [[] | ].
    + cbn. instantiate (1 := ltac:(clear f b0; refine _)).
      TM_Correct.
    + instantiate (1 := ltac:(clear f b0; refine _)).
      eapply Switch_TerminatesIn. eapply ReadB_Realise. eassumption.
      intros []. cbn. TM_Correct.
      instantiate (1 := fun f => if f then _ else _). cbn.
      instantiate (1 := ltac:(clear f; refine _)). TM_Correct.
      cbn.
      instantiate (1 := ltac:(clear f; refine _)).  TM_Correct.
    + cbn. instantiate (1 := ltac:(clear f; refine _)).  TM_Correct.
    + cbn. instantiate (1 := ltac:(clear f; refine _)).  TM_Correct.
    + cbn. intros ? ? ?. exists 1. eexists. split.
      lia. split. 2:{ intros. TMSimp. destruct_tapes. TMSimp.
      destruct (current _).
      * exists 1. eexists. split. lia. split. 2:{ intros. TMSimp. destruct_tapes. TMSimp.
        exists 1. eexists. split. lia. split. 2:{ intros. TMSimp. destruct_tapes. TMSimp.
        destruct current. destruct b0. instantiate (1 := S _). lia. 2:lia.
        exists c. eexists. split. lia. split. 2:{ intros. destruct yout. instantiate (1 := S _). lia. lia. }
        ring_simplify. shelve. }
        ring_simplify. shelve. }
        ring_simplify. cbn. shelve.
      * shelve. } shelve.
      Unshelve. 2:exact 0. 4: exact (S c). all: try lia. 2:{ eapply H. }
Qed.

Require Import Undecidability.TM.Compound.WriteString.

Fixpoint MoveM {Σ : finType} (D : move) (n : nat) : pTM Σ unit 1 :=
  match n with
  | 0 => Nop
  | S n => MoveM D n ;; Move D
  end.

Definition TestLeftof {Σ : finType} : pTM Σ bool 1 :=
  Switch ReadChar (fun s1 => match s1 with Some _ => Return Nop false | None => Move Rmove ;; Switch ReadChar (fun s2 => match s2 with None => Return Nop false | Some _ => Return (Move Lmove) true end) end).

Lemma TestLeftof_Realise {Σ : finType} :
  @TestLeftof Σ ⊨ fun t '(b, t') => t = t' /\ match t with [| leftof _ _ |] => b = true | _ => b = false end.
Proof.
  eapply Realise_monotone. unfold TestLeftof. TM_Correct.
  intros t (b, t') ?. TMSimp. destruct_tapes. TMSimp. rename t_0 into t.
  destruct t; cbn in *; TMSimp; eauto.
Qed.

Definition MoveL_rel {Σ : finType} D (n : nat) : Vector.t (tape Σ) 1 -> unit * Vector.t (tape Σ) 1 -> Prop :=
  fun t '(_, t') => t' = Vector.map (Nat.iter n (fun t => @tape_move Σ t D)) t.

Lemma MoveM_Realise {Σ : finType} D (n : nat) :
  @MoveM Σ D n ⊨ MoveL_rel D n.
Proof.
  induction n; unfold MoveL_rel; cbn.
  - eapply Realise_monotone. TM_Correct. intros t ([], t') ->.
    destruct_tapes. reflexivity.
  - eapply Realise_monotone. eapply Seq_Realise. eassumption. TM_Correct.
    intros t ([], t') ?; cbn in *. TMSimp. destruct_tapes. TMSimp. reflexivity.
Qed.

Definition WriteB (n : nat) (c : option (Fin.t n)) : pTM (FinType (EqType bool)) unit 1 :=
  match c with
  | None => Nop
  | Some c =>
    Switch TestLeftof (fun b => if b then WriteString Lmove (rev (false :: encode_sym c ++ [true])) else
      WriteString Rmove (false :: encode_sym c ++ [true]) ;; MoveM Lmove (S n))
  end.

Lemma Nat_iter_S' {A} (f : A -> A) (a : A) n :
  Nat.iter (S n) f a = f (Nat.iter n f a).
Proof.
  reflexivity.
Qed.

Lemma Nat_iter_S {A} (f : A -> A) (a : A) n :
   Nat.iter (S n) f a = Nat.iter n f (f a).
Proof.
  induction n in a |- *; cbn.
  - reflexivity.
  - unfold Nat.iter in IHn. now rewrite <- IHn.
Qed.

Lemma Nat_iter_id {A} (a : A) n :
   Nat.iter n (fun a : A => a) a = a.
Proof.
  induction n in a |- *; cbn.
  - reflexivity.
  - unfold Nat.iter in IHn. now rewrite <- IHn.
Qed.

Lemma WriteString_MoveBack {Σ : finType} (x : Σ) l :
  (WriteString Rmove (x :: l) ;; MoveM Lmove (|l|)) ⊨ fun t '(_, t') => t' = Vector.map (fun t => midtape (left t) x (l ++ skipn (|l|) (right t))) t.
Proof.
  eapply Realise_monotone. TM_Correct. eapply RealiseIn_Realise, WriteString_Sem. eapply MoveM_Realise.
  intros t ([], t') ([] & t1 & ? & ?). TMSimp. destruct_tapes. TMSimp. f_equal. rename t_0 into t.
  induction l in x, t |- *.
  - reflexivity.
  - cbn [length plus]. rewrite Nat_iter_S'.
    rewrite WriteString_Fun_eq. setoid_rewrite IHl. clear.
    destruct t; cbn.
    + now rewrite skipn_nil.
    + reflexivity.
    + now rewrite skipn_nil.
    + unfold tape_move_left'. unfold tape_move_right'. cbn. destruct l1; cbn.
      * now rewrite skipn_nil.
      * reflexivity.
Qed.

Lemma WriteB_Realise (n : nat) (c : option (Fin.t n)) :
  WriteB c ⊨ fun t '(_, t') => forall t_sig, t = [| encode_tape t_sig |] -> t' = [| encode_tape (wr c t_sig) |].
Proof.
  destruct c as [c | ].
  - eapply Realise_monotone. unfold WriteB. eapply Switch_Realise.
    eapply TestLeftof_Realise. intros []. instantiate (1 := fun b => if b then _ else _).
    cbn. eapply RealiseIn_Realise, WriteString_Sem.
    pose proof (@WriteString_MoveBack (finType_CS bool) false (encode_sym c ++ [true])). cbn in H.
    replace (|encode_sym c ++ [true]|) with (S n) in H. 2:rewrite app_length, length_encode_sym; cbn; lia. cbn.
    eapply H.
    intros t ([], t') ? ? ->. TMSimp. destruct_tapes. TMSimp. f_equal.
    destruct t_sig eqn:E; cbn - [skipn].
    + cbn in *. TMSimp. now rewrite app_nil_r.
    + cbn in *. TMSimp. generalize (encode_sym t ++ true :: encode_string l). clear. intros.
      replace (encode_sym c ++ true :: false :: l) with ((encode_sym c ++ [true]) ++ false :: l).
      generalize (encode_sym c ++ [true]). generalize false. intros.
      generalize b at 1 4. intros.
      induction l0 in b0, b, l |- * using rev_ind; cbn.
      * reflexivity.
      * rewrite rev_app_distr. cbn. rewrite WriteString_Fun_eq.
        destruct l0 as [ | x0 l0 _] using rev_ind.
        -- cbn. reflexivity.
        -- rewrite rev_app_distr. cbn. rewrite <- !app_assoc.
           specialize (IHl0 (b0 :: l) b x). rewrite rev_app_distr in IHl0.
           cbn in *. rewrite <- app_assoc in IHl0. cbn in IHl0. eassumption.
      * now rewrite <- app_assoc.
    + cbn in *. TMSimp. rewrite <- app_assoc. cbn. repeat  f_equal. rewrite encode_string_app. cbn.
      rewrite !rev_app_distr. cbn. rewrite rev_app_distr. cbn. now rewrite <- app_assoc.
    + cbn in *. TMSimp. rewrite <- app_assoc. cbn -[skipn]. repeat f_equal.
      replace (encode_sym t ++ true :: encode_string l0) with ((encode_sym t ++ [true]) ++ encode_string l0).
      pose proof (length_encode_sym t).
      destruct (encode_sym) eqn:E.
      * cbn in *. subst. reflexivity.
      * cbn in *. inv H. rewrite skipn_app. reflexivity. rewrite app_length. cbn. lia.
      * now rewrite <- app_assoc.
  - cbn. eapply Realise_monotone. TM_Correct.
    intros t ([], t') ->. eauto.
Qed.

Lemma MoveM_isTotal {Σ : finType} D (n : nat) :
  isTotal (@MoveM Σ D n).
Proof.
  induction n; cbn.
  - eexists. TM_Correct.
  - destruct IHn as [c IH]. eexists. eapply TerminatesIn_monotone.
    TM_Correct. eapply MoveM_Realise. intros ? ? ?.
    repeat eexists. eapply le_plus_l. cbn. 2: intros; eapply le_plus_l.
    eapply H.
  Unshelve. all:exact 0.
Qed.

Lemma WriteB_TerminatesIn (n : nat) (c : option (Fin.t n)) :
  isTotal (WriteB c).
Proof.
  destruct (@MoveM_isTotal (finType_CS bool) Lmove n) as [MoveM_c H_MoveM].
  red. eexists. eapply TerminatesIn_monotone.
  unfold WriteB. destruct c; cbn.
  - instantiate (1 := ltac:(destruct c; refine _ )). cbn.
    TM_Correct. eapply TestLeftof_Realise. unfold TestLeftof.
    TM_Correct. eapply RealiseIn_TerminatesIn, WriteString_Sem.
    eapply RealiseIn_Realise, WriteString_Sem.
    eapply RealiseIn_TerminatesIn, WriteString_Sem.
    eapply MoveM_Realise.
  - cbn. TM_Correct.
  - cbn. intros ? ? ?. destruct c; cbn.
    + repeat eexists. help. eapply le_plus_l.
      intros. TMSimp. destruct_tapes. cbn.
      destruct (current _).
      * destruct b; help.
      * repeat eexists. help. help. help. eapply le_plus_l.
        intros. TMSimp. destruct_tapes. TMSimp. destruct current.
        destruct b; help. lia.
      * eapply H.
      * intros. TMSimp. destruct_tapes. rename tout_0 into h. destruct h; help.
        -- TMSimp. repeat eexists.
           rewrite !app_length, length_encode_sym. cbn. eapply le_plus_l. cbn.
           instantiate (1 := ltac:(destruct c; refine _ )). cbn in *.
           eapply le_plus_l. eapply le_plus_l. eapply le_plus_l. intros. eapply le_plus_l.
        -- TMSimp. rewrite !app_length, rev_length, !app_length, length_encode_sym. cbn. lia.
        -- TMSimp. repeat eexists. rewrite !app_length, length_encode_sym. cbn. eapply le_plus_l.
           2: eapply le_plus_l. 2:eapply le_plus_l. 2: intros; eapply le_plus_l.
           ring_simplify. shelve.
        -- TMSimp. repeat eexists. rewrite !app_length, length_encode_sym. cbn.
           eapply le_plus_l. cbn. shelve. eapply le_plus_l. eapply le_plus_l. intros. eapply le_plus_l.
    + lia.
    Unshelve. all: try exact 0. lia. lia. lia.
Qed.

Definition MoveB (m : move) n : pTM (finType_CS bool) unit 1 :=
  Switch TestLeftof (fun b => match b, m with
                              | true, Rmove => Move Rmove
                              | _, _ => MoveM m (2 + n)
                              end).

Arguments Nat.iter : simpl never.
Opaque Nat.iter.

Lemma midtape_left_midtape {Σ : finType} (l1 l2 : list Σ) m m' r n :
  n = S (length l1) ->
  Nat.iter n (@tape_move_left Σ) (midtape (rev l1 ++ [m'] ++ l2) m r) = midtape l2 m' (l1 ++ m :: r).
Proof.
  intros ->. induction l1 in m, m', l2 |- *.
  - cbn. reflexivity.
  - cbn. rewrite <- app_assoc. rewrite Nat_iter_S'.
    now rewrite (IHl1 (m' :: l2) m a).
Qed.

Lemma midtape_right_midtape {Σ : finType} l m r1 c r2 n :
  n = S (length r1) ->
  Nat.iter n (@tape_move_right Σ) (midtape l m (r1 ++ c :: r2)) = midtape (rev r1 ++ m :: l) c r2.
Proof.
  intros ->. induction r1 in m, c, r2 |- * using rev_ind; cbn.
  - reflexivity.
  - rewrite app_length. cbn. rewrite plus_comm. cbn.
    rewrite <- app_assoc, Nat_iter_S'. cbn.
    rewrite (IHr1 m x (c :: r2)). cbn. now rewrite rev_app_distr.
Qed.

Lemma midtape_right_rightof {Σ : finType} l m rs c n :
  n = 2 + (length rs) ->
  Nat.iter n (@tape_move_right Σ) (midtape l m (rs ++ [c])) = rightof c (rev rs ++ m :: l).
Proof.
  intros ->. cbn. rewrite Nat_iter_S'.
  rewrite midtape_right_midtape. 2:reflexivity. cbn. reflexivity.
Qed.

Lemma MoveB_Realise (n : nat) m :
  MoveB m n ⊨ fun t '(l, t') => forall t_sig, t = [| encode_tape t_sig |] -> t' = [| @encode_tape n (mv m t_sig) |].
Proof.
  epose (R := _). eapply Realise_monotone.
  { unfold MoveB.
    eapply Switch_Realise. eapply TestLeftof_Realise.
    instantiate (1 := R m). subst R.
    instantiate (1 := fun m b => if b then _ else _). cbn.
    intros []. cbn. instantiate (1 := match m0 with Rmove => _ | _ => _ end). cbn. destruct m.
    TM_Correct. eapply MoveM_Realise. TM_Correct. TM_Correct. eapply MoveM_Realise.
    TM_Correct. eapply MoveM_Realise. } subst R.

  assert (forall n c rs, Nat.iter n (fun t : tape bool  => tape_move_left t) (leftof c rs) = leftof c rs) as Eleft. {
    clear. intros. clear. induction  n; cbn. reflexivity. rewrite Nat_iter_S', IHn. reflexivity. }

  intros t ([], t') ? t_sig ->. TMSimp. destruct_tapes. f_equal.
  destruct t_sig.
  - TMSimp. destruct_tapes. TMSimp.
    assert (Nat.iter n (fun t : tape bool  => tape_move t m) niltape = niltape) as ->.
    { induction  n; cbn. reflexivity. rewrite Nat_iter_S', IHn. now destruct m. }
    now destruct m.
  - cbn in *. TMSimp. destruct m.
    + TMSimp. destruct_tapes. TMSimp. now rewrite Eleft.
    + TMSimp. reflexivity.
    + TMSimp. destruct_tapes. TMSimp. now rewrite Nat_iter_id.
  - TMSimp. destruct_tapes. TMSimp.
    destruct m.
    + cbn. rewrite <- !Nat_iter_S' with (f := fun t0 => tape_move_left t0).
      rewrite Nat_iter_S. cbn.
      pose proof (@midtape_left_midtape (finType_CS bool)). cbn in H. erewrite <- H.
      2: reflexivity. rewrite Nat_iter_S'. rewrite length_encode_sym. reflexivity.
    + enough (forall c rs, Nat.iter n (fun t : tape bool  => tape_move_right t) (rightof c rs) = rightof c rs) as -> by reflexivity.
      intros. clear. induction  n; cbn. reflexivity. rewrite Nat_iter_S', IHn. reflexivity.
    + now rewrite Nat_iter_id.
  - TMSimp. destruct_tapes. TMSimp. rename l into rs, l0 into ls.
    rewrite <- !Nat_iter_S' with (f := fun t0 => tape_move t0 m).
    destruct m.
    + cbn. destruct rs.
      * cbn. rewrite Nat_iter_S. cbn. now rewrite Eleft.
      * cbn. pose proof (@midtape_left_midtape (finType_CS bool)). cbn in H.
        rewrite encode_string_app, rev_app_distr. cbn. rewrite rev_app_distr. cbn.
        rewrite Nat_iter_S. cbn. rewrite <- app_assoc.
        erewrite <- H. 2:reflexivity. rewrite length_encode_sym. reflexivity.
    + cbn. destruct ls.
      * cbn.
        pose proof (@midtape_right_rightof (finType_CS bool)). cbn in H.
        rewrite H. 2:now rewrite length_encode_sym. reflexivity.
      * cbn. rewrite Nat_iter_S'.
        pose proof (@midtape_right_midtape (finType_CS bool)). cbn in H.
        rewrite H. cbn. rewrite encode_string_app. cbn. rewrite !rev_app_distr. cbn.
        rewrite rev_app_distr. cbn. rewrite <- app_assoc. cbn. reflexivity.
        now rewrite length_encode_sym.
    + cbn. rewrite Nat_iter_id. reflexivity.
Qed.

Lemma TestLeftof_total {Σ} :
  isTotal (@TestLeftof Σ).
Proof.
  unfold TestLeftof.
  eexists. eapply TerminatesIn_monotone.
  TM_Correct. intros ? ? ?. repeat eexists; help.
  destruct current; help.
  repeat eexists. help. help. help. instantiate (1 := ltac:(destruct x; refine _)). cbn. eapply le_plus_l.
  help. destruct current. help. help.
  Unshelve. all: try destruct x; cbn.
  4:{ eapply H. } all:exact 0.
Qed.

Lemma MoveB_total (n : nat) :
  exists c, forall m, projT1 (MoveB m n) ↓ fun t k => c <= k.
Proof.
  destruct (@TestLeftof_total (finType_CS bool)) as [c Hlo].
  destruct (@MoveM_isTotal (finType_CS bool) Lmove n) as [c1 H1].
  destruct (@MoveM_isTotal (finType_CS bool) Nmove n) as [c2 H2].
  destruct (@MoveM_isTotal (finType_CS bool) Rmove n) as [c3 H3].

  eexists. intros m. eapply TerminatesIn_monotone.
  unfold MoveB.
  eapply Switch_TerminatesIn.
  TM_Correct. eapply TestLeftof_Realise. eapply Hlo.
  intros f. instantiate (1 := fun f => if f then _ else _). cbn.
  destruct f.
  - destruct m. instantiate (1 := ltac:(destruct m, f; refine _)). all: cbn.
    eapply Seq_TerminatesIn. TM_Correct. eapply MoveM_Realise. TM_Correct.
    eapply MoveM_Realise. TM_Correct. TM_Correct.
    TM_Correct. eapply MoveM_Realise. eapply MoveM_Realise.
  - instantiate (1 := ltac:(destruct f; refine _)); cbn.
    TM_Correct. eapply MoveM_Realise. eapply MoveM_Realise.
    destruct m. instantiate (1 := ltac:(destruct m; refine _)); cbn. all: cbn.
    all:eassumption.
  - cbn. intros ? ? ?. repeat eexists; help.
    TMSimp. destruct_tapes. TMSimp.
    rename tout_0 into h. destruct h; TMSimp. repeat eexists; help. destruct m.
    instantiate (1:= ltac:(destruct m; refine _)); cbn. all:cbn.
    all:help.
    destruct m. instantiate (1:= ltac:(destruct m; refine _)); cbn. all:cbn.

    repeat eexists; help. lia.
    repeat eexists; help.
    repeat eexists. destruct m. instantiate (1:= ltac:(destruct m; refine _)); cbn. all:cbn.
    all:help.
    repeat eexists. destruct m. instantiate (1:= ltac:(destruct m; refine _)); cbn. all:cbn.
    all:help.
    Unshelve. all: try destruct x; cbn in *.
      all: try destruct x; cbn in *.
      all:try destruct m; cbn in *.
      17:{ eapply H. }
      16:{
      instantiate (6 := c1).
      instantiate (6 := c3) in H. ring_simplify in H.
      ring_simplify.
      replace (c + c1 + c3) with (c + c3 + c1) by lia. eapply H. }
      14:{ring_simplify. ring_simplify in H.
      instantiate (6 := c3). instantiate (5 := c1).
      instantiate (5 := c2) in H.
      replace (c + c3 + c2 + c1) with (c + c3 + c1 + c2) by lia. eapply H. }
      all:try exact 0. all: try lia. all: exact (fun _ _ => True).
Qed.

Section FixM.

  Variable Σ : finType.

  Let n := (projT1 (finite_n Σ)).
  Let f := (projT1 (projT2 (finite_n Σ))).
  Let g := (proj1_sig (projT2 (projT2 (finite_n Σ)))).
  Let Hf := (proj1 (proj2_sig (projT2 (projT2 (finite_n Σ))))).
  Let Hg := (proj2 (proj2_sig (projT2 (projT2 (finite_n Σ))))).

  Instance R : Retract (Fin.t n) Σ.
  Proof.
    eapply (@Build_Retract _ _ g (fun x => Some (f x ))).
    econstructor.
    - intros [= <-]; now rewrite Hg.
    - intros ->; now rewrite Hf.
  Qed.

  Definition encode_tape' (t : tape Σ) : tape bool := encode_tape (mapTape f t).

  Lemma ReadB_Realise' :
    ReadB n ⊨ fun t '(l, t') => forall t_sig : tape Σ, t = [| encode_tape' t_sig |] -> t' = t /\ l = map_opt f (current t_sig).
  Proof.
    eapply Realise_monotone. eapply ReadB_Realise.
    intros t (?, t') ? t_sig ->. destruct_tapes. cbn in *.
    specialize (H (mapTape f t_sig) eq_refl) as [[= ->] ->].
    split. eauto. eapply mapTape_current.
  Qed.

  Lemma WriteB_Realise' (c : option Σ) :
    WriteB (map_opt f c) ⊨ fun t '(_, t') => forall t_sig, t = [| encode_tape' t_sig |] -> t' = [| encode_tape' (wr c t_sig) |].
  Proof.
    eapply Realise_monotone. eapply WriteB_Realise.
    intros t (?, t') ? t_sig ->. destruct_tapes. cbn in *.
    specialize (H (mapTape f t_sig) eq_refl) as [= ->].
    unfold tape_write. destruct c.
    - cbn. destruct t_sig; reflexivity.
    - reflexivity.
  Qed.

  Lemma MoveB_Realise' m :
    MoveB m n ⊨ fun t '(l, t') => forall t_sig, t = [| encode_tape' t_sig |] -> t' = [| encode_tape' (mv m t_sig) |].
  Proof.
    eapply Realise_monotone. eapply MoveB_Realise.
    intros t (?, t') ? t_sig ->. destruct_tapes. cbn in *.
    specialize (H (mapTape f t_sig) eq_refl) as [= ->].
    f_equal. destruct t_sig, m; try reflexivity.
    cbn. destruct l; cbn; reflexivity.
    cbn. destruct l0; cbn; reflexivity.
  Qed.

  Variable M : TM Σ 1.

  Definition Step (q : state M) : pTM (finType_CS bool) (state M + state M) 1 :=
        Switch (ReadB n) (fun c_i => if halt q then Return Nop (inr q)
                                     else let '(q', e) := trans M (q, [| map_opt g c_i |]) in
                                          let '(existT _ (c', m) _) := destruct_vector_cons e in
                                          WriteB (map_opt f c') ;; MoveB m n ;; Return Nop (inl q')).

  Smpl Add (eapply ReadB_Realise') : TM_Correct.
  Smpl Add (eapply WriteB_Realise') : TM_Correct.
  Smpl Add (eapply MoveB_Realise') : TM_Correct.

  Lemma Step_Realise q :
    Step q ⊨ fun t '(q_, t') =>
      forall t_sig, t = [| encode_tape' t_sig |] ->
      if halt q then q_ = inr q /\ t' = t
                else let '(q', a) := trans M (q, [| current t_sig |]) in
                     let '(existT _ (c', m) _) := destruct_vector_cons a in
                     q_ = inl q' /\ t' = [| encode_tape' (mv m (wr c' t_sig)) |].
  Proof.
    eapply Realise_monotone.

    {
      unfold Step. eapply Switch_Realise. TM_Correct. cbn.
      intros c_i. instantiate (1 := fun c_i => _). cbn. instantiate (1 := ltac:(destruct (halt q); refine _)).
      destruct (halt q). cbn.
      TM_Correct.
      instantiate (1 := ltac:(destruct (trans (q, [|map_opt g c_i|])); refine _)). cbn.
      destruct (trans (q, [|map_opt g c_i|])).
      instantiate (1 := ltac:(destruct (destruct_vector_cons t); refine _)). cbn.
      destruct (destruct_vector_cons t). cbn.
      instantiate (1 := ltac:(destruct x; refine _)). cbn.
      destruct x. TM_Correct.
    }

    intros t (q_, t') ? t_sig ->. TMSimp.
    rename t'_0 into t'.
    destruct (halt q) eqn:Eq.
    - TMSimp. split. reflexivity. eapply H. reflexivity.
    - specialize (H _ eq_refl) as [[= ->] ->]. cbn in *.
      assert (Efg : forall o, map_opt g (map_opt f o) = o). { intros [s | ]; cbn; now rewrite ?Hg.  }
      rewrite Efg in H0. clear Efg.
      destruct trans as [q' T] eqn:Eqt.
      destruct destruct_vector_cons as [[m c'] [nl ->]].
      TMSimp. destruct_vector. split. reflexivity.
      now eapply H0, H.
  Qed.

  Lemma WriteB_total'  :
    exists C, forall (c : option (Fin.t n)), projT1 (WriteB c) ↓ fun t k => k >= C.
  Proof.
    eapply fintype_forall_exists; cbn.
    - intros. eapply TerminatesIn_monotone. eassumption.
      intros ? ? ?. lia.
    - eapply WriteB_TerminatesIn.
  Qed.

  Lemma Step_total q :
    isTotal (Step q).
  Proof.
    destruct (MoveB_total n).
    destruct (ReadB_total n).
    destruct (WriteB_total').
    eexists. eapply TerminatesIn_monotone.
    - unfold Step. eapply Switch_TerminatesIn.
      TM_Correct.  cbn in *. eapply H0. cbn.
      intros c_i. instantiate (1 := ltac:(intros c_i; refine _)); cbn.
        instantiate (1 := ltac:(destruct (halt q); refine _)); cbn.
        destruct halt.
        TM_Correct.
        instantiate (1 := ltac:(destruct (trans (q, [| map_opt g c_i |])),
        (destruct_vector_cons t),
        x2 ; refine _)); cbn.

        destruct (trans (q, [| map_opt g c_i |])); cbn.
        destruct (destruct_vector_cons t); cbn.
        destruct x2. TM_Correct. eapply H1. eapply H.
    - cbn. intros ? ? ?. repeat eexists; help.
      instantiate (1 := ltac:(destruct (halt q); refine _)); cbn.
      destruct halt. lia. rename yout into c_i.
      destruct (trans (q, [| map_opt g c_i |])); cbn.
      destruct (destruct_vector_cons t); cbn.
      instantiate (1 := ltac:(destruct x2; refine _)).
      destruct x2. TM_Correct.
      repeat eexists.
      eapply le_plus_l. eapply le_plus_l. eapply le_plus_l.
      eapply le_plus_l. intros. eapply le_plus_l.
    Unshelve. all:cbn.
    all: try destruct x2; cbn in *.
    3:{ destruct halt. cbn. eapply H2. eapply H2. }
    all:exact 0.
    Unshelve. all:exact 0.
  Qed.

  Lemma Step_total' :
    exists C, forall q, projT1 (Step q) ↓ fun t k => C <= k.
  Proof.
    eapply fintype_forall_exists.
    - intros. eapply TerminatesIn_monotone. eassumption. intros ? ?. lia.
    - intros q. eapply Step_total.
  Qed.

  Theorem WhileStep_Realise :
    StateWhile Step (start M) ⊨
      fun t '(q', t') => forall t_sig, t = [| encode_tape' t_sig |] -> exists t_sig', eval M (start M) [| t_sig |] q' [| t_sig' |] /\ t' = [| encode_tape' t_sig'|].
  Proof.
    generalize (start M). intros q.

    eapply Realise_monotone.
    {
      TM_Correct. eapply Step_Realise.
    }

    intros t (l, t') ? t_sig E.
    TMSimp. destruct_tapes. rename t'_0 into t'.
    remember ([|encode_tape' t_sig|]) as tin.
    remember (l, [|t'|]) as cout.
    induction H in t_sig, l, t', Heqtin, Heqcout |- *.
    - TMSimp. destruct_tapes. specialize (H _ eq_refl).
      rename l0 into q. destruct (halt q) eqn:Eq.
      + inv Heqcout. destruct H as [[= ->] [= ->]].
      + inv Heqcout. destruct trans as [q' T] eqn:Eqt.
        destruct destruct_vector_cons as [[m c'] [nl ->]].
        destruct_vector. destruct H as [[= ->] [= ->]].
        specialize (IHStateWhile_Rel _ _ _ eq_refl eq_refl) as [t_sig' [H1 [= ->]]].
        exists t_sig'. split; try reflexivity.
        econstructor. eassumption. eassumption. cbn. eassumption.
    - inv Heqcout. specialize (H _ eq_refl).
      rename l0 into q. destruct (halt q) eqn:Eq.
      + destruct H as [[= ->] [= ->]]. eexists; split; try reflexivity.
        now econstructor.
      + destruct trans as [q' T] eqn:Eqt.
        destruct destruct_vector_cons as [[m c'] [nl ->]].
        destruct_vector. destruct H as [[= ->] [= ->]].
  Qed.

  Theorem WhileStep_Terminates :
   exists C1 C2,
    projT1 (StateWhile Step (start M)) ↓ fun t k =>
            exists t_sig, t = [| encode_tape' t_sig |] /\
            exists k' t_sig' q', loopM (initc M [| t_sig |]) k' = Some (mk_mconfig q' [| t_sig' |] ) /\
             k >= C1 * k' + C2.
  Proof.
    unfold initc.
    generalize (start M). intros q.
    destruct (Step_total') as [C HC].
    eexists. eexists.

    eapply TerminatesIn_monotone.

    {
      eapply StateWhile_TerminatesIn. intros. eapply Step_Realise. intros. eapply HC.
    }

    revert q. eapply StateWhileCoInduction.
    intros q tin k H. TMSimp.
    rename ymid0 into steps, ymid into t_sig, ymid1 into t_sig', ymid2 into q'.
    remember [|t_sig|] as tin. remember [|t_sig'|] as tout.
    rename H0 into H. rename H1 into H0.
    induction steps in tin, t_sig, Heqtin, q, H0, H |- *.
    - cbn in H. unfold haltConf in H. cbn in *.
      destruct (halt q) eqn:Eq; cbn.
      + inv H. eexists. split. eapply le_plus_l.
        intros. destruct_tapes. specialize (H _ eq_refl) as [[= ->] [= ->]].
        ring_simplify in H0. shelve.
      + inv H.
    - cbn in H. unfold haltConf in H. cbn in *.
      destruct (halt q) eqn:Eq; cbn.
      + inv H. eexists. split. eapply le_plus_l.
        intros. destruct_tapes. specialize (H _ eq_refl) as [[= ->] [= ->]].
        ring_simplify in H0. shelve.
      + subst. unfold step in H. cbn in *.
        unfold current_chars in *. cbn in *.
        destruct trans as (qnxt, A) eqn:Et. cbn in *.
        destruct (destruct_vector_cons A) eqn:E2.
        destruct x as (c', m) eqn:E3. destruct s as [? ->].
        destruct_vector.
        cbn in *. pose proof (Hrem := H).
        eapply IHsteps in H. eexists. split.
        eapply le_plus_l.
        intros. specialize (H1 _ eq_refl).
        rewrite Et in H1. rewrite E2 in H1. destruct H1. subst.
        repeat eexists. rewrite <- Hrem. repeat f_equal. now destruct t_sig, m, c'.
        shelve. shelve. reflexivity. shelve.
  Unshelve.
    exact (1 + C). exact (2 + 2 * C). exact 0.
    2: exact 0. 3: exact 0. 3: (exact ((2 + steps) * S C)).
    all:lia.
  Qed.

End FixM.

Lemma Sim_Realise {Σ} (L : finType) (M : pTM Σ L 1) R :
  M ⊨ R ->
  Relabel (StateWhile (@Step Σ (projT1 M)) (start (projT1 M))) (projT2 M) ⊨
    fun t '(l, t') => forall t_sig, t = [| encode_tape' t_sig |] ->
                      exists t_sig', R [| t_sig |] (l, [| t_sig' |]) /\ t' = [| encode_tape' t_sig' |].
Proof.
  intros HM.
  eapply Realise_monotone. { eapply Relabel_Realise, WhileStep_Realise. }
  intros ? ? ?. TMSimp. specialize (H0 _ eq_refl). TMSimp.
  repeat eexists. unfold Realise in HM.
  eapply TM_eval_iff in H as [k H].
  now eapply HM in H.
Qed.
Lemma Sim_Terminates {Σ} (L : finType) (M : pTM Σ L 1) T :
  projT1 M ↓ T ->
  exists C1 C2,
  projT1 (Relabel (StateWhile (@Step Σ (projT1 M)) (start (projT1 M))) (projT2 M)) ↓
    fun t k => exists t_sig k', t = [| encode_tape' t_sig |] /\ T [| t_sig |] k' /\ k >= C1 * k' + C2.
Proof.
  intros HM.
  destruct (WhileStep_Terminates (projT1 M)) as (C1 & C2 & HC).
  exists C1, C2.
  eapply TerminatesIn_monotone. { eapply Relabel_Terminates, HC. }
  intros ? ? ?. TMSimp.
  eapply HM in H0. TMSimp.
  destruct ymid1. destruct_tapes. repeat eexists; eassumption.
Qed.

Require Import Undecidability.Synthetic.Definitions.
Require Import Undecidability.Synthetic.ReducibilityFacts Undecidability.TM.Util.TM_facts.

Theorem reduction :
  HaltTM 1 ⪯ fun '(M,t) => @HaltsTM (finType_CS bool) 1 M t.
Proof.
  unshelve eexists.
  - intros [Σ M t]. split. exact (projT1 (StateWhile (@Step Σ M) (start M))).
    exact (Vector.map (fun t => encode_tape' t) t).
  - intros [Σ M t]. cbn. split.
    + intros (q' & t' & [n H] % TM_eval_iff).
      edestruct @Sim_Terminates with (M := (existT _ M (fun _ : state M => tt))) (T := fun tin k => tin = t /\ k >= n).
      * intros tin k [-> Hk]. cbn. exists (mk_mconfig q' t').  eapply @loop_monotone. exact H. eapply Hk.
      * destruct H0 as [k H0]. cbn in H0. edestruct H0 as [[] H1].
        -- exists (Vector.hd t), n. split. reflexivity. split. 2: now unfold ge. split. 2:lia.
           apply (Vector.caseS' t). intros ?.
           apply (Vector.case0). reflexivity.
        -- exists cstate. eexists ctapes. eapply TM_eval_iff. exists (x * n + k). unfold Relabel, initc in H1. cbn in H1.
           revert H1. apply (Vector.caseS' t). intros ?. cbn.
           intros t0. pattern t0. apply Vector.case0.
           intros H1. exact H1.
    + intros (q' & t' & [n H] % TM_eval_iff).
      eapply (Sim_Realise (M := (existT _ M (fun _ : state M => tt))) (R := fun tin '(_,tout) => exists q', eval M (start M) tin q' tout)) in H.
      * revert H. apply (Vector.caseS' t). intros ?. cbn.
        intros t0. pattern t0. apply Vector.case0.
        clear t. rename h into t. intros H.
        specialize (H t eq_refl) as [t'_sig [[q'_ H1] H2]]. cbn in H1.
        cbn in H2. subst. exists q'_, [|t'_sig|]. eassumption.
      * intros tin k [q'_ tout] Hter. cbn in *. exists q'_. eapply TM_eval_iff. exists k. exact Hter.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma lem2: forall l n, Cons n (rev l) = rev (append l (Cons n Nil)).
Proof.
intros. induction l.
  - simpl. rewrite <- IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem: forall l, rev (rev l) = l.
Proof.
induction l.
  - simpl. rewrite <- lem2. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (rev (append x y))) (append (rev (rev x)) (rev (rev y))).
Proof.
  intros. rewrite lem.
  rewrite lem.
 lfind. Admitted.


Require Import Bool Arith List Omega.
Require Import Recdef Morphisms.
Require Import Program.Tactics.
Require Import Relation_Operators.
Require FMapList.
Require FMapFacts.
Require Import Classical.
Require Import Coq.Classes.RelationClasses.
Require Import OrderedType OrderedTypeEx DecidableType.
Require Import Sorting.Permutation.
Import ListNotations.

(** * Process isolation

This problem set contains a model of a multi-process
operating system with a single ramdisk. You show that process
isolation holds across system calls.

The problem set has two purposes. First, it shows one way to model
a real system -- it’s much more like seL4 than like mergesort.
Second, we delve deeper into the standard library. Most large Coq
developments use complex data structures like finite maps; we do
too. *)

(** ** Memory

A _memory_ is a partial function from addresses to “byte” values (we use
[nat] because why not). An address is a [nat]; a value is an [option nat],
where [None] indicates unmapped memory. We use the [memory] type to
represent both process memory and the ramdisk. *)

Section Memory.

  (** We represent a memory as a function. *)
  Definition memory : Set := nat -> option nat.

  Implicit Types m : memory.
  Implicit Types addr len : nat.
  Implicit Types vs : list nat.

  (** The empty memory *)
  Definition memnil : memory :=
    fun a => None.

  (** Returns [True] iff the [len] addresses starting at [addr] are all
      mapped. *)
  Definition memmapped m addr len : Prop :=
    forall i, i < len -> m (addr + i) <> None.

  (** These functions create a new memory based on [m]. *)

  (** Add new values [vs] to [m], starting at [addr]. *)
  Definition memmap m addr vs : memory :=
    fun a =>
      if (addr <=? a) && (a <? addr + length vs)
      then nth_error vs (a - addr)
      else m a.

  (** Remove the addresses from [addr] to [addr + len - 1] in [m]. *)
  Definition memunmap m addr len : memory :=
    fun a =>
      if (addr <=? a) && (a <? addr + len)
      then None
      else m a.

  (** This function returns a [list] containing the [len] bytes starting
      at [addr] in [m].  If _any_ of the bytes are unmapped, it should
      return [None]. *)
  Fixpoint memrange m addr len : option (list nat) :=
    (* YOUR CODE HERE *)
    None.

  (* Test out your code with some [Example]s! *)
End Memory.

(** As always, we need a few more facts about lists. *)

Section ListFacts.
  Context {A:Type}.
  Implicit Types l:list A.

  Lemma filter_app (f:A -> bool) l1 l2:
    filter f (l1 ++ l2) = filter f l1 ++ filter f l2.
  Proof.
    (* YOUR CODE HERE *)
  Admitted.

  Lemma Forall_app (P:A -> Prop) l1 l2:
    Forall P (l1 ++ l2) <-> Forall P l1 /\ Forall P l2.
  Proof.
    (* YOUR CODE HERE *)
  Admitted.
End ListFacts.

(** ** Process definitions

Main definitions:

- [process]: The internal configuration of a process, including
  its memory, its current execution mode, and what system call
  it’s executing (if any).

- [event]: A history variable that records execution steps for
  proofs.

- [procview]: A process’s view of the system. Comprises a
  [process], the kernel’s ramdisk, and a trace (a list of
  [event]s).

- [procstep1]: The transition relation for [procview]s. *)

Section Process.

  (** A [process] is computing on its current memory ([PComp]),
      blocked in a system call ([PSys]), or dead ([PDead]).
      The system-call constructor [PSys] also specifies the system
      call name and arguments. Not all arguments are used for all
      system calls. *)

  Inductive syscall : Set := Map | Unmap | Read | Write | Kill.

  Inductive process : Set :=
  | PComp: forall (pm:memory), process
  | PSys: forall (pm:memory) (sysc:syscall) (addr len offset:nat), process
  | PDead.

  Inductive event : Set :=
  | EC (* Computation event *)
  | ES (* system call Start event *)
  | ER (* system call Return event *)
  | EK (* system call in-Kernel event *)
  | EKW: forall (offset len:nat), event
       (* system call in-Kernel Write event: records what offsets written *)
  | ED. (* Die event *)

  (** Is event [e] not a write? *)
  Definition event_nonwrite e : Prop :=
    match e with
    | EKW _ _ => False
    | _ => True
    end.

  (** Is event [e] not an in-kernel event? *)
  Definition event_nonkernel e : Prop :=
    match e with
    | EK => False
    | EKW _ _ => False
    | _ => True
    end.

  Inductive procview : Set :=
  | PS: forall (p:process) (km:memory) (tr:list event), procview.

  (** The [procstep1 : procview -> procview -> Prop] relation
      determines how the OS works. The basic ideas are that processes
      alternate between computing and system calls, and that system
      calls execute one byte at a time.

      - [PS_compute]: A computing process can change its memory (but
        it can only change memory that is already mapped).
      - [PS_syscall]: A computing process can make a new system call.
      - [PS_sysdone]: When a system call is done, the process starts
        computing again.
      - [PS_kill]: A process can be killed at any time.

      Then there are four constructors to execute the four system
      calls. The system calls take the same arguments: [addr] is an
      address in the process’s memory, [len] is a number of bytes,
      and [offset] (not always used) is an offset into the ramdisk.

      - [Map addr len]: Like malloc or mmap: adds [len] bytes to this
        process’s address space. The new bytes are zeroed out.
      - [Unmap addr len]: Like munmap: removes [len] bytes from this
        process’s address space.
      - [Read addr len offset]: Reads [len] bytes from the ramdisk
        starting at [offset].
      - [Write addr len offset]: Writes [len] bytes to the ramdisk
        starting at [offset].

      The [Read] and [Write] system calls require that the relevant
      part of the process’s memory is mapped.

      Each step records its function in the [procview]’s [tr] trace
      history variable. *)

  Inductive procstep1 : relation procview :=
  | PS_compute: forall pm km tr addr vs,
      memmapped pm addr (length vs) ->
      procstep1 (PS (PComp pm) km tr)
                (PS (PComp (memmap pm addr vs)) km (tr ++ [EC]))
  | PS_syscall: forall pm km tr sysc addr len offset,
      procstep1 (PS (PComp pm) km tr)
                (PS (PSys pm sysc addr len offset) km (tr ++ [ES]))
  | PS_sysdone: forall pm km tr sysc addr offset,
      procstep1 (PS (PSys pm sysc addr 0 offset) km tr)
                (PS (PComp pm) km (tr ++ [ER]))
  | PS_map: forall pm km tr addr len offset,
      procstep1 (PS (PSys pm Map addr (S len) offset) km tr)
                (PS (PSys (memmap pm addr [0]) Map (S addr) len (S offset))
                    km (tr ++ [EK]))
  | PS_unmap: forall pm km tr addr len offset,
      procstep1 (PS (PSys pm Unmap addr (S len) offset) km tr)
                (PS (PSys (memunmap pm addr 1) Unmap (S addr) len (S offset))
                    km (tr ++ [EK]))
  | PS_read: forall pm km tr addr len offset v,
      km offset = Some v ->
      procstep1 (PS (PSys pm Read addr (S len) offset) km tr)
                (PS (PSys (memmap pm addr [v]) Read (S addr) len (S offset))
                    km (tr ++ [EK]))
  | PS_write: forall pm km tr addr len offset v,
      pm addr = Some v ->
      memmapped km offset 1 ->
      procstep1 (PS (PSys pm Write addr (S len) offset) km tr)
                (PS (PSys pm Write (S addr) len (S offset))
                    (memmap km offset [v]) (tr ++ [EKW offset 1]))
  | PS_kill: forall p km tr,
      procstep1 (PS p km tr)
                (PS PDead km (tr ++ [ED])).

  (** [procsteps : procview -> procview -> Prop] is the reflexive,
      transitive closure of [procstep1]. So [procsteps a b] holds if
      there is some chain [a0, a1, a2, ..., an] of zero or more steps,
      so that [a0 = a], [an = b], and
      [forall i, i < n -> procstep1 ai a{i+1}].

      [clos_refl_trans_n1] is defined in Coq’s standard library. *)

  Definition procsteps := clos_refl_trans_n1 procview procstep1.

End Process.

(** ** Finite maps

We now examine Coq’s [FMap] module, which defines a dictionary-like data type.

[FMap] functions are defined in the [FMapInterface] module, which also has
many lemmas. Many other lemmas are defined in [FMapFacts].

[FMap]s are instantiated in three steps. First, we choose an underlying
representation, such as an AVL tree. We, though, use sorted lists, via
the [FMapList] type, since they print nicer.

Second, we provide the type of keys, which must be an ordered type.
This gives us a new module specialized for a kind of key. For example:
<<
  Module NatMap := FMapList.Make Nat_as_OT.
>>
Now [NatMap] defines [FMap] types, functions, and lemmas specialized
for [nat] keys. ([Nat_as_OT] is defined in the Coq library.) We can refer
to those types, functions, and lemmas as [NatMap.whatever].

Finally, we provide the type of values, which can be anything.
<<
  Definition Map_from_nat_to_bool := NatMap.t bool.
  Definition an_empty_map := NatMap.empty bool.
>>
Now [Map_from_nat_to_bool] is a map type. Its representation is hidden,
meaning you can only access its contents via [FMap] functions and lemmas
(and things you build on top).

The most important [Map] accessors are as follows. In the below, [key]
is the map’s key type, [elt] is its value type, and [t elt] is the map
type. In arguments, [x] and [y] are keys, [e] and [e'] are values, and
[m] and [m'] are maps.

- [Map.empty elt] is an empty map storing [elt] values.
- [Map.add x e m: t elt] sets [x]’s value to [e] in [m]. Coq is functional,
  of course, so this involves making a copy of [m].
- [Map.find x m: option elt] returns [x]’s value in [m], if it exists.
- [Map.In x m: Prop] is [True] iff [x] has a value in [m].
- [Map.MapsTo x e m: Prop] is [True] iff [x]’s value in [m] is [e].

Three lemmas in [Map] show how [MapsTo] and [add] relate. [add_1] is about
the value of the added key, [add_2] and [add_3] are about other keys.
These lemmas are use [E.eq] to test keys for equality; for [nat]s, [E.eq]
is just [=].
<<
  Lemma Map.add_1 (x y:key) (e:elt) (m:t elt) :
     E.eq x y -> Map.MapsTo y e (Map.add x e m).
  Lemma Map.add_2 (x y:key) (e e':elt) (m:t elt) :
     ~ E.eq x y -> Map.MapsTo y e m -> Map.MapsTo y e (Map.add x e' m).
  Lemma Map.add_3 (x y:key) (e e':elt) (m:t elt) :
     ~ E.eq x y -> Map.MapsTo y e (Map.add x e' m) -> Map.MapsTo y e m.
>>

Then there are some useful lemmas in [MapFacts]. [add_mapsto_iff]
completely specifies the behavior of [Map.add]; it’s like a combination
of [add_1], [add_2], and [add_3].
<<
  Lemma MapFacts.add_mapsto_iff (m:t elt) (x y:key) (e e':elt) :
    Map.MapsTo y e' (Map.add x e m) <->
      (E.eq x y /\ e = e') \/
      (~ E.eq x y /\ Map.MapsTo y e' m).
>>

[MapsTo_fun] says that [MapsTo] is a (partial) function: if the
same key maps to two different values, then those values are equal.
<<
  Lemma MapFacts.MapsTo_fun (m:t elt) (x:key) (e e':elt) :
    Map.MapsTo x e m -> Map.MapsTo x e' m -> e = e'.
>>

And there are others, such as [add_in_iff].

*** The problem of equality

Maps (and other complicated data structures) force us to think more
carefully about equality. Intuitively, we think two maps are equal if
they contain the same elements. This is captured by the [Map.Equal]
relation:

<<
  Definition Map.Equal m m' := forall x, Map.find x m = Map.find x m'.
>>

Unfortunately, it is _not_ true that [Map.Equal m m' -> m = m'].
“Different” [Map]s, in terms of Leibniz equality (Coq’s primitive
equality), can have the same contents. For example, the [Map]s might
be balanced trees with different layouts. :(

This makes life more difficult! It’s very nice to use [rewrite]
tactics, and usually [rewrite] requires Leibniz equality.

To use [rewrite] on [Map]s, or data types containing [Map]s, we must
provide separate lemmas showing that rewriting in specific situations
is OK. We’ll see some such lemmas below. But the Coq library already
provides many of these lemmas for [Map] operations, so this proof
works:

<<
  Lemma MapsTo_Equal x e m m':
    Map.Equal m m' ->
    Map.MapsTo x e m ->
    Map.MapsTo x e m'.

    intros EQ H. now rewrite <- EQ.
  Qed.
>>

The [rewrite] succeeds because the Coq library has proved that
[Equal] [Map]s can be substituted inside a [MapsTo]’s arguments.

A useful fact about [Equal]:

<<
  Lemma MapFacts.Equal_mapsto_iff m m':
    Equal m m' <-> (forall x e, MapsTo x e m <-> MapsTo x e m').
>>

*** Your work

Get started by proving some useful facts about [Map]s in general. We
start a new module for these facts, called [WXFacts_fun].

*)

Module WXFacts_fun (E:DecidableType) (Import Map:FMapInterface.WSfun E).
Module MapFacts := FMapFacts.WFacts_fun E Map.
Section XFacts.
  Notation eq_dec := E.eq_dec.
  Variable elt: Type.
  Implicit Types m: t elt.
  Implicit Types x y z: key.
  Implicit Types e: elt.

  (** A map doesn’t change if you [add] the same element to it. *)
  Lemma add_same_Equal: forall m x e,
      MapsTo x e m ->
      Equal m (add x e m).
  Proof.
    intros; rewrite MapFacts.Equal_mapsto_iff; split; intros.
    - destruct (eq_dec x k); subst.
      + rewrite <- e1 in H0.
        rewrite (MapFacts.MapsTo_fun H H0).
        now eapply Map.add_1.
      + now eapply Map.add_2.
    - rewrite MapFacts.add_mapsto_iff in H0;
        destruct H0; destruct_conjs.
      + rewrite <- H0; now rewrite <- H1.
      + auto.
  Qed.

  (** Now you prove this: [add]ing an element overrides the previous
      element at that key. *)
  Lemma add_redundant_Equal: forall m x e e',
      Equal (add x e m) (add x e (add x e' m)).
  Proof.
    (* YOUR CODE HERE *)
  Admitted.
End XFacts.
End WXFacts_fun.

(** Our [Map]s have [nat] as keys. We instantiate the three useful modules:
    the [Map] itself, its [Facts], and its [XFacts] (that we just wrote). *)
Module NatMap := FMapList.Make Nat_as_OT.
Module NatMapFacts := FMapFacts.WFacts_fun Nat_as_OT NatMap.
Module NatMapXFacts := WXFacts_fun Nat_as_OT NatMap.

(** ** Operating system view

An [osview] is the analogy to [procview], but for the whole operating system,
not just a single process. An [osview] contains a [NatMap] of [process]es,
mapped by process ID; a ramdisk; and a trace history variable, where this time
each trace element is a pair of process ID and event.

Since [osview]s contain [Map]s, Leibniz equality isn’t the right notion of
equality. We provide our own equality definition, prove that it is reflexive,
symmetric, and transitive, and finally show that it is an equivalence relation,
allowing it to be used by tactics like [reflexivity], [symmetry], and
[transitivity]. *)

Section OSView.

  Definition processes := NatMap.t process.

  Definition trace := list (nat * event).

  Inductive osview :=
  | OS: forall (ps:processes) (km:memory) (tr:trace), osview.

  Definition osv_ps os := match os with OS ps _ _ => ps end.
  Definition osv_km os := match os with OS _ km _ => km end.
  Definition osv_tr os := match os with OS _ _ tr => tr end.

  Definition osv_equal os1 os2 :=
    match os1, os2 with
    | OS ps1 km1 tr1, OS ps2 km2 tr2 =>
      NatMap.Equal ps1 ps2 /\ km1 = km2 /\ tr1 = tr2
    end.

  Global Instance osv_equal_refl : Reflexive osv_equal.
    intro os1. (* unpack the [Reflexive] definition *)
    destruct os1; simpl; intuition.
  Qed.

  Global Instance osv_equal_sym : Symmetric osv_equal.
    intros os1 os2.
    destruct os1, os2; simpl; intuition.
  Qed.

  Global Instance osv_equal_trans : Transitive osv_equal.
    intros os1 os2 os3.
    destruct os1, os2, os3; simpl; intros; destruct_conjs; repeat split.
    - now transitivity ps0.
    - now subst.
    - now subst.
  Qed.

  Global Instance : Equivalence osv_equal.
    split;
    [ apply osv_equal_refl | apply osv_equal_sym | apply osv_equal_trans ].
  Qed.

End OSView.

(** ** Trace facts

Some helper functions and lemmas about traces. *)

Section TraceFacts.
  Implicit Types tr:trace.
  Implicit Types pid:nat.

  (** Returns a trace that _only_ contains events from process [pid]. *)
  Definition trace_filter_pid pid tr : trace :=
    filter (fun pr => fst pr =? pid) tr.

  (** Returns a trace that _strips out_ events from process [pid]. *)
  Definition trace_remove_pid pid tr : trace :=
    filter (fun pr => negb (fst pr =? pid)) tr.

  (** [True] iff none of the events in [tr] are kernel writes. *)
  Definition trace_nowrites tr : Prop :=
    Forall event_nonwrite (map snd tr).

  Lemma trace_filter_pid_app pid tr1 tr2:
    trace_filter_pid pid (tr1 ++ tr2) =
    trace_filter_pid pid tr1 ++ trace_filter_pid pid tr2.
  Proof.
    (* YOUR CODE HERE -- remember ListFacts above! *)
  Admitted.

  Lemma trace_remove_pid_app pid tr1 tr2:
    trace_remove_pid pid (tr1 ++ tr2) =
    trace_remove_pid pid tr1 ++ trace_remove_pid pid tr2.
  Proof.
    (* YOUR CODE HERE *)
  Admitted.

  Lemma trace_nowrites_app tr1 tr2:
    trace_nowrites (tr1 ++ tr2) <-> trace_nowrites tr1 /\ trace_nowrites tr2.
  Proof.
    (* YOUR CODE HERE *)
  Admitted.

  (** These lemmas relate the [trace_filter_pid] and [trace_remove_pid]
      operations to [map]s over event lists. *)
  Lemma trace_filter_pid_map_eq pid es:
    trace_filter_pid pid (map (pair pid) es) = map (pair pid) es.
  Proof.
    (* YOUR CODE HERE *)
  Admitted.

  Lemma trace_filter_pid_map_neq pid pid':
    pid <> pid' ->
    forall es, trace_filter_pid pid (map (pair pid') es) = [].
  Proof.
    (* YOUR CODE HERE *)
  Admitted.

  Lemma trace_remove_pid_map_neq pid pid':
    pid <> pid' ->
    forall es, trace_remove_pid pid (map (pair pid') es) = map (pair pid') es.
  Proof.
    (* YOUR CODE HERE *)
  Admitted.

End TraceFacts.

(** ** Operating system step relation

We are now ready to state the [osstep1 : osview -> osview -> Prop]
step relation: the OS as a whole takes a step when one of its component
processes takes a step. And we define [ossteps], which is the reflexive,
transitive closure of [osstep1].

Issues involving equality affect both of these definitions. In [OS_step],
we don’t require that the new OS contain _exactly_ [NatMap.add pid p' ps];
instead, we require that it contain some _equivalent_ process map.
Similarly, the [os_refl] rule applies to _equivalent_ OSs, not merely
_equal_ ones. *)

Section OSStep.

  Inductive osstep1 : relation osview :=
  | OS_step : forall ps km tr ps' km' tr' pid p p',
      NatMap.MapsTo pid p ps ->
      procstep1 (PS p km []) (PS p' km' tr') ->
      NatMap.Equal ps' (NatMap.add pid p' ps) ->
      osstep1 (OS ps km tr)
              (OS ps' km' (tr ++ (map (pair pid) tr'))).

  Inductive ossteps : relation osview :=
  | os_refl: forall os1 os2,
      osv_equal os1 os2 ->
      ossteps os1 os2
  | os_trans: forall os1 os2 os3,
      ossteps os1 os2 ->
      osstep1 os2 os3 ->
      ossteps os1 os3.

End OSStep.

(** ** Rewriting for [osstep1] and [ossteps]

In this section you prove that [osstep1] and [ossteps] hold true up to
the [osv_equal] equivalence relation. This lets us show the [Proper]
instances that will let us [rewrite] the arguments of [osstep1] and
[ossteps]. *)

Section OSStepRewriting.

  Lemma osstep1_equal os1 os1' os2 os2':
    osv_equal os1 os1' ->
    osv_equal os2 os2' ->
    osstep1 os1 os2 ->
    osstep1 os1' os2'.
  Proof.
    (* YOUR CODE HERE *)
  Admitted.

  Global Instance: Proper (osv_equal ==> osv_equal ==> iff) osstep1.
  Proof.
    intros os1 os1' H1 os2 os2' H2.
    split; intros.
    - now apply osstep1_equal with (os1:=os1) (os2:=os2).
    - apply osstep1_equal with (os1:=os1') (os2:=os2'); intuition.
  Qed.

  Lemma ossteps_equal os1 os1' os2 os2':
    osv_equal os1 os1' ->
    osv_equal os2 os2' ->
    ossteps os1 os2 ->
    ossteps os1' os2'.
  Proof.
    (* YOUR CODE HERE *)
  Admitted.

  Global Instance: Proper (osv_equal ==> osv_equal ==> iff) ossteps.
  Proof.
    intros os1 os1' H1 os2 os2' H2.
    split; intros.
    - now apply ossteps_equal with (os1:=os1) (os2:=os2).
    - now apply ossteps_equal with (os1:=os1') (os2:=os2').
  Qed.

End OSStepRewriting.

(** ** Process isolation

You’re finally there: you’re going to prove two process isolation lemmas.

The first theorem, [process_isolation], says that if a process takes no steps
in some trace, then that process’s internal state remains unchanged.

The second theorem, [write_isolation], says that for processes only communicate
through [Write]s to the ramdisk. Specifically, we consider a trace in which
no process but [p] writes to the ramdisk. Given that trace, we show that
[p] could take the exact same steps, with the same results, in a different
trace where _no other process takes any steps at all_.

You can imagine many other theorems. For example, [read_isolation] would show
that if a process performs no [Read]s from the ramdisk, then it could take
the same steps in a different trace where no other process takes steps.
Or [reverse_write_isolation] would show that _adding_ non-write actions to a
trace containing [p] won’t affect [p]’s actions. *)

Section ProcessIsolation.

  (* Helper lemma: processes never disappear. *)
  Lemma ossteps_In_ps pid os1 os2:
    NatMap.In pid (osv_ps os1) ->
    ossteps os1 os2 ->
    NatMap.In pid (osv_ps os2).
  Proof.
    (* YOUR CODE HERE *)
  Admitted.

  Theorem process_isolation os1 os2 pid p:
    ossteps os1 os2 ->
    NatMap.MapsTo pid p (osv_ps os1) ->
    osv_tr os1 = [] ->
    ~ In pid (map fst (osv_tr os2)) ->
    NatMap.MapsTo pid p (osv_ps os2).
  Proof.
    (* YOUR CODE HERE *)
  Admitted.

  Theorem write_isolation os1 os2 pid p p':
    ossteps os1 os2 ->
    NatMap.MapsTo pid p (osv_ps os1) ->
    NatMap.MapsTo pid p' (osv_ps os2) ->
    osv_tr os1 = [] ->
    trace_nowrites (trace_remove_pid pid (osv_tr os2)) ->
    ossteps os1 (OS (NatMap.add pid p' (osv_ps os1))
                    (osv_km os2)
                    (trace_filter_pid pid (osv_tr os2))).
  Proof.
    (* YOUR CODE HERE *)
  Admitted.

End ProcessIsolation.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Theorem append_nil: forall (l: lst), append l Nil = l.
Proof.
   induction l.
   { simpl. f_equal. assumption. }
   { simpl. reflexivity. }
Qed.

Theorem append_assoc:
   forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
   induction l1; induction l2; induction l3; try (simpl; reflexivity).
   { simpl. rewrite <- IHl1. f_equal. }
   { simpl. rewrite 2 append_nil. reflexivity. }
   { simpl. rewrite append_nil.  reflexivity. }
   { simpl. rewrite 2 append_nil. reflexivity. }
Qed.

Theorem qreva_append : forall (x y : lst), (qreva x y) = (append (rev x) y).
Proof.
   induction x; induction y; simpl; try reflexivity.
   { rewrite IHx.
   rewrite <- append_assoc.
   f_equal. }
   { rewrite IHx.
   rewrite append_nil.
   reflexivity. }
Qed.

Theorem theorem0 : forall (x : lst), eq (rev x) (qreva x Nil).
Proof.
   intros.
lfind.
Admitted.


Require Export Elementary_Algebra.

Module Existence.

Axiom Axiom_Subsets : forall (x : Class),
  Ensemble x -> exists y, Ensemble y /\ (forall z, z ⊂ x -> z ∈ y).

Hint Resolve Axiom_Subsets : set.

Theorem sub_set x z :
  Ensemble x -> z ⊂ x -> Ensemble z.
Proof.
  move => x_ zx.
  case (Axiom_Subsets x x_) => [y [y_ H]].
  move : (H z zx) => {H} zy.
  Ens.
Qed.

Theorem universe_eleU :
  μ = ⊔ μ.
Proof.
  extent; rewrite !Axiom_Scheme.
  split => [[z_ _]|[z_ [y [zy y_]]]]; split => //.
  move : (Axiom_Subsets z z_) => [y [y_ Hy]].
  exists y; split.
  + by apply Hy.
  + by apply bel_universe_set.
Qed.

Theorem universe_eleI :
  Φ = ⊓ μ.
Proof.
  extent; rewrite !Axiom_Scheme.
  split => [[z_ F]|[z_ H]]; split => // _.
  apply (not_bel_zero z).
  apply (H Φ).
  apply bel_universe_set.
  apply sub_set with (x:=z) => //.
  move => x F.
  zero F.
Qed.

Hint Rewrite universe_eleI universe_eleU : set.

Lemma not_zero_exist_bel x :
  x <> Φ -> exists z, z ∈ x.
Proof.
  move => H.
  apply NNPP => F.
  apply H.
  move /not_ex_all_not : F => F.
  extent; split => [zx|zz].
  + case ((F z) zx).
  + zero zz.
Qed.

Theorem not_zero_set_eleI x :
  x <> Φ -> Ensemble (⊓ x).
Proof.
  move /not_zero_exist_bel => [z zx].
  case (bel_ele z x zx) => [L R].
  apply sub_set with (x := z); Ens.
Qed.

Hint Resolve not_zero_exist_bel not_zero_set_eleI : set.

Definition PowerClass x := {|λ y, y ⊂ x|}.
Notation "pow( x )" := (PowerClass x) (at level 0, right associativity).
Hint Unfold PowerClass : set.

Theorem bel_pow x y :
  Ensemble y -> x ⊂ y <-> x ∈ pow(y).
Proof.
  rewrite Axiom_Scheme => x_; split => [H |[L R]] => //.
  split => //; apply sub_set with (x:=y) => //.
Qed.

Theorem universe_pow :
  μ = pow(μ).
Proof.
  extent; rewrite !Axiom_Scheme.
  split => [[z_ _]|[z_ zu]]; split => //.
  move => x xz; rewrite bel_universe_set; Ens.
Qed.

Hint Rewrite universe_pow.

Lemma eleU_pow x :
  Ensemble x -> ⊔ pow(x) = x.
Proof.
  move => x_ ; extent; rewrite !Axiom_Scheme.
  split => [[z_ [y [zy yp]]]|zx].
  + apply Axiom_Scheme in yp.
    case yp => [y_ yx].
    by apply yx.
  + split; first by Ens.
    exists x; split => //.
    rewrite Axiom_Scheme; split => //.
Qed.

Lemma pow_zero :
  forall x, x ∈ pow(Φ) -> x = Φ.
Proof.
  move => x; rewrite Axiom_Scheme; case => [x_ xz].
  extent;split => [zx | F].
  + by apply xz.
  + zero F.
Qed.

Theorem pow_set x y :
  Ensemble x -> Ensemble pow(x) /\ (y ⊂ x <-> y ∈ pow(x)).
Proof.
  move => x_.
  move :(Axiom_Subsets x x_) => [z [z_ Hz]].
  split.
  + apply sub_set with (x:=z) => //.
    move => p; rewrite Axiom_Scheme; case => [p_ px].
    by apply Hz.
  + split => [yz | yP].
    - rewrite Axiom_Scheme; split => //.
      by apply sub_set with (x := x).
    - by move /Axiom_Scheme : yP => [y_ yx].
Qed.

Hint Resolve pow_set : set.

Definition R := {|λ x, ~ x ∈ x|}.

Lemma Russell_N :
  ~ Ensemble R.
Proof.
  case (classic ({|λ x, ~ x ∈ x|} ∈ {|λ x, ~ x ∈ x|})); rewrite Axiom_Scheme.
  + case => U_ HU F.
    apply HU.
    rewrite Axiom_Scheme; split => //.
  + move => H F; apply H.
    case /not_and_or : H => H //.
    split => //.
    move /NNPP : H => H.
    by move  /Axiom_Scheme : H => [_ H].
Qed.

Theorem universe_notset :
  ~ Ensemble μ.
Proof.
  move => F.
  apply Russell_N.
  apply sub_set with (x := μ) => //.
  apply sub_universe.
Qed.

Hint Resolve Russell_N universe_notset : set.

Definition Singleton x := {|λ z, Ensemble z -> z = x|}.
Notation "[ x ]" := (Singleton x) (at level 0, right associativity).
Hint Unfold Singleton : set.

Theorem set_bel_sing_eq x :
  Ensemble x -> (forall y, y ∈ [x] <-> y = x).
Proof.
  move => x_; split => [H | yx].
  + move /Axiom_Scheme : H => [y_ H]; auto.
  + by subst y; rewrite Axiom_Scheme.
Qed.

Hint Resolve set_bel_sing_eq : set.

Theorem sing_set x :
  Ensemble x -> Ensemble [x].
Proof.
  move => x_.
  move : (Axiom_Subsets x x_) => [y [y_ Hy]].
  apply sub_set with (x:= pow(x)).
  + by apply pow_set.
  + move => p px.
    apply Axiom_Scheme; split; Ens.
    move /Axiom_Scheme : px => [p_ Hp].
    by rewrite (Hp p_).
Qed.

Hint Resolve sing_set : set.

Lemma bel_sing x y :
 Ensemble x -> x ∈ [y] <-> x = y.
Proof.
  move => x_; rewrite Axiom_Scheme.
  split => [[_ H]|H];auto.
Qed.

Theorem sing_eq_universe_iff_not_set x :
  [x] = μ <-> ~ Ensemble x.
Proof.
  split => [H x_| _x].
  + apply universe_notset.
    rewrite -H.
    by apply sing_set.
  + extent; rewrite bel_universe_set; split => [xz|z_].
    - Ens.
    - rewrite Axiom_Scheme; split => // _.
      move : (Axiom_Subsets z z_) => [y [y_ Hy]].
      rewrite Axiom_Extent => p.
      split => [pz|px].
Abort.

Theorem sing_eq_universe_iff_not_set x :
  [x] = μ -> ~ Ensemble x.
Proof.
  move => H F.
  apply universe_notset.
  rewrite -H.
  by apply sing_set.
Qed.

Lemma sub_sing x y:
  Ensemble x -> x ⊂ [y] <-> x = [y] \/ x = Φ.
Proof.
  move => x_; split => [H|H].
  + case (classic (x = Φ)) => [Hz|Hz];[by right|left].
    extent; split => [zx|zy].
    - by apply H.
    - move /Axiom_Scheme : zy => [z_ zy].
      rewrite (zy z_) => {z_ zy}.
      move : (not_zero_exist_bel x Hz) => [p px].
      move : (H p px) => py.
      move /Axiom_Scheme : py => [p_ py].
      by rewrite <- (py p_).
  + case H => {H}[H|H]; subst x => //.
    apply zero_sub.
Qed.

Lemma sing_pow x y:
  Ensemble [x] -> Ensemble y-> y ∈ pow([x]) <-> y = [x] \/ y = Φ.
Proof.
  move => x_ y_.
  rewrite -bel_pow => //; split => [yx |H]; apply sub_sing => //.
Qed.

Theorem sing_set_inv x :
  Ensemble [x] -> Ensemble x.
Proof.
  move => x_.
  apply NNPP => F.
  move : x_.
Abort.

Theorem sing_eleI x :
  Ensemble x -> ⊓[x] = x.
Proof.
  move => x_;  extent; rewrite !Axiom_Scheme.
  split => [[z_ H]|H].
  + apply H.
    by apply bel_sing.
  + split; first by Ens.
    move => y; rewrite Axiom_Scheme; case => [y_ Hy].
    by rewrite (Hy y_).
Qed.

Theorem sing_eleU x :
    Ensemble x -> ⊔ [x] = x.
Proof.
  move => x_; extent; rewrite Axiom_Scheme.
  split => [[z_ [y [zy yx]]]|H].
  + move /Axiom_Scheme : yx => [y_ Hy].
    by rewrite -(Hy y_).
  + split;Ens.
    exists x; split => //; rewrite Axiom_Scheme; split => //.
Qed.

Hint Resolve sing_eleI sing_eleU : set.

Theorem not_sing_eleI x :
    ~ Ensemble x -> ⊓ [x] = Φ /\ ⊔ [x] = x.
Proof.
Abort.

Axiom union_set : forall x y,
  Ensemble x -> Ensemble y -> Ensemble (x ∪ y).

Theorem Axiom_Union' x y :
  Ensemble (x ∪ y) -> Ensemble x /\ Ensemble y.
Proof.
  move => H.
  split; apply sub_set with (x := x ∪ y) => // p Hp; rewrite -bel_union; [left|right] => //.
Qed.

Hint Resolve union_set Axiom_Union': set.

Definition Unordered x y := [x] ∪ [y].
Notation "<| x , y |>" := (Unordered x y)(at level 0).
Hint Unfold Unordered : set.

Theorem Unordered_set x y :
  Ensemble x -> Ensemble y -> Ensemble <|x,y|>.
Proof.
  move => x_ y_.
  apply union_set; apply sing_set => //.
Qed.

Theorem bel_unordered x y z:
  Ensemble x -> Ensemble y -> z ∈ <|x,y|> <-> (z = x \/ z = y).
Proof.
  move => x_ y_; split; rewrite -bel_union => H.
  + case : H => [H|H]; have z_ : Ensemble z by Ens.
    by apply (bel_sing z _ z_) in H; subst z; left.
    by apply (bel_sing z _ z_) in H; subst z; right.
  + case H => {H} [H|H]; subst z; [left|right]; apply bel_sing => //.
Qed.

Hint Resolve Unordered_set bel_unordered : set.

Theorem unord_notset : forall x y, <|x,y|> = μ <-> ~ Ensemble x \/ ~ Ensemble y.
Abort.

Theorem unord_eleI x y :
  Ensemble x -> Ensemble y -> ⊓ <|x,y|> = x ∩ y.
Proof.
  move => x_ y_; extent; split; rewrite !Axiom_Scheme => [[z_ H]]; split => //.
  + split; apply H; apply bel_unordered => //; [left|right] => //.
  + case : H => [zx zy] p. case /(bel_unordered x y p x_ y_); move -> => //.
Qed.

Theorem unord_eleU x y :
  Ensemble x -> Ensemble y -> ⊔ <|x,y|> = x ∪ y.
Proof.
  move => x_ y_;  extent; split; rewrite !Axiom_Scheme => [[z_ H]]; split => //.
  + case : H => [p [zp H]]; case /(bel_unordered x y p x_ y_) : H; move <-; [left|right] => //.
  + case H => [zx|zy]; [exists x|exists y]; split => //; apply bel_unordered => //; [left|right] => //.
Qed.

Hint Resolve unord_eleU unord_eleI : set.

Theorem unord_ele_not : forall x y,
  ~ Ensemble x \/ ~ Ensemble y -> (⊓<|x,y|> = Φ) /\ (⊔ <|x,y|> = μ).
Abort.

End Existence.

Export Existence.