(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 12: Hoare Logic: Verifying Imperative Programs
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap.

(** * Syntax and semantics of a simple imperative language *)

(* Here's some appropriate syntax for expressions (side-effect-free) of a simple
 * imperative language with a mutable memory. *)
Inductive exp :=
| Const (n : nat)
| Var (x : string)
| Read (e1 : exp)
| Plus (e1 e2 : exp)
| Minus (e1 e2 : exp)
| Mult (e1 e2 : exp).

(* Those were the expressions of numeric type.  Here are the Boolean
 * expressions. *)
Inductive bexp :=
| Equal (e1 e2 : exp)
| Less (e1 e2 : exp).

Definition heap := fmap nat nat.
Definition valuation := fmap var nat.
Definition assertion := heap -> valuation -> Prop.

(* Here's the syntax of side-effecting commands, where we attach an assertion to
 * every "while" loop, for reasons that should become clear later.  The
 * assertion is ignored in the operational semantics! *)
Inductive cmd :=
| Skip
| Assign (x : var) (e : exp)
| Write (e1 e2 : exp)
| Seq (c1 c2 : cmd)
| If_ (be : bexp) (then_ else_ : cmd)
| While_ (inv : assertion) (be : bexp) (body : cmd)

(* And one more, which we'll use to characterize program correctness more
 * simply: *)
| Assert (a : assertion).

(* Shorthand notation for looking up in a finite map, returning zero if the key
 * is not found *)
Notation "m $! k" := (match m $? k with Some n => n | None => O end) (at level 30).

(* Start of expression semantics: meaning of expressions *)
Fixpoint eval (e : exp) (h : heap) (v : valuation) : nat :=
  match e with
  | Const n => n
  | Var x => v $! x
  | Read e1 => h $! eval e1 h v
  | Plus e1 e2 => eval e1 h v + eval e2 h v
  | Minus e1 e2 => eval e1 h v - eval e2 h v
  | Mult e1 e2 => eval e1 h v * eval e2 h v
  end.

(* Meaning of Boolean expressions *)
Fixpoint beval (b : bexp) (h : heap) (v : valuation) : bool :=
  match b with
  | Equal e1 e2 => if eval e1 h v ==n eval e2 h v then true else false
  | Less e1 e2 => if eval e2 h v <=? eval e1 h v then false else true
  end.

(* A big-step operational semantics for commands *)
Inductive exec : heap -> valuation -> cmd -> heap -> valuation -> Prop :=
| ExSkip : forall h v,
  exec h v Skip h v
| ExAssign : forall h v x e,
  exec h v (Assign x e) h (v $+ (x, eval e h v))
| ExWrite : forall h v e1 e2,
  exec h v (Write e1 e2) (h $+ (eval e1 h v, eval e2 h v)) v
| ExSeq : forall h1 v1 c1 h2 v2 c2 h3 v3,
  exec h1 v1 c1 h2 v2
  -> exec h2 v2 c2 h3 v3
  -> exec h1 v1 (Seq c1 c2) h3 v3
| ExIfTrue : forall h1 v1 b c1 c2 h2 v2,
  beval b h1 v1 = true
  -> exec h1 v1 c1 h2 v2
  -> exec h1 v1 (If_ b c1 c2) h2 v2
| ExIfFalse : forall h1 v1 b c1 c2 h2 v2,
  beval b h1 v1 = false
  -> exec h1 v1 c2 h2 v2
  -> exec h1 v1 (If_ b c1 c2) h2 v2
| ExWhileFalse : forall I h v b c,
  beval b h v = false
  -> exec h v (While_ I b c) h v
| ExWhileTrue : forall I h1 v1 b c h2 v2 h3 v3,
  beval b h1 v1 = true
  -> exec h1 v1 c h2 v2
  -> exec h2 v2 (While_ I b c) h3 v3
  -> exec h1 v1 (While_ I b c) h3 v3

(* Assertions execute only when they are true.  They provide a way to embed
 * proof obligations within programs. *)
| ExAssert : forall h v (a : assertion),
  a h v
  -> exec h v (Assert a) h v.

(** * Hoare logic *)

(* Here's an inductive predicate capturing a class of *proved* specifications
 * for commands.  The intuition is that, when [hoare_triple P c Q], we know
 * that, when we start [c] in a state satisfying [P], if [c] finishes, its final
 * state satisfies [Q]. *)

Inductive hoare_triple : assertion -> cmd -> assertion -> Prop :=
| HtSkip : forall P, hoare_triple P Skip P
| HtAssign : forall (P : assertion) x e,
  hoare_triple P (Assign x e) (fun h v => exists v', P h v' /\ v = v' $+ (x, eval e h v'))
