(******************************************************************************
September 2004
Authors: Jean-Yves Vion-dury and Pierre Geneves

jean-yves.vion-dury@xrce.xerox.com
WAM Research Project, INRIA Rhone-Alpes and Xerox Research Center Europe

pierre.geneves@inrialpes.fr
WAM Research Project, INRIA Rhone-Alpes

Please do not reuse or publish this code without explicit consent from authors.
*******************************************************************************)
Require Import ZArith.
Require Import setOrder.
Require Import Bool.
Require Import genSetsInt.

Module geneSets (theorder: CmpOrderTheory) : genSetsInt with Definition
  A := theorder.A with Definition A_le := theorder.le with Definition
  A_lt := theorder.lt with Definition A_eq := theorder.eq.

Definition A := theorder.A.
Definition A_le := theorder.le.
Definition A_lt := theorder.lt.
Definition A_eq := theorder.eq.

(* ----------------------------------------------------------------- *)
(*	the data structure, very much like lists                     *)

Inductive set : Set :=
  | empty : set
  | item : A -> set -> set.

Definition single (x : A) := item x empty.

(*  -----------------------------------------------------------------
     tests the membership
 -----------------------------------------------------------------
Fixpoint s_in [a:A;s:set]: bool :=
Cases s of
| empty => false
| (item b ss) => if (A_le b a)
	         then
		      if (A_le a b)
		      then true
		      else (s_in a ss)
		 else
 		      false
end.
*)

(*  -----------------------------------------------------------------
     tests the membership (simplified)
 ----------------------------------------------------------------- *)

Fixpoint s_in (a : A) (s : set) {struct s} : bool :=
  match s with
  | empty => false
  | item b ss => if A_eq a b then true else s_in a ss
  end.

(*  -----------------------------------------------------------------
     Concatenation of two sets
 ----------------------------------------------------------------- *)

Fixpoint cat (s1 s2 : set) {struct s1} : set :=
  match s1 with
  | empty => s2
  | item a ss1 => item a (cat ss1 s2)
  end.

(* ---------------------------------------------------------------- *)
(* Well formedness: all items are unique in the set, and ordered    *)
(*----------------------------------------------------------------- *)
Fixpoint wf (s : set) : bool :=
  match s with
  | empty => true
  | item a ss =>
      if s_in a ss
      then false
      else
       if wf ss
       then match ss with
            | item b _ => A_lt a b
            | empty => true
            end
       else false
  end.

(* -----------------------------------------------------------------
	cardinal of sets. Always positive Z
-----------------------------------------------------------------  *)
Fixpoint card (s : set) : Z :=
  match s with
  | empty => 0%Z
  | item _ ss => Zsucc (card ss)
  end.
(* Zs is the successor function for Z *)

(* -----------------------------------------------------------------
	constructors and tests
-----------------------------------------------------------------  *)

Fixpoint add (a : A) (s : set) {struct s} : set :=
  match s with
  | empty => item a empty
  | item b ss =>
      if A_le b a
      then if A_le a b then s else item b (add a ss)
      else item a s
  end.

Fixpoint sub (a : A) (s : set) {struct s} : set :=
  match s with
  | empty => empty
  | item b ss =>
      if A_le b a then if A_le a b then ss else item b (sub a ss) else s
  end.

Section set_reduction.

 Variable B : Set.
 Fixpoint reduce (f : B -> A -> B) (b : B) (s : set) {struct s} : B :=
   match s with
   | empty => b
   | item a ss => reduce f (f b a) ss
   end.

End set_reduction.

  Fixpoint inter (x : set) : set -> set :=
    match x with
    | empty => fun y => empty
    | item a1 x1 =>
        fun y => if s_in a1 y then item a1 (inter x1 y) else inter x1 y
    end.

  Fixpoint union (x y : set) {struct y} : set :=
    match y with
    | empty => x
    | item a1 y1 => add a1 (union x y1)
    end.

  (** returns the set of all els of [x] that does not belong to [y] *)
  Fixpoint diff (x y : set) {struct x} : set :=
    match x with
    | empty => empty
    | item a1 x1 => if s_in a1 y then diff x1 y else item a1 (diff x1 y)
    end.

    Fixpoint incl (s1 s2 : set) {struct s1} : bool :=
      match s1 with
      | empty => true
      | item a s => if s_in a s2 then incl s s2 else false
      end.

    Fixpoint s_eq (s1 s2 : set) {struct s2} : bool :=
      match s1, s2 with
      | empty, empty => true
      | item a1 ss1, item a2 ss2 =>
          if A_eq a1 a2 then s_eq ss1 ss2 else false
      | _, _ => false
      end.
(*
    Definition s_eq:set->set->bool :=
	[s1,s2:set]
	if (incl s1 s2) then (incl s2 s1) else false
	.
*)
    Fixpoint product (s : set) (fs : A -> set) {struct s} : set :=
      match s with
      | empty => empty
      | item a s1 => union (fs a) (product s1 fs)
      end.

    Fixpoint filter (s : set) (fs : A -> bool) {struct s} : set :=
      match s with
      | empty => empty
      | item a s1 => if fs a then item a (filter s1 fs) else filter s1 fs
      end.

(* ----- Properties ------- *)

Axiom not_single_empty : forall x : A, single x <> empty.
Axiom single_sem : forall x : A, s_in x (single x) = true.
Axiom in_single : forall x y : A, s_in x (single y) = true -> x=y.

(* ----- cat ------- *)

Axiom
  cat_incl :
    forall s1 s2 : set,
    wf (cat s1 s2) = true ->
    forall a : A,
    (s_in a s1 = true -> s_in a s2 = false) /\
    (s_in a s2 = true -> s_in a s1 = false).

Axiom
  cat_union :
    forall s1 s2 : set, wf (cat s1 s2) = true -> cat s1 s2 = union s1 s2.
Axiom
  cat_inter :
    forall s1 s2 : set, wf (cat s1 s2) = true -> inter s1 s2 = empty.

(* ----- in ------- *)

Theorem in_add2 : forall (a : A) (s : set), s_in a (add a s) = true.
Proof.
intros.
induction  s as [| a0 s Hrecs].
simpl in |- *.
assert (H := theorder.eq_reflexive a).
compute in |- *.
rewrite H.
reflexivity.

simpl in |- *.
cut ({A_le a a0 = true} + {A_le a a0 = false}).
cut ({A_le a0 a = true} + {A_le a0 a = false}).
intros.
elim H.
elim H0.
intros.
rewrite a1.
rewrite a2.
assert (a = a0).
apply theorder.le_antisymmetric.
assumption.

assumption.

rewrite H1.
simpl in |- *.
assert (A_eq a0 a0 = true).
apply theorder.eq_reflexive.

rewrite H2.
reflexivity.

intros.
rewrite b.
rewrite a1.
simpl in |- *.
assert (A_eq a a0 = false).
compute in |- *.
apply theorder.le_nle_neq.
assumption.

assumption.

rewrite H1.
apply Hrecs.

intros.
rewrite b.
simpl in |- *.
assert (A_eq a a = true).
apply theorder.eq_reflexive.

rewrite H1.
reflexivity.

apply theorder.le_dec.

apply theorder.le_dec.
Qed.

Theorem in_add :
 forall (a : A) (s : set),
 s_in a s = true -> forall b : A, s_in a (add b s) = true.
Proof.
simple induction s.
simpl in |- *.
intros.
discriminate.

intros.
assert ({A_eq a b = true} + {A_eq a b = false}).
apply theorder.eq_dec.

elim H1.
intro.
assert (a = b).
apply theorder.eq_eq.
compute in a1.
assumption.

rewrite H2.
apply in_add2.

intro.
simpl in |- *.
cut ({A_le a0 b = true} + {A_le a0 b = false}).
cut ({A_le b a0 = true} + {A_le b a0 = false}).
intros.
elim H2.
elim H3.
intros.
rewrite a1.
rewrite a2.
assumption.

intros.
rewrite b1.
simpl in |- *.
rewrite b0.
unfold s_in in H0.
assumption.

intros.
rewrite b1.
elim H3.
intro.
rewrite a1.
simpl in |- *.
cut ({A_eq a a0 = true} + {A_eq a a0 = false}).
intros.
elim H4.
intro.
rewrite a2.
reflexivity.

intro.
rewrite b2.
apply H.
unfold s_in in H0.
rewrite b2 in H0.
exact H0.

apply theorder.eq_dec.

intro.
rewrite b2.
unfold s_in in |- *.
rewrite b0.
assumption.

apply theorder.le_dec.

apply theorder.le_dec.
Qed.

Axiom
  nin_add :
    forall (a b : A) (s : set), s_in a (add b s) = false -> s_in a s = false.

(*
Induction s.
Simpl.
Intros.
Reflexivity.

Intros.
Simpl in H0.
Cut {(A_le a0 b)=true}+{(A_le a0 b)=false}.
Cut {(A_le b a0)=true}+{(A_le b a0)=false}.
Intros.
Elim H1.
Elim H2.
Intros.
Rewrite -> a1 in H0.
Rewrite -> a2 in H0.
Assumption.

Intros.
Rewrite -> a1 in H0.
Rewrite -> b0 in H0.
Exact ((nin_succ a b (item a0 s0)) H0).

Intro.
Rewrite -> b0 in H0.
Elim H2.
Intro.
Rewrite -> a1 in H0.

Axiom nin_add2 : (a,b,c:A; s : set) (s_in a (add b (item c s)))=false->(s_in a (add b s))=false.

Axiom nin_add2 : (a,b,c:A; s : set) (s_in a (add b (item c s)))=false->(A_eq a c)=false.

*)

Theorem in_sem1 : forall a : A, s_in a empty = false.
Proof.
auto.
Qed.

Theorem in_sem2 : forall (a : A) (s : set), s_in a (item a s) = true.
Proof.
intros; simpl in |- *; rewrite theorder.eq_reflexive; reflexivity.
Qed.

Axiom
  in_sem3 :
    forall (a : A) (s : set),
    wf s = true ->
    s_in a s = true ->
    exists s1 : set, (exists s2 : set, s = cat s1 (item a s2)).

Axiom
  in_sem4 :
    forall (a : A) (s1 s2 : set),
    wf (cat s1 s2) = true ->
    s_in a (cat s1 s2) = true -> s_in a s1 = true \/ s_in a s2 = true.

Axiom in_sem5 : forall (a b : A) (s : set),
s_in a s = true -> s_in a (item b s) = true.

Axiom in_sem6 : forall (a b : A) (s : set),
s_in a (item b s) = true -> ~a=b -> s_in a s = true.

Axiom
  in_Lunion :
    forall (a : A) (s1 s2 : set),
     s_in a (union s1 s2) = true -> s_in a s2 = false ->
     s_in a s1 = true.

Axiom
  in_unionL :
    forall (a : A) (s s2 : set),
    s_in a s = true -> s_in a (union s s2) = true.

Axiom
  in_unionR :
    forall (a : A) (s s2 : set),
    s_in a s = true -> s_in a (union s2 s) = true.

Axiom in_union: forall (a b : set)(y : A),
(s_in y (union a b)=true)
->((s_in y a=true) \/ (s_in y b=true)).

Axiom in_inter1: forall (a b :set) (y : A),
 (s_in y (inter a b)=true)->
((s_in y a=true) /\ (s_in y b=true)).

Axiom in_inter2: forall (a b : set) (y : A),
((s_in y a=true) /\ (s_in y b=true)) ->
(s_in y (inter a b)=true).

(* Why dealing with wf here ?
Axiom in_embedded:
  (a,b:A;s:set)
  (wf (item b s))=true ->
  (s_in a s)=true ->
  (s_in a (item b s))=true
  .
*)

Axiom
  in_embedded :
    forall (a b : A) (s : set), s_in a s = true -> s_in a (item b s) = true.

Theorem in_succ :
 forall (a b : A) (s : set),
 A_eq a b = false -> s_in a (item b s) = true -> s_in a s = true.
Proof.
intros a b s.
simpl in |- *.
case A_eq.
intro.
discriminate.
intros.
assumption.
Qed.

Theorem nin_succ :
 forall (a b : A) (s : set), s_in a (item b s) = false -> s_in a s = false.
Proof.
simple induction s.
simpl in |- *.
intros.
reflexivity.

intros.
cut ({A_eq a a0 = true} + {A_eq a a0 = false}).
intros.
elim H1.
intro.
simpl in |- *.
rewrite a1.
simpl in H0.
rewrite a1 in H0.
assert ({A_eq a b = true} + {A_eq a b = false}).
apply theorder.eq_dec.

elim H2.
intro.
rewrite a2 in H0.
discriminate.

intro.
rewrite b0 in H0.
discriminate.

intro.
simpl in |- *.
rewrite b0.
apply H.
simpl in H0.
rewrite b0 in H0.
cut ({A_eq a b = true} + {A_eq a b = false}).
intros.
elim H2.
intro.
rewrite a1 in H0.
discriminate.

intro.
rewrite b1 in H0.
simpl in |- *.
rewrite b1.
assumption.

apply theorder.eq_dec.

apply theorder.eq_dec.
Qed.

Theorem in_dec :
 forall (s : set) (a : A), {s_in a s = true} + {s_in a s = false}.
(* Obsolete : *)
(*
Proof.
Induction s.
Simpl;Auto.

Intros a0 s0 H a1.
Simpl.
Assert H1:=(theorder.le_dec a0 a1).
Assert H2:=(theorder.le_dec a1 a0).
Elim H1; Elim H2.

Intros H3 H4; Rewrite -> H3; Rewrite -> H4; Auto.
Intros H3 H4; Rewrite -> H3; Rewrite -> H4; Auto.
Intros H3 H4; Rewrite -> H3; Rewrite -> H4; Auto.
Intros H3 H4; Rewrite -> H3; Rewrite -> H4; Auto.
Qed.
*)

(* new proof for simplified version of s_in: *)
Proof.
simple induction s.
simpl in |- *; auto.

intros.
simpl in |- *.
assert (H1 := theorder.eq_dec a0 a).
elim H1.
intro.
case A_eq.
left.
reflexivity.

apply (H a0).

intro.
case A_eq.
left.
reflexivity.

apply (H a0).

Qed.

(* ----- card ------- *)

Theorem card_is_pos : forall s : set, (0 <= card s)%Z.
Proof.
simple induction s.
compute in |- *; intro H; discriminate H.
intros a l; simpl in |- *; apply Zle_le_succ.
Qed.

