(**************************************************************************
* TLC: A library for Coq                                                  *
* Examples for LibFix                                                     *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
From TLC Require Import LibTactics LibLogic LibReflect LibFun LibEpsilon LibList
  LibInt LibNat LibProd LibSum LibRelation LibWf LibFix LibStream.
Require Coq.Arith.Even. (* for demo *)
Open Scope nat_scope.
Open Scope comp_scope.
Open Scope fun_scope.

(** Setting up of automation *)

Hint Resolve wf_lt : wf.

Ltac auto_tilde ::= auto with wf.
Ltac auto_star ::= try solve [ auto | false | math | intuition eauto ].

Hint Resolve equiv_eq equiv_list_equiv.

(* ********************************************************************** *)
(** * The log function -- basic recursion *)

(** Properties of div2 *)

Lemma div2_lt : forall n m, m <= n -> n > 0 -> Nat.div2 m < n.
Proof using. (* using stdlib *)
  nat_comp_to_peano. introv Le Gt.
  forwards: Nat.div2_decr m (n-1). omega. omega.
Qed.

Lemma div2_grows : forall n m, m <= n -> Nat.div2 m <= Nat.div2 n.
Proof using.
  nat_comp_to_peano.
  induction n using peano_induction. introv Le.
  destruct~ m. simpl. omega.
  destruct~ n. simpl. omega.
  destruct~ m. simpl. omega.
  destruct~ n. simpl. omega.
  simpl. forwards~: H n m. nat_math. nat_math. nat_math.
Qed.

Module LogBasic.

(** Definition of the functional *)

Definition Log log n :=
 If n <= 1 then 0 else 1 + log (Nat.div2 n).

(** Construction of the fixed point *)

Definition log := FixFun Log.

Lemma fix_log : forall n,
  log n = Log log n.
Proof using.
  applys~ (FixFun_fix (@lt nat _)).
  introv H. unfolds. case_if~.
  fequals. apply H. apply* div2_lt.
Qed.

(** Example of unfolding of the body *)

Lemma log_double : forall n, n > 0 ->
  log(2*n) = 1 + log n.
Proof using.
  introv Pos. rewrite fix_log. unfold Log.
  case_if*. fequals. rewrite~ Nat.div2_double.
Qed.

(** Example of reasoning by induction *)

Lemma log_grows : forall n m,
  m <= n -> log m <= log n.
Proof using.
  induction n using peano_induction. introv Le.
  do 2 rewrite fix_log. unfolds Log.
  (do 2 case_if); autos*.
  forwards: H (Nat.div2 n) (Nat.div2 m).
    apply* div2_lt. apply~ div2_grows.
  math.
Qed.

(*
Extraction Language Ocaml.
Extraction Inline Log.
Set Extraction Optimize.
Extraction log.
*)

End LogBasic.

(* ********************************************************************** *)
(** * The log function, version that computes *)

Module LogCompute.
(** Example of computing inside Coq *)

Definition Log log n :=
  if le_dec n 1 then 0 else 1 + log (Nat.div2 n).

Definition log := FixFun Log.

Lemma fix_log : forall N n,
  log n = func_iter N Log log n.
Proof using.
  applys~ (FixFun_fix_iter (@lt nat _)).
  introv H. unfolds. case_if~.
  fequals. apply H. apply* div2_lt.
Qed.

Definition many_steps := 10.

Lemma log_compute : log 256 = 8.
Proof using.
  rewrite (@fix_log many_steps). dup.
  { reflexivity. }
  { applys eq_trans. unfold Log; simpl. eauto. eauto. }
  (* --TODO: eauto bug: it should try reflexivity before applying lemmas *)
Qed.

End LogCompute.

(* ********************************************************************** *)
(** * Loop on odd numbers -- partial function *)

Module OnlyEven.

(** The function [F] defined in this module returns [1]
    on any even number and "loops" on any odd number.
    It does not actually loop, since when a recursive
    call is not made on a smaller argument, the recursion
    is stopped and a dummy value is returned. *)

Definition Only_even only_even n :=
  If n = 0 then 1 else
  If n = 1 then 1 + only_even 1 else
  only_even (n - 2).

Definition only_even := FixFun Only_even.

Lemma only_even_fix : forall n, Nat.even n ->
  only_even n = Only_even only_even n.
Proof using.
  applys~ (FixFun_fix_partial (@lt nat _)).
  intros f1 f2 n Pn IH. unfolds. case_if~. case_if as C'.
  subst. inverts Pn as Pn'.
  apply* IH. math_rewrite (n = S (S (n - 2))) in Pn.
  rewrite Nat.even_succ_succ in Pn. auto.
  (* --TODO: revive the TLC definition of even to avoid dependency
     on stdlib
     inverts Pn as Pn'; tryfalse. inverts Pn'. simpl. rew_nat~. *)
Qed.

End OnlyEven.

(** Same, but now computable version *)

Module OnlyEvenCompute.

Import Coq.Arith.Even.

Definition Only_even only_even n :=
  if eq_nat_dec n 0 then 1 else
  if eq_nat_dec n 1 then 1 + only_even 1 else
  only_even (n - 2).

Definition only_even := FixFun Only_even.

Lemma only_even_fix : forall N n, even n ->
  only_even n = func_iter N Only_even only_even n.
Proof using.
  applys~ (FixFun_fix_partial_iter (@lt nat _)).
  intros f1 f2 n Pn IH. unfolds. case_if~. case_if.
  subst. inverts Pn as Pn'. inverts Pn'.
  apply* IH. inverts Pn as Pn'; tryfalse. inverts Pn'. simpl. rew_nat~.
Qed.

Definition many_steps := 100.

Lemma even_8 : even 8.
Proof using. Hint Constructors even odd. eauto 18. Qed.

Lemma only_even_compute : only_even 8 = 1.
Proof using.
  rewrite (@only_even_fix many_steps); [ | apply even_8 ].
  { reflexivity. }
Qed.

(* Note: many_steps needs to exceed the number of levels of recursion,
   else reflexivity fails. *)

End OnlyEvenCompute.

(* ********************************************************************** *)
(** * GCD function (binary currified function, by measure) *)

Definition Gcd gcd x y :=
  If x = 0 then y else
  If y = 0 then x else
  If x <= y then gcd x (y-x) else gcd (x-y) y.

(** The measure is the sum of the arguments *)

Definition gcd := FixFun2 Gcd.

Lemma fix_gcd : forall x y,
  gcd x y = Gcd gcd x y.
Proof using.
  applys~ (FixFun2_fix (measure2 plus)).
  unfold measure2. introv IH. unfolds.
  case_if~. case_if~. case_if. apply* IH. apply* IH.
Qed.

(* ********************************************************************** *)
(** * Zero function (nested recursion) *)

(** [zero n] is a function that always returns [0]. *)

Definition Zero zero n :=
  If n = 0 then 0 else zero (zero (n-1)).

Definition zero := FixFun Zero.

Lemma zero_fix : forall x, zero x = Zero zero x
              /\ forall x, zero x = 0.
Proof using.
  forwards~ [H1 H2]: (FixFun_fix_partial_inv lt pred_true (fun (x y : nat) => y = 0) (F:=Zero)).
  introv _ H. unfold Zero. case_if~.
  forwards* [H1 H2]: (H (x-1)). rewrite <- H1. rewrite H2. apply* H.
Qed.

(* ********************************************************************** *)
(** * Ackerman's function (nested non-primitive recursion, two arguments) *)

Ltac emaths := eauto with maths.

Definition Ack ack m n :=
  If m = 0 then n+1 else
  If n = 0 then ack (m-1) 1 else
  ack (m-1) (ack m (n-1)).

Definition ack := FixFun2 Ack.

Lemma fix_ack : forall m n,
  ack m n = Ack ack m n.
Proof using.
  applys~ (FixFun2_fix (lexico2 (@lt nat _) (@lt nat _))).
  introv IH. unfolds. case_if~. case_if~.
  apply IH. emaths.
  rewrite IH. fequals~. emaths. emaths.
Qed.

(* ********************************************************************** *)
(** * McCarthy's 91 function (nested recursion) *)

(** [McCarthy n] returns [n-10] if [n > 100] and returns
    [91] otherwise. It is defined using nested recursion. *)

Definition McCarthy mcCarthy n :=
  If n > 100
    then n - 10
    else mcCarthy (mcCarthy (n + 11)).

Definition mcCarthy := FixFun McCarthy.

Definition McCarthy_post n r :=
  If n > 100 then r = n - 10 else r = 91.

Lemma McCarthy_fix_post :
     (forall n, mcCarthy n = McCarthy mcCarthy n)
  /\ (forall n, McCarthy_post n (mcCarthy n)).
Proof using.
  sets meas: (fun n => If n > 100 then 0 else 101 - n).
  applys~ (FixFun_fix_inv (measure meas)). introv IH.
  unfold McCarthy. unfold McCarthy_post. case_if~.
  forwards [K1 K2]: IH (x+11). unfold measure, meas. case_if; case_if*.
  rewrite <- K1 in *. sets y: (f1(x+11)). unfolds in K2.
  forwards [L1 L2]: IH y. unfold measure, meas. case_if; case_if*. case_if*.
  rewrite <- L1 in *. sets z: (f1 y). unfolds in L2. split~.
  case_if*. case_if*.
Qed.

(** Corrolaries *)

Lemma McCarthy_fix : forall n,
  mcCarthy n = McCarthy mcCarthy n.
Proof using. apply (proj1 (McCarthy_fix_post)). Qed.

Lemma McCarthy_spec_gt100 : forall n,
  n > 100 -> mcCarthy n = n - 10.
Proof using.
  introv Lt. lets H: (proj2 McCarthy_fix_post n). unfolds in H. case_if*.
Qed.

Lemma McCarthy_spec_le100 : forall n,
  n <= 100 -> mcCarthy n = 91.
Proof using.
  introv Le. lets H: (proj2 McCarthy_fix_post n). unfolds in H. case_if*.
Qed.

(* ********************************************************************** *)
(** * Integer division (binary function) *)

(** [div n m] returns a pair [(q,r)] such that
    [n = q*m + r] with [r < m]. Its definition involves
    non-structural recursion. *)

Definition Div div n m :=
  If n < m then (0,n)
  else let (q,r) := div (n-m) m : nat*nat in
       (q+1,r).

Definition div := FixFun2 Div.

Lemma fix_div : forall n m, m <> 0 ->
  div n m = Div div n m.
Proof using.
  applys~ (FixFun2_fix_partial (measure (@fst nat nat))).
  introv Posm IH. unfold Div. case_if~.
  rewrite~ IH. unfolds. simpl. math.
Qed.

(* ********************************************************************** *)
(** * A function on trees -- higher-order recursion *)

Definition Mem A (x:A) l := Exists (=x) l. (* --TODO: move *)

(** The congruence rule for [map] on lists *)

Lemma map_congr : forall A B (f1 f2 : A->B) l,
  (forall x, Mem x l -> f1 x = f2 x) ->
  LibList.map f1 l = LibList.map f2 l.
Proof using. Hint Constructors Exists. Hint Unfold Mem.
  introv H. induction l. auto. rew_listx. fequals~.
Qed.

(** Definition of trees *)

Inductive tree : Type :=
  | leaf : nat -> tree
  | node : list tree -> tree.

Instance Inhab_tree : Inhab tree.
Proof using. intros. apply (Inhab_of_val (leaf 0)). Qed.

(** An induction principle for trees *)

Section Tree_induct.
Variables
(P : tree -> Prop)
(Q : list tree -> Prop)
(P1 : forall n, P (leaf n))
(P2 : forall l, Q l -> P (node l))
(Q1 : Q nil)
(Q2 : forall t l, P t -> Q l -> Q (t::l)).

Fixpoint tree_induct_gen (T : tree) : P T :=
  match T as x return P x with
  | leaf n => P1 n
  | node l => P2
      ((fix tree_list_induct (l : list tree) : Q l :=
      match l as x return Q x with
      | nil   => Q1
      | t::l' => Q2 (tree_induct_gen t) (tree_list_induct l')
      end) l)
  end.

End Tree_induct.

Lemma tree_induct : forall (P : tree -> Prop),
  (forall n : nat, P (leaf n)) ->
  (forall l : list tree,
    (forall t, Mem t l -> P t) -> P (node l)) ->
  forall T : tree, P T.
Proof using.
  introv Hl Hn. eapply tree_induct_gen with (Q := fun l =>
    forall t, Mem t l -> P t); intros.
  auto. auto. inversions H. inversions~ H1.
Qed.

(** Definition of immediate subtrees *)

Inductive subtree : binary tree :=
  | subtree_intro : forall t l,
     Mem t l -> subtree t (node l).

Hint Constructors subtree.

Lemma subtree_wf : wf subtree.
Proof using.
  intros t. induction t using tree_induct;
  constructor; introv K; inversions~ K.
Qed.

(** Definition of the [treeincr] function *)

Definition Treeincr treeincr t :=
  match t with
  | leaf n => leaf (S n)
  | node l => node (LibList.map treeincr l)
  end.

Definition treeincr := FixFun Treeincr.

Lemma treeincr_fix : forall t,
  treeincr t = Treeincr treeincr t.
Proof using.
  applys (FixFun_fix subtree).
  reflexivity. apply subtree_wf.
  introv H. unfold Treeincr. destruct x.
    auto.
    fequals. apply~ map_congr.
Qed.

(* ********************************************************************** *)
(** * DFS *)

Module DFS.

Parameter marks : Type.
Parameter marks_inhab : Inhab marks.
Existing Instance marks_inhab.
Implicit Type i : nat.

Parameter is_marked : marks -> nat -> bool.
Parameter add_mark : marks -> nat -> marks.
Parameter nb_unmarked : marks -> nat.
Parameter add_mark_nb_unmarked : forall m i,
  ~ is_marked m i ->
  nb_unmarked (add_mark m i) < nb_unmarked m.

Parameter neighbours : nat -> list nat.

Definition Dfs dfs m i :=
  'let m := add_mark m i in
  'let v := neighbours i in
  'let aux := (fun j m => if is_marked m j then m else dfs m j) in
  fold_left aux m v.

Definition dfs := FixFun2 Dfs.

Lemma fix_dfs : forall m i,
  ~ is_marked m i ->
  dfs m i = Dfs dfs m i.
  (* Could be added to the statement:
     /\ (forall m i, is_marked m i = false ->
         nb_unmarked (Dfs dfs m i) < nb_unmarked m). *)
Proof using.
  applys~ FixFun2_fix_partial_inv
    (measure2 (fun m i => nb_unmarked m))
    (fun m i m' => nb_unmarked m' < nb_unmarked m).
  intros m i f1 f2 Hi IH. unfolds Dfs.
  unfold measure2 in IH. sets_eq N: (nb_unmarked m).
  let_name_all. let_name_all.
  let_name_all as aux1. let_name_all as aux2.
  asserts L: (nb_unmarked m0 < N).
    subst N m0. applys* add_mark_nb_unmarked.
  clears m i. gen m0. induction v as [|i v]. simple*.
  intros m Lt. simpl.
  asserts [E F]: (aux1 i m = aux2 i m /\ nb_unmarked (aux1 i m) < N).
    rewrite EQaux1, EQaux2. case_if as C.
      auto.
      forwards* [E L]: IH C. split. auto. math.
  rewrite <- E. applys* IHv.
Qed.

(*
Extraction Language Ocaml.
Extraction Inline Dfs
  FixFun2Mod FixFun2 curry2 uncurry2 FixFunMod.
Set Extraction Optimize.
Extraction dfs.
*)

End DFS.

(* ********************************************************************** *)
(** * COFE for streams *)

(** Definition of stream ordered family of requiv *)

Definition stream_mod_family A (E:binary A) : family nat (stream A) :=
  nat_family (bisimilar_mod_upto E).

(** Special case of comparing stream values wrt equality *)

Definition stream_family A := stream_mod_family (@eq A).

(** Similarity for this OFE is equal to stream bisimilarity *)

Lemma stream_mod_similarity : forall A (E:binary A),
  bisimilar_mod E = similar (stream_mod_family E).
Proof using.
  extens. intros s1 s2.
  unfold similar. simpl. split.
  intros. apply~ bisimilar_mod_to_upto.
  intros. apply~ bisimilar_mod_take.
Qed.

Hint Resolve stream_mod_similarity.

Lemma stream_similarity : forall A,
  @bisimilar A = similar (stream_family A).
Proof using. intros. apply stream_mod_similarity. Qed.

Hint Resolve stream_similarity.

(** Completeness of the OFE *)

Hint Unfold list_equiv.
Hint Constructors Forall2.

Lemma stream_mod_cofe : forall A {IA:Inhab A} (E:binary A),
  equiv E -> COFE (stream_mod_family E).
Proof using.
  introv IA Equiv. apply nat_cofe. typeclass.
  intros. apply~ equiv_bisimilar_mod_upto.
  introv H. exists (diagonal (fun i => u (S i)) 0).
  induction i; unfolds.
    simple~.
    apply~ bisimilar_mod_upto_succ. apply~ (trans_sym_rl (u i)).
    rewrite stream_diagonal_nth. math_rewrite~ (i + 0 = i).
Qed.

Lemma stream_cofe : forall A {IA:Inhab A}, COFE (stream_family A).
Proof using. intros. apply~ stream_mod_cofe. Qed.

Hint Resolve @stream_cofe.

(* ********************************************************************** *)
(** * Constant stream -- basic corecursive value *)

Definition Const1 const1 := (1%nat) ::: const1.

Definition const1 := FixValMod (@bisimilar nat) Const1.

Lemma const1_fix : const1 === Const1 const1.
Proof using.
  applys~ (FixValMod_fix (stream_family nat)). typeclass.
  intros i s1 s2 H. simpls. destruct~ i.
  unfolds. simpl. constructor~. apply* H.
Qed.

(* ********************************************************************** *)
(** * Constant stream -- basic corecursion *)

Definition Const const (n:nat) := n ::: const n.

Definition const := FixFunMod (@bisimilar nat) Const.

Lemma const_fix : forall n, const n === Const const n.
Proof using.
  intros.
  applys (FixFunMod_corec (stream_family nat) (@pred_true nat)); autos*.
  apply stream_cofe.
  clear n. intros i n s1 s2 _ H. simpls. destruct~ i.
  unfolds. simpl. constructor~. apply* H.
Qed.

(* ********************************************************************** *)
(** * Polymorphic Constant stream -- basic corecursion with polymorphism *)

Definition PConst A pconst (n:A) := n ::: pconst n.

Definition pconst `{IA:Inhab A} := FixFunMod (@bisimilar A) (@PConst A).

Lemma pconst_fix : forall A {IA:Inhab A} (n:A),
  pconst n === PConst pconst n.
Proof using.
  intros.
  applys* (FixFunMod_corec (stream_family A) (@pred_true A)).
  clears n. intros i n s1 s2 _ H. simpls. destruct~ i.
  unfolds. simpl. constructor~. apply* H.
Qed.

Lemma pconst_spec : forall A {IA:Inhab A} (x:A),
  LibStream.const x === pconst x.
Proof using.
  intros.
  apply bisimilar_mod_take. induction i. simple~.
  apply* sym_inv. apply* trans_sym_lr.
   apply bisimilar_mod_to_upto. apply pconst_fix.
   simpl. constructor~.
Qed.

(* ********************************************************************** *)
(** * Mutually-defined stream -- basic corecursion *)
(* u = 1::2::3::1::2::3::1::2::3::1::2::3::1::2::3::...*)

Definition MU (mu mv : stream nat) := (1%nat) ::: mv.
Definition MV (mu mv : stream nat) := (2%nat) ::: ((3%nat) ::: mu).

Definition muv := FixValModMut2 (@bisimilar nat) (@bisimilar nat) MU MV.
Definition mu := fst muv.
Definition mv := snd muv.

Lemma uv_fix : mu === MU mu mv /\ mv === MV mu mv.
Proof using.
  applys (FixValModMut2_fix
    (prod_family (stream_family nat) (stream_family nat))).
  rewrite~ prod2_eq_tuple_proj.
  unfold bisimilar. rewrite stream_mod_similarity. apply prod_similar.
  apply prod_cofe; typeclass.
  intros i u1 v1 u2 v2 H. simpls. destruct~ i. split.
    unfolds. simpl. constructor~. apply* H.
    unfolds. simpl. constructor~. destruct i. simple~. simpl.
     constructor~. apply* H.
Qed.

(* ********************************************************************** *)
(** * Stream of natural numbers *)

Definition Nats nats (n:nat) := n ::: nats (S n).

Definition nats := FixFunMod (@bisimilar nat) Nats.

Lemma nats_fix : forall (n:nat),
  nats n === Nats nats n.
Proof using.
  intros.
  applys (FixFunMod_corec (stream_family nat) (@pred_true nat)); autos*.
  apply stream_cofe.
  clears n. intros i n s1 s2 _ H. simpls. destruct~ i.
  unfolds. simpl. constructor~. apply* H.
Qed.

(* ********************************************************************** *)
(** * Filter on streams *)

Definition dist_to_next A (P:A->Prop) (s:stream A) :=
  epsilon (first_st_at P s).

Lemma eventually_to_dist : forall A (P:A->Prop) s,
  eventually P s -> exists n, first_st_at P s n.
Proof using.
  introv H. induction H. exists 0. simple~.
  destruct (prop_inv (P x)).
    exists 0. simple~.
    destruct IHeventually as [n Pn]. exists (S n). simple~.
Qed.

Lemma eventually_dist_cons : forall A (P:A->Prop) s x,
  eventually P s -> ~ P x ->
  dist_to_next P s < dist_to_next P (x:::s).
Proof using.
  introv H Nx. unfold dist_to_next.
  epsilon n. apply~ eventually_to_dist. intros Pn.
  epsilon n'. apply~ eventually_to_dist. apply~ eventually_tail.
  intros Pn'. clearbody n n'. destruct n'; simpl in Pn'; tryfalse.
  rewrite* (@first_st_at_inj n n' A P s).
Qed.

Section MyFilters.
Context (A:Type) {IA:Inhab A}.
Variable (P:A->Prop).

Definition Filter filter s :=
  let '(x:::s') := s in
  let s'' := filter s' in
  If P x then x:::s'' else s''.

Definition filter := FixFunMod (@bisimilar A) Filter.

Lemma filter_fix : forall s,
  infinitely_often P s ->
  filter s === Filter filter s.
Proof using.
  applys~ (FixFunMod_mixed_partial
    (stream_family A)
    (measure (dist_to_next P))
    (infinitely_often P)
    (@bisimilar A)).
  intros i s f1 f2 Ps H. simpls.
  destruct s. simpl. unfolds. destruct i. simple~.
   inverts Ps as Ps' Ev. case_if as C.
     simpl. constructor~. apply~ H. left*.
     inverts Ev as Ev.
       false.
       apply~ H. right. split~.
         forwards~: eventually_dist_cons Ev C.
Qed.

End MyFilters.

(* ********************************************************************** *)
(** * An example with cofinite trees *)

Require Import TLC.LibNat.

(** Definition of [itree], trees with possibly-infinite branches *)

CoInductive itree : Type :=
  | itree_leaf : nat -> itree
  | itree_node : itree -> itree -> itree.

(** The type [itree] is inhabited *)

Instance Inhab_itree : Inhab itree.
Proof using. intros. apply (Inhab_of_val (itree_leaf 0)). Qed.

(** Similarity up to level [i] between two trees *)

Fixpoint itree_similar_upto (i:nat) (m1 m2: itree) :=
  match i with
  | O => True
  | S i' => match m1,m2 with
     | itree_leaf n1, itree_leaf n2 => n1 = n2
     | itree_node t11 t12, itree_node t21 t22 =>
           itree_similar_upto i' t11 t21
        /\ itree_similar_upto i' t12 t22
     | _, _ => False
     end
  end.

(** Similarity upto is an equivalence *)

Lemma itree_similar_upto_equiv :
  forall i, equiv (itree_similar_upto i).
Proof using.
  constructor; unfolds.
  induction i; intros; simple~. destruct~ x.
  induction i; intros; simple~. destruct x; destruct y; simpls*.
  induction i; intros; simple~. destruct x; destruct y; destruct z; simpls*.
Qed.

Hint Resolve itree_similar_upto_equiv.
Hint Extern 1 (itree_similar_upto ?i _ _) =>
  apply (@equiv_refl _ _ (itree_similar_upto_equiv i)).

(** Construction of the COFE for the family [itree] *)

Definition itree_family := Build_family lt itree_similar_upto.

Definition itree_left t :=
  match t with
  | itree_leaf n => arbitrary
  | itree_node t1 t2 => t1
  end.

Definition itree_right t :=
  match t with
  | itree_leaf n => arbitrary
  | itree_node t1 t2 => t2
  end.

Definition shifts A (u:nat->A) :=
  fun n => u (S n).

CoFixpoint itree_diagonal (u:nat->itree) : itree :=
  match u 0 with
  | itree_leaf n => itree_leaf n
  | itree_node t1 t2 =>
      itree_node (itree_diagonal (itree_left \o shifts u))
                 (itree_diagonal (itree_right \o shifts u))
  end.

Lemma itree_family_COFE : COFE itree_family.
Proof using.
  apply~ nat_cofe'. typeclass.
  introv H. exists (itree_diagonal (shifts u)).
  cuts M: (forall k i u, i <= k ->
    (forall i j : nat, i < j -> itree_similar_upto (S i) (u i) (u j)) ->
      itree_similar_upto (S i) (u k) (itree_diagonal u)).
    intros i. destruct i. simple~.
    sets u': (shifts u). change (u (S i)) with (u' i).
    apply M. math.
      intros i' j' Ri'j'. unfold u', shifts. apply H. math.
  clears u. induction k using peano_induction; introv Lik Coh.
  tests: (k = 0). math_rewrite (i = 0). simpl. destruct~ (u 0).
  unfolds. fold itree_similar_upto.
  forwards S0: (>> Coh 0 k __). math. simpl in S0.
  unfold itree_diagonal; fold itree_diagonal.
  sets_eq <- u0: (u 0). sets_eq <- uk: (u k).
  destruct u0 as [|t01 t02]; destruct uk as [|tk1 tk2]; auto_false.
  split. (* --TODO: find a way to factorize both sides *)
  (* left subtree *)
  destruct i. simple~.
  sets u': (itree_left \o shifts u).
  asserts_rewrite (tk1 = u' (k-1)).
    unfold u'. unfold compose, shifts, itree_left.
    math_rewrite (S (k - 1) = k). rewrite~ EQuk.
  apply H; try math. intros i' j' Li'j'.
  unfold u'. unfold compose, shifts, itree_left.
  sets_eq i'': (S i'). sets_eq j'': (S j').
  forwards Ssi: (Coh i'' j''). math.
  simpl in Ssi. destruct (u i''); destruct (u j''); auto_false*.
  (* right subtree *)
  destruct i. simple~.
  sets u': (itree_right \o shifts u).
  asserts_rewrite (tk2 = u' (k-1)).
    unfold u'. unfold compose, shifts. unfold itree_right.
    math_rewrite (S (k - 1) = k). rewrite~ EQuk.
  apply H; try math. intros i' j' Li'j'.
  unfold u'. unfold compose, shifts, itree_left.
  sets_eq i'': (S i'). sets_eq j'': (S j').
  forwards Ssi: (Coh i'' j''). math.
  simpl in Ssi. destruct (u i''); destruct (u j''); auto_false*.
Qed.

(** Two equivalent definitions of similarity between two trees,
    one using an coinductive predicate and another constructed
    as the intersection of the "similarity-upto" relations. *)

CoInductive itree_similar : binary itree :=
  | itree_similar_leaf : forall n,
      itree_similar (itree_leaf n) (itree_leaf n)
  | itree_similar_node : forall t11 t12 t21 t22 : itree,
      itree_similar t11 t21 ->
      itree_similar t12 t22 ->
      itree_similar (itree_node t11 t12) (itree_node t21 t22).

Hint Constructors itree_similar.

Lemma itree_similar_eq : itree_similar = similar itree_family.
Proof using.
  extens. intros t1 t2. iff H.
  intros i. hnf. gen t1 t2. induction i; simpl; introv H.
   auto. inversions~ H.
  hnf in H. gen t1 t2. cofix IH.
   intros t1 t2. destruct t1; destruct t2;
    introv H; lets H1: (H 1); simpl in H1; inverts H1; constructor.
      apply IH. intros i. lets_simpl HSi: (H (S i)). autos*.
      apply IH. intros i. lets_simpl HSi: (H (S i)). autos*.
Qed.

(** A first corecursive operation: the "product" of two trees.
   Note that it always add a head element. *)

Definition Product product m1 m2 :=
  match m1,m2 with
  | itree_node t11 t12, itree_node t21 t22 =>
     itree_node (product t11 t22) (product t12 t21)
  | _, _ => itree_node m1 m2
  end.

Definition product := FixFun2Mod itree_similar Product.

(** We prove that [product] satisfies the fixed point equation *)

Lemma product_fixpoint : forall m1 m2,
  itree_similar (product m1 m2) (Product product m1 m2).
Proof using.
  apply (FixFun2Mod_corec itree_family).
  reflexivity. apply itree_similar_eq. apply itree_family_COFE.
  simpl. introv H. destruct i. simple~. unfold Product.
  destruct x1; destruct x2; simpl; auto with maths.
Qed.

(** And we show that it is productive wrt its arguments *)

Lemma product_incr_similarity : forall i m1 m1' m2 m2',
   itree_similar_upto i m1 m1' ->
   itree_similar_upto i m2 m2' ->
   itree_similar_upto (S i) (product m1 m2) (product m1' m2').
Proof using.
  induction i using peano_induction.
  change (itree_similar_upto) with (family_sim itree_family).
  introv K1 K2. (* --TODO: setoid rewrite *)
  eapply cofe_similar_modulo. apply itree_family_COFE.
    rewrite <- itree_similar_eq. apply product_fixpoint.
    rewrite <- itree_similar_eq. apply product_fixpoint.
  simpl in K1, K2 |- *.
  destruct m1; destruct m2; simpl; auto.
  destruct m1'; destruct m2'; simple~. destruct~ i. inversions K1.
  destruct m1'; destruct m2'; simple~. destruct~ i. inversions K1.
  destruct m1'; destruct m2'; simple~. destruct~ i. inversions K2.
  destruct m1'; destruct m2'; simple~; destruct~ i.
    inversions K1. inversions K1. inversions K2.
    simpl in K1, K2. destruct K1. destruct K2. auto with maths.
Qed.

(** A second corecursive function, which is not guarded:
    it is productive only because the function [product]
    is productive. *)

Definition Makeitree makeitree m :=
  match m with
  | itree_node t1 t2 => product (makeitree t1) (makeitree t2)
  | itree_leaf n => itree_leaf (S n)
  end.

Definition makeitree := FixFunMod itree_similar Makeitree.

(** Still, we can establish the fixed point equation for our function *)

Lemma makeitree_fixpoint : forall m,
  itree_similar (makeitree m) (Makeitree makeitree m).
Proof using.
  apply (FixFunMod_corec_total itree_family).
  reflexivity. apply itree_similar_eq. apply itree_family_COFE.
  introv H. unfold Makeitree. simpl. destruct x.
  auto.
  destruct i. auto. apply product_incr_similarity.
    apply H; simpl; auto with maths.
    apply H; simpl; auto with maths.
Qed.

(* ********************************************************************** *)
(** * Verification of a recursive parser in CPS form *)

Ltac auto_tilde ::= auto with wf.

(* ---------------------------------------------------------------------- *)
(** ** The assertion construction *)

(** The expression [ ##P## v ] is equivalent to [v],
    with the assertion that [P] holds. If [P] does not hold,
    then the expression is undefined. *)

Definition asserts (P:Prop) (A:Type) `{Inhab A} (v:A) :=
  If P then v else arbitrary.

Notation "'##' P '##' v" := (asserts P v) (at level 69).

Tactic Notation "case_asserts" :=
  unfold asserts; case_if.
Tactic Notation "case_asserts" "~" :=
  case_asserts; auto_tilde.

(* ---------------------------------------------------------------------- *)
(** ** Definition of the data types *)

Inductive regexp : Type :=
  | regexp_null : regexp
  | regexp_empty : regexp
  | regexp_char : nat -> regexp
  | regexp_alt : regexp -> regexp -> regexp
  | regexp_seq : regexp -> regexp -> regexp
  | regexp_star : regexp -> regexp.

Definition text := list nat.

Definition arg_type := (regexp * text * (text -> bool))%type.

(* ---------------------------------------------------------------------- *)
(** ** Definition of the regexp parser as an optimal fixed point *)

Definition Parse (parse : arg_type -> bool) (p : arg_type) : bool :=
  let '(r,s,k) := p in
  match r with
  | regexp_null => false
  | regexp_empty => k s
  | regexp_char c =>
     match s with
     | nil => false
     | c'::s' => If c = c' then k s' else false
     end
  | regexp_alt r1 r2 => parse (r1,s,k) || parse (r2,s,k)
  | regexp_seq r1 r2 => parse (r1,s,(fun s' => parse (r2,s',k)))
  | regexp_star r1 => k s || parse (r1,s,(fun s' => parse (r,s',k)))
  end.