| HtWrite : forall (P : assertion) (e1 e2 : exp),
  hoare_triple P (Write e1 e2) (fun h v => exists h', P h' v /\ h = h' $+ (eval e1 h' v, eval e2 h' v))
| HtSeq : forall (P Q R : assertion) c1 c2,
  hoare_triple P c1 Q
  -> hoare_triple Q c2 R
  -> hoare_triple P (Seq c1 c2) R
| HtIf : forall (P Q1 Q2 : assertion) b c1 c2,
  hoare_triple (fun h v => P h v /\ beval b h v = true) c1 Q1
  -> hoare_triple (fun h v => P h v /\ beval b h v = false) c2 Q2
  -> hoare_triple P (If_ b c1 c2) (fun h v => Q1 h v \/ Q2 h v)
| HtWhile : forall (I P : assertion) b c,
  (forall h v, P h v -> I h v)
  -> hoare_triple (fun h v => I h v /\ beval b h v = true) c I
  -> hoare_triple P (While_ I b c) (fun h v => I h v /\ beval b h v = false)
| HtAssert : forall P I : assertion,
  (forall h v, P h v -> I h v)
  -> hoare_triple P (Assert I) P
| HtConsequence : forall (P Q P' Q' : assertion) c,
  hoare_triple P c Q
  -> (forall h v, P' h v -> P h v)
  -> (forall h v, Q h v -> Q' h v)
  -> hoare_triple P' c Q'.

(* Let's prove that the intuitive description given above really applies to this
 * predicate.  First, a lemma, which is difficult to summarize intuitively!
 * More or less precisely this obligation shows up in the main proof below. *)
Lemma hoare_triple_big_step_while: forall (I : assertion) b c,
  (forall h v h' v', exec h v c h' v'
                     -> I h v
                     -> beval b h v = true
                     -> I h' v')
  -> forall h v h' v', exec h v (While_ I b c) h' v'
                       -> I h v
                       -> I h' v' /\ beval b h' v' = false.
Proof.
  induct 2; eauto.
Qed.

(* That main theorem statement literally translates our intuitive description of
 * [hoare_triple] from above. *)
Theorem hoare_triple_big_step : forall pre c post,
    hoare_triple pre c post
    -> forall h v h' v', exec h v c h' v'
                         -> pre h v
                         -> post h' v'.
Proof.
  induct 1; eauto; invert 1; eauto.

  simplify.
  eapply hoare_triple_big_step_while; eauto.
Qed.

(* BEGIN syntax macros that won't be explained *)
Coercion Const : nat >-> exp.
Coercion Var : string >-> exp.
Notation "*[ e ]" := (Read e) : cmd_scope.
Infix "+" := Plus : cmd_scope.
Infix "-" := Minus : cmd_scope.
Infix "*" := Mult : cmd_scope.
Infix "=" := Equal : cmd_scope.
Infix "<" := Less : cmd_scope.
Definition set (dst src : exp) : cmd :=
  match dst with
  | Read dst' => Write dst' src
  | Var dst' => Assign dst' src
  | _ => Assign "Bad LHS" 0
  end.
Infix "<-" := set (no associativity, at level 70) : cmd_scope.
Infix ";;" := Seq (right associativity, at level 75) : cmd_scope.
Notation "'when' b 'then' then_ 'else' else_ 'done'" := (If_ b then_ else_) (at level 75, b at level 0).
Notation "{{ I }} 'while' b 'loop' body 'done'" := (While_ I b body) (at level 75).
Notation "'assert' {{ I }}" := (Assert I) (at level 75).
Delimit Scope cmd_scope with cmd.

Infix "+" := plus : reset_scope.
Infix "-" := Init.Nat.sub : reset_scope.
Infix "*" := mult : reset_scope.
Infix "=" := eq : reset_scope.
Infix "<" := lt : reset_scope.
Delimit Scope reset_scope with reset.
Open Scope reset_scope.
(* END macros *)

(* We should draw some attention to the next notation, which defines special
 * lambdas for writing assertions. *)
Notation "h & v ~> e" := (fun h v => e%reset) (at level 85, v at level 0).

(* And here's the classic notation for Hoare triples. *)
Notation "{{ P }} c {{ Q }}" := (hoare_triple P c%cmd Q) (at level 90, c at next level).

(* Special case of consequence: keeping the precondition; only changing the
 * postcondition. *)
Lemma HtStrengthenPost : forall (P Q Q' : assertion) c,
  hoare_triple P c Q
  -> (forall h v, Q h v -> Q' h v)
  -> hoare_triple P c Q'.
Proof.
  simplify; eapply HtConsequence; eauto.
Qed.

(* Finally, three tactic definitions that we won't explain.  The overall tactic
 * [ht] tries to prove Hoare triples, essentially by rote application of the
 * rules.  Some other obligations are generated, generally of implications
 * between assertions, and [ht] also makes a best effort to solve those. *)

Ltac ht1 := apply HtSkip || apply HtAssign || apply HtWrite || eapply HtSeq
            || eapply HtIf || eapply HtWhile || eapply HtAssert
            || eapply HtStrengthenPost.

Ltac t := cbv beta; propositional; subst;
          repeat match goal with
                 | [ H : ex _ |- _ ] => invert H; propositional; subst
                 end;
          simplify;
          repeat match goal with
                 | [ _ : context[?a <=? ?b] |- _ ] => destruct (a <=? b); try discriminate
                 | [ H : ?E = ?E |- _ ] => clear H
                 end; simplify; propositional; auto; try equality; try linear_arithmetic.

Ltac ht := simplify; repeat ht1; t.

(** * Some examples of verified programs *)

(** ** Swapping the values in two variables *)

(* First, let's prove it with more manual applications of the Hoare-logic
 * rules. *)
Theorem swap_ok : forall a b,
  {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
    "tmp" <- "x";;
    "x" <- "y";;
    "y" <- "tmp"
  {{_&v ~> v $! "x" = b /\ v $! "y" = a}}.
Proof.
  simplify.
  eapply HtSeq.
  apply HtAssign.
  eapply HtSeq.
  apply HtAssign.
  eapply HtStrengthenPost.
  apply HtAssign.
  simplify.
  t.
Qed.

(* We can also automate the proof easily. *)
Theorem swap_ok_snazzy : forall a b,
  {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
    "tmp" <- "x";;
    "x" <- "y";;
    "y" <- "tmp"
  {{_&v ~> v $! "x" = b /\ v $! "y" = a}}.
Proof.
  ht.
Qed.

(** ** Computing the maximum of two variables *)

Theorem max_ok : forall a b,
  {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
    when "x" < "y" then
      "m" <- "y"
    else
      "m" <- "x"
    done
  {{_&v ~> v $! "m" = max a b}}.
Proof.
  simplify.
  eapply HtStrengthenPost.
  apply HtIf.
  apply HtAssign.
  apply HtAssign.
  simplify.
  t.
Qed.

Theorem max_ok_snazzy : forall a b,
  {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
    when "x" < "y" then
      "m" <- "y"
    else
      "m" <- "x"
    done
  {{_&v ~> v $! "m" = max a b}}.
Proof.
  ht.
Qed.

(** ** Iterative factorial *)

(* These two rewrite rules capture the definition of functional [fact], in
 * exactly the form useful in our Hoare-logic proof. *)
Lemma fact_base : forall n,
  n = 0
  -> fact n = 1.
Proof.
  simplify; subst; auto.
Qed.

Hint Rewrite <- minus_n_O.

Lemma fact_rec : forall n,
  n > 0
  -> fact n = n * fact (n - 1).
Proof.
  simplify; cases n; simplify; linear_arithmetic.
Qed.

Hint Rewrite fact_base fact_rec using linear_arithmetic.

(* Note the careful choice of loop invariant below.  It may look familiar from
 * earlier chapters' proofs! *)
Theorem fact_ok : forall n,
  {{_&v ~> v $! "n" = n}}
    "acc" <- 1;;
    {{_&v ~> v $! "acc" * fact (v $! "n") = fact n}}
    while 0 < "n" loop
      "acc" <- "acc" * "n";;
      "n" <- "n" - 1
    done
  {{_&v ~> v $! "acc" = fact n}}.
Proof.
  simplify.
  eapply HtSeq.
  apply HtAssign.
  eapply HtStrengthenPost.
  eapply HtWhile.
  simplify.
  t.
  eapply HtSeq.
  apply HtAssign.
  eapply HtStrengthenPost.
  apply HtAssign.
  simplify.
  t.
  ring [H0].
  (* This variant of [ring] suggests a hypothesis to use in the proof. *)
  simplify.
  t.
Qed.

Theorem fact_ok_snazzy : forall n,
  {{_&v ~> v $! "n" = n}}
    "acc" <- 1;;
    {{_&v ~> v $! "acc" * fact (v $! "n") = fact n}}
    while 0 < "n" loop
      "acc" <- "acc" * "n";;
      "n" <- "n" - 1
    done
  {{_&v ~> v $! "acc" = fact n}}.
Proof.
  ht.
  ring [H0].
Qed.

(** ** Selection sort *)

(* This is our one example of a program reading/writing memory, which holds the
 * representation of an array that we want to sort in-place. *)

(* One simple lemma turns out to be helpful to guide [eauto] properly. *)
Lemma leq_f : forall A (m : fmap A nat) x y,
  x = y
  -> m $! x <= m $! y.
Proof.
  ht.
Qed.

Hint Resolve leq_f.
Hint Extern 1 (@eq nat _ _) => linear_arithmetic.
Hint Extern 1 (_ < _) => linear_arithmetic.
Hint Extern 1 (_ <= _) => linear_arithmetic.
(* We also register [linear_arithmetic] as a step to try during proof search. *)

(* These invariants are fairly hairy, but probably the best way to understand
 * them is just to spend a while reading them.  They generally talk about
 * sortedness of subsets of the array.  See the final postcondition for how we
 * interpret a part of memory as an array.  Also note that we only prove here
 * that the final array is sorted, *not* that it's a permutation of the original
 * array!  (Exercise for the reader?  I'm not sure how much work it would
 * take.) *)
Theorem selectionSort_ok :
  {{_&_ ~> True}}
    "i" <- 0;;
    {{h&v ~> v $! "i" <= v $! "n"
        /\ (forall i j, i < j < v $! "i" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j))
        /\ (forall i j, i < v $! "i" -> v $! "i" <= j < v $! "n" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j)) }}
    while "i" < "n" loop
      "j" <- "i"+1;;
      "best" <- "i";;
      {{h&v ~> v $! "i" < v $! "j" <= v $! "n"
         /\ v $! "i" <= v $! "best" < v $! "n"
         /\ (forall k, v $! "i" <= k < v $! "j" -> h $! (v $! "a" + v $! "best") <= h $! (v $! "a" + k))
         /\ (forall i j, i < j < v $! "i" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j))
         /\ (forall i j, i < v $! "i" -> v $! "i" <= j < v $! "n" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j)) }}
      while "j" < "n" loop
        when *["a" + "j"] < *["a" + "best"] then
          "best" <- "j"
        else
          Skip
        done;;
        "j" <- "j" + 1
      done;;
      "tmp" <- *["a" + "best"];;
      *["a" + "best"] <- *["a" + "i"];;
      *["a" + "i"] <- "tmp";;
      "i" <- "i" + 1
    done
  {{h&v ~> forall i j, i < j < v $! "n" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j)}}.
Proof.
  ht; repeat match goal with
             | [ |- context[_ $+ (?a + ?x, _) $! (?a + ?y)] ] =>
               cases (x ==n y); ht
             end.

  cases (k ==n x0 $! "j"); ht.
  specialize (H k); ht.

  cases (k ==n x $! "j"); ht.
Qed.

(** * An alternative correctness theorem for Hoare logic, with small-step semantics *)

(* In case you were worried that this chapter is too far removed from the
 * pattern of program reasoning we've seen recur again and again, help is here!
 * We can also characterize Hoare triples in terms of invariants of transition
 * systems.  To start with, here's a small-step semantics for our running
 * language. *)
Inductive step : heap * valuation * cmd -> heap * valuation * cmd -> Prop :=
| StAssign : forall h v x e,
  step (h, v, Assign x e) (h, v $+ (x, eval e h v), Skip)
| StWrite : forall h v e1 e2,
  step (h, v, Write e1 e2) (h $+ (eval e1 h v, eval e2 h v), v, Skip)
| StStepSkip : forall h v c,
  step (h, v, Seq Skip c) (h, v, c)
| StStepRec : forall h1 v1 c1 h2 v2 c1' c2,
  step (h1, v1, c1) (h2, v2, c1')
  -> step (h1, v1, Seq c1 c2) (h2, v2, Seq c1' c2)
| StIfTrue : forall h v b c1 c2,
  beval b h v = true
  -> step (h, v, If_ b c1 c2) (h, v, c1)
| StIfFalse : forall h v b c1 c2,
  beval b h v = false
  -> step (h, v, If_ b c1 c2) (h, v, c2)
| StWhileFalse : forall I h v b c,
  beval b h v = false
  -> step (h, v, While_ I b c) (h, v, Skip)
| StWhileTrue : forall I h v b c,
  beval b h v = true
  -> step (h, v, While_ I b c) (h, v, Seq c (While_ I b c))
| StAssert : forall h v (a : assertion),
  a h v
  -> step (h, v, Assert a) (h, v, Skip).

Hint Constructors step.

Definition trsys_of (st : heap * valuation * cmd) := {|
  Initial := {st};
  Step := step
|}.

(* We'll characterize *unstuckness* in roughly the same way as we did for
 * lambda-calculus type soundness: the program is done (reached [Skip]) or can
 * take a step. *)
Definition unstuck (st : heap * valuation * cmd) :=
  snd st = Skip
  \/ exists st', step st st'.

(* A convenient property of Hoare triples: they rule out stuckness, regardless
 * of the specs we choose, so long as the precondition accurately describes the
 * real execution state!  Note that the only real possibility for stuckness in
 * the semantics is via [Assert], which is why we included it.  We reduce
 * arbitrary correctness checks, on intermediate program states, to stuckness or
 * lack thereof in program execution. *)
Lemma hoare_triple_unstuck : forall P c Q,
  {{P}} c {{Q}}
  -> forall h v, P h v
                 -> unstuck (h, v, c).
Proof.
  induct 1; unfold unstuck; simplify; propositional; eauto.

  apply IHhoare_triple1 in H1.
  unfold unstuck in H1; simplify; first_order; subst; eauto.
  cases x.
  cases p.
  eauto.

  cases (beval b h v); eauto.

  cases (beval b h v); eauto.

  apply H0 in H2.
  apply IHhoare_triple in H2.
  unfold unstuck in H2; simplify; first_order.
Qed.

(* Another basic property: [Skip] has no effect on program state, and the set of
 * derivable specs for [Skip] reflects that fact. *)
Lemma hoare_triple_Skip : forall P Q,
  {{P}} Skip {{Q}}
  -> forall h v, P h v -> Q h v.
Proof.
  induct 1; auto.
Qed.

(* Finally, our main inductive proof: small steps preserve the existence of
 * Hoare triples.  We even give the concrete specification for the new command
 * [c'] that was stepped to.  It keeps the old postcondition, and we give it a
 * very specific precondition saying "the state is exactly this." *)
Lemma hoare_triple_step : forall P c Q,
  {{P}} c {{Q}}
  -> forall h v h' v' c',
      step (h, v, c) (h', v', c')
      -> P h v
      -> {{h''&v'' ~> h'' = h' /\ v'' = v'}} c' {{Q}}.
Proof.
  induct 1.

  invert 1.

  invert 1; ht; eauto.

  invert 1; ht; eauto.

  invert 1; simplify.

  eapply HtConsequence; eauto.
  propositional; subst.
  eapply hoare_triple_Skip; eauto.

  econstructor; eauto.

  invert 1; simplify.
  eapply HtConsequence; eauto; equality.
  eapply HtConsequence; eauto; equality.

  invert 1; simplify.
  eapply HtConsequence with (P := h'' & v'' ~> h'' = h' /\ v'' = v').
  apply HtSkip.
  auto.
  simplify; propositional; subst; eauto.

  econstructor.
  eapply HtConsequence; eauto.
  simplify; propositional; subst; eauto.
  econstructor; eauto.

  invert 1; simplify.
  eapply HtConsequence; eauto.
  econstructor.
  simplify; propositional; subst; eauto.

  simplify.
  eapply HtConsequence.
  eapply IHhoare_triple; eauto.
  simplify; propositional; subst; eauto.
  auto.
Qed.

(* Oh, what a coincidence! ;-)  As with type-safety proofs, we find that the
 * reasonably intuitive properties we just proved are precisely the hard parts
 * of a standard proof by invariant strengthening and invariant induction. *)
Theorem hoare_triple_invariant : forall P c Q h v,
  {{P}} c {{Q}}
  -> P h v
  -> invariantFor (trsys_of (h, v, c)) unstuck.
Proof.
  simplify.
  apply invariant_weaken with (invariant1 := fun st => {{h&v ~> h = fst (fst st)
                                                           /\ v = snd (fst st)}}
                                                         snd st
                                                       {{_&_ ~> True}}).

  apply invariant_induction; simplify.

  propositional; subst; simplify.
  eapply HtConsequence; eauto.
  equality.

  cases s.
  cases s'.
  cases p.
  cases p0.
  simplify.
  eapply hoare_triple_step; eauto.
  simplify; auto.

  simplify.
  cases s.
  cases p.
  simplify.
  eapply hoare_triple_unstuck; eauto.
  simplify; auto.
Qed.

(* A very simple example, just to show all this in action *)
Definition forever := (
  "i" <- 1;;
  "n" <- 1;;
  {{h&v ~> v $! "i" > 0}}
  while 0 < "i" loop
    "i" <- "i" * 2;;
    "n" <- "n" + "i";;
    assert {{h&v ~> v $! "n" >= 1}}
  done;;

  assert {{_&_ ~> False}}
  (* Note that this last assertion implies that the program never terminates! *)
)%cmd.

Theorem forever_ok : {{_&_ ~> True}} forever {{_&_ ~> False}}.
Proof.
  ht.
Qed.

Theorem forever_invariant : invariantFor (trsys_of ($0, $0, forever)) unstuck.
Proof.
  eapply hoare_triple_invariant.
  apply forever_ok.
  simplify; trivial.
Qed.


(** * Types: Type Systems *)

Require Export Smallstep.

Hint Constructors multi.

(** Our next major topic is _type systems_ -- static program
    analyses that classify expressions according to the "shapes" of
    their results.  We'll begin with a typed version of a very simple
    language with just booleans and numbers, to introduce the basic
    ideas of types, typing rules, and the fundamental theorems about
    type systems: _type preservation_ and _progress_.  Then we'll move
    on to the _simply typed lambda-calculus_, which lives at the core
    of every modern functional programming language (including
    Coq). *)

(* ###################################################################### *)
(** * Typed Arithmetic Expressions *)

(** To motivate the discussion of type systems, let's begin as
    usual with an extremely simple toy language.  We want it to have
    the potential for programs "going wrong" because of runtime type
    errors, so we need something a tiny bit more complex than the
    language of constants and addition that we used in chapter
    [Smallstep]: a single kind of data (just numbers) is too simple,
    but just two kinds (numbers and booleans) already gives us enough
    material to tell an interesting story.

    The language definition is completely routine.  The only thing to
    notice is that we are _not_ using the [asnum]/[aslist] trick that
    we used in chapter [HoareList] to make all the operations total by
    forcibly coercing the arguments to [+] (for example) into numbers.
    Instead, we simply let terms get stuck if they try to use an
    operator with the wrong kind of operands: the [step] relation
    doesn't relate them to anything. *)

(* ###################################################################### *)
(** ** Syntax *)

(** Informally:
    t ::= true
        | false
        | if t then t else t
        | 0
        | succ t
        | pred t
        | iszero t
    Formally:
*)

Inductive tm : Type :=
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm
  | tzero : tm
  | tsucc : tm -> tm
  | tpred : tm -> tm
  | tiszero : tm -> tm.

(** _Values_ are [true], [false], and numeric values... *)

Inductive bvalue : tm -> Prop :=
  | bv_true : bvalue ttrue
  | bv_false : bvalue tfalse.

Inductive nvalue : tm -> Prop :=
  | nv_zero : nvalue tzero
  | nv_succ : forall t, nvalue t -> nvalue (tsucc t).

Definition value (t:tm) := bvalue t \/ nvalue t.

Hint Constructors bvalue nvalue.
Hint Unfold value.
Hint Unfold extend.

(* ###################################################################### *)
(** ** Operational Semantics *)

(** Informally: *)
(**
                    ------------------------------                  (ST_IfTrue)
                    if true then t1 else t2 ==> t1

                   -------------------------------                 (ST_IfFalse)
                   if false then t1 else t2 ==> t2

                              t1 ==> t1'
                      -------------------------                         (ST_If)
                      if t1 then t2 else t3 ==>
                        if t1' then t2 else t3

                              t1 ==> t1'
                         --------------------                         (ST_Succ)
                         succ t1 ==> succ t1'

                             ------------                         (ST_PredZero)
                             pred 0 ==> 0

                           numeric value v1
                        ---------------------                     (ST_PredSucc)
                        pred (succ v1) ==> v1

                              t1 ==> t1'
                         --------------------                         (ST_Pred)
                         pred t1 ==> pred t1'

                          -----------------                     (ST_IszeroZero)
                          iszero 0 ==> true

                           numeric value v1
                      --------------------------                (ST_IszeroSucc)
                      iszero (succ v1) ==> false

                              t1 ==> t1'
                       ------------------------                     (ST_Iszero)
                       iszero t1 ==> iszero t1'
*)

(** Formally: *)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)
  | ST_Succ : forall t1 t1',
      t1 ==> t1' ->
      (tsucc t1) ==> (tsucc t1')
  | ST_PredZero :
      (tpred tzero) ==> tzero
  | ST_PredSucc : forall t1,
      nvalue t1 ->
      (tpred (tsucc t1)) ==> t1
  | ST_Pred : forall t1 t1',
      t1 ==> t1' ->
      (tpred t1) ==> (tpred t1')
  | ST_IszeroZero :
      (tiszero tzero) ==> ttrue
  | ST_IszeroSucc : forall t1,
       nvalue t1 ->
      (tiszero (tsucc t1)) ==> tfalse
  | ST_Iszero : forall t1 t1',
      t1 ==> t1' ->
      (tiszero t1) ==> (tiszero t1')

where "t1 '==>' t2" := (step t1 t2).

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_IfTrue" | Case_aux c "ST_IfFalse" | Case_aux c "ST_If"
  | Case_aux c "ST_Succ" | Case_aux c "ST_PredZero"
  | Case_aux c "ST_PredSucc" | Case_aux c "ST_Pred"
  | Case_aux c "ST_IszeroZero" | Case_aux c "ST_IszeroSucc"
  | Case_aux c "ST_Iszero" ].

Hint Constructors step.
(** Notice that the [step] relation doesn't care about whether
    expressions make global sense -- it just checks that the operation
    in the _next_ reduction step is being applied to the right kinds
    of operands.

    For example, the term [succ true] (i.e., [tsucc ttrue] in the
    formal syntax) cannot take a step, but the almost as obviously
    nonsensical term
       succ (if true then true else true)
    can take a step (once, before becoming stuck). *)

(* ###################################################################### *)
(** ** Normal Forms and Values *)

(** The first interesting thing about the [step] relation in this
    language is that the strong progress theorem from the Smallstep
    chapter fails!  That is, there are terms that are normal
    forms (they can't take a step) but not values (because we have not
    included them in our definition of possible "results of
    evaluation").  Such terms are _stuck_. *)

Notation step_normal_form := (normal_form step).

Definition stuck (t:tm) : Prop :=
  step_normal_form t /\ ~ value t.

Hint Unfold stuck.

(** **** Exercise: 2 stars (some_term_is_stuck) *)
Example some_term_is_stuck :
  exists t, stuck t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** However, although values and normal forms are not the same in this
    language, the former set is included in the latter.  This is
    important because it shows we did not accidentally define things
    so that some value could still take a step. *)

(** **** Exercise: 3 stars, advanced (value_is_nf) *)
(** Hint: You will reach a point in this proof where you need to
    use an induction to reason about a term that is known to be a
    numeric value.  This induction can be performed either over the
    term itself or over the evidence that it is a numeric value.  The
    proof goes through in either case, but you will find that one way
    is quite a bit shorter than the other.  For the sake of the
    exercise, try to complete the proof both ways. *)

Lemma value_is_nf : forall t,
  value t -> step_normal_form t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, optional (step_deterministic) *)
(** Using [value_is_nf], we can show that the [step] relation is
    also deterministic... *)

Theorem step_deterministic:
  deterministic step.
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** ** Typing *)

(** The next critical observation about this language is that,
    although there are stuck terms, they are all "nonsensical", mixing
    booleans and numbers in a way that we don't even _want_ to have a
    meaning.  We can easily exclude such ill-typed terms by defining a
    _typing relation_ that relates terms to the types (either numeric
    or boolean) of their final results.  *)

Inductive ty : Type :=
  | TBool : ty
  | TNat : ty.

(** In informal notation, the typing relation is often written
    [|- t \in T], pronounced "[t] has type [T]."  The [|-] symbol is
    called a "turnstile".  (Below, we're going to see richer typing
    relations where an additional "context" argument is written to the
    left of the turnstile.  Here, the context is always empty.) *)
(**
                           ----------------                            (T_True)
                           |- true \in Bool

                          -----------------                           (T_False)
                          |- false \in Bool

             |- t1 \in Bool    |- t2 \in T    |- t3 \in T
             --------------------------------------------                (T_If)
                    |- if t1 then t2 else t3 \in T

                             ------------                              (T_Zero)
                             |- 0 \in Nat

                            |- t1 \in Nat
                          ------------------                           (T_Succ)
                          |- succ t1 \in Nat

                            |- t1 \in Nat
                          ------------------                           (T_Pred)
                          |- pred t1 \in Nat

                            |- t1 \in Nat
                        ---------------------                        (T_IsZero)
                        |- iszero t1 \in Bool
*)

Reserved Notation "'|-' t '\in' T" (at level 40).

Inductive has_type : tm -> ty -> Prop :=
  | T_True :
       |- ttrue \in TBool
  | T_False :
       |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T,
       |- t1 \in TBool ->
       |- t2 \in T ->
       |- t3 \in T ->
       |- tif t1 t2 t3 \in T
  | T_Zero :
       |- tzero \in TNat
  | T_Succ : forall t1,
       |- t1 \in TNat ->
       |- tsucc t1 \in TNat
  | T_Pred : forall t1,
       |- t1 \in TNat ->
       |- tpred t1 \in TNat
  | T_Iszero : forall t1,
       |- t1 \in TNat ->
       |- tiszero t1 \in TBool

where "'|-' t '\in' T" := (has_type t T).

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_True" | Case_aux c "T_False" | Case_aux c "T_If"
  | Case_aux c "T_Zero" | Case_aux c "T_Succ" | Case_aux c "T_Pred"
  | Case_aux c "T_Iszero" ].

Hint Constructors has_type.

(* ###################################################################### *)
(** *** Examples *)

(** It's important to realize that the typing relation is a
    _conservative_ (or _static_) approximation: it does not calculate
    the type of the normal form of a term. *)

Example has_type_1 :
  |- tif tfalse tzero (tsucc tzero) \in TNat.
Proof.
  apply T_If.
    apply T_False.
    apply T_Zero.
    apply T_Succ.
      apply T_Zero.
Qed.

(** (Since we've included all the constructors of the typing relation
    in the hint database, the [auto] tactic can actually find this
    proof automatically.) *)

Example has_type_not :
  ~ (|- tif tfalse tzero ttrue \in TBool).
Proof.
  intros Contra. solve by inversion 2.  Qed.

(** **** Exercise: 1 star, optional (succ_hastype_nat__hastype_nat) *)
Example succ_hastype_nat__hastype_nat : forall t,
  |- tsucc t \in TNat ->
  |- t \in TNat.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** ** Canonical forms *)

(** The following two lemmas capture the basic property that defines
    the shape of well-typed values.  They say that the definition of value
    and the typing relation agree. *)

Lemma bool_canonical : forall t,
  |- t \in TBool -> value t -> bvalue t.
Proof.
  intros t HT HV.
  inversion HV; auto.

  induction H; inversion HT; auto.
Qed.

Lemma nat_canonical : forall t,
  |- t \in TNat -> value t -> nvalue t.
Proof.
  intros t HT HV.
  inversion HV.
  inversion H; subst; inversion HT.

  auto.
Qed.

(* ###################################################################### *)
(** ** Progress *)

(** The typing relation enjoys two critical properties.  The first is
    that well-typed normal forms are values (i.e., not stuck). *)

Theorem progress : forall t T,
  |- t \in T ->
  value t \/ exists t', t ==> t'.

(** **** Exercise: 3 stars (finish_progress) *)
(** Complete the formal proof of the [progress] property.  (Make sure
    you understand the informal proof fragment in the following
    exercise before starting -- this will save you a lot of time.) *)

Proof with auto.
  intros t T HT.
  has_type_cases (induction HT) Case...
  (* The cases that were obviously values, like T_True and
     T_False, were eliminated immediately by auto *)
  Case "T_If".
    right. inversion IHHT1; clear IHHT1.
    SCase "t1 is a value".
    apply (bool_canonical t1 HT1) in H.
    inversion H; subst; clear H.
      exists t2...
      exists t3...
    SCase "t1 can take a step".
      inversion H as [t1' H1].
      exists (tif t1' t2 t3)...
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced (finish_progress_informal) *)
(** Complete the corresponding informal proof: *)

(** _Theorem_: If [|- t \in T], then either [t] is a value or else
    [t ==> t'] for some [t']. *)

(** _Proof_: By induction on a derivation of [|- t \in T].

      - If the last rule in the derivation is [T_If], then [t = if t1
        then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T] and [|- t3
        \in T].  By the IH, either [t1] is a value or else [t1] can step
        to some [t1'].

            - If [t1] is a value, then by the canonical forms lemmas
              and the fact that [|- t1 \in Bool] we have that [t1]
              is a [bvalue] -- i.e., it is either [true] or [false].
              If [t1 = true], then [t] steps to [t2] by [ST_IfTrue],
              while if [t1 = false], then [t] steps to [t3] by
              [ST_IfFalse].  Either way, [t] can step, which is what
              we wanted to show.

            - If [t1] itself can take a step, then, by [ST_If], so can
              [t].

    (* FILL IN HERE *)
[]
*)

(** This is more interesting than the strong progress theorem that we
    saw in the Smallstep chapter, where _all_ normal forms were
    values.  Here, a term can be stuck, but only if it is ill
    typed. *)

(** **** Exercise: 1 star (step_review) *)
(** Quick review.  Answer _true_ or _false_.  In this language...
      - Every well-typed normal form is a value.

      - Every value is a normal form.

      - The single-step evaluation relation is
        a partial function (i.e., it is deterministic).

      - The single-step evaluation relation is a _total_ function.

*)
(** [] *)

(* ###################################################################### *)
(** ** Type Preservation *)

(** The second critical property of typing is that, when a well-typed
    term takes a step, the result is also a well-typed term.

    This theorem is often called the _subject reduction_ property,
    because it tells us what happens when the "subject" of the typing
    relation is reduced.  This terminology comes from thinking of
    typing statements as sentences, where the term is the subject and
    the type is the predicate. *)

Theorem preservation : forall t t' T,
  |- t \in T ->
  t ==> t' ->
  |- t' \in T.

(** **** Exercise: 2 stars (finish_preservation) *)
(** Complete the formal proof of the [preservation] property.  (Again,
    make sure you understand the informal proof fragment in the
    following exercise first.) *)

Proof with auto.
  intros t t' T HT HE.
  generalize dependent t'.
  has_type_cases (induction HT) Case;
         (* every case needs to introduce a couple of things *)
         intros t' HE;
         (* and we can deal with several impossible
            cases all at once *)
         try (solve by inversion).
    Case "T_If". inversion HE; subst; clear HE.
      SCase "ST_IFTrue". assumption.
      SCase "ST_IfFalse". assumption.
      SCase "ST_If". apply T_If; try assumption.
        apply IHHT1; assumption.
    (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced (finish_preservation_informal) *)
(** Complete the following proof: *)

(** _Theorem_: If [|- t \in T] and [t ==> t'], then [|- t' \in T]. *)

(** _Proof_: By induction on a derivation of [|- t \in T].

      - If the last rule in the derivation is [T_If], then [t = if t1
        then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T] and [|- t3
        \in T].

        Inspecting the rules for the small-step reduction relation and
        remembering that [t] has the form [if ...], we see that the
        only ones that could have been used to prove [t ==> t'] are
        [ST_IfTrue], [ST_IfFalse], or [ST_If].

           - If the last rule was [ST_IfTrue], then [t' = t2].  But we
             know that [|- t2 \in T], so we are done.

           - If the last rule was [ST_IfFalse], then [t' = t3].  But we
             know that [|- t3 \in T], so we are done.

           - If the last rule was [ST_If], then [t' = if t1' then t2
             else t3], where [t1 ==> t1'].  We know [|- t1 \in Bool] so,
             by the IH, [|- t1' \in Bool].  The [T_If] rule then gives us
             [|- if t1' then t2 else t3 \in T], as required.

    (* FILL IN HERE *)
[]
*)

(** **** Exercise: 3 stars (preservation_alternate_proof) *)
(** Now prove the same property again by induction on the
    _evaluation_ derivation instead of on the typing derivation.
    Begin by carefully reading and thinking about the first few
    lines of the above proof to make sure you understand what
    each one is doing.  The set-up for this proof is similar, but
    not exactly the same. *)

Theorem preservation' : forall t t' T,
  |- t \in T ->
  t ==> t' ->
  |- t' \in T.
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** ** Type Soundness *)

(** Putting progress and preservation together, we can see that a
    well-typed term can _never_ reach a stuck state.  *)

Definition multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

Corollary soundness : forall t t' T,
  |- t \in T ->
  t ==>* t' ->
  ~(stuck t').
Proof.
  intros t t' T HT P. induction P; intros [R S].
  destruct (progress x T HT); auto.
  apply IHP.  apply (preservation x y T HT H).
  unfold stuck. split; auto.   Qed.

(* ###################################################################### *)
(** * Aside: the [normalize] Tactic *)

(** When experimenting with definitions of programming languages in
    Coq, we often want to see what a particular concrete term steps
    to -- i.e., we want to find proofs for goals of the form [t ==>*
    t'], where [t] is a completely concrete term and [t'] is unknown.
    These proofs are simple but repetitive to do by hand. Consider for
    example reducing an arithmetic expression using the small-step
    relation [astep]. *)

Definition amultistep st := multi (astep st).
Notation " t '/' st '==>a*' t' " := (amultistep st t t')
  (at level 40, st at level 39).

Example astep_example1 :
  (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state
  ==>a* (ANum 15).
Proof.
  apply multi_step with (APlus (ANum 3) (ANum 12)).
    apply AS_Plus2.
      apply av_num.
      apply AS_Mult.
  apply multi_step with (ANum 15).
    apply AS_Plus.
  apply multi_refl.
Qed.

(** We repeatedly apply [multi_step] until we get to a normal
    form. The proofs that the intermediate steps are possible are
    simple enough that [auto], with appropriate hints, can solve
    them. *)

Hint Constructors astep aval.
Example astep_example1' :
  (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state
  ==>a* (ANum 15).
Proof.
  eapply multi_step. auto. simpl.
  eapply multi_step. auto. simpl.
  apply multi_refl.
Qed.

(** The following custom [Tactic Notation] definition captures this
    pattern.  In addition, before each [multi_step] we print out the
    current goal, so that the user can follow how the term is being
    evaluated. *)

Tactic Notation "print_goal" := match goal with |- ?x => idtac x end.
Tactic Notation "normalize" :=
   repeat (print_goal; eapply multi_step ;
             [ (eauto 10; fail) | (instantiate; simpl)]);
   apply multi_refl.

Example astep_example1'' :
  (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state
  ==>a* (ANum 15).
Proof.
  normalize.
  (* At this point in the proof script, the Coq response shows
     a trace of how the expression evaluated.

   (APlus (ANum 3) (AMult (ANum 3) (ANum 4)) / empty_state ==>a* ANum 15)
   (multi (astep empty_state) (APlus (ANum 3) (ANum 12)) (ANum 15))
   (multi (astep empty_state) (ANum 15) (ANum 15))
*)
Qed.

(** The [normalize] tactic also provides a simple way to calculate
    what the normal form of a term is, by proving a goal with an
    existential variable in it. *)

Example astep_example1''' : exists e',
  (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state
  ==>a* e'.
Proof.
  eapply ex_intro. normalize.

(* This time, the trace will be:

    (APlus (ANum 3) (AMult (ANum 3) (ANum 4)) / empty_state ==>a* ??)
    (multi (astep empty_state) (APlus (ANum 3) (ANum 12)) ??)
    (multi (astep empty_state) (ANum 15) ??)

   where ?? is the variable ``guessed'' by eapply.
*)
Qed.

(** **** Exercise: 1 star (normalize_ex) *)
Theorem normalize_ex : exists e',
  (AMult (ANum 3) (AMult (ANum 2) (ANum 1))) / empty_state
  ==>a* e'.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 1 star, optional (normalize_ex') *)
(** For comparison, prove it using [apply] instead of [eapply]. *)

Theorem normalize_ex' : exists e',
  (AMult (ANum 3) (AMult (ANum 2) (ANum 1))) / empty_state
  ==>a* e'.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** ** Additional Exercises *)

(** **** Exercise: 2 stars (subject_expansion) *)
(** Having seen the subject reduction property, it is reasonable to
    wonder whether the opposity property -- subject _expansion_ --
    also holds.  That is, is it always the case that, if [t ==> t']
    and [|- t' \in T], then [|- t \in T]?  If so, prove it.  If
    not, give a counter-example.  (You do not need to prove your
    counter-example in Coq, but feel free to do so if you like.)

    (* FILL IN HERE *)
[]
*)

(** **** Exercise: 2 stars (variation1) *)
(** Suppose, that we add this new rule to the typing relation:
      | T_SuccBool : forall t,
           |- t \in TBool ->
           |- tsucc t \in TBool
   Which of the following properties remain true in the presence of
   this rule?  For each one, write either "remains true" or
   else "becomes false." If a property becomes false, give a
   counterexample.
      - Determinism of [step]

      - Progress

      - Preservation

[]
*)

(** **** Exercise: 2 stars (variation2) *)
(** Suppose, instead, that we add this new rule to the [step] relation:
      | ST_Funny1 : forall t2 t3,
           (tif ttrue t2 t3) ==> t3
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

[]
*)

(** **** Exercise: 2 stars, optional (variation3) *)
(** Suppose instead that we add this rule:
      | ST_Funny2 : forall t1 t2 t2' t3,
           t2 ==> t2' ->
           (tif t1 t2 t3) ==> (tif t1 t2' t3)
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

[]
*)

(** **** Exercise: 2 stars, optional (variation4) *)
(** Suppose instead that we add this rule:
      | ST_Funny3 :
          (tpred tfalse) ==> (tpred (tpred tfalse))
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

[]
*)

(** **** Exercise: 2 stars, optional (variation5) *)
(** Suppose instead that we add this rule:

      | T_Funny4 :
            |- tzero \in TBool
   ]]
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

[]
*)

(** **** Exercise: 2 stars, optional (variation6) *)
(** Suppose instead that we add this rule:

      | T_Funny5 :
            |- tpred tzero \in TBool
   ]]
   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.

[]
*)

(** **** Exercise: 3 stars, optional (more_variations) *)
(** Make up some exercises of your own along the same lines as
    the ones above.  Try to find ways of selectively breaking
    properties -- i.e., ways of changing the definitions that
    break just one of the properties and leave the others alone.
    []
*)

(** **** Exercise: 1 star (remove_predzero) *)
(** The evaluation rule [E_PredZero] is a bit counter-intuitive: we
    might feel that it makes more sense for the predecessor of zero to
    be undefined, rather than being defined to be zero.  Can we
    achieve this simply by removing the rule from the definition of
    [step]?  Would doing so create any problems elsewhere?

(* FILL IN HERE *)
[] *)

(** **** Exercise: 4 stars, advanced (prog_pres_bigstep) *)
(** Suppose our evaluation relation is defined in the big-step style.
    What are the appropriate analogs of the progress and preservation
    properties?

(* FILL IN HERE *)
[]
*)

(* $Date: 2014-04-08 23:31:16 -0400 (Tue, 08 Apr 2014) $ *)


Require Import ZArith.
Require Import Lia.
Require Import List.
Require Import Utils.
Require Import Coq.Arith.Compare_dec.
Import ListNotations.

Require Import Instr.
Require Import Semantics.
Require Import Concrete.
Require Import CodeGen.
Require Import CodeTriples.
Require Import ConcreteMachine.
Require Import ConcreteExecutions.

(** Proof of various [HT], [GT], and [HTEscape] style specifications of (generic)
code generators, and concrete (privileged) code. *)

(** * Contained [HT] specifications *)

Section CodeSpecs.
Local Open Scope Z_scope.

Ltac run1 := eapply rte_step; eauto; econstructor; eauto.

Lemma nop_spec: forall Q,
  HT nop Q Q.
Proof.
  unfold nop, HT; simpl; intros.
  split_vc.
  apply_f_equal rte_refl; subst; rec_f_equal ltac:(try lia; eauto).
Qed.

Lemma add_spec: forall Q,
  HT [Add]
     (fun m s => exists s0 z1 l1 z2 l2,
                   s = (z1,l1) ::: (z2,l2) ::: s0
                   /\ Q m ((z1 + z2,handlerTag) ::: s0))
     Q.
Proof.
  unfold HT; split_vc; subst; run1.
Qed.

Lemma sub_spec: forall Q,
  HT [Sub]
     (fun m s => exists s0 z1 l1 z2 l2,
                   s = (z1,l1) ::: (z2,l2) ::: s0
                   /\ Q m ((z1 - z2,handlerTag) ::: s0))
     Q.
Proof.
  unfold HT; split_vc; subst; run1.
Qed.

Lemma push_spec : forall i Q,
  HT [Push i]
     (fun m s0 => Q m ((i,handlerTag):::s0))
     Q.
Proof.
  unfold HT; split_vc; subst; run1.
Qed.

Lemma load_spec: forall Q,
  HT [Load]
     (fun m s0 => exists a v vl s,
                    s0 = (a,handlerTag) ::: s /\
                   index_list_Z a m = Some(v,vl) /\
                   Q m ((v,vl) ::: s))
     Q.
Proof.
  unfold HT; split_vc; subst; run1.
Qed.

Lemma loadFrom_spec : forall a (Q: memory-> stack -> Prop),
  HT (loadFrom a)
     (fun m s => exists v vl, index_list_Z a m = Some (v,vl) /\ Q m ((v,vl):::s))
     Q.
Proof.
  intros.
  eapply HT_compose_bwd.
  eapply load_spec.
  eapply HT_strengthen_premise.
  eapply push_spec.
  split_vc.
Qed.

(** To prove that addresses are valid per this definition, we just
   need to know that that the memory is at least as large as the
   [tmuCacheSize], since we only use [valid_address] assumptions for
   [addrTag*]. *)
Definition valid_address a (m: memory) :=
  (0 <= a) /\ (Z.to_nat a < length m)%nat.

Lemma valid_address_upd: forall a a' vl m m',
  valid_address a m ->
  upd_m a' vl m = Some m' ->
  valid_address a m'.
Proof.
  unfold valid_address; intuition.
  unfold upd_m in *.
  destruct (a' <? 0).
  - discriminate.
  - erewrite update_preserves_length; eauto.
Qed.

Lemma valid_read: forall a m,
  valid_address a m ->
  exists v, read_m a m = Some v.
Proof.
  intros a m H.
  unfold valid_address in H.
  unfold read_m.
  destruct (a <? 0) eqn:E.
  - rewrite Z.ltb_lt in E. lia.
  - remember (Z.to_nat a) as n; clear Heqn.
    destruct H as [_ Hbound].
    generalize dependent n.
    generalize dependent m.
    induction m; intros.
    + simpl in *; lia.
    + destruct n eqn:En; subst.
      * simpl; eauto.
      * simpl in Hbound.
        apply lt_S_n in Hbound.
        eauto.
Qed.

Lemma valid_store: forall a v m,
  valid_address a m ->
  exists m', upd_m a v m = Some m'.
Proof.
  intros.
  unfold valid_address in H.
  eapply update_list_Z_Some; intuition auto.
Qed.

Lemma store_spec: forall Q a al v vl,
  forall m s,
  HT [Store]
     (fun m0 s0 => s0 = (a,al) ::: (v,vl) ::: s /\
                   upd_m a (v,vl) m0 = Some m /\
                   Q m s)
     Q.
Proof.
  unfold HT; split_vc; subst; run1.
Qed.

Lemma storeAt_spec: forall a v vl Q,
  forall m s,
  HT (storeAt a)
     (fun m0 s0 => s0 = (v,vl) ::: s /\
                   upd_m a (v,vl) m0 = Some m /\
                   Q m s)
     Q.
Proof.
  intros.
  eapply HT_compose_bwd.
  eapply store_spec.
  eapply HT_strengthen_premise.
  eapply push_spec.
  split_vc.
  subst; split_vc.
Qed.

Lemma skipNZ_continuation_spec_NZ: forall c Q v l,
  v <> 0 ->
  HT   (skipNZ (length c) ++ c)
       (fun m s => (exists s', s = CData (v,l) :: s'
                               /\ Q m s'))
       Q.
Proof.
  unfold HT; split_vc.

  (* massage to match the rule we want to run *)
  match goal with
    | |- context[n + ?z] =>
      replace (n + z) with (if v =? 0 then n + 1 else n + z)
  end.
  run1.
  rewrite <- Z.eqb_neq in H. rewrite H. auto.
Qed.

Lemma skipNZ_spec_Z: forall n Q v l,
  v = 0 ->
  HT   (skipNZ n)
       (fun m s => (exists s', s = CData (v,l) :: s'
                               /\ Q m s'))
       Q.
Proof.
  unfold HT; split_vc.

  (* pick the rule we want to run *)
  eapply rte_step; auto.
  apply_f_equal cstep_branchnz_p.
  eauto.
Qed.

Lemma skipNZ_continuation_spec_Z: forall c P Q v l,
  v = 0 ->
  HT   c P Q  ->
  HT   (skipNZ (length c) ++ c)
       (fun m s => (exists s', s = CData (v,l) :: s'
                               /\ P m s'))
       Q.
Proof.
  intros c P Q v l Hv HTc.
  eapply HT_compose.
  eapply skipNZ_spec_Z; auto.
  auto.
Qed.

Lemma skip_spec: forall c Q,
  HT   (skip (length c) ++ c)
       Q
       Q.
Proof.
  intros c P.
  unfold skip.
  rewrite app_ass.
  eapply HT_compose_bwd.
  eapply skipNZ_continuation_spec_NZ with (v:= 1); lia.
  eapply HT_strengthen_premise.
  eapply push_spec.
  split_vc.
Qed.

Lemma ifNZ_spec_Z: forall v l t f P Q,
  HT   f P Q ->
  v = 0 ->
  HT   (ifNZ t f)
       (fun m s => (exists s', s = CData (v,l) :: s' /\ P m s'))
       Q.
Proof.
  intros v l t f P Q HTf Hveq0.
  unfold ifNZ.
  rewrite app_ass.
  eapply HT_compose.
  apply skipNZ_spec_Z; auto.
  eapply HT_compose; eauto.
  apply skip_spec.
Qed.

Lemma ifNZ_spec_NZ: forall v l t f P Q,
  HT   t P Q ->
  v <> 0 ->
  HT   (ifNZ t f)
       (fun m s => (exists s', s = CData (v,l) :: s' /\ P m s'))
       Q.
Proof.
  intros v l t f P Q HTt Hveq0.
  unfold ifNZ.
  rewrite <- app_ass.
  eapply HT_compose; eauto.
  apply skipNZ_continuation_spec_NZ; auto.
Qed.

Lemma ifNZ_spec_helper: forall v l t f Pt Pf Q,
  HT   t Pt Q ->
  HT   f Pf Q ->
  HT   (ifNZ t f)
       (fun m s => ((v <> 0 -> exists s', s = CData (v,l) :: s' /\ Pt m s') /\
                    (v =  0 -> exists s', s = CData (v,l) :: s' /\ Pf m s')))
       Q.
Proof.
  intros v l t f Pt Pf Q HTt HTf.
  eapply HT_decide_join with (D := fun v => v = 0).
  apply ifNZ_spec_NZ.
  apply ifNZ_spec_Z.
  intros; lia.
  auto.
  auto.
Qed.

Lemma ifNZ_spec: forall v l t f Pt Pf Q,
  HT   t Pt Q ->
  HT   f Pf Q ->
  HT   (ifNZ t f)
       (fun m s => (exists s', s = CData (v,l) :: s' /\
                                   (v <> 0 -> Pt m s') /\
                                   (v =  0 -> Pf m s')))
       Q.
Proof.
  intros v l t f Pt Pf Q HTt HTf.
  eapply HT_strengthen_premise.
  eapply ifNZ_spec_helper; eauto.
  intros m s [s' [s_eq [HNZ HZ]]].
  destruct (dec_eq v 0); subst; intuition;
    eexists; intuition.
Qed.

(* I need to existentially bind [v] for the [ite_spec]. May have been
   easier to use existentials from the beginning ... *)
Lemma ifNZ_spec_existential: forall t f Pt Pf Q,
  HT   t Pt Q ->
  HT   f Pf Q ->
  HT   (ifNZ t f)
       (fun m s => (exists v l s', s = CData (v,l) :: s' /\
                                   (v <> 0 -> Pt m s') /\
                                   (v =  0 -> Pf m s')))
       Q.
Proof.
  intros t f Pt Pf Q HTt HTf.
  eapply HT_forall_exists.
  intro v.
  eapply HT_forall_exists.
  intro l.
  apply ifNZ_spec.
  auto.
  auto.
Qed.

(* Might make more sense to make [Qc] be the thing that [Qc] implies
   here.  I.e., this version has an implicit use of
   [HT_strengthen_premise] in it, which could always be inserted
   manually when needed. *)
Lemma ite_spec: forall c t f (P Pt Pf: HProp) Q,
  let P' := fun m s => exists v l s', s = (v,l) ::: s' /\
                                      (v <> 0 -> Pt m s') /\
                                      (v =  0 -> Pf m s') in
  HT   c P P' ->
  HT   t Pt Q ->
  HT   f Pf Q ->
  HT   (ite c t f) P Q.
Proof.
  intros c t f P Pt Pf Q P' HTc HTt HTf.
  unfold ite.
  eapply HT_compose.
  apply HTc.
  apply ifNZ_spec_existential.
  auto.
  auto.
Qed.

(** A version of [ite_spec] that restricts the effect of the condition
   code [c] to pushing one value to the stack.

   In [genApplyRule_spec] we are considering a particular memory,
   [m0], so, here it helps to make the memory a parameter. *)
Lemma ite_spec_specialized: forall v c t f Q, forall m0 s0,
  let P := fun m s => m = m0 /\ s = s0 in
  HT c P  (fun m s => m = m0 /\ s = (v,handlerTag) ::: s0) ->
  (v <> 0 -> HT t P Q) ->
  (v =  0 -> HT f P Q) ->
  HT (ite c t f) P Q.
Proof.
  intros v c t f Q m0 s0 P HTc HZ HNZ.
  eapply ite_spec with (Pt := fun m s => v <> 0 /\ m = m0 /\ s = s0)
                       (Pf := fun m s => v =  0 /\ m = m0 /\ s = s0).
  eauto.
  eapply HT_weaken_conclusion.
  eauto.

  intros m s  Heq.
  simpl in Heq.
  intuition eauto. subst.
  do 3 eexists. split; eauto.
  split; eauto.

  eapply HT_fold_constant_premise; auto.
  eapply HT_fold_constant_premise; auto.
Qed.

Lemma cases_spec_base: forall d P Q,
  HT   d P Q -> HT   (cases nil d) P Q.
Proof.
  auto.
Qed.

Lemma cases_spec_step: forall c b cbs d P (Pt Pf Q: HProp),
  let P' := fun m s => exists v l s', s = (v,l) ::: s' /\
                                      (v <> 0 -> Pt m s') /\
                                      (v =  0 -> Pf m s') in
  HT   c P P' ->
  HT   b Pt Q ->
  HT   (cases cbs d) Pf Q ->
  HT   (cases ((c,b)::cbs) d) P Q.
Proof.
  intros.
  eapply ite_spec; eauto.
Qed.

(** A specialized spec for the [cases] combinator.

   If

   - the conditions don't modify the existing stack or memory,
     but just push a value onto the stack, and that value is computed as
     a function of the stack and memory;

   - the different branches have different conclusions.

  Then if [cases] terminates, the conclusion of the first branch whose
  guard returned non-zero holds.

  Actually, that's what you get if you unfold this definition over a
  list of [(guard, branch)] pairs; this spec is just one step of
  unfolding. *)

Lemma cases_spec_step_specialized: forall c vc b cbs d P Qb Qcbs,
  (* This could be abstracted: code that transforms the stack by
  pushing one value computed from the existing stack and memory *)
  (forall m0 s0,
     HT   c (fun m s => P m0 s0 /\
                        m = m0 /\
                        s = s0)
            (fun m s => P m0 s0 /\
                        m = m0 /\
                        s = CData (vc m0 s0, handlerTag) :: s0)) ->
  HT   b P Qb ->
  HT   (cases cbs d) P Qcbs ->
  (forall m0 s0,
    HT   (cases ((c,b)::cbs) d) (fun m s => P m0 s0 /\
                                            m = m0 /\
                                            s = s0)
                                (fun m s => (vc m0 s0 <> 0 -> Qb m s) /\
                                            (vc m0 s0 = 0 -> Qcbs m s))).
Proof.
  intros c vc b cbs d P Qb Qcbs Hc Hb Hcbs.
  intros m0 s0.
  pose (Hc m0 s0) as Hcm0s0.
  eapply ite_spec with (Pt := (fun m s => P m s /\ vc m0 s0 <> 0))
                       (Pf := (fun m s => P m s /\ vc m0 s0 =  0)).
  eapply HT_weaken_conclusion.
  exact Hcm0s0.

  intuition.
  exists (vc m0 s0).
  exists handlerTag.
  exists s0.
  intuition; subst; auto.

  apply (HT_consequence' _ _ _ _ _ Hb); intuition.
  destruct H as (? & ? & ? & H).
  exfalso. eauto.

  apply (HT_consequence' _ _ _ _ _ Hcbs); intuition.
  destruct H as (? & ? & ? & H).
  exfalso. eauto.
Qed.

Lemma genTrue_spec: forall Q,
  HT genTrue
     (fun m s => Q m ((1,handlerTag):::s))
     Q.
Proof.
  eapply push_spec.
Qed.

Lemma genFalse_spec: forall Q,
  HT genFalse
     (fun m s => Q m ((0,handlerTag):::s))
     Q.
Proof.
  eapply push_spec.
Qed.

Lemma pop_spec: forall Q,
  HT pop
     (fun m s => exists v vl s0, s = (v,vl):::s0 /\ Q m s0)
     Q.
Proof.
  unfold HT, pop.
  split_vc; simpl; run1.
Qed.

Lemma genAnd_spec : forall (Q:memory -> stack -> Prop),
  HT genAnd
     (fun m s => exists b1 b2 s0, s = (boolToZ b1,handlerTag):::(boolToZ b2,handlerTag):::s0 /\
                                  Q m ((boolToZ (andb b1 b2),handlerTag):::s0))
     Q.
Proof.
  intros.
  eapply HT_strengthen_premise with
     (fun m s => exists b1 b2 s0 m0, s = (boolToZ b1,handlerTag):::(boolToZ b2,handlerTag):::s0 /\ m = m0 /\
                                     Q m0 ((boolToZ (andb b1 b2),handlerTag):::s0)).

  eapply HT_forall_exists.  intro b1.
  eapply HT_forall_exists.  intro b2.
  eapply HT_forall_exists.  intro s0.
  eapply HT_forall_exists.  intro m1.

  destruct b1; eapply HT_strengthen_premise.
  eapply ifNZ_spec_NZ with (v:=1).
  apply nop_spec.
  lia.
  simpl; intuition eauto; subst. eauto.
  split_vc; subst. auto.

  eapply ifNZ_spec_existential.
  apply nop_spec.
  eapply HT_compose_bwd.
  eapply genFalse_spec.
  eapply pop_spec.
  split_vc.

  split_vc.
Qed.

Lemma genOr_spec : forall (Q:memory -> stack -> Prop),
  HT genOr
     (fun m s => exists b1 b2 s0, s = (boolToZ b1,handlerTag):::(boolToZ b2,handlerTag):::s0 /\
                                  Q m ((boolToZ (orb b1 b2),handlerTag):::s0))
     Q.
Proof.
  intros.
  eapply HT_strengthen_premise with
     (fun m s => exists b1 b2 s0 m0, s = (boolToZ b1,handlerTag):::(boolToZ b2,handlerTag):::s0 /\ m = m0 /\
                                     Q m0 ((boolToZ (orb b1 b2),handlerTag):::s0)).
  eapply HT_forall_exists.  intro b1.
  eapply HT_forall_exists.  intro b2.
  eapply HT_forall_exists.  intro s0.
  eapply HT_forall_exists.  intro m1.

  destruct b1; eapply HT_strengthen_premise.

    eapply ifNZ_spec_NZ with (v:=1).
    eapply HT_compose_bwd.
    eapply genTrue_spec.
    eapply pop_spec.
    lia.

    split_vc. subst; auto.

    eapply ifNZ_spec_Z with (v:=0).
    apply nop_spec.
    reflexivity.
    split_vc. subst; auto.

    split_vc.
Qed.

Definition negz (z: Z) : Z :=
  match z with
      | 0 => 1
      | _ => 0
  end.

Lemma genNot_spec: forall Q,
  HT genNot
     (fun m s => exists z s0,
                   s = (z, handlerTag) ::: s0
                   /\ Q m ((negz z,handlerTag) ::: s0))
     Q.
Proof.
  intros. unfold genNot.
  eapply HT_strengthen_premise.
  eapply ifNZ_spec_existential.
  eapply genFalse_spec.
  eapply genTrue_spec.
  split_vc. subst; intuition; (destruct x eqn:?; try intuition); try congruence.
Qed.

Lemma genImpl_spec: forall b1 b2, forall m0 s0,
  HT genImpl
     (fun m s => m = m0 /\ s = CData (boolToZ b1,handlerTag) ::
                               CData (boolToZ b2,handlerTag) :: s0)
     (fun m s => m = m0 /\ s = CData (boolToZ (implb b1 b2),handlerTag) :: s0).
Proof.
  intros.
  unfold genImpl.
  eapply HT_compose_bwd.
  eapply genOr_spec.
  eapply HT_strengthen_premise.
  eapply genNot_spec.
  intros; simpl. inv H; subst.
  exists (boolToZ b1) ; exists ((boolToZ b2, handlerTag) ::: s0).
  split; eauto.
  unfold boolToZ in *.
  (destruct b1 eqn:?; destruct b2 eqn:?; try intuition); simpl.
  exists false; exists true;  eauto.
  exists false; exists false;  eauto.
  exists true; exists true;  eauto.
  exists true; exists false;  eauto.
Qed.

(* NC: use [Z.eqb_eq] and [Z.eqb_neq] to relate the boolean equality
   to propositional equality. *)
Lemma genTestEqual_spec: forall c1 c2, forall v1 v2, forall m0,
  (forall s0,
     HT c1
        (fun m s => m = m0 /\ s = s0)
        (fun m s => m = m0 /\ s = (v1,handlerTag) ::: s0)) ->
  (forall s0,
     HT c2
        (fun m s => m = m0 /\ s = s0)
        (fun m s => m = m0 /\ s = (v2,handlerTag) ::: s0)) ->
  (forall s0,
     HT (genTestEqual c1 c2)
        (fun m s => m = m0 /\ s = s0)
        (fun m s => m = m0 /\ s = (boolToZ (v1 =? v2),handlerTag) ::: s0)).
Proof.
  intros.
  unfold genTestEqual.
  eapply HT_compose_bwd; eauto.
  eapply HT_compose_bwd; eauto.
  eapply HT_compose_bwd.

  eapply (genNot_spec); eauto.
  eapply HT_strengthen_premise.
  eapply sub_spec.
  split_vc; subst.
  repeat f_equal; eauto.
  destruct (Z.eq_dec v1 v2); subst.
  - rewrite <- Zminus_diag_reverse.
    rewrite Z.eqb_refl.
    reflexivity.
  - generalize n. intros. rewrite <- Z.eqb_neq in n.
    rewrite n.
    destruct (v2 - v1) eqn:E; try lia; simpl; eauto.
Qed.

(** * Some specs of [cases] combinator, expressed with ghost variables *)
Lemma cases_spec_base_GT_specialized: forall cnil P Qnil,
  GT cnil P Qnil ->
  GT (cases [] cnil) P Qnil.
Proof.
unfold GT; intros; eapply cases_spec_base.
  eapply HT_strengthen_premise; eauto.
Qed.

Definition GT_push_v (c: code) (P: HProp) (v: HFun): Prop :=
  GT c P (fun m0 s0 m s => P m0 s0 /\
                           m = m0 /\
                           s = CData (v m0 s0, handlerTag) :: s0).
Definition GT_guard_v (b: code) (P: HProp) (v: HFun) (Q: GProp): Prop :=
  GT b (fun m s => P m s /\ v m s <> 0) Q.

Lemma cases_spec_step_GT_specialized: forall c v b cbs cnil P Qb Qcbs,
  GT_push_v c P v ->
  GT_guard_v b P v Qb ->
  GT (cases cbs cnil) P Qcbs ->
  GT (cases ((c,b)::cbs) cnil)
     P
     (fun m0 s0 m s => (v m0 s0 <> 0 -> Qb m0 s0 m s) /\
                       (v m0 s0 = 0 -> Qcbs m0 s0 m s)).
Proof.
  intros c vc b cbs d P Qb Qcbs Hc Hb Hcbs.
  intros m0 s0.
  pose (Hc m0 s0) as Hcm0s0.
  eapply ite_spec with (Pt := (fun m s => P m0 s0 /\ m = m0 /\ s = s0 /\ vc m0 s0 <> 0))
                       (Pf := (fun m s => P m0 s0 /\ m = m0 /\ s = s0 /\ vc m0 s0 =  0)).
  eapply HT_weaken_conclusion.
  exact Hcm0s0.

  intuition.
  exists (vc m0 s0).
  exists handlerTag.
  exists s0.
  intuition; subst; auto.

  apply (HT_consequence' _ _ _ _ _ (Hb m0 s0)); intuition.
  destruct H as (? & ? & ? & ? & ? & H).
  exfalso. auto.

  fold cases.
  apply (HT_consequence' _ _ _ _ _ (Hcbs m0 s0)); intuition.
  destruct H as (? & ? & ? & ? & ? & H).
  exfalso. auto.
Qed.

(** Proof of a specification for the switch-case generator indexed by type [I]. *)
Section IndexedCasesSpec.

Variable cnil: code.
Variable Qnil: GProp.
Variable I: Type.
Variable genC genB: I -> code.
Variable genQ: I -> GProp.
Variable genV: I -> HFun.

Definition indexed_post: (list I) -> GProp :=
  fix f (indices: list I) :=
    fun m0 s0 m s =>
      match indices with
      | []            => Qnil m0 s0 m s
      | i :: indices' => (genV i m0 s0 <> 0 -> genQ i m0 s0 m s) /\
                         (genV i m0 s0 =  0 -> f indices' m0 s0 m s)
      end.

Variable P: HProp.
Definition indexed_hyps: (list I) -> Prop :=
  fix f (indices: list I) :=
    match indices with
    | []            => True
    | i :: indices' => GT_push_v (genC i) P (genV i) /\
                       GT_guard_v (genB i) P (genV i) (genQ i) /\
                       f indices'
    end.

Lemma indexed_cases_spec: forall is,
  GT cnil P Qnil ->
  indexed_hyps is ->
  GT (indexed_cases cnil genC genB is)
     P
     (indexed_post is).
Proof.
  induction is; intros.
  - eapply cases_spec_base_GT_specialized; eauto.
  - simpl in *.
    eapply cases_spec_step_GT_specialized; intuition auto.
Qed.

End IndexedCasesSpec.

(** * HTEscape specification for escaping code *)

Lemma ret_specEscape: forall raddr (P: HProp),
  HTEscape raddr [Ret]
    (fun m s => exists s', s = (CRet raddr false false::s') /\ P m s')
    (fun m s => (P m s , Success)).
Proof.
  intros. destruct raddr eqn:E; subst.
  unfold HTEscape.
  split_vc; subst.

  (* Run an instruction *)
  eapply rte_success; auto.
  eapply ruu_end; simpl; eauto.
  eapply cstep_ret_p; auto.
  eapply cptr_done.
Qed.

Lemma jump_specEscape_Failure: forall tag raddr (P: HProp),
  HTEscape raddr [Jump]
           (fun m s => exists s0, (-1, tag) ::: s0 = s /\ P m s0)
           (fun m s => (P m s , Failure)).
Proof.
  intros.
  unfold HTEscape.
  split_vc; subst.

  (* Run an instruction *)
  eapply rte_fail; auto.
  eapply rte_step; eauto.
  eapply cstep_jump_p; auto.
  simpl; eauto; lia.
Qed.

Lemma skipNZ_specEscape: forall r c1 c2 v P1 P2 Q,
  (v =  0 -> HTEscape r c1 P1 Q) ->
  (v <> 0 -> HTEscape r c2 P2 Q) ->
  HTEscape r ((skipNZ (length c1) ++ c1) ++ c2)
           (fun m s => exists s0, s = (v, handlerTag) ::: s0 /\
                                  (v =  0 -> P1 m s0) /\
                                  (v <> 0 -> P2 m s0))
           Q.
Proof.
  intros.
  unfold skipNZ.
  destruct (dec_eq v 0); subst.
  - eapply HTEscape_append.
    eapply HTEscape_compose.
    eapply skipNZ_spec_Z; auto.
    eapply HTEscape_strengthen_premise; intuition eauto.
  - eapply HTEscape_compose.
    eapply skipNZ_continuation_spec_NZ; auto.
    eapply HTEscape_strengthen_premise; intuition eauto.
Qed.

Lemma ifNZ_specEscape: forall r t f v Pt Pf Q,
  (v <> 0 -> HTEscape r t Pt Q) ->
  (v =  0 -> HTEscape r f Pf Q) ->
  HTEscape r (ifNZ t f)
           (fun m s => exists s0, s = (v, handlerTag) ::: s0 /\
                                  (v <> 0 -> Pt m s0) /\
                                  (v =  0 -> Pf m s0))
           Q.
Proof.
  intros.
  unfold ifNZ.
  rewrite <- app_ass.
  eapply HTEscape_strengthen_premise.
  eapply skipNZ_specEscape with (v:=v).
  - intros.
    eapply HTEscape_append; eauto.
  - intros.
    eauto.
  - intros m s (s0 & ? & H1 & H2); subst; eauto.
Qed.

End CodeSpecs.


Section ml.
Variables A B C:Prop.
Theorem Anddiste: and A (or B C) <-> or (and A B) (and A C).
Proof.
split.
intro H0.
elim H0.
intro Ha.
intro H1.
elim H1.
intro Hb; left; split; assumption.
intro Hc; right; split; assumption.
intro H2.
elim H2.
intro Hab.
elim Hab.
intros Ha Hb.
split.
assumption.
left; assumption.
intro Hac; elim Hac; intros Ha Hc.
split.
assumption.
right; assumption.
Qed.
End ml.

Check Anddiste.


Require Import Utf8.
Require Import LibTactics LibFset.
Require Import CpdtTactics.
Local Set Implicit Arguments.

Section section_subset_facts.
Context (A : Type).
Context (E F G : fset A).

Lemma subset_trans :
E \c F → F \c G → E \c G.
Proof.
intros_all ; crush.
Qed.

Lemma subset_union_l :
E \c F → E \c (F \u G).
Proof.
intros_all.
rewrite in_union.
crush.
Qed.

Lemma subset_union_r :
E \c G → E \c (F \u G).
Proof.
intros_all.
rewrite in_union.
crush.
Qed.

Lemma notin_subset (a : A) :
a \notin F → E \c F → a \notin E.
Proof.
intros_all ; crush.
Qed.

Lemma subset_refl' :
E = F → E \c F.
Proof.
crush.
Qed.

Lemma union_subset :
E \c G → F \c G → (E \u F) \c G.
Proof.
intros_all.
rewrite in_union in *.
crush.
Qed.

Lemma union_subset_inv_l :
E \u F \c G → E \c G.
Proof.
intros H1 x H2.
apply (H1 x).
rewrite in_union ; crush.
Qed.

Lemma union_subset_inv_r :
E \u F \c G → F \c G.
Proof.
intros H1 x H2.
apply (H1 x).
rewrite in_union ; crush.
Qed.

Lemma union_subset_inv :
E \u F \c G → E \c G ∧ F \c G.
Proof.
intro ; split ; [ apply union_subset_inv_l | apply union_subset_inv_r ] ; trivial.
Qed.

End section_subset_facts.


Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Coq.Lists.List.
Require Import Optimizer.AbstractMap.
Require Import Optimizer.ProofOfConcept.Flags.
Require Import Optimizer.Util.Deciders.
Require Import Optimizer.Util.Tactics.
Import ListNotations.
Local Open Scope Z_scope.

Section Defns.
  Context {register : Type} {register_size : register -> Z}.

  Local Notation "x '[' n ']'" := (List.nth_default 0 x n) (at level 0).
  Local Notation "x >> y" := (Z.shiftr x y) (at level 100).
  Local Notation "x << y" := (Z.shiftl x y) (at level 100).
  Local Coercion Z.b2z : bool >-> Z.

  Inductive instruction : Set := ADD32 | ADD64 | ADC64 | SUB64 | MUL64 | SHR64 | SHL64 | MOV64.

  Definition flags_written (i:instruction) : list Flags.flag :=
    match i with
    | ADD32 | ADD64 | ADC64 | SUB64 | MUL64 | SHR64 | SHL64 => (Flags.C :: Flags.Z :: nil)
    | MOV64 => nil
    end.

  Definition flags_read (i:instruction) : list Flags.flag :=
    match i with
    | ADC64 => (Flags.C :: nil)
    | ADD32 | ADD64| SUB64 | MUL64 | SHR64 | SHL64 | MOV64 => nil
    end.

  Definition spec (i:instruction) (args : list Z) (fctx : Flags.flag -> bool) : Z :=
    match i with
    | ADD32 => args[0] + args[1]
    | ADD64 => args[0] + args[1]
    | ADC64 => args[0] + args[1] + fctx Flags.C
    | SUB64 => args[0] - args[1]
    | MUL64 => args[0] * args[1]
    | SHR64 => args[0] >> args[1]
    | SHL64 => args[0] << args[1]
    | MOV64 => args[0]
    end.

  Definition instr_size (i:instruction) : Z :=
    match i with
    | ADD32 => 32
    | ADD64 | ADC64 | SUB64 | MUL64 | SHR64 | SHL64 | MOV64 => 64
    end.

  Definition num_source_regs (i:instruction) : nat :=
    match i with
    | ADD32 | ADD64 | ADC64 | SUB64 | MUL64 | SHR64 | SHL64 => 2
    | MOV64 => 1
    end.

  Definition arg_size (x : register + Z) : Z :=
    match x with
    | inl r => register_size r
    | inr z =>
      if Z_lt_dec z 0
      then 0
      else Z.pos (Pos.size (Z.to_pos z))
    end.

  Definition precondition (i:instruction) (rd:register) (args:list (register + Z)) : Prop :=
    length args = num_source_regs i
    /\ Forall (fun r => 0 < arg_size r <= instr_size i) args
    /\ instr_size i <= register_size rd.

  Definition instr_cost (i:instruction) : nat :=
    match i with
    | ADD32 => 2
    | ADD64 | ADC64 | SUB64 => 4
    | MUL64 => 8
    | SHR64 | SHL64 => 2
    | MOV64 => 1
    end.

  Definition instr_eq_dec (i1 i2 : instruction) : {i1 = i2} + {i1 <> i2}.
  Proof. destruct i1, i2; try (right; congruence); left; reflexivity. Defined.

  (* TODO: is there a more elegant way to do this? *)
  Definition all_instructions := [ADD32; ADD64; ADC64; SUB64; MUL64; SHR64; SHL64; MOV64].
End Defns.

Section Proofs.
  Context {register : Type} {register_size : register -> Z}.
  (* TODO: simplify/automate; probably want a push_pos2z tactic, etc *)
  Lemma arg_size_constant_upper_bound x u :
    0 < arg_size (register_size:=register_size) (inr x) <= u ->
    0 <= x < 2 ^ u.
  Proof.
    cbv [arg_size]; break_match; intro Hrange;
      destruct Hrange as [Hlower Hupper]; [lia | split; [ lia | ] ].
    destruct (Z.eq_dec x 0); (* Z->positive proofs want x > 0 *)
      [ subst; apply Z.pow_pos_nonneg; lia | ].
    eapply Z.le_lt_trans with (m:=Z.pos (Z.to_pos x));
      [rewrite Z2Pos.id by lia; reflexivity | ].
    eapply Z.lt_le_trans with (m:=Z.pos (2^(Pos.size (Z.to_pos x)))).
    { auto using Pos2Z.pos_lt_pos, Pos.size_gt. }
    { rewrite Pos2Z.inj_pow.
      apply Z.pow_le_mono_r; [ lia | ].
      lia. }
  Qed.
  Lemma all_instructions_complete : forall i, In i all_instructions.
  Proof. destruct i; cbn; tauto. Qed.
  Lemma instr_cost_pos i : (0 < instr_cost i)%nat.
  Proof. destruct i; cbn; lia. Qed.

  Lemma precondition_length_args i rd args :
    precondition (register_size:=register_size) i rd args ->
    length args = i.(num_source_regs).
  Proof. inversion 1; intros; tauto. Qed.

  Lemma precondition_instr_size i rd args x :
    precondition (register_size:=register_size) i rd args ->
    In (inr x) args ->
    0 <= x < 2^instr_size i.
  Proof.
    inversion 1; intros. destruction.
    match goal with
    | H : _ |- _ => rewrite Forall_forall in H;
                      specialize (H (inr x) ltac:(assumption))
    end.
    apply arg_size_constant_upper_bound. lia.
  Qed.

  Definition precondition_dec i rd args :
    {precondition (register_size:=register_size) i rd args}
    + {~ precondition (register_size:=register_size) i rd args}.
  Proof. cbv [precondition]; auto with deciders. Defined.

  Context {flag_mapt : map_impl Flags.flag}.

  Lemma flags_read_correct i f :
    ~ (In f i.(flags_written)) ->
    forall v args flag_values,
      spec i args (get (update flag_values f v)) =
      spec i args (get (flag_values)).
  Proof.
    destruct i; destruct f;
      repeat match goal with
             | _ => progress intros
             | _ => progress cbn [flags_written spec In] in *
             | _ => reflexivity
             | _ => rewrite get_update_neq by congruence
             | _ => tauto
             end.
  Qed.
End Proofs.
Hint Resolve precondition_dec instr_eq_dec : deciders.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor Functor.Functor_Ops.
Require Import Basic_Cons.Terminal.
Require Import Cat.Cat Cat.Cat_Iso.

(** In this section we show that if a category C has a terminal object and D is
a category isomorphic to C, then D also has a terminal object. *)
Section Term_IsoCat.
  Context {C D : Category} (I : (C ≃≃ D ::> Cat)%isomorphism) (trm : Terminal C).

  Program Definition Term_IsoCat : Terminal D
    :=
      {|
        terminal := ((iso_morphism I) _o)%object trm;
        t_morph :=
          fun c =>
            match
              f_equal (fun w : (D –≻ D)%functor => (w _o)%object c) (right_inverse I)
              in _ = u return
              (u –≻ _)%morphism
            with
              eq_refl => ((iso_morphism I) _a ((t_morph trm ((I⁻¹)%morphism _o c))))%morphism
            end;
        t_morph_unique :=
          fun c f g => _
      |}
  .

  Next Obligation.
  Proof.
    assert (H := f_equal (fun w : (C –≻ C)%functor => (w _o)%object (terminal trm)) (left_inverse I)).
    cbn in H.
    cut (
        match H in _ = u return
              (_ –≻ u)%morphism
        with
        | eq_refl => ((I ⁻¹) _a f)%morphism
        end
        =
        match H in _ = u return
              (_ –≻ u)%morphism
        with
        | eq_refl => ((I ⁻¹) _a g)%morphism
        end
    ).
    {
      intros H2.
      destruct H.
      match type of H2 with
        ?A = ?B =>
        assert (((iso_morphism I) _a A) = ((iso_morphism I) _a B))%morphism by (rewrite H2; trivial)
      end.
      rewrite <- (Cat_Iso_conv_inv_I_inv_I (Inverse_Isomorphism I) f).
      rewrite <- (Cat_Iso_conv_inv_I_inv_I (Inverse_Isomorphism I) g).
      apply f_equal.
      trivial.
    }
    {
      apply t_morph_unique.
    }
  Qed.

End Term_IsoCat.


Parameters p1 p2 t1 t2 : Prop.

Definition aff1 := (p1 \/ p2).
Definition aff2 := t1.
Definition k := (aff1 /\ aff2) \/ (~aff1 /\ ~aff2).
Definition h1 := ~(p1 /\ t1) /\ ~(p2 /\ t2).
Definition h2 := (p1 \/ t1) /\ (p2 \/ t2).

Lemma epreuve_2 : h1 /\ h2 /\ k -> t1 /\ p2.
Proof.
unfold k, h1, h2.
unfold aff1, aff2.
intros.
destruct H.
destruct H.
destruct H0.
destruct H0.
destruct H2.
destruct H2.
split; try assumption.
destruct H3; try assumption.
destruct H2; try assumption.
elimtype False.
auto.

destruct H2.
destruct H0.
elimtype False.
auto.

elimtype False.
auto.

Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

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

(* Generalizable All Variables. *)
Require Import Aw_0_Notations.
Require Import Aw_1_3_Categories.
Require Import Aw_1_4_Functors.
Require Import Aw_1_5_Isomorphisms.

(*******************************************************************************)
(* Chapter 7.5: Natural Isomorphisms                                           *)
(*******************************************************************************)

Generalizable Variable A B.

(* Definition 7.10 *)
Class NaturalIsomorphism `{C1 : Category} `{C2 : Category} {Fobj1 Fobj2 : C1 -> C2}
      (F1 : @Functor C1 _ _ C2 _ _ Fobj1) (F2 : @Functor C1 _ _ C2 _ _ Fobj2) :=
  {
    ni_iso      : forall A, Fobj1 A ≅ Fobj2 A;
    ni_commutes : forall `(f : A ~> B),
                    F2 \ f \\o #(ni_iso A) === #(ni_iso B) \\o F1 \ f
  }.
Arguments ni_iso {Obj Hom Obj0 Hom0 C1 C2 Fobj1 Fobj2 F1 F2} Ni A : rename.
Arguments ni_commutes {Obj Hom Obj0 Hom0 C1 C2 Fobj1 Fobj2 F1 F2} Ni A B f : rename.
Check ni_commutes.

(* FIXME: coerce to NaturalTransformation instead *)

Coercion ni_iso : NaturalIsomorphism >-> Funclass.
Notation "F <~~~> G" := (@NaturalIsomorphism _ _ _ _ _ _ _ _ F G) : category_scope.

(* same as ni_commutes, but phrased in terms of inverses *)
Lemma ni_commutes' `(ni : NaturalIsomorphism) :
  forall `(f : A ~> B),
    #(ni_iso ni B)⁻¹ \\o F2 \ f === F1 \ f \\o #(ni_iso ni A)⁻¹.
Proof.
  intros.
  apply iso_shift_right'.
  setoid_rewrite associativity.
  symmetry.
  apply iso_shift_left'.
  symmetry.
  apply ni_commutes.
Qed.

(* FIXME: Lemma 7.11: natural isos are natural transformations in which every morphism is an iso *)

(* every natural iso is invertible, and that inverse is also a natural iso *)

Generalizable Variable Fa Fb.

Definition ni_inv `(N : NaturalIsomorphism (F1 := Fa) (F2 := Fb)) : NaturalIsomorphism Fb Fa.
Proof.
  Check @Build_NaturalIsomorphism.
  Check @Build_NaturalIsomorphism _ _ _ _ _ _ _ _ Fb Fa.
  Check (fun A : C1 => @iso_inv _ _ _ _ _ (ni_iso N A)). (* ∀ A : C1, Fobj2 A ≅ Fobj1 A *)
  Check (@Build_NaturalIsomorphism _ _ _ _ _ _ _ _ Fb Fa (fun A : C1 => @iso_inv _ _ _ _ _ (ni_iso N A))).

  apply (@Build_NaturalIsomorphism _ _ _ _ _ _ _ _ Fb Fa (fun A : C1 => @iso_inv _ _ _ _ _ (ni_iso N A))).
  move=> A' B f /=.
  Check ni_commutes N A' B f.
  have qqq := ni_commutes N A' B f.
  symmetry in qqq.
  apply iso_shift_left' in qqq.
  rewrite qqq.
  rewrite 2!associativity.
  rewrite [# (N A') \\o iso_backward (N A')]iso_comp2.
  rewrite right_identity.
  reflexivity.
Defined.

Definition ni_id `{C1 : Category} `{C2 : Category} {Fobj}
           (F : @Functor C1 _ _ C2 _ _ Fobj) : NaturalIsomorphism F F.
Proof.
  Check @Build_NaturalIsomorphism _ _ _ _ _ _ _ _ F F.
  Check (fun A : C1 => @iso_id _ _ _ (F A)).
  Check @Build_NaturalIsomorphism _ _ _ _ _ _ _ _ F F (fun A : C1 => @iso_id _ _ _ (F A)).

  apply (@Build_NaturalIsomorphism _ _ _ _ _ _ _ _ F F (fun A : C1 => @iso_id _ _ _ (F A))).
  move=> A B f /=.
  rewrite left_identity.
  rewrite right_identity.
  reflexivity.
Defined.

(* two different choices of composition order are naturally isomorphic (strictly, in fact) *)
Program Instance ni_associativity `{C1 : Category} `{C2 : Category} `{C3 : Category} `{C4 : Category}
  {Fobj1} (F1 : @Functor C1 _ _ C2 _ _ Fobj1)
  {Fobj2} (F2 : @Functor C2 _ _ C3 _ _ Fobj2)
  {Fobj3} (F3 : @Functor C3 _ _ C4 _ _ Fobj3) : ((F1 >>>> F2) >>>> F3) <~~~> (F1 >>>> (F2 >>>> F3)).
Obligation 1.
Proof.
  Check @iso_id.
  Check @iso_id _ _ _ (F3 (F2 (F1 A))).
  by apply (@iso_id _ _ _ (F3 (F2 (F1 A)))).
Defined.
Obligation 2.
Proof.
  rewrite left_identity.
  rewrite right_identity.
  reflexivity.
Defined.

(*
Definition ni_comp `{C:Category}`{D:Category}
   {F1Obj}{F1:@Functor _ _ C _ _ D F1Obj}
   {F2Obj}{F2:@Functor _ _ C _ _ D F2Obj}
   {F3Obj}{F3:@Functor _ _ C _ _ D F3Obj}
   (N1:NaturalIsomorphism F1 F2)
   (N2:NaturalIsomorphism F2 F3)
   : NaturalIsomorphism F1 F3.
   intros.
     destruct N1 as [ ni_iso1 ni_commutes1 ].
     destruct N2 as [ ni_iso2 ni_commutes2 ].
   exists (fun A => iso_comp (ni_iso1 A) (ni_iso2 A)).
   abstract (intros; simpl;
             setoid_rewrite <- associativity;
             setoid_rewrite <- ni_commutes1;
             setoid_rewrite associativity;
             setoid_rewrite <- ni_commutes2;
             reflexivity).
   Defined.
*)

Definition ni_respects1 `{A : Category} `{B : Category}
           {Fobj} (F : @Functor A _ _ B _ _ Fobj)
           `{C : Category}
           {G0obj} (G0 : @Functor B _ _ C _ _ G0obj)
           {G1obj} (G1 : @Functor B _ _ C _ _ G1obj) :
  (G0 <~~~> G1) -> ((F >>>> G0) <~~~> (F >>>> G1)).
Proof.
  move=> phi.
  destruct phi as [ phi_niso phi_comm ].
  refine {| ni_iso := (fun a => phi_niso (Fobj a)) |}.
  intros; simpl; apply phi_comm.
Defined.

Definition ni_respects2
  `{A:Category}`{B:Category}
  {F0obj}(F0:Functor A B F0obj)
  {F1obj}(F1:Functor A B F1obj)
  `{C:Category}
  {Gobj}(G:Functor B C Gobj)
  : (F0 <~~~> F1) -> ((F0 >>>> G) <~~~> (F1 >>>> G)).
  intro phi.
  destruct phi as [ phi_niso phi_comm ].
  refine {| ni_iso := fun a => (@functors_preserve_isos _ _ _ _ _ _ _ G) _ _ (phi_niso a) |}.
  intros; simpl.
  setoid_rewrite fmor_preserves_comp.
  apply fmor_respects.
  apply phi_comm.
  Defined.

Definition ni_respects
  `{A : Category} `{B : Category}
  {F0obj}(F0 : Functor A B F0obj)
  {F1obj}(F1 : Functor A B F1obj)
  `{C : Category}
  {G0obj}(G0 : Functor B C G0obj)
  {G1obj}(G1 : Functor B C G1obj)
  : (F0 <~~~> F1) -> (G0 <~~~> G1) -> ((F0 >>>> G0) <~~~> (F1 >>>> G1)).
  intro phi.
  intro psi.
  destruct psi as [ psi_niso psi_comm ].
  destruct phi as [ phi_niso phi_comm ].
  refine {| ni_iso :=
      (fun a => iso_comp ((@functors_preserve_isos _ _ _ _ _ _ _ G0) _ _ (phi_niso a)) (psi_niso (F1obj a))) |}.
  abstract (intros; simpl;
            setoid_rewrite <- associativity;
            setoid_rewrite fmor_preserves_comp;
            setoid_rewrite <- phi_comm;
            setoid_rewrite <- fmor_preserves_comp;
            setoid_rewrite associativity;
            apply comp_respects; try reflexivity;
            apply psi_comm).
  Defined.

(*
 * Some structures (like monoidal and premonoidal functors) use the isomorphism
 * component of a natural isomorphism in an "informative" way; these structures
 * should use NaturalIsomorphism.
 *
 * However, in other situations the actual iso used is irrelevant; all
 * that matters is the fact that a natural family of them exists.  In
 * these cases we can speed up Coq (and the extracted program)
 * considerably by making the family of isos belong to [Prop] rather
 * than [Type].  IsomorphicFunctors does this -- it's essentially a
 * copy of NaturalIsomorphism which lives in [Prop].
 *)

(* Definition 7.10 *)
Definition IsomorphicFunctors `{C1 : Category} `{C2 : Category} {Fobj1 Fobj2 : C1->C2}(F1 : Functor C1 C2 Fobj1)(F2 : Functor C1 C2 Fobj2) :=
  exists  ni_iso      : (forall A, Fobj1 A ≅ Fobj2 A),
                         forall `(f : A~>B), #(ni_iso A) >>> F2 \ f ~~ F1 \ f >>> #(ni_iso B).
Notation "F ≃ G" := (@IsomorphicFunctors _ _ _ _ _ _ _ _ F G) : category_scope.

Definition if_id `{C : Category} `{D : Category} {Fobj}(F : Functor C D Fobj) : IsomorphicFunctors F F.
  exists (fun A => iso_id (F A)).
  abstract (intros;
            simpl;
            etransitivity;
            [ apply left_identity |
            symmetry;
            apply right_identity]).
  Qed.

(* every natural iso is invertible, and that inverse is also a natural iso *)
Definition if_inv
  `{C1 : Category} `{C2 : Category} {Fobj1 Fobj2 : C1->C2} {F1 : Functor C1 C2 Fobj1} {F2 : Functor C1 C2 Fobj2}
   (N : IsomorphicFunctors F1 F2)  :  IsomorphicFunctors F2 F1.
  intros.
    destruct N as [ ni_iso ni_commutes ].
    exists (fun A => iso_inv _ _ (ni_iso A)).
  intros; simpl.
    symmetry.
    set (ni_commutes _ _ f) as qq.
    symmetry in qq.
    apply iso_shift_left' in qq.
    setoid_rewrite qq.
    repeat setoid_rewrite <- associativity.
    setoid_rewrite iso_comp2.
    setoid_rewrite left_identity.
    reflexivity.
  Qed.

Definition if_comp `{C : Category} `{D : Category}
   {F1Obj} {F1 : @Functor _ _ C _ _ D F1Obj}
   {F2Obj} {F2 : @Functor _ _ C _ _ D F2Obj}
   {F3Obj} {F3 : @Functor _ _ C _ _ D F3Obj}
   (N1 : IsomorphicFunctors F1 F2)
   (N2 : IsomorphicFunctors F2 F3)
    :  IsomorphicFunctors F1 F3.
   intros.
     destruct N1 as [ ni_iso1 ni_commutes1 ].
     destruct N2 as [ ni_iso2 ni_commutes2 ].
   exists (fun A => iso_comp (ni_iso1 A) (ni_iso2 A)).
   abstract (intros; simpl;
             setoid_rewrite <- associativity;
             setoid_rewrite <- ni_commutes1;
             setoid_rewrite associativity;
             setoid_rewrite <- ni_commutes2;
             reflexivity).
   Qed.

(* two different choices of composition order are naturally isomorphic (strictly, in fact) *)
Definition if_associativity
  `{C1 : Category} `{C2 : Category} `{C3 : Category} `{C4 : Category}
  {Fobj1}(F1 : Functor C1 C2 Fobj1)
  {Fobj2}(F2 : Functor C2 C3 Fobj2)
  {Fobj3}(F3 : Functor C3 C4 Fobj3)
   :
  ((F1 >>>> F2) >>>> F3) ≃ (F1 >>>> (F2 >>>> F3)).
  exists (fun A => iso_id (F3 (F2 (F1 A)))).
  abstract (intros;
            simpl;
            setoid_rewrite left_identity;
            setoid_rewrite right_identity;
            reflexivity).
  Defined.

Definition if_left_identity `{C1 : Category} `{C2 : Category} {Fobj1}(F1 : Functor C1 C2 Fobj1)  :  (functor_id _ >>>> F1) ≃ F1.
  exists (fun a => iso_id (F1 a)).
  abstract (intros; unfold functor_comp; simpl;
            setoid_rewrite left_identity;
            setoid_rewrite right_identity;
            reflexivity).
  Defined.

Definition if_right_identity `{C1 : Category} `{C2 : Category} {Fobj1}(F1 : Functor C1 C2 Fobj1)  :  (F1 >>>> functor_id _) ≃ F1.
  exists (fun a => iso_id (F1 a)).
  abstract (intros; unfold functor_comp; simpl;
            setoid_rewrite left_identity;
            setoid_rewrite right_identity;
            reflexivity).
  Defined.

Definition if_respects
  `{A : Category} `{B : Category}
  {F0obj}(F0 : Functor A B F0obj)
  {F1obj}(F1 : Functor A B F1obj)
  `{C : Category}
  {G0obj}(G0 : Functor B C G0obj)
  {G1obj}(G1 : Functor B C G1obj)
   :  (F0 ≃ F1) -> (G0 ≃ G1) -> ((F0 >>>> G0) ≃ (F1 >>>> G1)).
  intro phi.
  intro psi.
  destruct psi as [ psi_niso psi_comm ].
  destruct phi as [ phi_niso phi_comm ].
  exists (fun a => iso_comp ((@functors_preserve_isos _ _ _ _ _ _ _ G0) _ _ (phi_niso a)) (psi_niso (F1obj a))).
  abstract (intros; simpl;
            setoid_rewrite <- associativity;
            setoid_rewrite fmor_preserves_comp;
            setoid_rewrite <- phi_comm;
            setoid_rewrite <- fmor_preserves_comp;
            setoid_rewrite associativity;
            apply comp_respects; try reflexivity;
            apply psi_comm).
  Defined.

Section ni_prod_comp.
Require Import ProductCategories_ch1_6_1.
  Context
  `{C1 : Category} `{C2 : Category}
  `{D1 : Category} `{D2 : Category}
   {F1Obj}(F1 : @Functor _ _ C1 _ _ D1 F1Obj)
   {F2Obj}(F2 : @Functor _ _ C2 _ _ D2 F2Obj)
  `{E1 : Category} `{E2 : Category}
   {G1Obj}(G1 : @Functor _ _ D1 _ _ E1 G1Obj)
   {G2Obj}(G2 : @Functor _ _ D2 _ _ E2 G2Obj).

  Definition ni_prod_comp_iso A  :  (((F1 >>>> G1) **** (F2 >>>> G2)) A) ≅ (((F1 **** F2) >>>> (G1 **** G2)) A).
    unfold functor_fobj.
    unfold functor_product_fobj.
    simpl.
    apply iso_id.
    Defined.

  Lemma ni_prod_comp  :  (F1 >>>> G1) **** (F2 >>>> G2) <~~~> (F1 **** F2) >>>> (G1 **** G2).
    refine {| ni_iso := ni_prod_comp_iso |}.
    intros.
    destruct A.
    destruct B.
    simpl.
    setoid_rewrite left_identity.
    setoid_rewrite right_identity.
    split; reflexivity.
    Defined.
End ni_prod_comp.


From stdpp Require Import list.
From Coq Require Import ssreflect.

Ltac normalize_app_assoc :=
  repeat match goal with
  | [ |- context [ (?l1 ++ ?l2) ++ ?l3 ] ] => rewrite -app_assoc
  end.

Section slice.
  Context {A : Type}.
  Implicit Type l : list A.
  Implicit Type a k : nat.

  Definition slice l a k : list A :=
    take k (drop a l).

  Lemma slice_nil l a :
    slice l a 0 = [].
  Proof.
    by rewrite /slice take_0.
  Qed.

  Lemma slice_full l k :
    k = length l → slice l 0 k = l.
  Proof.
    intros ->. by rewrite /slice drop_0 firstn_all.
  Qed.

  Lemma slice_length l a k :
    a + k ≤ length l → length (slice l a k) = k.
  Proof.
    rewrite take_length drop_length. lia.
  Qed.

  Lemma slice_nil_iff l a k :
    a + k ≤ length l →
    slice l a k = [] ↔ k = 0.
  Proof.
    intros. rewrite -length_zero_iff_nil slice_length //.
  Qed.

  Lemma slice_nonempty_iff l a k :
    a + k ≤ length l →
    slice l a k ≠ [] ↔ 0 < k.
  Proof.
    intros. have -> : 0 < k ↔ k ≠ 0 by lia.
    by apply not_iff_compat, slice_nil_iff.
  Qed.

  Lemma slice_lookup l a k i :
    i < k → (slice l a k) !! i = l !! (a + i).
  Proof.
    intros. by rewrite /slice lookup_take ?lookup_drop.
  Qed.

  Lemma slice_singleton l a x :
    l !! a = Some x → slice l a 1 = [x].
  Proof.
    intros. eapply list_eq_same_length; eauto.
    - have ? : a < length l by apply lookup_lt_is_Some; naive_solver.
      rewrite slice_length //; lia.
    - intros i x' x'' => /= => ?.
      rewrite slice_lookup //.
      have -> : i = 0 by lia.
      rewrite Nat.add_0_r. naive_solver.
  Qed.

  Lemma slice_singleton_iff l a k x :
    a + k ≤ length l →
    slice l a k = [x] ↔ k = 1 ∧ l !! a = Some x.
  Proof.
    intros. split.
    - intros Heq.
      have ? : k = 1.
      { apply (f_equal length) in Heq. by rewrite slice_length in Heq. }
      subst. apply (f_equal (lookup 0)) in Heq. simpl in Heq.
      rewrite slice_lookup in Heq; [lia|]. by rewrite Nat.add_0_r in Heq.
    - intros [-> ?]. by apply slice_singleton.
  Qed.

  Lemma slice_full_iff l a k :
    a + k ≤ length l → l ≠ [] →
    slice l a k = l ↔ a = 0 ∧ k = length l.
  Proof.
    intros. split.
    - intros Hl. apply (f_equal length) in Hl.
      rewrite slice_length in Hl; first done. lia.
    - intros [-> ->]. by rewrite /slice drop_0 firstn_all.
  Qed.

  Lemma slice_app_1 l a k1 k2 :
    slice l a k1 ++ slice l (a + k1) k2 = slice l a (k1 + k2).
  Proof.
    by rewrite /slice -drop_drop take_take_drop.
  Qed.

  Lemma slice_app_2 l a k1 k2 :
    k1 ≤ a →
    slice l (a - k1) k1 ++ slice l a k2 = slice l (a - k1) (k1 + k2).
  Proof.
    intros. have {2}-> : a = (a - k1) + k1 by lia.
    by rewrite slice_app_1.
  Qed.

  Lemma slice_split l a k h :
    h ≤ k →
    slice l a k = slice l a h ++ slice l (a + h) (k - h).
  Proof.
    intros. have {1}-> : k = h + (k - h) by lia.
    by rewrite slice_app_1.
  Qed.

  Lemma slice_eq_inv l a k k' :
    a + k ≤ length l →
    a + k' ≤ length l →
    slice l a k = slice l a k' → k' = k.
  Proof.
    intros ? ? Heq.
    apply (f_equal length) in Heq. rewrite !slice_length in Heq => //.
  Qed.

  Lemma NoDup_lookup_in_range l i j :
    NoDup l →
    i < length l →
    j < length l →
    l !! i = l !! j →
    i = j.
  Proof.
    intros Hnd Hi Hj Heq.
    apply lookup_lt_is_Some in Hi as [x ?].
    apply lookup_lt_is_Some in Hj as [y ?].
    have ? : x = y by congruence. subst.
    eapply NoDup_lookup; eauto.
  Qed.

  Lemma slice_eq_inv_NoDup l a k a' k' :
    NoDup l →
    a + k ≤ length l →
    a' + k' ≤ length l →
    0 < k' →
    slice l a k = slice l a' k' →
    a' = a ∧ k' = k.
  Proof.
    intros ? ? ? ? Heq.
    have ? : k = k'.
    { apply (f_equal length) in Heq. rewrite !slice_length in Heq => //. }
    subst. split => //.
    apply (f_equal (lookup 0)) in Heq.
    rewrite !slice_lookup ?Nat.add_0_r in Heq => //.
    eapply NoDup_lookup_in_range; eauto; lia.
  Qed.

  Lemma slice_app_inv_NoDup_aux l a k a1 k1 a2 k2 :
    NoDup l →
    a + k ≤ length l →
    a1 + k1 ≤ length l →
    a2 + k2 ≤ length l →
    0 < k1 →
    0 < k2 →
    slice l a k = slice l a1 k1 ++ slice l a2 k2 →
    a1 = a ∧ a2 = a1 + k1 ∧ k1 + k2 = k.
  Proof.
    intros ? ? ? ? ? ? Heq.
    have ? : k = k1 + k2.
    { apply (f_equal length) in Heq. rewrite app_length !slice_length in Heq => //. }
    subst.
    have ? : a1 = a.
    { apply (f_equal (lookup 0)) in Heq.
      rewrite lookup_app_l in Heq; first by rewrite slice_length //.
      rewrite !slice_lookup ?Nat.add_0_r in Heq; [lia..|].
      eapply NoDup_lookup_in_range; eauto; lia. }
    subst.
    have ? : a2 = a + k1.
    { apply (f_equal (lookup k1)) in Heq.
      rewrite lookup_app_r in Heq; first by rewrite slice_length.
      rewrite !slice_lookup ?slice_length ?Nat.sub_diag ?Nat.add_0_r in Heq; [lia..|].
      eapply NoDup_lookup_in_range; eauto; lia. }
    naive_solver.
  Qed.

  Definition sublist l' l : Prop :=
    ∃ l1 l2, l = l1 ++ l' ++ l2.

  Lemma sublist_app_l l l1 l2 :
    sublist (l1 ++ l2) l → sublist l1 l.
  Proof.
    intros [lp [ls Hl]]. exists lp, (l2 ++ ls).
    revert Hl. by normalize_app_assoc.
  Qed.

  Lemma sublist_app_r l l1 l2 :
    sublist (l1 ++ l2) l → sublist l2 l.
  Proof.
    intros [lp [ls Hl]]. exists (lp ++ l1), ls.
    revert Hl. by normalize_app_assoc.
  Qed.

  Lemma sublist_slice l' l :
    sublist l' l →
    ∃ a, a + length l' ≤ length l ∧ l' = slice l a (length l').
  Proof.
    intros [l1 [l2 ->]]. exists (length l1). split.
    - rewrite !app_length. lia.
    - by rewrite /slice drop_app take_app.
  Qed.

  Lemma sublist_app_slice_NoDup l l1 l2 :
    NoDup l →
    sublist (l1 ++ l2) l →
    0 < length l1 →
    0 < length l2 →
    ∃ a, a + length l1 + length l2 ≤ length l ∧
      l1 = slice l a (length l1) ∧ l2 = slice l (a + length l1) (length l2).
  Proof.
    intros ? Hl ? ?.
    have Hl1 : sublist l1 l by eapply sublist_app_l; eauto.
    apply sublist_slice in Hl1 as [a1 [? Hl1]].
    have Hl2 : sublist l2 l by eapply sublist_app_r; eauto.
    apply sublist_slice in Hl2 as [a2 [? Hl2]].
    apply sublist_slice in Hl as [a [Hlen Hl]].
    rewrite app_length in Hlen.
    symmetry in Hl. rewrite Hl1 Hl2 in Hl.
    rewrite app_length !slice_length in Hl => //.
    apply slice_app_inv_NoDup_aux in Hl => //.
    naive_solver.
  Qed.

  Lemma slice_sublist l a k :
    a + k ≤ length l → sublist (slice l a k) l.
  Proof.
    intros. exists (slice l 0 a), (slice l (a + k) (length l - a - k)).
    rewrite !slice_app_1.
    have -> : a + (k + (length l - a - k)) = length l by lia.
    by rewrite slice_full.
  Qed.

  Lemma slice_app_inv_NoDup l a k l1 l2 :
    NoDup l →
    a + k ≤ length l →
    slice l a k = l1 ++ l2 →
    l1 = slice l a (length l1) ∧ l2 = slice l (a + length l1) (k - length l1).
  Proof.
    intros ? ? Hl.
    have Hsub : sublist (l1 ++ l2) l. { rewrite -Hl. by apply slice_sublist. }
    destruct l1 as [|x1 l1]; last destruct l2 as [|x2 l2].
    - rewrite app_nil_l in Hl. rewrite slice_nil Nat.add_0_r Nat.sub_0_r //.
    - rewrite app_nil_r in Hl.
      have ? : k = length (x1 :: l1) by rewrite -Hl slice_length.
      subst. rewrite Nat.sub_diag slice_nil //.
    - apply sublist_app_slice_NoDup in Hsub as [a' [Hlen [Hl1 Hl2]]] => //.
      2,3: rewrite cons_length; lia.
      rewrite Hl1 Hl2 in Hl. rewrite cons_length in Hlen.
      apply slice_app_inv_NoDup_aux in Hl as [? [? ?]] => //.
      2-4: rewrite cons_length; lia.
      have -> : k - length (x1 :: l1) = length (x2 :: l2) by lia.
      naive_solver.
  Qed.

End slice.