(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 9: Compiler Correctness
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap.

Set Implicit Arguments.

(* Let's look at another example of what we can model with operational
 * semantics: correctness of compiler transformations.  Our inspiration here is
 * the seminal project CompCert, which uses Coq to verify a realistic C
 * compiler.  We will adopt the same *simulation*-based techniques as CompCert,
 * albeit on a simpler language and with simpler compiler phases.  We'll stick
 * to transformations from the source language to itself, since that's enough to
 * illustrate the big ideas.  Here's the object language that we'll use, which
 * is _almost_ the same as from Chapter 7. *)

Inductive arith : Set :=
| Const (n : nat)
| Var (x : var)
| Plus (e1 e2 : arith)
| Minus (e1 e2 : arith)
| Times (e1 e2 : arith).

Inductive cmd :=
| Skip
| Assign (x : var) (e : arith)
| Sequence (c1 c2 : cmd)
| If (e : arith) (then_ else_ : cmd)
| While (e : arith) (body : cmd)
| Output (e : arith).
(* The last constructor above is the new one, for generating an _output_ value,
 * say to display in a terminal.  By including this operation, we create
 * interesting differences between the behaviors of different nonterminating
 * programs.  A correct compiler should preserve these differences. *)

(* The next span of notations and definitions is the same as from Chapter 7. *)

Coercion Const : nat >-> arith.
Coercion Var : var >-> arith.
(*Declare Scope arith_scope.*)
Infix "+" := Plus : arith_scope.
Infix "-" := Minus : arith_scope.
Infix "*" := Times : arith_scope.
Delimit Scope arith_scope with arith.
Notation "x <- e" := (Assign x e%arith) (at level 75).
Infix ";;" := Sequence (at level 76). (* This one changed slightly, to avoid parsing clashes. *)
Notation "'when' e 'then' then_ 'else' else_ 'done'" := (If e%arith then_ else_) (at level 75, e at level 0).
Notation "'while' e 'loop' body 'done'" := (While e%arith body) (at level 75).

Definition valuation := fmap var nat.
Fixpoint interp (e : arith) (v : valuation) : nat :=
  match e with
  | Const n => n
  | Var x =>
    match v $? x with
    | None => 0
    | Some n => n
    end
  | Plus e1 e2 => interp e1 v + interp e2 v
  | Minus e1 e2 => interp e1 v - interp e2 v
  | Times e1 e2 => interp e1 v * interp e2 v
  end.

Inductive context :=
| Hole
| CSeq (C : context) (c : cmd).

Inductive plug : context -> cmd -> cmd -> Prop :=
| PlugHole : forall c, plug Hole c c
| PlugSeq : forall c C c' c2,
  plug C c c'
  -> plug (CSeq C c2) c (Sequence c' c2).

(* Here's our first difference.  We add a new parameter to [step0], giving a
 * _label_ that records which _externally visible effect_ the step has.  For
 * this language, output is the only externally visible effect, so a label
 * records an optional output value.  Including this element makes our semantics
 * a _labelled transition system_. *)

Inductive step0 : valuation * cmd -> option nat -> valuation * cmd -> Prop :=
| Step0Assign : forall v x e,
  step0 (v, Assign x e) None (v $+ (x, interp e v), Skip)
| Step0Seq : forall v c2,
  step0 (v, Sequence Skip c2) None (v, c2)
| Step0IfTrue : forall v e then_ else_,
  interp e v <> 0
  -> step0 (v, If e then_ else_) None (v, then_)
| Step0IfFalse : forall v e then_ else_,
  interp e v = 0
  -> step0 (v, If e then_ else_) None (v, else_)
| Step0WhileTrue : forall v e body,
  interp e v <> 0
  -> step0 (v, While e body) None (v, Sequence body (While e body))
| Step0WhileFalse : forall v e body,
  interp e v = 0
  -> step0 (v, While e body) None (v, Skip)
| Step0Output : forall v e,
  step0 (v, Output e) (Some (interp e v)) (v, Skip).

(* It's easy to push labels through steps with context. *)
Inductive cstep : valuation * cmd -> option nat -> valuation * cmd -> Prop :=
| CStep : forall C v c l v' c' c1 c2,
  plug C c c1
  -> step0 (v, c) l (v', c')
  -> plug C c' c2
  -> cstep (v, c1) l (v', c2).

(* To characterize correct compilation, it is helpful to define a relation to
 * capture which output _traces_ a command might generate.  Note that, for us, a
 * trace is a list of output values and/or terminating markers.  We drop silent
 * labels as we run, and we use [Some n] for outputting of [n] and [None] for
 * termination. *)
Inductive generate : valuation * cmd -> list (option nat) -> Prop :=
| GenDone : forall vc,
  generate vc []
| GenSkip : forall v,
  generate (v, Skip) [None]
| GenSilent : forall vc vc' ns,
  cstep vc None vc'
  -> generate vc' ns
  -> generate vc ns
| GenOutput : forall vc n vc' ns,
  cstep vc (Some n) vc'
  -> generate vc' ns
  -> generate vc (Some n :: ns).

Hint Constructors plug step0 cstep generate : core.

(* Notice that [generate] is defined so that, for any two of a starting state's
 * traces, one is a prefix of the other.  The same wouldn't necessarily hold if
 * our language were nondeterministic. *)

(* We define trace inclusion to capture the notion of
 * _preserving all behaviors_. *)
Definition traceInclusion (vc1 vc2 : valuation * cmd) :=
  forall ns, generate vc1 ns -> generate vc2 ns.
Infix "<|" := traceInclusion (at level 70).

(* And trace equivalence captures _having the same behaviors_. *)
Definition traceEquivalence (vc1 vc2 : valuation * cmd) :=
  vc1 <| vc2 /\ vc2 <| vc1.
Infix "=|" := traceEquivalence (at level 70).

(* Trace equivalence is an appropriate notion of correctness, to relate the
 * "before" and "after" programs of a compiler transformation.  Note that here
 * we break from our usual modus operandi, as we will not be using invariants to
 * characterize correctness!  This kind of trace equivalence is one of the other
 * big concepts that competes with invariants to unify different correctness
 * notions. *)

(* Here's a simple example program, which outputs how many days have elapsed at
 * the end of each one-month period (with a simplified notion of "month"!). *)

Definition daysPerWeek := 7.
Definition weeksPerMonth := 4.
Definition daysPerMonth := (daysPerWeek * weeksPerMonth)%arith.
(* We are purposely building an expression with arithmetic that can be resolved
 * at compile time, to give our optimizations something to do. *)

Example month_boundaries_in_days :=
  "acc" <- 0;;
  while 1 loop
    when daysPerMonth then
      "acc" <- "acc" + daysPerMonth;;
      Output "acc"
    else
      (* Oh no!  We must have calculated it wrong, since we got zero! *)
      (* And, yes, we know this spot can never be reached.  Some of our
       * optimizations will prove it for us! *)
      Skip
    done
  done.

(* Moderately laboriously, we can prove a particular example trace for this
 * program, including its first two outputs.  Traces of all lengths exist,
 * because the program does not terminate, generating new output infinitely
 * often. *)

Hint Extern 1 (interp _ _ = _) => simplify; equality : core.
Hint Extern 1 (interp _ _ <> _) => simplify; equality : core.

Theorem first_few_values :
  generate ($0, month_boundaries_in_days) [Some 28; Some 56].
Proof.
  unfold month_boundaries_in_days.
  eapply GenSilent.
  eapply CStep with (C := CSeq Hole _); eauto.
  eapply GenSilent.
  eapply CStep with (C := Hole); eauto.
  eapply GenSilent.
  eapply CStep with (C := Hole); eauto.
  eapply GenSilent.
  eapply CStep with (C := CSeq Hole _); eauto.
  eapply GenSilent.
  eapply CStep with (C := CSeq (CSeq Hole _) _); eauto.
  eapply GenSilent.
  eapply CStep with (C := CSeq Hole _); eauto.
  eapply GenOutput.
  eapply CStep with (C := CSeq Hole _); eauto.
  replace 28 with (interp "acc"
    ($0 $+ ("acc", interp 0 $0)
      $+ ("acc", interp ("acc" + daysPerMonth)%arith ($0 $+ ("acc", interp 0 $0))))); eauto.
  eapply GenSilent.
  eapply CStep with (C := Hole); eauto.
  eapply GenSilent.
  eapply CStep with (C := Hole); eauto.
  eapply GenSilent.
  eapply CStep with (C := CSeq Hole _); eauto.
  eapply GenSilent.
  eapply CStep with (C := CSeq (CSeq Hole _) _); eauto.
  eapply GenSilent.
  eapply CStep with (C := CSeq Hole _); eauto.
  eapply GenOutput.
  eapply CStep with (C := CSeq Hole _); eauto.
  replace 56 with (interp "acc"
    ($0 $+ ("acc", interp 0 $0) $+ ("acc",
     interp ("acc" + daysPerMonth)%arith ($0 $+ ("acc", interp 0 $0))) $+ ("acc",
     interp ("acc" + daysPerMonth)%arith
       ($0 $+ ("acc", interp 0 $0) $+ ("acc",
        interp ("acc" + daysPerMonth)%arith ($0 $+ ("acc", interp 0 $0))))))); eauto.
  constructor.
Qed.

(** * Basic Simulation Arguments and Optimizing Expressions *)

(* Let's define an optimization that just simplifies expressions. *)

Fixpoint cfoldArith (e : arith) : arith :=
  match e with
  | Const _ => e
  | Var _ => e
  | Plus e1 e2 =>
    let e1' := cfoldArith e1 in
    let e2' := cfoldArith e2 in
    match e1', e2' with
    | Const n1, Const n2 => Const (n1 + n2)
    | _, _ => Plus e1' e2'
    end
  | Minus e1 e2 =>
    let e1' := cfoldArith e1 in
    let e2' := cfoldArith e2 in
    match e1', e2' with
    | Const n1, Const n2 => Const (n1 - n2)
    | _, _ => Minus e1' e2'
    end
  | Times e1 e2 =>
    let e1' := cfoldArith e1 in
    let e2' := cfoldArith e2 in
    match e1', e2' with
    | Const n1, Const n2 => Const (n1 * n2)
    | _, _ => Times e1' e2'
    end
  end.

Theorem cfoldArith_ok : forall v e,
    interp (cfoldArith e) v = interp e v.
Proof.
  induct e; simplify; try equality;
  repeat (match goal with
          | [ |- context[match ?E with _ => _ end] ] => cases E
          | [ H : _ = interp _ _ |- _ ] => rewrite <- H
          end; simplify); subst; ring.
Qed.

Fixpoint cfoldExprs (c : cmd) : cmd :=
  match c with
  | Skip => c
  | Assign x e => Assign x (cfoldArith e)
  | Sequence c1 c2 => Sequence (cfoldExprs c1) (cfoldExprs c2)
  | If e then_ else_ => If (cfoldArith e) (cfoldExprs then_) (cfoldExprs else_)
  | While e body => While (cfoldArith e) (cfoldExprs body)
  | Output e => Output (cfoldArith e)
  end.

(* Here's what our optimization does to the example program. *)
Compute cfoldExprs month_boundaries_in_days.

(* It's actually not obvious how to prove trace equivalence for this kind of
 * optimization, and we should be on the lookout for general principles that
 * help us avoid rehashing the same argument structure for each optimization.
 * To let us prove such principles, we first establish a few key properties of
 * the object language. *)

(* First, any program that isn't a [Skip] can make progress. *)
Theorem skip_or_step : forall v c,
    c = Skip
    \/ exists v' l c', cstep (v, c) l (v', c').
Proof.
  induct c; simplify; first_order; subst;
    try match goal with
        | [ H : cstep _ _ _ |- _ ] => invert H
        end;
    try match goal with
        | [ |- context[cstep (?v, If ?e _ _)] ] => cases (interp e v ==n 0)
        | [ |- context[cstep (?v, While ?e _)] ] => cases (interp e v ==n 0)
        end; eauto 10.
Qed.

(* Now, a set of (boring) lemmas relevant to contexts: *)

Theorem plug_function : forall C c1 c2, plug C c1 c2
  -> forall c2', plug C c1 c2'
  -> c2 = c2'.
Proof.
  induct 1; invert 1; eauto.
  apply IHplug in H5.
  equality.
Qed.

Lemma peel_cseq : forall C1 C2 c (c1 c2 : cmd),
    C1 = C2 /\ c1 = c2
    -> CSeq C1 c = CSeq C2 c /\ c1 = c2.
Proof.
  equality.
Qed.

Hint Resolve peel_cseq : core.

Lemma plug_deterministic : forall v C c1 c2, plug C c1 c2
  -> forall l vc1, step0 (v, c1) l vc1
  -> forall C' c1', plug C' c1' c2
  -> forall l' vc1', step0 (v, c1') l' vc1'
  -> C' = C /\ c1' = c1.
Proof.
  induct 1; invert 1; invert 1; invert 1; auto;
    try match goal with
        | [ H : plug _ _ _ |- _ ] => invert1 H
        end; eauto.
Qed.

(* Finally, the big theorem we are after: the [cstep] relation is
 * deterministic. *)

Lemma deterministic0 : forall vc l vc',
  step0 vc l vc'
  -> forall l' vc'', step0 vc l' vc''
                     -> l = l' /\ vc'' = vc'.
Proof.
  invert 1; invert 1; simplify; propositional.
Qed.

Theorem deterministic : forall vc l vc',
  cstep vc l vc'
  -> forall l' vc'', cstep vc l' vc''
                     -> l = l' /\ vc' = vc''.
Proof.
  invert 1; invert 1; simplify.
  eapply plug_deterministic in H0; eauto.
  invert H0.
  match goal with
  | [ H : step0 _ _ _, H' : step0 _ _ _ |- _ ] => eapply deterministic0 in H; [ | apply H' ]
  end.
  propositional; subst; auto.
  invert H0.
  auto.
  eapply plug_function in H2; eauto.
  equality.
Qed.

(* OK, we are ready for the first variant of today's big proof technique,
 * _simulation_.  The method is much like with invariants.  Recall that, in our
 * old workhorse technique, we pick a predicate over states, and we show that
 * all steps preserve it.  Simulation is very similar, but now we have a
 * two-argument predicate or _relation_ between states of two systems.  The
 * relation is a simulation when it is able to track execution in one system by
 * playing appropriate steps in the other.  For deterministic systems like ours,
 * the existence of a simulation implies trace equivalence. *)
Section simulation.
  (* Here's the kind of relation we assume. *)
  Variable R : valuation * cmd -> valuation * cmd -> Prop.

  (* Starting from two related states, when the lefthand one makes a step, the
   * righthand one can make a matching step, such that the new states are also
   * related. *)
  Hypothesis one_step : forall vc1 vc2, R vc1 vc2
    -> forall vc1' l, cstep vc1 l vc1'
      -> exists vc2', cstep vc2 l vc2' /\ R vc1' vc2'.

  (* When a righthand command is related to [Skip], it must be [Skip], too. *)
  Hypothesis agree_on_termination : forall v1 v2 c2, R (v1, Skip) (v2, c2)
    -> c2 = Skip.

  (* First (easy) step: [R] implies left-to-right trace inclusion. *)

  Lemma simulation_fwd' : forall vc1 ns, generate vc1 ns
    -> forall vc2, R vc1 vc2
      -> generate vc2 ns.
  Proof.
    induct 1; simplify; eauto.

    cases vc2.
    apply agree_on_termination in H; subst.
    auto.

    eapply one_step in H; eauto.
    first_order.
    eauto.

    eapply one_step in H1; eauto.
    first_order.
    eauto.
  Qed.

  Theorem simulation_fwd : forall vc1 vc2, R vc1 vc2
    -> vc1 <| vc2.
  Proof.
    unfold traceInclusion; eauto using simulation_fwd'.
  Qed.

  (* Second (slightly harder) step: [R] implies right-to-left trace
   * inclusion. *)

  Lemma simulation_bwd' : forall vc2 ns, generate vc2 ns
    -> forall vc1, R vc1 vc2
      -> generate vc1 ns.
  Proof.
    induct 1; simplify; eauto.

    cases vc1.
    assert (c = Skip \/ exists v' l c', cstep (v0, c) l (v', c')) by apply skip_or_step.
    first_order; subst.
    auto.
    eapply one_step in H; eauto.
    first_order.
    invert H.
    invert H4.
    invert H5.

    cases vc1; cases vc.
    assert (c = Skip \/ exists v' l c', cstep (v, c) l (v', c')) by apply skip_or_step.
    first_order; subst.
    apply agree_on_termination in H1; subst.
    invert H.
    invert H3.
    invert H4.
    specialize (one_step H1 H2).
    first_order.
    eapply deterministic in H; eauto.
    propositional; subst.
    eauto.

    cases vc1; cases vc.
    assert (c = Skip \/ exists v' l c', cstep (v, c) l (v', c')) by apply skip_or_step.
    first_order; subst.
    apply agree_on_termination in H1; subst.
    invert H.
    invert H3.
    invert H4.
    specialize (one_step H1 H2).
    first_order.
    eapply deterministic in H; eauto.
    propositional; subst.
    eauto.
  Qed.

  Theorem simulation_bwd : forall vc1 vc2, R vc1 vc2
    -> vc2 <| vc1.
  Proof.
    unfold traceInclusion; eauto using simulation_bwd'.
  Qed.

  (* Put them together and we have trace equivalence. *)

  Theorem simulation : forall vc1 vc2, R vc1 vc2
    -> vc1 =| vc2.
  Proof.
    simplify; split; auto using simulation_fwd, simulation_bwd.
  Qed.
End simulation.

(* Now to prove our particular optimization.  First, original steps can be
 * lifted into optimized steps. *)

Lemma cfoldExprs_ok' : forall v1 c1 l v2 c2,
    step0 (v1, c1) l (v2, c2)
    -> step0 (v1, cfoldExprs c1) l (v2, cfoldExprs c2).
Proof.
  invert 1; simplify;
    try match goal with
        | [ _ : context[interp ?e ?v] |- _ ] => rewrite <- (cfoldArith_ok v e) in *
        | [ |- context[interp ?e ?v] ] => rewrite <- (cfoldArith_ok v e)
        end; eauto.
Qed.

(* It helps to add optimization on contexts, as a proof device. *)
Fixpoint cfoldExprsContext (C : context) : context :=
  match C with
  | Hole => Hole
  | CSeq C c => CSeq (cfoldExprsContext C) (cfoldExprs c)
  end.

(* The optimization can be applied over [plug]. *)
Lemma plug_cfoldExprs1 : forall C c1 c2, plug C c1 c2
  -> plug (cfoldExprsContext C) (cfoldExprs c1) (cfoldExprs c2).
Proof.
  induct 1; simplify; eauto.
Qed.

Hint Resolve plug_cfoldExprs1 : core.

(* The main correctness property! *)
Theorem cfoldExprs_ok : forall v c,
    (v, c) =| (v, cfoldExprs c).
Proof.
  simplify.
  (* Notice our clever choice of a simulation relation here, much as we often
   * choose strengthened invariants.  We basically just recast the theorem
   * statement as a two-state predicate using equality. *)
  apply simulation with (R := fun vc1 vc2 => fst vc1 = fst vc2
                                             /\ snd vc2 = cfoldExprs (snd vc1));
    simplify; propositional.

  invert H0; simplify; subst.
  apply cfoldExprs_ok' in H3.
  cases vc2; simplify; subst.
  eauto 7.
Qed.

(** * Simulations That Allow Skipping Steps *)

(* Here's a reasonable variant of the last optimization: when an [If] test
 * expression reduces to a constant, replace the [If] with whichever branch is
 * guaranteed to run. *)
Fixpoint cfold (c : cmd) : cmd :=
  match c with
  | Skip => c
  | Assign x e => Assign x (cfoldArith e)
  | Sequence c1 c2 => Sequence (cfold c1) (cfold c2)
  | If e then_ else_ =>
    let e' := cfoldArith e in
    match e' with
    | Const n => if n ==n 0 then cfold else_ else cfold then_
    | _ => If e' (cfold then_) (cfold else_)
    end
  | While e body => While (cfoldArith e) (cfold body)
  | Output e => Output (cfoldArith e)
  end.

(* Here's how our running example optimizes further. *)
Compute cfold month_boundaries_in_days.

(* It will be helpful to have a shorthand for steps that don't generate output.
 * [Notation] is a useful way to introduce a shorthand so that it looks exactly
 * the same as its expansion, to all Coq tactics. *)
Notation silent_cstep := (fun a b => cstep a None b).

(* Silent steps have a few interesting properties, proved here. *)

Lemma silent_generate_fwd : forall ns vc vc',
    silent_cstep^* vc vc'
    -> generate vc ns
    -> generate vc' ns.
Proof.
  induct 1; simplify; eauto.
  invert H1; auto.

  invert H.
  invert H3.
  invert H4.

  eapply deterministic in H; eauto.
  propositional; subst.
  auto.

  eapply deterministic in H; eauto.
  equality.
Qed.

Lemma silent_generate_bwd : forall ns vc vc',
    silent_cstep^* vc vc'
    -> generate vc' ns
    -> generate vc ns.
Proof.
  induct 1; eauto.
Qed.

Lemma generate_Skip : forall v a ns,
    generate (v, Skip) (Some a :: ns)
    -> False.
Proof.
  induct 1; simplify.

  invert H.
  invert H3.
  invert H4.

  invert H.
  invert H3.
  invert H4.
Qed.

Hint Resolve silent_generate_fwd silent_generate_bwd generate_Skip : core.

(* You might have noticed that our old notion of simulation doesn't apply to the
 * new optimization.  The reason is that, because the optimized program skips
 * some steps, some steps in the source program may not have matching steps in
 * the optimized program.  Let's extend simulation to allow skipped steps. *)
Section simulation_skipping.
  (* Now the relation takes a number as an argument.  The idea is that, for
   * [R n vc1 vc2], at most [n] steps of [vc1] may go unmatched by [vc2], before
   * we finally find one that matches.  It is an interesting exercise to work
   * out why, without tracking such quantities, this notion of simulation
   * wouldn't imply trace equivalence! *)
  Variable R : nat -> valuation * cmd -> valuation * cmd -> Prop.

  (* Now this key hypothesis has two cases. *)
  Hypothesis one_step : forall n vc1 vc2, R n vc1 vc2
    -> forall vc1' l, cstep vc1 l vc1'

                         (* Case 1: Skipping a (silent!) step, decreasing [n] *)
                      -> (exists n', n = S n' /\ l = None /\ R n' vc1' vc2)

                         (* Case 2: Matching the step like before; note how [n]
                          * resets to an arbitrary new limit! *)
                         \/ exists n' vc2', cstep vc2 l vc2' /\ R n' vc1' vc2'.

  Hypothesis agree_on_termination : forall n v1 v2 c2, R n (v1, Skip) (v2, c2)
    -> c2 = Skip.

  (* The forward direction is just as easy to prove. *)

  Lemma simulation_skipping_fwd' : forall vc1 ns, generate vc1 ns
    -> forall n vc2, R n vc1 vc2
      -> generate vc2 ns.
  Proof.
    induct 1; simplify; eauto.

    cases vc2.
    apply agree_on_termination in H.
    subst.
    auto.

    eapply one_step in H; eauto.
    first_order.
    eauto.

    eapply one_step in H1; eauto.
    first_order.
    equality.
    eauto.
  Qed.

  Theorem simulation_skipping_fwd : forall n vc1 vc2, R n vc1 vc2
    -> vc1 <| vc2.
  Proof.
    unfold traceInclusion; eauto using simulation_skipping_fwd'.
  Qed.

  (* This one isn't so obvious: a step on the right can now be matched by
   * _one or more_ steps on the left, preserving [R]. *)
  Lemma match_step : forall n vc2 l vc2' vc1,
      cstep vc2 l vc2'
      -> R n vc1 vc2
      -> exists vc1' vc1'' n', silent_cstep^* vc1 vc1'
                              /\ cstep vc1' l vc1''
                              /\ R n' vc1'' vc2'.
  Proof.
    induct n; simplify.

    cases vc1; cases vc2.
    assert (c = Skip \/ exists v' l' c', cstep (v, c) l' (v', c')) by apply skip_or_step.
    first_order; subst.
    apply agree_on_termination in H0; subst.
    invert H.
    invert H2.
    invert H3.
    eapply one_step in H0; eauto.
    first_order; subst.
    equality.
    eapply deterministic in H; eauto.
    first_order; subst.
    eauto 6.

    cases vc1; cases vc2.
    assert (c = Skip \/ exists v' l' c', cstep (v, c) l' (v', c')) by apply skip_or_step.
    first_order; subst.
    apply agree_on_termination in H0; subst.
    invert H.
    invert H2.
    invert H3.
    eapply one_step in H0; eauto.
    first_order; subst.
    invert H0.
    eapply IHn in H3; eauto.
    first_order.
    eauto 8.
    eapply deterministic in H; eauto.
    first_order; subst.
    eauto 6.
  Qed.

  Lemma step_to_termination : forall vc v,
      silent_cstep^* vc (v, Skip)
      -> generate vc [None].
  Proof.
    clear; induct 1; eauto.
  Qed.

  Hint Resolve step_to_termination : core.

  Lemma R_Skip : forall n vc1 v,
      R n vc1 (v, Skip)
      -> exists v', silent_cstep^* vc1 (v', Skip).
  Proof.
    induct n; simplify.

    cases vc1.
    assert (c = Skip \/ exists v' l c', cstep (v0, c) l (v', c')) by apply skip_or_step.
    first_order; subst.
    eauto.
    eapply one_step in H; eauto.
    first_order.
    equality.
    invert H.
    invert H4.
    invert H5.

    cases vc1.
    assert (c = Skip \/ exists v' l c', cstep (v0, c) l (v', c')) by apply skip_or_step.
    first_order; subst.
    eauto.
    eapply one_step in H; eauto.
    first_order; subst.
    invert H.
    apply IHn in H2.
    first_order.
    eauto.
    invert H.
    invert H4.
    invert H5.
  Qed.

  Lemma simulation_skipping_bwd' : forall ns vc2, generate vc2 ns
    -> forall n vc1, R n vc1 vc2
      -> generate vc1 ns.
  Proof.
    induct 1; simplify; eauto.

    cases vc1.
    apply R_Skip in H; first_order.
    eauto.

    eapply match_step in H1; eauto.
    first_order.
    eauto.

    eapply match_step in H1; eauto.
    first_order.
    eauto.
  Qed.

  Theorem simulation_skipping_bwd : forall n vc1 vc2, R n vc1 vc2
    -> vc2 <| vc1.
  Proof.
    unfold traceInclusion; eauto using simulation_skipping_bwd'.
  Qed.

  Theorem simulation_skipping : forall n vc1 vc2, R n vc1 vc2
    -> vc1 =| vc2.
  Proof.
    simplify; split; eauto using simulation_skipping_fwd, simulation_skipping_bwd.
  Qed.
End simulation_skipping.

Hint Extern 1 (_ < _) => linear_arithmetic : core.
Hint Extern 1 (_ >= _) => linear_arithmetic : core.
Hint Extern 1 (_ <> _) => linear_arithmetic : core.

(* We will need to do some bookkeeping of [n] values.  This function is the
 * trick, as we only need to skip steps based on removing [If]s from the code.
 * That means the number of [If]s in a program is an upper bound on skipped
 * steps.  (It's not a tight bound, because some [If]s may be in branches that
 * are themselves removed by the optimization!) *)
Fixpoint countIfs (c : cmd) : nat :=
  match c with
  | Skip => 0
  | Assign _ _ => 0
  | Sequence c1 c2 => countIfs c1 + countIfs c2
  | If _ c1 c2 => 1 + countIfs c1 + countIfs c2
  | While _ c1 => countIfs c1
  | Output _ => 0
  end.

(* Our notion of [step0] porting must now allow some skipped steps, also showing
 * that they decrease [If] count. *)
Lemma cfold_ok' : forall v1 c1 l v2 c2,
    step0 (v1, c1) l (v2, c2)
    -> step0 (v1, cfold c1) l (v2, cfold c2)
       \/ (l = None /\ v1 = v2 /\ cfold c1 = cfold c2 /\ countIfs c2 < countIfs c1).
Proof.
  invert 1; simplify;
    try match goal with
        | [ _ : context[interp ?e ?v] |- _ ] => rewrite <- (cfoldArith_ok v e) in *
        | [ |- context[interp ?e ?v] ] => rewrite <- (cfoldArith_ok v e)
        end;
    repeat match goal with
           | [ |- context[match ?E with _ => _ end] ] => cases E; subst; simplify
           end; propositional; eauto.
Qed.

(* Now some fiddling with contexts: *)

Fixpoint cfoldContext (C : context) : context :=
  match C with
  | Hole => Hole
  | CSeq C c => CSeq (cfoldContext C) (cfold c)
  end.

Lemma plug_cfold1 : forall C c1 c2, plug C c1 c2
  -> plug (cfoldContext C) (cfold c1) (cfold c2).
Proof.
  induct 1; simplify; eauto.
Qed.

Hint Resolve plug_cfold1 : core.

Lemma plug_samefold : forall C c1 c1',
    plug C c1 c1'
    -> forall c2 c2', plug C c2 c2'
    -> cfold c1 = cfold c2
    -> cfold c1' = cfold c2'.
Proof.
  induct 1; invert 1; simplify; propositional.
  f_equal; eauto.
Qed.

Hint Resolve plug_samefold : core.

Lemma plug_countIfs : forall C c1 c1',
    plug C c1 c1'
    -> forall c2 c2', plug C c2 c2'
    -> countIfs c1 < countIfs c2
    -> countIfs c1' < countIfs c2'.
Proof.
  induct 1; invert 1; simplify; propositional.
  apply IHplug in H5; linear_arithmetic.
Qed.

Hint Resolve plug_countIfs : core.

Hint Extern 1 (interp ?e _ = _) =>
  match goal with
  | [ H : cfoldArith e = _ |- _ ] => rewrite <- cfoldArith_ok; rewrite H
  end : core.
Hint Extern 1 (interp ?e _ <> _) =>
  match goal with
  | [ H : cfoldArith e = _ |- _ ] => rewrite <- cfoldArith_ok; rewrite H
  end : core.

(* The final proof is fairly straightforward now. *)
Lemma cfold_ok : forall v c,
    (v, c) =| (v, cfold c).
Proof.
  simplify.
  (* Note the use of [countIfs] in the simulation relation. *)
  apply simulation_skipping with (R := fun n vc1 vc2 => fst vc1 = fst vc2
                                                        /\ snd vc2 = cfold (snd vc1)
                                                        /\ countIfs (snd vc1) < n)
                                   (n := S (countIfs c));
    simplify; propositional; auto.

  invert H0; simplify; subst.
  apply cfold_ok' in H4.
  propositional; subst.
  cases vc2; simplify; subst.
  eauto 11.
  cases vc2; simplify; subst.
  cases n; try linear_arithmetic.
  assert (countIfs c2 < n).
  eapply plug_countIfs in H2; eauto.
  eauto.
  eauto 10.
Qed.

(** * Simulations That Allow Taking Multiple Matching Steps *)

(* Some optimizations actually transform code toward lower-level languages.
 * Let's take the example of breaking compound expressions into step-by-step
 * computations using new temporary variables. *)

(* We'll use this function to give us an infinite supply of disjoint
 * temporaries. *)
Fixpoint tempVar (n : nat) : string :=
  match n with
  | O => "_tmp"
  | S n' => tempVar n' ++ "'"
  end%string.

Compute tempVar 0.
Compute tempVar 1.
Compute tempVar 2.

(* With that kind of temporary, we need to watch our for name clashes with
 * variables that already exist in a program.  These Boolean functions check for
 * lack of clashes.  We also prove some properties that will come in handy
 * later. *)

Definition noUnderscoreVar (x : var) : bool :=
  match x with
  | String "_" _ => false
  | _ => true
  end.

Lemma append_assoc : forall a b c,
    (a ++ (b ++ c) = (a ++ b) ++ c)%string.
Proof.
  induct a; simplify; equality.
Qed.

Lemma append_assoc_String : forall a b,
    (String a b = String a "" ++ b)%string.
Proof.
  induct b; simplify; equality.
Qed.

Lemma noUnderscoreVar_tempVar' : forall n,
    exists s, tempVar n = ("_tmp" ++ s)%string.
Proof.
  induct n; simplify; first_order.

  exists ""; auto.

  rewrite H.
  exists (x ++ "'")%string.
  repeat match goal with
         | [ |- context[String ?c ?x] ] =>
           match x with
           | "" => fail 1
           | _ => rewrite (append_assoc_String c x)
           end
         end.
  repeat rewrite append_assoc.
  reflexivity.
Qed.

Theorem noUnderscoreVar_tempVar : forall x,
    noUnderscoreVar x = true
    -> forall n, x <> tempVar n.
Proof.
  unfold not; simplify.
  subst.
  pose proof (noUnderscoreVar_tempVar' n).
  first_order.
  rewrite H0 in H.
  simplify.
  equality.
Qed.

Lemma tempVar_inj' : forall s1 s2,
    (s1 ++ "'" = s2 ++ "'")%string
    -> s1 = s2.
Proof.
  induct s1; simplify.

  cases s2; simplify; try equality.
  invert H.
  cases s2; simplify; equality.

  cases s2; simplify.
  invert H.
  cases s1; simplify; equality.
  invert H.
  f_equal; auto.
Qed.

Theorem tempVar_inj : forall n1 n2,
    tempVar n1 = tempVar n2
    -> n1 = n2.
Proof.
  induct n1; simplify; cases n2; simplify; try equality.

  repeat match goal with
         | [ _ : context[(?s ++ "'")%string] |- _ ] => cases s; simplify; try equality
         end.

  repeat match goal with
         | [ _ : context[(?s ++ "'")%string] |- _ ] => cases s; simplify; try equality
         end.

  auto using tempVar_inj'.
Qed.

Fixpoint noUnderscoreArith (e : arith) : bool :=
  match e with
  | Const _ => true
  | Var x => noUnderscoreVar x
  | Plus e1 e2
  | Minus e1 e2
  | Times e1 e2 => noUnderscoreArith e1 && noUnderscoreArith e2
  end.

Fixpoint noUnderscore (c : cmd) : bool :=
  match c with
  | Skip => true
  | Assign x e => noUnderscoreVar x && noUnderscoreArith e
  | Sequence c1 c2 => noUnderscore c1 && noUnderscore c2
  | If e then_ else_ => noUnderscoreArith e && noUnderscore then_ && noUnderscore else_
  | While e body => noUnderscoreArith e && noUnderscore body
  | Output e => noUnderscoreArith e
  end.

(* It's good to verify that our example program makes the grade. *)
Compute noUnderscore month_boundaries_in_days.

(* Now here's the optimization.  First, we flatten expressions.  The idea is
 * that argument [tempCount] gives us the index of the next temporary we should
 * use, also guaranteeing that earlier code only uses lower-numbered
 * temporaries.  Argument [dst] is a variable where we should write the result
 * of the expression.  A return value is a command that has the
 * effect of writing the value of [e] into [dst]. *)
Fixpoint flattenArith (tempCount : nat) (dst : var) (e : arith) : cmd :=
  match e with
  | Const _
  | Var _ => Assign dst e
  | Plus e1 e2 =>
    let x1 := tempVar tempCount in
    let c1 := flattenArith (S tempCount) x1 e1 in
    let x2 := tempVar (S tempCount) in
    let c2 := flattenArith (S (S tempCount)) x2 e2 in
    Sequence c1 (Sequence c2 (Assign dst (Plus x1 x2)))
  | Minus e1 e2 =>
    let x1 := tempVar tempCount in
    let c1 := flattenArith (S tempCount) x1 e1 in
    let x2 := tempVar (S tempCount) in
    let c2 := flattenArith (S (S tempCount)) x2 e2 in
    Sequence c1 (Sequence c2 (Assign dst (Minus x1 x2)))
  | Times e1 e2 =>
    let x1 := tempVar tempCount in
    let c1 := flattenArith (S tempCount) x1 e1 in
    let x2 := tempVar (S tempCount) in
    let c2 := flattenArith (S (S tempCount)) x2 e2 in
    Sequence c1 (Sequence c2 (Assign dst (Times x1 x2)))
  end.

(* For simplicity, the main optimization only flattens variables in
 * assignments. *)
Fixpoint flatten (c : cmd) : cmd :=
  match c with
  | Skip => c
  | Assign x e => flattenArith 0 x e
  | Sequence c1 c2 => Sequence (flatten c1) (flatten c2)
  | If e then_ else_ => If e (flatten then_) (flatten else_)
  | While e body => While e (flatten body)
  | Output _ => c
  end.

(* Here's what it does on our example. *)
Compute flatten month_boundaries_in_days.

(* The alert reader may noticed that, yet again, we picked a transformation that
 * our existing simulation relations can't handle directly, at least if we put
 * the original system on the left and the compiled version on the right.  Now
 * we need a single step on the left to be matched by _one or more_ steps on the
 * right. *)
Section simulation_multiple.
  (* At least we can remove that pesky numeric parameter of [R]. *)
  Variable R : valuation * cmd -> valuation * cmd -> Prop.

  Hypothesis one_step : forall vc1 vc2, R vc1 vc2
    -> forall vc1' l, cstep vc1 l vc1'
                      -> exists vc2' vc2'',
                        silent_cstep^* vc2 vc2'
                        /\ cstep vc2' l vc2''
                        /\ R vc1' vc2''.

  Hypothesis agree_on_termination : forall v1 v2 c2, R (v1, Skip) (v2, c2)
    -> c2 = Skip.

  (* The forward direction is easy, as usual. *)

  Lemma simulation_multiple_fwd' : forall vc1 ns, generate vc1 ns
    -> forall vc2, R vc1 vc2
      -> generate vc2 ns.
  Proof.
    induct 1; simplify; eauto.

    cases vc2.
    apply agree_on_termination in H; subst.
    auto.

    eapply one_step in H; eauto.
    first_order.
    eauto.

    eapply one_step in H1; eauto.
    first_order.
    eauto.
  Qed.

  Theorem simulation_multiple_fwd : forall vc1 vc2, R vc1 vc2
    -> vc1 <| vc2.
  Proof.
    unfold traceInclusion; eauto using simulation_multiple_fwd'.
  Qed.

  (* The backward proof essentially proceeds by strong induction on
   * _how many steps it took to generate a trace_, which we facilitate by
   * defining a [generate] variant parameterized by a step count. *)
  Inductive generateN : nat -> valuation * cmd -> list (option nat) -> Prop :=
  | GenDoneN : forall vc,
      generateN 0 vc []
  | GenSkupN : forall v,
      generateN 0 (v, Skip) [None]
  | GenSilentN : forall sc vc vc' ns,
      cstep vc None vc'
      -> generateN sc vc' ns
      -> generateN (S sc) vc ns
  | GenOutputN : forall sc vc n vc' ns,
      cstep vc (Some n) vc'
      -> generateN sc vc' ns
      -> generateN (S sc) vc (Some n :: ns).

  (* We won't comment on the other proof details, though they could be
   * interesting reading. *)

  Hint Constructors generateN : core.

  Lemma generateN_fwd : forall sc vc ns,
      generateN sc vc ns
      -> generate vc ns.
  Proof.
    induct 1; eauto.
  Qed.

  Hint Resolve generateN_fwd : core.

  Lemma generateN_bwd : forall vc ns,
      generate vc ns
      -> exists sc, generateN sc vc ns.
  Proof.
    induct 1; first_order; eauto.
  Qed.

  Lemma generateN_silent_cstep : forall sc vc ns,
      generateN sc vc ns
      -> forall vc', silent_cstep^* vc vc'
      -> exists sc', sc' <= sc /\ generateN sc' vc' ns.
  Proof.
    clear; induct 1; simplify; eauto.

    invert H; eauto.
    invert H0.
    invert H3.
    invert H4.

    invert H1; eauto.
    eapply deterministic in H; eauto.
    propositional; subst.
    apply IHgenerateN in H3.
    first_order.
    eauto.

    invert H1; eauto.
    eapply deterministic in H; eauto.
    equality.
  Qed.

  Lemma termination_is_last : forall sc vc ns,
      generateN sc vc (None :: ns)
      -> ns = [].
  Proof.
    induct 1; eauto.
  Qed.

  Lemma simulation_multiple_bwd' : forall sc sc', sc' < sc
    -> forall vc2 ns, generateN sc' vc2 ns
    -> forall vc1, R vc1 vc2
    -> generate vc1 ns.
  Proof.
    induct sc; simplify.

    linear_arithmetic.

    cases sc'.
    invert H0.
    auto.

    cases vc1.
    assert (c = Skip \/ exists v' l c', cstep (v0, c) l (v', c')) by apply skip_or_step.
    first_order; subst.
    auto.
    eapply one_step in H1; eauto.
    first_order.
    invert H1.
    invert H2.
    invert H5.
    invert H6.
    invert H4.
    invert H7.
    invert H8.

    cases vc1; cases vc2.
    assert (c = Skip \/ exists v' l c', cstep (v, c) l (v', c')) by apply skip_or_step.
    first_order; subst.
    apply agree_on_termination in H1; subst.
    cases ns; auto.
    cases o.
    exfalso; eauto.
    eapply termination_is_last in H0; subst.
    auto.

    eapply one_step in H1; eauto.
    first_order.
    eapply generateN_silent_cstep in H0; eauto.
    first_order.
    invert H5; auto.
    invert H3.
    invert H7.
    invert H8.
    eapply deterministic in H3; eauto.
    propositional; subst.
    econstructor.
    eauto.
    eapply IHsc; try eassumption.
    linear_arithmetic.

    eapply deterministic in H3; eauto.
    propositional; subst.
    eapply GenOutput.
    eauto.
    eapply IHsc; try eassumption.
    linear_arithmetic.
  Qed.

  Theorem simulation_multiple_bwd : forall vc1 vc2, R vc1 vc2
    -> vc2 <| vc1.
  Proof.
    unfold traceInclusion; simplify.
    apply generateN_bwd in H0.
    first_order.
    eauto using simulation_multiple_bwd'.
  Qed.

  Theorem simulation_multiple : forall vc1 vc2, R vc1 vc2
    -> vc1 =| vc2.
  Proof.
    simplify; split; auto using simulation_multiple_fwd, simulation_multiple_bwd.
  Qed.
End simulation_multiple.

(* Now, to verify our particular flattening translation.  First, one wrinkle is
 * that, by writing to new temporary variables, valuations will _not_ be exactly
 * the same across the sides of our relation.  Here is the sense in which we
 * need the sides to agree: *)
Definition agree (v v' : valuation) :=
  forall x,
    noUnderscoreVar x = true
    -> v $? x = v' $? x.
(* That is, they only need to agree on variables that aren't legal
 * temporaries. *)

(* There now follow a whole bunch of thrilling lemmas about agreement. *)

Ltac bool :=
  simplify;
  repeat match goal with
         | [ H : _ && _ = true |- _ ] => apply andb_true_iff in H; propositional
         end.

Lemma interp_agree : forall v v', agree v v'
  -> forall e, noUnderscoreArith e = true
  -> interp e v = interp e v'.
Proof.
  induct e; bool; try equality.

  unfold agree in H.
  specialize (H _ H0).
  rewrite H.
  equality.
Qed.

Lemma agree_add : forall v v' x n,
    agree v v'
    -> agree (v $+ (x, n)) (v' $+ (x, n)).
Proof.
  unfold agree; simplify.
  apply H in H0.
  cases (x ==v x0); simplify; auto.
Qed.

Lemma agree_add_tempVar_fwd : forall v v' n nv,
    agree v v'
    -> agree (v $+ (tempVar n, nv)) v'.
Proof.
  unfold agree; simplify.
  cases (x ==v tempVar n); simplify; subst; auto.
  eapply noUnderscoreVar_tempVar in H0.
  propositional.
Qed.

Lemma agree_add_tempVar_bwd : forall v v' n nv,
    agree (v $+ (tempVar n, nv)) v'
    -> agree v v'.
Proof.
  unfold agree; simplify.
  specialize (H _ H0).
  cases (x ==v tempVar n); simplify; subst; auto.
  eapply noUnderscoreVar_tempVar in H0.
  propositional.
Qed.

Lemma agree_add_tempVar_bwd_prime : forall v v' n nv,
    agree (v $+ (tempVar n ++ "'", nv)%string) v'
    -> agree v v'.
Proof.
  simplify.
  change (tempVar n ++ "'")%string with (tempVar (S n)) in *.
  eauto using agree_add_tempVar_bwd.
Qed.

Lemma agree_refl : forall v,
    agree v v.
Proof.
  first_order.
Qed.

Hint Resolve agree_add agree_add_tempVar_fwd agree_add_tempVar_bwd agree_add_tempVar_bwd_prime agree_refl : core.

(* And here are two more unremarkable lemmas. *)

Lemma silent_csteps_front : forall c v1 v2 c1 c2,
    silent_cstep^* (v1, c1) (v2, c2)
    -> silent_cstep^* (v1, c1;; c) (v2, c2;; c).
Proof.
  induct 1; eauto.
  invert H.
  eauto 6.
Qed.

Hint Resolve silent_csteps_front : core.

Lemma tempVar_contra : forall n1 n2,
    tempVar n1 = tempVar n2
    -> n1 <> n2
    -> False.
Proof.
  pose proof tempVar_inj.
  first_order.
Qed.

Hint Resolve tempVar_contra : core.

Lemma self_prime_contra : forall s,
    (s ++ "'")%string = s -> False.
Proof.
  induct s; simplify; equality.
Qed.

Hint Resolve self_prime_contra : core.

(* We've now proved all properties of [tempVar] that we need, so let's ask Coq
 * not to reduce applications of it anymore, to keep goals simpler. *)
Opaque tempVar.

(* This is our workhorse lemma, establishing correct compilation of assignments
 * with [flattenArith]. *)
Lemma flatten_Assign : forall e dst tempCount,
  noUnderscoreArith e = true
  (* We compile an expression [e] with no variable clashes. *)

  -> (forall n, n >= tempCount -> dst <> tempVar n)
  (* Our destination variable [dst] is distinct from any temporary that we give
   * [flattenArith] permission to use. *)

  -> forall v1 v2, agree v1 v2
  (* The valuations on the two sides agree on non-temporaries. *)

  (* THEN we conclude existence of further values, such that *)
  -> exists v c v2',
    silent_cstep^* (v2, flattenArith tempCount dst e) (v, c)
    (* The compiled program steps silently to an intermediate state. *)

    /\ cstep (v, c) None (v2', Skip)
    (* Next, it runs one final silent step (arithmetic never outputs). *)

    /\ agree (v1 $+ (dst, interp e v1)) v2'
    (* The place we end up agrees with the original lefthand valuation, with the
     * destination updated with the requested value. *)

    /\ v2' $? dst = Some (interp e v1)
    (* The destination has had the right value set.  (This isn't redundant with
     * the last fact because the destination might be a temporary, in which case
     * [agree] ignores it.) *)

    /\ (forall n, n < tempCount -> dst <> tempVar n -> v2' $? tempVar n = v2 $? tempVar n)
    (* We have not touched any temporaries both less than [tempCount] and not
     * equal to the destination *).
Proof.
  induct e; bool.

  do 3 eexists.
  split.
  auto.
  split.
  eauto.
  split.
  eauto.
  propositional; auto.
  simplify; auto.
  simplify.
  cases (dst ==v tempVar n0); simplify; subst; auto.

  do 3 eexists.
  split.
  auto.
  split.
  eauto.
  split.
  eauto.
  propositional; auto.
  simplify.
  unfold agree in H1.
  apply H1 in H.
  rewrite H.
  eauto.
  simplify.
  unfold agree in H1.
  apply H1 in H.
  rewrite H.
  split.
  equality.
  simplify.
  equality.

  eapply IHe1 with (dst := tempVar tempCount) (tempCount := S tempCount) in H1; eauto; clear IHe1.
  first_order.
  eapply IHe2 with (dst := tempVar (S tempCount)) (tempCount := S (S tempCount)) in H4; eauto; clear IHe2.
  first_order.
  eexists; exists (dst <- tempVar tempCount + tempVar (S tempCount)); eexists.
  split.
  apply trc_trans with (y := (x2, x3;; dst <- tempVar tempCount + tempVar (S tempCount))).
  apply trc_trans with (y := (x1, flattenArith (S (S tempCount)) (tempVar (S tempCount)) e2;; dst <- tempVar tempCount + tempVar (S tempCount))).
  eauto 7 using trc_trans.
  eauto 7 using trc_trans.
  eauto 7 using trc_trans.
  split.
  eauto.
  split.
  simplify.
  rewrite H9.
  rewrite H10 by eauto.
  rewrite H5.
  erewrite interp_agree with (v := v1 $+ (tempVar tempCount, interp e1 v1)) (v' := v1) by eauto.
  eauto.
  simplify.
  propositional.
  rewrite H9.
  rewrite H10 by eauto.
  rewrite H5.
  erewrite interp_agree with (v := v1 $+ (tempVar tempCount, interp e1 v1)) (v' := v1) by eauto.
  auto.
  simplify.
  rewrite H10 by eauto.
  eauto.

  (* Apologies for the copy-and-paste between the binary-operator cases! *)
  eapply IHe1 with (dst := tempVar tempCount) (tempCount := S tempCount) in H1; eauto; clear IHe1.
  first_order.
  eapply IHe2 with (dst := tempVar (S tempCount)) (tempCount := S (S tempCount)) in H4; eauto; clear IHe2.
  first_order.
  eexists; exists (dst <- tempVar tempCount - tempVar (S tempCount)); eexists.
  split.
  apply trc_trans with (y := (x2, x3;; dst <- tempVar tempCount - tempVar (S tempCount))).
  apply trc_trans with (y := (x1, flattenArith (S (S tempCount)) (tempVar (S tempCount)) e2;; dst <- tempVar tempCount - tempVar (S tempCount))).
  eauto 7 using trc_trans.
  eauto 7 using trc_trans.
  eauto 7 using trc_trans.
  split.
  eauto.
  split.
  simplify.
  rewrite H9.
  rewrite H10 by eauto.
  rewrite H5.
  erewrite interp_agree with (v := v1 $+ (tempVar tempCount, interp e1 v1)) (v' := v1) by eauto.
  eauto.
  simplify.
  propositional.
  rewrite H9.
  rewrite H10 by eauto.
  rewrite H5.
  erewrite interp_agree with (v := v1 $+ (tempVar tempCount, interp e1 v1)) (v' := v1) by eauto.
  auto.
  simplify.
  rewrite H10 by eauto.
  eauto.

  eapply IHe1 with (dst := tempVar tempCount) (tempCount := S tempCount) in H1; eauto; clear IHe1.
  first_order.
  eapply IHe2 with (dst := tempVar (S tempCount)) (tempCount := S (S tempCount)) in H4; eauto; clear IHe2.
  first_order.
  eexists; exists (dst <- tempVar tempCount * tempVar (S tempCount)); eexists.
  split.
  apply trc_trans with (y := (x2, x3;; dst <- tempVar tempCount * tempVar (S tempCount))).
  apply trc_trans with (y := (x1, flattenArith (S (S tempCount)) (tempVar (S tempCount)) e2;; dst <- tempVar tempCount * tempVar (S tempCount))).
  eauto 7 using trc_trans.
  eauto 7 using trc_trans.
  eauto 7 using trc_trans.
  split.
  eauto.
  split.
  simplify.
  rewrite H9.
  rewrite H10 by eauto.
  rewrite H5.
  erewrite interp_agree with (v := v1 $+ (tempVar tempCount, interp e1 v1)) (v' := v1) by eauto.
  eauto.
  simplify.
  propositional.
  rewrite H9.
  rewrite H10 by eauto.
  rewrite H5.
  erewrite interp_agree with (v := v1 $+ (tempVar tempCount, interp e1 v1)) (v' := v1) by eauto.
  auto.
  simplify.
  rewrite H10 by eauto.
  eauto.
Qed.

(* Now our reasoning can be fit within a general theorem about [step0].  Note
 * how the conclusions use [cstep] instead of [step0], to accommodate steps
 * within the structure of a term in the [Assign] case. *)
Lemma flatten_ok' : forall v1 c1 l v2 c2,
    step0 (v1, c1) l (v2, c2)
    -> noUnderscore c1 = true
    -> forall v1', agree v1 v1'
    -> exists v c v2', silent_cstep^* (v1', flatten c1) (v, c)
                       /\ cstep (v, c) l (v2', flatten c2)
                       /\ agree v2 v2'.
Proof.
  invert 1; simplify; bool;
    repeat erewrite interp_agree in * by eassumption; eauto 10.

  assert (Hnu : noUnderscoreArith e = true) by assumption.
  eapply flatten_Assign with (tempCount := 0) (dst := x) in Hnu; try eassumption.
  first_order.
  do 3 eexists.
  split.
  eassumption.
  split.
  eassumption.
  erewrite <- interp_agree; eauto.
  simplify.
  eauto using noUnderscoreVar_tempVar.
Qed.

(* Now, some thrilling lemmas about underscores and plugging! *)

Lemma noUnderscore_plug : forall C c0 c1,
    plug C c0 c1
    -> noUnderscore c1 = true
    -> noUnderscore c0 = true.
Proof.
  induct 1; bool; auto.
Qed.

Hint Immediate noUnderscore_plug : core.

Lemma silent_csteps_plug : forall C c1 c1',
    plug C c1 c1'
    -> forall v1 v2 c2 c2', plug C c2 c2'
    -> silent_cstep^* (v1, c1) (v2, c2)
    -> silent_cstep^* (v1, c1') (v2, c2').
Proof.
  induct 1; invert 1; eauto.
Qed.

Hint Resolve silent_csteps_plug : core.

Fixpoint flattenContext (C : context) : context :=
  match C with
  | Hole => Hole
  | CSeq C c => CSeq (flattenContext C) (flatten c)
  end.

Lemma plug_flatten : forall C c1 c2, plug C c1 c2
  -> plug (flattenContext C) (flatten c1) (flatten c2).
Proof.
  induct 1; simplify; eauto.
Qed.

Hint Resolve plug_flatten : core.

Lemma plug_total : forall c C, exists c', plug C c c'.
Proof.
  induct C; first_order; eauto.
Qed.

Lemma plug_cstep : forall C c1 c1', plug C c1 c1'
  -> forall c2 c2', plug C c2 c2'
  -> forall v l v', cstep (v, c1) l (v', c2)
                    -> cstep (v, c1') l (v', c2').
Proof.
  induct 1; invert 1; first_order; eauto.
  eapply IHplug in H0; eauto.
  first_order.
  invert H0.
  eauto.
Qed.

Hint Resolve plug_cstep : core.

Lemma step0_noUnderscore : forall v c l v' c',
    step0 (v, c) l (v', c')
    -> noUnderscore c = true
    -> noUnderscore c' = true.
Proof.
  invert 1; bool; auto.
  rewrite H0, H1.
  reflexivity.
Qed.

Hint Resolve step0_noUnderscore : core.

Fixpoint noUnderscoreContext (C : context) : bool :=
  match C with
  | Hole => true
  | CSeq C' c => noUnderscoreContext C' && noUnderscore c
  end.

Lemma noUnderscore_plug_context : forall C c0 c1,
    plug C c0 c1
    -> noUnderscore c1 = true
    -> noUnderscoreContext C = true.
Proof.
  induct 1; bool; auto.
  rewrite H0, H2; reflexivity.
Qed.

Lemma noUnderscore_plug_fwd : forall C c0 c1,
    plug C c0 c1
    -> noUnderscoreContext C = true
    -> noUnderscore c0 = true
    -> noUnderscore c1 = true.
Proof.
  induct 1; bool; auto.
  rewrite H4, H3; reflexivity.
Qed.

Hint Resolve noUnderscore_plug_context noUnderscore_plug_fwd : core.

(* Finally, the main correctness theorem. *)
Lemma flatten_ok : forall v c,
    noUnderscore c = true
    -> (v, c) =| (v, flatten c).
Proof.
  simplify.
  (* Note that our simulation relation remembers lack of underscores, and it
   * enforces mere agreement between valuations, rather than full equality. *)
  apply simulation_multiple with (R := fun vc1 vc2 => noUnderscore (snd vc1) = true
                                                      /\ agree (fst vc1) (fst vc2)
                                                      /\ snd vc2 = flatten (snd vc1));
    simplify; propositional; eauto.

  invert H1; simplify; subst.
  assert (noUnderscore c2 = true) by eauto 4.
  eapply flatten_ok' in H5; eauto 4.
  first_order.
  cases vc2; simplify; subst.
  pose proof (plug_total x0 (flattenContext C)).
  first_order.
  do 2 eexists.
  split.
  eapply silent_csteps_plug; try apply H4; eauto.
  eauto 6.
Qed.


Require Import Coq.Lists.List.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Tactics.BreakMatch.

Module List.
  Section IndexOf.
    Context {A} (f : A -> bool).
    Fixpoint indexof (l : list A) : option nat :=
      match l with
      | nil => None
      | cons a l =>
          if f a then Some 0
          else option_map S (indexof l )
      end.
    Lemma indexof_Some l i (H : indexof l = Some i) :
      exists a, nth_error l i = Some a /\ f a = true.
    Proof using Type.
      revert dependent i; induction l; cbn in *; try congruence; [].
      destruct (f a) eqn:?; cbn.
      { inversion 1; subst. eexists. split. exact eq_refl. eassumption. }
      { cbv [option_map]; destruct (indexof l) eqn:?; inversion 1; subst; eauto. }
    Qed.

    Lemma indexof_None l (H : indexof l = None) :
      forall i a, nth_error l i = Some a -> f a = false.
    Proof using Type.
      induction l, i.
      all: repeat first [ reflexivity
                        | progress cbn in *
                        | progress cbv [option_map] in *
                        | progress intros
                        | progress inversion_option
                        | progress subst
                        | progress break_innermost_match_hyps
                        | solve [ eauto ] ].
    Qed.

    Lemma indexof_app l1 l2
      : indexof (l1 ++ l2) = Option.sequence (indexof l1) (option_map (fun x => List.length l1 + x) (indexof l2)).
    Proof using Type.
      revert l2; induction l1 as [|x xs IH]; cbn; intros; [ | rewrite IH ].
      all: cbv [option_map Option.sequence]; break_innermost_match; reflexivity.
    Qed.
  End IndexOf.
End List.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Infinite streams                                                        *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
Require Import LibTactics LibLogic LibInt LibList LibRelation LibWf.

(* ********************************************************************** *)
(** * Construction of streams *)

(* ---------------------------------------------------------------------- *)
(** ** Definition *)

CoInductive stream (A:Type) :=
  | stream_intro : A -> stream A -> stream A.

Notation "x ::: s" := (stream_intro x s) (at level 35).

(* ---------------------------------------------------------------------- *)
(** ** Projections *)

Definition stream_head A (s:stream A) :=
  let '(x:::s') := s in x.

Definition stream_tail A (s:stream A) :=
  let '(x:::s') := s in s'.

(* ---------------------------------------------------------------------- *)
(** ** Basic operations *)

(** Constant stream *)

CoFixpoint const A (x:A) : stream A :=
  x:::(const x).

(** List obtained by cutting a stream at length [n] *)

Fixpoint take A (n:nat) (s:stream A) : list A :=
  match n with
  | O => nil
  | S n' => let '(x:::s') := s in x::(take n' s')
  end.

(** Mapping of a function on values from a stream *)

CoFixpoint map A B (f:A->B) (s:stream A) : stream B :=
  let '(x:::s') := s in f x ::: (map f s').

(** N-th element of a stream *)

Fixpoint nth A (n:nat) (s:stream A) : A :=
  let '(x:::s') := s in
  match n with
  | O => x
  | S n' => nth n' s'
  end.

(** Streams are inhabited *)

Instance stream_inhab : forall `{Inhab A}, Inhab (stream A).
Proof. intros. apply (prove_Inhab (const arbitrary)). Qed.

(* ---------------------------------------------------------------------- *)
(** ** Diagonal stream *)

(** Diagonal stream constructed from a sequence of streams *)

CoFixpoint diagonal A (u:nat->stream A) (n:nat) : stream A :=
  (nth n (u n)):::(diagonal u (S n)).

(** Description of the [n]-th element of a diagonal stream *)

Lemma stream_diagonal_nth : forall A (u:nat->stream A) n k,
  nth n (diagonal u k) = nth ((n+k)%nat) (u (n+k)%nat).
Proof.
  intros. gen k. induction n; intros.
  simple~.
  math_rewrite ((S n + k)%nat = (n + (S k))%nat). rewrite~ <- IHn.
Qed.

(* ********************************************************************** *)
(** * Bisimilarity *)

(* ---------------------------------------------------------------------- *)
(** ** Definition of bisimilarity *)

(** Bisimilarity modulo [E] *)

CoInductive bisimilar_mod (A:Type) (E:binary A) : binary (stream A) :=
  | bisimilar_mod_intro : forall x1 x2 s1 s2,
      E x1 x2 ->
      bisimilar_mod E s1 s2 ->
      bisimilar_mod E (x1:::s1) (x2:::s2).

(** Bisimilarity modulo Leibnitz *)

Definition bisimilar (A:Type) := bisimilar_mod (@eq A).

Notation "x === y" := (bisimilar x y) (at level 68).

(** Bisimilarity is an equivalence *)

Lemma bisimilar_mod_equiv : forall A (E:binary A),
  equiv E -> equiv (bisimilar_mod E).
Proof.
  introv Equiv. constructor.
  unfolds. cofix IH. destruct x. constructor*.
  unfolds. cofix IH. destruct x; destruct y; introv M.
   inversions M. constructor*.
  unfolds. cofix IH. destruct x; destruct y; destruct z; introv M1 M2.
   inversions M1. inversions M2. constructor*.
Qed.

Lemma bisimilar_equiv : forall A,
  equiv (@bisimilar A).
Proof. intros. apply~ bisimilar_mod_equiv. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Bisimilarity up to a given index *)

(** Bisimilarity modulo [E] up to index [n] *)

Definition bisimilar_mod_upto A (E:binary A) n s1 s2 :=
  list_equiv E (take n s1) (take n s2).

Section Bisimilar.
Hint Unfold list_equiv.
Hint Constructors Forall2.

(** This relation is an equivalence *)

Lemma bisimilar_mod_upto_equiv : forall A (E:binary A) n,
  equiv E -> equiv (bisimilar_mod_upto E n).
Proof.
  introv Equiv. unfold bisimilar_mod_upto.
  lets: (list_equiv_equiv Equiv). constructor; unfolds*.
Qed.

(** Bisimilarity implies bisimilarity at any index *)

Lemma bisimilar_mod_to_upto : forall A (E:binary A) n s1 s2,
  bisimilar_mod E s1 s2 -> bisimilar_mod_upto E n s1 s2.
Proof.
  unfold bisimilar_mod_upto.
  induction n; introv H. simple~.
  destruct s1; destruct s2; simpls. inversions H. constructor~. apply~ IHn.
Qed.

(** Bisimilarity at any index imply bisimilarity *)

Lemma bisimilar_mod_take : forall A (E:binary A) s1 s2,
  (forall i, list_equiv E (take i s1) (take i s2)) ->
  bisimilar_mod E s1 s2.
Proof.
  intros A E. cofix IH. intros.
  destruct s1 as [x1 s1]. destruct s2 as [x2 s2]. constructor.
    lets_inverts (H 1%nat). auto.
    apply IH. intros i. lets_inverts (H (S i)). auto.
Qed.

(** Bisimilarity up to index zero always holds *)

Lemma bisimilar_mod_upto_zero : forall A (E:binary A) s1 s2,
  bisimilar_mod_upto E 0%nat s1 s2.
Proof. intros; hnf; simple~. Qed.

(** Bisimilarity up to [S n] from bisimilarity up to [n]
    and equality between n-th elements *)

Lemma bisimilar_mod_upto_succ : forall A (E:binary A) n s1 s2,
  equiv E ->
  bisimilar_mod_upto E n s1 s2 ->
  nth n s1 = nth n s2 ->
  bisimilar_mod_upto E (S n) s1 s2.
Proof.
  introv Equiv Bis Equ. unfolds bisimilar_mod_upto.
  gen s1 s2. induction n; intros; destruct s1; destruct s2.
  simpls. subst. constructor*.
  set_eq m: (S n). simpls.
  inversions Bis. constructor~. apply~ IHn.
Qed.

End Bisimilar.

Hint Resolve bisimilar_mod_upto_equiv.
Hint Resolve bisimilar_mod_upto_zero.

(* ********************************************************************** *)
(** * Properties of streams *)

(** [eventually P s] holds if [s] contains a value satisfying [P] *)

Inductive eventually A (P:A->Prop) : stream A -> Prop :=
  | eventually_head : forall x s,
      P x -> eventually P (x:::s)
  | eventually_tail : forall x s,
      eventually P s -> eventually P (x:::s).

(** [always P s] holds if every substream of [s] satisfies [P] *)

CoInductive always A (P:stream A -> Prop) : stream A -> Prop :=
  | always_intro : forall s x,
      always P s -> P (x:::s) -> always P (x:::s).

(** [infinitely_often P s] holds if the stream [s] contains
    infinitely many values satisfying [P] *)

Definition infinitely_often A (P:A->Prop) :=
  always (eventually P).

(** [first_st P s n] holds if the first element of [s] satisfying
    [P] is found at index [n] *)

Fixpoint first_st_at A (P:A->Prop) (s:stream A) (n:nat) :=
  let '(x:::s') := s in
  match n with
  | O => P x
  | S n' => ~ P x /\ first_st_at P s' n'
  end.

(** [first_st] is a functional relation; there is at most
    one index [n] such that [first_st_at P s n] holds *)

Lemma first_st_at_unique : forall n1 n2 A (P:A->Prop) s,
  first_st_at P s n1 -> first_st_at P s n2 -> n1 = n2.
Proof.
  induction n1; destruct n2; destruct s; simpl; introv H1 H2.
  auto. destruct H2. false. destruct H1. false.
  destruct H1. destruct H2. fequals. apply* IHn1.
Qed.

Implicit Arguments first_st_at_unique [n1 n2 A P s].


(* Check that problems with several solutions are solved in 8.4 as in 8.2 and 8.3 *)

Inductive Fin: nat -> Set :=
| first k : Fin (S k)
| succ k: Fin k -> Fin (S k).

Lemma match_sym_eq_eq: forall (n1 n2: nat)(f: Fin n1)(e: n1 = n2),
f = match sym_eq e in (_ = l) return (Fin l) with refl_equal =>
    match e in (_ = l) return (Fin l) with refl_equal => f end end.
Proof.
  intros n1 n2 f e.
  (* Next line has a dependent and a non dependent solution *)
  (* 8.2 and 8.3 used to choose the dependent one which is the one to make *)
  (* the goal progress *)
  refine (match e return _ with refl_equal => _ end).
  reflexivity.
  Undo 2.
  (** Check insensitivity to alphabetic order *)
  refine (match e as a in _ = b return _ with refl_equal => _ end).
  reflexivity.
  Undo 2.
  (** Check insensitivity to alphabetic order *)
  refine (match e as z in _ = y return _ with refl_equal => _ end).
  reflexivity.
  Undo 2.
  (* Next line similarly has a dependent and a non dependent solution *)
  refine (match e with refl_equal => _ end).
  reflexivity.
Qed.


(* Diophantus20.v *)

(****************************)
(* Diophantus' 20th problem *)
(****************************)

Require Export Descent.
Require Export Pythagorean.

(*************************)
(* Some auxiliary lemmas *)
(*************************)

Lemma multiple4_2: forall u v : Z,
  Zodd v -> Zodd u -> v <= u -> rel_prime u v -> 1 < u -> 1 < v ->
  exists two : Z * Z,
    let (s, w) := two in
    (u - v = 4 * s /\ u + v = 2 * w \/
     u - v = 2 * w /\ u + v = 4 * s) /\ 0 < s /\ 0 < w /\ rel_prime s w.
Proof.
  intros; elim (Zodd_mult u v H0 H); intros; elim H5; clear H5; intros;
    elim_hyps; split with (x,x0); intuition; cut (u <> 1); auto with zarith;
    intro; cut (u <> -1); auto with zarith; intro.
  apply (Zmult_lt_0_reg_r 4 x); auto with zarith; rewrite Zmult_comm;
    rewrite <- H5; generalize (relp_neq _ _ H7 H8 H2); auto with zarith.
  apply (gcd2_rel_prime (u - v) (u + v) x x0); auto; apply gcd2_relp_odd; auto.
  apply (Zmult_lt_0_reg_r 2 x0); auto with zarith; rewrite Zmult_comm;
    rewrite <- H5; generalize (relp_neq _ _ H7 H8 H2); auto with zarith.
  apply (gcd2_rel_prime (u + v) (u - v) x x0); auto; apply Zis_gcd_sym;
    apply gcd2_relp_odd; auto.
Qed.

Lemma for_exists_ab : forall u v m n : Z,
  v <= u -> u * u = m * m + n * n -> v * v = n * n - m * m -> 1 < u -> 1 < v ->
  Zodd v -> Zodd u -> rel_prime u v ->
  exists two : Z * Z,
    let (a, b) := two in
    (u - v = 4 * (a * a) /\ u + v = 2 * (b * b) \/
     u - v = 2 * (b * b) /\ u + v = 4 * (a * a)) /\ 0 < a /\ 0 < b.
Proof.
  intros u v m n Huv H H0 H1 H2 H3 H4 H5;
    elim (multiple4_2 u v H3 H4 Huv H5 H1 H2); intro; elim x; intros;
    elim_hyps; (cut (is_sqr (a * b));
      [ intro Hab; elim (prop4 a b (Zlt_le_weak 0 a H7) (Zlt_le_weak 0 b H8) H9
        Hab); intros; elim H11; intros Ha H11'; elim H11'; clear H11';
        intros a0 H11'; elim H11'; clear H11'; intros H11' Ha0; elim H12;
        intros Hb H12'; elim H12'; clear H12'; intros b0 H12'; elim H12';
        clear H12'; intros H12' Hb0; split with (a0,b0); intuition;
          [ rewrite <- H11' in H7; generalize (sqr_poss a0 H7); intro;
            auto with zarith
          | rewrite <- H12' in H8; generalize (sqr_poss b0 H8); intro;
            auto with zarith ]
      | apply (is_sqr_compat 2); try discriminate;
        replace (2 * 2 * (a * b)) with (m * m);
          [ apply is_sqr_sqr
          | apply (Zmult_eq_reg_l 2); try discriminate;
            replace (2 * (m * m)) with ((u * u) - (v * v));
              [ replace (u * u - v * v) with ((u - v) * (u + v));
                [ rewrite H6; rewrite H10; ring | ring ]
              | replace (2 * (m * m)) with ((m * m + n * n) - (n * n - m * m));
                [ rewrite H; rewrite H0; ring | ring ] ] ] ]).
Qed.

(***********************)
(* Diophantus' problem *)
(***********************)

Lemma for_mba_pytha1: forall m n u v a b : Z,
  u * u = m * m + n * n -> v * v = n * n - m * m -> u - v = 4 * (a * a) ->
  u + v = 2 * (b * b) -> b * b * (b * b) + 2 * (a * a) * (2 * (a * a)) = n * n.
Proof.
  intros; cut (2 * n * n = u * u + v * v).
  intro; cut (u = 2 * a * a + b * b).
  intro; cut (v = b * b - 2 * a * a).
  intro; rewrite H4 in H3; rewrite H5 in H3; symmetry;
    apply (Zmult_eq_reg_l 2).
  replace (2 * (n * n)) with (2 * n * n); [ rewrite H3; ring | ring ].
  discriminate.
  apply (Zmult_eq_reg_l 2).
  replace (2 * v) with (u + v - (u - v));
    [ rewrite H2; rewrite H1; ring | ring ].
  discriminate.
  apply (Zmult_eq_reg_l 2).
  replace (2 * u) with (u + v + (u - v));
    [ rewrite H2; rewrite H1; ring | ring ].
  discriminate.
  replace (2 * n * n) with (m * m + n * n + (n * n - m * m));
    [ rewrite H; rewrite H0; ring | ring ].
Qed.

Lemma for_mba_pytha2: forall m n u v a b : Z,
  u * u = m * m + n * n -> v * v = n * n - m * m -> u - v = 2 * (b * b) ->
  u + v = 4 * (a * a) -> b * b * (b * b) + 2 * (a * a) * (2 * (a * a)) = n * n.
Proof.
  intros; cut (2 * n * n = u * u + v * v).
  intro; cut (u = 2 * a * a + b * b).
  intro; cut (v = 2 * a * a - b * b).
  intro; rewrite H4 in H3; rewrite H5 in H3; symmetry;
    apply (Zmult_eq_reg_l 2).
  replace (2 * (n * n)) with (2 * n * n); [ rewrite H3; ring | ring ].
  discriminate.
  apply (Zmult_eq_reg_l 2).
  replace (2 * v) with (u + v - (u - v));
    [ rewrite H2; rewrite H1; ring | ring ].
  discriminate.
  apply (Zmult_eq_reg_l 2).
  replace (2 * u) with (u + v + (u - v));
    [ rewrite H2; rewrite H1; ring | ring ].
  discriminate.
  replace (2 * n * n) with (m * m + n * n + (n * n - m * m));
    [ rewrite H; rewrite H0; ring | ring ].
Qed.

Lemma diophantus20_equiv: forall y z : Z,
  y > 0 -> z > 0 -> y <= z -> rel_prime y z -> distinct_parity y z ->
  ~ is_sqr ((z * z + y * y) * (z * z - y * y)).
Proof.
  intros y z Hy Hz H' H0' H1' H2'; generalize (infinite_descent
    (fun p q : Z => 0 < p /\ 0 < q /\ p <= q /\ rel_prime p q /\
     distinct_parity p q /\ is_sqr (p * (q * (q * q - p * p))))).
  intro H3; cut (forall x1 x2 : Z, 0 <= x1 -> 0 <= x2 -> 0 < x1 /\ 0 < x2 /\
    x1 <= x2 /\ rel_prime x1 x2 /\ distinct_parity x1 x2 /\
    is_sqr (x1 * (x2 * (x2 * x2 - x1 * x1))) ->
    exists y1 : Z, exists y2 : Z, 0 <= y1 /\ 0 <= y2 /\ y1 + y2 < x1 + x2 /\
      0 < y1 /\ 0 < y2 /\ y1 <= y2 /\ rel_prime y1 y2 /\
      distinct_parity y1 y2 /\ is_sqr (y1 * (y2 * (y2 * y2 - y1 * y1)))).
  intro H4; apply (H3 H4) with (y * y) (z * z);
    try (apply Zge_le; apply sqr_pos).
  intuition; try (apply Zgt_lt; apply sqr_spos; auto with zarith).
  cut (y >= 0); auto with zarith.
  apply (prop2 y z H0').
  apply (distp_sqr1 _ _ H1').
  apply is_sqr_mult.
  apply is_sqr_sqr.
  apply is_sqr_mult.
  apply is_sqr_sqr.
  replace (z * z * (z * z) - y * y * (y * y)) with
    ((z * z + y * y) * (z * z - y * y)); [assumption | ring ].
  clear H3; intros p q Hp Hq H; elim H; clear H; intros H0p H; elim H; clear H;
    intros H0q H; elim H; clear H; intros H H0; elim H0; clear H0;
    intros H0 H1; elim H1; clear H1; intros H1 H2.
  elim (prop4b _ _ Hp Hq H H0 H2); intros H3 H4; elim H4; clear H4;
    intros H4 H5; elim H3; intros Hpp H3p; elim H3p; intros m H3'; elim H4;
    intros Hqq H4q; elim H4q; intros n H4'; elim H5; intros Hpq2 H5pq;
    elim H5pq; intros r H5'; elim H3'; clear H3'; intros H3' Hm; elim H4';
    clear H4'; intros H4' Hn; elim H5'; clear H5'; intros H5' Hr;
    generalize H5'; rewrite <- H3'; rewrite <- H4';
    replace (n * n * (n * n) - m * m * (m * m)) with
    ((m * m + n * n) * (n * n - m * m)).
  intro; elim (distp_odd _ _ H1); rewrite <- H3'; rewrite <- H4'; intros;
    symmetry in H3'; symmetry in H4'; cut (rel_prime (m * m) (n * n));
    try (rewrite <- H3'; rewrite <- H4'; assumption); intro;
    generalize (prop3 _ _ H8); clear H8; intro; generalize (prop1 _ _ H0 H1);
    rewrite H3'; rewrite H4'.
  intro; rewrite <- H5' in H5; rewrite H5'0 in H5; cut (0 <= m * m + n * n).
  cut (0 <= n * n - m * m).
  intros Hmn2 Hmn2';
    elim (prop4 (m * m + n * n) (n * n - m * m) Hmn2' Hmn2 H9 H5); intros;
    elim H10; intros Hmn21 Hmn22; clear Hmn21; elim Hmn22; intros u H12;
    elim H11; intros Hmn21' Hmn22'; clear Hmn21'; elim Hmn22'; intros v H13;
    elim H12; clear H12; intros H12 Hu; elim H13; clear H13; intros H13 Hv;
    generalize H6 H7 H9; rewrite <- H12; rewrite <- H13; intros H6' H7' H9';
    intros; generalize (Zodd_sqr2 _ H6'); generalize (Zodd_sqr2 _ H7'); intros;
    generalize (prop3 u v H9'); intro; cut (exists two : Z * Z,
      let (a, b) := two in
        (u - v = 4 * (a * a) /\ u + v = 2 * (b * b) \/
         u - v = 2 * (b * b) /\ u + v = 4 * (a * a))
          /\ 0 < a /\ 0 < b).
  intro; elim H17; clear H17; intro x; elim x; clear x; intros a b H17;
    elim H17; clear H17; intros; elim H18; clear H18; intros Ha Hb;
    cut (is_pytha (b * b) (2 * (a * a)) n);
      [ intro H19; cut (Zodd (b * b));
        [ intro Hodd; generalize (pytha_thm3 _ _ _ H19 Hodd); clear Hodd H19;
          intro H19; elim H19; clear H19; unfold cond_pq, cond_pqb; intro p';
          intro H19; elim H19; clear H19; intro q'; intro H19; elim H19;
          clear H19; intro k'; intro H19; elim H19; clear H19; intro H21;
          intro H19; elim H19; clear H19; intro H22; intro H19; elim H19;
          clear H19; intro H23; intro H19; elim H19; clear H19; intro H20;
          intro H19; elim H19; clear H19; intro H19; intro H25; elim H19;
          clear H19; intro Hp'; intro H19; elim H19; clear H19; intro Hq';
          intro H19; elim H19; clear H19; intros Hpq' H24
        | elim H17; clear H17; intro H17; elim H17; clear H17; intros H17 H18;
          cut (u = b * b + 2 * (a * a)); auto with zarith; intro;
          rewrite H20 in H15; apply Zodd_sum3 with (b := a * a); assumption ]
      | unfold is_pytha, pos_triple; intuition; (apply Zle_ge; apply sqr_2) ||
        (apply (for_mba_pytha1 m n u v a b); assumption) ||
        (apply (for_mba_pytha2 m n u v a b); assumption) ].
  cut (k' = 1).
  intro Hk'; generalize H21 H22 H23; clear H21 H22 H23; rewrite Hk';
    ring_simplify q' p' (1 * (p' * p' + q' * q')) (1 * (p' * q'));
    intros; cut (0 <= p'); auto with zarith; cut (0 <= q'); auto with zarith;
    intros Hq'4 Hp'4; elim (prop4 p' q' Hp'4 Hq'4 H24).
  intros; generalize (prop1 _ _ H24 H25); intro;
    elim (prop4 (p' + q') (q' - p')); auto with zarith.
  intros; elim H18; rename H18 into H18'; intros Hpp' H18; clear Hpp';
    elim H18; clear H18; intros n' H18; elim H18; clear H18; intros H18 Hn';
    elim H19; rename H19 into H19'; intros Hpp' H19; elim H19; clear H19;
    intros m' H19; elim H19; clear H19; intros H19 Hm';
    cut (m' * m' + n' * n' < m * m + n * n).
  intro; split with (n' * n'); split with (m' * m');
    repeat (match goal with | |- _ /\ _ => split end); auto with zarith;
    try (rewrite H18; replace (2 * 1 * (p' * q')) with (2 * (p' * q')) in H22;
    try ring; cut (2 <> 0); try discriminate; intro h2;
    generalize (Zmult_eq_reg_l 2 (a * a) (p' * q') H22 h2); intro;
    apply (Zmult_lt_0_reg_r q'); auto with zarith; rewrite <- H30;
    apply Zmult_lt_O_compat; assumption); rewrite H18; rewrite H19;
    assumption || (repeat apply is_sqr_mult; try assumption;
    replace (q' * q' - p' * p') with ((p' + q') * (q' - p')); try ring;
    apply is_sqr_mult; assumption).
  rewrite H19; rewrite H18; rewrite H23.
    apply (Zlt_le_trans (q' + p') (q' ^2 + p' ^2)
      (m * m + (q' ^2 + p' ^2) * (q' ^2 + p' ^2))).
  generalize (Zlt_not_eq _ a Ha); intro Han0.
  generalize (Zgt_lt q' _ Hq'); intro Hq'g.
  generalize (Zlt_not_eq _ q' Hq'g); intro Hqn0.
  replace (q' + p') with (p' + q'); try ring;
    replace (q' ^2 + p' ^2) with (p' * p' + q' * q'); try ring.
  cut (p' <> 0); try (intro; cut (q' <> 0); progress auto with zarith).
  intro; rewrite H29 in H22; replace (2 * 1 * (0 * q')) with 0 in H22.
  apply Han0; symmetry; apply sqr_0; auto with zarith.
  ring.
  apply (Zle_trans (q' ^2 + p' ^2)
    ((q' ^2 + p' ^2) * (q' ^2 + p' ^2))
    (m * m + (q' ^2 + p' ^2) * (q' ^2 + p' ^2))); auto with zarith.
  apply sqr_le.
  replace ((p' + q') * (q' - p')) with (q' * q' - p' * p'); try ring;
    generalize H21; replace (1 * (q' * q' - p' * p')) with (q' * q' - p' * p');
    try ring; clear H21; intro H21; rewrite <- H21; generalize sqr_pos; intro.
  apply is_sqr_sqr.
  split.
  apply Zmult_le_0_compat; assumption.
  split with a; split; auto with zarith.
  apply (relp_mult1 (b * b) (2 * (a * a)) (q' * q' - p' * p')
    (2 * (p' * q')) k'); auto with zarith.
  generalize (distp_neq _ _ H25); intro Hneq; generalize (Zge_le _ _ Hp');
    clear Hp'; intro Hp'; cut (p' < q'); auto with zarith.
  rewrite H22; ring.
  apply (relp_sum (b * b) (2 * (a * a))).
  elim H17; clear H17; intro H17; elim H17; clear H17; intros H18 H19.
  cut (v = b * b - 2 * (a * a)).
  intro; cut (u = b * b + 2 * (a * a)).
  intro; rewrite <- H17; rewrite <- H26; auto.
  apply (Zmult_eq_reg_l 2 u (b * b + 2 * (a * a))).
  replace (2 * u) with ((u + v) + (u - v));
    [ rewrite H18; rewrite H19; ring | ring ].
  discriminate.
  apply (Zmult_eq_reg_l 2 v (b * b - 2 * (a * a))).
  replace (2 * v) with ((u + v) - (u - v));
    [ rewrite H18; rewrite H19; ring | ring ].
  discriminate.
  cut ((-v) = b * b - 2 * (a * a)).
  intro; cut (u = b * b + 2 * (a * a)).
  intro; rewrite <- H17; rewrite <- H26.
  apply rel_prime_oppr; auto.
  apply (Zmult_eq_reg_l 2 u (b * b + 2 * (a * a))).
  replace (2 * u) with ((u + v) + (u - v));
    [ rewrite H18; rewrite H19; ring | ring ].
  discriminate.
  apply (Zmult_eq_reg_l 2 (-v) (b * b - 2 * (a * a))).
  replace (2 * (-v)) with ((u - v) - (u + v));
    [ rewrite H18; rewrite H19; ring | ring ].
  discriminate.
  apply (for_exists_ab u v m n); try assumption; rewrite H3' in H0p;
    rewrite H4' in H0q; generalize (sqr_poss n H0q);
    generalize (sqr_poss m H0p); intros Hneqn Hneqm;
    elim (neq_1 u v m n Hneqn Hneqm H12 H13); intros Hu1 Hv1;
    generalize (Zodd_0 _ H15); intro; generalize (Zodd_0 _ H14); intro;
    cut (1 < u); auto with zarith; intro; cut (1 < v); auto with zarith; intro;
    auto with zarith; intros; apply Zle_square_simpl; auto with zarith.
  auto with zarith.
  auto with zarith.
  ring.
Qed.

Lemma diophantus20_refined : forall p q : Z,
  p > 0 -> q > 0 -> p <= q -> rel_prime p q -> distinct_parity p q ->
  ~ is_sqr (p * (q * (q * q - p * p))).
Proof.
  intros p0 q0 Hp0 Hq0 H' H0' H1' H2'.
  cut (0 <= p0).
  intro; cut (0 <= q0).
  intro; elim (prop4b _ _ H H0 H' H0' H2').
  intros; elim H2; clear H2; intros; unfold is_sqr in H3; elim H3; clear H3;
    intros; do 2 (elim H4; clear H4; intros); unfold is_sqr in H1;
    unfold is_sqr in H2; elim H1; clear H1; intros; elim H2; clear H2; intros;
    elim H6; clear H6; intros; elim H7; clear H7; intros; elim H6; clear H6;
    intros; elim H7; clear H7; intros; apply (diophantus20_equiv x0 x1).
  cut (p0 <> 0); auto with zarith; intro; rewrite <- H6 in H10;
    elim (Zmult_neq_0 _ _ H10); auto with zarith.
  cut (q0 <> 0); auto with zarith; intro; rewrite <- H7 in H10;
    elim (Zmult_neq_0 _ _ H10); auto with zarith.
  rewrite <- H6 in H'; rewrite <- H7 in H'; apply Zle_square_simpl; auto.
  apply prop3; rewrite H6; rewrite H7; assumption.
  apply distp_sqr2; rewrite H6; rewrite H7; assumption.
  unfold is_sqr; split.
  rewrite H6; rewrite H7;
    replace ((q0 + p0) * (q0 - p0)) with (q0 * q0 - p0 * p0).
  assumption.
  ring.
  split with x; rewrite H6; rewrite H7; split.
  rewrite H4; ring.
  assumption.
  auto with zarith.
  auto with zarith.
Qed.

Lemma diophantus20 :
  ~ (exists x : Z, exists y : Z, exists z : Z, exists t : Z,
       0 < x /\ 0 < y /\ 0 < z /\ 0 < t /\ x * x + y * y = z * z /\
       x * y = 2 * (t * t)).
Proof.
  intro; elim_hyps; cut (is_pytha x x0 x1); try (unfold is_pytha, pos_triple;
    solve [ intuition ]).
  intro; elim (pytha_thm1 _ _ _ H5); clear H5; unfold cond_pq, cond_pqb;
    intros; elim_hyps;
    (cut (x3 > 0);
     [ intro; apply (diophantus20_refined x3 x4); try assumption;
       generalize (Zge_le _ _ H8); intro; (cut (x5 > 0);
       [ intro; apply (is_sqr_compat x5); auto with zarith;
         repeat progress (apply Zmult_le_0_compat; auto with zarith); split;
           [ repeat progress (apply Zmult_le_0_compat; auto with zarith)
           | exists x2; intuition; rewrite H5 in H4; rewrite H13 in H4;
             match goal with
             | id : ?x = 2 * _ |- _ => replace x with
               (2 * (x5 * x5 * (x3 * (x4 * (x4 * x4 - x3 * x3))))) in id
             end; [ auto with zarith | ring ] ]
       | apply Zlt_gt; apply (Zmult_lt_0_reg_r (x3 * x3 + x4 * x4));
         try (apply Zgt_lt; progress auto with zarith); rewrite <- H6; auto ])
     | match goal with
       | id : ?x = 2 * _ * (_ * _) |- _ =>
         cut (x <> 0); auto with zarith; intro;
         match goal with
         | id' : _ |- _ => rewrite id in id'
         end
       end;
       repeat
         match goal with
         | id : _ |- _ => elim (Zmult_neq_0 _ _ id); auto with zarith; intros
         end ]).
Qed.


From mathcomp Require Import all_ssreflect.
Require Import all_core rs_base rs_base_fun.
Require Import FunctionalExtensionality ClassicalFacts ClassicalChoice Psatz ProofIrrelevance.
Require Import Morphisms.

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

Section ISOMORPHISMS.
Definition isomorphism (X Y: rep_space) (f: X c-> Y) :=
	exists (g: Y c-> X) (P: f \is_recursive_element) (Q:g \is_recursive_element),
		(forall y, (projT1 f) ((projT1 g) y) = y) /\ (forall x, (projT1 g) ((projT1 f) x) = x).

Definition wisomorphism (X Y: rep_space) (f: X ->> Y) :=
	exists (g: Y ->> X) (P: f \is_computable) (Q: g \is_computable),
	(f o g =~= F2MF id /\ g o f =~= F2MF id).

Definition isomorphic (X Y: rep_space):=
	exists f, @isomorphism X Y f.
Arguments isomorphic {X Y}.

Definition wisomorphic (X Y: rep_space):=
	exists f, @wisomorphism X Y f.
Arguments isomorphic {X Y}.

Notation "X ~=~ Y" := (@isomorphic X Y) (at level 2).

Lemma iso_ref X:
	X ~=~ X.
Proof.
exists (id_fun X); exists (id_fun X).
by exists (id_rec_elt X); exists (id_rec_elt X).
Qed.

Lemma iso_sym X Y:
	X ~=~ Y -> Y ~=~ X.
Proof.
move => [f [g [fcomp [gcomp [bij1 bij2]]]]].
exists g; exists f.
by exists gcomp; exists fcomp.
Qed.

(*
Lemma iso_trans X Y Z (someqx: questions X) (someqz: questions Z):
	X ~=~ Y -> Y ~=~ Z -> X ~=~ Z.
Proof.
move => [f [g [fcomp [gcomp [bij1 bij2]]]]] [f' [g' [f'comp [g'comp [bij1' bij2']]]]].
exists (fun_comp f f').
exists (fun_comp g' g).
split.
	apply/ cmpt_fun_cmpt_elt; [apply: fun_sprd someqx | apply fcmp_mon_cmpt | apply fcmp_sing | | ].
		by apply prod_cmpt_elt; [apply fcomp | apply f'comp].
	by trivial.
split.
	by apply: (@cmpt_fun_cmpt_elt
		(rep_space_prod (Z c-> Y) (Y c-> X)) (Z c-> X)
		(@composition Z Y X)
		(g', g)
		(fun_comp g' g)
		(fun_sprd someqz)
		(fcmp_mon_cmpt Z Y X)
		(@fcmp_sing Z Y X)
		(prod_cmpt_elt g'comp gcomp)
		_
		).
rewrite /fun_comp/=.
split.
	rewrite -comp_assoc (comp_assoc (sval f') (sval f) (sval g)).
	by rewrite bij1 comp_id bij1'.
rewrite -comp_assoc (comp_assoc (sval g) (sval g') (sval f')).
by rewrite bij2' comp_id bij2.
Qed.
*)
End ISOMORPHISMS.
Notation "X ~=~ Y" := (@isomorphic X Y) (at level 2).


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e174m17_6limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia.

From Undecidability.Shared.Libs.DLW
  Require Import utils gcd pos vec subcode sss.

From Undecidability.MinskyMachines.MMA
  Require Import mma_defs mma_utils.

From Undecidability.FRACTRAN
  Require Import FRACTRAN fractran_utils.

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 ø := vec_nil.

Local Notation "P //ₐ s -+> t" := (sss_progress (@mma_sss _) P s t) (at level 70, no associativity).
Local Notation "P //ₐ s ->> t" := (sss_compute (@mma_sss _) P s t) (at level 70, no associativity).
Local Notation "P //ₐ s ~~> t" := (sss_output (@mma_sss _) P s t) (at level 70, no associativity).
Local Notation "P //ₐ s ↓" := (sss_terminates (@mma_sss _) P s) (at level 70, no associativity).

Local Notation "Q /F/ x ≻ y" := (fractran_step Q x y) (at level 70, no associativity).
Local Notation "Q /F/ x ⊁ *" := (fractran_stop Q x) (at level 70, no associativity).

(* FRACTRAN with two counter *)

Section Fractran_with_two_counters.

  Hint Resolve subcode_refl : core.
  Hint Rewrite mma_jump_length mma_null_length mma_transfert_length mma_incs_length mma_decs_copy_length
               mma_mult_cst_length mma_decs_length mma_mod_cst_length mma_div_cst_length : length_db.

  Notation JUMPₐ := mma_jump.
  Notation NULLₐ := mma_null.
  Notation TRANSFERTₐ := mma_transfert.
  Notation INCSₐ := mma_incs.
  Notation DECSₐ := mma_decs.
  Notation DECS_COPYₐ := mma_decs_copy.
  Notation MULT_CSTₐ := mma_mult_cst.
  Notation MOD_CSTₐ := mma_mod_cst.
  Notation DIV_CSTₐ := mma_div_cst.
  Notation LOOPₐ := mma_loop.

  Let src : pos 2 := pos0.
  Let dst : pos 2 := pos1.

  Ltac dest x y := destruct (pos_eq_dec x y) as [ | ]; [ subst x | ]; rew vec.

  Let Hsrc_dst : src <> dst.    Proof. discriminate. Qed.
  Let Hdst_src : dst <> src.    Proof. discriminate. Qed.

  Section mma_fractran_one.

    (* FRACTRAN computation, try one fraction u/v *)

    Variables (p q : nat) (j i : nat).

    Notation i0 := i.
    Notation i1 := (5+p+i0).
    Notation i2 := (6+4*q+i1).
    Notation i3 := (5+3*q+i2).
    Notation i4 := (3+i3).
    Notation i5 := (2+i4).
    Notation i6 := (5+3*p+i5).

    Definition mma_fractran_one :=
           MULT_CSTₐ src dst p i0
        ++ MOD_CSTₐ dst src i2 i5 q i1
        ++ DIV_CSTₐ src dst q i2
        ++ TRANSFERTₐ dst src i3
        ++ JUMPₐ j dst
        ++ DIV_CSTₐ src dst p i5
        ++ TRANSFERTₐ dst src i6.

    Fact mma_fractran_one_length : length mma_fractran_one = 29+4*p+7*q.
    Proof. unfold mma_fractran_one; rew length; lia. Qed.

    Hypothesis (Hq : q <> 0).

    (* If the state in src is compatible with p/q then
       src becomes src*p/q and jump at j *)

    Fact mma_fractran_one_ok_progress k v :
            k*q = p*(v#>src)
         -> v#>dst = 0
         -> (i0,mma_fractran_one) //ₐ (i0,v) -+> (j,v[k/src]).
    Proof using Hq.
      intros H1 H2; unfold mma_fractran_one.
      apply sss_progress_trans with (i1,v[0/src][(k*q)/dst]).
      { apply subcode_sss_progress with (P := (i,mma_mult_cst src dst p i)); auto.
        apply mma_mult_cst_progress; auto.
        rewrite H2, <- H1; do 2 f_equal; lia. }
      apply sss_progress_trans with (i2,v[(k*q)/src][0/dst]).
      { apply subcode_sss_progress with (P := (i1,mma_mod_cst dst src i2 i5 q i1)); auto.
        apply mma_mod_cst_divides_progress with k; rew vec; try lia.
        f_equal; apply vec_pos_ext; intros y; dest y dst; try lia; dest y src. }
      apply sss_progress_trans with (i3,v[0/src][k/dst]).
      { apply subcode_sss_progress with (P := (i2,mma_div_cst src dst q i2)); auto.
        apply mma_div_cst_progress with k; auto; rew vec; try lia.
        f_equal; try lia.
        apply vec_pos_ext; intros y; dest y dst; try lia; dest y src. }
      apply sss_progress_trans with (i4,v[k/src][0/dst]).
      { apply subcode_sss_progress with (P := (i3,mma_transfert dst src i3)); auto.
        apply mma_transfert_progress; auto.
        f_equal; try lia.
        apply vec_pos_ext; intros y; dest y dst; try lia; dest y src. }
      apply sss_progress_compute_trans with (j,v[k/src][0/dst]).
      { apply subcode_sss_progress with (P := (i4,JUMPₐ j dst)); auto.
        apply mma_jump_progress; auto. }
      mma sss stop; f_equal.
      apply vec_pos_ext; intros y; dest y dst; try lia; dest y src.
    Qed.

    (* If the state in src is not compatible with a/b then jump at the end of the code *)

    Fact mma_fractran_one_nok_progress v :
            ~ divides q (p*(v#>src))
         -> v#>dst = 0
         -> (i0,mma_fractran_one) //ₐ (i0,v) -+> (length mma_fractran_one+i0,v).
    Proof using Hq.
      rewrite mma_fractran_one_length.
      intros H1 H2; unfold mma_fractran_one.
      rewrite divides_rem_eq in H1.
      revert H1.
      generalize (div_rem_spec1 (p*(v#>src)) q)
                 (div_rem_spec2 (p*(v#>src)) Hq).
      generalize (div (p*(v#>src)) q) (rem (p*(v#>src)) q); intros x y H3 H4 H5.
      apply sss_progress_trans with (i1,v[0/src][(x*q+y)/dst]).
      { apply subcode_sss_progress with (P := (i0,mma_mult_cst src dst p i0)); auto.
        apply mma_mult_cst_progress; auto.
        rewrite H2, <- H3; do 2 f_equal; lia. }
      apply sss_progress_trans with (i5,v[(p*(v#>src))/src][0/dst]).
      { apply subcode_sss_progress with (P := (i1,mma_mod_cst dst src i2 i5 q i1)); auto.
        apply mma_mod_cst_not_divides_progress with x y; rew vec; try lia.
        f_equal; apply vec_pos_ext; intros c; dest c dst; try lia; dest c src; lia. }
      apply sss_progress_trans with (i6,v[0/src][(v#>src)/dst]).
      { apply subcode_sss_progress with (P := (i5,mma_div_cst src dst p i5)); auto.
        apply mma_div_cst_progress with (v#>src); auto; rew vec; try lia; try ring.
        f_equal; try lia.
        apply vec_pos_ext; intros c; dest c dst; try lia; dest c src. }
      apply subcode_sss_progress with (P := (i6,mma_transfert dst src i6)); auto.
      apply mma_transfert_progress; auto.
      f_equal; try lia.
      apply vec_pos_ext; intros c; dest c dst; try lia; dest c src.
    Qed.

  End mma_fractran_one.

  Notation FRAC_ONEₐ := mma_fractran_one.

  Hint Rewrite mma_fractran_one_length : length_db.

  Section mma_fractran_step.

    (* One step of Fractran computation *)

    Variable (j : nat).

    Fixpoint mma_fractran_step Q i { struct Q } :=
      match Q with
        | nil      => nil
        | (p,q)::Q => let P := FRAC_ONEₐ p q j i
                      in  P ++ mma_fractran_step Q (length P+i)
      end.

    Notation FRAC_STEPₐ := mma_fractran_step.

    Fact mma_fractran_step_success_progress Q i x y :
            fractran_regular Q
         -> Q /F/ x ≻ y
         -> (i,mma_fractran_step Q i) //ₐ (i,x##0##ø) -+> (j,y##0##ø).
    Proof.
      unfold fractran_regular.
      intros H1 H2; revert H2 i H1.
      induction 1 as [ p q ll x y H1 | p q ll x y H1 H2 IH2 ];
        intros i H3; rewrite Forall_cons_inv in H3; destruct H3 as (H3 & H4); simpl in H3, H4;
        unfold mma_fractran_step; fold mma_fractran_step.
      + apply subcode_sss_progress with (P := (i,mma_fractran_one p q j i)); auto.
        apply mma_fractran_one_ok_progress with (v := _##_##ø); auto.
        simpl; rewrite <- H1; ring.
      + apply sss_progress_trans with (length (mma_fractran_one p q j i)+i,x##0##ø).
        { apply subcode_sss_progress with (P := (i,mma_fractran_one p q j i)); auto.
          apply mma_fractran_one_nok_progress; auto. }
        { apply subcode_sss_progress
            with (P := (length (mma_fractran_one p q j i)+i,
                        mma_fractran_step ll (length (mma_fractran_one p q j i)+i))); auto. }
    Qed.

    Fact mma_fractran_step_failure_compute Q i x :
            fractran_regular Q
         -> Q /F/ x ⊁ *
         -> (i,mma_fractran_step Q i) //ₐ (i,x##0##ø) ->> (length (mma_fractran_step Q i)+i,x##0##ø).
    Proof.
      unfold fractran_regular.
      intros H1 H2; revert H1 i H2.
      induction 1 as [ | (p,q) ll Hq Hll IH ]; intros i H4.
      + mma sss stop.
      + apply fractan_stop_cons_inv in H4 as (H4 & H5).
        unfold mma_fractran_step; fold mma_fractran_step.
        set (P := mma_fractran_one p q j i); rew length.
        apply sss_compute_trans with (length P+i,x##0##ø).
        * apply subcode_sss_compute with (P := (i,P)); auto.
          apply sss_progress_compute, mma_fractran_one_nok_progress; auto.
        * apply subcode_sss_compute with (P := (length P+i,mma_fractran_step ll (length P + i))); auto.
          replace (length P+length (mma_fractran_step ll (length P + i))+i)
          with    (length (mma_fractran_step ll (length P + i)) + (length P+i)) by lia; auto.
    Qed.

  End mma_fractran_step.

  Section fractran_mma.

    Variables (Q : list (nat*nat)) (HQ : fractran_regular Q).

    Definition fractran_mma := mma_fractran_step 1 Q 1.

    Lemma fractran_mma_sound x y :
               fractran_compute Q x y
            -> Q /F/ y ⊁ *
            -> (1,fractran_mma) //ₐ (1,x##0##ø) ->> (length fractran_mma+1,y##0##ø).
    Proof using HQ.
      intros (u & H2) H3.
      revert x y H2 H3.
      induction u as [ | u IHu ]; simpl; intros x y H2 H3.
      + rewrite H2; apply mma_fractran_step_failure_compute; auto.
      + destruct H2 as (z & H2 & H4).
        apply mma_fractran_step_success_progress
          with (1 := HQ) (j := 1) (i := 1) in H2; auto.
        apply IHu with (x := z) in H3; auto; rew vec.
        apply sss_compute_trans with (2 := H3).
        apply sss_progress_compute; auto.
    Qed.

    Lemma fractran_mma_complete x :
               (1,fractran_mma) //ₐ (1,x##0##ø) ↓
            -> Q /F/ x ↓.
    Proof using HQ.
      intros ((j,w) & (k & H2) & H3); simpl fst in H3.
      revert x H2; induction on k as IHu with measure k; intros x H2.
      destruct (fractran_step_dec Q x) as [ (y & Hy) | H4 ].
      2: { exists x; split; auto; exists 0; simpl; auto. }
      generalize Hy; intros H4.
      apply mma_fractran_step_success_progress
        with (1 := HQ) (j := 1) (i := 1)
        in H4; auto.
      fold fractran_mma in H4.
      destruct subcode_sss_progress_inv with (4 := H4) (5 := H2)
        as (r & H5 & H6); auto.
      1: apply mma_sss_fun.
      apply IHu in H6; auto; rew vec.
      destruct H6 as (z & (u & Hk) & Hz2).
      exists z; split; auto; exists (S u), y; split; auto.
    Qed.

    Theorem fractran_mma_reduction x :
        Q /F/ x ↓ <-> (1,fractran_mma) //ₐ (1,x##0##ø) ↓.
    Proof using HQ.
      split; auto.
      + intros (y & H2 & H3).
        exists (length fractran_mma+1,y##0##vec_nil); split; simpl; auto; try lia.
        apply fractran_mma_sound; auto.
      + apply fractran_mma_complete; auto.
    Qed.

  End fractran_mma.

  Section fractran_mma0.

    Variables (Q : list (nat*nat)) (HQ : fractran_regular Q).

    Let P := fractran_mma Q.

    Definition fractran_mma0 := P ++ NULLₐ src (length P + 1) ++ JUMPₐ 0 src.

    Notation FRAC_MMAₐ := fractran_mma0.

    Let fmma0_1 x : (1,FRAC_MMAₐ) //ₐ (length P+1,x##0##ø) -+> (0,0##0##ø).
    Proof.
      unfold fractran_mma0.
      apply subcode_sss_progress with (P := (length P+1, NULLₐ src (length P + 1) ++ JUMPₐ 0 src)); auto.
      apply sss_progress_trans with (length (NULLₐ src (length P + 1)) + length P+1,0##0##ø).
      + apply subcode_sss_progress with (P := (length P+1,NULLₐ src (length P+1))); auto.
        apply mma_null_progress; auto.
      + apply subcode_sss_progress with (2 := mma_jump_progress _ src _ eq_refl); auto.
    Qed.

    Lemma fractran_mma0_sound x y :
               fractran_compute Q x y
            -> fractran_stop Q y
            -> (1,FRAC_MMAₐ) //ₐ (1,x##0##ø) ->> (0,0##0##ø).
    Proof using HQ.
      intros H2 H3.
      unfold fractran_mma0.
      apply sss_compute_trans with (length P+1,y##0##ø).
      + apply subcode_sss_compute with (P := (1,P)); auto.
        apply fractran_mma_sound with (2 := H2); auto.
      + apply sss_progress_compute, fmma0_1; auto.
    Qed.

    Variable x : nat.

    Let Term1 := Q /F/ x ↓.
    Let Term2 := (1,FRAC_MMAₐ) //ₐ (1,x##0##ø) ~~> (0,0##0##ø).
    Let Term3 := (1,FRAC_MMAₐ) //ₐ (1,x##0##ø) ↓.

    Theorem fractran_mma0_reduction :
         (Term1 -> Term2) /\ (Term2 -> Term3) /\ (Term3 -> Term1).
    Proof using HQ.
      msplit 2; unfold Term1, Term2, Term3.
      + intros (y & H1 & H2); split; simpl; auto.
        apply fractran_mma0_sound with (1 := H1); auto.
      + now exists (0,0##0##ø).
      + intros H1; apply fractran_mma_reduction; auto.
        revert H1; apply subcode_sss_terminates.
        unfold fractran_mma0, P; auto.
    Qed.

  End fractran_mma0.

End Fractran_with_two_counters.

Theorem fractran_reg_mma0_reductions Q :
             fractran_regular Q
          -> (forall x, Q /F/ x ↓ <-> (1,fractran_mma0 Q) //ₐ (1,x##0##ø) ↓)
          /\ (forall x, Q /F/ x ↓ <-> (1,fractran_mma0 Q) //ₐ (1,x##0##ø) ~~> (0,(0##0##ø))).
Proof.
  do 2 (split; intros); repeat (apply fractran_mma0_reduction; auto).
Qed.


Require Export Unicode.Utf8.
Require Export JRWTactics.
Require Export List Init.Datatypes.
Export ListNotations.
Open Scope program_scope.

Require Export EqNat Arith.Peano_dec Program.Basics.

Definition all := fold_right andb true.

Fixpoint zipWith {a b c} (f : a → b → (c a b)) (xs : list a) (ys : list b) : list (c a b) :=
  match xs, ys with
  | [], _ => []
  | _, [] => []
  | x::xs, y::ys => f x y::zipWith f xs ys
  end.

Definition zip {a b} := @zipWith a b _ pair.

Fixpoint tails {a} (l : list a) : list (list a) := match l with
  | [] => []
  | x::xs => (x::xs) :: tails xs
  end.

Fixpoint contains {a} (eq : a → a → bool) (y : a) (xs : list a) :=
  match xs with
  | [] => false
  | x::xs => if eq x y then true else contains eq y xs
  end.

Fixpoint groupBy {a} (f : a → a → bool) (xs : list a) := match xs with
  | [] => []
  | x::xs => (x::filter (f x) xs) :: filter (negb ∘ contains f x) (groupBy f xs)
  end.

Definition Map a b := list (prod a b).

Definition lookup {a} (x:nat) (l:Map nat a) : option a :=
  match find (λ p, beq_nat x (fst p)) l with
    | None => None
    | Some (k,v) => Some v
  end.

Lemma lookup_cons : ∀ {a} (x:nat) (l:Map nat a) (v:a), lookup x ((x,v)::l) = Some v.
intros. unfold lookup. unfold find. simpl. rewrite <- beq_nat_refl. reflexivity.
Qed.

Notation " x ∈ y " := (In x y) (at level 30).
Notation " x ∉ y " := (¬ In x y) (at level 30).

Definition subset {a} xs ys := ∀ x:a, In x xs → In x ys.
Notation " x ⊆ y " := (subset x y) (at level 50).

Lemma subset_nil_nil {a} : ∀ xs:list a, xs ⊆ [] → xs = [].
intros. unfold subset in H. simpl in H. destruct xs. auto. assert False.
apply H with (x:=a0). simpl. apply or_introl. auto. inversion H0. Qed.

Lemma subset_refl {a} : ∀ xs:list a, subset xs xs. intros. unfold subset;
intros. assumption. Qed.

Lemma subset_trans {a} : ∀ xs ys zs : list a, xs ⊆ ys → ys ⊆ zs → xs ⊆ zs.
intros. unfold subset. intros. apply H in H1. apply H0. assumption. Qed.

Lemma contains_beq_nat_in : ∀ x xs, contains beq_nat x xs = true ↔ x ∈ xs.
intros; split; intros. induction xs. simpl in H. inversion H. simpl. simpl in
H. destruct (PeanoNat.Nat.eqb a x) eqn:ax. apply beq_nat_true in ax. subst.
apply or_introl.  reflexivity. apply or_intror. apply IHxs. assumption.
induction xs. inversion H. destruct H . subst. simpl. rewrite <- beq_nat_refl.
reflexivity. apply IHxs in H. simpl. rewrite H. destruct (beq_nat a x); auto.
Qed.

Lemma contains_beq_nat_not_in : ∀ x xs, contains beq_nat x xs = false ↔ x ∉ xs.
intros; split; intros. induction xs. auto. simpl in H. destruct
(PeanoNat.Nat.eqb a x) eqn:ax. inversion H. apply beq_nat_false in ax. unfold
not. intros. destruct H0. subst. apply ax. reflexivity. apply IHxs in H. apply
H. assumption. induction xs; intros. auto. simpl. destruct (beq_nat a x) eqn:ax.
simpl in H.  assert False. apply H. apply or_introl. apply beq_nat_true in ax.
assumption. inversion H0. apply IHxs. unfold not. intros. unfold not in H.
apply H. simpl. apply or_intror. assumption. Qed.

Fixpoint intersection (xs ys : list nat) : list nat := match xs with
  | [] => []
  | x::xs => (if contains beq_nat x ys then cons x else id) (intersection xs ys)
  end.

Notation " x ∩ y " := (intersection x y) (at level 50).

Lemma intersection_in : ∀ x xs ys, x ∈ (xs ∩ ys) ↔ x ∈ xs ∧ x ∈ ys.
intros. split; intros. induction xs; intros. inversion
H. simpl in H.  destruct (contains PeanoNat.Nat.eqb a ys) eqn:cays. simpl in H. destruct H. subst.
rewrite contains_beq_nat_in in cays. split. simpl. apply or_introl. reflexivity. assumption. apply IHxs in H.
destruct H. split. apply or_intror. assumption. assumption. rewrite contains_beq_nat_not_in in cays. apply IHxs in H.
destruct H. split. apply or_intror. assumption. assumption. induction xs. simpl. destruct H. inversion H. simpl. simpl.
destruct (contains beq_nat a ys) eqn:cays. simpl. destruct H. rewrite contains_beq_nat_in in cays. simpl in H. destruct H.
subst. apply or_introl. reflexivity. apply or_intror. apply IHxs. split; assumption. apply IHxs. destruct H.
rewrite contains_beq_nat_not_in in cays. destruct H. subst. apply cays in H0. inversion H0. split; assumption. Qed.

Definition seteq {a} (xs ys : list a) := subset xs ys /\ subset ys xs.

Lemma intersection_comm : forall xs ys, subset (intersection xs ys) (intersection ys xs).
intros. unfold subset; intros. rewrite intersection_in. rewrite intersection_in in H.
destruct H. split; auto. Qed.

Lemma subset_intersection : ∀ xs ys zs, xs ⊆ ys → (xs ∩ zs) ⊆ (ys ∩ zs).
intros. unfold subset. intros. rewrite intersection_in. rewrite intersection_in in H0.
destruct H0. apply H in H0. split; auto. Qed.

Fixpoint inits {a} (xs : list a) : list (list a) := match xs with
  | [] => []
  | x::xs => [x] :: map (cons x) (inits xs)
  end.

Definition lu {a} (x:nat) (l:Map nat (list a)) : list a :=
  match lookup x l with
    | None => []
    | Some l => l
  end.