Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Import Blech.Functor.
Require Blech.Reflect.

Import CategoryNotations.
Import FunctorNotations.
Import BishopNotations.

Open Scope category_scope.
Open Scope bishop_scope.

#[local]
Obligation Tactic := Reflect.category_simpl.

#[universes(cumulative)]
 Record Algebra [C:Category] (F: Functor C C) := {
  s: C ;
  π: F s ~> s
}.

Arguments s [C F] _.
Arguments π [C F] _.

#[program]
Definition Alg [C: Category] (F: Functor C C): Category := {|
  Obj := Algebra F ;
  Mor A B := {m: s A ~> s B | m ∘ π A == π B ∘ map F m } ;
  Mor_Setoid _ _ := {| equiv x y := proj1_sig x == proj1_sig y |} ;

  id A := @id _ (s A) ;
  compose A B C := @compose _ (s A) (s B) (s C) ;
|}.

Next Obligation.
Proof.
  exists.
  all: unfold Reflexive, Symmetric, Transitive.
  - intros.
    reflexivity.
  - intros.
    symmetry.
    auto.
  - intros ? ? ? p q.
    rewrite p, q.
    reflexivity.
Qed.

Next Obligation.
Proof.
  rewrite map_id, compose_id_left, compose_id_right.
  reflexivity.
Qed.

Next Obligation.
Proof.
  rewrite <- map_composes.
  rewrite compose_assoc.
  rewrite <- H0.
  rewrite <- compose_assoc.
  rewrite H.
  rewrite compose_assoc.
  reflexivity.
Qed.

Next Obligation.
Proof.
  intros ? ? p ? ? q.
  cbn in *.
  rewrite p, q.
  reflexivity.
Qed.


From RecordUpdate Require Import RecordUpdate.

Record X := mkX { A: nat; B: nat; }.
Instance etaX : Settable _ := settable! mkX <A; B>.

Definition setA (x:X) n := x <|B:=n|>.
Print setA.

Definition updateA (x:X) n := x <|B::=Nat.add n|>.
Print updateA.

Record Nested := mkNested { anX: X; aNat: nat; }.
Instance etaNested : Settable _ := settable! mkNested <anX; aNat>.

Definition setXB (n:Nested) := n <|anX; B:=3|>.
Print setXB.

Definition updateXB (n:Nested) := n <|anX; B::=S|>.
Print updateXB.


Require Export TM.TM.
Require Import Shared.FiniteTypes.DepPairs EqdepFacts.

(** * Switch Combinator *)

