Require Import Coq.Relations.Relation_Operators.
Require Import Metalib.Metatheory.

Module Syntax.

Inductive channel : Set :=
| free : atom -> channel
| bound : nat -> channel
.

Inductive process : Set :=
| stop : process
| input : channel -> process -> process
| output : channel -> channel -> process -> process
| compose : process -> process -> process
| replicate : process -> process.

Definition fv_channel c :=
  match c with
    | free f => singleton f
    | bound _ => empty
  end.

Fixpoint fv p :=
  match p with
    | stop => empty
    | input c1 p => union (fv p) (fv_channel c1)
    | output c1 c2 p => union (fv p) (union (fv_channel c1) (fv_channel c2))
    | compose p1 p2 => union (fv p1) (fv p2)
    | replicate p => fv p
  end.

Definition open_channel n a c :=
  match c with
    | free f => free f
    | bound b => if beq_nat b n then a else bound b
  end.

Fixpoint open_rec n a p :=
  match p with
    | stop => stop
    | input c p =>
      input (open_channel n a c) (open_rec (S n) a p)
    | output c1 c2 p =>
      output (open_channel n a c1) (open_channel n a c2) (open_rec n a p)
    | replicate p => replicate (open_rec n a p)
    | compose p1 p2 => compose (open_rec n a p1) (open_rec n a p2)
  end.

Definition open a p := open_rec 0 a p.

Inductive lc_channel : channel -> Prop :=
| lc_free : forall a, lc_channel (free a)
.

(* This is different from local closure of expressions in e.g. System T,
since we don't actually care if when we substitute, the name is free
in the expression we're substituting for.
*)
Inductive lc : process -> Prop :=
| lc_replicate : forall p, lc p -> lc (replicate p)
| lc_compose : forall p1 p2, lc p1 -> lc p2 -> lc (compose p1 p2)
| lc_stop : lc stop
| lc_output : forall c1 c2 p, lc p -> lc_channel c1 -> lc_channel c2 -> lc (output c1 c2 p)
| lc_input : forall c p, lc_channel c -> lc p -> lc (input c p)
.

End Syntax.

Module Semantics.

Import Syntax.

Inductive context : Type :=
| c_input : channel -> channel -> context -> context
| c_output : channel -> channel -> context -> context
| c_replicate : context -> context
| c_compose_l : context -> process -> context
| c_compose_r : process -> context -> context
| c_hole : context
.

Fixpoint fill (c : context) (p : process) : process :=
  match c with
    | c_input c1 c2 con => input c1 (fill con p)
    | c_output c1 c2 con => output c1 c2 (fill con p)
    | c_hole => p
    | c_replicate con => replicate (fill con p)
    | c_compose_l con r => compose (fill con p) r
    | c_compose_r l con => compose l (fill con p)
  end.

Inductive congruent : process -> process -> Prop :=
| cong_compose_comm : forall P1 P2, congruent (compose P1 P2) (compose P2 P1)
| cong_compose_assoc : forall P1 P2 P3, congruent (compose P1 (compose P2 P3)) (compose (compose P1 P2) P3)
| cong_zero : forall P, congruent (compose P stop) P
| cong_replicate : forall P, congruent (replicate P) (compose P (replicate P))
| cong_context : forall c P Q, congruent P Q -> congruent (fill c P) (fill c Q)
| cong_refl : forall P, congruent P P
| cong_symm : forall P Q, congruent P Q -> congruent Q P
| cong_trans : forall P Q R, congruent P Q -> congruent Q R -> congruent P R
.

(*Definition congruent : process -> process -> Prop :=
  clos_refl_sym_trans process cong_base.*)

Inductive step_process_base : process -> process -> Prop :=
| step_composition : forall P1 P2 P3, step_process_base P1 P2 -> step_process_base (compose P1 P3) (compose P2 P3)
| step_communication : forall c z P Q, step_process_base (compose (output c z Q) (input c P)) (compose Q (open z P)).

Definition step_process P Q : Prop :=
  exists P' Q', congruent P P' /\ congruent Q Q' /\ step_process_base P' Q'.

Inductive step_process_cong : process -> process -> Prop :=
| step_composition_cong : forall P1 P2 P3, step_process_cong P1 P2 -> step_process_cong (compose P1 P3) (compose P2 P3)
| step_communication_cong : forall c z P Q, step_process_cong (compose (output c z Q) (input c P)) (compose Q (open z P))
| step_cong : forall P Q P' Q', step_process_cong P Q -> congruent P P' -> congruent Q Q' -> step_process_cong P' Q'.

