(* week-13_a-continuation-passing-interpreter_the-live-coding-session.v *)
(* was: *)
(* week-13_a-continuation-passing-interpreter.v *)
(* FPP 2020 - YSC3236 2020-2021, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 14 Nov 2020 *)

(* ********** *)

Ltac fold_unfold_tactic name := intros; unfold name; fold name; reflexivity.

Require Import Arith Bool List String Ascii.

(* ***** *)

Check (1 =? 2).
Check Nat.eqb.
Check (Nat.eqb 1 2).

Check (1 <=? 2).
Check Nat.leb.
Check (Nat.leb 1 2).

Check (1 <? 2).
Check Nat.ltb.
Check (Nat.ltb 1 2).

Notation "A =n=? B" := (beq_nat A B) (at level 70, right associativity).

(* ***** *)

(* caution: only use natural numbers up to 5000 *)
Definition string_of_nat (q0 : nat) : string :=
  let s0 := String (ascii_of_nat (48 + (q0 mod 10))) EmptyString
  in if q0 <? 10
     then s0
     else let q1 := q0 / 10
          in let s1 := String (ascii_of_nat (48 + (q1 mod 10))) s0
             in if q1 <? 10
                then s1
                else let q2 := q1 / 10
                     in let s2 := String (ascii_of_nat (48 + (q2 mod 10))) s1
                        in if q2 <? 10
                           then s2
                           else let q3 := q2 / 10
                                in let s2 := String (ascii_of_nat (48 + (q3 mod 10))) s2
                        in if q3 <? 10
                           then s2
                           else "00000".

(* ********** *)

(* Arithmetic expressions: *)

Inductive arithmetic_expression : Type :=
| Literal : nat -> arithmetic_expression
| Plus : arithmetic_expression -> arithmetic_expression -> arithmetic_expression
| Minus : arithmetic_expression -> arithmetic_expression -> arithmetic_expression.

(* Source programs: *)

Inductive source_program : Type :=
| Source_program : arithmetic_expression -> source_program.

(* ********** *)

(* Semantics: *)

Inductive expressible_value : Type :=
| Expressible_nat : nat -> expressible_value
| Expressible_msg : string -> expressible_value.

(* ********** *)

Definition specification_of_evaluate (evaluate : arithmetic_expression -> expressible_value) :=
  (forall n : nat,
     evaluate (Literal n) = Expressible_nat n)
  /\
  ((forall (ae1 ae2 : arithmetic_expression)
           (s1 : string),
       evaluate ae1 = Expressible_msg s1 ->
       evaluate (Plus ae1 ae2) = Expressible_msg s1)
   /\
   (forall (ae1 ae2 : arithmetic_expression)
           (n1 : nat)
           (s2 : string),
       evaluate ae1 = Expressible_nat n1 ->
       evaluate ae2 = Expressible_msg s2 ->
       evaluate (Plus ae1 ae2) = Expressible_msg s2)
   /\
   (forall (ae1 ae2 : arithmetic_expression)
           (n1 n2 : nat),
       evaluate ae1 = Expressible_nat n1 ->
       evaluate ae2 = Expressible_nat n2 ->
       evaluate (Plus ae1 ae2) = Expressible_nat (n1 + n2)))
  /\
  ((forall (ae1 ae2 : arithmetic_expression)
           (s1 : string),
       evaluate ae1 = Expressible_msg s1 ->
       evaluate (Minus ae1 ae2) = Expressible_msg s1)
   /\
   (forall (ae1 ae2 : arithmetic_expression)
           (n1 : nat)
           (s2 : string),
       evaluate ae1 = Expressible_nat n1 ->
       evaluate ae2 = Expressible_msg s2 ->
       evaluate (Minus ae1 ae2) = Expressible_msg s2)
   /\
   (forall (ae1 ae2 : arithmetic_expression)
           (n1 n2 : nat),
       evaluate ae1 = Expressible_nat n1 ->
       evaluate ae2 = Expressible_nat n2 ->
       n1 <? n2 = true ->
       evaluate (Minus ae1 ae2) = Expressible_msg (String.append "numerical underflow: -" (string_of_nat (n2 - n1))))
   /\
   (forall (ae1 ae2 : arithmetic_expression)
           (n1 n2 : nat),
       evaluate ae1 = Expressible_nat n1 ->
       evaluate ae2 = Expressible_nat n2 ->
       n1 <? n2 = false ->
       evaluate (Minus ae1 ae2) = Expressible_nat (n1 - n2))).

Definition specification_of_interpret (interpret : source_program -> expressible_value) :=
  forall evaluate : arithmetic_expression -> expressible_value,
    specification_of_evaluate evaluate ->
    forall ae : arithmetic_expression,
      interpret (Source_program ae) = evaluate ae.

(* ********** *)

Fixpoint evaluate_cps (ae : arithmetic_expression) (k : nat -> expressible_value) : expressible_value :=
  match ae with
  | Literal n =>
    k n
  | Plus ae1 ae2 =>
    evaluate_cps
      ae1
      (fun n1 =>
         evaluate_cps
           ae2
           (fun n2 =>
              k (n1 + n2)))
  | Minus ae1 ae2 =>
    evaluate_cps
      ae1
      (fun n1 =>
         evaluate_cps
           ae2
           (fun n2 =>
              if n1 <? n2
              then Expressible_msg
                     (String.append
                        "numerical underflow: -"
                        (string_of_nat (n2 - n1)))
              else k (n1 - n2)))
  end.

Lemma fold_unfold_evaluate_cps_Literal :
  forall (n : nat)
         (k : nat -> expressible_value),
    evaluate_cps
      (Literal n)
      k =
    k n.
Proof.
  fold_unfold_tactic evaluate_cps.
Qed.

Lemma fold_unfold_evaluate_cps_Plus :
  forall (ae1 ae2 : arithmetic_expression)
         (k : nat -> expressible_value),
    evaluate_cps
      (Plus ae1 ae2)
      k =
    evaluate_cps
      ae1
      (fun n1 =>
         evaluate_cps
           ae2
           (fun n2 =>
              k (n1 + n2))).
Proof.
  fold_unfold_tactic evaluate_cps.
Qed.

Lemma fold_unfold_evaluate_cps_Minus :
  forall (ae1 ae2 : arithmetic_expression)
         (k : nat -> expressible_value),
    evaluate_cps
      (Minus ae1 ae2)
      k =
    evaluate_cps
      ae1
      (fun n1 =>
         evaluate_cps
           ae2
           (fun n2 =>
              if n1 <? n2
              then Expressible_msg
                     (String.append
                        "numerical underflow: -"
                        (string_of_nat (n2 - n1)))
              else k (n1 - n2))).
Proof.
  fold_unfold_tactic evaluate_cps.
Qed.

Definition interpret (sp : source_program) : expressible_value :=
  match sp with
  | Source_program ae =>
    evaluate_cps ae (fun (n : nat) => Expressible_nat n)
  end.

(* ********** *)

Theorem interpret_satisfies_specification_of_interpret :
  specification_of_interpret interpret.
Proof.
  unfold specification_of_interpret, interpret.
  intros evaluate S_evaluate ae.
Abort.

Lemma about_evaluate_cps :
  forall evaluate : arithmetic_expression -> expressible_value,
    specification_of_evaluate evaluate ->
    forall ae : arithmetic_expression,
      (exists n : nat,
          evaluate ae = Expressible_nat n
          /\
          forall k : nat -> expressible_value,
            evaluate_cps ae k = k n)
      \/
      (exists s : string,
          evaluate ae = Expressible_msg s
          /\
          forall k : nat -> expressible_value,
            evaluate_cps ae k = Expressible_msg s).
Proof.
  intros evaluate S_evaluate ae.
  induction ae as [n |
                   ae1 [[n1 [IH1 IH1_cps]] | [s1 [IH1 IH1_cps]]] ae2 [[n2 [IH2 IH2_cps]] | [s2 [IH2 IH2_cps]]] |
                   ae1 [[n1 [IH1 IH1_cps]] | [s1 [IH1 IH1_cps]]] ae2 [[n2 [IH2 IH2_cps]] | [s2 [IH2 IH2_cps]]]].
  - left.
    unfold specification_of_evaluate in S_evaluate.
    destruct S_evaluate as [S_evaluate _].
    rewrite -> (S_evaluate n).
    exists n.
    split.
    + reflexivity.
    + intro k.
      rewrite -> fold_unfold_evaluate_cps_Literal.
      reflexivity.
  - left.
    unfold specification_of_evaluate in S_evaluate.
    destruct S_evaluate as [_ [[_ [_ S_evaluate]] _]].
    Check (S_evaluate
             ae1
             ae2
             n1
             n2
             IH1
             IH2).
    rewrite -> (S_evaluate
                  ae1
                  ae2
                  n1
                  n2
                  IH1
                  IH2).
    exists (n1 + n2).
    split.
    + reflexivity.
    + intro k.
      rewrite -> fold_unfold_evaluate_cps_Plus.
      rewrite -> IH1_cps.
      rewrite -> IH2_cps.
      reflexivity.
  - right.
    unfold specification_of_evaluate in S_evaluate.
    destruct S_evaluate as [_ [[_ [S_evaluate _]] _]].
    Check (S_evaluate
             ae1
             ae2
             n1
             s2
             IH1
             IH2).
    rewrite -> (S_evaluate
                  ae1
                  ae2
                  n1
                  s2
                  IH1
                  IH2).
    exists s2.
    split.
    + reflexivity.
    + intro k.
      rewrite -> fold_unfold_evaluate_cps_Plus.
      rewrite -> IH1_cps.
      rewrite -> IH2_cps.
      reflexivity.
  - right.
    unfold specification_of_evaluate in S_evaluate.
    destruct S_evaluate as [_ [[S_evaluate [_ _]] _]].
    Check (S_evaluate
             ae1
             ae2
             s1
             IH1).
    rewrite -> (S_evaluate
                  ae1
                  ae2
                  s1
                  IH1).
    exists s1.
    split.
    + reflexivity.
    + intro k.
      rewrite -> fold_unfold_evaluate_cps_Plus.
      rewrite -> IH1_cps.
      reflexivity.
  - right.
    unfold specification_of_evaluate in S_evaluate.
    destruct S_evaluate as [_ [[S_evaluate [_ _]] _]].
    Check (S_evaluate
             ae1
             ae2
             s1
             IH1).
    rewrite -> (S_evaluate
                  ae1
                  ae2
                  s1
                  IH1).
    exists s1.
    split.
    + reflexivity.
    + intro k.
      rewrite -> fold_unfold_evaluate_cps_Plus.
      rewrite -> IH1_cps.
      reflexivity.
  - case (n1 <? n2) eqn:H_ltb.
    + right.
      unfold specification_of_evaluate in S_evaluate.
      destruct S_evaluate as [_ [_ [_ [_ [S_evaluate _]]]]].
      Check (S_evaluate
               ae1
               ae2
               n1
               n2
               IH1
               IH2
               H_ltb).
      rewrite -> (S_evaluate
                    ae1
                    ae2
                    n1
                    n2
                    IH1
                    IH2
                    H_ltb).
      exists (String.append "numerical underflow: -" (string_of_nat (n2 - n1))).
      split.
      * reflexivity.
      * intro k.
        rewrite -> fold_unfold_evaluate_cps_Minus.
        rewrite -> IH1_cps.
        rewrite -> IH2_cps.
        rewrite -> H_ltb.
        reflexivity.
    + left.
      unfold specification_of_evaluate in S_evaluate.
      destruct S_evaluate as [_ [_ [_ [_ [_ S_evaluate]]]]].
      Check (S_evaluate
               ae1
               ae2
               n1
               n2
               IH1
               IH2
               H_ltb).
      rewrite -> (S_evaluate
                    ae1
                    ae2
                    n1
                    n2
                    IH1
                    IH2
                    H_ltb).
      exists (n1 - n2).
      split.
      * reflexivity.
      * intro k.
        rewrite -> fold_unfold_evaluate_cps_Minus.
        rewrite -> IH1_cps.
        rewrite -> IH2_cps.
        rewrite -> H_ltb.
        reflexivity.
  - right.
    unfold specification_of_evaluate in S_evaluate.
    destruct S_evaluate as [_ [_ [_ [S_evaluate _]]]].
    Check (S_evaluate
             ae1
             ae2
             n1
             s2
             IH1
             IH2).
    rewrite -> (S_evaluate
                  ae1
                  ae2
                  n1
                  s2
                  IH1
                  IH2).
    exists s2.
    split.
    + reflexivity.
    + intro k.
      rewrite -> fold_unfold_evaluate_cps_Minus.
      rewrite -> IH1_cps.
      rewrite -> IH2_cps.
      reflexivity.
  - right.
    unfold specification_of_evaluate in S_evaluate.
    destruct S_evaluate as [_ [_ [S_evaluate [_ _]]]].
    Check (S_evaluate
             ae1
             ae2
             s1
             IH1).
    rewrite -> (S_evaluate
                  ae1
                  ae2
                  s1
                  IH1).
    exists s1.
    split.
    + reflexivity.
    + intro k.
      rewrite -> fold_unfold_evaluate_cps_Minus.
      rewrite -> IH1_cps.
      reflexivity.
  - right.
    unfold specification_of_evaluate in S_evaluate.
    destruct S_evaluate as [_ [_ [S_evaluate [_ _]]]].
    Check (S_evaluate
             ae1
             ae2
             s1
             IH1).
    rewrite -> (S_evaluate
                  ae1
                  ae2
                  s1
                  IH1).
    exists s1.
    split.
    + reflexivity.
    + intro k.
      rewrite -> fold_unfold_evaluate_cps_Minus.
      rewrite -> IH1_cps.
      reflexivity.
