(*|
=============================================================
 6.822 Formal Reasoning About Programs, Spring 2022 - Pset 9
=============================================================
|*)

Require Import Pset9Sig.

(*|
Hoare Logic with Input/Output Traces
====================================

Hoare logic as covered in lecture is only the beginning, in terms of programming
features that can be supported. In this problem set, we will use a variant, a
Hoare logic that deals with input/output traces.

This problem set is not about defining a program logic; instead, we'll focus
on proving programs.
|*)

Module Impl.

(*|
Language syntax
===============

There is nothing special with the definitions of `exp` and `bexp`; they are
similar to what we've seen in lecture.
|*)

Inductive nat_op :=
| Plus
| Minus
| Times.

Inductive exp :=
| Const (n : nat)
| Var (x : string)
| Read (e1 : exp)
| NatOp (b: nat_op) (e1 e2 : exp).

Inductive bool_op :=
| Equal
| Less.

Inductive bexp :=
| BoolOp (b: bool_op) (e1 e2 : exp)
| Neg (b: bexp).

(*|
`heap` and `valuation` are also as usual.
|*)

Definition heap := fmap nat nat.
Definition valuation := fmap var nat.

(*|
Besides `heap` and `valuation` objects, we now have `trace` objects.  Traces are
lists of `io` events used to track communication with the outside world.
|*)

Inductive io := In (v : nat) | Out (v : nat).
Definition trace := list io.

(*|
Assertions now talk about traces in addition to internal states.
|*)

Definition assertion := trace -> heap -> valuation -> Prop.

(*|
`cmd` has two new constructors: `Input` and `Output`.
|*)

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)
  (* `Input` takes an input from the external world and assigns
     the value to the local variable `x`. *)
| Input (x : var)
  (* `Output` sends the value of `e` to the outside world. *)
| Output (e : exp).

(* BEGIN NOTATION MAGIC *)
Coercion Const : nat >-> exp.
Coercion Var : string >-> exp.
Declare Scope cmd_scope.
Notation "*[ e ]" := (Read e) : cmd_scope.
Notation "a + b" := (NatOp Plus a b) : cmd_scope.
Notation "a - b" := (NatOp Minus a b) : cmd_scope.
Notation "a * b" := (NatOp Times a b) : cmd_scope.
Notation "a = b" := (BoolOp Equal a b) : cmd_scope.
Notation "a < b" := (BoolOp Less a b) : cmd_scope.
Notation "! e" := (Neg e) (at level 90) : 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) : cmd_scope.
Notation "'when' b 'then' then_ 'done'" :=
  (If_ b then_ Skip) (at level 75, b at level 0) : cmd_scope.
Notation "{{ I }}  'while' b 'loop' body 'done'" := (While_ I%nat%type b body) (at level 75) : cmd_scope.
Notation "x '<--' 'input'" := (Input x) (at level 75) : cmd_scope.
Notation "'output' e" := (Output e) (at level 75) : cmd_scope.
Delimit Scope cmd_scope with cmd.
(* END NOTATION MAGIC *)

(*|
Big-step operational semantics for commands
===========================================

Here is the definition of a big-step operational semantics for commands.  It is
very similar to what we've seen in class, but it also describes how `trace`
objects are accumulated as a program runs.  Note that IO events happen in
reverse chronological order: the most recent IO event appears at the *front* of
the list in the trace.

In the definition of `exec` below, the first three arguments are the trace,
heap, and valuation before execution, and the final three arguments are the
trace, heap, and valuation after execution.
|*)

(* Convenience notation: look up and default to 0 *)
Notation "m $! k" := (match m $? k with Some n => n | None => O end) (at level 30).

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
  | NatOp b e1 e2 =>
    let e1 := eval e1 h v in
    let e2 := eval e2 h v in
    match b with
    | Plus => e1 + e2
    | Minus => e1 - e2
    | Times => e1 * e2
    end
  end.

Fixpoint beval (b : bexp) (h : heap) (v : valuation) : bool :=
  match b with
  | BoolOp b e1 e2 =>
    let e1 := eval e1 h v in
    let e2 := eval e2 h v in
    match b with
    | Equal => if eval e1 h v ==n eval e2 h v then true else false
    | Less => if eval e2 h v <=? eval e1 h v then false else true
    end
  | Neg e => negb (beval e h v)
  end.

Inductive exec : trace -> heap -> valuation -> cmd ->
                 trace -> heap -> valuation -> Prop :=
| ExSkip : forall tr h v,
    exec tr h v Skip tr h v
| ExAssign : forall tr h v x e,
    exec tr h v (Assign x e) tr h (v $+ (x, eval e h v))
| ExWrite : forall tr h v e1 e2,
    exec tr h v (Write e1 e2) tr (h $+ (eval e1 h v, eval e2 h v)) v
| ExSeq : forall tr1 h1 v1 c1 tr2 h2 v2 c2 tr3 h3 v3,
    exec tr1 h1 v1 c1 tr2 h2 v2 ->
    exec tr2 h2 v2 c2 tr3 h3 v3 ->
    exec tr1 h1 v1 (Seq c1 c2) tr3 h3 v3
| ExIfTrue : forall tr1 h1 v1 b c1 c2 tr2 h2 v2,
    beval b h1 v1 = true ->
    exec tr1 h1 v1 c1 tr2 h2 v2 ->
    exec tr1 h1 v1 (If_ b c1 c2) tr2 h2 v2
| ExIfFalse : forall tr1 h1 v1 b c1 c2 tr2 h2 v2,
    beval b h1 v1 = false ->
    exec tr1 h1 v1 c2 tr2 h2 v2 ->
    exec tr1 h1 v1 (If_ b c1 c2) tr2 h2 v2
| ExWhileFalse : forall I tr h v b c,
    beval b h v = false ->
    exec tr h v (While_ I b c) tr h v
| ExWhileTrue : forall I tr1 h1 v1 b c tr2 h2 v2 tr3 h3 v3,
    beval b h1 v1 = true ->
    exec tr1 h1 v1 c tr2 h2 v2 ->
    exec tr2 h2 v2 (While_ I b c) tr3 h3 v3 ->
    exec tr1 h1 v1 (While_ I b c) tr3 h3 v3
| ExInput : forall tr h v x inp,
    exec tr h v (Input x) (In inp :: tr) h (v $+ (x, inp))
| ExOutput : forall tr h v e,
    exec tr h v (Output e) (Out (eval e h v) :: tr) h v.

(*|
Note an interesting property of `ExInput`: it's *nondeterministic*, as we
consider that any `Input` command could read any value.  Without that rule,
our semantics would remain deterministic.

Hoare logic
===========

Up to this point in the class, we've mostly proved properties directly using
operational semantics, but it turns out that using a program logic is usually
much more convenient.

The logic below derives triples of the form `<{ P }> c <{ Q }>`, where `P` and
`Q` have type `assertion` and `c` has type `cmd`. It is also very similar to
the Hoare logic we've defined in class.

For succinctness, we write pre- and postconditions with `fun/inv tr h v => …`,
as an alias for `fun (tr: trace) (h: heap) (v: valuation) => …`

Definition of the logic
-----------------------
|*)

(* Cool Coq trick: forward-declare a notation to use it in a definition. *)
Reserved Notation "<{ P }> c <{ Q }>"
         (at level 90, c at next level,
          format "'[hv' <{  P  }> '/'  c  '/' <{  Q  }> ']'").

Notation "'fun/inv' tr h v => e" :=
  (fun (tr : trace) (h : heap) (v : valuation) => e%nat%type)
    (at level 90, tr name, h name, v name).

Inductive hoare_triple : assertion -> cmd -> assertion -> Prop :=
| HtSkip : forall P, <{ P }> Skip <{ P }>
| HtAssign : forall P x e,
    <{ P }>
    Assign x e
    <{ fun/inv tr h v => exists v', P tr h v' /\ v = v' $+ (x, eval e h v') }>
