(** * Types: Type Systems *)

(** Our next major topic is _type systems_ -- static program
    analyses that classify expressions according to the "shapes" of
    their results.  We'll begin with a typed version of the simplest
    imaginable language, to introduce the basic ideas of types and
    typing rules and the fundamental theorems about type systems:
    _type preservation_ and _progress_.  In chapter [Stlc] we'll move
    on to the _simply typed lambda-calculus_, which lives at the core
    of every modern functional programming language (including
    Coq!). *)

Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Arith.Arith.
From PLF Require Import Maps.
From PLF Require Import Imp.
From PLF Require Import Smallstep.

Hint Constructors multi : core.

(* ################################################################# *)
(** * Typed Arithmetic Expressions *)

(** To motivate the discussion of type systems, let's begin as
    usual with a tiny toy language.  We want it to have the potential
    for programs to go wrong because of runtime type errors, so we
    need something a tiny bit more complex than the language of
    constants and addition that we used in chapter [Smallstep]: a
    single kind of data (e.g., numbers) is too simple, but just two
    kinds (numbers and booleans) gives us enough material to tell an
    interesting story.

    The language definition is completely routine. *)

(* ================================================================= *)
(** ** Syntax *)

(** Here is the syntax, informally:

    t ::= tru
        | fls
        | test t then t else t
        | zro
        | scc t
        | prd t
        | iszro t

    And here it is formally: *)

Inductive tm : Type :=
  | tru : tm
  | fls : tm
  | test : tm -> tm -> tm -> tm
  | zro : tm
  | scc : tm -> tm
  | prd : tm -> tm
  | iszro : tm -> tm.

(** (Since it is so simple, we will not bother introducing custom
    concrete syntax for this language.) *)

(** _Values_ are [tru], [fls], and numeric values... *)

Inductive bvalue : tm -> Prop :=
  | bv_tru : bvalue tru
  | bv_fls : bvalue fls.

Inductive nvalue : tm -> Prop :=
  | nv_zro : nvalue zro
  | nv_scc : forall t, nvalue t -> nvalue (scc t).

Definition value (t : tm) := bvalue t \/ nvalue t.

Hint Constructors bvalue nvalue : core.
Hint Unfold value : core.

(* ================================================================= *)
(** ** Operational Semantics *)

(** Here is the single-step relation, first informally...

                   -------------------------------                  (ST_TestTru)
                   test tru then t1 else t2 --> t1

                   -------------------------------                  (ST_TestFls)
                   test fls then t1 else t2 --> t2

                               t1 --> t1'
            ----------------------------------------------------       (ST_Test)
            test t1 then t2 else t3 --> test t1' then t2 else t3

                             t1 --> t1'
                         ------------------                             (ST_Scc)
                         scc t1 --> scc t1'

                           ---------------                           (ST_PrdZro)
                           prd zro --> zro

                         numeric value v
                        -------------------                          (ST_PrdScc)
                        prd (scc v) --> v

                              t1 --> t1'
                         ------------------                             (ST_Prd)
                         prd t1 --> prd t1'

                          -----------------                        (ST_IszroZro)
                          iszro zro --> tru

                         numeric value v
                      ---------------------                       (ST_IszroScc)
                      iszro (scc v) --> fls

                            t1 --> t1'
                       ----------------------                         (ST_Iszro)
                       iszro t1 --> iszro t1'
*)

(** ... and then formally: *)

Reserved Notation "t '-->' t'" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_TestTru : forall t1 t2,
      (test tru t1 t2) --> t1
  | ST_TestFls : forall t1 t2,
      (test fls t1 t2) --> t2
  | ST_Test : forall t1 t1' t2 t3,
      t1 --> t1' ->
      (test t1 t2 t3) --> (test t1' t2 t3)
  | ST_Scc : forall t1 t1',
      t1 --> t1' ->
      (scc t1) --> (scc t1')
  | ST_PrdZro :
      (prd zro) --> zro
  | ST_PrdScc : forall v,
      nvalue v ->
      (prd (scc v)) --> v
  | ST_Prd : forall t1 t1',
      t1 --> t1' ->
      (prd t1) --> (prd t1')
  | ST_IszroZro :
      (iszro zro) --> tru
  | ST_IszroScc : forall v,
       nvalue v ->
      (iszro (scc v)) --> fls
  | ST_Iszro : forall t1 t1',
      t1 --> t1' ->
      (iszro t1) --> (iszro t1')

where "t '-->' t'" := (step t t').

Hint Constructors step : core.

(** Notice that the [step] relation doesn't care about whether the
    expression being stepped makes global sense -- it just checks that
    the operation in the _next_ reduction step is being applied to the
    right kinds of operands.  For example, the term [scc tru] cannot
    take a step, but the almost as obviously nonsensical term

       scc (test tru then tru else tru)

    can take a step (once, before becoming stuck). *)

(* ================================================================= *)
(** ** Normal Forms and Values *)

(** The first interesting thing to notice about this [step] relation
    is that the strong progress theorem from the [Smallstep]
    chapter fails here.  That is, there are terms that are normal
    forms (they can't take a step) but not values (they are not
    included in our definition of possible "results of reduction").
    Such terms are said to be _stuck_. *)

Notation step_normal_form := (normal_form step).

Definition stuck (t : tm) : Prop :=
  step_normal_form t /\ ~ value t.

Hint Unfold stuck : core.

(** **** Exercise: 2 stars, standard (some_term_is_stuck) *)
Example some_term_is_stuck :
  exists t, stuck t.
Proof.
  exists (scc tru). unfold stuck. split.
  - unfold step_normal_form. intros [H1 H2]. inversion H2. inversion H0.
  - intros contra. inversion contra. inversion H. inversion H. inversion H1.
Qed.
(** [] *)

(** However, although values and normal forms are _not_ the same in
    this language, the set of values is a subset of the set of normal
    forms.  This is important because it shows we did not accidentally
    define things so that some value could still take a step. *)

(** **** Exercise: 3 stars, standard (value_is_nf) *)
Lemma nv_impossbile : forall v,
  nvalue v -> ~(exists t, v --> t).
Proof.
  intros v H. induction H; intros [t' H'].
  - inversion H'.
  - apply IHnvalue. inversion H'. exists t1'. assumption.
Qed.

Lemma value_is_nf : forall t,
  value t -> step_normal_form t.
Proof.
  intros t H. unfold step_normal_form. intros [t' H']. inversion H.
  - inversion H0; subst; inversion H'.
  - induction H0.
    * inversion H'.
    * assert (Hv: nvalue (scc t)). constructor. assumption.
      apply nv_impossbile in Hv. apply Hv. exists t'. assumption.
Qed.

(** (Hint: You will reach a point in this proof where you need to
    use an induction to reason about a term that is known to be a
    numeric value.  This induction can be performed either over the
    term itself or over the evidence that it is a numeric value.  The
    proof goes through in either case, but you will find that one way
    is quite a bit shorter than the other.  For the sake of the
    exercise, try to complete the proof both ways.)

    [] *)

(** **** Exercise: 3 stars, standard, optional (step_deterministic)

    Use [value_is_nf] to show that the [step] relation is also
    deterministic. *)

Theorem step_deterministic:
  deterministic step.
Proof with eauto.
  unfold deterministic. intros x y1 y2 Hy1 Hy2. generalize dependent y2.
  induction Hy1; intros y2 Hy2.
  - inversion Hy2; subst. reflexivity. inversion H3.
  - inversion Hy2; subst. reflexivity. inversion H3.
  - inversion Hy2; subst. inversion Hy1. inversion Hy1. apply IHHy1 in H3. rewrite H3. reflexivity.
  - inversion Hy2. subst. apply IHHy1 in H0. rewrite H0. reflexivity.
  - inversion Hy2; subst. reflexivity. inversion H0.
  - inversion Hy2; subst. reflexivity.
    assert (Hv: nvalue (scc v)). constructor. assumption. apply nv_impossbile in Hv.
    exfalso. apply Hv. exists t1'. assumption.
  - inversion Hy2; subst. inversion Hy1.
    assert (Hy: nvalue (scc y2)). constructor. assumption.
    apply nv_impossbile in Hy. exfalso. apply Hy. exists t1'. assumption.
    apply IHHy1 in H0. rewrite H0. reflexivity.
  - inversion Hy2. reflexivity. inversion H0.
  - inversion Hy2; subst. reflexivity.
    assert (Hv : nvalue (scc v)). constructor. assumption.
    apply nv_impossbile in Hv. exfalso. apply Hv. exists t1'. assumption.
  - inversion Hy2; subst. inversion Hy1.
    assert (Hv : nvalue (scc v)). constructor. assumption.
    apply nv_impossbile in Hv. exfalso. apply Hv. exists t1'. assumption.
    apply IHHy1 in H0. rewrite H0. reflexivity.
Qed.
(** [] *)

(* ================================================================= *)
(** ** Typing *)

(** The next critical observation is that, although this
    language has stuck terms, they are always nonsensical, mixing
    booleans and numbers in a way that we don't even _want_ to have a
    meaning.  We can easily exclude such ill-typed terms by defining a
    _typing relation_ that relates terms to the types (either numeric
    or boolean) of their final results.  *)

Inductive ty : Type :=
  | Bool : ty
  | Nat : ty.

(** In informal notation, the typing relation is often written
    [|- t \in T] and pronounced "[t] has type [T]."  The [|-] symbol
    is called a "turnstile."  Below, we're going to see richer typing
    relations where one or more additional "context" arguments are
    written to the left of the turnstile.  For the moment, the context
    is always empty.

                           ---------------                     (T_Tru)
                           |- tru \in Bool

                          ---------------                      (T_Fls)
                          |- fls \in Bool

             |- t1 \in Bool    |- t2 \in T    |- t3 \in T
             --------------------------------------------     (T_Test)
                    |- test t1 then t2 else t3 \in T

                             --------------                    (T_Zro)
                             |- zro \in Nat

                            |- t1 \in Nat
                          -----------------                    (T_Scc)
                          |- scc t1 \in Nat

                            |- t1 \in Nat
                          -----------------                    (T_Prd)
                          |- prd t1 \in Nat

                            |- t1 \in Nat
                        --------------------                 (T_IsZro)
                        |- iszro t1 \in Bool
*)

Reserved Notation "'|-' t '\in' T" (at level 40).

Inductive has_type : tm -> ty -> Prop :=
  | T_Tru :
       |- tru \in Bool
  | T_Fls :
       |- fls \in Bool
  | T_Test : forall t1 t2 t3 T,
       |- t1 \in Bool ->
       |- t2 \in T ->
       |- t3 \in T ->
       |- test t1 t2 t3 \in T
  | T_Zro :
       |- zro \in Nat
  | T_Scc : forall t1,
       |- t1 \in Nat ->
       |- scc t1 \in Nat
  | T_Prd : forall t1,
       |- t1 \in Nat ->
       |- prd t1 \in Nat
  | T_Iszro : forall t1,
       |- t1 \in Nat ->
       |- iszro t1 \in Bool

where "'|-' t '\in' T" := (has_type t T).

Hint Constructors has_type : core.

Example has_type_1 :
  |- test fls zro (scc zro) \in Nat.
Proof.
  apply T_Test.
  - apply T_Fls.
  - apply T_Zro.
  - apply T_Scc. apply T_Zro.
Qed.

(** (Since we've included all the constructors of the typing relation
    in the hint database, the [auto] tactic can actually find this
    proof automatically.) *)

(** It's important to realize that the typing relation is a
    _conservative_ (or _static_) approximation: it does not consider
    what happens when the term is reduced -- in particular, it does
    not calculate the type of its normal form. *)

Example has_type_not :
  ~ ( |- test fls zro tru \in Bool ).
Proof.
  intros Contra. solve_by_inverts 2.  Qed.

(** **** Exercise: 1 star, standard, optional (scc_hastype_nat__hastype_nat) *)
Example scc_hastype_nat__hastype_nat : forall t,
  |- scc t \in Nat ->
  |- t \in Nat.
Proof.
  intros t H. inversion H. assumption.
Qed.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Canonical forms *)

(** The following two lemmas capture the fundamental property that the
    definitions of boolean and numeric values agree with the typing
    relation. *)

Lemma bool_canonical : forall t,
  |- t \in Bool -> value t -> bvalue t.
Proof.
  intros t HT [Hb | Hn].
  - assumption.
  - destruct Hn as [ | Hs].
    + inversion HT.
    + inversion HT.
Qed.

Lemma nat_canonical : forall t,
  |- t \in Nat -> value t -> nvalue t.
Proof.
  intros t HT [Hb | Hn].
  - inversion Hb; subst; inversion HT.
  - assumption.
Qed.

(* ================================================================= *)
(** ** Progress *)

(** The typing relation enjoys two critical properties.  The first is
    that well-typed normal forms are not stuck -- or conversely, if a
    term is well typed, then either it is a value or it can take at
    least one step.  We call this _progress_. *)

(** **** Exercise: 3 stars, standard (finish_progress) *)
(* Lemma prd_v : forall t,
  nvalue t -> nvalue (prd t).
Proof.
  intros t H. apply nat_canonical.
  - constructor. induction H.
    * constructor.
    * constructor. assumption.
  - right. induction H.
    * constructor.

  inversion H.

  induction H.
  -  *)

Theorem progress : forall t T,
  |- t \in T ->
  value t \/ exists t', t --> t'.

(** Complete the formal proof of the [progress] property.  (Make sure
    you understand the parts we've given of the informal proof in the
    following exercise before starting -- this will save you a lot of
    time.) *)
Proof.
  intros t T HT.
  induction HT; auto.
  (* The cases that were obviously values, like T_Tru and
     T_Fls, are eliminated immediately by auto *)
  - (* T_Test *)
    right. destruct IHHT1.
    + (* t1 is a value *)
    apply (bool_canonical t1 HT1) in H.
    destruct H.
      * exists t2. auto.
      * exists t3. auto.
    + (* t1 can take a step *)
      destruct H as [t1' H1].
      exists (test t1' t2 t3). auto.
  - destruct IHHT as [H1 | H2].
    * left. right. constructor. apply nat_canonical; assumption.
    * right. destruct H2 as [t' H]. exists (scc t'). constructor. assumption.
  - destruct IHHT as [H | H].
    * induction H.
      + inversion H; subst; inversion HT.
      + induction H.
        ++ right. exists zro. constructor.
        ++ right. exists t. constructor. assumption.
    * destruct H as [t' H]. right. exists (prd t'). constructor. assumption.
  - destruct IHHT as [H | H].
    * right. inversion H; inversion H0; subst; try (inversion HT).
      + exists tru. constructor.
      + exists fls. constructor. assumption.
    * destruct H as [t' H]. right. exists (iszro t'). constructor. assumption.
Qed.

(** [] *)

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

    Complete the corresponding informal proof: *)

(** _Theorem_: If [|- t \in T], then either [t] is a value or else
    [t --> t'] for some [t']. *)

(** _Proof_: By induction on a derivation of [|- t \in T].

    - If the last rule in the derivation is [T_Test], then [t = test t1
      then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T] and [|- t3
      \in T].  By the IH, either [t1] is a value or else [t1] can step
      to some [t1'].

      - If [t1] is a value, then by the canonical forms lemmas
        and the fact that [|- t1 \in Bool] we have that [t1]
        is a [bvalue] -- i.e., it is either [tru] or [fls].
        If [t1 = tru], then [t] steps to [t2] by [ST_TestTru],
        while if [t1 = fls], then [t] steps to [t3] by
        [ST_TestFls].  Either way, [t] can step, which is what
        we wanted to show.

      - If [t1] itself can take a step, then, by [ST_Test], so can
        [t].

    - (* FILL IN HERE *)
 *)

(* Do not modify the following line: *)
Definition manual_grade_for_finish_progress_informal : option (nat*string) := None.
(** [] *)

(** This theorem is more interesting than the strong progress theorem
    that we saw in the [Smallstep] chapter, where _all_ normal forms
    were values.  Here a term can be stuck, but only if it is ill
    typed. *)

(* ================================================================= *)
(** ** Type Preservation *)

(** The second critical property of typing is that, when a well-typed
    term takes a step, the result is a well-typed term (of the same type). *)

(** **** Exercise: 2 stars, standard (finish_preservation) *)
Theorem preservation : forall t t' T,
  |- t \in T ->
  t --> t' ->
  |- t' \in T.

(** Complete the formal proof of the [preservation] property.  (Again,
    make sure you understand the informal proof fragment in the
    following exercise first.) *)

Proof.
  intros t t' T HT HE.
  generalize dependent t'.
  induction HT;
         (* every case needs to introduce a couple of things *)
         intros t' HE;
         (* and we can deal with several impossible
            cases all at once *)
         try solve_by_invert.
    - (* T_Test *) inversion HE; subst; clear HE.
      + (* ST_TESTTru *) assumption.
      + (* ST_TestFls *) assumption.
      + (* ST_Test *) apply T_Test; try assumption.
        apply IHHT1; assumption.
    - inversion HE; subst. apply T_Scc. apply IHHT in H0. assumption.
    - inversion HE; subst.
      + constructor.
      + inversion HT. subst. assumption.
      + constructor. apply IHHT in H0. assumption.
    - inversion HE; subst; try constructor.
      apply IHHT in H0. assumption.
Qed.
(** [] *)

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

    Complete the following informal proof: *)

(** _Theorem_: If [|- t \in T] and [t --> t'], then [|- t' \in T]. *)

(** _Proof_: By induction on a derivation of [|- t \in T].

    - If the last rule in the derivation is [T_Test], then [t = test t1
      then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T] and [|- t3
      \in T].

      Inspecting the rules for the small-step reduction relation and
      remembering that [t] has the form [test ...], we see that the
      only ones that could have been used to prove [t --> t'] are
      [ST_TestTru], [ST_TestFls], or [ST_Test].

      - If the last rule was [ST_TestTru], then [t' = t2].  But we
        know that [|- t2 \in T], so we are done.

      - If the last rule was [ST_TestFls], then [t' = t3].  But we
        know that [|- t3 \in T], so we are done.

      - If the last rule was [ST_Test], then [t' = test t1' then t2
        else t3], where [t1 --> t1'].  We know [|- t1 \in Bool] so,
        by the IH, [|- t1' \in Bool].  The [T_Test] rule then gives us
        [|- test t1' then t2 else t3 \in T], as required.

    - (* FILL IN HERE  *)
*)
(* Do not modify the following line: *)
Definition manual_grade_for_finish_preservation_informal : option (nat*string) := None.
(** [] *)

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

    Now prove the same property again by induction on the
    _evaluation_ derivation instead of on the typing derivation.
    Begin by carefully reading and thinking about the first few
    lines of the above proofs to make sure you understand what
    each one is doing.  The set-up for this proof is similar, but
    not exactly the same. *)

Theorem preservation' : forall t t' T,
  |- t \in T ->
  t --> t' ->
  |- t' \in T.
Proof with eauto.
  intros t t' T HT HE. generalize dependent HT. generalize dependent T.
  induction HE; intros T HT; inversion HT; subst; auto.
  - inversion H1. assumption.
Qed.
(** [] *)

(** The preservation theorem is often called _subject reduction_,
    because it tells us what happens when the "subject" of the typing
    relation is reduced.  This terminology comes from thinking of
    typing statements as sentences, where the term is the subject and
    the type is the predicate. *)

(* ================================================================= *)
(** ** Type Soundness *)

(** Putting progress and preservation together, we see that a
    well-typed term can never reach a stuck state.  *)

Definition multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

Corollary soundness : forall t t' T,
  |- t \in T ->
  t -->* t' ->
  ~(stuck t').
Proof.
  intros t t' T HT P. induction P; intros [R S].
  - apply progress in HT. destruct HT; auto.
  - apply IHP.
    + apply preservation with (t := x); auto.
    + unfold stuck. split; auto.
Qed.

(* ================================================================= *)
(** ** Additional Exercises *)

(** **** Exercise: 2 stars, standard, especially useful (subject_expansion)

    Having seen the subject reduction property, one might
    wonder whether the opposity property -- subject _expansion_ --
    also holds.  That is, is it always the case that, if [t --> t']
    and [|- t' \in T], then [|- t \in T]?  If so, prove it.  If
    not, give a counter-example.  (You do not need to prove your
    counter-example in Coq, but feel free to do so.)

    ANSWER:
    t = test fls zro fls
    (test fls zro fls) --> (fls)
    t' = fls
    |- t' \in Bool
    but ~(|- t \in Bool)
*)

(* Do not modify the following line: *)
Definition manual_grade_for_subject_expansion : option (nat*string) := None.
(** [] *)

(** **** Exercise: 2 stars, standard (variation1)

    Suppose that we add this new rule to the typing relation:

      | T_SccBool : forall t,
           |- t \in Bool ->
           |- scc t \in Bool

   Which of the following properties remain true in the presence of
   this rule?  For each one, write either "remains true" or
   else "becomes false." If a property becomes false, give a
   counterexample.
      - Determinism of [step]
            remains true, as it did not modify the definition of step.
      - Progress
            becomes false. (scc tru) not a value & cannot take any steps
      - Preservation
            remains true.
*)
(* Do not modify the following line: *)
Definition manual_grade_for_variation1 : option (nat*string) := None.
(** [] *)

(** **** Exercise: 2 stars, standard (variation2)

    Suppose, instead, that we add this new rule to the [step] relation:

      | ST_Funny1 : forall t2 t3,
           (test tru t2 t3) --> t3

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.
      - Determinism
          (test tru t2 t3) --> t2 By ST_TestTru
          (test tru t2 t3) --> t3 By ST_Funny1

*)
(* Do not modify the following line: *)
Definition manual_grade_for_variation2 : option (nat*string) := None.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (variation3)

    Suppose instead that we add this rule:

      | ST_Funny2 : forall t1 t2 t2' t3,
           t2 --> t2' ->
           (test t1 t2 t3) --> (test t1 t2' t3)

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.
        - Determinisim
          (test (iszro zro) (iszro zro) t3) --> (test tru (iszro zro) t3) By ST_Test
          (test (iszro zro) (iszro zro) t3) --> (test (iszro zro) tru t3) By ST_Funny2
*)
(** [] *)

(** **** Exercise: 2 stars, standard, optional (variation4)

    Suppose instead that we add this rule:

      | ST_Funny3 :
          (prd fls) --> (prd (prd fls))

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.
    No
*)
(** [] *)

(** **** Exercise: 2 stars, standard, optional (variation5)

    Suppose instead that we add this rule:

      | T_Funny4 :
            |- zro \in Bool

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.
    - progress
        (test zro tru tru) is not a value & cannot take any steps
    - preservation
        !remains true.
        as there will be only one new case
        (test zro t1 t2) : T, but it cannot take any steps... 无法构成第二个assumption
*)
(** [] *)

(** **** Exercise: 2 stars, standard, optional (variation6)

    Suppose instead that we add this rule:

      | T_Funny5 :
            |- prd zro \in Bool

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.
   - progress
    !remains true
      (test (prd zro) tru tru) is not a value but .. --> (test zro tru tru)
   - preservation
      (test (prd zro) tru tru) : Bool
      (test (prd zro) tru tru) --> (test zro tru tru)
      (test zro tru tru) is ill-typed.
*)
(** [] *)

(** **** Exercise: 3 stars, standard, optional (more_variations)

    Make up some exercises of your own along the same lines as
    the ones above.  Try to find ways of selectively breaking
    properties -- i.e., ways of changing the definitions that
    break just one of the properties and leave the others alone.
*)
(* 懒得写了。。。

    [] *)

(** **** Exercise: 1 star, standard (remove_prdzro)

    The reduction rule [ST_PrdZro] is a bit counter-intuitive: we
    might feel that it makes more sense for the predecessor of [zro] to
    be undefined, rather than being defined to be [zro].  Can we
    achieve this simply by removing the rule from the definition of
    [step]?  Would doing so create any problems elsewhere?

    progress becomes false.
    (test (iszro (prd zro)) tru tru): Bool
    but it's not a value & cannot take any steps

*)
(* Do not modify the following line: *)
Definition manual_grade_for_remove_predzro : option (nat*string) := None.
(** [] *)

(** **** Exercise: 4 stars, advanced (prog_pres_bigstep)

    Suppose our evaluation relation is defined in the big-step style.
    State appropriate analogs of the progress and preservation
    properties. (You do not need to prove them.)

    Can you see any limitations of either of your properties?  Do they
    allow for nonterminating programs?  Why might we prefer the
    small-step semantics for stating preservation and progress?

*)
(* Do not modify the following line: *)
Definition manual_grade_for_prog_pres_bigstep : option (nat*string) := None.
(** [] *)

(* 2020-12-03 14:13 *)


From LF Require Export Lists.

Inductive boollist : Type :=
  | bool_nil
  | bool_cons (b : bool) (l : boollist).

Inductive list (X:Type) : Type :=
  | nil
  | cons (x : X) (l : list X).

Check list : Type -> Type.

Check (nil nat) : list nat.
Check (cons nat 3 (nil nat)) : list nat.
Check nil : forall X : Type, list X.
Check cons.
Check (cons nat 2 (cons nat 1 (nil nat))).

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

Example test_repeat1 :
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity. Qed.

Example test_repeat2 :
  repeat bool false 1 = cons bool false (nil bool).
Proof. reflexivity. Qed.

Module MumbleGrumble.
Inductive mumble : Type :=
  | a
  | b (x : mumble) (y : nat)
  | c.
Inductive grumble (X:Type) : Type :=
  | d (m : mumble)
  | e (x : X).

End MumbleGrumble.
Fixpoint repeat' X x count : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat' X x count')
  end.
Check repeat'
  : forall X : Type, X -> nat -> list X.
Check repeat
  : forall X : Type, X -> nat -> list X.

Fixpoint repeat'' X x count : list X :=
  match count with
  | 0 => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

Definition list123 :=
  cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

Definition list123' :=
  cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil
  | S count' => cons x (repeat''' x count')
  end.

Inductive list' {X:Type} : Type :=
  | nil'
  | cons' (x : X) (l : list').

Fixpoint app {X : Type} (l1 l2 : list X)
             : (list X) :=
  match l1 with
  | nil => l2
  | cons h t => cons h (app t l2)
  end.
Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.
Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.
Print length.

Definition mynil : list nat := nil.

Check @nil : forall X : Type, list X.
Definition mynil' := @nil nat.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).
Check [1; 2; 3].
Definition list123''' := [1; 2; 3].

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
  intros. induction l.
  - simpl. reflexivity.
  - simpl. rewrite->IHl. reflexivity.
Qed.
Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros. induction l.
  - simpl. reflexivity.
  - simpl. rewrite -> IHl. reflexivity.
Qed.
Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros. induction l1.
  - simpl. reflexivity.
  - simpl. rewrite->IHl1. reflexivity.
Qed.
Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros. induction l1.
  - simpl. rewrite->app_nil_r. reflexivity.
  - simpl. rewrite->IHl1. rewrite<-app_assoc. reflexivity.
Qed.
Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros. induction l as [].
  - simpl. reflexivity.
  - simpl. rewrite -> rev_app_distr. simpl.
    rewrite -> IHl. reflexivity.
Qed.

Inductive prod (X Y : Type) : Type :=
| pair (x : X) (y : Y).
Print prod.
Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.
Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

Check @combine.

Compute (combine [1;2] [false;false;true;true]).

Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y) :=
  match l with
  | [] => ([], [])
  | (x, y) :: tl => match split tl with
                    | (lx, ly) => (x :: lx,y :: ly)
                    end
   end.
Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof.
(* 请在此处解答 *)
  simpl. reflexivity.
Qed.

Module OptionPlayground.
Inductive option (X:Type) : Type :=
  | Some (x : X)
  | None.
Arguments Some {X} _.
Arguments None {X}.
End OptionPlayground.

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | [] => None
  | a :: l' => if n = O then Some a else nth_error l' (pred n)
  end.

Definition hd_error {X : Type} (l : list X) : option X :=
  match l with
  | [] => None
  | hd :: tl => Some hd
  end.

Check @hd_error.

Definition doit3times {X:Type} (f:X->X) (n:X) : X :=
  f (f (f n)).

Fixpoint filter {X:Type} (test: X->bool) (l:list X)
                : (list X) :=
  match l with
  | [] => []
  | h :: t => if test h then h :: (filter test t)
                        else filter test t
  end.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  (length l) = 1.
Example test_filter2:
    filter length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof.
(* 请在此处解答 *)
  simpl. reflexivity.
Qed.

Definition countoddmembers' (l:list nat) : nat :=
  length (filter oddb l).

Definition filter_even_gt7 (l : list nat) : list nat:=
  filter (fun n => if leb 7 n then true else false) (filter evenb l).

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
Proof.
  unfold filter_even_gt7. simpl. reflexivity.
Qed.
Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
Proof.
  unfold filter_even_gt7. simpl. reflexivity.
Qed.

Definition partition {X : Type}
                     (test : X -> bool)
                     (l : list X)
                   : list X * list X :=
  (filter test l, filter (fun x => negb (test x)) l).
Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. unfold partition. simpl. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. unfold partition. simpl. reflexivity. Qed.

Fixpoint map {X Y: Type} (f:X->Y) (l:list X) : (list Y) :=
  match l with
  | [] => []
  | h :: t => (f h) :: (map f t)
  end.

Theorem map_app : forall (X Y : Type) (f : X -> Y) (l1 l2 : list X),
  map f (l1 ++ l2) = map f l1 ++ map f l2.
Proof.
  intros. induction l1.
  - simpl. reflexivity.
  - simpl. rewrite IHl1. reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros. induction l.
  + simpl. reflexivity.
  + simpl. rewrite -> map_app. simpl.
     rewrite -> IHl. reflexivity.
Qed.

Fixpoint flat_map {X Y: Type} (f: X -> list Y) (l: list X)
                   : (list Y) :=
  match l with
  | [] => []
  | h :: t => f h ++ (flat_map f t)
  end.
Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof.
  unfold flat_map. simpl. reflexivity.
Qed.

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X)
                      : option Y :=
  match xo with
    | None => None
    | Some x => Some (f x)
  end.

Fixpoint filter' (X:Type) (test: X->bool) (l:list X)
                : (list X) :=
  match l with
  | [] => nil
  | h :: t => if test h then h :: (filter' X test t)
                        else filter' X test t
  end.

Fixpoint map' (X Y: Type) (f:X->Y) (l:list X) : (list Y) :=
  match l with
  | [] => []
  | h :: t => (f h) :: (map' X Y f t)
  end.

Fixpoint fold {X Y: Type} (f: X->Y->Y) (l: list X) (b: Y)
                         : Y :=
  match l with
  | nil => b
  | h :: t => f h (fold f t b)
  end.

Check (fold andb).

Definition constfun {X: Type} (x: X) : nat->X :=
  fun (k:nat) => x.
Definition ftrue := constfun true.

Module Exercises.

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.
Example test_fold_length1 : fold_length [4;7;0] = 3.
Proof. reflexivity. Qed.

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
  intros.
  induction l.
  + simpl. unfold fold_length. simpl.
    reflexivity.
  + simpl. unfold fold_length. simpl.
    rewrite <- IHl.  unfold fold_length.
    reflexivity.
Qed.

Definition fold_map {X Y: Type} (f: X -> Y) (l: list X) : list Y :=
  fold (fun m n => f m :: n) l [].

Theorem fold_map_correct : forall X Y (f: X -> Y) (l : list X),
  fold_map f l = map f l.
Proof.
  intros. induction l.
  + simpl. unfold fold_map. simpl. reflexivity.
  + simpl. unfold fold_map. simpl. rewrite <- IHl.
    unfold fold_map. reflexivity.
Qed.

Definition prod_curry {X Y Z : Type}
  (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z
  := f (fst p) (snd p).

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type)
                        (f : X -> Y -> Z)
                        x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
  intros. unfold prod_curry. unfold prod_uncurry.
  simpl. reflexivity.
Qed.
Theorem curry_uncurry : forall (X Y Z : Type)
                        (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
  intros. unfold prod_uncurry. unfold prod_curry.
  destruct p. simpl. reflexivity.
Qed.

Fixpoint nth_error {X : Type} (l : list X) (n : nat) : option X :=
     match l with
     | [] => None
     | a :: l' => if n = O then Some a else nth_error l' (pred n)
     end.

Theorem eqb_l_0 : forall n,
   ((n = 0) = true) -> n = 0.
Proof.
  intros n. destruct n as [| n'] eqn:E.
  - (* n = 0 *)
    intros H. reflexivity.
  - (* n = S n' *)
    simpl. intros H. discriminate H.
Qed.

Lemma ntherror_len : forall X l n, length l = n -> @nth_error X l n = None.
Proof.
  intros. generalize dependent n. induction l.
  - simpl. intros. reflexivity.
  - intros. induction n.
    + simpl in H. discriminate H.
    + simpl. apply IHl. simpl in H. injection H as Hsm. apply Hsm.
Qed.

Module Church.
Definition cnat := forall X : Type, (X -> X) -> X -> X.

Definition one : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f x.

Definition two : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f x).

Definition zero : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => x.

Definition three : cnat := @doit3times.

Definition succ (n : cnat) : cnat
  := fun (X : Type) (f : X -> X) (x : X) => f (n X f x).

Example succ_1 : succ zero = one.
Proof.
  reflexivity.
Qed.
Example succ_2 : succ one = two.
Proof.
  reflexivity.
Qed.
Example succ_3 : succ two = three.
Proof.
  reflexivity.
Qed.

Definition plus (n m : cnat) : cnat
  := fun (X : Type) (f : X -> X) (x : X) => m X f (n X f x).
Example plus_1 : plus zero one = one.
Proof.
  reflexivity.
Qed.
Example plus_2 : plus two three = plus three two.
Proof.
  reflexivity.
Qed.
Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
Proof.
  reflexivity.
Qed.

Definition mult (n m : cnat) : cnat
  := fun (X : Type) (f : X -> X) (x : X) => m X (n X f) x.
Example mult_1 : mult one one = one.
Proof.
  reflexivity.
Qed.
Example mult_2 : mult zero (plus three three) = zero.
Proof.
  reflexivity.
Qed.
Example mult_3 : mult two three = plus three three.
Proof.
  reflexivity.
Qed.

Definition exp (n m : cnat) : cnat
  := fun (X : Type) => m (X -> X) (n X).

Example exp_1 : exp two two = plus two two.
Proof.
  reflexivity.
Qed.
Example exp_2 : exp three zero = one.
Proof.
  reflexivity.
Qed.
Example exp_3 : exp three two = plus (mult two (mult two two)) one.
Proof.
  reflexivity.
Qed.

End Church.
End Exercises.


From Undecidability.L Require Import L.
From Undecidability.L.Tactics Require Import LTactics GenEncode.
From Undecidability.L.Datatypes Require Import Lists LNat LProd.
From Complexity.Libs Require Import PSLCompat CookPrelim.MorePrelim Pigeonhole.
From Complexity.NP.Clique Require Import Clique UGraph.
From Complexity.NP.SAT Require Import SAT kSAT.

(** * Reduction from k-SAT to Clique *)

Implicit Types (a : assgn) (N : cnf) (C : clause) (l :literal).

Definition cnfGetClause N n := nth_error N n.
Definition clauseGetLiteral C n := nth_error C n.
Definition cnfGetLiteral N n1 n2 :=
  do C <- cnfGetClause N n1;
  clauseGetLiteral C n2.

Section fixSAT.
  Variable (k : nat).
  Variable (Hkgt : k > 0).
  Variable (N : cnf).
  Variable (Hkcnf : kCNF k N).

  (** We start by defining the graph *)

  Definition Ncl := |N|.

  Definition literalsConflict l1 l2 :=
    let (b1, v1) := l1 in
    let (b2, v2) := l2 in
    v1 = v2 /\ b1 <> b2.

  Definition opt_literalsConflict o1 o2 :=
    match o1, o2 with
    | Some l1, Some l2 => literalsConflict l1 l2
    | _, _ => False
    end.

  (** The nodes are pairs (ci, li): the first component describes the clause, the second one the literal *)
  Definition Vcnf := finType_CS ((Fin.t Ncl * Fin.t k)%type).
  Implicit Type v : Vcnf.

  Definition Ecnf (p : Vcnf * Vcnf) :=
    let (v1, v2) := p in
    let (ci1, li1) := v1 in
    let (ci2, li2) := v2 in
    let o1 := cnfGetLiteral N (index ci1) (index li1) in
    let o2 := cnfGetLiteral N (index ci2) (index li2) in
    not (opt_literalsConflict o1 o2) /\ ci1 <> ci2.

  Proposition literalsConflict_symm l1 l2 : literalsConflict l1 l2 <-> literalsConflict l2 l1.
  Proof.
    unfold literalsConflict. destruct l1, l2. split; intros [H1 H2]; split; congruence.
  Qed.

  Lemma Ecnf_symm v1 v2 : Ecnf (v1, v2) <-> Ecnf (v2, v1).
  Proof.
    unfold Ecnf. destruct v1, v2.
    unfold opt_literalsConflict. destruct cnfGetLiteral, cnfGetLiteral.
    2-4: firstorder. rewrite literalsConflict_symm. easy.
  Qed.

  Lemma literalsConflict_dec l1 l2 : {literalsConflict l1 l2} + {~ literalsConflict l1 l2}.
  Proof.
    unfold literalsConflict.
    destruct l1, l2.
    destruct (nat_eq_dec n n0).
    - destruct (bool_eq_dec b b0); tauto.
    - now right.
  Defined (* because informative*).

  Lemma Ecnf_dec v1 v2 : {Ecnf (v1, v2) } + {not (Ecnf (v1, v2))}.
  Proof.
    unfold Ecnf. destruct v1 as (ci1 & li1), v2 as (ci2 & li2).
    unfold opt_literalsConflict.
    destruct (eqType_dec ci1 ci2) as [He | He].
    - destruct cnfGetLiteral; [ | now right].
      destruct cnfGetLiteral; [ | now right].
      destruct (literalsConflict_dec p p0); tauto.
    - destruct cnfGetLiteral; [ | now left].
      destruct cnfGetLiteral; [ | now left].
      destruct (literalsConflict_dec p p0); tauto.
  Defined. (* because informative*)

  Definition Gcnf := Build_UGraph Ecnf_dec Ecnf_symm.

  (** we show the correctness of the encoding *)

  Section SAT_implies_Clique.
    (** ** SAT implies Clique *)
    (** Assume that there is a satisfying assignment for the CNF. *)
    Variable (a__sat : assgn).
    Context (H_sat : evalCnf a__sat N = true).

    Lemma evalLiteral_true_no_conflict a l1 l2 : evalLiteral a l1 = true -> evalLiteral a l2 = true -> not (literalsConflict l1 l2).
    Proof using.
      clear k N a__sat Hkgt Hkcnf H_sat.
      intros H1 H2 H. unfold literalsConflict in H.
      destruct l1, l2. destruct H as [<- H].
      unfold evalLiteral in *.
      rewrite Bool.eqb_true_iff in H1, H2.
      congruence.
    Qed.

    Definition verticesClauseGe (L : list (V Gcnf)) (i : nat) := forall ci li, (ci, li) el L -> index ci >= i.

    Proposition Vcnf_inhabitated : |N| > 0 -> exists (v : Vcnf), True.
    Proof using Hkgt Hkcnf.
      clear H_sat.
      unfold Vcnf, Ncl.
      intros H1. destruct k, N; cbn in *; try lia.
      exists (@Fin.F1 (|l0|), @Fin.F1 n). easy.
    Qed.

    Lemma nth_index (t : finType) (def : t) i: i < (| elem t |) -> index (nth i (elem t) def) = i.
    Proof.
      intros H.
      unfold index. apply getPosition_nth.
      - apply dupfree_elements.
      - exact H.
    Qed.

    (*we fix the index of the clause: the same clause might appear twice, but for the proof, we really need to work on a particular clause given by an index *)
    Lemma literalInClause_exists_vertex l C i:
      l el C -> cnfGetClause N i = Some C -> exists (v : V Gcnf),
      let (ci, li) := v in index ci = i /\ clauseGetLiteral C (index li) = Some l.
    Proof using Hkgt Hkcnf.
      clear H_sat.
      intros H1 H2.
      destruct Vcnf_inhabitated as ((cdef & ldef) & _).
      1: { unfold cnfGetClause in H2. apply nth_error_In in H2. destruct N; cbn in *; [destruct H2 | lia]. }
      specialize (In_nth_error _ _ H1) as (j & H1').
      unfold Gcnf, Vcnf. cbn [V].
      exists (nth i (elem (finType_CS (Fin.t Ncl))) cdef, nth j (elem (finType_CS (Fin.t k))) ldef).
      split.
      - apply nth_index. rewrite Fin_cardinality. unfold Ncl. eapply nth_error_Some_lt, H2.
      - unfold clauseGetLiteral. rewrite nth_index; [apply H1' | ].
        rewrite Fin_cardinality. apply nth_error_Some_lt in H1'.
        rewrite kCNF_clause_length in Hkcnf.
        unfold cnfGetClause in H2. apply nth_error_In in H2.
        apply Hkcnf in H2. lia.
    Qed.

    Definition vertexSatisfied a (v : V (Gcnf)) := let (ci, li) := v in
      match cnfGetLiteral N (index ci) (index li) with
      | Some l => evalLiteral a__sat l = true
      | None => False
      end.

    Lemma vertexSatisfied_edge a ci ci' li li' : ci <> ci' -> vertexSatisfied a (ci, li) -> vertexSatisfied a (ci', li') -> E (((ci, li), (ci', li')) : (V Gcnf * V Gcnf)).
    Proof.
      intros H. unfold vertexSatisfied.
      unfold E. cbn.
      destruct cnfGetLiteral, cnfGetLiteral; try tauto.
      intros H1 H2. unfold opt_literalsConflict. split; [now eapply evalLiteral_true_no_conflict | apply H].
    Qed.

    Hint Constructors dupfree : core.
    Lemma exists_clique' N' i : (exists N'', N = N'' ++ N') -> |N'| + i = |N| ->
        exists L, isKClique (|N'|) L /\ verticesClauseGe L i /\ (forall v, v el L -> vertexSatisfied a__sat v).
    Proof using Hkgt Hkcnf H_sat.
      revert i. induction N'; cbn; intros.
      - exists []. unfold isKClique, verticesClauseGe. cbn. split; [split; [lia | ] | split; [intros ? _ [] | tauto]].
        unfold isClique. split; [ intros ? ? [] | eauto].
      - rename a into C. destruct H as (N'' & H).
        edestruct (IHN' (S i)) as (L & IH1 & IH2 & IH3).
        2: lia.
        1: { exists (N'' ++ [C]). rewrite H. rewrite <- app_assoc. now cbn. }
        clear IHN'.
        rewrite H in H_sat. apply evalCnf_app_iff in H_sat as (_ & H_sat).
        apply evalCnf_step_inv in H_sat as (b1 & b2 & H1 & H2 & H3).
        symmetry in H3; apply andb_true_iff in H3 as [-> ->].
        apply evalClause_literal_iff in H2 as (l & Hel & H2).
        edestruct (@literalInClause_exists_vertex l C (|N''|)) as (v & Hv).
        + apply Hel.
        + rewrite H. unfold cnfGetClause. rewrite nth_error_app2; [ | lia].
          rewrite Nat.sub_diag. cbn. easy.
        + exists (v :: L). destruct v as (ci & li). destruct Hv as [Hv1 Hv2].
          assert (vertexSatisfied a__sat (ci, li)) as H_sat.
          { unfold vertexSatisfied. unfold cnfGetLiteral.
            rewrite Hv1, H. unfold cnfGetClause. rewrite nth_error_app2 by lia. rewrite Nat.sub_diag.
            cbn -[clauseGetLiteral index]. rewrite Hv2. apply H2.
          }
          split; [ | split].
          * apply indKClique_iff. constructor.
            -- apply indKClique_iff, IH1.
            -- unfold verticesClauseGe in IH2. intros H3%IH2. rewrite H, app_length in H0. cbn in H0. lia.
            -- intros (ci' & li') Hv'. specialize (IH3 _ Hv'). apply IH2 in Hv'.
               eapply vertexSatisfied_edge; [ rewrite H, app_length in H0; cbn in H0; intros ->; lia | apply H_sat | apply IH3].
          * unfold verticesClauseGe. intros ci' li' [[=] | HL]; [ | specialize (IH2 _ _ HL); lia].
            subst ci'. subst li'. rewrite Hv1. rewrite H, app_length in H0. cbn in H0. lia.
          * intros v [<- | Hsat]; [ apply H_sat | now apply IH3].
    Qed.

    Lemma exists_clique: exists (L : list (V Gcnf)), isKClique Ncl L.
    Proof using a__sat Hkgt Hkcnf H_sat.
      specialize (@exists_clique' N 0 ltac:(exists []; firstorder) ltac:(lia)) as (L & H & _).
      unfold Ncl. exists L; apply H.
    Qed.
  End SAT_implies_Clique.

  Section Clique_implies_SAT.
    (** ** Clique implies SAT *)
    (** Assume that the graph has a clique *)
    Variable (L : list (V Gcnf)).
    Context (Hclique : isKClique Ncl L).

    (** The proof proceeds in four steps:
        - We show that there exists a vertex of the clique for every clause of the CNF, using the pigeonhole principle.
        - Thus, there exists a list of (clause, literal) indices such that there is contained exactly one position per clause and the referenced literals are non-conflicting.
        - Resolving this list of indices, there exists a list of literals (one for every clause) which is non-conflicting. Every assignment satisfying this list of literals also satisfies the whole CNF.
        - From this list of literals, a satisfying assignment can be derived.
      *)

    (** *** Step 1*)

    (** proof by contradiction for decidable predicates *)
    Fact contradiction_dec_bipredicate (X Y : Type) (p : X -> Y -> Prop) : (forall x y, dec (p x y)) -> forall x y, (~ (~ p x y)) -> p x y.
    Proof.
      intros Hdec x y Hdn. destruct (Hdec x y); tauto.
    Qed.

    Definition clausesOf (L : list (V Gcnf)) := map (fun '(ci, li) => ci) L.
    Lemma isClique_clausesOf_dupfree cl : isClique cl -> dupfree (clausesOf cl).
    Proof.
      intros [H1 H2]. induction cl; cbn; [constructor | ].
      destruct a as (ci & li). constructor.
      - rewrite in_map_iff. intros ((ci' & li') & -> & H3).
        destruct (eqType_dec li li') as [He | He].
        + subst. inv H2. auto.
        + specialize (H1 (ci, li) (ci, li') ltac:(now left) ltac:(now right) ltac:(congruence)).
          unfold E in H1. cbn in H1. destruct H1 as (_ & H1). congruence.
      - apply IHcl; [ | now inv H2]. intros; now apply H1.
    Qed.

    Fact lt_le_rew (a b c : nat) : a < b -> b <= c -> a < c.
    Proof using Hkgt. lia. Qed.

    Definition ofClause (v : V Gcnf) i := match v with (ci, li) => index ci = i end.
    Lemma clique_vertex_for_all_clauses : forall i, i < Ncl -> exists v, v el L /\ ofClause v i.
    Proof using Hkgt Hclique.
      intros i Hi. eapply contradiction_dec_bipredicate with (p := fun i L => exists v : Vcnf, v el L /\ ofClause v i).
      1: { clear i L Hclique Hi. intros i L.
           induction L.
           - right. intros (v & [] & _).
           - destruct IHl as [IH | IH].
             + left. destruct IH as (v & H1 & H2). now exists v.
             + destruct a as (ci & li). unfold ofClause.
               destruct (nat_eq_dec (index ci) i) as [H1 | H1].
               * left. exists (ci, li). eauto.
               * right. intros (v & [<- | H2] & H3); [congruence | apply IH; eauto].
      }
      intros H. assert (forall v, v el L -> not (ofClause v i)) as H0.
      { intros v Hel Hc. apply H; eauto. }
      clear H.
      enough (not (dupfree (clausesOf L))) as H.
      { destruct Hclique as (_ & H1). now apply isClique_clausesOf_dupfree in H1. }
      eapply Pigeonhole.pigeonhole'; [easy | | ].
      - instantiate (1 := remove (@eqType_dec (EqType (Fin.t Ncl))) (nth i (elem (finType_CS (Fin.t Ncl))) (Fin.of_nat_lt Hi)) (elem (finType_CS (Fin.t Ncl)))).
        intros ci Hel. apply in_remove_iff.
        split; [apply elem_spec | ].
        unfold clausesOf in Hel. apply in_map_iff in Hel as ((ci' & li) & -> & Hel).
        apply H0 in Hel. unfold ofClause in Hel.
        specialize (H0 (ci, Fin.of_nat_lt Hkgt)). intros Heq; apply Hel.
        rewrite Heq. rewrite nth_index; [easy | rewrite Fin_cardinality; apply Hi].
      - unfold clausesOf. eapply lt_le_rew.
        + apply remove_length_el. apply elem_spec.
        + rewrite map_length. destruct Hclique as (H1 & _).
          setoid_rewrite H1.
          specialize (Fin_cardinality Ncl). intros Heq. now setoid_rewrite Heq.
    Qed.

    (** *** Step 2 *)
    (** We map to a list of (clause, literal) positions *)
    Definition toPos (L : list (V Gcnf)) := map (fun '(ci, li) => (index ci, index li)) L.

    Definition satPositions := toPos L.

    Lemma satPositions_dupfree : dupfree satPositions.
    Proof using Hclique.
      unfold satPositions, toPos.
      apply FinFun.Injective_map_NoDup. 2: apply Hclique.
      unfold injective. intros (ci1 & li1) (ci2 & li2) [=].
      apply injective_index in H0, H1. congruence.
    Qed.

    Lemma satPositions_for_all_clauses : forall i, i < Ncl -> exists li, (i, li) el satPositions.
    Proof using Hkgt Hclique.
      intros i (v & H1 & H2)%clique_vertex_for_all_clauses.
      destruct v as (ci & li).
      exists (index li). unfold toPos. apply in_map_iff.
      exists (ci, li). unfold ofClause in H2. rewrite <- H2.  easy.
    Qed.

    Lemma satPositions_non_conflicting ci1 ci2 li1 li2 :
      (ci1, li1) el satPositions
      -> (ci2, li2) el satPositions
      -> (ci1, li1) <> (ci2, li2)
      -> exists l1 l2, cnfGetLiteral N ci1 li1 = Some l1
          /\ cnfGetLiteral N ci2 li2 = Some l2 /\ not (literalsConflict l1 l2).
    Proof using Hkcnf Hclique.
      intros H1 H2 Hneq. unfold satPositions, toPos in *.
      apply in_map_iff in H1 as ((Ci1 & Li1) & H1' & H1). inv H1'.
      apply in_map_iff in H2 as ((Ci2 & Li2) & H2' & H2). inv H2'.
      unfold cnfGetLiteral, cnfGetClause, clauseGetLiteral.

      specialize (index_le Ci1) as H3. rewrite Fin_cardinality in H3.
      apply (proj2 (nth_error_Some N (index Ci1))) in H3.
      destruct (nth_error N (index Ci1)) as [ C1 | ] eqn:H3'; [clear H3 | congruence].
      specialize (nth_error_In _ _ H3') as H5'.

      specialize (index_le Ci2) as H4. rewrite Fin_cardinality in H4.
      apply (proj2 (nth_error_Some N (index Ci2))) in H4.
      destruct (nth_error N (index Ci2)) as [ C2 | ] eqn:H4'; [clear H4 | congruence].
      specialize (nth_error_In _ _ H4') as H6'.

      cbn -[index]. rewrite kCNF_clause_length in Hkcnf.
      apply Hkcnf in H5'. apply Hkcnf in H6'.

      specialize (index_le Li1) as H5. rewrite Fin_cardinality, <- H5' in H5. clear H5'.
      apply (proj2 (nth_error_Some C1 (index Li1))) in H5.
      destruct (nth_error C1 (index Li1)) as [l1 | ] eqn:H5'; [clear H5 | congruence].

      specialize (index_le Li2) as H6. rewrite Fin_cardinality, <- H6' in H6. clear H6'.
      apply (proj2 (nth_error_Some C2 (index Li2))) in H6.
      destruct (nth_error C2 (index Li2)) as [l2 | ] eqn:H6'; [clear H6 | congruence].

      exists l1, l2; split; [easy | split; [easy | ]].
      unfold isKClique in Hclique. destruct Hclique as (_ & (H & _)).
      specialize (H _ _ H1 H2 ltac:(congruence)).

      unfold E in H. cbn -[index] in H.
      unfold cnfGetLiteral, cnfGetClause, clauseGetLiteral in H.
      rewrite H3', H4' in H. cbn -[index] in H. rewrite H5', H6' in H.
      cbn in H. apply H.
    Qed.

    Proposition satPositions_valid ci li : (ci, li) el satPositions -> exists l, cnfGetLiteral N ci li = Some l.
    Proof using Hkcnf.
      unfold satPositions, toPos. intros ((Ci & Li) & H1' & H1)%in_map_iff. inv H1'.
      unfold cnfGetLiteral, cnfGetClause, clauseGetLiteral.

      specialize (index_le Ci) as H2. rewrite Fin_cardinality in H2.
      apply (proj2 (nth_error_Some N (index Ci))) in H2.
      destruct (nth_error N (index Ci)) as [ C | ] eqn:H2'; [clear H2 | congruence].
      apply nth_error_In in H2'.

      cbn -[index]. rewrite kCNF_clause_length in Hkcnf.
      apply Hkcnf in H2'.
      specialize (index_le Li) as H3. rewrite Fin_cardinality, <- H2' in H3. clear H2'.
      apply (proj2 (nth_error_Some C (index Li))) in H3.
      destruct (nth_error C (index Li)) as [l | ]; [clear H3 | congruence].
      eauto.
    Qed.

    (** *** Step 3: map to literals *)
    Definition toLiterals (L : list (nat * nat)) := filterSome (map (fun '(ci, li) => cnfGetLiteral N ci li) L).

    Definition satLiterals := toLiterals satPositions.

    Lemma satLiterals_for_all_clauses : forall C, C el N -> exists l, l el C /\ l el satLiterals.
    Proof using Hkgt Hkcnf Hclique.
      intros C Hel. apply In_nth_error in Hel as (i & Hel).
      specialize (nth_error_Some_lt Hel) as Hel'.
      specialize (satPositions_for_all_clauses Hel') as (li & H1).
      specialize (satPositions_valid H1) as (l & H2).
      exists l. split.
      - unfold cnfGetLiteral, cnfGetClause, clauseGetLiteral in H2.
        rewrite Hel in H2. cbn in H2. now eapply nth_error_In.
      - unfold satLiterals, toLiterals. apply in_filterSome_iff, in_map_iff.
        exists (i, li). easy.
    Qed.

    Lemma satLiterals_sat a : (forall l, l el satLiterals -> evalLiteral a l = true) -> evalCnf a N = true.
    Proof using Hkgt Hkcnf Hclique.
      intros H. apply evalCnf_clause_iff. setoid_rewrite evalClause_literal_iff.
      intros C (l & Hl & Hsat)%satLiterals_for_all_clauses.
      exists l. split; [apply Hl | ].
      now apply H.
    Qed.

    Lemma satLiterals_not_conflicting : forall l1 l2, l1 el satLiterals -> l2 el satLiterals -> not(literalsConflict l1 l2).
    Proof using Hkcnf Hclique.
      intros l1 l2 Hel1 Hel2.
      unfold satLiterals, toLiterals in *.
      apply in_filterSome_iff, in_map_iff in Hel1 as ((ci1 & li1) & Hel1' & Hel1).
      apply in_filterSome_iff, in_map_iff in Hel2 as ((ci2 & li2) & Hel2' & Hel2).
      destruct (eqType_dec (ci1, li1) (ci2, li2)) as [ | Hneq].
      - inv e. rewrite Hel1' in Hel2'. inv Hel2'. unfold literalsConflict.
        destruct l2. easy.
      - specialize (satPositions_non_conflicting Hel1 Hel2 Hneq) as (l1' & l2' & H1 & H2 & H3).
        rewrite H1 in Hel1'. inv Hel1'. rewrite H2 in Hel2'. inv Hel2'.
        apply H3.
    Qed.

    (** *** Step 4: map to a satisfying assignment *)
    Fixpoint toAssignment (L : list literal) :=
      match L with
      | [] => []
      | (true, v) :: L => v :: toAssignment L
      | (false, v) :: L => toAssignment L
      end.

    Lemma in_toAssignment_iff (v : var) lits : v el toAssignment lits <-> (true, v) el lits.
    Proof.
      induction lits; cbn; [tauto | ].
      destruct a as (b & v'). destruct b.
      - split; [intros [-> | H1]; [now left | right; now apply IHlits]
              | intros [[=->] | H1]; [now left | right; now apply IHlits]].
      - rewrite IHlits. split; [intros H; now right | intros [[=] | H]; apply H].
    Qed.

    Definition satAssgn := toAssignment satLiterals.

    Lemma satAssgn_sat_literals : forall l, l el satLiterals -> evalLiteral satAssgn l = true.
    Proof using Hkcnf Hclique.
      intros l Hel. destruct l as (b & v). apply evalLiteral_var_iff.
      destruct b.
      - apply evalVar_in_iff. apply in_toAssignment_iff, Hel.
      - destruct evalVar eqn:H1; [ | easy].
        apply evalVar_in_iff, in_toAssignment_iff in H1.
        exfalso; eapply satLiterals_not_conflicting; [apply Hel | apply H1 | ].
        unfold literalsConflict. split; congruence.
    Qed.

    Lemma satAssgn_sat_cnf : satisfies satAssgn N.
    Proof using Hkgt Hkcnf Hclique.
      unfold satisfies.
      apply satLiterals_sat, satAssgn_sat_literals.
    Qed.

    Corollary exists_assignment : exists a, satisfies a N.
    Proof using Hkgt Hkcnf Hclique.
      exists satAssgn; apply satAssgn_sat_cnf.
    Qed.

  End Clique_implies_SAT.

  Corollary reduction_to_Clique : kSAT k N <-> Clique (Gcnf, Ncl).
  Proof using Hkgt Hkcnf.
    split.
    - intros (_ & _ & (a & H)). eapply exists_clique, H.
    - intros (L & H). split; [ | split].
      + apply Hkgt.
      + apply Hkcnf.
      + eapply exists_assignment, H.
  Qed.
End fixSAT.

Lemma trivialNoInstance : {p : UGraph * nat & not (Clique p)}.
Proof.
  exists (@Build_UGraph (finType_CS (Fin.t 0)) (fun _ => False) ltac:(intros; now right) ltac:(intros; tauto), 1).
  intros (L & H). cbn in L. destruct H. destruct L as [ | e]; cbn in *; [congruence | ].
  inv e.
Qed.

Definition reduction (k : nat) (N : cnf) :=
  if kCNF_decb k N && Nat.ltb 0 k then (Gcnf k N, Ncl N) else projT1 trivialNoInstance.

Theorem kSAT_reduces_to_Clique k: forall N, kSAT k N <-> Clique (reduction k N).
Proof.
  intros N. unfold reduction. destruct kCNF_decb eqn:H1.
  - destruct k; cbn.
    + unfold kSAT. specialize (projT2 trivialNoInstance) as H2. cbn in H2. split; [lia | tauto].
    + rewrite reduction_to_Clique; [easy | lia | apply kCNF_decb_iff, H1].
  - cbn. unfold kSAT.
    assert (not (kCNF_decb k N = true)) as H1'. { destruct kCNF_decb; firstorder. }
    rewrite kCNF_decb_iff in H1'.
    specialize (projT2 trivialNoInstance) as H2. cbn in H2.
    split; tauto.
Qed.


Require Import Coq.Classes.Morphisms.
Require Import Crypto.Util.Tactics.RewriteHyp.
Require Import Crypto.Algebra.Hierarchy.

Section Monoid.
  Context {T eq op id} {monoid:@monoid T eq op id}.
  Local Infix "=" := eq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
  Local Infix "*" := op.
  Declare Scope eq_scope.
  Local Infix "=" := eq : eq_scope.
  Local Open Scope eq_scope.

  Lemma cancel_right z iz (Hinv:op z iz = id) :
    forall x y, x * z = y * z <-> x = y.
  Proof using Type*.
    intros x y; split; intro.
    { assert (op (op x z) iz = op (op y z) iz) as Hcut by (rewrite_hyp ->!*; reflexivity).
      rewrite <-associative in Hcut.
      rewrite <-!associative, !Hinv, !right_identity in Hcut; exact Hcut. }
    { rewrite_hyp ->!*. reflexivity. }
  Qed.

  Lemma cancel_left z iz (Hinv:op iz z = id) :
    forall x y, z * x = z * y <-> x = y.
  Proof using Type*.
    intros x y; split; intros.
    { assert (op iz (op z x) = op iz (op z y)) as Hcut by (rewrite_hyp ->!*; reflexivity).
      rewrite !associative, !Hinv, !left_identity in Hcut; exact Hcut. }
    { rewrite_hyp ->!*; reflexivity. }
  Qed.

  Lemma inv_inv x ix iix : ix*x = id -> iix*ix = id -> iix = x.
  Proof using Type*.
    intros Hi Hii.
    assert (H:op iix id = op iix (op ix x)) by (rewrite Hi; reflexivity).
    rewrite associative, Hii, left_identity, right_identity in H; exact H.
  Qed.

  Lemma inv_op x y ix iy : ix*x = id -> iy*y = id -> (iy*ix)*(x*y) =id.
  Proof using Type*.
    intros Hx Hy.
    cut (iy * (ix*x) * y = id); try intro H.
    { rewrite <-!associative; rewrite <-!associative in H; exact H. }
    rewrite Hx, right_identity, Hy. reflexivity.
  Qed.

End Monoid.

Section Homomorphism.
  Context {T  EQ OP ID} {monoidT:  @monoid T  EQ OP ID }.
  Context {T' eq op id} {monoidT': @monoid T' eq op id }.
  Context {phi:T->T'}.
  Local Infix "=" := eq. Local Infix "=" := eq : type_scope.
  Class is_homomorphism :=
    {
      homomorphism : forall a b,  phi (OP a b) = op (phi a) (phi b);

      is_homomorphism_phi_proper : Proper (respectful EQ eq) phi
    }.
  Global Existing Instance is_homomorphism_phi_proper.
End Homomorphism.

Section HomomorphismComposition.
  Context {G EQ OP ID} {monoidG:@monoid G EQ OP ID}.
  Context {H eq op id} {monoidH:@monoid H eq op id}.
  Context {K eqK opK idK} {monoidK:@monoid K eqK opK idK}.
  Context {phi:G->H} {phi':H->K}
          {Hphi:@is_homomorphism G EQ OP H eq op phi}
          {Hphi':@is_homomorphism H eq op K eqK opK phi'}.
  Lemma is_homomorphism_compose
        {phi'':G->K}
        (Hphi'' : forall x, eqK (phi' (phi x)) (phi'' x))
    : @is_homomorphism G EQ OP K eqK opK phi''.
  Proof using Hphi Hphi' monoidK.
    split; repeat intro; rewrite <- !Hphi''.
    { rewrite !homomorphism; reflexivity. }
    { apply Hphi', Hphi; assumption. }
  Qed.

  Global Instance is_homomorphism_compose_refl
    : @is_homomorphism G EQ OP K eqK opK (fun x => phi' (phi x))
    := is_homomorphism_compose (fun x => reflexivity _).
End HomomorphismComposition.


Require Export GeoCoq.Elements.OriginalProofs.proposition_16.
Require Export GeoCoq.Elements.OriginalProofs.lemma_angletrichotomy.

Section Euclid.

Context `{Ax1:euclidean_neutral_ruler_compass}.

Lemma lemma_26helper :
   forall A B C D E F,
   Triangle A B C -> CongA A B C D E F -> CongA B C A E F D -> Cong A B D E ->
   ~ Lt E F B C.
Proof.
intros.
assert (nCol A B C) by (conclude_def Triangle ).
assert (CongA A B C A B C) by (conclude lemma_equalanglesreflexive).
assert (neq A B) by (forward_using lemma_angledistinct).
assert (neq B A) by (conclude lemma_inequalitysymmetric).
assert (neq B C) by (forward_using lemma_angledistinct).
assert (neq C B) by (conclude lemma_inequalitysymmetric).
assert (neq A C) by (forward_using lemma_angledistinct).
assert (neq C A) by (conclude lemma_inequalitysymmetric).
assert (~ Lt E F B C).
 {
 intro.
 rename_H H;let Tf:=fresh in
 assert (Tf:exists H, (BetS B H C /\ Cong B H E F)) by (conclude_def Lt );destruct Tf as [H];spliter.
 assert (CongA A B C A B C) by (conclude lemma_equalanglesreflexive).
 assert (eq A A) by (conclude cn_equalityreflexive).
 assert (Out B A A) by (conclude lemma_ray4).
 assert (Out B C H) by (conclude lemma_ray4).
 assert (CongA A B C A B H) by (conclude lemma_equalangleshelper).
 assert (CongA A B H A B C) by (conclude lemma_equalanglessymmetric).
 assert (CongA A B H D E F) by (conclude lemma_equalanglestransitive).
 assert (Cong B A E D) by (forward_using lemma_congruenceflip).
 assert ((Cong A H D F /\ CongA B A H E D F /\ CongA B H A E F D)) by (conclude proposition_04).
 assert (CongA E F D B C A) by (conclude lemma_equalanglessymmetric).
 assert (~ Col A C H).
  {
  intro.
  assert (Col H C A) by (forward_using lemma_collinearorder).
  assert (Col B H C) by (conclude_def Col ).
  assert (Col H C B) by (forward_using lemma_collinearorder).
  assert (neq H C) by (forward_using lemma_betweennotequal).
  assert (Col C A B) by (conclude lemma_collinear4).
  assert (Col A B C) by (forward_using lemma_collinearorder).
  contradict.
  }
 assert (Triangle A C H) by (conclude_def Triangle ).
 assert (BetS C H B) by (conclude axiom_betweennesssymmetry).
 assert (LtA H C A A H B) by (conclude proposition_16).
 assert (Out C B H) by (conclude lemma_ray4).
 assert (eq A A) by (conclude cn_equalityreflexive).
 assert (Out C A A) by (conclude lemma_ray4).
 assert (~ Col B C A).
  {
  intro.
  assert (Col A B C) by (forward_using lemma_collinearorder).
  contradict.
  }
 assert (CongA B C A B C A) by (conclude lemma_equalanglesreflexive).
 assert (CongA B C A H C A) by (conclude lemma_equalangleshelper).
 assert (CongA H C A B C A) by (conclude lemma_equalanglessymmetric).
 assert (LtA B C A A H B) by (conclude lemma_angleorderrespectscongruence2).
 assert (LtA E F D A H B) by (conclude lemma_angleorderrespectscongruence2).
 assert (~ Col A H B).
  {
  intro.
  assert (Col H B A) by (forward_using lemma_collinearorder).
  assert (Col B H C) by (conclude_def Col ).
  assert (Col H B C) by (forward_using lemma_collinearorder).
  assert (neq B H) by (forward_using lemma_betweennotequal).
  assert (neq H B) by (conclude lemma_inequalitysymmetric).
  assert (Col B A C) by (conclude lemma_collinear4).
  assert (Col A B C) by (forward_using lemma_collinearorder).
  contradict.
  }
 assert (CongA A H B B H A) by (conclude lemma_ABCequalsCBA).
 assert (CongA A H B E F D) by (conclude lemma_equalanglestransitive).
 assert (LtA A H B A H B) by (conclude lemma_angleorderrespectscongruence2).
 assert (~ LtA A H B A H B) by (conclude lemma_angletrichotomy).
 contradict.
 }
close.
Qed.

End Euclid.


(************************************************************************)
(*         *   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)         *)
(************************************************************************)

(** A constructive proof of a version of Weak König's Lemma over a
    decidable predicate in the formulation of which infinite paths are
    treated as predicates. The representation of paths as relations
    avoid the need for classical logic and unique choice. The
    decidability condition is sufficient to ensure that some required
    instance of double negation for disjunction of finite paths holds.

    The idea of the proof comes from the proof of the weak König's
    lemma from separation in second-order arithmetic.

    Notice that we do not start from a tree but just from an arbitrary
    predicate. Original Weak Konig's Lemma is the instantiation of
    the lemma to a tree *)

Require Import WeakFan List.
Import ListNotations.

Require Import Omega.

(** [is_path_from P n l] means that there exists a path of length [n]
    from [l] on which [P] does not hold *)

Inductive is_path_from (P:list bool -> Prop) : nat -> list bool -> Prop :=
| here l : ~ P l -> is_path_from P 0 l
| next_left l n : ~ P l -> is_path_from P n (true::l) -> is_path_from P (S n) l
| next_right l n : ~ P l -> is_path_from P n (false::l) -> is_path_from P (S n) l.

(** We give the characterization of is_path_from in terms of a more common arithmetical formula *)

Proposition is_path_from_characterization P n l :
  is_path_from P n l <-> exists l', length l' = n /\ forall n', n'<=n -> ~ P (rev (firstn n' l') ++ l).
Proof.
intros. split.
- induction 1 as [|* HP _ (l'&Hl'&HPl')|* HP _ (l'&Hl'&HPl')].
  + exists []. split. reflexivity. intros n <-%le_n_0_eq. assumption.
  + exists (true :: l'). split. apply eq_S, Hl'. intros [|] H.
    * assumption.
    * simpl. rewrite <- app_assoc. apply HPl', le_S_n, H.
  + exists (false :: l'). split. apply eq_S, Hl'. intros [|] H.
    * assumption.
    * simpl. rewrite <- app_assoc. apply HPl', le_S_n, H.
- intros (l'& <- &HPl'). induction l' as [|[|]] in l, HPl' |- *.
  + constructor. apply (HPl' 0). apply le_0_n.
  + eapply next_left.
    * apply (HPl' 0), le_0_n.
    * fold (length l'). apply IHl'. intros n' H%le_n_S. apply HPl' in H. simpl in H. rewrite <- app_assoc in H. assumption.
  + apply next_right.
    * apply (HPl' 0), le_0_n.
    * fold (length l'). apply IHl'. intros n' H%le_n_S. apply HPl' in H. simpl in H. rewrite <- app_assoc in H. assumption.
Qed.

(** [infinite_from P l] means that we can find arbitrary long paths
    along which [P] does not hold above [l] *)

Definition infinite_from (P:list bool -> Prop) l := forall n, is_path_from P n l.

(** [has_infinite_path P] means that there is an infinite path
    (represented as a predicate) along which [P] does not hold at all *)

Definition has_infinite_path (P:list bool -> Prop) :=
  exists (X:nat -> Prop), forall l, approx X l -> ~ P l.

(** [inductively_barred_at P n l] means that [P] eventually holds above
    [l] after at most [n] steps upwards *)

Inductive inductively_barred_at (P:list bool -> Prop) : nat -> list bool -> Prop :=
| now_at l n : P l -> inductively_barred_at P n l
| propagate_at l n :
    inductively_barred_at P n (true::l) ->
    inductively_barred_at P n (false::l) ->
    inductively_barred_at P (S n) l.

(** The proof proceeds by building a set [Y] of finite paths
   approximating either the smallest unbarred infinite path in [P], if
   there is one (taking [true]>[false]), or the path
   true::true::... if [P] happens to be inductively_barred *)

Fixpoint Y P (l:list bool) :=
  match l with
  | [] => True
  | b::l =>
      Y P l /\
      if b then exists n, inductively_barred_at P n (false::l) else infinite_from P (false::l)
  end.

Require Import Compare_dec Le Lt.

Lemma is_path_from_restrict : forall P n n' l, n <= n' ->
  is_path_from P n' l -> is_path_from P n l.
Proof.
intros * Hle H; induction H in n, Hle, H |- * ; intros.
- apply le_n_0_eq in Hle as <-. apply here. assumption.
- destruct n.
  + apply here. assumption.
  + apply next_left; auto using le_S_n.
- destruct n.
  + apply here. assumption.
  + apply next_right; auto using le_S_n.
Qed.

Lemma inductively_barred_at_monotone : forall P l n n', n' <= n ->
  inductively_barred_at P n' l -> inductively_barred_at P n l.
Proof.
intros * Hle Hbar.
induction Hbar in n, l, Hle, Hbar |- *.
- apply now_at; auto.
- destruct n; [apply le_Sn_0 in Hle; contradiction|].
  apply le_S_n in Hle.
  apply propagate_at; auto.
Qed.

Definition demorgan_or (P:list bool -> Prop) l l' := ~ (P l /\ P l') -> ~ P l \/ ~ P l'.

Definition demorgan_inductively_barred_at P :=
  forall n l, demorgan_or (inductively_barred_at P n) (true::l) (false::l).

Lemma inductively_barred_at_imp_is_path_from :
  forall P, demorgan_inductively_barred_at P -> forall n l,
  ~ inductively_barred_at P n l -> is_path_from P n l.
Proof.
intros P Hdemorgan; induction n; intros l H.
- apply here.
  intro. apply H.
  apply now_at. auto.
- assert (H0:~ (inductively_barred_at P n (true::l) /\ inductively_barred_at P n (false::l)))
  by firstorder using inductively_barred_at.
  assert (HnP:~ P l) by firstorder using inductively_barred_at.
  apply Hdemorgan in H0 as [H0|H0]; apply IHn in H0; auto using is_path_from.
Qed.

Lemma is_path_from_imp_inductively_barred_at : forall P n l,
   is_path_from P n l -> inductively_barred_at P n l -> False.
Proof.
intros P; induction n; intros l H1 H2.
- inversion_clear H1. inversion_clear H2. auto.
- inversion_clear H1.
  + inversion_clear H2.
    * auto.
    * apply IHn with (true::l); auto.
  + inversion_clear H2.
    * auto.
    * apply IHn with (false::l); auto.
Qed.

Lemma find_left_path : forall P l n,
  is_path_from P (S n) l -> inductively_barred_at P n (false :: l) -> is_path_from P n (true :: l).
Proof.
inversion 1; subst; intros.
- auto.
- exfalso. eauto using is_path_from_imp_inductively_barred_at.
Qed.

Lemma Y_unique : forall P, demorgan_inductively_barred_at P ->
  forall l1 l2, length l1 = length l2 -> Y P l1 -> Y P l2 -> l1 = l2.
Proof.
intros * DeMorgan. induction l1, l2.
- trivial.
- discriminate.
- discriminate.
- intros [= H] (HY1,H1) (HY2,H2).
  pose proof (IHl1 l2 H HY1 HY2). clear HY1 HY2 H IHl1.
  subst l1.
  f_equal.
  destruct a, b; try reflexivity.
  + destruct H1 as (n,Hbar).
    destruct (is_path_from_imp_inductively_barred_at _ _ _ (H2 n) Hbar).
  + destruct H2 as (n,Hbar).
    destruct (is_path_from_imp_inductively_barred_at _ _ _ (H1 n) Hbar).
Qed.

(** [X] is the translation of [Y] as a predicate *)

Definition X P n := exists l, length l = n /\ Y P (true::l).

Lemma Y_approx : forall P, demorgan_inductively_barred_at P ->
  forall l, approx (X P) l -> Y P l.
Proof.
intros P DeMorgan. induction l.
- trivial.
- intros (H,Hb). split.
  + auto.
  + unfold X in Hb.
    destruct a.
    * destruct Hb as (l',(Hl',(HYl',HY))).
      rewrite <- (Y_unique P DeMorgan l' l Hl'); auto.
    * intro n. apply inductively_barred_at_imp_is_path_from. assumption.
      firstorder.
Qed.

(** Main theorem *)

Theorem PreWeakKonigsLemma : forall P,
  demorgan_inductively_barred_at P -> infinite_from P [] -> has_infinite_path P.
Proof.
intros P DeMorgan Hinf.
exists (X P). intros l Hl.
assert (infinite_from P l).
{ induction l.
  - assumption.
  - destruct Hl as (Hl,Ha).
    intros n.
    pose proof (IHl Hl) as IHl'. clear IHl.
    apply Y_approx in Hl; [|assumption].
    destruct a.
    + destruct Ha as (l'&Hl'&HY'&n'&Hbar).
      rewrite (Y_unique _ DeMorgan _ _ Hl' HY' Hl) in Hbar.
      destruct (le_lt_dec n n') as [Hle|Hlt].
      * specialize (IHl' (S n')).
        apply is_path_from_restrict with n'; [assumption|].
        apply find_left_path; trivial.
      * specialize (IHl' (S n)).
        apply inductively_barred_at_monotone with (n:=n) in Hbar; [|apply lt_le_weak, Hlt].
        apply find_left_path; trivial.
    + apply inductively_barred_at_imp_is_path_from; firstorder. }
specialize (H 0). inversion H. assumption.
Qed.

Lemma inductively_barred_at_decidable :
  forall P, (forall l, P l \/ ~ P l) -> forall n l, inductively_barred_at P n l \/ ~ inductively_barred_at P n l.
Proof.
intros P HP. induction n; intros.
- destruct (HP l).
  + left. apply now_at, H.
  + right. inversion 1. auto.
- destruct (HP l).
  + left. apply now_at, H.
  + destruct (IHn (true::l)).
    * destruct (IHn (false::l)).
      { left. apply propagate_at; assumption. }
      { right. inversion_clear 1; auto. }
    * right. inversion_clear 1; auto.
Qed.

Lemma inductively_barred_at_is_path_from_decidable :
  forall P, (forall l, P l \/ ~ P l) -> demorgan_inductively_barred_at P.
Proof.
intros P Hdec n l H.
destruct (inductively_barred_at_decidable P Hdec n (true::l)).
- destruct (inductively_barred_at_decidable P Hdec n (false::l)).
  + auto.
  + auto.
- auto.
Qed.

(** Main corollary *)

Corollary WeakKonigsLemma : forall P, (forall l, P l \/ ~ P l) ->
  infinite_from P [] -> has_infinite_path P.
Proof.
intros P Hdec Hinf.
apply inductively_barred_at_is_path_from_decidable in Hdec.
apply PreWeakKonigsLemma; assumption.
Qed.


Require Export prosa.model.schedule.tdma.
Require Import prosa.util.all.
From mathcomp Require Import div.

(** In this section, we define the properties of TDMA and prove some basic lemmas. *)
Section TDMAFacts.
  Context {Task:eqType}.

  (** Consider any task set ts... *)
  Variable ts: {set Task}.

  (** ... with a TDMA policy *)
  Context `{TDMAPolicy Task}.

  Section TimeSlotFacts.
    (** Consider any task in ts*)
    Variable task: Task.
    Hypothesis H_task_in_ts: task \in ts.

    (** Assume task_time_slot is valid time slot*)
    Hypothesis time_slot_positive:
      valid_time_slot ts.

    (** Obviously, the TDMA cycle is greater or equal than any task time slot which is
          in TDMA cycle *)
    Lemma TDMA_cycle_ge_each_time_slot:
      TDMA_cycle ts >= task_time_slot task.
    Proof.
      rewrite /TDMA_cycle (big_rem task) //.
      apply:leq_trans; last by exact: leq_addr.
        by apply leqnn.
    Qed.

    (** Thus, a TDMA cycle is always positive *)
    Lemma TDMA_cycle_positive:
      TDMA_cycle ts > 0.
    Proof.
      move:time_slot_positive=>/(_ task H_task_in_ts)/leq_trans;apply;apply TDMA_cycle_ge_each_time_slot.
    Qed.

    (** Slot offset is less then cycle *)
    Lemma Offset_lt_cycle:
      task_slot_offset ts task < TDMA_cycle ts.
    Proof.
      rewrite /task_slot_offset /TDMA_cycle big_mkcond.
      apply leq_ltn_trans with (n:=\sum_(prev_task <- ts )if prev_task!=task then task_time_slot prev_task else 0).
      - apply leq_sum. intros* T. case (slot_order i task);auto.
      - rewrite -big_mkcond (bigD1_seq task)?set_uniq//=.
        rewrite -subn_gt0 -addnBA. rewrite subnn addn0 //.
        exact: time_slot_positive.
        easy.
    Qed.

    (** For a task, the sum of its slot offset and its time slot is
          less then or equal to cycle. *)
    Lemma Offset_add_slot_leq_cycle:
      task_slot_offset ts task + task_time_slot task <= TDMA_cycle ts.
    Proof.
      rewrite /task_slot_offset /TDMA_cycle.
      rewrite addnC (bigD1_seq task) //=. rewrite leq_add2l.
      rewrite big_mkcond.
      replace (\sum_(i <- ts | i != task) task_time_slot i)
        with (\sum_(i <- ts ) if i != task then task_time_slot i else 0).
      apply leq_sum. intros*T. case (slot_order i task);auto.
        by rewrite -big_mkcond. apply (set_uniq ts).
    Qed.
  End TimeSlotFacts.

  (** Now we prove that no two tasks share the same time slot at any time. *)
  Section TimeSlotOrderFacts.
    (** Consider any task in ts*)
    Variable task: Task.
    Hypothesis H_task_in_ts: task \in ts.

    (** Assume task_time_slot is valid time slot*)
    Hypothesis time_slot_positive:
      valid_time_slot ts.

    (** Assume that slot order is total... *)
    Hypothesis slot_order_total:
      total_slot_order ts.

    (*..., antisymmetric... *)
    Hypothesis slot_order_antisymmetric:
      antisymmetric_slot_order ts.

    (*... and transitive. *)
    Hypothesis slot_order_transitive:
      transitive_slot_order.

    (** Then, we can prove that the difference value between two offsets is
        at least a slot *)
    Lemma relation_offset:
      forall tsk1 tsk2, tsk1 \in ts ->
                                 tsk2 \in ts ->
                                          slot_order tsk1 tsk2 ->
                                          tsk1 != tsk2 ->
                                          task_slot_offset ts tsk2 >=
                                          task_slot_offset ts tsk1 + task_time_slot tsk1 .
    Proof.
      intros* IN1 IN2 ORDER NEQ.
      rewrite /task_slot_offset big_mkcond addnC/=.
      replace (\sum_(tsk <- ts | slot_order tsk tsk2 && (tsk != tsk2)) task_time_slot tsk)
        with (task_time_slot tsk1 + \sum_(tsk <- ts )if slot_order tsk tsk2 && (tsk != tsk1) && (tsk!=tsk2) then task_time_slot tsk else O).
      rewrite leq_add2l. apply leq_sum_seq. intros* IN T.
      case (slot_order i tsk1)eqn:SI2;auto. case (i==tsk1)eqn:IT2;auto;simpl.
      case (i==tsk2)eqn:IT1;simpl;auto.
      - by move/eqP in IT1;rewrite IT1 in SI2;apply slot_order_antisymmetric in ORDER;auto;apply ORDER in SI2;move/eqP in NEQ.
      - by rewrite (slot_order_transitive _ _ _ SI2 ORDER).
      - symmetry. rewrite big_mkcond /=. rewrite->bigD1_seq with (j:=tsk1);auto;last by apply (set_uniq ts).
        move/eqP /eqP in ORDER. move/eqP in NEQ. rewrite ORDER //=. apply /eqP.
        have TS2: (tsk1 != tsk2) = true . apply /eqP;auto. rewrite TS2.
        rewrite eqn_add2l. rewrite big_mkcond. apply/eqP. apply eq_bigr;auto.
        intros* T. case(i!=tsk1);case (slot_order i tsk2);case (i!=tsk2) ;auto.
    Qed.

    (** Then, we proved that no two tasks share the same time slot at any time. *)
    Lemma task_in_time_slot_uniq:
      forall tsk1 tsk2 t, tsk1 \in ts -> task_time_slot tsk1 > 0 ->
                                   tsk2 \in ts -> task_time_slot tsk2 > 0 ->
                                            task_in_time_slot ts tsk1 t ->
                                            task_in_time_slot ts tsk2 t ->
                                            tsk1 = tsk2.
    Proof.
      intros* IN1 SLOT1 IN2 SLOT2.
      rewrite /task_in_time_slot.
      set cycle:=TDMA_cycle ts.
      set O1:= task_slot_offset ts tsk1.
      set O2:= task_slot_offset ts tsk2.
      have CO1: O1 < cycle by apply Offset_lt_cycle.
      have CO2: O2 < cycle by apply Offset_lt_cycle.
      have C: cycle > 0 by apply (TDMA_cycle_positive tsk1).
      have GO1:O1 %% cycle = O1 by apply modn_small,Offset_lt_cycle. rewrite GO1.
      have GO2:O2 %% cycle = O2 by apply modn_small,Offset_lt_cycle. rewrite GO2.
      have SO1:O1 + task_time_slot tsk1 <= cycle by apply (Offset_add_slot_leq_cycle tsk1).
      have SO2:O2 + task_time_slot tsk2 <= cycle by apply (Offset_add_slot_leq_cycle tsk2).
      repeat rewrite mod_elim;auto.
      case (O1 <= t%%cycle)eqn:O1T;case (O2 <= t %%cycle)eqn:O2T;intros G1 G2;try ssromega.
      apply ltn_subLR in G1;apply ltn_subLR in G2. case (tsk1==tsk2) eqn:NEQ;move/eqP in NEQ;auto.
      destruct (slot_order_total tsk1 tsk2) as [order |order];auto;apply relation_offset in order;
      fold O1 O2 in order;try ssromega;auto. by move/eqP in NEQ. apply /eqP;auto.
    Qed.

  End TimeSlotOrderFacts.
End TDMAFacts.


Require Import util.
Require Import Coq.omega.Omega.
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import language.
Require Import semantic.
Require Import state.
Import ListNotations.

Definition assertionV := state -> Prop.

Definition empV : assertionV :=
  fun st:state => match st with
                  | (stoV,stoB,stoF,hV,hB) => hV = emp_heapV
                  end.

Definition trueV : assertionV :=
  fun st:state => True.

Definition falseV : assertionV :=
  fun st:state => False.

Definition point_toV (e1 e2:aexp) : assertionV :=
  fun st:state =>
  match st with
  | (stoV,stoB,stoF,hV,hB) =>
      hV = h_updateV emp_heapV (aeval stoV stoF e1) (aeval stoV stoF e2)
  end.

Notation "e1 '|->' e2" := (point_toV e1 e2) (at level 60).

Definition notV (p:assertionV) : assertionV :=
  fun st:state => not (p st).

Definition eqV (a1 a2: aexp) : assertionV :=
  fun st:state =>
  match st with
  | (stoV,stoB,stoF,hV,hB) => (aeval stoV stoF a1) = (aeval stoV stoF a2)
  end.

Definition leV (a1 a2: aexp) : assertionV :=
  fun st:state =>
  match st with
  | (stoV,stoB,stoF,hV,hB) => (aeval stoV stoF a1) <= (aeval stoV stoF a2)
  end.

Definition sep_conjV (p q : assertionV) : assertionV :=
    fun st: state =>
      match st with
      | (stoV,stoB,stoF,hV,hB) =>
        exists hv1, exists hv2,
          disjointV hv1 hv2 /\ h_unionV hv1 hv2 = hV /\
          p (stoV,stoB,stoF,hv1,hB) /\ q (stoV,stoB,stoF,hv2,hB)
      end.
Notation "p '**' q" := (sep_conjV p q) (at level 70).

Definition sep_disjV (p q: assertionV) : assertionV :=
  fun (st : state) =>
    match st with
    | (stoV,stoB,stoF,hV,hB) =>
      forall hv', disjointV hv' hV -> p (stoV,stoB,stoF, hv', hB) ->
      q (stoV,stoB,stoF,h_unionV hV hv',hB)
    end.
Notation "p '--*' q" := (sep_disjV p q) (at level 80).

Definition s_conjV (p q: assertionV) : assertionV :=
  fun (s: state) => p s /\ q s.
Notation "p '//\\' q" := (s_conjV p q) (at level 75).

Definition s_disjV (p q: assertionV) : assertionV :=
  fun (s: state) => p s \/ q s.
Notation "p '\\//' q" := (s_disjV p q) (at level 78).

Definition s_impV (p q: assertionV) : assertionV :=
  fun (s: state) => p s -> q s.
Notation "p '-->' q" := (s_impV p q) (at level 85).

Definition strongerThanV (p q: assertionV) : Prop :=
  forall s: state, s_impV p q s.
Notation "p '==>' q" := (strongerThanV p q) (at level 90).


(************************************************************************)
(* Copyright (c) 2010, Martijn Vermaat <martijn@vermaat.name>           *)
(*                                                                      *)
(* Licensed under the MIT license, see the LICENSE file or              *)
(* http://en.wikipedia.org/wiki/Mit_license                             *)
(************************************************************************)

(** This library defines the type [context] of infinite one-hole contexts
   whose holes are at a finite depth. *)

Require Import Prelims.
Require Export Term.
Require Export TermEquality.
Require Import Equality.

Set Implicit Arguments.

Section Context.

(** Contexts are defined inductively over a signature [F] and a set of
   variables [X]. *)

Variable F : signature.
Variable X : variables.

Notation term := (term F X).
Notation terms := (vector term).

(** One-hole contexts where a hole can occur at any finite depth. *)
Inductive context : Type :=
  | Hole : context
  | CFun : forall (f : F) (i j : nat),
           i + S j = arity f -> terms i -> context -> terms j -> context.

Implicit Arguments CFun [i j].

(** Depth of a hole. *)
Fixpoint hole_depth c : nat :=
  match c with
  | Hole                => 0
  | CFun _ _ _ _ _ c' _ => 1 + hole_depth c'
  end.

(** Position of a hole. *)
Fixpoint hole_position c : position :=
  match c with
  | Hole                => nil
  | CFun _ i _ _ _ c' _ => i :: (hole_position c')
  end.

(** Depth of a hole is depth of its position. *)
Lemma hole_position_depth :
  forall c,
    hole_depth c = position_depth (hole_position c).
Proof.
induction c; simpl; try (rewrite IHc); reflexivity.
Qed.

(** Fill a hole in a context with a term. *)
Fixpoint fill (c : context) (t : term) : term :=
  match c with
  | Hole                  => t
  | CFun f i j H v1 c' v2 => Fun f (vcast (vappend v1 (vcons (fill c' t) v2)) H)
  end.

(*
   TODO: I would prefer the definition below where we try to avoid explicit
   casts but prove equalities with Program.
   Unfortunately this gives us problems I cannot solve in proofs like
   fill_eq_up_to below.

Program Fixpoint fill (c : context) (t : term) : term :=
  match c with
  | Hole                  => t
  | CFun f i j H v1 c' v2 => Fun f (vappend v1 (vcons (fill c' t) v2))
  end.
*)

(** Filling a context gives terms equal up to the hole depth. *)
Lemma fill_eq_up_to :
  forall (c : context) t u n,
  n <= hole_depth c -> term_eq_up_to n (fill c t) (fill c u).
Proof.
intros c t u n.
revert c.
induction n as [| n IH]; simpl.
constructor.
destruct c; simpl; intro H.
inversion H.
constructor.
revert v e.
generalize (arity f).
induction i as [| i IHi]; simpl; intro a.
intros _ e k.
destruct k; repeat (rewrite vcast_vcons).
apply IH.
auto with arith.
apply term_eq_refl.
intros v e k.
destruct k; repeat (rewrite vcast_vcons).
apply term_eq_refl.
apply IHi.
Qed.

(** Filling a context with bisimilar terms yields bisimilar terms. *)
Lemma fill_term_bis :
  forall (c : context) t u,
    t [~] u ->
    fill c t [~] fill c u.
Proof.
intros c t u H.
induction c as [| f i j H1 v1 c IH v2]; simpl.
assumption.
constructor.
intro k.
destruct H1.
simpl.
induction i as [| i IHi].
simpl in k.
simpl.
dependent destruction k.
simpl.
assumption.
apply term_bis_refl.
dependent destruction k.
apply term_bis_refl.
specialize IHi with (vtail v1) k.
simpl.
assumption.
Qed.

Require Import Arith.

Lemma lt_plus_minus_r : forall n m, n < m -> n + S (m - S n) = m.
intros.
rewrite <- plus_Snm_nSm.
apply le_plus_minus_r.
assumption.
Qed.

Require Import Lt.
Require Import Bool_nat.

(** Create a context from a term by making a hole. *)
Fixpoint dig (t : term) (p : position) {struct p} : option context :=
  match p with
  | nil    => Some Hole
  | n :: p => match t with
              | Var _      => None
              | Fun f args => match lt_ge_dec n (arity f) with
                              | left h  => match dig (vnth h args) p with
                                           | None   => None
                                           | Some c => Some (CFun f (lt_plus_minus_r h)
                                                                  (vtake (lt_le_weak n (arity f) h) args)
                                                                  c
                                                                  (vdrop h args))
                                           end
                              | right _ => None
                              end
              end
  end.

(**
   Digging a hole and filling it with the same gets you nothing new.

[[
Lemma dig_fill :
  forall t p,
    match dig t p, subterm t p with
    | Some c, Some s => fill c s [=] t
    | _,      _      => True
    end.
Proof.
intros t p.
induction p as [| n p IH]; simpl.
apply term_eq_refl.
]]

   By the way, CoLoR states it like this:

[[
Lemma subterm_elim : forall p t s, subterm t p = Some s ->
  {c | dig s p = Some c /\ s [=] fill c s}.
]]
*)

(*
   TODO: waarom eigenlijk niet de diepte van een context in het type? als
   volgt:

Inductive context : nat -> Type :=
  | Hole : context 0
  | CFun : forall (d : nat) (f : F) (n m : nat), n + S m = arity f ->
           vector term n -> context d -> vector term m -> context (S d).

   dan natuurlijk:

Definition hole_depth (d : nat) (c : context d) := d.

Fixpoint fill (d : nat) (c : context d) (t : term) : term :=
  match c with
  | Hole                  => t
  | CFun _ f i j H v1 c' v2 => Fun f (vcast (vappend v1 (vcons (fill c' t) v2)) H)
  end.

   - een gevolg zal dan zijn, dat ook steps geparameteriseerd worden met de
     diepte (is dat handig?)

   - een andere vraag die opkomt is: waarom parameteriseren we niet meteen
     met de positie van de hole ...
*)

End Context.

Implicit Arguments Hole [F X].


Require Import list_examples.

Require Import ZArith.
Require Import List.

(*

int sum_recursive(struct listNode* x)
//@ rule <k> $ => return sum(A); ...</k> <heap>... list(x)(A) ...</heap>
{
  if (x == NULL)
    return 0;

  return x->val + sum_recursive(x->next);
}
*)

Open Scope Z.
Definition sum_code :=
 (SIf ("x" = 0)
      (SReturn 0)
      (SReturn (EPlus (ELoad "x") (ECall "sum_recursive" [ELoad ("x" + 1)]))))%code.
Definition sum_fun :=
  FunDef "sum_recursive" ["x"] sum_code.
Inductive sum_spec : kcfg -> (kcfg -> Prop) -> Prop :=
  sum_claim :
    forall c, kcell c = kra (KStmt sum_code) kdot ->
    forall xv, store c ~= "x" s|-> KInt xv ->
    forall f', functions c ~=  "sum_recursive" s|-> sum_fun :* f' ->
    forall l P, heap c |= rep_list l xv :* P ->
      sum_spec c (returning c (sum l)).

Lemma sum_proof : sound kstep sum_spec.
Proof.
list_solver.
Qed.