Require Import ZArith.

Module NaiveLang.
  Definition expr := (nat -> option Z) -> Prop.
  Definition context := expr -> Prop.
  Definition andp (e1 e2 : expr) : expr := fun st => e1 st /\ e2 st.
  Definition orp  (e1 e2 : expr) : expr := fun st => e1 st \/ e2 st.
  Definition falsep : expr := fun st => False.
  Definition truep : expr := fun st => True.

  Definition join : (nat -> option Z) -> (nat -> option Z) -> (nat -> option Z) -> Prop :=
    fun x y z =>
      forall p: nat,
       (exists v, x p = Some v /\ y p = None /\ z p = Some v) \/
       (exists v, x p = None /\ y p = Some v /\ z p = Some v) \/
       (x p = None /\ y p = None /\ z p = None).
  Definition sepcon (e1 e2 : expr) : expr := fun st =>
    exists st1 st2, join st1 st2 st /\ e1 st1 /\ e2 st2.
  Definition emp : expr := fun st =>
    forall p, st p = None.
  Definition derivable1 (e1 e2 : expr) : Prop := forall st, e1 st -> e2 st.
End NaiveLang.

Require Import interface_4.

Module NaiveRule.
  Include DerivedNames (NaiveLang).
  Axiom falsep_sepcon_left : (forall x : expr, derivable1 (sepcon falsep x) falsep) .
  Axiom orp_sepcon_left : (forall x y z : expr, derivable1 (sepcon (orp x y) z) (orp (sepcon x z) (sepcon y z))) .
  Axiom sepcon_emp_left : (forall x : expr, derivable1 (sepcon x emp) x) .
  Axiom sepcon_emp_right : (forall x : expr, derivable1 x (sepcon x emp)) .
  Axiom derivable1_sepcon_comm : (forall x y : expr, derivable1 (sepcon x y) (sepcon y x)) .
  Axiom derivable1_sepcon_assoc1 : (forall x y z : expr, derivable1 (sepcon x (sepcon y z)) (sepcon (sepcon x y) z)) .
  Axiom derivable1_sepcon_mono : (forall x1 x2 y1 y2 : expr, derivable1 x1 x2 -> derivable1 y1 y2 -> derivable1 (sepcon x1 y1) (sepcon x2 y2)) .
  Axiom derivable1_truep_intros : (forall x : expr, derivable1 x truep) .
  Axiom derivable1_falsep_elim : (forall x : expr, derivable1 falsep x) .
  Axiom derivable1_orp_intros1 : (forall x y : expr, derivable1 x (orp x y)) .
  Axiom derivable1_orp_intros2 : (forall x y : expr, derivable1 y (orp x y)) .
  Axiom derivable1_orp_elim : (forall x y z : expr, derivable1 x z -> derivable1 y z -> derivable1 (orp x y) z) .
  Axiom derivable1_andp_intros : (forall x y z : expr, derivable1 x y -> derivable1 x z -> derivable1 x (andp y z)) .
  Axiom derivable1_andp_elim1 : (forall x y : expr, derivable1 (andp x y) x) .
  Axiom derivable1_andp_elim2 : (forall x y : expr, derivable1 (andp x y) y) .

End NaiveRule.

Module T := LogicTheorem NaiveLang NaiveRule.
Module Solver := IPSolver NaiveLang.
Import T.
Import Solver.


Require Import List Extraction.
Section LLists.

Variable (A:Type).

CoInductive LList :=
  | LNil: LList
  | LCons : A -> LList -> LList.

Inductive Finite : LList -> Prop :=
  |Finite_LNil: Finite LNil
  |Finite_LCons     : forall a l, Finite l-> Finite (LCons a l).

(* An equivalent (one contructor) definition of Finite *)

Inductive Finite_alt (x:LList) :Prop :=
  |finite_alt_intro: (forall a y , x = LCons a y ->Finite_alt y)->
       Finite_alt x.

Lemma Finite_Finite_alt : forall x, Finite x -> Finite_alt x.
Proof.
  intros x H;induction H.
 -  constructor; intros a y H;inversion H.
 -  constructor;intros b y;injection 1; intros;subst y;assumption.
Qed.

Lemma Finite_alt_Finite : forall x, Finite_alt x -> Finite x.
Proof.
 intros x H; induction H as [x H H0]; destruct x;constructor.
 eapply H0;eauto.
Qed.

Definition Finite_rect_0 (P:LList->Type) :
    (forall x : LList,
        (forall(h:A) (y  : LList),  x = LCons h y -> P y) -> P x) ->
    forall x : LList, Finite x -> P x.
Proof.
 intros H x Hx;apply Finite_Finite_alt in Hx.
 induction Hx.
 apply H; auto.
Defined.

Definition Finite_rect (P:LList->Type) :
 P LNil ->
 (forall x (l:LList), P l -> (P (LCons  x l))) ->
 forall l, Finite l -> P l.
Proof.
 intros X X0 l H; induction H using Finite_rect_0.
  destruct x; auto.
  apply X0; apply X1 with a;reflexivity.
Defined.

Fixpoint list_inject (l:list A) : LList :=
 match l with nil => LNil
            |List.cons a l' => LCons a (list_inject l')
 end.

Lemma inj_Finite : forall l, Finite (list_inject l).
Proof.
 induction l;constructor;auto.
Qed.

Definition to_list_strong: forall x, Finite x-> {l:list A | x=list_inject l}.
Proof.
  intros x H;  induction H using Finite_rect.
 -   exists nil;auto.
 -   destruct IHFinite as [l0 H0]; exists (x::l0);subst l;trivial.
Defined.

Definition to_list: forall x, Finite x-> list A.
Proof.
  intros x Hx;destruct (to_list_strong _ Hx) as  [x0 _];  exact x0.
Defined.

End LLists.
Recursive Extraction to_list_strong.


(** * Teorija tipov in λ-račun. *)

(** Tipi so posplošitev množic, topološki prostorov in podatkovnih tipov. Naivno si jih
    lahko predstavljamo kot množice. Dejstvo, da ima izraz [e] tip [A] pišemo [e : A].

    Razne konstrukcije tipov se vedno uvede po istem vzorcu:

    - _formacija_: kako se naredi nov tip

    - _vpeljava_: kako se naredi ali sestavi elemente tipa (konstruktorji)

    - _upraba_: kako se elemente uporabi ali razstavi na sestavne dele (eliminatorji)

    - _enačbe_: kakšne enačbe povezujejo konstruktorje in eliminatorje
*)

(** ** Funkcije

  Za vsaka dva tipa [A] in [B] lahko tvorimo tip funkcij:

  - _formacija_: če sta [A] in [B] tipa, je tudi [A -> B] tip

  - _vpeljava_: če je [x : A] spremenljivka tipa [A] in [t : B] izraz tipa [B],
    odvisen od [x], potem je [fun (x : A) => t] tipa [A -> B]. Izrazu [fun ...]
    pravimo _λ-abstrakcija_, ker se v logiki piše $\lambda x : A . t$.

  - _uporaba_: če je [f : A -> B] in [e : A] potem je [f e : B]. Pravimo, da smo
    funkcijo [f] aplicirali na argumentu [e].

  - _enačbe_:

    - _pravilo $\beta$_: [(fun (x : A) => t) e = t{e/x}] kjer zapis "[t{e/x}]" pomeni,
      da v izrazu [t] vstavimo [e] namesto [x].

    - _pravilo $\eta$_: [(fun (x : A) => f x) = f]
*)

(** ** Kartezični produkt

    Da bomo lahko počeli kaj zanimivega, vpeljemo še kartezični produkt tipov:

    - _formacija_: če sta [A] in [B] tipa, je [A * B] tip (matematični zapis $A \times B$)

    - _vpeljava_: če je [a : A] in [b : B], potem je [(a,b) : A * B], _urejeni par_

    - _uporaba_: če je [p : A * B], potem imamo

      - _prva projekcija_: [fst p : A]
      - _druga projekcija_: [snd p : B]

    - enačbe, pri čemer je [a : A], [b : B] in [p : A * B]:
      - [fst (a, b) = a]
      - [snd (a, b) = b]
      - [p = (fst p, snd p)]

    Poznamo še enotski tip:

    - _formacija_: [unit] je tip
    - _vpeljava_: [tt : unit]
    - _uporaba_: pravil za uporabo ni
    - _enačbe_: če je [u : unit], je [u = tt].
*)

(** V Coqu lahko datoteko razdelimo na posamične razdelke z [Section X.] in [End X.] *)
Section RazneFunkcije.

  (* Predpostavimo, da imamo tipe [A], [B] in [C]. *)
  Context {A B C : Type}.

  Definition vaja1_1 : A * B -> B * A :=
    fun (p : A * B) => (snd p, fst p).

  Definition vaja1_2 : (A * B) * C -> A * (B * C) :=
    fun (p : (A * B) * C) => (fst (fst p), (snd (fst p), snd p)).

  Definition vaja1_3 : A -> (B -> A).
  Admitted.

  Definition vaja1_4 : (A -> B -> C) -> (A -> B) -> (A -> C).
  Admitted.

  Definition vaja1_5 : (A * B -> C) -> (A -> (B -> C)).
  Admitted.

  Definition vaja1_6 : (A -> (B -> C)) -> (A * B -> C) :=
    fun (f : A -> (B -> C)) => (fun p : A * B => f (fst p) (snd p)).

  Definition vaja1_7 : unit * A -> A.
  Admitted.

  Definition vaja1_8 : A -> unit * A :=
    fun (a : A) => (tt, a).
End RazneFunkcije.

(** Ko zapremo razdelek [RazneFunkcije] nimamo več predpostavke, da so [A], [B], [C] tipi,
    vse definicije iz razdelka pa postanejo funkcije z dodatnimi parametri [A], [B], [C]. *)
Print vaja1_1.

(** Coq pravi: "Arguments [A], [B] are implicit and maximally inserted". To pomeni,
    da jih ni treba podati, ko uporabimo funkcijo [vaja1_1]. *)
Eval compute in vaja1_1 (42, false).

(* Če želimo eksplicitno nastaviti tudi [A] in [B], pišemo [@vaja1_1] namesto [vaja1_1]: *)
Eval compute in @vaja1_1 nat bool (42, false).

(** ** Izomorfni tipi

   Pravimo, da sta tipa [X] in [Y] izomorfna, če obstajata [f : X -> Y] in
   [g : Y -> X], da velja [g (f x) = x] za vse [x : X] in [g (g y) = y] za vse [y : Y].
*)
Definition iso (X : Type) (Y : Type) :=
  exists (f : X -> Y) (g : Y -> X),
    (forall x : X, g (f x) = x) /\ (forall y : Y, f (g y) = y).

(** V Coqu lahko uvedemo prikladno notacijo za izomorfizem. *)
Notation "X <~> Y" := (iso X Y) (at level 60).

Section Izomorfizmi1.
  (** Predpostavimo, da imamo tipe [A], [B] in [C]. *)
  Context {A B C : Type}.

  (** Dokaži, da so naslednji tipi izomorfni. *)

  Lemma vaja2_1 : A * B <~> B * A.
  Proof.
    admit.
  Qed.

  Lemma vaja2_2 : (A * B) * C <~> A * (B * C).
  Proof.
    admit.
  Qed.

  Lemma vaja2_3 : unit * A <~> A.
  Proof.
    admit.
  Qed.

  (** Pravimo, da sta funkciji [f g : X -> Y] _enaki po točkah_, če velja [forall x : X, f
      x = g x]. Aksiom _funkcijske ekstenzionalnosti_ pravi, da sta funkciji enaki,
      če sta enaki po točkah. Coq ne verjame v ta aksiom, zato ga po potrebi predpostavimo.
      Najprej ga definirajmo. *)
  Definition funext :=
    forall (X Y : Type) (f g : X -> Y), (forall x, f x = g x) -> f = g.

  (** S pomočjo ekstenzionalnosti lahko dokažemo nekatere izomorfizme. *)
  Lemma vaja2_4 (F : funext) : (A * B -> C) <~> (A -> (B -> C)).
  Proof.
    admit.
  Qed.

  Lemma vaja2_5 (F : funext) : (unit -> A) <~> A.
  Proof.
    admit.
  Qed.

  Lemma vaja2_6 (F : funext) : (A -> unit) <~> unit.
  Proof.
    admit.
  Qed.
End Izomorfizmi1.