Qed.

Theorem interpret_satisfies_specification_of_interpret :
  specification_of_interpret interpret.
Proof.
  unfold specification_of_interpret, interpret.
  intros evaluate S_evaluate ae.
  Check (about_evaluate_cps
           evaluate
           S_evaluate
           ae).
  destruct (about_evaluate_cps
              evaluate
              S_evaluate
              ae) as [[n [H_nat H_nat_cps]] |
                      [s [H_msg H_msg_cps]]].
  - Check (H_nat_cps (fun n : nat => Expressible_nat n)).
    rewrite -> (H_nat_cps (fun n : nat => Expressible_nat n)).
    symmetry.
    exact H_nat.
  - rewrite -> (H_msg_cps (fun n : nat => Expressible_nat n)).
    symmetry.
    exact H_msg.
Qed.

(* ********** *)

(* end of week-13_a-continuation-passing-interpreter.v *)


(*******************************************************************************

Title: LongExactSequences.v
Authors: Jeremy Avigad, Chris Kapulkin, Peter LeFanu Lumsdaine
Date: 1 March 2013

Gives a construction analogous to the long exact sequence of a fibration in
classical homotopy theory.

*******************************************************************************)

(* Imports *)

Require Import HoTT EquivalenceVarieties.

Require Import Auxiliary Arith Fundamentals Pullbacks Pullbacks2 PointedTypes.

Open Scope path_scope.

(*******************************************************************************

General long sequences

*******************************************************************************)

Section Long_Sequences.

(* TODO: move *)
Definition nat_ptd : pointed_type
:= {| pt_type := nat;
      point := 0 |}.

Record long_sequence := {
  lseq_obs :> nat -> pointed_type;
  lseq_maps : forall n:nat, lseq_obs (1+n) .-> lseq_obs n ;
  lseq_null : forall n:nat,
    compose_ptd (lseq_maps n) (lseq_maps (1+n))
    .== (@point (pointed_map_ptd (lseq_obs (2+n)) (lseq_obs n)))}.

Definition lseq_is_hfiber (X : long_sequence)
  := forall n, is_hfiber (lseq_maps X (1+n)) (lseq_maps X n) (lseq_null X n).

End Long_Sequences.