Theorem card_empty : card empty = 0%Z.
Proof.
auto.
Qed.

(* ----- add ------- *)

Axiom add_sem1 : forall (a : A) (s : set), s_in a s = true -> add a s = s.
(*
Theorem add_sem1:
	(a:A;s:set)
	(s_in a s)=true -> (add a s)=s .
Proof.
Induction s.
Simpl;Intro H; Discriminate H.

Intros a1 s0 Hind;Simpl.
Case (A_le a1 a);Case (A_le a a1).
Auto.

Intro H; Assert H1:=(Hind H); Rewrite -> H1; Reflexivity.

Intro H; Discriminate H.
Abort.
*)

Theorem add_sem2 : forall (a : A) (s : set), s_in a (add a s) = true.
Proof.
intros.
case s.
simpl in |- *.
assert (H := theorder.eq_reflexive a).
compute in |- *.
rewrite H.
reflexivity.

intros.
apply in_add2.
Qed.

Axiom add_wf : forall (a : A) (s : set), wf s = true -> wf (add a s) = true.
Axiom
  add_card1 :
    forall (a : A) (s : set),
    s_in a s = false -> card (add a s) = (card s + 1)%Z.
Axiom add_card2 : forall (a : A) (s : set), (card (add a s) >= card s)%Z.

(* ---- equality ---- *)
Axiom
  s_eq_sem : forall s1 s2 : set, s_eq s1 s2 = andb (incl s1 s2) (incl s2 s1).
Axiom
  s_eq_eq :
    forall s1 s2 : set,
    wf s1 = true -> wf s2 = true -> (s1 = s2 <-> s_eq s1 s2 = true).
Axiom
  s_neq_neq :
    forall s1 s2 : set,
    wf s1 = true -> wf s2 = true -> (s1 <> s2 <-> s_eq s1 s2 = false).

Section decidableEq.
  Axiom
    s_eq_dec : forall s1 s2 : set, {s_eq s1 s2 = true} + {s_eq s1 s2 = false}.
  Axiom s_eq_struct : forall s1 s2 : set, s_eq s1 s2 = true -> s1 = s2.
  Axiom s_eq_reflexive : forall s : set, s_eq s s = true.
  Axiom
    s_eq_symmetric :
      forall s1 s2 : set, s_eq s1 s2 = true -> s_eq s2 s1 = true.
  Axiom
    s_eq_transitive :
      forall s1 s2 s3 : set,
      s_eq s1 s2 = true -> s_eq s2 s3 = true -> s_eq s1 s3 = true.
End decidableEq.

(* ----- sub ------- *)
Axiom sub_sem1 : forall (a : A) (s : set), s_in a s = false -> sub a s = s.
Axiom sub_sem2 : forall (a : A) (s : set), s_in a (sub a s) = false.
Axiom sub_wf : forall (a : A) (s : set), wf s = true -> wf (sub a s) = true.
Axiom
  sub_card1 :
    forall (a : A) (s : set),
    s_in a s = true -> card (sub a s) = (card s - 1)%Z.
Axiom sub_card2 : forall (a : A) (s : set), (card (sub a s) <= card s)%Z.
Axiom sub_add_sem : forall (a : A) (s : set), sub a (add a s) = s.

(* ----- inter ------- *)
Axiom
  inter_semL :
    forall (a : A) (s1 s2 : set),
    s_in a s1 = true -> s_in a s2 = true -> s_in a (inter s1 s2) = true.
Axiom inter_empty : forall s : set, inter s empty = empty.
Axiom inter_incl : forall s1 s2 : set, incl s1 s2 = true -> inter s1 s2 = s1.
Axiom inter_idem : forall s : set, inter s s = s.
Axiom inter_sym : forall s1 s2 : set, inter s1 s2 = inter s2 s1.
Axiom
  inter_assoc :
    forall s1 s2 s3 : set, inter s1 (inter s2 s3) = inter (inter s1 s2) s3.

Axiom
  wf_inter :
    forall s1 s2 : set,
    wf s1 = true -> wf s2 = true -> wf (inter s1 s2) = true.
Axiom card_interL : forall s1 s2 : set, (card (inter s1 s2) <= card s1)%Z.
Axiom card_interR : forall s1 s2 : set, (card (inter s1 s2) <= card s2)%Z.

(* ----- diff ------- *)
Axiom
  inter_sem :
    forall (a : A) (s1 s2 : set),
    s_in a s2 = true -> s_in a (diff s1 s2) = false.
Axiom diff_empty : forall s : set, diff s empty = s.
Axiom diff_diff : forall s : set, diff s s = empty.
Axiom diff_inter : forall s1 s2 : set, diff s1 s2 = diff s1 (inter s1 s2).
Axiom
  diff_inter_empty :
    forall s1 s2 : set, inter s1 s2 = empty -> diff s1 s2 = s1.
Axiom
  wf_diff :
    forall s1 s2 : set,
    wf s1 = true -> wf s2 = true -> wf (diff s1 s2) = true.
Axiom card_diff : forall s1 s2 : set, (card (diff s1 s2) <= card s1)%Z.
Axiom
  incl_inter_union :
    forall s1 s2 : set, incl (inter s1 s2) (union s1 s2) = true.

(* ----- union ------- *)
Axiom
  union_semL :
    forall (a : A) (s1 s2 : set),
    s_in a s1 = true -> s_in a (union s1 s2) = true.
Axiom
  union_semR :
    forall (a : A) (s1 s2 : set),
    s_in a s2 = true -> s_in a (union s1 s2) = true.

Axiom union_incl : forall s1 s2 : set, incl s1 s2 = true -> union s1 s2 = s2.
Axiom union_empty : forall s : set, union s empty = s.
Axiom union_empty2 : forall s : set, union empty s = s.
Axiom union_idem : forall s : set, union s s = s.

Axiom
  union_item :
    forall (a : A) (s1 s2 : set),
    union (item a s1) s2 = union (item a empty) (union s1 s2).

Axiom union_sym : forall s1 s2 : set, union s1 s2 = union s2 s1.

Axiom
  union_assoc :
    forall s1 s2 s3 : set, union s1 (union s2 s3) = union (union s1 s2) s3.

Axiom
  wf_union :
    forall s1 s2 : set,
    wf s1 = true -> wf s2 = true -> wf (union s1 s2) = true.
Axiom
  card_union :
    forall s1 s2 : set, (card (union s1 s2) <= card s1 + card s2)%Z.

(* ---- inclusion ---- *)

Theorem incl_succ :
 forall (a1 : A) (s1 s2 : set),
 incl (item a1 s1) s2 = true -> incl s1 s2 = true.
Proof.
intros.
assert ({s_in a1 s2 = true} + {s_in a1 s2 = false}).
apply in_dec.

elim H0.
intro.
unfold incl in H.
rewrite a in H.
apply H.

intro.
unfold incl in H.
rewrite b in H.
discriminate.
Qed.

Axiom
  in_incl :
    forall s1 s2 : set,
    (forall a : A, s_in a s1 = true -> s_in a s2 = true) <->
    incl s1 s2 = true.

Axiom incl_empty : forall s : set, incl empty s = true.
Axiom incl_empty_not : forall s : set, s <> empty -> incl s empty = false.

Axiom incl_reflexive : forall s : set, incl s s = true.

Section reflexiveSets.

Theorem incl_dec :
 forall s1 s2 : set, {incl s1 s2 = true} + {incl s1 s2 = false}.
Proof.
simple induction s1.
intro.
simpl in |- *.
left.
reflexivity.

intros.
cut ({incl s s2 = true} + {incl s s2 = false}).
cut ({s_in a s2 = true} + {s_in a s2 = false}).
intros.
elim H0.
elim H1.
intros.
left.
unfold incl in |- *.
rewrite a1.
exact a0.

intros.
right.
unfold incl in |- *.
rewrite a0.
assumption.

intros.
right.
unfold incl in |- *.
rewrite b.
reflexivity.

apply in_dec.

apply (H s2).
Qed.

(*Axiom incl_reflexive:(x:set)(incl x x)=true.*)

(* wrong *)
(*Axiom incl_asymmetric:(x,y:set)(incl x y)=false -> (incl y x)=true.*)

Theorem incl_antisymmetric :
 forall x y : set, incl x y = true -> incl y x = true -> x = y.
Proof.
intros.
apply s_eq_struct.
assert (H1 := s_eq_sem x y).
rewrite H1.
rewrite H.
rewrite H0.
compute in |- *.
reflexivity.
Qed.

Axiom
  incl_transitive :
    forall (b : bool) (x y z : set),
    incl x y = b -> incl y z = b -> incl x z = b.
End reflexiveSets.

Theorem incl_add :
 forall (a : A) (s1 s2 : set), incl s1 s2 = true -> incl s1 (add a s2) = true.
Proof.
simple induction s1.
simpl in |- *.
trivial.

intros.
unfold incl in |- *.
cut ({s_in a0 (add a s2) = true} + {s_in a0 (add a s2) = false}).
intros.
elim H1.
intro.
rewrite a1.
apply H.
generalize H0.
apply incl_succ.

intro.
rewrite b.
cut ({A_eq a a0 = true} + {A_eq a a0 = false}).
intro.
elim H2.
intro.
assert (a = a0).
apply theorder.eq_eq.
assumption.

rewrite H3 in b.
assert (HC := in_add2 a0 s2).
rewrite HC in b.
discriminate.

intro.
simpl in H0.
assert (s_in a0 s2 = false).
generalize b.
apply nin_add.

rewrite H3 in H0.
discriminate.

apply theorder.eq_dec.

apply in_dec.
Qed.

Theorem incl_unionR : forall s1 s2 : set, incl s2 (union s1 s2) = true.
Proof.
simple induction s2.
simpl in |- *.
reflexivity.

intros.
simpl in |- *.
cut (s_in a (add a (union s1 s)) = true).
intro.
rewrite H0.
apply incl_add.
assumption.

apply in_add2.
Qed.

Theorem incl_unionL : forall s1 s2 : set, incl s1 (union s1 s2) = true.
Proof.
intros.
assert (union s1 s2 = union s2 s1).
apply union_sym.

rewrite H.
apply incl_unionR.
Qed.

Theorem incl_incl_unionR :
 forall s s1 s2 : set, incl s s2 = true -> incl s (union s1 s2) = true.
Proof.
simple induction s.
simpl in |- *.
intros; assumption.

intros.
assert ({s_in a s2 = true} + {s_in a s2 = false}).
apply in_dec.

assert ({incl s0 s2 = true} + {incl s0 s2 = false}).
apply incl_dec.

elim H1.
intro.
elim H2.
intro.
unfold incl in |- *.
assert (s_in a (union s1 s2) = true).
apply in_unionR.
exact a0.

rewrite H3.
apply H.
exact a1.

intro.
assert (incl s0 s2 = true).
generalize H0.
apply incl_succ.

rewrite b in H3.
discriminate.

intro.
unfold incl in H0.
rewrite b in H0.
discriminate.
Qed.

Theorem incl_incl_unionL :
 forall s s1 s2 : set, incl s s2 = true -> incl s (union s2 s1) = true.
Proof.
intros.
rewrite union_sym.
apply incl_incl_unionR.
apply H.
Qed.

Axiom
  incl_add_union :
    forall (s1 s2 : set) (a : A),
    incl s1 s2 = true -> incl (add a s1) (add a s2) = true.

(*
Proof
Induction s1.
Intros.
Simpl.
Assert (s_in a (add a s2))=true.
Apply in_add2.

Rewrite -> H0.
Reflexivity.

Intros.
Simpl.
Cut {(A_le a a0)=true}+{(A_le a a0)=false}.
Cut {(A_le a0 a)=true}+{(A_le a0 a)=false}.
Intros.
Elim H1.
Elim H2.
Intros.
Rewrite -> a1.
Rewrite -> a2.
Assert a=a0.
Apply theorder.le_antisymmetric.
Assumption.

Assumption.

Rewrite <- H3.
Apply incl_add.
Apply H0.

Intros.
Rewrite -> b.
Simpl.
Assert (s_in a0 (add a0 s2))=true.
Apply in_add2.

Rewrite -> H3.
Abort.

*)

Theorem incl_union_unionR :
 forall s s1 s2 : set,
 incl s1 s2 = true -> incl (union s1 s) (union s2 s) = true.
Proof.
simple induction s.
intros.
simpl in |- *.
exact H.

intros.
simpl in |- *.
apply incl_add_union.
apply H.
exact H0.
Qed.

Theorem incl_union_union :
 forall s s1 s2 : set,
 incl s1 s2 = true -> incl (union s s1) (union s s2) = true.
Proof.
intros.
assert (union s s1 = union s1 s).
apply union_sym.

assert (union s s2 = union s2 s).
apply union_sym.

rewrite H0; rewrite H1.
apply incl_union_unionR.
apply H.
Qed.

(* ----- wf ------- *)

Axiom
  wf_cat :
    forall s1 s2 : set,
    wf s1 = true ->
    wf s2 = true ->
    forall (s11 s22 : set) (a b : A),
    s1 = cat s11 (item a empty) ->
    s2 = item b s22 -> A_lt a b = true -> wf (cat s1 s2) = true.

Axiom wf_emb : forall (a : A) (s : set), wf (item a s) = true -> wf s = true.
(*Lemma wf_emb:(a:A;s:set) (wf (item a s))=true -> (wf s)=true.
Proof.
Intros a s H.
Elim H.

Intro H1; Intro H2; Elim H2.
Intro H3; Intro H4.
Unfold wf.
Exact H3.
Qed.
*)

Axiom
  wf_in_lt :
    forall (a : A) (s : set),
    wf (item a s) = true -> forall b : A, s_in b s = true -> A_lt a b = true.
(*
Proof.
Induction s;[
  Intros wf b H;Contradiction
|
  Intros a0 s0 Hind H b H1;
  Assert HH:=(wf_emb a (item a0 s0) H);
  Cut (A_eq b a0)=true \/ (A_lt a0 b)=true;[
    Intro H2;Elim H2;[
	Intro H3
    |

    ]
  |
    ...
  ]
].
Qed.
*)

(* ---- product ---- *)

Axiom product_empty : forall f : A -> set, product empty f = empty.

Axiom product_empty2 : forall s : set, product s (fun a : A => empty) = empty.