| HtWrite : forall P (e1 e2 : exp),
    <{ P }>
    Write e1 e2
    <{ fun/inv tr h v =>
         exists h', P tr h' v /\ h = h' $+ (eval e1 h' v, eval e2 h' v) }>
| HtSeq : forall (P Q R : assertion) c1 c2,
    <{ P }> c1 <{ Q }> -> <{ Q }> c2 <{ R }> -> <{ P }> c1;; c2 <{ R }>
| HtIf : forall (P Q1 Q2 : assertion) b c1 c2,
    <{ fun/inv tr h v => P tr h v /\ beval b h v = true }> c1 <{ Q1 }> ->
    <{ fun/inv tr h v => P tr h v /\ beval b h v = false }> c2 <{ Q2 }> ->
    <{ P }> (when b then c1 else c2 done) <{ fun/inv tr h v => Q1 tr h v \/ Q2 tr h v }>
| HtWhile : forall (I P : assertion) b c,
    (forall tr h v, P tr h v -> I tr h v) ->
    <{ fun/inv tr h v => I tr h v /\ beval b h v = true }> c <{ I }> ->
    <{ P }>
    {{ I }} while b loop c done
    <{ fun/inv tr h v => I tr h v /\ beval b h v = false }>
| HtInput : forall (P : assertion) x,
    <{ P }>
    x <-- input
    <{ fun/inv tr h v =>
         exists tr' v' inp, P tr' h v' /\ tr = In inp :: tr' /\ v = v' $+ (x, inp) }>
| HtOutput : forall (P : assertion) e,
    <{ P }>
    output e
    <{ fun/inv tr h v => exists tr', P tr' h v /\ tr = Out (eval e h v) :: tr' }>
| HtConsequence : forall (P Q P' Q' : assertion) c,
    <{ P }> c <{ Q }> ->
    (forall tr h v, P' tr h v -> P tr h v) ->
    (forall tr h v, Q tr h v -> Q' tr h v) ->
    <{ P' }> c <{ Q' }>
where "<{ P }> c <{ Q }>" := (hoare_triple P c%cmd Q).

(*|
Consistency proof
-----------------

This logic is consistent with the semantics we've defined.  The consistency
theorem below will be needed to prove the correctness of our programs.
|*)

Lemma hoare_triple_big_step_while:
  forall I b c,
    (forall tr h v tr' h' v',
        exec tr h v c tr' h' v' ->
        I tr h v /\ beval b h v = true ->
        I tr' h' v') ->
    forall tr h v tr' h' v',
      exec tr h v (While_ I b c) tr' h' v' ->
      I tr h v ->
      I tr' h' v' /\ beval b h' v' = false.
Proof.
  induct 2; eauto.
Qed.

Theorem hoare_triple_big_step :
  forall pre c post,
    hoare_triple pre c post ->
    forall tr h v tr' h' v',
      exec tr h v c tr' h' v' ->
      pre tr h v -> post tr' h' v'.
Proof.
  induct 1; eauto.
  all: invert 1; simplify.
  all: eauto 6 using hoare_triple_big_step_while.
Qed.

(*|
Helper tactics
--------------

Phew, almost done with the setup!  The last step is to define some convenient
tactics for proving programs, which we'll demonstrate by example shortly.
That is, it's not important to understand these tactic definitions.
|*)

Lemma HtStrengthenPost :
  forall (P Q Q' : assertion) c,
    hoare_triple P c Q ->
    (forall tr h v, Q tr h v -> Q' tr h v) ->
    hoare_triple P c Q'.
Proof.
  simplify; eapply HtConsequence; eauto.
Qed.

Ltac cleanup :=
  lazymatch goal with
  | [  |- <{ _ }> _ <{ _ }> ] => fail "Can't clean up a Hoare triple"
  | _ => autounfold with core; cbv beta; first_order; subst; simplify
  end.

Ltac autosolve_t :=
  match goal with
  | [ _ : context[?a <=? ?b] |- _ ] => destruct (a <=? b); try discriminate
  | [ _ : context[?a ==n ?b] |- _ ] => destruct (a ==n b); try discriminate
  | [ H: _ <= 0 |- _ ] => apply Nat.le_0_r in H
  | [ H : ?E = ?E |- _ ] => clear H
  | [ H : ?E <= ?E |- _ ] => clear H
  | _ => progress subst
  end.

Ltac autosolve :=
  repeat autosolve_t; simplify; propositional; eauto 10; try equality; try linear_arithmetic.

Ltac ht1 :=
  lazymatch goal with
  | [  |- <{ _ }> _ <{ ?P }> ] =>
    tryif is_evar P then
      apply HtSkip || apply HtAssign || apply HtWrite || eapply HtSeq
      || eapply HtIf || eapply HtWhile
      || eapply HtInput || eapply HtOutput
    else eapply HtStrengthenPost
  | _ => fail "Goal is not a Hoare triple"
  end.

Ltac ht := simplify; repeat ht1; cleanup; autosolve.

(*|
Hoare-logic-based program proofs
================================

Now it's time to verify programs using the Hoare logic we've just defined!
Your task is to prove the theorems stated below using Hoare logic.  Do *not*
appeal directly to the operational semantics!  Using the Hoare logic is much
more automated and pleasant, and using completely manual derivations with
operational semantics would be particularly unpleasant (especially for the
last problem!).

Here is an example, to help you orient yourself:

First, a program:
|*)

Example add_two_inputs :=
  ("x" <-- input;;
   "y" <-- input;;
   output ("x" + "y"))%cmd.

(*|
Second, its specification and proof.  We'll demonstrate four versions:

- A proof ignoring the Hoare logic (but don't do this!)
- A proof using the Hoare logic by hand (usually not needed)
- A proof using the `ht1` automated tactic (great for debugging)
- A proof using the full `ht` automation (great after trying `ht1` for a bit).

The `ht` tactic is simple but powerful.  In particular, it runs `simplify`
and `eauto`, so you can add new rewritings to it using `Hint Rewrite …` and
new lemmas to it using `Hint Resolve …: core`.
|*)

Lemma add_two_inputs_ok0 :
  forall tr h v tr' h' v',
    exec tr h v add_two_inputs tr' h' v' ->
    tr = nil ->
    exists vx vy, tr' = [Out (vx + vy); In vy; In vx].
Proof.
  simplify.
  unfold add_two_inputs.
  invert H.
  invert H6.
  invert H10.
  invert H4.
  invert H8.
  simplify; subst; eauto.
Qed.

Lemma add_two_inputs_ok1:
  forall tr h v tr' h' v',
    exec tr h v add_two_inputs tr' h' v' ->
    tr = nil ->
    exists vx vy, tr' = [Out (vx + vy); In vy; In vx].
Proof.
  eapply hoare_triple_big_step
    with (pre := fun/inv tr _ _ => tr = nil)
         (post := fun/inv tr _ _ => exists vx vy, tr = [Out (vx + vy); In vy; In vx]).
  eapply HtSeq.
  eapply HtInput.
  eapply HtSeq.
  eapply HtInput.
  eapply HtStrengthenPost.
  eapply HtOutput.
  cleanup.
  autosolve.
Qed.

Lemma add_two_inputs_ok2:
  forall tr h v tr' h' v',
    exec tr h v add_two_inputs tr' h' v' ->
    tr = nil ->
    exists vx vy, tr' = [Out (vx + vy); In vy; In vx].
Proof.
  eapply hoare_triple_big_step.
  ht1.
  ht1.
  ht1.
  ht1.
  ht1.
  ht1.
  cleanup.
  autosolve.
Qed.

Lemma add_two_inputs_ok:
  forall tr h v tr' h' v',
    exec tr h v add_two_inputs tr' h' v' ->
    tr = nil ->
    exists vx vy, tr' = [Out (vx + vy); In vy; In vx].
Proof.
  eapply hoare_triple_big_step; ht.
Qed.

(*|
Notice how we started by applying `hoare_triple_big_step`.  In the following,
we'll give you goals phrased directly in terms of Hoare-logic triples.

Simple programs
===============

Your turn!  The following program finds the maximum of three numbers.  Try to
step through the execution with `ht1` before handing control to `ht`!.
|*)

Example max3 :=
  ("x" <-- input;;
   "y" <-- input;;
   "z" <-- input;;
   when "x" < "y" then
     when "y" < "z" then
       output "z"
     else
       output "y"
     done
   else
     when "x" < "z" then
       output "z"
     else
       output "x"
     done
   done)%cmd.

Definition max3_spec (tr: trace): Prop :=
  exists x y z,
    tr = [Out (max x (max y z)); In z; In y; In x].

Theorem max3_ok:
  <{ fun/inv tr _ _ => tr = [] }>
  max3
  <{ fun/inv tr' _ _ => max3_spec tr' }>.
Proof.
Admitted.

(*|
Euclidian Algorithm for GCD
---------------------------

Our first example with loops involves the classic Euclidean algorithm for
calculating the greatest common denominator of two natural numbers.

The definition below is parametric in an invariant ‘inv’ — the key part of
your job is to define an ‘inv’ that is correct and strong enough to make the
proof go through.

|*)

Example euclidean_algorithm a b inv :=
  ("a_orig" <- Const a;;
   "b_orig" <- Const b;;

   "a" <- "a_orig";;
   "b" <- "b_orig";;

   {{inv}}
   while !"a" = "b" loop
     when "a" < "b"
       then "b" <- "b" - "a"
       else "a" <- "a" - "b"
     done
   done;;
   output "a")%cmd.

Definition euclidean_algorithm_invariant (a b : nat) : assertion :=
   fun/inv _ _ _ => True.

Local Hint Unfold euclidean_algorithm_invariant : core.

(* HINT 1 (see Pset9Sig.v) *)
Theorem euclidean_algorithm_ok : forall a b,
    <{ fun/inv tr h v =>
         0 < a /\ 0 < b /\
       tr = [] }>
    euclidean_algorithm a b (euclidean_algorithm_invariant a b)
    <{ fun/inv tr h v =>
         v $! "a" = v $! "b"
         /\ exists d, tr = [Out d]/\ Nat.gcd a b = d }>.
Proof.
Admitted.

(*|
Streaming Fibonacci sequence
----------------------------

Let's tackle a program that makes nontrivial use of the trace. Our next
example with loops recycles our favorite example, an iterative computation of
the Fibonnaci sequence, but with a twist: it outputs all intermediate results.

Once again, the definition is parametric in an invariant ‘inv’ that is then
key for proving the final specification.
|*)

Example fibonacci n inv :=
  ("cnt" <- 0;;
   "x" <- 0;;
   output "x";;
   "y" <- 1;;
   output "y";;
   {{ inv }}
   while "cnt" < n loop
     "tmp" <- "y";;
     "y" <- "x" + "y";;
     "x" <- "tmp";;
     "cnt" <- "cnt" + 1;;
     output "y"
   done)%cmd.

Inductive fibonacci_spec : trace -> Prop :=
| FibInit: fibonacci_spec [Out 1; Out 0]
| FibRec: forall x y tr,
    fibonacci_spec (Out y :: Out x :: tr) ->
    fibonacci_spec (Out (x + y) :: Out y :: Out x :: tr).

(*|
Here's the definition of the loop invariant that you will have to modify to complete the proof:
|*)

(* HINT 2 (see Pset9Sig.v) *)
Definition fibonacci_invariant (n: nat) : assertion :=
   fun/inv _ _ _ => True.

Local Hint Unfold fibonacci_invariant : core.
Local Hint Constructors fibonacci_spec : core.

Theorem fibonacci_ok (n: nat):
  <{ fun/inv tr _ _ => tr = [] }>
  fibonacci n (fibonacci_invariant n)
  <{ fun/inv tr' _ _ => fibonacci_spec tr' }>.
Proof.
Admitted.

(*|
Streaming factorial
-------------------

The Fibonnaci example above cheats somewhat: the number of iteration of the
main loop, `n`, is a compile-time constant.  In the ‘fact’ example below,
which streams partial results of a factorial computation, "n" is a regular
variable taken by the program as input.  As before, the definition of ‘fact’
takes an arbitrary invariant, and the hardest part of your job is to find one
that makes the proof go through.
|*)

Example fact inv :=
  ("cnt" <- 0;;
   "x" <- 1;;
   output "x";;
   {{ inv }}
   while "cnt" < "n" loop
     "cnt" <- 1 + "cnt";;
     "x" <- "x" * "cnt";;
     output "x"
   done)%cmd.

Inductive fact_spec : nat -> trace -> Prop :=
| FactInit: fact_spec 0 [Out 1]
| FactRec: forall x n tr,
    fact_spec n (Out x :: tr) ->
    fact_spec (S n) (Out (x * S n) :: Out x :: tr).

Definition fact_invariant (n: nat) : assertion :=
   fun/inv _ _ _ => True.

Local Hint Unfold fact_invariant : core.
Local Hint Constructors fact_spec : core.

(* HINT 3 (see Pset9Sig.v) *)
Theorem fact_ok (n: nat):
  <{ fun/inv tr _ v => tr = [] /\ v $! "n" = n }>
  fact (fact_invariant n)
  <{ fun/inv tr' _ _ => fact_spec n tr' }>.
Proof.
Admitted.

Fixpoint fact_rec (n: nat) :=
  match n with
  | 0 => 1
  | S n => fact_rec n * S n
  end.

(* Sanity check: *)
Lemma fact_spec_fact_rec : forall n hd tl,
    fact_spec n (Out hd :: tl) -> fact_rec n = hd.
Proof.
  induct 1; simplify; equality.
Qed.

(*|
Heap-manipulating programs
==========================

Mailbox
-------

Let's spice things up a little by exploiting the heap, too.  The program
below implements a mailbox server: every time a client sends an address and a
value, the server stores the value and responds by outputting the previously
stored value.  The process stops as soon as a client tries to write to
address 0.
|*)

Example mailbox inv :=
  ("done" <- 0;;
   {{ inv }}
   while "done" = 0 loop
     "address" <-- input;;
     when "address" = 0 then
       "done" <- 1
     else
       "val" <-- input;;
       output *["address"];;
       *["address"] <- "val"
     done
   done)%cmd.

(*|
Take a moment to think about how you would specify this program before
reading the inductive spec below.
|*)

Inductive mailbox_spec : forall (h: heap) (tr: trace), Prop :=
| MBNil: mailbox_spec $0 []
| MBPut: forall h address val ret tr,
    address <> 0 ->
    ret = h $! address ->
    mailbox_spec h tr ->
    mailbox_spec (h $+ (address, val)) (Out ret :: In val :: In address :: tr).

Inductive mailbox_done (h: heap) : trace -> Prop :=
| MBDone: forall tr,
    mailbox_spec h tr ->
    mailbox_done h (In 0 :: tr).

(*|
Here is an example to help you understand how the spec works:
|*)

Goal mailbox_done
       ($0 $+ (5, 41)  (* From request 1 *)
           $+ (3, 11)  (* From request 2 *)
           $+ (5, 18)  (* From request 3 *)
           $+ (3, 39)) (* From request 4 *)
       [(* Final request: stop program by writing at 0 *)
        In 0;
        (* Fourth request: put 39 at address 3 (returns 11 from request 2) *)
        Out 11; In 39; In 3;
        (* Third request: put 18 at address 5 (returns 41 from request 1) *)
        Out 41; In 18; In 5;
        (* Second request: put 11 at address 3 (returns 0) *)
        Out 0; In 11; In 3;
        (* First request: put 41 at address 5 (returns 0) *)
        Out 0; In 41; In 5].
Proof.
  econstructor.
  econstructor; [ simplify; equality.. | ].
  econstructor; [ simplify; equality.. | ].
  econstructor; [ simplify; equality.. | ].
  econstructor; [ simplify; equality.. | ].
  econstructor.
Qed.

(*|
As always, the key part of the proof is the choice of invariant.
|*)

Definition mailbox_invariant : assertion :=
   fun/inv _ _ _ => True.

Local Hint Unfold mailbox_invariant : core.
Local Hint Constructors mailbox_spec mailbox_done : core.

(* HINT 4 (see Pset9Sig.v) *)
Theorem mailbox_ok:
  <{ fun/inv tr h _ => tr = [] /\ h = $0 }>
  mailbox mailbox_invariant
  <{ fun/inv tr' h' _ => mailbox_done h' tr' }>.
Proof.
Admitted.

(*|
Streaming search
----------------

Our final example is the trickiest.  It takes the address of an array (“ptr”)
and its length ("length") as local variables, then reads a value to search
for (“needle”) as input and outputs the indices of all positions in the
array at which the value is found.
|*)

Example search inv :=
  ("needle" <-- input;;
   {{ inv }}
   while 0 < "length" loop
     "length" <- "length" - 1;;
     when *["ptr" + "length"] = "needle" then
       output "length" done
   done)%cmd.

(*|
The specification of this program is a bit trickier. There are three cases:

- Searching an empty array doesn't produce output.
- Searching an array that ends with the right value produces one output and
  continues the search.
- Searching an array that ends with another value continues the search
  without producing output.

The key to understand the definition of this predicate is to remember that
the most recent output is at the front of the trace, and we're searching from
the end of the array.
|*)

Inductive search_spec (needle: nat) : forall (offset: nat) (haystack: list nat), trace -> Prop :=
| SearchNil: forall offset,
    search_spec needle offset [] [In needle]
| SearchConsYes: forall n offset haystack tr,
    0 < offset ->
    n = needle ->
    search_spec needle offset haystack tr ->
    search_spec needle (offset - 1) (n :: haystack) (Out (offset - 1) :: tr)
| SearchConsNo: forall n offset haystack tr,
    0 < offset ->
    n <> needle ->
    search_spec needle offset haystack tr ->
    search_spec needle (offset - 1) (n :: haystack) tr.

Inductive search_done haystack tr : Prop :=
| SearchDone: forall needle offset,
    offset = 0 ->
    search_spec needle offset haystack tr ->
    search_done haystack tr.

(*|
Here is an example to help you understand how the spec works:
|*)

Goal search_done [1; 82; 9; 3; 8; 82; 8] [Out 1; Out 5; In 82].
Proof.
  apply SearchDone with (offset := 0) (needle := 82); auto.
  change 0 with (7 - 1 - 1 - 1 - 1 - 1 - 1 - 1) at 2.
  constructor; [ linear_arithmetic | equality | ].
  constructor; [ linear_arithmetic | equality | ].
  constructor; [ linear_arithmetic | equality | ].
  constructor; [ linear_arithmetic | equality | ].
  constructor; [ linear_arithmetic | equality | ].
  constructor; [ linear_arithmetic | equality | ].
  constructor; [ linear_arithmetic | equality | ].
  constructor.
Qed.

(*|
The predicate `array_at h ptr data` asserts that the values in `data` are found in
the range [ptr; ptr + length [data]) in memory.
|*)

Inductive array_at (h: heap) : nat -> list nat -> Prop :=
| ArrayEmpty : forall ptr, array_at h ptr []
| ArrayCons : forall ptr hd tl,
    h $! ptr = hd ->
    array_at h (S ptr) tl ->
    array_at h ptr (hd :: tl).

(*|
Here's an example: the heap below contains the array [12; 8; 7] starting at
address 3: address 3 contains the value 12, address 4 contains 8, and address
5 contains 7.
|*)

Goal array_at
     ($0 $+ (3, 12) $+ (1, 6) $+ (4, 8) $+ (12, 9) $+ (5, 7))
     3
     [12; 8; 7].
Proof.
  econstructor.
  simplify; equality.
  econstructor.
  simplify; equality.
  econstructor.
  simplify; equality.
  econstructor.
Qed.

(*|
You'll need to customize this invariant:
|*)

Definition search_invariant (ptr: nat) (data: list nat) : assertion :=
   fun/inv _ _ _ => True.

Local Hint Unfold search_invariant : core.
Local Hint Constructors search_spec search_done : core.
Arguments List.nth: simpl nomatch.

(* HINT 5 (see Pset9Sig.v) *)
Theorem search_ok ptr data:
  <{ fun/inv tr h v =>
       tr = [] /\
       v $! "ptr" = ptr /\
       v $! "length" = Datatypes.length data /\
       array_at h ptr data }>
  search (search_invariant ptr data)
  <{ fun/inv tr' h' _ =>
       array_at h' ptr data /\
       search_done data tr' }>.
Proof.
Admitted.

(*|
Congratulations!  If you have extra time and you'd like to explore
opportunities for automation, here is a teaser: with appropriate hints added
to the `core` database (`Hint Resolve`, `Hint Extern` for things like linear arithmetic, and
`Hint Rewrite`), our proofs for all programs above are just `ht.`.
|*)

End Impl.

Module ImplCorrect : Pset9Sig.S := Impl.

(*|
Authors:

- Clément Pit-Claudel
- Joonwon Choi
- Amanda Liu
- Adam Chlipala
|*)


Require Import Iron.Data.List.Base.

Definition extends {A: Type} (xs: list A) (ys: list A)
 := exists zs, xs = zs >< ys.

Lemma extends_refl
 : forall {A: Type} (se: list A)
 , extends se se.
Proof.
 induction se; intros.
  unfold extends. exists (@nil A). eauto.
  unfold extends. exists (@nil A). eauto.
Qed.
Hint Resolve extends_refl.

Lemma extends_trans
 :  forall A (xx2 xx1 xx0: list A)
 ,  extends xx2 xx1
 -> extends xx1 xx0
 -> extends xx2 xx0.
Proof.
 intros.
 unfold extends in H.
 unfold extends in H0.
 destruct H as [zs1].
 destruct H0 as [zs0].
 unfold extends.
 rewrite H0 in H.
 exists (zs1 >< zs0).
 rewrite app_assoc. auto.
Qed.

Lemma extends_snoc
 : forall {A: Type} x (xx: list A)
 , extends (x <: xx) xx.
Proof.
 intros. unfold extends.
 exists (x :: nil).
 induction xx.
  simpl. auto.
  simpl. rewrite IHxx. auto.
Qed.
Hint Resolve extends_snoc.


Set Warnings "-notation-overridden,-parsing".
Require Export tactics.

Definition plus_fact : Prop := 2 + 2 = 14.
Check plus_fact.

(**Theorem plus_fact_is_true :
  plus_fact.
Proof. reflexivity. Qed.
reflexivity does not work**)

Definition is_three (n : nat) : Prop :=
  n = 3.
Check is_three.

Definition injective {A B :Type } (f : A -> B) :=
  forall x y : A, eq (f x) (f y) -> eq x y.
Check @injective.
Check eq.

Lemma and_intro : forall A B : Prop, A -> B -> A /\ B.
Proof.
intros. split. apply H. apply H0. Qed.

Example and_example' : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  apply and_intro.
  - (* 3 + 4 = 7 *) reflexivity.
  - (* 2 + 2 = 4 *) reflexivity.
Qed.

Example and_exercise :
  forall n m : nat, n + m = 0 -> n = 0 /\ m = 0.
Proof.
  destruct n.
  - intros m H. destruct m.
    + simpl in H. split. reflexivity. reflexivity.
    + simpl in H. split. reflexivity. inversion H.
 - intros m H. destruct m.
   + split. inversion H. reflexivity.
   + split. inversion H. inversion H.
Qed.

Lemma and_example2 :
  forall n m : nat, n = 0 /\ m = 0 -> n + m = 0.
Proof.
intros n m [HA HB].
rewrite HA. rewrite HB.
simpl. reflexivity.
Qed.

Lemma and_example3 :
  forall n m : nat, n + m = 0 -> n * m = 0.
Proof.
intros n m H.
assert (A : n = 0 /\ m = 0).
{ apply and_exercise. apply H. }
destruct A as [Ha Hb].
rewrite Ha. simpl. reflexivity.
Qed.

Lemma proj2 : forall P Q : Prop,
  P /\ Q -> Q.
Proof.
intros P Q [HP HQ].
apply HQ.
Qed.

Lemma and_commut : forall P Q : Prop,
  P /\ Q -> Q /\ P.
Proof.
intros P Q [HP HQ].
split.
apply HQ. apply HP.
Qed.

Theorem and_assoc : forall P Q R : Prop,
  P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros P Q R [HP [HQ HR]].
  split. split. apply HP. apply HQ. apply HR.
Qed.

Lemma or_example :
  forall n m : nat, n = 0 \/ m = 0 -> n * m = 0.
Proof.
intros n m.
intros [Hn | Hm].
- rewrite Hn. simpl. reflexivity.
- rewrite Hm. rewrite <- mult_n_O. reflexivity.
Qed.

Lemma or_intro : forall A B : Prop, A -> A \/ B.
Proof.
  intros A B HA.
  left.
  apply HA.
Qed.

Lemma zero_or_succ :
  forall n : nat, n = 0 \/ n = S (pred n).
Proof.
intros [| n].
- left. reflexivity.
- right. reflexivity.
Qed.

Module MyNot.
Definition not (P:Prop) := P -> False.
Notation "~ x" := (not x) : type_scope.
Check not.
(* ===> Prop -> Prop *)
End MyNot.
Check not.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  (* WORKED IN CLASS *)
  intros P xyz.
  destruct xyz. Qed.

Fact not_implies_our_not : forall (P:Prop),
  ~ P -> (forall (Q:Prop), P -> Q).
Proof.
intros P notP.
Admitted.

Theorem zero_not_one : ~(0 = 1).
Proof.
intros c. inversion c. Qed.
Theorem zero_not_one' : 0 <> 1.
Proof.
intros H. inversion H.
Qed.

Theorem not_False :
  ~ False.
Proof.
unfold not. intros H. apply H. Qed.

Theorem contradiction_implies_anything : forall P Q : Prop,
  (P /\ ~P) -> Q.
Proof.
intros P Q.
intros c.
destruct c.
unfold not in H0.
apply H0 in H.
destruct H. Qed.

Theorem double_neg : forall P : Prop,
  P -> ~~P.
Proof.
intros P.
intros C.
unfold not.
intros D. apply D. apply C. Qed.

Theorem contrapositive : forall (P Q : Prop),
  (P -> Q) -> (~Q -> ~P).
Proof.
unfold not.
intros P Q. intros PQ Qf p.
apply Qf. apply PQ. apply p.
Qed.

Theorem not_both_true_and_false : forall P : Prop,
  ~ (P /\ ~P).
Proof.
unfold not.
intros P.
intros [Hp Pf]. apply Pf. apply Hp.
Qed.

Theorem not_true_is_false : forall b : bool,
  b <> true -> b = false.
Proof.
intros b. intros H. unfold not in H.
destruct b.
- apply ex_falso_quodlibet. apply H. reflexivity.
- reflexivity.
Qed.

Lemma True_is_true : True.
Proof. apply I. Qed.

Module MyIff.
Definition iff (P Q : Prop) := (P -> Q) /\ (Q -> P).
Notation "P <-> Q" := (iff P Q)
                      (at level 95, no associativity)
                      : type_scope.
End MyIff.

Theorem iff_sym : forall P Q : Prop,
  (P <-> Q) -> (Q <-> P).
Proof.
intros P Q.
unfold iff.
intros [L R].
split.
apply R.
apply L.
Qed.

Lemma not_true_iff_false : forall b,
  b <> true <-> b = false.
Proof.
intros b.
unfold iff.
split.
apply not_true_is_false.
intros bf.
rewrite bf.
unfold not.
intros bf'. inversion bf'.
Qed.

Lemma or_commut : forall A B : Prop,
A \/ B -> B \/ A.
Proof.
intros A B.
intros [l | r].
right. apply l. left.  apply r.
Qed.

Theorem or_distributes_over_and : forall P Q R : Prop,
  P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
intros P Q R.
split.
- intros [l|r]. split. apply or_intro . apply l. apply or_intro.
apply l. split. right. apply r. right. apply r.
- intros [l r]. inversion l as [ p | q]. left. apply p.
  inversion r as [pp | rr]. left. apply pp. right.
  apply and_intro. apply q. apply rr.
Qed.

Lemma mult_0 : forall n m, n * m = 0 <-> n = 0 \/ m = 0.
Proof.
intros.
unfold iff.
split.
- intros.
destruct n in H.
+ destruct m.
  { simpl in H. right. apply H. }
  { left. inversion H.
Admitted.

Lemma or_assoc :
  forall P Q R : Prop, P \/ (Q \/ R) <-> (P \/ Q) \/ R.
Proof.
intros.
unfold iff.
split.
- intros. inversion H as [p | [q | r]]. left. left. apply p.
  left. right. apply q. right. apply r.
- intros. inversion H as [[p|q]|r]. left. apply p. right. left.
  apply q. right. right. apply r.
Qed.

Lemma mult_0_3 :
  forall n m p, n * m * p = 0 <-> n = 0 \/ m = 0 \/ p = 0.
Proof.
Admitted.

Lemma four_is_even : exists n : nat, 4 = n + n.
Proof.
  exists 2. reflexivity.
Qed.

Theorem exists_example_2 : forall n,
  (exists m, n = 4 + m) ->
  (exists o, n = 2 + o).
Proof.
  (* WORKED IN CLASS *)
  intros n [m Hm]. (* note implicit destruct here *)
  exists (2 + m).
  apply Hm. Qed.

Theorem dist_not_exists : forall (X:Type) (P : X -> Prop),
  (forall x, P x) -> ~ (exists x, ~ P x).
Proof.
intros.
unfold not. intros.
inversion H0.
apply H1.
apply H.
Qed.

Theorem dist_exists_or : forall (X:Type) (P Q : X -> Prop),
  (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
intros.
split.
- intros. destruct H. destruct H. left.
Admitted.

Fixpoint In {A : Type} (x : A) (l : list A) : Prop :=
  match l with
  | [] => False
  | x' :: l' => x' = x \/ In x l'
  end.

Example In_example_1 : In 4 [1; 2; 3; 4; 5].
Proof.
  (* WORKED IN CLASS *)
  simpl. right. right. right. left. reflexivity.
Qed.

Example In_example_2 :
  forall n, In n [2; 4] ->
  exists n', n = 2 * n'.
Proof.
  (* WORKED IN CLASS *)
  simpl.
  intros n [H | [H | []]].
  - exists 1. rewrite <- H. reflexivity.
  - exists 2. rewrite <- H. reflexivity.
Qed.

Lemma In_map :
  forall (A B : Type) (f : A -> B) (l : list A) (x : A),
    In x l ->
    In (f x) (map f l).
Proof.
  intros A B f l x.
  induction l as [|x' l' IHl'].
  - (* l = nil, contradiction *)
    simpl. intros. apply H.
  - (* l = x' :: l' *)
    simpl. intros [H | H].
    + rewrite H. left. reflexivity.
    + right. apply IHl'. apply H.
Qed.

Lemma In_map_iff :
  forall (A B : Type) (f : A -> B) (l : list A) (y : B),
    In y (map f l) <->
    exists x, f x = y /\ In x l.
Proof.
intros.
split.
- induction l as [ | h t IH]. intros.
simpl in H. simpl. inversion H. intros. simpl in H. inversion H.

Admitted.

Lemma In_app_iff : forall A l l' (a:A),
  In a (l++l') <-> In a l \/ In a l'.
Proof.
intros. split.
- intros. induction l.
  + simpl. simpl in H. right. apply H.
  + simpl. simpl in H. inversion H. left. left. apply H0.
    apply IHl in H0. inversion H0. left. right. apply H1.
    right. apply H1.
- intros. induction l.
  + simpl in H. simpl. inversion H.
  apply ex_falso_quodlibet. apply H0. apply H0.
  + simpl.
  simpl in H. apply or_assoc in H. inversion H. left.
  apply H0. apply IHl in H0.
  right. apply H0.
Qed.

Definition combine_odd_even (Podd Peven : nat -> Prop)
: nat -> Prop :=
fun n => if (evenb n) then Peven n else Podd n.

Theorem combine_odd_even_intro :
  forall (Podd Peven : nat -> Prop) (n : nat),
    (oddb n = true -> Podd n) ->
    (oddb n = false -> Peven n) ->
    combine_odd_even Podd Peven n.
Proof.
intros po pe n.
unfold oddb. intros h1 h2.
induction n.
- unfold combine_odd_even. apply h2. reflexivity.
- unfold combine_odd_even. destruct evenb.
 + apply h2. reflexivity.
 + apply h1. reflexivity.
Qed.

Lemma plus_comm3_take2 :
  forall x y z, x + (y + z) = (z + y) + x.
Proof.
  intros x y z.
  rewrite plus_comm.
  assert (H : y + z = z + y).
  { rewrite plus_comm. reflexivity. }
  rewrite H.
  reflexivity.
Qed.

Lemma plus_comm3_take3 :
  forall x y z, x + (y + z) = (z + y) + x.
Proof.
  intros x y z.
  rewrite plus_comm .
  rewrite (plus_comm z y).
  reflexivity.
Qed.

Example lemma_application_ex :
  forall {n : nat} {ns : list nat},
    In n (map (fun m => m * 0) ns) ->
    n = 0.
Proof.
intros n ns . intros.
Admitted.

Axiom functional_extensionality : forall {X Y: Type}
                                    {f g : X -> Y},
  (forall (x:X), f x = g x) -> f = g.

Theorem evenb_double_conv : forall n,
  exists k, n = if evenb n then double k
                else S (double k).
Proof.
Admitted.


Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Export Coq.Strings.String.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Lists.List.
Import ListNotations.

Definition beq_string x y :=
  if string_dec x y then true else false.

Theorem beq_string_refl : forall s, true = beq_string s s.
Proof.
intros. unfold beq_string.
destruct (string_dec s s).
- reflexivity.
- destruct n. reflexivity.
Qed.

Theorem beq_string_eql : forall s,
beq_string s s = true.
Proof.
intros. unfold beq_string.
destruct (string_dec s s).
- reflexivity.
- destruct n. reflexivity.
Qed.

Theorem beq_string_true_iff : forall x y : string,
  beq_string x y = true <-> x = y.
Proof.
intros.
unfold iff.
split.
- intros. unfold beq_string in H. destruct (string_dec x y) in H.
  + apply e.
  + inversion H.
- intros. rewrite H. symmetry. apply beq_string_refl.
Qed.

Theorem false_beq_string : forall x y : string,
   x <> y -> beq_string x y = false.
Proof.
Admitted.

Theorem beq_string_false_iff : forall x y : string,
  beq_string x y = false
  <-> x <> y.
Proof.
intros.
unfold iff.
split.
- intros.
unfold beq_string in H. destruct (string_dec x y).
 + inversion H.
 + apply n.
- apply false_beq_string.
Qed.

(** starting of total maps **)

Definition total_map (A:Type) := string -> A.
(** function that can be used to look up strings, yielding As.**)
Definition t_empty {A:Type} (v : A) : total_map A :=
  (fun _ => v).

Definition t_update {A:Type} (m : total_map A)
                    (x : string) (v : A) :=
  fun x' => if beq_string x x' then v else m x'.

Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true)
           "bar" true.

Notation "{ !-> d }" := (t_empty d) (at level 0).

Notation "m '&' { a !-> x }" :=
  (t_update m a x) (at level 20).
Notation "m '&' { a !-> x ; b !-> y }" :=
  (t_update (m & { a !-> x }) b y) (at level 20).
Notation "m '&' { a !-> x ; b !-> y ; c !-> z }" :=
  (t_update (m & { a !-> x ; b !-> y }) c z) (at level 20).
Notation "m '&' { a !-> x ; b !-> y ; c !-> z ; d !-> t }" :=
    (t_update (m & { a !-> x ; b !-> y ; c !-> z }) d t) (at level 20).
Notation "m '&' { a !-> x ; b !-> y ; c !-> z ; d !-> t ; e !-> u }" :=
    (t_update (m & { a !-> x ; b !-> y ; c !-> z ; d !-> t }) e u) (at level 20).
Notation "m '&' { a !-> x ; b !-> y ; c !-> z ; d !-> t ; e !-> u ; f !-> v }" :=
    (t_update (m & { a !-> x ; b !-> y ; c !-> z ; d !-> t ; e !-> u }) f v) (at level 20).

Definition examplemap' :=
  { !-> false } & { "foo" !-> true ; "bar" !-> true }.

Lemma t_apply_empty: forall
(A:Type) (x: string) (v: A), { !-> v } x = v.
Proof.
intros.
unfold t_empty.
reflexivity.
Qed.

Lemma t_update_eq : forall A (m: total_map A) x v,
  (m & {x !-> v}) x = v.
Proof.
intros.
unfold t_update.
replace (beq_string x x) with true.
- reflexivity.
- rewrite beq_string_eql. reflexivity.
Qed.

Theorem t_update_neq : forall (X:Type) v x1 x2
                         (m : total_map X),
  x1 <> x2 ->
  (m & {x1 !-> v}) x2 = m x2.
Proof.
intros.
unfold t_update.
replace (beq_string x1 x2) with false.
- reflexivity.
- rewrite false_beq_string.
  reflexivity. apply H.
Qed.

(** Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x,
    t_update (t_update m x v1) x v2
  = t_update m x v2.
Proof.
  intros A m v1 v2 x.
  unfold t_update.
  extensionality x'.
  remember (beq_string x x') as e; induction e.
  trivial. trivial. **)

Lemma t_update_shadow' : forall A (m: total_map A) v1 v2 x,
    m & {x !-> v1 ; x !-> v2} = m & {x !-> v2}.
Proof.
intros.
unfold t_update.
extensionality x'.
induction (beq_string x x').
- reflexivity.
- reflexivity.
Qed.

Lemma beq_stringP : forall x y,
reflect (x = y) (beq_string x y).
Proof.
Admitted.

Lemma beq_equal : forall x x',
 beq_string x x' = true -> x = x'.
Proof.
Admitted.

Theorem t_update_same : forall X x (m : total_map X),
    m & { x !-> m x } = m.
Proof.
intros.
unfold t_update.
extensionality x'.
remember (beq_string x x') as h.
induction h.
- symmetry in Heqh. apply beq_equal in Heqh.
rewrite Heqh. reflexivity.
- trivial.
Qed.

Theorem t_update_permute : forall (X:Type) v1 v2 x1 x2
                             (m : total_map X),
  x2 <> x1 ->
  m & { x2 !-> v2 ; x1 !-> v1 }
  = m & { x1 !-> v1 ; x2 !-> v2 }.
Proof.
intros.
unfold t_update.
extensionality x'.
remember (beq_string x1 x') as h1.
induction h1.
- symmetry in Heqh1. apply beq_equal in Heqh1.
symmetry in Heqh1. rewrite Heqh1.
remember (beq_string x2 x1) as h2.
 apply false_beq_string in H.
symmetry in Heqh2. rewrite H in Heqh2.
symmetry in Heqh2.
rewrite Heqh2 . trivial.
- trivial.
Qed.

Definition partial_map (A:Type) := total_map (option A).
Definition empty {A:Type} : partial_map A :=
  t_empty None.

Definition update {A:Type} (m : partial_map A)
           (x : string) (v : A) :=
  m & { x !-> (Some v) }.

Notation "m '&' {{ a !-> x }}" :=
  (update m a x) (at level 20).
Notation "m '&' {{ a !-> x ; b !-> y }}" :=
  (update (m & {{ a !-> x }}) b y) (at level 20).
Notation "m '&' {{ a !-> x ; b !-> y ; c !-> z }}" :=
  (update (m & {{ a !-> x ; b !-> y }}) c z) (at level 20).
Notation "m '&' {{ a !-> x ; b !-> y ; c !-> z ; d !-> t }}" :=
    (update (m & {{ a !-> x ; b !-> y ; c !-> z }}) d t) (at level 20).
Notation "m '&' {{ a !-> x ; b !-> y ; c !-> z ; d !-> t ; e !-> u }}" :=
    (update (m & {{ a !-> x ; b !-> y ; c !-> z ; d !-> t }}) e u) (at level 20).
Notation "m '&' {{ a !-> x ; b !-> y ; c !-> z ; d !-> t ; e !-> u ; f !-> v }}" :=
    (update (m & {{ a !-> x ; b !-> y ; c !-> z ; d !-> t ; e !-> u }}) f v) (at level 20).

Lemma apply_empty : forall (A: Type) (x: string),
 @empty A x = None.
Proof.
intros.
unfold empty. rewrite t_apply_empty.
trivial. Qed.

Lemma update_eq : forall A (m: partial_map A) x v,
    (m & {{ x !-> v }}) x = Some v.
Proof.
intros.
unfold update. apply t_update_eq. Qed.

Theorem update_neq : forall (X:Type) v x1 x2
                       (m : partial_map X),
  x2 <> x1 ->
  (m & {{ x2 !-> v }}) x1 = m x1.
Proof.
intros.
unfold update. apply t_update_neq. apply H. Qed.


(* Boring stuff, including but not limited to list lemmas *)
Require Import Arith List Omega StructTact.StructTactics.
Require Import oeuf.StuartTact.
Require Import ZArith.
Import ListNotations.
Require Import Psatz.
Require Import StructTact.Assoc.

Require Import oeuf.Monads.
Require Import oeuf.Forall3.

Require Import compcert.lib.Coqlib.
Local Close Scope Z_scope.

(* nat <= *)

Lemma nat_max_le : forall n1 n2 m,
    max n1 n2 <= m ->
    n1 <= m /\ n2 <= m.
intros0 Hle. destruct (Max.max_spec n1 n2) as [[? ?] | [? ?]]; split; omega.
Qed.

Lemma nat_max_le1 : forall n1 n2 m, max n1 n2 <= m -> n1 <= m.
intros. destruct (nat_max_le ?? ?? ?? **). assumption.
Qed.

Lemma nat_max_le2 : forall n1 n2 m, max n1 n2 <= m -> n2 <= m.
intros. destruct (nat_max_le ?? ?? ?? **). assumption.
Qed.

Lemma nat_le_max : forall n1 n2 m,
    n1 <= m ->
    n2 <= m ->
    max n1 n2 <= m.
intros0 Hle1 Hle2. destruct (Max.max_spec n1 n2) as [[? ?] | [? ?]]; omega.
Qed.

Lemma nat_max_lt : forall n1 n2 m,
    max n1 n2 < m ->
    n1 < m /\ n2 < m.
intros0 Hlt. destruct (Max.max_spec n1 n2) as [[? ?] | [? ?]]; split; omega.
Qed.

Lemma nat_max_lt1 : forall n1 n2 m, max n1 n2 < m -> n1 < m.
intros. destruct (nat_max_lt ?? ?? ?? **). assumption.
Qed.

Lemma nat_max_lt2 : forall n1 n2 m, max n1 n2 < m -> n2 < m.
intros. destruct (nat_max_lt ?? ?? ?? **). assumption.
Qed.

Lemma nat_lt_max : forall n1 n2 m,
    n1 < m ->
    n2 < m ->
    max n1 n2 < m.
intros0 Hlt1 Hlt2. destruct (Max.max_spec n1 n2) as [[? ?] | [? ?]]; omega.
Qed.

(* maximum *)

Fixpoint maximum ns :=
    match ns with
    | [] => 0
    | n :: ns => max n (maximum ns)
    end.

Lemma maximum_le_Forall_fwd : forall ns m,
    maximum ns <= m ->
    Forall (fun n => n <= m) ns.
induction ns; intros; simpl in *; eauto using nat_max_le1, nat_max_le2.
Qed.

Lemma maximum_le_Forall_rev : forall ns m,
    Forall (fun n => n <= m) ns ->
    maximum ns <= m.
induction ns; inversion 1; [simpl; omega | eauto using nat_le_max].
Qed.

Lemma maximum_le_Forall : forall ns m,
    maximum ns <= m <-> Forall (fun n => n <= m) ns.
intros; split; eauto using maximum_le_Forall_fwd, maximum_le_Forall_rev.
Qed.

Lemma maximum_app : forall xs ys,
    maximum (xs ++ ys) = max (maximum xs) (maximum ys).
induction xs; destruct ys; simpl; try reflexivity.
- rewrite app_nil_r. lia.
- rewrite IHxs. simpl. lia.
Qed.

(* map_partial *)

Fixpoint map_partial {A B : Type} (f : A -> option B) (l : list A) : option (list B) :=
  match l with
  | [] => Some []
  | a :: l' => match f a, map_partial f l' with
              | Some b, Some l'' => Some (b :: l'')
              | _, _ => None
              end
  end.

Lemma map_partial_Forall_exists : forall A B (f : A -> option B) xs,
    Forall (fun x => exists y, f x = Some y) xs ->
    exists ys, map_partial f xs = Some ys.
induction xs; intros0 Hfa; invc Hfa.
- eexists. reflexivity.
- specialize (IHxs **). do 2 break_exists.
  eexists. simpl. repeat find_rewrite. reflexivity.
Qed.

Lemma Forall_map_partial_exists : forall A B (f : A -> option B) xs ys,
    map_partial f xs = Some ys ->
    Forall (fun x => exists y, f x = Some y) xs.
induction xs; intros0 Hmp; simpl in *; invc Hmp.
- constructor.
- repeat (break_match; try discriminate). inject_some.
  constructor; eauto.
Qed.

Lemma map_partial_Forall2 : forall A B (f : A -> option B) xs ys,
    map_partial f xs = Some ys ->
    Forall2 (fun x y => f x = Some y) xs ys.
induction xs; intros0 Hmap; destruct ys; simpl in *; repeat break_match; try congruence.
- constructor.
- inject_some. specialize (IHxs _ ***). constructor; eauto.
Qed.

Lemma Forall2_map_partial : forall A B (f : A -> option B) xs ys,
    Forall2 (fun x y => f x = Some y) xs ys ->
    map_partial f xs = Some ys.
induction xs; inversion 1; subst; simpl in *.
- reflexivity.
- find_rewrite. erewrite IHxs by eauto. reflexivity.
Qed.

Lemma map_partial_cons : forall A B (f : A -> option B) x xs y ys,
    f x = Some y ->
    map_partial f xs = Some ys ->
    map_partial f (x :: xs) = Some (y :: ys).
intros0 Hx Hxs. simpl. repeat find_rewrite. reflexivity.
Qed.

Lemma map_partial_app : forall A B (f : A -> option B) xs1 xs2 ys1 ys2,
    map_partial f xs1 = Some ys1 ->
    map_partial f xs2 = Some ys2 ->
    map_partial f (xs1 ++ xs2) = Some (ys1 ++ ys2).
induction xs1; destruct ys1; intros0 Hxs1 Hxs2; simpl in * |-;
repeat (break_match; try discriminate); try discriminate.
- eauto.
- inject_some. specialize (IHxs1 xs2 ?? ?? *** **).
  repeat rewrite <- app_comm_cons in *. repeat find_rewrite.
  eapply map_partial_cons; eassumption.
Qed.

Lemma map_partial_cons_inv : forall A B (f : A -> option B) x1 xs2 ys
        (P : _ -> _ -> _ -> Prop),
    (forall y1 ys2,
        f x1 = Some y1 ->
        map_partial f xs2 = Some ys2 ->
        ys = y1 :: ys2 ->
        P x1 xs2 ys) ->
    map_partial f (x1 :: xs2) = Some ys -> P x1 xs2 ys.
intros0 HQ Hmap.
simpl in Hmap. repeat (break_match; try discriminate).
inject_some. eauto.
Qed.

Lemma map_partial_app_inv : forall A B (f : A -> option B) xs1 xs2 ys
        (P : _ -> _ -> _ -> Prop),
    (forall ys1 ys2,
        map_partial f xs1 = Some ys1 ->
        map_partial f xs2 = Some ys2 ->
        ys = ys1 ++ ys2 ->
        P xs1 xs2 ys) ->
    map_partial f (xs1 ++ xs2) = Some ys -> P xs1 xs2 ys.
induction xs1; intros0 HQ Hmap; simpl in Hmap.
- simpl in HQ. eauto.
- repeat (break_match; try congruence). inject_some.
  inversion Heqo0 using (IHxs1 xs2 l).
  intros. subst. eapply HQ.
  + simpl. repeat find_rewrite. reflexivity.
  + eassumption.
  + reflexivity.
Qed.

Lemma map_partial_3part_inv : forall A B (f : A -> option B) xs1 x2 xs3 ys
        (P : _ -> _ -> _ -> _ -> Prop),
    (forall ys1 y2 ys3,
        map_partial f xs1 = Some ys1 ->
        f x2 = Some y2 ->
        map_partial f xs3 = Some ys3 ->
        ys = ys1 ++ y2 :: ys3 ->
        P xs1 x2 xs3 ys) ->
    map_partial f (xs1 ++ x2 :: xs3) = Some ys -> P xs1 x2 xs3 ys.
intros0 HQ Hmap.
on _, invc_using map_partial_app_inv.
on _, invc_using map_partial_cons_inv.
eauto.
Qed.

Lemma map_partial_length : forall A B (f : A -> option B) xs ys,
    map_partial f xs = Some ys ->
    length xs = length ys.
intros0 Hmap. eapply map_partial_Forall2 in Hmap. eauto using Forall2_length.
Qed.

(* Forall / Forall2 *)

(* This formulation is suitable for use by auto *)
Lemma Forall_forall_intro :
  forall A (P : A -> Prop) l,
    (forall x, In x l -> P x) ->
    List.Forall P l.
Proof. intros. now rewrite Forall_forall. Qed.

Lemma Forall_map : forall A B (P : B -> Prop) (f : A -> B) xs,
    Forall (fun x => P (f x)) xs <-> Forall P (map f xs).
induction xs; intros; split; inversion 1; subst; simpl in *; eauto.
- constructor; eauto. rewrite <- IHxs. assumption.
- constructor; eauto. rewrite -> IHxs. assumption.
Qed.

(* This formulation is suitable for use by auto *)
Lemma Forall_map_intro : forall A B (P : B -> Prop) (f : A -> B) xs,
    Forall (fun x => P (f x)) xs -> Forall P (map f xs).
Proof. intros. now rewrite <- Forall_map. Qed.

Lemma Forall2_map : forall A A' B B' (P : A' -> B' -> Prop) (fx : A -> A') (fy : B -> B') xs ys,
    Forall2 (fun x y => P (fx x) (fy y)) xs ys <-> Forall2 P (map fx xs) (map fy ys).
induction xs; destruct ys; intros; split; inversion 1; subst; simpl in *; eauto.
- constructor; eauto. rewrite <- IHxs. assumption.
- constructor; eauto. rewrite -> IHxs. assumption.
Qed.

Lemma Forall2_map_l : forall A A' B (P : A' -> B -> Prop) (fx : A -> A') xs ys,
    Forall2 (fun x y => P (fx x) y) xs ys <-> Forall2 P (map fx xs) ys.
intros. rewrite <- map_id with (l := ys) at 2. eapply Forall2_map.
Qed.

Lemma Forall2_map_r : forall A B B' (P : A -> B' -> Prop) (fy : B -> B') xs ys,
    Forall2 (fun x y => P x (fy y)) xs ys <-> Forall2 P xs (map fy ys).
intros. rewrite <- map_id with (l := xs) at 2. eapply Forall2_map.
Qed.

Lemma Forall2_map_eq : forall A B R (fx : A -> R) (fy : B -> R) xs ys,
    Forall2 (fun x y => fx x = fy y) xs ys ->
    map fx xs = map fy ys.
induction xs; destruct ys; intros0 Hfa; invc Hfa; eauto.
simpl. specialize (IHxs ?? **). repeat find_rewrite. reflexivity.
Qed.

Lemma map_Forall2 : forall A B (f : A -> B) xs ys,
    map f xs = ys ->
    Forall2 (fun x y => f x = y) xs ys.
induction xs; intros0 Hmap; destruct ys; try discriminate; eauto.
simpl in *. invc Hmap. eauto.
Qed.

Lemma Forall2_rev : forall A B P (xs : list A) (ys : list B),
    Forall2 P xs ys ->
    Forall2 P (rev xs) (rev ys).
induction xs; intros0 Hfa; invc Hfa.
- simpl. constructor.
- change (a :: xs) with ([a] ++ xs).
  change (y :: l') with ([y] ++ l').
  do 2 rewrite rev_app_distr.
  eapply Forall2_app; eauto.
  simpl. eauto.
Qed.

Lemma Forall2_Forall_exists : forall A B (P : A -> B -> Prop) xs ys,
    Forall2 P xs ys ->
    Forall (fun x => exists y, P x y) xs.
induction xs; destruct ys; intros0 Hfa; invc Hfa; eauto.
Qed.

Lemma Forall2_same : forall A (P : A -> A -> Prop) xs,
    Forall2 P xs xs <-> Forall (fun x => P x x) xs.
induction xs; split; intro; try on _, invc; firstorder eauto.
Qed.

Lemma Forall_app_inv : forall A (P : A -> Prop) xs1 xs2
        (Q : _ -> _ -> _ -> _ -> Prop),
    (Forall P xs1 -> Forall P xs2 -> Q A P xs1 xs2) ->
    Forall P (xs1 ++ xs2) -> Q A P xs1 xs2.
induction xs1; intros0 HQ Hfa.
- eauto.
- rewrite <- app_comm_cons in *. invc Hfa.
  on _, invc_using IHxs1. eauto.
Qed.

Lemma Forall_3part_inv : forall A (P : A -> Prop) xs1 x2 xs3
        (Q : _ -> _ -> _ -> _ -> _ -> Prop),
    (Forall P xs1 -> P x2 -> Forall P xs3 -> Q A P xs1 x2 xs3) ->
    Forall P (xs1 ++ x2 :: xs3) -> Q A P xs1 x2 xs3.
intros0 HQ Hfa.
inversion Hfa using Forall_app_inv; intros.
on (Forall _ (_ :: _)), invc.
eauto.
Qed.

Lemma Forall2_app_inv : forall A B (P : A -> B -> Prop) xs1 xs2 ys
        (Q : _ -> _ -> _ -> Prop),
    (forall ys1 ys2,
        Forall2 P xs1 ys1 ->
        Forall2 P xs2 ys2 ->
        ys = ys1 ++ ys2 ->
        Q xs1 xs2 ys) ->
    Forall2 P (xs1 ++ xs2) ys -> Q xs1 xs2 ys.
induction xs1; intros0 HQ Hfa.
- eauto.
- rewrite <- app_comm_cons in *. invc Hfa.
  on _, invc_using IHxs1. eauto.
Qed.

Lemma Forall2_3part_inv : forall A B (P : A -> B -> Prop) xs1 x2 xs3 ys
        (Q : _ -> _ -> _ -> _ -> Prop),
    (forall ys1 y2 ys3,
        Forall2 P xs1 ys1 ->
        P x2 y2 ->
        Forall2 P xs3 ys3 ->
        ys = ys1 ++ y2 :: ys3 ->
        Q xs1 x2 xs3 ys) ->
    Forall2 P (xs1 ++ x2 :: xs3) ys -> Q xs1 x2 xs3 ys.
intros0 HQ Hmap.
on _, invc_using Forall2_app_inv.
on _, invc.
eauto.
Qed.

Lemma Forall_app : forall A (P : A -> Prop) xs ys,
    Forall P xs ->
    Forall P ys ->
    Forall P (xs ++ ys).
induction xs; intros0 Hx Hy; simpl.
- assumption.
- invc Hx. constructor; eauto.
Qed.

Lemma Forall2_nth_error_ex : forall A B (P : A -> B -> Prop) xs ys i x,
    Forall2 P xs ys ->
    nth_error xs i = Some x ->
    exists y,
        nth_error ys i = Some y /\
        P x y.
intros0 Hfa Hnth.
fwd eapply length_nth_error_Some with (xs := xs) (ys := ys); eauto using Forall2_length.
break_exists.
eexists. split; eauto.
eapply Forall2_nth_error; eauto.
Qed.

Lemma Forall2_swap : forall A B (P : A -> B -> Prop) xs ys,
    Forall2 P xs ys ->
    Forall2 (fun y x => P x y) ys xs.
induction xs; destruct ys; intros0 Hfa; invc Hfa; simpl in *; eauto.
Qed.

Lemma Forall2_nth_error_ex' : forall A B (P : A -> B -> Prop) xs ys i y,
    Forall2 P xs ys ->
    nth_error ys i = Some y ->
    exists x,
        nth_error xs i = Some x /\
        P x y.
intros0 Hfa Hnth.
eapply Forall2_swap in Hfa.
fwd eapply Forall2_nth_error_ex; eauto.
Qed.

Lemma Forall2_imp : forall {A B} (P Q : A -> B -> Prop) xs ys,
    Forall2 P xs ys ->
    (forall x y, P x y -> Q x y) ->
    Forall2 Q xs ys.
induction xs; destruct ys; intros0 Hfa Himp; invc Hfa; econstructor; eauto.
Qed.

Lemma Forall2_conj : forall {A B} (P Q : A -> B -> Prop) xs ys,
    Forall2 P xs ys ->
    Forall2 Q xs ys ->
    Forall2 (fun x y => P x y /\ Q x y) xs ys.
induction xs; destruct ys; intros0 Hfa1 Hfa2; invc Hfa1; invc Hfa2; econstructor; eauto.
Qed.

Lemma Forall2_conj_inv : forall A B (P Q : A -> B -> Prop) xs ys (M : Prop),
    (Forall2 P xs ys ->
        Forall2 Q xs ys ->
        M) ->
    Forall2 (fun x y => P x y /\ Q x y) xs ys -> M.
intros0 HM Hfa.
eapply HM; eapply Forall2_imp with (1 := Hfa); intros; firstorder.
Qed.

(* misc *)

Lemma map_id : forall A (xs : list A), map id xs = xs.
induction xs; unfold id in *; simpl; congruence.
Qed.

Lemma skipn_more : forall A i (xs : list A) y ys,
    skipn i xs = y :: ys ->
    skipn (S i) xs = ys.
induction i; intros; simpl in *; subst.
- reflexivity.
- destruct xs; try discriminate. eapply IHi; eauto.
Qed.

(* unsorted *)

Lemma firstn_all : forall A n xs,
    n = length xs ->
    @firstn A n xs = xs.
induction n; simpl; intros0 Hn.
- destruct xs; simpl in *; congruence.
- destruct xs; simpl in *; try discriminate Hn.
  rewrite IHn; eauto.
Qed.

Lemma firstn_all' : forall A n xs,
    n >= length xs ->
    @firstn A n xs = xs.
induction n; simpl; intros0 Hn; destruct xs; simpl in *; try reflexivity.
- lia.
- f_equal. eapply IHn. lia.
Qed.

Lemma skipn_nth_error : forall A i j (xs : list A),
    nth_error (skipn i xs) j = nth_error xs (i + j).
first_induction xs; first_induction i; simpl; intros; eauto.
destruct j; simpl; reflexivity.
Qed.

Lemma skipn_nth_error_change' : forall A i j (xs ys : list A),
    skipn i xs = skipn i ys ->
    j >= 0 ->
    nth_error xs (i + j) = nth_error ys (i + j).
intros0 Hskip Hj.
rewrite <- skipn_nth_error, <- skipn_nth_error. congruence.
Qed.

Lemma skipn_nth_error_change : forall A i j (xs ys : list A),
    skipn i xs = skipn i ys ->
    j >= i ->
    nth_error xs j = nth_error ys j.
intros0 Hskip Hj.
set (k := j - i).
replace j with (i + k) by (unfold k; lia).
eapply skipn_nth_error_change'.
- assumption.
- lia.
Qed.

Lemma firstn_nth_error_lt : forall A (xs : list A) n i,
    i < n ->
    nth_error (firstn n xs) i = nth_error xs i.
first_induction n; intros0 Hlt.
{ lia. }

destruct xs, i; simpl.
- reflexivity.
- reflexivity.
- reflexivity.
- eapply IHn. lia.
Qed.

Lemma firstn_nth_error_ge : forall A (xs : list A) n i,
    i >= n ->
    nth_error (firstn n xs) i = None.
first_induction n; intros0 Hlt.

- simpl. destruct i; reflexivity.
- destruct xs, i; simpl; try reflexivity.
  + lia.
  + eapply IHn. lia.
Qed.

Lemma app_inv_length : forall A (xs ys zs : list A),
    xs = ys ++ zs ->
    firstn (length ys) xs = ys /\
    skipn (length ys) xs = zs.
first_induction ys; intros0 Heq; destruct xs; try discriminate; simpl in *.
- eauto.
- eauto.
- specialize (IHys xs zs ltac:(congruence)). break_and.
  split; congruence.
Qed.

Lemma nth_error_length_le : forall A (xs : list A) n,
    (forall i, i >= n -> nth_error xs i = None) ->
    length xs <= n.
first_induction n; intros0 Hge.
- destruct xs.
  + simpl. lia.
  + specialize (Hge 0 ltac:(lia)). discriminate.
- destruct xs.
  + simpl. lia.
  + simpl. cut (length xs <= n). { intros. lia. }
    eapply IHn. intros. specialize (Hge (S i) ltac:(lia)). simpl in *. assumption.
Qed.

Lemma nth_error_firstn : forall A (xs ys : list A) n,
    (forall i, i < n -> nth_error ys i = nth_error xs i) ->
    (forall i, i >= n -> nth_error ys i = None) ->
    ys = firstn n xs.
induction xs; intros0 Hlt Hge.
- replace (firstn n []) with (@nil A) by (destruct n; reflexivity).
  destruct ys.
    { reflexivity. }
  destruct (eq_nat_dec n 0).
  + specialize (Hge 0 ltac:(lia)). discriminate.
  + specialize (Hlt 0 ltac:(lia)). discriminate.
- destruct ys.
  + destruct n.
      { reflexivity. }
    specialize (Hlt 0 ltac:(lia)). discriminate.
  + destruct n.
      { specialize (Hge 0 ltac:(lia)). discriminate. }
    simpl.
    rewrite <- (IHxs ys).
    * specialize (Hlt 0 ltac:(lia)). simpl in Hlt. inject_some. reflexivity.
    * intros. specialize (Hlt (S i) ltac:(lia)). assumption.
    * intros. specialize (Hge (S i) ltac:(lia)). assumption.
Qed.

Lemma firstn_app : forall A (xs ys : list A) n,
    n <= length xs ->
    firstn n (xs ++ ys) = firstn n xs.
induction xs; intros0 Hle.
- simpl in *. destruct n; try lia. simpl. reflexivity.
- destruct n; simpl in *.
    { reflexivity. }
  f_equal. eapply IHxs. lia.
Qed.

Lemma skipn_app : forall A (xs ys : list A) n,
    n >= length xs ->
    skipn n (xs ++ ys) = skipn (n - length xs) ys.
induction xs; intros0 Hge.
- simpl. replace (n - 0) with n by lia. reflexivity.
- destruct n; simpl in *.
    { lia. }
  eapply IHxs. lia.
Qed.

Lemma skipn_add : forall A (xs : list A) n m,
    skipn n (skipn m xs) = skipn (n + m) xs.
first_induction m; intros.
- simpl. replace (n + 0) with n by lia. reflexivity.
- replace (n + S m) with (S (n + m)) by lia. destruct xs; simpl.
  + destruct n; simpl; reflexivity.
  + eapply IHm.
Qed.

Lemma Forall_firstn : forall A P (xs : list A) n,
    Forall P xs ->
    Forall P (firstn n xs).
induction xs; intros0 Hfa.
- destruct n; constructor.
- destruct n; simpl.
  + constructor.
  + invc Hfa. constructor; eauto.
Qed.

Lemma Forall_skipn : forall A P (xs : list A) n,
    Forall P xs ->
    Forall P (skipn n xs).
induction xs; intros0 Hfa.
- destruct n; constructor.
- destruct n; simpl.
  + assumption.
  + invc Hfa. eauto.
Qed.

Lemma Forall2_firstn : forall A B P (xs : list A) (ys : list B) n,
    Forall2 P xs ys ->
    Forall2 P (firstn n xs) (firstn n ys).
induction xs; destruct ys; intros0 Hfa; invc Hfa;
destruct n; constructor; eauto.
Qed.

Lemma Forall2_skipn : forall A B P (xs : list A) (ys : list B) n,
    Forall2 P xs ys ->
    Forall2 P (skipn n xs) (skipn n ys).
induction xs; destruct ys; intros0 Hfa; invc Hfa.
- destruct n; constructor.
- destruct n; simpl.
  + constructor; eauto.
  + eauto.
Qed.

Lemma map_nth_error' : forall A B (f : A -> B) xs n x,
    nth_error (map f xs) n = Some x ->
    exists y,
        nth_error xs n = Some y /\
        x = f y.
induction xs; intros0 Hnth; simpl in *.
- destruct n; discriminate Hnth.
- destruct n; simpl in *.
  + inject_some. eauto.
  + eapply IHxs; eauto.
Qed.

Lemma nth_error_split' : forall A i (xs : list A) x,
    nth_error xs i = Some x ->
    xs = firstn i xs ++ [x] ++ skipn (S i) xs.
induction i; intros0 Hnth; simpl in *.
- break_match; try discriminate. congruence.
- break_match; try discriminate. simpl.
  erewrite <- IHi; eauto.
Qed.

Definition slice {A} (n m : nat) (xs : list A) :=
    firstn (m - n) (skipn n xs).

Lemma firstn_slice : forall A (xs : list A) n,
    firstn n xs = slice 0 n xs.
intros. unfold slice. simpl. f_equal. lia.
Qed.

Lemma skipn_length : forall A (xs : list A) n,
    length (skipn n xs) = length xs - n.
first_induction n; intros; simpl.
- lia.
- destruct xs.
  + simpl. lia.
  + simpl. rewrite IHn. reflexivity.
Qed.

Lemma skipn_slice : forall A (xs : list A) n,
    skipn n xs = slice n (length xs) xs.
intros. unfold slice. rewrite firstn_all; eauto.
rewrite skipn_length. reflexivity.
Qed.

Lemma slice_length : forall A (xs : list A) n m,
    m <= length xs ->
    length (slice n m xs) = m - n.
intros0 Hle.  unfold slice.
rewrite firstn_length, skipn_length. lia.
Qed.

Lemma slice_cons : forall A (xs : list A) x n m,
    slice n m xs = slice (S n) (S m) (x :: xs).
intros. unfold slice.
simpl. reflexivity.
Qed.

Lemma nth_error_slice : forall A (xs : list A) i x,
    nth_error xs i = Some x ->
    slice i (S i) xs = [x].
induction xs; destruct i; intros0 Hnth; try discriminate; simpl in *.
- unfold slice. simpl. congruence.
- rewrite <- slice_cons. eauto.
Qed.

Lemma firstn_firstn' : forall A (xs : list A) n k,
    firstn n (firstn (n + k) xs) = firstn n xs.
first_induction n; intros; simpl.
  { reflexivity. }
destruct xs.
- reflexivity.
- f_equal. eapply IHn.
Qed.

Lemma firstn_firstn : forall A (xs : list A) n m,
    m >= n ->
    firstn n (firstn m xs) = firstn n xs.
intros0 Hle.
replace m with (n + (m - n)) by lia.
eapply firstn_firstn'.
Qed.

Lemma firstn_skipn_swap : forall A (xs : list A) n m,
    firstn n (skipn m xs) = skipn m (firstn (n + m) xs).
induction xs; intros; simpl.
- destruct n, m; simpl; reflexivity.
- destruct m; simpl.
  + f_equal. lia.
  + replace (n + S m) with (S (n + m)) by lia. simpl. eauto.
Qed.

Lemma skipn_skipn : forall A (xs : list A) n k,
    k <= n ->
    skipn (n - k) (skipn k xs) = skipn n xs.
first_induction n; intros; simpl.
  { replace k with 0 by lia. simpl. reflexivity. }
destruct k, xs; simpl.
- reflexivity.
- reflexivity.
- destruct (n - k); reflexivity.
- eapply IHn. lia.
Qed.

Lemma slice_split : forall A (xs : list A) n k m,
    n <= k ->
    k <= m ->
    slice n m xs = slice n k xs ++ slice k m xs.
intros0 Hn Hm.
rewrite <- firstn_skipn with (n := k - n) at 1. f_equal.
- unfold slice. simpl.
  eapply firstn_firstn. lia.
- unfold slice. simpl.
  replace (m - n) with ((m - k) + (k - n)) by lia.
  rewrite <- firstn_skipn_swap.
  rewrite skipn_skipn by auto.
  reflexivity.
Qed.

Lemma Forall_contradict : forall A P (xs : list A),
    0 < length xs ->
    Forall P xs ->
    ~ Forall (fun x => ~ P x) xs.
intros0 Hlen Hfa Hnfa.
cut (Forall (fun _ => False) xs).
  { destruct xs; simpl in *; try lia.
    inversion 1. assumption. }
list_magic_on (xs, tt).
Qed.

Definition sliding {A} i (xs1 xs2 ys : list A) :=
    firstn i ys = firstn i xs1 /\
    skipn i ys = skipn i xs2.

Lemma sliding_next : forall A i (xs1 xs2 ys : list A) x,
    i < length ys ->
    sliding i xs1 xs2 ys ->
    nth_error xs1 i = Some x ->
    sliding (S i) xs1 xs2 (firstn i ys ++ [x] ++ skipn (S i) ys).
intros0 Hlt Hsld Hnth. destruct Hsld as [Hpre Hsuf].

assert (S i = length (firstn i ys ++ [x])). {
  rewrite app_length. simpl.
  cut (i = length (firstn i ys)).  { intro. lia. }
  rewrite firstn_length. lia.
}

split.

- rewrite app_assoc. rewrite firstn_app by lia. rewrite firstn_all by lia.
  do 2 rewrite firstn_slice.
  rewrite slice_split with (n := 0) (k := i) (m := S i) by lia.
  erewrite <- nth_error_slice by eassumption.
  f_equal. unfold slice. simpl. replace (i - 0) with i by lia. assumption.

- rewrite app_assoc. rewrite skipn_app by lia.
  replace (S i - _) with 0 by lia.
  unfold skipn at 1. replace (S i) with (1 + i) by lia.
  do 2 rewrite <- skipn_add.
  f_equal. assumption.
Qed.

Lemma skipn_app_l : forall A (xs ys : list A) n,
    n <= length xs ->
    skipn n (xs ++ ys) = skipn n xs ++ ys.
induction xs; destruct n; intros0 Hlt; simpl in *; try lia.
- reflexivity.
- reflexivity.
- apply IHxs. lia.
Qed.

Lemma slice_app_l : forall A i j (xs1 xs2 : list A),
    i <= j ->
    j <= length xs1 ->
    slice i j (xs1 ++ xs2) = slice i j xs1.
intros0 Hi Hj.
unfold slice.
rewrite skipn_app_l by lia.
rewrite firstn_app; cycle 1.
  { rewrite skipn_length. lia. }
reflexivity.
Qed.

Lemma slice_app_r : forall A i j (xs1 xs2 : list A),
    i >= length xs1 ->
    slice i j (xs1 ++ xs2) = slice (i - length xs1) (j - length xs1) xs2.
intros0 Hlen.
unfold slice.
replace (j - _ - (i - _)) with (j - i) by lia. f_equal.
eapply skipn_app. lia.
Qed.

Lemma slice_app_change_l : forall A i j (xs1 xs1' xs2 : list A),
    i >= length xs1 ->
    length xs1 = length xs1' ->
    slice i j (xs1 ++ xs2) = slice i j (xs1' ++ xs2).
intros0 Hi Hlen.
rewrite slice_app_r by auto.
rewrite Hlen. rewrite <- slice_app_r by lia.
reflexivity.
Qed.

Lemma slice_app_change_r : forall A i j (xs1 xs2 xs2' : list A),
    i <= j ->
    j <= length xs1 ->
    slice i j (xs1 ++ xs2) = slice i j (xs1 ++ xs2').
intros0 Hi Hj.
rewrite slice_app_l by auto.
erewrite <- slice_app_l by auto.
reflexivity.
Qed.

Lemma app_inv_both : forall A (xs1 xs2 ys1 ys2 : list A),
    length xs1 = length ys1 ->
    xs1 ++ xs2 = ys1 ++ ys2 ->
    xs1 = ys1 /\ xs2 = ys2.
first_induction xs1; destruct ys1; intros0 Hlen Happ; try discriminate; simpl in *.
- eauto.
- invc Happ. specialize (IHxs1 xs2 ys1 ys2 ltac:(lia) **).
  firstorder congruence.
Qed.

Lemma sliding_next' : forall A i (xs1 xs2 ys1 ys3 : list A) y2 y2',
    i = length ys1 ->
    sliding i xs1 xs2 (ys1 ++ [y2] ++ ys3) ->
    nth_error xs1 i = Some y2' ->
    sliding (S i) xs1 xs2 (ys1 ++ [y2'] ++ ys3).
intros0 Hlen Hsld Hnth.
unfold sliding in *.
repeat rewrite firstn_slice in *. repeat rewrite skipn_slice in *.
eapply nth_error_slice in Hnth.
destruct Hsld as [Hpre Hsuf]. split.

- rewrite slice_split with (k := i) by lia.
  rewrite slice_split with (k := i) (xs := xs1) by lia.
  f_equal.
  + erewrite slice_app_change_r by lia. eassumption.
  + rewrite slice_app_r by lia.
    replace (i - _) with 0 by lia. replace (S i - _) with 1 by lia.
    rewrite Hnth.  unfold slice. simpl. reflexivity.

- simple refine (let Hxs2 : length _ = length _ := _ in _); [ shelve.. | | ].
    { eapply f_equal. exact Hsuf. }
    clearbody Hxs2.
    rewrite slice_length in Hxs2 by lia.
    rewrite slice_length in Hxs2 by lia.

  repeat rewrite app_length in *. simpl in *.
  rewrite slice_split with (k := S i) in Hsuf by omega.
  rewrite slice_split with (k := S i) (xs := xs2) in Hsuf by omega.
  eapply app_inv_both in Hsuf; cycle 1.
    { rewrite slice_length by (rewrite app_length; simpl; lia).
      rewrite slice_length by lia. reflexivity. }
  destruct Hsuf as [Hsuf1 Hsuf2].
  rewrite <- Hsuf2.
  change (y2' :: ys3) with ([y2'] ++ ys3). rewrite app_assoc.
  change (y2 :: ys3) with ([y2] ++ ys3). rewrite app_assoc.
  eapply slice_app_change_l.
  + rewrite app_length. simpl. lia.
  + do 2 rewrite app_length. simpl. lia.
Qed.

Lemma sliding_app : forall A i (xs1 xs2 : list A) x,
    i < length xs2 ->
    length xs1 = length xs2 ->
    nth_error xs1 i = Some x ->
    sliding (S i) xs1 xs2 (firstn i xs1 ++ [x] ++ skipn (S i) xs2).
intros0 Hlt Hlen Hnth.

assert (S i = length (firstn i xs1 ++ [x])). {
  rewrite app_length. simpl.
  cut (i = length (firstn i xs1)).  { intro. lia. }
  rewrite firstn_length. lia.
}

split.

- rewrite app_assoc. rewrite firstn_app by lia. rewrite firstn_all by lia.
  do 2 rewrite firstn_slice.
  rewrite slice_split with (n := 0) (k := i) (m := S i) by lia.
  erewrite <- nth_error_slice by eassumption.
  reflexivity.

- rewrite app_assoc. rewrite skipn_app by lia.
  replace (S i - _) with 0 by lia.
  unfold skipn at 1. reflexivity.
Qed.

Lemma sliding_nth_error_lt : forall A i j (xs1 xs2 ys : list A),
    j < i ->
    sliding i xs1 xs2 ys ->
    nth_error ys j = nth_error xs1 j.
intros0 Hlt Hsld. destruct Hsld as [Hpre Hsuf].
fwd eapply firstn_nth_error_lt with (xs := ys); eauto.
fwd eapply firstn_nth_error_lt with (xs := xs1); eauto.
congruence.
Qed.

Lemma sliding_nth_error_ge : forall A i j (xs1 xs2 ys : list A),
    j >= i ->
    sliding i xs1 xs2 ys ->
    nth_error ys j = nth_error xs2 j.
intros0 Hlt Hsld. destruct Hsld as [Hpre Hsuf].
replace j with (i + (j - i)) by lia.
do 2 rewrite <- skipn_nth_error. congruence.
Qed.

Lemma sliding_split : forall A i (xs1 xs2 ys : list A) x,
    nth_error xs2 i = Some x ->
    sliding i xs1 xs2 ys ->
    ys = firstn i xs1 ++ [x] ++ skipn (S i) xs2.
intros0 Hnth Hsld. destruct Hsld as [Hpre Hsuf].
fwd eapply nth_error_slice with (1 := Hnth) as Hnth'.
rewrite <- Hnth'. rewrite skipn_slice. rewrite <- slice_split; try lia; cycle 1.
  { cut (i < length xs2). { intro. lia. }
    rewrite <- nth_error_Some. congruence. }
rewrite <- skipn_slice.
rewrite <- firstn_skipn with (l := ys) (n := i). congruence.
Qed.

Lemma sliding_length : forall A i (xs1 xs2 ys : list A),
    length xs1 = length xs2 ->
    sliding i xs1 xs2 ys ->
    length ys = length xs1.
intros0 Hlen Hsld. destruct Hsld as [Hpre Hsuf].
rewrite <- firstn_skipn with (l := ys) (n := i). rewrite app_length.
rewrite Hpre, Hsuf.
rewrite firstn_length. rewrite skipn_length. lia.
Qed.

Lemma sliding_zero : forall A (xs1 xs2 : list A),
    sliding 0 xs1 xs2 xs2.
intros. split.
- simpl. reflexivity.
- simpl. reflexivity.
Qed.

Lemma skipn_all : forall A n (xs : list A),
    n >= length xs ->
    skipn n xs = [].
first_induction xs; intros0 Hlen.
- destruct n; reflexivity.
- destruct n; simpl in *.  { lia. }
  eapply IHxs. lia.
Qed.

Lemma skipn_all' : forall A n (xs : list A),
    skipn n xs = [] ->
    n >= length xs.
first_induction xs; intros0 Hlen.
- destruct n; simpl in *; try discriminate; lia.
- destruct n; simpl in *; try discriminate.
  specialize (IHxs ?? **).
  lia.
Qed.

Lemma sliding_all : forall A (xs1 xs2 : list A),
    length xs1 >= length xs2 ->
    sliding (length xs1) xs1 xs2 xs1.
intros. split.
- rewrite firstn_all; auto.
- rewrite skipn_all, skipn_all; eauto.
Qed.

Lemma sliding_all_eq : forall A (xs1 xs2 xs3 : list A),
    sliding (length xs1) xs1 xs2 xs3 ->
    length xs1 >= length xs2 ->
    xs3 = xs1.
intros. fwd eapply sliding_all; eauto.
on >@sliding, invc.
on >@sliding, invc.
rewrite <- firstn_skipn with (n := length xs1) (l := xs1).
rewrite <- firstn_skipn with (n := length xs1) (l := xs3).
congruence.
Qed.

Lemma sliding_predicate_all : forall A (P : A -> Prop) i xs ys zs,
    sliding i xs ys zs ->
    Forall P xs ->
    Forall (fun y => ~ P y) ys ->
    Forall P zs ->
    i >= length ys.
intros0 Hsld Hxs Hys Hzs.
destruct (lt_dec i (length ys)); try lia.
destruct Hsld as [Hpre Hsuf].

assert (length (skipn i ys) > 0).
  { rewrite skipn_length. lia. }
assert (length (skipn i zs) > 0) by congruence.
assert (HH : i < length zs).
  { rewrite skipn_length in *. lia. }
  rewrite <- nth_error_Some in HH.
  destruct (nth_error zs i) eqn:?; try congruence.
  clear HH.

assert (nth_error ys i = Some a).
  { replace i with (i + 0) by lia. rewrite <- skipn_nth_error.
    rewrite <- Hsuf.
    rewrite skipn_nth_error. replace (i + 0) with i by lia.
    assumption. }

fwd eapply Forall_nth_error with (xs := ys); eauto.
fwd eapply Forall_nth_error with (xs := zs); eauto.
simpl in *. contradiction.
Qed.

Lemma sliding_predicate_i : forall A (P : A -> Prop) i xs ys zs1 z2 zs3,
    sliding i xs ys (zs1 ++ [z2] ++ zs3) ->
    Forall P xs ->
    Forall (fun y => ~ P y) ys ->
    Forall P zs1 ->
    ~ P z2 ->
    i = length zs1.
intros0 Hsld Hxs Hys Hzs1 Hz2.

destruct (lt_eq_lt_dec (length zs1) i) as [[? | ?] | ?]; try lia.

- (* i > length zs1 *) exfalso.
  fwd eapply sliding_nth_error_lt as HH; eauto.
  rewrite nth_error_app2 in HH by lia.
  replace (_ - _) with 0 in HH by lia. simpl in HH. symmetry in HH.
  fwd eapply Forall_nth_error with (P := P); [ | eassumption | ]; auto.

- (* i < length zs1 *) exfalso.
  fwd eapply sliding_nth_error_ge as HH; [ | eauto | ]; eauto.
  rewrite nth_error_app1 in HH by lia.
  destruct (nth_error _ _) eqn:Heq; cycle 1.
    { rewrite <- nth_error_Some in *. congruence. }
  symmetry in HH.
  eapply Forall_nth_error in Heq; eauto.
  eapply Forall_nth_error in HH; eauto. simpl in *.
  auto.
Qed.

Lemma sliding_predicate_nth : forall A (P : A -> Prop) i xs ys zs1 z2 zs3,
    sliding i xs ys (zs1 ++ [z2] ++ zs3) ->
    Forall P xs ->
    Forall (fun y => ~ P y) ys ->
    Forall P zs1 ->
    ~ P z2 ->
    nth_error ys i = Some z2.
intros. fwd eapply sliding_predicate_i; eauto.
erewrite <- sliding_nth_error_ge by eauto.
subst i. rewrite nth_error_app2 by lia.
replace (_ - _) with 0 by lia. simpl. reflexivity.
Qed.

(* distinctness and disjointness *)

Inductive distinct {A} : list A -> Prop :=
| DistinctNil : distinct []
| DistinctCons : forall x xs,
        ~ In x xs ->
        distinct xs ->
        distinct (x :: xs).

Inductive disjoint {A} : list A -> list A -> Prop :=
| Disjoint : forall xs ys,
        Forall (fun x => ~ In x ys) xs ->
        disjoint xs ys.

Lemma app_distinct : forall A (xs ys : list A),
    distinct xs ->
    distinct ys ->
    disjoint xs ys ->
    distinct (xs ++ ys).
induction xs; intros0 Hx Hy Hxy.
- simpl. assumption.
- invc Hx. invc Hxy. on >Forall, invc.
  rewrite <- app_comm_cons.
  constructor; eauto.
  + rewrite in_app_iff. firstorder.
  + eapply IHxs; eauto. constructor; eauto.
Qed.

Lemma cons_disjoint_l : forall A (xs ys : list A) x,
    ~ In x ys ->
    disjoint xs ys ->
    disjoint (x :: xs) ys.
intros0 Hin Hxy. invc Hxy. constructor.
constructor; eauto.
Qed.
Hint Resolve cons_disjoint_l.

Lemma cons_disjoint_r : forall A (xs ys : list A) y,
    ~ In y xs ->
    disjoint xs ys ->
    disjoint xs (y :: ys).
intros0 Hin Hxy; invc Hxy; constructor; eauto.
rewrite Forall_forall in *. intros.
on >In, contradict. simpl in *. on (_ \/ _), invc; eauto.
intro. firstorder.
Qed.
Hint Resolve cons_disjoint_r.

Lemma tail_disjoint_l : forall A (xs ys : list A) x,
    disjoint (x :: xs) ys ->
    disjoint xs ys.
intros0 Hxy. invc Hxy. on >Forall, invc.
constructor. eauto.
Qed.
Hint Resolve tail_disjoint_l.

Lemma tail_disjoint_r : forall A (xs ys : list A) y,
    disjoint xs (y :: ys) ->
    disjoint xs ys.
intros0 Hxy. invc Hxy. constructor.
rewrite Forall_forall in *. intros.
simpl in *. firstorder.
Qed.
Hint Resolve tail_disjoint_r.

Lemma disjoint_sym : forall A (xs ys : list A),
    disjoint xs ys ->
    disjoint ys xs.
intros0 Hxy. invc Hxy. constructor.
rewrite Forall_forall in *. intros.
firstorder.
Qed.

Lemma disjoint_head_l : forall A (xs ys : list A) x,
    disjoint (x :: xs) ys ->
    ~ In x ys.
intros0 Hxy. invc Hxy. on >Forall, invc. auto.
Qed.

Lemma disjoint_head_r : forall A (xs ys : list A) y,
    disjoint xs (y :: ys) ->
    ~ In y xs.
intros. eauto using disjoint_sym, disjoint_head_l.
Qed.

Lemma nil_disjoint_l : forall A (ys : list A),
    disjoint [] ys.
intros. constructor. constructor.
Qed.
Hint Resolve nil_disjoint_l.

Lemma nil_disjoint_r : forall A (xs : list A),
    disjoint xs [].
intros. constructor. rewrite Forall_forall. intros. inversion 1.
Qed.
Hint Resolve nil_disjoint_r.

Lemma disjoint_cons_inv_l : forall A (xs ys : list A) x
        (P : _ -> _ -> _ -> Prop),
    (~ In x ys ->
        disjoint xs ys ->
        P x xs ys) ->
    disjoint (x :: xs) ys -> P x xs ys.
intros0 HP Hxy. invc Hxy. on >Forall, invc.
eapply HP; eauto using Disjoint.
Qed.

Lemma disjoint_cons_inv_r : forall A (xs ys : list A) y
        (P : _ -> _ -> _ -> Prop),
    (~ In y xs ->
        disjoint xs ys ->
        P xs y ys) ->
    disjoint xs (y :: ys) -> P xs y ys.
intros0 HP Hxy. eapply disjoint_sym in Hxy.
invc_using disjoint_cons_inv_l Hxy.
eauto using disjoint_sym.
Qed.

Lemma disjoint_app_inv_l : forall A (xs1 xs2 ys : list A)
        (P : _ -> _ -> _ -> Prop),
    (disjoint xs1 ys ->
        disjoint xs2 ys ->
        P xs1 xs2 ys) ->
    disjoint (xs1 ++ xs2) ys -> P xs1 xs2 ys.
induction xs1; intros0 HP Hxy.
- eapply HP; eauto.
- rewrite <- app_comm_cons in *. invc_using disjoint_cons_inv_l Hxy.
  on _, invc_using IHxs1.
  eapply HP; eauto.
Qed.

Lemma disjoint_app_inv_r : forall A (xs ys1 ys2 : list A)
        (P : _ -> _ -> _ -> Prop),
    (disjoint xs ys1 ->
        disjoint xs ys2 ->
        P xs ys1 ys2) ->
    disjoint xs (ys1 ++ ys2) -> P xs ys1 ys2.
intros0 HP Hxy. eapply disjoint_sym in Hxy.
invc_using disjoint_app_inv_l Hxy.
eauto using disjoint_sym.
Qed.

Lemma disjoint_app_l : forall A (xs1 xs2 ys : list A),
    disjoint xs1 ys ->
    disjoint xs2 ys ->
    disjoint (xs1 ++ xs2) ys.
induction xs1; intros0 Hxy1 Hxy2.
- simpl in *. auto.
- simpl. on _, invc_using disjoint_cons_inv_l.
  eapply cons_disjoint_l; eauto.
Qed.

Lemma disjoint_app_r : forall A (xs ys1 ys2 : list A),
    disjoint xs ys1 ->
    disjoint xs ys2 ->
    disjoint xs (ys1 ++ ys2).
intros. eauto using disjoint_sym, disjoint_app_l.
Qed.

Lemma distinct_disjoint : forall A (xs ys : list A),
    distinct (xs ++ ys) ->
    disjoint xs ys.
induction xs; intros0 Hxy.
- eapply nil_disjoint_l.
- rewrite <- app_comm_cons in *. invc Hxy.
  eapply cons_disjoint_l; eauto.
  rewrite in_app_iff in *. firstorder.
Qed.

Lemma distinct_app_inv' : forall A (xs ys : list A)
        (P : _ -> _ -> Prop),
    (distinct xs ->
        distinct ys ->
        P xs ys) ->
    distinct (xs ++ ys) -> P xs ys.
induction xs; intros0 HP Hxy.
- eapply HP; eauto. constructor.
- rewrite <- app_comm_cons in *. invc Hxy.
  rewrite in_app_iff in *.
  on >@distinct, invc_using IHxs.
  eapply HP; eauto.
  constructor; eauto.
Qed.

Lemma distinct_app_inv : forall A (xs ys : list A)
        (P : _ -> _ -> Prop),
    (distinct xs ->
        distinct ys ->
        disjoint xs ys ->
        P xs ys) ->
    distinct (xs ++ ys) -> P xs ys.
intros0 HP Hxy. inv_using distinct_app_inv' Hxy.
eapply HP; eauto using distinct_disjoint.
Qed.

Definition distinct_dec {A}
    (A_eq_dec : forall (x y : A), { x = y } + { x <> y })
    (xs : list A) : { distinct xs } + { ~ distinct xs }.
induction xs.
- left. constructor.
- rename a into x.
  destruct (in_dec A_eq_dec x xs).
    { right. inversion 1. auto. }
  destruct IHxs; [ | right; inversion 1; eauto ].
  left. constructor; eauto.
Defined.

Definition disjoint_dec {A}
    (A_eq_dec : forall (x y : A), { x = y } + { x <> y })
    (xs ys : list A) : { disjoint xs ys } + { ~ disjoint xs ys }.
induction xs.
- left. constructor. constructor.
- rename a into x.
  destruct (in_dec A_eq_dec x ys).
    { right. inversion 1. on >Forall, invc. auto. }
  destruct IHxs; [ | right; inversion 1; eauto ].
  left. on >@disjoint, invc. constructor; eauto.
Defined.

(* association list lookups *)

Fixpoint lookup {A} (xs : list (nat * A)) (k : nat) : option A :=
    match xs with
    | [] => None
    | (k', x) :: xs =>
            if eq_nat_dec k k'
                then Some x
                else lookup xs k
    end.

Definition keys {A} (xs : list (nat * A)) : list nat := map fst xs.

Lemma cons_lookup_ne : forall A k (x : A) k' xs,
    ~ In k (keys xs) ->
    k' <> k ->
    lookup ((k, x) :: xs) k' = lookup xs k'.
destruct xs; intros0 Hin Hk; simpl in *;
break_if; congruence.
Qed.

Lemma lookup_some_in_keys : forall A xs k (x : A),
    lookup xs k = Some x ->
    In k (keys xs).
first_induction xs; intros0 Hlook; simpl in *.
- discriminate.
- destruct a. break_if; eauto.
Qed.

Lemma in_keys_lookup_some_ex : forall A xs k,
    In k (keys xs) ->
    exists x : A, lookup xs k = Some x.
first_induction xs; intros0 Hin; simpl in *.
- exfalso. auto.
- destruct a. simpl in *. break_if; eauto.
  destruct Hin; eauto. congruence.
Qed.

Lemma lookup_none_in_keys : forall A (xs : list (nat * A)) k,
    lookup xs k = None ->
    ~ In k (keys xs).
induction xs; intros0 Hlook; simpl in *.
- eauto.
- destruct a. simpl in *. break_if.
  + discriminate.
  + inversion 1; eauto.
    eapply IHxs; eauto.
Qed.

Lemma in_keys_lookup_none : forall A (xs : list (nat * A)) k,
    ~ In k (keys xs) ->
    lookup xs k = None.
induction xs; intros0 Hin; simpl in *.
- reflexivity.
- destruct a. simpl in *. break_if; eauto.
  contradict Hin. eauto.
Qed.

(* association list lookups (Z keys) *)

Fixpoint zlookup {A} (xs : list (Z * A)) (k : Z) : option A :=
    match xs with
    | [] => None
    | (k', x) :: xs =>
            if Z.eq_dec k k'
                then Some x
                else zlookup xs k
    end.

(* assoc *)

Lemma assoc_cons_l : forall A B eq_dec (x : A * B) xs k,
    fst x = k ->
    assoc eq_dec (x :: xs) k = Some (snd x).
intros0 Heq.
simpl. break_match. simpl in Heq. break_if; try congruence.
reflexivity.
Qed.

Lemma assoc_cons_r : forall A B eq_dec (x : A * B) xs k,
    fst x <> k ->
    assoc eq_dec (x :: xs) k = assoc eq_dec xs k.
intros0 Hne.
simpl. break_match. simpl in Hne. break_if; try congruence.
Qed.

Lemma assoc_app_l : forall A B eq_dec (xs1 xs2 : list (A * B)) k,
    In k (map fst xs1) ->
    assoc eq_dec (xs1 ++ xs2) k = assoc eq_dec xs1 k.
induction xs1; intros0 Heq; simpl in *.
- contradiction.
- break_match. simpl in Heq. break_if.
  + reflexivity.
  + destruct Heq; try congruence.
    eauto.
Qed.

Lemma assoc_app_r : forall A B eq_dec (xs1 xs2 : list (A * B)) k,
    ~ In k (map fst xs1) ->
    assoc eq_dec (xs1 ++ xs2) k = assoc eq_dec xs2 k.
induction xs1; intros0 Heq; simpl in *.
- reflexivity.
- break_match. simpl in Heq. break_if.
  + exfalso. on _, eapply_. auto.
  + eapply IHxs1. contradict Heq. auto.
Qed.

Lemma in_fst_assoc : forall A B eq_dec (xs : list (A * B)) k,
    In k (map fst xs) ->
    exists v, assoc eq_dec xs k = Some v.
induction xs; intros0 Hin; simpl in *.
- contradiction.
- break_match. simpl in Hin. break_if.
  + eauto.
  + destruct Hin; try congruence.
    auto.
Qed.

Lemma assoc_in_fst : forall A B eq_dec (xs : list (A * B)) k v,
    assoc eq_dec xs k = Some v ->
    In k (map fst xs).
induction xs; intros0 Heq; simpl in *.
- discriminate.
- break_match. simpl. break_if.
  + auto.
  + right. eauto.
Qed.

Lemma assoc_in_fst' : forall A B eq_dec (xs : list (A * B)) k,
    assoc eq_dec xs k <> None ->
    In k (map fst xs).
intros0 Hne.
destruct (assoc _ _ _) eqn:?; try congruence.
eauto using assoc_in_fst.
Qed.

(* count_up + numbered *)

Fixpoint count_up' acc n :=
    match n with
    | 0 => acc
    | S n' => count_up' (n' :: acc) n'
    end.

Definition count_up n := count_up' [] n.

Fixpoint numbered' {A} n (xs : list A) :=
    match xs with
    | [] => []
    | x :: xs => (n, x) :: numbered' (S n) xs
    end.

Definition numbered {A} (xs : list A) := numbered' 0 xs.

Lemma count_up'_nth_error : forall acc n i,
    (forall i', i' < length acc -> nth_error acc i' = Some (n + i')) ->
    i < n + length acc ->
    nth_error (count_up' acc n) i = Some i.
first_induction n; intros0 Hacc Hlt; simpl in *.
- eauto.
- eapply IHn; cycle 1.
    { simpl. omega. }
  intros.  destruct i'.
  + simpl. f_equal. omega.
  + simpl. replace (n + S i') with (S (n + i')) by omega.
    eapply Hacc. simpl in *. omega.
Qed.

Lemma count_up_nth_error : forall n i,
    i < n ->
    nth_error (count_up n) i = Some i.
intros. eapply count_up'_nth_error.
- intros. simpl in *. omega.
- simpl. omega.
Qed.

Lemma numbered'_length : forall A (xs : list A) base,
    length (numbered' base xs) = length xs.
induction xs; intros; simpl in *; eauto.
Qed.

Lemma numbered_length : forall A (xs : list A),
    length (numbered xs) = length xs.
intros. eapply numbered'_length; eauto.
Qed.

Lemma count_up'_length : forall acc n,
    length (count_up' acc n) = n + length acc.
first_induction n; intros; simpl in *; eauto.
rewrite IHn. simpl. omega.
Qed.

Lemma count_up_length : forall n,
    length (count_up n) = n.
intros. unfold count_up. rewrite count_up'_length. simpl. omega.
Qed.

Lemma numbered'_nth_error : forall A (xs : list A) base n x,
    nth_error xs n = Some x ->
    nth_error (numbered' base xs) n = Some (base + n, x).
induction xs; intros0 Hnth; simpl in *.
- destruct n; discriminate.
- destruct n; simpl in *.
  + inject_some. replace (base + 0) with base by omega. reflexivity.
  + replace (base + S n) with (S base + n) by omega. eapply IHxs. eauto.
Qed.

Lemma numbered_nth_error : forall A (xs : list A) n x,
    nth_error xs n = Some x ->
    nth_error (numbered xs) n = Some (n, x).
intros. eapply numbered'_nth_error. eauto.
Qed.

Lemma numbered_count_up : forall A (xs : list A),
    Forall2 (fun a b => fst a = b) (numbered xs) (count_up (length xs)).
intros.
eapply nth_error_Forall2.
- rewrite numbered_length, count_up_length. reflexivity.
- intros.
  assert (i < length xs). {
    rewrite <- numbered_length. rewrite <- nth_error_Some. congruence.
  }
  assert (exists x', nth_error xs i = Some x'). {
    rewrite <- nth_error_Some in *. destruct (nth_error xs i); try congruence. eauto.
  }
  break_exists.
  erewrite numbered_nth_error in *; eauto. inject_some.
  rewrite count_up_nth_error in *; eauto. inject_some.
  reflexivity.
Qed.

Lemma numbered_count_up_eq : forall A (xs : list A),
    map fst (numbered xs) = count_up (length xs).
intros.
rewrite <- map_id with (xs := count_up _).
eapply Forall2_map_eq. eauto using numbered_count_up.
Qed.

Lemma numbered'_nth_error_fst : forall A (xs : list A) n i x,
    nth_error (numbered' n xs) i = Some x ->
    fst x = n + i.
induction xs; intros0 Hnth; simpl in *.
- destruct i; discriminate Hnth.
- destruct i; simpl in *.
  + inject_some. simpl. omega.
  + replace (n + S i) with (S n + i) by omega.
    eauto.
Qed.

Lemma numbered_nth_error_fst : forall A (xs : list A) i x,
    nth_error (numbered xs) i = Some x ->
    fst x = i.
intros. change i with (0 + i).  eapply numbered'_nth_error_fst; eauto.
Qed.

Lemma numbered'_nth_error_snd : forall A (xs : list A) n i x,
    nth_error (numbered' n xs) i = Some x ->
    nth_error xs i = Some (snd x).
induction xs; intros0 Hnth; simpl in *.
- destruct i; discriminate Hnth.
- destruct i; simpl in *.
  + inject_some. simpl. reflexivity.
  + replace (n + S i) with (S n + i) by omega.
    eauto.
Qed.

Lemma numbered_nth_error_snd : forall A (xs : list A) i x,
    nth_error (numbered xs) i = Some x ->
    nth_error xs i = Some (snd x).
intros. change i with (0 + i).  eapply numbered'_nth_error_snd; eauto.
Qed.

Lemma numbered_nth_error_fst_snd : forall A (xs : list A) i x,
    nth_error (numbered xs) i = Some x ->
    nth_error xs (fst x) = Some (snd x).
intros.
erewrite numbered_nth_error_fst;
  eauto using numbered_nth_error_snd.
Qed.

(* zip *)

Fixpoint zip {A B} (a : list A) (b : list B) : list (A * B) :=
  match a,b with
  | f :: r, x :: y => (f,x) :: zip r y
  | _,_ => nil
  end.

Lemma zip_nth_error : forall A B (xs : list A) (ys : list B) n xy,
    nth_error (zip xs ys) n = Some xy ->
    nth_error xs n = Some (fst xy) /\
    nth_error ys n = Some (snd xy).
induction xs; destruct ys, n; intros0 Hzip; simpl in *; try discriminate.
- inject_some. split; reflexivity.
- eapply IHxs; eauto.
Qed.

(* list_forall2 <-> Forall2 *)

Lemma list_forall2_Forall2 : forall A B (P : A -> B -> Prop) xs ys,
    list_forall2 P xs ys <-> Forall2 P xs ys.
induction xs; destruct ys; split; intro HH; invc HH; econstructor; eauto.
all: firstorder.
Qed.

(* unsorted *)

Lemma nth_error_app_Some : forall A (xs ys : list A) n x,
    nth_error xs n = Some x ->
    nth_error (xs ++ ys) n = Some x.
intros. rewrite nth_error_app1; eauto.
eapply nth_error_Some. congruence.
Qed.

Lemma Forall3_nth_error_ex1 : forall A B C (P : A -> B -> C -> Prop) xs ys zs i x,
    Forall3 P xs ys zs ->
    nth_error xs i = Some x ->
    exists y z,
        nth_error ys i = Some y /\
        nth_error zs i = Some z /\
        P x y z.
induction xs; intros0 Hfa Hnth; invc Hfa; destruct i; try discriminate.
- simpl in *. inject_some. eauto.
- simpl in *. eauto.
Qed.

Lemma Forall3_nth_error_ex2 : forall A B C (P : A -> B -> C -> Prop) xs ys zs i y,
    Forall3 P xs ys zs ->
    nth_error ys i = Some y ->
    exists x z,
        nth_error xs i = Some x /\
        nth_error zs i = Some z /\
        P x y z.
first_induction ys; intros0 Hfa Hnth; invc Hfa; destruct i; try discriminate.
- simpl in *. inject_some. eauto.
- simpl in *. eauto.
Qed.

Lemma map_inj : forall {A B} (f : A -> B) xs ys,
    (forall x y, f x = f y -> x = y) ->
    map f xs = map f ys -> xs = ys.
induction xs; destruct ys; intros0 Hinj Hmap; simpl in *; try discriminate.
- reflexivity.
- invc Hmap. erewrite Hinj with (x := a); eauto.
  erewrite IHxs; eauto.
Qed.


(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra.

(* -------------------------------------------------------------------- *)
Import Order.TTheory GRing.Theory Num.Theory Num.Def.

(* -------------------------------------------------------------------- *)
Set   Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Unset SsrOldRewriteGoalsOrder.

Local Obligation Tactic := idtac.

(* -------------------------------------------------------------------- *)
Local Open Scope ring_scope.

(* ==================================================================== *)
Section ProdVector.
Section Defn.
Context {I : finType} (E : I -> Type).

Variant mvector := MVector of {dffun forall i : I, E i}.

Definition mv_val u := let: MVector t := u in t.

Canonical mvector_subType := Eval hnf in [newType for mv_val].

Fact mvector_key : unit. Proof. by []. Qed.
Definition mvector_of_fun_def F := MVector [ffun i : I => F i].
Definition mvector_of_fun k := locked_with k mvector_of_fun_def.
Canonical mvector_unlockable k := [unlockable fun mvector_of_fun k].

Definition fun_of_mvector u (i : I) := mv_val u i.

Coercion fun_of_mvector : mvector >-> Funclass.

Lemma mvE k F i : mvector_of_fun k F i = F i.
Proof. by rewrite unlock /fun_of_mvector /= ffunE. Qed.

Lemma mvectorP (u v : mvector) : (forall i, u i = v i) <-> u = v.
Proof.
rewrite /fun_of_mvector; split=> [/= eq_uv | -> //].
by apply/val_inj/ffunP=> i; apply: eq_uv.
Qed.

Lemma eq_mv k u v : (forall i, u i = v i) ->
  mvector_of_fun k u = mvector_of_fun k v.
Proof. by move=> eq_uv; apply/mvectorP => i; rewrite !mvE eq_uv. Qed.
End Defn.

Definition mvector_eqMixin {I : finType} (E : I -> eqType) :=
  Eval hnf in [eqMixin of mvector E by <:].
Canonical mvector_eqType {I : finType} (E : I -> eqType) :=
  Eval hnf in EqType (mvector E) (mvector_eqMixin E).
Definition mvector_choiceMixin {I : finType} (E : I -> choiceType) :=
  [choiceMixin of mvector E by <:].
Canonical mvector_choiceType {I : finType} (E : I -> choiceType) :=
  Eval hnf in ChoiceType (mvector E) (mvector_choiceMixin E).
Definition mvector_countMixin {I : finType} (E : I -> countType) :=
  [countMixin of mvector E by <:].
Canonical mvector_countType {I : finType} (E : I -> countType) :=
  Eval hnf in CountType (mvector E) (mvector_countMixin E).
Canonical mvector_subCountType {I : finType} (E : I -> countType) :=
  Eval hnf in [subCountType of mvector E].
Definition mvector_finMixin (I : finType) (E : I -> finType) :=
  [finMixin of mvector E by <:].
Canonical mvector_finType (I : finType) (E : I -> finType) :=
  Eval hnf in FinType (mvector E) (mvector_finMixin E).
Canonical mvector_subFinType (I : finType) (E : I -> finType) :=
  Eval hnf in [subFinType of mvector E].

Lemma card_mv (I: finType) (E: I -> finType) :
  #|mvector_finType E| = #|{dffun forall i : I, E i}|.
Proof. by rewrite card_sub. Qed.
End ProdVector.

Notation "\mvector_ ( i : I ) E" := (mvector_of_fun mvector_key (fun i : I => E))
  (at level 36, E at level 36, i, I at level 50): ring_scope.

(* ==================================================================== *)
Section ProdVectorZmod.
Context {I : finType} (E : I -> zmodType).

Implicit Types u v w : mvector E.

Definition mvector_zero     := \mvector_(i : I) (0 : E i).
Definition mvector_add  u v := \mvector_(i : I) (u i + v i).
Definition mvector_opp  u   := \mvector_(i : I) -u i.

Program Canonical mvector_zmodType := Eval hnf in ZmodType (mvector E)
  (@GRing.Zmodule.Mixin _ mvector_zero mvector_opp mvector_add _ _ _ _).

Next Obligation.
by move=> f g h; apply/mvectorP=> i; rewrite !mvE addrA.
Qed.

Next Obligation.
by move=> f g; apply/mvectorP=> i; rewrite !mvE addrC.
Qed.

Next Obligation.
by move=> f; apply/mvectorP=> i; rewrite !mvE add0r.
Qed.

Next Obligation.
by move=> f; apply/mvectorP=> i; rewrite !mvE addNr.
Qed.

Lemma mv_sumE T (P : pred T) (F : T -> mvector E) (r : seq T) i :
  (\sum_(x <- r | P x) F x) i = \sum_(x <- r | P x) F x i.
Proof. by elim/big_rec2: _ => /= [|x _ s Px <-]; rewrite mvE. Qed.
End ProdVectorZmod.

(* ==================================================================== *)
Section ProdVectorVectLmodType.
Context {A : ringType} {I : finType} (E : I -> lmodType A).

Implicit Types u v w : mvector E.

Definition mvector_scale (c : A) u :=
  \mvector_(i : I) (c *: u i).

Program Canonical ffun_lmodType := Eval hnf in LmodType A (mvector E)
  (@LmodMixin _ _ mvector_scale _ _ _ _).

Next Obligation.
by move=> /= c d x; apply/mvectorP=> i; rewrite !mvE scalerA.
Qed.

Next Obligation.
by move=> /= x; apply/mvectorP=> i; rewrite !mvE scale1r.
Qed.

Next Obligation.
by move=> /= c u v; apply/mvectorP=> i; rewrite !mvE scalerDr.
Qed.

Next Obligation.
by move=> /= u c d; apply/mvectorP=> i; rewrite !mvE scalerDl.
Qed.

Lemma scalemvE (c : A) (u : forall i, E i) :
  c *: \mvector_(i : I) u i = \mvector_(i : I) (c *: u i).
Proof. by apply/mvectorP=> i; rewrite !mvE. Qed.
End ProdVectorVectLmodType.

(* -------------------------------------------------------------------- *)
Import Vector.InternalTheory.

Section ProdVectorVectType.
Context {I : finType} {k : fieldType} (E : I -> vectType k).

Let Z := {i : I & 'I_(Vector.dim (E i))}.

Let S {i : I} (x : 'I_(Vector.dim (E i))) : Z := Tagged _ x.

Let D := (\sum_i Vector.dim (E i))%N.

Lemma vect_axiom_eqdim
    {A : ringType} {M : lmodType A} (m n : nat) (eq_nm : n = m)
  : Vector.axiom n M -> Vector.axiom m M.
Proof.
pose F (r : 'rV[A]_n) := castmx (erefl _, eq_nm) r.
pose G (r : 'rV[A]_m) := castmx (esym (erefl _), esym eq_nm) r.
case=> [f lin_f bij_f]; exists (F \o f).
- move=> c x y /=; rewrite lin_f; apply/rowP => i.
  by rewrite castmxE !mxE !castmxE /=.
apply/bij_comp => //; exists G => r; rewrite /G /F.
- by rewrite castmxK. - by rewrite castmxKV.
Qed.

Lemma mvector_vect_iso : Vector.axiom D (mvector E).
Proof.
suff: Vector.axiom #|{: Z}| (mvector E).
- apply: vect_axiom_eqdim; rewrite /D card_tagged.
  rewrite sumnE big_map big_enum /=.
  by apply: eq_bigr=> i _; rewrite card_ord.
pose fr (f : mvector E) := \row_(i < #|{: Z}|)
  v2r (f (tag (enum_val i))) 0 (tagged (enum_val i)).
exists fr=> /= [c f g|].
- by apply/rowP=> i; rewrite !mxE !mvE linearP /= !mxE.
pose gr (i : I) (x : 'rV[k]_#|{: Z}|) :=
  r2v (\row_(j < Vector.dim (E i)) x 0 (enum_rank (S j))).
exists (fun x => \mvector_(i : I) gr i x) => [g|r].
- apply/mvectorP=> i; rewrite mvE /fr /gr.
  set r := (X in r2v X); suff ->: r = v2r (g i) by rewrite v2rK.
  by apply/rowP=> j; rewrite !mxE enum_rankK /=.
- apply/rowP=> j; rewrite !mxE !mvE r2vK mxE; congr (_ _ _).
  by apply/(canLR enum_valK)/esym/eqP; rewrite eq_Tagged.
Qed.

Definition mvector_vectMixin := VectMixin mvector_vect_iso.
Canonical mvector_vectType := VectType k (mvector E) mvector_vectMixin.

End ProdVectorVectType.