Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type :=   Zero : natural | Succ : natural -> natural .

Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) : natural
           := match mult_arg0, mult_arg1 with
              | Zero, n => Zero
              | Succ n, m => plus (mult n m) m
              end.

Fixpoint qmult (qmult_arg0 : natural) (qmult_arg1 : natural) (qmult_arg2 : natural) : natural
           := match qmult_arg0, qmult_arg1, qmult_arg2 with
              | Zero, n, m => m
              | Succ n, m, p => qmult n m (plus p m)
              end.

Lemma plus_succ : forall (x y : natural), plus x (Succ y) = Succ (plus x y).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_assoc : forall (x y z : natural), plus (plus x y) z = plus x (plus y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_zero : forall (x : natural), plus x Zero = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_commut : forall (x y : natural), plus x y = plus y x.
Proof.
   intros.
   induction x.
   - rewrite plus_zero. reflexivity.
   - simpl. rewrite plus_succ. rewrite IHx. reflexivity.
Qed.

Lemma plus_qmult : forall (x y z a : natural), plus (qmult x y z) a = qmult x y (plus z a).
Proof.
   intro.
   induction x.
   - reflexivity.
   - intros. simpl. rewrite IHx. rewrite plus_assoc. rewrite (plus_commut y a).
     lfind. Admitted.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.priority.
Require Import prosa.classic.model.arrival.basic.task.
Require Import prosa.classic.model.arrival.jitter.job prosa.classic.model.arrival.jitter.task_arrival
               prosa.classic.model.arrival.jitter.arrival_sequence prosa.classic.model.arrival.jitter.arrival_bounds.
Require Import prosa.classic.model.schedule.uni.schedule_of_task prosa.classic.model.schedule.uni.service
               prosa.classic.model.schedule.uni.schedulability prosa.classic.model.schedule.uni.response_time.
Require Import prosa.classic.model.schedule.uni.jitter.schedule
               prosa.classic.model.schedule.uni.jitter.busy_interval
               prosa.classic.model.schedule.uni.jitter.platform.
Require Import prosa.classic.analysis.uni.jitter.workload_bound_fp.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module ResponseTimeAnalysisFP.

  Import ArrivalSequenceWithJitter JobWithJitter TaskArrivalWithJitter ArrivalBounds
         UniprocessorScheduleWithJitter ScheduleOfTask SporadicTaskset Priority
         ResponseTime WorkloadBoundFP Platform Schedulability BusyInterval.

  (* In this section, we prove that any fixed point in the RTA for jitter-aware
     uniprocessor FP scheduling is a response-time bound. *)
  Section ResponseTimeBound.

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

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_jitter: Job -> time.
    Variable job_task: Job -> SporadicTask.

    (* Consider any task set ts... *)
    Variable ts: seq SporadicTask.

    (* ...with positive task periods. *)
    Hypothesis H_positive_periods: forall tsk, tsk \in ts -> task_period tsk > 0.

    (* Consider any job arrival sequence with consistent, duplicate-free arrivals... *)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_arrival_times_are_consistent: arrival_times_are_consistent job_arrival arr_seq.
    Hypothesis H_arr_seq_is_a_set: arrival_sequence_is_a_set arr_seq.

    (* ... in which jobs arrive sporadically,... *)
    Hypothesis H_sporadic_tasks:
      sporadic_task_model task_period job_arrival job_task arr_seq.

    (* ...the cost of each job is bounded by the cost of its task, ... *)
    Hypothesis H_job_cost_le_task_cost:
      forall j,
        arrives_in arr_seq j ->
        job_cost j <= task_cost (job_task j).

    (* ...and the jitter of each job is bounded by the jitter of its task. *)
    Hypothesis H_job_jitter_le_task_jitter:
      forall j,
        arrives_in arr_seq j ->
        job_jitter j <= task_jitter (job_task j).

    (* Assume that all jobs in the arrival sequence come from the task set. *)
    Hypothesis H_all_jobs_from_taskset:
      forall j, arrives_in arr_seq j -> job_task j \in ts.

    (* Next, consider any uniprocessor schedule of this arrival sequence... *)
    Variable sched: schedule Job.
    Hypothesis H_jobs_come_from_arrival_sequence:
      jobs_come_from_arrival_sequence sched arr_seq.

    (* ...such that jobs do not execute before the jitter has passed nor after completion. *)
    Hypothesis H_jobs_execute_after_jitter: jobs_execute_after_jitter job_arrival job_jitter sched.
    Hypothesis H_completed_jobs_dont_execute: completed_jobs_dont_execute job_cost sched.

    (* Consider any FP policy that indicates a higher-or-equal priority relation,
       where the relation is reflexive and transitive. *)
    Variable higher_eq_priority: FP_policy SporadicTask.
    Hypothesis H_priority_is_reflexive: FP_is_reflexive higher_eq_priority.
    Hypothesis H_priority_is_transitive: FP_is_transitive higher_eq_priority.

    (* Next, assume that the schedule is a jitter-aware, work-conserving FP schedule. *)
    Hypothesis H_work_conserving: work_conserving job_arrival job_cost job_jitter arr_seq sched.
    Hypothesis H_respects_fp_policy:
      respects_FP_policy job_arrival job_cost job_jitter job_task arr_seq sched higher_eq_priority.

    (* Now we proceed with the analysis.
       Let tsk be any task in ts that is to be analyzed. *)
    Variable tsk: SporadicTask.
    Hypothesis H_tsk_in_ts: tsk \in ts.

    (* Recall the definition of response-time bound and the total workload bound W
       for higher-or-equal-priority tasks (with respect to tsk). *)
    Let response_time_bounded_by :=
      is_response_time_bound_of_task job_arrival job_cost job_task arr_seq sched.
    Let W := total_workload_bound_fp task_cost task_period task_jitter higher_eq_priority ts tsk.

    (* Let R be any positive fixed point of the response-time recurrence. *)
    Variable R: time.
    Hypothesis H_R_positive: R > 0.
    Hypothesis H_response_time_is_fixed_point: R = W R.

    (* Since R = W R bounds the workload of higher-or-equal priority and actual arrival
       time in any interval of length R, it follows from the busy-interval lemmas that
       R bounds the response-time of job j.
       (For more details, see model/uni/jitter/busy_interval.v and
        analysis/uni/jitter/workload_bound_fp.v.) *)
    Theorem uniprocessor_response_time_bound_fp:
      response_time_bounded_by tsk (task_jitter tsk + R).
    Proof.
      unfold valid_sporadic_job_with_jitter, valid_sporadic_job,
             valid_sporadic_taskset, is_valid_sporadic_task in *.
      rename H_response_time_is_fixed_point into FIX.
      intros j IN JOBtsk.
      set arr := actual_arrival job_arrival job_jitter.
      apply completion_monotonic with (t := arr j + R); try (by done).
      {
        rewrite -addnA leq_add2l leq_add2r.
        by rewrite -JOBtsk; apply H_job_jitter_le_task_jitter.
      }
      set prio := FP_to_JLFP job_task higher_eq_priority.
      apply busy_interval_bounds_response_time with (arr_seq0 := arr_seq)
                                                    (higher_eq_priority0 := prio); try (by done).
        - by intros x; apply H_priority_is_reflexive.
        - by intros x z y; apply H_priority_is_transitive.
      intros t.
      apply fp_workload_bound_holds with (task_cost0 := task_cost)
            (task_period0 := task_period) (task_jitter0 := task_jitter) (ts0 := ts); try (by done).
      by rewrite JOBtsk.
    Qed.

  End ResponseTimeBound.

End ResponseTimeAnalysisFP.


From Coq Require Import ssreflect ssrfun ssrbool.

Require Import Setoid.
From Coq Require Import Unicode.Utf8.
From Coq.Logic Require Import Classical_Prop FunctionalExtensionality.
From Coq.Classes Require Import Morphisms_Prop.

From stdpp Require Import base sets.

From MatchingLogic Require Import Logic.
Import MatchingLogic.Logic.Notations.
Require Import MatchingLogic.Theories.Definedness_Syntax.

Import MatchingLogic.Theories.Definedness_Syntax.Notations.
Import BoundVarSugar.

Inductive Symbols := inhabitant.

Global Instance Symbols_eqdec : EqDecision Symbols.
Proof. unfold EqDecision. intros x y. unfold Decision. destruct x. decide equality. (*solve_decision.*) Defined.

Section sorts_syntax.
  Open Scope ml_scope.
  Context {Σ : Signature}.

  Class Syntax :=
    { inj : Symbols -> symbols;
      imported_definedness :> Definedness_Syntax.Syntax;
    }.

  Context {self : Syntax}.

  Local Definition sym (s : Symbols) : Pattern :=
    patt_sym (inj s).

  Example test_pattern_1 := patt_equal (sym inhabitant) (sym inhabitant).
  Definition patt_inhabitant_set(phi : Pattern) : Pattern := sym inhabitant $ phi.

  Definition patt_element_of (φ ψ : Pattern) := ⌈ φ and ψ ⌉.

End sorts_syntax.

Section sorts.
  Context {Σ : Signature}.
  Context {self : Syntax}.
  Open Scope ml_scope.
  Local Notation "〚 phi 〛" := (patt_inhabitant_set phi) (at level 0) : ml_scope.

  Obligation Tactic := idtac.

  #[global]
  Program Instance Unary_inhabitant_set : Unary patt_inhabitant_set := {}.
  Next Obligation.
    intros. repeat rewrite pm_correctness. reflexivity.
  Defined.
  Next Obligation.
    wf_auto2.
  Qed.
  Next Obligation.
    wf_auto2.
  Qed.
  Next Obligation.
    wf_auto2.
  Qed.

  Definition patt_sorted_neg (sort phi : Pattern) : Pattern :=
    〚sort〛 and ! phi.

  #[global]
  Program Instance Binary_sorted_neg : Binary patt_sorted_neg := {}.
  Next Obligation.
    intros. repeat rewrite pm_correctness. reflexivity.
  Defined.
  Next Obligation.
    intros. wf_auto2.
  Qed.
  Next Obligation.
    intros. wf_auto2.
  Qed.
  Next Obligation.
    intros. wf_auto2.
  Qed.

  Definition patt_exists_of_sort (sort phi : Pattern) : Pattern :=
    ex , ((b0 ∈ml 〚nest_ex sort〛) and phi).
  Local Notation "'ex' s ,  phi" :=
    (patt_exists_of_sort s phi) (at level 70) : ml_scope.

  #[global]
  Program Instance sorted_exists_binder : ESortedBinder patt_exists_of_sort nest_ex := {}.
  Next Obligation.
    intros.
    repeat rewrite pm_correctness.
    cbn.
    rewrite (@eswap _ _ _ nest_ex _ f_swap).
    replace (on_bevar pm_spec_data (increase_ex pm_spec_data a) 0) with b0. reflexivity.
    now rewrite pm_ezero_increase.
  Defined.

  Definition patt_forall_of_sort (sort phi : Pattern) : Pattern :=
    all , ((b0 ∈ml 〚nest_ex sort〛) ---> phi).

  Local Notation "'all' s ,  phi" :=
    (patt_forall_of_sort s phi) (at level 70) : ml_scope.

  #[global]
  Program Instance sorted_forall_binder : ESortedBinder patt_forall_of_sort nest_ex := {}.
  Next Obligation.
    intros.
    repeat rewrite pm_correctness.
    cbn.
    rewrite (@eswap _ _ _ nest_ex _ f_swap).
    replace (on_bevar pm_spec_data (increase_ex pm_spec_data a) 0) with b0. reflexivity.
    now rewrite pm_ezero_increase.
  Defined.

  (* TODO patt_forall_of_sort and patt_exists_of_sorts are duals - a lemma *)

  (* TODO a lemma about patt_forall_of_sort *)

  Definition patt_total_function(phi from to : Pattern) : Pattern :=
    all from , (ex (nest_ex to) , ((nest_ex (nest_ex phi) $ b1) =ml b0)).

  Definition patt_partial_function(phi from to : Pattern) : Pattern :=
    all from , (ex (nest_ex to), ((nest_ex (nest_ex phi) $ b1) ⊆ml b0)).

  (* Assuming `f` is a total function, says it is injective on given domain. Does not quite work for partial functions. *)
  Definition patt_total_function_injective f from : Pattern :=
    all from , (all (nest_ex from) ,
                (((nest_ex (nest_ex f) $ b1) =ml (nest_ex (nest_ex f) $ b0)) --->
                  (b1 =ml b0))).

  (* Assuming `f` is a partial function, says it is injective on given domain. Works for total functions, too. *)
  Definition patt_partial_function_injective f from : Pattern :=
    all
      from ,
      (all
         (nest_ex from) ,
         (
            ! ((nest_ex (nest_ex f) $ b1) =ml ⊥ )
            --->
            ((nest_ex (nest_ex f) $ b1) =ml (nest_ex (nest_ex f) $ b0))
             ---> (b1 =ml b0))).

End sorts.

Module Notations.
  Notation "〚 phi 〛" := (patt_inhabitant_set phi) (at level 0) : ml_scope.
  Notation "'all' s ,  phi" := (patt_forall_of_sort s phi) (at level 70) : ml_scope.
  Notation "'ex' s ,  phi" := (patt_exists_of_sort s phi) (at level 70) : ml_scope.
End Notations.


(** * AltAuto: A Streamlined Treatment of Automation *)

(** This chapter gives an alternative treatment of Coq automation that
    does not depend on [Imp].  It contains most of the automation
    material from that chapter, and most of the existing [Auto]
    chapter except for material on [match].  It is suitable, e.g., for
    a course that wants to move quickly on to VFA (which covers
    [match]) without doing any language metatheory at all. *)

Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Lia Arith.
From LF Require Import IndProp.

(** Up to now, we've used the more manual part of Coq's tactic
    facilities.  In this chapter, we'll learn more about some of Coq's
    powerful automation features.

    As a simple illustration of the benefits of automation, let's
    consider another problem on regular expressions, which we
    formalized in [IndProp].  A given set of strings can be
    denoted by many different regular expressions.  For example, [App
    EmptyString re] matches exactly the same strings as [re].  We can
    write a function that "optimizes" any regular expression into a
    potentially simpler one by applying this fact throughout the
    r.e.  (Note that, for simplicity, the function does not optimize
    expressions that arise as the result of other optimizations.) *)

Fixpoint re_opt_e {T:Type} (re: reg_exp T) : reg_exp T :=
  match re with
  | App EmptyStr re2 => re_opt_e re2
  | App re1 re2 => App (re_opt_e re1) (re_opt_e re2)
  | Union re1 re2 => Union (re_opt_e re1) (re_opt_e re2)
  | Star re => Star (re_opt_e re)
  | _ => re
  end.

(** We would like to show the equivalence of re's with their "optimized" form.
One direction of this equivalence looks like this (the other is similar).
*)

Lemma re_opt_e_match : forall T (re: reg_exp T) s,
  s =~ re -> s =~ re_opt_e re.
Proof.
  intros T re s M.
  induction M
    as [| x'
        | s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
        | s1 re1 re2 Hmatch IH | re1 s2 re2 Hmatch IH
        | re | s1 s2 re Hmatch1 IH1 Hmatch2 IH2].
  - (* MEmpty *) simpl. apply MEmpty.
  - (* MChar *) simpl. apply MChar.
  - (* MApp *) simpl.
    destruct re1.
    + apply MApp. apply IH1. apply IH2.
    + inversion Hmatch1. simpl.  apply IH2.
    + apply MApp. apply IH1. apply IH2.
    + apply MApp. apply IH1. apply IH2.
    + apply MApp. apply IH1. apply IH2.
    + apply MApp. apply IH1. apply IH2.
  - (* MUnionL *) simpl. apply MUnionL. apply IH.
  - (* MUnionR *) simpl. apply MUnionR. apply IH.
  - (* MStar0 *) simpl. apply MStar0.
  - (* MStarApp *) simpl. apply MStarApp. apply IH1.  apply IH2.
Qed.

(* ################################################################# *)
(** * Coq Automation *)

(** The amount of repetition in this last proof is rather
    annoying.  And if we wanted to extend the optimization function to
    handle other, similar, rewriting opportunities,
    it would start to be a real problem.

    So far, we've been doing all our proofs using just a small handful
    of Coq's tactics and completely ignoring its powerful facilities
    for constructing parts of proofs automatically.  This section
    introduces some of these facilities, and we will see more over the
    next several chapters.  Getting used to them will take some
    energy -- Coq's automation is a power tool -- but it will allow us
    to scale up our efforts to more complex definitions and more
    interesting properties without becoming overwhelmed by boring,
    repetitive, low-level details. *)

(* ################################################################# *)
(** * Tacticals *)

(** _Tacticals_ is Coq's term for tactics that take other tactics as
    arguments -- "higher-order tactics," if you will.  *)

(* ----------------------------------------------------------------- *)
(** *** The [try] Tactical *)

(** If [T] is a tactic, then [try T] is a tactic that is just like [T]
    except that, if [T] fails, [try T] _successfully_ does nothing at
    all (instead of failing). *)

Theorem silly1 : forall n,  1 + n = S n.
Proof. try reflexivity. (* this just does [reflexivity] *) Qed.

Theorem silly2 : forall (P : Prop), P -> P.
Proof.
  intros P HP.
  try reflexivity. (* just [reflexivity] would have failed *)
  apply HP. (* we can still finish the proof in some other way *)
Qed.

(** There is no real reason to use [try] in completely manual
    proofs like these, but it is very useful for doing automated
    proofs in conjunction with the [;] tactical, which we show
    next. *)

(* ----------------------------------------------------------------- *)
(** *** The [;] Tactical (Simple Form) *)

(** In its most common form, the [;] tactical takes two tactics as
    arguments.  The compound tactic [T;T'] first performs [T] and then
    performs [T'] on _each subgoal_ generated by [T]. *)

(** For example, consider the following trivial lemma: *)

Lemma foo : forall n,  n+1 =? 0 = false.
Proof.
  intros.
  destruct n eqn:E.
    (* Leaves two subgoals, which are discharged identically...  *)
    - (* n=0 *) simpl. reflexivity.
    - (* n=Sn' *) simpl. reflexivity.
Qed.

(** We can simplify this proof using the [;] tactical: *)

Lemma foo' : forall n, n+1 =? 0 = false.
Proof.
  intros.
  (* [destruct] the current goal *)
  destruct n;
  (* then [simpl] each resulting subgoal *)
  simpl;
  (* and do [reflexivity] on each resulting subgoal *)
  reflexivity.
Qed.

(** Using [try] and [;] together, we can get rid of the repetition in
    the proof that was bothering us a little while ago. *)

Lemma re_opt_e_match' : forall T (re: reg_exp T) s,
  s =~ re -> s =~ re_opt_e re.
Proof.
  intros T re s M.
  induction M
    as [| x'
        | s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
        | s1 re1 re2 Hmatch IH | re1 s2 re2 Hmatch IH
        | re | s1 s2 re Hmatch1 IH1 Hmatch2 IH2];
    (* Do the [simpl] for every case here: *)
    simpl.
  - (* MEmpty *) apply MEmpty.
  - (* MChar *) apply MChar.
  - (* MApp *)
    destruct re1;
    (* Most cases follow by the same formula.
       Notice that [apply MApp] gives two subgoals:
       [try apply IH1] is run on both of them and
       succeeds on the first but not the second;
       [apply IH2] is then run on this remaining goal. *)
    try (apply MApp; try apply IH1; apply IH2).
    (* The interesting case, on which [try...] does nothing,
       is when [re1 = EmptyStr]. In this case, we have
       to appeal to the fact that [re1] matches only the
       empty string: *)
    inversion Hmatch1. simpl. apply IH2.
  - (* MUnionL *) apply MUnionL. apply IH.
  - (* MUnionR *) apply MUnionR. apply IH.
  - (* MStar0 *) apply MStar0.
  - (* MStarApp *)  apply MStarApp. apply IH1.  apply IH2.
Qed.

(* ----------------------------------------------------------------- *)
(** *** The [;] Tactical (General Form) *)

(** The [;] tactical also has a more general form than the simple
    [T;T'] we've seen above.  If [T], [T1], ..., [Tn] are tactics,
    then

      T; [T1 | T2 | ... | Tn]

    is a tactic that first performs [T] and then performs [T1] on the
    first subgoal generated by [T], performs [T2] on the second
    subgoal, etc.

    So [T;T'] is just special notation for the case when all of the
    [Ti]'s are the same tactic; i.e., [T;T'] is shorthand for:

      T; [T' | T' | ... | T']
*)

(** We can use this mechanism to give a slightly neater version
    of our optimization proof: *)

Lemma re_opt_e_match'' : forall T (re: reg_exp T) s,
  s =~ re -> s =~ re_opt_e re.
Proof.
  intros T re s M.
  induction M
    as [| x'
        | s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
        | s1 re1 re2 Hmatch IH | re1 s2 re2 Hmatch IH
        | re | s1 s2 re Hmatch1 IH1 Hmatch2 IH2];
    (* Do the [simpl] for every case here: *)
    simpl.
  - (* MEmpty *) apply MEmpty.
  - (* MChar *) apply MChar.
  - (* MApp *)
    destruct re1;
    try (apply MApp; [apply IH1 | apply IH2]).  (* <=== *)
    inversion Hmatch1. simpl. apply IH2.
  - (* MUnionL *) apply MUnionL. apply IH.
  - (* MUnionR *) apply MUnionR. apply IH.
  - (* MStar0 *) apply MStar0.
  - (* MStarApp *)  apply MStarApp; [apply IH1 |  apply IH2].  (* <=== *)
Qed.

(* ----------------------------------------------------------------- *)
(** *** The [repeat] Tactical *)

(** The [repeat] tactical takes another tactic and keeps applying this
    tactic until it fails or stops making progress. Here is an example
    showing that [10] is in a long list using repeat. *)

Theorem In10 : In 10 [1;2;3;4;5;6;7;8;9;10].
Proof.
  repeat (try (left; reflexivity); right).
Qed.

(** The tactic [repeat T] never fails: if the tactic [T] doesn't apply
    to the original goal, then repeat still succeeds without changing
    the original goal (i.e., it repeats zero times). *)

Theorem In10' : In 10 [1;2;3;4;5;6;7;8;9;10].
Proof.
  repeat (left; reflexivity).
  repeat (right; try (left; reflexivity)).
Qed.

(** The tactic [repeat T] also does not have any upper bound on the
    number of times it applies [T].  If [T] is a tactic that always
    succeeds, then repeat [T] will loop forever (e.g., [repeat simpl]
    loops, since [simpl] always succeeds).  While evaluation in Coq's
    term language, Gallina, is guaranteed to terminate, tactic
    evaluation is not!  This does not affect Coq's logical
    consistency, however, since the job of [repeat] and other tactics
    is to guide Coq in constructing proofs; if the construction
    process diverges, this simply means that we have failed to
    construct a proof, not that we have constructed a wrong one. *)

(** **** Exercise: 3 stars, standard (re_opt) *)

(** Consider this more powerful version of the regular expression optimizer. *)

Fixpoint re_opt {T:Type} (re: reg_exp T) : reg_exp T :=
  match re with
  | App _ EmptySet => EmptySet
  | App EmptyStr re2 => re_opt re2
  | App re1 EmptyStr => re_opt re1
  | App re1 re2 => App (re_opt re1) (re_opt re2)
  | Union EmptySet re2 => re_opt re2
  | Union re1 EmptySet => re_opt re1
  | Union re1 re2 => Union (re_opt re1) (re_opt re2)
  | Star EmptySet => EmptyStr
  | Star EmptyStr => EmptyStr
  | Star re => Star (re_opt re)
  | EmptySet => EmptySet
  | EmptyStr => EmptyStr
  | Char x => Char x
  end.

(* Here is an incredibly tedious manual proof of (one direction of) its correctness: *)

Lemma re_opt_match : forall T (re: reg_exp T) s,
  s =~ re -> s =~ re_opt re.
Proof.
  intros T re s M.
  induction M
    as [| x'
        | s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
        | s1 re1 re2 Hmatch IH | re1 s2 re2 Hmatch IH
        | re | s1 s2 re Hmatch1 IH1 Hmatch2 IH2].
  - simpl. apply MEmpty.
  - simpl. apply MChar.
  - simpl.
    destruct re1.
    + inversion IH1.
    + inversion IH1. simpl. destruct re2.
      * apply IH2.
      * apply IH2.
      * apply IH2.
      * apply IH2.
      * apply IH2.
      * apply IH2.
    + destruct re2.
      * inversion IH2.
      * inversion IH2. rewrite app_nil_r. apply IH1.
      * apply MApp. apply IH1. apply IH2.
      * apply MApp. apply IH1. apply IH2.
      * apply MApp. apply IH1. apply IH2.
      * apply MApp. apply IH1. apply IH2.
    + destruct re2.
      * inversion IH2.
      * inversion IH2. rewrite app_nil_r.  apply IH1.
      * apply MApp. apply IH1. apply IH2.
      * apply MApp. apply IH1.  apply IH2.
      * apply MApp. apply IH1.  apply IH2.
      * apply MApp. apply IH1.  apply IH2.
    + destruct re2.
      * inversion IH2.
      * inversion IH2. rewrite app_nil_r. apply IH1.
      * apply MApp. apply IH1.  apply IH2.
      * apply MApp. apply IH1.  apply IH2.
      * apply MApp. apply IH1.  apply IH2.
      * apply MApp. apply IH1.  apply IH2.
    + destruct re2.
      * inversion IH2.
      * inversion IH2. rewrite app_nil_r. apply IH1.
      * apply MApp. apply IH1.  apply IH2.
      * apply MApp. apply IH1.  apply IH2.
      * apply MApp. apply IH1.  apply IH2.
      * apply MApp. apply IH1.  apply IH2.
  - simpl.
    destruct re1.
    + inversion IH.
    + destruct re2.
      * apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
    + destruct re2.
      * apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
    + destruct re2.
      * apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
    + destruct re2.
      * apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
    + destruct re2.
      * apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
      * apply MUnionL. apply IH.
  - simpl.
    destruct re1.
    + apply IH.
    + destruct re2.
      * inversion IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
    + destruct re2.
      * inversion IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
    + destruct re2.
      * inversion IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
    + destruct re2.
      * inversion IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
    + destruct re2.
      * inversion IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
      * apply MUnionR. apply IH.
 - simpl.
    destruct re.
    + apply MEmpty.
    + apply MEmpty.
    + apply MStar0.
    + apply MStar0.
    + apply MStar0.
    + simpl.
      destruct re.
      * apply MStar0.
      * apply MStar0.
      * apply MStar0.
      * apply MStar0.
      * apply MStar0.
      * apply MStar0.
 - simpl.
   destruct re.
   + inversion IH1.
   + inversion IH1. inversion IH2. apply MEmpty.
   + apply star_app.
     * apply MStar1. apply IH1.
     * apply IH2.
   + apply star_app.
     * apply MStar1.  apply IH1.
     * apply IH2.
   + apply star_app.
     * apply MStar1.  apply IH1.
     * apply IH2.
   + apply star_app.
     * apply MStar1.  apply IH1.
     * apply IH2.
Qed.

(* Use the automation tools described so far to shorten the proof. *)

Lemma re_opt_match' : forall T (re: reg_exp T) s,
  s =~ re -> s =~ re_opt re.
Proof.
(* FILL IN HERE *) Admitted.
(* Do not modify the following line: *)
Definition manual_grade_for_re_opt : option (nat*string) := None.
(** [] *)

(* ================================================================= *)
(** ** A Few More Handy Tactics *)

(** By the way, here are some miscellaneous tactics that you may find
    convenient as we continue.

     - [clear H]: Delete hypothesis [H] from the context.

     - [rename... into...]: Change the name of a hypothesis in the
       proof context.  For example, if the context includes a variable
       named [x], then [rename x into y] will change all occurrences
       of [x] to [y].

     - [subst x]: Find an assumption [x = e] or [e = x] in the
       context, replace [x] with [e] throughout the context and
       current goal, and clear the assumption.

     - [subst]: Substitute away _all_ assumptions of the form [x = e]
       or [e = x].

    We'll see examples as we go along. *)

(* ================================================================= *)
(** ** Defining New Tactics *)

(** Coq also provides several ways of "programming" tactic
scripts.

    - Coq has a built-in language called [Ltac] with primitives that
      can examine and modify the proof state.  The full details are a
      bit too complicated to get into here (and it is generally agreed
      that [Ltac] is not the most beautiful part of Coq's design!),
      but they can be found in the reference manual and other books on
      Coq. Simple use cases are not too difficult.

    - There is also an OCaml API, which can be used to build tactics
      that access Coq's internal structures at a lower level, but this
      is seldom worth the trouble for ordinary Coq users.
*)

(**    Here is a simple [Ltac] example: *)

Ltac impl_and_try c := simpl; try c.

(** This defines a new tactical called [simpl_and_try] that takes one
    tactic [c] as an argument and is defined to be equivalent to the
    tactic [simpl; try c].  Now writing "[simpl_and_try reflexivity.]"
    in a proof will be the same as writing "[simpl; try
    reflexivity.]" *)

(* ################################################################# *)
(** * Decision Procedures *)

(** So far, the automation we have considered has primarily been
    useful for removing repetition. Another important category of
    automation consists of built-in decision procedures for specific
    kinds of problems.  There are several of these, but the [lia]
    tactic is the most important to start with. *)

(* ================================================================= *)
(** ** The [lia] Tactic *)

(** The [lia] tactic implements a decision procedure for integer linear
    arithmetic, a subset of propositional logic and arithmetic.

    If the goal is a formula made out of

      - variables and constants of type [nat] (or other integer types)

      - numeric constants, addition ([+] and [S]), subtraction ([-]
        and [pred]), and multiplication by constants
        (this is what makes it linear arithmetic)

      - equality ([=] and [<>]) and ordering ([<=]), and

      - the logical connectives [/\], [\/], [~], [->], and [<->].

    then invoking [lia] will either solve the goal or fail, meaning
    that the goal is actually false.  (If the goal is _not_ of this
    form, [lia] will also fail.) *)

Example silly_lia_example : forall m n o p,
  m + n <= n + o /\ o + 3 = p + 3 ->
  m <= p.
Proof.
  intros. lia.
Qed.

(* ################################################################# *)
(** * Search Tactics *)

(** Another very important category of automation tactics
    helps us construct proofs by _searching_ for relevant facts
    These tactics include the [auto] tactic for backwards reasoning,
    automated forward reasoning via the [Ltac] hypothesis matching
    machinery, and deferred instantiation of existential variables
    using [eapply] and [eauto].  Using these features together with
    Ltac's scripting facilities will enable us to make our proofs
    startlingly short!  Used properly, they can also make proofs more
    maintainable and robust to changes in underlying definitions.  A
    deeper treatment of [auto] and [eauto] can be found in the
    [UseAuto] chapter in _Programming Language Foundations_. *)

(* ================================================================= *)
(** ** The [constructor] tactic. *)

(** A simple first example of a search tactic is [constructor],
    which tries to find a constructor [c] (from some
    [Inductive] definition in the current environment) that can be
    applied to solve the current goal.  If one is found, behave
    like [apply c]. *)

Print ev.
(* ===>
   Inductive ev : nat -> Prop :=
    ev_0 : ev 0
  | ev_SS : forall n : nat, ev n -> ev (S (S n))
*)

Example constructor_example: forall (n:nat),
    ev (n+n).
Proof.
  induction n; simpl.
  - constructor. (* applies ev_0 *)
  - rewrite add_comm. simpl. constructor. (* applies ev_SS *) auto.
Qed.

(** This saves us from needing to remember the names of our constructors.
    Warning: if more than one constructor can apply, [constructor] picks
    the first one (in the order in which they were defined in the [Inductive])
    which is not necessarily the one we want! *)

(* ================================================================= *)
(** ** The [auto] Tactic *)

(** Thus far, our proof scripts mostly apply relevant hypotheses or
    lemmas by name, and one at a time. *)

Example auto_example_1 : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P Q R H1 H2 H3.
  apply H2. apply H1. apply H3.
Qed.

(** The [auto] tactic frees us from this drudgery by _searching_ for a
    sequence of applications that will prove the goal: *)

Example auto_example_1' : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  auto.
Qed.

(** The [auto] tactic solves goals that are solvable by any combination of
     - [intros] and
     - [apply] (of hypotheses from the local context, by default). *)

(** Using [auto] is always "safe" in the sense that it will never fail
    and will never change the proof state: either it completely solves
    the current goal, or it does nothing. *)

(** Here is a more interesting example showing [auto]'s power: *)

Example auto_example_2 : forall P Q R S T U : Prop,
  (P -> Q) ->
  (P -> R) ->
  (T -> R) ->
  (S -> T -> U) ->
  ((P -> Q) -> (P -> S)) ->
  T ->
  P ->
  U.
Proof. auto. Qed.

(** Proof search could, in principle, take an arbitrarily long time,
    so there are limits to how far [auto] will search by default. *)

Example auto_example_3 : forall (P Q R S T U: Prop),
  (P -> Q) ->
  (Q -> R) ->
  (R -> S) ->
  (S -> T) ->
  (T -> U) ->
  P ->
  U.
Proof.
  (* When it cannot solve the goal, [auto] does nothing *)
  auto.
  (* Optional argument says how deep to search (default is 5) *)
  auto 6.
Qed.

(** When searching for potential proofs of the current goal,
    [auto] considers the hypotheses in the current context together
    with a _hint database_ of other lemmas and constructors.  Some
    common lemmas about equality and logical operators are installed
    in this hint database by default. *)

Example auto_example_4 : forall P Q R : Prop,
  Q ->
  (Q -> R) ->
  P \/ (Q /\ R).
Proof. auto. Qed.

(** If we want to see which facts [auto] is using, we can use
    [info_auto] instead. *)

Example auto_example_5: 2 = 2.
Proof.
  (* auto subsumes reflexivity because eq_refl is in hint database *)
  info_auto.
Qed.

(** We can extend the hint database just for the purposes of one
    application of [auto] by writing "[auto using ...]". *)

Lemma le_antisym : forall n m: nat, (n <= m /\ m <= n) -> n = m.
Proof. intros. lia. Qed.

Example auto_example_6 : forall n m p : nat,
  (n <= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  auto using le_antisym.
Qed.

(** Of course, in any given development there will probably be
    some specific constructors and lemmas that are used very often in
    proofs.  We can add these to the global hint database by writing

      Hint Resolve T : core.

    at the top level, where [T] is a top-level theorem or a
    constructor of an inductively defined proposition (i.e., anything
    whose type is an implication).  As a shorthand, we can write

      Hint Constructors c : core.

    to tell Coq to do a [Hint Resolve] for _all_ of the constructors
    from the inductive definition of [c].

    It is also sometimes necessary to add

      Hint Unfold d : core.

    where [d] is a defined symbol, so that [auto] knows to expand uses
    of [d], thus enabling further possibilities for applying lemmas that
    it knows about. *)

(** It is also possible to define specialized hint databases that can
    be activated only when needed.  See the Coq reference manual for
    more. *)

Hint Resolve le_antisym : core.

Example auto_example_6' : forall n m p : nat,
  (n<= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  auto. (* picks up hint from database *)
Qed.

Definition is_fortytwo x := (x = 42).

Example auto_example_7: forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof.
  auto.  (* does nothing *)
Abort.

Hint Unfold is_fortytwo : core.

Example auto_example_7' : forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof. info_auto. Qed.

(** **** Exercise: 3 stars, advanced (pumping_redux)

    Use [auto], [lia], and any other useful tactics from this chapter to
    shorten your proof (or the "official" solution proof) of the weak Pumping
    Lemma exercise from [IndProp]. *)
Import Pumping.
Lemma weak_pumping : forall T (re : reg_exp T) s,
  s =~ re ->
  pumping_constant re <= length s ->
  exists s1 s2 s3,
    s = s1 ++ s2 ++ s3 /\
    s2 <> [] /\
    forall m, s1 ++ napp m s2 ++ s3 =~ re.
Proof.
(* FILL IN HERE *) Admitted.
(* Do not modify the following line: *)
Definition manual_grade_for_pumping_redux : option (nat*string) := None.
(** [] *)

(** **** Exercise: 3 stars, advanced, optional (pumping_redux_strong)

    Use [auto], [lia], and any other useful tactics from this chapter to
    shorten your proof (or the "official" solution proof) of the stronger
    Pumping Lemma exercise from [IndProp]. *)
Import Pumping.
Lemma pumping : forall T (re : reg_exp T) s,
  s =~ re ->
  pumping_constant re <= length s ->
  exists s1 s2 s3,
    s = s1 ++ s2 ++ s3 /\
    s2 <> [] /\
    length s1 + length s2 <= pumping_constant re /\
    forall m, s1 ++ napp m s2 ++ s3 =~ re.
Proof.
(* FILL IN HERE *) Admitted.
(* Do not modify the following line: *)
Definition manual_grade_for_pumping_redux_strong : option (nat*string) := None.
(** [] *)

(* ================================================================= *)
(** ** The [eapply] and [eauto] variants *)

(** To close the chapter, we'll introduce one more convenient feature
    of Coq: its ability to delay instantiation of quantifiers. To motivate
    this feature, consider again this simple example: *)

Example trans_example1:  forall a b c d,
    a <= b + b*c  ->
    (1+c)*b <= d ->
    a <= d.
Proof.
  intros a b c d H1 H2.
  apply le_trans with (b+ b*c).  (* <-- We must supply the intermediate value *)
  + apply H1.
  + simpl in H2. rewrite mul_comm. apply H2.
Qed.

(** In the first step of the proof, we had to explicitly provide a
    longish expression to help Coq instantiate a "hidden" argument to
    the [le_trans] constructor. This was needed because the definition
    of [le_trans]...

    le_trans : forall m n o : nat, m <= n -> n <= o -> m <= o

   is quantified over a variable, [n], that does not appear in its
   conclusion, so unifying its conclusion with the goal state doesn't
   help Coq find a suitable value for this variable.  If we leave
   out the [with], this step fails ("Error: Unable to find an
   instance for the variable [n]").

   We already know one way to avoid an explicit [with] clause, namely
   to provide [H1] as the (first) explicit argument to [le_trans].
   But here's another way, using the [eapply tactic]: *)

Example trans_example1':  forall a b c d,
    a <= b + b*c  ->
    (1+c)*b <= d ->
    a <= d.
Proof.
  intros a b c d H1 H2.
  eapply le_trans.  (* 1 *)
  + apply H1.  (* 2 *)
  + simpl in H2. rewrite mul_comm. apply H2.
Qed.

(** The [eapply H] tactic behaves just like [apply H] except
    that, after it finishes unifying the goal state with the
    conclusion of [H], it does not bother to check whether all the
    variables that were introduced in the process have been given
    concrete values during unification.

    If you step through the proof above, you'll see that the goal
    state at position [1] mentions the _existential variable_ [?n]
    in both of the generated subgoals.  The next step (which gets us
    to position [2]) replaces [?n] with a concrete value.  When we
    start working on the second subgoal (position [3]), we observe
    that the occurrence of [?n] in this subgoal has been replaced
    by the value that it was given during the first subgoal. *)

(** Several of the tactics that we've seen so far, including [exists],
    [constructor], and [auto], have [e...] variants.  For example,
    here's a proof using [eauto]: *)

Example trans_example2:  forall a b c d,
    a <= b + b*c  ->
    b + b*c <= d ->
    a <= d.
Proof.
  intros a b c d H1 H2.
  info_eauto using le_trans.
Qed.

(** The [eauto] tactic works just like [auto], except that it uses
    [eapply] instead of [apply].

    Pro tip: One might think that, since [eapply] and [eauto] are more
    powerful than [apply] and [auto], it would be a good idea to use
    them all the time.  Unfortunately, they are also significantly
    slower -- especially [eauto].  Coq experts tend to use [apply] and
    [auto] most of the time, only switching to the [e] variants when
    the ordinary variants don't do the job. *)

(* 2021-08-11 15:08 *)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

Require Import NAxioms NProperties OrdersFacts.

(** Implementation of [NAxiomsSig] by [nat] *)

Module Nat
 <: NAxiomsSig
 <: UsualDecidableTypeFull
 <: OrderedTypeFull
 <: TotalOrder.

(** Operations over [nat] are defined in a separate module *)

Include Coq.Init.Nat.

(** When including property functors, inline t eq zero one two lt le succ *)

Set Inline Level 50.

(** All operations are well-defined (trivial here since eq is Leibniz) *)

Definition eq_equiv : Equivalence (@eq nat) := eq_equivalence.
Local Obligation Tactic := simpl_relation.
Program Instance succ_wd : Proper (eq==>eq) S.
Program Instance pred_wd : Proper (eq==>eq) pred.
Program Instance add_wd : Proper (eq==>eq==>eq) plus.
Program Instance sub_wd : Proper (eq==>eq==>eq) minus.
Program Instance mul_wd : Proper (eq==>eq==>eq) mult.
Program Instance pow_wd : Proper (eq==>eq==>eq) pow.
Program Instance div_wd : Proper (eq==>eq==>eq) div.
Program Instance mod_wd : Proper (eq==>eq==>eq) modulo.
Program Instance lt_wd : Proper (eq==>eq==>iff) lt.
Program Instance testbit_wd : Proper (eq==>eq==>eq) testbit.

(** Bi-directional induction. *)

Theorem bi_induction :
  forall A : nat -> Prop, Proper (eq==>iff) A ->
    A 0 -> (forall n : nat, A n <-> A (S n)) -> forall n : nat, A n.
Proof.
intros A A_wd A0 AS. apply nat_ind. assumption. intros; now apply -> AS.
Qed.

(** Recursion fonction *)

Definition recursion {A} : A -> (nat -> A -> A) -> nat -> A :=
  nat_rect (fun _ => A).

Instance recursion_wd {A} (Aeq : relation A) :
 Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) recursion.
Proof.
intros a a' Ha f f' Hf n n' Hn. subst n'.
induction n; simpl; auto. apply Hf; auto.
Qed.

Theorem recursion_0 :
  forall {A} (a : A) (f : nat -> A -> A), recursion a f 0 = a.
Proof.
reflexivity.
Qed.

Theorem recursion_succ :
  forall {A} (Aeq : relation A) (a : A) (f : nat -> A -> A),
    Aeq a a -> Proper (eq==>Aeq==>Aeq) f ->
      forall n : nat, Aeq (recursion a f (S n)) (f n (recursion a f n)).
Proof.
unfold Proper, respectful in *; induction n; simpl; auto.
Qed.

(** ** Remaining constants not defined in Coq.Init.Nat *)

(** NB: Aliasing [le] is mandatory, since only a Definition can implement
    an interface Parameter... *)

Definition eq := @Logic.eq nat.
Definition le := Peano.le.
Definition lt := Peano.lt.

(** ** Basic specifications : pred add sub mul *)

Lemma pred_succ n : pred (S n) = n.
Proof.
reflexivity.
Qed.

Lemma pred_0 : pred 0 = 0.
Proof.
reflexivity.
Qed.

Lemma one_succ : 1 = S 0.
Proof.
reflexivity.
Qed.

Lemma two_succ : 2 = S 1.
Proof.
reflexivity.
Qed.

Lemma add_0_l n : 0 + n = n.
Proof.
reflexivity.
Qed.

Lemma add_succ_l n m : (S n) + m = S (n + m).
Proof.
reflexivity.
Qed.

Lemma sub_0_r n : n - 0 = n.
Proof.
now destruct n.
Qed.

Lemma sub_succ_r n m : n - (S m) = pred (n - m).
Proof.
revert m. induction n; destruct m; simpl; auto. apply sub_0_r.
Qed.

Lemma mul_0_l n : 0 * n = 0.
Proof.
reflexivity.
Qed.

Lemma mul_succ_l n m : S n * m = n * m + m.
Proof.
assert (succ_r : forall x y, x+S y = S(x+y)) by now induction x.
assert (comm : forall x y, x+y = y+x).
{ induction x; simpl; auto. intros; rewrite succ_r; now f_equal. }
now rewrite comm.
Qed.

Lemma lt_succ_r n m : n < S m <-> n <= m.
Proof.
split. apply Peano.le_S_n. induction 1; auto.
Qed.

(** ** Boolean comparisons *)

Lemma eqb_eq n m : eqb n m = true <-> n = m.
Proof.
 revert m.
 induction n; destruct m; simpl; rewrite ?IHn; split; try easy.
 - now intros ->.
 - now injection 1.
Qed.

Lemma leb_le n m : (n <=? m) = true <-> n <= m.
Proof.
 revert m.
 induction n; destruct m; simpl.
 - now split.
 - split; trivial. intros; apply Peano.le_0_n.
 - now split.
 - rewrite IHn; split.
   + apply Peano.le_n_S.
   + apply Peano.le_S_n.
Qed.

Lemma ltb_lt n m : (n <? m) = true <-> n < m.
Proof.
 apply leb_le.
Qed.

(** ** Decidability of equality over [nat]. *)

Lemma eq_dec : forall n m : nat, {n = m} + {n <> m}.
Proof.
  induction n; destruct m.
  - now left.
  - now right.
  - now right.
  - destruct (IHn m); [left|right]; auto.
Defined.

(** ** Ternary comparison *)

(** With [nat], it would be easier to prove first [compare_spec],
    then the properties below. But then we wouldn't be able to
    benefit from functor [BoolOrderFacts] *)

Lemma compare_eq_iff n m : (n ?= m) = Eq <-> n = m.
Proof.
 revert m; induction n; destruct m; simpl; rewrite ?IHn; split; auto; easy.
Qed.

Lemma compare_lt_iff n m : (n ?= m) = Lt <-> n < m.
Proof.
 revert m; induction n; destruct m; simpl; rewrite ?IHn; split; try easy.
 - intros _. apply Peano.le_n_S, Peano.le_0_n.
 - apply Peano.le_n_S.
 - apply Peano.le_S_n.
Qed.

Lemma compare_le_iff n m : (n ?= m) <> Gt <-> n <= m.
Proof.
 revert m; induction n; destruct m; simpl; rewrite ?IHn.
 - now split.
 - split; intros. apply Peano.le_0_n. easy.
 - split. now destruct 1. inversion 1.
 - split; intros. now apply Peano.le_n_S. now apply Peano.le_S_n.
Qed.

Lemma compare_antisym n m : (m ?= n) = CompOpp (n ?= m).
Proof.
 revert m; induction n; destruct m; simpl; trivial.
Qed.

Lemma compare_succ n m : (S n ?= S m) = (n ?= m).
Proof.
 reflexivity.
Qed.

(* BUG: Ajout d'un cas * après preuve finie (deuxième niveau +++*** ) :
    *  --->   Anomaly: Uncaught exception Proofview.IndexOutOfRange(_). Please report. *)

(** ** Minimum, maximum *)

Lemma max_l : forall n m, m <= n -> max n m = n.
Proof.
 exact Peano.max_l.
Qed.

Lemma max_r : forall n m, n <= m -> max n m = m.
Proof.
 exact Peano.max_r.
Qed.

Lemma min_l : forall n m, n <= m -> min n m = n.
Proof.
 exact Peano.min_l.
Qed.

Lemma min_r : forall n m, m <= n -> min n m = m.
Proof.
 exact Peano.min_r.
Qed.

(** Some more advanced properties of comparison and orders,
    including [compare_spec] and [lt_irrefl] and [lt_eq_cases]. *)

Include BoolOrderFacts.

(** We can now derive all properties of basic functions and orders,
    and use these properties for proving the specs of more advanced
    functions. *)

Include NBasicProp <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties.

(** ** Power *)

Lemma pow_neg_r a b : b<0 -> a^b = 0. inversion 1. Qed.

Lemma pow_0_r a : a^0 = 1.
Proof. reflexivity. Qed.

Lemma pow_succ_r a b : 0<=b -> a^(S b) = a * a^b.
Proof. reflexivity. Qed.

(** ** Square *)

Lemma square_spec n : square n = n * n.
Proof. reflexivity. Qed.

(** ** Parity *)

Definition Even n := exists m, n = 2*m.
Definition Odd n := exists m, n = 2*m+1.

Module Private_Parity.

Lemma Even_1 : ~ Even 1.
Proof.
 intros ([|], H); try discriminate.
 simpl in H. now rewrite <- plus_n_Sm in H.
Qed.

Lemma Even_2 n : Even n <-> Even (S (S n)).
Proof.
 split; intros (m,H).
 - exists (S m). rewrite H. simpl. now rewrite plus_n_Sm.
 - destruct m; try discriminate.
   exists m. simpl in H. rewrite <- plus_n_Sm in H. now inversion H.
Qed.

Lemma Odd_0 : ~ Odd 0.
Proof.
 now intros ([|], H).
Qed.

Lemma Odd_2 n : Odd n <-> Odd (S (S n)).
Proof.
 split; intros (m,H).
 - exists (S m). rewrite H. simpl. now rewrite <- (plus_n_Sm m).
 - destruct m; try discriminate.
   exists m. simpl in H. rewrite <- plus_n_Sm in H. inversion H.
   simpl. now rewrite <- !plus_n_Sm, <- !plus_n_O.
Qed.

End Private_Parity.
Import Private_Parity.

Lemma even_spec : forall n, even n = true <-> Even n.
Proof.
 fix even_spec 1.
  destruct n as [|[|n]]; simpl.
  - split; [ now exists 0 | trivial ].
  - split; [ discriminate | intro H; elim (Even_1 H) ].
  - rewrite even_spec. apply Even_2.
Qed.

Lemma odd_spec : forall n, odd n = true <-> Odd n.
Proof.
 unfold odd.
 fix odd_spec 1.
  destruct n as [|[|n]]; simpl.
  - split; [ discriminate | intro H; elim (Odd_0 H) ].
  - split; [ now exists 0 | trivial ].
  - rewrite odd_spec. apply Odd_2.
Qed.

(** ** Division *)

Lemma divmod_spec : forall x y q u, u <= y ->
 let (q',u') := divmod x y q u in
 x + (S y)*q + (y-u) = (S y)*q' + (y-u') /\ u' <= y.
Proof.
 induction x.
 - simpl; intuition.
 - intros y q u H. destruct u; simpl divmod.
   + generalize (IHx y (S q) y (le_n y)). destruct divmod as (q',u').
     intros (EQ,LE); split; trivial.
     rewrite <- EQ, sub_0_r, sub_diag, add_0_r.
     now rewrite !add_succ_l, <- add_succ_r, <- add_assoc, mul_succ_r.
   + assert (H' : u <= y).
     { apply le_trans with (S u); trivial. do 2 constructor. }
     generalize (IHx y q u H'). destruct divmod as (q',u').
     intros (EQ,LE); split; trivial.
     rewrite <- EQ.
     rewrite !add_succ_l, <- add_succ_r. f_equal. now rewrite <- sub_succ_l.
Qed.

Lemma div_mod x y : y<>0 -> x = y*(x/y) + x mod y.
Proof.
 intros Hy.
 destruct y; [ now elim Hy | clear Hy ].
 unfold div, modulo.
 generalize (divmod_spec x y 0 y (le_n y)).
 destruct divmod as (q,u).
 intros (U,V).
 simpl in *.
 now rewrite mul_0_r, sub_diag, !add_0_r in U.
Qed.

Lemma mod_bound_pos x y : 0<=x -> 0<y -> 0 <= x mod y < y.
Proof.
 intros Hx Hy. split. apply le_0_l.
 destruct y; [ now elim Hy | clear Hy ].
 unfold modulo.
 apply lt_succ_r, le_sub_l.
Qed.

(** ** Square root *)

Lemma sqrt_iter_spec : forall k p q r,
 q = p+p -> r<=q ->
 let s := sqrt_iter k p q r in
 s*s <= k + p*p + (q - r) < (S s)*(S s).
Proof.
 induction k.
 - (* k = 0 *)
   simpl; intros p q r Hq Hr.
   split.
   + apply le_add_r.
   + apply lt_succ_r.
     rewrite mul_succ_r.
     rewrite add_assoc, (add_comm p), <- add_assoc.
     apply add_le_mono_l.
     rewrite <- Hq. apply le_sub_l.
 - (* k = S k' *)
   destruct r.
   + (* r = 0 *)
     intros Hq _.
     replace (S k + p*p + (q-0)) with (k + (S p)*(S p) + (S (S q) - S (S q))).
     * apply IHk.
       simpl. now rewrite add_succ_r, Hq. apply le_n.
     * rewrite sub_diag, sub_0_r, add_0_r. simpl.
       rewrite add_succ_r; f_equal. rewrite <- add_assoc; f_equal.
       rewrite mul_succ_r, (add_comm p), <- add_assoc. now f_equal.
   + (* r = S r' *)
     intros Hq Hr.
     replace (S k + p*p + (q-S r)) with (k + p*p + (q - r)).
     * apply IHk; trivial. apply le_trans with (S r); trivial. do 2 constructor.
     * simpl. rewrite <- add_succ_r. f_equal. rewrite <- sub_succ_l; trivial.
Qed.

Lemma sqrt_specif n : (sqrt n)*(sqrt n) <= n < S (sqrt n) * S (sqrt n).
Proof.
 set (s:=sqrt n).
 replace n with (n + 0*0 + (0-0)).
 apply sqrt_iter_spec; auto.
 simpl. now rewrite !add_0_r.
Qed.

Definition sqrt_spec a (Ha:0<=a) := sqrt_specif a.

Lemma sqrt_neg a : a<0 -> sqrt a = 0.
Proof. inversion 1. Qed.

(** ** Logarithm *)

Lemma log2_iter_spec : forall k p q r,
 2^(S p) = q + S r -> r < 2^p ->
 let s := log2_iter k p q r in
 2^s <= k + q < 2^(S s).
Proof.
 induction k.
 - (* k = 0 *)
   intros p q r EQ LT. simpl log2_iter. cbv zeta.
   split.
   + rewrite add_0_l.
     rewrite (add_le_mono_l _ _ (2^p)).
     simpl pow in EQ. rewrite add_0_r in EQ. rewrite EQ.
     rewrite add_comm. apply add_le_mono_r. apply LT.
   + rewrite EQ, add_comm. apply add_lt_mono_l.
     apply lt_succ_r, le_0_l.
 - (* k = S k' *)
   intros p q r EQ LT. destruct r.
   + (* r = 0 *)
     rewrite add_succ_r, add_0_r in EQ.
     rewrite add_succ_l, <- add_succ_r. apply IHk.
     * rewrite <- EQ. remember (S p) as p'; simpl. now rewrite add_0_r.
     * rewrite EQ. constructor.
   + (* r = S r' *)
     rewrite add_succ_l, <- add_succ_r. apply IHk.
     * now rewrite add_succ_l, <- add_succ_r.
     * apply le_lt_trans with (S r); trivial. do 2 constructor.
Qed.

Lemma log2_spec n : 0<n ->
 2^(log2 n) <= n < 2^(S (log2 n)).
Proof.
 intros.
 set (s:=log2 n).
 replace n with (pred n + 1).
 apply log2_iter_spec; auto.
 rewrite add_1_r.
 apply succ_pred. now apply neq_sym, lt_neq.
Qed.

Lemma log2_nonpos n : n<=0 -> log2 n = 0.
Proof.
 inversion 1; now subst.
Qed.

(** ** Gcd *)

Definition divide x y := exists z, y=z*x.
Notation "( x | y )" := (divide x y) (at level 0) : nat_scope.

Lemma gcd_divide : forall a b, (gcd a b | a) /\ (gcd a b | b).
Proof.
 fix gcd_divide 1.
 intros [|a] b; simpl.
 split.
  now exists 0.
  exists 1. simpl. now rewrite <- plus_n_O.
 fold (b mod (S a)).
 destruct (gcd_divide (b mod (S a)) (S a)) as (H,H').
 set (a':=S a) in *.
 split; auto.
 rewrite (div_mod b a') at 2 by discriminate.
 destruct H as (u,Hu), H' as (v,Hv).
 rewrite mul_comm.
 exists ((b/a')*v + u).
 rewrite mul_add_distr_r.
 now rewrite <- mul_assoc, <- Hv, <- Hu.
Qed.

Lemma gcd_divide_l : forall a b, (gcd a b | a).
Proof.
 intros. apply gcd_divide.
Qed.

Lemma gcd_divide_r : forall a b, (gcd a b | b).
Proof.
 intros. apply gcd_divide.
Qed.

Lemma gcd_greatest : forall a b c, (c|a) -> (c|b) -> (c|gcd a b).
Proof.
 fix gcd_greatest 1.
 intros [|a] b; simpl; auto.
 fold (b mod (S a)).
 intros c H H'. apply gcd_greatest; auto.
 set (a':=S a) in *.
 rewrite (div_mod b a') in H' by discriminate.
 destruct H as (u,Hu), H' as (v,Hv).
 exists (v - (b/a')*u).
 rewrite mul_comm in Hv.
 rewrite mul_sub_distr_r, <- Hv, <- mul_assoc, <-Hu.
 now rewrite add_comm, add_sub.
Qed.

Lemma gcd_nonneg a b : 0<=gcd a b.
Proof. apply le_0_l. Qed.

(** ** Bitwise operations *)

Lemma div2_double n : div2 (2*n) = n.
Proof.
 induction n; trivial.
 simpl mul. rewrite add_succ_r. simpl. now f_equal.
Qed.

Lemma div2_succ_double n : div2 (S (2*n)) = n.
Proof.
 induction n; trivial.
 simpl. f_equal. now rewrite add_succ_r.
Qed.

Lemma le_div2 n : div2 (S n) <= n.
Proof.
 revert n.
 fix le_div2 1.
 destruct n; simpl; trivial. apply lt_succ_r.
 destruct n; [simpl|]; trivial. now constructor.
Qed.

Lemma lt_div2 n : 0 < n -> div2 n < n.
Proof.
 destruct n.
 - inversion 1.
 - intros _. apply lt_succ_r, le_div2.
Qed.

Lemma div2_decr a n : a <= S n -> div2 a <= n.
Proof.
 destruct a; intros H.
 - simpl. apply le_0_l.
 - apply succ_le_mono in H.
   apply le_trans with a; [ apply le_div2 | trivial ].
Qed.

Lemma double_twice : forall n, double n = 2*n.
Proof.
 simpl; intros. now rewrite add_0_r.
Qed.

Lemma testbit_0_l : forall n, testbit 0 n = false.
Proof.
 now induction n.
Qed.

Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true.
Proof.
 unfold testbit. rewrite odd_spec. now exists a.
Qed.

Lemma testbit_even_0 a : testbit (2*a) 0 = false.
Proof.
 unfold testbit, odd. rewrite (proj2 (even_spec _)); trivial.
 now exists a.
Qed.

Lemma testbit_odd_succ' a n : testbit (2*a+1) (S n) = testbit a n.
Proof.
 unfold testbit; fold testbit.
 rewrite add_1_r. f_equal.
 apply div2_succ_double.
Qed.

Lemma testbit_even_succ' a n : testbit (2*a) (S n) = testbit a n.
Proof.
 unfold testbit; fold testbit. f_equal. apply div2_double.
Qed.

Lemma shiftr_specif : forall a n m,
 testbit (shiftr a n) m = testbit a (m+n).
Proof.
 induction n; intros m. trivial.
 now rewrite add_0_r.
 now rewrite add_succ_r, <- add_succ_l, <- IHn.
Qed.

Lemma shiftl_specif_high : forall a n m, n<=m ->
 testbit (shiftl a n) m = testbit a (m-n).
Proof.
 induction n; intros m H. trivial.
 now rewrite sub_0_r.
 destruct m. inversion H.
 simpl. apply succ_le_mono in H.
 change (shiftl a (S n)) with (double (shiftl a n)).
 rewrite double_twice, div2_double. now apply IHn.
Qed.

Lemma shiftl_spec_low : forall a n m, m<n ->
 testbit (shiftl a n) m = false.
Proof.
 induction n; intros m H. inversion H.
 change (shiftl a (S n)) with (double (shiftl a n)).
 destruct m; simpl.
 unfold odd. apply negb_false_iff.
 apply even_spec. exists (shiftl a n). apply double_twice.
 rewrite double_twice, div2_double. apply IHn.
 now apply succ_le_mono.
Qed.

Lemma div2_bitwise : forall op n a b,
 div2 (bitwise op (S n) a b) = bitwise op n (div2 a) (div2 b).
Proof.
 intros. unfold bitwise; fold bitwise.
 destruct (op (odd a) (odd b)).
 now rewrite div2_succ_double.
 now rewrite add_0_l, div2_double.
Qed.

Lemma odd_bitwise : forall op n a b,
 odd (bitwise op (S n) a b) = op (odd a) (odd b).
Proof.
 intros. unfold bitwise; fold bitwise.
 destruct (op (odd a) (odd b)).
 apply odd_spec. rewrite add_comm. eexists; eauto.
 unfold odd. apply negb_false_iff. apply even_spec.
 rewrite add_0_l; eexists; eauto.
Qed.

Lemma testbit_bitwise_1 : forall op, (forall b, op false b = false) ->
 forall n m a b, a<=n ->
 testbit (bitwise op n a b) m = op (testbit a m) (testbit b m).
Proof.
 intros op Hop.
 induction n; intros m a b Ha.
 simpl. inversion Ha; subst. now rewrite testbit_0_l.
 destruct m.
 apply odd_bitwise.
 unfold testbit; fold testbit. rewrite div2_bitwise.
 apply IHn. now apply div2_decr.
Qed.

Lemma testbit_bitwise_2 : forall op, op false false = false ->
 forall n m a b, a<=n -> b<=n ->
 testbit (bitwise op n a b) m = op (testbit a m) (testbit b m).
Proof.
 intros op Hop.
 induction n; intros m a b Ha Hb.
 simpl. inversion Ha; inversion Hb; subst. now rewrite testbit_0_l.
 destruct m.
 apply odd_bitwise.
 unfold testbit; fold testbit. rewrite div2_bitwise.
 apply IHn; now apply div2_decr.
Qed.

Lemma land_spec a b n :
 testbit (land a b) n = testbit a n && testbit b n.
Proof.
 unfold land. apply testbit_bitwise_1; trivial.
Qed.

Lemma ldiff_spec a b n :
 testbit (ldiff a b) n = testbit a n && negb (testbit b n).
Proof.
 unfold ldiff. apply testbit_bitwise_1; trivial.
Qed.

Lemma lor_spec a b n :
 testbit (lor a b) n = testbit a n || testbit b n.
Proof.
 unfold lor. apply testbit_bitwise_2.
 - trivial.
 - destruct (compare_spec a b).
   + rewrite max_l; subst; trivial.
   + apply lt_le_incl in H. now rewrite max_r.
   + apply lt_le_incl in H. now rewrite max_l.
 - destruct (compare_spec a b).
   + rewrite max_r; subst; trivial.
   + apply lt_le_incl in H. now rewrite max_r.
   + apply lt_le_incl in H. now rewrite max_l.
Qed.

Lemma lxor_spec a b n :
 testbit (lxor a b) n = xorb (testbit a n) (testbit b n).
Proof.
 unfold lxor. apply testbit_bitwise_2.
 - trivial.
 - destruct (compare_spec a b).
   + rewrite max_l; subst; trivial.
   + apply lt_le_incl in H. now rewrite max_r.
   + apply lt_le_incl in H. now rewrite max_l.
 - destruct (compare_spec a b).
   + rewrite max_r; subst; trivial.
   + apply lt_le_incl in H. now rewrite max_r.
   + apply lt_le_incl in H. now rewrite max_l.
Qed.

Lemma div2_spec a : div2 a = shiftr a 1.
Proof.
 reflexivity.
Qed.

(** Aliases with extra dummy hypothesis, to fulfil the interface *)

Definition testbit_odd_succ a n (_:0<=n) := testbit_odd_succ' a n.
Definition testbit_even_succ a n (_:0<=n) := testbit_even_succ' a n.
Lemma testbit_neg_r a n (H:n<0) : testbit a n = false.
Proof. inversion H. Qed.

Definition shiftl_spec_high a n m (_:0<=m) := shiftl_specif_high a n m.
Definition shiftr_spec a n m (_:0<=m) := shiftr_specif a n m.

(** Properties of advanced functions (pow, sqrt, log2, ...) *)

Include NExtraProp.

(** Properties of tail-recursive addition and multiplication *)

Lemma tail_add_spec n m : tail_add n m = n + m.
Proof.
 revert m. induction n as [|n IH]; simpl; trivial.
 intros. now rewrite IH, add_succ_r.
Qed.

Lemma tail_addmul_spec r n m : tail_addmul r n m = r + n * m.
Proof.
 revert m r. induction n as [| n IH]; simpl; trivial.
 intros. rewrite IH, tail_add_spec.
 rewrite add_assoc. f_equal. apply add_comm.
Qed.

Lemma tail_mul_spec n m : tail_mul n m = n * m.
Proof.
 unfold tail_mul. now rewrite tail_addmul_spec.
Qed.

End Nat.

(** Re-export notations that should be available even when
    the [Nat] module is not imported. *)

Bind Scope nat_scope with Nat.t nat.

Infix "^" := Nat.pow : nat_scope.
Infix "=?" := Nat.eqb (at level 70) : nat_scope.
Infix "<=?" := Nat.leb (at level 70) : nat_scope.
Infix "<?" := Nat.ltb (at level 70) : nat_scope.
Infix "?=" := Nat.compare (at level 70) : nat_scope.
Infix "/" := Nat.div : nat_scope.
Infix "mod" := Nat.modulo (at level 40, no associativity) : nat_scope.

Hint Unfold Nat.le : core.
Hint Unfold Nat.lt : core.

(** [Nat] contains an [order] tactic for natural numbers *)

(** Note that [Nat.order] is domain-agnostic: it will not prove
    [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *)

Section TestOrder.
 Let test : forall x y, x<=y -> y<=x -> x=y.
 Proof.
 Nat.order.
 Qed.
End TestOrder.


From Coq Require Import Datatypes.
From Coq Require Import Lia.
From Coq Require Import List.
From Coq Require Import Logic.Eqdep_dec.
From Coq Require Import ZArith.

Import ListNotations.
Require Import Program.

Require Import FutharkUtils.

Declare Scope arr_scope.

Open Scope arr_scope.
Open Scope list_scope.

Notation "#| l |" := (List.length l) (at level 0, l at level 99, format "#| l |") : arr_scope.

Notation "[| n |] A" := ({ xs : list A | #|xs| = n }) (at level 100) : arr_scope.

Definition nil_arr {A : Type} : [|0|]A := exist _ [] eq_refl.

Program Definition cons {A : Type} {n : nat} (a : A) (l : [|n|]A) : [|S n|]A :=
  a :: l.

Notation "a [::] l" := (cons a l) (at level 60, right associativity) : arr_scope.

Program Definition append {A : Type} {n1 n2 : nat} (l1 : [|n1|]A) (l2 : [|n2|]A) : [|n1 + n2|]A :=
  l1 ++ l2.
Next Obligation.
  rewrite app_length; trivial.
Defined.

Notation "l1 [++] l2" := (append l1 l2) (at level 60, right associativity) : arr_scope.

Definition to_arr {A : Type} {n : nat} (l : list A) (len : #|l| = n) : [|n|]A :=
  exist (fun xs : list A => #|xs| = n) l len.

Instance arr_sigeq {n : nat} {A : Type} : SigEq (fun xs : list A => #|xs| = n) := SigEq_dec.
Instance arr_dec {n : nat} {A : Type} `{Dec A} : Dec ([|n|]A) := sig_dec.

Lemma equal_arr_f:
  forall (A B : Type) (f : forall {k : nat}, ([|k|]A) -> B) (n1 n2 : nat) (x1 : [|n1|]A) (x2 : [|n2|]A),
    n1 = n2 -> proj1_sig x1 = proj1_sig x2 -> f x1 = f x2.
Proof.
  intros; apply heterog_subset_eq_f; trivial; intros; apply arr_sigeq.
Qed.

Section equality.

  Context {A : Type} `{Dec A} {n : nat}.

  Lemma nil_eq:
    forall (xs : [|0|]A), xs = nil_arr.
  Proof.
    intros [[]]; apply subset_eq; discriminate + reflexivity.
  Qed.

  Lemma arr_cons_eq:
    forall (x1 x2 : A) (xs1 xs2 : [|n|]A), x1 [::] xs1 = x2 [::] xs2 -> x1 = x2 /\ xs1 = xs2.
  Proof.
    intros ? ? [] [] arr_eq;
      apply (f_equal (@proj1_sig _ _)) in arr_eq;
      simpl in arr_eq;
      inversion arr_eq;
      subst;
      split;
      try apply subset_eq;
      reflexivity.
  Qed.

End equality.

Section cons_rewrite.

  Context {A : Type} `{Dec A} {n : nat}.

  Lemma cons_convert_sig_len:
    forall (h : A) (t : list A), #|h :: t| = S n -> #|t| = n.
  Proof.
    intros * len; inversion len; reflexivity.
  Qed.

  Lemma cons_convert:
    forall (h : A) (t : list A) (len : #|h :: t| = S n),
      exist (fun xs : list A => #|xs| = S n) (h :: t) len = h [::] (to_arr t (cons_convert_sig_len _ _ len)).
  Proof.
    intros; apply subset_eq; reflexivity.
  Qed.

  Lemma cons_convert_sig:
    forall (h : A) (arr : [|n|]A) (pf : #|h :: `arr| = S n),
      exist (fun xs : list A => #|xs| = S n) (h :: `arr) pf = h [::] arr.
  Proof.
    intros; apply subset_eq; reflexivity.
  Qed.

End cons_rewrite.

Section decons.

  Context {A : Type} `{Dec A}.

End decons.

Ltac subst_arrs :=
  repeat let xs := fresh in
          let H  := fresh in
          match goal with
          | xs : [|_|]_, H : proj1_sig ?xs = proj1_sig _ |- _
            => apply subset_eq in H; subst xs
          | xs : [|_|]_, H : proj1_sig _ = proj1_sig ?xs |- _
            => apply subset_eq in H; subst xs
          end.

Section induction.

  Context {A : Type} `{Dec A}.

  Variable P : forall {n : nat} (arr : [|n|]A), Prop.
  Hypothesis base_case : P nil_arr.
  Hypothesis ind_step  : forall (n : nat) (a : A) (arr : [|n|]A), P arr -> P (a [::] arr).

  Lemma arr_ind:
    forall (n : nat) (arr : [|n|]A), P arr.
  Proof.
    intros n; induction n as [ | n IH ].
    * intros arr; assert (arr = nil_arr) by apply nil_eq; subst; apply base_case.
    * destruct arr as [[ | h t ] ?].
      + discriminate.
      + rewrite cons_convert; apply ind_step; apply IH.
  Qed.

End induction.

Section destruct.

  Context {A : Type} `{Dec A}.

  Variable P : forall {n : nat} (arr : [|n|]A), Prop.
  Hypothesis nil_case  : forall (arr : [|0|]A), P arr.
  Hypothesis cons_case : forall (n : nat) (a : A) (arr : [|n|]A), P (a [::] arr).

  Lemma arr_dest:
    forall (n : nat) (arr : [|n|]A), P arr.
  Proof.
    intros n arr; induction n, arr using arr_ind; auto.
  Qed.

End destruct.

Section decons.

  Context {A : Type} `{Dec A}.

  Lemma arr_decons:
    forall (n : nat) (arr : [|S n|]A), exists (h : A) (t : [|n|]A), arr = h [::] t.
  Proof.
    intros n [[ |h t]].
    * discriminate.
    * rewrite cons_convert;
      remember (to_arr t _) as t';
      exists h; exists t'; reflexivity.
  Qed.

  Variable P : forall {n : nat} (arr : [|S n|]A), Prop.
  Hypothesis decons : forall (n : nat) (a : A) (arr : [|n|]A), P (a [::] arr).

  Lemma decons_dest:
    forall (n : nat) (arr : [|S n|]A), P arr.
  Proof.
    intros n arr; pose proof (arr_decons n arr) as [h [t]]; subst; auto.
  Qed.

End decons.

Section indeuction_S.

  Context {A : Type} `{Dec A}.

  Variable P : forall {n : nat} (arr : [|S n|]A), Prop.
  Hypothesis base_case : forall (a : A), P (a [::] nil_arr).
  Hypothesis ind_step  : forall (a : A) (n : nat) (arr : [|S n|]A), P arr -> P (a [::] arr).

  Lemma arr_ind_S:
    forall (n : nat) (arr : [|S n|]A), P arr.
  Proof.
    intros n arr;
      destruct n, arr as [n h t] using decons_dest;
      generalize dependent h;
      induction n, t using arr_ind;
      intros.
    + apply base_case.
    + apply ind_step; auto.
  Qed.

End indeuction_S.

Ltac simplify_arrays :=
  repeat let a1 := fresh "a" in
         let a2 := fresh "a" in
         let k := fresh "k" in
         let T := fresh "T" in
         let H := fresh "H" in
         match goal with
         | a1 : [|0|]_    |- _ => rewrite (nil_eq a1)
         | a1 : [|S ?k|]_ |- _ => destruct k, a1 using decons_dest
         | a1 : [|?k|]?T, a2 : [|?k|]?T, H : proj1_sig ?a1 = proj1_sig ?a2 |- _
           => apply subset_eq in H; subst a1
         end.

Section cons_app.

  Context {A : Type} `{Dec A}.

  Lemma cons_app_assoc {n1 n2 : nat}:
    forall (h : A) (a1 : [|n1|]A) (a2 : [|n2|]A), (h [::] a1) [++] a2 = h [::] (a1 [++] a2).
  Proof.
    intros h a1 a2;
      apply subset_eq;
      destruct n1, a1 using arr_dest;
      reflexivity.
  Qed.

  Lemma cons_app_singleton {n : nat}:
    forall (h : A) (t : [|n|]A), h [::] t = to_arr [h] eq_refl [++] t.
  Proof.
    intros; apply subset_eq; reflexivity.
  Qed.

  Lemma app_nil:
    forall (l1 : [|0|]A) (n : nat) (l2 : [|n|]A), l1 [++] l2 = l2.
  Proof.
    intros [[]] *; apply subset_eq; simpl; (reflexivity + discriminate).
  Qed.

  Lemma nil_app:
    forall (n : nat) (l1 : [|n|]A) (l2 : [|0|]A), proj1_sig (l1 [++] l2) = proj1_sig l1.
  Proof.
    intros n l1 [[]]; simpl; (apply app_nil_r + discriminate).
  Qed.

End cons_app.

Section indexing.

  Context {A : Type} `{Dec A}.

  Inductive Index : forall {n : nat} (i : nat) (a : A) (xs : [|n|]A), Prop :=
  | IndexHead : forall {k : nat} (a : A) (t : [|k|]A), Index 0 a (a [::] t)
  | IndexTail : forall {k : nat} (i : nat) (a h : A) (t : [|k|]A),
      Index i a t -> Index (S i) a (h [::] t).

  Inductive Prefix : forall {l n : nat} (p : [|l|]A) (xs : [|n|]A), Prop :=
  | PrefixEmpty : forall {k : nat} (xs : [|k|]A), Prefix nil_arr xs
  | PrefixHead  : forall {l k : nat} (h : A) (p : [|l|]A) (xs : [|k|]A),
                      Prefix p xs -> Prefix (h [::] p) (h [::] xs).

  Inductive Segment : forall {n1 n2 : nat}, ([|n1|]A) -> ([|n2|]A) -> Prop :=
  | SegmentHead : forall {n1 n2 : nat} (l1 : [|n1|]A) (l2 : [|n2|]A),
      Prefix l1 l2 -> Segment l1 l2
  | SegmentInner : forall {n1 n2 : nat} (h : A) (l1 : [|n1|]A) (l2 : [|n2|]A),
      Segment l1 l2 -> Segment l1 (h [::] l2).

  Lemma index_len_rel:
    forall (i n : nat) (x : A) (xs : [|n|]A), Index i x xs -> i < n.
  Proof.
    intros i n x xs;
      generalize dependent x;
      generalize dependent i;
      induction n, xs using arr_ind;
      intros [ | i ] x cond;
      inversion cond;
      simplify_arrays;
      subst.
    * apply Nat.lt_0_succ.
    * specialize (IHxs i x); apply lt_n_S; auto.
  Qed.

  #[program] Fixpoint safe_index {n : nat} (i : nat) (pf : i < n) (xs : [|n|]A) : A :=
    match xs, i, n with
    | h :: t, 0, _       => h
    | h :: t, S i', S n' => @safe_index n' i' _ t
    | _, _, _           => !
    end.
  Next Obligation.
    simpl in pf; lia.
  Defined.
  Next Obligation.
    destruct xs as [ | h t ];
      destruct i as [ | i ];
      simpl in *.
    * inversion pf.
    * inversion pf.
    * apply (H1 h t (S #|t|)); auto.
    * apply (H0 h t i (#|t|)); auto.
  Defined.
  Next Obligation.
    unfold not; split; intros * [? []]; discriminate.
  Defined.
  Next Obligation.
    unfold not; split; intros * [? []]; discriminate.
  Defined.

  Lemma safe_index_pi:
    forall (i n : nat) (xs : [|n|]A) (pf1 pf2 : i < n),
      safe_index i pf1 xs = safe_index i pf2 xs.
  Proof.
    intros i n;
      generalize dependent i;
      induction n as [ | n IH ];
      intros [ | i ] [[ | h t ] len] pf1 pf2;
      simpl in *;
      match goal with
        (* the case where we reduce to indexing into the tail. *)
      | |- safe_index i ?_pf1' ?xs1 = safe_index i ?_pf2' ?xs2
        => replace xs1 with xs2; [apply IH | apply subset_eq; reflexivity]
        (* the rest of the cases. *)
      | |- _ => lia + reflexivity
      end.
  Qed.

  Lemma safe_index_equal_arrays:
    forall (i n : nat) (xs1 xs2 : [|n|]A) (pf1 pf2 : i < n),
      proj1_sig xs1 = proj1_sig xs2 -> safe_index i pf1 xs1 = safe_index i pf2 xs2.
  Proof.
    intros i n xs1 xs2 pf1 pf2 cond;
      replace xs2 with xs1 by (apply subset_eq; assumption);
      apply safe_index_pi.
  Qed.

  Lemma safe_index_head:
    forall (i n : nat) (x : A) (xs : [|n|]A) (pf : S i < S n), exists (pf' : i < n),
      safe_index (S i) pf (x [::] xs) = safe_index i pf' xs.
  Proof.
    intros [ | i ] [ | n ] x [[ | h t ] len] pf;
      (* take cara of all cases with contradicting inequalities. *)
      try (simpl in *; lia).
    * (* Cases indexing the head of the list. *)
      exists (Nat.lt_0_succ n); reflexivity.
    * (* Cases indexing the tail of the list. *)
      assert (pf' : S i < S n) by (lia);
        exists pf';
        simpl;
        apply safe_index_equal_arrays;
        reflexivity.
  Qed.

  Lemma safe_index_correct:
    forall (i n : nat) (x : A) (xs : [|n|]A) (pf : i < n),
      Index i x xs -> safe_index i pf xs = x.
  Proof.
    induction 1 as [ | n i x h t HInd IH ].
    + reflexivity.
    + pose proof (safe_index_head i n h t pf) as [pf' Hsafe];
      rewrite Hsafe;
      apply IH.
  Qed.

End indexing.


Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Program.Equality. (* for dependent induction *)
Require Import as2.

(* contexts *)
Definition ctxt n := fin n -> ty. (* this definition of a context lets us more readily use autosubst's notation and substitution machinery *)

Definition empty : ctxt 0 := fun x : fin 0 => let t := match x return ty with
                                                       end in t.

(* value relation *)
Inductive value {n} : tm n -> Prop :=
| v_abs : forall T t,
    value (lam T t)
| v_true : value ttrue
| v_false : value tfalse.

Hint Constructors value.

(* evaluation relation *)
Reserved Notation "t --> t'" (at level 50).
Inductive red {n} : tm n -> tm n -> Prop :=
| red_beta : forall (t : tm (S n)) (t' : tm n) (T: ty), (app (lam T t) t') --> (t [t' ..])
| red_app_1 : forall t1 t1' t2, t1 --> t1' ->
                                (app t1 t2) --> (app t1' t2)
| red_app_2 : forall t1 t2 t2', t2 --> t2' ->
                                (app t1 t2) --> (app t1 t2')
| red_tif_disc : forall t1 t1' t2 t3, t1 --> t1' ->
                                      (tif t1 t2 t3) --> (tif t1' t2 t3)
| red_tif_true : forall t2 t3, (tif ttrue t2 t3) --> t2
| red_tif_false : forall t2 t3, (tif tfalse t2 t3) --> t3
where " t --> t' " := (red t t').

Hint Constructors red.

(* typing relation *)
Reserved Notation " Gamma ||- t : T " (at level 60, t at level 70).
Inductive hasType {n} : ctxt n -> tm n -> ty -> Prop :=
| T_var: forall Gamma i,
    Gamma ||- (var_tm i) : (Gamma i)
| T_app : forall Gamma t1 t2 T1 T2,
    Gamma ||- t1 : (arrow T1 T2) ->
    Gamma ||- t2 : T1 ->
    Gamma ||- (app t1 t2) : T2
| T_abs : forall Gamma t T1 T2,
    @hasType (S n) (T1 .: Gamma) t T2 -> (* use stream cons defined by as2 to implement context bindings *)
    Gamma ||- (lam T1 t) : (arrow T1 T2)
| T_ttrue : forall Gamma, Gamma ||- ttrue : bool
| T_tfalse : forall Gamma, Gamma ||- ttrue : bool
| T_tif : forall Gamma t1 t2 t3 T,
    Gamma ||- t1 : bool ->
    Gamma ||- t2 : T ->
    Gamma ||- t3 : T ->
    Gamma ||- (tif t1 t2 t3) : T
where " Gamma ||- t : T " := (hasType Gamma t T).

Hint Constructors hasType.

Ltac inv H := inversion H; subst; clear H.

Theorem canonical_forms_abs: forall n Gamma (t : tm n) T1 T2,
    Gamma ||- t : (arrow T1 T2) ->
    value t ->
    exists t', t = lam T1 t'.
  intros n Gamma t T1 T2 HTy Hval.
  induction Hval; inv HTy; exists t; reflexivity.
Qed.

Theorem canonical_forms_bool: forall n Gamma (t : tm n),
    Gamma ||- t : bool ->
    value t ->
    (t = ttrue) \/ (t = tfalse).
  intros n Gamma t HTy Hval.
  induction Hval; inv HTy; auto.
Qed.

(* catch-all automation tactic; not great, but works *)
Ltac crunch :=
  try match goal with
         | [t : tm _ |- _] => match goal with
                            | [ HTy : _ ||- t : (arrow _ _) , Hval : value t |- _] => pose proof (canonical_forms_abs _ _ _ _ _ HTy Hval)
                            end

         | [t : tm _ |- _] => match goal with
                            | [ HTy : _ ||- t : bool , Hval : value t |- _] => pose proof (canonical_forms_bool _ _ _ HTy Hval)
                            end
         (* fin 0 is uninhabited; this immediately solves the goal. *)
         | [ f : fin 0 |- _ ] => destruct f; crunch
         (* deal with some nonsense that crops up during induction and inversion on our typing relation *)
         | [ t1 : tm 0 |- _] => match goal with
                          | [ HTy : empty ||- t1 : _ , H : forall t0 : tm 0,
                                  0 = 0 -> t1 ~= t0 -> forall T : ty, empty ||- t0 : T -> value t0 \/ (exists t' : tm 0, t0 --> t') |- _] => specialize (H _ eq_refl JMeq_refl _ HTy); crunch
                              end
         end.

Lemma progess: forall t T,
    empty ||- t : T ->
    value t \/ exists t', t --> t'.
Proof.
  intros t T HTy.
  dependent induction t; try inv HTy; eauto; crunch.
  - (* t is an application *)
    right.
    destruct IHt1 as [Hvalt1 | Hstept1].
    + (* t1 is a value *)
      destruct IHt2 as [Hvalt2 | Hstept2].
      * (* t2 is also value *)
        crunch.
        destruct H as [t0 Heq]. (* AUTOMATEME *)
        exists (t0 [t2 ..]).
        subst.
        eauto.
      * (* t2 steps *)
        inv Hstept2; exists (app t1 x); eauto.
    + (* t1 steps *)
      inv Hstept1; exists (app x t2); eauto.
  - (* t is an if *)
    right.
    destruct IHt1 as [Hvalt1 | Hstept1].
    + (* discriminant of if is a value *)
      crunch.
      destruct H; subst. (* AUTOMATEME *)
      * (* branch left *)
        exists t2; auto.
      * (* branch right *)
        exists t3; auto.
    + destruct Hstept1 as [t1' Hred].
      exists (tif t1' t2 t3); eauto.
Qed.

  Fixpoint typres_ren n m Gamma Delta t T (H : Gamma ||- t : T) (delta : fin n -> fin m) {struct H}:
    (forall f, Gamma f = Delta (delta f)) -> (Delta ||- t⟨delta⟩ : T).
    destruct H; simpl; intros; asimpl; try rewrite (H i); eauto; econstructor; try eapply typres_ren; try assumption; try eauto; try intro; try destruct f; try simpl; try eauto.
  Qed.

  (* CLEAN ME *)
  Fixpoint typres_subst n m (sigma : fin n -> tm m) (Gamma : ctxt n) (Delta : ctxt m) (t : tm n) T (H: Gamma ||- t : T) {struct H} :
(forall i, Delta ||- (sigma i) : (Gamma i)) -> Delta ||- t[sigma] : T.
  Proof with eauto.
    intros.
    (* everything but the lambda case is immediate by substitution and the definitions *)
    destruct H; asimpl...
    (* lambda case follows by structural induction on terms, our
    substitution rules, and by preservation of types under
    renamings. *)
    econstructor.
    eapply typres_subst.
    exact H.
    intro.
    asimpl.
    destruct i.
    simpl.
    asimpl.
    eapply typres_ren...
    simpl.
    econstructor.
  Qed.

  Theorem typres_beta : forall n (Gamma : ctxt n) t t' T' T,
      (T' .: Gamma) ||- t : T ->
      Gamma ||- t' : T' ->
      Gamma ||- (t [t' ..]) : T.
  Proof.
    intros.
    eapply typres_subst.
    exact H.
    intro.
    destruct i; asimpl; simpl; eauto.
  Qed.

  (* preservation *)
  Theorem preservation t t' T (H: empty ||- t : T) (Hred: t --> t') :
    empty ||- t' : T.
    induction H.
    - inversion Hred.
    - inversion Hred; subst.
      +
        inversion H; subst.
        apply (typres_beta _ _ _ _ T1 T2 H3 H0).
      +
        eapply T_app.
        eapply IHhasType1.
        assumption.
        assumption.
      +
        eapply T_app.
        apply H.
        eapply IHhasType2.
        assumption.
    - inversion Hred.
    -
      inversion Hred.
    -
      inversion Hred.
    -
      inversion Hred; subst;
        try econstructor;
        try eapply IHhasType1;
        auto.
  Qed.


Require Export Modal.
Require Import Arith.EqNat.
Require Export SecOrder.

Fixpoint at_pred (l : list predicate) (i : nat) : predicate :=
  match l with
  | nil => (Pred 1)
  | cons q l' => match i with
                 | S 0 => q
                 | 0 => Pred 1
                 | _ => at_pred l' (i-1)
                 end
  end.

Lemma at_pred_0 : forall (l : list predicate),
  at_pred l 0 = Pred 1.
Proof.
  intros.
  induction l.
    simpl; reflexivity.

    simpl; reflexivity.
Qed.

Lemma at_pred_cons_1 : forall (l : list predicate) (P : predicate)
                            (j : nat),
  at_pred (cons P l) 1 = P.
Proof.
  intros; reflexivity.
Qed.

Lemma at_pred_cons : forall (l : list predicate) (P : predicate)
                            (j : nat),
  at_pred (cons P l) (S (S j)) = at_pred l (S j).
Proof.
  intros; reflexivity.
Qed.

Lemma at_pred_app_cons : forall (l1 l2 : list predicate) (p : predicate),
  at_pred (app l1 (cons p l2)) (length l1 + 1) = p.
Proof.
  intros; induction l1.
  simpl; reflexivity.
  simpl in *.
  rewrite <- plus_n_Sm. simpl.
  rewrite plus_n_Sm. assumption.
Qed.
(*   pose proof (beq_nat_false ((length l1) +1) 0 (not_zero (length l1))).
  case_eq (length l1 + 1).
    intros; specialize (H H0); contradiction.

    intros n H2.
    rewrite H2 in IHl1.
    simpl in *.
    exact IHl1.
Qed. *)

Lemma at_pred_app_l : forall (l1 l2 : list predicate) (i : nat),
  i <= (length l1) -> at_pred (app l1 l2) i = at_pred l1 i.
(*
  leb_nat i (length l1) = true -> at_pred (app l1 l2) i = at_pred l1 i. *)
Proof.
  induction l1.
    simpl in *.
    induction l2; simpl in *; try reflexivity.
      intros i H.
      destruct i; try reflexivity.
      contradiction (PeanoNat.Nat.nle_succ_0 _ H).

      simpl app.
      intros l2 i H.
      case_eq i.
        intros Hi.
        simpl.
        reflexivity.

      simpl.
      intros n Hi.
      rewrite IHl1.
        reflexivity.

        simpl in H. rewrite PeanoNat.Nat.sub_0_r.
        rewrite Hi in H. apply le_S_n. assumption.
Qed.

(*       unfold leb_nat in H; discriminate.

      simpl app.
      intros l2 i H.
      case_eq i.
        intros Hi.
        simpl.
        reflexivity.

      simpl.
      intros n Hi.
      rewrite IHl1.
        reflexivity.

        simpl in H.
        pose proof (leb_nat_plus (i-1) (length l1) 1) as H0.
        rewrite arith_plus_minus_assoc in H0.
        simpl in H0; rewrite arith_minus_zero in *.
        rewrite <- one_suc in H0.
        rewrite H in H0.
        rewrite Hi in *.
        simpl in H0.
        rewrite arith_minus_zero in H0.
        exact H0.

        rewrite Hi .
        simpl; reflexivity.

        simpl; reflexivity.
Qed.
 *)
Lemma at_pred_app_r : forall (l1 l2 : list predicate) (i : nat),
  beq_nat i 0 = false ->
    at_pred (app l1 l2) (length l1 + i) = at_pred l2 i.
Proof.
  intros l1 l2 i H.
  induction l1.
    simpl; reflexivity.

    simpl.
    case_eq (length l1 + i).
      intros H_eq. rewrite H_eq in IHl1. destruct l1.
        simpl in H_eq.
        rewrite H_eq in H. rewrite <- beq_nat_refl in H.
        discriminate.

        discriminate.
(*       pose proof (arith_plus_zero (length l1) i H_eq) as H1.
      pose proof (arith_plus_zero i (length l1)) as H2.
      rewrite arith_plus_comm in H2.
      specialize (H2 H_eq).
      pose proof (length_nil l1 H1) as H3.
      rewrite H1 in *; rewrite H2 in *.
      rewrite H_eq in *.
      simpl in *.
      discriminate.
 *)
      intros n H2.
      simpl in *.
      rewrite <- H2; exact IHl1.
Qed.
(*
    simpl.
    case_eq (length l1 + i).
      intros H_eq.
      pose proof (arith_plus_zero (length l1) i H_eq) as H1.
      pose proof (arith_plus_zero i (length l1)) as H2.
      rewrite arith_plus_comm in H2.
      specialize (H2 H_eq).
      pose proof (length_nil l1 H1) as H3.
      rewrite H1 in *; rewrite H2 in *.
      rewrite H_eq in *.
      simpl in *.
      discriminate.

      intros n H2.
      simpl in *.
      rewrite <- H2; exact IHl1.
Qed.

 *)


Require Import Types.
Require Import Axioms.
Require Import Basics.
Require Import SetCtx.

(* Define new ModuleType for id and ty, for later using them as key-value types of the
   Key-Value Set. *)

Module Type ModuleId <: ModuleType.

  Definition T := id.

End ModuleId.

Module Type ModuleTy <: ModuleType.

  Definition T := ty.

End ModuleTy.

(* Now, here is the Declarative Typing using a Key-Value Set as the Context. *)

Module Type DeclarativeTyping
    ( M : SetCtx.AbelianMonoid )
    ( mid : ModuleId )
    ( mty : ModuleTy )
    ( kvs : SetCtx.KeyValueSet M mid mty ).

Import kvs.

(* Context *)
Notation "'Ø'" := (empty).
Notation "G '∷' x T" := (append G x T) (at level 29, left associativity).
Notation "G1 '∪' G2" := (M.mult G1 G2) (at level 40, left associativity).

(* Context Split (see Figure 1-4) *)
Reserved Notation "G '≜' G1 '∘' G2" (at level 80).

Inductive split' : T -> T -> T -> Prop :=
  | M_Empty : empty ≜ empty ∘ empty
  | M_Un : forall G G1 G2 x P,
      G ≜ G1 ∘ G2 -> (append G x (P qun)) ≜ (append G1 x (P qun)) ∘ (append G2 x (P qun))
  | M_Lin1 : forall G G1 G2 x P,
      G ≜ G1 ∘ G2 -> (append G x (P qlin)) ≜ (append G1 x (P qlin)) ∘ G2
  | M_Lin2 : forall G G1 G2 x P,
      G ≜ G1 ∘ G2 -> (append G x (P qlin)) ≜ G1 ∘ (append G2 x (P qlin))

where "G '≜' G1 '∘' G2" := (split' G G1 G2).

Parameter unr : T -> T.
Parameter split_id_l : forall G, G ≜ (unr G) ∘ G.
Parameter split_id_r : forall G, G ≜ G ∘ (unr G).
Parameter unr_members : forall G x P Q, contains (unr G) x (P Q) -> Q = qun.

Lemma split_comm : forall G G1 G2, G ≜ G1 ∘ G2 -> G ≜ G2 ∘ G1.
Proof. Admitted.

Lemma split_contains : forall G G1 G2 k v,
    G ≜ G1 ∘ G2 ->
    contains G2 k v ->
    contains G k v.
Proof.
  intros. induction H.
  - apply H0.
  - assert (HH : { x = k }+{ x <> k }).
    { apply principium_tertii_exclusi. }
    destruct HH.
    + subst k. admit.
    + inversion H0. subst k0 v0.
Admitted.

Notation "'ctx'" := T.

(* Relations between Quantifiers and Types *)
Reserved Notation "Q1 '<<' Q2" (at level 70).  (* Q1 ⊑ Q2 *)

Inductive q_rel : q -> q -> Prop :=
  | Q_Ref : forall Q, Q << Q
  | Q_Axiom : qlin << qun

where "Q1 '<<' Q2" := (q_rel Q1 Q2).

Lemma q_rel_trans : forall Q Q' Q'', Q << Q' -> Q' << Q'' -> Q << Q''.
Proof.
  induction Q; induction Q'; induction Q''; intros H H';
  try inversion H; try inversion H'; try apply Q_Ref; try apply Q_Axiom.
Qed.

Inductive q_rel' : q -> ty -> Prop :=  (* q(T) *)
  | Q_Rel_Type : forall Q Q' P, Q << Q' -> q_rel' Q (P Q').

Reserved Notation "Q '〔' G '〕'" (at level 30).  (* q(Γ) *)

Inductive q_rel'' : q -> ctx -> Prop :=
  | Q_Rel_Ctx_Empty : forall Q, Q 〔empty〕
  | Q_Rel_Ctx_Update : forall Q G x T,
      q_rel' Q T ->
      Q 〔G〕 ->
      Q 〔append G x T〕

where "Q '〔' G '〕'" := (q_rel'' Q G).

Lemma q_rel''_unr : forall G Q, Q 〔unr G〕.
Proof. Admitted.

Lemma q_rel''_concat_ctx : forall Q G1 G2,
  Q 〔G1〕 ->
  Q 〔G2〕 ->
  Q 〔G1 ∪ G2〕.
Proof. Admitted.

Lemma q_rel''_concat_ctx' : forall G1 G2 Q,
  Q 〔G1 ∪ G2〕 -> Q 〔G1〕 /\ Q 〔G2〕.
Proof. Admitted.

(* Declarative Typing [Figure 1-5] *)
Reserved Notation "G '|-' t '|' T" (at level 60).  (* G ⊢ t : T *)

Inductive ctx_ty : ctx -> tm -> ty -> Prop :=
  | T_Var : forall G1 G2 x T,
      qun 〔G1 ∪ G2〕 ->
      ( (append G1 x T) ∪ G2 ) |- (tmvar x) | T
  | T_Bool : forall G (Q : q) (B : b),
      qun 〔G〕 ->
      G |- (tmbool Q B) | ty_bool Q
  | T_If : forall G G1 G2 t1 t2 t3 Q T,
      G1 |- t1 | ty_bool Q ->
      G2 |- t2 | T ->
      G2 |- t3 | T ->
      G ≜ G1 ∘ G2 ->
      G |- tmif t1 t2 t3 | T
  | T_Pair : forall G G1 G2 t1 t2 T1 T2 Q,
      G1 |- t1 | T1 ->
      G2 |- t2 | T2 ->
      q_rel' Q T1 ->
      q_rel' Q T2 ->
      G ≜ G1 ∘ G2 ->
      G |- tmpair Q t1 t2 | (T1 ** T2) Q
  | T_Split : forall G G1 G2 t1 t2 T1 T2 T x y Q,
      G1 |- t1 | (T1 ** T2) Q ->
      append (append G2 x T1) y T2 |- t2 | T ->
      G ≜ G1 ∘ G2 ->
      G |- tmsplit t1 x y t2 | T
  | T_Abs : forall Q G t2 T1 T2 x,
      Q 〔G〕 ->
      append G x T1 |- t2 | T2 ->
      G |- tmabs Q x T1 t2 | (T1 --> T2) Q
  | T_App : forall G G1 G2 t1 t2 T11 T12 Q,
      G1 |- t1 | (T11 --> T12) Q ->
      G2 |- t2 | T11 ->
      G ≜ G1 ∘ G2 ->
      G |- tmapp t1 t2 | T12

where "G '|-' t '|' T" := (ctx_ty G t T).

Hint Constructors ctx_ty.

(* Three Lemmas *)
Lemma exchange : forall t x1 x2 T1 T2 T G1 G2,
  (append (append G1 x1 T1) x2 T2) ∪ G2 |- t | T ->
  (append (append G1 x2 T2) x1 T1) ∪ G2 |- t | T.
Proof.
  intros.
  assert (H' : (append (append G1 x1 T1) x2 T2) ∪ G2 = (append (append G1 x2 T2) x1 T1) ∪ G2).
    { apply exchange. }
  rewrite <- H'. apply H.
Qed.

Lemma unrestricted_weakening : forall G t x T P,
  G |- t | T ->
  append G x (P qun) |- t | T.
Proof.
  intros. generalize dependent G. generalize dependent T0. induction t; intros; inversion H; subst.
  - rewrite -> append_to_concat. rewrite -> M.assoc. eapply T_Var. apply q_rel''_concat_ctx' in H2.
    inversion H2 as [H2l H2r]. apply q_rel''_concat_ctx; try apply H2l. apply q_rel''_concat_ctx; try apply H2r.
    eapply Q_Rel_Ctx_Update; try apply Q_Rel_Ctx_Empty. apply Q_Rel_Type. apply Q_Ref.
  - apply T_Bool. apply Q_Rel_Ctx_Update; try apply H4. apply Q_Rel_Type. apply Q_Ref.
  - eapply T_If.
    + apply IHt1 in H3. apply H3.
    + apply IHt2 in H5. apply H5.
    + apply IHt3 in H7. apply H7.
    + apply M_Un with (x := x) (P := P) in H8. apply H8.
  - apply T_Pair with (G1 := append G1 x (P qun)) (G2 := append G2 x (P qun)); try apply H6; try apply H8.
    + apply IHt1 in H3. apply H3.
    + apply IHt2 in H4. apply H4.
    + apply M_Un with (x := x) (P := P) in H9. apply H9.
  - eapply T_Split.
    + apply IHt1 in H6. apply H6.
    + assert ( H' : forall G x ti x' ti' x'' ti'', append (append (append G x ti ) x' ti') x'' ti'' =
        G ∪ (append empty x ti) ∪ (append empty x' ti') ∪ (append empty x'' ti'') ).
      { intros. repeat rewrite <- append_to_concat. reflexivity. }
      assert ( weak_set_exchange : forall A B C, A ∪ B ∪ C = A ∪ C ∪ B ).
      { intros. rewrite <- M.id_r. rewrite -> M.exchange. rewrite -> M.id_r. reflexivity. }
      rewrite -> H'. rewrite -> M.exchange. rewrite -> weak_set_exchange. repeat rewrite <- kvs.append_to_concat.
      apply IHt2. apply H7.
    + apply M_Un with (x := x) (P := P) in H8. apply H8.
  - apply T_Abs.
    + rewrite -> append_to_concat. apply q_rel''_concat_ctx; try apply H6. apply Q_Rel_Ctx_Update; try apply Q_Rel_Ctx_Empty.
      apply Q_Rel_Type. destruct q; try apply Q_Axiom. apply Q_Ref.
    + assert ( H' : append (append G x (P qun)) i t = G ∪ (append empty x (P qun)) ∪ (append empty i t) ).
      { repeat rewrite <- append_to_concat. reflexivity. }
      assert ( weak_set_exchange : forall A B C, A ∪ B ∪ C = A ∪ C ∪ B ).
      { intros. rewrite <- M.id_r. rewrite -> M.exchange. rewrite -> M.id_r. reflexivity. }
      rewrite -> H'. rewrite -> weak_set_exchange. repeat rewrite <- append_to_concat. apply IHt. apply H7.
  - eapply T_App.
    + apply IHt1 in H2. apply H2.
    + apply IHt2 in H4. apply H4.
    + apply M_Un with (x := x) (P := P) in H6. apply H6.
Qed.

Lemma unrestricted_contraction : forall G t x1 x2 x3 T P,
  append (append G x2 (P qun) ) x3 (P qun) |- t | T ->
  append G x1 (P qun) |- rpi (rpi t x2 x1) x3 x1 | T.
Proof.
Admitted.

End DeclarativeTyping.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export Setoid_dup2.

Set Implicit Arguments.
Unset Strict Implicit.

(***  COMPOSITION OPERATOR  ***)

Section composition_to_operator''.

Variables (A : Type) (H : A -> A -> Setoid'')
  (Cfun : forall a b c : A, H a b -> H b c -> H a c).

Definition Congl_law'' :=
  forall (a b c : A) (f g : H b c) (h : H a b),
  f =_S'' g -> Cfun h f =_S'' Cfun h g.

Definition Congr_law'' :=
  forall (a b c : A) (f g : H a b) (h : H b c),
  f =_S'' g -> Cfun f h =_S'' Cfun g h.

Definition Cong_law'' :=
  forall (a b c : A) (f f' : H a b) (g g' : H b c),
  f =_S'' f' -> g =_S'' g' -> Cfun f g =_S'' Cfun f' g'.

Hypothesis pcgl : Congl_law''.
Hypothesis pcgr : Congr_law''.

Variable a b c : A.

Definition Build_Comp'' :=
  Build_Map2'' (pcgl (a:=a) (b:=b) (c:=c)) (pcgr (a:=a) (b:=b) (c:=c)).

End composition_to_operator''.

(***  CATEGORY  ***)

Section cat''.

Variables (Ob'' : Type) (Hom'' : Ob'' -> Ob'' -> Setoid'').

Variable
  Op_comp'' : forall a b c : Ob'', Map2'' (Hom'' a b) (Hom'' b c) (Hom'' a c).

Definition Cat_comp'' (a b c : Ob'') (f : Hom'' a b)
  (g : Hom'' b c) := Op_comp'' a b c f g.

Definition Assoc_law'' :=
  forall (a b c d : Ob'') (f : Hom'' a b) (g : Hom'' b c) (h : Hom'' c d),
  Cat_comp'' f (Cat_comp'' g h) =_S'' Cat_comp'' (Cat_comp'' f g) h.

Variable Id'' : forall a : Ob'', Hom'' a a.

Definition Idl_law'' :=
  forall (a b : Ob'') (f : Hom'' a b), Cat_comp'' (Id'' _) f =_S'' f.

Definition Idr_law'' :=
  forall (a b : Ob'') (f : Hom'' b a), f =_S'' Cat_comp'' f (Id'' _).

End cat''.

Structure Category'' : Type :=
  {Ob'' :> Type;
   Hom'' : Ob'' -> Ob'' -> Setoid'';
   Op_comp'' :
    forall a b c : Ob'', Map2'' (Hom'' a b) (Hom'' b c) (Hom'' a c);
   Id'' : forall a : Ob'', Hom'' a a;
   Prf_ass'' : Assoc_law'' Op_comp'';
   Prf_idl'' : Idl_law'' Op_comp'' Id'';
   Prf_idr'' : Idr_law'' Op_comp'' Id''}.

Definition Comp'' (C : Category'') := Cat_comp'' (Op_comp'' (c:=C)).

Infix "o''" := Comp'' (at level 20, right associativity).


(*|
#############################################################################
Why can't Coq infer the that ``0 + n = n`` in this dependently typed program?
#############################################################################

:Link: https://stackoverflow.com/q/35989122
|*)

(*|
Question
********

I'm starting to use Coq and I'd like to define some dependently typed
programs. Consider the following:
|*)

Inductive natlist : nat -> Type :=
| natnil : natlist 0
| natcons : forall k, nat -> natlist k -> natlist (S k).

Fail Fixpoint natappend (n : nat) (l1 : natlist n) (m : nat) (l2 : natlist m) :
  natlist (n + m) :=
  match l1 with
  | natnil => l2
  | natcons _ x rest => natcons (n + m) x (natappend rest l2)
  end. (* .fails *)

(*|
So ``natlist k`` would be a list of ``nat``\ s of length ``k``. The
problem with the definition of concatenation as ``natappend`` is the
following error:
|*)

Fail Fixpoint natappend (n : nat) (l1 : natlist n) (m : nat) (l2 : natlist m) :
  natlist (n + m) :=
  match l1 with
  | natnil => l2
  | natcons _ x rest => natcons (n + m) x (natappend rest l2)
  end. (* .unfold .messages *)

(*|
As you can see it has a problem with the clause:

.. code-block::

    | natnil => l2

because it claims that the type of ``l2`` is ``natlist m`` while the
result type must be ``natlist (n + m) = natlist (0 + m)``.

I know that Coq cannot resolve arbitrary expressions at the type level
to avoid non-terminating computations, but I find strange that even
this simple case isn't handled.
|*)

(*|
Answer (Arthur Azevedo De Amorim)
*********************************

The problem is that you had a type error in your second branch. Here
is a version that works:
|*)

Fixpoint natappend {n m : nat} (l1 : natlist n) (l2 : natlist m) :
  natlist (n + m) :=
  match l1 with
  | natnil => l2
  | natcons n' x rest => natcons (n' + m) x (natappend rest l2)
  end.

(*|
The crucial difference between this version and the original one is
the parameter passed to ``natcons``: here, it is ``n' + m``, whereas
before it was ``n + m``.

This example illustrates very well a general issue with non-locality
of error messages in Coq, in particular when writing dependently typed
programs. Even though Coq complained about the first branch, the
problem was actually in the second branch. Adding annotations in your
``match`` statement, as suggested by @jbapple, can be useful when
trying to diagnose what is going wrong.
|*)

(*|
Answer (jbapple)
****************

You need ``match ... as ... in ... return ...`` to do more
sophisticated type annotations. See `Adam Chlipala's chapter "Library
MoreDep" in his Book "Certified Programming with Dependent Types"
<http://adam.chlipala.net/cpdt/html/MoreDep.html>`__ or `"Chapter 17:
Extended pattern-matching" in the Coq manual
<https://coq.inria.fr/refman/Reference-Manual020.html>`__. Both have
the ``concat`` example you are working on.

You could also just delay the dependent type bit until the end:
|*)

Reset Initial. (* .none *)
Definition natlist n := { x : list nat & n = length x }.

(*|
Then prove that non-dependently-typed ``concat`` preserves length
sums.

----

**A:** I much support @jbapple's definition of ``natlist`` as a
dependent record instead of the original one, however I'd suggest
using
|*)

Reset Initial. (* .none *)
Require Import PeanoNat Bool. (* .none *)
Definition natlist n := { x : list nat & Is_true (n =? length x) }.

(*|
where ``=?`` is the boolean equality on ``nat``, for reasons of proof
irrelevance.

**A:** In general using a ``bool`` makes it easier to prove
injectivity of the first projection, see:
http://stackoverflow.com/questions/35290012/inductive-subset-of-an-inductive-set-in-coq/35300521#35300521

**A:** By the way, I learned about this by reading the ``tuple.v``, a
very good example of a complete sized list library is
http://ssr.msr-inria.inria.fr/~jenkins/current/mathcomp.ssreflect.tuple.html,
I really learned a lot from trying to understand it.
|*)