Definition parse := FixFun Parse.

(** At this point, the function [parse] exists and can thus
    be mentioned in other definitions. *)

(* ---------------------------------------------------------------------- *)
(** ** Domain of the parser *)

(** [productive r] is the same as [not (nullable r)];
    it asserts that [r] consumes at least one character *)

Fixpoint productive (r:regexp) : Prop :=
  match r with
  | regexp_null => True
  | regexp_empty => False
  | regexp_char c => True
  | regexp_alt r1 r2 => productive r1 /\ productive r2
  | regexp_seq r1 r2 => productive r1 \/ productive r2
  | regexp_star r1 => False
  end.

(** [normal r] ensures that expressions under a star are productive *)

Fixpoint normal (r:regexp) : Prop :=
  match r with
  | regexp_null => True
  | regexp_empty => True
  | regexp_char c => True
  | regexp_alt r1 r2 => normal r1 /\ normal r2
  | regexp_seq r1 r2 => normal r1 /\ normal r2
  | regexp_star r1 => productive r1 /\ normal r1
  end.

Hint Unfold productive normal.

(** Definition of the domain *)

Definition parse_dom (p:arg_type) :=
  let '(r,s,k) := p in normal r.

(* ---------------------------------------------------------------------- *)
(** ** Termination relation for the parser *)