Theorem cong_end : forall P Q, step_process_cong P Q <-> step_process P Q.
Proof.
  intros. split.
  - intros. induction H.
    + unfold step_process. destruct IHstep_process_cong as [P1'].
      destruct H0 as [P2'].
      exists (compose P1' P3). exists (compose P2' P3).
      destruct H0 as [CP1 H0]. destruct H0 as [CP2 SPB].
      repeat split.
      * assert (compose P1 P3 = fill (c_compose_l c_hole P3) P1); eauto.
        assert (compose P1' P3 = fill (c_compose_l c_hole P3) P1'); eauto.
        rewrite H0; rewrite H1. eapply cong_context. eapply CP1.
      * assert (compose P2 P3 = fill (c_compose_l c_hole P3) P2); eauto.
        assert (compose P2' P3 = fill (c_compose_l c_hole P3) P2'); eauto.
        rewrite H0; rewrite H1. eapply cong_context. eapply CP2.
      * constructor. eapply SPB.
    + unfold step_process.
      exists (compose (output c z Q) (input c P)).
      exists (compose Q (open z P)).
      repeat split; try (eapply cong_refl); constructor.
    + destruct IHstep_process_cong as [P1].
      destruct H2 as [Q1]. exists P1. exists Q1.
      repeat split.
      * eapply cong_trans. eapply cong_symm; eauto. eapply H2.
      * eapply cong_trans. eapply cong_symm; eauto. eapply H2.
      * eapply H2.
  - intros. destruct H as [P']. destruct H as [Q'].
    destruct H as [CPP' H]. destruct H as [CQQ' H].
    apply step_cong with (P := P') (Q := Q').
    generalize dependent P. generalize dependent Q. induction H.
    + intros. eapply step_composition_cong. eapply IHstep_process_base.
      eapply cong_refl. eapply cong_refl.
    + intros. eapply step_communication_cong.
    + eapply cong_symm; eauto.
    + eapply cong_symm; eauto.
Qed.

Inductive label :=
| send_label : channel -> channel -> label
| recv_label : channel -> channel -> label
| tau_label : label.

Definition fv_label l :=
  match l with
    | send_label c1 c2 => union (fv_channel c1) (fv_channel c2)
    | recv_label c1 c2 => union (fv_channel c1) (fv_channel c2)
    | tau_label => empty
  end.

Definition bound_label l :=
  match l with
    | recv_label c1 c2 => fv_channel c2
    | _ => empty
  end.

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let D := gather_atoms_with (fun x : process => fv x) in
  constr:(A `union` B `union` D).

Inductive lts : process -> label -> process -> Prop :=
| lts_comp_left : forall P P' Q l, lts P l P' -> lts (compose P Q) l (compose P' Q)
| lts_comp_right : forall P Q Q' l, lts Q l Q' -> lts (compose P Q) l (compose P Q')
| lts_input : forall P c n, lts (input c P) (recv_label c n) (open n P)
| lts_output : forall P c c', lts (output c c' P) (send_label c c') P
| lts_comm_left : forall P P' Q Q' c n, lts P (send_label c n) P' -> lts Q (recv_label c n) Q' -> lts (compose P Q) (tau_label) (compose P' Q')
| lts_comm_right : forall P P' Q Q' c n, lts P (recv_label c n) P' -> lts Q (send_label c n) Q' -> lts (compose P Q) tau_label (compose P' Q')
| lts_rep_act : forall P a P', lts P a P' -> lts (replicate P) a (compose P' (replicate P))
| lts_rep_comm : forall P c n P' P'',
                   lts P (send_label c n) P' -> lts P (recv_label c n) P'' ->
                   lts (replicate P) tau_label (compose (compose P' P'') (replicate P))
.

Lemma lts_input_helper :
  forall P Q c1 c2, lts P (recv_label c1 c2) Q ->
                exists R S, congruent P (compose (input c1 R) S) /\
                            congruent Q (compose (open c2 R) S).
Proof.
  intros. remember (recv_label c1 c2). induction H; try (inversion Heql; subst).
  - apply IHlts in H0. destruct H0 as [R]. destruct H0 as [S].
    exists R. exists (compose S Q).
    split.
    + apply cong_trans with (Q := (compose (compose (input c1 R) S) Q)).
      assert (compose P Q = fill (c_compose_l c_hole Q) P); eauto.
      assert (compose (compose (input c1 R) S) Q = fill (c_compose_l c_hole Q) (compose (input c1 R) S)); eauto.
      rewrite H1; rewrite H2; eapply cong_context. eapply H0.
      eapply cong_symm; eapply cong_compose_assoc.
    + apply cong_trans with (Q := (compose (compose (open c2 R) S) Q)).
      assert (compose P' Q = fill (c_compose_l c_hole Q) P'); eauto.
      assert (compose (compose (open c2 R) S) Q = fill (c_compose_l c_hole Q) (compose (open c2 R) S)); eauto.
      rewrite H1; rewrite H2; eapply cong_context. eapply H0.
      eapply cong_symm; eapply cong_compose_assoc.
  - apply IHlts in H0. destruct H0 as [R]. destruct H0 as [S].
    exists R. exists (compose P S).
    split.
    + eapply cong_trans with (Q := (compose P (compose (input c1 R) S))).
      assert (compose P Q = fill (c_compose_r P c_hole) Q); eauto.
      assert (compose P (compose (input c1 R) S) = fill (c_compose_r P c_hole) (compose (input c1 R) S)); eauto.
      rewrite H1; rewrite H2; eapply cong_context. eapply H0.
      eapply cong_trans. eapply cong_compose_assoc.
      eapply cong_trans with (Q := (compose (compose (input c1 R) P) S)).
      assert (compose (compose P (input c1 R)) S = fill (c_compose_l c_hole S) (compose P (input c1 R))); eauto.
      assert (compose (compose (input c1 R) P) S = fill (c_compose_l c_hole S) (compose (input c1 R) P)); eauto.
      rewrite H1; rewrite H2; eapply cong_context.
      eapply cong_compose_comm. eapply cong_symm; eapply cong_compose_assoc.
    + apply cong_trans with (Q := (compose P (compose (open c2 R) S))).
      assert (compose P Q' = fill (c_compose_r P c_hole) Q'); eauto.
      assert (compose P (compose (open c2 R) S) = fill (c_compose_r P c_hole) (compose (open c2 R) S)); eauto.
      rewrite H1; rewrite H2; eapply cong_context; eapply H0.
      eapply cong_trans. eapply cong_compose_assoc.
      eapply cong_trans.
      assert (compose (compose P (open c2 R)) S = fill (c_compose_l c_hole S) (compose P (open c2 R))); eauto.
      rewrite H1; eapply cong_context. eapply cong_compose_comm. simpl.
      eapply cong_symm; eapply cong_compose_assoc.
  - inversion Heql; subst. exists P. exists stop.
    split. eapply cong_symm; eapply cong_zero. eapply cong_symm; eapply cong_zero.
  - eapply IHlts in H0. destruct H0 as [R]. destruct H0 as [S].
    exists R. exists (compose S (replicate P)). split.
    + eapply cong_trans. eapply cong_replicate.
      eapply cong_trans.
      assert (compose P (replicate P) = fill (c_compose_l c_hole (replicate P)) P); eauto.
      rewrite H1. eapply cong_context. eapply H0. simpl.
      eapply cong_symm. eapply cong_compose_assoc.
    + eapply cong_trans.
      assert (compose P' (replicate P) = fill (c_compose_l c_hole (replicate P)) P'); eauto.
      rewrite H1; eapply cong_context. eapply H0. simpl.
      eapply cong_symm; eapply cong_compose_assoc.
Qed.

Lemma lts_output_helper :
  forall P Q c1 c2, lts P (send_label c1 c2) Q ->
                    exists R S, congruent P (compose (output c1 c2 R) S) /\
                                congruent Q (compose R S).
Proof.
  intros. remember (send_label c1 c2). induction H; try (inversion Heql; subst).
  - apply IHlts in H0. destruct H0 as [R]. destruct H0 as [S].
    exists R. exists (compose S Q).
    split.
    + eapply cong_trans.
      assert (compose P Q = fill (c_compose_l c_hole Q) P); eauto.
      rewrite H1. eapply cong_context. eapply H0. simpl.
      eapply cong_symm; eapply cong_compose_assoc.
    + eapply cong_trans.
      assert (compose P' Q = fill (c_compose_l c_hole Q) P'); eauto.
      rewrite H1. eapply cong_context. eapply H0. simpl.
      eapply cong_symm; eapply cong_compose_assoc.
  - apply IHlts in H0. destruct H0 as [R]. destruct H0 as [S].
    exists R. exists (compose P S).
    split.
    + eapply cong_trans.
      assert (compose P Q = fill (c_compose_r P c_hole) Q); eauto.
      rewrite H1; eapply cong_context. eapply H0. simpl.
      eapply cong_trans. eapply cong_compose_assoc.
      eapply cong_trans.
      assert (compose (compose P (output c1 c2 R)) S = fill (c_compose_l c_hole S) (compose P (output c1 c2 R))); eauto.
      rewrite H1; eapply cong_context. eapply cong_compose_comm. simpl.
      eapply cong_symm; eapply cong_compose_assoc.
    + eapply cong_trans.
      assert (compose P Q' = fill (c_compose_r P c_hole) Q'); eauto.
      rewrite H1; eapply cong_context. eapply H0. simpl.
      eapply cong_trans. eapply cong_compose_assoc.
      eapply cong_trans.
      assert (compose (compose P R) S = fill (c_compose_l c_hole S) (compose P R)); eauto.
      rewrite H1; eapply cong_context. eapply cong_compose_comm. simpl.
      eapply cong_symm; eapply cong_compose_assoc.
  - exists P. exists stop. split. eapply cong_symm; eapply cong_zero.
    eapply cong_symm; eapply cong_zero.
  - eapply IHlts in H0. destruct H0 as [R]. destruct H0 as [S].
    exists R. exists (compose S (replicate P)). split.
    + eapply cong_trans. eapply cong_replicate.
      eapply cong_trans.
      assert (compose P (replicate P) = fill (c_compose_l c_hole (replicate P)) P); eauto.
      rewrite H1; eapply cong_context. apply H0. simpl.
      eapply cong_symm; eapply cong_compose_assoc.
    + eapply cong_trans.
      assert (compose P' (replicate P) = fill (c_compose_l c_hole (replicate P)) P'); eauto.
      rewrite H1; eapply cong_context. apply H0. simpl.
      eapply cong_symm; eapply cong_compose_assoc.
Qed.

Definition lts_cong P a Q :=
  exists P' Q', congruent P P' /\ congruent Q Q' /\ lts P' a Q'.

Theorem lts_tau_step : forall P Q, step_process P Q -> lts_cong P tau_label Q.
Proof.
  intros. destruct H as [P']. destruct H as [Q'].
  destruct H as [CPP' H]; destruct H as [CQQ' S].
  unfold lts_cong. exists P'. exists Q'. repeat split; eauto.
  clear CPP'; clear CQQ'.
  induction S.
  - eapply lts_comp_left. eapply IHS.
  - eapply lts_comm_left. constructor. constructor.
Qed.

Theorem tau_lts_comm_step :
  forall P Q P' Q' c n, lts P (send_label c n) P' ->
                        lts Q (recv_label c n) Q' ->
                        step_process (compose P Q) (compose P' Q').
Proof.
  intros.
  eapply lts_input_helper in H0.
  eapply lts_output_helper in H.
  destruct H as [R]. destruct H as [S]. destruct H.
  destruct H0 as [R']. destruct H0 as [S']. destruct H0.
  unfold step_process.
  exists (compose (compose (output c n R) (input c R')) (compose S S')).
  exists (compose (compose R (open n R')) (compose S S')).
  repeat split.
  + eapply cong_trans. assert (compose P Q = fill (c_compose_l c_hole Q) P); eauto. rewrite H3.
    eapply cong_context. eapply H. simpl.
    eapply cong_trans. assert (compose (compose (output c n R) S) Q = fill (c_compose_r (compose (output c n R) S) c_hole) Q); eauto.
    rewrite H3. eapply cong_context. eapply H0. simpl.
    eapply cong_trans. eapply cong_symm. eapply cong_compose_assoc.
    eapply cong_trans.
    assert (compose (output c n R) (compose S (compose (input c R') S')) = fill (c_compose_r (output c n R) c_hole) (compose S (compose (input c R') S'))); eauto.
    rewrite H3. eapply cong_context. eapply cong_compose_assoc. simpl.
    eapply cong_trans.
    assert (compose (output c n R) (compose (compose S (input c R')) S') = fill (c_compose_r (output c n R) (c_compose_l c_hole S')) (compose S (input c R'))); eauto.
    rewrite H3. eapply cong_context. eapply cong_compose_comm. simpl.
    eapply cong_trans.
    assert (compose (output c n R) (compose (compose (input c R') S) S') = fill (c_compose_r (output c n R) c_hole) (compose (compose (input c R') S) S')); eauto.
    rewrite H3; eapply cong_context. eapply cong_symm; eapply cong_compose_assoc. simpl.
    eapply cong_compose_assoc.
  + eapply cong_trans. assert (compose P' Q' = fill (c_compose_l c_hole Q') P'); eauto. rewrite H3.
    eapply cong_context. eapply H1. simpl.
    eapply cong_trans. assert (compose (compose R S) Q' = fill (c_compose_r (compose R S) c_hole) Q'); eauto.
    rewrite H3. eapply cong_context. eapply H2. simpl.
    eapply cong_trans. eapply cong_symm. eapply cong_compose_assoc.
    eapply cong_trans.
    assert (compose R (compose S (compose (open n R') S')) = fill (c_compose_r R c_hole) (compose S (compose (open n R') S'))); eauto.
    rewrite H3. eapply cong_context. eapply cong_compose_assoc. simpl.
    eapply cong_trans.
    assert (compose R (compose (compose S (open n R')) S') = fill (c_compose_r R (c_compose_l c_hole S')) (compose S (open n R'))); eauto.
    rewrite H3. eapply cong_context. eapply cong_compose_comm. simpl.
    eapply cong_trans.
    assert (compose R (compose (compose (open n R') S) S') = fill (c_compose_r R c_hole) (compose (compose (open n R') S) S')); eauto.
    rewrite H3; eapply cong_context. eapply cong_symm; eapply cong_compose_assoc. simpl.
    eapply cong_compose_assoc.
  + constructor. constructor.
Qed.

Theorem tau_lts_step : forall P Q, lts P tau_label Q -> step_process P Q.
Proof.
  intros. remember tau_label. induction H; inversion Heql; subst.
  - unfold step_process. eapply IHlts in H0. destruct H0 as [P0'].
    destruct H0 as [Q']. exists (compose P0' Q). exists (compose Q' Q).
    repeat split.
    + assert (compose P Q = fill (c_compose_l c_hole Q) P); eauto.
      assert (compose P0' Q = fill (c_compose_l c_hole Q) P0'); eauto.
      rewrite H1. rewrite H2. eapply cong_context. eapply H0.
    + assert (compose P' Q = fill (c_compose_l c_hole Q) P'); eauto.
      assert (compose Q' Q = fill (c_compose_l c_hole Q) Q'); eauto.
      rewrite H1. rewrite H2. eapply cong_context.  eapply H0.
    + eapply step_composition. eapply H0.
  - unfold step_process. eapply IHlts in H0. destruct H0 as [X].
    destruct H0 as [Y]. exists (compose X P).  exists (compose Y P).
    repeat split.
    + eapply cong_trans. apply cong_compose_comm.
      assert (compose Q P = fill (c_compose_l c_hole P) Q); eauto.
      assert (compose X P = fill (c_compose_l c_hole P) X); eauto.
      rewrite H1. rewrite H2. eapply cong_context. eapply H0.
    + eapply cong_trans. apply cong_compose_comm.
      assert (compose Q' P = fill (c_compose_l c_hole P) Q'); eauto.
      assert (compose Y P = fill (c_compose_l c_hole P) Y); eauto.
      rewrite H1. rewrite H2. eapply cong_context. eapply H0.
    + eapply step_composition. eapply H0.
  - eapply tau_lts_comm_step. eapply H. eapply H0.
  - eapply tau_lts_comm_step in H. destruct H as [P0]. destruct H as [Q0].
    exists P0. exists Q0.
    repeat split; eauto.
    + eapply cong_trans. eapply cong_compose_comm. eapply H.
    + eapply cong_trans. eapply cong_compose_comm. eapply H.
    + eapply H.
    + eauto.
  - eapply IHlts in H0. unfold step_process in *. clear IHlts.
    destruct H0 as [P'0]. destruct H0 as [Q].
    exists (compose P'0 (replicate P)). exists (compose Q (replicate P)).
    repeat split.
    + eapply cong_trans. eapply cong_replicate.
      assert (compose P (replicate P) = fill (c_compose_l c_hole (replicate P)) P); eauto. rewrite H1. eapply cong_trans. eapply cong_context.
      eapply H0. simpl. eapply cong_refl.
    + assert (compose P' (replicate P) = fill (c_compose_l c_hole (replicate P)) P'); eauto. rewrite H1. eapply cong_trans. eapply cong_context.
      eapply H0. simpl. eapply cong_refl.
    + eapply step_composition. eapply H0.
  - eapply tau_lts_comm_step in H; eauto.
    destruct H as [P0]. destruct H as [P0'].
    unfold step_process. exists (compose P0 (replicate P)).
    exists (compose P0' (replicate P)).
    repeat split.
    + eapply cong_trans. eapply cong_replicate.
      eapply cong_trans. assert (compose P (replicate P) = fill (c_compose_r P c_hole) (replicate P)); eauto.
      rewrite H1; eapply cong_context. eapply cong_replicate. simpl.
      eapply cong_trans. eapply cong_compose_assoc.
      eapply cong_trans. assert (compose (compose P P) (replicate P) = fill (c_compose_l c_hole (replicate P)) (compose P P)); eauto.
      rewrite H1; eapply cong_context. eapply H. simpl; eapply cong_refl.
    + assert (compose (compose P' P'') (replicate P) = fill (c_compose_l c_hole (replicate P)) (compose P' P'')); eauto.
      eapply cong_trans. rewrite H1; eapply cong_context. eapply H.
      simpl. eapply cong_refl.
    + eapply step_composition. eapply H.
Qed.

End Semantics.

Module EarlyBisim.

Import Syntax.
Import Semantics.

Definition early_bisimulation (R : process -> process -> Prop) :=
  (forall P1 P2, R P1 P2 -> R P2 P1) /\
  forall P1 P1' P2 l, R P1 P2 ->
                      lts P1 l P1' ->
                      exists P2', lts P2 l P2' /\ R P1' P2'.

Definition early_bisimilar (p : process) (q : process) :=
  exists R, early_bisimulation R /\ R p q.

Theorem early_bisimilarity_symm :
  forall p q, early_bisimilar p q -> early_bisimilar q p.
Proof.
  intros. destruct H as [R]. destruct H.
  unfold early_bisimilar. exists R.
  split. eauto.
  unfold early_bisimulation in H.
  destruct H. apply H. apply H0.
Qed.

Theorem early_bisimilarity_refl :
  forall p, early_bisimilar p p.
Proof.
  intros. unfold early_bisimilar.
  exists (fun p q => p = q). split; eauto.
  unfold early_bisimulation. split; eauto.
  intros; subst; eauto.
Qed.

Theorem early_bisimilarity_trans :
  forall p q r, early_bisimilar p q -> early_bisimilar q r -> early_bisimilar p r.
Proof.
  intros. unfold early_bisimilar in *. destruct H as [R1]; destruct H0 as [R2].
  destruct H; destruct H0.
  exists (clos_trans process (fun p q => (R1 p q \/ R2 p q))).
  split.
  - unfold early_bisimulation in *. split.
    + intros. induction H3. destruct H3. eapply t_step.
      left; apply H; eauto.
      eapply t_step. right; apply H0; eauto.
      eapply t_trans. eapply IHclos_trans2. eapply IHclos_trans1.
    + intros. generalize dependent P1'. induction H3.
      * destruct H3. destruct H. intros. eapply H4 in H5. destruct H5.
        exists x0. split. destruct H5. apply H5. eapply t_step. destruct H5. left; apply H6. apply H3.
        intros. eapply H0 in H4. destruct H4. destruct H4.
        exists x0. split. apply H4. eapply t_step. right; apply H5. apply H3.
      * intros. apply IHclos_trans1 in H4. destruct H4. destruct H3.
        apply IHclos_trans2 in H3. destruct H3. destruct H3.
        exists x1. split. apply H3. eapply t_trans. apply H4. apply H5.
  - eapply t_trans. eapply t_step. left; apply H1.
    eapply t_step. right; apply H2.
Qed.

End EarlyBisim.

Module Relations.

Import Syntax.
Import Semantics.

Definition relation := process -> process -> Prop.
Definition symmetric (R : relation) := forall P Q, R P Q -> R Q P.
Definition subset (R : relation) (S : relation) := forall P Q, R P Q -> S P Q.
Definition reverse (R : relation) := fun P Q => R Q P.
Definition r_compose (R : relation) (S: relation) :=
  fun P Q => exists A, (R P A) /\ (S A Q).

Definition progresses (R : relation) S : Prop :=
  (forall P Q l Q', lts Q l Q' -> R P Q -> exists P', lts P l P' /\ S P' Q') /\
  (forall P Q l P', lts P l P' -> R P Q -> exists Q', lts Q l Q' /\ S P' Q').

Definition strongly_safe (F : relation -> relation) : Prop :=
  forall (R : relation) (S : relation),
    subset R S -> progresses R S ->
    (subset (F R) (F S) /\ progresses (F R) (F S)).

Definition preserves_symm F : Prop :=
  forall R, symmetric R -> symmetric (F R).

End Relations.

Module EarlyBisimProp.

Import EarlyBisim.
Import Syntax.
Import Relations.

(*Theorem progresses_bisim : forall R, progresses R R -> early_bisimulation R.
Proof.
  intros. unfold progresses in H; unfold early_bisimulation.
  split. eapply H. intros; eapply H; eauto.
Qed.*)
(* Need to take symmetric closure here *)

Theorem progresses_subset_left :
  forall R S T, subset R S -> progresses S T ->
                progresses R T.
Proof.
  intros. unfold progresses in *. repeat split; eauto.
  - destruct H0. intros.  eapply H0 in H2. destruct H2 as [Q'0].
    exists Q'0. split; eapply H2. apply H. apply H3.
  - destruct H0. intros. eapply H1 in H2. destruct H2 as [Q'0].
    exists Q'0. eapply H2. apply H. apply H3.
Qed.

Theorem progresses_subset_right :
  forall R S T, subset S T -> progresses R S ->
                progresses R T.
Proof.
  intros. unfold progresses in *. repeat split; eauto.
  - destruct H0. intros. eapply H0 in H2. destruct H2 as [P'].
    exists P'. split. eapply H2. eapply H. eapply H2. eapply H3.
  - destruct H0. intros. eapply H1 in H2. destruct H2 as [Q'].
    exists Q'. split. eapply H2. eapply H. eapply H2. eapply H3.
Qed.

Fixpoint apply_n n R (F : relation -> relation) :=
  match n with
    | O => R
    | S n' => fun P Q => apply_n n' R F P Q \/ F (apply_n n' R F) P Q
  end.

Lemma apply_n_symm :
  forall n R F, symmetric R -> preserves_symm F ->
                symmetric (apply_n n R F).
Proof.
  intros. induction n.
  - simpl; eauto.
  - simpl. unfold symmetric. intros.
    destruct H1. left; eauto. right; eauto. eapply H0 in IHn.
    eauto.
Qed.

Lemma apply_n_subset :
  forall R F n, subset (apply_n n R F) (apply_n (S n) R F).
Proof.
  intros. simpl. unfold subset. intros. left; eapply H.
Qed.

Lemma progresses_union :
  forall R1 R2 S, progresses R1 S -> progresses R2 S -> progresses (fun P Q => R1 P Q \/ R2 P Q) S.
Proof.
  intros. unfold progresses. repeat split.
  - intros.
    destruct H as [H _]. destruct H0 as [H0 _].
    destruct H2.
    + eapply H in H1. apply H1. apply H2.
    + eapply H0 in H1. apply H1. apply H2.
  - intros.
    destruct H as [_ H]. destruct H0 as [_ H0].
    destruct H2.
    + eapply H in H1. eapply H1. apply H2.
    + eapply H0 in H1. eapply H1. apply H2.
Qed.

Theorem apply_n_progresses :
  forall (R : relation) F n, strongly_safe F -> progresses R (F R) ->
                             progresses (apply_n n R F) (apply_n (S n) R F).
Proof.
  intros. induction n.
  - simpl. eapply progresses_subset_right; try (apply H0).
    unfold subset. intros; eauto.
  - simpl in *. eapply progresses_union.
    + eapply progresses_subset_right; try (apply IHn).
      unfold subset. intros. left. apply H1.
    + eapply progresses_subset_right with (F (fun P Q => apply_n n R F P Q \/ F (apply_n n R F) P Q)).
      unfold symmetric. intros.
      unfold subset; intros. right; eauto. eapply H in IHn.
      apply IHn.
      unfold subset; intros. left; eauto.
Qed.

Theorem strongly_safe_in_bisimulation :
  forall (R : relation) F, preserves_symm F -> symmetric R -> strongly_safe F -> progresses R (F R) ->
                           early_bisimulation (fun P Q => exists n, apply_n n R F P Q).
Proof.
  intros. unfold early_bisimulation. unfold progresses in H2. split.
  - intros. destruct H3 as [n]. generalize dependent P1. generalize dependent P2.
    induction n.
    + intros. simpl in H3. exists 0; simpl; eauto.
    + intros. simpl in H3. destruct H3.
      * eapply IHn; eauto.
      * exists (S n). simpl. right.
        assert (symmetric (apply_n n R F)).
        { eapply apply_n_symm. apply H0. apply H. }
        apply H in H4. apply H4. apply H3.
  - intros. destruct H3 as [n]. eapply apply_n_progresses in H3; eauto.
    destruct H3 as [P2']. exists P2'.
    split. eapply H3.  exists (S n); eapply H3.
Qed.

Fixpoint iterate n (F : relation -> relation) (R : relation) :=
  match n with
    | O => F R
    | S n => r_compose (F R) (iterate n F R)
  end.

Theorem iterate_sum :
  forall F R P A Q n m, iterate n F R P A -> iterate m F R A Q ->
                        iterate (S (n + m)) F R P Q.
Proof.
  intros. generalize dependent P. induction n.
  - intros. simpl. simpl in H. exists A; eauto.
  - intros. simpl. simpl in H. simpl in IHn. inversion H; subst.
    exists x. split. eapply H1. eapply IHn. eapply H1.
Qed.

(*Theorem iterate_symmetric :
  forall n R F, symmetric R ->
                (forall f, symmetric f -> symmetric (F f)) ->
                symmetric (iterate n F R).
Proof.
  intros. induction n; eauto.
  simpl. unfold symmetric. intros. inversion H1; subst.
  - eapply symm_backwards. eapply H2. eapply H3.
  - eapply symm_forwards. eapply H2. eapply H3.
Qed.*)

Definition closure F R :=
  fun P Q => exists n, iterate n F R P Q.

Theorem closure_compose :
  forall A P Q F R, closure F R P A -> closure F R A Q -> closure F R P Q.
Proof.
  intros. destruct H. destruct H0.
  exists (1 + x + x0). eapply iterate_sum. eapply H. eapply H0.
Qed.

(*Theorem closure_symmetric :
  forall R F, symmetric R ->
              (forall f, symmetric f -> symmetric (F f)) ->
              symmetric (closure F R).
Proof.
  intros. unfold symmetric. intros. destruct H1 as [n].
  exists n.
  eapply iterate_symmetric; eauto.
Qed.*)

Theorem iterate_progresses :
  forall (R : relation) S F n,
    (forall f, symmetric f -> symmetric (F f)) ->
    (forall R S, subset R S -> progresses R S ->
     (subset (F R) (closure F S) /\ (progresses (F R) (closure F S)))) ->
    subset R S -> progresses R S ->
    (subset (iterate n F R) (closure F S) /\ (progresses (iterate n F R) (closure F S))).
Proof.
  intros. generalize dependent R. generalize dependent S. induction n.
  - intros; split.
    + simpl. unfold closure. unfold subset. intros.
      eapply H0; eauto.
    + simpl. unfold closure. unfold progresses. repeat split.
      * intros. eapply H0 in H1; eauto. eapply H1. eapply H3. eapply H4.
      * intros. eapply H0 in H1; eauto. eapply H1. eapply H3. eapply H4.
  - intros. split.
    + unfold subset. simpl. intros. destruct H3 as [A]; subst. destruct H3.
      assert (progresses R S); eauto.
      apply IHn in H2; eauto. destruct H2 as [H2 H2']. eapply H2 in H4.
      eapply H0 in H1; eauto. destruct H1. eapply H1 in H3. destruct H3 as [n']. destruct H4 as [n'']. exists (1 + (n' + n'')). eapply iterate_sum; eauto.
    + repeat split.
      * intros. simpl in H4. destruct H4 as [A]. destruct H4.
        assert (subset R S); eauto.
        eapply IHn in H6; eauto.
        assert (subset R S); eauto. eapply H0 in H7; eauto.
        destruct H7.
        destruct H8 as [H8 _].
        destruct H6 as [_ H6]. destruct H6 as [H6 _]. eapply H6 in H5.
        destruct H5. destruct H5.
        eapply H8 in H4. destruct H4. destruct H4.
        Focus 2. eapply H5. Focus 2. eapply H3. exists x0.
        split. eapply H4. eapply closure_compose. eapply H10. eapply H9.
      * intros. simpl in H4. destruct H4 as [A]. destruct H4.
        assert (subset R S); eauto.
        eapply IHn in H6; eauto.
        assert (subset R S); eauto. eapply H0 in H7; eauto.
        destruct H7.
        destruct H8 as [_ H8].
        destruct H6 as [_ H6]. destruct H6 as [_ H6].
        eapply H8 in H4. destruct H4. destruct H4.
        eapply H6 in H5. destruct H5. destruct H5.
        Focus 2. eapply H4. Focus 2. eapply H3. exists x0.
        split. eapply H5. eapply closure_compose. eapply H9. eapply H10.
Qed.

Theorem closure_safe :
  forall F, (forall f, symmetric f -> symmetric (F f)) ->
            (forall R S, subset R S -> progresses R S ->
                         subset (F R) (closure F S) /\ (progresses (F R) (closure F S))) ->
            strongly_safe (closure F).
Proof.
  intros.
  unfold closure. unfold strongly_safe. intros. split.
  - unfold subset. intros. destruct H3 as [n]. eapply iterate_progresses; eauto.
  - unfold progresses. repeat split.
    + intros. destruct H4. eapply iterate_progresses in H1; eauto. eapply H1; eauto.
    + intros. destruct H4. eapply iterate_progresses in H1; eauto. eapply H1; eauto.
Qed.

End EarlyBisimProp.

Module Contexts.

Import Syntax.
Import Semantics.
Import EarlyBisimProp.
Import EarlyBisim.
Import Relations.

Inductive ni_context : Type :=
| ni_output : channel -> channel -> ni_context -> ni_context
| ni_replicate : ni_context -> ni_context
| ni_compose_l : ni_context -> process -> ni_context
| ni_compose_r : process -> ni_context -> ni_context
| ni_hole : ni_context
.

Fixpoint ni_fill (nc : ni_context) (p : process) : process :=
  match nc with
    | ni_hole => p
    | ni_output c1 c2 c => output c1 c2 (ni_fill c p)
    | ni_replicate nic => replicate (ni_fill nic p)
    | ni_compose_l nic r => compose (ni_fill nic p) r
    | ni_compose_r l nic => compose l (ni_fill nic p)
  end.

Fixpoint ni_compose nc1 nc2 :=
  match nc1 with
    | ni_hole => nc2
    | ni_output c1 c2 c => ni_output c1 c2 (ni_compose c nc2)
    | ni_replicate nic => ni_replicate (ni_compose nic nc2)
    | ni_compose_l nic r => ni_compose_l (ni_compose nic nc2) r
    | ni_compose_r l nic => ni_compose_r l (ni_compose nic nc2)
  end.

Theorem ni_compose_fill :
  forall nc1 nc2 P,
    ni_fill nc1 (ni_fill nc2 P) = ni_fill (ni_compose nc1 nc2) P.
Proof.
  intros. induction nc1; try (simpl; rewrite IHnc1; eauto).
  - simpl. eauto.
Qed.

Definition ni_context_relation (R: relation) : relation :=
  fun P Q => exists (C : ni_context) P' Q',
               R P' Q' /\ P = (ni_fill C P') /\ Q = (ni_fill C Q').

Lemma ni_context_helper :
  forall x R P Q C,
    iterate x ni_context_relation R P Q ->
    iterate x ni_context_relation R (ni_fill C P) (ni_fill C Q).
Proof.
  intros. generalize dependent P. generalize dependent Q. induction x; simpl in *.
  - intros. destruct H as [C'].  destruct H as [P']. destruct H as [Q'].
    exists (ni_compose C C'). exists P'. exists Q'.
    repeat split.
    + eapply H.
    + destruct H. destruct H0. rewrite H0. rewrite ni_compose_fill. eauto.
    + destruct H. destruct H0. rewrite H1. rewrite ni_compose_fill. eauto.
  - intros. destruct H. destruct H. eapply IHx in H0. destruct H as [C'].
    destruct H as [P']. destruct H as [Q']. unfold r_compose.
    exists (ni_fill C x0). split; try (eapply H0).
    exists (ni_compose C C'). exists P'. exists Q'.
    repeat split.
    + eapply H.
    + destruct H. destruct H1. rewrite H1. rewrite ni_compose_fill. eauto.
    + destruct H. destruct H1. rewrite H2. rewrite ni_compose_fill. eauto.
Qed.

Lemma ni_context_progresses :
  forall P P' Q C R S l,
    subset R S -> progresses R S -> lts (ni_fill C P) l P' -> R P Q ->
    exists Q', lts (ni_fill C Q) l Q' /\ closure ni_context_relation S P' Q'.
Proof.
  intros. generalize dependent l. generalize dependent P'. induction C.
  - intros. simpl in *. inversion H1; subst.
    exists (ni_fill C Q). split. constructor. exists 0. simpl.
    exists C. exists P. exists Q. repeat split. eapply H. eapply H2.
  - intros. simpl in *. inversion H1; subst.
    + eapply IHC in H4. destruct H4 as [Q']. destruct H3.
      exists (compose Q' (replicate (ni_fill C Q))). split.
      * eapply lts_rep_act. eapply H3.
      * destruct H4.
        exists (1 + x). simpl.
        exists (compose P'0 (replicate (ni_fill C Q))).
        split.
        exists (ni_compose_r P'0 (ni_replicate C)).
        exists P. exists Q. repeat split. eauto.
        apply ni_context_helper with (C := (ni_compose_l ni_hole (replicate (ni_fill C Q)))) in H4. eapply H4.
    + eapply IHC in H4. eapply IHC in H5. destruct H4. destruct H3.
      destruct H5. destruct H5.
      exists (compose (compose x x0) (replicate (ni_fill C Q))).
      split.
      * eapply lts_rep_comm. eapply H3. eapply H5.
      * destruct H4 as [m]. destruct H6 as [m'']. exists (2 + m + m'').
        simpl. exists (compose (compose P'0 P'') (replicate (ni_fill C Q))).
        split. exists (ni_compose_r (compose P'0 P'') (ni_replicate C)).
        exists P. exists Q. repeat split. eauto.
        eapply iterate_sum.
        apply ni_context_helper with (C := (ni_compose_l (ni_compose_l ni_hole P'') (replicate (ni_fill C Q)))) in H4. eapply H4.
        simpl. apply ni_context_helper with (C := (ni_compose_l (ni_compose_r x ni_hole) (replicate (ni_fill C Q)))) in H6. eapply H6.
  - intros. inversion H1; subst.
    + eapply IHC in H7. destruct H7. destruct H3. exists (compose x p). split.
      * simpl. eapply lts_comp_left. eapply H3.
      * destruct H4. exists (x0).
        apply ni_context_helper with (C := (ni_compose_l ni_hole p)) in H4. eapply H4.
    + simpl in *. exists (compose (ni_fill C Q) Q'). split.
      * eapply lts_comp_right. eapply H7.
      * exists 0. simpl. exists (ni_compose_l C Q'). exists P. exists Q.
        repeat split; eauto.
    + eapply IHC in H5. destruct H5 as [Q0]. destruct H3. simpl.
      exists (compose Q0 Q'). split.
      * eapply lts_comm_left. eapply H3. eapply H8.
      * destruct H4. exists x.
        apply ni_context_helper with (C := ni_compose_l ni_hole Q') in H4. eapply H4.
    + eapply IHC in H5. destruct H5 as [Q0].  destruct H3. simpl.
      exists (compose Q0 Q'). split.
      * eapply lts_comm_right; eauto.
      * destruct H4 as [n']. exists n'.
        apply ni_context_helper with (C := ni_compose_l ni_hole Q') in H4. eapply H4.
  - intros. inversion H1; subst.
    + simpl in *. exists (compose P'0 (ni_fill C Q)). split.
      * eapply lts_comp_left. eapply H7.
      * exists 0. simpl. exists (ni_compose_r P'0 C). exists P. exists Q.
        repeat split; eauto.
    + eapply IHC in H7. destruct H7. destruct H3. exists (compose p x). split.
      * simpl. eapply lts_comp_right. eapply H3.
      * destruct H4. exists (x0).
        apply ni_context_helper with (C := (ni_compose_r p ni_hole)) in H4. eapply H4.
    + eapply IHC in H8. destruct H8 as [Q0]. destruct H3. simpl.
      exists (compose P'0 Q0). split.
      * eapply lts_comm_left. eapply H5. eapply H3.
      * destruct H4. exists x.
        apply ni_context_helper with (C := ni_compose_r P'0 ni_hole) in H4. eapply H4.
    + eapply IHC in H8. destruct H8 as [Q0].  destruct H3. simpl.
      exists (compose P'0 Q0). split.
      * eapply lts_comm_right; eauto.
      * destruct H4 as [n']. exists n'.
        apply ni_context_helper with (C := ni_compose_r P'0 ni_hole) in H4. eapply H4.
  - intros. simpl in *. eapply H0 in H1; eauto. destruct H1 as [Q']. exists Q'.
    split. eapply H1. exists 0. simpl. exists ni_hole. simpl.
    exists P'. exists Q'. repeat split; eauto. eapply H1.
Qed.

Lemma ni_context_progresses' :
  forall P Q' Q C R S l,
    subset R S -> progresses R S -> lts (ni_fill C Q) l Q' -> R P Q ->
    exists P', lts (ni_fill C P) l P' /\ closure ni_context_relation S P' Q'.
Proof.
  intros. generalize dependent l. generalize dependent Q'. induction C.
  - intros. simpl in *. inversion H1; subst.
    exists (ni_fill C P). split. constructor. exists 0. simpl.
    exists C. exists P. exists Q. repeat split. eauto.
  - intros. simpl in *. inversion H1; subst.
    + eapply IHC in H4. destruct H4 as [Q']. destruct H3.
      exists (compose Q' (replicate (ni_fill C P))). split.
      * eapply lts_rep_act. eapply H3.
      * destruct H4.
        exists (1 + x). simpl.
        exists (compose Q' (replicate (ni_fill C Q))).
        split.
        exists (ni_compose_r Q' (ni_replicate C)).
        exists P. exists Q. repeat split. eauto.
        apply ni_context_helper with (C := (ni_compose_l ni_hole (replicate (ni_fill C Q)))) in H4. eapply H4.
    + eapply IHC in H4. eapply IHC in H5. destruct H4. destruct H3.
      destruct H5. destruct H5.
      exists (compose (compose x x0) (replicate (ni_fill C P))).
      split.
      * eapply lts_rep_comm. eapply H3. eapply H5.
      * destruct H4 as [m]. destruct H6 as [m'']. exists (2 + m + m'').
        simpl. exists (compose (compose x x0) (replicate (ni_fill C Q))).
        split. exists (ni_compose_r (compose x x0) (ni_replicate C)).
        exists P. exists Q. repeat split. eauto.
        eapply iterate_sum.
        apply ni_context_helper with (C := (ni_compose_l (ni_compose_l ni_hole x0) (replicate (ni_fill C Q)))) in H4. simpl in H4. eapply H4.
        simpl. apply ni_context_helper with (C := (ni_compose_l (ni_compose_r P' ni_hole) (replicate (ni_fill C Q)))) in H6. eapply H6.
  - intros. inversion H1; subst.
    + eapply IHC in H7. destruct H7. destruct H3. exists (compose x p). split.
      * simpl. eapply lts_comp_left. eapply H3.
      * destruct H4. exists (x0).
        apply ni_context_helper with (C := (ni_compose_l ni_hole p)) in H4. eapply H4.
    + simpl in *. exists (compose (ni_fill C P) Q'0). split.
      * eapply lts_comp_right. eapply H7.
      * exists 0. simpl. exists (ni_compose_l C Q'0). exists P. exists Q.
        repeat split; eauto.
    + eapply IHC in H5. destruct H5 as [Q0]. destruct H3. simpl.
      exists (compose Q0 Q'0). split.
      * eapply lts_comm_left. eapply H3. eapply H8.
      * destruct H4. exists x.
        apply ni_context_helper with (C := ni_compose_l ni_hole Q'0) in H4. eapply H4.
    + eapply IHC in H5. destruct H5 as [Q0].  destruct H3. simpl.
      exists (compose Q0 Q'0). split.
      * eapply lts_comm_right; eauto.
      * destruct H4 as [n']. exists n'.
        apply ni_context_helper with (C := ni_compose_l ni_hole Q'0) in H4. eapply H4.
  - intros. inversion H1; subst.
    + simpl in *. exists (compose P' (ni_fill C P)). split.
      * eapply lts_comp_left. eapply H7.
      * exists 0. simpl. exists (ni_compose_r P' C). exists P. exists Q.
        repeat split; eauto.
    + eapply IHC in H7. destruct H7. destruct H3. exists (compose p x). split.
      * simpl. eapply lts_comp_right. eapply H3.
      * destruct H4. exists (x0).
        apply ni_context_helper with (C := (ni_compose_r p ni_hole)) in H4. eapply H4.
    + eapply IHC in H8. destruct H8 as [Q0]. destruct H3. simpl.
      exists (compose P' Q0). split.
      * eapply lts_comm_left. eapply H5. eapply H3.
      * destruct H4. exists x.
        apply ni_context_helper with (C := ni_compose_r P' ni_hole) in H4. eapply H4.
    + eapply IHC in H8. destruct H8 as [Q0].  destruct H3. simpl.
      exists (compose P' Q0). split.
      * eapply lts_comm_right; eauto.
      * destruct H4 as [n']. exists n'.
        apply ni_context_helper with (C := ni_compose_r P' ni_hole) in H4. eapply H4.
  - intros. simpl in *. destruct H0. eapply H0 in H1; eauto.
    destruct H1 as [P']. exists P'.
    split. eapply H1. exists 0. simpl. exists ni_hole. simpl.
    exists P'. exists Q'. repeat split; eauto. eapply H1.
Qed.

Theorem strongly_safe_ni_context : strongly_safe (closure ni_context_relation).
  eapply closure_safe.
  - intros. unfold symmetric. intros. unfold ni_context_relation.
    unfold ni_context_relation in H0.  destruct H0 as [C].
    destruct H0 as [P']. destruct H0 as [Q'].
    exists C. exists Q'. exists P'.
    destruct H0. destruct H1.
    repeat split; eauto.
  - intros. split.
    + unfold subset. intros.
      exists 0. simpl. unfold ni_context_relation in *.
      destruct H1 as [C]. destruct H1 as [P']. destruct H1 as [Q'].
      exists C. exists P'. exists Q'.
      destruct H1. destruct H2.
      repeat split; eauto.
    + unfold progresses. split.
      * intros. destruct H2 as [C]. destruct H2 as [P']. destruct H2 as [Q_fill].
        destruct H2. destruct H3. subst.
        eapply ni_context_progresses'; eauto.
      * intros. destruct H2 as [C]. destruct H2 as [P_fill]. destruct H2 as [Q'].
        destruct H2. destruct H3. subst.
        eapply ni_context_progresses; eauto.
Qed.

End Contexts.


(** * Maps: Total and Partial Maps *)

(** Maps (or dictionaries) are ubiquitous data structures, both in
    software construction generally and in the theory of programming
    languages in particular; we're going to need them in many places
    in the coming chapters.  They also make a nice case study using
    ideas we've seen in previous chapters, including building data
    structures out of higher-order functions (from [Basics] and
    [Poly]) and the use of reflection to streamline proofs (from
    [IndProp]).

    We'll define two flavors of maps: _total_ maps, which include a
    "default" element to be returned when a key being looked up
    doesn't exist, and _partial_ maps, which return an [option] to
    indicate success or failure.  The latter is defined in terms of
    the former, using [None] as the default element. *)

(** HIDE: Recall the type [partial_map] from the [Lists] chapter.  Its
    basic operations were [empty], the contant empty map, [update],
    which takes a map and returns a new map with one key bound to a
    new value, and [find], which looks up a key in a map. *)

(* ###################################################################### *)
(** * The Coq Standard Library *)

(** One small digression before we start.

    Unlike the chapters we have seen so far, this one does not
    [Require Import] the chapter before it (and, transitively, all the
    earlier chapters).  Instead, in this chapter and from now, on
    we're going to import the definitions and theorems we need
    directly from Coq's standard library stuff.  You should not notice
    much difference, though, because we've been careful to name our
    own definitions and theorems the same as their counterparts in the
    standard library, wherever they overlap. *)

Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Logic.FunctionalExtensionality.

(** Documentation for the standard library can be found at
    ##http://coq.inria.fr/library/##.

    The [SearchAbout] command is a good way to look for theorems
    involving objects of specific types. *)

(* ###################################################################### *)
(** * Identifiers *)

(** First, we need a type for the keys that we use to index into our
    maps.  For this purpose, we again use the type [id] from the
    [Lists] chapter.  To make this chapter self contained, we repeat
    its definition here, together with the equality comparison
    function for [id]s and its fundamental property. *)

Inductive id : Type :=
  | Id : nat -> id.

Definition beq_id id1 id2 :=
  match id1,id2 with
    | Id n1, Id n2 => beq_nat n1 n2
  end.

Theorem beq_id_refl : forall id, true = beq_id id id.
(* FOLD *)
Proof.
  intros [n]. simpl. rewrite <- beq_nat_refl.
  reflexivity. Qed.
(* /FOLD *)

(** The following useful property of [beq_id] follows from an
    analogous lemma about numbers: *)

Theorem beq_id_true_iff : forall id1 id2 : id,
  beq_id id1 id2 = true <-> id1 = id2.
(* FOLD *)
Proof.
   intros [n1] [n2].
   unfold beq_id.
   rewrite beq_nat_true_iff.
   split.
   - (* -> *) intros H. rewrite H. reflexivity.
   - (* <- *) intros H. inversion H. reflexivity.
Qed.
(* /FOLD *)

(** Similarly: *)

Theorem beq_id_false_iff : forall x y : id,
  beq_id x y = false
  <-> x <> y.
(* FOLD *)
Proof.
  intros x y. rewrite <- beq_id_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.
(* /FOLD *)

(** This useful variant follows just by rewriting: *)

Theorem false_beq_id : forall x y : id,
   x <> y
   -> beq_id x y = false.
(* FOLD *)
Proof.
  intros x y. rewrite beq_id_false_iff.
  intros H. apply H. Qed.
(* /FOLD *)

(* ###################################################################### *)
(** * Total Maps *)

(** Our main job in this chapter will be to build a definition of
    partial maps that is similar in behavior to the one we saw in the
    [Lists] chapter, plus accompanying lemmas about their behavior.

    This time around, though, we're going to use _functions_, rather
    than lists of key-value pairs, to build maps.  The advantage of
    this representation is that it offers a more _extensional_ view of
    maps, where two maps that respond to queries in the same way will
    be represented as literally the same thing (the same function),
    rather than just "equivalent" data structures.  This, in turn,
    simplifies proofs that use maps.

    We build partial maps in two steps.  First, we define a type of
    _total maps_ that return a default value when we look up a key
    that is not present in the map. *)

Definition total_map (A:Type) := id -> A.

(** Intuitively, a total map over an element type [A] _is_ just a
    function that can be used to look up [id]s, yielding [A]s.

    The function [t_empty] yields an empty total map, given a default
    element; this map always returns the default element when applied
    to any id. *)

Definition t_empty {A:Type} (v : A) : total_map A :=
  (fun _ => v).

(** More interesting is the [update] function, which (as before) takes
    a map [m], a key [x], and a value [v] and returns a new map that
    takes [x] to [v] and takes every other key to whatever [m] does. *)

Definition t_update {A:Type} (m : total_map A)
                    (x : id) (v : A) :=
  fun x' => if beq_id x x' then v else m x'.

(** This definition is a nice example of higher-order programming.
    The [t_update] function takes a _function_ [m] and yields a new
    function [fun x' => ...] that behaves like the desired map.

    For example, we can build a map taking [id]s to [bool]s, where [Id
    3] is mapped to [true] and every other key is mapped to [false],
    like this: *)

Definition examplemap :=
  t_update (t_update (t_empty false) (Id 1) false)
           (Id 3) true.

(** This completes the definition of total maps.  Note that we don't
    need to define a [find] operation because it is just function
    application! *)

(** TERSE: *** *)

Example update_example1 : examplemap (Id 0) = false.
(* FOLD *)
Proof. reflexivity. Qed.
(* /FOLD *)

Example update_example2 : examplemap (Id 1) = false.
(* FOLD *)
Proof. reflexivity. Qed.
(* /FOLD *)

Example update_example3 : examplemap (Id 2) = false.
(* FOLD *)
Proof. reflexivity. Qed.
(* /FOLD *)

Example update_example4 : examplemap (Id 3) = true.
(* FOLD *)
Proof. reflexivity. Qed.
(* /FOLD *)

(** To use maps in later chapters, we'll need several fundamental
    facts about how they behave.  Even if you don't work the following
    exercises, make sure you thoroughly understand the statements of
    the lemmas!  (Some of the proofs require the functional
    extensionality axiom discussed in the [Logic] chapter, which is
    also included in the standard library.) *)

(* EX2? (t_update_eq) *)
(** First, if we update a map [m] at a key [x] with a new value [v]
    and then look up [x] in the map resulting from the [update], we
    get back [v]: *)

Lemma t_update_eq : forall A (m: total_map A) x v,
  (t_update m x v) x = v.
Proof.
  (* ADMITTED *)
  intros. unfold t_update. rewrite <- beq_id_refl.
  reflexivity.
Qed.
(* /ADMITTED *)
(** [] *)

(* EX2? (t_update_neq) *)
(** On the other hand, if we update a map [m] at a key [x1] and then
    look up a _different_ key [x2] in the resulting map, we get the
    same result that [m] would have given: *)

Theorem t_update_neq : forall (X:Type) v x1 x2
                         (m : total_map X),
  x1 <> x2 ->
  (t_update m x1 v) x2 = m x2.
Proof.
  (* ADMITTED *)
  intros X v x1 x2 m.
  rewrite <- beq_id_false_iff.
  intros Hneq.
  unfold t_update.
  rewrite -> Hneq.
  reflexivity.  Qed.
(* /ADMITTED *)
(** [] *)

(* EX2? (t_update_shadow) *)
(** If we update a map [m] at a key [x] with a value [v1] and then
    update again with the same key [x] and another value [v2], the
    resulting map behaves the same (gives the same result when applied
    to any key) as the simpler map obtained by performing just
    the second [update] on [m]: *)

Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x,
    t_update (t_update m x v1) x v2
  = t_update m x v2.
Proof.
  (* ADMITTED *)
  intros A m v1 v2 x1.
  apply functional_extensionality. intros x2.
  unfold t_update. destruct (beq_id x1 x2).
  - reflexivity.
  - reflexivity.
Qed.
(* /ADMITTED *)
(** [] *)

(** For the final two lemmas about total maps, it's convenient to use
    the reflection idioms introduced in chapter [IndProp].  We begin
    by proving a fundamental _reflection lemma_ relating the equality
    proposition on [id]s with the boolean function [beq_id]. *)

(* EX2 (beq_idP) *)
(** Use the proof of [beq_natP] in chapter [IndProp] as a template to
    prove the following: *)

Lemma beq_idP : forall x y, reflect (x = y) (beq_id x y).
Proof.
  (* ADMITTED *)
  intros x y.
  apply iff_reflect. rewrite beq_id_true_iff.
  reflexivity.
Qed.
(* /ADMITTED *)
(** [] *)

(** Now, given [id]s [x1] and [x2], we can use the [destruct (beq_idP
    x1 x2)] to simultaneously perform case analysis on the result of
    [beq_id x1 x2] and generate hypotheses about the equality (in the
    sense of [=]) of [x1] and [x2]. *)

(* EX2 (t_update_same) *)
(** Using the example in chapter [IndProp] as a template, use
    [beq_idP] to prove the following theorem, which states that if we
    update a map to assign key [x] the same value as it already has in
    [m], then the result is equal to [m]: *)

Theorem t_update_same : forall X x (m : total_map X),
  t_update m x (m x) = m.
Proof.
  (* ADMITTED *)
  intros X x1 m. apply functional_extensionality. intros x2.
  unfold t_update.
  destruct (beq_idP x1 x2) as [H | H].
  - (* x1 = x2 *)
    rewrite H. reflexivity.
  - (* false *)
    reflexivity.  Qed.
(* /ADMITTED *)
(** [] *)

(* EX3! (t_update_permute) *)
(** Use [beq_idP] to prove one final property of the [update]
    function: If we update a map [m] at two distinct keys, it doesn't
    matter in which order we do the updates. *)

Theorem t_update_permute : forall (X:Type) v1 v2 x1 x2
                             (m : total_map X),
  x2 <> x1 ->
    (t_update (t_update m x2 v2) x1 v1)
  = (t_update (t_update m x1 v1) x2 v2).
Proof.
  (* ADMITTED *)
  intros X v1 v2 x1 x2 m H.
  apply functional_extensionality. intros x3.
  rewrite <- beq_id_false_iff in H.
  unfold t_update.
  destruct (beq_idP x1 x3).
  - (* beq_id x1 x3 = true *)
    subst. rewrite H. reflexivity.
  - (* beq_id x1 x3 = false *) reflexivity.
Qed.
(* /ADMITTED *)
(* GRADE_THEOREM 3: t_update_permute *)
(** [] *)

(* ###################################################################### *)
(** * Partial maps *)

(** Finally, we define _partial maps_ on top of total maps.  A partial
    map with elements of type [A] is simply a total map with elements
    of type [option A] and default element [None]. *)

Definition partial_map (A:Type) := total_map (option A).

Definition empty {A:Type} : partial_map A :=
  t_empty None.

(* HIDE: Notation "'\empty'" := empty. *)

Definition update {A:Type} (m : partial_map A)
                  (x : id) (v : A) :=
  t_update m x (Some v).

(** We can now lift all of the basic lemmas about total maps to
    partial maps.  *)

Lemma update_eq : forall A (m: partial_map A) x v,
  (update m x v) x = Some v.
(* FOLD *)
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.
(* /FOLD *)

Theorem update_neq : forall (X:Type) v x1 x2
                       (m : partial_map X),
  x2 <> x1 ->
  (update m x2 v) x1 = m x1.
(* FOLD *)
Proof.
  intros X v x1 x2 m H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.
(* /FOLD *)

Lemma update_shadow : forall A (m: partial_map A) v1 v2 x,
  update (update m x v1) x v2 = update m x v2.
(* FOLD *)
Proof.
  intros A m v1 v2 x1. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.
(* /FOLD *)

Theorem update_same : forall X v x (m : partial_map X),
  m x = Some v ->
  update m x v = m.
(* FOLD *)
Proof.
  intros X v x m H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.
(* /FOLD *)

Theorem update_permute : forall (X:Type) v1 v2 x1 x2
                                (m : partial_map X),
  x2 <> x1 ->
    (update (update m x2 v2) x1 v1)
  = (update (update m x1 v1) x2 v2).
(* FOLD *)
Proof.
  intros X v1 v2 x1 x2 m. unfold update.
  apply t_update_permute.
Qed.
(* /FOLD *)

(** 2016/03/25 12:34:16 *)

(* HIDE *)
(*
Local Variables:
fill-column: 70
End:
*)
(* /HIDE *)


(*|
############################
How to make sublists in Coq?
############################

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

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

I'm working in Coq and trying to figure out how to do the next thing:
If I have a list of natural numbers and a given number ``n``, I want
to break my list in what goes before and after each of the ``n``'s. To
make it clearer, if I have the list ``[1; 2; 0; 3; 4; 0; 9]`` and the
number ``n = 0``, then I want to have as output the three lists:
``[1;2]``, ``[3;4]`` and ``[9]``. The main problem I have is that I
don't know how to output several elements on a ``Fixpoint``. I think I
need to nest ``Fixpoint``\ s but I just don't see how. As a very raw
idea with one too many issues I have:
|*)

Require Import PeanoNat List. (* .none *)
Import ListNotations. (* .none *)
Fail Fixpoint SubLists (A : list nat) (m : nat) :=
  match A with
  | [] => []
  | n :: A0 => if n =? m then SubLists L else n :: SubLists L
  end. (* .fails *)

(*|
I would very much appreciate your input on how to do this, and how to
navigate having an output of several elements.
|*)

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

You can do this by combining a few fixpoints:
|*)

Reset Initial. (* .none *)
Require Import Coq.Arith.Arith.
Require Import Coq.Lists.List.
Import ListNotations.

Fixpoint prefix n l :=
  match l with
  | [] => []
  | m :: l' => if beq_nat n m then [] else m :: prefix n l'
  end.

Fixpoint suffix n l :=
  match l with
  | [] => l
  | m :: l' => if beq_nat n m then l' else suffix n l'
  end.

Fixpoint split_at n l :=
  match l with
  | [] => []
  | m :: l' => prefix n (m :: l') :: split_at n (suffix n (m :: l'))
  end.

(*|
Notice that Coq's termination checker accepts the recursive call to
``split_at``, even though it is not done syntactically a subterm of
``l``. The reason for that is that it is able to detect that suffix
only outputs subterms of its argument. But in order for this to work,
we *must* return ``l``, and not ``[]`` on its first branch (try
changing it to see what happens!).
|*)

(*|
Answer (ejgallego)
******************

In addition to Arthur's solution, you can use an accumulator, which is
typical of Functional Programming style:
|*)

Reset Initial. (* .none *)
Require Import Coq.Arith.Arith.
Require Import Coq.Lists.List.
Import ListNotations.

Definition add_acc m (s : list (list nat)) :=
  match s with
  | []      => [[m]]
  | s :: ss => (m :: s) :: ss
  end.

Fixpoint split_seq n l acc :=
  match l with
  | []      => map (@rev _) (rev acc)
  | m :: l' => if beq_nat n m
               then split_seq n l' ([] :: acc)
               else split_seq n l' (add_acc m acc)
  end.

Compute (split_seq 0 [1; 2; 0; 3; 4; 0; 9] []).

(*|
Note that the result is reversed so you need to use ``rev``. A bonus
exercise is to improve this.

EDIT: Provided second variant that doesn't add ``[]`` for repeated
separators.
|*)

Definition reset_acc (s : list (list nat)) :=
  match s with
  | [] :: ss => [] :: ss
  | ss       => [] :: ss
  end.

Fixpoint split_seq_nodup n l acc :=
  match l with
  | []      => map (@rev _) (rev acc)
  | m :: l' => if beq_nat n m
               then split_seq_nodup n l' (reset_acc acc)
               else split_seq_nodup n l' (add_acc m acc)
  end.

Compute (split_seq_nodup 0 [1; 2; 0; 3; 4; 0; 9] []).

(*|
----

**A:** (1) For ``reset_acc``'s body I'd write ``match s with | [] :: _
=> s | _ => [] :: s`` (2) For novice Coq programmers, not familiar
with the `@ syntax
<https://coq.inria.fr/refman/Reference-Manual004.html#Implicits-explicitation>`__:
it turns off "implicitness", so ``(@rev _)`` stands for ``(@rev
nat)``. Without ``@``, one could have used eta-expansion: ``map (fun
xs => rev xs) (rev acc)``.
|*)

(*|
Answer (gallais)
****************

An alternative way to tackle this issue is to formally describe the
problem you are trying to solve and then either write a
dependently-typed function proving that this problem can indeed be
solved or using tactics to slowly build up your proof.

This is, if I am not mistaken, a relation describing the relationship
between the outputs ``n`` and ``ns`` you want to pass your function
and the output ``mss`` you want to get back.

The ``(* ------- *)`` lines are simple comments used to suggest that
these constructors should be seen as `inference rules
<https://en.wikipedia.org/wiki/Inference_rule>`__: whatever is under
one such line is the conclusion one can make based on the assumptions
above it.

.. coq:: none
|*)

Reset Initial.

Require Import Arith.
Require Import List.
Local Open Scope list_scope.

(*||*)

Inductive SubListsRel (n : nat) :
  forall (ns : list nat) (mss : list (list nat)), Prop :=
| base      : SubListsRel n nil (nil :: nil)
| consEq    : forall ns m mss,
    n = m -> SubListsRel n ns mss ->
    (* ------------------------------ *)
    SubListsRel n (m :: ns) (nil :: mss)
| consNotEq : forall ns m ms mss,
    (n <> m) -> SubListsRel n ns (ms :: mss) ->
    (* -------------------------------------- *)
    SubListsRel n (m :: ns) ((m :: ms) :: mss).

(*|
We can then express your ``Sublists`` problem as being, given inputs
``n`` and ``ns``, the existence of an output ``mss`` such that
``SubListsRel n ns mss`` holds:
|*)

Definition SubLists (n : nat) (ns : list nat) : Set :=
  { mss | SubListsRel n ns mss }.

(*|
Using tactics we can readily generate such ``Sublists`` for concrete
examples in order to sanity-check our specification. We can for
instance take the example you had in your original post:
|*)

Example example1 : SubLists 0 (1 :: 2 :: 0 :: 3 :: 4 :: 0 :: 9 :: nil).
Proof.
  eexists. repeat econstructor; intro Hf; inversion Hf.
Defined.

(*|
And check that the output is indeed the list you were expecting:
|*)

Check (eq_refl : proj1_sig example1
                 = ((1 :: 2 :: nil) :: (3 :: 4 :: nil) :: (9 :: nil) :: nil)).

(*|
Now comes the main part of this post: the proof that ``forall n ns,
SubLists n ns``. Given that the premise of ``consNotEq`` assumes that
``mss`` is non-empty, we will actually prove a strengthened statement
in order to make our life easier:
|*)

Definition Strenghtened_SubLists (n : nat) (ns : list nat) : Set :=
  { mss | SubListsRel n ns mss /\ mss <> nil }.

(*|
And given that oftentimes we will have goals of the shape
``something_absurd -> False``, I define a simple tactic to handle
these things. It introduces the absurd assumption and inverts it
immediately to make the goal disappear:
|*)

Ltac dismiss := intro Hf; inversion Hf.

(*|
We can now prove the main statement by proving the strengthened
version by induction and deducing it. I guess that here it's better
for you to step through it in Coq rather than me trying to explain
what happens. The key steps are the ``cut`` (proving a stronger
statement), ``induction`` and the case analysis on ``eq_nat_dec``.
|*)

Lemma subLists : forall n ns, SubLists n ns.
Proof.
  intros n ns. cut (Strenghtened_SubLists n ns).
  - intros [mss [Hmss _]]. eexists. eassumption.
  - induction ns.
    + eexists. split; [econstructor | dismiss].
    + destruct IHns as [mss [Hmss mssNotNil]];
        destruct (eq_nat_dec n a).
      * eexists. split; [eapply consEq; eassumption | dismiss].
      * destruct mss; [apply False_rect, mssNotNil; reflexivity |].
        eexists. split; [eapply consNotEq; eassumption | dismiss].
Defined.

(*|
Once we have this function, we can come back to our example and
generate the appropriate ``Sublists`` this time not by calling tactics
but by running the function ``subLists`` we just defined.
|*)

Example example2 : SubLists 0 (1 :: 2 :: 0 :: 3 :: 4 :: 0 :: 9 :: nil) :=
  subLists _ _.

(*|
And we can ``Check`` that the computed list is indeed the same as the
one obtained in ``example1``:
|*)

Check (eq_refl : proj1_sig example1 = proj1_sig example2).

(*|
**Nota Bene**: It is paramount here that our proofs are ended with
``Defined`` rather than ``Qed`` in order for them to be unfolded when
computing with them (which is what we want to do here: they give us
the ``list (list nat)`` we are looking for!).

`A gist
<https://gist.github.com/gallais/e6c7dac6542459037a9b3935f3fd3741>`__
with all the code and the right imports.
|*)

(*|
Answer (Anton Trunov)
*********************

Here is another take, based on the standard library function
``List.fold_left``. It works by maintaining an accumulator, which is a
pair of the overall *reversed* result (a list of lists) and a current
sublist (also reversed while accumulating). Once we reach a delimiter,
we reverse the current sublist and put it into the resulting list of
sublists. After executing ``fold_left``, we reverse the result in the
outermost ``match`` expression.
|*)

Reset Initial. (* .none *)
Require Import Coq.Arith.Arith.
Require Import Coq.Lists.List.
Import ListNotations.

Definition split_skip_dup_delims (m : nat) (xs : list nat) :=
  match fold_left
          (fun (acctup: _ * _) x =>
             let (acc, rev_subl) := acctup in
             if beq_nat x m
             then match rev_subl with (* a delimiter found *)
                  | [] => (acc, []) (* do not insert empty sublist *)
                  | _ => (rev rev_subl :: acc, []) end
             else (acc, x :: rev_subl)) (* keep adding to the current sublist *)
          xs
          ([],[]) with
  | (acc, []) => rev acc        (* list ends with a delimiter *)
  | (acc, rev_subl) => rev (rev rev_subl :: acc) (* no delimiter at the end *)
  end.

Eval compute in split_skip_dup_delims 0 [1; 2; 0; 0; 0; 3; 4; 0; 9]. (* .unfold *)


From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
Require Export Coq.Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Lists.List.
Import ListNotations.
From LF Require Export IndProp.

(* Identifiers *)

Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.

Theorem eqb_string_refl : forall s : string, true = eqb_string s s.
intros s.
unfold eqb_string.
destruct (string_dec s s) as [Hs|Hs] eqn: E.
reflexivity.
unfold not in Hs.
destruct Hs.
reflexivity.
Qed.

Theorem eqb_string_true_iff : forall x y : string,
    eqb_string x y = true <-> x = y.
Proof.
intros x y.
split.
  - intro H.
  unfold eqb_string in H.
  destruct (string_dec x y) eqn: E.
  assumption.
  discriminate.
  - intro H.
    rewrite H.
    symmetry.
    apply eqb_string_refl.
Qed.

Theorem eqb_string_true_iff' : forall x y : string,
    eqb_string x y = true <-> x = y.
Proof.
   intros x y.
   unfold eqb_string.
   destruct (string_dec x y) as [|Hs].
   - subst. split. reflexivity. reflexivity.
   - split.
     + intros contra. discriminate contra.
     + intros H. rewrite H in Hs. destruct Hs. reflexivity.
Qed.

Theorem eqb_string_false_iff : forall x y : string,
    eqb_string x y = false <-> x <> y.
Proof.
intros x y.
unfold eqb_string.
destruct (string_dec x y) as [|Hs].
- subst. split.
  + intro contra. discriminate contra.
  + intro H. destruct H. reflexivity.
- split.
  + intro H. apply Hs.
  + reflexivity.
Qed.

Theorem false_eqb_string : forall x y : string,
   x <> y -> eqb_string x y = false.
Proof.
intros x y.
unfold eqb_string.
intro Hxy.
destruct (string_dec x y) as [|Hs].
- destruct Hxy. assumption.
- reflexivity.
Qed.

Theorem false_eqb_string' : forall x y : string,
   x <> y -> eqb_string x y = false.
Proof.
  intros x y. rewrite eqb_string_false_iff.
  intros H. apply H.
Qed.

(* Total Maps *)

Definition total_map (A : Type) := string -> A.

Definition t_empty {A : Type} (v : A) : total_map A :=
  (fun _ => v).

Definition t_update {A : Type} (m : total_map A)
                    (x : string) (v : A) :=
  fun x' => if eqb_string x x' then v else m x'.

Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true)
           "bar" true.

Notation "'_' '!->' v" := (t_empty v)
  (at level 100, right associativity).
Example example_empty := (_ !-> false).

Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).

Definition examplemap' :=
  ( "bar" !-> true;
    "foo" !-> true;
    _ !-> false
  ).

Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
    (_ !-> v) x = v.
Proof.
intros A s v. reflexivity.
Qed.

Lemma t_update_eq : forall (A : Type) (m : total_map A) x v,
    (x !-> v ; m) x = v.
Proof.
intros A m s v.
unfold t_update.
rewrite <- eqb_string_refl.
reflexivity.
Qed.

Theorem t_update_neq : forall (A : Type) (m : total_map A) x1 x2 v,
    x1 <> x2 ->
    (x1 !-> v ; m) x2 = m x2.
Proof.
intros A m s v v0 H.
unfold t_update.
apply eqb_string_false_iff in H.
rewrite H.
reflexivity.
Qed.

Lemma t_update_shadow : forall (A : Type) (m : total_map A) x v1 v2,
    (x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
Proof.
intros A m x v1 v2.
unfold t_update.
Search "extensionality".
Search "f_equal".
apply functional_extensionality.
intros x0.
destruct (eqb_string x x0).
- reflexivity.
- reflexivity.
Qed.

Lemma eqb_stringP : forall x y : string,
    reflect (x = y) (eqb_string x y).
Proof.
intros x y.
apply iff_reflect.
rewrite eqb_string_true_iff.
reflexivity.
Qed.

Theorem t_update_same : forall (A : Type) (m : total_map A) x,
    (x !-> m x ; m) = m.
Proof.
intros.
unfold t_update.
apply functional_extensionality.
intros.
destruct (eqb_stringP x x0).
- rewrite H. reflexivity.
- reflexivity.
Qed.

Theorem t_update_permute : forall (A : Type) (m : total_map A)
                                  v1 v2 x1 x2,
    x2 <> x1 ->
    (x1 !-> v1 ; x2 !-> v2 ; m)
    =
    (x2 !-> v2 ; x1 !-> v1 ; m).
Proof.
intros A m v1 v2 x1 x2 H.
unfold t_update.
apply functional_extensionality.
intros.
destruct (eqb_stringP x1 x).
  - destruct (eqb_stringP x2 x).
    + rewrite H0 in H.
      rewrite H1 in H.
      unfold not in H.
      assert(H': x = x). { reflexivity. }
      apply H in H'.
      destruct H'.
    + reflexivity.
  - destruct (eqb_stringP x2 x).
    + reflexivity.
    + reflexivity.
Qed.

(* Partial maps *)

Definition partial_map (A : Type) := total_map (option A).

Definition empty {A : Type} : partial_map A :=
  t_empty None.

Definition update {A : Type} (m : partial_map A)
           (x : string) (v : A) :=
  (x !-> Some v ; m).

Notation "x '|->' v ';' m" := (update m x v)
  (at level 100, v at next level, right associativity).

Notation "x '|->' v" := (update empty x v)
  (at level 100).

Example examplepmap :=
  ("Church" |-> true ; "Turing" |-> false).

Lemma apply_empty : forall (A : Type) (x : string),
    @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty.
  reflexivity.
Qed.

Lemma update_eq : forall (A : Type) (m : partial_map A) x v,
    (x |-> v ; m) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (A : Type) (m : partial_map A) x1 x2 v,
    x2 <> x1 ->
    (x2 |-> v ; m) x1 = m x1.
Proof.
  intros A m x1 x2 v H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall (A : Type) (m : partial_map A) x v1 v2,
    (x |-> v2 ; x |-> v1 ; m) = (x |-> v2 ; m).
Proof.
  intros A m x v1 v2. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall (A : Type) (m : partial_map A) x v,
    m x = Some v ->
    (x |-> v ; m) = m.
Proof.
  intros A m x v H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (A : Type) (m : partial_map A)
                                x1 x2 v1 v2,
    x2 <> x1 ->
    (x1 |-> v1 ; x2 |-> v2 ; m) = (x2 |-> v2 ; x1 |-> v1 ; m).
Proof.
  intros A m x1 x2 v1 v2. unfold update.
  apply t_update_permute.
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Well-founded relations                                                  *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic
 LibProd LibSum LibRelation LibNat LibInt.

(* ********************************************************************** *)
(** * Compatibility *)

(** Coq's stdlib Prelude defines:

 Inductive Acc A (R:A->A->Prop) (x:A) : Prop :=
   | Acc_intro : (forall (y:A), R y x -> Acc y) -> Acc x.

 Definition well_founded A (R:A->A->Prop) :=
    forall (x:A), Acc x.

*)

(** TLC introduces [wf] as a shorter name for [well_founded], both
    for conciseness and for tactics to specifically recognize
    this symbol. *)

Definition wf := well_founded.

(* ---------------------------------------------------------------------- *)
(** ** Tactics *)

(** [auto with wf] attempts to unfold the names of
    the relations given as argument to [wf]. *)

#[global]
Hint Extern 1 (wf ?R) => progress (unfold R) : wf.

(** [solve_wf] is a shorthand for solving goals using
    [auto with wf], aimed to prove goals of the form [wf R]. *)

Tactic Notation "solve_wf" :=
  solve [ auto with wf ].

(* ********************************************************************** *)
(* * Measures *)

(* ---------------------------------------------------------------------- *)
(** ** Definition *)

(** [measure f] is a well-founded binary relation which
    relates [x] to [y] when [f x < f y], at type [nat]. *)

Definition measure A (f:A->nat) : binary A :=
  fun x1 x2 => (f x1 < f x2).

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

Section Measure.
Variables (A : Type).
Implicit Type f : A -> nat.

Lemma wf_measure : forall f,
  wf (measure f).
Proof using.
  intros f a. gen_eq n: (f a). gen a. pattern n.
  apply peano_induction. clear n. introv IH Eq.
  apply Acc_intro. introv H. unfolds in H.
  rewrite <- Eq in H. apply* IH.
Qed.

Lemma trans_measure : forall (f : A -> nat),
  trans (measure f).
Proof using. intros. unfold measure, trans. intros. nat_math. Qed.

(* -- LATER: Lemma order_measure *)

End Measure.

#[global]
Hint Resolve wf_measure : wf.

(* ---------------------------------------------------------------------- *)
(** ** Measure on pairs *)

Definition measure2 A1 A2 (f : A1 -> A2 -> nat) : binary (A1*A2) :=
  fun p1 p2 => let (x1,y1) := p1 in
               let (x2,y2) := p2 in
               (f x1 y1 < f x2 y2).

Lemma wf_measure2 : forall A1 A2 (f:A1->A2->nat),
  wf (measure2 f).
Proof using.
  intros A1 A2 f [x1 x2]. apply (@measure_induction _ (uncurry2 f)). clear x1 x2.
  intros [x1 x2] H. apply Acc_intro. intros [y1 y2] Lt. apply~ H.
Qed.

#[global]
Hint Resolve wf_measure2 : wf.

(* ---------------------------------------------------------------------- *)
(** Extension of LibTactic's [induction_wf] tactic for [measure] *)

Ltac induction_wf_process_wf_hyp tt ::= (* original in LibTactics *)
  match goal with
  | |- wf _ => auto with wf
  | |- well_founded _ => change well_founded with wf; auto with wf
  end.

Ltac induction_wf_process_measure E ::= (* original in LibTactics *)
  applys well_founded_ind (wf_measure E).

(* ********************************************************************** *)
(** * Construction of well-founded relations *)

(* ---------------------------------------------------------------------- *)
(** ** Empty relation *)

Lemma wf_empty : forall A,
  wf (@empty A).
Proof using. intros_all. constructor. introv H. false. Qed.

#[global]
Hint Resolve wf_empty : wf.

(* ---------------------------------------------------------------------- *)
(** ** Inclusion *)

(** Well-foundedness preserved by inclusion *)

Lemma wf_of_rel_incl : forall A (R1 R2 : binary A),
  wf R1 ->
  rel_incl R2 R1 ->
  wf R2.
Proof using.
  introv W1 Inc. intros x.
  pattern x. apply (well_founded_ind W1). clear x.
  intros x IH. constructor. intros. apply IH. apply~ Inc.
Qed.

(* ********************************************************************** *)
(* * Classic well-founded relations on [nat] *)

(* ---------------------------------------------------------------------- *)
(** ** [Peano.lt] on [nat] *)

(** The relation "less than" on natural numbers is well_founded. *)

Lemma wf_peano_lt : wf Peano.lt.
Proof using.
  intros x.
  induction x using peano_induction. apply~ Acc_intro.
    intros. applys H. math.
Qed.

#[global]
Hint Resolve wf_peano_lt : wf.

(* ---------------------------------------------------------------------- *)
(** ** [lt] on [nat] *)

(** The relation "less than" on natural numbers is well_founded. *)

Lemma wf_lt : @wf nat lt.
Proof using.
  intros x.
  induction x using peano_induction. apply~ Acc_intro.
Qed.

#[global]
Hint Resolve wf_lt : wf.

(* ---------------------------------------------------------------------- *)
(** ** The relation "greater than" on the set of
       natural number lower than a fixed upper bound. *)

Definition nat_upto (b:nat) :=
  fun (n m:nat) => (n <= b)%nat /\ (m < n)%nat.

Lemma nat_upto_eq : forall (b n m:nat),
  nat_upto b n m = ((n <= b)%nat /\ (m < n)%nat).
Proof using. auto. Qed.

Lemma wf_nat_upto : forall (b:nat),
  wf (nat_upto b).
Proof using.
  intros b n.
  induction_wf IH: (wf_measure (fun n => (b-n)%nat)) n.
  apply Acc_intro. introv [H1 H2]. apply IH.
  hnf. nat_math.
Qed.

(* ********************************************************************** *)
(* * Classic well-founded relations on [Z] *)

(* ---------------------------------------------------------------------- *)
(** ** The relation "less than" on the set of
       integers greater than a fixed lower bound. *)

Definition downto (b:Z) :=
  fun (n m:Z) => (b <= n) /\ (n < m).

Lemma downto_eq : forall (b n m:Z),
  downto b n m = (b <= n /\ n < m).
Proof using. auto. Qed.

Lemma downto_intro : forall (b n m:Z),
  b <= n ->
  n < m ->
  downto b n m.
Proof using. split~. Qed.

Lemma wf_downto : forall (b:Z),
  wf (downto b).
Proof using.
  intros b n.
  induction_wf IH: (wf_measure (fun n => Z.abs_nat (n-b))) n.
  apply Acc_intro. introv [H1 H2]. apply IH.
  unfolds. applys lt_abs_abs; math.
Qed.

#[global]
Hint Resolve wf_downto : wf.
#[global]
Hint Unfold downto.
#[global]
Hint Extern 1 (downto _ _ _) => math : maths.

(* ---------------------------------------------------------------------- *)
(** ** The relation "greater than" on the set of
       integers lower than a fixed upper bound. *)

Definition upto (b:Z) :=
  fun (n m:Z) => (n <= b) /\ (m < n).

Lemma upto_eq : forall b n m,
  upto b n m = ((n <= b) /\ (m < n)).
Proof using. auto. Qed.

Lemma upto_intro : forall b n m,
  n <= b ->
  m < n ->
  upto b n m.
Proof using. split~. Qed.

Lemma wf_upto : forall n,
  wf (upto n).
Proof using.
  intros b n.
  induction_wf IH: (wf_measure (fun n => Z.abs_nat (b-n))) n.
  apply Acc_intro. introv [H1 H2]. apply IH.
  applys lt_abs_abs; math.
Qed.

#[global]
Hint Resolve wf_upto : wf.
#[global]
Hint Unfold upto.
#[global]
Hint Extern 1 (upto _ _ _) => math : maths.

(* ********************************************************************** *)
(** * Inverse projections *)

Section UnprojWf.
Variables (A1 A2 A3 A4 A5 : Type).

Lemma wf_unproj21 : forall (R:binary A1),
  wf R ->
  wf (unproj21 A2 R).
Proof using.
  intros R H [x1 x2]. gen x2.
  induction_wf IH: H x1. constructor. intros [y1 y2]. auto.
Qed.

Lemma wf_unproj22 : forall (R:binary A2),
  wf R ->
  wf (unproj22 A1 R).
Proof using.
  intros R H [x1 x2]. gen x1.
  induction_wf IH: H x2. constructor. intros [y1 y2]. auto.
Qed.

Lemma wf_unproj31 : forall (R:binary A1),
  wf R ->
  wf (unproj31 A2 A3 R).
Proof using.
  intros R H [[x1 x2] x3]. gen x2 x3.
  induction_wf IH: H x1. constructor. intros [[y1 y2] y3]. auto.
Qed.

Lemma wf_unproj32 : forall (R:binary A2),
  wf R ->
  wf (unproj32 A1 A3 R).
Proof using.
  intros R H [[x1 x2] x3]. gen x1 x3.
  induction_wf IH: H x2. constructor. intros [[y1 y2] y3]. auto.
Qed.

Lemma wf_unproj33 : forall (R:binary A3),
  wf R ->
  wf (unproj33 A1 A2 R).
Proof using.
  intros R H [[x1 x2] x3]. gen x1 x2.
  induction_wf IH: H x3. constructor. intros [[y1 y2] y3]. auto.
Qed.

Lemma wf_unproj41 : forall (R:binary A1),
  wf R ->
  wf (unproj41 A2 A3 A4 R).
Proof using.
  intros R H [[[x1 x2] x3] x4]. gen x2 x3 x4.
  induction_wf IH: H x1. constructor. intros [[[y1 y2] y3] y4]. auto.
Qed.

Lemma wf_unproj42 : forall (R:binary A2),
  wf R ->
  wf (unproj42 A1 A3 A4 R).
Proof using.
  intros R H [[[x1 x2] x3] x4]. gen x1 x3 x4.
  induction_wf IH: H x2. constructor. intros [[[y1 y2] y3] y4]. auto.
Qed.

Lemma wf_unproj43 : forall (R:binary A3),
  wf R ->
  wf (unproj43 A1 A2 A4 R).
Proof using.
  intros R H [[[x1 x2] x3] x4]. gen x1 x2 x4.
  induction_wf IH: H x3. constructor. intros [[[y1 y2] y3] y4]. auto.
Qed.

Lemma wf_unproj44 : forall (R:binary A4),
  wf R ->
  wf (unproj44 A1 A2 A3 R).
Proof using.
  intros R H [[[x1 x2] x3] x4]. gen x1 x2 x3.
  induction_wf IH: H x4. constructor. intros [[[y1 y2] y3] y4]. auto.
Qed.

Lemma wf_unproj51 : forall (R:binary A1),
  wf R ->
  wf (unproj51 A2 A3 A4 A5 R).
Proof using.
  intros R H [[[[x1 x2] x3] x4] x5]. gen x2 x3 x4 x5.
  induction_wf IH: H x1. constructor. intros [[[[y1 y2] y3] y4] y5]. auto.
Qed.

End UnprojWf.

#[global]
Hint Resolve
  wf_unproj21 wf_unproj22
  wf_unproj31 wf_unproj32 wf_unproj33
  wf_unproj41 wf_unproj42 wf_unproj43 wf_unproj44
  wf_unproj51 : wf.

(* ********************************************************************** *)
(** * Lexicographical product *)

Lemma wf_lexico2 : forall A1 A2
 (R1:binary A1) (R2:binary A2),
  wf R1 ->
  wf R2 ->
  wf (lexico2 R1 R2).
Proof using.
  introv W1 W2. intros [x1 x2]. gen x2.
  induction_wf IH1: W1 x1. intros.
  induction_wf IH2: W2 x2. constructor. intros [y1 y2] H.
  simpls. destruct H as [H1|[H1 H2]].
  apply~ IH1. rewrite H1. apply~ IH2.
Qed.

Lemma wf_lexico3 : forall A1 A2 A3
 (R1:binary A1) (R2:binary A2) (R3:binary A3),
  wf R1 ->
  wf R2 ->
  wf R3 ->
  wf (lexico3 R1 R2 R3).
Proof using.
  intros. apply~ wf_lexico2. apply~ wf_lexico2.
Qed.

Lemma wf_lexico4 : forall A1 A2 A3 A4
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4),
  wf R1 ->
  wf R2 ->
  wf R3 ->
  wf R4 ->
  wf (lexico4 R1 R2 R3 R4).
Proof using.
  intros. apply~ wf_lexico3. apply~ wf_lexico2.
Qed.

#[global]
Hint Resolve wf_lexico2 wf_lexico3 wf_lexico4 : wf.

(* ********************************************************************** *)
(** * Symmetric product *)

Lemma wf_prod2_of_wf_1 : forall (A1 A2:Type)
 (R1:binary A1) (R2:binary A2),
  wf R1 ->
  wf (prod2 R1 R2).
Proof using.
  introv W1. intros [x1 x2].
  gen x2. induction_wf IH: W1 x1. intros.
  constructor. intros [y1 y2] [E1 E2]. apply~ IH.
Qed.

Lemma wf_prod2_of_wf_2 : forall (A1 A2:Type)
 (R1:binary A1) (R2:binary A2),
  wf R2 ->
  wf (prod2 R1 R2).
Proof using.
  introv W2. intros [x1 x2].
  gen x1. induction_wf IH: W2 x2. intros.
  constructor. intros [y1 y2] [E1 E2]. apply~ IH.
Qed.

Lemma wf_prod3_of_wf_1 : forall (A1 A2 A3:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3),
  wf R1 ->
  wf (prod3 R1 R2 R3).
Proof using. intros. apply wf_prod2_of_wf_1. apply~ wf_prod2_of_wf_1. Qed.

Lemma wf_prod3_of_wf_2 : forall (A1 A2 A3:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3),
  wf R2 ->
  wf (prod3 R1 R2 R3).
Proof using. intros. apply wf_prod2_of_wf_1. apply~ wf_prod2_of_wf_2. Qed.

Lemma wf_prod3_of_wf_3 : forall (A1 A2 A3:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3),
  wf R3 ->
  wf (prod3 R1 R2 R3).
Proof using. intros. apply~ wf_prod2_of_wf_2. Qed.

Lemma wf_prod4_of_wf_1 : forall (A1 A2 A3 A4:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4),
  wf R1 ->
  wf (prod4 R1 R2 R3 R4).
Proof using. intros. apply wf_prod2_of_wf_1. apply~ wf_prod3_of_wf_1. Qed.

Lemma wf_prod4_of_wf_2 : forall (A1 A2 A3 A4:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4),
  wf R2 ->
  wf (prod4 R1 R2 R3 R4).
Proof using. intros. apply wf_prod2_of_wf_1. apply~ wf_prod3_of_wf_2. Qed.

Lemma wf_prod4_of_wf_3 : forall (A1 A2 A3 A4:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4),
  wf R3 ->
  wf (prod4 R1 R2 R3 R4).
Proof using. intros. apply wf_prod2_of_wf_1. apply~ wf_prod3_of_wf_3. Qed.

Lemma wf_prod4_of_wf_4 : forall (A1 A2 A3 A4:Type)
 (R1:binary A1) (R2:binary A2) (R3:binary A3) (R4:binary A4),
  wf R4 ->
  wf (prod4 R1 R2 R3 R4).
Proof using. intros. apply~ wf_prod2_of_wf_2. Qed.

#[global]
Hint Resolve
  wf_prod2_of_wf_1 wf_prod2_of_wf_2
  wf_prod3_of_wf_1 wf_prod3_of_wf_2 wf_prod3_of_wf_3
  wf_prod4_of_wf_1 wf_prod4_of_wf_2 wf_prod4_of_wf_3 wf_prod4_of_wf_4 : wf.

(* ********************************************************************** *)
(** * Well-foundedness of a function image *)

Lemma wf_rel_preimage : forall A B (R:binary B) (f:A->B),
  wf R ->
  wf (rel_preimage R f).
Proof using.
  introv W. intros x. gen_eq a: (f x). gen x.
  induction_wf IH: W a. introv E. constructors.
  intros y Hy. subst a. hnf in Hy. applys* IH.
Qed.

#[global]
Hint Resolve wf_rel_preimage : wf.

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)
(* TEMPORARY *)

(* begin hide *)

(* ********************************************************************** *)
(** * Union *)

(* --TODO..

Section WfUnion.
  Variables (A : Type).
  Variables R1 R2 : binary A.

  Notation Union := (union A R1 R2).

  Remark strip_commut :
    commut A R1 R2 ->
    forall x y:A,
      clos_trans A R1 y x ->
      forall z:A, R2 z y ->  exists2 y' : A, R2 y' x & clos_trans A R1 z y'.
  Proof using.
    induction 2 as [x y| x y z H0 IH1 H1 IH2]; intros.
    elim H with y x z; auto with sets; intros x0 H2 H3.
    exists x0; auto with sets.

    elim IH1 with z0; auto with sets; intros.
    elim IH2 with x0; auto with sets; intros.
    exists x1; auto with sets.
    apply t_trans with x0; auto with sets.
  Qed.

  Lemma Acc_union :
    commut A R1 R2 ->
    (forall x:A, Acc R2 x -> Acc R1 x) -> forall a:A, Acc R2 a -> Acc Union a.
  Proof using.
    induction 3 as [x H1 H2].
    apply Acc_intro; intros.
    elim H3; intros; auto with sets.
    cut (clos_trans A R1 y x); auto with sets.
    elimtype (Acc (clos_trans A R1) y); intros.
    apply Acc_intro; intros.
    elim H8; intros.
    apply H6; auto with sets.
    apply t_trans with x0; auto with sets.

    elim strip_commut with x x0 y0; auto with sets; intros.
    apply Acc_inv_trans with x1; auto with sets.
    unfold union in |- *.
    elim H11; auto with sets; intros.
    apply t_trans with y1; auto with sets.

    apply (Acc_clos_trans A).
    apply Acc_inv with x; auto with sets.
    apply H0.
    apply Acc_intro; auto with sets.
  Qed.

  Theorem wf_union :
    commut A R1 R2 -> well_founded R1 -> well_founded R2 -> well_founded Union.
  Proof using.
    unfold well_founded in |- *.
    intros.
    apply Acc_union; auto with sets.
  Qed.

End WfUnion.

*)

(* --TODO: Disjoint union, useful? *)

(* end hide *)

(* ********************************************************************** *)
(** * Transitive closure *)

Lemma wf_tclosure : forall A (R:binary A),
  wf R ->
  wf (tclosure R).
Proof using.
  unfold wf, well_founded.
  introv HAcc. intro a. specializes HAcc a. generalize dependent a.
  induction 1 as [ a _ IH ].
  constructor. intros b Hba.
  generalize a b Hba IH. clear a b Hba IH.
  induction 1; eauto using Acc_inv.
Qed.


Require Import Decidable.
Require Import Relation_Operators.
Require Import Equality.

Inductive term : Set :=
| trueT : term
| falseT : term
| if_then_elseT : term -> term -> term -> term.

Inductive eval1 : term -> term -> Prop :=
| e_if_true : forall t2 t3, eval1 (if_then_elseT trueT t2 t3) t2
| e_if_false : forall t2 t3, eval1 (if_then_elseT falseT t2 t3) t3
| e_if : forall t1 t1' t2 t3,
    eval1 t1 t1' -> eval1 (if_then_elseT t1 t2 t3) (if_then_elseT t1' t2 t3).

Notation "t1 --> t2" := (eval1 t1 t2) (at level 70, no associativity).

Theorem eval1_deterministic : forall t t' t'',
    t --> t' -> t --> t'' -> t' = t''.
Proof.
  intros t t' t'' Ht'. generalize dependent t''.
  induction Ht' as [].
  - intros t'' Ht''. inversion Ht''. reflexivity.
    inversion H3.
  - intros t'' Ht''. inversion Ht''. reflexivity.
    inversion H3.
  - intros t'' Ht''. inversion Ht''. rewrite <- H0 in Ht'.
    inversion Ht'. rewrite <- H0 in Ht'.
    inversion Ht'. f_equal. apply IHHt'. auto.
Qed.

Inductive value : term -> Prop :=
| value_true : value trueT
| value_false : value falseT.

Lemma value_dec : forall t, decidable (value t).
Proof.
  unfold decidable. destruct t.
  - left. apply value_true.
  - left. apply value_false.
  - right. intros H. inversion H.
Qed.

Definition nf (t : term) : Prop := ~ exists t', t --> t'.

Theorem nf_value : forall t, value t <-> nf t.
Proof.
  intros t. split.
  - intros Hvt. inversion Hvt; intros [t' Ht']; inversion Ht'.
  - apply contrapositive. apply value_dec.
    induction t.
    + intros Hnv. exfalso. apply Hnv. apply value_true.
    + intros Hnv. exfalso. apply Hnv. apply value_false.
    + intros Hnv Hnf. destruct t1.
      * apply Hnf. exists t2. apply e_if_true.
      * apply Hnf. exists t3. apply e_if_false.
      * apply IHt1. intros Hv. inversion Hv.
        intros [t' Ht']. apply Hnf.
        exists (if_then_elseT t' t2 t3). apply e_if. auto.
Qed.

Notation "t1 -->* t2" := (clos_refl_trans_1n _ eval1 t1 t2) (at level 70).

Theorem multistep_nf_unique : forall t u u',
    t -->* u -> nf u -> t -->* u' -> nf u' -> u = u'.
Proof.
  intros t u u' Hu Hnfu. generalize dependent u'.
  induction Hu.
  - intros u' Hu' Hnfu'. inversion Hu'.
    reflexivity. exfalso. apply Hnfu.
    exists y. auto.
  - intros u' Hu' Hnfu'. inversion Hu'.
    exfalso. apply Hnfu'. exists y. rewrite <- H0. auto.
    apply IHHu. apply Hnfu.
    assert (Heq : y0 = y).
    { apply eval1_deterministic with (t:=x). auto. auto. }
    rewrite <- Heq. auto. auto.
Qed.

Fixpoint size (t : term) :=
  match t with
  | trueT => 1
  | falseT => 1
  | if_then_elseT t1 t2 t3 => 1 + (size t1) + (size t2) + (size t3)
  end.

Require Import PeanoNat.
Require Import Operators_Properties.

Lemma add_lt_l : forall m n p, m + n < p -> m < p.
Proof.
  intros m n p H.
  assert (H'': p <> 0).
  { unfold lt in H. inversion H. intros E. inversion E.
    intros E. inversion E. }
  unfold lt in H. apply Nat.le_succ_le_pred in H.
  assert (H' : m <= Nat.pred p).
  { transitivity (Nat.pred p - n).
    apply Nat.le_add_le_sub_r. apply H.
    apply Nat.le_sub_l. }
  unfold lt.
  rewrite <- (Nat.succ_pred).
  apply Nat.succ_le_mono in H'. apply H'. auto.
Qed.

Lemma multistep_cong_if : forall t1 t1' t2 t3,
    t1 -->* t1' -> if_then_elseT t1 t2 t3 -->* if_then_elseT t1' t2 t3.
Proof.
  intros t1 t1' t2 t3 Hev.
  induction Hev.
  - apply rt1n_refl.
  - apply e_if with (t2:=t2) (t3:=t3) in H.
    apply Relation_Operators.rt1n_trans with (y:=(if_then_elseT y t2 t3)).
    auto. auto.
Qed.

Lemma multistep_transitive : forall t1 t2 t3,
    t1 -->* t2 -> t2 -->* t3 -> t1 -->* t3.
Proof.
  intros t1 t2 t3 H12 H23. induction H12.
  - apply H23.
  - apply IHclos_refl_trans_1n in H23.
    apply Relation_Operators.rt1n_trans with (y:=y). auto. auto.
Qed.

Theorem normalizing : forall t, exists t', nf t' /\ t -->* t'.
Proof.
  pose (P:= fun n => forall t, size t = n -> exists t', nf t' /\ t-->* t').
  assert (H : forall n, P n).
  { apply (well_founded_ind Nat.lt_wf_0).
    unfold P.
    intros n IH.
    intros t Ht. destruct t as [].
    - exists trueT. split. apply nf_value. apply value_true.
      apply rt1n_refl.
    - exists falseT. split. apply nf_value. apply value_false.
      apply rt1n_refl.
    - simpl in Ht.
      assert (Hs : size t1 + size t2 + size t3 < n).
      { unfold lt. rewrite Ht. apply Nat.le_refl. }
      assert (Hs1: size t1 < n).
      { rewrite <- Nat.add_assoc in Hs.
        apply add_lt_l with (n:=(size t2 + size t3)). auto. }
      assert (Hs2: size t2 < n).
      { rewrite (Nat.add_comm (size t1)) in Hs.
        rewrite <- Nat.add_assoc in Hs.
        apply add_lt_l with (n:=(size t1 + size t3)). auto. }
      assert (Hs3: size t3 < n).
      { rewrite (Nat.add_comm _ (size t3)) in Hs.
        apply add_lt_l with (n:=(size t1 + size t2)). auto. }
      apply IH with (t:=t1) in Hs1.
      apply IH with (t:=t2) in Hs2.
      apply IH with (t:=t3) in Hs3.
      destruct Hs1 as [t1' [Hnft1' Hevt1']].
      destruct Hs2 as [t2' [Hnft2' Hevt2']].
      destruct Hs3 as [t3' [Hnft3' Hevt3']].
      apply nf_value in Hnft1'.
      apply multistep_cong_if with (t2:=t2) (t3:=t3) in Hevt1'.
      destruct Hnft1'.
      + exists t2'. split. auto.
        assert (Hevt2'' : if_then_elseT trueT t2 t3 -->* t2').
        { apply Relation_Operators.rt1n_trans with (y:=t2).
          apply e_if_true. auto. }
        apply multistep_transitive with (t2:=if_then_elseT trueT t2 t3).
        auto. auto.
      + exists t3'. split. auto.
        assert (Hevt3'' : if_then_elseT falseT t2 t3 -->* t3').
        { apply Relation_Operators.rt1n_trans with (y:=t3).
          apply e_if_false. auto. }
        apply multistep_transitive with (t2:=if_then_elseT falseT t2 t3).
        auto. auto.
      + reflexivity.
      + reflexivity.
      + reflexivity. }
  intros t. unfold P in H. apply H with (n:=size t). reflexivity.
Qed.