(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*             Yannick Forster            [+]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*                             [+] Affiliation Saarland Univ. *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)
(* ** Compiler from MM to FRACTRAN *)
From Undecidability.Shared.Libs.DLW
pos vec subcode sss.
From Undecidability.MinskyMachines.MM Require Import mm_defs mm_no_self.
From Undecidability.FRACTRAN Require Import FRACTRAN fractran_utils prime_seq.
Set Implicit Arguments.
Tactic Notation "rew" "length" := autorewrite with length_db.
Local Notation "e #> x" := (vec_pos e x).
Local Notation "e [ v / x ]" := (vec_change e x v).
Local Notation "I // s -1> t" := (mm_sss I s t).
Local Notation "P /MM/ s → t" := (sss_step (@mm_sss _) P s t) (at level 70, no associativity).
Local Notation "P /MM/ s -[ k ]-> t" := (sss_steps (@mm_sss _) P k s t) (at level 70, no associativity).
Local Notation "P /MM/ s ↓" := (sss_terminates (@mm_sss _) P s) (at level 70, no associativity).
Local Notation "l /F/ x → y" := (fractran_step l x y) (at level 70, no associativity).
Local Notation "l /F/ x -[ k ]-> y" := (fractran_steps l k x y) (at level 70, no associativity).
Set Implicit Arguments.
(* Fractran simulates MM *)
(*       let a MM program 1: INC ... k: DEC ... n: _ *)
(*       with variables x1...xm *)
(*    we use p1...pn,q1...qm distinct primes and  *)
(*    encode the state (i,v1,...,vm) *)
(*    as p1^0*...*pi^1*...*pn^0*q1^v1*...*qm^vm *)
(*    i: INC xu   ---> (qu*p(i+1) / pi) *)
(*    i: DEC xu j ---> (p(i+1) / pi*qu) and (pj / pi) (the second constraint should appear AFTER in the list) *)
Definition encode_state {n} (c : nat * vec nat n) := ps (fst c) * @exp n 0 (snd c).
Definition encode_inc n  i (u : pos n) := (ps (i + 1) * qs u, ps i).
Definition encode_dec n  i (u : pos n) (_ : nat) := (ps (i + 1), ps i * qs u).
Definition encode_dec2 n i (u : pos n) j := (ps j, ps i).
Definition encode_one_instr m i (rho : mm_instr (pos m)) :=
match rho with
| INC u   => encode_inc i u :: nil
| DEC u j => encode_dec i u j :: encode_dec2 i u j :: nil
end.
Fixpoint encode_mm_instr m i (l : list (mm_instr (pos m))) : list (nat * nat) :=
match l with
| nil          => nil
| rho :: l => encode_one_instr i rho ++ encode_mm_instr (S i) l
end.
Fact encode_mm_instr_app m i l r : @encode_mm_instr m i (l++r) = encode_mm_instr i l++encode_mm_instr (length l+i) r.
Fact encode_mm_instr_regular n i l : Forall (fun c => fst c <> 0 /\ snd c <> 0) (@encode_mm_instr n i l).
Fact encode_mm_instr_regular' n i l : fractran_regular (@encode_mm_instr n i l).
Fact encode_mm_instr_in_inv n i P el c er :
@encode_mm_instr n i P = el++c::er
-> exists l rho r, P = l++rho::r /\ In c (encode_one_instr (length l+i) rho).
Local Notation divides_mult_inv := prime_div_mult.
Local Ltac inv H := inversion H; subst; clear H.
Opaque ps qs.
Proof with eauto; try lia.
revert k. induction l; cbn - [subcode] in *; intros.
- revert H0. ring_simplify (k + 0). eauto.
- revert H0. ring_simplify (k + S (length l)). intros H1. destruct a.
+ econstructor 2. intros [[|] % divides_mult_inv | ] % divides_mult_inv; eauto.
* eapply primestream_divides in H0; lia.
* now eapply ps_qs_div in H0.
* eapply divides_encode_state in H0; lia.
* specialize IHl with (k := S k). revert IHl.
cbn - [subcode]. ring_simplify (S (k + length l)).
intros IHl. eapply IHl. 2:exact H1.
intros ? ? ?. eapply H. eapply subcode_cons. eassumption.
+ repeat econstructor 2. 2:unfold encode_dec2.
2,3: cbn- [subcode]. 1: intros [] % divides_mult_inv_l.
2: intros [ | ] % divides_mult_inv...
* eapply divides_mult_inv in H0 as [? | ?]...
eapply primestream_divides in H0...
eapply divides_encode_state in H0...
* eapply primestream_divides in H0... subst.
eapply (H n t). eauto.
* eapply divides_encode_state in H0...
* specialize (IHl (S k)). revert IHl.
cbn - [subcode]. ring_simplify (S (k + length l)).
intros IHl. eapply IHl. 2:exact H1.
intros ? ? ?. eapply H. eapply subcode_cons. eassumption.
Qed.
Proof with eauto; try lia.
intros HP (k & l & [ u | u j ] & r & v & ? & ? & ?); inversion H; subst; clear H.
- inversion H0; inversion H1; subst; clear H0 H1.
eapply skip_steps...
econstructor. cbn. ring_simplify.
replace (1 + (k + length l)) with (k + length l + 1) by lia. unfold encode_state, fst, snd.
rewrite vec_prod_mult.
rewrite Nat.add_0_r; ring.
- inversion H0; inversion H1; subst; clear H0 H1.
all:eapply skip_steps...
+ cbn. econstructor 2.
intros [] % divides_mult_inv_l...
eapply divides_mult_inv in H0 as [ | ]...
* now eapply qs_ps_div in H0.
* eapply qs_encode_state in H0. lia.
* unfold encode_dec2. econstructor. unfold encode_state, fst, snd. ring.
+ econstructor. cbn. unfold encode_state, fst, snd. ring_simplify.
replace (1 + (k + length l)) with (k + length l + 1) by lia.
erewrite <- (vec_prod_div _ _ _ H4).
rewrite Nat.add_0_r; ring.
Qed.

Lemma steps_forward m i P i1 v1 i2 v2 k :
@mm_no_self_loops m (i, P)
-> (i, P) /MM/ (i1, v1) -[k]-> (i2,v2)
-> encode_mm_instr i P /F/ encode_state (i1,v1) -[k]-> encode_state (i2,v2).