(** ** Vsota tipov

   Vsota tipov je kot disjunktna unija v teorijo množic ali koprodukt v kategorijah:

   - _formacija_: če sta [A] in [B] tipa, je [A + B] tip

   - _vpeljava_:

      - če je [a : A], potem je [inl a : A + B]
      - če je [b : B], potem je [inr b : A + B]

   - _uporaba_: če pri predpostavki [x : A] velja [u(x) : C] in
     če pri predpostavki [y : B] velja [v(y) : C] in če je [t : A + B], potem
     ima
     [(match t with
       | inl x => u(x)
       | inr y => v(y)
      end)]
     tip [C].

   - _enačbe_:

      - [match (inl a) with
         | x => u(x)
         | y => v(y)
         end] je enako [u(a)].

      - [match (inr b) with
         | x => u(x)
         | y => v(y)
         end] je enako [v(b)].

      - [match t with
         | inl x => inl x
         | inr y => inr y
         end] je enako [t].

*)

(** ** Prazen tip

    Nekoliko bolj nenavaden je prazen tip:

    - _formacija_: [Empty_set] je tip

    - _vpeljava_: ni pravil za uporabo

    - _uporaba_: če [t : Empty_set], potem ima [match t with end] tip [A]

    - _enačbe_: [match t with end] je enako [a] za vse [a : A]
*)

Section FunkcijeVsote.
  (** Predpostavimo, da imamo tipe [A], [B] in [C]. *)
  Context {A B C : Type}.

  Definition vaja3_1 : (A + B -> C) -> (A -> C) * (B -> C).
  Admitted.

  (* S stavkom match obravnavmo element, ki je vsota tipov. *)

  Definition vaja3_2 : A + B -> B + A.
  Admitted.

  Definition vaja3_3 : (A + B) * C -> A * C + B * C.
  Admitted.

  Definition vaja3_4 : A * C + B * C -> (A + B) * C.
  Admitted.

  Definition vaja3_5 : (A -> C) * (B -> C) -> (A + B -> C).
  Admitted.

  Definition vaja3_6 : Empty_set -> A.
  Admitted.

  Definition vaja3_7 : Empty_set + A -> A.
  Admitted.

  Definition vaja3_8 : A -> ((A -> Empty_set) -> Empty_set).
  Admitted.

  Definition vaja3_9 : A + (A -> Empty_set) -> (((A -> Empty_set) -> Empty_set) -> A).
  Admitted.

End FunkcijeVsote.

Section Izomorfizmi2.
  (** Sam ugotovi, kje potrebuješ funkcijsko ekstenzionalnost. *)

  Context {A B C : Type}.

  Definition vaja4_1 : A + B <~> B + A.
  Proof.
    admit.
  Qed.

  Definition vaja4_2 : (A + B) * C <~> A * C + B * C.
  Proof.
    admit.
  Qed.

  Definition vaja4_3 : (A + B -> C) <~> (A -> C) * (B -> C).
  Proof.
    admit.
  Qed.

  Definition vaja4_4 : Empty_set + A <~> A.
  Proof.
    admit.
  Qed.

  Definition vaja4_5 : (A -> Empty_set) <~> Empty_set.
  Proof.
    admit.
  Qed.

  Definition vaja5_5 : (Empty_set -> A) <~> unit.
  Proof.
    admit.
  Qed.

End Izomorfizmi2.

Section Zabava.
  (** Pa še neka vaj za zabavo. *)
  Context {A B : Type}.

  (* Koliko funkcij A * B -> A + B lahko definiraš? *)
  Definition vaja5_1_XX : A * B -> A + B.
  Admitted.

  (* Koliko funkcij tipa (A * A) * A -> A * A lahko definiraš? *)
  Definition vaja5_2_XX : (A * A) * A -> A * A.
  Admitted.

  (* Koliko funkcij tipa (A -> A) -> (A -> A) lahko definiraš? *)
  Definition vaja5_3_XX : (A -> A) -> (A -> A).
  Admitted.

End Zabava.