Axiom
  product_single : forall (f : A -> set) (a : A), product (single a) f = f a.

(* -- on les a tous-- *)

Theorem product_sem :
 forall (f : A -> set) (a : A) (s : set),
 s_in a s = true -> incl (f a) (product s f) = true.
Proof.
simple induction s.
simpl in |- *.
intro.
discriminate.

intros.
simpl in |- *.
cut ({A_eq a a0 = true} + {A_eq a a0 = false}).
intros.
elim H1.
intro H'.
assert (H2 : a = a0).
apply theorder.eq_eq.
assumption.

rewrite H2.
apply incl_unionL.

intros.
apply incl_incl_unionR.
apply H.
generalize H0.
apply in_succ.
exact b.

apply theorder.eq_dec.
Qed.

(* -- manque la réciproque -- *)

Axiom product_sem2 :
 forall (f : A -> set) (a : A) (s : set),
 (product (item a s) f) = union (f a) (product s f).

Theorem incl_pa_up :
 forall (f : A -> set) (a : A) (s : set),
 incl (product (add a s) f) (union (f a) (product s f)) = true.
Proof.
simple induction s.
simpl in |- *.
apply incl_reflexive.

intros.
simpl in |- *.
cut ({A_le a0 a = true} + {A_le a0 a = false}).
cut ({A_le a a0 = true} + {A_le a a0 = false}).
intros.
elim H0.
elim H1.
intros.
rewrite a1.
rewrite a2.
simpl in |- *.
assert (HE := union_sym (f a) (union (f a0) (product s0 f))).
rewrite HE.
assert (HA := union_assoc).
rewrite <- HA.
apply incl_union_union.
apply incl_unionL.

intros.
rewrite b.
simpl in |- *.
apply incl_union_union.
apply incl_reflexive.

elim H1.
intros.
rewrite a1.
rewrite b.
simpl in |- *.
assert (HE := union_sym (f a) (union (f a0) (product s0 f))).
rewrite HE.
assert (HA := union_assoc).
rewrite <- HA.
apply incl_union_union.
rewrite union_sym.
apply H.

intros.
rewrite b.
simpl in |- *.
apply incl_union_union; apply incl_reflexive.

apply theorder.le_dec.

apply theorder.le_dec.

Qed.

Theorem incl_up_pa :
 forall (f : A -> set) (a : A) (s : set),
 incl (union (f a) (product s f)) (product (add a s) f) = true.
Proof.
simple induction s.
simpl in |- *.
apply incl_reflexive.

intros.
simpl in |- *.
cut ({A_le a0 a = true} + {A_le a0 a = false}).
cut ({A_le a a0 = true} + {A_le a a0 = false}).
intros.
elim H0.
elim H1.
intros.
rewrite a1.
rewrite a2.
simpl in |- *.
assert (a = a0).
apply theorder.le_antisymmetric.
unfold A_le in a2.
unfold A_le in a1.
assumption.

assumption.

rewrite H2.
rewrite union_assoc.
rewrite union_idem.
apply incl_reflexive.

intros.
rewrite a1.
rewrite b.
simpl in |- *.
apply incl_union_union.
apply incl_reflexive.

elim H1; intros.
rewrite a1; rewrite b; simpl in |- *.
rewrite union_sym.
rewrite <- union_assoc.
apply incl_union_union.
rewrite union_sym.
apply H.

rewrite b.
simpl in |- *.
apply incl_union_union.
apply incl_reflexive.

apply theorder.le_dec.

apply theorder.le_dec.
Qed.

Theorem product_add :
 forall (f : A -> set) (a : A) (s : set),
 product (add a s) f = union (f a) (product s f).
Proof.
intros.
apply incl_antisymmetric.
apply incl_pa_up.

apply incl_up_pa.
Qed.

Theorem incl_pu_up :
 forall (f : A -> set) (s1 s2 : set),
 incl (product (union s1 s2) f) (union (product s1 f) (product s2 f)) = true.
Proof.
simple induction s2.
simpl in |- *.
apply incl_reflexive.

intros a0 s Hrec.
simpl in |- *.
assert (H := product_add f a0 (union s1 s)).
rewrite H.
clear H.
assert (H := union_sym (product s1 f) (union (f a0) (product s f))).
rewrite H.
clear H.
assert (H := union_assoc (f a0) (product s f) (product s1 f)).
rewrite <- H.
apply incl_union_union.
clear H.
assert (H := union_sym (product s f) (product s1 f)).
rewrite H; clear H.
apply Hrec.
Qed.

Theorem incl_up_pu :
 forall (f : A -> set) (s1 s2 : set),
 incl (union (product s1 f) (product s2 f)) (product (union s1 s2) f) = true.
Proof.
simple induction s2.
simpl in |- *.
apply incl_reflexive.

intros.
simpl in |- *.
rewrite union_sym.
rewrite <- union_assoc.
rewrite product_add.
apply incl_union_union.
rewrite union_sym.
apply H.
Qed.

Theorem product_unionL :
 forall (f : A -> set) (s1 s2 : set),
 product (union s1 s2) f = union (product s1 f) (product s2 f).
Proof.
intros.
apply incl_antisymmetric.
apply incl_pu_up.
apply incl_up_pu.
Qed.

Theorem incl_puR_up :
 forall (f1 f2 : A -> set) (s : set),
 incl (product s (fun x : A => union (f1 x) (f2 x)))
   (union (product s f1) (product s f2)) = true.
Proof.
simple induction s.
simpl in |- *.
reflexivity.

intros.
simpl in |- *.
rewrite <- union_assoc.
rewrite <- union_assoc.
apply incl_union_union.
assert (H2 := union_sym (product s0 f1) (union (f2 a) (product s0 f2))).
rewrite H2.
rewrite <- union_assoc.
apply incl_union_union.
clear H2.
assert (H3 := union_sym (product s0 f2) (product s0 f1)).
rewrite H3.
apply H.
Qed.

Theorem incl_up_puR :
 forall (f1 f2 : A -> set) (s : set),
 incl (union (product s f1) (product s f2))
   (product s (fun x : A => union (f1 x) (f2 x))) = true.
Proof.
simple induction s.
simpl in |- *.
reflexivity.

intros.
simpl in |- *.
rewrite <- union_assoc.
assert (H4 := union_sym (product s0 f1) (union (f2 a) (product s0 f2))).
rewrite H4.
rewrite union_assoc.
rewrite union_assoc.
rewrite <- union_assoc.
apply incl_union_union.
clear H4.
rewrite union_sym.
apply H.
Qed.

Theorem product_unionR :
 forall (f1 f2 : A -> set) (s : set),
 product s (fun x : A => union (f1 x) (f2 x)) =
 union (product s f1) (product s f2).
Proof.
intros.
apply incl_antisymmetric.
apply incl_puR_up.
apply incl_up_puR.
Qed.

(*

Theorem product_associativity:
	(s:set)(f:A->set)(a:A)
	((product (product s f) f))=true

bad...

transitivity?

*)

Axiom
  wf_product :
    forall (f : A -> set) (s : set),
    wf s = true -> (forall a : A, wf (f a) = true) -> wf (product s f) = true.

(* ---- filter ---- *)

Axiom
  filter_sem1 :
    forall (f : A -> bool) (s : set) (a : A),
    s_in a s = true -> f a = true -> s_in a (filter s f) = true.

Axiom
  filter_sem2 :
    forall (f : A -> bool) (s : set) (a : A),
    s_in a s = true -> f a = false -> s_in a (filter s f) = false.

(* used *)
Axiom filter_sem3:
    forall (f : A -> bool),
    filter empty f = empty.

(* used *)
Axiom filter_sem4:
    forall (f : A -> bool) (s : set) (a : A),
    filter (item a s) f = if (f a) then (item a (filter s f)) else (filter s f).

Axiom filter_sem5:
    forall (f : A -> bool) (s : set) (a : A),
    (f a=true)->s_in a (filter (item a s) f) = true.

Axiom filter_sem6:
    forall (f : A -> bool) (s : set) (a : A),
    (f a=false)->s_in a (filter (item a s) f) = false.

Axiom
  wf_filter :
    forall (f : A -> bool) (s : set), wf s = true -> wf (filter s f) = true.

End geneSets.

Module SetOrder (M: genSetsInt) : PartialReflexiveOrder.

Definition A := M.set.
Definition A_le := M.incl.
Definition dec := M.incl_dec.
Definition reflexive := M.incl_reflexive.
Definition antisymmetric := M.incl_antisymmetric.
Definition transitive := M.incl_transitive.

End SetOrder.

Module SetDecidableEq (M: genSetsInt) : DecidableEquality with Definition
  A := M.set.

Definition A := M.set.
Definition A_eq := M.s_eq.
Definition dec := M.s_eq_dec.
Definition reflexive := M.s_eq_reflexive.
Definition symmetric := M.s_eq_symmetric.
Definition transitive := M.s_eq_transitive.
Definition eq_struct := M.s_eq_struct.

End SetDecidableEq.


Require Omega.
Require Export Bool List.
Export ListNotations.
Require Export Arith Arith.EqNat.
Require Export Smallest Insort.

Function dist a b := max a b - min a b.

Inductive are_merged : list nat -> list nat -> list nat -> Prop :=
  merged_nil_left: forall (l : list nat), are_merged [] l l
| merged_nil_right : forall (l : list nat), are_merged l [] l
| merged_le : forall m n l l' l'',
    m <= n -> are_merged l (n::l') l'' -> are_merged (m::l) (n::l') (m::l'')
| merged_gt : forall m n l l' l'',
    n <= m -> are_merged (m::l) l' l'' -> are_merged (m::l) (n::l') (n::l'').

Require Import Permutation.

Lemma dist_S_l a b: dist a b <= 1 -> min a b = a -> dist (S a) b <= 1.
Proof.
unfold dist. intros H1 H2. rewrite H2 in H1.
  assert (a <= b) as H_3. rewrite <- H2; apply Min.le_min_r; auto.
  assert (max a b = b) as H0. apply max_r; auto. rewrite H0 in H1.
  inversion H1 as [H_1|c H_1 H_2];
  destruct (Min.min_spec (S a) b) as [H3|H3]; destruct H3 as [H3 H4];
  destruct (Max.max_spec (S a) b) as [H5|H5]; destruct H5 as [H5 H6]; try omega.
Qed.

Lemma dist_S_r a b: dist a b <= 1 -> min a b = b -> dist a (S b) <= 1.
Proof.
unfold dist. intros H1 H2. rewrite H2 in H1.
  assert (b <= a) as H_3. rewrite <- H2; apply Min.le_min_l; auto.
  assert (max a b = a) as H0. apply max_l; auto. rewrite H0 in H1.
  inversion H1 as [H_1|c H_1 H_2];
  destruct (Min.min_spec a (S b)) as [H3|H3]; destruct H3 as [H3 H4];
  destruct (Max.max_spec a (S b)) as [H5|H5]; destruct H5 as [H5 H6]; try omega.
Qed.

