Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.arrival_sequence
               prosa.classic.model.schedule.uni.schedule
               prosa.classic.model.schedule.uni.schedulability.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module Sustainability.

  Import ArrivalSequence UniprocessorSchedule Schedulability.

  Section SustainabilityDefs.

    (* Consider any job type. *)
    Context {Job: eqType}.

    Section DefiningParameters.

      (** Defining Parameter Type *)
      Section ParameterType.

        (* We begin by defining the set of possible parameter labels, ... *)
        Inductive parameter_label :=
        | JOB_ARRIVAL
        | JOB_COST
        | JOB_DEADLINE
        | JOB_JITTER
        | JOB_SUSPENSION.

        (* ...which can be compared with the built-in decidable equality. *)
        Scheme Equality for parameter_label.
        Lemma eqlabelP: Equality.axiom parameter_label_beq.
        Proof.
          intros x y.
          by destruct x; destruct y; try (by apply ReflectT); try (by apply ReflectF).
        Qed.
        Canonical label_eqMixin := EqMixin eqlabelP.
        Canonical label_eqType := Eval hnf in EqType parameter_label label_eqMixin.

        (* Next, we associate to each label a type of function over jobs. *)
        Definition type_of_label (l: parameter_label) : Type :=
          match l with
          | JOB_ARRIVAL => Job -> instant
          | JOB_COST => Job -> time
          | JOB_DEADLINE => Job -> time
          | JOB_JITTER => Job -> time
          | JOB_SUSPENSION => Job -> time -> duration
          end.

        (* For each function type, we also define a default value to simplify lookups. *)
        Definition default_val (l : parameter_label) : type_of_label l :=
          match l with
          | JOB_ARRIVAL => fun _ => 0
          | JOB_COST => fun _ => 0
          | JOB_DEADLINE => fun _ => 0
          | JOB_JITTER => fun _ => 0
          | JOB_SUSPENSION => fun _ _ => 0
          end.

        (* Finally, we define a job parameter as a pair containing a label and a function. *)
        Record job_parameter := param
        {
          p_label : parameter_label;
          p_function : type_of_label p_label
        }.

        (* With the definitions above, we can declare parameter lists as follows. *)
        Variable example_job_cost: Job -> time.
        Variable example_job_suspension: Job -> time -> duration.
        Let example_params :=
          [:: param JOB_COST example_job_cost; param JOB_SUSPENSION example_job_suspension].

      End ParameterType.

      (** Looking up parameters *)
      Section ParameterLookup.

        (* By comparing labels, we define a function that finds a parameter in a list. *)
        Definition find_param (l : parameter_label) (s : seq job_parameter) :=
          nth (param l (default_val l)) s
              (find (fun x => p_label x == l) s).

        (* Next, we define a function that converts a given parameter p to the
           type of label l, given a proof EQ that the labels are the same. *)
        Let convert_parameter_type (p: job_parameter) (l: parameter_label)
                                   (EQ_PROOF: p_label p = l) :=
          eq_rect (p_label p) (fun x => type_of_label x) (p_function p) l EQ_PROOF.

        (* This allows returning the function of (type_of_label l) from a parameter p.
           (If the label of p is not l, we return a dummy default value instead.) *)
        Definition get_param_function (l: parameter_label) (p: job_parameter) : type_of_label l :=
          if (parameter_label_eq_dec (p_label p) l) is left EQ_PROOF then
            convert_parameter_type p l EQ_PROOF
          else (default_val l).

        (* To conclude, we define a function that returns the function with label l from a parameter list. *)
        Definition return_param (l: parameter_label) (s: seq job_parameter) : type_of_label l :=
          get_param_function l (find_param l s).

        (* To illustrate how these functions work, consider this simple parameter list. *)
        Variable example_job_cost: Job -> time.
        Variable example_job_suspension: Job -> time -> duration.
        Let example_params :=
          [:: param JOB_COST example_job_cost; param JOB_SUSPENSION example_job_suspension].

        (* In that case, JOB_COST returns the function example_job_cost, ...*)
        Example return_param_works1:
          return_param JOB_COST example_params = example_job_cost.
        Proof. by done. Qed.

        (* ...and JOB_SUSPENSION_DURATION returns the function example_job_suspension. *)
        Example return_param_works2:
          return_param JOB_SUSPENSION example_params = example_job_suspension.
        Proof. by done. Qed.

      End ParameterLookup.

      (** Additional properties of parameter lists *)
      Section Properties.

        (* Given a set of labels, we define whether two parameter lists differ only
           by the parameters with those labels.
           Note: This predicate assumes that both lists have similar, unique labels.  *)
        Definition differ_only_by (variable_labels: seq parameter_label) (s1 s2: seq job_parameter) :=
          forall (param param': job_parameter),
            List.In param s1 ->
            List.In param' s2 ->
            p_label param = p_label param' ->
            p_label param \notin variable_labels ->
            param = param'.

        (* Next, we define a function that returns the labels of a parameter list. *)
        Definition labels_of (params: seq job_parameter) := [seq p_label p | p <- params].

        (* Next, we define whether a parameter list has unique labels. *)
        Definition has_unique_labels (params: seq job_parameter) := uniq (labels_of params).

        (* We also define whether a parameter list corresponds to a given set of labels. *)
        Definition corresponding_labels (params: seq job_parameter) (labels: seq parameter_label) :=
          forall l, l \in labels_of params <-> l \in labels.

        (* Finally, we prove that in any list of unique parameters, return_param always
           returns the corresponding parameter. *)
        Lemma found_param_label:
          forall (params: seq job_parameter) (p: job_parameter) (label: parameter_label),
            has_unique_labels params ->
            List.In p params ->
            p_label p = label ->
            p = param label (return_param label params).
        Proof.
          induction params as [| p0 params']; first by done.
          move => p label /= /andP [NOTIN UNIQ] IN EQ /=.
          move: IN => [EQ0 | IN].
          {
            subst p0; rewrite /return_param /find_param /= EQ eq_refl /=.
            by destruct p, label; simpl in *; subst.
          }
          {
            rewrite /return_param /find_param /=.
            case EQ': (_ == _); last by apply IHparams'.
            move: EQ' => /eqP EQ'; rewrite EQ' in NOTIN.
            move: NOTIN => /negP NOTIN; exfalso; apply NOTIN.
            by apply/mapP2; exists p.
          }
        Qed.

      End Properties.

    End DefiningParameters.

    (** Definition of sustainability for scheduling policies. *)
    Section SustainabilityPolicy.

      (* First, we define the set of possible labels for the job parameters. *)
      Variable all_labels: seq parameter_label.

      (* Next, let's consider any good schedulability property of a job, such as
         "no deadline miss" or "response time bounded by R".
         Given a sequence of job parameters, a schedule and a job j in this schedule,
         the predicate indicates whether j satisfies the schedulability property. *)
      Variable is_schedulable:
        seq job_parameter -> schedule Job -> Job -> bool.

      (* Also, consider any predicate that, given a parameter list, states whether the arrival
         sequence and schedule belong to a certain task model. *)
      Variable belongs_to_task_model:
        seq job_parameter -> arrival_sequence Job -> schedule Job -> Prop.

      (* Let sustainable_param denote the label of the parameter for which we claim sustainability. *)
      Variable sustainable_param: parameter_label.

      (* Let better_params denote any total order relation over the old and new values of the
         sustainable parameter, i.e., it indicates: "the second parameter is better than the first".
         For example, in many task models, lower job costs lead to better schedules, so a valid
         predicate would be: (fun job_cost job_cost' => forall j, job_cost j >= job_cost' j).  *)
      Variable has_better_params: (type_of_label sustainable_param) ->
                                  (type_of_label sustainable_param) -> Prop.

      (* Next, we define whether the sustainable parameter becomes better when moving from list
         params to params'. *)
      Definition sustainable_param_becomes_better (params params': seq job_parameter) :=
        let P := return_param sustainable_param params in
        let P' := return_param sustainable_param params' in
          has_better_params P P'.

      Section VaryingParameters.

        (* Let variable_params denote the set of parameters that are allowed to vary. *)
        Variable variable_params: seq parameter_label.

        (* Now we define whether both the sustainable and the variable parameters belong to a parameter list. *)
        Definition sustainable_and_varying_params_in (params: seq job_parameter) :=
          forall label,
            label \in sustainable_param :: variable_params ->
            label \in labels_of params.

      (* Next, we define whether a parameter list has consistent labels. Since
         we'll have to quantify over many parameter lists, this prevents issues
         with empty/invalid parameter lists. *)
      Definition has_consistent_labels (params: seq job_parameter) :=
        has_unique_labels params /\
        corresponding_labels params all_labels /\
        sustainable_and_varying_params_in params.

        (* Next, we define whether all jobs sets with given params are schedulable... *)
        Definition jobs_are_schedulable_with (params: seq job_parameter) :=
          forall arr_seq sched j,
            belongs_to_task_model params arr_seq sched ->
            is_schedulable params sched j.

        (* ...and also define whether the job sets that only differ from the given params
           by the 'set of variable parameters' are all schedulable. *)
        Definition jobs_are_V_schedulable_with (params: seq job_parameter) :=
          forall (similar_params: seq job_parameter),
            has_consistent_labels similar_params ->
            differ_only_by variable_params params similar_params ->
            jobs_are_schedulable_with similar_params.

        (* Then, we say that the scheduling policy is weakly-sustainable with sustainable_param
           and variable_params iff the following holds:
              if jobs are V-schedulable with the original parameters, then they are also
              schedulable with better parameters (according to the has_better_params relation). *)
        Definition weakly_sustainable :=
          forall (params better_params: seq job_parameter),
            has_consistent_labels params ->
            has_consistent_labels better_params ->
            differ_only_by [::sustainable_param] params better_params ->
            sustainable_param_becomes_better params better_params ->
            jobs_are_V_schedulable_with params ->
            jobs_are_schedulable_with better_params.

        (* Next, using the contrapositive of weakly_sustainable, we provide
           an alternative definition of weak sustainability. *)
        Section AlternativeDefinition.

          (* First, let's define whether the sustainable parameter becomes
             worse when switching from params to params'. *)
          Definition sustainable_param_becomes_worse (params params': seq job_parameter) :=
            let P := return_param sustainable_param params in
            let P' := return_param sustainable_param params' in
              has_better_params P' P.

          (* Next, we define whether jobs are not schedulable with a given set of parameters. *)
          Definition jobs_are_not_schedulable_with (params: seq job_parameter) :=
            exists arr_seq sched j,
              belongs_to_task_model params arr_seq sched /\
              ~~ is_schedulable params sched j.

          (* Based on that, we formalize the alternative definition of weakly sustainable. *)
          Definition weakly_sustainable_contrapositive :=
            forall params params_worse,
              has_consistent_labels params ->
              has_consistent_labels params_worse ->
              jobs_are_not_schedulable_with params ->
              differ_only_by [:: sustainable_param] params params_worse ->
              sustainable_param_becomes_worse params params_worse ->
              exists params_worse',
                has_consistent_labels params_worse' /\
                differ_only_by variable_params params_worse params_worse' /\
                jobs_are_not_schedulable_with params_worse'.

          (* Assume De Morgan's law for propositional and predicate logic. *)
          Hypothesis H_classical_forall_exists:
            forall (T: Type) (P: T -> Prop),
              ~ (forall x, ~ P x) -> exists x, P x.
          Hypothesis H_classical_and_or:
            forall (P Q: Prop), ~ (P /\ Q) -> ~ P \/ ~ Q.

          (* Then, we can prove the equivalence of the two definitions. *)
          Theorem weak_sustainability_equivalence:
            weakly_sustainable <-> weakly_sustainable_contrapositive.
          Proof.
            rename H_classical_forall_exists into NOTALL, H_classical_and_or into ANDOR.
            split.
            {
              intros WEAK params params_worse CONS CONSworse NOTSCHED DIFF WORSE.
              apply NOTALL; intro ALL.
              unfold weakly_sustainable in *.
              specialize (WEAK params_worse params CONSworse CONS).
              feed WEAK.
              {
                intros p p' IN IN' EQ NOTIN; symmetry.
                apply DIFF; try by done.
                by rewrite -EQ.
              }
              feed WEAK; first by done.
              feed WEAK.
              {
                intros params' CONS' DIFF'; specialize (ALL params').
                apply ANDOR in ALL; move: ALL => [BUG | ALL] //.
                apply ANDOR in ALL; move: ALL => [BUG | ALL] //.
                unfold jobs_are_not_schedulable_with in *.
                intros arr_seq sched j BELONGS; apply contraT; intro NOTSCHED'.
                by exfalso; apply ALL; exists arr_seq, sched, j.
              }
              unfold jobs_are_schedulable_with, jobs_are_not_schedulable_with in *.
              clear -WEAK NOTSCHED.
              move: NOTSCHED => [arr_seq [sched [j [BELONGS NOTSCHED]]]].
              specialize (WEAK arr_seq sched j BELONGS).
              by rewrite WEAK in NOTSCHED.
            }
            {
              intros WEAK params better_params CONS CONSbetter DIFF BETTER VSCHED.
              intros arr_seq sched j BELONGS; apply contraT; intros NOTSCHED.
              unfold weakly_sustainable_contrapositive in *.
              feed (WEAK better_params params); first by done.
              feed WEAK; first by done.
              feed WEAK; first by exists arr_seq, sched, j.
              feed WEAK.
              {
                intros p p' IN IN' EQ NOTIN; symmetry.
                apply DIFF; try by done.
                by rewrite -EQ.
              }
              feed WEAK; first by done.
              move: WEAK => [params_worse' [CONS' [DIFF' NOTSCHED']]].
              unfold jobs_are_V_schedulable_with in *.
              specialize (VSCHED params_worse' CONS' DIFF').
              move: NOTSCHED' => [arr_seq' [sched' [j' [BELONGS' NOTSCHED']]]].
              specialize (VSCHED arr_seq' sched' j' BELONGS').
              by rewrite VSCHED in NOTSCHED'.
            }
          Qed.

        End AlternativeDefinition.

      End VaryingParameters.

      (* Also, we say that the scheduling policy is strongly-sustainable
         with sustainable_param iff it is weakly-sustainable with
         sustainable_param and the set of variable parameters is empty. *)
      Definition strongly_sustainable := weakly_sustainable [::].

    End SustainabilityPolicy.

  End SustainabilityDefs.

  Global Arguments job_parameter: clear implicits.

End Sustainability.


(* The "?" of cons and eq should be inferred *)
Variable list : Set -> Set.
Variable cons : forall T : Set, T -> list T -> list T.
Check (forall n : list nat, exists l : _, (exists x : _, n = cons _ x l)).

(* Examples provided by Eduardo Gimenez *)

Definition c A (Q : (nat * A -> Prop) -> Prop) P :=
  Q (fun p : nat * A => let (i, v) := p in P i v).

(* What does this test ? *)
Require Import List.
Definition list_forall_bool (A : Set) (p : A -> bool)
  (l : list A) : bool :=
  fold_right (fun a r => if p a then r else false) true l.

(* Checks that solvable ? in the lambda prefix of the definition are harmless*)
Parameter A1 A2 F B C : Set.
Parameter f : F -> A1 -> B.
Definition f1 frm0 a1 : B := f frm0 a1.

(* Checks that solvable ? in the type part of the definition are harmless *)
Definition f2 frm0 a1 : B := f frm0 a1.

(* Checks that sorts that are evars are handled correctly (BZ#705) *)
Require Import List.

Fixpoint build (nl : list nat) :
 match nl with
 | nil => True
 | _ => False
 end -> unit :=
  match nl return (match nl with
                   | nil => True
                   | _ => False
                   end -> unit) with
  | nil => fun _ => tt
  | n :: rest =>
      match n with
      | O => fun _ => tt
      | S m => fun a => build rest (False_ind _ a)
      end
  end.

(* Checks that disjoint contexts are correctly set by restrict_hyp *)
(* Bug de 1999 corrigé en déc 2004 *)

Check
  (let p :=
     fun (m : nat) f (n : nat) =>
     match f m n with
     | exist _ a b => exist _ a b
     end in
   p
   :forall x : nat,
    (forall y n : nat, {q : nat | y = q * n}) ->
    forall n : nat, {q : nat | x = q * n}).

(* Check instantiation of nested evars (BZ#1089) *)

Check (fun f:(forall (v:Type->Type), v (v nat) -> nat) => f _ (Some (Some O))).

(* This used to fail with anomaly (Pp.str "evar was not declared.") in V8.0pl3 *)

Theorem contradiction : forall p, ~ p -> p -> False.
Proof. trivial. Qed.
Hint Resolve contradiction.
Goal False.
eauto.
Abort.

(* This used to fail in V8.1beta because first-order unification was
   used before using type information *)

Check (exist _ O (refl_equal 0) : {n:nat|n=0}).
Check (exist _ O I : {n:nat|True}).

(* An example (initially from Marseille/Fairisle) that involves an evar with
   different solutions (Input, Output or bool) that may or may not be
   considered distinct depending on which kind of conversion is used *)

Section A.
Definition STATE := (nat * bool)%type.
Let Input := bool.
Let Output := bool.
Parameter Out : STATE -> Output.
Check fun (s : STATE) (reg : Input) => reg = Out s.
End A.

(* The return predicate found should be: "in _=U return U" *)
(* (feature already available in V8.0) *)

Definition g (T1 T2:Type) (x:T1) (e:T1=T2) : T2 :=
  match e with
  | refl_equal => x
  end.

(* An example extracted from FMapAVL which (may) test restriction on
   evars problems of the form ?n[args1]=?n[args2] with distinct args1
   and args2 *)

Set Implicit Arguments.
Parameter t:Set->Set.
Parameter map:forall elt elt' : Set, (elt -> elt') -> t elt -> t elt'.
Parameter avl: forall elt : Set, t elt -> Prop.
Parameter bst: forall elt : Set, t elt -> Prop.
Parameter map_avl: forall (elt elt' : Set) (f : elt -> elt') (m : t elt),
   avl m -> avl (map f m).
Parameter map_bst: forall (elt elt' : Set) (f : elt -> elt') (m : t elt),
   bst m -> bst (map f m).
Record bbst (elt:Set) : Set :=
  Bbst {this :> t elt; is_bst : bst this; is_avl: avl this}.
Definition t' := bbst.
Section B.
Variables elt elt': Set.
Definition map' f (m:t' elt) : t' elt' :=
  Bbst (map_bst f m.(is_bst)) (map_avl f m.(is_avl)).
End B.
Unset Implicit Arguments.

(* An example from Lexicographic_Exponentiation that tests the
   contraction of reducible fixpoints in type inference *)

Require Import List.
Check (fun (A:Set) (a b x:A) (l:list A)
  (H : l ++ cons x nil = cons b (cons a nil)) =>
  app_inj_tail l (cons b nil) _ _ H).

(* An example from NMake (simplified), that uses restriction in solve_refl *)

Parameter h:(nat->nat)->(nat->nat).
Fixpoint G p cont {struct p} :=
  h (fun n => match p with O => cont | S p => G p cont end n).

(* An example from Bordeaux/Cantor that applies evar restriction
   below  a binder *)

Require Import Relations.
Parameter lex : forall (A B : Set), (forall (a1 a2:A), {a1=a2}+{a1<>a2})
-> relation A -> relation B -> A * B -> A * B -> Prop.
Check
 forall (A B : Set) eq_A_dec o1 o2,
 antisymmetric A o1 -> transitive A o1 -> transitive B o2 ->
 transitive _ (lex _ _ eq_A_dec o1 o2).

(* Another example from Julien Forest that tests unification below binders *)

Require Import List.
Set Implicit Arguments.
Parameter
 merge : forall (A B : Set) (eqA : forall (a1 a2 : A), {a1=a2}+{a1<>a2})
                         (eqB : forall (b1 b2 : B), {b1=b2}+{b1<>b2})
                        (partial_res l : list (A*B)), option (list (A*B)).
Axiom merge_correct :
   forall (A B : Set) eqA eqB (l1 l2 : list (A*B)),
       (forall a2 b2 c2, In (a2,b2) l2 -> In (a2,c2) l2 -> b2 = c2) ->
       match merge eqA eqB l1 l2 with _ => True end.
Unset Implicit Arguments.

(* An example from Bordeaux/Additions that tests restriction below binders *)

Section Additions_while.

Variable A : Set.
Variables P Q : A -> Prop.
Variable le : A -> A -> Prop.
Hypothesis Q_dec : forall s : A, P s -> {Q s} + {~ Q s}.
Hypothesis le_step : forall s : A, ~ Q s -> P s -> {s' | P s' /\ le s' s}.
Hypothesis le_wf : well_founded le.

Lemma loopexec : forall s : A, P s -> {s' : A | P s' /\ Q s'}.
refine
  (well_founded_induction_type le_wf (fun s => _ -> {s' : A | _ /\ _})
    (fun s hr i =>
       match Q_dec s i with
       | left _ => _
       | right _ =>
           match le_step s _ _ with
           | exist _ s' h' =>
               match hr s' _ _ with
               | exist _ s'' _ => exist _ s'' _
               end
           end
       end)).
Abort.

End Additions_while.

(* Two examples from G. Melquiond (BZ#1878 and BZ#1884) *)

Parameter F1 G1 : nat -> Prop.
Goal forall x : nat, F1 x -> G1 x.
refine (fun x H => proj2 (_ x H)).
Abort.

Goal forall x : nat, F1 x -> G1 x.
refine (fun x H => proj2 (_ x H) _).
Abort.

(* An example from y-not that was failing in 8.2rc1 *)

Fixpoint filter (A:nat->Set) (l:list (sigT A)) : list (sigT A) :=
  match l with
  | nil => nil
  | (existT _ k v)::l' => (existT _ k v):: (filter A l')
  end.

(* BZ#2000: used to raise Out of memory in 8.2 while it should fail by
   lack of information on the conclusion of the type of j *)

Goal True.
set (p:=fun j => j (or_intror _ (fun a:True => j (or_introl _ a)))) || idtac.
Abort.

(* Remark: the following example stopped succeeding at some time in
   the development of 8.2 but it works again (this was because 8.2
   algorithm was more general and did not exclude a solution that it
   should have excluded for typing reason; handling of types and
   backtracking is still to be done) *)

Section S.
Variables A B : nat -> Prop.
Goal forall x : nat, A x -> B x.
refine (fun x H => proj2 (_ x H) _).
Abort.
End S.

(* Check that constraints are taken into account by tactics that instantiate *)

Lemma inj : forall n m, S n = S m -> n = m.
intros n m H.
eapply f_equal with (* should fail because ill-typed *)
  (f := fun n =>
        match n return match n with S _ => nat | _ => unit end with
        | S n => n
        | _ => tt
        end) in H
|| injection H.
Abort.

(* A legitimate simple eapply that was failing in coq <= 8.3.
   Cf. in Unification.w_merge the addition of an extra pose_all_metas_as_evars
   on 30/9/2010
*)

Lemma simple_eapply_was_failing :
 (forall f:nat->nat, exists g, f = g) -> True.
Proof.
 assert (modusponens : forall P Q, P -> (P->Q) -> Q) by auto.
 intros.
 eapply modusponens.
 simple eapply H.
 (* error message with V8.3 :
    Impossible to unify "?18" with "fun g : nat -> nat => ?6 = g". *)
Abort.

(* Regression test *)

Definition fo : option nat -> nat := option_rec _ (fun a => 0) 0.

(* This example revealed an incorrect evar restriction at some time
   around October 2011 *)

Goal forall (A:Type) (a:A) (P:forall A, A -> Prop), (P A a) /\ (P A a).
intros.
refine ((fun H => conj (proj1 H) (proj2 H)) _).
Abort.

(* The argument of e below failed to be inferred from r14219 (Oct 2011) to *)
(* r14753 after the restrictions made on detecting Miller's pattern in the *)
(* presence of alias, only the second-order unification procedure was *)
(* able to solve this problem but it was deactivated for 8.4 in r14219 *)

Definition k0
  (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat)
  (j : forall a, exists n : nat, n = a) o :=
 match o with (* note: match introduces an alias! *)
 | Some a => e _ (j a)
 | None => O
 end.

Definition k1
  (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat)
  (j : forall a, exists n : nat, n = a) a (b:=a) := e _ (j a).

Definition k2
  (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat)
  (j : forall a, exists n : nat, n = a) a (b:=a) := e _ (j b).

(* Other examples about aliases involved in pattern unification *)

Definition k3
  (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat)
  (j : forall a, exists n : nat, let a' := a in n = a') a (b:=a) := e _ (j b).

Definition k4
  (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat)
  (j : forall a, exists n : nat, let a' := S a in n = a') a (b:=a) := e _ (j b).

Definition k5
  (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat)
  (j : forall a, let a' := S a in exists n : nat, n = a') a (b:=a) := e _ (j b).

Definition k6
  (e:forall P : nat -> Prop, (exists n : nat, P n) -> nat)
  (j : forall a, exists n : nat, let n' := S n in n' = a) a (b:=a) := e _ (j b).

Definition k7
  (e:forall P : nat -> Prop, (exists n : nat, let n' := n in P n') -> nat)
  (j : forall a, exists n : nat, n = a) a (b:=a) := e _ (j b).

(* An example that uses materialize_evar under binders *)
(* Extracted from bigop.v in the mathematical components library *)

Section Bigop.

Variable bigop : forall R I: Type,
  R -> (R -> R -> R) -> list I -> (I->Prop) -> (I -> R) -> R.

Hypothesis eq_bigr :
forall (R : Type) (idx : R) (op : R -> R -> R)
       (I : Type) (r : list I) (P : I -> Prop) (F1 F2 : I -> R),
       (forall i : I, P i -> F1 i = F2 i) ->
       bigop R I idx op r (fun i : I => P i) (fun i : I => F1 i) = idx.

Hypothesis big_tnth :
forall (R : Type) (idx : R) (op : R -> R -> R)
     (I : Type) (r : list I) (P : I -> Prop) (F : I -> R),
     bigop R I idx op r (fun i : I => P i) (fun i : I => F i) = idx.

Hypothesis big_tnth_with_letin :
forall (R : Type) (idx : R) (op : R -> R -> R)
     (I : Type) (r : list I) (P : I -> Prop) (F : I -> R),
     bigop R I idx op r (fun i : I => let i:=i in P i) (fun i : I => F i) = idx.

Variable R : Type.
Variable idx : R.
Variable op : R -> R -> R.
Variable I : Type.
Variable J : Type.
Variable rI : list I.
Variable rJ : list J.
Variable xQ : J -> Prop.
Variable P : I -> Prop.
Variable Q : I -> J -> Prop.
Variable F : I -> J -> R.

(* Check unification under binders *)

Check (eq_bigr _ _ _ _ _ _ _ _ (fun _ _ => big_tnth _ _ _ _ rI _ _))
  : (bigop R J idx op rJ
        (fun j : J => let k:=j in xQ k)
        (fun j : J => let k:=j in
         bigop R I idx
           op rI
           (fun i : I => P i /\ Q i k) (fun i : I => let k:=j in F i k))) = idx.

(* Check also with let-in *)

Check (eq_bigr _ _ _ _ _ _ _ _ (fun _ _ => big_tnth_with_letin _ _ _ _ rI _ _))
  : (bigop R J idx op rJ
        (fun j : J => let k:=j in xQ k)
        (fun j : J => let k:=j in
         bigop R I idx
           op rI
           (fun i : I => P i /\ Q i k) (fun i : I => let k:=j in F i k))) = idx.

End Bigop.

(* Check the use of (at least) an heuristic to solve problems of the form
   "?x[t] = ?y" where ?y occurs in t without easily knowing if ?y can
   eventually be erased in t *)

Section evar_evar_occur.
  Variable id : nat -> nat.
  Variable f : forall x, id x = 0 -> id x = 0 -> x = 1 /\ x = 2.
  Variable g : forall y, id y = 0 /\ id y = 0.
  (* Still evars in the resulting type, but constraints should be solved *)
  Check match g _ with conj a b => f _ a b end.
End evar_evar_occur.

(* Eta expansion (BZ#2936) *)
Record iffT (X Y:Type) : Type := mkIff { iffLR : X->Y; iffRL : Y->X }.
Record tri (R:Type->Type->Type) (S:Type->Type->Type) (T:Type->Type->Type) := mkTri {
  tri0 : forall a b c, R a b -> S a c -> T b c
}.
Arguments mkTri [R S T].
Definition tri_iffT : tri iffT iffT iffT :=
  (mkTri
    (fun X0 X1 X2 E01 E02 =>
     (mkIff _ _ (fun x1 => iffLR _ _ E02 (iffRL _ _ E01 x1))
     (fun x2 => iffLR _ _ E01 (iffRL _ _ E02 x2))))).

(* Check that local defs names are preserved if possible during unification *)

Goal forall x (x':=x) (f:forall y, y=y:>nat -> Prop), f _ (eq_refl x').
intros.
unfold x' at 2. (* A way to check that there are indeed 2 occurrences of x' *)
Abort.

(* A simple example we would like not to fail (it used to fail because of
   not strict enough evar restriction) *)

Check match Some _ with None => _ | _ => _ end.

(* Used to fail for a couple of days in Nov 2014 *)

Axiom test : forall P1 P2, P1 = P2 -> P1 -> P2.

(* Check use of candidates *)

Import EqNotations.
Definition test2 {A B:Type} {H:A=B} (a:A) : B := rew H in a.

(* Check that pre-existing evars are not counted as newly undefined in "set" *)
(* Reported by Théo *)

Goal exists n : nat, n = n -> True.
eexists.
set (H := _ = _).
Abort.

(* Check interpretation of default evar instance in pretyping *)
(* (reported as bug #7356) *)

Check fun (P : nat -> Prop) (x:nat) (h:P x) => exist _ ?[z] (h : P ?z).


Require Export SQIR.UnitaryOps.

Local Open Scope ucom_scope.
Local Close Scope R_scope.

Inductive only_uses {U dim} : ucom U dim -> list nat -> Prop :=
| ou_seq : forall c1 c2 qs, only_uses c1 qs -> only_uses c2 qs -> only_uses (c1; c2) qs
| ou_app1 : forall u q qs, List.In q qs -> only_uses (uapp1 u q) qs
| ou_app2 : forall u q1 q2 qs, List.In q1 qs -> List.In q2 qs -> only_uses (uapp2 u q1 q2) qs
| ou_app3 : forall u q1 q2 q3 qs, List.In q1 qs -> List.In q2 qs -> List.In q3 qs -> only_uses (uapp3 u q1 q2 q3) qs.

Definition bounded_list (l : list nat) n := forall x, List.In x l -> x < n.

Lemma one_elem_list : forall (m : nat), List.length (m :: []) = 1.
Proof. easy. Qed.
Lemma two_elem_list : forall (m n : nat), List.length (m :: n :: []) = 2.
Proof. easy. Qed.
Lemma three_elem_list : forall (m n p : nat), List.length (m :: n :: p :: []) = 3.
Proof. easy. Qed.

Lemma map_nth_In : forall l n d0 d1 (f : nat -> nat),
  n < length l -> nth n (map f l) d0 = f (nth n l d1).
Proof.
  intros l n d0 d1 f H.
  generalize dependent n.
  induction l; simpl in *.
  lia.
  intros n Hn.
  destruct n.
  reflexivity.
  apply IHl.
  lia.
Qed.

(* General definition of a gate set used in ListRepresentation.v. *)
Module Type GateSet.

  (* Gates are parameterized by a number of arguments. *)
  Parameter U : nat -> Set.

  (* Given a gate in set U + input arguments, produce a program using
     the base_Unitary set defined in SQIR's UnitarySem.v. *)
  Parameter to_base : forall (n dim : nat) (u : U n)
        (qs : list nat) (pf : List.length qs = n),
    base_ucom dim.
  Arguments to_base {n} {dim}.

  (* Any reasonable definition of to_base should satisfy:
     1. (to_base G qs) shouldn't use any qubits besides those in qs; this is
        important so we can say that (to_base G1 [q1]) commutes with
        (to_base G2 [q2]) when q1 ≠ q2
     2. (to_base G qs) should be well-typed iff qs is the correct length
        and has no duplicates
     3. (to_base G (List.map f qs)) should be the same as
        (SQIR.map_qubits f (to_base G qs))

     TODO: Is there some more general property that ensures 1-3? Or does some
     some subset of these imply the others? *)
  Axiom to_base_only_uses_qs : forall {n} (dim : nat) (u : U n)
        (qs : list nat) (pf : List.length qs = n),
    @only_uses _ dim (to_base u qs pf) qs.
  Axiom to_base_WT : forall {n} (dim : nat) (u : U n)
        (qs : list nat) (pf : List.length qs = n),
    @uc_well_typed _ dim (to_base u qs pf) <-> (bounded_list qs dim /\ List.NoDup qs).
  Axiom to_base_map_commutes : forall {n} (dim : nat) (u : U n)
        (qs : list nat) (pf : List.length qs = n)
        (f : nat -> nat) (pfm : List.length (map f qs) = n),
    @to_base _ dim u (map f qs) pfm = map_qubits f (to_base u qs pf).

  (* Boolean equality over gates. *)
  Parameter match_gate : forall (n : nat), U n -> U n -> bool.
  Arguments match_gate {n}.
  Axiom match_gate_refl : forall {n} (u : U n), match_gate u u = true.
  Axiom match_gate_implies_equiv : forall {n} (dim : nat) (u u': U n)
        (qs : list nat) (pf : List.length qs = n),
    match_gate u u' = true -> @to_base _ dim u qs pf ≡ to_base u' qs pf.

End GateSet.


Lemma iffInvert (A B B2: Prop): ((A/\B) <-> (A/\B2))  -> (B<->B2).
Proof.
intros.
Fail tauto.
Abort.

Lemma iffInvert (A B B2: Prop): ((A/\B) <-> (A/\B2))  -> (A->(B<->B2)).
Proof.
intros. tauto.
Qed.


Require Import Vec.

(* SIMPLIFICATIONS
 * ~~~~~~~~~~~~~~~
 * No kinds ==> no type applications, everything fully saturated
 * Less coercion forms (we don't need them all for this)
 * No recursion
 *)

Inductive FcTy : Set :=
  | FcTyVar (a : nat)                     (* Type variable (a) *)
  | FcTyArr (υ₁ υ₂ : FcTy)                (* Arrow type (υ₁ → υ₂) *)
  | FcTyAll (υ : FcTy)                    (* Universal quantification (∀a. υ) *)
  | FcTyCon (tc : nat) (υ : FcTy)         (* Type constructor application (T υ) *)
  | FcTyFam (fn : nat) (υ : FcTy)         (* Type family application (F υ) *)
  | FcTyTup (n : nat) (υs : Vec FcTy n).  (* Tuple type ((υ₁,…,υₙ)) *)

Inductive Co : Set :=
  | CoRefl  (υ : FcTy)                             (* Reflexivity (<γ>) *)
  | CoSym   (γ : Co)                               (* Symmetry (sym γ) *)
  | CoTrans (γ₁ γ₂ : Co)                           (* Transitivity (γ₁ ; γ₂) *)
  | CoAxiom (g : nat) (n : nat) (υs : Vec FcTy n). (* Axiom application (g υs) *)

Inductive FcTm : Set :=
    (* Term variable (x) *)
  | FcTmVar (x : nat)
    (* Term abstraction (λ(x : υ). t) *)
  | FcTmAbs (υ : FcTy) (t : FcTm)
    (* Term application (t₁ t₂) *)
  | FcTmApp (t₁ t₂ : FcTm)
    (* Tuple term (t₁,…,tₙ) *)
  | FcTmTup (n : nat) (ts : Vec FcTm n)
    (* Type abstraction (Λa. t) *)
  | FcTyAbs (t : FcTm)
    (* Type application (t υ) *)
  | FcTyApp (t : FcTm) (υ : FcTy)
    (* Type cast (t ▹ γ) *)
  | FcCast  (t : FcTm) (γ : Co)
    (* Constructor (K υ t₀ tⁿ md) *)
  | FcCon   (dc : nat) (υ : FcTy) (ctx : FcTm) n (scs : Vec FcTm n) (md : FcTm)
    (* Case expression (case scr of { K ctx scs x → rhs }) *)
  | FcDCase (scr : FcTm) (* 1+n+1 *) (rhs : FcTm)
    (* Tuple case (case scr of { (x₁,…,xₙ) → rhs }) *)
  | FcTCase (scr : FcTm) (* ps : nat *) (rhs : FcTm).

(* Top-level Value Binding *)
Inductive FcVal : Set :=
  | MkFcVal (t : FcTm) (υ : FcTy).

(* Datatype Declaration *)
Inductive FcData : Set :=
  | MkFcData (ctx : FcTy) n (scs : Vec FcTy n) (md : FcTy).

(* Type Family Declaration *)
Inductive FcFam : Set :=
  | MkFcFam. (* TODO : USELESS *)

Inductive FcAx : Set :=
    (* axiom g asⁿ : F (υ) ∼ (υ₁,…,υₘ) *)
  | MkFcAx (bnds : nat) (fn : nat) (υ : FcTy) (m : nat) (υs : Vec FcTy m).

(* Target Program *)
Inductive FcPgm : Set :=
  | FcPgmEmpty
  | FcPgmVal  (fcval  : FcVal)  (fcpgm : FcPgm)
  | FcPgmData (fcdata : FcData) (fcpgm : FcPgm)
  | FcPgmFam  (fcfam  : FcFam)  (fcpgm : FcPgm)
  | FcPgmAx   (fcax   : FcAx)   (fcpgm : FcPgm).

(* Target Typing Environment *)
Inductive FcTyEnv : Set :=
  | FcEnvNil                                                                     (* Empty environment *)
  | FcConsTy (Δ : FcTyEnv)                                                       (* Type variable     *)
  | FcConsTm (Δ : FcTyEnv) (υ : FcTy)                                            (* Term variable     *)
  | FcConsFn (Δ : FcTyEnv)                                                       (* Family name       *)
  | FcConsDt (Δ : FcTyEnv) (dt : FcData)                                         (* Data type         *)
  | FcConsAx (Δ : FcTyEnv) (ax : FcAx).                                          (* Equality axiom    *)

(* ************************************ *)
(* SOME UTILITIES *)

Fixpoint appToTms (t : FcTm) n (ts : Vec FcTm n) : FcTm :=
  match ts with
    | VN          => t
    | VC t' m ts' => appToTms (FcTmApp t t') m ts'
  end.

Fixpoint appToTys (t : FcTm) n (υs : Vec FcTy n) : FcTm :=
  match υs with
    | VN        => t
    | VC υ m υs => appToTys (FcTyApp t υ) m υs
  end.


From isla Require Import opsem.

Definition a50 : isla_trace :=
  Smt (DeclareConst 0%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "PC" [] (RegVal_Base (Val_Symbolic 0%Z)) Mk_annot :t:
  Smt (DefineConst 1%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 0%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DeclareConst 10%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "x8" [] (RegVal_Base (Val_Symbolic 10%Z)) Mk_annot :t:
  Smt (DefineConst 11%Z (Binop ((Bvarith Bvshl)) (Val (Val_Symbolic 10%Z) Mk_annot) (Val (Val_Bits (BV 64%N 0x3%Z)) Mk_annot) Mk_annot)) Mk_annot :t:
  WriteReg "x10" [] (RegVal_Base (Val_Symbolic 11%Z)) Mk_annot :t:
  WriteReg "PC" [] (RegVal_Base (Val_Symbolic 1%Z)) Mk_annot :t:
  tnil
.


From iris.heap_lang Require Export notation.

Definition increaseValueTo: val :=
  rec: "loop" "loc" "val" :=
    let: "cur" := !"loc" in
    if: "val" ≤ "cur" then #()
    else if: CAS "loc" "cur" "val" then #()
         else "loop" "loc" "val".

From iris.program_logic Require Import atomic.
From iris.heap_lang Require Export proofmode.

Section proof.

Context `{heapG}.

Theorem increaseValueTo_spec (ℓ: loc) (n: Z):
  ⊢ <<< ∀ (m: Z), ▷ ℓ ↦ #m >>>
    increaseValueTo #ℓ #n @ ⊤
  <<< ⌜(m >= n)%Z⌝ ∧ ℓ ↦ #m ∨ ⌜(m < n)%Z⌝ ∧ ℓ ↦ #n, RET #() >>>.
Proof.
  iIntros (Φ) "AU". wp_lam. wp_pures. iLöb as "IH".
  wp_bind (!_)%E. iMod "AU" as (m) "[Hℓ HClose]".
  wp_load.
  destruct (decide (n <= m)%Z) as [HLe|HGt].
  - iDestruct "HClose" as "[_ HClose]".
    iMod ("HClose" with "[Hℓ]") as "HΦ".
    { iLeft. iFrame. iPureIntro. lia. }
    iModIntro. wp_pures. rewrite bool_decide_true; last lia.
    by wp_pures.
  - iDestruct "HClose" as "[HClose _]".
    iMod ("HClose" with "Hℓ") as "AU".
    iModIntro. wp_pures. rewrite bool_decide_false; last lia.
    wp_pures. wp_bind (CmpXchg _ _ _).
    iMod "AU" as (m') "[Hℓ HClose]".
    destruct (decide (m = m')) as [<-|HNeq].
    + wp_cmpxchg_suc.
      iDestruct "HClose" as "[_ HClose]".
      iMod ("HClose" with "[Hℓ]") as "HΦ".
      { iRight. iFrame. iPureIntro. lia. }
      iModIntro. by wp_pures.
    + wp_cmpxchg_fail.
      iDestruct "HClose" as "[HClose _]".
      iMod ("HClose" with "Hℓ") as "AU".
      iModIntro. wp_pures. wp_lam. wp_pures.
      by iApply ("IH" with "AU").
Qed.

End proof.