(** Sub-expression order for [regexp] *)

Inductive regexp_sub : binary regexp :=
  | regexp_sub_seq_1 : forall r1 r2,
      regexp_sub r1 (regexp_seq r1 r2)
  | regexp_sub_seq_2 : forall r1 r2,
      regexp_sub r2 (regexp_seq r1 r2)
  | regexp_sub_alt_1 : forall r1 r2,
      regexp_sub r1 (regexp_alt r1 r2)
  | regexp_sub_alt_2 : forall r1 r2,
      regexp_sub r2 (regexp_alt r1 r2)
  | regexp_sub_star : forall r1,
      regexp_sub r1 (regexp_star r1).

Hint Constructors regexp_sub.

Lemma regexp_sub_wf : wf regexp_sub.
Proof using. intros r. induction r; constructor; intros r' le; inverts~ le. Qed.

Hint Resolve regexp_sub_wf : wf.

(** [text_sub] is the transitive closure of the sub-list order *)

Definition text_sub : binary text := tclosure (@list_sub _).

Lemma text_sub_wf : wf text_sub.
Proof using. lets: wf_tclosure. unfold text_sub. solve_wf. Qed.

Hint Resolve text_sub_wf : wf.

Lemma text_sub_once : forall s c,
  text_sub s (c::s).
Proof using. intros. apply~ tclosure_once. Qed.

Lemma trans_text_sub : trans text_sub.
Proof using. apply trans_tclosure. Qed.

Hint Resolve trans_text_sub text_sub_once.

Lemma text_sub_app : forall s s1 s2,
  s = s1 ++ s2 ->
  rclosure text_sub s2 s.
Proof using.
  intros. rewrite rclosure_eq.
  subst. induction s1; rew_list. auto.
  inverts IHs1.
    left. applys~ (@trans_inv text) (s1++s2).
    rewrite <- H. left. apply text_sub_once.
Qed.

(** [parse_sub] is the termination relation used for [parse];
    It is the lexicographical order [(s,r)] *)

Definition parse_sub : binary (regexp * text) :=
  lexico2 regexp_sub text_sub.

Lemma parse_sub_wf : wf parse_sub.
Proof using. solve_wf. Qed.

Hint Unfold parse_sub.
Hint Resolve parse_sub_wf : wf.

(** [parse_arg_sub] is similar to [parse_sub] except that
    it takes triples of the form [(r,s,k)] as arguments *)

Definition parse_arg_sub : binary arg_type :=
  fun p1 p2 => let '(r1,s1,k1) := p1 in let '(r2,s2,k2) := p2 in
               parse_sub (r1,s1) (r2,s2).

Lemma parse_arg_sub_wf : wf parse_arg_sub.
Proof using.
  intros [[r s] k].
  sets_eq p: (r,s). gen k r s. induction_wf IH: parse_sub_wf p.
  intros. subst p. constructor. intros [[r2 s2] k2] S. applys~ IH S.
Qed.

Hint Unfold parse_arg_sub.
Hint Resolve parse_arg_sub_wf : wf.

(* ---------------------------------------------------------------------- *)
(** ** Auxiliary recursive function *)