Lemma can_split : forall (l : list nat),
  {l' | Permutation ((fst l') ++ (snd l')) l & dist (length (fst l')) (length (snd l')) <= 1}.
Proof.
induction l. exists ([], []); auto.
  destruct IHl. destruct x as [pl pr]. simpl in p, l0.
    unfold dist in l0.
      destruct (Min.min_dec (length pl) (length pr)) as [H1 | H1].
        exists (a :: pl, pr). simpl. apply perm_skip; auto.
          simpl. apply dist_S_l; auto.
        exists (pl, a :: pr). simpl.
          apply Permutation_sym; apply Permutation_cons_app; apply Permutation_sym; auto.
          simpl. apply dist_S_r; auto.
Qed.

Lemma merged_permutation : forall (l l' l'': list nat),
  are_merged l l' l'' -> Permutation (l ++ l') l''.
Proof.
intros. induction H; simpl; try rewrite app_nil_r; auto.
  apply Permutation_sym. apply (@Permutation_cons_app _ l'' (m :: l) l' n).
    apply Permutation_sym; auto.
Qed.

Lemma merge : forall (a b : list nat),
  is_sorted a -> is_sorted b -> {ab | is_sorted ab & are_merged a b ab}.
Proof.
induction a as [| ah al].
  intros b _ H. exists b; auto. constructor.
  induction b as [| bh bl].
    intros H _. exists (ah::al); auto. constructor.
    intros H1 H2. destruct (lt_eq_lt_dec ah bh) as [H3|H3].
      assert (is_sorted al) as H4. apply (tail_is_sorted _ _ H1).
      pose (IHal (bh::bl) H4 H2) as H5. destruct H5 as [l H5 H6].
      exists (ah::l); auto. constructor; auto. apply in_list_smallest. left; auto.
        intros x H; destruct H. omega.
        apply merged_permutation in H6. apply Permutation_sym in H6.
          apply (Permutation_in x H6) in H. apply in_app_or in H. destruct H.
            apply (smallest_in (ah::al)). apply head_is_smallest; auto. right; auto.
            apply (le_trans ah bh x). destruct H3; omega.
              apply (smallest_in (bh::bl)). apply head_is_smallest; auto. auto.
        apply merged_le; destruct H3; auto; omega.
    assert (is_sorted bl) as H4. apply (tail_is_sorted _ _ H2).
    pose (IHbl H1 H4) as H5. destruct H5 as [l H5 H6].
      exists (bh::l); auto. constructor; auto. apply in_list_smallest. left; auto.
        intros x H; destruct H. omega.
        apply merged_permutation in H6. apply Permutation_sym in H6.
          apply (Permutation_in x H6) in H. apply in_app_or in H. destruct H.
            apply (le_trans bh ah x). destruct H3; omega.
              apply (smallest_in (ah::al)). apply head_is_smallest; auto. auto.
            apply (smallest_in (bh::bl)). apply head_is_smallest; auto. right; auto.
        apply merged_gt. omega. auto.
Qed.

Theorem genListInd_big_l {A} (P : list A -> Type) (l : list A) :
  P [] ->
  (forall l1 : list A,
      (forall l2, length l2 <  length l1 -> P l2)  ->
      (forall l2, length l2 <= length l1 -> P l2)
  ) ->
  (forall l1 : list A, length l1 <= length l -> P l1).
Proof.
intros HBase; induction l.
  intros _ l1; simpl.
    destruct l1; auto. intros H; apply le_Sn_0 in H; inversion H.
  intros H1. apply H1. intros l2 H2. simpl in H2.
    apply gt_S_le in H2. apply IHl; auto.
Qed.

Theorem genListInd_big {A} (P : list A -> Type) :
  P [] ->
  (forall l : list A,
      (forall l1, length l1 <  length l -> P l1) ->
      (forall l1, length l1 <= length l -> P l1)
  ) ->
  (forall l : list A, P l).
Proof. intros HBase HStep l; apply (genListInd_big_l P l); auto. Qed.

Theorem genListInd {A} (P : list A -> Type) :
  P [] -> (forall l1, (forall l2, length l2 < length l1 -> P l2) -> P l1) ->
  (forall l, P l).
Proof.
intros HBase HStep. apply genListInd_big; auto.
  intros l H1 l1 H2. apply HStep. intros l2 H3. apply H1.
    apply (lt_le_trans _ _ _ H3 H2).
Qed.

Theorem merge_sort : forall (l : list nat), {l' | Permutation l l' & is_sorted l'}.
Proof.
apply genListInd. exists []; auto.
  intros l HStep.
    pose (can_split l). destruct s as [x H1 H2]. destruct x as [hl rl]. simpl in H1, H2.
      destruct hl; destruct rl. exists []; auto; simpl in H1; rewrite <- H1; auto.
        simpl in H1, H2. unfold dist in H2; simpl in H2.
          apply le_S_gt in H2; destruct rl. exists [n]; auto; rewrite <- H1; auto.
            simpl in H2; omega.
        rewrite app_nil_r in H1. unfold dist in H2; simpl in H2.
          apply le_S_gt in H2; destruct hl. exists [n]; auto; rewrite <- H1; auto.
            simpl in H2; omega.
        assert (length (n  :: hl) < length l) as H3.
          rewrite <- (Permutation_length H1).
            rewrite app_length. apply NPeano.Nat.lt_add_pos_r. simpl; omega.
        assert (length (n0 :: rl) < length l) as H4.
          rewrite <- (Permutation_length H1).
            rewrite app_length. apply NPeano.Nat.lt_add_pos_l. simpl; omega.
        apply HStep in H3; apply HStep in H4. destruct H3; destruct H4.
          pose (merge x x0 i i0) as H3. destruct H3. exists x1; auto.
            remember (Permutation_app p p0) as H3. clear HeqH3. apply Permutation_sym in H1.
              apply (Permutation_trans H1) in H3. apply (Permutation_trans H3).
                apply merged_permutation; auto.
Qed.

(* Program Fixpoint Definition. *)

Program Fixpoint can_split_fix (l : list nat) :
  {l' | Permutation ((fst l') ++ (snd l')) l /\ dist (length (fst l')) (length (snd l')) <= 1} :=
  match l with
  | [] => ([], [])
  | a :: l =>
    let: (pl, pr) := can_split_fix l in
    match (Min.min_dec (length pl) (length pr)) with
    | left  _ => (a::pl, pr)
    | right _ => (pl, a::pr)
    end
  end.
Next Obligation. split. apply perm_skip; auto. apply dist_S_l; auto. Defined.
Next Obligation.
split. apply Permutation_sym; apply Permutation_cons_app; apply Permutation_sym; auto.
  apply dist_S_r; auto.
Defined.

Definition mm (lls : list nat * list nat) := let (l1, l2) := lls in length l1 + length l2.

Require Import Coq.Program.Wf Recdef.

Program Fixpoint merge_fix (ab : list nat * list nat) {measure (mm ab)} :
    is_sorted (fst ab) -> is_sorted (snd ab) ->
     {l | is_sorted l /\ are_merged (fst ab) (snd ab) l} := fun aS bS =>
  let: a := fst ab in (* In case you use 'let' instead 'let:' there will be not *)
  let: b := snd ab in (* information in obligation proof.                       *)
  match a with
  | [] => b
  | ah :: al =>
    match b with
    | [] => ah :: al
    | bh :: bl =>
      match lt_eq_lt_dec ah bh with
      | inleft  _ => let: l := merge_fix (al, bh::bl) _ _ in
                     ah :: l
      | inright _ => let: l := merge_fix (ah::al, bl) _ _ in
                     bh :: l  (* In case you use 'a' instread of 'ah::al'   *)
      end                     (* There will be not enough information in    *)
    end                       (* obligation proof. The same thing with 'b'. *)
  end.
Next Obligation. split; auto. simpl. apply merged_nil_left.              Qed.
Next Obligation. split. rewrite Heq_a; auto.  apply merged_nil_right.    Qed.
Next Obligation. simpl in *; rewrite <- Heq_a, <- Heq_b. simpl. omega.   Qed.
Next Obligation. simpl in *. rewrite <- Heq_a in aS. inversion aS; auto. Qed.
Next Obligation. simpl in *. rewrite <- Heq_b in bS; auto.               Qed.
Next Obligation.
simpl in *.
  remember (merge_fix (al, bh :: bl)
            (merge_fix_obligation_3 (l0, l1) merge_fix aS bS l0 eq_refl l1
               eq_refl ah al Heq_a bh bl Heq_b wildcard' Heq_anonymous1)
            (merge_fix_obligation_4 (l0, l1) merge_fix aS bS l0 eq_refl l1
               eq_refl ah al Heq_a bh bl Heq_b wildcard' Heq_anonymous1)
            (merge_fix_obligation_5 (l0, l1) merge_fix aS bS l0 eq_refl l1
               eq_refl ah al Heq_a bh bl Heq_b wildcard' Heq_anonymous1)).
  clear Heqs. destruct s; simpl; destruct a; simpl in *.
    split.
      constructor; auto. apply in_list_smallest. left; auto.
        intros y H1; destruct H1. omega.
          apply merged_permutation in H0. apply Permutation_sym in H0.
            apply (Permutation_in y H0) in H1. apply in_app_or in H1. destruct H1.
              apply (smallest_in (ah :: al)). apply head_is_smallest; auto.
                rewrite Heq_a; auto. right; auto.
              apply (le_trans ah bh y). destruct wildcard'; omega.
                apply (smallest_in (bh :: bl)); auto. apply head_is_smallest; auto.
                  rewrite Heq_b; auto.
      constructor; auto. destruct wildcard'; omega.
Qed.
Next Obligation. simpl in *. rewrite <- Heq_a, <- Heq_b. simpl. omega.   Qed.
Next Obligation. simpl in *. rewrite Heq_a; auto.                        Qed.
Next Obligation. simpl in *. rewrite <- Heq_b in bS. inversion bS; auto. Qed.
Next Obligation.
simpl in *.
  remember (merge_fix (ah :: al, bl)
            (merge_fix_obligation_7 (l0, l1) merge_fix aS bS l0 eq_refl l1
               eq_refl ah al Heq_a bh bl Heq_b wildcard' Heq_anonymous1)
            (merge_fix_obligation_8 (l0, l1) merge_fix aS bS l0 eq_refl l1
               eq_refl ah al Heq_a bh bl Heq_b wildcard' Heq_anonymous1)
            (merge_fix_obligation_9 (l0, l1) merge_fix aS bS l0 eq_refl l1
               eq_refl ah al Heq_a bh bl Heq_b wildcard' Heq_anonymous1)).
  clear Heqs. destruct s; simpl; destruct a; simpl in *.
    split.
      constructor; auto. apply in_list_smallest. left; auto.
        intros y H1; destruct H1. omega.
          apply merged_permutation in H0. apply Permutation_sym in H0.
            apply (Permutation_in y H0) in H1. apply in_app_or in H1. destruct H1.
              apply (le_trans bh ah y). omega.
                apply (smallest_in (ah :: al)); auto. apply head_is_smallest; auto.
                  rewrite Heq_a; auto.
              apply (smallest_in (bh :: bl)). apply head_is_smallest; auto.
                rewrite Heq_b; auto. right; auto.
     constructor; auto. omega.
Qed.

Program Fixpoint merge_sort_fix (l : list nat) {measure (length l)} :
    {l' | Permutation l l' /\ is_sorted l'} :=
  let: (nl, nr):= can_split_fix l in
  match nl, nr with
  | [], _ => nr
  | _, [] => nl
  | hl::tl, hr::tr =>
    let: sl := merge_sort_fix nl in
    let: sr := merge_sort_fix nr in
    merge_fix (sl, sr) _ _
  end.
Next Obligation.
remember (can_split_fix l) as spl. clear Heqspl. destruct spl as [lr H1].
  destruct H1 as [H1 H2]; simpl in *. rewrite <- Heq_anonymous in *; simpl in *.
    apply Permutation_sym in H1; split; auto.
      assert (length nr <= 1). unfold dist in H2; simpl in H2.
        rewrite <- minus_n_O in H2; auto.
        destruct nr; auto; destruct nr; auto. simpl in H. omega.
Qed.
Next Obligation.
remember (can_split_fix l) as spl. clear Heqspl. destruct spl as [lr H1].
  destruct H1 as [H1 H2]; simpl in *. rewrite <- Heq_anonymous in *; simpl in *.
    rewrite app_nil_r in H1. apply Permutation_sym in H1; split; auto.
      assert (length nl <= 1). unfold dist in H2.
        rewrite (Min.min_0_r (length nl)) in H2. rewrite (Max.max_0_r (length nl)) in H2.
        rewrite <- minus_n_O in H2; auto.
      destruct nl; auto; destruct nl; auto. simpl in H0. omega.
Qed.
Next Obligation.
remember (can_split_fix l) as spl. clear Heqspl. destruct spl as [lr H1].
  destruct H1 as [H1 H2]; simpl in *. rewrite <- Heq_anonymous in *; simpl in *.
    apply Permutation_length in H1. rewrite <- H1. simpl.
      rewrite app_length. simpl. omega.
Qed.
Next Obligation.
remember (can_split_fix l) as spl. clear Heqspl. destruct spl as [lr H1].
  destruct H1 as [H1 H2]; simpl in *. rewrite <- Heq_anonymous in *; simpl in *.
    apply Permutation_length in H1. rewrite <- H1. simpl.
      rewrite app_length. simpl. omega.
Qed.
Next Obligation.
remember (merge_sort_fix (hl :: tl)
           (merge_sort_fix_obligation_3 l merge_sort_fix
              (hl :: tl) (hr :: tr) Heq_anonymous hl tl hr tr eq_refl eq_refl)) as spl.
  clear Heqspl. destruct spl as [lr H1]. destruct H1 as [H1 H2]; auto.
Qed.
Next Obligation.
remember (merge_sort_fix (hr :: tr)
           (merge_sort_fix_obligation_4 l merge_sort_fix
              (hl :: tl) (hr :: tr) Heq_anonymous hl tl hr tr eq_refl eq_refl
              (proj1_sig
                 (merge_sort_fix (hl :: tl)
                    (merge_sort_fix_obligation_3 l merge_sort_fix
                       (hl :: tl) (hr :: tr) Heq_anonymous hl tl hr tr
                       eq_refl eq_refl))) eq_refl)) as spl.
  clear Heqspl. destruct spl as [lr H1]. destruct H1 as [H1 H2]; auto.
Qed.
Next Obligation. admit. Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (z : natural) (lf3 : natural) : natural :=
  plus z (plus Zero lf3).


(** This file is self study of coinduction in Coq.
    The contents are based on
    http://www.cse.chalmers.se/research/group/logic/TypesSS05/Extra/bertot_sl2.pdf
    https://www.labri.fr/perso/casteran/CoqArt/Tsinghua/C7.pdf
  *)

(*
   This is solution for https://www.labri.fr/perso/casteran/CoqArt/Tsinghua/exercises_7.v
 *)

Require Import List.
Require Import ArithRing.

Set Implicit Arguments.

(** Let us consider the following co-inductive definition *)

 CoInductive LList (A: Type) : Type := (* lazy lists *)
 |  LNil : LList A
 |  LCons : A -> LList A -> LList A.

Check (LCons 1 (LCons 2 (LCons 3 (LNil nat)))).

(* builds the infinite list n, 1+n, 2+n, 3+n, etc. *)

CoFixpoint from (n : nat) : LList nat := LCons n (from (S n)).

Definition nat_stream := from 0.

(* exercise 1 :

Build the infinite list  true_false_alter  which alternates the
 boolean values :  true,false,true,false, ...
*)

CoFixpoint alter (b : bool) : LList bool := LCons b (alter (negb b)).

(* exercise 2 *)
(* generate the infinite list n_times_n  :
                   1,2,2,3,3,3,4,4,4,4, .... *)

CoFixpoint n_times_n (n : nat) (m : nat) : LList nat :=
  match m with
  | 0 => LCons (S n) (n_times_n (S n) n)
  | S m' => LCons n (n_times_n n m')
  end.

(* exercise 3 :
 : Let A be any type and f : A -> A.
  define  "iterates f a" as the infinite list
     a, f a , f (f a), f (f (f a), etc.

  apply this functional for defining the sequence Exp2 of powers of 2 :
  1,2,4,8,16, etc.
*)

CoFixpoint iterates (A : Type) (f : A -> A) (a : A) : LList A :=
  LCons a (iterates f (f a)).

Definition isEmpty (A:Type) (l:LList A) : Prop :=
  match l with
  | LNil _ => True
  | LCons a l' => False
  end.

(* exercise 4: prove the following lemma *)

Lemma nat_stream_not_Empty : ~ isEmpty nat_stream.
Proof.
  unfold isEmpty. intro contra.
  unfold nat_stream in contra.
  simpl in contra. destruct contra.
  Qed.

Definition LHead (A:Type) (l:LList A) : option A :=
  match l with
  | LNil _ => None
  | LCons a l' => Some a
  end.

Eval compute in (LHead (LCons 1 (LCons 2 (LCons 3 (LNil nat))))).

(* Exercise 5 :
  prove the following lemma *)

Lemma Head_of_from : forall n, LHead (from n) = Some n.
Proof.
  intros. reflexivity. Qed.

Definition LTail (A:Type) (l:LList A) : LList A :=
  match l with
  | LNil _ => LNil A
  | LCons a l' => l'
  end.

(* Exercise 6 :

 define a function Nth (A:Type)  (n:nat) (l:LList A) : option A
   such that (Nth n l) returns
     - (Some a) if a is the n-th element of l (0-based)
     - None if l has less than n+1 elements

If your solution is good, you can make a simple test :

Eval compute in (LNth 5 Exp2).
Some 32 : option nat

*)

Fixpoint LNth (A : Type) (n : nat) (l : LList A) : option A :=
  match l, n with
  | LCons a l', S n' => LNth n' l'
  | LCons a l', 0 => Some a
  | LNil _, _ => None
  end.

(* Exercise 7 :

   For this exercise (and perhaps another one) , you may use the
   following tools  (but it's not mandatory) :

   Standard library's  theorem f_equal
   tactic ring on natural numbers (from  the ArithRing module) :

Proove the following theorem :

Lemma LNth_from : forall n p, LNth n (from p) = Some (n+p).
*)

Lemma LNth_from : forall n p, LNth n (from p) = Some (n+p).
Proof.
  intros. generalize dependent p. induction n.
  - simpl. reflexivity.
  - intros. simpl. rewrite -> IHn.
    assert (n + S p = S (n + p)) by ring.
    rewrite H. reflexivity.
  Qed.

(* exercise 8 :
   define a function   list_inj (A:Type)(l : list A) : LList A

  which maps any (finite) list to a lazy list having the same elements
  in the same order
 *)

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

(* exercise 9 :

  in order to validate your function list_inj,
   prove the lemma list_inj_ok (which uses the following nth function on
   finite lists).
 *)

Fixpoint nth (A:Type)  (n:nat) (l:list A)  {struct l} : option A :=
match n,l  with | _,nil => None
                | 0,a::_ =>  Some a
                | S p, _::l' => nth p l'
end.

(*
Lemma list_inj_Ok : forall (A:Type)(l : list A)(n:nat),
   nth n l  = LNth  n (list_inj l) .

*)

Lemma list_inj_Ok : forall (A:Type)(l : list A)(n:nat),
   nth n l  = LNth  n (LList_inj l) .
Proof.
  intros. generalize dependent l. induction n.
  - intros. simpl. destruct l.
    + reflexivity.
    + simpl. reflexivity.
  - intros. simpl. destruct l.
    + simpl. reflexivity.
    + simpl. rewrite -> IHn. reflexivity.
  Qed.

Fixpoint firsts (A : Type) (n : nat) (l : LList A) : list A :=
  match l, n with
  | LCons a l', S n' => a :: (firsts n' l')
  | _, _ => nil
  end.

(* exercise 10 :
  Define a "reciprocal"  to list_inj :
   firsts (A:Type) n (l:LList A): list A
   returns the list of n-ths first elements of l

   if l is finite and too short, firsts returns the list of all elements of l

Here is a little test :
*)
Definition Exp2 : LList nat := iterates (fun n => 2 * n) 1.

Eval compute in (firsts 6 Exp2).

Eval compute in (firsts 10 (n_times_n 1 1)).

(* Exercise 11 (not so easy) :
 Prove that Exp2 truely contains the sequence of all powers of 2 *)

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

CoInductive Infinite(A:Type): LList A -> Prop :=
 Infinite_LCons : forall a l, Infinite l -> Infinite (LCons a l).

CoInductive LList_eq (A:Type): LList A -> LList A -> Prop :=
| LList_eq_LNil : LList_eq (LNil A) (LNil A)
| LList_eq_LCons : forall a l l', LList_eq l l' ->
                                  LList_eq (LCons a l) (LCons a l').

Definition LList_decomp (A:Type) (l:LList A) : LList A :=
  match l with
  | LNil _ => LNil A
  | LCons a l' => LCons a l'
  end.

Eval simpl in (LList_decomp (n_times_n 1 1)).

Lemma LList_decompose : forall (A:Type) (l:LList A), l = LList_decomp l.
Proof.
 intros A l; case l; trivial.
Qed.

Ltac unwind_i :=
 match goal with | |- ?t1= ?t2  =>
          apply trans_equal with (1 := LList_decompose t1);auto
end.

Ltac unwind term1 term2 :=
  let eg := fresh "eg" in
  assert(eg : term1 = term2);
     [unwind_i|idtac].

Lemma bool_alternate_Infinite : forall b, Infinite (alter b).
Proof.
 cofix H.
 intro b.
 unwind (alter b) (LCons b (alter (negb b))).
 rewrite eg.
 constructor.
 auto.
Guarded.
Qed.

(* exercise 12 : Prove the following lemmas

Lemma Exp2_Infinite : Infinite Exp2.

Lemma bool_alternate_eqn : forall b, bool_alternate b =
                                     LCons b (bool_alternate (negb b)).
*)
Lemma iterates_Infinite : forall (A : Type) (f : A -> A) (n : A),
  Infinite (iterates f n).
Proof.
  intro A. cofix H. intros.
  unwind (iterates f n) (LCons n (iterates f (f n))).
  rewrite eg. apply Infinite_LCons.
  apply H. Qed.

Lemma bool_alternate_eqn :
  forall b, alter b = LCons b (alter (negb b)).
Proof.
  intro.
  unwind (alter b) (LCons b (alter (negb b))).
  apply eg. Qed.

CoFixpoint LAppend (A:Type) (u v:LList A) : LList A :=
  match u with
  | LNil _ => v
  | LCons a u' => LCons a (LAppend u' v)
  end.

Lemma LAppend_LNil : forall (A:Type) (v:LList A), LAppend (LNil A) v = v.
Proof.
 intros A v.
 destruct v; unwind_i.
Qed.

Lemma LAppend_LCons :
  forall (A:Type) (a:A) (u v:LList A),
    LAppend (LCons a u) v = LCons a (LAppend u v).
Proof.
 intros A a u v.
 unwind_i.
Qed.

Hint Rewrite  LAppend_LNil LAppend_LCons : llists.

Lemma LAppend_Infinite_1 : forall (A:Type)(u v : LList A),
                             Infinite u -> Infinite (LAppend u v).
Proof.
 intro A;cofix H1.
 destruct u.
 intros v H;inversion H.
 intros v H;rewrite LAppend_LCons.
constructor;auto.
 apply H1.
 inversion H;auto.
Qed.

(* exercise 13 :
Prove the following lemma :

Lemma LAppend_Infinite_2 : forall (A:Type)(u v : LList A),
                           Infinite v -> Infinite (LAppend u v).
*)

Lemma LAppend_Infinite_2 : forall (A:Type)(u v : LList A),
                           Infinite v -> Infinite (LAppend u v).
Proof.
  intro A. cofix H.
  intros. destruct v.
  - inversion H0.
  - destruct u.
    + rewrite LAppend_LNil. apply H0.
    + rewrite LAppend_LCons.
      constructor. apply H. apply H0.
  Qed.

(* exercise 14 :
Prove the following lemma :

Lemma LAppend_Infinite_3 : forall (A:Type)(u v : LList A),
                             Infinite (LAppend u v) ->
                             Finite u ->  Infinite v.
*)

Lemma LAppend_Infinite_3 : forall (A:Type)(u v : LList A),
                             Infinite (LAppend u v) ->
                             Finite u ->  Infinite v.
Proof.
  intro A. cofix H. intros.
  destruct v.
  - induction H1.
    + rewrite LAppend_LNil in H0. inversion H0.
    + rewrite LAppend_LCons in H0.
      inversion H0; subst. apply IHFinite in H3.
      inversion H3.
  - induction H1.
    + rewrite LAppend_LNil in H0. apply H0.
    + apply IHFinite.
      rewrite LAppend_LCons in H0.
      inversion H0; subst. apply H3.
  Qed.

(* exercise 15 :
Prove the following lemma :
Lemma LAppend_absorbent : forall (A:Type)( u v: LList A),
                                       Infinite u ->
                                       LList_eq u (LAppend u v).
*)

Lemma LAppend_absorbent : forall (A:Type)( u v: LList A),
                                       Infinite u ->
                                       LList_eq u (LAppend u v).
Proof.
  intro A. cofix H.
  intros.
  destruct u.
  - inversion H0.
  - rewrite LAppend_LCons. apply LList_eq_LCons.
    apply H. inversion H0; subst. apply H2.
  Qed.


Require Import Coq.Logic.Classical_Prop.
About classic.
(*Axiom LEM : forall P:Prop, P \/ ~ P.*)

Theorem NDRid1 : forall (p q : Prop), q -> (p \/ q).
Proof.
intros.
right. exact H. Show Proof.
Qed.

Theorem NDRid2 : forall (p q : Prop), p -> (p \/ q).
Proof.
intros.
left. exact H.
Qed.

Theorem Conversion: forall (p q: Prop),(p -> q) -> (~ p \/ q).
Proof.
  intros p q.
  intros p_implies_q.
  destruct (classic p) as [p_true | p_not_true].
  - apply p_implies_q in p_true as q_true. apply NDRid1. exact q_true. Show Proof. (* prove ~p \/ q using p *)
  - apply NDRid2. exact p_not_true. Show Proof. (* prove ~p \/ q using ~p *)
Qed.
(*demostracion demorgan*)
Lemma morgan : forall P Q : Prop, ~(P \/ Q) -> ~P /\ ~Q.
Proof.
  unfold not.
  intros P Q PorQ_false.
    split.
    intros P_holds.
    apply PorQ_false.
    left.
      exact P_holds.
      intros Q_holds.
      apply PorQ_false.
    right.
      exact Q_holds.
Qed.

(*Double negation*)
Theorem double_neg : forall (P : Prop),
  P -> ~~P.
Proof.
  unfold not.
  intros.
  destruct (H0 H).
Qed.

(*distributes_law*)
Theorem distributes_law: forall (P Q R : Prop),
  P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  split.
  - intros [HP | [HQ HR]].
    + split.
      * left. apply HP.
      * left. apply HP.
    + split.
      * right. apply HQ.
      * right. apply HR.
  - intros [[HP | HQ] [HP' | HR]].
    + left. apply HP.
    + left. apply HP.
    + left. apply HP'.
    + right.
      split.
      * apply HQ.
      * apply HR.
Qed.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require Reals.Rtrigo_def.
Require Reals.Rpower.
Require BuiltIn.
Require real.Real.

Import Rtrigo_def.
Import Rpower.

(* Why3 comment *)
(* exp is replaced with (Reals.Rtrigo_def.exp x) by the coq driver *)

(* Why3 goal *)
Lemma Exp_zero : ((Reals.Rtrigo_def.exp 0%R) = 1%R).
exact exp_0.
Qed.

Require Import Exp_prop.

(* Why3 goal *)
Lemma Exp_sum : forall (x:R) (y:R),
  ((Reals.Rtrigo_def.exp (x + y)%R) = ((Reals.Rtrigo_def.exp x) * (Reals.Rtrigo_def.exp y))%R).
exact exp_plus.
Qed.

(* Why3 comment *)
(* log is replaced with (Reals.Rpower.ln x) by the coq driver *)

(* Why3 goal *)
Lemma Log_one : ((Reals.Rpower.ln 1%R) = 0%R).
exact ln_1.
Qed.

(* Why3 goal *)
Lemma Log_mul : forall (x:R) (y:R), ((0%R < x)%R /\ (0%R < y)%R) ->
  ((Reals.Rpower.ln (x * y)%R) = ((Reals.Rpower.ln x) + (Reals.Rpower.ln y))%R).
intros x y (Hx,Hy).
now apply ln_mult.
Qed.

(* Why3 goal *)
Lemma Log_exp : forall (x:R),
  ((Reals.Rpower.ln (Reals.Rtrigo_def.exp x)) = x).
exact ln_exp.
Qed.

(* Why3 goal *)
Lemma Exp_log : forall (x:R), (0%R < x)%R ->
  ((Reals.Rtrigo_def.exp (Reals.Rpower.ln x)) = x).
exact exp_ln.
Qed.

(* Why3 assumption *)
Definition log2 (x:R): R := ((Reals.Rpower.ln x) / (Reals.Rpower.ln 2%R))%R.

(* Why3 assumption *)
Definition log10 (x:R): R :=
  ((Reals.Rpower.ln x) / (Reals.Rpower.ln 10%R))%R.


(* Difference of squares. *)

Require Import Omega.
Require Import Arith.

(* If you're still on 8.4 (laggard!), try this instead: *)
(* Import NPeano.Nat. *)
Import Nat.

(* Some useful lemmas from the standard library... *)
Check mul_sub_distr_l: forall n m p, p * (n - m) = p * n - p * m.
Check mul_add_distr_r: forall n m p, (n + m) * p = n * p + m * p.
Check mult_assoc: forall n m p, n * (m * p) = n * m * p.
Check mult_comm: forall n m, n * m = m * n.
Check mul_1_r: forall n, n * 1 = n.

(* None of these lemmas require induction. Just use the library lemmas above. *)
Lemma squared_squared:
  forall x, x ^ 4 = (x * x) * (x * x).
Proof.

Qed.

(* Expand the right hand side first. *)
Lemma difference_of_squares:
  forall a b, a * a - b * b = (a + b) * (a - b).
Proof.

Qed.

(* Use both lemmas you just proved. *)
Lemma difference_of_squares_nested:
  forall a b, a ^ 4 - b ^ 4 = (a * a + b * b) * (a + b) * (a - b).
Proof.

Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (x : natural) (y : natural) : natural := plus y (mult y x).


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (x : natural) : natural := plus Zero (mult x y).


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling    [*]              *)
(*             Jean-François Monin           [+]              *)
(*                                                            *)
(*            [*] Affiliation LORIA -- CNRS                   *)
(*            [+] Affiliation VERIMAG - Univ. Grenoble-Alpes  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(** Using the simulated IR definition of

              𝔻 : Ω -> Prop and nm : forall e, 𝔻 e -> Ω

    we show show partial correctness of nm:

      a) if De : 𝔻 e then nm e De is normal

      b) if De : 𝔻 e then nm e De is equivalent to e

    both by dependent induction on De : 𝔻 e
*)

Require Import Arith Omega Wellfounded.

Require Import nm_defs.

Set Implicit Arguments.

(* Now we show the partial correctness of nm, independently of its termination *)

(** normal forms only have atoms as boolean condition ie. b in if b then _ else _ *)

Inductive normal : Ω -> Prop :=
  | in_normal_0 : normal α
  | in_normal_1 : forall y z, normal y -> normal z -> normal (ω α y z).

Notation ℕ := normal.

(** nm produces normal forms *)

Theorem nm_normal e D : ℕ (nm e D).
Proof.
  induction D as [ e D1 D2 | | y z D1 ID1 D2 ID2 | u v w y z D1 ID1 D2 ID2 D3 ID3 ].
  - rewrite (nm_pirr _ D1); auto.
  - rewrite nm_fix_0; constructor.
  - rewrite nm_fix_1; constructor; auto.
  - rewrite nm_fix_2; auto.
Qed.

(** equiv is the congruence generated by ω (ω a b c) y z ~e ω a (ω b y z) (ω c y z) *)

Reserved Notation "x '~Ω' y" (at level 70, no associativity).

Inductive equiv : Ω -> Ω -> Prop :=
  | in_eq_0 : forall u v w y z, ω (ω u v w) y z ~Ω ω u (ω v y z) (ω w y z)
  | in_eq_1 : forall x x' y y' z z', x ~Ω x' -> y ~Ω y' -> z ~Ω z'-> ω x y z ~Ω ω x' y' z'
  | in_eq_2 : α ~Ω α
  | in_eq_3 : forall x y z, x ~Ω y -> y ~Ω z -> x ~Ω z
where "x ~Ω y" := (equiv x y).

Hint Constructors equiv.

Fact equiv_refl e : e ~Ω e.
Proof. induction e; auto. Qed.

Hint Resolve equiv_refl.

Notation equiv_trans := in_eq_3.

(** nm preserves equivalence *)

Fact nm_equiv e D : e ~Ω nm e D.
Proof.
  induction D as [ e D1 D2 | | y z D1 ID1 D2 ID2 | u v w y z D1 ID1 D2 ID2 D3 ID3 ].
  - rewrite (nm_pirr _ D1); auto.
  - rewrite nm_fix_0; auto.
  - rewrite nm_fix_1; auto.
  - rewrite nm_fix_2.
    apply equiv_trans with (2 := ID3),
          equiv_trans with (1 := in_eq_0 _ _ _ _ _); auto.
Qed.


Require Import ZArith Znumtheory.
Require Import MyNat Ztools.

(** * Results about [eqm], congruence modulo some integer *)

Notation " a ≡ b [ p ] " := ( eqm p a b ) (at level 70).

Existing Instances eqm_setoid Zplus_eqm Zminus_eqm Zmult_eqm.

Lemma mod0_eqm : forall x m, x ≡ 0 [m] <-> x mod m = 0.
Proof.
  intros x m.
  rewrite <- Zmod_0_l with m.
  intuition.
Qed.

Lemma divide_eqm : forall x m, m <> 0 -> (x ≡ 0 [m] <-> (m | x)).
Proof.
  intros x m Nm; split; rewrite mod0_eqm; intros H.
    apply Zmod_divide; auto.
    apply Zdivide_mod; auto.
Qed.

Lemma eq_eqm : forall m a b, a = b -> a ≡ b [m].
Proof.
  intros; subst; reflexivity.
Qed.

Lemma eqm_diag : forall m, m ≡ 0 [m].
Proof.
  intros; red; rewrite Z_mod_same_full; reflexivity.
Qed.

Lemma eqm_minus_0 : forall a b m, a ≡ b [m] <-> a - b ≡ 0 [m].
Proof.
  intros a b m; split; intros E.
    rewrite E; red; f_equal; ring.
    rewrite <- (Zminus_0_r a), <- E; red; f_equal; ring.
Qed.

Lemma eqm_divide m a b : m <> 0 -> a ≡ b [ m ] <-> (m | a - b).
Proof.
  intros mz.
  rewrite eqm_minus_0.
  rewrite <-Z.mod_divide; tauto.
Qed.

Lemma eqm_mult_compat_l : forall k a b m, a ≡ b [m] -> k * a ≡ k * b [k * m].
Proof.
  intros k a b m E.
  red.
  repeat rewrite Zmult_mod_distr_l.
  rewrite E.
  auto.
Qed.

Lemma eqm_mult_compat_r : forall k a b m, a ≡ b [m] -> a * k ≡ b * k [k * m].
Proof.
  intros k a b m.
  repeat rewrite <- (Zmult_comm k).
  apply eqm_mult_compat_l.
Qed.

(** Modulo m if a≡m/2 then a²≡m²/4 *)

Lemma eqm_square_half : forall x m, 0 <> m ->
  x ≡ m [2 * m] -> x * x ≡ m * m [4 * (m * m)].
Proof.
  intros x m Nm D.
  rewrite eqm_minus_0 in D.
  rewrite divide_eqm in D; notzero.
  destruct (Zdivide_inf _ _ D) as (k, Ek).
  replace x with (x - m + m) by ring.
  rewrite Ek.
  apply eqm_minus_0.
  ring_simplify.
  apply divide_eqm; notzero.
  exists (k + k ^ 2).
  ring.
Qed.


(* begin hide *)

Unset Implicit Arguments.
Set Asymmetric Patterns.
Axiom todo : forall {A}, A.
Ltac todo := apply todo.
(* end hide *)

Class Monoid {A:Type} (dot : A -> A -> A) (one : A) : Type :=
  { dot_assoc : forall x y z : A, dot x (dot y z) = dot (dot x y) z;
    one_left : forall x, dot one x = x;
    one_right : forall x, dot x one = x }.

Generalizable Variables A dot one.

(** %\end{frame}\begin{frame}\frametitle{Generic notations}%
   Global names for parameters: *)

Definition monop `{Monoid A dot one} := dot.
Definition monunit `{Monoid A dot one} := one.

(** Generic notations: *)

Infix "*" := monop.
Notation "1" := monunit.

Section Reification.
  Context `{Monoid A dot one}.

  Inductive MonoidExpr A :=
  | monoid_cst : A -> MonoidExpr A (* for any constant not recognized as the unit or operation *)
  | monoid_unit : MonoidExpr A
  | monoid_op : MonoidExpr A -> MonoidExpr A -> MonoidExpr A.

  Fixpoint interp (e : MonoidExpr A) : A :=
    match e with
    | monoid_cst x => x
    | monoid_unit => one
    | monoid_op x y => dot (interp x) (interp y)
    end.

  Class ReifyExpr (a : A) :=
    { reified_expr : MonoidExpr A;
      reified_correct : interp reified_expr = a }.

  Instance reify_var (a : A) : ReifyExpr a | 100 := {| reified_expr := monoid_cst _ a |}.
  Proof. reflexivity. Defined.

  Instance reify_op (a b : A) (ra : ReifyExpr a) (rb : ReifyExpr b) : ReifyExpr (dot a b) :=
    {| reified_expr := monoid_op _ (reified_expr (a:=a)) (reified_expr (a:=b)) |}.
  Proof. simpl. rewrite !reified_correct. reflexivity. Defined.

  Instance reify_unit : ReifyExpr one :=
    {| reified_expr := monoid_unit _ |}.
  Proof. simpl. reflexivity. Defined.

  Fixpoint simplify_expr (x : MonoidExpr A) : MonoidExpr A :=
    match x with
    | monoid_op x y =>
      match simplify_expr x, simplify_expr y with
      | monoid_unit, y => y
      | x, monoid_unit => x
      | x, y => monoid_op _ x y
      end
    | x => x
    end.

  (* Show it is correct: it should only apply valid laws of the monoid *)
  Lemma simplify_expr_correct (e : MonoidExpr A) : interp (simplify_expr e) = interp e.
  Proof.
    induction e; simpl; auto.
    destruct (simplify_expr e1) eqn:eq1;
    destruct (simplify_expr e2) eqn:eq2;
    rewrite <- IHe1, <- IHe2;
    simpl in *; auto. subst; auto. now rewrite one_right.
    now rewrite one_left.
    now rewrite one_left.
    now rewrite (one_left (one:=one)).
    now rewrite (one_right (one:=one)).
  Qed.

  (* Using correctness, show that simplifying a reified expression for [a]
     and interpreting it back gives a term equal to [a] *)
  Lemma simplify_monoid (a : A) {e : ReifyExpr a} : a = interp (simplify_expr reified_expr).
  Proof.
    rewrite simplify_expr_correct.
    now rewrite reified_correct.
  Qed.

  (** This proof script should go through once the above is finished. *)
  Example simpl_goal (x : A) : monop x monunit = x.
  Proof. pose proof (simplify_monoid (monop x monunit)) as Heq.
    simpl in Heq. assumption. Qed.

End Reification.v


(** * 6.822 Formal Reasoning About Programs, Spring 2020 - Pset 5 *)

(* Author: Samuel Gruetter <gruetter@mit.edu> *)

Require Import Frap.Frap.
Require Import Pset5Sig.

(* Delete this line if you don't like bullet points and errors like
   "Expected a single focused goal but 2 goals are focused." *)
(* Set Default Goal Selector "!". *)

(* In this pset, we will explore different ways of defining semantics for the
   simple imperative language we used in Chapter 4 (Interpreters.v) and
   Chapter 7 (OperationalSemantics.v).
   Make sure to re-read these two files, because many definitions we ask you
   to come up with in this pset are similar to definitions in these two files.

   Pset5Sig.v contains the number of points you get for each definition and
   proof. Note that since we ask you to come up with some definitions
   yourself, all proofs being accepted by Coq does not necessarily guarantee a
   full score: You also need to make sure that your definitions correspond to
   what we ask for in the instructions. *)

(* Our language has arithmetic expressions (note that we removed Times and Minus,
   because they don't add anything interesting for this pset): *)
Inductive arith : Set :=
| Const(n: nat)
| Var(x: var)
| Plus(e1 e2: arith).

(* And it has commands, some of which contain arithmetic expressions: *)
Inductive cmd :=
| Skip
| Assign(x: var)(e: arith)
| Sequence(c1 c2: cmd)
| If(e: arith)(thn els: cmd)
| While(e: arith)(body: cmd).

(* As in the lecture, we use a finite map to store the values the variables: *)
Definition valuation := fmap var nat.

(* To make it a bit more interesting, we add a twist:
   If an arithmetic expression reads an undefined variable, instead of just
   returning 0, we specify that an arbitrary value can be returned.
   Therefore, the signature we used in class,

     Fixpoint interp (e : arith) (v : valuation) : nat := ...

   will not work any more, because that one can only return one value.
   Instead, we will use the following definition: *)
Fixpoint interp(e: arith)(v: valuation)(a: nat): Prop :=
  match e with
  | Const n => a = n
  | Var x =>
    match v $? x with
    | None => True (* any a is possible! *)
    | Some n => a = n
    end
  | Plus e1 e2 => exists a1 a2, interp e1 v a1 /\ interp e2 v a2 /\ a = a1 + a2
  end.
(* You can read "interp e v a" as the claim "interpreting expression e under
   the valuation v can return the value a".
   And if we don't provide the last argument, we can think of "interp e v",
   which has type "nat -> Prop", as "the set of all possible values e could
   return". *)

(* For example, if we interpret the expression "y+z" in a valuation where
   y is defined to be 2, but z is undefined, we can get any value for z,
   so the possible results are all values greater or equal to 2. *)
Goal interp (Plus (Var "y") (Var "z")) ($0 $+ ("y", 2)) = (fun a => 2 <= a).
Proof.
  simplify.
  apply sets_equal.
  split; simplify.
  - invert H. invert H0. linear_arithmetic.
  - exists 2, (x - 2). linear_arithmetic.
Qed.
(* Hint which will be useful later:
   In the above proof, you can see how you can deal with existentials:
   - If you have an "H: exists x, P" above the line, you can "invert H"
     do obtain such an "x" and an "H0: P".
   - If you have an "exists x, P" below the line, you can use "exists y"
     to provide the value for which you want to prove the existential. *)

(* An alternative way of specifying how arithmetic expressions are evaluated
   is by using inference rules, where we put preconditions above the line,
   and the conclusion below the line, and a name of the rule to the right of
   the line, and use "Oxford brackets" to write statements of the form
   "a ∈ [[e]]_v" which we read as "the natural number a is in the set of
   values to which e can evaluate under the valuation v".
   If we were to write this on a blackboard, it might look like this:

                      ------------ ValuesConst
                      n ∈ [[n]]_v

                       ( x ↦  a) ∈  v
                      ------------ ValuesVarDefined
                      a ∈ [[x]]_v

                      x ∉  dom(v)
                     ------------- ValuesVarUndefined
                     a ∈ [[x]]_v

          a1 ∈ [[e1]]_v   a2 ∈ [[e2]]_v   a= a1 + a2
          ----------------------------------------- ValuesPlus
                     a ∈ [[e1+e2]]_v

   Let's translate this to an Inductive Prop in Coq called "values", that is,
   "values e v a" should mean "the natural number a is in the set of
   values to which e can evaluate under the valuation v".
   Define an Inductive with four constructors, one for each of the four rules
   above, using the names written to the right of the lines above as the
   constructor names.
*)
Inductive values: arith -> valuation -> nat -> Prop :=
  | ValuesConst : forall v a, values (Const a) v a
  | ValuesVarDefined : forall v x a, v $? x = Some a -> values (Var x) v a
  | ValuesVarUndefined : forall v x a,  v $? x = None -> values (Var x) v a
  | ValuesPlus : forall a1 a2 e1 e2 v a, values e1 v a1 -> values e2 v a2 -> a = a1 + a2 -> values (Plus e1 e2) v (a).
(* Note that the following alternative would also work for ValuesPlus:

          a1 ∈ [[e1]]_v     a2 ∈ [[e2]]_v
          --------------------------------- ValuesPlus
                a1+a2 ∈ [[e1+e2]]_v

   But in Coq, this would be a bit less convenient, because the tactic
   "eapply ValuesPlus" would only work if the goal is of the shape
   "values _ _ (_ + _)", whereas if we add this extra equality,
   "eapply ValuesPlus" works no matter what the last argument to "values" is. *)

(* Contrary to the Fixpoint-based definition "interp", we can't do simplification
   of the kind "replace interp by its body and substitute the arguments in it",
   because an Inductive Prop describes a family of proof trees, and isn't a
   function with a right-hand side you could plug in somewhere else.
   In order to prove the example Goal from above for "values", we need to construct
   the following proof tree:

  ("y"↦2) ∈ {"y"↦2}                         "z" ∉ dom({"y"↦2})
 -------------------- ValuesVarDefined      ------------------------ ValuesVarUndefined
 2 ∈ [["y"]]_{"y"↦2}                        a-2 ∈ [["z"]]_{"y"↦2}                          a=2+a-2
 ---------------------------------------------------------------------------------------------------- ValuesPlus
                                a ∈ [["y"+"z"]]_{"y"↦2}
*)
Example values_example: forall a,
    2 <= a ->
    values (Plus (Var "y") (Var "z")) ($0 $+ ("y", 2)) a.
Proof.
  (* "simplify" only introduces the hypotheses but can't really simplify
     anything here. This is not a limitation of "simplify", but by design. *)
  simplify.
  (* Once you define the four constructors for "values", you can uncomment
     the script below. Make sure you understand how it relates to the proof
     tree above! *)
  eapply ValuesPlus with (a1 := 2) (a2 := a - 2).
  - eapply ValuesVarDefined. simplify. equality.
  - eapply ValuesVarUndefined. simplify. equality.
  - linear_arithmetic.
Qed.

Lemma constructor_const_impl: forall n v a, interp (Const n) v a -> values (Const n) v a.
Proof.
simplify.
rewrite H.
econstructor.
Qed.

Lemma constructor_var_impl: forall x v a, interp (Var x) v a -> values (Var x) v a.
Proof.
- simplify.
  cases (v $? x).
  + econstructor. equality.
  + eapply ValuesVarUndefined. equality.
Qed.

(* Now, let's prove that "interp" and "values" are equivalent: *)
Theorem interp_to_values: forall e v a,
    interp e v a -> values e v a.
Proof.
  simplify.
  induct e.
  - apply constructor_const_impl. assumption.
  - apply constructor_var_impl.   assumption.
  - invert H.
    invert H0.
    propositional.
    apply IHe1 in H0.
    apply IHe2 in H.
    simplify.
    apply ValuesPlus with (a1:=x) (a2:=x0); assumption.
Qed.

(* To prove the other direction, we can induct on the proof tree of "values" *)
Theorem values_to_interp: forall e v a,
    values e v a -> interp e v a.
Proof.
  induct 1; (* <-- do not change this line *)
    simplify.
    equality.
    cases (v $? x).
    assert (n = a) by equality. equality.
    equality.
    rewrite H.
    equality.
    exists a1, a2.
    propositional.
Qed.

(* Note that we could also induct on e, but this is a bit more work
   (let's still do it as an exercise, though). *)
Theorem values_to_interp_induction_on_e: forall e v a,
    values e v a -> interp e v a.
Proof.
  induct e; (* <-- BAD, but for the sake of the exercise, do not change this line *)
    simplify.
    invert H.
    equality.
    cases  (v $? x).
    simplify.

    invert H.
    equality.
    equality.
    equality.
    invert H.
    specialize (IHe1 v a1).
    specialize (IHe2 v a2).
    exists a1, a2.
    propositional.
Qed.
(* Let's define nondeterministic big-step semantics for evaluating a command.
   Define "eval" as an Inductive Prop such that "eval v1 c v2" means
   "If we run command c on valuation v1, we can obtain valuation v2".
   Whenever you encounter an arithmetic expression, use "values" to obtain a
   value it can step to.
   Hint: This will be quite similar to "eval" in OperationalSemantics.v! *)
Inductive eval : valuation -> cmd -> valuation -> Prop :=
  | EvalSkip : forall v,
    eval v Skip v
  | EvalAssign : forall v x e a,
    interp e v a -> eval v (Assign x e) (v $+ (x, a))
  | EvalSeq : forall v c1 v1 c2 v2,
    eval v c1 v1
    -> eval v1 c2 v2
    -> eval v (Sequence c1 c2) v2
  | EvalIfTrue : forall n v e thn els v',
    interp e v n
    -> n <> 0
    -> eval v thn v'
    -> eval v (If e thn els) v'
  | EvalIfFalse : forall v e thn els v',
    interp e v 0
    -> eval v els v'
    -> eval v (If e thn els) v'
  | EvalWhileTrue : forall n v e body v' v'',
    interp e v n
    -> n <> 0
    -> eval v body v'
    -> eval v' (While e body) v''
    -> eval v (While e body) v''
  | EvalWhileFalse : forall v e body,
    interp e v 0
    -> eval v (While e body) v.

(* Before you continue your epic journey through this adventure game, I want
   to give you another tool. It's much more powerful than any combination of
   "invert", "simplify", "exists", "eapply", etc you could ever imagine, so
   please make sure to keep the following tool at an easy to access place in
   your toolbox. Here it is, in the form of a hint:

   Hint: Many of the proofs below will depend on definitions we ask you to
   find yourself, and if you get these definitions wrong, the proofs will
   not work, so keep in mind that you might have to go back and adapt your
   definitions!
   Also, it can happen that many proofs go through and you become (overly)
   confident that your definitions are correct, even though they aren't. *)

(* Here's an example program. If we run it on the empty valuation, reading the
   variable "oops" can return any value, but after that, no matter whether
   "oops" was zero or not, we assign a non-zero value to "tmp", so the answer
   will always be 42. *)
Example the_answer_is_42 :=
  Sequence (Assign "x" (Var "oops"))
           (Sequence (If (Var "x")
                         (Assign "tmp" (Plus (Var "x") (Var "x")))
                         (Assign "tmp" (Const 1)))
                     (If (Var "tmp")
                         (Assign "answer" (Const 42))
                         (Assign "answer" (Const 24)))).

(* To prove that this sample program always returns 42, we first prove a handy
   helper lemma: *)
Lemma read_last_value: forall x v c n,
    values (Var x) (v $+ (x, c)) n -> n = c.
Proof.
  simplify.
  apply values_to_interp in H.
  simplify.
  equality.
Qed.

(* Hint: This one is a bit boring -- it's about 30 lines of "invert", "simplify",
   "discriminate", "equality", "exfalso", "linear_arithmetic" and
   "apply read_last_value in H", "subst" in our solution.
   But it's a good test case to make sure you got the definition of "eval" right!
   And note that inverting the hypotheses in the right order, i.e.
   in the order the program is executed, as well as using read_last_value
   whenever possible, will make your proof less long. *)
Theorem the_answer_is_indeed_42:
  forall v, eval $0 the_answer_is_42 v -> v $? "answer" = Some 42.
Proof.
  simplify.
  invert H.
  simplify.
  invert H3.
  simplify.
  invert H5.
  simplify.
  - simplify.
    invert H2.
    + simplify.
      invert H8.
      simplify.
      invert H3.
      invert H.
      propositional.
      invert H6.
      simplify.
      invert H11.
      simplify.
      equality.
      simplify.
      invert H10.
      simplify.
      linear_arithmetic.
    + simplify.
      invert H7.
      simplify.
      invert H6.
      simplify.
      invert H8.
      simplify.
      equality.
      simplify.
      equality.
Qed.

(* Here's another example program. If we run it on a valuation which is
   undefined for "x", it will read the undefined variable "x" to decide
   whether to abort the loop, so any number of loop iterations is possible. *)
Example loop_of_unknown_length :=
  (While (Var "x") (Assign "counter" (Plus (Var "counter") (Const 1)))).

(* Hint: you might need the "maps_equal" tactic to prove that two maps are the same. *)
Theorem eval_loop_of_unknown_length: forall n initialCounter,
    eval ($0 $+ ("counter", initialCounter))
         loop_of_unknown_length
         ($0 $+ ("counter", initialCounter + n)).
Proof.
  unfold loop_of_unknown_length.
  induct n; simplify.
  + replace (initialCounter + 0) with initialCounter by linear_arithmetic.
    eapply EvalWhileFalse.
    simplify.
    equality.
  +
    eapply EvalWhileTrue.
    simplify.
    equality.
    eauto.
    econstructor.
    simplify.
    exists initialCounter, 1.
    propositional.
    specialize (IHn (initialCounter + 1)).
    replace ($0 $+ ("counter", initialCounter) $+ ("counter", initialCounter + 1)) with ($0 $+ ("counter", initialCounter + 1)) by maps_equal.
    replace (initialCounter + S n) with (initialCounter + 1 + n) by linear_arithmetic.
    assumption.
Qed.

(* Wherever this TODO_FILL_IN is used, you should replace it with your solution *)
Axiom TODO_FILL_IN: Prop.

(* You might wonder whether we can use "Fixpoint" instead of "Inductive" to define
   such nondeterministic big-step evaluation of commands, and indeed we can.
   But we need some trick to convince Coq that this Fixpoint will always terminate,
   even though there could be infinite loops.
   We achieve this by using a "fuel" argument that limits the recursion depth.
   This does not exclude any possible final valuations, because for every final
   valuation, there exists a recursion depth sufficient to reach it.
   So let's define a Fixpoint "run" such that "run fuel v1 c v2" means
   "if we run command c on valuation v1, and limit the recursion depth to fuel,
   we can obtain valuation v2".
   We already defined all cases for you except the "While" case, but all the
   building blocks you need can be found in the other cases too.
 *)
Fixpoint run(fuel: nat)(v1: valuation)(c: cmd)(v2: valuation): Prop :=
  match fuel with
  | O => False
  | S fuel' =>
    match c with
    | Skip => v1 = v2
    | Assign x e => exists a, interp e v1 a /\ v2 = (v1 $+ (x, a))
    | Sequence c1 c2 => exists vmid, run fuel' v1 c1 vmid /\ run fuel' vmid c2 v2
    | If e c1 c2 =>
      (exists r, interp e v1 r /\ r <> 0 /\ run fuel' v1 c1 v2) \/
      (interp e v1 0 /\ run fuel' v1 c2 v2)
    | While e c1 =>
      (interp e v1 0 /\ v1 = v2) \/
      (exists v', exists r, interp e v1 r /\ r <> 0 /\ run fuel' v1 c1 v' /\ run fuel' v' (While e c1) v2)
    end
  end.

(* Now let's prove that "run" and "eval" are equivalent! *)
(*Lemma running_with_more_fuel: forall fuel v1 c v2, run (S fuel) v1 c v2 -> run fuel v1 c v2.
Proof.
  induct fuel.
  simplify.
  cases c.
  equality.
  simplify.
*)
Theorem run_to_eval: forall fuel v1 c v2,
    run fuel v1 c v2 ->
    eval v1 c v2.
Proof.
  simplify.
  induct fuel.
  simplify.
  equality.

  simplify.

  cases c.
  rewrite H.
  eapply EvalSkip.

  invert H.
  propositional.
  rewrite H1.
  eapply EvalAssign.
  assumption.

  invert H.
  propositional.
  eapply EvalSeq.
  eauto.
  apply IHfuel.
  assumption.

  {
    invert H.
    invert H0.

    propositional.
    eapply EvalIfTrue.
    eauto.
    assumption.
    apply IHfuel.
    assumption.

    propositional.
    eapply EvalIfFalse.
    eauto.
    apply IHfuel.
    assumption.
  }

  propositional.
  rewrite <- H1.
  eapply EvalWhileFalse.
  assumption.

  invert H0.
  invert H.
  propositional.
  eapply EvalWhileTrue.

  eauto.
  assumption.
  eauto.
  apply IHfuel.
  assumption.
Qed.

(* For the other direction, we could naively start proving it like this: *)
Theorem eval_to_run: forall v1 c v2,
    eval v1 c v2 ->
    exists fuel, run fuel v1 c v2.
Proof.
  induct 1; simplify.

  exists 1.
  simplify.
  equality.

  exists 1.
  simplify.
  exists a.
  propositional.

  exists 1.
  simplify.
  eexists.
  equality.
  propositional.
  invert IHeval1.
  invert IHeval2.
  simplify.
  (* feel free to prove part of this to experience how tedious the existentials
     are, but don't waste too much time on it, because there's a better way
     to do it below! *)
Abort. (* <-- do not change this line *)

(* To prove the other direction, we will first define a wrapper around "run"
   that hides the existential: *)
Definition wrun(v1: valuation)(c: cmd)(v2: valuation): Prop :=
  exists fuel, run fuel v1 c v2.

(* The idea is that in the run_to_eval proof above, using the constructors of
   "eval", i.e. doing "eapply EvalAssign", "eapply EvalSeq", "eapply EvalIfTrue",
   was quite convenient, so let's expose the same "API" for constructing proofs
   of "run" (or actually, proofs of the slightly nicer "wrun"). *)

(* But first, we need a helper lemma run_monotone.
   Hint: Here, some proof automation might pay off!
   You could try writing a "repeat match goal" loop, to do all possible
   simplifications on your hypotheses, and then use "eauto" to solve
   the goal. Maybe you need to increase the maximum search depth of eauto;
   in our solution, we had to write "eauto 10" instead of just "eauto",
   which defaults to "eauto 5".
   And note that "eauto" does not know about linear arithmetic by default,
   so either you have to register that as an extern hint, but a simpler
   way here would be to use the lemma "le_S_n" to turn "S fuel1 <= S fuel2"
   into "fuel1 <= fuel2", which will be needed for the IH. *)

Lemma run_monotone_less_fuel_impl: forall fuel1 v1 c v2,
  run fuel1 v1 c v2 -> run (S fuel1) v1 c v2.
Proof.
  induct fuel1.
  simplify.
  equality.

  intros.
  cases c.
  assumption.
  assumption.
  invert H.
  propositional.

  + apply IHfuel1 in H.
    apply IHfuel1 in H1.
    econstructor.
    eauto.
  +
    simpl in H.
    invert H.
    invert H0.
    propositional.
    apply IHfuel1 in H2.
    econstructor.
    eexists.
    eauto.

    propositional.
    apply IHfuel1 in H1.
    constructor 2.
    propositional.
  +
    simpl in H.
    invert H.
    - propositional.
      econstructor 1.
      propositional.
    - invert H0.
      invert H.
      propositional.
      econstructor 2.
      eexists.
      eexists.
      apply IHfuel1 in H1.
      propositional.
      eauto.
      linear_arithmetic.
      eauto.
      apply IHfuel1 in H3.
      assumption.
Qed.

Lemma run_monotone: forall fuel1 fuel2 v1 c v2,
    fuel1 <= fuel2 ->
    run fuel1 v1 c v2 ->
    run fuel2 v1 c v2.
Proof.
  induct 1.
  trivial.
  induct m.
  apply le_lt_or_eq in H.
  cases H.
  linear_arithmetic.
  rewrite H.
  simplify. equality.

  intros.
  apply IHle in H0.
  apply run_monotone_less_fuel_impl.
  assumption.
Qed.

(* Now let's define proof rules to get the same "API" for "wrun" as for "eval".
   Hint: Again, some proof automation might simplify the task (but manual proofs are
   possible too, of course). *)

Lemma WRunSkip: forall v,
    wrun v Skip v.
Proof.
simplify.
eexists 1.
simplify.
equality.
Qed.

Lemma WRunAssign: forall v x e a,
    interp e v a ->
    wrun v (Assign x e) (v $+ (x, a)).
Proof.
  exists 1.
  simplify.
  exists a.
  propositional.
Qed.

Lemma WRunSeq: forall v c1 v1 c2 v2,
    wrun v c1 v1 ->
    wrun v1 c2 v2 ->
    wrun v (Sequence c1 c2) v2.
Proof.
  simplify.
  invert H.
  invert H0.

  exists (S x + S x0).
  simplify.
  econstructor.
  propositional.
  apply run_monotone with (fuel2:= x + S x0) in H1; eauto; linear_arithmetic.
  apply run_monotone with (fuel2:= x + S x0) in H; eauto; linear_arithmetic.
Qed.

Lemma WRunIfTrue: forall n v e thn els v',
  interp e v n ->
  n <> 0 ->
  wrun v thn v' ->
  wrun v (If e thn els) v'.
Proof.
  simplify.
  invert H1.
  exists (S x).
  econstructor.
  eexists.
  propositional.
  eauto.
  equality.
Qed.

Lemma WRunIfFalse: forall v e thn els v',
    interp e v 0
    -> wrun v els v'
    -> wrun v (If e thn els) v'.
Proof.
  simplify.
  invert H0.
  exists (S x).
  econstructor 2.
  propositional.
Qed.

Lemma WRunWhileTrue: forall n v e body v' v'',
    interp e v n
    -> n <> 0
    -> wrun v body v'
    -> wrun v' (While e body) v''
    -> wrun v (While e body) v''.
Proof.
  simplify.
  invert H1.
  invert H2.
  exists (S x + S x0).
  econstructor 2.
  eexists.
  eexists.
  propositional.
  eauto.
  equality.
  apply run_monotone with (fuel2:= x + S x0) in H3; eauto; linear_arithmetic.
  apply run_monotone with (fuel2:= x + S x0) in H1; eauto; linear_arithmetic.
Qed.

Lemma WRunWhileFalse: forall v e body,
    interp e v 0
    -> wrun v (While e body) v.
Proof.
simplify.
exists 1.
econstructor.
propositional.
Qed.

(* Now, thanks to these helper lemmas, proving the direction from eval to wrun
   becomes easy: *)
Theorem eval_to_wrun: forall v1 c v2,
    eval v1 c v2 ->
    wrun v1 c v2.
Proof.
  induct 1.
  apply WRunSkip.
  apply WRunAssign; assumption.
  apply WRunSeq with (v:=v) (c1:=c1)(v1:=v1); assumption.
  apply WRunIfTrue with (v:=v) (n:=n);assumption.
  apply WRunIfFalse with (v:=v) ;assumption.
  apply WRunWhileTrue with (n:=n) (v:=v) (v':=v'); assumption.
  apply WRunWhileFalse with (v:=v) (e:=e); assumption.
Qed.

(* The following definitions are needed because of a limitation of Coq
   (the kernel does not recognize that a parameter can be instantiated by an
   inductive type).
   Please do not remove them! *)
Definition values_alias_for_grading := values.
Definition eval_alias_for_grading := eval.

(* You've reached the end of this pset, congratulations! *)

(* ****** Everything below this line is optional ****** *)

(* Let's take the deterministic semantics we used in OperationalSemantics.v, but
   prefix them with "d" to mark them as deterministic: *)

Fixpoint dinterp(e: arith)(v: valuation): nat :=
  match e with
  | Const n => n
  | Var x =>
    match v $? x with
    | None => 0
    | Some n => n
    end
  | Plus e1 e2 => dinterp e1 v + dinterp e2 v
  end.

Inductive deval: valuation -> cmd -> valuation -> Prop :=
| DEvalSkip: forall v,
    deval v Skip v
| DEvalAssign: forall v x e,
    deval v (Assign x e) (v $+ (x, dinterp e v))
| DEvalSeq: forall v c1 v1 c2 v2,
    deval v c1 v1 ->
    deval v1 c2 v2 ->
    deval v (Sequence c1 c2) v2
| DEvalIfTrue: forall v e thn els v',
    dinterp e v <> 0 ->
    deval v thn v' ->
    deval v (If e thn els) v'
| DEvalIfFalse: forall v e thn els v',
    dinterp e v = 0 ->
    deval v els v' ->
    deval v (If e thn els) v'
| DEvalWhileTrue: forall v e body v' v'',
    dinterp e v <> 0 ->
    deval v body v' ->
    deval v' (While e body) v'' ->
    deval v (While e body) v''
| DEvalWhileFalse: forall v e body,
    dinterp e v = 0 ->
    deval v (While e body) v.

Lemma interp_same_dinerp: forall e v, interp e v (dinterp e v).
Proof.
  induct e; simplify; try equality.
  cases ( v $? x); try equality.
  exists (dinterp e1 v).
  exists (dinterp e2 v).
  specialize (IHe1 v).
  specialize (IHe2 v).
  propositional.
Qed.

(* Now let's prove that if a program evaluates to a valuation according to the
   deterministic semantics, it also evaluates to that valuation according to
   the nondeterministic semantics (the other direction does not hold, though). *)
Theorem deval_to_eval: forall v1 v2 c,
    deval v1 c v2 ->
    eval v1 c v2.
Proof.
  induct 1; simplify.
  econstructor.
  + econstructor.
    apply interp_same_dinerp.
  + econstructor; eauto; assumption.
  + econstructor. instantiate (1:= dinterp e v). apply interp_same_dinerp.
    assumption. assumption.
  + constructor. replace 0 with (dinterp e v). apply interp_same_dinerp. assumption.
  + econstructor. instantiate (1:=dinterp e v). apply interp_same_dinerp.
    assumption. eauto. assumption.
  + constructor. replace 0 with (dinterp e v). apply interp_same_dinerp.
Qed.

(* In deterministic semantics, Fixpoints work a bit better, because they
   can return just one value, and let's use "option" to indicate whether
   we ran out of fuel: *)
Fixpoint drun(fuel: nat)(v: valuation)(c: cmd): option valuation :=
  match fuel with
  | O => None
  | S fuel' =>
    match c with
    | Skip => Some v
    | Assign x e => Some (v $+ (x, (dinterp e v)))
    | Sequence c1 c2 =>
        match (drun fuel' v c1) with
        | None => None
        | Some v2 => drun fuel' v2  c2
        end
    | If e c1 c2 =>
        match (dinterp e v) with
        | 0 =>   drun fuel' v c2
        | _ =>   drun fuel' v c1
        end
    | While e c1 =>
        match (dinterp e v) with
        | 0 => Some v
        | _ => match (drun fuel' v c1) with
               | None => None
               | Some v2 => drun fuel' v2 (While e c1)
               end
        end
    end
  end.

Lemma run_once: forall fuel1 v1 c,
  drun (S fuel1) v1 c =  match c with
    | Skip => Some v1
    | Assign x e => Some (v1 $+ (x, dinterp e v1))
    | Sequence c1 c2 =>
        match drun fuel1 v1 c1 with
        | Some v2 => drun fuel1 v2 c2
        | None => None
        end
    | If e c1 c2 =>
        match dinterp e v1 with
        | 0 => drun fuel1 v1 c2
        | S _ => drun fuel1 v1 c1
        end
    | While e c1 =>
        match dinterp e v1 with
        | 0 => Some v1
        | S _ =>
            match drun fuel1 v1 c1 with
            | Some v2 => drun fuel1 v2 (While e c1)
            | None => None
            end
        end
    end.
Proof.
  equality.
Qed.

Lemma drun_monotone_less_fuel_impl: forall fuel1 v1 c v2,
  drun fuel1 v1 c = Some v2 -> drun (S fuel1) v1 c = Some v2.
Proof.
  induct fuel1.
  simplify.
  equality.

  intros.
  cases c.
  simpl in H.
  + simpl; try assumption.
  + simpl; try assumption.
  + rewrite run_once. simpl in H. cases (drun fuel1 v1 c1).
    - apply IHfuel1 in Heq. rewrite Heq. apply IHfuel1 in H. assumption.
    - equality.
  + rewrite run_once. simpl in H. cases (dinterp e v1).
    - apply IHfuel1 in H. assumption.
    - apply IHfuel1 in H. assumption.
  + rewrite run_once. simpl in H. cases (dinterp e v1).
    - assumption.
    - cases (drun fuel1 v1 c).
     --  apply IHfuel1 in Heq0. rewrite Heq0. apply IHfuel1 in H. assumption.
     -- equality.
Qed.

Lemma drun_monotone: forall fuel1 fuel2 v1 c v2,
    fuel1 <= fuel2 ->
    drun fuel1 v1 c = Some v2 ->
    drun fuel2 v1 c = Some v2.
Proof.
  induct 1.
  trivial.
  induct m.
  apply le_lt_or_eq in H.
  cases H.
  linear_arithmetic.
  rewrite H.
  simplify. equality.

  intros.
  apply IHle in H0.
  apply drun_monotone_less_fuel_impl.
  assumption.
Qed.

Definition dwrun(v1: valuation)(c: cmd)(v2: valuation): Prop :=
  exists fuel, drun fuel v1 c = Some v2.

Lemma dWRunSkip: forall v,
    dwrun v Skip v.
Proof.
simplify.
eexists 1.
simplify.
equality.
Qed.

Lemma dWRunAssign: forall v x e a,
    dinterp e v = a ->
    dwrun v (Assign x e) (v $+ (x, a)).
Proof.
  exists 1.
  simplify.
  rewrite H.
  equality.
Qed.

Lemma dWRunSeq: forall v c1 v1 c2 v2,
    dwrun v c1 v1 ->
    dwrun v1 c2 v2 ->
    dwrun v (Sequence c1 c2) v2.
Proof.
  simplify.
  invert H.
  invert H0.

  exists (S (x + x0)).
  rewrite run_once.
  apply drun_monotone with (fuel1:= x) (fuel2:= (x + x0)) in H1.
  rewrite H1.
  apply drun_monotone with (fuel2:= (x + x0)) in H.
  assumption.
  linear_arithmetic.
  linear_arithmetic.
Qed.

Lemma dWRunIfTrue: forall v e thn els v',
  dinterp e v <> 0 ->
  dwrun v thn v' ->
  dwrun v (If e thn els) v'.
Proof.
  simplify.
  invert H0.
  exists (S x).
  cases (dinterp e v).
  equality.
  simpl.
  rewrite Heq.
  assumption.
Qed.

Lemma dWRunIfFalse: forall v e thn els v',
    dinterp e v = 0
    -> dwrun v els v'
    -> dwrun v (If e thn els) v'.
Proof.
  simplify.
  invert H0.
  exists (S x).
  rewrite run_once.
  cases (dinterp e v).
  equality.
  equality.
Qed.

Lemma dWRunWhileFalse: forall v e body,
    dinterp e v = 0
    -> dwrun v (While e body) v.
Proof.
simplify.
exists 1.
simpl.
cases (dinterp e v); equality.
Qed.

Lemma dWRunWhileTrue: forall v e body v' v'',
    dinterp e v <> 0
    -> dwrun v body v'
    -> dwrun v' (While e body) v''
    -> dwrun v (While e body) v''.
Proof.
  simplify.
  invert H1.
  invert H0.
  exists (S (x + x0)).
  rewrite run_once.
  cases (dinterp e v ).
  equality.
  apply drun_monotone with (fuel2:= x + x0) in H1. rewrite H1.
  apply drun_monotone with (fuel2:=x + x0) in H2. assumption.
  linear_arithmetic.
  linear_arithmetic.
Qed.

Lemma deval_to_drun: forall v1 c v2,
  deval v1 c v2 -> exists f, drun f v1 c = Some v2.
Proof.
  induct 1.
  apply dWRunSkip.
  apply dWRunAssign. equality.
  apply dWRunSeq with (v:=v) (c1:=c1)(v1:=v1); assumption.
  apply dWRunIfTrue with (v:=v); assumption.
  apply dWRunIfFalse with (v:=v) ;assumption.
  apply dWRunWhileTrue with (v:=v) (v':=v'); assumption.
  apply dWRunWhileFalse with (v:=v) (e:=e); assumption.
Qed.

Lemma drun_to_run: forall f v1 c v2 ,
  drun f v1 c = Some v2 -> run f v1 c v2.
Proof.
  induct f.

  simplify.
  equality.
  intros.
  cases c.
  + simplify. equality.
  + simplify. econstructor. eexists. instantiate (1:=dinterp e v1). apply interp_same_dinerp. equality.
  + rewrite run_once in H. cases (drun f v1 c1).
   - econstructor. instantiate (1:= v). propositional; first_order.
   - equality.
  + simplify. cases (dinterp e v1). econstructor 2. propositional. rewrite <- Heq. apply interp_same_dinerp. apply IHf. assumption.
    econstructor 1. exists (S n). propositional. rewrite <- Heq. apply interp_same_dinerp. equality. apply IHf. assumption.
  + simplify. cases (dinterp e v1).
    - econstructor 1. propositional; try equality. rewrite <- Heq. apply interp_same_dinerp.
    - cases (drun f v1 c). econstructor 2. eexists. eexists. propositional. instantiate (1:= S n). rewrite <- Heq. apply interp_same_dinerp. equality.
      apply IHf. eauto. apply IHf. assumption. equality.
Qed.

(* More open-ended exercise:
   Now we have six different definitions of semantics:

                        deterministic     nondeterministic

   Inductive            deval             eval

   Wrapped Fixpoint     dwrun             wrun

   Fixpoint             drun              run

   We have proved that all the nondeterministic semantics are equivalent among
   each other.
   If you want, you could also prove that all the deterministic semantics are
   equivalent among each other and experiment whether it's worth creating an
   "Inductive"-like API for "dwrun", or whether you're ok dealing with drun's
   existentials when proving deval_to_drun.
   Moreover, we have proved that "deval" implies "eval", so every definition in
   the left column of the above table implies every definition in the right
   column of the table.
   If you're curious to learn more about the trade-offs between Inductive Props
   and Fixpoints, you can try to prove some of these implications directly,
   and see how much harder than "deval_to_eval" it is (we believe that
   "deval_to_eval" is the simplest one).
 *)