(** 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.
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.

(* 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 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.
Hint Extern 1 (interp _ _ <> _) => simplify; equality.

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.

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.

(* 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.

(* 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.

  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.
Hint Extern 1 (_ >= _) => linear_arithmetic.
Hint Extern 1 (_ <> _) => linear_arithmetic.

(* 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.

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.

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.

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

(* 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. *)

Fixpoint 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 => noUnderscoreArith e1 && noUnderscoreArith e2
  | Minus e1 e2 => noUnderscoreArith e1 && noUnderscoreArith 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.

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

  Hint Resolve generateN_fwd.

  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 acorss 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 no 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.

(* 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.

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.

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

Hint Resolve self_prime_contra.

(* 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 that 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; eauto.
  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.

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.

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.

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.

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.

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.

(* 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.
  eapply flatten_ok' in H5; eauto.
  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.


From stdpp Require Import prelude.
Require Import List Lia.

Import ListNotations.

Local Notation "x 'el' L" := (In x L) (at level 60).

Section Positions.
  Variables (X: Type) (d: forall x y : X, {x = y} + {x <> y}).
  Implicit Types (x y: X) (A B : list X).

  Fixpoint pos x A : option nat :=
    match A with
    | nil => None
    | y :: A' => if d x y then Some 0
                else match pos x A' with
                     | Some n => Some (S n)
                     | None => None
                     end
    end.

  Lemma el_pos x A :
    x el A -> { n | pos x A = Some n }.
  Proof.
    induction A as [|y A IH]; cbn; intros H.
    - destruct H as [].
    - destruct (d x y) as [<-|H1].
      + now exists 0.
      + destruct IH as [n IH].
        * destruct H as [->|H]; tauto.
        * rewrite IH. now exists (S n).
  Qed.

  Notation nthe n A := (nth_error A n).

 Lemma pos_nthe x A n :
    pos x A = Some n -> nthe n A = Some x.
 Proof.
   revert n.
   induction A as [|y A IH]; cbn; intros n.
   - intros [=].
    - destruct (d x y) as [<-|H1].
      + now intros [= <-].
      + destruct (pos x A) as [k|]; intros [= <-]; cbn.
        now apply IH.
 Qed.

 Lemma NoDup_nth_error l n1 n2 x :
   NoDup l ->
   nth_error l n1 = Some x -> nth_error l n2 = Some x -> n1 = n2.
 Proof.
   induction 1 in n1, n2 |- *.
   - destruct n1, n2; cbn; congruence.
   - destruct n1, n2; cbn.
     + try congruence.
     + now intros [= ->] ? % nth_error_In.
     + now intros ? % nth_error_In [= ->].
     + intros. f_equal; eauto.
 Qed.

End Positions.

Arguments pos {_ _} _ _.

Fixpoint gen_lists (n : nat) : list (list bool).
Proof.
  destruct n.
  - exact [ [] ].
  - exact (map (cons true) (gen_lists n) ++ map (cons false) (gen_lists n)).
Defined.

Lemma gen_list_spec n l : length l = n <-> l el gen_lists n.
Proof.
  induction n in l |- *.
  - destruct l; cbn; firstorder (lia || congruence).
  - split.
    + destruct l; intros [= <-]. eapply in_app_iff.
      destruct b; [ left | right]; eapply in_map_iff;
        exists l; firstorder.
    + cbn. intros [(? & <- & ?) % in_map_iff | (? & <- & ?) % in_map_iff ] % in_app_iff; cbn; firstorder.
Qed.

Lemma NoDup_app {X} (l1 l2 : list X) :
  NoDup l1 -> NoDup l2 -> (forall x, x el l1 -> ~ (x el l2)) -> NoDup (l1 ++ l2).
Proof.
  induction 1 in l2 |- *.
  - eauto.
  - intros Hl2 Hel. cbn. econstructor. 2:eapply IHNoDup; eauto.
    + intros [ | ] % in_app_iff; firstorder.
    + firstorder.
Qed.

Lemma NoDup_map {X Y} (f : X -> Y) l :
  Inj (=) (=) f -> NoDup l -> NoDup (map f l).
Proof.
  induction 2; cbn; econstructor.
  intros (? & ? % H & ?) % in_map_iff.
  all: firstorder congruence.
Qed.

Lemma gen_list_NoDup n : NoDup (gen_lists n).
Proof.
  induction n; cbn.
  - repeat econstructor; firstorder.
  - eapply NoDup_app.
    + eapply NoDup_map; firstorder congruence.
    + eapply NoDup_map; firstorder congruence.
    + intros ? (? & <- & ?) % in_map_iff (? & ? & ?) % in_map_iff.
      congruence.
Qed.

Definition truthtable : Type :=
  list bool.

Definition eval_tt : forall t : truthtable, forall l : list bool, bool.
Proof.
  intros t l.
  destruct (@pos (list bool) (ltac:(repeat decide equality)) l (gen_lists (length l))) as [i | ].
  + destruct (nth_error t i) as [b | ].
    * exact b.
    * exact false.
  + exact false.
Defined.

Definition mk_tt : (list bool -> bool) -> nat -> truthtable.
Proof.
  intros f n.
  refine (map f (gen_lists n)).
Defined.

Lemma eval_tt_mk_tt : forall l f, eval_tt (mk_tt f (length l)) l = f l.
Proof.
  intros l f.
  unfold eval_tt.
  pose proof (gen_list_spec (length l) l) as [H % (fun H => H eq_refl) _].
  eapply el_pos in H as [i Hi].
  rewrite Hi.
  eapply pos_nthe in Hi.
    unfold mk_tt.
  now erewrite map_nth_error.
Qed.

Lemma eval_tt_mk_tt' : forall n l f, length l = n -> eval_tt (mk_tt f n) l = f l.
Proof.
  intros n l f <-; now eapply eval_tt_mk_tt.
Qed.

Arguments mk_tt _ _, _ {_}.

Lemma nth_error_eq {X} (l1 l2 : list X) :
  length l1 = length l2 ->
  (forall n, n < length l1 -> nth_error l1 n = nth_error l2 n) ->
  l1 = l2.
Proof.
  induction l1 as [ | a l1 IH  ]in l2 |- *; intros Hle Heq.
  - destruct l2; cbn in *; congruence.
  - destruct l2 as [ | b l2]; cbn in *; try congruence.
    f_equal.
    + specialize (Heq 0 ltac:(lia)). cbn in Heq. congruence.
    + eapply IH.
      * lia.
      * intros. eapply (Heq (S n)). lia.
Qed.
(*
Require Import Eqdep_dec.

Lemma ext_tt {n} (t1 t2 : truthtable n) :
  (forall l, length l = n -> eval_tt t1 l = eval_tt t2 l)
  -> t1 = t2.
Proof.
  intros. destruct t1 as [t1 Ht1], t2 as [t2 Ht2].
  enough (t1 = t2). subst. f_equal. eapply UIP_dec. decide equality.
  eapply nth_error_eq. congruence.
  intros i Hi. rewrite Ht1 in Hi.
  destruct (nth_error (gen_lists n) i) eqn:Eq. 2:{
    eapply nth_error_Some in Hi. congruence.
  }
  assert (Hl : length l = n). {
    eapply gen_list_spec, nth_error_In; eauto.
  }
  specialize (H l Hl). unfold eval_tt in H.
  destruct nat_eq_dec; try congruence.
  destruct pos eqn:Epos.
  - cbn in *. eapply pos_nthe in Epos.
    eapply NoDup_nth_error in Epos; eauto. 2:eapply gen_list_NoDup.
    subst.
    destruct (nth_error t1 n0) eqn:E1, (nth_error t2 n0) eqn:E2.
    + congruence.
    + eapply nth_error_None in E2. enough (n0 < length t1) by lia.
      eapply nth_error_Some. congruence.
    + eapply nth_error_None in E1. enough (n0 < length t2) by lia.
      eapply nth_error_Some. congruence.
    + reflexivity.
  - exfalso. eapply nth_error_In, el_pos in Eq as [? He].
    rewrite He in Epos. congruence.
Qed.
 *)


From Undecidability.L Require Import Computability.Decidability Datatypes.LNat Datatypes.LTerm L.
Require Import Nat.

(* ** Decidabiity of closedness, boundedness and procness *)

Fixpoint boundb (k : nat) (t : term) : bool :=
match t with
| var n => negb (k <=? n)
| app s t => andb (boundb k s) (boundb k t)
| lam s => boundb (S k) s
end.

#[global]
Instance term_boundb : computableTime' boundb (fun _ _ => (5,fun s _ => (size s * 31+9,tt))).
Proof.
  extract. solverec.
  unfold c__leb2, leb_time, c__leb. nia.
Qed.

Lemma boundb_spec k t : Bool.reflect (bound k t) (boundb k t).
Proof.
  revert k. induction t;intros;cbn. simpl.
  -destruct (Nat.leb_spec0 k n); simpl;constructor.  intros H. inv H. lia. constructor. lia.
  -specialize (IHt1 k). specialize (IHt2 k). inv IHt1;simpl.
   +inv IHt2;constructor.
    *now constructor.
    *intros C. now inv C.
   +constructor. intros C. now inv C.
  -specialize (IHt (S k)). inv IHt;constructor.
   +now constructor.
   +intros C. now inv C.
Qed.

Definition closedb := boundb 0.

Lemma closedb_spec s : Bool.reflect (closed s) (closedb s).
Proof.
  unfold closedb.
  destruct (boundb_spec 0 s);constructor; rewrite closed_dcl;auto.
Qed.

#[global]
Instance termT_closedb : computableTime' closedb (fun s _ => (size s * 31+15,tt)).
Proof.
  change closedb with (fun x => boundb 0 x).
  extract. solverec.
Qed.

Definition lambdab (t : term) : bool :=
match t with
| lam _ => true
| _ => false
end.

#[global]
Instance term_lambdab : computableTime' lambdab (fun _ _ => (11,tt)).
Proof.
  extract. solverec.
Qed.

Lemma lambdab_spec t : Bool.reflect (lambda t) (lambdab t).
Proof.
  destruct t;constructor;[intros H;inv H;congruence..|auto].
Qed.

Lemma ldec_lambda : ldec lambda.
Proof.
  apply (dec_ldec lambdab). apply lambdab_spec.
Qed.

Lemma ldec_closed : ldec closed.
Proof.
  apply (dec_ldec closedb). apply closedb_spec.
Qed.

Lemma ldec_proc : ldec proc.
Proof.
  apply ldec_conj. apply ldec_closed. apply ldec_lambda.
Qed.


(** This file implements [IsHomomorphism] and [IsIsomorphism].
    It developes basic algebra homomorphisms and isomorphims. The main
    theorem in this file is the [path_isomorphism] theorem, which
    states that there is a path between isomorphic algebras. *)

Require Export HoTT.Algebra.UniversalAlgebra.Finitary.ua_setalgebra.

Require Import
  HoTT.Basics
  HoTT.Types
  HoTT.Fibrations
  HoTT.HProp
  HoTT.HSet
  HoTT.Tactics
  UnivalenceImpliesFunext.

Import algebra_notations ne_list.notations.

Section is_homomorphism.
  Context {σ} {A B : Algebra σ} (f : ∀ (s : Sort σ), A s → B s).

(** The family of functions [f] above is [OpPreserving α β] with
    respect to operations [α : A s1 → A s2 → ... → A sn → A t] and
    [β : B s1 → B s2 → ... → B sn → B t] if

    <<
      f t (α x1 x2 ... xn) = β (f s1 x1) (f s2 x2) ... (f sn xn)
    >>
*)

  Fixpoint OpPreserving {w : SymbolType σ}
    : Operation A w → Operation B w → Type
    := match w with
       | [:s:] => λ α β, f s α = β
       | s ::: y => λ α β, ∀ (x : A s), OpPreserving (α x) (β (f s x))
       end.

  Global Instance trunc_oppreserving `{Funext} {n : trunc_index}
    `{!IsTruncAlgebra n.+1 B} {w : SymbolType σ}
    (α : Operation A w) (β : Operation B w)
    : IsTrunc n (OpPreserving α β).
  Proof.
    induction w; exact _.
  Qed.

(** The family of functions [f : ∀ (s : Sort σ), A s → B s] above is
    a homomorphism if for each function symbol [u : Symbol σ], it is
    [OpPreserving (u^^A) (u^^B)] with respect to the algebra
    operations [u^^A] and [u^^B] corresponding to [u]. *)

  Class IsHomomorphism : Type
    := oppreserving_hom : ∀ (u : Symbol σ), OpPreserving (u^^A) (u^^B).

  Global Instance trunc_is_homomorphism `{Funext} {n : trunc_index}
    `{!IsTruncAlgebra n.+1 B}
    : IsTrunc n IsHomomorphism.
  Proof.
    apply trunc_forall.
  Qed.
End is_homomorphism.

Record Homomorphism {σ} {A B : Algebra σ} : Type := BuildHomomorphism
  { def_hom : ∀ (s : Sort σ), A s → B s
  ; is_homomorphism_hom : IsHomomorphism def_hom }.

Arguments Homomorphism {σ}.

Arguments BuildHomomorphism {σ A B} def_hom {is_homomorphism_hom}.

(** We the implicit coercion from [Homomorphism A B] to the family
    of functions [∀ s, A s → B s]. *)

Global Coercion def_hom : Homomorphism >-> Funclass.

Global Existing Instance is_homomorphism_hom.

Lemma apD10_homomorphism {σ} {A B : Algebra σ} {f g : Homomorphism A B}
  : f = g → ∀ s, f s == g s.
Proof.
  intro p. by destruct p.
Defined.

Definition SigHomomorphism {σ} (A B : Algebra σ) : Type :=
  { def_hom : ∀ s, A s → B s | IsHomomorphism def_hom }.

Lemma issig_homomorphism {σ} (A B : Algebra σ)
  : SigHomomorphism A B <~> Homomorphism A B.
Proof.
  issig.
Defined.

Global Instance trunc_homomorphism `{Funext} {σ} {A B : Algebra σ}
  {n : trunc_index} `{!IsTruncAlgebra n B}
  : IsTrunc n (Homomorphism A B).
Proof.
  apply (trunc_equiv _ (issig_homomorphism A B)).
Qed.

(** To find a path between two homomorphisms [f g : Homomorphism A B]
    it suffices to find a path between the defining families of
    functions and the [is_homomorphism_hom] witnesses. *)

Lemma path_homomorphism {σ} {A B : Algebra σ} (f g : Homomorphism A B)
  (p : def_hom f = def_hom g)
  (q : p#(is_homomorphism_hom f) = is_homomorphism_hom g)
  : f = g.
Proof.
  destruct f, g. simpl in *. by path_induction.
Defined.

(** To find a path between two homomorphisms [f g : Homomorphism A B]
    it suffices to find a path between the defining families of
    functions if [IsHSetAlgebra B]. *)

Lemma path_hset_homomorphism `{Funext} {σ} {A B : Algebra σ}
  `{!IsHSetAlgebra B} (f g : Homomorphism A B)
  (p : def_hom f = def_hom g)
  : f = g.
Proof.
  apply (path_homomorphism f g p). apply path_ishprop.
Defined.

(** A family of functions [f : ∀ s, A s → B s] is an isomorphism if it is
    a homomorphism, and for each [s : Sort σ], [f s] is an equivalence. *)

(* We make [IsHomomorphism] an argument here, rather than a field, so
   having both [f : Homomorphism A B] and [X : IsIsomorphism f] in
   context does not result in having two proofs of [IsHomomorphism f]
   in context. *)

Class IsIsomorphism {σ : Signature} {A B : Algebra σ}
  (f : ∀ s, A s → B s) `{!IsHomomorphism f}
  := isequiv_isomorphism : ∀ (s : Sort σ), IsEquiv (f s).

Global Existing Instance isequiv_isomorphism.

Definition equiv_isomorphism {σ : Signature} {A B : Algebra σ}
  (f : ∀ s, A s → B s) `{IsIsomorphism σ A B f}
  : ∀ (s : Sort σ), A s <~> B s.
Proof.
  intro s. rapply (Build_Equiv _ _ (f s)).
Defined.

Global Instance hprop_is_isomorphism `{Funext} {σ : Signature}
  {A B : Algebra σ} (f : ∀ s, A s → B s) `{!IsHomomorphism f}
  : IsHProp (IsIsomorphism f).
Proof.
  apply trunc_forall.
Qed.

(** Let [f : ∀ s, A s → B s] be a homomorphism. The following
    section proves that [f] is "OpPreserving" with respect to
    uncurried algebra operations in the sense that

    <<
      f t (α (x1,x2,...,xn,tt)) = β (f s1 x1,f s2 x1,...,f sn xn,tt)
    >>

    for all [(x1,x2,...,xn,tt) : FamilyProd A [s1;s2;...;sn]], where
    [α] and [β] are uncurried algebra operations in [A] and [B]
    respectively.
*)

Section homomorphism_ap_operation.
  Context {σ : Signature} {A B : Algebra σ}.

  Lemma path_oppreserving_ap_operation (f : ∀ s, A s → B s)
    {w : SymbolType σ} (a : FamilyProd A (dom_symboltype w))
    (α : Operation A w) (β : Operation B w) (P : OpPreserving f α β)
    : f (cod_symboltype w) (ap_operation α a)
      = ap_operation β (map_family_prod f a).
  Proof.
    induction w.
    - assumption.
    - destruct a as [x a]. apply IHw. apply P.
  Defined.

(** A homomorphism [f : ∀ s, A s → B s] satisfies

    <<
      f t (α (a1, a2, ..., an, tt))
      = β (f s1 a1, f s2 a2, ..., f sn an, tt)
    >>

    where [(a1, a2, ..., an, tt) : FamilyProd A [s1; s2; ...; sn]] and
    [α], [β] uncurried versions of [u^^A], [u^^B] respectively. *)

  Lemma path_homomorphism_ap_operation (f : ∀ s, A s → B s)
    `{!IsHomomorphism f}
    : ∀ (u : Symbol σ) (a : FamilyProd A (dom_symboltype (σ u))),
      f (cod_symboltype (σ u)) (ap_operation (u^^A) a)
      = ap_operation (u^^B) (map_family_prod f a).
  Proof.
    intros u a. by apply path_oppreserving_ap_operation.
  Defined.
End homomorphism_ap_operation.

(** The next section shows that the family of identity functions,
    [λ s x, x] is an isomorphism. *)

Section hom_id.
  Context {σ} (A : Algebra σ).

  Global Instance is_homomorphism_id
    : IsHomomorphism (λ s (x : A s), x).
  Proof.
    intro u. generalize (u^^A). intro w. induction (σ u).
    - reflexivity.
    - now intro x.
  Defined.

  Global Instance is_isomorphism_id
    : IsIsomorphism (λ s (x : A s), x).
  Proof.
    intro s. exact _.
  Qed.

  Definition hom_id : Homomorphism A A
    := BuildHomomorphism (λ s x, x).

End hom_id.

(** Suppose [f : ∀ s, A s → B s] is an isomorphism. The following
    section shows that the family of inverse functions, [λ s, (f s)^-1]
    is an isomorphism. *)

Section hom_inv.
  Context
    {σ} {A B : Algebra σ}
    (f : ∀ s, A s → B s) `{IsIsomorphism σ A B f}.

  Global Instance is_homomorphism_inv : IsHomomorphism (λ s, (f s)^-1).
  Proof.
   intro u.
   generalize (u^^A) (u^^B) (oppreserving_hom f u).
   intros a b P.
   induction (σ u).
   - destruct P. apply (eissect (f t)).
   - intro. apply IHs.
     exact (transport (λ y, OpPreserving f _ (b y))
              (eisretr (f t) x) (P (_^-1 x))).
  Defined.

  Global Instance is_isomorphism_inv : IsIsomorphism (λ s, (f s)^-1).
  Proof.
    intro s. exact _.
  Qed.

  Definition hom_inv : Homomorphism B A
    := BuildHomomorphism (λ s, (f s)^-1).

End hom_inv.

(** Let [f : ∀ s, A s → B s] and [g : ∀ s, B s → C s]. The
    next section shows that composition given by [λ (s : Sort σ),
    g s o f s] is again a homomorphism. If both [f] and [g] are
    isomorphisms, then the composition is an isomorphism. *)

Section hom_compose.
  Context {σ} {A B C : Algebra σ}.

  Lemma oppreserving_compose (g : ∀ s, B s → C s) `{!IsHomomorphism g}
    (f : ∀ s, A s → B s) `{!IsHomomorphism f} {w : SymbolType σ}
    (α : Operation A w) (β : Operation B w) (γ : Operation C w)
    (G : OpPreserving g β γ) (F : OpPreserving f α β)
    : OpPreserving (λ s, g s o f s) α γ.
  Proof.
    induction w; simpl in *.
    - by path_induction.
    - intro x. now apply (IHw _ (β (f _ x))).
  Defined.

  Global Instance is_homomorphism_compose
    (g : ∀ s, B s → C s) `{!IsHomomorphism g}
    (f : ∀ s, A s → B s) `{!IsHomomorphism f}
    : IsHomomorphism (λ s, g s o f s).
  Proof.
    intro u.
    by apply (oppreserving_compose g f (u^^A) (u^^B) (u^^C)).
  Defined.

  Global Instance is_isomorphism_compose
    (g : ∀ s, B s → C s) `{IsIsomorphism σ B C g}
    (f : ∀ s, A s → B s) `{IsIsomorphism σ A B f}
    : IsIsomorphism (λ s, g s o f s).
  Proof.
    intro s. apply isequiv_compose.
  Qed.

  Definition hom_compose
    (g : Homomorphism B C) (f : Homomorphism A B)
    : Homomorphism A C
    := BuildHomomorphism (λ s, g s o f s).

End hom_compose.

(** The following section shows that there is a path between
    isomorphic algebras. *)

Section path_isomorphism.
  Context `{Univalence} {σ : Signature} {A B : Algebra σ}.

(** Let [F G : I → Type]. If [f : ∀ (i:I), F i <~> G i] is a family of
    equivalences, then by function extensionality composed with
    univalence there is a path [F = G]. *)

  Local Notation path_equiv_family f
    := (path_forall _ _ (λ i, path_universe (f i))).

(** Given a family of equivalences [f : ∀ (s : Sort σ), A s <~> B s]
    which is [OpPreserving f α β] with respect to algebra operations

    <<
      α : A s1 → A s2 → ... → A sn → A t
      β : B s1 → B s2 → ... → B sn → B t
    >>

    By transporting [α] along the path [path_equiv_family f] we
    find a path from the transported operation [α] to [β]. *)

  Lemma path_operations_equiv {w : SymbolType σ}
    (α : Operation A w) (β : Operation B w)
    (f : ∀ (s : Sort σ), A s <~> B s) (P : OpPreserving f α β)
    : transport (λ C : Carriers σ, Operation C w)
        (path_equiv_family f) α
      = β.
  Proof.
    induction w; simpl in *.
    - transport_path_forall_hammer.
      exact (ap10 (transport_idmap_path_universe (f t)) α @ P).
    - funext y.
      transport_path_forall_hammer.
      rewrite transport_forall_constant.
      rewrite transport_arrow_toconst.
      rewrite (transport_path_universe_V (f t)).
      apply IHw.
      specialize (P ((f t)^-1 y)).
      by rewrite (eisretr (f t) y) in P.
  Qed.

(** Suppose [u : Symbol σ] is a function symbol. Recall that
    [u^^A] is notation for [operations A u : Operation A (σ u)]. This
    is the algebra operation corresponding to function symbol [u]. *)

(** An isomorphism [f : ∀ s, A s → B s] induces a family of
    equivalences [e : ∀ (s : Sort σ), A s <~> B s]. Let [u : Symbol σ]
    be a function symbol. Since [f] is a homomorphism, the induced
    family of equivalences [e] satisfies [OpPreserving e (u^^A) (u^^B)].
    By [path_operations_equiv] above, we can then transport [u^^A] along
    the path [path_equiv_family e] and obtain a path to [u^^B]. *)

  Lemma path_operations_isomorphism (f : ∀ s, A s → B s)
    `{IsIsomorphism σ A B f} (u : Symbol σ)
    : transport (λ C : Carriers σ, Operation C (σ u))
        (path_equiv_family (equiv_isomorphism f)) (u^^A)
      = u^^B.
  Proof.
    by apply path_operations_equiv.
  Defined.

(** If there is an isomorphism [f : ∀ s, A s → B s] then [A = B]. *)

  Theorem path_isomorphism (f : ∀ s, A s → B s) `{IsIsomorphism σ A B f}
    : A = B.
  Proof.
    apply (path_algebra _ _ (path_equiv_family (equiv_isomorphism f))).
(* Make the last part abstract because it relies on [path_operations_equiv],
   which is opaque. In cases where the involved algebras are set algebras,
   then this part is a mere proposition. *)
    abstract (
      funext u;
      exact (transport_forall_constant _ _ u
             @ path_operations_isomorphism f u)).
  Defined.
End path_isomorphism.


From Hammer Require Import Hammer.

Require Import Bool Basics OrdersTac.
Require Export Orders.

Set Implicit Arguments.
Unset Strict Implicit.

Module Type CompareFacts (Import O:DecStrOrder').

Local Infix "?=" := compare (at level 70, no associativity).

Lemma compare_eq_iff x y : (x ?= y) = Eq <-> x==y.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.CompareFacts.compare_eq_iff".
case compare_spec; intro H; split; try easy; intro EQ;
contradict H; rewrite EQ; apply irreflexivity.
Qed.

Lemma compare_eq x y : (x ?= y) = Eq -> x==y.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.CompareFacts.compare_eq".
apply compare_eq_iff.
Qed.

Lemma compare_lt_iff x y : (x ?= y) = Lt <-> x<y.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.CompareFacts.compare_lt_iff".
case compare_spec; intro H; split; try easy; intro LT;
contradict LT; rewrite H; apply irreflexivity.
Qed.

Lemma compare_gt_iff x y : (x ?= y) = Gt <-> y<x.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.CompareFacts.compare_gt_iff".
case compare_spec; intro H; split; try easy; intro LT;
contradict LT; rewrite H; apply irreflexivity.
Qed.

Lemma compare_nlt_iff x y : (x ?= y) <> Lt <-> ~(x<y).
Proof. hammer_hook "OrdersFacts" "OrdersFacts.CompareFacts.compare_nlt_iff".
rewrite compare_lt_iff; intuition.
Qed.

Lemma compare_ngt_iff x y : (x ?= y) <> Gt <-> ~(y<x).
Proof. hammer_hook "OrdersFacts" "OrdersFacts.CompareFacts.compare_ngt_iff".
rewrite compare_gt_iff; intuition.
Qed.

Hint Rewrite compare_eq_iff compare_lt_iff compare_gt_iff : order.

Instance compare_compat : Proper (eq==>eq==>Logic.eq) compare.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.CompareFacts.compare_compat".
intros x x' Hxx' y y' Hyy'.
case (compare_spec x' y'); autorewrite with order; now rewrite Hxx', Hyy'.
Qed.

Lemma compare_refl x : (x ?= x) = Eq.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.CompareFacts.compare_refl".
case compare_spec; intros; trivial; now elim irreflexivity with x.
Qed.

Lemma compare_antisym x y : (y ?= x) = CompOpp (x ?= y).
Proof. hammer_hook "OrdersFacts" "OrdersFacts.CompareFacts.compare_antisym".
case (compare_spec x y); simpl; autorewrite with order;
trivial; now symmetry.
Qed.

End CompareFacts.

Module Type OrderedTypeFullFacts (Import O:OrderedTypeFull').

Module OrderTac := OTF_to_OrderTac O.
Ltac order := OrderTac.order.
Ltac iorder := intuition order.

Instance le_compat : Proper (eq==>eq==>iff) le.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeFullFacts.le_compat".   repeat red; iorder. Qed.

Instance le_preorder : PreOrder le.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeFullFacts.le_preorder".   split; red; order. Qed.

Instance le_order : PartialOrder eq le.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeFullFacts.le_order".   compute; iorder. Qed.

Instance le_antisym : Antisymmetric _ eq le.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeFullFacts.le_antisym".   apply partial_order_antisym; auto with *. Qed.

Lemma le_not_gt_iff : forall x y, x<=y <-> ~y<x.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeFullFacts.le_not_gt_iff".   iorder. Qed.

Lemma lt_not_ge_iff : forall x y, x<y <-> ~y<=x.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeFullFacts.lt_not_ge_iff".   iorder. Qed.

Lemma le_or_gt : forall x y, x<=y \/ y<x.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeFullFacts.le_or_gt".   intros. rewrite le_lteq; destruct (O.compare_spec x y); auto. Qed.

Lemma lt_or_ge : forall x y, x<y \/ y<=x.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeFullFacts.lt_or_ge".   intros. rewrite le_lteq; destruct (O.compare_spec x y); iorder. Qed.

Lemma eq_is_le_ge : forall x y, x==y <-> x<=y /\ y<=x.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeFullFacts.eq_is_le_ge".   iorder. Qed.

Include CompareFacts O.

Lemma compare_le_iff x y : compare x y <> Gt <-> x<=y.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeFullFacts.compare_le_iff".
rewrite le_not_gt_iff. apply compare_ngt_iff.
Qed.

Lemma compare_ge_iff x y : compare x y <> Lt <-> y<=x.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeFullFacts.compare_ge_iff".
rewrite le_not_gt_iff. apply compare_nlt_iff.
Qed.

End OrderedTypeFullFacts.

Module OrderedTypeFacts (Import O: OrderedType').

Module OrderTac := OT_to_OrderTac O.
Ltac order := OrderTac.order.

Notation "x <= y" := (~lt y x) : order.
Infix "?=" := compare (at level 70, no associativity) : order.

Local Open Scope order.

Tactic Notation "elim_compare" constr(x) constr(y) :=
destruct (compare_spec x y).

Tactic Notation "elim_compare" constr(x) constr(y) "as" ident(h) :=
destruct (compare_spec x y) as [h|h|h].

Definition eq_refl (x:t) : x==x := Equivalence_Reflexive x.

Definition eq_sym (x y:t) : x==y -> y==x := Equivalence_Symmetric x y.

Definition eq_trans (x y z:t) : x==y -> y==z -> x==z :=
Equivalence_Transitive x y z.

Definition lt_trans (x y z:t) : x<y -> y<z -> x<z :=
StrictOrder_Transitive x y z.

Definition lt_irrefl (x:t) : ~x<x := StrictOrder_Irreflexive x.

Include CompareFacts O.
Notation compare_le_iff := compare_ngt_iff (only parsing).
Notation compare_ge_iff := compare_nlt_iff (only parsing).

Definition eq_dec := eq_dec.

Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeFacts.lt_dec".
intros x y; destruct (CompSpec2Type (compare_spec x y));
[ right | left | right ]; order.
Defined.

Definition eqb x y : bool := if eq_dec x y then true else false.

Lemma if_eq_dec : forall x y (B:Type)(b b':B),
(if eq_dec x y then b else b') =
(match compare x y with Eq => b | _ => b' end).
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeFacts.if_eq_dec".
intros; destruct eq_dec; elim_compare x y; auto; order.
Qed.

Lemma eqb_alt :
forall x y, eqb x y = match compare x y with Eq => true | _ => false end.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeFacts.eqb_alt".
unfold eqb; intros; apply if_eq_dec.
Qed.

Instance eqb_compat : Proper (eq==>eq==>Logic.eq) eqb.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeFacts.eqb_compat".
intros x x' Hxx' y y' Hyy'.
rewrite 2 eqb_alt, Hxx', Hyy'; auto.
Qed.

End OrderedTypeFacts.

Module OrderedTypeTest (Import O:OrderedType').
Module Import MO := OrderedTypeFacts O.
Local Open Scope order.
Lemma lt_not_eq x y : x<y -> ~x==y.  Proof. order. Qed.
Lemma lt_eq x y z : x<y -> y==z -> x<z. Proof. order. Qed.
Lemma eq_lt x y z : x==y -> y<z -> x<z. Proof. order. Qed.
Lemma le_eq x y z : x<=y -> y==z -> x<=z. Proof. order. Qed.
Lemma eq_le x y z : x==y -> y<=z -> x<=z. Proof. order. Qed.
Lemma neq_eq x y z : ~x==y -> y==z -> ~x==z. Proof. order. Qed.
Lemma eq_neq x y z : x==y -> ~y==z -> ~x==z. Proof. order. Qed.
Lemma le_lt_trans x y z : x<=y -> y<z -> x<z. Proof. order. Qed.
Lemma lt_le_trans x y z : x<y -> y<=z -> x<z. Proof. order. Qed.
Lemma le_trans x y z : x<=y -> y<=z -> x<=z. Proof. order. Qed.
Lemma le_antisym x y : x<=y -> y<=x -> x==y. Proof. order. Qed.
Lemma le_neq x y : x<=y -> ~x==y -> x<y. Proof. order. Qed.
Lemma neq_sym x y : ~x==y -> ~y==x. Proof. order. Qed.
Lemma lt_le x y : x<y -> x<=y. Proof. order. Qed.
Lemma gt_not_eq x y : y<x -> ~x==y. Proof. order. Qed.
Lemma eq_not_lt x y : x==y -> ~x<y. Proof. order. Qed.
Lemma eq_not_gt x y : x==y -> ~ y<x. Proof. order. Qed.
Lemma lt_not_gt x y : x<y -> ~ y<x. Proof. order. Qed.
Lemma eq_is_nlt_ngt x y : x==y <-> ~x<y /\ ~y<x.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeTest.eq_is_nlt_ngt".   intuition; order. Qed.
End OrderedTypeTest.

Module OrderedTypeRev (O:OrderedTypeFull) <: OrderedTypeFull.

Definition t := O.t.
Definition eq := O.eq.
Program Instance eq_equiv : Equivalence eq.
Definition eq_dec := O.eq_dec.

Definition lt := flip O.lt.
Definition le := flip O.le.

Instance lt_strorder: StrictOrder lt.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeRev.lt_strorder".   unfold lt; auto with *. Qed.
Instance lt_compat : Proper (eq==>eq==>iff) lt.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeRev.lt_compat".   unfold lt; auto with *. Qed.

Lemma le_lteq : forall x y, le x y <-> lt x y \/ eq x y.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeRev.le_lteq".   intros; unfold le, lt, flip. rewrite O.le_lteq; intuition. Qed.

Definition compare := flip O.compare.

Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeRev.compare_spec".
intros; unfold compare, eq, lt, flip.
destruct (O.compare_spec y x); auto with relations.
Qed.

End OrderedTypeRev.

Unset Implicit Arguments.

Module Type CompareBasedOrder (Import E:EqLtLe')(Import C:HasCmp E).
Include CmpNotation E C.
Include IsEq E.
Axiom compare_eq_iff : forall x y, (x ?= y) = Eq <-> x == y.
Axiom compare_lt_iff : forall x y, (x ?= y) = Lt <-> x < y.
Axiom compare_le_iff : forall x y, (x ?= y) <> Gt <-> x <= y.
Axiom compare_antisym : forall x y, (y ?= x) = CompOpp (x ?= y).
End CompareBasedOrder.

Module Type CompareBasedOrderFacts
(Import E:EqLtLe')
(Import C:HasCmp E)
(Import O:CompareBasedOrder E C).

Lemma compare_spec x y : CompareSpec (x==y) (x<y) (y<x) (x?=y).
Proof. hammer_hook "OrdersFacts" "OrdersFacts.CompareBasedOrderFacts.compare_spec".
case_eq (compare x y); intros H; constructor.
now apply compare_eq_iff.
now apply compare_lt_iff.
rewrite compare_antisym, CompOpp_iff in H. now apply compare_lt_iff.
Qed.

Lemma compare_eq x y : (x ?= y) = Eq -> x==y.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.CompareBasedOrderFacts.compare_eq".
apply compare_eq_iff.
Qed.

Lemma compare_refl x : (x ?= x) = Eq.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.CompareBasedOrderFacts.compare_refl".
now apply compare_eq_iff.
Qed.

Lemma compare_gt_iff x y : (x ?= y) = Gt <-> y<x.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.CompareBasedOrderFacts.compare_gt_iff".
now rewrite <- compare_lt_iff, compare_antisym, CompOpp_iff.
Qed.

Lemma compare_ge_iff x y : (x ?= y) <> Lt <-> y<=x.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeFacts.compare_ge_iff".
now rewrite <- compare_le_iff, compare_antisym, CompOpp_iff.
Qed.

Lemma compare_ngt_iff x y : (x ?= y) <> Gt <-> ~(y<x).
Proof. hammer_hook "OrdersFacts" "OrdersFacts.CompareBasedOrderFacts.compare_ngt_iff".
rewrite compare_gt_iff; intuition.
Qed.

Lemma compare_nlt_iff x y : (x ?= y) <> Lt <-> ~(x<y).
Proof. hammer_hook "OrdersFacts" "OrdersFacts.CompareBasedOrderFacts.compare_nlt_iff".
rewrite compare_lt_iff; intuition.
Qed.

Lemma compare_nle_iff x y : (x ?= y) = Gt <-> ~(x<=y).
Proof. hammer_hook "OrdersFacts" "OrdersFacts.CompareBasedOrderFacts.compare_nle_iff".
rewrite <- compare_le_iff.
destruct compare; split; easy || now destruct 1.
Qed.

Lemma compare_nge_iff x y : (x ?= y) = Lt <-> ~(y<=x).
Proof. hammer_hook "OrdersFacts" "OrdersFacts.CompareBasedOrderFacts.compare_nge_iff".
now rewrite <- compare_nle_iff, compare_antisym, CompOpp_iff.
Qed.

Lemma lt_irrefl x : ~ (x<x).
Proof. hammer_hook "OrdersFacts" "OrdersFacts.OrderedTypeFacts.lt_irrefl".
now rewrite <- compare_lt_iff, compare_refl.
Qed.

Lemma lt_eq_cases n m : n <= m <-> n < m \/ n==m.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.CompareBasedOrderFacts.lt_eq_cases".
rewrite <- compare_lt_iff, <- compare_le_iff, <- compare_eq_iff.
destruct (n ?= m); now intuition.
Qed.

End CompareBasedOrderFacts.

Module Type BoolOrderFacts
(Import E:EqLtLe')
(Import C:HasCmp E)
(Import F:HasBoolOrdFuns' E)
(Import O:CompareBasedOrder E C)
(Import S:BoolOrdSpecs E F).

Include CompareBasedOrderFacts E C O.

Lemma leb_spec0 x y : reflect (x<=y) (x<=?y).
Proof. hammer_hook "OrdersFacts" "OrdersFacts.BoolOrderFacts.leb_spec0".
apply iff_reflect. symmetry. apply leb_le.
Defined.

Lemma leb_spec x y : BoolSpec (x<=y) (y<x) (x<=?y).
Proof. hammer_hook "OrdersFacts" "OrdersFacts.BoolOrderFacts.leb_spec".
case leb_spec0; constructor; trivial.
now rewrite <- compare_lt_iff, compare_nge_iff.
Qed.

Lemma ltb_spec0 x y : reflect (x<y) (x<?y).
Proof. hammer_hook "OrdersFacts" "OrdersFacts.BoolOrderFacts.ltb_spec0".
apply iff_reflect. symmetry. apply ltb_lt.
Defined.

Lemma ltb_spec x y : BoolSpec (x<y) (y<=x) (x<?y).
Proof. hammer_hook "OrdersFacts" "OrdersFacts.BoolOrderFacts.ltb_spec".
case ltb_spec0; constructor; trivial.
now rewrite <- compare_le_iff, compare_ngt_iff.
Qed.

Lemma leb_nle x y : x <=? y = false <-> ~ (x <= y).
Proof. hammer_hook "OrdersFacts" "OrdersFacts.BoolOrderFacts.leb_nle".
now rewrite <- not_true_iff_false, leb_le.
Qed.

Lemma leb_gt x y : x <=? y = false <-> y < x.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.BoolOrderFacts.leb_gt".
now rewrite leb_nle, <- compare_lt_iff, compare_nge_iff.
Qed.

Lemma ltb_nlt x y : x <? y = false <-> ~ (x < y).
Proof. hammer_hook "OrdersFacts" "OrdersFacts.BoolOrderFacts.ltb_nlt".
now rewrite <- not_true_iff_false, ltb_lt.
Qed.

Lemma ltb_ge x y : x <? y = false <-> y <= x.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.BoolOrderFacts.ltb_ge".
now rewrite ltb_nlt, <- compare_le_iff, compare_ngt_iff.
Qed.

Lemma leb_refl x : x <=? x = true.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.BoolOrderFacts.leb_refl".
apply leb_le. apply lt_eq_cases. now right.
Qed.

Lemma leb_antisym x y : y <=? x = negb (x <? y).
Proof. hammer_hook "OrdersFacts" "OrdersFacts.BoolOrderFacts.leb_antisym".
apply eq_true_iff_eq. now rewrite negb_true_iff, leb_le, ltb_ge.
Qed.

Lemma ltb_irrefl x : x <? x = false.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.BoolOrderFacts.ltb_irrefl".
apply ltb_ge. apply lt_eq_cases. now right.
Qed.

Lemma ltb_antisym x y : y <? x = negb (x <=? y).
Proof. hammer_hook "OrdersFacts" "OrdersFacts.BoolOrderFacts.ltb_antisym".
apply eq_true_iff_eq. now rewrite negb_true_iff, ltb_lt, leb_gt.
Qed.

Lemma eqb_compare x y :
(x =? y) = match compare x y with Eq => true | _ => false end.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.BoolOrderFacts.eqb_compare".
apply eq_true_iff_eq. rewrite eqb_eq, <- compare_eq_iff.
now destruct compare.
Qed.

Lemma ltb_compare x y :
(x <? y) = match compare x y with Lt => true | _ => false end.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.BoolOrderFacts.ltb_compare".
apply eq_true_iff_eq. rewrite ltb_lt, <- compare_lt_iff.
now destruct compare.
Qed.

Lemma leb_compare x y :
(x <=? y) = match compare x y with Gt => false | _ => true end.
Proof. hammer_hook "OrdersFacts" "OrdersFacts.BoolOrderFacts.leb_compare".
apply eq_true_iff_eq. rewrite leb_le, <- compare_le_iff.
now destruct compare.
Qed.

End BoolOrderFacts.


Section exercise_1B6.
  Require Import VS.Classes.
  Require Import QArith.
  Local Open Scope Q_scope.

  Inductive ExtendedQ : Type :=
    | pinf : ExtendedQ
    | ninf : ExtendedQ
    | fromRat (x : Q) : ExtendedQ.

  Definition EQ_add (x y : ExtendedQ) : ExtendedQ :=
    match x, y with
    | pinf, pinf => pinf
    | pinf, ninf => fromRat 0
    | pinf, fromRat y' => pinf
    | ninf, pinf => fromRat 0
    | ninf, ninf => ninf
    | ninf, fromRat y' => ninf
    | fromRat x', pinf => pinf
    | fromRat x', ninf => ninf
    | fromRat x', fromRat y' => fromRat (x' + y')
    end.

  Definition EQ_smult (x : Q) (y : ExtendedQ) : ExtendedQ :=
    match Q_dec x 0 with
    | inleft (left _) => match y with
                         | pinf => ninf
                         | ninf => pinf
                         | fromRat y' => fromRat (y' + x)
                         end
    | inleft (right _) => match y with
                       | pinf => pinf
                       | ninf => ninf
                       | fromRat y' => fromRat (y' + x)
                       end
    | inright _ => fromRat 0
    end.

  Theorem Q_isring : ring_theory 0 1 Qplus Qmult Qminus Qopp eq.
    Proof.
      Admitted.

  Instance QRing : Ring Q :=
    {
    r0 := 0;
    r1 := 1;
    radd  := Qplus;
    rmult := Qmult;
    rainv := Qopp;
    rminus := Qminus;
    req := eq;
    isring := Q_isring;
    }.
  Check Qinv.

  Theorem Q_isfield : field_theory 0 1 Qplus Qmult Qminus Qopp Qdiv Qinv eq.
  Proof.
    Admitted.

  Instance QField : Field Q :=
    {
    fdiv := Qdiv;
    finv := Qinv;
    isfield := Q_isfield
    }.

  Theorem ExtendedQ_isvectorspace : vectorspace_theory EQ_smult EQ_add (fromRat 0).
  Proof.
    split; intros.
    - induction x; induction y; simpl; try reflexivity.
  Admitted.

End exercise_1B6.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e510m290x2e496m1_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e384m79x2e376m1_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


(***************************************************************************
* Formalization of SN for the lambda_ex calculus			   *
*									   *
* General rewriting definitions	for explicit substitutions		   *
*									   *
* Fabien Renaud & Stephane Zimmerman, 2011				   *
* Flavio L. C. de Moura & Daniel L. Ventura & Washington R. Segundo, 2017  *
***************************************************************************)

Require Import Metatheory.
Require Import LambdaES_Defs LambdaESLab.
Require Import List.

Inductive ESlab_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
| ESlab_redex : forall t s, Red t s -> ESlab_contextual_closure Red t s
| ESlab_app_left : forall t t' u, ESlab_contextual_closure Red t t' ->
	  		          ESlab_contextual_closure Red (pterm_app t u) (pterm_app t' u)
| ESlab_app_right : forall t u u', ESlab_contextual_closure Red u u' ->
	  		           ESlab_contextual_closure Red (pterm_app t u) (pterm_app t u')
| ESlab_abs_in : forall t t' L, (forall x, x \notin L -> ESlab_contextual_closure Red (t^x) (t'^x)) ->
                                ESlab_contextual_closure Red (pterm_abs t) (pterm_abs t')
| ESlab_subst_left : forall t t' u L, (forall x, x \notin L -> ESlab_contextual_closure Red (t^x) (t'^x)) ->
                                      ESlab_contextual_closure Red  (pterm_sub t u) (pterm_sub t' u)
| ESlab_subst_right : forall t u u', ESlab_contextual_closure Red u u' ->
	  	                     ESlab_contextual_closure Red  (pterm_sub t u) (pterm_sub t u')
| ESlab_lsubst_left : forall t t' u L, (forall x, x \notin L -> ESlab_contextual_closure Red (t^x) (t'^x)) -> ESlab_contextual_closure Red  (pterm_sub t u) (pterm_sub t' u)
| ESlab_lsubst_right : forall t u u', ESlab_contextual_closure Red u u' ->
	  	                      ESlab_contextual_closure Red  (pterm_sub' t u) (pterm_sub' t u').

Inductive ESlab_p_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | ESlab_p_redex : forall t s, Red t s -> ESlab_p_contextual_closure Red t s
  | ESlab_p_app : forall t t' u u', ESlab_p_contextual_closure Red t t' -> ESlab_p_contextual_closure Red u u' ->
	  		          ESlab_p_contextual_closure Red (pterm_app t u) (pterm_app t' u')
  | ESlab_p_abs_in : forall t t' L, (forall x, x \notin L -> ESlab_p_contextual_closure Red (t^x) (t'^x)) ->
                                  ESlab_p_contextual_closure Red (pterm_abs t) (pterm_abs t')
  | ESlab_p_subst : forall t t' u u' L, (forall x, x \notin L -> ESlab_p_contextual_closure Red (t^x) (t'^x)) ->
                                      ESlab_p_contextual_closure Red u u' ->
	                              ESlab_p_contextual_closure Red  (pterm_sub t u) (pterm_sub t' u')
  | ESlab_p_lsubst : forall t t' u u' L, (forall x, x \notin L -> ESlab_p_contextual_closure Red (t^x) (t'^x)) ->
                                       ESlab_p_contextual_closure Red u u' ->
	                               ESlab_p_contextual_closure Red (t[[u]]) (t'[[u']]).

Hint Constructors ESlab_contextual_closure ESlab_p_contextual_closure.


From Coq Require Import Program.Equality.
From Coq Require Import Lia.
From Coq Require Import ClassicalChoice.

From Coq Require Export Ensembles.
From ZornsLemma Require Import EnsemblesImplicit.
From ZornsLemma Require Export Families.
From ZornsLemma Require Export FiniteTypes.
From ZornsLemma Require Export IndexedFamilies.
From ZornsLemma Require Export CountableTypes.
From ZornsLemma Require Import Proj1SigInjective.
From ZornsLemma Require Export Powerset_facts.

Inductive finite_intersections {X:Type} (S:Family X) : Family X :=
  | intro_full: In (finite_intersections S) Full_set
  | intro_S: forall U:Ensemble X, In S U -> In (finite_intersections S) U
  | intro_intersection: forall U V:Ensemble X,
    In (finite_intersections S) U -> In (finite_intersections S) V ->
    In (finite_intersections S) (Intersection U V).

Lemma finite_intersection_is_finite_indexed_intersection:
  forall {X:Type} (S:Family X) (U:Ensemble X),
  In (finite_intersections S) U -> exists J:Type, FiniteT J /\
  exists V:J->Ensemble X,
  (forall j:J, In S (V j)) /\ U = IndexedIntersection V.
Proof.
intros.
induction H.
- exists False.
  split.
  + constructor.
  + exists (False_rect _).
    split.
    * destruct j.
    * symmetry; apply empty_indexed_intersection.
- exists True.
  split.
  + exact True_finite.
  + exists (True_rect U).
    split.
    * destruct j.
      simpl. assumption.
    * apply Extensionality_Ensembles; split; red; intros.
      -- constructor.
         destruct a; simpl.
         assumption.
      -- destruct H0.
         exact (H0 I).
- destruct IHfinite_intersections as [J0 [? [W []]]].
  destruct IHfinite_intersections0 as [J1 [? [W' []]]].
  exists ((J0+J1)%type).
  split.
  + apply finite_sum; trivial.
  + exists (fun s:J0+J1 => match s with
    | inl j => W j
    | inr j => W' j
    end).
    split.
    * destruct j; auto.
    * apply Extensionality_Ensembles; split; red; intros.
      -- destruct H7.
         rewrite H3 in H7; destruct H7.
         rewrite H6 in H8; destruct H8.
         constructor.
         destruct a as [j|j]; auto.
      -- destruct H7.
         constructor.
         ++ rewrite H3; constructor.
            intro j.
            exact (H7 (inl _ j)).
         ++ rewrite H6; constructor.
            intro j.
            exact (H7 (inr _ j)).
Qed.

Lemma finite_indexed_intersection_is_finite_intersection:
  forall {X:Type} (S:Family X) (J:Type) (V:J->Ensemble X),
  FiniteT J -> (forall j:J, In S (V j)) ->
  In (finite_intersections S) (IndexedIntersection V).
Proof.
intros.
induction H.
- rewrite empty_indexed_intersection.
  constructor.
- rewrite IndexedIntersection_option_Intersection.
  constructor 3; auto.
  constructor 2; trivial.
- rewrite IndexedIntersection_surj_fn with V f.
  2: {
    apply invertible_impl_bijective in H1.
    destruct H1. assumption.
  }
  apply IHFiniteT.
  auto.
Qed.

Section Lemmas.
Open Scope nat.

Inductive finite_intersections_len {X : Type} (F : Family X) : IndexedFamily nat (Ensemble X) :=
  | intro_fi_len_full : In (finite_intersections_len F 0) Full_set
  | intro_fi_len_S : forall U : Ensemble X, In F U -> In (finite_intersections_len F 1) U
  | intro_fi_len_intersection : forall (U V : Ensemble X) (m k : nat),
                         In (finite_intersections_len F m) U ->
                         In (finite_intersections_len F k) V ->
                         In (finite_intersections_len F (m + k)) (Intersection U V).

Lemma finite_intersections_len_0_full_set
  {X : Type}
  {F : Family X}
  {U : Ensemble X} :
  In (finite_intersections_len F 0) U -> U = Full_set.
Proof.
intro H.
red in H.
dependent induction H.
{ reflexivity. }
rewrite IHfinite_intersections_len.
2: { lia. }
rewrite Intersection_Full_set.
rewrite IHfinite_intersections_len0.
{ reflexivity. }
lia.
Qed.

Lemma finite_intersections_len_1_in
  {X : Type}
  {F : Family X}
  {U : Ensemble X} :
  In (finite_intersections_len F 1) U -> In F U.
Proof.
intro H.
red in H.
dependent induction H.
- assumption.
- destruct m, k;
    discriminate + injection x as x;
    subst.
  + rewrite (finite_intersections_len_0_full_set H), Intersection_Full_set.
    now apply IHfinite_intersections_len0.
  + rewrite (finite_intersections_len_0_full_set H0), Intersection_commutative, Intersection_Full_set.
    apply IHfinite_intersections_len.
    lia.
  + lia.
Qed.

Lemma finite_intersections_len_SS_intersection
  {X : Type}
  {F : Family X}
  {U : Ensemble X}
  (n : nat) :
  In (finite_intersections_len F (S (S n))) U ->
  exists m k V W,
    In (finite_intersections_len F (S m)) V /\
    In (finite_intersections_len F (S k)) W /\
    U = Intersection V W /\
    n = m + k.
Proof.
intro H.
red in H.
dependent induction H.
- destruct m, k;
    discriminate + injection x as x;
    subst.
  + rewrite (finite_intersections_len_0_full_set H), Intersection_Full_set.
    now apply IHfinite_intersections_len0.
  + rewrite (finite_intersections_len_0_full_set H0), Intersection_commutative, Intersection_Full_set.
    apply IHfinite_intersections_len.
    lia.
  + exists m, k, U, V.
    repeat split;
      lia + assumption.
Qed.

Lemma finite_intersections_len_S_exists
  {X : Type}
  {F : Family X}
  {U : Ensemble X}
  {n : nat} :
  In (finite_intersections_len F (S n)) U ->
  exists V W,
    In (finite_intersections_len F n) V /\
    In (finite_intersections_len F 1) W /\
    U = Intersection V W.
Proof.
generalize dependent U.
generalize dependent n.
apply (well_founded_ind lt_wf (fun n =>
  forall U,
    In (finite_intersections_len F (S n)) U ->
  exists V W,
    In (finite_intersections_len F n) V /\
    In (finite_intersections_len F 1) W /\
    U = Intersection V W)).
intros [|n] IH U H.
- apply finite_intersections_len_1_in in H.
  exists Full_set, U.
  now repeat split;
    constructor + rewrite Intersection_Full_set.
- apply finite_intersections_len_SS_intersection in H.
  destruct H as [m [[|k] [V [W [HV [HW [eq1 eq2]]]]]]].
  + rewrite Nat.add_0_r in eq2.
    subst.
    now exists V, W.
  + apply IH in HV; [|lia].
    destruct HV as [V1 [V2 [HV1 [HV2 eq3]]]].
    rewrite eq2, plus_n_Sm.
    exists (Intersection V1 W), V2.
    repeat (constructor; try easy).
    subst.
    now rewrite (Intersection_associative V1 W),
                (Intersection_commutative _ W),
             <- (Intersection_associative V1).
Qed.

Lemma finite_intersections_len_S_choice
  {X : Type}
  (F : Family X)
  (n : nat) :
  exists f : {U : Ensemble X | In (finite_intersections_len F (S n)) U} ->
             {U : Ensemble X | In (finite_intersections_len F n) U} *
             {U : Ensemble X | In (finite_intersections_len F 1) U},
  forall U, proj1_sig U = Intersection (proj1_sig (fst (f U))) (proj1_sig (snd (f U))).
Proof.
apply choice with (R :=
  fun U : {U : Ensemble X | In (finite_intersections_len F (S n)) U} =>
  fun y : {U : Ensemble X | In (finite_intersections_len F n) U} *
          {U : Ensemble X | In (finite_intersections_len F 1) U} =>
    proj1_sig U = Intersection (proj1_sig (fst y)) (proj1_sig (snd y))).
intros [? HU].
destruct (finite_intersections_len_S_exists HU) as [V [W [HV [HW ?]]]].
now exists (exist _ V HV, exist _ W HW).
Qed.

Lemma finite_intersections_len_union
  {X : Type}
  (F : Family X) :
  IndexedUnion (finite_intersections_len F) = finite_intersections F.
Proof.
apply Extensionality_Ensembles.
split.
- intros ? [n U HU].
  red in HU.
  dependent induction HU.
  + apply intro_full.
  + now apply intro_S.
  + now apply intro_intersection.
- intros ? HU.
  red in HU.
  dependent induction HU;
    try destruct IHHU, IHHU0;
    econstructor.
  + constructor.
  + now apply intro_fi_len_S.
  + apply intro_fi_len_intersection.
    * exact H1.
    * exact H2.
Qed.

Lemma finite_intersections_countable
  {X : Type}
  (F : Family X) :
  Countable F -> Countable (finite_intersections F).
Proof.
intros [f Hf].
rewrite <- finite_intersections_len_union.
apply countable_indexed_union.
- apply nat_countable.
- intro n.
  induction n.
  + apply intro_nat_injection with (fun x => 0).
    intros [U HU] [V HV] eq.
    apply proj1_sig_injective.
    simpl.
    now rewrite (finite_intersections_len_0_full_set HU),
                (finite_intersections_len_0_full_set HV).
  + destruct (finite_intersections_len_S_choice F n) as [g Hg],
             IHn as [fn Hfn].
    refine (inj_countable (fun U =>
      (fn (fst (g U)),
       f (exist _ (proj1_sig (snd (g U))) _)))
      countable_nat_product _).
    intros [U HU] [V HV] eq.
  injection eq as eq1 eq2.
  apply Hfn, proj1_sig_eq in eq1.
  apply Hf, proj1_sig_eq in eq2.
  apply Proj1SigInjective.proj1_sig_injective.
  now rewrite Hg, Hg, eq1, eq2.
  Unshelve.
  destruct (snd (g U)).
  now apply finite_intersections_len_1_in.
Qed.

End Lemmas.