(** [parse'] is a function equivalen to [parse] except that it includes
    some assertions in order to make termination more obvious.
    Those assertions appear in-between [##] symbols. *)

Definition Parse' (parse : arg_type -> bool) (p : arg_type) : bool :=
  let '(r,s,k) := p in
  match r with
  | regexp_null => false
  | regexp_empty => k s
  | regexp_char c =>
     match s with
     | nil => false
     | c'::s' => If c = c' then k s' else false
     end
  | regexp_alt r1 r2 => parse (r1,s,k) || parse (r2,s,k)
  | regexp_seq r1 r2 => parse (r1,s,(fun s' => parse (r2,s',k)))
  | regexp_star r1 => k s || parse (r1,s,(fun s' => ##text_sub s' s## parse (r,s',k)))
  end.

Definition parse' := FixFun Parse'.

(** Remark: I will show further on how to factorize the definitions
    of [Parse] and [Parse'] so as to avoid the duplication of code. *)

(* ---------------------------------------------------------------------- *)
(** ** Proof of termination of the auxiliary function *)

(** Thanks to the assertions it contains, [parse'] is a total function
    that satisfies a contraction condition, and thus satisfies the
    fixed point equation for [Parse']. *)

Lemma parse'_fix : forall p,
  parse' p = Parse' parse' p.
Proof using.
  applys~ (FixFun_fix parse_arg_sub).
  intros f1 f2 [[r s] k] H. unfolds. destruct r; auto.
  fequal; auto 7.
  rewrite H; [|auto 7]. fequals_rec.
   apply fun_ext_1. intros s'. apply~ H.
  fequal. rewrite H; [|auto 7]. fequals_rec.
   apply fun_ext_1. intros s'. case_asserts; auto 7.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Properties of the auxiliary function *)

(** [select_sub r] is equivalent to the strict sub-text relation
    when [r] is [productive], and it is otherwise equivalent to
    the large sub-text relation. *)

Definition select_sub (r:regexp) : binary text :=
  If productive r then text_sub else rclosure text_sub.

(** The key result consists in showing that, when [r] is is normal form,
    the computation of [parse' (r,s,k)] is not affected by the evaluations
    of the assertions. *)

Lemma parse'_cont : forall r s k1 k2, normal r ->
  (forall s', select_sub r s' s -> k1 s' = k2 s') ->
  parse' (r,s,k1) = parse' (r,s,k2).
Proof using.
  intros r s. sets_eq p: (r,s). gen r s. induction_wf IH: parse_sub_wf p.
  introv P N E. subst p. do 2 rewrite parse'_fix. unfolds. destruct r; simpl in N.
  auto.
  apply E. hnf. rewrite~ If_r.
  destruct s as [|c' s']. auto. case_if~. apply E. unfolds. rewrite~ If_l.
  inverts N. asserts M: (forall r s', (r = r1 \/ r = r2) -> select_sub r s' s ->
                select_sub (regexp_alt r1 r2) s' s).
    introv C S. hnf in S |- *. simpl. case_if as C'.
      destruct C'. case_if. auto. inverts C; tryfalse.
      case_if~.
   fequals.
     applys~ IH. auto 7. eauto 8.
     applys~ IH. auto 7. eauto 8.
  inverts N. applys~ IH. intros s' S'. applys~ IH.
    intros s'' S''. apply E. hnf in S',S''|-*. simpl.
    tests: (productive r1); tests: (productive r2).
      rewrite~ If_l. applys* (@trans_inv text) s'.
      rewrite~ If_l. applys* trans_rclosure_l s'.
      rewrite~ If_l. applys* trans_rclosure_r s'.
      rewrite If_r; [|rew_logic;auto]. applys~ trans_rclosure s'.
  fequals.
    apply E. unfold select_sub. simpl. rewrite~ If_r.
  inverts N. applys~ IH. auto 7. intros s' S'. case_asserts~.
   applys~ IH. hnf in S'. rewrite~ If_l in S'.
   intros s'' S''. apply E. hnf in S'' |- *. simpls. case_if; tryfalse.
   inverts S''. left. applys* trans_inv. auto.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Proof of the fixed point equation for [parse] *)

(** The first step consists in proving that [parse']
    is a fixed point for [Parse] on the domain. This is done
    by showing that the assertions in the continuations are
    irrelevant, using the lemma [parse'_cont]. Yet, the statement
    [ Lemma parse'_fix_Parse_simple : forall p, parse_dom p ->
      parse' p = Parse parse' p. ]
    is not strong enough. Indeed, we need to generalize this
    into a form where we replace [parse'] with an arbitrary
    other total function that behave like [parse'] on the domain. *)

Lemma parse'_fix_Parse :
  fixed_point (pfun_equal parse_dom) Parse parse'.
Proof using.
  intros f Hf [[r s] k] N. asserts E: (pfun_equal parse_dom f parse').
    unfolds. apply~ equiv_sym. clear Hf.
  rewrite~ E. rewrite parse'_fix.
  unfold Parse, Parse'. destruct r; auto; simpl in N.
  inverts N. fequals; rewrite~ E.
  inverts N. rewrite~ E. apply~ parse'_cont. intros s' S'. rewrite~ E.
  inverts N. fequals. rewrite~ E. apply~ parse'_cont. intros s' S'.
   hnf in S'. rewrite~ If_l in S'. case_asserts; auto_false. rewrite~ E. simple~.
Qed.

(** The second step consists in proving that the functional [Parse]
    satisfies a contraction condition. This is almost the standard
    contraction condition, except that [f1] is specialized as [parse'].
    In this proof, we exploit the fact that [parse'] depends only
    a subdomain of its continuation. Remark: the statement is equivalent
    to [rec_contractive' eq parse_dom Parse parse_arg_sub parse']. *)

Lemma Parse_contractive_for_parse' : forall f' p, parse_dom p ->
  (forall q, parse_dom q -> parse_arg_sub q p -> parse' q = f' q) ->
  Parse parse' p = Parse f' p.
Proof using.
  introv N IH. unfold Parse. destruct p as [[r s] k].
  hnf in N. destruct r; simpl in N; auto.
  inverts N. fequals; apply~ IH.
  inverts N. erewrite parse'_cont; auto. apply~ IH.
   simpl. intros s' S'. apply~ IH.
  inverts N. fequals. erewrite parse'_cont; auto. apply IH; auto 7.
   simpl. intros s' S'. hnf in S'. rewrite~ If_l in S'. apply~ IH; hnfs~.
Qed.

(** Third and last step: we can put all the pieces together.
    Since [parse'] is a generally-consistent fixed point for [Parse]
    on the domain [parse_dom], [parse'] is extended by [parse],
    which is the optimal fixed point of [Parse]. Hence, [parse]
    and [parse'] agree on the domain [parse_dom]. It follows that
    [parse] satsifies the fixed point equation for [Parse] on the domain. *)

Lemma parse_fix : forall p, parse_dom p ->
  parse p = Parse parse p.
Proof using.
  applys~ (FixFun_fix_partial' (P:=parse_dom) (R:=parse_arg_sub) (F:=Parse) (f':=parse')).
  applys Parse_contractive_for_parse'. apply parse'_fix_Parse.
Qed.

Corollary parse_fix' : forall r s k, normal r ->
  parse (r,s,k) = Parse parse (r,s,k).
Proof using. intros. applys~ parse_fix. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Bonus: factorization of the definitions of [Parse] and [Parse'] *)

(** The idea is to define a single functional that takes as argument a
    function, which is intented to be instantiated either as [asserts]
    or as [ignore]. *)

Definition ignore (P:Prop) (A:Type) `{Inhab A} (v:A) := v.

Section Common.

Context (check : Prop -> forall A `{Inhab A}, A -> A).

Notation "'#' P '#' v" := (@check P _ _ v) (at level 69).

(** Here is the common definition to build [Parse] and [Parse']. *)

Definition Parse_common (parse : arg_type -> bool) (p : arg_type) : bool :=
  let '(r,s,k) := p in
  match r with
  | regexp_null => false
  | regexp_empty => k s
  | regexp_char c =>
     match s with
     | nil => false
     | c'::s' => If c = c' then k s' else false
     end
  | regexp_alt r1 r2 => parse (r1,s,k) || parse (r2,s,k)
  | regexp_seq r1 r2 => parse (r1,s,(fun s' => parse (r2,s',k)))
  | regexp_star r1 => k s || parse (r1,s,(fun s' => #text_sub s' s# parse (r,s',k)))
  end.

End Common.

(** Here are the alternative definitions for [Parse] and [Parse']. *)

Definition Parse_alternative := Parse_common ignore.
Definition Parse'_alternative := Parse_common asserts.

(** Finally, we can check that the alternative definitions are convertible
    with the one we had written by hand previously. *)

Lemma Parse_alternative_correct : Parse = Parse_alternative.
Proof using. reflexivity. Qed.

Lemma Parse'_alternative_correct : Parse' = Parse'_alternative.
Proof using. reflexivity. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Reasoning about [parse] *)

(** The inductively-defined proposition [sem r s] asserts that the
    string [s] matches the regular expression [r]. *)

Inductive sem : regexp -> text -> Prop :=
  | sem_empty :
      sem regexp_empty nil
  | sem_char : forall c,
      sem (regexp_char c) (c::nil)
  | sem_alt_1 : forall r1 r2 s,
      sem r1 s -> sem (regexp_alt r1 r2) s
  | sem_alt_2 : forall r1 r2 s,
      sem r2 s -> sem (regexp_alt r1 r2) s
  | sem_seq : forall r1 r2 s1 s2,
      sem r1 s1 -> sem r2 s2 -> sem (regexp_seq r1 r2) (s1 ++ s2)
  | sem_star_void : forall r1,
      sem (regexp_star r1) nil
  | sem_star_step : forall r1 s1 s2,
      sem r1 s1 ->
      sem (regexp_star r1) s2 ->
      sem (regexp_star r1) (s1 ++ s2).

Hint Constructors sem.

(** Observe that if a string [s] matches a productive regular
    expression [r], then [s] is not the empty string. *)

Lemma sem_productive : forall r s,
  sem r s -> productive r -> s <> nil.
Proof using.
  introv S. induction S; introv P; simpl in P; auto_false*.
  intros E. destruct (app_eq_nil_inv E). subst. destruct* P.
Qed.

(** The continuation [is_nil] holds only of the empty string *)

Definition is_nil (s:text) :=
  match s with nil => true | _ => false end.

(** The first result asserts that if [s] matches [r] semantically,
    then the [parse] function applied to [r] and [s] returns true. *)

Lemma sem_to_parse_ind : forall r s s' k,
  sem r s ->
  normal r ->
  k s' = true ->
  parse (r, s ++ s', k) = true.
Proof using.
  introv S N K. gen s' k N. induction S; intros;
   (rewrite parse_fix; [ | apply N ]); unfold Parse at 1; simpl in N;
   (try match type of N with _ /\ _ => destruct N end).
  rew_list~.
  rew_list. rewrite~ If_l.
  rewrite~ IHS.
  rewrite IHS at 1; auto. rew_bool~.
  rew_list. auto.
  rew_list. rewrite~ K.
  rew_list. rewrite~ IHS1. rew_bool~.
Qed.

Corollary sem_to_parse : forall r s,
  sem r s ->
  normal r ->
  parse (r,s,is_nil) = true.
Proof using. intros. forwards~ M: (@sem_to_parse_ind r s nil is_nil). rew_list~ in M. Qed.

(** The second result asserts the reciprocal: if the parse function
    applied to [r] and [s] returns true, then [s] matches [r] semantically. *)

Lemma parse_to_sem_ind : forall r s k,
  normal r ->
  parse (r,s,k) = true ->
  exists s1 s2, s = s1 ++ s2 /\ sem r s1 /\ k s2 = true.
Proof using.
  introv N P. sets_eq p: (r,s). gen r s k.
  induction_wf IH: parse_sub_wf p. intros. subst p.
  rewrite~ parse_fix in P. unfold Parse in P. destruct r;
   simpl in N; (try match type of N with _ /\ _ => destruct N end).
  false.
  exists (nil:text) s. splits~.
  destruct s; tryfalse. case_if; tryfalse.
   exists (n0::nil) s. subst. splits~.
  case_eq (parse (r1,s,k)); intros P1.
    forwards~ (s1&s2&E&S&P'): IH P1. auto 7. exists~ s1 s2.
    rewrite P1 in P. rew_bool in P.
    forwards~ (s1&s2&E&S&P'): IH P. auto 7. exists~ s1 s2.
  forwards~ (s1&s2&E&S&P'): IH P. auto.
    forwards~ (s3&s4&E'&S'&K): IH P'. auto.
    forwards M: text_sub_app E. subst s s2. exists (s1 ++ s3) s4. rew_list~.
  case_eq (k s); intros K.
    exists (nil:text) s. splits~.
    rewrite K in P. rew_bool in P.
    forwards~ (s1&s2&E&S&P'): IH P. auto.
    forwards~ (s3&s4&E'&S'&K'): IH P'; try solve [hnfs~].
      forwards M: text_sub_app E. inverts M. auto. false.
       applys~ sem_productive S. apply* self_eq_app_r_inv.
    subst s s2. exists (s1++s3) s4. rew_list~.
Qed.

Corollary parse_to_sem : forall r s,
  normal r ->
  parse (r,s,is_nil) = true ->
  sem r s.
Proof using.
  intros. forwards~ (s1&s2&E&S&K): (@parse_to_sem_ind r s is_nil).
  subst. destruct s2; tryfalse. rew_list~ in *.
Qed.

(** We can reformulate those two results in the form of an
    equivalence between [sem] and [parse] *)

Theorem parse_eq_sem : forall r s, normal r ->
    (parse (r,s,is_nil) = true)
  = (sem r s).
Proof using.
  extens. iff. apply~ parse_to_sem. apply~ sem_to_parse.
Qed.

(** A similar, more general, result *)

Theorem parse_eq_sem_ind : forall r s k, normal r ->
    (parse (r,s,k) = true)
  = (exists s1 s2, s = s1 ++ s2 /\ sem r s1 /\ k s2 = true).
Proof using.
  extens. iff M.
  apply~ parse_to_sem_ind.
  destruct M as (s1&s2&?&?&?). subst. apply~ sem_to_parse_ind.
Qed.


(*
Verificación Formal - 2020-II
Archivo de proposiciones - Lógica Intuicionista

Resultados de lógica intuicionista.
*)

(*
Doble negación vs implicación
*)
Lemma DobleNegacion_Implicacion_LI :
forall A B : Prop,
( ~ ~( A -> B) )  <-> ( (~ ~ A) -> (~ ~ B) ).
Proof.
  unfold not.
  split.
  - intros.
    apply H0.
    intro.
    apply H.
    intro.
    apply H3 in H2.
    contradiction.
  - intros.
    (* Esta parte de la prueba es la sugerencia *)
    apply H;
      intro;
      apply H0;
      intro;
      (*Se generan dos metas, en la primera hay una contradicción
      y en la segunda es una hipotesis*)
      contradiction || assumption.
Qed.


Lemma true_true : true = true.
Proof.
  reflexivity.
Qed.

Lemma false_false : false = false.
Proof.
  reflexivity.
Qed.

Lemma contrapos_bool_tt : forall (a b : bool),
  (a = true -> b = true) -> (b = false -> a = false).
Proof.
  intros.
  case_eq a; intros Ha; try reflexivity.
    rewrite H0 in H; symmetry; apply H; exact Ha.
Qed.

Lemma contrapos_bool_tf : forall (a b : bool),
  (a = true -> b = false) -> (b = true -> a = false).
Proof.
  intros a b H1 Hb.
  case_eq a; intros Ha; try reflexivity.
    rewrite Hb in *; specialize (H1 Ha);
    rewrite H1 in *; discriminate.
Qed.

Lemma contrapos_bool_ft : forall (a b : bool),
  (a = false -> b = true) -> (b = false -> a = true).
Proof.
  intros a b H1 Hb.
  case_eq a;
  [reflexivity |
    intros Ha; specialize (H1 Ha); rewrite H1 in *; discriminate].
Qed.

Lemma contrapos_bool_ff : forall (a b : bool),
  (a = false -> b = false) -> (b = true -> a = true).
Proof.
  intros a b H1 Hb.
  case_eq a; intros Ha; [reflexivity |
  specialize (H1 Ha); rewrite H1 in *; discriminate].
Qed.

Lemma contrapos_bool_or : forall (a b c : bool),
  (a = true <-> b = true \/ c = true) ->
    (a = false <-> b = false /\ c = false).
Proof.
  intros a b c H.
  destruct H as [f r].
  case_eq a; intros Ha; rewrite Ha in *.
    split; intros H1.
      discriminate.

      case_eq b; intros Hb; rewrite Hb in *;
        destruct H1 as [L R]; try discriminate.

        case_eq c; intros Hc; rewrite Hc in *.
          discriminate.

          symmetry.
          specialize (f true_true).
          destruct f; discriminate.

          split; intros H1; try reflexivity.
            apply conj.
              case_eq b; intros Hb; rewrite Hb in *.
                symmetry; apply r; left; reflexivity.

                reflexivity.

              case_eq c; intros Hc; rewrite Hc in *.
                symmetry; apply r; right; reflexivity.

                reflexivity.
Qed.

Lemma if_then_else_same : forall {A : Type} (a : bool) ( b : A),
  (if a then b else b) = b.
Proof.
  intros A a b.
  case a; reflexivity.
Qed.

Lemma if_then_else_false : forall a : bool,
  (if a then false else false )= false.
Proof.
  intros; case a; reflexivity.
Qed.

Lemma if_then_else_true : forall a : bool,
  (if a then true else true )= true.
Proof.
  intros; case a; reflexivity.
Qed.

Lemma if_then_else_true_false : forall a : bool,
(if a then true else false) = false -> a = false.
Proof.
  intros a H.
  case_eq a; intros Ha.
    rewrite Ha in *.
    discriminate.

    reflexivity.
Qed.


Require Import List.
Require Import Sorting.Sorted Sorting.Permutation.

Definition IsSorted {A:Set} (A_cmp:A -> A -> Prop) (l:list A) :=
  (@StronglySorted A A_cmp l).

Definition SortedOf {A:Set} (A_cmp:A -> A -> Prop) (l l':list A) :=
  (@Permutation A l l') /\
  (@IsSorted A A_cmp l').

Definition DecCmp {A:Set} (A_cmp:A -> A -> Prop) :=
  forall x y,
    {A_cmp x y} + {~ A_cmp x y}.

Definition Total {A:Set} (A_cmp:A -> A -> Prop) :=
  forall x y,
    (~ A_cmp x y) ->
    A_cmp y x.

Lemma Permutation_cons_step:
  forall A (a a':A) x y,
    Permutation (a :: x) y ->
    Permutation (a :: a' :: x) (a' :: y).
Proof.
  intros. rename H into PM.
  eapply Permutation_trans.
  apply perm_swap.
  apply perm_skip.
  auto.
Qed.


Require Import ZArith.

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

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

  Definition provable (e : expr) : Prop := forall st, e st.
End NaiveLang.

Require Import interface_1.

Module NaiveRule.
  Import NaiveLang.
  Include DerivedNames (NaiveLang).
  Lemma modus_ponens :
    forall x y : expr, provable (impp x y) -> provable x -> provable y.
  Proof. unfold provable, impp. auto. Qed.

  Lemma axiom1 : forall x y : expr, provable (impp x (impp y x)).
  Proof. unfold provable, impp. auto. Qed.

  Lemma axiom2 : forall x y z : expr,
      provable (impp (impp x (impp y z)) (impp (impp x y) (impp x z))).
  Proof. unfold provable, impp. auto. Qed.

  Lemma andp_intros :
    forall x y : expr, provable (impp x (impp y (andp x y))).
  Proof. unfold provable, impp, andp. auto. Qed.

  Lemma andp_elim1 : forall x y : expr, provable (impp (andp x y) x).
  Proof. unfold provable, impp, andp. tauto. Qed.

  Lemma andp_elim2 : forall x y : expr, provable (impp (andp x y) y).
  Proof. unfold provable, impp, andp. tauto. Qed.

  Lemma orp_intros1 : forall x y : expr, provable (impp x (orp x y)).
  Proof. unfold provable, impp, orp. auto. Qed.

  Lemma orp_intros2 : forall x y : expr, provable (impp y (orp x y)).
  Proof. unfold provable, impp, orp. auto. Qed.

  Lemma orp_elim : forall x y z : expr,
      provable (impp (impp x z) (impp (impp y z) (impp (orp x y) z))).
  Proof. unfold provable, impp, orp. tauto. Qed.

  Lemma falsep_elim : forall x : expr, provable (impp falsep x).
  Proof. unfold provable, impp, falsep. destruct 1. Qed.

  Lemma excluded_middle : forall x : expr, provable (orp x (negp x)).
  Proof. unfold provable, orp, negp, impp, falsep. intros; tauto. Qed.

  Axiom sepcon_comm: forall x y, provable (iffp (sepcon x y) (sepcon y x)).
  Axiom sepcon_assoc: forall x y z,
      provable (iffp (sepcon x (sepcon y z)) (sepcon (sepcon x y) z)).
  Axiom sepcon_mono : (forall x1 x2 y1 y2 : expr, provable (impp x1 x2) -> provable (impp y1 y2) -> provable (impp (sepcon x1 y1) (sepcon x2 y2))) .
  Axiom sepcon_emp : (forall x : expr, provable (iffp (sepcon x emp) x)) .
  Axiom falsep_sepcon_left : (forall x : expr, provable (impp (sepcon falsep x) falsep)) .
  Axiom orp_sepcon_left : (forall x y z : expr, provable (impp (sepcon (orp x y) z) (orp (sepcon x z) (sepcon y z)))) .
End NaiveRule.

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


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

(************************************************************************)
(** * Some properties of the operators on relations                     *)
(************************************************************************)
(** * Initial version by Bruno Barras                                   *)
(************************************************************************)

Set Warnings "-notation-overridden".

Require Import CRelationClasses.
Require Import Equations.Init.
Require Import Equations.Type.Logic.
Require Import Equations.Type.Relation.

Import Sigma_Notations.
Import Id_Notations.

(** Synonyms *)
Notation inclusion R R' := (subrelation R R').

#[export]
Hint Constructors sum : relations.

Section Properties.

  Context{A : Type}.
  Variable R : relation A.

  Section Clos_Refl_Trans.

    Local Notation "R *" := (clos_refl_trans R)
      (at level 8, no associativity, format "R *").

    (** Correctness of the reflexive-transitive closure operator *)

    Lemma clos_rt_is_preorder : PreOrder R*.
    Proof.
      constructor.
      - exact (rt_refl R).
      - exact (rt_trans R).
    Defined.

    (** Idempotency of the reflexive-transitive closure operator *)

    Lemma clos_rt_idempotent : subrelation (R*)* R*.
    Proof.
      red.
      induction 1; auto with relations.
      intros.
      apply rt_trans with y; auto with relations.
    Defined.

  End Clos_Refl_Trans.

  Section Clos_Refl_Sym_Trans.

    (** Reflexive-transitive closure is included in the
        reflexive-symmetric-transitive closure *)

    Lemma clos_rt_clos_rst :
      subrelation (clos_refl_trans R) (clos_refl_sym_trans R).
    Proof.
      red.
      induction 1; auto with relations.
      apply rst_trans with y; auto with relations.
    Defined.

    (** Reflexive closure is included in the
        reflexive-transitive closure *)

    Lemma clos_r_clos_rt :
      inclusion (clos_refl R) (clos_refl_trans R).
    Proof.
      induction 1 as [? ?| ].
      - constructor; auto.
      - constructor 2.
    Defined.

    Lemma clos_rt_t : forall x y z,
      clos_refl_trans R x y -> trans_clos R y z ->
      trans_clos R x z.
    Proof.
      induction 1 as [b d H1|b|a b d H1 H2 IH1 IH2]; auto.
      intro H. apply t_trans with (y:=d); auto.
      constructor. auto.
    Defined.

    (** Correctness of the reflexive-symmetric-transitive closure *)

    Lemma clos_rst_is_equiv : Equivalence (clos_refl_sym_trans R).
    Proof.
      constructor.
      - exact (rst_refl R).
      - exact (rst_sym R).
      - exact (rst_trans R).
    Defined.

    (** Idempotency of the reflexive-symmetric-transitive closure operator *)

    Lemma clos_rst_idempotent :
      inclusion (clos_refl_sym_trans (clos_refl_sym_trans R))
      (clos_refl_sym_trans R).
    Proof.
      red.
      induction 1; auto with relations.
      apply rst_trans with y; auto with relations.
    Defined.

  End Clos_Refl_Sym_Trans.

  Section Equivalences.

  (** *** Equivalences between the different definition of the reflexive,
      symmetric, transitive closures *)

  (** *** Contributed by P. Castéran *)

    (** Direct transitive closure vs left-step extension *)

    Lemma clos_t1n_trans : forall x y, trans_clos_1n R x y -> trans_clos R x y.
    Proof.
     induction 1.
     - left; assumption.
     - right with y; auto.
       left; auto.
    Defined.

    Lemma trans_clos_t1n : forall x y, trans_clos R x y -> trans_clos_1n R x y.
    Proof.
      induction 1.
      - left; assumption.
      - generalize IHX2; clear IHX2; induction IHX1.
        -- right with y; auto.
        -- right with y; auto.
           eapply IHIHX1; auto.
           apply clos_t1n_trans; auto.
    Defined.

    Lemma trans_clos_t1n_iff : forall x y,
        trans_clos R x y <-> trans_clos_1n R x y.
    Proof.
      intros x y.
      exists (trans_clos_t1n x y).
      apply (clos_t1n_trans x y).
    Defined.

    (** Direct transitive closure vs right-step extension *)

    Lemma clos_tn1_trans : forall x y, trans_clos_n1 R x y -> trans_clos R x y.
    Proof.
      induction 1.
      - left; assumption.
      - right with y; auto.
        left; assumption.
    Defined.

    Lemma trans_clos_tn1 :  forall x y, trans_clos R x y -> trans_clos_n1 R x y.
    Proof.
      induction 1.
      - left; assumption.
      - elim IHX2.
        -- intro y0; right with y; auto.
        -- intros. right with y0; auto.
    Defined.

    Lemma trans_clos_tn1_iff : forall x y,
        trans_clos R x y <-> trans_clos_n1 R x y.
    Proof.
      split.
      - apply trans_clos_tn1.
      - apply clos_tn1_trans.
    Defined.

    (** Direct reflexive-transitive closure is equivalent to
        transitivity by left-step extension *)

    Lemma clos_rt1n_step : forall x y, R x y -> clos_refl_trans_1n R x y.
    Proof.
      intros x y H.
      right with y;[assumption|left].
    Defined.

    Lemma clos_rtn1_step : forall x y, R x y -> clos_refl_trans_n1 R x y.
    Proof.
      intros x y H.
      right with x;[assumption|left].
    Defined.

    Lemma clos_rt1n_rt : forall x y,
        clos_refl_trans_1n R x y -> clos_refl_trans R x y.
    Proof.
      induction 1.
      - constructor 2.
      - constructor 3 with y; auto.
        constructor 1; auto.
    Defined.

    Lemma clos_rt_rt1n : forall x y,
        clos_refl_trans R x y -> clos_refl_trans_1n R x y.
    Proof.
      induction 1.
      - apply clos_rt1n_step; assumption.
      - left.
      - generalize IHX2; clear IHX2;
          induction IHX1; auto.
        right with y; auto.
        eapply IHIHX1; auto.
        apply clos_rt1n_rt; auto.
    Defined.

    Lemma clos_rt_rt1n_iff : forall x y,
      clos_refl_trans R x y <-> clos_refl_trans_1n R x y.
    Proof.
      split.
      - apply clos_rt_rt1n.
      - apply clos_rt1n_rt.
    Defined.

    (** Direct reflexive-transitive closure is equivalent to
        transitivity by right-step extension *)

    Lemma clos_rtn1_rt : forall x y,
        clos_refl_trans_n1 R x y -> clos_refl_trans R x y.
    Proof.
      induction 1.
      - constructor 2.
      - constructor 3 with y; auto.
        constructor 1; assumption.
    Defined.

    Lemma clos_rt_rtn1 :  forall x y,
        clos_refl_trans R x y -> clos_refl_trans_n1 R x y.
    Proof.
      induction 1.
      - apply clos_rtn1_step; auto.
      - left.
      - elim IHX2; auto.
        intros.
        right with y0; auto.
    Defined.

    Lemma clos_rt_rtn1_iff : forall x y,
        clos_refl_trans R x y <-> clos_refl_trans_n1 R x y.
    Proof.
      split.
      - apply clos_rt_rtn1.
      - apply clos_rtn1_rt.
    Defined.

    (** Induction on the left transitive step *)

    Lemma clos_refl_trans_ind_left :
      forall (x:A) (P:A -> Type), P x ->
	(forall y z:A, clos_refl_trans R x y -> P y -> R y z -> P z) ->
	forall z:A, clos_refl_trans R x z -> P z.
    Proof.
      intros.
      revert X X0.
      induction X1; intros; auto with relations.
      { apply X0 with x; auto with relations. }
      apply IHX1_2.
      { apply IHX1_1; auto with relations. }
      intros.
      apply X0 with y0; auto with relations.
      apply rt_trans with y; auto with relations.
    Defined.

    (** Induction on the right transitive step *)

    Lemma rt1n_ind_right : forall (P : A -> Type) (z:A),
      P z ->
      (forall x y, R x y -> clos_refl_trans_1n R y z -> P y -> P x) ->
      forall x, clos_refl_trans_1n R x z -> P x.
      induction 3; auto.
      apply X0 with y; auto.
    Defined.

    Lemma clos_refl_trans_ind_right : forall (P : A -> Type) (z:A),
      P z ->
      (forall x y, R x y -> P y -> clos_refl_trans R y z -> P x) ->
      forall x, clos_refl_trans R x z -> P x.
      intros P z Hz IH x Hxz.
      apply clos_rt_rt1n_iff in Hxz.
      elim Hxz using rt1n_ind_right; auto.
      clear x Hxz.
      intros x y Hxy Hyz Hy.
      apply clos_rt_rt1n_iff in Hyz.
      eauto.
    Defined.

    (** Direct reflexive-symmetric-transitive closure is equivalent to
        transitivity by symmetric left-step extension *)

    Lemma clos_rst1n_rst  : forall x y,
      clos_refl_sym_trans_1n R x y -> clos_refl_sym_trans R x y.
    Proof.
      induction 1.
      - constructor 2.
      - constructor 4 with y; auto.
        case s; [constructor 1 | constructor 3; constructor 1]; auto.
    Defined.

    Lemma clos_rst1n_trans : forall x y z, clos_refl_sym_trans_1n R x y ->
        clos_refl_sym_trans_1n R y z -> clos_refl_sym_trans_1n R x z.
      induction 1.
      - auto.
      - intros; right with y; eauto.
    Defined.

    Lemma clos_rst1n_sym : forall x y, clos_refl_sym_trans_1n R x y ->
      clos_refl_sym_trans_1n R y x.
    Proof.
      intros x y H; elim H.
      - constructor 1.
      - intros x0 y0 z D H0 H1; apply clos_rst1n_trans with y0; auto.
        right with x0.
        + destruct D; [right|left]; auto.
        + left.
    Defined.

    Lemma clos_rst_rst1n  : forall x y,
      clos_refl_sym_trans R x y -> clos_refl_sym_trans_1n R x y.
      induction 1.
      - constructor 2 with y; auto with relations.
        constructor 1.
      - constructor 1.
      - apply clos_rst1n_sym; auto.
      - eapply clos_rst1n_trans; eauto.
    Defined.

    Lemma clos_rst_rst1n_iff : forall x y,
      clos_refl_sym_trans R x y <-> clos_refl_sym_trans_1n R x y.
    Proof.
      split.
      - apply clos_rst_rst1n.
      - apply clos_rst1n_rst.
    Defined.

    (** Direct reflexive-symmetric-transitive closure is equivalent to
        transitivity by symmetric right-step extension *)

    Lemma clos_rstn1_rst : forall x y,
      clos_refl_sym_trans_n1 R x y -> clos_refl_sym_trans R x y.
    Proof.
      induction 1.
      - constructor 2.
      - constructor 4 with y; auto.
        case s; [constructor 1 | constructor 3; constructor 1]; auto.
    Defined.

    Lemma clos_rstn1_trans : forall x y z, clos_refl_sym_trans_n1 R x y ->
      clos_refl_sym_trans_n1 R y z -> clos_refl_sym_trans_n1 R x z.
    Proof.
      intros x y z H1 H2.
      induction H2.
      - auto.
      - intros.
        right with y0; eauto.
    Defined.

    Lemma clos_rstn1_sym : forall x y, clos_refl_sym_trans_n1 R x y ->
      clos_refl_sym_trans_n1 R y x.
    Proof.
      intros x y H; elim H.
      - constructor 1.
      - intros y0 z D H0 H1. apply clos_rstn1_trans with y0; auto.
        right with z.
        + destruct D; auto with relations.
        + left.
    Defined.

    Lemma clos_rst_rstn1 : forall x y,
      clos_refl_sym_trans R x y -> clos_refl_sym_trans_n1 R x y.
    Proof.
      induction 1.
      - constructor 2 with x; auto with relations.
        constructor 1.
      - constructor 1.
      - apply clos_rstn1_sym; auto.
      - eapply clos_rstn1_trans; eauto.
    Defined.

    Lemma clos_rst_rstn1_iff : forall x y,
      clos_refl_sym_trans R x y <-> clos_refl_sym_trans_n1 R x y.
    Proof.
      split.
      - apply clos_rst_rstn1.
      - apply clos_rstn1_rst.
    Defined.

  End Equivalences.

  Lemma trans_clos_transp_permute : forall x y,
    transp (trans_clos R) x y <-> trans_clos (transp R) x y.
  Proof.
    split; induction 1;
    (apply t_step; assumption) || eapply t_trans; eassumption.
  Defined.

End Properties.


(* ********************************************** *)
(* Types and Semantics for Programming Languages  *)
(* ********************************************** *)

(* Place an X in front of the appropriate statement *)
(* [ ]  I have done Problems 1 and 2 *)
(* [ ]  I have done Problems 1 and 3 *)

Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Import ListNotations.
Require Export Maps.
Require Export SfLib.

(* ********************************************** *)
(* Problem 1 *)
(* ********************************************** *)

Inductive last {X : Type} : list X -> X -> Prop :=
  | last_end : forall x,
      last (x :: nil) x
  | last_step : forall x y xs,
      last xs y -> last (x :: xs) y.

Theorem last_app : forall (X : Type) (x : X) (xs : list X),
  last xs x -> exists xs', xs = xs' ++ [x].
Proof.
  intros.
  induction xs.
 + inversion H.
 + inversion H. subst.
    - exists nil. reflexivity.
    - apply IHxs in H3. inversion H3. subst.
      exists (a :: x1). reflexivity.
Qed.

(* ********************************************** *)
(* Problem 2 *)
(* ********************************************** *)

(* Arithmetic and boolean expressions *)

Definition state := total_map nat.

Definition ble_nat := leb.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2  => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2   => ble_nat (aeval st a1) (aeval st a2)
  | BNot b1     => negb (beval st b1)
  | BAnd b1 b2  => andb (beval st b1) (beval st b2)
  end.

(* Commands *)

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CLoop : com -> bexp -> com -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'LOOP' c1 'WHILE' b 'DO' c2 'END'" :=
  (CLoop c1 b c2) (at level 80, right associativity).

(* Evaluation relation *)

Reserved Notation "c1 '/' st '||' st'" (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st || st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      (x ::= a1) / st || (t_update st x n)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st  || st' ->
      c2 / st' || st'' ->
      (c1 ;; c2) / st || st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      c1 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      c2 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_WhileEnd : forall b st c,
      beval st b = false ->
      (WHILE b DO c END) / st || st
  | E_WhileLoop : forall st st' st'' b c,
      beval st b = true ->
      c / st || st' ->
      (WHILE b DO c END) / st' || st'' ->
      (WHILE b DO c END) / st || st''
  | E_LoopEnd : forall st st' c1 b c2,
       c1 / st || st' ->
       beval st' b = false ->
       (LOOP c1 WHILE b DO c2 END) / st || st'
  | E_LoopLoop : forall st st' st'' st''' c1 b c2,
       c1 / st || st' ->
       beval st' b = true ->
       c2 / st' || st'' ->
       (LOOP c1 WHILE b DO c2 END) / st'' || st''' ->
       (LOOP c1 WHILE b DO c2 END) / st || st'''

  where "c1 '/' st '||' st'" := (ceval c1 st st').

(* Assertions *)

Definition Assertion := state -> Prop.

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P ->> Q" :=
  (assert_implies P Q) (at level 80) : hoare_spec_scope.
Open Scope hoare_spec_scope.

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

(* Hoare triples *)

Definition hoare_triple
           (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
       c / st || st'  ->
       P st  ->
       Q st'.

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level)
  : hoare_spec_scope.

(* Assertions *)

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

Lemma bexp_eval_true : forall b st,
  beval st b = true -> (bassn b) st.
Proof.
  intros b st Hbe.
  unfold bassn. assumption.  Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~ ((bassn b) st).
Proof.
  intros b st Hbe contra.
  unfold bassn in contra.
  rewrite -> contra in Hbe. inversion Hbe.  Qed.

(* Assignment *)

(*
             ------------------------------ (hoare_asgn)
             {{Q [X |-> a]}} X::=a {{Q}}
*)

Definition assn_sub X a P : Assertion :=
  fun (st : state) =>
    P (t_update st X (aeval st a)).

Notation "P [ X |-> a ]" := (assn_sub X a P) (at level 10).

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} (X ::= a) {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q X a st st' HE HQ.
  inversion HE. subst.
  unfold assn_sub in HQ. assumption.  Qed.

(* Consequence *)

(*
                {{P'}} c {{Q'}}
                   P ->> P'
                   Q' ->> Q
         -----------------------------   (hoare_consequence)
                {{P}} c {{Q}}
*)

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q c Hhoare Himp.
  intros st st' Hc HP. apply (Hhoare st st').
  assumption. apply Himp. assumption. Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P Q Q' c Hhoare Himp.
  intros st st' Hc HP.
  apply Himp.
  apply (Hhoare st st').
  assumption. assumption. Qed.

Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  P ->> P' ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q Q' c Hht HPP' HQ'Q.
  apply hoare_consequence_pre with (P' := P').
  apply hoare_consequence_post with (Q' := Q').
  assumption. assumption. assumption.  Qed.

(* Skip *)

(*
             --------------------  (hoare_skip)
             {{ P }} SKIP {{ P }}
*)

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof.
  intros P st st' H HP. inversion H. subst.
  assumption.  Qed.

(* Sequencing *)

(*
               {{ P }} c1 {{ Q }}
               {{ Q }} c2 {{ R }}
              ---------------------  (hoare_seq)
              {{ P }} c1;;c2 {{ R }}
*)

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1;;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st st' H12 Pre.
  inversion H12; subst.
  apply (H1 st'0 st'); try assumption.
  apply (H2 st st'0); assumption. Qed.

(* Conditional *)

(*
              {{P /\  b}} c1 {{Q}}
              {{P /\ ~b}} c2 {{Q}}
      ------------------------------------  (hoare_if)
      {{P}} IFB b THEN c1 ELSE c2 FI {{Q}}
*)

Theorem hoare_if : forall P Q b c1 c2,
  {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
  {{fun st => P st /\ ~(bassn b st)}} c2 {{Q}} ->
  {{P}} (IFB b THEN c1 ELSE c2 FI) {{Q}}.
Proof.
  intros P Q b c1 c2 HTrue HFalse st st' HE HP.
  inversion HE; subst.
  + (* "b is true" *)
    apply (HTrue st st').
      assumption.
      split. assumption.
             apply bexp_eval_true. assumption.
  + (* "b is false" *)
    apply (HFalse st st').
      assumption.
      split. assumption.
             apply bexp_eval_false. assumption. Qed.

(* While *)

(*
               {{P /\ b}} c {{P}}
        -----------------------------------  (hoare_while)
        {{P}} WHILE b DO c END {{P /\ ~b}}
    The proposition [P] is called an _invariant_ of the loop.
*)

Lemma hoare_while : forall P b c,
  {{fun st => P st /\ bassn b st}} c {{P}} ->
  {{P}} WHILE b DO c END {{fun st => P st /\ ~ (bassn b st)}}.
Proof.
  intros P b c Hhoare st st' He HP.
  (* Like we've seen before, we need to reason by induction
     on [He], because, in the "keep looping" case, its hypotheses
     talk about the whole loop instead of just [c]. *)
  remember (WHILE b DO c END) as wcom eqn:Heqwcom.
  induction He;
    try (inversion Heqwcom); subst; clear Heqwcom.
  + (* Case "E_WhileEnd" *)
    split. assumption. apply bexp_eval_false. assumption.
  + (* Case "E_WhileLoop" *)
    apply IHHe2. reflexivity.
    apply (Hhoare st st'). assumption.
      split. assumption. apply bexp_eval_true. assumption.
Qed.

Theorem hoare_loop : forall P Q c1 b c2,
  {{P}} c1 {{Q}} ->
  {{fun st => Q st /\ bassn b st}} c2 {{P}} ->
  {{P}} LOOP c1 WHILE b DO c2 END {{ fun st => Q st /\ ~(bassn b st)}}.
Proof.
    intros P Q c1 b c2 HTriple1 HTrue st st' HE HP.
    remember (LOOP c1 WHILE b DO c2 END) as wcom eqn:Heqwcom.
    induction HE;
    try (inversion Heqwcom); subst; clear Heqwcom.
    + split.
       - apply ( HTriple1 st st'). assumption. assumption.
       - apply bexp_eval_false. assumption.
    + apply IHHE3. reflexivity.
       apply (HTrue st'). assumption.
       split.
       - apply ( HTriple1 st st'). assumption. assumption.
       - apply bexp_eval_true. assumption.
Qed.

(* ********************************************** *)
(* Problem 3 *)
(* ********************************************** *)

(* Types *)

Inductive ty : Type :=
  | TBool  : ty
  | TArrow : ty -> ty -> ty.

(* Terms *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm.

(* Values *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_true :
      value ttrue
  | v_false :
      value tfalse.

Hint Constructors value.

(* Substitution *)

Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if beq_id x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if beq_id x x' then t1 else ([x:=s] t1))
  | tapp t1 t2 =>
      tapp ([x:=s] t1) ([x:=s] t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

(* Evaluation relation *)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tapp t1 t2 ==> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tapp v1 t2 ==> tapp v1  t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)

where "t1 '==>' t2" := (step t1 t2).

Hint Constructors step.

Definition relation a := a -> a -> Prop.

Inductive multi {X:Type} (R: relation X) : relation X :=
  | multi_refl : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi R y z ->
                    multi R x z.

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

(* Contexts *)

Definition context := partial_map ty.

(* Typing relation *)

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

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      update Gamma x T11 |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 \in TArrow T11 T12 ->
      Gamma |- t2 \in T11 ->
      Gamma |- tapp t1 t2 \in T12
  | T_True : forall Gamma,
       Gamma |- ttrue \in TBool
  | T_False : forall Gamma,
       Gamma |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T Gamma,
       Gamma |- t1 \in TBool ->
       Gamma |- t2 \in T ->
       Gamma |- t3 \in T ->
       Gamma |- tif t1 t2 t3 \in T

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

Hint Constructors has_type.

(* Canonical Forms *)

Lemma cannonical_forms_bool : forall t,
  empty |- t \in TBool ->
  value t ->
  (t = ttrue) \/ (t = tfalse).
Proof.
  intros t HT HVal.
  inversion HVal; intros; subst; try inversion HT; auto.
Qed.

Lemma cannonical_forms_fun : forall t T1 T2,
  empty |- t \in (TArrow T1 T2) ->
  value t ->
  exists x u, t = tabs x T1 u.
Proof.
  intros t T1 T2 HT HVal.
  inversion HVal; intros; subst; try inversion HT; subst; auto.
  exists x. exists t0.  auto.
Qed.

(* Progress, by induction on type derivation *)

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

Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  induction Ht; subst Gamma...
  + (* Case "T_Var" *)
    (* contradictory: variables cannot be typed in an
       empty context *)
    inversion H.

  + (* Case "T_App" *)
    (* [t] = [t1 t2].  Proceed by cases on whether [t1] is a
       value or steps... *)
    right. destruct IHHt1...
    - (* t1 is a value *)
      destruct IHHt2...
      * (* t2 is also a value *)
        assert (exists x0 t0, t1 = tabs x0 T11 t0).
        eapply cannonical_forms_fun; eauto.
        destruct H1 as [x0 [t0 Heq]]. subst.
        exists ([x0:=t2]t0)...

      * (* t2 steps *)
        inversion H0 as [t2' Hstp]. exists (tapp t1 t2')...

    - (* t1 steps *)
      inversion H as [t1' Hstp]. exists (tapp t1' t2)...

  + (* Case "T_If" *)
    right. destruct IHHt1...

    - (* t1 is a value *)
      destruct (cannonical_forms_bool t1); subst; eauto.

    - (* t1 also steps *)
      inversion H as [t1' Hstp]. exists (tif t1' t2 t3)...
Qed.


Require Import List ListSet basic Morphisms RelationClasses Equivalence.
Import ListNotations.

Section Definitions.

Definition union_fold {A B} (eq_dec : dec_type B) (f : A -> set B) (s : set A) (base : set B) : set B :=
  set_fold_left (fun acc a => set_union eq_dec acc (f a)) s base.
Definition union_map {A B} (eq_dec : dec_type B) (f : A -> set B) (s : set A) : set B :=
  union_fold eq_dec f s (empty_set _).

Definition triple_union_fold {A B C D}
           (Beq_dec : dec_type B) (Ceq_dec : dec_type C) (Deq_dec : dec_type D)
           (f : A -> (set B * set C * set D)) (l : set A) (base : set B * set C * set D) :
  (set B * set C * set D) :=
  set_fold_left
    (fun (acc : (set B * set C * set D)) (a : A) =>
               match acc with
                   (bs,cs,ds) =>
                   match f a with
                       (bs',cs',ds') =>
                       (set_union Beq_dec bs bs', set_union Ceq_dec cs cs', set_union Deq_dec ds ds')
                   end
               end)
    l base.

Definition triple_union_map {A B C D}
           (Beq_dec : dec_type B) (Ceq_dec : dec_type C) (Deq_dec : dec_type D)
           (f : A -> (set B * set C * set D)) (l : set A) : (set B * set C * set D) :=
  triple_union_fold Beq_dec Ceq_dec Deq_dec f l ((empty_set _),(empty_set _),(empty_set _)).
Definition Subset {A} (s s' : set A) := forall x, In x s -> In x s'.
Definition Set_equiv {A} (s s' : set A) := Subset s s' /\ Subset s' s.

Fixpoint dedup {A} (eq_dec : dec_type A) (s : set A) :=
  match s with
      nil => nil
    | a::s' => if set_mem eq_dec a s' then
                 dedup eq_dec s'
               else
                 a::(dedup eq_dec s')
  end.
Fixpoint set_remove_all {A} (eq_dec : dec_type A) (a : A) (s : set A) :=
  match s with
      nil => nil
    | a'::s' => if eq_dec a a' then
                  set_remove_all eq_dec a s'
                else
                  a'::(set_remove_all eq_dec a s')
  end.

End Definitions.

Global Program Instance subset_refl {A} : Reflexive (@Subset A).
Next Obligation.
intros y Hin; auto.
Qed.
Hint Immediate subset_refl.

Global Program Instance subset_trans {A} : Transitive (@Subset A).
Next Obligation. intros w Hin; apply H,H0 in Hin; assumption.
Qed.

Global Program Instance set_equiv_equiv {A} : Equivalence (@Set_equiv A).
Next Obligation.
intro; split; reflexivity.
Qed.
Next Obligation.
intros ? ? [? ?]; split; auto.
Qed.
Next Obligation.
intros ? ? ? [H ?] [H1 ?]; split; intros ? ?;[apply H1,H|]; auto.
Qed.

Section Facts.
Variables (A : Type) (Aeq_dec : dec_type A).

Lemma set_add_elim_LEM : forall (s : set A) a b, set_In a (set_add Aeq_dec b s) ->
                                                 (a = b /\ ~ set_In a s) \/ set_In a s.
Proof.
  intros s a ? H; destruct (set_add_elim _ _ _ _ H);
  [destruct (set_In_dec Aeq_dec a s)|]; auto.
Qed.

Theorem set_union_elim_LEM : forall (s s' : set A) a, set_In a (set_union Aeq_dec s s') ->
                                                      set_In a s \/
                                                      (set_In a s' /\ ~ set_In a s).
Proof.
  intros s ? a H; destruct (set_union_elim _ _ _ _ H);[|destruct (set_In_dec Aeq_dec a s)]; auto.
Qed.

Lemma set_add_nodup : forall (s : set A) a, NoDup s -> NoDup (set_add Aeq_dec a s).
Proof.
  induction s as [|a' s IH]; intros; simpl;
  [constructor; [intro bad; inversion bad|constructor]
  |destruct (Aeq_dec a a');
    [|inversion H as [|? ? Hnin Hdup]; subst;
      specialize (IH a Hdup);
      constructor;
      [intro Hin; apply set_add_elim2 in Hin;[apply Hnin in Hin|]
      |]]]; auto.
Qed.

Lemma set_union_nodup : forall (s s' : set A), NoDup s -> NoDup (set_union Aeq_dec s s').
Proof.
  induction s'; intro nds; [|apply set_add_nodup];auto.
Qed.

Theorem set_remove_in : forall (s : set A) (a a' : A), set_In a (set_remove Aeq_dec a' s) -> set_In a s.
Proof.
  induction s as [|a_ s IH]; intros a a' H;
  [inversion H
  |simpl in H;
    destruct (Aeq_dec a' a_);
    [right; auto
    |inversion H; [subst; left|right; apply (IH a a')]; auto]].
Qed.

Theorem set_remove_all_in : forall (s : set A) (a a' : A), set_In a (set_remove_all Aeq_dec a' s) -> set_In a s.
Proof.
  induction s as [|a_ s IH]; intros a a' H;
  [inversion H
  |simpl in H;
    destruct (Aeq_dec a' a_);
    [subst; right; apply (IH a a_); auto
    |inversion H; [subst; left|right; apply (IH a a')]]]; auto.
Qed.

Theorem set_remove_all_neq : forall (s : set A) (a a' : A), set_In a (set_remove_all Aeq_dec a' s) -> a <> a'.
Proof.
  induction s as [|a_ s IH]; intros a a' H;
  [inversion H
  |simpl in H;
    destruct (Aeq_dec a' a_); [|inversion H];subst]; auto.
Qed.

Theorem set_remove_all_neq_in : forall (s : set A) (a a' : A), set_In a s -> a <> a' -> set_In a (set_remove_all Aeq_dec a' s).
Proof.
  induction s as [|a_ s IH]; intros a a' Hin Hneq;
  [inversion Hin
  |simpl;
    destruct (Aeq_dec a' a_);
    inversion Hin;
    subst; [bad_eq|apply IH |left |right; apply IH]]; auto.
Qed.

Theorem set_remove_all_notin : forall a (s : set A), ~ set_In a (set_remove_all Aeq_dec a s).
Proof.
  induction s; [intros bad; inversion bad
               |simpl; destruct (Aeq_dec a a0);
                [subst|intro bad; inversion bad; [subst;bad_eq|]]; auto].
Qed.

Global Program Instance set_union_respects : Proper (Set_equiv ==> Set_equiv ==> Set_equiv) (set_union Aeq_dec).
Next Obligation.
intros x y H0 z w H1; split; intros u Hin;
(destruct (set_union_elim Aeq_dec _ _ _ Hin);
[apply set_union_intro1, H0
|apply set_union_intro2, H1]; auto).
Qed.

Global Program Instance set_remove_all_respects : Proper ((@eq A) ==> Set_equiv ==> Set_equiv) (set_remove_all Aeq_dec).
Next Obligation.
intros ? ? Heq s s' [Sub Sub']; split; intros u Hin;
(subst;
cut (In u s');
  [cut (u <> y);
    [intros Hin' Hneq; apply set_remove_all_neq_in; try apply Sub'
    |apply (set_remove_all_neq _ _ _ Hin)]
  |apply set_remove_all_in in Hin; (apply Sub in Hin || apply Sub' in Hin)]; auto).
Qed.

Global Program Instance set_add_respects : Proper ((@eq A) ==> Set_equiv ==> Set_equiv) (set_add Aeq_dec).
Next Obligation.
  intros ? ? Heq s s' [Sub Sub']; subst; split; intros u Hin;
  (destruct (set_add_elim Aeq_dec _ _ _ Hin) as [|Hin'];
    [subst; apply set_add_intro2; reflexivity
    |(apply Sub in Hin' || apply Sub' in Hin'); apply set_add_intro1]; auto).
Qed.

Global Program Instance set_diff_respects : Proper (Set_equiv ==> Set_equiv ==> Set_equiv) (set_diff Aeq_dec).
Next Obligation.
intros u v [Subv Subu] s s' [Subs Subs']; split; intros x Hin;
(pose (need0 := set_diff_elim1 _ _ _ _ Hin);
pose (need1 := set_diff_elim2 _ _ _ _ Hin);
(apply Subv in need0 || apply Subu in need0);
((cut (~ In x s');[intro; apply set_diff_intro; auto|intro xs'; apply Subs' in xs'; contradiction])
||(cut (~ In x s);[intro; apply set_diff_intro; auto|intro xs'; apply Subs in xs'; contradiction]))).
Qed.

Theorem dedup_notin : forall (s : set A) a, ~ set_In a s -> ~ set_In a (dedup Aeq_dec s).
Proof.
  induction s; intros a' Hnin bad; [inversion bad|simpl in bad;case_eq (set_mem Aeq_dec a s); intro res; rewrite res in bad;[apply IHs in bad; [|intro bad'; apply Hnin; right]; auto|]].
inversion bad; [subst; apply Hnin; left; reflexivity|apply IHs in H; [|intro bad'; apply Hnin; right]]; auto.
Qed.

Theorem dedup_in : forall (s : set A) a, set_In a (dedup Aeq_dec s) -> set_In a s.
Proof.
  induction s; intros a' Hin; [inversion Hin|simpl in Hin].
  case_eq (set_mem Aeq_dec a s); intro res; rewrite res in Hin.
  apply IHs in Hin; right; auto.
  inversion Hin; [subst; left|apply IHs in H; right]; auto.
Qed.

Theorem in_dedup : forall (s : set A) a, set_In a s -> set_In a (dedup Aeq_dec s).
Proof.
  induction s; intros a' Hin; [inversion Hin|simpl].
  case_eq (set_mem Aeq_dec a s); intro res;
  [apply set_mem_correct1 in res; apply IHs;
   inversion Hin; subst; auto
  |inversion Hin; subst; [left|right; apply IHs]; auto].
Qed.

Theorem dedup_nodup : forall (s : set A), NoDup (dedup Aeq_dec s).
Proof.
  induction s;[constructor|simpl; case_eq (set_mem Aeq_dec a s);intro res;[auto|apply set_mem_complete1 in res]].
  apply dedup_notin in res; constructor; auto.
Qed.

Global Program Instance dedup_respects : Proper (Set_equiv ==> Set_equiv) (dedup Aeq_dec).
Next Obligation.
intros s s' [Subs Subs']; split; intros ? ?; apply in_dedup; [apply Subs|apply Subs']; apply dedup_in; auto.
Qed.

Theorem fold_left_nodup : forall B (f: set A -> B -> set A) (fprop : forall X b, NoDup X -> NoDup (f X b))
                                 (s : set B) (b : set A),
                            NoDup b -> NoDup (set_fold_left f s b).
Proof.
  induction s; intros b ndb;[|apply IHs, fprop]; auto.
Qed.

Theorem union_map_nodup : forall B (f : B -> set A) s, NoDup (union_map Aeq_dec f s).
Proof.
  intros; apply fold_left_nodup;
  [intros; apply set_union_nodup; auto
  |constructor].
Qed.

Theorem union_fold_base_subset : forall B (f: B -> set A) (s : set B) (base : set A),
                                   Subset base (union_fold Aeq_dec f s base).
Proof.
  induction s as [|b s IH]; intros base; simpl.
  reflexivity.
  transitivity (set_union Aeq_dec base (f b)); [intros ? ?; apply set_union_intro1; auto|apply IH].
Qed.

Theorem fold_left_subset : forall B (f: B -> set A) (s : set B) (base : set A),
                             Subset base (set_fold_left (fun acc b =>
                                                           set_union Aeq_dec acc (f b))
                                                        s base).
Proof.
  induction s; intros b a' Hin.
  auto.
  simpl in *.
  apply IHs.
  apply set_union_intro1; auto.
Qed.

Theorem union_subset1 : forall {B} (Beq_dec : dec_type B) (s s' s'' : set B), Subset (set_union Beq_dec s s') s'' ->
                                                                              Subset s s''.
Proof.
  intros; intros x Hin; apply (set_union_intro1 Beq_dec _ _ s'),H in Hin; auto.
Qed.

Theorem union_subset2 : forall {B} (Beq_dec : dec_type B) (s s' s'' : set B), Subset (set_union Beq_dec s s') s'' ->
                                                                              Subset s' s''.
Proof.
  intros; intros x Hin; apply (set_union_intro2 Beq_dec _ _ s'),H in Hin; auto.
Qed.

Definition Triple_subset {A B C} (s s' : set A * set B * set C) : Prop :=
  match s,s' with
      (As,Bs,Cs),(As',Bs',Cs') => Subset As As' /\ Subset Bs Bs' /\ Subset Cs Cs'
  end.
Theorem triple_union_fold_base_subset : forall B C D (Beq_dec : dec_type B) (Ceq_dec : dec_type C)
                                               (f: D -> set A * set B * set C) (s : set D)
                                               (base : set A * set B * set C),
                                          Triple_subset base (triple_union_fold Aeq_dec Beq_dec Ceq_dec f s base).
Proof.
  induction s; intros [[Bas Bbs] Bcs].
  hnf; repeat split; reflexivity.
  simpl.
  specialize (IHs (let (p, ds') := f a in
          let (bs', cs') := p in
          (set_union Aeq_dec Bas bs', set_union Beq_dec Bbs cs',
          set_union Ceq_dec Bcs ds'))).
  destruct (f a) as [[bs' cs'] ds'].
  destruct (triple_union_fold Aeq_dec Beq_dec Ceq_dec f s
         (set_union Aeq_dec Bas bs', set_union Beq_dec Bbs cs',
         set_union Ceq_dec Bcs ds')) as [[As' Bs'] Cs'].
  destruct IHs as [X [Y Z]]; repeat split; solve [eapply union_subset1; eauto| eapply union_subset2; eauto].
Qed.

Theorem fold_left_subset_in : forall B (f: B -> set A) (s : set B) (base : set A) b,
                             In b s -> Subset (f b) (set_fold_left (fun acc b =>
                                                           set_union Aeq_dec acc (f b))
                                                        s base).

Proof.
  induction s; intros base b Hin a' Hin'.
  inversion Hin.
  simpl in *.
  inversion Hin as [Heq|Hrest].
  subst; apply union_fold_base_subset,set_union_intro2; auto.
  apply (IHs (set_union Aeq_dec base (f a)) b Hrest); auto.
Qed.

Theorem union_fold_subset_in : forall B (f: B -> set A) (s : set B) (base : set A) b,
                                 In b s -> Subset (f b) (union_fold Aeq_dec f s base).
Proof.
  intros; apply fold_left_subset_in; auto.
Qed.

Theorem triple_union_fold_subset_in : forall B C D
                                            (Beq_dec : dec_type B) (Ceq_dec : dec_type C)
                                            (f: D -> set A * set B * set C) (s : set D)
                                            (base : set A * set B * set C) d,
                                       In d s ->
                                       Triple_subset (f d) (triple_union_fold Aeq_dec Beq_dec Ceq_dec f s base).
Proof.
  induction s; intros base d Hin; inversion Hin; [subst|apply IHs; auto].

  case_eq (triple_union_fold Aeq_dec Beq_dec Ceq_dec f s
         (let (p, ds) := base in
          let (bs, cs) := p in
          let (p0, ds') := f d in
          let (bs', cs') := p0 in
          (set_union Aeq_dec bs bs', set_union Beq_dec cs cs',
          set_union Ceq_dec ds ds'))).
    intros [As' Bs'] Cs' peq.
    pose (L := triple_union_fold_base_subset).
    specialize (L _ _ _ Beq_dec Ceq_dec f s (let (p, ds) := base in
           let (bs, cs) := p in
           let (p0, ds') := f d in
           let (bs', cs') := p0 in
           (set_union Aeq_dec bs bs', set_union Beq_dec cs cs',
           set_union Ceq_dec ds ds'))).
    rewrite peq in L.
    simpl; rewrite peq.
    destruct base as [[bs cs] ds].
    destruct (f d) as [[a b] c].
    destruct L as [Asub [Bsub Csub]]; repeat split; solve [eapply union_subset1; eauto | eapply union_subset2; eauto].
Qed.

Theorem union_map_subset : forall B (f : B -> set A) s b, In b s -> Subset (f b) (union_map Aeq_dec f s).
Proof.
  intros; apply union_fold_subset_in; auto.
Qed.

Theorem triple_union_map_subset : forall B C D (Beq_dec : dec_type B) (Ceq_dec : dec_type C)
                                          (f : D -> (set A * set B * set C)) (s : set D) d,
                                    set_In d s ->
                                    Triple_subset (f d) (triple_union_map Aeq_dec Beq_dec Ceq_dec f s).
Proof.
  intros; apply triple_union_fold_subset_in; auto.
Qed.

Lemma in_set_ind : forall A (P : set A -> Prop),
                     P nil ->
                     forall s',
                       (forall s a, P s /\ In a s' /\ Subset s s' -> P (a :: s)) ->
                       P s'.
induction s'; intros; auto.
apply H0; split. apply IHs'; intros ? ? [? [? ?]]. apply H0; repeat split; [|right|intros x X; apply H3 in X;right]; auto.
(* Todo *)
split;[left|right];auto.
Qed.

Theorem union_folded_property : forall B (f : B -> set A) (P : A -> Prop) s base
                                       (fprop : forall b, set_In b s -> Forall P (f b)),
                                  Forall P base ->
                                  Forall P (union_fold Aeq_dec f s base).
Proof.
  intros ? ? ? s;
  apply (@in_set_ind _ (fun s =>
                     forall base (fprop : forall b, set_In b s -> Forall P (f b)),
                       Forall P base ->
                       Forall P (union_fold Aeq_dec f s base))).
  intros base fprop allbase; auto.
  intros s' a [IH [ains Hsub]] base fprop allbase.
  simpl; apply IH.
  intros b Hin; apply fprop; right; auto.
  rewrite Forall_forall; intros x Hin; apply set_union_elim in Hin.
  destruct Hin as [inbase|inf].
  rewrite Forall_forall in allbase; apply allbase; auto.
  specialize (fprop a (or_introl (eq_refl _))); rewrite Forall_forall in fprop; apply fprop; auto.
Qed.

(*
Inductive Forall3 {D B C} (P : D -> B -> C -> Prop) : list D -> list B -> list C -> Prop :=
  nil_forall3 : Forall3 P nil nil nil
| cons_forall3 : forall d b c Ds Bs Cs, Forall3 P Ds Bs Cs -> P d b c -> Forall3 P (d::Ds) (b::Bs) (c::Cs).

Fixpoint In3 {D B C} (d : D) (b : B) (c : C) (Ds : list D) (Bs : list B) (Cs : list C) : Prop :=
  length Ds = length Bs /\ length Bs = length Cs /\
  match Ds,Bs,Cs with
      d'::Ds,b'::Bs,c'::Cs => (d = d' /\ b' = b /\ c' = c) \/ (In3 d b c Ds Bs Cs)
    | nil,nil,nil => False
    | _,_,_ => True (* bad lists just make this meaningless *)
  end.
Fixpoint list3 {D B C} (Ds : list D) (Bs : list B) (Cs : list C) : Prop :=
  match Ds,Bs,Cs with
      d'::Ds,b'::Bs,c'::Cs => (list3 Ds Bs Cs)
    | _,_,_ => True
  end.
Functional Scheme in3_ind := Induction for list3 Sort Prop.

Theorem Forall3_forall : forall D B C (P : D -> B -> C -> Prop) (Ds : list D) (Bs : list B) (Cs : list C),
                           (Forall3 P Ds Bs Cs) <-> (length Ds = length Bs /\ length Bs = length Cs /\ forall d b c, In3 d b c Ds Bs Cs -> P d b c).
Proof.
  intros; split.
  intro H; induction H; repeat split.
  intros d b c Hin; inversion Hin.
  intuition.
  destruct IHForall3 as [len0 [len1 IH]]; simpl; auto.
  destruct IHForall3 as [len0 [len1 IH]]; simpl; auto.
  intros d' b' c' Hin.
  inversion Hin as [len0 [len1 [[dd [bb cc]]|Hrest]]].
  subst; auto.
  apply IHForall3; auto.
  apply (@in3_ind _ _ _ (fun Ds Bs Cs prp => prp -> length Ds = length Bs /\ length Bs = length Cs /\ (forall d b c, In3 d b c Ds Bs Cs -> P d b c) -> Forall3 P Ds Bs Cs)); intros; try solve [auto |contradiction|intuition; simpl in *; discriminate].
  subst; intuition; simpl in *;
  cut (Bs0 = []); [|destruct Bs0; [auto|discriminate]];
  intro;
  cut (Cs0 = []); [|destruct Cs0; [auto|subst; simpl in *; discriminate]];
  intros; subst; constructor.

  subst.
  destruct H1 as [? [? ?]].
  simpl in *.
  injects H2; injects H1.
  remember H3 as IH; clear HeqIH.
  specialize (H3 _x _x0 _x1 (conj H1 (conj H2 (or_introl (conj (eq_refl _x) (conj (eq_refl _x0) (eq_refl _x1))))))).
  constructor; auto.
  apply H; auto.
  repeat split; auto.
  revert Bs Cs.
  induction Ds; simpl; [auto|];
  induction Bs; simpl; [auto|];
  induction Cs; simpl; [auto|];
  apply IHDs.
Qed.
*)
Theorem triple_union_folded_property : forall B C D (Beq_dec : dec_type B) (Ceq_dec : dec_type C)
                                              (f : D -> set A * set B * set C)
                                              (PA : A -> Prop) (PB : B -> Prop) (PC : C -> Prop) s
                                              (base : set A * set B * set C)
                                              (fprop : forall d, set_In d s -> match (f d) with (As,Bs,Cs) => Forall PA As /\ Forall PB Bs /\ Forall PC Cs end),
                                         match base with (As,Bs,Cs) => Forall PA As /\ Forall PB Bs /\ Forall PC Cs end  ->
                                         (match (triple_union_fold Aeq_dec Beq_dec Ceq_dec f s base) with
                                              (As,Bs,Cs) => Forall PA As /\ Forall PB Bs /\ Forall PC Cs end).
  intros ? ? ? ? ? ? ? ? ? s;
  apply (@in_set_ind _ (fun s => forall (base : set A * set B * set C)
                                              (fprop : forall d, set_In d s -> match (f d) with (As,Bs,Cs) => Forall PA As /\ Forall PB Bs /\ Forall PC Cs end),
                                         match base with (As,Bs,Cs) => Forall PA As /\ Forall PB Bs /\ Forall PC Cs end  ->
                                         (match (triple_union_fold Aeq_dec Beq_dec Ceq_dec f s base) with
                                              (As,Bs,Cs) => Forall PA As /\ Forall PB Bs /\ Forall PC Cs end))).
  auto.
  intros s' a IH base fprop allbase.
  simpl; apply IH.
  intros d Hin; apply fprop; right; auto.
  destruct base as [[ds bs] cs].
  case_eq (f a); intros [bs' cs'] ds' Heq.
  repeat rewrite Forall_forall; repeat split; intros x Hin;
  specialize (fprop a (or_introl (eq_refl _)));
  rewrite Heq in fprop;
  repeat rewrite Forall_forall in *;
  apply set_union_elim in Hin; destruct Hin as [inbase|inf];
  try solve [apply allbase; auto|apply fprop;auto].
Qed.

Theorem length_add : forall s a, ~ set_In a s -> length (set_add Aeq_dec a s) = S (length s).
Proof.
  induction s as [|a s IH]; intros a' H;
  [|simpl;
     destruct (Aeq_dec a' a);
     [subst; elimtype False; apply H; left
     |simpl; f_equal; apply IH; intro bad; apply H; right]]; auto.
Qed.

End Facts.