(* Long sequences are often constructed inductively.  This is just a little
delicate, due to the dependency between the types of the components.

Here we give a typical example construction; this serves as a template for
[hfiber_sequence] and [loop_space_sequence] below.  This template could of
course be generalised to a precise theorem, but for the present applications,
that would be more trouble than it's worth. *)

Section Long_Sequence_Template.

Hypothesis A0 : pointed_type.
Hypothesis template_iterator_dom : forall A B (f : B .-> A),
  pointed_type.
Arguments template_iterator_dom [A B] f.
Hypothesis template_iterator_map : forall A B (f : B .-> A),
  (template_iterator_dom f) .-> B.
Arguments template_iterator_map [A B] f.
Hypothesis template_iterator_null : forall A B (f : B .-> A),
  compose_ptd f (template_iterator_map f)
  .== (@point (pointed_map_ptd _ _)).
Arguments template_iterator_null [A B] f.

Definition lseq_template_aux (n:nat) : { A:pointed_type & {B : pointed_type & B .-> A}}.
Proof.
  induction n as [ | n' ABf].
  (* n=0 *) exists A0; exists A0; apply idmap_ptd.
  set (B := pr1 (pr2 ABf)).
  set (f := pr2 (pr2 ABf)).
  exists B. exists (template_iterator_dom f). exact (template_iterator_map f).
Defined.

Definition lseq_template (n:nat) : long_sequence
  := {| lseq_obs n := pr1 (lseq_template_aux n);
        lseq_maps n := pr2 (pr2 (lseq_template_aux n));
        lseq_null n := template_iterator_null
                        (pr2 (pr2 (lseq_template_aux n))) |}.

End Long_Sequence_Template.

(*******************************************************************************

The fiber sequence of a pointed map.

We first construct the fibration sequence of a pointed map simply by iteratedly
taking its fiber.  Constructed this way, it is trivially exact at each step.
We then show, in [Omega_to_hfiber_seq_0] et seq., that it is equivalent to a
sequence of loop spaces.

*******************************************************************************)

Section Hfiber_Sequence.

Definition hfiber_sequence_aux {A0 B0} (f0 : B0 .-> A0) (n:nat)
  : { A:pointed_type & {B : pointed_type & B .-> A}}.
Proof.
  induction n as [ | n' ABf].
  (* n=0 *) exists A0; exists B0; exact f0.
  (* n=1+n' *)
  set (B := pr1 (pr2 ABf)). set (f := pr2 (pr2 ABf)).
  exists B. exists (hfiber_ptd f). apply hfiber_incl_ptd.
Defined.

Arguments hfiber_sequence_aux [A B] f n : rename, simpl nomatch.

Definition hfiber_sequence {A B} (f : B .-> A) : long_sequence
:= {| lseq_obs n := pr1 (hfiber_sequence_aux f n);
      lseq_maps n := pr2 (pr2 (hfiber_sequence_aux f n));
      lseq_null n := hfiber_null _ |}.

Lemma is_hfiber_hfiber_sequence {A B} (f : B .-> A)
  : lseq_is_hfiber (hfiber_sequence f).
Proof.
  intro; apply (is_hfiber_hfiber _).
Qed.

Lemma hfiber_sequence_shift_aux {A B} (f : B .-> A) (n:nat)
  : hfiber_sequence_aux f (1+n)
  = hfiber_sequence_aux (hfiber_incl_ptd f) n.
Proof.
  induction n as [ | n' IH].
  (* n = 0 *) simpl; exact 1.
  (* n = 1+n' *)
  exact (@ap { A:pointed_type & {B : pointed_type & B .-> A}}
             { A:pointed_type & {B : pointed_type & B .-> A}}
             (fun ABf =>
               (pr1 (pr2 ABf); (hfiber_ptd (pr2 (pr2 ABf));
                 hfiber_incl_ptd (pr2 (pr2 ABf)))))
             _ _ IH).
Defined.

Lemma hfiber_sequence_shift {A B} (f : B .-> A) (n:nat)
  : hfiber_sequence f (1+n) = hfiber_sequence (hfiber_incl_ptd f) n.
Proof.
  simpl.
  change (pr1 (pr2 (hfiber_sequence_aux f n)))
  with (pr1 (hfiber_sequence_aux f (1+n))).
  apply ap, hfiber_sequence_shift_aux.
Defined.

End Hfiber_Sequence.

(******************************************************************************

The long exact sequence of loop spaces.

                                W -> Z -> 1
                                |    |    |
                                V    V    V
                                1 -> Y -> X

We show that the objects of the hfiber sequence of a map are equivalent to
iterated loop spaces.  The key lemma is showing that the double fiber of a
pointed map [f : Y .-> X] is pointed-equivalent to the loop space [Omega_ptd X].

We do *not* currently show the stronger statement that the *maps* of the hfiber
sequence agree (under the above equivalences) with the action on iterated loop
spaces of [f], and hence that the whole sequence is equivalent to one built
from loop spaces.

*******************************************************************************)

Lemma hfiber_to_Omega {X Y : pointed_type} (f:Y.->X)
: (hfiber_ptd (hfiber_incl_ptd f)) .-> Omega_ptd X.
Proof.
  apply @composeR_ptd with (pullback_ptd (hfiber_incl_ptd f) name_point).
    apply hfiber_to_pullback_ptd.
  apply @composeR_ptd with (pullback_ptd (pullback_ptd_pr1 f name_point) name_point).
    apply pullback_ptd_fmap.
    apply mk_ptd_cospan_map with (hfiber_to_pullback_ptd _) (idmap_ptd _) (idmap_ptd _).
      apply hfiber_to_pullback_ptd_factn.
      apply (concat_ptd_htpy (compose_f1_ptd _)).
      apply inverse_ptd_htpy, compose_1f_ptd.
  apply @composeR_ptd with (pullback_ptd (pullback_ptd_pr2 name_point f) name_point).
    apply pullback_ptd_fmap.
    apply mk_ptd_cospan_map with (pullback_ptd_symm _ _) (idmap_ptd _) (idmap_ptd _).
      apply (concat_ptd_htpy (pullback_ptd_symm_pr2 _ _)).
        apply inverse_ptd_htpy, compose_1f_ptd.
      apply (concat_ptd_htpy (compose_f1_ptd _)).
      apply inverse_ptd_htpy, compose_1f_ptd.
  apply @composeR_ptd with (pullback_ptd name_point (compose_ptd f name_point)).
    apply (@equiv_inverse_ptd _ _ (outer_to_double_pullback_ptd _ _ _)).
    refine (two_pullbacks_isequiv name_point f name_point).
  apply @composeR_ptd with (pullback_ptd (@name_point X) name_point).
    apply pullback_ptd_fmap.
    apply mk_ptd_cospan_map with (idmap_ptd _) (idmap_ptd _) (idmap_ptd _).
      apply (concat_ptd_htpy (compose_f1_ptd _)).
      apply inverse_ptd_htpy, compose_1f_ptd.
      apply (concat_ptd_htpy (compose_f1_ptd _)).
      apply inverse_ptd_htpy, (concat_ptd_htpy (compose_1f_ptd _)).
      exists (fun _ => pt_map_pt f).
      simpl. exact ((concat_p1 _ @ concat_1p _)^).
  apply equiv_inverse_ptd with (Omega_to_pullback_ptd X).
    apply isequiv_Omega_to_pullback.
Defined.

Lemma isequiv_hfiber_to_Omega {X Y : pointed_type} (f:Y.->X)
: IsEquiv (hfiber_to_Omega f).
Proof.
  apply @isequiv_composeR_ptd.
    apply isequiv_hfiber_to_pullback.
  apply @isequiv_composeR_ptd.
    apply (pullback_fmap_isequiv _ name_point _ name_point).
      apply isequiv_hfiber_to_pullback.
      apply isequiv_idmap.
      apply isequiv_idmap.
  apply @isequiv_composeR_ptd.
    apply (pullback_fmap_isequiv _ name_point _ name_point).
      apply pullback_symm_isequiv.
      apply isequiv_idmap.
      apply isequiv_idmap.
  apply @isequiv_composeR_ptd.
    apply isequiv_inverse.
  apply @isequiv_composeR_ptd.
    apply (pullback_fmap_isequiv name_point (f o name_point)
                                 name_point name_point);
    apply isequiv_idmap.
  apply isequiv_inverse.
Qed.

(* Note that this must be defined as a *pointed* map, since pointedness is
required for the functoriality of Omega, and hence for the induction step. *)
Lemma Omega_to_hfiber_seq_0 {X Y} (f : Y .-> X) (n:nat)
  : hfiber_sequence f (n*3) .-> (iterate Omega_ptd n) X.
Proof.
  induction n as [ | n' IH]; simpl.
  (* n=0 *) apply idmap_ptd.
  (* n=S n' *)
  apply @compose_ptd with (Y := Omega_ptd (hfiber_sequence f (n'*3))).
    apply Omega_ptd_fmap, IH.
  apply hfiber_to_Omega.
Defined.

Lemma isequiv_Omega_to_hfiber_seq_0 {X Y} (f : Y .-> X) (n:nat)
  : IsEquiv (Omega_to_hfiber_seq_0 f n).
Proof.
  induction n as [ | n' IH].
  (* n=0 *) simpl; apply isequiv_idmap.
  (* n=S n' *)
  apply @isequiv_compose with (B := Omega_ptd (hfiber_sequence f (n'*3))).
    apply isequiv_hfiber_to_Omega.
  apply isequiv_Omega_ptd_fmap, IH.
Qed.

Corollary Omega_to_hfiber_seq_1 {X Y} (f : Y .-> X) (n:nat)
  : hfiber_sequence f (1 + n*3) .-> (iterate Omega_ptd n) Y.
Proof.
  apply (compose_ptd (Omega_to_hfiber_seq_0 (hfiber_incl_ptd f) n)).
  apply equiv_path_ptd, hfiber_sequence_shift.
Defined.

Corollary isequiv_Omega_to_hfiber_seq_1 {X Y} (f : Y .-> X) (n:nat)
  : IsEquiv (Omega_to_hfiber_seq_1 f n).
Proof.
  apply isequiv_compose_ptd.
    apply isequiv_Omega_to_hfiber_seq_0.
  exact _. (* [equiv_isequiv equiv_path] found automagically. *)
Qed.

Corollary Omega_to_hfiber_seq_2 {X Y} (f : Y .-> X) (n:nat)
  : hfiber_sequence f (2 + n*3) .-> (iterate Omega_ptd n) (hfiber_ptd f).
Proof.
  apply (compose_ptd (Omega_to_hfiber_seq_1 (hfiber_incl_ptd f) n)).
  apply equiv_path_ptd, hfiber_sequence_shift.
Defined.

Corollary isequiv_Omega_to_hfiber_seq_2 {X Y} (f : Y .-> X) (n:nat)
  : IsEquiv (Omega_to_hfiber_seq_2 f n).
Proof.
  apply isequiv_compose_ptd.
    apply isequiv_Omega_to_hfiber_seq_1.
  exact _. (* [equiv_isequiv equiv_path] found automagically. *)
Qed.

(* TODO: also show how this interacts with the functoriality of Omega. *)

(*******************************************************************************
Application of the LES: equivalence of loop spaces, via truncatedness of fibers.

Goal of the section: if [X -> Y] has [n]-truncated fibers, then
[Omega ^n X <~> Omega ^n Y].
*******************************************************************************)

Corollary isequiv_loop_space_map_from_trunc_fiber
  {Y X} (f : Y .-> X)
  {n:nat} (Hn : forall x:X, IsTrunc n (hfiber f x))
: IsEquiv (Omega_ptd_fmap_iterate f n).
Proof.
Admitted.

(*******************************************************************************

An alternative construction of the [hiber_to_Omega] equivalence, this time by
hand instead of via pullbacks.  Though elementary, this is not quite as
straightforward as one might expect.

*******************************************************************************)

Lemma hfiber_to_Omega_by_hand {X Y : pointed_type} (f:Y.->X)
: (hfiber_ptd (hfiber_incl_ptd f)) .-> Omega_ptd X.
Proof.
  exists (fun y1_p_q : (hfiber_ptd (hfiber_incl_ptd f)) =>
    match y1_p_q with ((y1;p);q) => ((pt_map_pt f)^ @ (ap f q)^ @ p) end).
  simpl. exact (whiskerR (concat_p1 _) _ @ concat_Vp _).
Defined.

Lemma isequiv_hfiber_to_Omega_by_hand {X Y : pointed_type} (f:Y.->X)
: IsEquiv (hfiber_to_Omega_by_hand f).
Proof.
  refine (isequiv_adjointify (fun p => ((point; pt_map_pt f @ p); 1)) _ _).
  (* section *) intro p; simpl.
  apply (concat (whiskerR (concat_p1 _) _)).
  apply concat_V_pp.
  (* retraction *) intros [[y1 p] q]. simpl in *.
  revert y1 q p.
  refine (@id_opp_elim Y point _ _).
  intro p; simpl.
  assert (pt_map_pt f @ (((pt_map_pt f) ^ @ 1) @ p) = p) as H.
    apply (concat (whiskerL _ (whiskerR (concat_p1 _) _))).
    apply concat_p_Vp.
  apply path_sigma_uncurried. simpl.
  set (pp := @path_sigma _ (fun y => f y = point) (point; pt_map_pt f @ (((pt_map_pt f) ^ @ 1) @ p)) (point;p) 1 H).
  exists pp.
  apply (concat (transport_compose (fun (y:Y) => y = point) (hfiber_incl f point) pp _)).
  apply (concat (transport_paths_l _ _)).
  apply (concat (concat_p1 _)).
  refine (@ap _ _ inverse _ 1 _).
  refine (@pr1_path_sigma _ _
    (point; pt_map_pt f @ (((pt_map_pt f) ^ @ 1) @ p)) (point; p) 1 H).
Qed.

(*
Local Variables:
coq-prog-name: "hoqtop"
End:
*)


Add LoadPath "$COQ_PROOFS" as Path.
Load unit_1_001_days_of_week.

(* Exercise 1 *)
Definition nandb (b1:bool) (b2:bool) : bool :=
  negb(andb b1 b2).

Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.


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

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

Print Assumptions nonzero.


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

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

Print Assumptions nonzero.


Require Import rt.util.all.
Require Import rt.model.basic.task rt.model.basic.job rt.model.basic.schedule
               rt.model.basic.priority rt.model.basic.task_arrival rt.model.basic.interference.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

Module Platform.

  Import Job SporadicTaskset Schedule ScheduleOfSporadicTask SporadicTaskset SporadicTaskArrival Interference Priority.

  Section SchedulingInvariants.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

    Context {Job: eqType}.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Consider any job arrival sequence ... *)
    Context {arr_seq: arrival_sequence Job}.

    (* ... and any schedule of this arrival sequence. *)
    Context {num_cpus: nat}.
    Variable sched: schedule num_cpus arr_seq.

    Section WorkConserving.

      (* A scheduler is work-conserving iff when a job j is backlogged,
         all processors are busy with other jobs. *)
      Definition work_conserving :=
        forall j t,
          backlogged job_cost sched j t ->
          forall cpu, exists j_other,
            scheduled_on sched j_other cpu t.

      (* We also provide an alternative, equivalent definition of work-conserving
         based on counting the number of scheduled jobs. *)
      Definition work_conserving_count :=
        forall j t,
          backlogged job_cost sched j t ->
          size (jobs_scheduled_at sched t) = num_cpus.

    End WorkConserving.

    Section JLDP.

      (* A JLFP/JLDP policy ...*)
      Variable higher_eq_priority: JLDP_policy arr_seq.

      (* ... is enforced by the scheduler iff at any time t,
         a scheduled job has higher (or same) priority than (as)
         a backlogged job. *)
      Definition enforces_JLDP_policy :=
        forall (j j_hp: JobIn arr_seq) t,
          backlogged job_cost sched j t ->
          scheduled sched j_hp t ->
          higher_eq_priority t j_hp j.

    End JLDP.

    Section FP.

      (* Given an FP policy, ...*)
      Variable higher_eq_priority: FP_policy sporadic_task.

      (* ... this policy is enforced by the scheduler iff
         a corresponding JLDP policy is enforced by the scheduler. *)
      Definition enforces_FP_policy :=
        enforces_JLDP_policy (FP_to_JLDP job_task higher_eq_priority).

    End FP.

    Section Lemmas.

      (* Assume all jobs have valid parameters, ...*)
      Hypothesis H_valid_job_parameters:
        forall (j: JobIn arr_seq),
          valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

      (* In this section, we prove that the two definitions of work-conserving are equivalent. *)
      Section EquivalentDefinitions.

        Lemma work_conserving_eq_work_conserving_count :
          work_conserving <-> work_conserving_count.
        Proof.
          unfold work_conserving, work_conserving_count; split.
          {
            intros EX j t BACK.
            specialize (EX j t BACK).
            apply eq_trans with (y := size (enum (processor num_cpus)));
              last by rewrite size_enum_ord.
            unfold jobs_scheduled_at.
            apply eq_trans with (y := size ((\cat_(cpu < num_cpus) map (fun x => Some x)
                                              (make_sequence (sched cpu t)))));
              first by rewrite -map_bigcat_ord size_map.
            apply eq_trans with (y := size (\cat_(cpu < num_cpus) [:: sched cpu t])).
            {
              f_equal; apply eq_bigr; intros cpu _.
              destruct (sched cpu t) eqn:SCHED; first by done.
              by specialize (EX cpu); des; move: EX => /eqP EX; rewrite EX in SCHED.
            }
            rewrite size_bigcat_ord.
            apply eq_trans with (y := \sum_(i < num_cpus) 1);
              last by rewrite big_const_ord iter_addn mul1n addn0 size_enum_ord.
            by apply eq_bigr.
          }
          {
            intros SIZE j t BACK cpu.
            specialize (SIZE j t BACK).
            destruct ([exists cpu, sched cpu t == None]) eqn:EX; last first.
            {
              apply negbT in EX; rewrite negb_exists in EX.
              move: EX => /forallP ALL; specialize (ALL cpu).
              destruct (sched cpu t) eqn:SOME; last by done.
              by exists j0; apply/eqP.
            }
            {
              move: EX => /existsP [cpu' /eqP EX].
              unfold jobs_scheduled_at in SIZE.
              move: SIZE => /eqP SIZE; rewrite -[size _ == _]negbK in SIZE.
              move: SIZE => /negP SIZE; exfalso; apply SIZE; clear SIZE.
              rewrite neq_ltn; apply/orP; left.
              rewrite size_bigcat_ord.
              rewrite -> big_mkord_ord with (x0 := 0).
              have MKORD := big_mkord (fun x => true); rewrite -MKORD.
              have CAT := big_cat_nat _ (fun x => true).
              rewrite -> CAT with (n := cpu'); [simpl | by done | by apply ltnW, ltn_ord].
              assert (DIFF: exists k, num_cpus = (cpu' + k).+1).
              {
                exists (num_cpus - cpu').-1.
                rewrite -addnS prednK; last by rewrite ltn_subRL addn0 ltn_ord.
                rewrite addnBA; last by apply ltnW, ltn_ord.
                by rewrite addnC -addnBA // subnn addn0.
              }
              des; rewrite {5}DIFF.
              rewrite big_nat_recl; last by apply leq_addr.
              apply leq_trans with (n := (\sum_(0 <= i < cpu') 1) + 1 + (\sum_(cpu' <= i < cpu' + k) 1));
                last first.
              {
                rewrite 2!big_const_nat 2!iter_addn 2!mul1n addn0 subn0.
                rewrite [cpu' + k]addnC -addnBA // subnn 2!addn0.
                by rewrite -addnA [1 + k]addnC addnA addn1 -DIFF.
              }
              {
                rewrite -addn1 addnC [_ + 1]addnC -addnA.
                apply leq_add; first by done.
                rewrite eq_fun_ord_to_nat; unfold make_sequence at 2; rewrite EX /= add0n.
                apply leq_add; apply leq_sum; ins; unfold fun_ord_to_nat; des_eqrefl; try done;
                by unfold make_sequence; desf.
              }
            }
          }
        Qed.

      End EquivalentDefinitions.

      Section JobInvariantAsTaskInvariant.

        (* Assume any work-conserving priority-based scheduler. *)
        Variable higher_eq_priority: JLDP_policy arr_seq.
        Hypothesis H_work_conserving: work_conserving.
        Hypothesis H_enforces_JLDP_policy: enforces_JLDP_policy higher_eq_priority.

        (* Consider task set ts. *)
        Variable ts: taskset_of sporadic_task.

        (* Assume the task set has no duplicates, ... *)
        Hypothesis H_ts_is_a_set: uniq ts.
        (* ... and all jobs come from the taskset. *)
        Hypothesis H_all_jobs_from_taskset:
          forall (j: JobIn arr_seq), job_task j \in ts.

        (* Suppose that jobs are sequential, ...*)
        Hypothesis H_sequential_jobs: sequential_jobs sched.
        (* ... jobs must arrive to execute, ... *)
        Hypothesis H_completed_jobs_dont_execute:
          completed_jobs_dont_execute job_cost sched.
        (* ... and jobs do not execute after completion. *)
        Hypothesis H_jobs_must_arrive_to_execute:
          jobs_must_arrive_to_execute sched.

        (* Assume that the schedule satisfies the sporadic task model ...*)
        Hypothesis H_sporadic_tasks:
          sporadic_task_model task_period arr_seq job_task.

        (* Consider a valid task tsk, ...*)
        Variable tsk: sporadic_task.
        Hypothesis H_valid_task: is_valid_sporadic_task task_cost task_period task_deadline tsk.

        (*... whose job j ... *)
        Variable j: JobIn arr_seq.
        Variable H_job_of_tsk: job_task j = tsk.

        (*... is backlogged at time t. *)
        Variable t: time.
        Hypothesis H_j_backlogged: backlogged job_cost sched j t.

        (* Assume that any previous jobs of tsk have completed by the period. *)
        Hypothesis H_all_previous_jobs_completed :
          forall (j_other: JobIn arr_seq) tsk_other,
            job_task j_other = tsk_other ->
            job_arrival j_other + task_period tsk_other <= t ->
            completed job_cost sched j_other (job_arrival j_other + task_period (job_task j_other)).

        Let scheduled_task_other_than (tsk tsk_other: sporadic_task) :=
          task_is_scheduled job_task sched tsk_other t && (tsk_other != tsk).

        (* Then, there can be at most one pending job of each task at time t. *)
        Lemma platform_at_most_one_pending_job_of_each_task :
          forall j1 j2,
            pending job_cost sched j1 t ->
            pending job_cost sched j2 t ->
            job_task j1 = job_task j2 ->
            j1 = j2.
        Proof.
          rename H_sporadic_tasks into SPO, H_all_previous_jobs_completed into PREV.
          intros j1 j2 PENDING1 PENDING2 SAMEtsk.
          apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
          move: PENDING1 PENDING2 => /andP [ARRIVED1 /negP NOTCOMP1] /andP [ARRIVED2 /negP NOTCOMP2].
          destruct (leqP (job_arrival j1) (job_arrival j2)) as [BEFORE1 | BEFORE2].
          {
            specialize (SPO j1 j2 DIFF SAMEtsk BEFORE1).
            exploit (PREV j1 (job_task j1));
              [by done | by apply leq_trans with (n := job_arrival j2) | intros COMP1].
            apply NOTCOMP1.
            apply completion_monotonic with (t0 := job_arrival j1 + task_period (job_task j1));
              try (by done).
            by apply leq_trans with (n := job_arrival j2).
          }
          {
            apply ltnW in BEFORE2.
            exploit (SPO j2 j1); [by red; ins; subst | by rewrite SAMEtsk | by done | intro SPO'].
            exploit (PREV j2 (job_task j2));
              [by done | by apply leq_trans with (n := job_arrival j1) | intros COMP2].
            apply NOTCOMP2.
            apply completion_monotonic with (t0 := job_arrival j2 + task_period (job_task j2));
              try (by done).
            by apply leq_trans with (n := job_arrival j1).
          }
        Qed.

        (* Therefore, all processors are busy with tasks other than tsk. *)
        Lemma platform_cpus_busy_with_interfering_tasks :
          count (scheduled_task_other_than tsk) ts = num_cpus.
        Proof.
          have UNIQ := platform_at_most_one_pending_job_of_each_task.
          rename H_all_jobs_from_taskset into FROMTS,
                 H_sequential_jobs into SEQUENTIAL,
                 H_work_conserving into WORK,
                 H_enforces_JLDP_policy into PRIO,
                 H_j_backlogged into BACK,
                 H_job_of_tsk into JOBtsk,
                 H_valid_job_parameters into JOBPARAMS,
                 H_valid_task into TASKPARAMS,
                 H_all_previous_jobs_completed into PREV,
                 H_completed_jobs_dont_execute into COMP,
                 H_jobs_must_arrive_to_execute into ARRIVE.
          apply work_conserving_eq_work_conserving_count in WORK.
          unfold valid_sporadic_job, valid_realtime_job,
                 enforces_JLDP_policy,
                 task_precedence_constraints, completed_jobs_dont_execute,
                 sporadic_task_model, is_valid_sporadic_task,
                 jobs_of_same_task_dont_execute_in_parallel,
                 sequential_jobs in *.
          apply/eqP; rewrite eqn_leq; apply/andP; split.
          {
            apply leq_trans with (n := count (fun x => task_is_scheduled job_task sched x t) ts);
              first by apply sub_count; first by red; move => x /andP [SCHED _].
            unfold task_is_scheduled.
            apply count_exists; first by done.
            {
              intros cpu x1 x2 SCHED1 SCHED2.
              unfold task_scheduled_on in *.
              destruct (sched cpu t); last by done.
              move: SCHED1 SCHED2 => /eqP SCHED1 /eqP SCHED2.
              by rewrite -SCHED1 -SCHED2.
            }
          }
          {
            rewrite -(WORK j t) // -count_predT.
            apply leq_trans with (n := count (fun j: JobIn arr_seq => scheduled_task_other_than tsk (job_task j)) (jobs_scheduled_at sched t));
              last first.
            {
              rewrite -count_map.
              apply count_sub_uniqr;
                last by red; move => tsk' /mapP [j' _ JOBtsk']; subst; apply FROMTS.
              rewrite map_inj_in_uniq; first by apply scheduled_jobs_uniq.
              red; intros j1 j2 SCHED1 SCHED2 SAMEtsk.
              rewrite 2!mem_scheduled_jobs_eq_scheduled in SCHED1 SCHED2.
              apply scheduled_implies_pending with (job_cost0 := job_cost) in SCHED1; try (by done).
              apply scheduled_implies_pending with (job_cost0 := job_cost) in SCHED2; try (by done).
              by apply UNIQ.
            }
            {
              apply sub_in_count; intros j' SCHED' _.
              rewrite mem_scheduled_jobs_eq_scheduled in SCHED'.
              unfold scheduled_task_other_than; apply/andP; split.
              {
                move: SCHED' => /existsP [cpu /eqP SCHED'].
                by apply/existsP; exists cpu; rewrite /task_scheduled_on SCHED' eq_refl.
              }
              {
                apply/eqP; red; intro SAMEtsk; symmetry in SAMEtsk.
                move: BACK => /andP [PENDING NOTSCHED].
                generalize SCHED'; intro PENDING'.
                apply scheduled_implies_pending with (job_cost0 := job_cost) in PENDING'; try (by done).
                exploit (UNIQ j j' PENDING PENDING'); [by rewrite -SAMEtsk | intro EQjob; subst].
                by rewrite SCHED' in NOTSCHED.
              }
            }
          }
        Qed.

      End JobInvariantAsTaskInvariant.

    End Lemmas.

  End SchedulingInvariants.

End Platform.


Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms Coq.Program.Basics.

Add Parametric Morphism {A: Type} :
  (fun (P: A -> Prop) => exists x, P x)
    with signature (pointwise_relation A iff ==> iff)
      as exists_eq_iff_morphism.
Proof.
  intros * equiv;
  split; intro H; destruct H as [x0 H']; exists x0;
  apply equiv in H'; assumption.
Qed.

Lemma impl_iff_Proper
: Proper (iff ==> iff ==> iff) impl.
Proof. lazy; tauto. Qed.
Lemma impl_impl_Proper
: Proper (Basics.flip impl ==> impl ==> impl) impl.
Proof. lazy; tauto. Qed.
Lemma ex_iff_Proper {A}
: Proper (pointwise_relation _ iff ==> iff) (@ex A).
Proof.
  lazy.
  intros ?? H;
    repeat (intros [] || intro || esplit);
    apply H; eassumption.
Defined.
Lemma ex_impl_Proper {A}
: Proper (pointwise_relation _ impl ==> impl) (@ex A).
Proof.
  lazy.
  intros ?? H;
    repeat (intros [] || intro || esplit);
    apply H; eassumption.
Defined.
Lemma and_iff_Proper
: Proper (iff ==> iff ==> iff) and.
Proof. lazy; tauto. Qed.
Lemma and_impl_Proper
: Proper (impl ==> impl ==> impl) and.
Proof. lazy; tauto. Qed.
Global Instance and_flip_impl_Proper
: Proper (flip impl ==> flip impl ==> flip impl) and.
Proof. lazy; tauto. Qed.


Require Import XR_frac_part.
Require Import XR_Rplus_eq_compat_r.
Require Import XR_IZR_eq.
Require Import XR_up_tech.
Require Import XR_Rplus_le_compat.

Local Open Scope R_scope.

Lemma plus_Int_part2 :
  forall r1 r2:R,
    frac_part r1 + frac_part r2 < R1 ->
    Int_part (r1 + r2) = (Int_part r1 + Int_part r2)%Z.
Proof.
  intros x y.
  unfold frac_part.
  unfold Int_part.
  repeat rewrite minus_IZR.
  set (u:=up(x+y)).
  simpl.
  intro h.
  apply eq_IZR.
  repeat rewrite minus_IZR.
  repeat rewrite plus_IZR.
  repeat rewrite minus_IZR.
  simpl.
  unfold Rminus.
  repeat rewrite <- Rplus_assoc.
  apply Rplus_eq_compat_r.
  symmetry.
  change R1 with (IZR 1).
  rewrite <- opp_IZR.
  repeat rewrite <- plus_IZR.
  apply IZR_eq.
  assert (ut:=up_tech).
  specialize (ut (x+y)).
  fold u in ut.
  apply eq_IZR.
  symmetry.
  rewrite <- Rplus_0_r.
  symmetry.
  rewrite <- Rplus_opp_l with R1.
  repeat rewrite <- Rplus_assoc.
  change R1 with (IZR 1).
  rewrite <- opp_IZR.
  repeat rewrite <- plus_IZR.
  apply IZR_eq.
  apply ut.
  {
    repeat rewrite plus_IZR.
    repeat rewrite opp_IZR.
    simpl.
    assert (ax := archimed x).
    assert (ay := archimed y).
    destruct ax as [ axl axr ].
    destruct ay as [ ayl ayr ].
    apply Rplus_le_reg_r with (-(x+y)).
    rewrite Rplus_opp_r.
    apply Rplus_le_reg_r with (R1+R1).
    rewrite Rplus_0_l.
    repeat rewrite Rplus_assoc.
    rewrite (Rplus_comm (-R1)).
    repeat rewrite Rplus_assoc.
    rewrite Rplus_opp_r, Rplus_0_r.
    rewrite (Rplus_comm (-R1)).
    repeat rewrite Rplus_assoc.
    rewrite Rplus_opp_r, Rplus_0_r.
    rewrite Ropp_plus_distr.
    rewrite (Rplus_comm (IZR (up y))).
    repeat rewrite Rplus_assoc.
    rewrite (Rplus_comm (-y)).
    set (py:=IZR(up y)+-y).
    rewrite <- Rplus_assoc.
    apply Rplus_le_compat.
    {
      unfold Rminus in axr.
      exact axr.
    }
    {
      unfold py.
      unfold Rminus in ayr.
      exact ayr.
    }
  }
  {
    clear ut.
    clear u.
    repeat rewrite plus_IZR.
    rewrite opp_IZR.
    simpl.
    repeat rewrite Rplus_assoc.
    rewrite Rplus_opp_l.
    rewrite Rplus_0_r.
    unfold Rminus in h.
    repeat rewrite Ropp_plus_distr in h.
    repeat rewrite Ropp_involutive in h.
    repeat rewrite <- Rplus_assoc in h.
    pattern R1 at 3 in h ; rewrite <- Rplus_0_l in h.
    apply Rplus_lt_reg_r in h.
    apply Rplus_lt_reg_r with R1.
    repeat rewrite Rplus_assoc.
    rewrite (Rplus_comm (-R1)).
    repeat rewrite Rplus_assoc.
    rewrite Rplus_opp_r.
    rewrite Rplus_0_r.
    apply (Rplus_lt_compat_r (IZR (up y))) in h.
    repeat rewrite Rplus_assoc in h.
    rewrite Rplus_opp_l in h.
    rewrite Rplus_0_l, Rplus_0_r in h.
    apply (Rplus_lt_compat_r (IZR (up x))) in h.
    repeat rewrite Rplus_assoc in h.
    rewrite (Rplus_comm (-IZR(up x))) in h.
    repeat rewrite Rplus_assoc in h.
    rewrite Rplus_opp_r in h.
    rewrite Rplus_0_r in h.
    rewrite (Rplus_comm R1) in h.
    repeat rewrite <- Rplus_assoc in h.
    repeat rewrite <- Rplus_assoc.
    rewrite (Rplus_comm (IZR(up y))) in h.
    exact h.
  }
Qed.


Require Import NoQ.PArrow.
Require Import NoQ.Eqv.
Require Import NoQ.PreOrder.
Require Import NoQ.Universe.
Require Import NoQ.PartialOrder.
Require Import NoQ.Relation.
Require Import NoQ.Reflexive.
Require Import NoQ.Prop.
Require Import NoQ.Equivalence.
Require Import NoQ.LibReflexive.
Require Import NoQ.Symmetric.
Require Import NoQ.Transitive.
Require Import NoQ.Antisymmetric.
Require Import NoQ.Arrow.

Class MonotonicArrow U `{! Universe U } :=
  { monotonic_arrow : U -> U -> U }.
Infix "⇗" := monotonic_arrow (at level 90, right associativity).

Inductive MFun t `{! Arrow t } (A B:UPO) :=
  { mfun : dom (t A B)
  ; mfun_monotonic : proper (lte ∙⇉∙ lte) mfun
  }.
Arguments mfun {t _ A B} _.
Arguments mfun_monotonic {t _ A B} _ _ _ _.

Local Instance MFun_Eqv t `{! Arrow t }
(A B:UPO) : Eqv (MFun t A B) :=
  { eqv f g := eqv (mfun f) (mfun g) }.
Proof.
  constructor.
  - constructor ; intros ; apply lib_reflexivity.
  - constructor ; intros ; apply symmetry ; auto.
  - constructor ; intros.
    apply (transitivity (mfun y)) ; auto.
Defined.

Local Instance MFun_PreOrder t `{! Arrow t ,! Logical t } (A B:UPO)
: PreOrder (MFun t A B) :=
  { lte f g := lte (mfun f) (mfun g) }.
Proof.
  - unfold proper,"⇉" ; simpl ; intros.
    apply (lte_change_eqv (mfun x) (mfun x0)) ; logical.
    apply H1 ; auto.
  - constructor ; intros.
    apply reflexivity ; logical.
  - constructor ; intros.
    apply (transitivity (mfun y)).
    + apply H ; apply reflexivity ; logical.
    + apply H0 ; auto.
Defined.

Instance MArrow_PartialOrder t `{! Arrow t ,! Logical t ,! Monotonic t }
(A B:UPO) `{! PartialOrder (dom A) ,! PartialOrder (dom B) }
: PartialOrder (MFun t A B).
Proof.
  constructor ; constructor ; intros.
  apply logical_elim ; unfold "∙⇉∙" ; intros.
  apply antisymmetry ; monotonic ; apply reflexivity ; logical.
Defined.

Definition MArrow (A B:UPO) : UPO :=
  {| UPreOrder_dom := MFun proper_arrow A B |}.
Instance UPreOrder_MonotonicArrow : MonotonicArrow UPO :=
  { monotonic_arrow := MArrow }.

Definition MArrow_apply {A B:UPO} (f:dom (A ⇗ B)) (x:dom A)
: dom B := mfun f ∙ x.
Definition MArrow_id {A:UPO} : dom (A ⇗ A).
Proof.
  refine {| mfun := id |}.
  unfold proper,"∙⇉∙" ; intros.
  apply (lte_change_eqv x y) ; try apply id_apply ; auto.
Defined.

Definition MArrow_compose
{A B C:UPO} : dom ((B ⇗ C) ⇗ (A ⇗ B) ⇗ (A ⇗ C)).
refine {| mfun := λ (g:dom (B ⇗ C)) →
          ({| mfun := λ (f:dom (A ⇗ B)) → mfun g ∙⊙∙ mfun f |} : dom ((A ⇗ B) ⇗ (A ⇗ C)))
       |}.
Proof.
  unfold proper,"∙⇉∙" ; intros.
  apply (lte_change_eqv (mfun g ∙ (mfun f ∙ x)) (mfun g ∙ (mfun f ∙ y)))
    ; try apply compose_apply.
  apply (mfun_monotonic g).
  apply (mfun_monotonic f) ; auto.
Defined.

Instance MArrow_Arrow : Arrow MArrow :=
  { lambda_p A B f := proper (eqv ⇉ eqv) f /\ proper (lte ⇉ lte) f
  ; lambda A B f p :=
      let (peqv,plte) := p in
      {| mfun := {| pfun := f ; pfun_proper := peqv |}
       ; mfun_monotonic := plte
      |}
  ; id := @MArrow_id
  ; apply := @MArrow_apply
  ; compose := @MArrow_compose
  }.
Proof.
  - intros ; unfold MArrow_id,MArrow_apply ; simpl.
    apply id_apply.
  - intros ; unfold MArrow_id,MArrow_apply ; simpl.
    apply compose_apply.
  - intros ; unfold MArrow_compose ; simpl.
    change ((id ∙⊙∙ mfun f) ≃ mfun f).
    apply compose_id_left.
  - intros ; unfold MArrow_compose ; simpl.
    change ((mfun f ∙⊙∙ id) ≃ mfun f).
    apply compose_id_right.
  - intros ; unfold MArrow_compose ; simpl.
    change (((mfun h ∙⊙∙ mfun g) ∙⊙∙ mfun f) ≃ (mfun h ∙⊙∙ mfun g ∙⊙∙ mfun f)).
    apply compose_associativity.
Defined.

Instance MArrow_Logical : Logical MArrow :=
  { logical_intro A B f g p := p
  ; logical_elim A B f g p := p
  }.
Instance MArrow_Monotonic : Monotonic MArrow.
Proof.
  constructor ; intros.
  - unfold "∙⇉∙" ; intros.
    apply (lte_change_lte (f ∙ y) (g ∙ y)).
    + apply (mfun_monotonic f) ; auto.
    + apply reflexivity ; logical.
    + apply H ; logical.
  - change ((eqv ∙⇉∙ lte) f g).
    unfold "∙⇉∙" ; intros.
    apply H.
    apply reflexivity ; auto.
Defined.


(*Proof: A -> B -> A*)

Theorem Ex002_1 (A B : Prop): A -> B -> A.
Proof.
  intros.
  exact H.
Qed.

(*using automation*)

Theorem Ex002_2 (A B : Prop): A -> B -> A.
Proof.
  firstorder.  (*auto would be enough*)
Qed.


From Coq Require Import String List Arith Bool.
Import ListNotations.

Section Model.

Inductive Symbol :=
  | Var (v : string)
  | Cst (c : string).

Definition Term := list Symbol.

Definition Context := list Term.

Record Proposition := PROP {
  hypothesis : Context;
  conclusion : Term;
}.

Definition Universe := list Proposition.

Fixpoint substitute (τ : Term) (σ : string -> Term) : Term :=
  match τ with
  | [] => []
  | Var v::τ => (σ v) ++ (substitute τ σ)
  | x::τ => x::(substitute τ σ)
  end.

Notation "x ∈ L" := (In x L) (at level 80).
Notation "τ '⟨' σ '⟩'" := (substitute τ σ) (at level 80).

Inductive Deduce (Ω : Universe) : Context -> Term -> Prop :=
  | rule_axiom Γ τ :
    τ ∈ Γ -> Deduce Ω Γ τ
  | rule_instance Γ' τ' σ Γ τ :
    (PROP Γ' τ') ∈ Ω ->
    τ'⟨σ⟩ = τ ->
    (forall h, h ∈ Γ' -> Deduce Ω Γ (h⟨σ⟩)) ->
    Deduce Ω Γ τ.

Notation "U , G ⊢ t" := (Deduce U G t) (at level 80).

Definition Ω := [PROP [] [Cst "a"; Var "x"]].
Definition τ := [Cst "a"; Cst "b"].

Goal Ω, [] ⊢ τ.
Proof.
  eapply (rule_instance _ _ _ (fun _ => [Cst "b"])).
  + now constructor.
  + reflexivity.
  + now intros.
Qed.

End Model.

Section Mm.

Inductive Label :=
  | TypeLbl (lbl : string)
  | FactLbl (lbl : string)
  | RuleLbl (lbl : string).

Inductive Statement :=
  | Ax (stmt : Term)
  | Th (stmt : Term) (proof : list Label).

Record Rule := RULE {
  type_hypothesis : list (string * (string * string));
  fact_hypothesis : list (string * Term);
  statement    : Statement;
}.

Record File := FILE {
  (* variables : list nat;
  constants : list string; *)
  rules     : list (string * Rule);
}.

Fixpoint get {A} (l : list (string * A)) (x : string) : option A :=
  match l with
  | [] => None
  | (y, vy)::xs =>
    if (x =? y)%string then
      Some vy
    else
      get xs x
  end.

Definition Stack := list Term.
Definition Binding : Type := (string * Term).
Definition Unifier := list Binding.

Fixpoint binds (u : Unifier) (x : string) :=
  match u with
  | [] => false
  | (v, _)::u =>
    (x =? v)%string || binds u x
  end.

Definition mbind [A B] (m : option A) (f : A -> option B) : option B :=
  match m with
  | Some a => f a
  | None   => None
  end.

Definition mret  [A] (a : A)    : option A := Some a.
Definition mfail [A] (u : unit) : option A := None.
Definition when   (b : bool)   := if b then Some tt else None.
Definition unless (b : bool)   := when (negb b).

Notation "a <- x ;; y" := (mbind x (fun a => y)) (at level 80).
Notation "x ;; y" := (mbind x (fun _ => y)) (at level 80).

Fixpoint unify (Σ : Stack) (unifier : Unifier)
               (type_hyps : list (string * (string * string)))
             : option (Stack * Unifier) :=
  match Σ, type_hyps with
  | [], [] => mret ([], unifier)
  | (Cst ty::τ)::Σ, (_, (ty', v))::type_hyps =>
    unless (binds unifier v) ;;
    when (ty =? ty')%string  ;;
    unify Σ ((v, τ)::unifier) type_hyps
  | _, _ => mfail tt
  end.

Definition as_subst (unifier : Unifier) : (string -> Term) :=
  fun x =>
    match get unifier x with
    | None => [Var x]
    | Some τ => τ
    end.

Notation "τ '.⟨' σ '⟩'" := (substitute τ (as_subst σ)) (at level 80).

Fixpoint apply_unifier (unifier : Unifier) (Σ : Stack) : Stack :=
  match Σ with
  | [] => []
  | τ::Σ =>
    (substitute τ (as_subst unifier))::apply_unifier unifier Σ
  end.

Fixpoint term_eqb (τ1 τ2 : Term) : bool :=
  match τ1, τ2 with
  | [], [] => true
  | (Cst x)::xs, (Cst y)::ys =>
    (x =? y)%string && term_eqb xs ys
  | (Var x)::xs, (Var y)::ys =>
    (x =? y)%string && term_eqb xs ys
  | _, _ => false
  end.

Declare Scope term.
Delimit Scope term with term.
Notation "x =? y" := (term_eqb x y)%term.

Fixpoint match_facts (Σ : Stack) (fact_hyps : list (string * Term)) : option Stack :=
  match Σ, fact_hyps with
  | [], [] => Some []
  | τ::Σ, (_, τ')::fact_hyps =>
    if (τ =? τ')%term then
      match_facts Σ fact_hyps
    else
      None
  | _, _ => None
  end.

Inductive status :=
  | UnificationFailed
  | MatchingFailed
  | StackUnderflow
  | StackOverflow
  | UndefinedType (id : string)
  | UndefinedFact (id : string)
  | UndefinedRule (id : string)
  | WrongStmt (τ : Term)
  | Assumed (τ : Term)
  | Proved (τ : Term).

Definition term (s : Statement) : Term :=
  match s with
  | Ax τ => τ
  | Th τ _ => τ
  end.

Fixpoint exec_proof (F : File) (Σ : Stack) type_hyps fact_hyps proof :=
  match proof with
  | [] =>
    match Σ with
    | [] => StackUnderflow
    | [τ] => Proved τ
    | _ => StackOverflow
    end
  | TypeLbl lbl::proof =>
    match get type_hyps lbl with
    | Some (ty, v) => exec_proof F ([Cst ty; Var v]::Σ) type_hyps fact_hyps proof
    | None => UndefinedType lbl
    end
  | FactLbl lbl::proof =>
    match get fact_hyps lbl with
    | Some f => exec_proof F (f::Σ) type_hyps fact_hyps proof
    | None => UndefinedFact lbl
    end
  | RuleLbl lbl::proof =>
    match get (rules F) lbl with
    | Some (RULE r_type_hyps r_fact_hyps r_stmt) =>
      match unify Σ [] r_type_hyps with
      | Some (Σ, unifier) =>
        match match_facts (apply_unifier unifier Σ) r_fact_hyps with
        | Some Σ => exec_proof F ((term r_stmt).⟨unifier⟩::Σ) type_hyps fact_hyps proof
        | None => MatchingFailed
        end
      | None => UnificationFailed
      end
    | None => UndefinedRule lbl
    end
  end.

Definition check (F : File) (R : Rule) : status :=
  match statement R with
  | Ax stmt => Assumed stmt
  | Th stmt proof =>
    match exec_proof F [] (type_hypothesis R) (fact_hypothesis R) proof with
    | Proved stmt' =>
      if (stmt =? stmt')%term then Proved stmt
      else WrongStmt stmt'
    | status => status
    end
  end.

Example my_rule := RULE [("wffx", ("wff", "x"))]%string [] (Ax [Cst "a"; Var "x"]).
Example my_file := FILE [("rule_1", my_rule)]%string.
Example my_thm := RULE [("wffy", ("wff", "y"))]%string [] (Th [Cst "a"; Var "y"] [TypeLbl "wffy"; RuleLbl "rule_1"]).
Compute (check my_file my_thm).
Compute (unify [[Cst "wff"; Var "x"]] [] [("hyp1", ("wff", "y"))])%string.

End Mm.

Section Soundness.
(* Definition interp_Rule (R : Rule) : Proposition := *)
End Soundness.


From mathcomp Require Import ssreflect ssrfun ssrbool ssrint eqtype ssrnat seq choice fintype rat finfun.
From mathcomp Require Import bigop ssralg div ssrnum ssrint finset.
Require Import PIOA Meas Posrat Lems.

Set Implicit Arguments.
Unset Strict Implicit.

(*
to adapt

Lemma nseq_rcons {A} (x : nat) (a : A) : nseq (S x) a = rcons (nseq x a) a.
  induction x.
  simpl.
  done.
  simpl.
  rewrite -IHx.
  simpl.
  done.
Qed.

Lemma runPIOA_appTask_nseq {A} (P : @PIOA A) (t : Task P) (n : nat) d :
  runPIOA P (nseq n t) (appTask P t d) =
  appTask P t (runPIOA  P (nseq n t) d).
  induction n.
  done.
  rewrite nseq_rcons.
  rewrite !runPIOA_rcons.
  rewrite IHn.
  done.
Qed.

Lemma finType_bij_enum (A : finType) (f : A -> A) :
  bijective f -> perm_eq (enum A) (map f (enum A)).
  intros.
  rewrite /perm_eq; apply/allP; intros; simpl.
  rewrite count_uniq_mem.
  rewrite mem_enum.
  simpl.
  rewrite -codomE.

  rewrite count_uniq_mem.
  rewrite inj_card_onto.
  done.
  destruct H; eapply can_inj.
  apply H.
  done.
  rewrite /codom.
  rewrite map_inj_uniq.
  apply enum_uniq.
  destruct H; eapply can_inj; apply H.
  apply enum_uniq.
Qed.

Definition unifFin (A : finType) : Meas A :=
  unif (enum A).

Lemma finType_unif_bij (A : finType) (f : A -> A) :
  bijective f ->
  (unifFin A) ~~ (meas_fmap (unifFin A) f) @ 0.
  intros.
  rewrite /measEquiv; intros.
  rewrite /integ.
  rewrite /unifFin.
  rewrite /meas_fmap.
  rewrite /measBind /measJoin /measSum.
  rewrite big_flatten //=.
  rewrite big_map.
  erewrite eq_big_perm.
  instantiate (1 := map f (enum A)).

  rewrite /measScale.
  rewrite /measRet.
  rewrite !big_map.
  rewrite pdist_le0; apply/eqP.
  apply eq_bigr.
  intros.
  rewrite big_map big_cons big_nil.
  apply/eqP; rewrite /eq_op //=.
  destruct (f0 (f i)).
  simpl.
  rewrite GRing.Theory.addr0.
  rewrite GRing.Theory.mulr1.
  done.
  apply finType_bij_enum.
  done.
Qed.

Lemma partition_set1 {A : finType} (s : {set A}) :
  s <> set0 -> partition [set s] s.
  unfold partition; intros; apply/andP; split.
  unfold cover.
  rewrite big_set1.
  apply eq_refl.
  apply/andP;split.
  apply/trivIsetP.
  move=> x y Hx Hy.
  rewrite (set1P Hx).
  rewrite (set1P Hy).
  rewrite eq_refl; done.

  apply/negP.
  move=> Hx.
  rewrite (set1P Hx) in H.
  done.
Qed.

Section RandDefs.
  Context (n : nat).

Inductive Action : Type :=
  | Choose : Action
  | Output : 'I_(S n) -> Action
  | Compute : Action .

Definition sum_of_action (a : Action) :=
  match a with
  | Choose => inl tt
  | Output x => inr (inl x)
  | Compute => inr (inr tt)
                   end.

Definition action_of_sum t :=
  match t with
  | inl tt => Choose
  | inr (inl x) => Output x
  | inr (inr tt) => Compute
                      end.

Lemma action_cancel : cancel sum_of_action action_of_sum.
  by case.
Qed.

Definition action_eqmix := CanEqMixin action_cancel.
Canonical action_eqType := EqType Action action_eqmix.
Definition action_choicemix := CanChoiceMixin action_cancel.
Canonical action_choiceType := ChoiceType Action action_choicemix.
Definition action_countmix := CanCountMixin action_cancel.
Canonical action_countType := CountType Action action_countmix.
Definition action_finmix := CanFinMixin action_cancel.
Canonical action_finType := FinType Action action_finmix.

Definition RndQ := [eqType of option ('I_(S n))].

Lemma uniford_subdist : isSubdist (unifFin [finType of 'I_(S n)]).
  apply isDist_isSubdist; apply unif_isDist; rewrite //= -cardE card_ord; done.
Qed.

Definition RndTr (x : RndQ) (a : Action) : option (Meas RndQ) :=
  match x, a with
  | None, Choose => Some (x <- unifFin ([finType of 'I_(S n)]); ret (Some x))
  | Some x, Output y => if x == y then Some (ret (Some x)) else None
  | _, _ => None
              end.

Lemma RndTr_subDist x a m : RndTr x a = Some m -> isSubdist m.
destruct x, a; simpl; try congruence.
case (eqVneq o o0); intro.
subst; rewrite eq_refl.
intro H; injection H; intro; subst.
dsubdist.
rewrite (negbTE i); congruence.
intro H; injection H; intro; subst.
dsubdist.
apply uniford_subdist.
intros; dsubdist.
Qed.

Definition rndpre : prePIOA := mkPrePIOA [finType of Action] [finType of RndQ] None RndTr RndTr_subDist.

Definition RndTH := [set [set Choose]].
Definition RndI : {set Action} := set0.
Definition RndTO : {set {set Action}} := [set Output @: 'I_(S n)].

Definition RndPIOA : @PIOA [finType of Action].
  econstructor.
  instantiate (1 := RndTH).
  instantiate (1 := RndTO).
  instantiate (1 := RndI).
  constructor.
  intros.
  rewrite /RndI.
  rewrite -setI_eq0.
  rewrite set0I; done.
  intros.
  rewrite /RndI.
  rewrite -setI_eq0.
  rewrite set0I; done.
  rewrite /RndTO /RndTH.
  move=> x y;
  rewrite !in_set.
  move/eqP; intro; subst.
  move/eqP; intro; subst.
  apply/disjointP.
  intro; move/imsetP; elim.
  rewrite in_set.
  intros; subst; done.
  rewrite /RndTO.
  move => x y; rewrite !in_set; move/eqP; intro; subst; move/eqP; intro; subst.
  rewrite eq_refl; done.
  rewrite /RndTH.
  move => x y; rewrite !in_set; move/eqP; intro; subst; move/eqP; intro; subst.
  rewrite eq_refl; done.
  instantiate (1 := rndpre).

  move=> T /setUP; elim.
  rewrite /RndTO in_set.
  move/eqP; intro; subst.

  rewrite /actionDeterm.
  move=> s x y; move/imsetP; elim; intros; subst.
  move/imsetP: H1; elim; intros; subst.
  destruct s.
  rewrite /enabled.
  simpl.
  caseOn (o == x0); caseOn (o == x); intros Hx0 Hx.
  rewrite -(eqP Hx0) (eqP Hx) eq_refl //= in H2.
  rewrite Hx (negbTE Hx0); done.
  rewrite (negbTE Hx) Hx0; done.
  rewrite (negbTE Hx) (negbTE Hx0); done.
  rewrite /enabled; done.

  rewrite /RndTH in_set; move/eqP; intro; subst; rewrite /actionDeterm.
  intro.
  move=> x y; rewrite !in_set; move/eqP; intro; subst; move/eqP; intro; subst; done.
  rewrite /RndI.
  move=> s x; rewrite in_set0; done.
  intros; destruct x.
  apply/setUP; right.
  apply/bigcupP; eexists.
  rewrite in_set //=.
  rewrite in_set //=.

  apply/setUP; left; apply/setUP; right.
  apply/bigcupP; eexists.
  rewrite in_set //=.
  apply/imsetP; eexists; rewrite //=.
  destruct s.
  rewrite /enabled //= in H.
  rewrite /enabled //= in H.
Defined.

Definition RndChoose : Task RndPIOA.
econstructor.
instantiate (1 := [set Choose]).
apply/setUP; right; rewrite //= /RndTH.
rewrite in_set //=.
Defined.

Lemma Choose_notin_Out : Choose \notin cover RndTO.
apply/bigcupP.
elim.
move=>x; rewrite //= /RndTO in_set.
move/eqP; intro; subst.
move/imsetP; elim; intros; done.
Qed.

Definition RndOutput : Task RndPIOA.
  econstructor.
instantiate (1 := Output @: 'I_(S n)).
apply/setUP; left; rewrite //= /RndTO .
rewrite in_set //=.
Defined.

Definition Output_in_external1 : forall o, Output o \in external RndPIOA.
rewrite /external.
intro; apply/setUP; right.
apply/bigcupP.
eexists.
rewrite //= /RndTO in_set //=.
apply/imsetP; eexists; rewrite //=.
Qed.

Inductive RndSpec (ts : seq (Task RndPIOA)) : Prop:=
  | RndSpec1 : runPIOA _ ts (startTr _) ~~ runPIOA _ nil (startTr _) @ 0 -> RndSpec ts
  | RndSpec2 : (exists n, runPIOA _ ts (startTr _) ~~ runPIOA _ (RndChoose :: nseq n RndOutput) (startTr _) @ 0 )  -> RndSpec ts.

Lemma rndChooseOutput : forall n, runPIOA RndPIOA (RndChoose :: nseq n RndOutput) (startTr _) ~~
                               (x <- unifFin _; ret (Some x, nseq n (Output x))) @ 0 .
  induction n0.
  simpl; rewrite /appTask /startTr; dsimp.
  case:pickP => x.
  move/andP => [i1 i2]; rewrite in_set in i1; rewrite (eqP i1).
  rewrite /external //= set0U.
  dsimp.
  apply measBind_cong_r; intros; dsimp.
  rewrite (negbTE Choose_notin_Out); reflexivity.
  apply uniford_subdist.
  move/andP: (x Choose); elim.
  rewrite in_set /enabled //=.

  simpl.
  rewrite runPIOA_appTask_nseq.
  rewrite (appTask_cong RndPIOA); last by apply IHn0.

  rewrite /appTask; dsimp.
  apply measBind_cong_r; intros; dsimp.
  case:pickP => y.
  move/andP => [y0 y1].
  case (imsetP y0); intros; subst.
  rewrite /enabled in y1.
  simpl in y1.
  case (eqVneq x x0).
  intros; subst.
  rewrite eq_refl.
  dsimp.
  rewrite Output_in_external1.
  reflexivity.
  intro Hneq.
  rewrite (negbTE Hneq) in y1; done.

  move/andP: (y (Output x)); elim; rewrite /enabled //= eq_refl //=; split.
  apply/imsetP; eexists; rewrite //=.
  done.
  apply uniford_subdist.
Qed.

Lemma rndSpec : forall ts, RndSpec ts.
  induction ts using last_ind.
  apply RndSpec1.
  apply measEquiv_refl.
  destruct IHts.
  destruct x.
  have Hi := i.
  rewrite !in_set in Hi.
  elim: (orP Hi); move/eqP; intro; subst.
  apply RndSpec1.
  rewrite runPIOA_rcons.
  simpl.
  rewrite (appTask_cong _ _ _ _ H) /appTask //=.
  have H2 := @bindRet_r _ (startTr RndPIOA).
  symmetry; etransitivity; symmetry in H2. apply H2.
  apply measBind_cong_r; intros.
  destruct x.
  rewrite /measSupport /measRed /startTr in H0.
  simpl in H0.
  rewrite mem_seq1 in H0; move/eqP: H0 => H0; injection H0; intros; subst.
  simpl.
  case: pickP.
  rewrite //= /RndTO.
  move=>x /andP; elim.
  move/imsetP; elim.
  intros; subst.
  done.
  intros; reflexivity.
  rewrite /startTr; dsubdist.

  apply RndSpec2; exists 0%nat.
  simpl.
  rewrite runPIOA_rcons.
  rewrite /RndTH.
  rewrite (appTask_cong _ _ _ _ H).
  simpl.
  reflexivity.

  destruct H.
  destruct x.
  have Hi := i.
  rewrite //= !in_set in Hi.
  move/orP: Hi; elim; move/eqP; intro; subst.
  apply RndSpec2; exists (S x0).
  rewrite runPIOA_rcons.
  rewrite (appTask_cong _ _ _ _ H).
  simpl.
  remember (appTask _ RndChoose (startTr RndPIOA)).
  rewrite -Heqm.
  generalize m.
  clear H.
  induction x0.
  simpl.
  reflexivity.
  simpl; intros.
  rewrite IHx0.
  reflexivity.

  apply RndSpec2; exists x0.
  simpl.
  rewrite (runPIOA_rcons).
  rewrite (appTask_cong _ _ _ _ H).
  rewrite (appTask_cong _ _ _ _ (rndChooseOutput _)).
  have He := rndChooseOutput x0.
  simpl in He.
  symmetry; etransitivity. apply He.
  rewrite /appTask.
  dsimp.
  apply measBind_cong_r; intros.
  dsimp.
  case:pickP => x1.
  move/andP; elim; rewrite /RndTH in_set; move/eqP; intro; subst.
  rewrite /enabled.
  simpl.
  done.
  reflexivity.
  apply uniford_subdist.
Qed.

Lemma RndInputClosed : inputClosed RndPIOA.
  constructor.
Qed.

End RandDefs.

Section TrapDefs.
  Context (n : nat).

Definition TrapQ := [eqType of (unit + 'I_(S n) + 'I_(S n))%type].

Context (f : 'I_(S n) -> 'I_(S n)).
Hypothesis (H : bijective f).

Definition TrapTr (x : TrapQ) (a : Action n) : option (Meas TrapQ) :=
  match x, a with
  | inl (inl _), Choose => Some (x <- unifFin ([finType of 'I_(S n)]); ret (inl (inr x)))
  | inl (inr x), Compute => Some (ret (inr (f x)))
  | inr x, Output y => if x == y then Some (ret (inr x)) else None
  | _, _ => None
              end.

Lemma TrapTr_subdist x a mu : TrapTr x a = Some mu -> isSubdist mu.
destruct x,a.
destruct s; simpl.
try ltac:(intro Heq; injection Heq; intros; subst); dsubdist; [ apply uniford_subdist | intros; dsubdist ]; try congruence.
congruence.
destruct s; simpl; try congruence.
destruct s; simpl; try congruence.
intro Heq; injection Heq; intros; subst.
dsubdist.
simpl; congruence.
simpl.
destruct (o == o0); simpl.
intro Heq; injection Heq; intro; subst; dsubdist.
congruence.
simpl; congruence.
Qed.

Definition trappre := mkPrePIOA [finType of Action n] [finType of TrapQ] (inl (inl tt)) TrapTr TrapTr_subdist.

Definition TrapTH := [set [set Choose n]; [set Compute n]].
Definition TrapI : {set Action n} := set0.
Definition TrapTO : {set {set Action n}} := [set (@Output n) @: 'I_(S n)].

Lemma set1_inter_neq {A : finType} (x y : A) : x != y -> [set x] :&: [set y] = set0.
  intro;apply/setP.
  move=>a.
  rewrite in_setI !in_set.
  destruct (eqVneq a x); subst.
  rewrite (negbTE H0) andbF; done.
  destruct (eqVneq a y); subst.
  rewrite (negbTE i) andFb; done.
  rewrite (negbTE i) (negbTE i0); done.
Qed.

Definition TrapPIOA : @PIOA [finType of (Action n)].
  econstructor.
  instantiate (1 := TrapTH).
  instantiate (1 := TrapTO).
  instantiate (1 := TrapI); constructor.
  rewrite /TrapI; intros; apply/disjointP => y; rewrite in_set //=.
  rewrite /TrapI; intros; apply/disjointP => x; rewrite in_set //=.
  move=> x y; rewrite /TrapTO /TrapTH !in_set.
  move/eqP; intro; subst; move/orP; elim; move/eqP; intros; subst.
  apply/disjointP; move => z /imsetP; elim; rewrite in_set; intros; subst; done.
  apply/disjointP; move => z /imsetP; elim; rewrite in_set; intros; subst; done.

  move=> x y; rewrite /TrapTO.
  rewrite !in_set; move/eqP => eqx /eqP => eqy; subst.
  rewrite eq_refl; done.

  move=> x y; rewrite /TrapTH.
  rewrite !in_set.
  move/orP; elim; move/eqP; intro; subst;
  move/orP; elim; move/eqP; intro; subst.
  rewrite eq_refl //=.
  intro; apply/disjointP; move=> z; rewrite !in_set; move/eqP; intro; subst; done.
  intro; apply/disjointP; move=> z; rewrite !in_set; move/eqP; intro; subst; done.
  rewrite eq_refl //=.

  instantiate (1 := trappre).
  move=> t /setUP; elim.
  rewrite /TrapTO in_set; move/eqP; intro; subst.
  rewrite /actionDeterm.
  move=> s x y /imsetP; elim => x0 Hx0 Heq; subst; move/imsetP; elim; intros; subst.
  rewrite /enabled //= /TrapTr //=.
  destruct s.
  destruct s; done.
  caseOn (o == x0); caseOn (o == x); move=> Hex0 Hex.
  rewrite -(eqP Hex0) -(eqP Hex) eq_refl in H2; done.
  rewrite Hex (negbTE Hex0); done.
  rewrite Hex0 (negbTE Hex); done.
  rewrite (negbTE Hex0) (negbTE Hex); done.

  rewrite /TrapTH in_set.
  move/orP; elim; rewrite !in_set; move/eqP; intro; subst.
  move=> s x y; rewrite !in_set.
  move/eqP; intro; subst; move/eqP; intro; subst; done.
  move=> s x y; rewrite !in_set.
  move/eqP; intro; subst; move/eqP; intro; subst; done.
  move=> s x; rewrite in_set0; done.
  intros; destruct x.
  apply/setUP; right.
  apply/bigcupP.
  eexists.
  rewrite /TrapTH !in_set.
  apply/orP; left; rewrite //=.
  rewrite in_set //=.
  apply/setUP; left; apply/setUP; right.
  apply/bigcupP; eexists.
  rewrite /TrapTO in_set //=.
  apply/imsetP; eexists; rewrite //=.
  apply/setUP; right; apply/bigcupP; eexists.
  apply/setUP; right; rewrite in_set //=.
  rewrite in_set //=.
Defined.

Definition TrapChoose : Task TrapPIOA.
  econstructor; apply/setUP; right; apply/setUP; left; rewrite in_set; done.
Defined.

Definition TrapCompute : Task TrapPIOA.
  econstructor; apply/setUP; right; apply/setUP; right; rewrite in_set; done.
Defined.

Definition TrapOutput : Task TrapPIOA.
  econstructor; apply/setUP; left; rewrite /RndTO //=; rewrite in_set; done.
Defined.

(* TODO finish *)

Inductive TrapSpec (ts : seq (Task TrapPIOA)) : Prop :=
| TrapSpec1 : runPIOA _ ts (startTr _) ~~ startTr _ @ 0 -> TrapSpec ts
| TrapSpec2 : runPIOA _ ts (startTr _) ~~ (runPIOA _ (TrapChoose :: nil) (startTr _)) @ 0 -> TrapSpec ts
| TrapSpec3 : (exists n, runPIOA _ ts (startTr _) ~~ (runPIOA _ (TrapChoose :: TrapCompute :: nseq n TrapOutput) (startTr _)) @ 0 ) -> TrapSpec ts.

Lemma trapChoose : runPIOA _ (TrapChoose :: nil) (startTr _) ~~
                   (x <- unifFin _; ret (inl (inr x), nil)) @ 0.
  simpl.
  rewrite /appTask /startTr; dsimp.
  case:pickP => y.
  move/andP.
  rewrite in_set; elim; move/eqP => Heq Henab; subst.
  dsimp.
  apply measBind_cong_r; intros; dsimp.
  rewrite /external //= /TrapI /TrapTO set0U.
  case:bigcupP.
  elim; intros.
  rewrite in_set in H1; rewrite (eqP H1) in H2.
  move/imsetP: H2; elim; done.
  reflexivity.
  apply uniford_subdist.
  move: ((y (Choose n))).
  move/negP; elim.
  rewrite /enabled in_set eq_refl //=.
Qed.

Lemma trapChooseComputeOutput : forall n,
    (runPIOA _ (TrapChoose :: TrapCompute :: nseq n TrapOutput) (startTr _)) ~~
    (x <- unifFin _; ret (inr (f x), nseq n (Output (f x)))) @ 0.
  intros; simpl.
  rewrite (runPIOA_cong _ _ _ _ (appTask_cong _ _ _ _ trapChoose)).
  induction n0.
  simpl.
  rewrite /appTask; dsimp.
  apply measBind_cong_r; intros; dsimp.
  case: pickP => y.
  move/andP; elim; rewrite in_set; move/eqP; intro; subst.
  rewrite /external //= set0U.

  case: bigcupP.
  elim; rewrite /TrapTO; intro z; rewrite in_set; move/eqP; intro; subst.
  case:imsetP.
  elim.
  intros; done.
  done.
  intros;
  dsimp.
  reflexivity.

  move: (y (Compute n)).
  move/negP; elim; apply/andP; split.
  rewrite in_set //=.
  rewrite /enabled //=.
  apply uniford_subdist.
  rewrite nseq_rcons.
  rewrite runPIOA_rcons.
  rewrite (appTask_cong _ _ _ _ IHn0).
  rewrite /appTask; dsimp.
  apply measBind_cong_r; intros.
  dsimp.
  case:pickP; intros.
  move/andP: i => [i1 i2].
  rewrite /RndTO in i1.
  move/imsetP: i1; elim; intros; subst.
  case (eqVneq (f x) x1).
  intro; subst; rewrite eq_refl; dsimp.
  rewrite /external //= set0U.
  case: bigcupP; elim; intros.
  reflexivity.
  rewrite /TrapTO.
  exists ([set Output x | x : 'I_(S n)]).
  rewrite in_set //=.
  apply/imsetP; eexists; rewrite //=.
  intro Hneq; rewrite /enabled //= in i2.
  rewrite (negbTE Hneq) in i2; done.
  move: (e (Output (f x))).
  move/negP; elim; apply/andP.
  rewrite /enabled //= eq_refl //=.
  split; [apply/imsetP; eexists; rewrite //= | done].
  apply uniford_subdist.
Qed.

Lemma trapSpec : forall ts, TrapSpec ts.
  induction ts using last_ind.
  apply TrapSpec1; reflexivity.
  destruct IHts.
  destruct x.
  have Hi := i.
  simpl in Hi.
  move/setUP: Hi.
  rewrite in_set.
  rewrite in_set.
  elim.
  move/eqP.
  rewrite /RndTO.
  intro; subst; apply TrapSpec1.
  rewrite runPIOA_rcons.
  rewrite (appTask_cong _ _ _ _ H0).
  rewrite /appTask /startTr; dsimp.
  case:pickP => y.
  move/andP; elim; move/imsetP; elim; intros; subst.
  done.
  reflexivity.

  move/orP; elim.
  rewrite in_set; move/eqP; intro; subst.
  apply TrapSpec2.
  simpl.
  rewrite runPIOA_rcons.
  rewrite (appTask_cong _ _ _ _ H0).
  reflexivity.
  rewrite in_set; move/eqP; intro; subst.
  apply TrapSpec1.
  rewrite runPIOA_rcons.
  rewrite (appTask_cong _ _ _ _ H0).
  rewrite /appTask; dsimp; rewrite /startTr; dsimp.
  case:pickP => y.
  move/andP; elim; rewrite in_set; move/eqP; intro; subst.
  reflexivity.
  reflexivity.

  destruct x.
  have Hi := i.
  move/setUP: Hi.
  simpl.
  elim.
  rewrite in_set; move/eqP; intro; subst.
  apply TrapSpec2.
  rewrite runPIOA_rcons.
  rewrite (appTask_cong _ _ _ _ H0).
  rewrite (appTask_cong _ _ _ _ trapChoose).
  symmetry; rewrite trapChoose; symmetry.
  rewrite /appTask.
  dsimp; apply measBind_cong_r; intros; dsimp.
  case:pickP => y.
  move/andP; elim; move/imsetP; elim; intros; subst.
  reflexivity.
  reflexivity.
  apply uniford_subdist.
  move/setUP; elim.
  rewrite in_set; move/eqP; intro; subst; apply TrapSpec2.
  rewrite runPIOA_rcons.
  rewrite (appTask_cong _ _ _ _ H0).
  rewrite (appTask_cong _ _ _ _ trapChoose).
  symmetry; rewrite trapChoose; symmetry.
  rewrite /appTask.
  dsimp; apply measBind_cong_r; intros; dsimp.
  case:pickP => y.
  move/andP; rewrite in_set; elim; move/eqP; intros; subst.
  reflexivity.
  reflexivity.
  apply uniford_subdist.
  rewrite in_set; move/eqP; intro; subst.
  apply TrapSpec3.
  rewrite runPIOA_rcons.
  exists 0%nat. rewrite (appTask_cong _ _ _ _ H0).
  rewrite (appTask_cong _ _ _ _ trapChoose).
  symmetry; rewrite trapChooseComputeOutput; symmetry.
  rewrite /appTask; dsimp.
  apply measBind_cong_r; intros; dsimp.

  case:pickP => y.
  move/andP; rewrite in_set; elim; move/eqP; intros; subst; dsimp.

  rewrite /external //= /TrapI /TrapTO set0U.

  case: bigcupP.
  elim => i0; rewrite in_set; move/eqP; intro; subst; case:imsetP.
  elim; done.
  done.
  reflexivity.

  move: (y (Compute n)).
  move/negP.
  elim.
  rewrite /enabled in_set eq_refl //=.
  apply uniford_subdist.

  destruct x.
  have Hi := i.
  move/setUP: Hi.
  simpl.
  elim.
  rewrite in_set; move/eqP; intro; subst.
  destruct H0.
  apply TrapSpec3.
  rewrite runPIOA_rcons.
  eexists.
  rewrite (appTask_cong _ _ _ _ H0).
  rewrite (appTask_cong _ _ _ _ (trapChooseComputeOutput _)).
  symmetry; rewrite trapChooseComputeOutput; symmetry.
  rewrite /appTask.
  dsimp.
  apply measBind_cong_r; intros; dsimp. case:pickP => y.
  move/andP; rewrite /RndTO; elim; move/imsetP; elim; intros; subst.
  have: (f x0) == x1.
  rewrite /enabled in H4.
  simpl in H4.
  apply/contraT.
  intro He; rewrite (negbTE He) in H4; done.
  intro He; rewrite He.
  dsimp.
  rewrite /external //= /TrapI /TrapTO set0U.
  case:bigcupP.
  instantiate (1 := S x).
  elim; intros; simpl.
  rewrite (eqP He).
  reflexivity.
  elim.
  exists ([set Output x | x : 'I_(S n)]).
  rewrite in_set //=.
  apply/imsetP; eexists; rewrite //=.
  move: (y (Output (f x0))).
  move/negP.
  elim.
  apply/andP; split.
  apply/imsetP; eexists; done.
  rewrite /enabled //= eq_refl //=;  done.
  apply uniford_subdist.
  intro; apply TrapSpec3.
  rewrite runPIOA_rcons.
  destruct H0.
  exists x0.
  rewrite (appTask_cong _ _ _ _ H0).
  rewrite (appTask_cong _ _ _ _ (trapChooseComputeOutput _)).
  symmetry; rewrite (trapChooseComputeOutput _); symmetry.
  rewrite /appTask.
  dsimp; apply measBind_cong_r; intros; dsimp.
  case:pickP => y.
  move/andP; elim.
  move/setUP: H1.
  elim;
  rewrite in_set; move/eqP; intro; subst; rewrite in_set; move/eqP; intro; subst.

  done.
  done.
  reflexivity.
  apply uniford_subdist.
Qed.

Lemma trapInputClosed : inputClosed TrapPIOA.
  constructor.
Qed.

End TrapDefs.

Section RndTrapProofs.
  Context (n : nat).
  Context (f : 'I_(S n) -> 'I_(S n)).
  Context (fbij : bijective f).

Lemma TRRefine : @refinement _ (TrapPIOA f) (RndPIOA n) (trapInputClosed f) (RndInputClosed _) 0.
  unfold refinement.
  intro.
  destruct (trapSpec ts);
  rewrite /traceOf.
  exists nil.
  simpl.
  rewrite (fmap_cong _ _ _ _ H).
  reflexivity.
  exists nil.
  simpl.
  rewrite (fmap_cong _ _ _ _ H).
  rewrite /meas_fmap.
  simpl.
  rewrite /appTask /startTr.
  dsimp.
  case: pickP.
  intro; move/andP; elim; rewrite in_set; move/eqP; intro; subst; intro.
  dsimp.
  apply measBind_irr.
  apply unif_isDist.
  rewrite -cardE card_ord; done.
  intro; dsimp.
  rewrite /external //= /TrapI /TrapTO set0U.
  case:bigcupP.
  elim => i; rewrite in_set; move/eqP; intro; subst; case:imsetP.
  elim; done.
  done.
  intro; dsimp.
  intro; dsimp.

  destruct H.
  exists (RndChoose n :: nseq x (RndOutput n)).
  rewrite (fmap_cong _ _ _ _ H).
  rewrite (fmap_cong _ _ _ _ (trapChooseComputeOutput _)).
  symmetry; rewrite (fmap_cong _ _ _ _ (rndChooseOutput _)).
  rewrite /meas_fmap; dsimp.

  rewrite (measBind_cong_l (finType_unif_bij fbij)).
  rewrite /meas_fmap.
  dsimp.

  apply measBind_cong_r; intros; dsimp.
  apply uniford_subdist.
  intro; dsubdist.
  intros; dsubdist.
Qed.

Lemma RTRefine : @refinement _ (RndPIOA n) (TrapPIOA f)  (RndInputClosed _) (trapInputClosed f) 0.
  intro.
  rewrite /traceOf.
  destruct (rndSpec ts).
  exists nil.
  rewrite (fmap_cong _ _ _ _ H).
  reflexivity.
  destruct H.
  exists (TrapChoose f :: TrapCompute f :: nseq x (TrapOutput f)).

  rewrite (fmap_cong _ _ _ _ H).
  rewrite (fmap_cong _ _ _ _ (rndChooseOutput _)).
  rewrite (fmap_cong _ _ _ _ (trapChooseComputeOutput _)).
  rewrite /meas_fmap; dsimp.
  rewrite (measBind_cong_l (finType_unif_bij fbij)) /meas_fmap; dsimp.
  apply measBind_cong_r; intros; dsimp.
  apply uniford_subdist.
  intros; dsubdist; intros; dsubdist.
Qed.

End RndTrapProofs.
*)


(** * 6.887 Formal Reasoning About Programs, Spring 2016 - Pset 1 *)

Require Import Frap Pset1Sig.

Theorem allPositive_ok : forall (m : map_) (x : nat),
  allPositive m
  -> x > 0
  -> interp_map m x > 0.
Proof.
Admitted.

Theorem reduce_swap : forall e ls1 ls2, interp_reduce e (ls1 ++ ls2) = interp_reduce e (ls2 ++ ls1).
Proof.
Admitted.

Theorem interp_swap : forall e ls1 ls2, interp_mr e (ls1 ++ ls2) = interp_mr e (ls2 ++ ls1).
Proof.
Admitted.

Theorem mapReduce_partition_two : forall m r ls1 ls2, interp_mr (m, r) (ls1 ++ ls2) = interp_reduce r [interp_mr (m, r) ls1; interp_mr (m, r) ls2].
Proof.
Admitted.

Arguments app {_} _ _ .

Theorem mapReduce_partition : forall m r lsls, interp_mr (m, r) (fold_left app lsls []) = interp_reduce r (List.map (interp_mr (m, r)) lsls).
Proof.
Admitted.

(* For full credit, the code you turn in can't use [Admitted] or [admit] anymore! *)


Require Import VST.floyd.proofauto. (* Import the Verifiable C system *)
Require Import VST.progs.bin_search. (* Import the AST of this C program *)
(* The next line is "boilerplate", always required after importing an AST. *)
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Fixpoint sorted (l : list Z) : Prop :=
  match l with
  | [] => True
  | x::rest =>
    match rest with [] => True | y::_ =>  x <= y /\ sorted rest end
  end.

(* Beginning of the API spec for the bin_search.c program *)
Definition search_spec :=
 DECLARE _search
  WITH a: val, sh : share, contents : list Z, tgt : Z, lo : Z, hi : Z
  PRE [ _a OF (tptr tint), _tgt OF tint, _lo OF tint, _hi OF tint ]
            PROP  (readable_share sh;
                     0 <= lo <= Int.max_signed;
                     hi <= Zlength contents <= Int.max_signed;
                     Int.min_signed <= hi <= Int.max_signed / 2;
                     sorted contents;
                     Forall (fun x => Int.min_signed <= x <= Int.max_signed) contents;
                     Int.min_signed <= tgt <= Int.max_signed)
                  LOCAL (temp _a a; temp _tgt (Vint (Int.repr tgt));
                         temp _lo (Vint (Int.repr lo)); temp _hi (Vint (Int.repr hi)))
          SEP   (data_at sh (tarray tint (Zlength contents)) (map Vint (map Int.repr contents)) a)
  POST [ tint ]
    EX i:Z,
         PROP (if in_dec Z.eq_dec tgt (sublist lo hi contents) then Znth i contents = tgt else i = -1)
          LOCAL (temp ret_temp  (Vint (Int.repr i)))
           SEP (data_at sh (tarray tint (Zlength contents)) (map Vint (map Int.repr contents)) a).

(* The spec of "int main(void){}" always looks like this. *)
Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog nil gv
  POST [ tint ] main_post prog nil gv.

(* Packaging the API spec all together. *)
Definition Gprog : funspecs :=
        ltac:(with_library prog [search_spec; main_spec]).

Lemma sublist_nil1 : forall A i j (l : list A), j <= i -> sublist i j l = [].
Proof.
  intros; destruct (eq_dec i j).
  - subst; apply sublist_nil.
  - unfold sublist; rewrite Z2Nat_neg; auto; omega.
Qed.

Lemma Znth_In : forall A (d: Inhabitant A) i (l : list A) x (Hrange : 0 <= i < Zlength l)
                       (Hnth : Znth i l = x), In x l.
Proof.
  unfold Znth; intros.
  destruct (zlt i 0); [omega|].
  subst; apply nth_In.
  rewrite Zlength_correct in Hrange; auto.
  rep_omega.
Qed.

Lemma In_Znth : forall A (d: Inhabitant A) (l : list A) x,
    In x l ->
    exists i, 0 <= i < Zlength l /\ Znth i l = x.
Proof.
  unfold Znth; intros.
  apply In_nth with (d := d) in H; destruct H as (n & ? & ?).
  exists (Z.of_nat n); split.
  - rewrite Zlength_correct; omega.
  - destruct (zlt (Z.of_nat n) 0); [omega|].
    rewrite Nat2Z.id; auto.
Qed.

Lemma sublist_of_nil : forall A i j, sublist i j (nil : list A) = [].
Proof.
  intros; unfold sublist.
  rewrite skipn_nil, firstn_nil; auto.
Qed.

Fixpoint sorted2 l :=
  match l with
  | [] => True
  | x :: rest => Forall (fun y => x <= y) rest /\ sorted2 rest
  end.

Lemma sorted_equiv : forall l, sorted l <-> sorted2 l.
Proof.
  induction l; simpl.
  - reflexivity.
  - destruct l.
    + simpl; split; auto.
    + rewrite IHl; simpl; split; intros (? & Hall & ?); split3; auto.
       * constructor; auto.
          rewrite Forall_forall in *; intros ? Hin.
          specialize (Hall _ Hin); omega.
       * inversion H. auto.
Qed.

Lemma sorted_mono : forall l i j (Hsort : sorted l) (Hi : 0 <= i <= j)
                           (Hj : j < Zlength l),
    Znth i l <= Znth j l.
Proof.
induction l; intros.
* rewrite !Znth_nil. omega.
*
 rewrite sorted_equiv in Hsort. destruct Hsort as [H9 Hsort].
 rewrite <- sorted_equiv in Hsort. rewrite Forall_forall in H9.
 rewrite Zlength_cons in Hj.
 destruct (zeq i 0).
 +
   subst i; rewrite Znth_0_cons.
   destruct (zeq j 0).
   - subst j. rewrite Znth_0_cons. omega.
   - rewrite Znth_pos_cons by omega.
      apply H9.
      eapply Znth_In; [ | reflexivity]; omega.
 +
    rewrite !Znth_pos_cons by omega.
    apply IHl; auto; omega.
Qed.

Lemma In_sorted_range : forall lo hi x l (Hsort : sorted l) (Hlo : 0 <= lo <= hi)
                              (Hhi : hi <= Zlength l)
                              (Hin : In x (sublist lo hi l)),
    Znth lo l <= x <= Znth (hi - 1) l.
Proof.
  intros.
  generalize (In_Znth _ _ _ _ Hin); intros (i & Hrange & Hi).
  rewrite Zlength_sublist in Hrange by auto.
  rewrite Znth_sublist in Hi by omega.
  subst; split; apply sorted_mono; auto; omega.
Qed.

Lemma In_sorted_gt : forall x i n l lo hi (Hsort : sorted l) (Hlo : lo >= 0)
                            (Hhi : hi <= Zlength l)
                            (Hin : In x (sublist lo hi l))
                            (Hi : lo <= i < hi) (Hn : Znth i l = n)
                            (Hgt : n < x),
    In x (sublist (i + 1) hi l).
Proof.
  intros.
  rewrite sublist_split with (mid := i + 1) in Hin; try omega.
  rewrite in_app in Hin; destruct Hin; auto.
  generalize (In_sorted_range lo (i + 1) x _ Hsort); intro X.
  repeat (lapply X; [clear X; intro X | omega]).
  replace (i + 1 - 1) with i in X by omega.
  specialize (X H); subst; omega.
Qed.

Lemma In_sorted_lt : forall x i n l lo hi (Hsort : sorted l) (Hlo : lo >= 0)
                            (Hhi : hi <= Zlength l)
                            (Hin : In x (sublist lo hi l))
                            (Hi : lo <= i < hi) (Hn : Znth i l = n)
                            (Hgt : x < n),
    In x (sublist lo i l).
Proof.
  intros.
  rewrite sublist_split with (mid := i) in Hin; try omega.
  rewrite in_app in Hin; destruct Hin; auto.
  generalize (In_sorted_range i hi x _ Hsort); intro X.
  repeat (lapply X; [clear X; intro X | omega]).
  specialize (X H); subst; omega.
Qed.

Lemma Znth_In_sublist : forall A (d: Inhabitant A) i (l : list A) lo hi
  (Hlo : 0 <= lo <= i) (Hhi : i < hi <= Zlength l),
  In (Znth i l) (sublist lo hi l).
Proof.
  intros.
  apply Znth_In with (i := i - lo)(d := d).
  - rewrite Zlength_sublist; omega.
  - rewrite <- (Z.sub_simpl_r i lo) at 2.
    apply Znth_sublist; omega.
Qed.

Lemma sublist_In_sublist : forall A (l : list A) x lo hi lo' hi' (Hlo : 0 <= lo <= lo')
  (Hhi : hi' <= hi), In x (sublist lo' hi' l) -> In x (sublist lo hi l).
Proof.
  intros.
  apply sublist_In with (lo0 := lo' - lo)(hi0 := hi' - lo); rewrite sublist_sublist;
    try split; try omega.
  - repeat rewrite Z.sub_simpl_r; auto.
  - destruct (Z_le_dec hi' lo'); try omega.
    rewrite sublist_nil1 in *; auto; simpl in *; contradiction.
Qed.

Lemma body_search: semax_body Vprog Gprog f_search search_spec.
Proof.
 start_function.
 destruct H0.
 assert (H6 := Int.min_signed_neg).
 forward_while (EX lo' : Z, EX hi' : Z,
    PROP  (0 <= lo' <= Int.max_signed;
           Int.min_signed <= hi' <= Int.max_signed / 2;
           hi' <= Zlength contents;
           In tgt (sublist lo hi contents) <-> In tgt (sublist lo' hi' contents))
    LOCAL (temp _a a; temp _tgt (Vint (Int.repr tgt));
           temp _lo (Vint (Int.repr lo')); temp _hi (Vint (Int.repr hi')))
    SEP   (data_at sh (tarray tint (Zlength contents))
                   (map Vint (map Int.repr contents)) a)).
 * Exists lo; Exists hi; entailer!.
 * entailer!.
 *
  match goal with H : _ <-> _ |- _ => rename H into H_tgt_sublist end.
  forward.  (* mid =  (lo + hi) >> 1; *) {
   entailer!.
   clear - H8 HRE H7.
   set (j := Int.max_signed / 2) in *; compute in j; subst j.
   set (j := Int.max_signed) in *; compute in j; subst j.
   set (j := Int.min_signed) in *; compute in j; subst j.
   omega.
 }
  rewrite add_repr, Int.shr_div_two_p.
  change (two_p (Int.unsigned (Int.repr 1))) with 2.
  assert (Hlo'hi':  lo' + hi' <= Int.max_signed). {
   transitivity (Int.max_signed / 2 + Int.max_signed / 2).
   - apply Zplus_le_compat; omega.
   - rewrite Zplus_diag_eq_mult_2, Z.mul_comm. apply Z_mult_div_ge; omega.
  }
  rewrite !Int.signed_repr by omega.
  set (mid := (lo' + hi') / 2) in *.
  assert (H13: 0 <= mid < Zlength contents)
    by (subst; split; [apply Z_div_pos | apply Zdiv_lt_upper_bound]; omega).
  assert (H15: lo' <= mid < hi')
    by (split; [apply Zdiv_le_lower_bound | apply Zdiv_lt_upper_bound]; omega).
  assert (H16: Int.min_signed <= Znth mid contents <= Int.max_signed)
    by (rewrite Forall_forall in H3; apply H3; eapply Znth_In; eauto).
  clear H3 Hlo'hi' H H0 H1.
  clearbody mid.
  forward. (* val = a[mid]; *)
  autorewrite with sublist.
  forward_if.
  - forward. (* return mid; *)
    Exists mid; entailer!.
    rewrite if_true; auto.
    rewrite H_tgt_sublist.
    apply Znth_In_sublist; omega.
  - forward_if.
    + forward. (*  lo = mid + 1; *)
      Exists ((mid + 1), hi'); simpl fst; simpl snd; entailer!.
      rewrite H_tgt_sublist.
      split; intro Hin'.
      eapply In_sorted_gt; eauto; omega.
      eapply sublist_In_sublist; try apply Hin'; omega.
    + forward. (* hi=mid; *)
      Exists (lo',mid). simpl fst. simpl snd. entailer!.
      rewrite H_tgt_sublist.
      split; intro Hin'.
      eapply In_sorted_lt; eauto; omega.
      eapply sublist_In_sublist; try apply Hin'; omega.
 *
    forward.  (* return -1; *)
    Exists (-1); entailer!.
    rewrite if_false; auto.
    match goal with H : _ <-> _ |- _ => rewrite H end.
    rewrite sublist_nil1 by omega.
    clear; simpl; tauto.
Qed.

(* Contents of the extern global initialized array "_four" *)
Definition four_contents := [1; 2; 3; 4].

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
  start_function.
  forward_call (gv _four,Ews,four_contents,3,0,4).
  { split. auto.
    change (Zlength four_contents) with 4.
    repeat constructor; computable.
  }
  Intro r; forward.
Qed.

Existing Instance NullExtension.Espec.

Lemma prog_correct:
  semax_prog prog Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons body_search.
semax_func_cons body_main.
Qed.