Section Switch.

  Variable n : nat.
  Variable sig : finType.

  Variable F : finType.

  Variable pM1 : pTM sig F n.
  Variable F' : finType.
  Variable pMf : F -> pTM sig F' n.

  (** The (unlabelled) machine [M] *)
  Notation M1 := (projT1 pM1).
  (** The labelling function of the machine [M] *)
  Notation p1 := (projT2 pM1).

  (** The (unlabelled) case-machine [M' y] *)
  Notation "'Mf' y" := (projT1 (pMf y)) (at level 10).
  (** The labelling function of the case-machine [M' y] *)
  Notation "'p2' y" := (projT2 (pMf y)) (at level 10).

  Definition Switch_trans :
    (TM.states M1 + { f : F & TM.states (Mf f) }) * Vector.t (option sig) n ->
    (TM.states M1 + { f : F & TM.states (Mf f) }) * Vector.t (option sig * move) n :=
    fun '(q, s) =>
        match q with
        | inl q =>
          if halt q
          then (inr (existT _ (p1 q) (start (Mf (p1 q)))), nop_action)
          else let (q', a) := trans (q, s) in (inl q', a)
        | inr q =>
          let (q', a) := trans (projT2 q, s) in
          (inr (existT _ (projT1 q) q'), a)
        end.

  Definition Switch_halt : (TM.states M1 + { f : F & TM.states (Mf f) }) -> bool :=
    fun q =>
      match q with
      | inl _ => false
      | inr q => halt (projT2 q)
      end.

  Definition SwitchTM : mTM sig n :=
    {|
      trans := Switch_trans;
      halt  := Switch_halt;
      start := inl (start M1);
    |}.

  Definition Switch_p : (states SwitchTM) -> F' :=
    fun q => match q with
          | inl q => p2 (p1 q) (start (Mf (p1 q))) (* Canonical value *)
          | inr q => p2 (projT1 q) (projT2 q)
          end.

  Definition Switch : pTM sig F' n := (SwitchTM; Switch_p).

  (** Lift configurations of [M1] to configurations of [Switch] *)
  Definition lift_confL (c : mconfig sig (states M1) n) : mconfig sig (states SwitchTM) n :=
    mk_mconfig (inl (cstate c)) (ctapes c).

  (** Lift configuration of [M2] to configurations of [Switch] *)
  Definition lift_confR (f : F) (c : mconfig sig (states (Mf f) ) n) : mconfig sig (states SwitchTM) n :=
    mk_mconfig (inr (existT (fun f0 : F => states (Mf f0)) f (cstate c))) (ctapes c).

  (** Lifted Steps of [M1] are compatible with steps in [M1], for non-halting states *)
  Lemma step_comp_liftL (c : mconfig sig (states M1) n) :
    haltConf c = false -> step (lift_confL c) = lift_confL (step c).
  Proof.
    unfold lift_confL, step, haltConf. cbn. destruct c as [q t]; cbn in *. intros H. rewrite H.
    destruct (trans _) eqn:E. cbn. reflexivity.
  Qed.

  (** Lifted steps of case-machines [Mf f] are compatible with steps in [Mf f] *)
  Lemma step_comp_liftR f (c : mconfig sig (states (Mf f)) n) :
    step (lift_confR c) = lift_confR (step c).
  Proof.
    destruct c. unfold lift_confR, step. cbn.
    destruct (trans _) eqn:E. cbn. reflexivity.
  Qed.

  (** Lifted halting states of [M1] *)
  Definition halt_liftL (c : mconfig sig (states (SwitchTM)) n) :=
    match cstate c with
    | inl q => halt (m := M1) q
    | inr q => true
    end.

  (** Non-halting states of [M1] are non-halting states of [Switch] *)
  Lemma halt_conf_liftL (c : mconfig sig (states SwitchTM) n) :
    halt_liftL c = false -> halt (cstate c) = false.
  Proof.
    intros H. cbn. unfold Switch_halt.
    destruct c as [q t]; cbn.
    destruct q; cbn in *; auto.
  Qed.

  (** The "nop" transition jumps from a halting configuration of [M1] to the initial configuration of the corresponding case-machine. *)
  Lemma step_nop_transition (c : mconfig sig (states M1) n) :
    haltConf c = true ->
     step (lift_confL c) = lift_confR (initc (Mf (p1 (cstate c))) (ctapes c)).
  Proof.
    intros Halt.
    unfold lift_confL, lift_confR. cbn. unfold haltConf in Halt.
    unfold step at 1; cbn.
    rewrite Halt. f_equal.
    apply doAct_nop.
  Qed.

  (** The starting configuration of [Switch] corresponds to the starting configuration of [M1]. *)
  Lemma lift_initc t :
    initc SwitchTM t = lift_confL (initc M1 t).
  Proof. reflexivity. Qed.

  (** This lemma is needed for the termination part. Suppose [M1] terminates in [c1].  The case machine [Mf f] starts with the tapes of [c1] and terminates in a configuration [c2]. Then, if we start [Switch] with the same tapes as [M1], [Switch] terminates in the lifted configuration of [c2]. *)
  Lemma Switch_merge t (k1 k2 : nat)
        (c1 : mconfig sig (states M1) n)
        (c2 : mconfig sig (states (Mf (p1 (cstate c1)))) n) :
    loopM (initc M1 t) k1 = Some c1 ->
    loopM (initc (Mf (p1 (cstate c1))) (ctapes c1)) k2 = Some c2 ->
    loopM (initc SwitchTM t) (k1 + (1 + k2)) = Some (lift_confR c2).
  Proof.
    intros HLoop1 HLoop2. unfold loopM in *.
    apply loop_merge with (h := halt_liftL) (a2 := lift_confL c1).
    - apply halt_conf_liftL.
    - rewrite lift_initc.
      apply loop_lift with (h := haltConf (M := M1)) (f := step (M := M1)).
      + unfold haltConf. intros. cbn. reflexivity.
      + apply step_comp_liftL.
      + apply HLoop1.
    - (* execute one step *)
      rewrite loop_step by auto.
      rewrite step_nop_transition by apply (loop_fulfills HLoop1).
      eapply loop_lift with (lift := lift_confR (f := p1 (cstate c1))) (f' := step (M := SwitchTM)) (h' := haltConf (M := SwitchTM)) in HLoop2.
      + apply HLoop2.
      + intros. cbn. now destruct x.
      + intros. apply step_comp_liftR.
  Qed.

  (** The [Switch] machine must take the "nop" action if it is in a final state of [M1]. *)
  Lemma step_nop_split (k2 : nat) (c2 : mconfig sig (states M1) n) (outc : mconfig sig (states SwitchTM) n) :
    haltConf c2 = true ->
    loopM (M := SwitchTM) (lift_confL c2) k2 = Some outc ->
    exists k2' c2',
      k2 = S k2' /\
      loopM (M := Mf (p1 (cstate c2))) (initc _ (ctapes c2)) k2' = Some c2' /\
      outc = lift_confR c2'.
  Proof.
    unfold loopM. intros HHalt HLoop2. unfold haltConf in HHalt.
    destruct k2 as [ | k2'].
    - inv HLoop2.
    - exists k2'. cbn in HLoop2.
      rewrite step_nop_transition in HLoop2 by assumption.
      apply loop_unlift with
          (f := step (M := Mf (p1 (cstate c2))))
          (h := haltConf (M := Mf (p1 (cstate c2)))) in HLoop2 as
          (c2'&HLoop2&->).
      + exists c2'. repeat split. exact HLoop2.
      + intros. reflexivity.
      + intros. apply step_comp_liftR.
  Qed.

  Lemma Switch_split k t (outc : mconfig sig (states SwitchTM) n) :
    loopM (initc SwitchTM t) k = Some outc ->
    exists k1 (c1 : mconfig sig (states M1) n) k2 (c2 : mconfig sig (states (Mf (p1 (cstate c1)))) n),
      loopM (initc M1 t) k1 = Some c1 /\
      loopM (initc (Mf (p1 (cstate c1))) (ctapes c1)) k2 = Some c2 /\
      outc = lift_confR c2.
  Proof.
    unfold loopM. intros H.
    apply loop_split with (h := halt_liftL) in H as (k1&c1&k2&HLoop1&HLoop2&_).
    - rewrite lift_initc in HLoop1.
      apply loop_unlift with (lift := lift_confL) (f := step (M := M1)) (h := haltConf (M := M1)) in HLoop1 as (c1'&HLoop1&->).
      + apply step_nop_split in HLoop2 as (k2'&c2'&_&HLoop2&->). 2: now apply (loop_fulfills HLoop1).
        exists k1, c1', k2', c2'. auto.
      + intros. cbn. reflexivity.
      + intros. now apply step_comp_liftL.
    - apply halt_conf_liftL.
  Qed.

  (** Correctness *)
  Lemma Switch_Realise (R1 : Rel _ (F * _)) (R2 : F -> Rel _ (F' * _)) :
    pM1 ⊨ R1 ->
    (forall f : F, pMf f ⊨ R2 f) -> Switch ⊨ (⋃_f (R1 |_ f) ∘ R2 f).
  Proof.
    intros HRel1 HRel2. hnf in HRel1.
    hnf. intros t i outc HLoop.
    apply Switch_split in HLoop as (k1&c1&k2&c2&HLoop1&HLoop2&->). cbn.
    exists (p1 (cstate c1)), (ctapes c1). split.
    - apply (HRel1 _ _ _ HLoop1).
    - apply (HRel2 _ _ _ _ HLoop2).
  Qed.

  (** Runtime *)
  Lemma Switch_TerminatesIn (R1 : Rel _ (F * _)) T1 T2 :
    pM1 ⊨ R1 -> M1 ↓ T1 -> (forall f : F, Mf f ↓(T2 f)) ->
    projT1 Switch ↓ (fun tin i => exists i1 i2, T1 tin i1 /\ 1 + i1 + i2 <= i /\ forall tout yout, R1 tin (yout, tout) -> T2 yout tout i2).
  Proof.
    unfold Switch. intros HRel1 HTerm1 HTerm2. hnf in HRel1, HTerm1.
    hnf. intros t i (i1&i2&HT1&Hk&H).
    specialize HTerm1 with (1 := HT1) as (c1&HLoop1).
    specialize HRel1 with (1 := HLoop1).
    specialize H with (1 := HRel1).
    specialize (HTerm2 _ _ _ H) as (c2&HLoop2).
    pose proof Switch_merge HLoop1 HLoop2 as HLoop.
    exists (lift_confR c2). eapply loop_monotone; eauto. omega.
  Qed.

  (** Correct + constant running time *)
  Lemma Switch_RealiseIn (R1 : Rel _ (F * _)) (R2 : F -> Rel _ (F' * _)) k1 k2:
    pM1 ⊨c(k1) R1 ->
    (forall f : F, pMf f ⊨c(k2) R2 f) ->
    Switch ⊨c(1 + k1 + k2) (⋃_f (R1 |_ f) ∘ R2 f).
  Proof.
    intros (H1&H2) % Realise_total H3. apply Realise_total. split.
    - eapply Switch_Realise; eauto. intros ?. eapply Realise_total; eauto.
    - eapply TerminatesIn_monotone.
      + apply Switch_TerminatesIn; eauto. intros ?. eapply Realise_total; eauto.
      + firstorder.
  Qed.

End Switch.

Arguments Switch : simpl never.

(* Deprecated names *)
Notation MATCH := Switch.
Notation Match := Switch.


Require Import Coq.Program.Basics Psatz.
Require Import StructTact.StructTactics.
Require Import Clight.factorial1.
Require Import VST.floyd.proofauto.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Open Scope program_scope.

Fixpoint fact (n : nat) : Z :=
  match n with
  | O => 1
  | S n' => (Z.of_nat n' + 1) * fact n'
  end.

Definition factZ (z : Z) : Z :=  fact (Z.to_nat z).

Definition factorial1_spec : ident * funspec :=
  DECLARE _factorial1
    WITH n : Z
    PRE [_input OF tuint]
      PROP(0 <= n <= Int.max_unsigned;
           0 <= factZ n <= Int.max_unsigned)
      LOCAL(temp _n ((Vint ∘ Int.repr) n))
      SEP()
    POST [tuint]
      PROP()
      LOCAL(temp ret_temp ((Vint ∘ Int.repr) (factZ n)))
      SEP().

Definition Gprog := ltac:(with_library prog [factorial1_spec]).

Lemma body_factorial1: semax_body Vprog Gprog f_factorial1 factorial1_spec.
Proof.
  start_function.
  abbreviate_semax.
  unfold compose in *; simpl.
  forward.
  forward.
  forward_while (
      EX i : Z,
        PROP( 0 <= i <= n)
        LOCAL(temp _i (Vint (Int.repr i));
              temp _n (Vint (Int.repr n));
              temp _out (Vint (Int.repr (factZ i))))
        SEP()).
  entailer.
  Exists 0.
  entailer!.
  entailer!.
  repeat forward.
  entailer!.
  repeat autorewrite with norm.
  Exists ((i + 1))%Z.
  entailer!.
  repeat f_equal.
  unfold factZ.
  replace (Z.to_nat (i + 1)) with (S (Z.to_nat i))%nat.
  simpl.
  replace (Z.of_nat (Z.to_nat i)) with i.
  nia.
  rewrite Z2Nat.id; auto.
  nia.
  rewrite Z2Nat.inj_add.
  replace (Z.to_nat 1) with 1%nat by auto with zarith.
  all: try omega.
  forward.
  replace i with n by nia.
  entailer!.
Qed.

Require Import Clight.factorial.

Definition factorial_spec : ident * funspec :=
  DECLARE _factorial
    WITH n : Z
    PRE [_input OF tuint]
      PROP(0 <= n <= Int.max_unsigned;
           0 <= factZ n <= Int.max_unsigned)
      LOCAL(temp _input ((Vint ∘ Int.repr) n))
      SEP()
    POST [tuint]
      PROP()
      LOCAL(temp ret_temp ((Vint ∘ Int.repr) (factZ n)))
      SEP().

Definition Gprog' := ltac:(with_library prog [factorial_spec]).

Lemma body_factorial: semax_body Vprog Gprog' f_factorial factorial_spec.
Proof.
  start_function.
  abbreviate_semax.
  unfold compose in *; simpl.
  forward.
  forward_while (
      EX i : Z,
        PROP( 0 <= i <= n)
        LOCAL(temp _input (Vint (Int.repr (n - i)));
              temp _output (Vint (Int.divu (Int.repr (factZ n))
                                           (Int.repr (factZ (n - i))))))
        SEP()).
  entailer.
  Exists 0.
  entailer!.
  replace (n - 0) with n by Lia.nia.
  split.
  easy.
  f_equal.
  unfold Int.divu.
  f_equal.
  autorewrite with norm.
  assert (0 < factZ n).
  unfold factZ.
  induction (Z.to_nat n).
  1,2: simpl; try nia.
  eapply Z_div_same.
  nia.
  entailer!.
  forward.
  forward.
  repeat autorewrite with norm.
  entailer.
  Exists ((i + 1))%Z.
  entailer.
  entailer!.
  split.
  f_equal.
  f_equal.
  nia.
  f_equal.
  admit.
  forward.
  entailer!.
  replace i with n.
  replace (n - n) with 0 by nia.
  f_equal.
  unfold factZ.
  simpl.
  eapply Int.divu_one.  assert (n - i = 0).
   {
    replace (n - i) with (Int.unsigned (Int.repr (n - i))).
    replace (0) with (Int.unsigned Int.zero).
    f_equal.
    assumption.
    reflexivity.
    rewrite Int.unsigned_repr.
    reflexivity.
    Lia.lia.
  }
nia.
Admitted.


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) TU Dortmund University, Dortmund, Germany
*)

(*
  Decision Procedure(s):
    Two-counter Machine Uniform Boundedness (CM2_UBOUNDED)
*)

Require Import List ListDec PeanoNat Lia Relation_Operators Operators_Properties.
Import ListNotations.
Require Import Undecidability.CounterMachines.CM2.
From Undecidability.CounterMachines.Util Require Import Facts CM2_facts.
Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".
Set Default Proof Using "Type".

Section Construction.
Variable M : Cm2.

#[local] Notation steps := (CM2.steps M).
#[local] Notation bounded := (CM2.bounded M).
#[local] Notation step := (CM2.step M).
#[local] Notation reaches := (CM2.reaches M).
#[local] Notation path := (CM2_facts.path M).

Lemma pointwise_decision K x : {bounded K x} + {not (bounded K x)}.
Proof.
  case HK: (steps K x) => [y|].
  - have [Hy|Hy] := In_dec option_Config_eq_dec (Some y) (path K x).
    + left. apply: loop_bounded. by rewrite HK.
    + right. apply: (NoDup_not_bounded HK).
      apply: path_noloopI. by rewrite HK.
  - left. by apply: mortal_bounded.
Qed.

Lemma shift_steps_a k K p a b :
  k <= K ->
  steps k (p, (K + a, b)) =
  match steps k (p, (K, b)) with
  | Some (p', (a', b')) => Some (p', (a' + a, b'))
  | None => None
  end.
Proof.
  move=> ?. rewrite [LHS]shift_steps [in RHS]shift_steps.
  have ->: Nat.min k (K + a) = k by lia.
  have ->: Nat.min k K = k by lia.
  case: (steps k _) => [[? [? ?]]|]; last done.
  congr (Some (_, (_, _))); lia.
Qed.

Lemma shift_steps_b k K p a b :
  k <= K ->
  steps k (p, (a, K + b)) =
  match steps k (p, (a, K)) with
  | Some (p', (a', b')) => Some (p', (a', b' + b))
  | None => None
  end.
Proof.
  move=> ?. rewrite [LHS]shift_steps [in RHS]shift_steps.
  have ->: Nat.min k (K + b) = k by lia.
  have ->: Nat.min k K = k by lia.
  case: (steps k _) => [[? [? ?]]|]; last done.
  congr (Some (_, (_, _))); lia.
Qed.

Lemma shift_path_a K p a b :
  path (K+1) (p, (K+a, b)) =
  map (fun oy => if oy is Some (p', (a', b')) then Some (p', (a'+a, b')) else None) (path (K+1) (p, (K, b))).
Proof.
  rewrite /path map_map. apply: map_ext_in => k /in_seq ?.
  apply: shift_steps_a. lia.
Qed.

Lemma shift_path_b K p a b :
  path (K+1) (p, (a, K+b)) =
  map (fun oy => if oy is Some (p', (a', b')) then Some (p', (a', b'+b)) else None) (path (K+1) (p, (a, K))).
Proof.
  rewrite /path map_map. apply: map_ext_in => k /in_seq ?.
  apply: shift_steps_b. lia.
Qed.

Lemma path_NoDup_a_bound K p a b : K <= a -> NoDup (path (K+1) (p, (a, b))) -> NoDup (path (K+1) (p, (K, b))).
Proof.
  move=> ?. have ->: a = K+(a-K) by lia.
  rewrite shift_path_a. by apply: NoDup_map_inv.
Qed.

Lemma path_NoDup_b_bound K p a b : K <= b -> NoDup (path (K+1) (p, (a, b))) -> NoDup (path (K+1) (p, (a, K))).
Proof.
  move=> ?. have ->: b = K+(b-K) by lia.
  rewrite shift_path_b. by apply: NoDup_map_inv.
Qed.

Lemma fixed_decision K :
  {forall x : Config, bounded K x} + {~ (forall x : Config, bounded K x)}.
Proof.
  (* need to check configurations up to values K *)
  have := Forall_dec (fun 'x => bounded K x) (pointwise_decision K)
    (list_prod (seq 0 (length M)) (list_prod (seq 0 (K+1)) (seq 0 (K+1)))).
  case; first last.
  { move=> H. right => HK. apply /H /Forall_forall. move=> ??. by apply: HK. }
  wlog: K /(0 < K).
  { move: K => [|K] H HK.
    - right. move=> /(_ (0, (0, 0))) [[|? L] [/= ? /(_ (0, (0, 0))) HL]].
      + apply: HL. by exists 0.
      + lia.
    - apply: H; [lia|done]. }
  move=> ? HK. left => x.
  have [|/path_noloopI] := In_dec option_Config_eq_dec (steps K x) (path K x).
  { by apply: loop_bounded. }
  case Hz: (steps K x) => [z|]; first last.
  { move=> _. by apply: mortal_bounded. }
  (* not bounded *)
  move=> Hx. exfalso.
  move: x Hx Hz => [p [a b]] Hx Hz.
  have Hp : not (length M <= p).
  { move=> /nth_error_None HM. move: Hz. have -> : K = S (K - 1) by lia.
    by rewrite /steps /= obind_oiter /step /= HM oiter_None. }
  move: Hx Hz.
  (* it suffices to consider configurations up to values K  *)
  wlog: a b z /(a <= K /\ b <= K); first last.
  { move=> ? Hx Hz. suff: bounded K (p, (a, b)).
    { by apply: (NoDup_not_bounded Hz). }
    move: HK => /Forall_forall.
    apply. apply: in_prod; [|apply: in_prod]; apply /in_seq; lia. }
  move=> H'K.
  wlog: a b z /(a <= K).
  { move=> H. have [/H|->] : a <= K \/ a = K + (a - K) by lia.
    { by apply. }
    move=> /path_NoDup_a_bound => /(_ ltac:(lia)) /H {H}.
    rewrite shift_steps_a; first done.
    case: (steps K (p, (K, b))) => [y|]; last done.
    move=> H _. by apply: (H y). }
  move=> ?. have [?|->] : b <= K \/ b = K + (b - K) by lia.
  { move=> /H'K H /H. by apply. }
  move=> /path_NoDup_b_bound => /(_ ltac:(lia)) /H'K.
  rewrite shift_steps_b; first done.
  case: (steps K (p, (a, K))) => [y|]; last done.
  move=> H _. by apply: (H y).
Qed.

Notation l := (length M).

(* from an arbitrary config arrive at config with at least one large value *)
Lemma uniform_decision_aux1 x : let n := l*(l+1) in
  (bounded (l*n*n+1) x) +
  { y | (exists k, k <= l*n*n /\ steps k x = Some y) /\ (n <= value1 y \/ n <= value2 y) }.
Proof.
  move=> n.
  have [|/path_noloopI Hx] :=
    In_dec option_Config_eq_dec (steps (l*n*n) x) (path (l*n*n) x).
  { move=> /loop_bounded H. left. apply: (bounded_monotone _ H). lia. }
  case Hxy: (steps (l*n*n+1) x) => [y|]; first last.
  { left. by apply: mortal_bounded. }
  right.
  have [/pigeonhole|] := incl_dec option_Config_eq_dec (path (l*n*n+1) x)
    (map Some (list_prod (seq 0 l) (list_prod (seq 0 n) (seq 0 n)))).
  { move=> H. exfalso. apply: (H _ Hx).
    rewrite path_length map_length ?prod_length ?seq_length. lia. }
  move=> /(not_inclE option_Config_eq_dec) [[z|]].
  - move=> H. exists z.
    move: H => [/in_map_iff] [k] [Hk] /in_seq ? H.
    have H'z : not (l <= state z).
    { move=> /nth_error_None Hz.
      have : steps (S k) x = None by rewrite /= Hk /= /step Hz.
      move=> /(steps_k_monotone (l*n*n+1)) /(_ ltac:(lia)).
      by rewrite Hxy. }
    split. { exists k. split; [lia|done]. }
    suff : not (value1 z < n /\ value2 z < n) by lia.
    move=> H'. apply: H. apply /in_map_iff. exists z. split; first done.
    move: z {Hk} H'z H' => [? [? ?]] /= ??.
    apply /in_prod; [|apply /in_prod]; apply /in_seq; lia.
  - move=> [/in_map_iff] H. exfalso.
    move: H => [k] [+ /in_seq ?].
    move=> /(steps_k_monotone (l*n*n+1)) /(_ ltac:(lia)).
    by rewrite Hxy.
Qed.

Lemma k_step_iter k p a1 b1 a2 b2 :
  (k <= a1 \/ a1 = a2) -> (k <= b1 \/ b1 = b2) ->
  steps k (p, (a1, b1)) = Some (p, (a2, b2)) ->
  let ca := if Nat.eq_dec a1 a2 then 0 else 1 in
  let cb := if Nat.eq_dec b1 b2 then 0 else 1 in
  forall i n a b, i <= n ->
    steps (i*k) (p, (a1+ca*(a+n*a1),b1+cb*(b+n*b1))) =
      Some (p, (a1+ca*(a+(n-i)*a1+i*a2),b1+cb*(b+(n-i)*b1+i*b2))).
Proof.
  move=> Ha Hb Hk ca cb. elim.
  { move=> ????. congr (Some (_, (_, _))); lia. }
  move=> i IH [|n] a b; first by lia.
  move=> /(iffRL (Nat.succ_le_mono _ _)) /IH {}IH.
  rewrite /= /steps iter_plus -/(steps _ _).
  have := IH (a2+a) (b2+b). congr eq; first last.
  { congr (Some (_, (_, _))); lia. }
  congr Nat.iter.
  rewrite /ca /cb.
  move: (Nat.eq_dec a1 a2) (Nat.eq_dec b1 b2) => [?|?] [?|?] /=.
  - rewrite ?Nat.add_0_r Hk.
    congr (Some (_, (_, _))); lia.
  - rewrite shift_steps_b; first lia.
    rewrite ?Nat.add_0_r Hk.
    congr (Some (_, (_, _))); lia.
  - rewrite shift_steps_a; first lia.
    rewrite ?Nat.add_0_r Hk.
    congr (Some (_, (_, _))); lia.
  - rewrite shift_steps_a; first lia.
    rewrite shift_steps_b; first lia.
    rewrite ?Nat.add_0_r Hk.
    congr (Some (_, (_, _))); lia.
Qed.

(* probably too much? *)
Lemma not_uniformly_boundedI k p a1 b1 a2 b2 :
  (k <= a1 \/ a1 = a2) -> (k <= b1 \/ b1 = b2) ->
  (a1 <> a2 \/ b1 <> b2) ->
  steps k (p, (a1, b1)) = Some (p, (a2, b2)) ->
  not (uniformly_bounded M).
Proof.
  move=> /k_step_iter H /H {}H Hab /H /= + [K].
  move=> /(_ _ K 0 0) /=.
  move Ha: (a1 + _ * _) => a.
  move Hb: (b1 + _ * _) => b.
  move=> {}H /(_ (p, (a, b))) [L [? HL]].
  have : incl (map (fun i => steps (i * k) (p, (a, b))) (seq 0 (K+1))) (map Some L).
  { move=> z /in_map_iff [i] [<- /in_seq ?]. rewrite H; first by lia.
    apply: in_map. apply: HL. exists (i*k). rewrite H; [lia|done]. }
  move=> /pigeonhole. apply.
  { rewrite ?map_length seq_length. lia. }
  under map_ext_in.
  { move=> i /in_seq ?. rewrite H; first by lia. over. }
  apply: NoDup_map_ext; last by apply: seq_NoDup.
  move=> i1 /in_seq ? i2 /in_seq ? [].
  move: (Nat.eq_dec a1 a2) (Nat.eq_dec b1 b2) => [?|?] [?|?] /=; nia.
Qed.

(* from a config with the a really large value arrive at config with two large values *)
Lemma uniform_decision_aux2 x : ({l*(l+1) <= value1 x} + {l*(l+1) <= value2 x}) ->
  (bounded (l*l+1) x) + (not (uniformly_bounded M)) +
    { y | (exists k, k <= l*l /\ steps k x = Some y) /\ (l <= value1 y /\ l <= value2 y) }.
Proof.
  move=> Hlx.
  have [|/path_noloopI Hx] :=
    In_dec option_Config_eq_dec (steps (l*l) x) (path (l*l) x).
  { move=> /loop_bounded H. left. left. apply: (bounded_monotone _ H). lia. }
  case Hxy: (steps (l*l+1) x) => [y|]; first last.
  { left. left. by apply: mortal_bounded. }
  pose P oz := if oz is Some z then
    (if Hlx then l <= value2 z else l <= value1 z) else True.
  have HP : forall x, {P x} + {not (P x)}.
  { move=> [? /= |]; last by left. clear P.
    case: Hlx => ?; by apply: Compare_dec.le_dec. }
  have [|H'x] := Exists_dec P (path (l * l + 1) x) HP.
  { move=> /(Exists_sig P HP) [[z|]] [Hz /= H'z].
    - right. exists z. move: Hz => /In_pathE [k [? Hk]]. split.
      + exists k. split; [lia|done].
      + move: Hk => /steps_values_bound. clear P HP.
        case: Hlx H'z => /=; lia.
    - exfalso. by move: Hz Hxy => /In_None_pathE ->. }
  (* all value1 or value2 are smaller than l, not uniformly bounded *)
  left. right. subst P.
  have /pigeonhole : incl
    (map (fun oz => if oz is Some (p, (a, b)) then (if Hlx then (p, b) else (p, a)) else (0, 0)) (path (l * l + 1) x))
    (list_prod (seq 0 l) (seq 0 l)).
  { move=> [p c] /in_map_iff [[[p' [a' b']]|]]; first last.
    { move=> [_ /In_pathE].
      move=> [?] [?] /(steps_k_monotone (l * l + 1)) /(_ ltac:(lia)).
      by rewrite Hxy. }
    move=> [+ H]. have ? : not (l <= p').
    { move=> /nth_error_None Hp. move: H => /in_map_iff [k] [Hk /in_seq ?].
      have : steps (S k) x = None by rewrite /= Hk /step /= Hp.
      move=> /(steps_k_monotone (l*l+1)) /(_ ltac:(lia)).
      by rewrite Hxy. }
    case: Hlx H'x HP => /= ? H'x HP.
    - move=> [? ?]. subst p c.
      move: H'x H => /Forall_Exists_neg /Forall_forall H /H{H} /= ?.
      apply /in_prod; apply /in_seq; lia.
    - move=> [? ?]. subst p c.
      move: H'x H => /Forall_Exists_neg /Forall_forall H /H{H} /= ?.
      apply /in_prod; apply /in_seq; lia. }
  apply: unnest. { rewrite map_length ?prod_length ?seq_length path_length. lia. }
  rewrite /path map_map. move=> /(dup_seq prod_nat_nat_eq_dec) [[i j]].
  move=> [+ ?].
  case Hi: (steps i x) => [[p [a1 b1]]|]; first last.
  { move: Hi => /(steps_k_monotone (l*l+1)) /(_ ltac:(lia)). by rewrite Hxy. }
  case Hj: (steps j x) => [[p' [a2 b2]]|]; first last.
  { move: Hj => /(steps_k_monotone (l*l+1)) /(_ ltac:(lia)). by rewrite Hxy. }
  clear H'x.
  have ? : not (p = p' /\ a1 = a2 /\ b1 = b2).
  { move=> [? [? ?]]. subst p' a2 b2.
    move: Hx. rewrite /path.
    have -> : l*l+1 = i + (S (j-i-1)) + (S (l*l -j)) by lia.
    rewrite seq_app seq_app /= ?map_app /= (NoDup_count_occ option_Config_eq_dec).
    move=> /(_ (Some (p, (a1, b1)))). have ->: i + S (j - i - 1) = j by lia.
    rewrite Hi Hj ?count_occ_app /=. case: (option_Config_eq_dec _ _); [lia|done]. }
  case: Hlx HP => /= ? HP.
  - move=> [? ?]. subst p' b2.
    have ? : a1 <> a2 by lia.
    (* x ->>i (p, (a1, b1)) ->>(j-i) (p, (a2, b2)); a1 >= j-i or b1 >= j-i *)
    have ? : j-i <= a1.
    { move: Hi => /steps_values_bound /=. lia. }
    move: Hi Hj => /steps_sub H /H{H} /(_ ltac:(lia)).
    move /not_uniformly_boundedI. apply; lia.
  - move=> [? ?]. subst p' a2.
    have ? : b1 <> b2 by lia.
    have ? : j-i <= b1.
    { move: Hi => /steps_values_bound /=. lia. }
    move: Hi Hj => /steps_sub H /H{H} /(_ ltac:(lia)).
    move /not_uniformly_boundedI. apply; lia.
Qed.

(* from a config with two large values decide boundedness *)
Lemma uniform_decision_aux3 x : l <= value1 x -> l <= value2 x -> (bounded (l+1) x) + (not (uniformly_bounded M)).
Proof.
  move=> ??.
  have [|/path_noloopI Hx] :=
    In_dec option_Config_eq_dec (steps (l) x) (path (l) x).
  { move=> /loop_bounded H. left. apply: (bounded_monotone _ H). lia. }
  case Hxy: (steps (l+1) x) => [y|]; first last.
  { left. by apply: mortal_bounded. }
  right. (* not uniformly bounded *)
  have /pigeonhole : incl
    (map (fun oz => if oz is Some (p, (a, b)) then p else 0) (path (l + 1) x))
    (seq 0 l).
  { move=> p /in_map_iff [[[p' [a' b']]|]]; first last.
    { move=> [_ /In_pathE].
      move=> [?] [?] /(steps_k_monotone (l + 1)) /(_ ltac:(lia)).
      by rewrite Hxy. }
    move=> [->] H. apply /in_seq. suff : not (l <= p) by lia.
    move=> /nth_error_None Hp. move: H => /in_map_iff [k] [Hk /in_seq ?].
    have : steps (S k) x = None by rewrite /= Hk /step /= Hp.
    move=> /(steps_k_monotone (l+1)) /(_ ltac:(lia)).
    by rewrite Hxy. }
  apply: unnest. { rewrite map_length ?seq_length path_length. lia. }
  rewrite /path map_map. move=> /(dup_seq Nat.eq_dec) [[i j]].
  move=> [+ ?].
  case Hi: (steps i x) => [[p [a1 b1]]|]; first last.
  { move: Hi => /(steps_k_monotone (l+1)) /(_ ltac:(lia)). by rewrite Hxy. }
  case Hj: (steps j x) => [[p' [a2 b2]]|]; first last.
  { move: Hj => /(steps_k_monotone (l+1)) /(_ ltac:(lia)). by rewrite Hxy. }
  move=> ?. subst p'.
  have ? : a1 <> a2 \/ b1 <> b2.
  { suff : not (a1 = a2 /\ b1 = b2) by lia. move=> [??]. subst a2 b2.
    move: Hx. rewrite /path.
    have -> : l+1 = i + (S (j-i-1)) + (S (l -j)) by lia.
    rewrite seq_app seq_app /= ?map_app /= (NoDup_count_occ option_Config_eq_dec).
    move=> /(_ (Some (p, (a1, b1)))). have ->: i + S (j - i - 1) = j by lia.
    rewrite Hi Hj ?count_occ_app /=. case: (option_Config_eq_dec _ _); [lia|done]. }
  have ?: j - i <= a1 /\ j - i <= b1.
  { move: Hi => /steps_values_bound /=. lia. }
  move: Hi Hj => /steps_sub H /H{H} /(_ ltac:(lia)).
  move=> /not_uniformly_boundedI. apply; lia.
Qed.

Lemma uniformly_bounded_empty : uniformly_bounded [].
Proof.
  exists 1. move=> x. exists [x]. split; first done.
  move=> y [[|k]].
  - move=> [<-]. by left.
  - rewrite /= obind_oiter /CM2.step.
    by case: (state x); rewrite /= oiter_None.
Qed.

(* a uniformly bounded machine M is uniformly bounded by (|M|+1)^5 *)
Lemma bound_on_uniform_bound : uniformly_bounded M ->
  forall x, bounded ((l+1)*(l+1)*(l+1)*(l+1)*(l+1)) x.
Proof.
  move=> HM x.
  set K := ((l+1)*(l+1)*(l+1)*(l+1)*(l+1)).
  (* x ->> y with at least one large counter *)
  have [|[y [[k1 [Hk1 Hxy]] ?]]] := uniform_decision_aux1 x.
  { apply: bounded_monotone. lia. }
  have -> : K = k1 + (K - k1) by lia.
  apply: (reaches_bounded Hxy).
  have : {l * (l + 1) <= value1 y} + {l * (l + 1) <= value2 y}.
  { case H: (l * (l + 1) - value1 y) => [|?]; [left|right]; lia. }
  move=> /uniform_decision_aux2 [[|]|[z]].
  - apply: bounded_monotone. lia.
  - by move=> /(_ HM).
  - move=> [[k2 [? Hyz]]] [/uniform_decision_aux3 H /H{H}].
    move=> [/bounded_monotone Hz|].
    + have -> : K - k1 = k2 + (K - k1 - k2) by lia.
      apply: (reaches_bounded Hyz). apply: Hz. lia.
    + by move=> /(_ HM).
Qed.

(* informative decision statement for uniform boundedness for Cm2 *)
Theorem decision : (uniformly_bounded M) + (not (uniformly_bounded M)).
Proof.
  wlog ? : /(l > 0).
  { move: (M) => [|? ?] /=.
    - move=> _. left. by apply: uniformly_bounded_empty.
    - apply. lia. }
  pose K := (l+1)*(l+1)*(l+1)*(l+1)*(l+1).
  (* test uniform boundedness by K ~ l^5 *)
  have [?|HK] := fixed_decision K. { left. by exists K. }
  (* not uniformly bounded *)
  right. move=> /bound_on_uniform_bound => HM.
  apply: HK => x. by apply: HM.
Qed.

End Construction.

Require Import Undecidability.Synthetic.Definitions.

(* decision procedure for uniform boundedness for Cm2 *)
Definition decide : Cm2 -> bool :=
  fun M =>
    match decision M with
    | inl _ => true
    | inr _ => false
    end.

(* decision procedure correctness *)
Lemma decide_spec : decider decide CM2_UBOUNDED.
Proof.
  rewrite /decider /reflects /decide => M.
  case: (decision M); intuition done.
Qed.