Require Import ssreflect ssrbool ssrfun eqtype ssrnat div seq choice fintype.
Require Import finfun bigop finset.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Goal FinSet [ffun x : 'I_3 => true] = setT.
apply/setP => /= x.
rewrite {1}SetDef.pred_of_setE /=.
rewrite {1}/in_mem.
rewrite {1}/mem.
rewrite /=.
rewrite ffunE.
rewrite in_setT.
done.
Qed.

(* おまけ。 *)
Goal [set: 'I_3] = setT.
apply/setP.
by case => /=.
Qed.

Section finset_example.

Variable T : finType.
Variables A B C : {set T}.

(* use setP *)
Lemma exo20 : (A :&: B) :|: C = (A :|: C) :&: (B :|: C).
Proof.
  Search (_ :&: _ :|: _).
  by rewrite setUIl.
Qed.

End finset_example.


Theorem my_first_proof : (forall A : Prop, forall value_of_A: A, A).
Proof.
  intros A.
  (* intros proof_of_A.
  exact proof_of_A. *)
  intros value_of_B.
  exact value_of_B.
  (* case value_of_B. *)
  (* elim value_of_B. *)
Qed.

Theorem my_second_proof : (forall A : Prop, A -> A).
trivial.
Qed.

Theorem forward_small : (forall A B : Prop, A -> (A->B) -> B).
Proof.
 intros A B.
 (* intros B. *)
 intros proof_of_A A_implies_B.
 (* intros A_implies_B. *)
 pose (proof_of_B := A_implies_B proof_of_A).
 exact proof_of_B.
Qed.

Theorem lalal : (forall A B : Prop, A -> (A -> B) -> B).
Proof.
  intros A B.
  intros proof_of_A A_implies_B.
  exact (A_implies_B proof_of_A).
Qed.

Theorem forward_small_2 :
 (forall A B : Prop,
  (forall value_of_A: A,
   (forall A_implies_B: A->B, B))).
Proof.
 intros A B.
 (* intros B. *)
 intros proof_of_A A_implies_B.
 (* intros A_implies_B. *)
 pose (proof_of_B := A_implies_B proof_of_A).
 exact proof_of_B.
Qed.

Theorem forward_small_3 : (forall A B : Prop, A -> (A->B) -> B).
Proof.
 intros A B.
 (* intros B. *)
 intros proof_of_A A_implies_B.
 (* intros A_implies_B. *)
 exact (A_implies_B proof_of_A).
Qed.

Theorem backward_small : (forall A B : Prop, A -> (A->B)->B).
Proof.
 intros A B.
 intros proof_of_A A_implies_B.
 (* refine (A_implies_B _). *)
 refine (A_implies_B proof_of_A).
 (*  exact proof_of_A. *)
Qed.

Theorem backward_huge : (forall A B C : Prop, A -> (A->B) -> (A->B->C) -> C).
Proof.
 intros A B C.
 intros proof_of_A A_implies_B A_imp_B_imp_C.
 refine (A_imp_B_imp_C _ _).
  exact proof_of_A.

  refine (A_implies_B _).
   exact proof_of_A.
Show Proof.
Qed.

Theorem backward_huge2 : (forall A B C : Prop, A -> (A->B) -> (A->B->C) -> C).
Proof.
 intros A B C.
 intros proof_of_A A_implies_B A_imp_B_imp_C.
 exact (A_imp_B_imp_C proof_of_A (A_implies_B proof_of_A)).
Show Proof.
Qed.

Theorem forward_huge : (forall A B C : Prop, A -> (A->B) -> (A->B->C) -> C).
Proof.
 intros A B C.
 intros proof_of_A A_implies_B A_imp_B_imp_C.
 pose (proof_of_B := A_implies_B proof_of_A).
 pose (proof_of_C := A_imp_B_imp_C proof_of_A proof_of_B).
Show Proof.
 (*exact proof_of_C.*)
 refine proof_of_C.
Show Proof.
Qed.
Extraction forward_huge.

(* Inductive False : Prop := . *)

(* Inductive True : Prop :=
  | I : True.
*)

(*
Inductive bool : Set :=
  | true : bool
  | false : bool.
*)

(*
Definition not (A:Prop) := A -> False.
*)

(* Notation "~ x" := (not x) : type_scope. *)

Theorem False_cannot_be_proven : ~False.
Proof.
  (* unfold not. *)
  (*unfold "~ _".*)
  (* simpl. *)
  intros proof_of_False.
  exact proof_of_False.
Qed.

Theorem False_cannot_be_proven2 : ~False.
Proof.
  intros proof_of_False.
  elim proof_of_False.
Qed.

Theorem thm_true_imp_true : True -> True.
Proof.
  intros proof_of_True.
  exact I.
Qed.

Theorem thm_false_imp_false : False -> False.
Proof.
  intros.
  case H.
Qed.

Theorem thm_true_imp_false : ~(True -> False).
Proof.
  unfold not.
  intros True_implies_False.
  case (True_implies_False I).
Qed.

Theorem thm_true_imp_false_2 : ~(True -> False).
Proof.
  intros T_implies_F.
  refine (T_implies_F _).
    case I.
    case I.
    elim I.
    exact I.
Qed.

Theorem thm_true_imp_false_3 : ~(True -> False).
Proof.
  intros T_implies_F.
  pose (f := T_implies_F I).
  exact f.
Qed.

Theorem absurd2 : forall A C : Prop, A -> ~ A -> C.
Proof.
  intros A C.
  intros proof_of_A.
  intros not_A.
  unfold not in not_A.
  pose (f := not_A proof_of_A).
  (* unfold not.
  intros A_implies_False.
  pose (f := A_implies_False proof_of_A). *)
  case f.
Qed.

Theorem absurd2_2 : forall A C : Prop, A -> ~ A -> C.
Proof.
  intros A C.
  intros proof_of_A.
  intros not_A.
  pose (f := not_A proof_of_A).
  case f.
Qed.

Require Import Bool.

Definition eqb' (b1 b2:bool) : bool :=
  match b1, b2 with
    | true, true => true
    | true, false => false
    | false, true => false
    | false, false => true
  end.

Definition Is_true' (b:bool) :=
  match b with
    | true => True
    | false => False
  end.

(*
Theorem llala2 : forall b1 b2 : bool, eqb' b1 b2 = eqb b1 b2.
Proof.
  intros b1 b2.
  simpl.
  case b1.
    case b2.
      pose (resEqb' := eqb' b1 b2).
      pose (resEqb := eqb b1 b2).
      exact (eqb' true true = eqb true true).
*)

Theorem true_is_True: Is_true true.
Proof.
  unfold Is_true.
  simpl.
  exact I.
Qed.

Theorem not_true_is_True: not (Is_true false).
  unfold "~".
  intros is_true_false.
  simpl is_true_false.
  unfold Is_true.
  case is_true_false.
Qed.

Theorem not_eqb_true_false: ~(Is_true (eqb true false)).
Proof.
  simpl.
  (*
  unfold "~".
  intros proof_of_False.
  exact proof_of_False.
  *)
  exact False_cannot_be_proven.
Qed.

Theorem eqb_a_a : (forall a : bool, Is_true (eqb a a)).
Proof.
  intros a.
  case a.
    unfold Is_true.
    simpl.
    exact I.

    simpl.
    exact I. Qed.

Theorem thm_eqb_a_t: (forall a:bool, (Is_true (eqb a true)) -> (Is_true a)).
Proof.
  intros a.
  case a.
    simpl.
    intros.
    exact I.

    simpl.
    intros.
    case H.
Qed.

(*
Theorem thm_eqb_a_t_2: (forall a:bool, (Is_true (eqb a true)) -> (Is_true a)).
Proof.
  intros a.
  simpl.
  intros H.
  case a.
    simpl. trivial.

    simpl. simpl in H.

Qed.
*)

(* Inductive or (A B:Prop) : Prop :=
  | or_introl : A -> A \/ B
  | or_intror : B -> A \/ B
where "A \/ B" := (or A B) : type_scope. *)

Theorem left_or : (forall A B : Prop, A -> A \/ B).
Proof.
  intros A B.
  intros proof_of_A.
  (* exact (or_introl proof_of_A). *)
  pose (proof_of_A_or_B := or_introl proof_of_A : A \/ B).
  exact proof_of_A_or_B.
Qed.

Theorem right_or : (forall A B : Prop, B -> A \/ B).
  intros A B.
  intros proof_of_B.
  refine (or_intror _).
    exact proof_of_B.
Qed.

Theorem right_or2 : (forall A B : Prop, B -> A \/ B).
  intros A B.
  intros proof_of_B.
  refine (or_intror proof_of_B).
Qed.

Theorem or_commutes : (forall A B, A \/ B -> B \/ A).
Proof.
  intros A B.
  intros A_or_B.
  case A_or_B.
    intros proof_of_A.
    exact (or_intror proof_of_A).

    intros proof_of_B.
    exact (or_introl proof_of_B).
Qed.

(*
Inductive and (A B:Prop) : Prop :=
  conj : A -> B -> A /\ B

where "A /\ B" := (and A B) : type_scope.
*)

Theorem both_and : (forall A B : Prop, A -> B -> A /\ B).
Proof.
  intros A B.
  intros proof_of_A proof_of_B.
  refine (conj _ _).
    exact proof_of_A.
    exact proof_of_B.
Qed.
Extraction both_and.

Theorem and_commutes : (forall A B, A /\ B -> B /\ A).
Proof.
  intros A B.
  intros A_and_B.
  case A_and_B.
    intros proof_of_A.
    intros proof_of_B.
    exact (conj proof_of_B proof_of_A).
Qed.

Theorem and_commutes__again : (forall A B, A /\ B -> B /\ A).
Proof.
  intros A B.
  intros A_and_B.
  destruct A_and_B as [ proof_of_A proof_of_B].
  refine (conj _ _).
    exact proof_of_B.
    exact proof_of_A.
Qed.

(*
Infix "&&" := andb : bool_scope.
Infix "" := orb : bool_scope.
*)

(*
Definition iff (A B:Prop) := (A -> B) /\ (B -> A).
Notation "A <-> B" := (iff A B) : type_scope.
*)

Theorem orb_is_or : (forall a b, Is_true (orb a b) <-> Is_true a \/ Is_true b).
Proof.
  intros a b.
  unfold iff.

  refine (conj _ _).
    intros H.
    case a, b.
      simpl. exact (or_introl I).
      simpl. exact (or_introl I).
      simpl. exact (or_intror I).
      simpl. simpl in H. (* exact (or_introl H). *) case H.

    intros H.
    case a, b.
      simpl. exact I.
      simpl. exact I.
      simpl. exact I.
      simpl. simpl in H. case H. trivial. trivial.

  (*
  case a.
    case b.
      simpl.
      refine (conj _ _).
        intros.
        exact (or_introl I).

        intros.
        exact I.

      simpl.
      refine (conj _ _).
        intros.
        exact (or_introl I).

        intros.
        exact I.

    case b.
      simpl.
      refine (conj _ _).
        intros.
        exact (or_intror I).

        intros _.
        exact I.

      simpl.
      refine (conj _ _).
        intros f.
        exact (or_introl f).

        intros f_or_f.
        case f_or_f.
          intros f.
          exact f.

          intros f.
          exact f.
  *)
Qed.

Theorem andb_is_and : (forall a b, Is_true (andb a b) <-> Is_true a /\ Is_true b).
Proof.
  intros a b.
  unfold iff.
  refine (conj _ _).
    intros H.
    case a, b.
      simpl. exact (conj I I).
      simpl. simpl in H. case H.
      simpl. simpl in H. case H.
      simpl. simpl in H. case H.

    intros lala.
    case a,b.
      simpl. trivial.
      simpl in lala. destruct lala as [ A B]. case B. (* case lala. intros _ f. exact f. *)
      simpl. simpl in lala. case lala. intros f _. case f.
      simpl. simpl in lala. case lala. intros f _. case f.
Qed.

Theorem negb_is_not : (forall a, Is_true (negb a) <-> (~(Is_true a))).
Proof.
  intros a.
  unfold "<->".
  unfold not.
  (* case a. *)
  refine (conj _ _).
    case a.
      simpl. intros f _. case f.
      simpl. intros _ f. case f.

    case a.
      simpl. intros True_implies_False. exact (True_implies_False I).
      simpl. intros _. exact I.
Qed.

Print ex.

Print or.

(*
Inductive ex (A : Type) (P : A -> Prop) : Prop :=
  ex_intro : forall x : A, P x -> ex (A) P.
*)

(*

Notation "'exists' x .. y , p" := (ex (fun x => .. (ex (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' 'exists'  '/  ' x  ..  y ,  '/  ' p ']'")
  : type_scope.
*)

Definition basic_predicate : bool -> Prop
:=
  (fun a => Is_true (andb a true))
.

Theorem thm_exists_basics : (ex basic_predicate).
Proof.
  (*
  pose (witness := true).
  refine (ex_intro basic_predicate witness _).
    unfold basic_predicate.
    simpl.
    exact I.
  *)
(*
Unset Printing Notations.
  simpl.
SearchAbout .
Locate "exists".
Print ex.
Check ex.
Extraction ex.
  pose (witness := true).
  refine (ex_intro basic_predicate witness _).
    simpl.
    exact I.
    intros H.
    Check basic_predicate.
    exact (basic_predicate true).
*)
(*
refine (ex_intro basic_predicate true _).
  simpl.
  unfold basic_predicate.
  simpl.
  unfold Is_true.
  exact (I).
*)

refine (ex_intro _ true I).

Qed.

 Theorem thm_exists_basics__again : (exists a, Is_true (andb a true)).
Proof.
  pose (witness := true).
(*
  refine (ex_intro _ _ _).
  exact (Is_true (andb true true)).
*)
  refine (ex_intro _ witness _).
    simpl.
    exact I.
Qed.

Theorem thm_forall_exists : (forall b, (exists a, Is_true(eqb a b))).
Proof.
  intros b.
  case b.
    refine (ex_intro _ true I).
    refine (ex_intro _ false I).
Qed.

Theorem thm_forall_exists__again : (forall b, (exists a, Is_true(eqb a b))).
Proof.
  intros b.
  refine (ex_intro _ b _).
     exact (eqb_a_a b).
Qed.

Theorem thm_forall_exists__again2 : (forall (b : bool), (exists (a : bool), Is_true(eqb a b))).
Proof.
  intros b.
  refine ((ex_intro _) b _).
    case b.
      simpl.
      exact I.

      simpl.
      exact I.
Qed.

Theorem forall_exists : (forall P : Set->Prop, (forall x, ~(P x)) -> ~(exists x, P x)).
Proof.
  intros p.
  intros lala.
  unfold not.
  unfold not in lala.
  intros existsbaba.
  destruct existsbaba as [ ].
  pose (haha := lala x).
  pose (gaga := haha H).
  case gaga.
Qed.

Theorem forall_exists_2 : (forall P : Set->Prop, (forall x, ~(P x)) -> ~(exists x, P x)).
Proof.
  intros P forallXNotPX notExistsPX.
  unfold not in forallXNotPX, notExistsPX.
  case notExistsPX.
  intros x.
  intros Px.
  case (forallXNotPX x Px).

  (*
  intros P forallXNotPX notExistsPX.
  unfold not in forallXNotPX, notExistsPX.
  destruct notExistsPX.
  exact (forallXNotPX x H).
  *)
Qed.

Theorem exists_forall : (forall P : Set->Prop, ~(exists x, P x) -> (forall x, ~(P x))).
Proof.
  intros.
  unfold not.
  unfold not in H.
  intros Px.
  case H.
  exact (ex_intro P x Px).
Qed.

Theorem lalala_eq : (forall (A : Set) (x : A), eq x x).
Proof.
  intros.
  exact (eq_refl : eq x x).
Qed.

Theorem thm_eq_sym : (forall x y : Set, x = y -> y = x).
Proof.
intros x y.
intros eq_x_y.
(*
case eq_x_y.
exact eq_refl.
*)
destruct eq_x_y.
exact eq_refl.
Qed.

Theorem thm_eq_trans : (forall x y z: Set, x = y -> y = z -> x = z).
Proof.
intros.
destruct H, H0.
exact eq_refl.
Qed.

(*Require Coq.*)
Require Coq.Setoids.Setoid.
Theorem thm_eq_trans__again : (forall x y z: Set, x = y -> y = z -> x = z).
Proof.
intros.
rewrite H.
rewrite <- H0.
exact eq_refl.
Qed.

Theorem andb_sym : (forall a b, a && b = b && a).
Proof.
intros.
case a,b.
  simpl. exact eq_refl.
  simpl. exact eq_refl.
  simpl. exact eq_refl.
  simpl. exact eq_refl.
Qed.

Theorem neq_nega: (forall a, a <> (negb a)).
Proof.
intros.
unfold not.
case a.
  unfold negb. discriminate.
  unfold negb. intros. discriminate H.
Qed.

Theorem plus_2_3 : (S (S O)) + (S (S (S O))) = (S (S (S (S (S O))))).
Proof.
  simpl.
  (* exact (eq_refl 5). *)
  exact (eq_refl (S (S (S (S (S O)))))).
Qed.

Theorem plus_O_n : (forall n, O + n = n).
Proof.
  intros.
  simpl.
  exact (eq_refl n).
Qed.

Theorem associativity_of_plus : (forall (n : nat) (m : nat), n + m = m + n).
Proof.
  admit.
Qed.

Theorem plus_n_O : (forall n, n + O = n).
Proof.
  intros.
  (* case n. *)
  (*
  induction n.
    exact eq_refl.

    simpl.
    rewrite IHn.
    exact eq_refl.
  *)
  (* apply nat_ind with (n := n). *)
  elim n.
    (* apply eq_refl. *)
    exact eq_refl.

    intros m H.
    simpl.
    rewrite H.
    exact (eq_refl).
Qed.

Theorem plus_sym: (forall n m, n + m = m + n).
Proof.
  intros n.
  elim n.
    intros m.
    elim m.
      simpl. exact (eq_refl).

      intros.
      simpl.
      rewrite <- H.
      simpl.
      exact (eq_refl (S n0)).

    intros.
    simpl.
    simpl H.
    rewrite (H m).
    elim m.
      simpl. exact (eq_refl).

      intros.
      simpl.
      rewrite H0.
      exact (eq_refl).
Qed.

Require Import List.

Theorem cons_adds_one_to_length :
   (forall A:Type, (forall (x : A) (lst : list A),
    length (x :: lst) = (S (length lst)))
   ).
Proof.
  intros.
  simpl.
  exact (eq_refl).
Qed.

(*
Definition hd (A : Type) (default : A) (l : list A) : A
:=
  match l with
    | nil => default
    | h :: _ => h
  end.
*)

Definition my_hd_for_nat_lists : list nat -> nat
:=
  hd 0.

Compute my_hd_for_nat_lists nil.

Compute my_hd_for_nat_lists (5 :: 4 :: nil).

Theorem correctness_of_hd :
   (forall A:Type,
   (forall (default : A) (x : A) (lst : list A),
   (hd default nil) = default /\ (hd default (x :: lst)) = x)).
Proof.
  intros.
  simpl.
  refine (conj _ _).
    exact eq_refl.
    exact eq_refl.
Qed.

Definition hd_error (A : Type) (l : list A)
:=
  match l with
    | nil => None
    | x :: _ => Some x
  end.

Compute hd_error nat nil.

Compute hd_error nat (5 :: 4 :: nil).

Theorem correctness_of_hd_error :
   (forall A:Type,
   (forall (x : A) (lst : list A),
   (hd_error A nil) = None /\ (hd_error A (x :: lst)) = Some x)).
Proof.
  intros.
  simpl.
  refine (conj _ _).
    exact eq_refl.
    exact eq_refl.
Qed.

Definition hd_never_fail (A : Type) (lst : list A) (safety_proof : lst <> nil)
  : A
:=
  (match lst as b return (lst = b -> A) with
    | nil => (fun foo : lst = nil =>
                   match (safety_proof foo) return A with
                   end
                )
    | x :: _ => (fun foo : lst = x :: _ =>
                   x
                )
  end) eq_refl.

Theorem cons_cant_equal_nil : (forall (A: Type), (forall (x : A) (rest : list A),
  (x :: rest) <> nil)).
Proof.
  unfold not.
  intros.
  discriminate H.
Qed.

Goal forall A B C:Prop, A /\ B /\ C \/ B /\ C \/ C /\ A -> C.
  intros.
  decompose [and or] H.
    assumption.
    assumption.
    assumption.
Qed.

Theorem correctness_of_hd_never_fail :
   (forall A:Type,
   (forall (x : A) (rest : list A),
   (exists safety_proof : ((x :: rest) <> nil),
      (hd_never_fail A (x :: rest) safety_proof) = x))).
Proof.
  unfold not.
  intros.
  assert (witness : ((x :: rest) = nil -> False)).
    exact (cons_cant_equal_nil A x rest).

  refine (ex_intro _ witness _).
  simpl.
  exact (eq_refl).
Qed.

Definition tl_error (A : Type) (l : list A)
  : option (list A)
:= match l with
   | nil => None
   | _ :: tail => Some tail
   end.

Theorem correctness_of_tl_error :
   (forall A:Type,
   (forall (x : A) (lst : list A),
   (tl_error A nil) = None /\ (tl_error A (x :: lst)) = Some lst)).
Proof.
  intros.
  refine (conj _ _).
    simpl.  trivial.
    simpl.  trivial.
Qed.

Theorem hd_tl :
   (forall A:Type,
   (forall (default : A) (x : A) (lst : list A),
   (hd default (x::lst)) :: (tl (x::lst)) = (x :: lst))).
Proof.
  intros.
  simpl.
  trivial.
Qed.

Theorem app_nil_l : (forall A:Type, (forall l:list A, nil ++ l = l)).
Proof.
  intros.
  simpl.
  trivial.
Qed.

Theorem app_nil_r : (forall A:Type, (forall l:list A, l ++ nil = l)).
Proof.
  intros.
  elim l.
    simpl. trivial.

    intros.
    simpl.
    rewrite H.
    trivial.
Qed.

Theorem app_comm_cons : forall A (x y:list A) (a:A), a :: (x ++ y) = (a :: x) ++ y.
Proof.
  intros.
  simpl.
  trivial.
Qed.

Theorem app_assoc : forall A (l m n:list A), l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros.
  simpl.
  case l,m,n.
    simpl. trivial.

    simpl. trivial.

    simpl. trivial.

    simpl. trivial.

    simpl.
    replace (app l nil) with (l).
    replace (app l nil) with (l).
    trivial.

    pose (witness := app_nil_r A l).
    rewrite (witness).
    trivial.

    pose (witness := app_nil_r A l).
    rewrite (witness).
    trivial.

    simpl.
    replace (app l nil) with (l).
    trivial.

    pose (witness := app_nil_r A l).
    rewrite (witness).
    trivial.

    simpl.

    admit.

    admit.
Qed.

Theorem app_cons_not_nil : forall A (x y:list A) (a:A), nil <> x ++ a :: y.
Proof.
  intros.
  unfold not.
  intros.
  case x, y.
    simpl in H.
    discriminate H.

    discriminate H.

    discriminate H.

    discriminate H.
Qed.


Inductive day : Type :=
| sun : day
| mon : day
| tue : day
| wed : day
| thu : day
| fri : day
| sat : day.

Let next_day d :=
  match d with
  | sun => mon
  | mon => tue
  | tue => wed
  | wed => thu
  | thu => fri
  | fri => sat
  | sat => sun
  end.

Definition prev_day d :=
  match d with
  | sun => sat
  | mon => sun
  | tue => mon
  | wed => tue
  | thu => wed
  | fri => thu
  | sat => fri
  end.

Theorem wed_after_tue : next_day tue = wed.
Proof.
  auto.
Qed.

Theorem wed_after_tue' : next_day tue = wed.
Proof.
  simpl. trivial.
Qed.

Theorem day_never_repeats : forall d : day, next_day d <> d.
Proof.
  intros d. destruct d.
  all: discriminate.
Qed.

Theorem day_never_repeats'' : forall d : day, next_day d <> d.
Proof.
  intros d. destruct d; discriminate.
Qed.

Theorem mon_preceds_tues : forall d : day,
  next_day d = tue -> d = mon.
Proof.
  intros d next_day_is_tue.
  destruct d.
  all: discriminate || trivial.
Qed.


From Coq Require Export List.
From Coq Require Import Nat Recdef Lia.
Export ListNotations.

(* Verification of a simple SAT solver
 * -----------------------------------
 *)

(* Types defining the problem and solution
   ---------------------------------------

   The solver takes as input a query in CNF form, representing a conjunction of
   clauses, where each clause represents a conjunction of literals.

   Each literal represents a boolean variable (or its negation), and the goal of
   the solver is to produce a boolean assignation for each literal present in
   the input formula.
*)

(* A literal. [Pos n] corresponds to literal n, and [Neg n] to its negation.
*)
Inductive literal :=
  | Pos : nat -> literal
  | Neg : nat -> literal.

(* A clause represents a disjunction of literals *)
Definition clause := list literal.

(* A SAT problem in Conjunctive Normal Form:
   it corresponds to a conjunction of clauses *)
Definition cnf := list clause.

(* Example:

   The following cnf:
   [[Pos 1; Neg 2];
    [Neg 1; Pos 3; Pos 4]]

   corresponds to the boolean formula:
   (x1 \/ ~x2) /\
   (~x1 \/ x3 \/ x4)

   where x1, x2, x3 and x4 are boolean variables.
*)

(* The goal of the solver is to produce an assignment. We represent it as a list
   of literals, which correspond to the literals that are taken to be true.

   In other words, if the assignment list contains [Neg 3], then the boolean
   variable x3 should be assigned to false.

   Note: we generally only want to consider "valid" assignments, which do not
   include both a literal and its negation. We will come back to this later (see
   [valid_assignment]).
*)
Definition assignment := list literal.

(* In fact, the solver we implement will return a list of all possible
   solutions.

   (This would be terribly inefficient if we were to run the solver and compute
   the full list of solutions, but we can instead compute it using a
   call-by-name strategy (thus, the list of solutions becomes a lazy list), and
   only retrieve the first solution of the list.)
*)
Definition solutions := list assignment.

(* Helper functions and lemmas
   ---------------------------

   Mainly define the (computable) equality function on literals,
   literal negation, and associated lemmas.
*)

(* Some auxiliary functions on literals. *)
Definition lit_eqb (l1 l2: literal): bool :=
  match l1, l2 with
  | Pos u, Pos v
  | Neg u, Neg v => u =? v
  | _, _ => false
  end.

Lemma lit_eqb_eq l1 l2: lit_eqb l1 l2 = true <-> l1 = l2.
Proof.
  destruct l1, l2; cbn; try now (split; congruence).
  all: rewrite PeanoNat.Nat.eqb_eq; split; congruence.
Qed.

Lemma lit_eqb_neq l1 l2 : lit_eqb l1 l2 = false <-> l1 <> l2.
Proof.
  destruct l1, l2; cbn; try now (split; congruence).
  all: rewrite PeanoNat.Nat.eqb_neq; split; congruence.
Qed.

Definition lit_neg (l: literal): literal :=
  match l with
  | Pos n => Neg n
  | Neg n => Pos n
  end.

Lemma lit_neg_idemp (l: literal) : lit_neg (lit_neg l) = l.
Proof. destruct l; auto. Qed.

(* The size of a CNF, defined as the the number of its literals.
   Used to prove termination of the solver. *)
Fixpoint cnf_size (c: cnf): nat :=
  match c with
  | [] => 0
  | cl :: rest => length cl + cnf_size rest
  end.

Ltac case_if :=
  match goal with
    |- context [if ?b then _ else _] =>
    destruct b eqn:?
  end.

Lemma existsb_lit_notin l c : existsb (lit_eqb l) c = false <-> ~ In l c.
Proof.
  split.
  { intros ? ?. enough (existsb (lit_eqb l) c = true) by congruence.
    apply existsb_exists. eexists; split; eauto. apply lit_eqb_eq; auto. }
  { intros HH. destruct (existsb (lit_eqb l) c) eqn:Heq; auto. exfalso.
    apply existsb_exists in Heq as [? [? ->%lit_eqb_eq]]. apply HH. auto. }
Qed.

(* The solver definition
   ------------------------

   This is the implementation of the SAT solver itself.

   Its main function is [resolve]. It relies on the [propagate] auxiliary
   function, which implements literal propagation.

   The high-level intuition is that [propagate l c] takes a literal [l] and a
   cnf [c], and, assuming that [l] is to be assigned to true, simplifies [c]
   into a new cnf which does not rely on [l] or [lit_neg l] anymore.

   The [_variant] lemmas can be ignored, they are only used in the (included)
   proof of termination for defining [resolve].
*)

Definition remove_lit (l: literal) (cl: clause) :=
  List.filter (fun l' => negb (lit_eqb l l')) cl.

Fixpoint propagate (l: literal) (c: cnf) : cnf :=
  match c with
  | [] => []
  | cl :: rest =>
    if List.existsb (lit_eqb l) cl
    then propagate l rest
    else (remove_lit (lit_neg l) cl) :: (propagate l rest)
  end.

Lemma remove_lit_variant (l: literal) (cl: clause):
  length (remove_lit l cl) <= length cl.
Proof.
  induction cl as [| ? ? IHcl]; cbn; try case_if; cbn; auto.
  unfold remove_lit in IHcl. lia.
Qed.

Lemma propagate_variant (l: literal) (c: cnf):
  cnf_size (propagate l c) <= cnf_size c.
Proof.
  induction c as [| cl c IHc]; cbn; auto.
  case_if; cbn; try lia. pose proof (remove_lit_variant (lit_neg l) cl).
  lia.
Qed.

Function resolve (c: cnf) {measure cnf_size c}: solutions :=
  match c with
  | [] => [[]]
  | cl :: rest =>
    match cl with
    | [] => []
    | l :: cl' =>
      let c1 := propagate l rest in
      let c2 := propagate (lit_neg l) (cl' :: rest) in
      let solutions1 := List.map (List.cons l) (resolve c1) in
      let solutions2 := List.map (List.cons (lit_neg l)) (resolve c2) in
      solutions1 ++ solutions2
    end
  end.
Proof.
  (* Proof of termination *)
  all: intros c cl rest l cl'; intros -> ->; cbn.
  { destruct (existsb (lit_eqb (lit_neg l))); cbn.
    - pose proof (propagate_variant (lit_neg l) rest). lia.
    - pose proof (remove_lit_variant (lit_neg (lit_neg l)) cl').
      pose proof (propagate_variant (lit_neg l) rest). lia. }
  { pose proof (propagate_variant l rest). lia. }
Defined.

(* NB: Function generates an induction principle for [resolve], and a lemma to
   unfold its body. You will need to use them. *)
Check resolve_ind.
Check resolve_equation.

(* Interpretation of clauses and cnf
   ------------------------------------

   Given an assignment, we can "evaluate" a clause/a cnf as a boolean.
   This is done by the [interp] functions below.
 *)

Fixpoint interp_clause (cl: clause) (a: assignment): bool :=
  match cl with
  | [] => false
  | l :: cl' => List.existsb (lit_eqb l) a || interp_clause cl' a
  end.

Fixpoint interp (c: cnf) (a: assignment): bool :=
  match c with
  | [] => true
  | cl :: rest => interp_clause cl a && interp rest a
  end.

(* To prove correctness of [resolve] in the unsat case we will need to define
what a *valid* assignment is, i.e. one that does not contain both a literal and
its negation. *)
Definition valid_assignment (a: assignment) :=
  forall (l: literal),
    List.In l a ->
    ~ List.In (lit_neg l) a.

    From Coq Require Import List Nat Recdef Lia.
    Import ListNotations.

    (* 1) Correctness of solutions returned by [resolve]
    -------------------------------------------------

       A first correctness lemma: assignments produced by [resolve] are correct wrt
       [interp].
    *)

    (* The core of the proof relies on a similar correctness lemma for [propagate]. *)
    Lemma propagate_correct (a: assignment) (l: literal) (c: cnf) :
      interp (propagate l c) a = true ->
      interp c (l :: a) = true.
    Admitted.

    Lemma resolve_correct (c: cnf) (a: assignment):
      List.In a (resolve c) ->
      interp c a = true.
    Admitted.

    (* 2) Correctness of [resolve] in the unsat case
       ---------------------------------------------

       If [resolve] returns no solutions (the empty list), then the input CNF should
       be unsatisfiable.

       To formally state this property, we first need to define what a *valid*
       assignment is, i.e. one that does not contain both a literal and its negation.
    *)

    (* You will need to formulate a lemma for [propagate], in a similar vein as
       [propagate_correct].

       However, there's an extra subtlety here. Think: does the following hold
       if (lit_neg) is in a?

         interp (propagate l c) a = false ->
         interp c (l :: a) = false
    *)

    Lemma resolve_unsat_correct (c: cnf):
      resolve c = [] ->
      forall a, valid_assignment a -> interp c a = false.
    Admitted.

    (* ==== This part is OPTIONAL and it is NOT graded. === *)
    (* ==== We keep this for the sake of completeness of the specification === *)
    (* ==== but exclude it from grading to keep the task complexity at bay. === *)

    (* 3) Validity of assignments produced by [resolve]
       ------------------------------------------------

       To complete the proof of the solver, we finally need to prove that it only
       produces valid assignments. Otherwise, a solver could simply return an
       assignment containing every literal and its negation, which would be
       considered as a valid solution according to [interp].

       The key idea is to prove that, for any literal that appears in an assignment
       returned by [resolve c], then either the literal or its negation were present
       in [c].
    *)

    (* useful helper lemmas *)
    Lemma valid_assignment_nil : valid_assignment [].
    Proof. intros ? ?. cbn in *. auto. Qed.

    Lemma valid_assignment_cons a l:
      valid_assignment a ->
      ~ List.In (lit_neg l) a ->
      valid_assignment (l :: a).
    Proof.
      intros Hv Ha l'. cbn. intros [->|Hl'].
      { intros HH. apply Ha. destruct HH; auto. exfalso.
        destruct l'; cbn in *; congruence. }
      { intros [?|HH].
        { subst l. rewrite lit_neg_idemp in Ha. auto. }
        { eapply (Hv l' Hl'); auto. } }
    Qed.

    Lemma resolve_valid (c: cnf) (a: assignment):
      List.In a (resolve c) ->
      valid_assignment a.
    Admitted.


(*-------------Description ------------------------------------------------------

This file implements maps on lists. Here we define functions to calculate range
of a function on list l. We also define one-one function predicate and its boolean
counterpart.

Following are the notions defined in this file:

 img f l                  : range set of f on list l
 one_one_on l f             : f is one one on l
 one_one_onb l f            : boolean counterpart of (one_one_on l f)

Lemma one_one_onP (l:list A) (f: A->B)(Hl: NoDup l):
    reflect (one_one_on l f)(one_one_onb l f).

Furthermore, we have results relating the cardinality of domain and range
for various kinds of functions (many one/one one).

---------------------------------------------------------------------------------*)

Require Export SetReflect.
Require Export OrdList.
Require Export OrdSet.

Set Implicit Arguments.

Section List_maps.

  Context { A B: Type }.

  (*------- This definition of map on lists is from standard library --------------*)

  (*  Lemma map_cons (x:A)(l:list A) : map (x::l) = (f x) :: (map l).

      Lemma in_map :
      forall (l:list A) (x:A), In x l -> In (f x) (map l).

      Lemma in_map_iff : forall l y, In y (map l) <-> exists x, f x = y /\ In x l.

      Lemma map_length : forall l, length (map l) = length l.   *)

  Lemma map_intro (f: A-> B): forall (l:list A) (x:A), In x l -> In (f x) (map f l).
  Proof. apply in_map. Qed.

  Lemma map_intro1 (f: A-> B)(l: list A) (y:B): (exists x, In x l /\ y = f x) -> In y (map f l).
  Proof. { intros h1. apply in_map_iff. destruct h1 as [x h1].
           destruct h1 as [h1 h2]. exists x. split;auto. } Qed.

  Lemma map_elim (f: A-> B)(l: list A) (y:B): In y (map f l) -> (exists x, In x l /\ y = f x).
  Proof. { intros h1. apply in_map_iff in h1 as h2.
           destruct h2 as [x h2]. destruct h2 as [h2a h2].
           exists x. split;auto. } Qed.
  Lemma map_length_same (f: A-> B)(l: list A): |l| = |map f l|.
  Proof. symmetry;apply map_length. Qed.

  Hint Immediate map_elim map_intro map_intro1 map_length_same: core.

End List_maps.

Hint Immediate map_elim map_intro map_intro1 map_length_same: core.

Section Set_maps.
  Context { A B: ordType }.

  Lemma EM_A: forall x y: A, x=y \/  x<>y.
  Proof.  eauto.  Qed.
  Lemma EM_B: forall x y:B, x=y \/ x<>y.
  Proof. eauto.  Qed.

  Fixpoint img (f:A->B) (l:list A): list B:= match l with
                                        | nil => nil
                                        | a1::l1 => add (f a1) (img f l1)
                                              end.

  Lemma IsOrd_img (f:A->B) (l:list A):  IsOrd (img f l).
  Proof. { induction l. simpl. constructor. simpl. eauto. } Qed.

  Lemma NoDup_img (f:A->B) (l:list A):  NoDup (img f l).
    Proof. cut (IsOrd (img f l)). eauto. apply IsOrd_img. Qed.

  Lemma img_intro1(f: A->B)(l: list A)(a:A)(y: B): In y (img f l)-> In y (img f (a::l)).
    Proof. simpl. eapply set_add_intro1. Qed.
  Lemma img_intro2 (f: A->B)(l: list A)(x:A): In x l -> In (f x) (img f l).
  Proof.  { induction l. simpl.  tauto.
          cut (x=a \/ x <> a).
          intro H;destruct H as [Hl | Hr].
          { intro H. rewrite Hl. simpl. eapply set_add_intro2. auto. }
          { intro H. cut (In x l). intro H1. eapply img_intro1;eauto.
            eapply in_inv2;eauto.  } eauto. } Qed.

  Lemma img_elim (f:A->B) (l: list A)(a0:A)(fa:B): In (fa) (img f (a0::l))->
                                                    fa = f(a0) \/ In fa (img f l).
    Proof. simpl. eapply set_add_elim. Qed.

  Lemma img_elim2 (f:A->B) (l: list A)(a0:A)(fa:B): In (fa) (img f (a0::l))->
                                                   fa <> f(a0) -> In fa (img f l).
  Proof. simpl. eapply set_add_elim2.  Qed.

  Lemma img_elim3 (f:A->B)(l:list A)(a:A): ~ In a l -> In (f a) (img f l) ->
                                           (exists y, In y l /\ f a = f y).
  Proof. { intros H H1. induction l. inversion H1.
         assert (H2: ~ In a l). intro H2; apply H. simpl;tauto.
         cut ( f a = f a0 \/ f a <> f a0 ). intro H3; destruct H3 as [H3a | H3b]. exists a0.
         split; auto. assert (H4: In (f a) (img f l)). eapply img_elim2.
         eapply H1. exact H3b. assert (H5: exists y : A, In y l /\ f a = f y). eauto.
         destruct H5 as [y0 H5]. exists y0. split;  simpl. tauto. tauto.
         eapply EM_B. } Qed.
  Lemma img_elim4 (f: A->B)(l: list A)(b:B): In b (img f l)-> (exists a, In a l /\ b = f a).
  Proof. { induction l.
         { simpl. tauto. }
         { intro H. apply img_elim in H as H1. destruct H1.
           { exists a. split;auto. }
           { apply IHl in H0 as H1.
             destruct H1 as [a' H1]; destruct H1 as [H1 H2].
             exists a'. split;auto. } } } Qed.

  Hint Resolve IsOrd_img NoDup_img : core.
  Hint Resolve img_intro1 img_intro2 img_elim: core.
  Hint Resolve img_elim2 img_elim3 img_elim4: core.

  Lemma map_is_img (f: A-> B)(l: list A): IsOrd (map f l) -> (map f l) = (img f l).
  Proof. { intro h1. apply set_equal. auto. auto.
           split.
           { intros y h2. assert (h3: exists x, In x l /\ y = f x). auto.
             destruct h3 as [x h3]; destruct h3 as [h3a h3]. subst y; auto. }
           { intros y h2. assert (h3: exists x, In x l /\ y = f x). auto.
             destruct h3 as [x h3]; destruct h3 as [h3a h3]. subst y; auto. } } Qed.

  Hint Immediate map_is_img: core.

  Lemma funP (f: A->B)(x y: A): f x <> f y -> x <> y.
  Proof. intros H H1. apply H;rewrite H1; auto. Qed.

  Definition one_one (f: A->B): Prop:= forall x y, x <> y -> f x <> f y.

  Lemma one_oneP1 (f:A->B): one_one f -> forall x y, f x = f y -> x =y.
  Proof. { unfold one_one;intros H x y H1. elim (EM_A x y). tauto.
           intro H2; absurd (f x = f y); auto. } Qed.

  Hint Immediate one_oneP1: core.

  Definition one_one_on (l: list A) (f: A-> B):Prop:= forall x y, In x l-> In y l ->  x<>y -> f x <> f y.

  Lemma one_one_on_elim (l:list A)(f: A-> B): one_one_on l f ->
                                         (forall x y, In x l-> In y l-> f x = f y -> x = y).
  Proof. { unfold one_one_on. intros H x y H1 H2. elim (EM_A x y). tauto.
           intros H3 H4. absurd (f x = f y); auto. } Qed.
  Lemma one_one_on_intro(l:list A)(f: A-> B): (forall x y, In x l-> In y l-> f x = f y -> x = y) ->
                                         (one_one_on l f).
  Proof. { intros H.  unfold one_one_on.
         intros x y H1 H2 H3 H4. apply H3. auto. } Qed.

  Lemma one_one_on_nil (f:A->B): one_one_on nil f.
  Proof. unfold one_one_on. intros x y H H0 H1 H2. inversion H. Qed.

  Lemma one_one_on_intro1(l:list A) (f: A->B)(a:A):
             (~ In (f a) (img f l)) -> (one_one_on l f) -> one_one_on (a::l) f.
  Proof. { unfold one_one_on. intros H H1.
         intros x y H2 H3. destruct H2; destruct H3.
         rewrite <- H0; rewrite <- H2.  tauto.
         rewrite <- H0. intros H3 H4. assert (H5: In (f a) (img f l)). rewrite H4.
         apply img_intro2;auto. absurd (In (f a) (img f l)); assumption.
         rewrite <- H2. intros H3 H4. absurd (In (f a) (img f l)). assumption.
         rewrite <- H4. apply img_intro2;auto. apply H1; auto. } Qed.

  Lemma one_one_on_elim1 (l:list A) (f: A->B)(a: A): one_one_on (a::l) f -> one_one_on l f.
  Proof. { unfold one_one_on.  intro H. intros x y H1 H2. eapply H; auto. } Qed.

  Lemma one_one_on_elim2 (l:list A) (f: A->B)(a: A)(Hl: NoDup (a::l)):
    one_one_on (a::l) f -> ~ In (f a)(img f l).
  Proof. { unfold one_one_on.  intros H H1.
         assert (H2: (exists y, In y l /\ f a = f y)).
         { eapply img_elim3. intro H2; inversion Hl;contradiction. auto. }
         destruct H2 as [b H2]; destruct H2 as [H2 H3].
         eapply H with (x:=a)(y:=b); auto. intro H4. rewrite <- H4 in H2.
         inversion Hl;contradiction. } Qed.

  Hint Immediate one_one_on_nil one_one_on_elim one_one_on_elim1 one_one_on_elim2 : core.
  Hint Immediate one_one_on_intro one_one_on_intro1: core.

  Lemma NoDup_map (f:A->B) (l:list A): NoDup l-> one_one_on l f-> NoDup (map f l).
  Proof. { induction l as [| a l'].
           { simpl. auto. }
           { intros h1 h2. simpl.
             apply nodup_intro.
             { intro h3.
               assert (h3a: exists b, In b l' /\ (f a) = (f b)).
               { auto. } destruct h3a as [b h3a]. destruct h3a as [h3a h3b].
               unfold one_one_on in h2.
               absurd (f a = f b). apply h2. auto. auto. intros h4. subst b.
               absurd (In a l'); auto. auto. }
             apply IHl'. eauto. eauto. } } Qed.

  Hint Resolve NoDup_map: core.

  Lemma map_IsOrd (f: A->B)(l:list A):
    IsOrd l -> (forall x y, In x l-> In y l-> x <b y -> f x <b f y)-> IsOrd (map f l).
  Proof. { induction l as [|a l'].
           { intros h1 h2. simpl. constructor. }
           { intros h1 h2. simpl. apply IsOrd_intro.
             apply IHl'. eauto. intros x y hx hy;apply h2;eauto.
             intros fx h3. assert(h4: exists x, In x l' /\ fx = f x). auto.
             destruct h4 as [x h4]. destruct h4 as [h4 h5].
             subst fx. apply h2;eauto. } } Qed.

  Hint Resolve map_IsOrd: core.

  Fixpoint one_one_onb (l: list A) (f: A->B): bool:=
    match l with
    |nil => true
    | a1::l1 => (negb ( memb (f a1) (img f l1))) && (one_one_onb l1 f)
    end.

   Lemma one_one_onP (l:list A) (f: A->B)(Hl: NoDup l):
    reflect (one_one_on l f)(one_one_onb l f).
  Proof. { apply reflect_intro. split.
         { induction l.
           { unfold one_one_onb. reflexivity. }
           { intro H. simpl one_one_onb. apply /andP. split. cut (~ In (f a)(img f l)).
             intro H1. assert (H2:  memb (f a) (img f l) = false ). apply /membP.
             auto. rewrite H2. simpl. reflexivity. eapply one_one_on_elim2.
             apply Hl. auto. apply IHl.
             eauto. eauto. } }
         { induction l.
           { auto.  }
           { simpl. move /andP. intro H; destruct H as [H H1].
             apply one_one_on_intro1.
             intro H2. unfold negb in H.
             replace (memb (f a) (img f l)) with true in H. inversion H.
             symmetry; apply /membP; eauto. apply IHl. eauto. apply H1. } }  } Qed.

  (*--------- Some more properties of imgs-----------------------------------*)

  Lemma one_one_img_elim (l: list A)(f: A->B)(x: A):
    one_one f -> In (f x) (img f l) -> In x l.
  Proof. { intros H H1. assert (H2: exists a, In a l /\ f x = f a). auto.
         destruct H2 as [a H2]. destruct H2 as [H2 H3].
         cut (x = a). intros; subst x; auto. eauto. } Qed.

  Lemma img_subset (l s: list A)(f: A->B): l [<=] s -> (img f l) [<=] (img f s).
  Proof. { intros H fx H1. assert (H2: exists x, In x l /\ fx = f x). auto.
         destruct H2 as [x H2]. destruct H2 as [H2 H3]. subst fx; auto. } Qed.

  Lemma img_size_less (l: list A)(f: A->B): |img f l| <= |l|.
  Proof.  { induction l.
          { simpl;auto. }
          { simpl. assert (H: (| add (f a) (img f l) |) <= S (| img f l |)).
            auto. omega. } } Qed.

  Lemma img_size_same (l: list A)(f: A->B): NoDup l -> one_one_on l f-> |l|=| img f l|.
  Proof.  { induction l.
          { simpl. auto. }
          { intros H H1.
            assert (Hl: NoDup l). eauto.
            assert (H1a: one_one_on l f). eauto.
            assert (H2: (| l |) = (| img f l |)). auto.
            simpl. assert (H3: ~ In (f a) (img f l)). auto.
            rewrite H2; symmetry;auto. }  } Qed.

  Hint Resolve img_subset img_size_less img_size_same: core.

  Lemma img_strict_less (l: list A)(f: A->B):
    NoDup l -> (|img f l| < |l|) -> ~ one_one_on l f.
  Proof. intros H H1 H2. assert(H3: |l|=| img f l|). auto. omega. Qed.

  Hint Immediate one_one_img_elim  img_strict_less : core.

  Lemma one_one_on_intro2 (l: list A)(f: A->B):
    NoDup l -> (|img f l| = |l|)->  one_one_on l f.
  Proof.  { induction l.
          { simpl; auto. }
          { intros H H0.
            assert (Ha: NoDup l). eauto.
            assert (Hb: ~ In a l ). auto.
            assert (H1: |img f l| = |l|).
            { match_up  (| img f l |)  (| l |).
              { auto. }
              { assert ((| img f (a :: l) |) <b (| a :: l |)).
                { move /ltP in H1. apply /ltP. simpl.
                  cut ((| add (f a) (img f l) |) <= S (|img f l|)). omega.
                  auto. } by_conflict. }
              { assert (H2: |img f l| <= |l|). auto.
                move /lebP in H2. auto. } }
            assert (H2: one_one_on l f). auto.
            assert (H3: ~ In (f a) (img f l)).
            { intro H3.
              assert (H4: img f (a :: l) = (img f l)).
              { simpl. eapply add_same. auto. auto. }
              rewrite H4 in H0. rewrite H1 in H0. simpl in H0. omega. } auto. } } Qed.

  Lemma one_one_on_intro3 (l s: list A)(f: A-> B): s [<=] l -> one_one_on l f -> one_one_on s f.
  Proof. intros H0 H1; unfold one_one_on; auto. Qed.

  Hint Immediate one_one_on_intro2 one_one_on_intro3 : core.

  (* ------------ set maps and set add interaction ------------------------ *)

  Lemma img_add (a: A)(l: list A)(f: A-> B): img f (add a l) = add (f a) (img f l).
  Proof. { apply set_equal;auto.
         induction l.
         { simpl. auto. }
         {  simpl.
           assert (H:  img f (add a l) = add (f a) (img f l)).
           apply set_equal; auto.
           destruct IHl as [IHl IHl1].  match_up a  a0.
           { subst a. simpl. auto. }
           { simpl. auto. }
           { simpl. rewrite H. auto. } }  } Qed.

  Lemma img_same (l: list A) (f g: A->B): (forall x, In x l -> f x = g x)-> (img f l = img g l).
  Proof. {  induction l.
         { simpl; auto. }
         { intro h1. simpl. replace (g a) with (f a). replace (img g l) with (img f l).
           auto. apply IHl. intros x h2. apply h1; auto. apply h1; auto. } } Qed.

  Hint Resolve img_add img_same: core.

  Lemma img_inter1 (l s: list A)(f: A-> B): img f (l [i] s) [<=] (img f l) [i] (img f s).
  Proof. { intros y hy.
           assert(h1: exists x, In x (l [i] s) /\ y = f  x); auto.
           destruct h1 as [x h1]. destruct h1 as [h1a h1].
           cut (In y (img f s)). cut (In y (img f l)). auto.
           subst y. cut (In x l); auto. eauto.
           subst y. cut (In x s); auto. eauto. } Qed.

  Lemma img_inter2 (l s: list A)(f: A-> B): one_one_on (l [u] s) f ->
                                             img f (l [i] s) = (img f l) [i] (img f s).
  Proof. { intros h. apply set_equal. all: auto.
           split. apply img_inter1. intros y h1.
           assert (h1a: In y (img f l)). eauto.
           assert (h1b: In y (img f s)). eauto.
           assert (hx1: exists x, In x l /\ y = f x). auto.
           destruct hx1 as [x1 hx1]. destruct hx1 as [hx1 h2].
           assert (hx2: exists x, In x s /\ y = f x). auto.
           destruct hx2 as [x2 hx2]. destruct hx2 as [hx2 h3].
           subst y. assert (h4: x1 = x2).
           cut (In x1 (l [u] s)). cut (In x2 (l [u] s)). eauto.
           all: auto.
           assert (h5: In x1 (l [i] s)). rewrite <- h4 in hx2; auto. auto. } Qed.

  Lemma img_union (l s: list A)(f: A-> B): img f (l [u] s) = (img f l) [u] (img f s).
  Proof.  { apply set_equal. all: auto.
            split.
            { intros y h1.
              assert (hx1: exists x, In x (l [u] s) /\ y = f x). auto.
              destruct hx1 as [x1 hx1]. destruct hx1 as [hx1 h2].
              assert (h3: In x1 l \/ In x1 s). auto. destruct h3 as [h3 | h3].
              cut (In y (img f l)). auto. subst y. auto.
              cut (In y (img f s)). auto. subst y. auto. }
            { intros y h1.
              assert (h2: In y (img f l) \/ In y (img f s)). auto.
              destruct h2 as [h2a | h2b].
              { assert (hx1: exists x, In x l /\ y = f x). auto.
                destruct hx1 as [x1 hx1]. destruct hx1 as [hx1 h3].
                assert (h4: In x1 (l [u] s)). auto. subst y. auto. }
              { assert (hx1: exists x, In x s /\ y = f x). auto.
                destruct hx1 as [x1 hx1]. destruct hx1 as [hx1 h3].
                assert (h4: In x1 (l [u] s)). auto. subst y. auto. } } } Qed.

  Lemma img_diff (l s: list A)(f: A-> B): one_one_on (l [u] s) f ->
                                           img f (l [\] s) = (img f l) [\] (img f s).
  Proof.  { intros h. apply set_equal. all: auto.
            split.
            { intros y h1.
              assert (hx1: exists x, In x (l [\] s) /\ y = f x). auto.
              destruct hx1 as [x1 hx1]. destruct hx1 as [hx1 h2].
              assert (hx1l: In x1 l). eauto.
              assert (hx1s: ~ In x1 s). eauto.
              cut (~ In y (img f s)). cut ( In y (img f l)). auto.
              subst y. auto. intro h3.
              assert (hx2: exists x, In x s /\ y = f x). auto.
              destruct hx2 as [x2 hx2]. destruct hx2 as [hx2 h4].
              assert (h5: x1 = x2).
              cut(In x1 (l [u] s)). cut(In x2 (l [u] s)). cut (f x1 = f x2).
              eauto. subst y;auto. all: auto.
              absurd (In x2 s). subst x2. all: auto. }
            { intros y h1.
              assert (hyl: In y (img f l)). eauto.
              assert (hys: ~ In y (img f s)). eauto.
              assert (hx: exists x, In x l /\ y = f x). auto.
              destruct hx as [x hx]. destruct hx as [hx h2].
              assert (hxs: ~ In x s).
              { intro h3. absurd (In y (img f s)). auto.
                subst y. auto. }
              cut (In x (l [\] s)). subst y. auto. auto. } } Qed.

  Hint Resolve img_inter1 img_inter2 img_union img_diff: core.

End Set_maps.

Hint Resolve IsOrd_img NoDup_img : core.
Hint Resolve img_intro1 img_intro2 img_elim: core.
Hint Resolve img_elim2 img_elim3 img_elim4 : core.
Hint Immediate one_oneP1: core.

Hint Resolve NoDup_map: core.
Hint Resolve map_IsOrd: core.

Hint Immediate map_is_img: core.
Hint Immediate one_one_on_nil one_one_on_elim one_one_on_elim1 one_one_on_elim2 : core.
Hint Immediate one_one_on_intro one_one_on_intro1: core.
Hint Resolve one_one_onP: core.

Hint Resolve img_subset img_size_less img_size_same: core.
Hint Immediate one_one_img_elim img_strict_less : core.

Hint Immediate one_one_on_intro2 one_one_on_intro3 : core.

Hint Resolve img_add img_same: core.

Hint Resolve img_inter1 img_inter2 img_union img_diff: core.

Section Map_composition.

  Context {A B C: ordType}.

  (*-------------------------  A  --f-->  B  --g-->  C    --------------------------------*)

  Lemma range_of_range (l:list A)(f: A->B)(g: B->C):
    img g (img f l) = img ( fun x => g (f x)) l.
  Proof. { assert (H: Equal  (img g (img f l)) (img ( fun x => g (f x)) l) ).
         { unfold Equal.
           split.
           { unfold Subset. intros c Hc.
             assert (Hb: exists b, In b (img f l) /\ c = g b). auto.
             destruct Hb as [b Hb]. destruct Hb as [Hb Hb1].
             assert (Ha: exists a, In a l /\ b = f a). auto.
             destruct Ha as [a Ha]. destruct Ha as [Ha Ha1].
             rewrite Hb1. set (gf := (fun x : A => g (f x))).
             rewrite Ha1.
             assert (H: (g (f a)) = (gf a)). unfold gf. auto.
             rewrite H. eapply img_intro2. auto. }
           { unfold Subset. intros c Hc.
             assert (Ha: exists a, In a l /\ c = g (f a)). auto.
             destruct Ha as [a Ha]. destruct Ha as [Ha1 Ha2].
             subst c. auto. } }  auto. } Qed.

  Hint Resolve range_of_range: core.
End Map_composition.

Hint Resolve range_of_range: core.

Section Maps_on_A.
  Context {A: ordType}.

    (*----------Identity map and its properties ---------------------------------*)

  Definition id:= fun (x:A)=> x.

  Lemma id_is_identity1 (l:list A) : l [=] img id l.
  Proof.  { induction l.
          { simpl. auto. }
          { simpl.  split.
           { intros x h. destruct h as [h | h].
             subst a. unfold id. auto.
             cut (In x (img id l)). auto.  apply IHl. auto. }
           { unfold id. fold id. intros x h.
             cut (x=a \/ In x (img id l)).
             intro h1. destruct h1 as [h1a | h1b].
             subst x. all: auto. cut (In x l). auto. apply IHl. auto. } } }  Qed.

  Lemma id_is_identity (l:list A)(hl: IsOrd l): l = img id l.
  Proof. { induction l.
         { simpl. auto. }
         { apply set_equal. auto. auto.
           simpl. replace (img id l) with l.
           split.
           { intros x h. destruct h as [h | h].
             subst a. unfold id. auto. unfold id. auto. }
           { unfold id. intros x h. cut (x=a \/ In x l).
             intro h1. destruct h1 as [h1a | h1b].
             subst x. all: auto. } eauto. } }  Qed.

  Hint Immediate id_is_identity id_is_identity1: core.

  End Maps_on_A.

Hint Immediate id_is_identity id_is_identity1: core.

Section One_one_onto.

  Context {A B: ordType}.
  Variable (da:A).

   (*-------------invertible functions --------------------------------------- *)

  Lemma one_one_onto (l: list A)(s: list B)(f: A-> B):
    IsOrd l -> IsOrd s -> one_one_on l f -> s = img f l ->
    exists g, (one_one_on s g /\ l = img g s /\ forall x, In x l -> g (f x) = x).
  Proof. { revert s. induction l.
         { (*-------base step: when l is nil------*)
           simpl. intros s h1 h2 h3 h4.
           exists (fun x:B => da).
           subst s. split. auto. split. auto. auto. }
         { (*------ induction step: when l is a::l ---------*)
           intros s h1 h2 h3 h4. simpl in h4. subst s. simpl.
           assert (h5: exists g : B -> A, one_one_on (img f l) g /\
                                    l = img g (img f l) /\ (forall x : A, In x l -> g (f x) = x)).
           { apply IHl. all: auto. eauto. eauto. }
           destruct h5 as [g0 h5].
           set (g:= fun y:B => match (y == f(a)) with
                            | true => a
                            | false => g0 y
                            end).
           assert (hga: g (f a) = a).
           { unfold g. replace (f a == f a) with true. auto. auto. }
           assert (hg_g0: forall x:A, In x l -> g (f x) = g0 (f x)).
           { intros x h6. unfold g.
             assert (h6a: x <> a).
             { intro  h7. subst x; absurd (In a l); auto. }
             assert (h6b: f x <> f a). auto.
             { replace (f x == f a) with false. auto. auto. } }
           assert (hgg0: img g0 (img f l) = img g (img f l)).
           { eapply img_same. intros y h6.
             assert (h7: exists x, In x l /\ y = f x ). auto.
             destruct h7 as [x h7]. destruct h7 as [h7a h7].
             symmetry. subst y. auto. }

           exists g. split.
           { (*-------one_one_on (add (f a) (img f l)) g -------*)
             apply one_one_on_intro. intros x y hx hy h6.
             unfold g in h6.
             destruct (x == f a) eqn: hxa; destruct (y == f a) eqn: hya.
             { move /eqP in hxa;move /eqP in hya. subst x. auto. }
             { absurd (a = g0 y).
               cut (In (g0 y) l). cut (NoDup (a::l)). eauto.
               auto.
               assert (h5a: l = img g0 (img f l)). apply h5.
               rewrite h5a. cut (In y (img f l)). auto. move /eqP in hya. eauto.
               auto. }
             { absurd (a = g0 x).
               cut (In (g0 x) l). cut (NoDup (a::l)). eauto.
               auto.
               assert (h5a: l = img g0 (img f l)). apply h5.
               rewrite h5a. cut (In x (img f l)). auto. move /eqP in hxa. eauto.
               auto. }
             { assert (h5a: one_one_on (img f l) g0). apply h5.
               move /eqP in hxa. move /eqP in hya.
               cut (In x (img f l)). cut (In y (img f l)). eauto.
               all: eauto. } }
           split.
           { (*------- a :: l = img g (add (f a) (img f l)) -------*)
             destruct h5 as [h5a h5]. destruct h5 as [h5b h5].
             assert (h6: img g (add (f a) (img f l)) = add (g (f a)) (img g (img f l))).
             auto. rewrite h6. rewrite <- hgg0. rewrite <- h5b. rewrite hga.
             auto. }
           { (*--------  forall x : A, a = x \/ In x l -> g (f x) = x --------*)
             intros x h6. destruct h6 as [h6 | h6]. subst x. auto.
             replace (g (f x)) with (g0 (f x)). apply h5. auto.
             symmetry;auto. } } } Qed.

End One_one_onto.

Hint Resolve one_one_onto: core.

Section PHP.

  Context {A B: ordType}.

  Variable R: A -> B-> Prop.

  Lemma php_eq (l: list A)(s: list B):
    IsOrd l -> IsOrd s -> (|l| = |s|) -> (forall x, In x l -> (exists y, In y s /\ R x y))->
                                (forall x y z, In x l -> In y l -> In z s -> R x z -> R y z -> x = y)->
                                (forall y, In y s -> (exists x, In x l /\ R x y )).
  Proof. { revert s. induction l as [|a l'].
           { intros s h1 h2 h3 h4 h5.
             assert (h6: s = nil).
             { symmetry in h3. destruct s.
               simpl. auto. simpl in h3. inversion h3. }
             subst s. simpl. tauto. }
           { intros s h1 h2 h3 h4 h5.
             assert (h4a: exists b : B, In b s /\ R a b).
             { apply h4. auto. }
             destruct h4a as [b h4a].
             set (s':= rmv b s).
             assert (hs: s = add b s').
             { subst s'. cut (In b s). auto. apply h4a. }
             assert (h6: |l'| = |s'|).
             { rewrite hs in h3.
               replace (| add b s'|) with (S (|s'|)) in h3. simpl in h3.
               omega. symmetry. cut (~ In b s'). auto. subst s'.
               apply set_rmv_elim3. auto. }

             assert (h7: forall y : B, In y s' -> exists x : A, In x l' /\ R x y ).
             { apply IHl'. eauto. subst s'. eauto. auto.
               { (*--  forall x : A, In x l' -> exists y : B, In y s' /\ R x y --*)
                 intros x h7.
                 assert (h4b: exists y : B, In y s /\ R x y).
                 { apply h4. auto. }
                 destruct h4b as [b' h4b]. destruct h4b as [h4b h4c].
                 exists b'. split. Focus 2.  auto.
                 rewrite hs in h4b.
                 assert (h8: b' = b \/ In b' s'). auto.
                 destruct h8 as [h8 |h8].
                 { absurd ( x = a). intro h9. subst x.
                   absurd (In a l'); auto. subst b'.
                   eapply h5. all: auto. apply h4a. auto. apply h4a. }
                 auto. }
               intros x y z hx hy hz h7. eapply h5. all: auto.
               rewrite hs. auto. }

             intros y h8.
             assert (h8a: y = b \/ In y s').
             { rewrite hs in h8. auto. }
             destruct h8a as [h8a | h8b].
             { exists a. split. auto. subst y. apply h4a. }
             { specialize (h7 y h8b) as h7a. destruct h7a as [x h7a].
               exists x. split. cut (In x l'). auto. all: apply h7a. } } } Qed.

  End PHP.


(* ** Abstract Reduction Systems *)
(* from Semantics Lecture at Programming Systems Lab, https://www.ps.uni-saarland.de/courses/sem-ws13/ *)

Require Export Undecidability.Shared.Libs.PSL.Base Lia.

Module ARSNotations.
  Notation "p '<=1' q" := (forall x, p x -> q x) (at level 70).
  Notation "p '=1' q" := (forall x, p x <-> q x) (at level 70).
  Notation "R '<=2' S" := (forall x y, R x y -> S x y) (at level 70).
  Notation "R '=2' S"  := (forall x y, R x y <-> S x y) (at level 70).
End ARSNotations.

Import ARSNotations.

(* Relational composition *)

Definition rcomp X Y Z (R : X -> Y -> Prop) (S : Y -> Z -> Prop)
: X -> Z -> Prop :=
  fun x z => exists y, R x y /\ S y z.

(* Power predicates *)

Require Import Arith.
Definition pow X R n : X -> X -> Prop := it (rcomp R) n eq.

Definition functional {X Y} (R: X -> Y -> Prop) := forall x y1 y2, R x y1 -> R x y2 -> y1 = y2.
Definition terminal {X Y} (R: X -> Y -> Prop) x:= forall y, ~ R x y.

Section FixX.
  Variable X : Type.
  Implicit Types R S : X -> X -> Prop.
  Implicit Types x y z : X.

  Definition reflexive R := forall x, R x x.
  Definition symmetric R := forall x y, R x y -> R y x.
  Definition transitive R := forall x y z, R x y -> R y z -> R x z.

  (* Reflexive transitive closure *)

  Inductive star R : X -> X -> Prop :=
  | starR x : star R x x
  | starC x y z : R x y -> star R y z -> star R x z.

  Definition evaluates R x y := star R x y /\ terminal R y.

  (* Making first argument a non-uniform parameter doesn't simplify the induction principle. *)

  Lemma star_simpl_ind R (p : X -> Prop) y :
    p y ->
    (forall x x', R x x' -> star R x' y -> p x' -> p x) ->
    forall x, star R x y -> p x.
  Proof.
    intros A B. induction 1; eauto.
  Qed.

  Lemma star_trans R:
    transitive (star R).
  Proof.
    induction 1; eauto using star.
  Qed.

  Lemma R_star R: R <=2 star R.
  Proof.
    eauto using star.
  Qed.

  Instance star_PO R: PreOrder (star R).
  Proof.
    constructor;repeat intro;try eapply star_trans;  now eauto using star.
  Qed.

  (* Power characterization *)

  Lemma star_pow R x y :
    star R x y <-> exists n, pow R n x y.
  Proof.
    split; intros A.
    - induction A as [|x x' y B _ [n IH]].
      + exists 0. reflexivity.
               + exists (S n), x'. auto.
               - destruct A as [n A].
                 revert x A. induction n; intros x A.
                 + destruct A. constructor.
                 + destruct A as [x' [A B]]. econstructor; eauto.
  Qed.

  Lemma pow_star R x y n:
    pow R n x y -> star R x y.
  Proof.
    intros A. erewrite star_pow. eauto.
  Qed.

  (* Equivalence closure *)

  Inductive ecl R : X -> X -> Prop :=
  | eclR x : ecl R x x
  | eclC x y z : R x y -> ecl R y z -> ecl R x z
  | eclS x y z : R y x -> ecl R y z -> ecl R x z.

  Lemma ecl_trans R :
    transitive (ecl R).
  Proof.
    induction 1; eauto using ecl.
  Qed.

  Lemma ecl_sym R :
    symmetric (ecl R).
  Proof.
    induction 1; eauto using ecl, (@ecl_trans R).
  Qed.

  Lemma star_ecl R :
    star R <=2 ecl R.
  Proof.
    induction 1; eauto using ecl.
  Qed.

  (* Diamond, confluence, Church-Rosser *)

  Definition joinable R x y :=
    exists z, R x z /\ R y z.

  Definition diamond R :=
    forall x y z, R x y -> R x z -> joinable R y z.

  Definition confluent R := diamond (star R).

  Definition semi_confluent R :=
    forall x y z, R x y -> star R x z -> joinable (star R) y z.

  Definition church_rosser R :=
    ecl R <=2 joinable (star R).

  Goal forall R, diamond R -> semi_confluent R.
  Proof.
    intros R A x y z B C.
    revert x C y B.
    refine (star_simpl_ind _ _).
    - intros y C. exists y. eauto using star.
    - intros x x' C D IH y E.
      destruct (A _ _ _ C E) as [v [F G]].
      destruct (IH _ F) as [u [H I]].
      assert (J:= starC G H).
      exists u. eauto using star.
  Qed.

  Lemma diamond_to_semi_confluent R :
    diamond R -> semi_confluent R.
  Proof.
    intros A x y z B C. revert y B.
    induction C as [|x x' z D _ IH]; intros y B.
    - exists y. eauto using star.
             - destruct (A _ _ _ B D) as [v [E F]].
               destruct (IH _ F) as [u [G H]].
               exists u. eauto using star.
  Qed.

  Lemma semi_confluent_confluent R :
    semi_confluent R <-> confluent R.
  Proof.
    split; intros A x y z B C.
    - revert y B.
      induction C as [|x x' z D _ IH]; intros y B.
      + exists y. eauto using star.
               + destruct (A _ _ _ D B) as [v [E F]].
                 destruct (IH _ E) as [u [G H]].
                 exists u. eauto using (@star_trans R).
               - apply (A x y z); eauto using star.
  Qed.

  Lemma diamond_to_confluent R :
    diamond R -> confluent R.
  Proof.
    intros A. apply semi_confluent_confluent, diamond_to_semi_confluent, A.
  Qed.

  Lemma confluent_CR R :
    church_rosser R <-> confluent R.
  Proof.
    split; intros A.
    - intros x y z B C. apply A.
      eauto using (@ecl_trans R), star_ecl, (@ecl_sym R).
    - intros x y B. apply semi_confluent_confluent in A.
      induction B as [x|x x' y C B IH|x x' y C B IH].
      + exists x. eauto using star.
               + destruct IH as [z [D E]]. exists z. eauto using star.
               + destruct IH as [u [D E]].
                 destruct (A _ _ _ C D) as [z [F G]].
                 exists z. eauto using (@star_trans R).
  Qed.

  (* End Semantics Library *)

  (* Uniform confluence and parametrized confluence *)

  Definition uniform_confluent (R : X -> X -> Prop ) := forall s t1 t2, R s t1 -> R s t2 -> t1 = t2 \/ exists u, R t1 u /\ R t2 u.

  Lemma functional_uc R :
    functional R -> uniform_confluent R.
  Proof.
    intros F ? ? ? H1 H2. left. eapply F. all:eauto.
  Qed.

  Lemma pow_add R n m (s t : X) : pow R (n + m) s t <-> rcomp (pow R n) (pow R m) s t.
  Proof.
    revert m s t; induction n; intros m s t.
    - simpl. split; intros. econstructor. split. unfold pow. simpl. reflexivity. eassumption.
      destruct H as [u [H1 H2]]. unfold pow in H1. simpl in *. subst s. eassumption.
    - simpl in *; split; intros.
      + destruct H as [u [H1 H2]].
        change (it (rcomp R) (n + m) eq) with (pow R (n+m)) in H2.
        rewrite IHn in H2.
        destruct H2 as [u' [A B]]. unfold pow in A.
        econstructor.
        split. econstructor. repeat split; repeat eassumption. eassumption.
      + destruct H as [u [H1 H2]].
        destruct H1 as [u' [A B]].
        econstructor.  split. eassumption. change (it (rcomp R) (n + m) eq) with (pow R (n + m)).
        rewrite IHn. econstructor. split; eassumption.
  Qed.

  Lemma rcomp_eq (R S R' S' : X -> X -> Prop) (s t : X) : (R =2 R') -> (S =2 S') -> (rcomp R S s t <-> rcomp R' S' s t).
  Proof.
    intros A B.
    split; intros H; destruct H as [u [H1 H2]];
    eapply A in H1; eapply B in H2;
    econstructor; split; eassumption.
  Qed.

  Lemma eq_ref : forall (R : X -> X -> Prop), R =2 R.
  Proof.
    split; tauto.
  Qed.

  Lemma rcomp_1 (R : X -> X -> Prop): R =2 pow R 1.
  Proof.
    intros s t; split;unfold pow in *; simpl in *; intros H.
    - econstructor. split; eauto.
    - destruct H as [u [H1 H2]]; subst u; eassumption.
  Qed.

  Lemma parametrized_semi_confluence (R : X -> X -> Prop) (m : nat) (s t1 t2 : X) :
    uniform_confluent R ->
    pow R m s t1 ->
    R s t2 ->
    exists k l u,
      k <= 1 /\ l <= m /\ pow R k t1 u /\ pow R l t2 u /\ m + k = S l.
  Proof.
    intros unifConfR; revert s t1 t2; induction m; intros s t1 t2 s_to_t1 s_to_t2.
    - unfold pow in s_to_t1. simpl in *. subst s.
      exists 1, 0, t2.
      repeat split; try lia.
      econstructor. split; try eassumption; econstructor.
    - destruct s_to_t1 as [v [s_to_v v_to_t1]].
      destruct (unifConfR _ _ _ s_to_v s_to_t2) as [H | [u [v_to_u t2_to_u]]].
      + subst v. eexists 0, m, t1; repeat split; try lia; eassumption.
      + destruct (IHm _ _ _ v_to_t1 v_to_u) as [k [l [u' H]]].
        eexists k, (S l), u'; repeat split; try lia; try tauto.
        econstructor. split. eassumption. tauto.
  Qed.

  Lemma rcomp_comm R m (s t : X) : rcomp R (it (rcomp R) m eq) s t <-> rcomp (it (rcomp R) m eq) R s t.
  Proof.
    split; intros H;
    [rewrite (rcomp_eq s t (rcomp_1 R) (eq_ref _)) in H;
      rewrite (rcomp_eq s t (eq_ref _) (rcomp_1 R)) |
     rewrite (rcomp_eq s t (eq_ref _) (rcomp_1 R)) in H;
       rewrite (rcomp_eq s t (rcomp_1 R) (eq_ref _))];
    change ((it (rcomp R) m eq)) with (pow R m) in *;
    try rewrite <- pow_add in *;
    rewrite plus_comm; eassumption.
  Qed.

  Lemma parametrized_confluence (R : X -> X -> Prop) (m n : nat) (s t1 t2 : X) :
    uniform_confluent R ->
    pow R m s t1 ->
    pow R n s t2 ->
    exists k l u,
      k <= n /\ l <= m /\ pow R k t1 u /\ pow R l t2 u /\ m + k = n + l.
  Proof.
    revert n s t1 t2; induction m; intros n s t1 t2 unifConR s_to_t1 s_to_t2.
    - unfold pow in s_to_t1. simpl in s_to_t1. subst s.
      exists n, 0, t2. repeat split; try now lia. eassumption.
    - unfold pow in s_to_t1. simpl in *.
      destruct s_to_t1 as [v [s_to_v v_to_t1]].
      destruct (parametrized_semi_confluence unifConR s_to_t2 s_to_v) as
          [k [l [u [k_lt_1 [l_lt_n [t2_to_u [v_to_u H]]]]]]].
      destruct (IHm _ _ _ _ unifConR v_to_t1 v_to_u) as
          [l'[k'[u'[l'_lt_l [k'_lt_m [t1_to_u' [u_to_u' H2]]]]]]].
      exists l', (k + k'), u'.
      repeat split; try lia. eassumption.
      rewrite pow_add.
      econstructor; split; eassumption.
  Qed.

  Lemma uniform_confluent_noloop R x y:
    uniform_confluent R ->
    star R x y -> (forall y', ~ R y y') ->
    ~exists z k, star R x z /\ pow R (S k) z z.
  Proof.
    intros UC (k0&R0)%star_pow Term (z&k1&R1&RL).
    induction R1 in k0,RL,R0|-*.
    -edestruct parametrized_confluence with (m:=k0) (n:=S k1 + k0) as (i0&i1&?&?&?&?&?&?).
     1,2:eassumption.
     now eapply pow_add;eexists;split;eassumption.
     destruct i0. destruct i1.
     +now lia.
     +destruct H2 as (?&?&_). edestruct Term. eauto.
     +destruct H1 as (?&?&_). edestruct Term. eauto.
    -edestruct parametrized_semi_confluence with (R:=R) (2:= R0) as (i0&?&?&?&?&?&?&?). 1,2:eassumption.
     destruct i0. 2:{ destruct H2 as (?&?&_). edestruct Term. eauto. }
     cbn in H2;inv H2.
     eapply IHR1. all:eauto.
  Qed.

 Lemma uc_terminal R x y z n:
    uniform_confluent R ->
    R x y ->
    pow R n x z ->
    terminal R z ->
    exists n' , n = S n' /\ pow R n' y z.
  Proof.
    intros ? ? ? ter. edestruct parametrized_semi_confluence as (k&?&?&?&?&R'&?&?). 1-3:now eauto.
    destruct k as [|].
    -inv R'. rewrite <- plus_n_O in *. eauto.
    -edestruct R' as (?&?&?). edestruct ter. eauto.
  Qed.

  (* classical *)
  Definition classical R x := terminal R x \/ exists y, R x y.

  (* Strong normalisation *)

  Inductive SN R : X -> Prop :=
  | SNC x : (forall y, R x y -> SN R y) -> SN R x.

  Fact SN_unfold R x :
    SN R x <-> forall y, R x y -> SN R y.
  Proof.
    split.
    - destruct 1 as [x H]. exact H.
    - intros H. constructor. exact H.
  Qed.

End FixX.

Existing Instance star_PO.

(* A notion of a reduction sequence which keeps track of the largest occuring state *)

Inductive redWithMaxSize {X} (size:X -> nat) (step : X -> X -> Prop): nat -> X -> X -> Prop:=
  redWithMaxSizeR m s: m = size s -> redWithMaxSize size step m s s
| redWithMaxSizeC s s' t m m': step s s' -> redWithMaxSize size step m' s' t -> m = max (size s) m' -> redWithMaxSize size step m s t.

Lemma redWithMaxSize_ge X size step (s t:X) m:
  redWithMaxSize size step m s t -> size s<= m /\ size t <= m.
Proof.
  induction 1;subst;firstorder (repeat eapply Nat.max_case_strong; try lia).
Qed.

Lemma redWithMaxSize_trans X size step (s t u:X) m1 m2 m3:
 redWithMaxSize size step m1 s t -> redWithMaxSize size step m2 t u -> max m1 m2 = m3 -> redWithMaxSize size step m3 s u.
Proof.
  induction 1 in m2,u,m3|-*;intros.
  -specialize (redWithMaxSize_ge H0) as [].
   revert H1;
     repeat eapply Nat.max_case_strong; subst m;intros. all:replace m3 with m2 by lia. all:eauto.
  - specialize (redWithMaxSize_ge H0) as [].
    specialize (redWithMaxSize_ge H2) as [].
    eassert (H1':=Max.le_max_l _ _);rewrite H3 in H1'.
    eassert (H2':=Max.le_max_r _ _);rewrite H3 in H2'.
    econstructor. eassumption.

    eapply IHredWithMaxSize. eassumption. reflexivity.
    subst m;revert H3;repeat eapply Nat.max_case_strong;intros;try lia.
Qed.

Lemma redWithMaxSize_star {X} f (step : X -> X -> Prop) n x y:
  redWithMaxSize f step n x y -> star step x y.
Proof.
  induction 1;eauto using star.
Qed.

Lemma terminal_noRed {X} (R:X->X->Prop) x y :
  terminal R x -> star R x y -> x = y.
Proof.
  intros ? R'. inv R'. easy. edestruct H. eassumption.
Qed.

Lemma unique_normal_forms {X} (R:X->X->Prop) x y:
  confluent R -> ecl R x y -> terminal R x -> terminal R y -> x = y.
Proof.
  intros CR%confluent_CR E T1 T2.
  specialize (CR _ _ E) as (z&R1&R2).
  apply terminal_noRed in R1. apply terminal_noRed in R2. 2-3:eassumption. congruence.
Qed.

Instance ecl_Equivalence {X} (R:X->X->Prop) : Equivalence (ecl R).
Proof.
  split.
  -constructor.
  -apply ecl_sym.
  -apply ecl_trans.
Qed.

Instance star_ecl_subrel {X} (R:X->X->Prop) : subrelation (star R) (ecl R).
Proof.
  intro. eapply star_ecl.
Qed.

Instance pow_ecl_subrel {X} (R:X->X->Prop) n : subrelation (pow R n) (ecl R).
Proof.
  intros ? ? H%pow_star. now rewrite H.
Qed.

Lemma uniform_confluence_parameterized_terminal (X : Type) (R : X -> X -> Prop) (m n : nat) (s t1 t2 : X):
  uniform_confluent R -> terminal R t1 ->
  pow R m s t1 -> pow R n s t2 -> exists n', pow R n' t2 t1 /\ m = n + n'.
Proof.
  intros H1 H2 H3 H4.
  specialize (parametrized_confluence H1 H3 H4) as (n0&n'&?&?&?&R'&?&?).
  destruct n0.
  -inv R'. exists n'. intuition.
  -exfalso. destruct R' as (?&?&?). eapply H2. eauto.
Qed.

Lemma uniform_confluence_parameterized_both_terminal (X : Type) (R : X -> X -> Prop) (n1 n2 : nat) (s t1 t2 : X):
  uniform_confluent R -> terminal R t1 -> terminal R t2 ->
  pow R n1 s t1 -> pow R n2 s t2 -> n1=n2 /\ t1 = t2.
Proof.
  intros H1 H2 H2' H3 H4.
  specialize (parametrized_confluence H1 H3 H4) as (n0&n'&?&?&?&R'&R''&?).
  destruct n0. destruct n'.
  -inv R'. inv H5. split;first [lia | easy].
  -exfalso. destruct R'' as (?&?&?). eapply H2'. eauto.
  -exfalso. destruct R' as (?&?&?). eapply H2. eauto.
Qed.

Lemma uniform_confluent_confluent (X : Type) (R : X -> X -> Prop):
  uniform_confluent R -> confluent R.
Proof.
  intros H x y y' Hy Hy'. apply ARS.star_pow in Hy as (?&Hy). apply ARS.star_pow in Hy' as (?&Hy').
  edestruct parametrized_confluence as (?&?&z&?&?&?&?&?).
  eassumption. exact Hy. exact Hy'. exists z. split;eapply pow_star. all:eauto.
Qed.

Definition computesRel {X Y} (f : X -> option Y) (R:X -> Y -> Prop) :=
  forall x, match f x with
         Some y => R x y
       | None => terminal R x
       end.

Definition evaluatesIn (X : Type) (R : X -> X -> Prop) n (x y : X) := pow R n x y /\ terminal R y.

Lemma evalevaluates_evaluatesIn X (step:X->X->Prop) s t:
  evaluates step s t -> exists k, evaluatesIn step k s t.
Proof.
  intros [(R&?)%star_pow ?]. unfold evaluatesIn. eauto.
Qed.