(* CSE 505 Programming Languages
   Homework 2
   Due: Friday, Oct 23

   Total points for Coq part: 100

   HW 2 requires you to write your own inductive definitions,
   theorems, and proofs. We encourage you to get started early!
*)

Require Import List.
Import ListNotations.
Require Import String.
Require Import ZArith.

Open Scope string_scope.
(* This tactic will be useful in many of the following problems *)
Ltac break_match :=
  match goal with
    | _ : context [ if ?cond then _ else _ ] |- _ =>
     destruct cond as [] eqn:?
    | |- context [ if ?cond then _ else _ ] =>
      destruct cond as [] eqn:?
    | _ : context [ match ?cond with _ => _ end ] |- _ =>
     destruct cond as [] eqn:?
    | |- context [ match ?cond with _ => _ end ] =>
      destruct cond as [] eqn:?
  end.

(* Use break_match to automatically destruct the expression you're
    matching against in a match statement. This is especially useful
    when the expression is complex:
 *)
Lemma break_match_example_1 :
  forall x y z,
    (match (3 * x + y * y + z) with
       | O => true
       | S _ => true
     end) = true.
Proof.
  intros. break_match; auto.
Qed.

(* break_match is also useful for getting rid of pesky let statements: *)
Lemma break_match_example_2 :
  forall p : nat * nat,
    (let (x, y) := p in x + y) = fst p + snd p.
Proof.
  intros. break_match. subst. simpl. reflexivity.
Qed.

(* This is necessary for annoying Coq reasons. *)
Notation length := List.length.

(* [PROBLEM 1 (5 points)]: Prove the following lemmas.
   They will be useful in many of the problems below!
 *)

Lemma orb_false_intro :
  forall b1 b2,
    b1 = false ->
    b2 = false ->
    (orb b1 b2) = false.
Proof.
  intros. rewrite H; rewrite H0.
  simpl. reflexivity.
Qed.

Lemma orb_false_elim :
  forall b1 b2,
    (orb b1 b2) = false ->
    b1 = false /\ b2 = false.
Proof.
  intros.
  destruct b1.
  - simpl in H. inversion H.
  - simpl in *. rewrite H.
    split. reflexivity. reflexivity.
Qed.
  (* About 10 tactics *)

(* END PROBLEM 1 *)

(*
  We will extend IMP with the ability to push and pop heaps.

  In normal IMP, program states just included the heap "h" and
  statement to execute "s".

  In our extended version of IMP, program state will also include
  the current stack of heaps "l", represented as a list.

  There will be two new statements: "PushHeap" and "PopHeap x".
    - "PushHeap" adds the current heap "h" to the beginning of "l".
      Informally, it copies "h" all at once.
    - "PopHeap x" replaces the current heap "h" with the first
      element of "l" *except* "x" maps to "lkup x h" and replaces "l"
      with the tail of "l".  If "l" is the empty list, then
     "PopHeap x" has no effect.
  Both "PushHeap" and "PopHeap x" become Skip in one step.

  Note that there are some other differences from IMP as defined in
  class : Cond takes an "else" case and heaps are represented as lists
  instead of functions.

*)

Set Implicit Arguments.

Definition var := string.

(* We'll start by defining the syntax of our extended IMP. *)

(* Expressions are just like those from IMP seen in lecture. *)
Inductive Expr : Type :=
| Int : nat -> Expr
| Var : var -> Expr
| Add : Expr -> Expr -> Expr
| Mul : Expr -> Expr -> Expr.

(* [PROBLEM 2 (5 points)]
   Add the PushHeap and PopHeap x statements to the Stmt type. *)
Inductive Stmt : Type :=
| Skip : Stmt
| Assign : var -> Expr -> Stmt
| Seq : Stmt -> Stmt -> Stmt
| Cond : Expr -> Stmt -> Stmt -> Stmt
| While : Expr -> Stmt -> Stmt
| PushHeap: Stmt
| PopHeap: var -> Stmt
(*
  Add constructors for PushHeap and PopHeap x here. Remember:
    - "PushHeap" adds the current heap "h" to the beginning of "l".
      Informally, it copies "h" all at once.
    - "PopHeap x" replaces the current heap "h" with the first
      element of "l" *except* "x" maps to "lkup x h" and replaces "l"
      with the tail of "l".  If "l" is the empty list, then
      "PopHeap x" has no effect.
*)
.

(* END PROBLEM 2 *)

(* Next we define the semantics of our language *)

(* Heaps are represented as association lists. *)
Definition Heap := list (var * nat).

Fixpoint lkup (x: var) (h: Heap) :=
  match h with
    | nil => 0
    | (k, v) :: h' => if string_dec x k then v else lkup x h'
  end.

(* Since expressions are unchanged from IMP, their semantics are the same: *)
Inductive Eval : Heap -> Expr -> nat -> Prop :=
| EInt : forall h z,
  Eval h (Int z) z
| EVar : forall h v,
  Eval h (Var v) (lkup v h)
| EAdd : forall h e1 e2 c1 c2 c3,
  Eval h e1 c1 ->
  Eval h e2 c2 ->
  c3 = (c1 + c2) ->
  Eval h (Add e1 e2) c3
| EMul : forall h e1 e2 c1 c2 c3,
  Eval h e1 c1 ->
  Eval h e2 c2 ->
  c3 = (c1 * c2) ->
  Eval h (Mul e1 e2) c3.

(*
  [Problem 3 (5 points)]:
  Define a small-step operational semantics for our extended version of IMP.
  Include all the rules.
*)
Inductive Step : list Heap -> Heap -> Stmt ->
                 list Heap -> Heap -> Stmt -> Prop :=
| step_skip:
  forall hlist h s,
    Step hlist h (Seq Skip s) hlist h s
| step_assign:
  forall hlist h e v n,
    Eval h e n ->
    Step hlist h (Assign v e) hlist ((v,n)::h) Skip
| step_seq:
    forall hlist h s1 hlist' h' s1' s2,
      Step hlist h s1 hlist' h' s1'->
        Step hlist h (Seq s1 s2) hlist' h' (Seq s1' s2)
| step_cond_true:
    forall hlist h e s1 s2 n,
      Eval h e n ->
        n <> 0 ->
          Step hlist h (Cond e s1 s2) hlist h s1
| step_cond_false:
    forall hlist h e s1 s2 n,
      Eval h e n ->
        n = 0 ->
          Step hlist h (Cond e s1 s2) hlist h s2
| step_while_true:
    forall hlist h e s n,
      Eval h e n ->
        n <> 0 ->
          Step hlist h (While e s) hlist h (Seq s (While e s))
| step_while_false:
    forall hlist h e s n,
      Eval h e n ->
        n = 0 ->
          Step hlist h (While e s) hlist h Skip
| step_pushHeap:
    forall hlist h,
      Step hlist h PushHeap (h::hlist) h Skip
| step_popHeap_empty:
    forall h x,
      Step [] h (PopHeap x) [] h Skip
| step_popHeap_nonempty:
    forall h hlhead hltail x,
      Step (hlhead::hltail) h (PopHeap x) hltail ((x,lkup x h)::hlhead) Skip.

(*
  Add the rules (constructors) for the small step semantics of
  our extended version of IMP.  I have 10 rules in my solution.

  * NOTE *
  For statements that involve branching (Cond and While), the
  "then" / "enter loop" branch should be taken when the condition
  expression evaluates to something not equal to 0, and the
  "else" / "exit loop" branch should be taken when the condition
  expression evaluates to 0.
*)
(* END PROBLEM 3 *)

(*
  [PROBLEM 4 (5 points)]
  In a short English paragraph, explain why our language would be much less
  useful if popping a heap did not copy one value from the popped heap.

  Ans: If we just simply pop a heap without changing its value, we are just returning to
  an old stage of the program when all new values in the current heap are not assigned.
  But if we copy a value from the currently heap, this means that we are actually we can have a
  'return value' from the most recent computation (computations between two heaps), and this allow
  us to implement sub-procedures in our program, where we can freely use original vairables without
  worrying about breaking them, and we can get a return value by 'PopHeap retval' operation.
*)

(*
  [PROBLEM 5 (5 points)]
  Give an IMP program with a non-trivial use of PushHeap and PopHeap.

*)

Definition myProg :=
(Seq
  (Seq
    (Seq
      (Assign "x" (Int 0))
      (Seq
        (Assign "y" (Int 1))
        (Assign "n" (Int 10))
      )
    )
    PushHeap
  )
  (Seq
    (While (Var "n")
      (Seq
        (Assign "x0" (Add (Var "x") (Var "y")))
        (Seq
          (Assign "x" (Var "y"))
          (Seq
            (Assign "y" (Var "x0"))
            (Assign "n" (Int 0)) (*should be n = n-1, but there is no minus here*)
          )
        )
      )
    )
    (PopHeap "result")
  )
).

(* Interpreters *)

(*
  In class we saw how to implement and verify a function
  that evaluates expressions:
*)

Fixpoint eval (h: Heap) (e: Expr) : nat :=
  match e with
    | Int z => z
    | Var v => lkup v h
    | Add e1 e2 =>  (eval h e1) + (eval h e2)
    | Mul e1 e2 =>  (eval h e1) * (eval h e2)
  end.

Lemma eval_Eval:
  forall h e c,
  eval h e = c -> Eval h e c.
Proof.
  induction e; intros; simpl in *; subst; try constructor.
  - specialize (IHe1 (eval h e1)).
    specialize (IHe2 (eval h e2)).
    econstructor; eauto.
  - specialize (IHe1 (eval h e1)).
    specialize (IHe2 (eval h e2)).
    econstructor; eauto.
Qed.

Lemma Eval_eval:
  forall h e c,
  Eval h e c -> eval h e = c.
Proof.
  intros.
  induction H; subst; reflexivity.
Qed.

Lemma Eval_eval':
  forall h e,
  Eval h e (eval h e).
Proof.
  intros. remember (eval h e) as c. apply eval_Eval. omega.
Qed.

(* [Problem 6 (5 points)] *)
(* Implement step as a function. *)
(* Hint: Use eq_nat_dec to decide if two nats are equal. *)

Check eq_nat_dec.

Fixpoint step (hlist: list Heap) (h: Heap) (s: Stmt) :
  option (list Heap * Heap * Stmt) :=
  match s with
  | Skip => None
  | Assign v e =>
      Some (hlist, (v,(eval h e))::h, Skip)
  | Seq s1 s2 =>
      match (step hlist h s1) with
      | None =>
          Some (hlist, h, s2)
      | Some (hlist', h', s1')
          => Some (hlist', h', (Seq s1' s2))
      end
  | Cond e s1 s2 =>
      if eq_nat_dec (eval h e) 0 then
        Some (hlist, h, s2)
      else
        Some (hlist, h, s1)
  | While e s =>
      if eq_nat_dec (eval h e) 0 then
        Some(hlist, h, Skip)
      else
        Some (hlist, h, (Seq s (While e s)))
  | PushHeap =>
      Some (h::hlist, h, Skip)
  | PopHeap x =>
      match hlist with
      | [] => Some ([], h, Skip)
      | hd::htail => Some (htail, (x, lkup x h)::hd, Skip)
      end
  end.

(* END PROBLEM 6 *)

(* [Problem 7 (5 points)] *)
(* Prove that only Skip cannot step. *)
Lemma step_None_Skip:
  forall l h s, step l h s = None -> s = Skip.
Proof.
  intros. induction s.
  - intros. reflexivity.
  - intros. inversion H.
  - intros. inversion H.
    break_match. break_match. break_match. inversion H1.
    inversion H1.
  - simpl in *. break_match. inversion H. inversion H.
  - inversion H. break_match.
    + inversion H1.
    + inversion H1.
  - inversion H.
  - inversion H. break_match. inversion H1. inversion H1.
Qed.

(* About 15 tactics *)

(* END PROBLEM 7 *)

(* [Problem 8 (5 points)] *)
(* Prove that your step function is SOUND with respect to the Step relation. *)
Lemma step_Step:
  forall l h s l' h' s',
  step l h s = Some (l', h', s') -> Step l h s l' h' s'.
Proof.
  intros l h s. revert l; revert h.
  induction s.
  - intros. simpl in H. inversion H.
  - intros. simpl in *. inversion H. constructor. apply Eval_eval'.
  - intros. simpl in *.
    destruct (step l h s1) as [[[eqo_hl eqo_h] eqo_s]|] eqn:?.
    + inversion H. constructor.
      apply IHs1 in Heqo. subst.
      apply Heqo.
    + inversion H. subst. apply step_None_Skip in Heqo.
      subst. constructor.
  - intros. simpl in *.
    destruct (eq_nat_dec (eval h e) 0) in H.
    + inversion H. subst. eapply step_cond_false.
      eapply Eval_eval'. apply e0.
    + inversion H. subst. eapply step_cond_true.
      eapply Eval_eval'. apply n.
  - intros. simpl in *.
    destruct (eq_nat_dec (eval h e) 0) in H.
    + inversion H. subst. eapply step_while_false.
      eapply Eval_eval'. apply e0.
    + destruct (step l h s) as [[[eqo_hl eqo_h]]|] eqn:?.
      * inversion H; subst. apply IHs in Heqo.
        eapply step_while_true. apply Eval_eval'. apply n.
      * inversion H; subst. apply step_None_Skip in Heqo.
        subst. econstructor. apply Eval_eval'. apply n.
  - intros. inversion H; subst. constructor.
  - intros. inversion H.
    destruct l.
    + inversion H1; subst. constructor.
    + inversion H1; subst. constructor.
Qed.
(* END PROBLEM 8 *)

(* [Problem 9 (5 points)] *)
(* Prove that your step function is COMPLETE with respect to the Step relation. *)
Lemma Step_step:
  forall l h s l' h' s',
  Step l h s l' h' s' -> step l h s = Some (l', h', s').
Proof.
  intros l h s. revert l h.
  induction s.
  - intros. inversion H.
  - intros. inversion H; subst.
    simpl in *. apply Eval_eval in H7.
    rewrite H7. reflexivity.
  - intros. inversion H; subst.
    + simpl. reflexivity.
    + simpl. apply IHs1 in H7.
      rewrite H7. reflexivity.
  - intros. inversion H; subst.
    + apply Eval_eval in H8.
      simpl. rewrite H8.
      unfold not in H9.
      destruct (eq_nat_dec n 0).
      * apply H9 in e0. inversion e0.
      * reflexivity.
    + simpl in *.
      apply Eval_eval in H8.
      rewrite H8. simpl. reflexivity.
 - intros. inversion H; subst.
    + simpl in *.
      apply Eval_eval in H4.
      rewrite H4.
      destruct (eq_nat_dec n 0).
      * unfold not in H8. apply H8 in e0. inversion e0.
      * reflexivity.
    + simpl in *.
      apply Eval_eval in H4.
      rewrite H4. simpl. reflexivity.
  - intros. inversion H; subst.
    simpl in *. reflexivity.
  - intros. inversion H; subst.
    + simpl in *. reflexivity.
    + simpl in *. reflexivity.
Qed.

(* END PROBLEM 9 *)

(* StepN as seen in class *)
Inductive StepN : list Heap -> Heap -> Stmt -> nat ->
                  list Heap -> Heap -> Stmt -> Prop :=
| StepN_refl : forall l h s,
  StepN l h s 0 l h s
| StepN_step : forall l h s l' h' s' l'' h'' s'' n,
  Step l h s l' h' s' ->
  StepN l' h' s' n l'' h'' s'' ->
  StepN l h s (S n) l'' h'' s''.

(* [Problem 10 (5 points)] *)
(* Implement stepn as a function. *)
Fixpoint stepn (l: list Heap) (h: Heap) (s: Stmt) (n: nat) :
  option (list Heap * Heap * Stmt) :=
  match n with
  | 0 => Some (l, h, s)
  | S n' =>
      match step l h s with
      | None => None
      | Some (l', h', s') =>
          stepn l' h' s' n'
      end
  end.

(* END PROBLEM 10 *)

(* [Problem 11 (5 points)] *)
(* Prove your stepn function SOUND. *)
Lemma stepn_StepN:
  forall n l h s l' h' s',
  stepn l h s n = Some (l', h', s') ->
  StepN l h s n l' h' s'.
Proof.
  induction n.
  - intros. inversion H; subst.
    constructor.
  - intros. simpl in H.
    destruct (step l h s) as [[[myl myh] mys]|] eqn:?.
    + apply IHn in H.
      econstructor.
      * apply step_Step in Heqo. eapply Heqo.
      * apply H.
    + inversion H; subst.
Qed.
  (* About 14 tactics *)

(* END PROBLEM 11 *)

(* [Problem 12 (5 points)] *)
(* Prove your stepn function COMPLETE. *)
Lemma StepN_stepn:
  forall l h s n l' h' s',
  StepN l h s n l' h' s' ->
  stepn l h s n = Some (l', h', s').
Proof.
  intros l h s n. revert l h s.
  induction n.
  - intros.
    inversion H; subst.
    simpl. reflexivity.
  - intros.
    inversion H; subst.
    simpl in *.
    apply IHn in H5.
    apply Step_step in H1.
    rewrite H1. apply H5.
Qed.

(* END PROBLEM 12 *)

(* The run function, which takes up to n steps. *)
Fixpoint run (n: nat) (l: list Heap) (h: Heap) (s: Stmt) : list Heap * Heap * Stmt :=
  match n with
    | O => (l, h, s)
    | S m =>
      match step l h s with
        | Some (l', h', s') => run m l' h' s'
        | None => (l, h, s)
      end
  end.

(* [Problem 13 (5 points)] *)
(* Define the StepStar relation, which corresponds to taking any number of steps. *)
Inductive StepStar : list Heap -> Heap -> Stmt ->
                     list Heap -> Heap -> Stmt -> Prop :=
| step_star_0:
    forall l h s, StepStar l h s l h s
| step_star_more:
    forall l h s l1 h1 s1 l2 h2 s2,
      Step l h s l1 h1 s1
        -> StepStar l1 h1 s1 l2 h2 s2
            -> StepStar l h s l2 h2 s2.

(* END PROBLEM 13 *)

(* [Problem 14 (5 points)] *)
(* Prove that run is SOUND with respect to StepStar. *)
Lemma run_StepStar:
  forall n l h s l' h' s',
  run n l h s = (l', h', s') -> StepStar l h s l' h' s'.
Proof.
  induction n.
  - intros. simpl in *. inversion H; subst.
    constructor.
  - intros. simpl in *.
    destruct (step l h s) as [[[myl myh] mys]|] eqn:?.
    + apply step_Step in Heqo.
      apply IHn in H.
      econstructor.
      * eapply Heqo.
      * apply H.
    + inversion H; subst.
      constructor.
Qed.

(* END PROBLEM 14 *)

(* [Problem 15 (5 points)] *)
(* Prove that running a state that can't step gives that same state. *)
Lemma nostep_run_refl:
  forall l h s, step l h s = None ->
           forall n, run n l h s = (l, h, s).
Proof.
  intros.
  induction n.
  - simpl. reflexivity.
  - simpl. rewrite H.
    reflexivity.
Qed.
(* END PROBLEM 15 *)

(* [Problem 16 (5 points)] *)
(* Prove that two consecutive runs are the same as one bigger run. *)
Lemma run_combine:
  forall m n l h s l' h' s' l'' h'' s'',
  run m l h s = (l', h', s') ->
  run n l' h' s' = (l'', h'', s'') ->
  run (m + n) l h s = (l'', h'', s'').
Proof.
  induction m.
  - intros. simpl. inversion H; subst. apply H0.
  - intros. simpl.
    destruct (step l h s) as [[[myl myh] mys]|] eqn:?.
    + eapply IHm.
      simpl in H. rewrite Heqo in H; simpl.
      eapply H. apply H0.
    + simpl in H. rewrite Heqo in H; simpl.
      inversion H; subst.
      apply step_None_Skip in Heqo. subst.
      destruct n.
      * simpl in *. apply H0.
      * simpl in H0. apply H0.
Qed.

(* END PROBLEM 16 *)

(* Here we define what it means for a statement to contain a while. *)
Fixpoint hasWhile (s: Stmt) : bool :=
  match s with
    | Skip => false
    | Assign _ _ => false
    | Seq s1 s2 => orb (hasWhile s1) (hasWhile s2)
    | Cond _ s1 s2 =>  orb (hasWhile s1) (hasWhile s2)
    | While _ _ => true
    | PushHeap => false
    | PopHeap _ => false
  end.

(* Here we define the number of PushHeap statements contained in a statement. *)
Fixpoint nPushHeap (s: Stmt) : nat :=
  match s with
    | Skip => 0
    | Assign _ _ => O
    | Seq s1 s2 => nPushHeap s1 + nPushHeap s2
    | Cond _ s1 s2 => nPushHeap s1 + nPushHeap s2
    | While _ s1 => nPushHeap s1
    | PushHeap => 1
    | PopHeap _ => 0
  end.

(*
  [Problem 17 (5 points)]
  Prove that if we take a step from a statement without any whiles,
  then the resulting statement still has no whiles.
*)
Lemma hasWhileStep:
  forall l h s l' h' s',
    Step l h s l' h' s' ->
    hasWhile s = false ->
    hasWhile s' = false.
Proof.
  intros l h s; revert l h.
  induction s.
  - intros. inversion H.
  - intros. inversion H; subst. simpl. reflexivity.
  - intros. inversion H; subst.
    + simpl in H0. apply H0.
    + simpl in H0. apply orb_false_elim in H0.
      inversion H0. simpl.
      rewrite H2.
      apply IHs1 in H8.
      * rewrite H8. simpl. reflexivity.
      * apply H1.
  - intros. simpl in *.
    apply orb_false_elim in H0. inversion H0.
    inversion H; subst.
    + apply H1.
    + apply H2.
  - intros. simpl in H0. inversion H0.
  - intros. inversion H; subst. simpl; reflexivity.
  - intros. inversion H; subst.
    + simpl; reflexivity.
    + simpl; reflexivity.
Qed.
(* END PROBLEM 17 *)

(* *** A BIT TRICKY! *** *)
(*
  [Problem 18 (10 points)]

  State and prove the following property:
    If statement s has no While loops and from the empty stack
    (l = nil) and empty heap (h = nil), s can step to stack l',
    heap h', and statement s', then the length of l' does not
    exceed the number of PushHeap statements in s (the original
    statement).

  Hints:
    - You will need two lemmas to prove this.
    - Think carefully about your induction hypotheses.
*)

Lemma Heap_onestep:
forall s l h l' h' s',
  Step l h s l' h' s'
  -> hasWhile s = false -> le (length l' + nPushHeap s') ((length l) + nPushHeap s).
Proof.
  induction s.
  - intros. simpl in *. inversion H; subst.
  - intros. simpl in *. inversion H; subst. simpl. omega.
  - intros. simpl in *. inversion H; subst.
    + omega.
    + apply orb_false_elim in H0; inversion H0. simpl in *.
      assert (HH1: length l' + nPushHeap s1' <= length l + nPushHeap s1
        -> length l' + (nPushHeap s1' + nPushHeap s2) <= length l + (nPushHeap s1 + nPushHeap s2)).
      * omega.
      * eapply HH1. eapply IHs1.
        apply H8. apply H1.
  - intros. simpl in *. inversion H; subst.
    + omega.
    + omega.
  - intros. inversion H0.
  - intros. simpl. inversion H; subst. simpl. omega.
  - intros. simpl. inversion H; subst.
    + simpl. omega.
    + simpl. omega.
Qed.

Theorem Heap_n_step:
  forall n s l h l' h' s',
  StepN l h s n l' h' s'
  -> hasWhile s = false -> le (length l' + nPushHeap s') (nPushHeap s + length l).
Proof.
  induction n.
  - intros. inversion H. subst. simpl. omega.
  - intros. inversion H. subst.
    assert (H_l'0_l': length l' +  nPushHeap s' <= nPushHeap s'0 + length l'0).
    + eapply IHn. eapply H6. eapply hasWhileStep.
      apply H2. apply H0.
    + apply Heap_onestep in H2.
      assert (HH1: length l' + nPushHeap s' <= length l'0 + nPushHeap s'0
                  -> length l'0 + nPushHeap s'0 <= length l + nPushHeap s
                  -> length l' + nPushHeap s' <= nPushHeap s + length l).
      * omega.
      * apply HH1. omega. apply H2.
      * apply H0.
Qed.

Theorem Heap_fromEmpty_step:
  forall n s l' h' s',
  StepN [] [] s n l' h' s'
  -> hasWhile s = false -> le (length l') (nPushHeap s).
Proof.
  intros. specialize (Heap_n_step).
  intros. apply H1 in H.
  simpl in H.
  assert (H_Finally: length l' + nPushHeap s' <= nPushHeap s + 0 -> length l' <= nPushHeap s).
  - omega.
  - apply H_Finally.
    apply H.
  - apply H0.
Qed.

(*
  [Problem 19 (5 points)]

  Prove the previous claim is false if we allow s to contain
  While loops.

  Hint:
    - No need to use induction.
*)

Eval compute in run 5 [] [] (While (Int 1) (PushHeap)).

Theorem Heap_wrong:
~(forall n s l' h' s', StepN [] [] s n l' h' s'
    -> hasWhile s = true -> le (length l') (nPushHeap s)).
Proof.
  intro H.
  specialize (H 5 (While (Int 1) (PushHeap)) [[]; []] [] (Seq Skip (While (Int 1) PushHeap))).
  simpl in H.
  assert (H0: StepN [] [] (While (Int 1) PushHeap) 5 [[]; []] []
      (Seq Skip (While (Int 1) PushHeap))).
  + apply stepn_StepN; reflexivity.
  + intuition.
Qed.


MacBook-Air:bin billw$ ./coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Variable D : Set.
D is assumed
Warning: D is declared as a parameter because it is at a global level

Coq < Variable P : D -> Prop.
P is assumed
Warning: P is declared as a parameter because it is at a global level

Coq < Hypothesis EM : forall A:Prop, A \/ ~ A.
EM is assumed
Warning: EM is declared as a parameter because it is at a global level

Coq < Lemma drinker : exists x:D, P x -> forall x:D, P x.
1 subgoal

  ============================
   exists x : D, P x -> forall x0 : D, P x0

drinker < elim (EM (exists x, ~ P x)).
2 subgoals

  ============================
   (exists x : D, ~ P x) -> exists x : D, P x -> forall x0 : D, P x0

subgoal 2 is:
 ~ (exists x : D, ~ P x) -> exists x : D, P x -> forall x0 : D, P x0

drinker < intro Non_drinker; elim Non_drinker; intros Tom Tom_does_not_drink.
2 subgoals

  Non_drinker : exists x : D, ~ P x
  Tom : D
  Tom_does_not_drink : ~ P Tom
  ============================
   exists x : D, P x -> forall x0 : D, P x0

subgoal 2 is:
 ~ (exists x : D, ~ P x) -> exists x : D, P x -> forall x0 : D, P x0

drinker < exists Tom; intro Tom_drinks.
2 subgoals

  Non_drinker : exists x : D, ~ P x
  Tom : D
  Tom_does_not_drink : ~ P Tom
  Tom_drinks : P Tom
  ============================
   forall x : D, P x

subgoal 2 is:
 ~ (exists x : D, ~ P x) -> exists x : D, P x -> forall x0 : D, P x0

drinker < absurd (P Tom); trivial.
1 subgoal

  ============================
   ~ (exists x : D, ~ P x) -> exists x : D, P x -> forall x0 : D, P x0

drinker < Variable d : D.
d is assumed
Warning: d is declared as a parameter because it is at a global level

drinker < intro No_nondrinker; exists d; intro d_drinks.
1 subgoal

  No_nondrinker : ~ (exists x : D, ~ P x)
  d_drinks : P d
  ============================
   forall x : D, P x

drinker < intro Dick; elim (EM (P Dick)); trivial.
1 subgoal

  No_nondrinker : ~ (exists x : D, ~ P x)
  d_drinks : P d
  Dick : D
  ============================
   ~ P Dick -> P Dick

drinker < intro Dick_does_not_drink; absurd (exists x, ~ P x); trivial.
1 subgoal

  No_nondrinker : ~ (exists x : D, ~ P x)
  d_drinks : P d
  Dick : D
  Dick_does_not_drink : ~ P Dick
  ============================
   exists x : D, ~ P x

drinker < exists Dick; trivial.
No more subgoals.

drinker < Qed.
elim (EM (exists x, ~ P x)).
 intro Non_drinker; elim Non_drinker; intros Tom Tom_does_not_drink.
 exists Tom; intro Tom_drinks.
 absurd (P Tom); trivial.

 intro No_nondrinker; exists d; intro d_drinks.
 intro Dick; elim (EM (P Dick)); trivial.
 intro Dick_does_not_drink; absurd (exists x, ~ P x); trivial.
 exists Dick; trivial.

drinker is defined

Coq < End predicate_calculus.
Error: There is nothing to end.

Coq < Check drinker.
drinker
     : exists x : D, P x -> forall x0 : D, P x0

Coq <


From WiSE Require Import imp.
From Coq Require Import ZArith String Bool Lia.

(** * A Naive Constraint Solver/simplifier *)

(** Smart constructor to build an [Add] term *)
Definition mk_add (a1 : aexpr) (a2 : aexpr) : aexpr :=
  match a1, a2 with
  | Cst c1, Cst c2 => Cst (c1 + c2)%Z
  | _, Sub a2_1 a2_2 =>
    if aeq a1 a2_2 then a2_1
    else Add a1 a2
  | _, _ => Add a1 a2
  end.

  (** Smart constructor to build a [Sub] term *)
Definition mk_sub (a1 : aexpr) (a2 : aexpr) : aexpr :=
  match a1, a2 with
  | Cst c1, Cst c2 => Cst (c1 - c2)%Z
  | _, Add a2_1 a2_2 =>
    if aeq a1 a2_1 then Sub (Cst 0) a2_2
    else if aeq a1 a2_2 then Sub (Cst 0) a2_1
    else Sub a1 a2
  | _, _ => Sub a1 a2
  end.

(** Basic, non-exhaustive simplification of arithmetic expressions *)
Fixpoint asimp (a: aexpr) : aexpr :=
  match a with
  | Cst _   => a
  | Var _   => a
  | Add a b => mk_add (asimp a) (asimp b)
  | Sub a b => mk_sub (asimp a) (asimp b)
  end.

Lemma mk_add_correct:
  forall env a1 a2, aeval env (Add a1 a2) = aeval env (mk_add a1 a2).
Proof.
  intros. Opaque aeq.
  destruct a1, a2; simpl; auto.
  all:
    destruct aeq eqn:Heq; auto;
    apply aeq_spec in Heq as <-; simpl; lia.
Qed.

Lemma mk_sub_correct:
  forall env a1 a2, aeval env (Sub a1 a2) = aeval env (mk_sub a1 a2).
Proof.
  intros. Opaque aeq.
  destruct a1, a2; simpl; auto.
  all:
    destruct (aeq _ a2_1) eqn:Heq1; [
      apply aeq_spec in Heq1 as <-; simpl; lia |
    ];
    destruct (aeq _ a2_2) eqn:Heq2; [
      apply aeq_spec in Heq2 as <-; simpl; lia |
    ]; reflexivity.
Qed.

Theorem asimp_correct:
  forall env a, aeval env a = aeval env (asimp a).
Proof.
  induction a; simpl; auto.
  + rewrite IHa1, IHa2.
    now rewrite <- mk_add_correct.
  + rewrite IHa1, IHa2.
    now rewrite <- mk_sub_correct.
Qed.

Definition mk_and (b1 b2 : bexpr) : bexpr :=
  match b1, b2 with
  | Bcst false, _ | _, Bcst false => Bcst false   (* Null Law *)
  | Bcst true, _ => b2                            (* Identity Law *)
  | _, Bcst true => b1                            (* Identity Law *)
  | lhs, Bnot rhs =>
    if beq lhs rhs
    then Bcst false                               (* Inverse Law *)
    else Band lhs (Bnot rhs)
  | Bnot lhs, rhs =>
    if beq lhs rhs
    then Bcst false                               (* Inverse Law *)
    else Band (Bnot lhs) rhs
  | _, _ =>
    if beq b1 b2
    then b1                                       (* Idempotent Law *)
    else Band b1 b2
  end.

Definition mk_not (b : bexpr) : bexpr :=
  match b with
  | Bnot lhs => lhs
  | Bcst true => Bcst false
  | Bcst false => Bcst true
  | lhs => Bnot lhs
  end.

(** Simplification of boolean formulas *)
Fixpoint bsimp (b : bexpr) : bexpr :=
  match b with
  | Bcst _ => b
  | Band lhs rhs => mk_and (bsimp lhs) (bsimp rhs)
  | Bnot lhs => mk_not (bsimp lhs)
  | Ble x y =>
    match asimp x, asimp y with
    | Cst x, Cst y => Bcst (x <=? y)%Z
    | x, y => Ble x y
    end
  | Beq x y =>
    match asimp x, asimp y with
    | Cst x, Cst y => Bcst (x =? y)%Z
    | x, y => if aeq x y then Bcst true else Beq x y
    end
  end.

Lemma mk_and_correct:
  forall env b1 b2,
    beval env (Band b1 b2) = beval env (mk_and b1 b2).
Proof.
  intros. Opaque beq.
  destruct b1, b2; simpl; auto.
  all: try now destruct b.
  all: try now destruct b, b0.
  all: try now destruct b; rewrite Bool.andb_comm.
  - destruct beq eqn:Heq1; auto.
    apply beq_spec in Heq1 as [=->->].
    now rewrite Bool.andb_diag.
  - destruct beq eqn:Heq1; auto.
    apply beq_spec in Heq1 as <-.
    apply Bool.andb_negb_r.
  - destruct beq eqn:Heq1; auto.
    apply beq_spec in Heq1 as [=->->].
    now rewrite Bool.andb_diag.
  - destruct beq eqn:Heq1; auto.
    apply beq_spec in Heq1 as <-.
    apply Bool.andb_negb_r.
  - destruct beq eqn:Heq1; auto.
    apply beq_spec in Heq1 as ->.
    apply Bool.andb_negb_l.
  - destruct beq eqn:Heq1; auto.
    apply beq_spec in Heq1 as ->.
    apply Bool.andb_negb_l.
  - destruct beq eqn:Heq1; auto.
    apply beq_spec in Heq1 as <-; simpl.
    rewrite Bool.negb_involutive.
    apply Bool.andb_negb_l.
  - destruct beq eqn:Heq1; auto.
    apply beq_spec in Heq1 as ->; simpl.
    apply Bool.andb_negb_l.
  - destruct beq eqn:Heq1; auto.
    apply beq_spec in Heq1 as <-; simpl.
    apply Bool.andb_negb_r.
  - destruct beq eqn:Heq1; auto.
    apply beq_spec in Heq1 as [=->->].
    now rewrite Bool.andb_diag.
Qed.

Lemma mk_not_correct:
  forall env b,
    beval env (Bnot b) = beval env (mk_not b).
Proof.
  intros env []; simpl; auto.
  - now destruct b.
  - now rewrite Bool.negb_involutive.
Qed.

(** Correctness of [bsimp] *)
Lemma bsimp_correct:
  forall env b,
    beval env (bsimp b) = beval env b.
Proof.
  Opaque asimp aeq beq.
  induction b; simpl; auto.
  - destruct (asimp a) eqn:Heq1, (asimp a0) eqn:Heq2.
    all: now rewrite (asimp_correct _ a), (asimp_correct _ a0), Heq1, Heq2.
  - destruct (asimp a) eqn:Heq1, (asimp a0) eqn:Heq2.
    all: try now rewrite (asimp_correct _ a), (asimp_correct _ a0), Heq1, Heq2.
    destruct aeq eqn:Heq.
    apply aeq_spec in Heq as [=->].
    rewrite (asimp_correct _ a), (asimp_correct _ a0), Heq1, Heq2.
    simpl. now rewrite Z.eqb_refl.
    now rewrite (asimp_correct _ a), (asimp_correct _ a0), Heq1, Heq2.
    destruct aeq eqn:Heq.
    apply aeq_spec in Heq as [=->->].
    rewrite (asimp_correct _ a), (asimp_correct _ a0), Heq1, Heq2.
    simpl. now rewrite Z.eqb_refl.
    now rewrite (asimp_correct _ a), (asimp_correct _ a0), Heq1, Heq2.
    destruct aeq eqn:Heq.
    apply aeq_spec in Heq as [=->->].
    rewrite (asimp_correct _ a), (asimp_correct _ a0), Heq1, Heq2.
    simpl. now rewrite Z.eqb_refl.
    now rewrite (asimp_correct _ a), (asimp_correct _ a0), Heq1, Heq2.
  - rewrite <- mk_not_correct; simpl.
    now rewrite IHb.
  - rewrite <- mk_and_correct; simpl.
    now rewrite IHb1, IHb2.
Qed.

Inductive sat : Type :=
  | SAT
  | UNSAT
  | MAYBE.

(** An extremely naive sover *)
Definition solver (b : bexpr) : sat :=
  match bsimp b with
  | Bcst true => SAT
  | Bcst false => UNSAT
  | _ => MAYBE
  end.

(** [solver] is correct (but absolutely not complete) *)
Lemma solver_correct:
  forall b,
    (solver b = UNSAT -> forall env, beval env b = false) /\
    (solver b = SAT ->   exists env, beval env b = true).
Proof.
  intros. split.
  - intros H env. unfold solver in H.
    destruct (bsimp b) eqn:Heq; try easy.
    destruct b0; try easy.
    now rewrite <- bsimp_correct, Heq.
  - intros H. unfold solver in H.
    destruct (bsimp b) eqn:Heq; try easy.
    destruct b0; try easy.
    exists (fun _ => 0%Z).
    now rewrite <- bsimp_correct, Heq.
Qed.

Definition is_sat (b : bexpr) : bool :=
  match solver b with
  | SAT => true
  | _ => false
  end.


Require Export Coq.Lists.ListSet.
Require Export Coq.Lists.List.
Require Export Coq.Bool.Bool.
Require Export Coq.Classes.RelationClasses.
Require Export maps_int.
Require Export assettheory_int.

Class AssetMapping (A N m: Type) {Mp: Maps A N m} {As: AssetTheory A N m}: Type := {
  (*====================functions=======================*)

  aMR : m -> m -> Prop;

  (*===========Axioms - Lemmas - Theorems====================*)
  assetMappingRefinement:
    forall x y z: m, aMR x x /\ aMR x y -> aMR y z ->  aMR x z;
  amRefCompositional:
    forall (am1 am2: m), aMR am1 am2 ->
      (unique_ am1) /\ (unique_ am2) ->
        forall (anSet: set A),
          forall (aSet: set N) (defaultT: N),
              assetRef (set_union Asset_dec aSet (maps defaultT am1 anSet))
                (set_union Asset_dec aSet (maps defaultT am2 anSet)) /\
                  wfProduct (set_union Asset_dec aSet (maps defaultT am1 anSet)) ->
                    wfProduct (set_union Asset_dec aSet (maps defaultT am2 anSet))

}.


From discprob.basic Require Import base order nify.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.rec Require Import karp span2.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
Require Import Reals Fourier ProofIrrelevance FunctionalExtensionality.
Require Import Psatz.
Require Import Coq.omega.Omega.
Require Import Ranalysis5.
Global Set Bullet Behavior "Strict Subproofs".

Module decreasing_rec.
Section decreasing_rec.
Variable X: eqType.
Variable B : X → finType.
Variable size: X → R.
Variable msr: X → R.
Variable Ωh: ∀ x, distrib (B x).
Variable h: ∀ x: X, rvar (Ωh x) X.
Variable d: R.
Variable msr_cutoff: R.
Hypothesis cutoff_non_neg: 0 ≤ msr_cutoff.
Hypothesis hmsr_shrink:
  ∀ z i, d < size z → msr (h z i) ≤ msr z - 1.
Hypothesis hmsr_below: ∀ x n, msr x ≤ msr_cutoff → size ((h x) n) <= d.
Hypothesis hrange1: ∀ x n, size ((h x) n) ≤ size x.
Hypothesis hrange2: ∀ x n, d < size x →  0 ≤ size ((h x) n).

Lemma recN_h_decreasing n z x:
  (rvar_comp (recN_rvar h z n) size) x ≤ size z.
Proof.
  revert z x; induction n as [| n IH]; rewrite //=.
  - reflexivity.
  - intros. destruct x as (x&s).
    specialize (IH ((h z) x) s). rewrite //= in IH.
    specialize (hrange2 z x). etransitivity; eauto.
Qed.

Lemma hinf_0_aux1:
  ∀ r z, size z ≤ r → pr_gt (rvar_comp (h z) size) r = 0.
Proof.
  intros r z Hbelow.
  rewrite /pr_gt /pr SeriesC_fin_big.
  apply big1 => i ?.
  destruct (Rgt_dec) as [Hgt|?] => //=.
  apply Rgt_not_le in Hgt.
  exfalso; apply Hgt. specialize (hrange1 z i). etransitivity; eauto.
Qed.

Lemma hinf_0_aux2:
  ∀ r z n, size z ≤ r → pr_gt (rvar_comp (recN_rvar h z n) size) r = 0.
Proof.
  intros r z n Hbelow.
  rewrite /pr_gt /pr SeriesC_fin_big.
  apply big1 => i ?.
  destruct (Rgt_dec) as [Hgt|?] => //=.
  apply Rgt_not_le in Hgt.
  exfalso; apply Hgt.
  etransitivity; first apply recN_h_decreasing; eauto.
Qed.

Lemma hinf_decreasingS:
  ∀ z r n, pr_gt (rvar_comp (recN_rvar h z (S n)) size) r
               ≤ pr_gt (rvar_comp (recN_rvar h z n) size) r.
Proof.
  intros z r n.
  rewrite recN_pr_gt'.
  rewrite /pr_gt.
  rewrite pr_gt_alt_comp.
  rewrite /index_enum.
  rewrite [@Finite.enum]unlock //=.
  rewrite (img_fin_big' _ (λ i, (pr_eq _ i * pr (rvar_dist (rvar_comp (h i) size))
                                                (λ a, Rgt_dec ((rvar_comp (h i) size) a) r)))
                          (λ i, true)).
  rewrite (img_fin_big' _ (λ i, if ((Rgt_dec (size i) r)) then
                                  pr_eq _ i
                                else
                                  0) (λ i, true)).
  eapply Rle_bigr => i _.
  destruct (Rgt_dec) as [?|Hngt] => //=.
 -  rewrite -[a in _ ≤ a]Rmult_1_r.
    apply Rmult_le_compat_l.
    * apply Rge_le, ge_pr_0.
    * apply pr_le_1.
  - apply Rnot_gt_le in Hngt. specialize (hinf_0_aux1 _ _ Hngt).
    rewrite /pr_gt //= => ->; fourier.
Qed.

Lemma hinf_decreasing:
  ∀ z r n n', (le n n') →
              pr_gt (rvar_comp (recN_rvar h z n') size) r
                    ≤ pr_gt (rvar_comp (recN_rvar h z n) size) r.
Proof.
  induction 1 as [| ? ? IHle].
  - reflexivity.
  - etransitivity; first apply hinf_decreasingS. done.
Qed.

Lemma hinf_decreasing0:
  ∀ z r n n', (le n n') →
              pr_gt (rvar_comp (recN_rvar h z n) size) r = 0 →
              pr_gt (rvar_comp (recN_rvar h z n') size) r = 0.
Proof.
  intros ???? Hle Hgt. apply (Rle_antisym).
  - etransitivity; last (right; apply Hgt).
    apply hinf_decreasing; auto.
  - rewrite /pr_gt. apply Rge_le, ge_pr_0.
Qed.

Lemma hinf_0_aux3:
  ∀ z, pr_gt (rvar_comp (recN_rvar h z (S (Z.to_nat (Rceil (msr z))))) size) d = 0.
Proof.
  intros z.
  remember (Z.to_nat (Rceil (msr z))) as k eqn:Hk.
  revert z Hk.
  induction k as [k IH] using lt_wf_ind. intros z (* Hlt *) Hk.
  destruct k.
  * rewrite /pr_gt.
    assert (msr z ≤ msr_cutoff) as Hbelow.
    {
      case (Rle_dec (msr z) msr_cutoff) as [Hle|Hnle]; auto.
      cut (msr z ≤ 0); first (intros; fourier).
      apply Rnot_le_gt in Hnle.
      assert (0 <= (Rceil (msr z)))%Z.
      { rewrite -Rceil_0. apply Rceil_mono. fourier. }
      assert ( Rceil 0 = (Rceil (msr z)))%Z as Hz.
      {
        rewrite Rceil_0. replace 0%nat with (Z.to_nat 0) in Hk by auto.
        apply Z2Nat.inj; omega.
      }
      apply Rnot_lt_le => Hlt'. apply Rceil_mono_strict in Hlt';
          last apply frac_part_0.
      omega.
    }
    rewrite //=.
    rewrite /pr_gt /pr //= ?SeriesC_fin_big.
    apply big1.  intros (i&?) Hin.
    destruct (Rgt_dec) as [Hgt|Hngt] => //.
    exfalso. apply Rgt_not_le in Hgt. apply Hgt.
    apply hmsr_below. eauto.
  * case (Rlt_dec d (size z)) as [Hlt|Hnlt]; last (by apply hinf_0_aux2, Rnot_lt_le).
    rewrite recN_pr_gt.
    rewrite big_seq_cond.
    apply big1. intros i. move/andP=>[Hin _].
    destruct i as (i&Hin').
    clear Hin. generalize Hin'. apply img_alt in Hin' as (x&Hin) => Hin'.
    generalize (hmsr_shrink z x) => Hle_size; rewrite Hin in Hle_size.
    apply Rmult_eq_0_compat_l.
    rewrite /sval.
    destruct (Rle_dec 0 (msr i)) as [Hlei|Hlt0%Rnot_le_gt]; last first.
    {
      assert (msr i ≤ msr_cutoff) as Hbelow by nra.
      assert (1 <= (S k))%coq_nat as Hto1 by omega.
      apply (hinf_decreasing0 _ _ _ _ Hto1).
      rewrite //=.
      rewrite /pr_gt /pr //= ?SeriesC_fin_big.
      apply big1.  intros (i'&?) _.
      destruct (Rgt_dec) as [Hgt|Hngt] => //.
      exfalso. apply Rgt_not_le in Hgt. apply Hgt.
      apply hmsr_below. eauto.
    }
    assert (le (Z.to_nat (Rceil (msr i))) k) as Hlek.
    {
    apply Rceil_mono in Hle_size.
    rewrite Rceil_minus_1 in Hle_size.
    apply Z2Nat.inj_le in Hle_size.
    - rewrite Z2Nat.inj_sub in Hle_size; last omega.
      replace (Z.to_nat 1) with 1%nat in Hle_size by auto with *.
      omega.
    - rewrite -Rceil_0. apply Rceil_mono. done.
    - transitivity (Rceil (msr i)); auto.
      rewrite -Rceil_0. apply Rceil_mono. done.
    - done.
    }
    assert (le (S (Z.to_nat (Rceil (msr i)))) (S k)) as HleSk.
    { omega. }
    apply (hinf_decreasing0 _ _ _ _ HleSk).
    apply IH; auto; try omega.
Qed.

Lemma hinf_0:
  ∀ z eps, eps > 0 → ∃ n, pr_gt (rvar_comp (recN_rvar h z n) size) d < eps.
Proof.
  intros z eps Hgt0.
  exists (S (Z.to_nat (Rceil (msr z)))).
  apply (Rle_lt_trans _ 0); last fourier.
  right; apply hinf_0_aux3.
Qed.
End decreasing_rec.
End decreasing_rec.

Module decreasing_rec_binary.
Section decreasing_rec_binary.
Variable X: eqType.
Variable B : X → finType.
Variable size: X → R.
Variable Ωh: ∀ x, distrib (B x).
Variable h: ∀ x: X, rvar (Ωh x) [eqType of X * X].
Variable d: R.
Hypothesis d_non_neg: 0 ≤ d.
Hypothesis hrange_shrink:
  ∀ x n, d < size x → size (fst ((h x) n)) + size (snd ((h x) n)) ≤ size x - 1.
Hypothesis hrange11: ∀ x n, size (fst ((h x) n)) ≤ size x.
Hypothesis hrange21: ∀ x n, size (snd ((h x) n)) ≤ size x.
Hypothesis hrange12: ∀ x n, d < size x →  0 ≤ size (fst ((h x) n)).
Hypothesis hrange22: ∀ x n, d < size x →  0 ≤ size (snd ((h x) n)).

Lemma recN_h_decreasing n z φ k x:
  (rvar_comp (recN_rvar (hpath _ _ _ h φ) (k, z) n) (λ x, size (snd x))) x ≤ size z.
Proof.
  revert z k x; induction n as [| n IH]; rewrite //=.
  - reflexivity.
  - intros. destruct x as (x&s).
    destruct (φ k).
    * move: x s. rewrite /Bn//= => x s.
      specialize (IH (fst ((h z) x)) (S k)).
      rewrite //= in IH. specialize (hrange12 z x). etransitivity; eauto.
    * move: x s. rewrite /Bn//= => x s.
      specialize (IH (snd ((h z) x)) (S k)).
      rewrite //= in IH. specialize (hrange22 z x). etransitivity; eauto.
Qed.

Lemma hinf_0_aux11:
  ∀ r z, size z ≤ r → pr_gt (rvar_comp (h z) (λ x, size (fst x))) r = 0.
Proof.
  intros r z Hbelow.
  rewrite /pr_gt /pr SeriesC_fin_big.
  apply big1 => i _.
  destruct (Rgt_dec) as [Hgt|?] => //=; [].
  rewrite //= in Hgt. generalize (hrange11 z i) => //=; nra.
Qed.

Lemma hinf_0_aux21:
  ∀ r z, size z ≤ r → pr_gt (rvar_comp (h z) (λ x, size (snd x))) r = 0.
Proof.
  intros r z Hbelow.
  rewrite /pr_gt /pr SeriesC_fin_big.
  apply big1 => i _.
  destruct (Rgt_dec) as [Hgt|?] => //=; [].
  rewrite //= in Hgt. generalize (hrange21 z i) => //=; nra.
Qed.

Lemma hinf_0_aux_below:
  ∀ r z n φ k,
    size z ≤ r → pr_gt (rvar_comp (recN_rvar (hpath _ _ _ h φ) (k, z) n) (λ x, size (snd x))) r = 0.
Proof.
  intros r z n φ k Hbelow.
  rewrite /pr_gt /pr SeriesC_fin_big.
  apply big1 => i _.
  destruct (Rgt_dec) as [Hgt|?] => //=; [].
  apply Rgt_not_le in Hgt. exfalso; apply Hgt.
  etransitivity; first apply recN_h_decreasing; eauto.
Qed.

Lemma hinf_decreasingS:
  ∀ z r n φ k, pr_gt (rvar_comp (recN_rvar (hpath _ _ _ h φ) (k, z) (S n)) (λ x, size (snd x))) r
               ≤ pr_gt (rvar_comp (recN_rvar (hpath _ _ _ h φ) (k, z) n) (λ x, size (snd x))) r.
Proof.
  intros z r n φ k.
  rewrite recN_pr_gt'.
  rewrite /pr_gt.
  rewrite pr_gt_alt_comp.
  eapply Rle_bigr => i Hin.
  destruct (Rgt_dec) as [?|Hle] => //=.
  - rewrite -[a in _ ≤ a]Rmult_1_r.
    apply Rmult_le_compat_l.
    * apply Rge_le, ge_pr_0.
    * apply pr_le_1.
  - rewrite //=. destruct i as ((k'&?)&?). rewrite /hpath//=.
    rewrite //= in Hle. apply Rnot_gt_le in Hle.
    destruct (φ k').
    * specialize (hinf_0_aux11 _ _ Hle).
      rewrite /pr_gt //= => ->; fourier.
    * specialize (hinf_0_aux21 _ _ Hle).
      rewrite /pr_gt //= => ->; fourier.
Qed.

Lemma hinf_decreasing:
  ∀ z r n n' φ k,
    (le n n') →
    pr_gt (rvar_comp (recN_rvar (hpath _ _ _ h φ) (k, z) n') (λ x, size (snd x))) r
          ≤ pr_gt (rvar_comp (recN_rvar (hpath _ _ _ h φ) (k, z) n) (λ x, size (snd x))) r.
Proof.
  induction 1 as [| ? ? IHle].
  - reflexivity.
  - etransitivity; first apply hinf_decreasingS. done.
Qed.

Lemma hinf_decreasing0:
  ∀ z r n n' φ k, (le n n') →
    pr_gt (rvar_comp (recN_rvar (hpath _ _ _ h φ) (k, z) n) (λ x, size (snd x))) r = 0 →
    pr_gt (rvar_comp (recN_rvar (hpath _ _ _ h φ) (k, z) n') (λ x, size (snd x))) r = 0.
Proof.
  intros ?????? Hle Hgt. apply (Rle_antisym).
  - etransitivity; last (right; apply Hgt).
    apply hinf_decreasing; auto.
  - rewrite /pr_gt. apply Rge_le, ge_pr_0.
Qed.

Lemma hinf_0_aux3:
  ∀ z φ sidx,
    pr_gt (rvar_comp (recN_rvar (hpath _ _ _ h φ) (sidx, z) (Z.to_nat (Rceil (size z))))
                   (λ x, size (snd x))) d = 0.
Proof.
  intros z φ sidx.
  remember (Z.to_nat (Rceil (size z))) as k eqn:Hk.
  revert z Hk sidx.
  induction k as [k IH] using lt_wf_ind. intros z (* Hlt *) Hk sidx.
  destruct k.
  * rewrite /pr_gt.
    assert (size z ≤ d) as Hbelow.
    {
      case (Rle_dec (size z) d) as [Hle|Hnle]; auto.
      cut (size z ≤ 0); first (intros; fourier).
      apply Rnot_le_gt in Hnle.
      assert (0 <= (Rceil (size z)))%Z.
      { rewrite -Rceil_0. apply Rceil_mono. fourier. }
      assert ( Rceil 0 = (Rceil (size z)))%Z as Hz.
      {
        rewrite Rceil_0. replace 0%nat with (Z.to_nat 0) in Hk by auto.
        apply Z2Nat.inj; omega.
      }
      apply Rnot_lt_le => Hlt'. apply Rceil_mono_strict in Hlt';
          last apply frac_part_0.
      omega.
    }
    rewrite //=.
    rewrite /pr_gt /pr //= SeriesC_fin_big.
    rewrite /index_enum {1}[@Finite.enum]unlock //=.
    rewrite big_seq1 => //=.
    destruct (Rgt_dec) => //=. nra.
  * case (Rlt_dec d (size z)) as [Hlt|Hnlt]; last (by apply hinf_0_aux_below, Rnot_lt_le).
    rewrite recN_pr_gt.
    rewrite big_seq_cond.
    apply big1. intros ((sidx', i)&Hin'). move/andP=>[Hin _].
    clear Hin. generalize Hin'. apply img_alt in Hin' as (x&Hin) => Hin'.
    generalize (hrange_shrink z x) => Hle_size. (* rewrite Hin in Hle_size. *)
    apply Rmult_eq_0_compat_l.
    destruct (Rle_dec 0 (size i)) as [Hlei|?%Rnot_le_gt]; last first.
    { apply hinf_0_aux_below. fourier. }
    assert (le (Z.to_nat (Rceil (size i))) k) as Hlek.
    {
      specialize (Hle_size Hlt).
      assert (Hle_size1: size (fst ((h z) x)) ≤ size z - 1).
      { generalize (hrange22 _ x Hlt). rewrite //= => ?.
        rewrite //= in Hle_size. fourier. }
      assert (Hle_size2: size (snd ((h z) x)) ≤ size z - 1).
      { generalize (hrange12 _ x Hlt). rewrite //= => ?.
        rewrite //= in Hle_size. fourier. }
    apply Rceil_mono in Hle_size1.
    apply Rceil_mono in Hle_size2.
    rewrite //= in Hin. destruct (φ sidx).
    - inversion Hin. subst. rewrite Rceil_minus_1 in Hle_size1.
      apply Z2Nat.inj_le in Hle_size1.
      * rewrite Z2Nat.inj_sub in Hle_size1; last omega.
        replace (Z.to_nat 1) with 1%nat in Hle_size1 by auto with *.
        rewrite -Hk //= in Hle_size1. omega.
      * rewrite -Rceil_0. apply Rceil_mono. done.
      * transitivity (Rceil (size (fst ((h z) x)))); auto.
        rewrite -Rceil_0. apply Rceil_mono. done.
    - inversion Hin. subst. rewrite Rceil_minus_1 in Hle_size2.
      apply Z2Nat.inj_le in Hle_size2.
      * rewrite Z2Nat.inj_sub in Hle_size2; last omega.
        replace (Z.to_nat 1) with 1%nat in Hle_size1 by auto with *.
        rewrite -Hk //= in Hle_size2. omega.
      * rewrite -Rceil_0. apply Rceil_mono. done.
      * transitivity (Rceil (size (snd ((h z) x)))); auto.
        rewrite -Rceil_0. apply Rceil_mono. done.
    }
    apply (hinf_decreasing0 _ _ _ _ _ _ Hlek).
    apply IH; auto; try omega.
Qed.

Lemma hinf_0: ∀ a, ∃ n, ∀ φ, pr_gt (rvar_comp (recN_rvar (hpath _ _ _ h φ) (O, a) n)
                                                  (λ x, size (snd x))) d = 0.
Proof.
  intros z.
  exists (Z.to_nat (Rceil (size z))) => φ.
  apply hinf_0_aux3.
Qed.
End decreasing_rec_binary.
End decreasing_rec_binary.


Require Export Relations Classical ClassicalEpsilon Zwf.
Require Export function_cpo.

(* SECTION : continuity of constant functions. *)

Theorem lub_cst :
  forall (A:Type)(R:A->A->Prop)(a:A),(forall x, R x x)->lub R a (fun n=>a).
intros A R a Hrefl.
split.
intros n; apply Hrefl.
intros v Hup.
apply (Hup 0).
Qed.

Theorem continuous_cst :
  forall (A B:Type)(R:A->A->Prop)(R':B->B->Prop)(b:B),
  reflexive R' -> continuous R R' (fun x:A => b).
intros A B R R' b Hrefl c Hch l Hlub.
apply lub_cst; auto.
Qed.

(* SECTION: the operation of composing on the left with an arbitrary
   function. *)

Definition comp_right (A:Type)(f g:A->option A)(x:A) :=
  match f x with None => None | Some r => g r end.

Arguments comp_right : default implicits.

Theorem comp_right_continuous :
  forall (A:Type)(f:A->option A),
     continuous (f_order' A)(f_order' A)(comp_right f).
intros A f c Hc l [Hu Hl].
split.
intros n x; unfold comp_right; case (f x);
   [exact (Hu n) | apply option_cpo_none_bot].
intros g' Hu' x.
assert (Hc' : forall n, option_cpo (comp_right f (c n) x)
                                   (comp_right f (c (S n)) x)).
intros n; unfold comp_right; case (f x);
   [intros a; exact (Hc n a) | apply option_cpo_none_bot].
case_eq (f x).
intros a Hfxeqa.
unfold comp_right; rewrite Hfxeqa.
generalize (lub_lift_reverse A (option A) (option_cpo (A:=A)) c l
            (conj Hu Hl) a).
intros [_ Hlla].
apply Hlla.
intros n; generalize (Hu' n x); unfold comp_right; rewrite Hfxeqa; trivial.
intros Hfxeqnone; unfold comp_right; rewrite Hfxeqnone.
apply option_cpo_none_bot.
Qed.

(* SECTION: a simple form of conditional statement. *)

Definition ifthenelse (A:Type)(t:option bool)(v w: option A) :=
  match t with Some true => v | Some false => w | None => None end.

Notation "'IF x 'THEN a 'ELSE b" :=
   (ifthenelse _ x a b) (at level 200).

Theorem ifthenelse_continuous :
  forall (A:Type) t F G,
     continuous (f_order' A) (f_order' A) F ->
     continuous (f_order' A) (f_order' A) G ->
     continuous (f_order' A) (f_order' A)
       (fun f x => 'IF (t x) 'THEN (F f x) 'ELSE (G f x)).
Proof.
intros A t F G HF HG c Hc l Hl.
apply (lift_lub A (option A) (@option_cpo A)).
intros x; destruct (t x) as [[ | ] | ]; simpl.
apply lub_lift_reverse with (l := F l)(c:= fun n => F (c n));
 apply HF; auto.
apply lub_lift_reverse with (l := G l)(c:= fun n => G (c n));
 apply HG; auto.
split;  intro; auto.
Qed.


Require Import Bool.
Load DFA_Def.

(** Sind zwei Zustaende gleich, so verhaelt sich [delta_hat] ebenso gleich. *)

Lemma eq_Q_eq_delta_hat : forall (w : @Word Sigma)
      (p q : Q) (d : forall q p : Q, (p = q)),
      delta_hat q w = delta_hat p w.
Proof.
  intros w p q d.
  induction w.
  - simpl.
    apply d.
  - simpl.
    rewrite IHw.
    reflexivity.
Qed.

(** [delta_hat] veraendert den Zustand nicht bei Eingabe von [eps]. *)

Lemma delta_hat_eps (q : Q) (w : @Word Sigma) :
      delta_hat q eps = q.
Proof.
  simpl.
  reflexivity.
Defined.

Lemma eq_Q_eq_delta_hat_left : forall (w : @Word Sigma)
      (p q : Q), q = p -> delta_hat q w = delta_hat p w.
Proof.
  intros w p q qEqp.
  induction w.
  - simpl.
    exact qEqp.
  - simpl.
    rewrite IHw.
    reflexivity.
Defined.

Lemma eq_Q_eq_delta_hat_right : forall (p q : Q),
      (forall (w : @Word Sigma), delta_hat q w = delta_hat p w) -> q = p.
Proof.
  intros p q H.
  pose (H eps).
  simpl in e.
  exact e.
Defined.

(**  *[Lang_delta] und [Lang_Conf] beschreiben die gleichen Sprachen. *)

(** Um zu zeigen, dass [Lang_delta] und [Lang_Conf] aequivalent zueinander sind, muss sowohl
[Lang_delta] w -> [Lang_Conf] w als auch [Lang_Conf] w -> [Lang_delta] w gezeigt werden. Dazu
sind eine Reihe von Hilfslemmata notwendig. *)

(** Hilfslemmata fuer [Lang_delta_Lang_Conf]: *)

(** Fuer jede Konfiguration (q, w) gibt es eine Konfiguration (p, eps), fuer die
 [Conf_rel_DFA (q, w) (p, eps)] bewohnt ist, mit p = delta_hat q w. Problematisch an
 dieser Stelle ist, dass [Conf_rel_DFA] das Wort von links nach rechts abarbeitet.
 Um den Beweis ueber Induktion fuehren zu koennen, wird das Wort herumgedreht
 und in einem zweiten Lemma [delta_hat_Conf] gezeigt, dass dies auch fuer die nicht
 gedrehte Variante gilt. *)

Lemma delta_hat_Conf_reverse (w : @Word Sigma) : forall (q : Q),
      Conf_rel_DFA (q, (word_reverse w)) (delta_hat q (word_reverse w), eps).
Proof.
  induction w.
  - intro q.
    simpl.
    apply refl.
  - intro q.
    simpl.
    rewrite (delta_hat_Lemma q a (word_reverse w)).
    pose (IHw (delta q a)) as step2.
    exact (step _ _ _ (one_step q a (word_reverse w)) step2).
Qed.

Lemma delta_hat_Conf (w : @Word Sigma) : forall (q : Q),
      Conf_rel_DFA (q, w) (delta_hat q w, eps).
Proof.
  rewrite <- (word_reverse_involutiv w).
  exact (delta_hat_Conf_reverse (word_reverse w)).
Qed.

(** Hinrichtung der Aequivalenz: *)
Lemma Lang_delta_Lang_Conf {w: @Word Sigma} :
      Lang_delta w -> Lang_Conf w.
Proof.
  intro LDw.
  unfold Lang_Conf.
  unfold Lang_delta in LDw.
  exists (delta_hat q0 w).
  split.
  - exact LDw.
  - exact (delta_hat_Conf w q0).
Qed.

(** Hilfslemmata fuer [Lang_Conf_Lang_delta].*)
(** Die vollstaendige Abarbeitung eines umgedrehten Wortes.*)
Lemma Conf_delta_hat_reverse (w : @Word Sigma) : forall (q p : Q),
      Conf_rel_DFA (q, word_reverse w) (p, eps) ->
      delta_hat q (word_reverse w) = p.
Proof.
  induction w.

  - simpl.
    intros q p rel.
    dependent destruction rel.
    + reflexivity.
    + dependent destruction c.
       induction w.
       * inversion x.
       * inversion x.

  - simpl.
    intros q p rel.
    rewrite delta_hat_Lemma.
    dependent destruction rel.

    + rewrite <- (word_reverse_snoc w a) in x.
       apply (f_equal word_reverse) in x.
       rewrite (word_reverse_involutiv (snoc w a)) in x.
       simpl in x.
       dependent destruction x.

    + dependent induction c.

       rewrite <- (word_reverse_involutiv w0) in x.
       rewrite <- (word_reverse_snoc (word_reverse w0) a0) in x.
       rewrite <- (word_reverse_snoc w a) in x.
       apply (word_reverse_injective) in x.

       injection x.
       intros a0Eqa revw0Eqw.

       rewrite a0Eqa in rel.
       apply (f_equal word_reverse) in revw0Eqw.
       rewrite (word_reverse_involutiv w0) in revw0Eqw.
       rewrite revw0Eqw in rel.

       exact (IHw (delta q a) p rel).

Defined.

Lemma Conf_delta_hat (w : @Word Sigma) : forall (q p : Q),
      Conf_rel_DFA (q, w) (p, eps) -> delta_hat q w = p.
Proof.
  rewrite <- (word_reverse_involutiv w).
  exact (Conf_delta_hat_reverse (word_reverse w)).
Qed.

(** Rueckrichtung der Aequivalenz: *)
Lemma Lang_Conf_Lang_delta {w: @Word Sigma} :
      Lang_Conf w -> Lang_delta w.
Proof.
  intro LCw.
  unfold Lang_delta.
  unfold Lang_Conf in LCw.
  destruct LCw as [p [pacc rel]].
  rewrite (Conf_delta_hat w q0 p rel).
  exact pacc.
Defined.


(** This library extends the standard library [Coq.Sets.Ensembles],
    and provides the usual mathematical notations of naive set
    theories. *)

Add LoadPath ".." as LSMTS.
Require Import Coq.Sets.Ensembles.
Require Import Coq.Sets.Finite_sets.

(****************)
(** * Notations *)
(****************)

(** [naiveSet] is a better name than [Ensemble]. *)

Notation Nv_naiveSet := Ensemble.

(** Some other renamings. *)

Notation Nv_in := In.
Notation Nv_included := Included.
Notation Nv_empty := Empty_set.
Notation Nv_full := Full_set.
Notation Nv_full_intro := Full_intro.
Notation Nv_singleton := Singleton.
Notation Nv_singleton_intro := In_singleton.
Notation Nv_union := Union.
Notation Nv_union_introl := Union_introl.
Notation Nv_union_intror := Union_intror.
Notation Nv_add := Add.
Notation Nv_intersection := Intersection.
Notation Nv_intersection_intro := Intersection_intro.
Notation Nv_couple := Couple.
Notation Nv_couple_introl := Couple_l.
Notation Nv_couple_intror := Couple_r.
Notation Nv_triple := Triple.
Notation Nv_triple_introl := Triple_l.
Notation Nv_triple_introm := Triple_m.
Notation Nv_triple_intror := Triple_r.
Notation Nv_complement := Complement.
Notation Nv_difference := Setminus.
Notation Nv_subtract := Subtract.
Notation Nv_disjoint := Disjoint.
Notation Nv_disjoint_intro := Disjoint_intro.
Notation Nv_notEmpty := Inhabited.
Notation Nv_notEmpty_intro := Inhabited_intro.
Notation Nv_strictlyIncluded := Strict_Included.
Notation Nv_eq := Same_set.
Notation Nv_extensionality := Extensionality_Ensembles.
Notation Nv_finite := Finite.
Notation Nv_empty_finite := Empty_is_finite.
Notation Nv_finite_union := Union_is_finite.
Notation Nv_cardinal := cardinal.
Notation Nv_cardinal_empty := card_empty.
Notation Nv_cardinal_add:= card_add.
Notation Nv_cardinal_invert := cardinal_invert.
Notation Nv_cardinal_elim := cardinal_elim.

(** In most cases, the universe can be considered implicit. *)

Arguments Nv_in {_} _ _.
Arguments Nv_included {_} _ _.
Arguments Nv_empty {_} _.
Arguments Nv_full _ _.
Arguments Nv_full_intro {_} _.
Arguments Nv_singleton {_} _ _.
Arguments Nv_singleton_intro {_} _.
Arguments Nv_union {_} _ _ _.
Arguments Nv_union_introl {_} _ _ _ _.
Arguments Nv_union_intror {_} _ _ _ _.
Arguments Nv_add {_} _ _ _.
Arguments Nv_intersection {_} _ _ _.
Arguments Nv_intersection_intro {_} _ _ _ _ _.
Arguments Nv_couple {_} _ _ _.
Arguments Nv_couple_introl {_} _ _.
Arguments Nv_couple_intror {_} _ _.
Arguments Nv_triple {_} _ _ _ _.
Arguments Nv_triple_introl {_} _ _ _.
Arguments Nv_triple_introm {_} _ _ _.
Arguments Nv_triple_intror {_} _ _ _.
Arguments Nv_complement {_} _ _.
Arguments Nv_difference {_} _ _ _.
Arguments Nv_subtract {_} _ _ _.
Arguments Nv_disjoint {_} _ _.
Arguments Nv_disjoint_intro {_} _ _ _.
Arguments Nv_notEmpty {_} _.
Arguments Nv_notEmpty_intro {_} _ _ _.
Arguments Nv_strictlyIncluded {_} _ _.
Arguments Nv_eq {_} _ _.
Arguments Nv_extensionality {_} _ _ _.
Arguments Nv_finite {_} _.
Arguments Nv_empty_finite {_}.
Arguments Nv_finite_union {_} _ _ _ _.
Arguments Nv_cardinal {_} _ _.
Arguments Nv_cardinal_empty {_}.
Arguments Nv_cardinal_add {_} _ _ _ _ _.
Arguments Nv_cardinal_invert {_} _ _ _.
Arguments Nv_cardinal_elim {_} _ _ _.

(** Let us take advantage of Unicode. *)

Notation "x ∈ E" := (Nv_in E x) (at level 70, no associativity).
Notation "x ∉ E" := (~(Nv_in E x)) (at level 70, no associativity).
Notation "S ⊆ T" := (Nv_included S T) (at level 70, no associativity).
Notation "S ⊈ T" := (~(Nv_included S T)) (at level 70, no associativity).
Notation "∅" := Nv_empty.
Notation "'Nv{' x , .. , y '}'" := (Nv_add .. (Nv_add ∅ x) .. y).
Notation "S ∪ T" := (Nv_union S T) (at level 50, left associativity).
Notation "S ∩ T" := (Nv_intersection S T) (at level 40, left associativity).
Notation "∁ S" := (Nv_complement S) (at level 35, right associativity).
Notation "S \ T" := (Nv_difference S T) (at level 50, left associativity).
Notation "S ⊂ T" := (Nv_strictlyIncluded S T) (at level 70, no associativity).
Notation "S == T  '[Nv]'" := (Nv_eq S T) (at level 70, no associativity).

(**************************)
(** * Product of Two Sets *)
(**************************)

Inductive Nv_product
    {U V : Type}
    (S : Nv_naiveSet U)
    (T : Nv_naiveSet V)
    : Nv_naiveSet (U * V)
    :=
        Nv_product_intro : forall (x : U) (y : V),
            x ∈ S -> y ∈ T -> (x, y) ∈ (Nv_product S T).

Notation "S × T" := (Nv_product S T) (at level 40, left associativity).


(* by Evelyne Contejean *)

(**  *Dickson Lemma: the multiset extension of a well-founded ordering is well-founded.
 *)

Set Implicit Arguments.

Require Import Relations.
Require Import Equivalence.
Require Import List.
From Cyclic_PA.Casteran Require Import closure.
From Cyclic_PA.Casteran Require Import more_list.
Require Import Multiset.
From Cyclic_PA.Casteran Require Import list_permut.

Module Make (DS1 : decidable_set.S).

Module DS := DS1.
Module LP := list_permut.Make (DS1).
Import LP.

(** ** Definition of the multiset extension of a relation. *)
Inductive multiset_extension_step (R : relation elt) : list elt -> list elt -> Prop :=
  | rmv_case :
     forall l1 l2 l la a, (forall b, In b la -> R b a) ->
      list_permut l1 (la ++ l) -> list_permut l2 (a :: l) ->
      multiset_extension_step R l1 l2.

(** If n << {a} U m, then
      either, there exists n' such that n = {a} U n' and n' << m,
      or, there exists k, such that n = k U m, and k << {a}. *)
Lemma two_cases :
 forall R a m n,
 multiset_extension_step R n (a :: m) ->
 (exists n', list_permut n (a :: n') /\
             multiset_extension_step R n' m) \/
 (exists k, (forall b, In b k -> R b a) /\
            list_permut n (k ++ m)).
Proof.
intros R a m n M; inversion_clear M as [x1 x2 l la a0 H H0 H1];
elim (eq_elt_dec a a0); intro a_eq_a0; subst.

assert (H2 : list_permut m l).
apply remove_context_list_permut_cons with a0; trivial.
right; exists la; split; trivial; setoid_rewrite H0; setoid_rewrite H2; auto.

left; elim (In_dec eq_elt_dec a0 m); intro In_a0.
generalize (split_list_app_cons eq_elt_dec _ _ In_a0); clear In_a0;
destruct (split_list eq_elt_dec m a0); intro; subst.
assert (H2 : list_permut (a :: l0 ++ l1) l).
apply remove_context_list_permut_cons with a0;
setoid_rewrite <- H1; pattern a at 1; do 2 rewrite app_comm_cons;
apply list_permut_add_cons_inside; auto.
exists (la ++ l0 ++ l1); split.
setoid_rewrite H0; setoid_rewrite <- H2; apply list_permut_sym;
apply list_permut_add_cons_inside; auto.
apply (rmv_case (l1:=la ++ l0 ++ l1) (l2:= l0 ++ a0 :: l1) (l:= l0 ++ l1) R la H); auto;
apply list_permut_sym; apply list_permut_add_cons_inside; auto.

absurd (In a0 (a :: m)).
intro H2; elim H2; clear H2; intro H2; subst;
[ absurd (a0 = a0) | absurd (In a0 m) ]; trivial.
setoid_rewrite H1; left; trivial.
Qed.

(** [multiset_extension_step] is compatible with permutation. *)
Lemma list_permut_multiset_extension_step_1 :
  forall R l1 l2 l, list_permut l1 l2 ->
  multiset_extension_step R l1 l -> multiset_extension_step R l2 l.
Proof.
intros R l1 l2 l P M1; inversion M1; subst.
apply (rmv_case (l1:=l2) (l2:=l) (l:=l4) R la H); trivial;
setoid_rewrite <- P; trivial.
Qed.

Lemma list_permut_multiset_extension_step_2 :
  forall R l1 l2 l, list_permut l1 l2 ->
  multiset_extension_step R l l1 -> multiset_extension_step R l l2.
Proof.
intros R l1 l2 l P M1; inversion M1; subst.
apply (rmv_case (l1:=l) (l2:=l2) (l:=l4) R la H); trivial;
setoid_rewrite <- P; trivial.
Qed.

Lemma context_multiset_extension_step_app1 :
  forall R l1 l2 l, multiset_extension_step R l1 l2 ->
                         multiset_extension_step R (l ++ l1) (l ++ l2).
Proof.
intros R l1 l2 l H; destruct H as [l1 l2 l12 la a H P1 P2].
apply (@rmv_case R (l++l1) (l++l2) (l++l12) la a); trivial.
apply list_permut_trans with (l ++ la ++ l12).
apply context_list_permut_app1; trivial.
do 2 rewrite <- app_ass; apply context_list_permut_app2; trivial.
apply list_permut_app_app.
apply list_permut_trans with (l ++ a :: l12).
apply context_list_permut_app1; trivial.
apply list_permut_sym; apply list_permut_add_cons_inside;
apply list_permut_refl.
Qed.

Lemma context_trans_clos_multiset_extension_step_app1 :
  forall R l1 l2 l, trans_clos (multiset_extension_step R) l1 l2 ->
                         trans_clos (multiset_extension_step R) (l ++ l1) (l ++ l2).
Proof.
intros R l1 l2 l H; induction H.
apply t_step; apply context_multiset_extension_step_app1; trivial.
apply t_trans with (l ++ y); trivial.
apply context_multiset_extension_step_app1; trivial.
Qed.

Lemma context_multiset_extension_step_app2 :
  forall R l1 l2 l, multiset_extension_step R l1 l2 ->
                         multiset_extension_step R (l1 ++ l) (l2 ++ l).
Proof.
intros R l1 l2 l H; destruct H as [l1 l2 l12 la a H P1 P2].
apply (@rmv_case R (l1++l) (l2++l) (l12++l) la a); trivial.
rewrite <- app_ass; apply context_list_permut_app2; trivial.
rewrite app_comm_cons; apply context_list_permut_app2; trivial.
Qed.

Lemma Relation_equiv_lists : forall (R1 R2 : relation elt) (l1 l2 : list elt), RelationClasses.relation_equivalence R1 R2 -> multiset_extension_step R1 l1 l2 = multiset_extension_step R2 l1  l2.
Proof.
intros. induction l2.
- destruct l1.
  + assert (multiset_extension_step R1 nil nil). assert (forall a b, In b nil -> R1 b a). admit. pose (fun a => rmv_case (a:=a) (l:=nil) (l1:=nil) (l2:=nil) R1 nil (H0 a)). assert (exists (a : elt), a = a). admit. destruct H1. apply (m x). simpl. auto. simpl. admit.
Admitted.

Add Morphism multiset_extension_step : mult_morph.
Proof.
intros R1 R2 RF l1 l2 P12 l3 l4 P34. split; [intro R13 | intro R24].
apply list_permut_multiset_extension_step_2 with l3; trivial.
apply list_permut_multiset_extension_step_1 with l1; trivial. rewrite (Relation_equiv_lists (R2 := R1) l1 l3); auto.
unfold RelationClasses.relation_equivalence in*. unfold RelationClasses.predicate_equivalence in *. simpl. simpl in RF. intros. destruct (RF x x0) as [RF1 RF2]. split; auto.
apply list_permut_multiset_extension_step_2 with l4; auto;
apply list_permut_multiset_extension_step_1 with l2; auto. rewrite (Relation_equiv_lists (R2 := R2) l2 l4); auto.
Qed.

(** *** Accessibility lemmata. *)
Lemma list_permut_acc :
  forall R l1 l2, list_permut l2 l1 ->
  Acc (multiset_extension_step R) l1 -> Acc (multiset_extension_step R) l2.
Proof.
intros R l1 l2 Meq A1; apply Acc_intro; intros l M2;
inversion A1; apply H; subst;
setoid_rewrite <- Meq; trivial.
Qed.

(*
Add Morphism (fun R => Acc (multiset_extension_step R)) : acc_morph.
Proof.
intros R1 R2 RF l1 l2 P; split; [intro A1 | intro A2].
apply list_permut_acc with l1; trivial; try setoid_rewrite <- P; auto.  admit.
apply list_permut_acc with l2; trivial. admit.
Admitted.
*)

Lemma dickson_aux1 :
forall (R : relation elt) a,
 (forall b, R b a ->
  forall m, Acc (multiset_extension_step R) m ->
            Acc (multiset_extension_step R) (b :: m)) ->
 forall m, Acc (multiset_extension_step R) m ->
 (forall m', (multiset_extension_step R) m' m ->
             Acc (multiset_extension_step R) (a :: m')) ->
 Acc (multiset_extension_step R) (a :: m).
Proof.
intros R a IH2_a m Acc_m IHa_M; apply Acc_intro;
intros n H; elim (two_cases H); clear H.
intros [n' [P M]]; refine (list_permut_acc P _); apply IHa_M; trivial.
intros [k [M P]]; refine (list_permut_acc P _); clear P; induction k; trivial; simpl;
apply IH2_a.
apply M; left; trivial.
apply IHk; intros; apply M; right; trivial.
Qed.

Lemma dickson_aux2 :
forall R m,
  Acc (multiset_extension_step R) m ->
  forall a, (forall b, R b a ->
             forall m, Acc (multiset_extension_step R) m ->
                       Acc (multiset_extension_step R) (b :: m)) ->
   Acc (multiset_extension_step R) (a :: m).
Proof.
intros R m Acc_m a IH2_a;
apply (Acc_iter  (R:= multiset_extension_step R)
(fun m => Acc (multiset_extension_step R) m ->
Acc (multiset_extension_step R) (a :: m))); trivial;
clear m Acc_m;
intros m H Acc_m; apply dickson_aux1; trivial;
intros; apply H; trivial;
apply Acc_inv with m; trivial.
Qed.

Lemma dickson_aux3 :
forall R a, Acc R a -> forall m, Acc (multiset_extension_step R) m ->
Acc (multiset_extension_step R) (a :: m).
Proof.
intros R a Acc_a;
apply (Acc_iter  (R:= R)
(fun a => Acc R a -> forall m, Acc (multiset_extension_step R) m ->
Acc (multiset_extension_step R) (a :: m))); trivial;
clear a Acc_a;
intros a H Acc_a m Acc_m; apply dickson_aux2; trivial;
intros; apply H; trivial;
apply Acc_inv with a; trivial.
Qed.

(** Main lemma. *)
Lemma dickson :
  forall R, well_founded R -> well_founded (multiset_extension_step R).
Proof.
intros R Wf_R; unfold well_founded in *;
intros m; induction m as [ | a m].
apply Acc_intro; intros m H; inversion_clear H;
absurd (a :: l = nil);
[ discriminate | apply list_permut_nil; setoid_rewrite H2; auto].
apply dickson_aux3; trivial.
Qed.

Lemma multiset_closure :
  forall R p q, transitive _ R ->
  closure.trans_clos (multiset_extension_step R) p q ->
	exists p', exists q', exists pq,
   	list_permut p (p' ++ pq) /\
   	list_permut q (q' ++ pq) /\
   	q' <> nil /\
   	(forall a, In a p' -> exists b, In b q' /\ R a b).
Proof.
intros R p q trans_R p_lt_q; induction p_lt_q as [p q p_lt_q | p q r p_lt_q q_lt_r].
destruct p_lt_q as [p q pq la a H Pp Pq].
exists la; exists (a :: nil); exists pq; simpl; split; trivial.
split; trivial.
split; trivial.
discriminate.
intros b b_in_la; exists a; split; [left; trivial | apply H; trivial].
destruct p_lt_q as [p q pq la a la_lt_a Pp Pq].
generalize IHq_lt_r; clear IHq_lt_r.
intros [q' [r' [qr [Pq' [Pr [r'_diff_nil q'_lt_r']]]]]].
assert (a_in_q'_qr : In a (q' ++ qr)).
apply in_permut_in with q; trivial.
apply in_permut_in with (a :: pq); [left | apply list_permut_sym]; trivial.
destruct (in_app_or _ _ _ a_in_q'_qr) as [a_in_q' | a_in_qr]; clear a_in_q'_qr.
generalize (split_list_app_cons eq_elt_dec _ _ a_in_q');
destruct (split_list eq_elt_dec q' a) as [q1' q2']; intro; subst.
exists (la ++ q1' ++ q2'); exists r'; exists qr; split.
refine (list_permut_trans Pp _).
do 2 rewrite app_ass; apply context_list_permut_app1.
apply list_permut_remove_hd with a.
refine (list_permut_trans (list_permut_sym Pq) _).
rewrite app_comm_cons; rewrite <- app_ass; trivial.
split; trivial.
split; trivial.
intros b b_in_la_q1'_q2';
destruct (in_app_or _ _ _ b_in_la_q1'_q2') as [b_in_la | b_in_q1'_q2'];
clear b_in_la_q1'_q2'; [idtac |
destruct (in_app_or _ _ _ b_in_q1'_q2') as [b_in_q1' | b_in_q2']; clear b_in_q1'_q2'].
destruct (q'_lt_r' a a_in_q') as [c [c_in_r' a_lt_c]]; exists c; split; trivial.
apply trans_R with a; trivial; apply la_lt_a; trivial.
apply q'_lt_r'; apply in_or_app; left; trivial.
apply q'_lt_r'; apply in_or_app; right; right; trivial.

generalize (split_list_app_cons eq_elt_dec _ _ a_in_qr);
destruct (split_list eq_elt_dec qr a) as [qr1 qr2]; intro; subst.
exists (la ++ q'); exists (a :: r'); exists (qr1 ++ qr2); split.
refine (list_permut_trans Pp _).
rewrite app_ass; apply context_list_permut_app1.
rewrite <- app_ass; apply list_permut_remove_hd with a.
refine (list_permut_trans (list_permut_sym Pq) _).
rewrite app_ass; trivial.
split.
refine (list_permut_trans Pr _); rewrite <- app_ass;
apply list_permut_sym; simpl; apply list_permut_add_cons_inside;
rewrite ass_app; apply list_permut_refl.
split.
discriminate.
intros b b_in_la_q';
destruct (in_app_or _ _ _ b_in_la_q') as [b_in_la | b_in_q']; clear b_in_la_q'.
exists a; split; [left | apply la_lt_a]; trivial.
destruct (q'_lt_r' _ b_in_q') as [c [c_in_r' b_lt_c]].
exists c; split; trivial; right; trivial.
Qed.

(*
Lemma trans_multiset_extension_step :
  forall R, antisymmetric elt R -> transitive elt R ->
  transitive (list elt) (multiset_extension_step R).
Proof.
intros R antisym trans.
intros l1 l2 l3 R12 R23.
destruct R12 as [ l1 l2 l12 la1 a2 H1 P1 P2].
destruct R23 as [ l2 l3 l23 la2 a3 H2 P2' P3].
generalize (ac_syntactic l12 (a2 :: nil) l23 la2 (list_permut_trans (list_permut_sym P2) P2')).
intros [u1 [u2 [u3 [u4 [Q1 [Q2 [Q3 Q4]]]]]]].
destruct u3 as [ | b3 u3]; destruct u4 as [ | b4 u4].
assert (H := list_permut_length Q2); discriminate.
destruct u4 as [ | c4 u4].
simpl in Q2; rewrite <- app_nil_end in Q3.
assert (a2_eq_b4 := list_permut_length_1 Q2); subst b4; clear Q2.
apply (@rmv_case R l1 l3 u1 (app la1 u2) a3).
intros b H; destruct (in_app_or _ _ _ H) as [b_in_la1 | b_in_u2]; clear H.
(*** ici ****)
     forall l1 l2 l la a, (forall b, In b la -> R b a) ->
      list_permut l1 (la ++ l) -> list_permut l2 (a :: l) ->
      multiset_extension_step R l1 l2.

assert (H := list_permut_length Q2).
 discriminate.
*)
End Make.


Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Psatz.
Local Open Scope string.
Local Open Scope Z.

(** * 一个极简的指令式程序语言 *)

Module While_SimpleWhile.

(** 以下考虑一种极简的程序语言。它的程序表达式分为整数类型表达式与布尔类型表达
    式，其中整数类型表达式只包含加减乘运算与变量、常数。布尔表达式中只包含整数类
    型表达式之间的大小比较或者这些比较结果之间的布尔运算。而它的程序语句也只有对
    变量赋值、顺序执行、if语句与while语句。 *)

(** 下面依次在Coq中定义该语言变量名、表达式与语句。*)

Definition var_name: Type := string.

Inductive expr_int : Type :=
  | EConst (n: Z): expr_int
  | EVar (x: var_name): expr_int
  | EAdd (e1 e2: expr_int): expr_int
  | ESub (e1 e2: expr_int): expr_int
  | EMul (e1 e2: expr_int): expr_int.

(** 在Coq中，可以利用_[Notation]_使得这些表达式更加易读。*)

Definition EVar': string -> expr_int := EVar.
Declare Custom Entry expr_entry.
Coercion EConst: Z >-> expr_int.
Coercion EVar: var_name >-> expr_int.
Coercion EVar': string >-> expr_int.
Notation "[[ e ]]" := e
  (at level 0, e custom expr_entry at level 99).
Notation "( x )" := x
  (in custom expr_entry, x custom expr_entry at level 99).
Notation "x" := x
  (in custom expr_entry at level 0, x constr at level 0).
Notation "f x" := (f x)
  (in custom expr_entry at level 1, only parsing,
   f custom expr_entry,
   x custom expr_entry at level 0).
Notation "x * y" := (EMul x y)
  (in custom expr_entry at level 11, left associativity).
Notation "x + y" := (EAdd x y)
  (in custom expr_entry at level 12, left associativity).
Notation "x - y" := (ESub x y)
  (in custom expr_entry at level 12, left associativity).

(** 使用_[Notation]_的效果如下：*)

Check [[1 + "x"]].
Check [["x" * ("a" + "b" + 1)]].

Inductive expr_bool: Type :=
  | ETrue: expr_bool
  | EFalse: expr_bool
  | ELt (e1 e2: expr_int): expr_bool
  | EAnd (e1 e2: expr_bool): expr_bool
  | ENot (e: expr_bool): expr_bool.

Inductive com : Type :=
  | CAss (x: var_name) (e: expr_int): com
  | CSeq (c1 c2: com): com
  | CIf (e: expr_bool) (c1 c2: com): com
  | CWhile (e: expr_bool) (c: com): com.

End While_SimpleWhile.

(** * While语言 *)

Module While_While.

(** 在许多以C语言为代表的常用程序语言中，往往不区分整数类型表达式与布尔类型表达
    式，同时表达式中也包含更多运算符。例如，我们可以如下规定一种程序语言的语法。*)

(** 下面依次在Coq中定义该语言的变量名、表达式与语句。*)

Definition var_name: Type := string.

(** 再定义二元运算符和一元运算符。*)

Inductive binop : Type :=
  | OOr | OAnd
  | OLt | OLe | OGt | OGe | OEq | ONe
  | OPlus | OMinus | OMul | ODiv | OMod.

Inductive unop : Type :=
  | ONot | ONeg.

(** 下面是表达式的抽象语法树。*)

Inductive expr : Type :=
  | ENum (n: Z)
  | EVar (x: var_name)
  | EBinop (op: binop) (e1 e2: expr)
  | EUnop (op: unop) (e: expr)
  | EDeref (e: expr).

(** 最后程序语句的定义是类似的。*)

Inductive com : Type :=
  | CAss (x: var_name) (e: expr): com
  | CSeq (c1 c2: com): com
  | CIf (e: expr) (c1 c2: com): com
  | CWhile (e: expr) (c: com): com.

End While_While.

(** * 用Coq归纳类型定义二叉树 *)

Inductive tree: Type :=
| Leaf: tree
| Node (l: tree) (v: Z) (r: tree): tree.

(** 这个定义说的是，一棵二叉树要么是一棵空树_[Leaf]_，要么有一棵左子树、有一棵右
    子树外加有一个根节点整数标号。我们可以在Coq中写出一些具体的二叉树的例子。*)

Definition tree_example0: tree :=
  Node Leaf 1 Leaf.

Definition tree_example1: tree :=
  Node (Node Leaf 0 Leaf) 2 Leaf.

Definition tree_example2a: tree :=
  Node (Node Leaf 8 Leaf) 100 (Node Leaf 9 Leaf).

Definition tree_example2b: tree :=
  Node (Node Leaf 9 Leaf) 100 (Node Leaf 8 Leaf).

Definition tree_example3a: tree :=
  Node (Node Leaf 3 Leaf) 5 tree_example2a.

Definition tree_example3b: tree :=
  Node tree_example2b 5 (Node Leaf 3 Leaf).

(** Coq中，我们往往可以使用递归函数定义归纳类型元素的性质。Coq中定义递归函数时使
    用的关键字是_[Fixpoint]_。下面两个定义通过递归定义了二叉树的高度和节点个数。*)

Fixpoint tree_height (t: tree): Z :=
  match t with
  | Leaf => 0
  | Node l v r => Z.max (tree_height l) (tree_height r) + 1
  end.

Fixpoint tree_size (t: tree): Z :=
  match t with
  | Leaf => 0
  | Node l v r => tree_size l + tree_size r + 1
  end.

(** Coq系统“知道”每一棵特定树的高度和节点个数是多少。下面是具体的Coq代码。其中，
    _[Example]_关键字与_[Theorem]_、_[Lemma]_、_[Corollary]_的作用是一样的，用于
    描述一个即将进行证明的性质。而证明中可以直接使用_[reflexivity]_指令则说明，
    该指令不仅可以用于等号两侧语法完全相同的情况，其还能基于Coq定义（例如此处的
    递归函数定义）进行化简。*)

Example Leaf_height:
  tree_height Leaf = 0.
Proof. reflexivity. Qed.

Example tree_example2a_height:
  tree_height tree_example2a = 2.
Proof. reflexivity. Qed.

Example treeexample3b_size:
  tree_size tree_example3b = 5.
Proof. reflexivity. Qed.

(** Coq中也可以定义树到树的函数。下面的_[tree_reverse]_函数把二叉树进行了左右翻转。 *)

Fixpoint tree_reverse (t: tree): tree :=
  match t with
  | Leaf => Leaf
  | Node l v r => Node (tree_reverse r) v (tree_reverse l)
  end.

(** 下面是三个二叉树左右翻转的例子：*)

Example Leaf_tree_reverse:
  tree_reverse Leaf = Leaf.
Proof. reflexivity. Qed.

Example tree_example0_tree_reverse:
  tree_reverse tree_example0 = tree_example0.
Proof. reflexivity. Qed.

Example tree_example3_tree_reverse:
  tree_reverse tree_example3a = tree_example3b.
Proof. reflexivity. Qed.

(** 归纳类型有几条基本性质。(1) 归纳定义规定了一种分类方法，以_[tree]_类型为例，
    一棵二叉树_[t]_要么是_[Leaf]_，要么具有形式_[Node l v r]_；(2) 以上的分类之
    间是互斥的，即无论_[l]_、_[v]_与_[r]_取什么值，_[Leaf]_与_[Node l v r]_都不
    会相等；(3) _[Node]_这样的构造子是函数也是单射。这三条性质对应了Coq中的三条
    证明指令：_[destruct]_、_[discriminate]_与_[injection]_。利用它们就可以证明
    几条最简单的性质：*)

Lemma Node_inj_left: forall l1 v1 r1 l2 v2 r2,
  Node l1 v1 r1 = Node l2 v2 r2 ->
  l1 = l2.
Proof.
  intros.
  injection H as H_l H_v H_r.
  (** 上面的_[injection]_指令使用了_[Node]_是单射这一性质。*)
  rewrite H_l.
  reflexivity.
Qed.

(** 有时，手动为_[injection]_生成的命题进行命名显得很啰嗦，Coq允许用户使用问号占
    位，从而让Coq进行自动命名。*)

Lemma Node_inj_right: forall l1 v1 r1 l2 v2 r2,
  Node l1 v1 r1 = Node l2 v2 r2 ->
  r1 = r2.
Proof.
  intros.
  injection H as ? ? ?.
  (** 这里，Coq自动命名的结果是使用了_[H]_、_[H0]_与_[H1]_。下面也使用_[apply]_
      指令取代_[rewrite]_简化后续证明。*)
  apply H1.
Qed.

(** 如果不需要用到_[injection]_生成的左右命题，可以将不需要用到的部分用下划线占
    位。*)

Lemma Node_inj_value: forall l1 v1 r1 l2 v2 r2,
  Node l1 v1 r1 = Node l2 v2 r2 ->
  v1 = v2.
Proof.
  intros.
  injection H as _ ? _.
  apply H.
Qed.

(** 下面引理说：若_[Leaf]_与_[Node l v r]_相等，那么_[1 = 2]_。换言之，_[Leaf]_
    与_[Node l v r]_始终不相等，否则就形成了一个矛盾的前提。*)

Lemma Leaf_Node_conflict: forall l v r,
  Leaf = Node l v r -> 1 = 2.
Proof.
  intros.
  discriminate.
Qed.

(** 下面这个简单性质与_[tree_reverse]_有关。*)

Lemma reverse_result_Leaf: forall t,
  tree_reverse t = Leaf ->
  t = Leaf.
Proof.
  intros.
  (** 下面的_[destruct]_指令根据_[t]_是否为空树进行分类讨论。*)
  destruct t.
  (** 执行这一条指令之后，Coq中待证明的证明目标由一条变成了两条，对应两种情况。
      为了增加Coq证明的可读性，我们推荐大家使用bullet记号把各个子证明过程分割开
      来，就像一个一个抽屉或者一个一个文件夹一样。Coq中可以使用的bullet标记有：
      _[+ - * ++ -- **]_等等*)
  + reflexivity.
    (** 第一种情况是_[t]_是空树的情况。这时，待证明的结论是显然的。*)
  + discriminate H.
    (** 第二种情况下，其实前提_[H]_就可以推出矛盾。可以看出，_[discriminate]_指
        令也会先根据定义化简，再试图推出矛盾。*)
Qed.

(** * 结构归纳法 *)

(** 我们接下去将证明一些关于_[tree_height]_，_[tree_size]_与_[tree_reverse]_的基
    本性质。我们在证明中将会使用的主要方法是归纳法。*)

(** 相信大家都很熟悉自然数集上的数学归纳法。数学归纳法说的是：如果我们要证明某性
    质_[P]_对于任意自然数_[n]_都成立，那么我可以将证明分为如下两步：*)
(** 奠基步骤：证明_[P 0]_成立；*)
(** 归纳步骤：证明对于任意自然数_[n]_，如果_[P n]_成立，那么_[P (n + 1)]_也成
    立。*)

(** 对二叉树的归纳证明与上面的数学归纳法稍有不同。具体而言，如果我们要证明某性质
    _[P]_对于一切二叉树_[t]_都成立，那么我们只需要证明以下两个结论：*)

(** 奠基步骤：证明_[P Leaf]_成立；*)
(** 归纳步骤：证明对于任意二叉树_[l]_ _[r]_以及任意整数标签_[n]_，如果_[P l]_与
    _[P r]_都成立，那么_[P (Node l n r)]_也成立。*)

(** 这样的证明方法就成为结构归纳法。在Coq中，_[induction]_指令表示：使用结构归纳
    法。下面是几个证明的例子。*)

(** 第一个例子是证明_[tree_size]_与_[tree_reverse]_之间的关系。*)

Lemma reverse_size: forall t,
  tree_size (tree_reverse t) = tree_size t.
Proof.
  intros.
  induction t.
  (** 上面这个指令说的是：对_[t]_结构归纳。Coq会自动将原命题规约为两个证明目标，
      即奠基步骤和归纳步骤。*)
  + simpl.
    (** 第一个分支是奠基步骤。这个_[simpl]_指令表示将结论中用到的递归函数根据定
        义化简。*)
    reflexivity.
  + simpl.
    (** 第二个分支是归纳步骤。我们看到证明目标中有两个前提_[IHt1]_以及_[IHt2]_。
        在英文中_[IH]_表示induction hypothesis的缩写，也就是归纳假设。在这个证明
        中_[IHt1]_与_[IHt2]_分别是左子树_[t1]_与右子树_[t2]_的归纳假设。 *)

    rewrite IHt1.
    rewrite IHt2.
    lia.
    (** 这个_[lia]_指令的全称是linear integer arithmatic，可以用来自动证明关于整
        数的线性不等式。*)
Qed.

(** 第二个例子很类似，是证明_[tree_height]_与_[tree_reverse]_之间的关系。*)

Lemma reverse_height: forall t,
  tree_height (tree_reverse t) = tree_height t.
Proof.
  intros.
  induction t.
  + simpl.
    reflexivity.
  + simpl.
    rewrite IHt1.
    rewrite IHt2.
    lia.
    (** 注意：这个_[lia]_指令也是能够处理_[Z.max]_与_[Z.min]_的。*)
Qed.

(** 下面我们将通过重写上面这一段证明，介绍Coq证明语言的一些其他功能。*)

Lemma reverse_height_attempt2: forall t,
  tree_height (tree_reverse t) = tree_height t.
Proof.
  intros.
  induction t; simpl.
  (** 在Coq证明语言中可以用分号将小的证明指令连接起来形成大的证明指令，其中
      _[tac1 ; tac2]_这个证明指令表示先执行指令_[tac1]_，再对于_[tac1]_生成的每
      一个证明目标执行_[tac2]_。分号是右结合的。*)
  + reflexivity.
  + simpl.
    lia.
    (** 此处的_[lia]_指令不仅可以处理结论中的整数线性运算，其自动证明过程中也会
        使用前提中关于整数线性运算的假设。*)
Qed.

(** 习题：*)
Lemma reverse_involutive: forall t,
  tree_reverse (tree_reverse t) = t.
Proof.
  intros.
  induction t; simpl.
  - reflexivity.
  - rewrite IHt1, IHt2.
    reflexivity.
Qed.

(** 下面证明_[tree_reverse]_是一个单射。*)

Lemma tree_reverse_inj: forall t1 t2,
  tree_reverse t1 = tree_reverse t2 ->
  t1 = t2.
Proof.
  (** 这个引理的Coq证明需要我们特别关注：真正需要归纳证明的结论是什么？如果选择
      对_[t1]_做结构归纳，那么究竟是归纳证明对于任意_[t2]_上述性质成立，还是归纳
      证明对于某“特定”的_[t2]_上述性质成立？如果我们按照之前的Coq证明习惯，用
      _[intros]_与_[induction t1]_两条指令开始证明，那就表示用归纳法证明一条关于
      “特定”_[t2]_的性质。*)
  intros.
  induction t1.
  + destruct t2.
    (** 奠基步骤的证明可以通过对_[t2]_的分类讨论完成。*)
    - reflexivity.
      (** 如果_[t2]_是空树，那么结论是显然的。*)
    - simpl in H.
      discriminate H.
      (** 如果_[t2]_是非空树，那么前提_[H]_就能导出矛盾。如上面指令展示的那样，
          _[simpl]_指令也可以对前提中的递归定义化简。当然，在这个证明中，由于之
          后的_[discriminate]_指令也会完成自动化简，这条_[simpl]_指令其实是可以
          沈略的。*)
  +
Abort.

(** 进入归纳步骤的证明时，不难发现，证明已经无法继续进行。因为需要使用的归纳假设
    并非关于原_[t2]_值的性质。正确的证明方法是用归纳法证明一条对于一切_[t2]_的结
    论。*)

Lemma tree_reverse_inj: forall t1 t2,
  tree_reverse t1 = tree_reverse t2 ->
  t1 = t2.
Proof.
  intros t1.
  (** 上面这条_[intros 1t]_指令可以精确地将_[t1]_放到证明目标的前提中，同时却将
      _[t2]_保留在待证明目标的结论中。*)
  induction t1; simpl; intros.
  + destruct t2.
    - reflexivity.
    - discriminate H.
  + destruct t2.
    - discriminate H.
    - injection H as ? ? ?.
      rewrite (IHt1_1 _ H1).
      rewrite (IHt1_2 _ H).
      rewrite H0.
      reflexivity.
Qed.

Lemma tree_reverse_inj1: forall t1 t2,
  tree_reverse t1 = tree_reverse t2 ->
  t1 = t2.
Proof.
  intro.
  induction t1; simpl; intros.
  - symmetry in H.
    rewrite (reverse_result_Leaf _ H).
    reflexivity.
  - destruct t2.
    + discriminate.
    + simpl in H.
      injection H as ? ? ?.
      rewrite (IHt1_1 _ H1).
      rewrite (IHt1_2 _ H).
      rewrite H0.
      reflexivity.
Qed.

Lemma tree_reverse_inj2 (t1 t2: tree):
  tree_reverse t1 = tree_reverse t2 -> t1 = t2.
Proof.
  revert t2.
  induction t1; simpl; intros.
  - symmetry in H.
    rewrite (reverse_result_Leaf _ H).
    reflexivity.
  - destruct t2.
    + discriminate.
    + simpl in H.
      injection H as ? ? ?.
      rewrite (IHt1_1 _ H1).
      rewrite (IHt1_2 _ H).
      rewrite H0.
      reflexivity.
Qed.

Lemma tree_reverse_inj3: forall t1 t2,
  tree_reverse t1 = tree_reverse t2 ->
  t1 = t2.
Proof.
  intros.
  rewrite <- (reverse_involutive t1).
  rewrite <- (reverse_involutive t2).
  rewrite H.
  reflexivity.
Qed.


Require Export FunctionalExtensionality.

Require Import Helpers.Automation.

Global Set Implicit Arguments.

(* [mem A V] is a partial function from A to V, which we interpret as a very
general type of memory with addresses of type A and values of type V. *)
Definition mem A V := A -> option V.
Definition empty_mem {A V} : @mem A V := fun _ => None.

(* This enables Coq's generalization feature: definitions will use [`(m: mem A
V)] (note the backtic); A and V, even if not bound, will be added as parameters
before [m]. By default no variables can be generalized; [Generalizable
Variables] allows to add identifers that are legal to generalize. *)
Global Generalizable Variables A V.

Section Memories.

  Variable A:Type.
  Variable V:Type.

  Implicit Type (m:mem A V).

  Definition mem_union m1 m2 : mem A V :=
    fun a => match m1 a with
          | Some a => Some a
          | None => m2 a
          end.

  Definition mem_disjoint m1 m2 :=
    forall a v1 v2,
      m1 a = Some v1 ->
      m2 a = Some v2 ->
      False.

  Theorem mem_union_comm : forall m1 m2,
      mem_disjoint m1 m2 ->
      mem_union m1 m2 = mem_union m2 m1.
  Proof.
    unfold mem_disjoint, mem_union; intuition.
    extensionality a.
    destruct matches; intuition.
    exfalso; eauto.
  Qed.

  Theorem mem_disjoint_comm : forall m1 m2,
      mem_disjoint m1 m2 ->
      mem_disjoint m2 m1.
  Proof.
    firstorder.
  Qed.

  Theorem mem_disjoint_from_union_1 : forall m1 m2 m3,
      mem_disjoint (mem_union m1 m2) m3 ->
      mem_disjoint m1 m3.
  Proof.
    unfold mem_disjoint, mem_union; intros.
    specialize (H a v1 v2); simpl_match; intuition.
  Qed.

  Theorem mem_disjoint_from_union_2 : forall m1 m2 m3,
      mem_disjoint (mem_union m1 m2) m3 ->
      mem_disjoint m2 m3.
  Proof.
    unfold mem_disjoint, mem_union; intros.
    case_eq (m1 a); intros.
    specialize (H a v v2); simpl_match; intuition.
    specialize (H a v1 v2); simpl_match; intuition.
  Qed.

  Theorem mem_disjoint_both_to_union : forall m1 m2 m3,
      mem_disjoint m1 m2 ->
      mem_disjoint m1 m3 ->
      mem_disjoint m1 (mem_union m2 m3).
  Proof.
    unfold mem_disjoint, mem_union; intros.
    specialize (H a).
    specialize (H0 a).
    destruct (m2 a); eauto.
  Qed.

  Theorem mem_union_assoc : forall m1 m2 m3,
      mem_disjoint m1 m2 ->
      mem_disjoint m1 m3 ->
      mem_disjoint m2 m3 ->
      mem_union (mem_union m1 m2) m3 = mem_union m1 (mem_union m2 m3).
  Proof.
    unfold mem_union, mem_disjoint; intros.
    extensionality a.
    destruct matches.
  Qed.

  Lemma mem_union_empty : forall m,
      mem_union empty_mem m = m.
  Proof.
    intros.
    extensionality a.
    reflexivity.
  Qed.

End Memories.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.LegacyArithmetic.Interface.
Require Import Crypto.LegacyArithmetic.Double.Core.
Require Import Crypto.LegacyArithmetic.Double.Proofs.Decode.
Require Import Crypto.LegacyArithmetic.Double.Proofs.ShiftLeftRightTactic.
Require Import Crypto.Util.ZUtil.
(*Require Import Crypto.Util.Tactics.*)

Local Open Scope Z_scope.

Local Opaque tuple_decoder.
Local Arguments Z.pow !_ !_.
Local Arguments Z.mul !_ !_.

Section shr.
  Context (n : Z) {W}
          {ldi : load_immediate W}
          {shl : shift_left_immediate W}
          {shr : shift_right_immediate W}
          {or : bitwise_or W}
          {decode : decoder n W}
          {isdecode : is_decode decode}
          {isldi : is_load_immediate ldi}
          {isshl : is_shift_left_immediate shl}
          {isshr : is_shift_right_immediate shr}
          {isor : is_bitwise_or or}.

  Global Instance is_shift_right_immediate_double : is_shift_right_immediate (shr_double n).
  Proof using Type*.
    intros r count H; hnf in H.
    assert (0 < 2^count) by auto with zarith.
    assert (0 < 2^(n+count)) by auto with zarith.
    assert (forall n', ~n' + count < n -> 2^n <= 2^(n'+count)) by auto with zarith omega.
    assert (forall n', ~n' + count < n -> 2^n <= 2^(n'+count)) by auto with zarith omega.
    unfold shr_double; simpl.
    generalize (decode_range r).
    pose proof (decode_range (fst r)).
    pose proof (decode_range (snd r)).
    assert (forall n', 2^n <= 2^n' -> 0 <= decode (fst r) < 2^n') by (simpl in *; auto with zarith).
    assert (forall n', n <= n' -> 0 <= decode (fst r) < 2^n') by auto with zarith omega.
    autorewrite with simpl_tuple_decoder; push_decode.
    shift_left_right_t.
  Qed.
End shr.


From Fiat.Narcissus Require Import Examples.TutorialPrelude.

Record msg := { data : list bool }.
Definition format :=
  format_nat 8 ◦ length ◦ data ++
  format_list format_bool ◦ data.
Definition invariant (m : msg) := length (m.(data)) < pow2 8.

Definition dec : CorrectAlignedDecoderFor invariant format.
Proof.
  synthesize_aligned_decoder.
Defined.


Set Primitive Projections.
Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x).
Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
Arguments idpath {A a} , [A] a.
Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := match p, q with idpath, idpath => idpath end.
Notation "p @ q" := (concat p q) (at level 20) : path_scope.
Axiom ap : forall {A B:Type} (f:A -> B) {x y:A} (p:x = y), f x = f y.
Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x.
Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A ; eisretr : forall x, f (equiv_inv x) = x }.
Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope.
Local Open Scope path_scope.
Local Open Scope equiv_scope.
Generalizable Variables A B C f g.
Lemma isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g}
: IsEquiv (compose g f).
Proof.
  refine (Build_IsEquiv A C
                        (compose g f)
                        (compose f^-1 g^-1) _).
  exact (fun c => ap g (@eisretr _ _ f _ (g^-1 c)) @ (@eisretr _ _ g _ c)).


Require Import List.

Require Import Logic.Axiom.LEM.
Require Import Logic.Axiom.Dec.
Require Import Logic.Axiom.Wec.

Require Import Logic.List.Filter.

Require Import Logic.Set.Set.
Require Import Logic.Set.Incl.
Require Import Logic.Set.Elem.
Require Import Logic.Set.Equal.
Require Import Logic.Set.ToList.
Require Import Logic.Set.Compatible.
Require Import Logic.Set.Extensionality.

(* The axiom schema of specification is implied by that of replacement.         *)

(* Given a set x and a decidable predicate p (which may depend on x), returns   *)
(* the set of all elements y of x for which p y is true. There is no need to    *)
(* consider p a two variable predicate in order to make the possible dependency *)
(* in the set x explicit. This single variable formalism will do just as well.  *)
Definition comp (x:set)(p:set -> Prop)(q:pDec p) : set :=
    fromList (filter q (toList x)).

(* The predicate needs to be decidable and compatible.                          *)
Lemma compCharac : forall (x:set) (p:set -> Prop) (q:pDec p),
    compatible p ->
    forall (z:set), z :: comp x p q <-> z :: x /\ p z.
Proof.
    intros x p q C z. unfold comp. split; intros H.
    - apply toListElem in H. destruct H as [y [H1 [H2 H3]]].
      rewrite toListFromList in H1. rewrite <- filterEquiv in H1.
      destruct H1 as [H0 H1]. split.
        + apply toListElem. exists y. split.
            { assumption. }
            { split; assumption. }
        + unfold compatible in C. apply C with y.
            { apply doubleIncl. split; assumption. }
            { assumption. }
    - destruct H as [H0 H1]. apply toListElem. apply toListElem in H0.
      destruct H0 as [y [H0 [H2 H3]]]. exists y. rewrite toListFromList. split.
        + apply filterEquiv. split.
            { assumption. }
            { unfold compatible in C. apply C with z.
                { apply doubleIncl. split; assumption. }
                { assumption. }}
        + split; assumption.
Qed.

(* Axiom schema of specification true in our model for decidable predicates.    *)
Theorem specificationDec : forall (p:set -> Prop),
    pDec p ->
    compatible p ->
    forall (x:set), exists (y:set), forall (z:set),
        z :: y <-> z :: x /\ p z.
Proof.
    intros p D C x. exists (comp x p D). apply compCharac. assumption.
Qed.

(* This is to emphasize that the predicate p above may depend on x. It is an    *)
(* immediate consequence of the main result so not very useful. It only serves  *)
(* to show there is no need to make dependency in x explicit in main result.    *)
Corollary specificationDec_ : forall (p:set -> set -> Prop),
    pDec2 p          ->
    compatible2 p   ->
    forall (x:set), exists (y:set), forall (z:set),
        z :: y <-> z :: x /\ p x z.  (* explicit dependency in x *)
Proof.
    intros p D C x. apply specificationDec.
    - apply pDec2Dec. assumption.
    - apply Comp2Comp. assumption.
Qed.

(* Axiom schema of specification for weaker assumption of weak decidability.    *)
(* Again, there is no need to make possible dependency in x explicit in p.      *)
Theorem specificationDec' : forall (p:set -> Prop),
    pWec p ->
    compatible p ->
    forall (x:set), exists (y:set), forall (z:set),
        z :: y <-> z :: x /\ p z.
Proof.
    intros p D C x.
    remember (filterWec set p D (toList x)) as H eqn:E. clear E.
    destruct H as [ys H]. exists (fromList ys). intros z. split; intros H'.
    - apply toListElem in H'. destruct H' as [z' H'].
      rewrite toListFromList in H'. destruct H' as [H0 [H1 H2]].
      remember (H z') as H3 eqn:E. clear E H. destruct H3 as [H3 H4].
      apply H4 in H0. destruct H0 as [H0 H5]. split.
        + apply toListElem. exists z'. split.
            {  assumption. }
            { split; assumption. }
        + unfold compatible in C. apply C with z'.
            { apply doubleIncl. split; assumption. }
            { assumption. }
    - destruct H' as [H0 H1]. rewrite toListElem in H0.
      destruct H0 as [z' [H0 [H2 H3]]]. apply toListElem. exists z'.
      rewrite toListFromList. split.
        + apply H. split.
            { assumption. }
            { unfold compatible in C. apply C with z.
                { apply doubleIncl. split; assumption. }
                { assumption. }}
        + split; assumption.
Qed.

(* Again, this is simply to demonstrate explicit dependency in x in not needed. *)
Corollary specificationDec'_ : forall (p:set -> set -> Prop),
    pWec2 p ->
    compatible2 p ->
    forall (x:set), exists (y:set), forall (z:set),
        z :: y <-> z :: x /\ p x z.
Proof.
    intros p D C x. apply specificationDec'.
    - apply pWec2Wec. assumption.
    - apply Comp2Comp. assumption.
Qed.


Require Import HoTT.
From GR.bicategories Require Import
     general_category.
From GR.bicategories.bicategory Require Import
     bicategory
     adjoint
     adjoint_unique
     bicategory_laws
     univalent.

Section OpBiCategory.
  Variable (C : BiCategory).

  Definition op_d : BiCategory_d.
  Proof.
    make_bicategory.
    - exact C.
    - exact (fun X Y => C⟦Y,X⟧).
    - exact (fun X => id₁ X).
    - intros X Y Z [f₁ f₂] ; cbn.
      exact (f₂ · f₁).
    - intros X Y Z [f₁ f₂] [g₁ g₂] [η₁ η₂] ; simpl in *.
      exact (η₂ * η₁).
    - intros X Y f ; simpl in *.
      apply right_unit .
    - intros X Y f ; simpl in *.
      apply right_unit_inv.
    - intros X Y f ; simpl in *.
      apply left_unit.
    - intros X Y f ; simpl in *.
      apply left_unit_inv.
    - intros W X Y Z h g f ; simpl in *.
      apply assoc_inv.
    - intros W X Y Z h g f ; simpl in *.
      apply assoc.
  Defined.

  Definition op_is_bicategory : is_bicategory op_d.
  Proof.
    make_is_bicategory.
    - intros X Y Z f ; simpl in *.
      apply hcomp_id₂.
    - intros X Y Z [f₁ f₂] [g₁ g₂] [h₁ h₂] [η₁ η₂] [ε₁ ε₂] ; simpl in *.
      apply interchange.
    - intros X Y f g η ; simpl in *.
      apply right_unit_natural.
    - intros X Y f g η ; simpl in *.
      apply right_unit_inv_natural.
    - intros X Y f g η ; simpl in *.
      apply left_unit_natural.
    - intros X Y f g η ; simpl in *.
      apply left_unit_inv_natural.
    - intros X Y f ; simpl in *.
      apply right_unit_left.
    - intros X Y f ; simpl in *.
      apply right_unit_right.
    - intros X Y f ; simpl in *.
      apply left_unit_left.
    - intros X Y f ; simpl in *.
      apply left_unit_right.
    - intros W X Y Z h₁ h₂ g₁ g₂ f₁ f₂ ηh ηg ηf ; simpl in *.
      apply assoc_inv_natural.
    - intros W X Y Z h₁ h₂ g₁ g₂ f₁ f₂ ηh ηg ηf ; simpl in *.
      apply assoc_natural.
    - intros W X Y Z f g h ; simpl in *.
      apply assoc_right.
    - intros W X Y Z f g h ; simpl in *.
      apply assoc_left.
    - intros X Y Z g f ; simpl in *.
      exact (triangle_l f g)^.
    - intros W V X Y Z k h g f ; simpl in *.
      apply inverse_pentagon.
  Qed.

  Definition op : BiCategory
    := Build_BiCategory op_d op_is_bicategory.

  Global Instance locally_univalent_op
         `{LocallyUnivalent C}
    : LocallyUnivalent op.
  Proof.
    intros X Y f g ; cbn in *.
    apply _.
  Qed.
End OpBiCategory.


Require Import rt.util.all.
Require Import rt.model.time rt.model.arrival.basic.job rt.model.arrival.basic.arrival_sequence rt.model.priority.
Require Import rt.model.schedule.uni.schedule rt.model.schedule.uni.workload.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

Module Swap.

  Import UniprocessorSchedule.

  (* In this section we define a function that swaps two jobs
     in a schedule. *)
  Section Defs.

    Context {Job: eqType}.

    (* Consider any schedule of jobs. *)
    Variable sched: schedule Job.

    (* Let t1 and t2 be any points in time. *)
    Variable t1 t2: time.

    (* For simplicity, define some local variables. *)
    Let job_at_t1 := sched t1.
    Let job_at_t2 := sched t2.

    (* We define swap as a new schedule in which whatever is scheduled
       at times t1 and t2 in the original schedule are swapped. *)
    Definition swap :=
      fun (t:time) =>
        if t == t2 then
          job_at_t1
        else if t == t1 then
          job_at_t2
        else sched t.

  End Defs.

  (* In this section we prove lemmas about the swap function. *)
  Section Lemmas.
    Context {Job: eqType}.

    (* Consider any schedule of jobs. *)
    Variable sched: schedule Job.

    (* In this section we prove symmetry properties of swap. *)
    Section Symmetry.

      (* Let t1 and t2 be any time instants to be swapped. *)
      Variable t1 t2: time.

      (* For simplicity, define some local variables. *)
      Let new_sched := swap sched t1 t2.

      (* First, we prove that the swap function is commutative with regard to times t1 and t2 ... *)
      Lemma swap_commutative:
        forall t, swap sched t2 t1 t = swap sched t1 t2 t.
      Proof.
        Admitted.

      (* ...which implies that the service function is also commutative. *)
      Corollary swap_service_commutative:
        forall j t,
          service (swap sched t2 t1) j t = service (swap sched t1 t2) j t.
      Proof.
        Admitted.

      (* If the two swap slots are the same, the schedule stays the same. *)
      Lemma swap_same_schedule_for_same_time :
	    forall t, t1 = t2 -> new_sched t = sched t.
      Proof.
        Admitted.

    End Symmetry.

    (* In this section we prove some lemmas about the service of jobs
       before the times that are swapped. *)
    Section TimeInstantsBeforeSwap.

      (* Let t1 and t2 any points *)
      Variable t1 t2: time.

      (* For simplicity, define some local variables. *)
      Let new_sched := swap sched t1 t2.

      (* ...and let j be any job.*)
      Variable j : Job.

      (* At any point in time different from the time that are swapped
         new_sched is the same as the original one. *)
      Lemma schedules_invariant_elsewhere_t1_and_t2:
        forall t, t <> t1 ->
                  t <> t2 ->
                  new_sched t = sched t.
      Proof.
        Admitted.

      (* Consequently the service of j in new_sched will be the same
         as in the original schedule. *)
      Corollary service_invariant_before_t1_and_t2:
        forall t, t <= t1 -> t <= t2 -> service new_sched j t = service sched j t.
      Proof.
        Admitted.

    End TimeInstantsBeforeSwap.

    Section TimeInstantsAfterSwap.

      (* Let t1 and t2 any points in time. *)
      Variable t1 t2: time.

      (* For simplicity, define some local variables. *)
      Let new_sched := swap sched t1 t2.

      (*Let t be any point in time after t1 and t2 ... *)
      Variable j : Job.
      Variable t : time.
      Hypothesis H_after_t1: t1 < t.
      Hypothesis H_after_t2: t2 < t.

      (* ... then the service of j in new_sched will be the same
             as in the original schedule. *)
      Lemma service_invariant_after_t1_and_t2:
        service new_sched j t = service sched j t.
      Proof.
        Admitted.

    End TimeInstantsAfterSwap.

    Section JobsNotInvolvedInSwap.

      (* Let t1 and t2 any points in time. *)
      Variable t1 t2: time.

      (* For simplicity, define some local variables. *)
      Let new_sched := swap sched t1 t2.

      (* Let j be any job that is neither scheduled at times t1 nor t2. *)
      Variable j : Job.
      Hypothesis H_not_scheduled_at_t1: scheduled_at sched j t1.
      Hypothesis H_not_scheduled_at_t2: scheduled_at sched j t2.

      (* If a job is neither scheduled at t1 nor at t2, the service for this job does not change. *)
      Lemma service_invariant_not_involved_job:
        forall t, service new_sched j t = service sched j t.
      Proof.
        Admitted.

    End JobsNotInvolvedInSwap.

  End Lemmas.

End Swap.