From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Export Category.Lib.Setoid.
Require Export Category.Lib.Tactics.

Require Import Coq.Bool.Bool.
Require Import Coq.Lists.List.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.NArith.NArith.
Require Import Coq.omega.Omega.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Open Scope lazy_bool_scope.

Lemma K_dec_on_type A (x : A) (eq_dec : ∀ y : A, x = y \/ x ≠ y)
(P : x = x -> Type) :
P eq_refl -> forall p:x = x, P p.
Proof. hammer_hook "Equality" "Equality.K_dec_on_type".
intros.
elim (@Eqdep_dec.eq_proofs_unicity_on A _) with x eq_refl p.
trivial.
exact eq_dec.
Qed.

Lemma Nat_eq_dec' : ∀ (x y : nat), x = y \/ x ≠ y.
Proof. hammer_hook "Equality" "Equality.Nat_eq_dec'". intros; destruct (Nat.eq_dec x y); auto. Qed.

Lemma Nat_eq_dec_refl (x : nat) :
Nat.eq_dec x x = left (@eq_refl (nat) x).
Proof. hammer_hook "Equality" "Equality.Nat_eq_dec_refl".
destruct (Nat.eq_dec x x); [| contradiction].
refine (K_dec_on_type (nat) x (Nat_eq_dec' x)
(fun H => @left _ _ H = @left _ _ (@eq_refl (nat) x)) _ _); auto.
Qed.

Lemma Nat_eqb_refl (x : nat) : Nat.eqb x x = true.
Proof. hammer_hook "Equality" "Equality.Nat_eqb_refl". now apply Nat.eqb_eq. Qed.

Lemma Pos_eq_dec' : ∀ x y : positive, x = y \/ x ≠ y.
Proof. hammer_hook "Equality" "Equality.Pos_eq_dec'".
intros.
destruct (Pos.eq_dec x y); auto.
Qed.

Lemma Pos_eq_dec_refl n : Pos.eq_dec n n = left (@eq_refl positive n).
Proof. hammer_hook "Equality" "Equality.Pos_eq_dec_refl".
destruct (Pos.eq_dec n n).
refine (K_dec_on_type positive n (Pos_eq_dec' n)
(fun x => @left _ _ x = @left _ _ (@eq_refl positive n)) _ _).
reflexivity.
contradiction.
Qed.

Theorem Pos_eqb_eq (p q : positive) : (p =? q)%positive = true <-> p=q.
Proof. hammer_hook "Equality" "Equality.Pos_eqb_eq".
revert q. induction p; destruct q; simpl; rewrite ?IHp; split; congruence.
Qed.

Fixpoint Pos_eqb_refl (x : positive) : Pos.eqb x x = true :=
match x with
| xI x => Pos_eqb_refl x
| xO x => Pos_eqb_refl x
| xH => eq_refl
end.

Lemma N_eq_dec' : ∀ x y : N, x = y \/ x ≠ y.
Proof. hammer_hook "Equality" "Equality.N_eq_dec'".
intros.
destruct (N.eq_dec x y); auto.
Qed.

Lemma N_eq_dec_refl n : N.eq_dec n n = left (@eq_refl N n).
Proof. hammer_hook "Equality" "Equality.N_eq_dec_refl".
destruct (N.eq_dec n n).
refine (K_dec_on_type N n (N_eq_dec' n)
(fun x => @left _ _ x = @left _ _ (@eq_refl N n)) _ _).
reflexivity.
contradiction.
Qed.

Definition nth_safe {a} (xs : list a) (n : nat) (H : (n < length xs)%nat) : a.
Proof. hammer_hook "Equality" "Equality.nth_safe".
induction xs; simpl in *; auto.
contradiction (Nat.nlt_0_r n).
Defined.

Definition nth_pos {a} (xs : list a) (n : positive) (default : a) : a.
Proof. hammer_hook "Equality" "Equality.nth_pos".
generalize dependent n.
induction xs; intros.
exact default.
destruct n using Pos.peano_rect.
exact a0.
exact (IHxs n).
Defined.

Definition within_bounds {A} (x : positive) (xs : list A) : Prop :=
(Nat.pred (Pos.to_nat x) < length xs)%nat.

Definition Pos_to_fin {n} (x : positive) :
(Nat.pred (Pos.to_nat x) < n)%nat -> Fin.t n := Fin.of_nat_lt.

Definition nth_pos_bounded {a} (xs : list a) (n : positive)
(H : within_bounds n xs) : a.
Proof. hammer_hook "Equality" "Equality.nth_pos_bounded".
generalize dependent n.
induction xs; intros.
unfold within_bounds in H; simpl in H; omega.
destruct n using Pos.peano_rect.
exact a0.
clear IHn.
apply IHxs with (n:=n).
unfold within_bounds in *.
simpl in H.
rewrite Pos2Nat.inj_succ in H.
simpl in H.
apply lt_S_n.
rewrite Nat.succ_pred_pos; auto.
apply Pos2Nat.is_pos.
Defined.

Lemma Nat_eqb_eq n m : Nat.eqb n m = true <-> n = m.
Proof. hammer_hook "Equality" "Equality.Nat_eqb_eq".
revert m.
induction n; destruct m; simpl; rewrite ?IHn; split; try easy.
- now intros ->.
- now injection 1.
Defined.

Lemma Fin_eqb_eq : forall n (p q : Fin.t n), Fin.eqb p q = true <-> p = q.
Proof. hammer_hook "Equality" "Equality.Fin_eqb_eq".
apply Fin.rect2; simpl; intros.
- split; intros ; [ reflexivity | now apply Nat_eqb_eq ].
- now split.
- now split.
- split; intros.
* f_equal.
now apply H.
* apply Fin.FS_inj in H0.
now apply H.
Defined.

Lemma Fin_eqb_eq' n (x y : Fin.t n) (H : Fin.eqb x y = true) : x = y.
Proof. hammer_hook "Equality" "Equality.Fin_eqb_eq'".
induction x.
revert H.
apply Fin.caseS with (p:=y); intros; eauto.
simpl in H; discriminate.
revert H.
apply Fin.caseS' with (p:=y); intros; eauto.
simpl in H; discriminate.
simpl in H.
f_equal.
now apply IHx.
Defined.

Lemma Fin_eq_dec {n} (x y : Fin.t n): {x = y} + {x <> y}.
Proof. hammer_hook "Equality" "Equality.Fin_eq_dec".
case_eq (Fin.eqb x y); intros.
- left; now apply Fin_eqb_eq.
- right. intros Heq. apply <- Fin_eqb_eq in Heq. congruence.
Defined.

Lemma Fin_eq_dec' : ∀ n (x y : Fin.t n), x = y \/ x ≠ y.
Proof. hammer_hook "Equality" "Equality.Fin_eq_dec'". intros; destruct (Fin_eq_dec x y); auto. Qed.

Lemma Fin_eq_dec_refl n (x : Fin.t n) :
Fin_eq_dec x x = left (@eq_refl (Fin.t n) x).
Proof. hammer_hook "Equality" "Equality.Fin_eq_dec_refl".
destruct (Fin_eq_dec x x).
refine (K_dec_on_type (Fin.t n) x (Fin_eq_dec' n x)
(fun H => @left _ _ H = @left _ _ (@eq_refl (Fin.t n) x)) _ _).
reflexivity.
contradiction.
Qed.

Fixpoint Fin_eqb_refl n (x : Fin.t n) : Fin.eqb x x = true :=
match x with
| @Fin.F1 m'    => Nat_eqb_refl m'
| @Fin.FS n0 p' => Fin_eqb_refl n0 _
end.

Import EqNotations.

Fixpoint nth_fin {a} (xs : list a) (n : Fin.t (length xs)) : a :=
match xs as xs' return length xs = length xs' -> a with
| nil => fun H => Fin.case0 _ (rew H in n)
| cons x xs' => fun H =>
match n in Fin.t n' return length xs = n' -> a with
| Fin.F1 => fun _ => x
| @Fin.FS n0 x => fun H0 =>
nth_fin
xs' (rew (eq_add_S n0 (length xs')
(rew [fun n => n = S (length xs')] H0 in H)) in x)
end eq_refl
end eq_refl.

Class Equality (A : Type) := {
Eq_eq := @eq A;
Eq_eq_refl x := eq_refl;

Eq_eqb : A -> A -> bool;
Eq_eqb_refl x : Eq_eqb x x = true;

Eq_eqb_eq x y : Eq_eqb x y = true -> x = y;

Eq_eq_dec  (x y : A) : { x = y } + { x ≠ y };
Eq_eq_dec_refl x : Eq_eq_dec x x = left (@Eq_eq_refl x)
}.

Program Instance Pos_Eq : Equality positive := {
Eq_eqb         := Pos.eqb;
Eq_eqb_refl    := Pos_eqb_refl;

Eq_eqb_eq x y  := proj1 (Pos_eqb_eq x y);

Eq_eq_dec      := Pos.eq_dec;
Eq_eq_dec_refl := Pos_eq_dec_refl
}.

Program Instance Fin_Eq (n : nat) : Equality (Fin.t n) := {
Eq_eqb         := Fin.eqb;
Eq_eqb_refl    := Fin_eqb_refl n;

Eq_eqb_eq x y  := proj1 (Fin_eqb_eq n x y);

Eq_eq_dec      := Fin_eq_dec;
Eq_eq_dec_refl := Fin_eq_dec_refl n
}.

Fixpoint list_beq {A : Type} (eq_A : A -> A -> bool) (X Y : list A)
{struct X} : bool :=
match X with
| [] => match Y with
| [] => true
| _ :: _ => false
end
| x :: x0 =>
match Y with
| [] => false
| x1 :: x2 => eq_A x x1 &&& list_beq eq_A x0 x2
end
end.

Lemma list_beq_eq {A} (R : A -> A -> bool) xs ys :
(∀ x y, R x y = true -> x = y) ->
list_beq R xs ys = true -> xs = ys.
Proof. hammer_hook "Equality" "Equality.list_beq_eq".
generalize dependent ys.
induction xs; simpl; intros.
destruct ys; congruence.
destruct ys.
discriminate.
destruct (R a a0) eqn:Heqe.
apply H in Heqe; subst.
erewrite IHxs; eauto.
discriminate.
Qed.

Lemma list_beq_refl {A} (R : A -> A -> bool) xs :
(∀ x, R x x = true) -> list_beq R xs xs = true.
Proof. hammer_hook "Equality" "Equality.list_beq_refl".
intros.
induction xs; auto; simpl.
now rewrite H.
Qed.

Program Instance list_Eq `{Equality A} : Equality (list A) := {
Eq_eqb         := list_beq Eq_eqb;
Eq_eqb_refl x  := list_beq_refl Eq_eqb x Eq_eqb_refl;

Eq_eqb_eq x y  := list_beq_eq Eq_eqb x y Eq_eqb_eq;

Eq_eq_dec      := list_eq_dec Eq_eq_dec;
Eq_eq_dec_refl := _
}.
Next Obligation.
induction x; simpl; auto.
unfold sumbool_rec, sumbool_rect.
rewrite Eq_eq_dec_refl, IHx.
reflexivity.
Qed.

Definition prod_eqb {A B} (A_eqb : A -> A -> bool) (B_eqb : B -> B -> bool)
(x y : A * B) : bool :=
A_eqb (fst x) (fst y) && B_eqb (snd x) (snd y).

Program Definition prod_eq_dec {A B}
(A_eq_dec : forall x y : A, {x = y} + {x ≠ y})
(B_eq_dec : forall x y : B, {x = y} + {x ≠ y})
(x y : A * B) : {x = y} + {x ≠ y} :=
match A_eq_dec (fst x) (fst y) with
| in_left =>
match B_eq_dec (snd x) (snd y) with
| in_left  => in_left
| in_right => in_right
end
| in_right => in_right
end.
Next Obligation. simpl in *; congruence. Qed.

Lemma prod_eq_dec' :
∀ (A B : Type) (A_eq_dec : ∀ x y : A, x = y ∨ x ≠ y)
(B_eq_dec : ∀ x y : B, x = y ∨ x ≠ y)
(x y : A ∧ B), x = y \/ x ≠ y.
Proof. hammer_hook "Equality" "Equality.prod_eq_dec'".
intros.
destruct x, y; simpl.
destruct (A_eq_dec a a0); subst.
destruct (B_eq_dec b b0); subst.
left; reflexivity.
right; congruence.
right; congruence.
Qed.

Lemma prod_eq_dec_refl (A B : Type) n
(A_eq_dec : ∀ x y : A, x = y ∨ x ≠ y)
(B_eq_dec : ∀ x y : B, x = y ∨ x ≠ y) :
prod_eq_dec A_eq_dec B_eq_dec n n = left (@eq_refl (A ∧ B) n).
Proof. hammer_hook "Equality" "Equality.prod_eq_dec_refl".
destruct (prod_eq_dec _ _ n n).
refine (K_dec_on_type (A ∧ B) n (prod_eq_dec' _ _ A_eq_dec B_eq_dec n)
(fun x => @left _ _ x = @left _ _ (@eq_refl (A ∧ B) n)) _ _).
reflexivity.
contradiction.
Qed.

Program Instance prod_Eq `{Equality A} `{Equality B} : Equality (prod A B) := {
Eq_eqb           := prod_eqb Eq_eqb Eq_eqb;
Eq_eqb_refl      := _;

Eq_eqb_eq x y    := _;

Eq_eq_dec        := prod_eq_dec Eq_eq_dec Eq_eq_dec;
Eq_eq_dec_refl x := prod_eq_dec_refl _ _ x Eq_eq_dec Eq_eq_dec
}.
Next Obligation.
unfold prod_eqb; simpl.
now rewrite !Eq_eqb_refl.
Defined.
Next Obligation.
unfold prod_eqb in H1; simpl in H1.
apply andb_true_iff in H1.
destruct H1.
apply Eq_eqb_eq in H1.
apply Eq_eqb_eq in H2.
now subst.
Defined.

Ltac equalities' :=
simplify;
match goal with
| [ H : (?X; _) = (?X; _) |- _ ] =>
try (apply Eqdep_dec.inj_pair2_eq_dec in H; [|apply Eq_eq_dec])

| [ H : context[Pos.eq_dec ?N ?M] |- _ ] =>
replace (Pos.eq_dec N M) with (Eq_eq_dec N M) in H
| [ |- context[Pos.eq_dec ?N ?M] ] =>
replace (Pos.eq_dec N M) with (Eq_eq_dec N M)
| [ H : context[(?N =? ?M)%positive] |- _ ] =>
replace ((N =? M)%positive) with (Eq_eqb N M) in H
| [ |- context[(?N =? ?M)%positive] ] =>
replace ((N =? M)%positive) with (Eq_eqb N M)

| [ H : context[@Fin_eq_dec ?N ?X ?Y] |- _ ] =>
replace (@Fin_eq_dec N X Y) with (Eq_eq_dec X Y) in H
| [ |- context[Fin_eq_dec ?N ?X ?Y] ] =>
replace (@Fin_eq_dec N X Y) with (Eq_eq_dec X Y)
| [ H : context[@Fin.eqb ?N ?X ?Y] |- _ ] =>
replace (@Fin.eqb ?N ?X ?Y) with (Eq_eqb X Y) in H
| [ |- context[@Fin.eqb ?N ?X ?Y] ] =>
replace (@Fin.eqb ?N ?X ?Y) with (Eq_eqb X Y)

| [ |- Eq_eqb ?X ?X = true ]     => apply Eq_eqb_refl
| [ H : Eq_eqb _ _ = true |- _ ] => apply Eq_eqb_eq in H
| [ |- Eq_eqb _ _ = true ]       => apply Eq_eqb_eq

| [ H : context[match Eq_eq_dec ?X ?X with _ => _ end] |- _ ] =>
rewrite (Eq_eq_dec_refl X) in H
| [ |- context[match Eq_eq_dec ?X ?X with _ => _ end] ] =>
rewrite (Eq_eq_dec_refl X)
| [ H : context[match Eq_eq_dec ?X ?Y with _ => _ end] |- _ ] =>
destruct (Eq_eq_dec X Y); subst
| [ |- context[match Eq_eq_dec ?X ?Y with _ => _ end] ] =>
destruct (Eq_eq_dec X Y); subst

| [ H : list_beq _ _ _ = true |- _ ] => apply list_beq_eq in H
| [ |- list_beq _ _ _ = true ]       => apply list_beq_eq
end.

Ltac equalities :=
try equalities';
repeat (
equalities';
subst; simpl; auto;
try discriminate;
try tauto;
try intuition idtac;
subst; simpl; auto).


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************)
(*                   Substitution.v                                   *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(* adapted from Substitution.v of Project Coq  to act on Tree-terms   *)
(**********************************************************************)

Require Import Arith Omega List.
Require Import IntensionalLib.SF_calculus.Test.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Tree_calculus.Tree_Terms.
Require Import IntensionalLib.Tree_calculus.Tree_Tactics.
Require Import IntensionalLib.Tree_calculus.Tree_reduction.
Require Import IntensionalLib.Tree_calculus.Tree_Normal.
Require Import IntensionalLib.Tree_calculus.Tree_Closed.

(* Lifting *)

Definition relocate (i k n : nat) :=
  match test k i with
   (* k<=i *) | left _ => n+i
   (* k>i  *) | _ => i
  end.

Lemma relocate_null :
forall (n n0 : nat), relocate n n0 0 = n.
Proof. split_all. unfold relocate. case (test n0 n); intro; auto with arith. Qed.

Lemma relocate_lessthan : forall m n k, m<=k -> relocate k m n = (n+k).
Proof. split_all. unfold relocate. elim(test m k); split_all; try noway. Qed.
Lemma relocate_greaterthan : forall m n k, m>k -> relocate k m n = k.
Proof. split_all. unfold relocate. elim(test m k); split_all; try noway. Qed.

Ltac relocate_lt :=
try (rewrite relocate_lessthan; [| omega]; relocate_lt);
try (rewrite relocate_greaterthan; [| omega]; relocate_lt);
try(rewrite relocate_null).

Lemma relocate_zero_succ :
forall n k, relocate 0 (S n) k = 0.
Proof.  split_all. Qed.

Lemma relocate_succ :
forall n n0 k, relocate (S n) (S n0) k = S(relocate n n0 k).
Proof.
intros; unfold relocate. elim(test(S n0) (S n)); elim(test n0 n); split_all.
noway.
noway.
Qed.

Lemma relocate_mono : forall M N n k, relocate M n k = relocate N n k -> M=N.
Proof.
intros M N n k.
unfold relocate.
elim(test n M); elim(test n N); split_all; omega.
Qed.

Lemma relocate_null2 :
forall n k, relocate 0 (S n) k = 0.
Proof. split_all. Qed.

Fixpoint lift_rec (L : Tree) : nat -> nat -> Tree :=
  fun k n =>
  match L with
  | Ref i => Ref (relocate i k n)
  | Op o => Op o
  | App M N => App (lift_rec M k n) (lift_rec N k n)
   end.

Definition lift (n : nat) (N : Tree) := lift_rec N 0 n.

(* Lifting lemmas *)

Lemma lift_rec_null_term :
forall (U : Tree)(n: nat), lift_rec U n 0 = U.
Proof.
simple induction U; split_all.
relocate_lt; auto.
rewrite H; auto. rewrite H0; auto.
Qed.

Lemma lift1 :
 forall (U : Tree) (j i k : nat),
 lift_rec (lift_rec U i j) (j + i) k = lift_rec U i (j + k).
Proof.
simple induction U; simpl in |- *;  split_all.
unfold relocate.
elim (test i n); elim (test (j+i) (j+ n)); split_all; try noway.
assert(k + (j + n) = j + k + n) by omega. congruence.
elim (test (j + i) n); split_all; try noway. rewrite H; auto. rewrite H0; auto.
Qed.

Lemma lift_lift_rec :
 forall (U : Tree) (k p n i : nat),
 i <= n ->
 lift_rec (lift_rec U i p) (p + n) k = lift_rec (lift_rec U n k) i p.
Proof.
simple induction U; simpl in |- *;  split_all.
(* Ref *)
unfold relocate.
elim(test i n); split_all; try noway.
elim(test n0 n); split_all; try noway.
elim(test (p+n0) (p+n)); split_all; try noway.
elim(test i (k+n)); split_all; try noway.
assert(k+(p+n) = p+ (k+n)) by omega.
rewrite H0; auto.
elim(test (p+n0) (p+n)); split_all; try noway.
elim(test i n); split_all; try noway.
elim(test n0 n); split_all; try noway.
elim(test (p+n0) n); split_all; try noway.
elim(test i n); split_all; try noway.
(* Ap *)
rewrite H; split_all.  rewrite H0; split_all.
Qed.

Lemma lift_lift_term :
 forall (U : Tree) (k p n : nat),
 lift_rec (lift p U) (p+ n) k = lift p (lift_rec U n k).
Proof.
unfold lift in |- *; intros; apply lift_lift_rec; trivial with arith.
Qed.

Lemma liftrecO : forall (U : Tree) (n : nat), lift_rec U n 0 = U.
Proof.
simple induction U; simpl in |- *; intros; split_all; relocate_lt; congruence.
Qed.

Lemma liftO : forall (U : Tree) , lift 0 U = U.
Proof.
unfold lift in |- *; split_all; apply liftrecO.
Qed.

Lemma lift_rec_lift_rec :
 forall (U : Tree) (n p k i : nat),
 k <= i + n ->
 i <= k -> lift_rec (lift_rec U i n) k p = lift_rec U i (p + n).

Proof.
simple induction U; split_all.
(* Ref *)
unfold relocate.
elim(test i n); split_all; try noway.
elim(test k (n0 + n)); split_all; try noway.
replace (p+(n0+n)) with (p + n0 + n) by omega. auto.
elim(test k n); split_all; try noway.
(* Ap *)
rewrite H; split_all; rewrite H0; split_all; split_all.
Qed.

Lemma lift_rec_lift :
 forall (U : Tree)  (n p k i : nat),
 k <= n -> lift_rec (lift  n U)  k p = lift (p + n) U.
Proof.
unfold lift in |- *; intros; rewrite lift_rec_lift_rec; trivial with arith.
Qed.

Lemma lift_rec_lift2 :
forall M n k, lift_rec (lift 1 M) (S n) k = lift 1 (lift_rec M n k).
Proof.
split_all.
unfold lift.
replace (S n) with (1+n) by omega.
rewrite lift_lift_rec; auto.
omega.
Qed.

Lemma lift_rec_app: forall M N n k, lift_rec (App M N) n k = App (lift_rec M n k) (lift_rec N n k).
Proof. split_all. Qed.
Lemma lift_rec_op: forall o n k, lift_rec (Op o) n k = Op o.
Proof. split_all. Qed.
Lemma lift_rec_ref: forall i n k, lift_rec (Ref i) n k = Ref (relocate i n k).
Proof. split_all. Qed.

Lemma lift_rec_not_ref_0 : forall M, lift_rec M 0 1 <> Ref 0.
Proof. induction M; split_all; try discriminate. case n; split_all; discriminate. Qed.

Lemma lift_rec_null :
forall (U : Tree) (n: nat), lift_rec U n 0 = U.
Proof. simple induction U; split_all.
 rewrite relocate_null; congruence.
rewrite H; auto. rewrite H0; auto.
Qed.

Ltac  lift_tac :=
unfold_op; rewrite ? lift_rec_app; rewrite ? lift_rec_op; rewrite ? lift_rec_ref; relocate_lt;
rewrite ? lift_rec_not_ref_0.

Lemma lift_rec_preserves_compound :
forall (M: Tree), compound M -> forall (n k : nat), compound(lift_rec M n k).
Proof.
intros M c; induction c; split_all.
Qed.
Hint Resolve lift_rec_preserves_compound.

Lemma lift_rec_preserves_status:
forall M n k, status (lift_rec M n k) = status M.
Proof.
match goal with
  | |- forall M, ?P  =>   cut (forall p M, p >= rank M -> P );
      [intros H M;  eapply2 H |
       intro p; induction p; intro M;  [ assert(rank M >0) by eapply2 rank_positive; noway |]
      ]
  end.

induction M; split_all.
rewrite IHM1. (* pepm 2: omega.  *)
gen_case H M1. gen_case H t. gen_case H t1. gen_case H o. eapply2 IHp; omega. omega.
Qed.

Lemma lift_rec_preserves_normal: forall M n k, normal M -> normal (lift_rec M n k).
Proof. induction M; intros. split_all. split_all.
inversion H. apply nf_active; fold lift_rec; auto.
replace  (App (lift_rec M1 n k) (lift_rec M2 n k))
with (lift_rec (App M1 M2) n k) by auto.
rewrite lift_rec_preserves_status. auto.
simpl. eapply2 nf_compound.
replace  (App (lift_rec M1 n k) (lift_rec M2 n k))
with (lift_rec (App M1 M2) n k) by auto.
eapply2 lift_rec_preserves_compound.
Qed.

Lemma lift_rec_closed: forall M n k, maxvar M = 0 -> lift_rec M n k = M.
Proof. induction M; split_all. omega. max_out. rewrite IHM1; auto;  rewrite IHM2; auto. Qed.

Lemma map_lift0 : forall Ms, map (lift 0) Ms = Ms.
Proof. induction Ms; split_all.   rewrite IHMs. unfold lift; rewrite lift_rec_null. auto. Qed.

Lemma lift_preserves_maxvar2:
  forall M, forall k, maxvar (lift k M) - k = maxvar M.
Proof.
  induction M; split_all. relocate_lt. induction k; split_all.
  rewrite max_minus. unfold lift in *; rewrite IHM1; rewrite IHM2; auto.
Qed.

Lemma lift_rec_reflects_compound : forall M n k, compound (lift_rec M n k) -> compound M.
Proof.
induction M; split_all; inversion H; subst; split_all.
gen_case H1 M1; try discriminate.  invsub.
gen_case H1 M1; try discriminate. inversion H1.
gen_case H2 t; try discriminate. case o; auto.
Qed.

Lemma lift_rec_reflects_normal : forall M n k, normal (lift_rec M n k) -> normal M.
Proof.
induction M; split_all. inversion H; split_all.
replace (App (lift_rec M1 n k) (lift_rec M2 n k)) with (lift_rec (App M1 M2) n k) in H4 by auto.
rewrite lift_rec_preserves_status in *. eapply2 nf_active.
replace (App (lift_rec M1 n k) (lift_rec M2 n k)) with (lift_rec (App M1 M2) n k) in H4 by auto.
eapply2 nf_compound. eapply2 lift_rec_reflects_compound.
Qed.

(* Substitution *)

Definition insert_Ref (N : Tree) (i k : nat) :=
  match compare k i with

   (* k<i *) | inleft (left _) => Ref (pred i)
   (* k=i *) | inleft _ => lift k N
   (* k>i *) | _ => Ref i
  end.

Fixpoint subst_rec (L : Tree) : Tree -> nat -> Tree :=
  fun (N : Tree) (k : nat) =>
  match L with
  | Ref i => insert_Ref N i k
  | Op o => Op o
  | App M M' => App (subst_rec M N k) (subst_rec M' N k)
  end.

Lemma subst_rec_op:
forall o N k, subst_rec (Op o) N k = Op o.
Proof.  split_all. Qed.

Lemma subst_rec_app:
forall M1 M2 N k, subst_rec (App M1 M2) N k = App (subst_rec M1 N k) (subst_rec M2 N k).
Proof.  split_all. Qed.

Lemma subst_rec_ref: forall i N k,  subst_rec (Ref i) N k = insert_Ref N i k.
Proof.  split_all. Qed.

Definition subst (M N : Tree) := subst_rec M N 0.

(* The three cases of substitution of U for (Ref n) *)

Lemma subst_eq :
 forall (M U : Tree) (n : nat), subst_rec (Ref n) U n = lift n U.
Proof.
simpl in |- *; unfold insert_Ref in |- *; split_all.
elim (compare n n); intro P; try noway.
elim P; intro Q; simpl in |- *; trivial with arith; try noway.
Qed.

Lemma subst_gt :
 forall (M U : Tree) (n p : nat),
 n > p -> subst_rec (Ref n) U p = Ref (pred n).
Proof.
simpl in |- *; unfold insert_Ref in |- *.
intros; elim (compare p n); intro P.
elim P; intro Q; trivial with arith.
absurd (n > p); trivial with arith; rewrite Q; trivial with arith.
absurd (n > p); auto with arith.
Qed.

Lemma subst_lt :
 forall (M U : Tree) (n p : nat), p > n -> subst_rec (Ref n) U p = Ref n.
Proof.
simpl in |- *; unfold insert_Ref in |- *.
intros; elim (compare p n); intro P; trivial with arith.
absurd (p > n); trivial with arith; elim P; intro Q; auto with arith.
rewrite Q; trivial with arith.
Qed.

(* Substitution lemma *)

Lemma lift_rec_subst_rec :
 forall (V U : Tree) (k p n : nat),
 lift_rec (subst_rec V U p) (p + n) k =
 subst_rec (lift_rec V (S (p + n)) k) (lift_rec U n k) p.
Proof.
simple induction V; split_all.
(* 1 Ref *)
unfold insert_Ref, relocate in |- *.
elim (test (S(p + n0)) n); elim (compare p n); split_all.
elim a; elim(compare p (k+n)); split_all.
unfold relocate.
elim(test (p+n0) (pred n)); elim a1; split_all; try noway.
replace (k + pred n) with (pred (k + n)) by omega; auto.
noway.
noway.
noway.
noway.
elim a; split_all.
unfold relocate. elim(test(p+n0) (pred n)); split_all.
noway.
unfold lift.
rewrite lift_lift_rec; auto; omega.
unfold relocate.
elim(test (p+n0) n); split_all.
noway.
rewrite H; auto; rewrite H0; auto.
Qed.

Lemma lift_subst :
 forall (U V : Tree) (k n : nat),
 lift_rec (subst U V) n k =
 subst (lift_rec U (S n) k) (lift_rec V n k).
Proof.
unfold subst in |- *; intros.
replace n with (0 + n).
rewrite lift_rec_subst_rec; trivial with arith.
auto.
Qed.

Lemma subst_rec_lift_rec1 :
 forall (U V : Tree) (n p k : nat),
 k <= n ->
 subst_rec (lift_rec U k p) V (p + n) =
 lift_rec (subst_rec U V n) k p.
Proof.
simple induction U; intros; simpl in |- *; split_all.
(* Ref *)
unfold insert_Ref, relocate.
elim(test k n); split_all.
elim(compare n0 n); split_all; try noway.
elim a0; split_all; try noway.
elim(compare (p+n0) (p+n)); split_all.
elim a2; split_all; try noway.
unfold relocate.
elim(test k (pred n)); split_all; try noway.
assert(pred (p+n) = p + pred n) by omega. auto.
noway.
elim(compare (p+n0) (p+n)); split_all.
elim a1; split_all; try noway.
unfold lift. rewrite lift_rec_lift_rec; split_all; try omega.
unfold lift. rewrite lift_rec_lift_rec; split_all; try omega.
elim(compare (p+n0) (p+n)); split_all.
elim a0; split_all; try noway.
unfold relocate.
elim(test k n); split_all; try noway.
elim(compare (p+n0) n); split_all; try noway.
elim a; split_all; try noway.
elim(compare n0 n); split_all; try noway.
elim a; split_all; try noway.
unfold relocate.
elim(test k n); split_all; try noway.
(* 1 *)
rewrite H; split_all.  rewrite H0; split_all.
Qed.

Lemma subst_rec_lift1 :
 forall (U V : Tree) (n p : nat),
 subst_rec (lift p U) V (p + n) = lift p (subst_rec U V n).
Proof.
unfold lift in |- *; intros; rewrite subst_rec_lift_rec1;
 trivial with arith.
Qed.

Lemma subst_rec_lift_rec :
 forall (U V : Tree) (p q n : nat),
 q <= p + n ->
 n <= q -> subst_rec (lift_rec U n (S p)) V q = lift_rec U n p.
Proof.
simple induction U; intros; simpl in |- *; split_all.
unfold relocate. elim(test n0 n); split_all.
unfold insert_Ref.
elim(compare q (S(p+n))); split_all; try noway.
elim a0; split_all; try noway.
unfold insert_Ref.
elim(compare q n); split_all; try noway.
elim a; split_all; try noway.

(* 1 *)
rewrite H; split_all.
rewrite H0; auto.
Qed.

(* subst_rec_subst_rec *)

Lemma subst_rec_subst_rec :
 forall (V U W : Tree) (n p : nat),
 subst_rec (subst_rec V U p) W (p + n) =
 subst_rec (subst_rec V W (S (p + n))) (subst_rec U W n) p.
Proof.
simple induction V;  split_all.

unfold insert_Ref in |- *.
elim (compare p n); split_all.
elim a; split_all.
elim (compare (S (p + n0)) n); split_all.
elim a1; split_all; try noway.
unfold insert_Ref.
elim (compare (p+n0) (pred n)); split_all; try noway.
elim a3; split_all; try noway.
elim (compare p (pred n)); split_all; try noway.
elim a5; split_all; try noway.
unfold lift; split_all.
unfold insert_Ref.
elim (compare (p+n0) (pred n)); split_all; try noway.
elim a2; split_all; try noway.
subst. unfold lift.
rewrite subst_rec_lift_rec; split_all; try omega.
unfold insert_Ref.
elim(compare (p+n0) (pred n)); split_all; try noway.
elim a1; split_all; try noway.
elim(compare p n); split_all; try noway.
elim a1; split_all; try noway.
elim (compare (S (p + n0)) n); split_all; try noway.
elim a0; split_all; try noway.
unfold insert_Ref.
elim(compare p n); split_all; try noway.
elim a0; split_all; try noway.
unfold lift.
subst.
rewrite subst_rec_lift_rec1; split_all.  omega.

unfold insert_Ref.
elim(compare (p+n0) n); split_all; try noway.
elim a; split_all; try noway.
elim(compare (S(p+n0)) n); split_all; try noway.
elim a; split_all; try noway.
unfold insert_Ref.
elim(compare p n); split_all; try noway.
elim a; split_all; try noway.
rewrite H; auto. rewrite H0; auto.
Qed.

Lemma subst_rec_subst_0 :
 forall (U V W : Tree) (n : nat),
 subst_rec (subst_rec V U 0) W n =
 subst_rec (subst_rec V W (S n)) (subst_rec U W n) 0.
Proof.
intros; pattern n at 1 3 in |- *.
replace n with (0 + n) by trivial with arith.
rewrite (subst_rec_subst_rec V U W n 0); trivial with arith.
Qed.

(**************************)
(* The Substitution Lemma *)
(**************************)

Lemma substitution :
 forall (U V W : Tree) (n : nat),
 subst_rec (subst U V) W n =
 subst (subst_rec U W (S n)) (subst_rec V W n).
Proof.
unfold subst in |- *; intros; apply subst_rec_subst_0; trivial with arith.
Qed.

(* to show (\ t)0 -> t  *)

Lemma subst_lift_null :
forall (W V : Tree)(n : nat), subst_rec (lift_rec W n 1) V n = W.
Proof.
simple induction W; split_all.
unfold insert_Ref.
unfold relocate.
elim(test n0 n); split_all.
elim(compare n0 (S n)); split_all.
elim a0; split_all; noway.
noway.
elim(compare n0 n); split_all.
elim a; split_all. noway.
noway.
rewrite H; auto; rewrite H0; auto.
Qed.

(* more  Properties *)

Lemma subst_rec_lift2 :
forall M N n , subst_rec (lift 1 M) N (S n)  = lift 1 (subst_rec M N n).
Proof.
split_all.
unfold lift.
replace (S n) with (1+n) by omega.
rewrite subst_rec_lift_rec1; auto.
omega.
Qed.

Lemma insert_Ref_lt : forall M n k, n< k -> insert_Ref M n k = Ref n.
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
Qed.

Lemma insert_Ref_eq : forall M n k, n= k -> insert_Ref M n k = lift k M.
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
unfold lift; unfold lift_rec. unfold relocate. elim(test 0 n); split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
unfold lift; unfold lift_rec. unfold relocate. elim(test 0 n); split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
Qed.

Lemma insert_Ref_gt : forall M n k, n> k -> insert_Ref M n k = Ref (pred n).
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
Qed.

Ltac insert_Ref_out :=
try (rewrite insert_Ref_lt; [|unfold relocate; split_all; omega]; insert_Ref_out);
try (rewrite insert_Ref_eq; [|unfold relocate; split_all; omega]; insert_Ref_out);
try (rewrite insert_Ref_gt; [|unfold relocate; split_all; omega]; insert_Ref_out).

Lemma fold_subst :  forall M1 M2 N, App (subst_rec M1 N 0) M2 = subst (App M1 (lift 1 M2)) N.
Proof.
  unfold subst, lift, subst_rec; split_all; fold subst_rec.
  rewrite subst_rec_lift_rec; try omega. rewrite lift_rec_null; auto.
Qed.

Ltac  subst_tac :=
unfold_op; unfold subst;
rewrite ? subst_rec_app; rewrite ? subst_rec_op; rewrite ? subst_rec_ref;
rewrite ? subst_rec_lift_rec; try omega; rewrite ? lift_rec_null;
unfold subst_rec; fold subst_rec; insert_Ref_out; unfold pred.

Definition subst_preserves_l (red: termred) :=
forall (M M' N : Tree), red M M' -> red  (subst M N) (subst M' N).

Definition subst_preserves_r (red: termred) :=
forall (M N N' : Tree), red N N' -> red  (subst M N) (subst M N').

Definition subst_preserves (red: termred) :=
forall (M M' : Tree), red M M' -> forall N N', red N N' ->
red  (subst M N) (subst M' N').

Lemma subst_preserves_l_multi_step :
forall (red: termred), subst_preserves_l red -> subst_preserves_l (multi_step red).
Proof. unfold subst_preserves_l.
 induction 2; split_all.
apply succ_red with (subst N0 N); auto.
Qed.

Lemma subst_preserves_r_multi_step :
forall (red: termred), subst_preserves_r red -> subst_preserves_r (multi_step red).
Proof. unfold subst_preserves_r.
 induction 2; split_all.
apply succ_red with (subst M N); auto.
Qed.

Lemma subst_preserves_multi_step :
forall (red: termred), subst_preserves_l red -> subst_preserves_r red -> subst_preserves (multi_step red).
Proof.
unfold subst_preserves. split_all.
assert(transitive (multi_step red)) by eapply2 transitive_red.
unfold transitive in *.
apply X with  (subst M' N); auto.
eapply2 subst_preserves_l_multi_step.
eapply2 subst_preserves_r_multi_step.
Qed.

Lemma subst_preserves_compound:
forall (M: Tree), compound M -> forall N, compound(subst M N).
Proof. intros M c; induction c; unfold subst; split_all. Qed.
Hint Resolve subst_preserves_compound.

Lemma  subst_rec_preserves_components_l : forall (M : Tree) n k, compound M ->
  subst_rec(left_component M) n k = left_component(subst_rec M n k).
Proof. induction M; split_all; inv1 compound. Qed.

Lemma  subst_rec_preserves_components_r :
forall (M : Tree),  compound M -> forall n k,
subst_rec(right_component M) n k = right_component(subst_rec M n k).
Proof. induction M; split_all; inversion H; subst; split_all. Qed.
Lemma subst_rec_preserves_compounds:
forall M N k, compound M -> compound (subst_rec M N k).
Proof. intros; inv1 compound. Qed.

Lemma subst_rec_preserves_left_component:
forall M N k, compound M ->
              subst_rec (left_component M) N k = left_component (subst_rec M N k) .
Proof. intros; inv1 compound. Qed.

Lemma subst_rec_preserves_right_component:
forall M N k, compound M ->
              subst_rec (right_component M) N k = right_component (subst_rec M N k) .
Proof. intros; inv1 compound. Qed.

Lemma subst_preserves_sf_red1 : subst_preserves sf_red1.
Proof.
red.
intros M M' R; induction R; unfold subst; split_all.
(* 5 *)
unfold insert_Ref. elim(compare 0 i); split_all. elim a; split_all.
unfold lift. repeat rewrite lift_rec_null_term; auto.
(* 4 *)
eapply2 app_sf_red.
(* 3 *)
eapply2 s_red.
(* 2 *)
eapply2 k_red.
(* 1 *)
eapply2 f_red.
Qed.

Lemma subst_preserves_sf_red : subst_preserves sf_red.
Proof. eapply2 subst_preserves_multi_step. red; split_all.
eapply2 subst_preserves_sf_red1. red; split_all.
eapply2 subst_preserves_sf_red1.
Qed.

Lemma subst_rec_closed: forall M N k, maxvar M <= k -> subst_rec M N k = M.
Proof.
induction M; split_all.
unfold insert_Ref. elim(compare k n); split_all. elim a; split_all. noway. noway.
assert (max (maxvar M1) (maxvar M2) >= maxvar M1) by eapply2 max_is_max.
assert (max (maxvar M1) (maxvar M2) >= maxvar M2) by eapply2 max_is_max.
rewrite IHM1; try omega;  rewrite IHM2; try omega. auto.
Qed.

Lemma subst_decreases_maxvar :
forall M N,  max (pred (maxvar M)) (maxvar N) >= maxvar(subst M N).
Proof.
unfold subst; induction M; split_all.
unfold insert_Ref.
case n; split_all. unfold lift. rewrite lift_rec_null_term. auto.
case (maxvar N); split_all.
assert(max n0 n1  >= n0) by eapply2 max_is_max.
omega.
omega.
(* 1 *)
rewrite max_pred.
assert(max (max (pred (maxvar M1)) (pred (maxvar M2))) (maxvar N) >=
max (pred (maxvar M1)) (maxvar N)).
eapply2 max_monotonic. eapply2 max_is_max.
assert(max (max (pred (maxvar M1)) (pred (maxvar M2))) (maxvar N) >=
max (pred (maxvar M2)) (maxvar N)).
eapply2 max_monotonic. eapply2 max_is_max.
assert(max (max (pred (maxvar M1)) (pred (maxvar M2))) (maxvar N) >=
max(max (pred (maxvar M1)) (maxvar N)) (max (pred (maxvar M2)) (maxvar N))).
eapply2 max_max2.
assert(max (max (pred (maxvar M1)) (maxvar N))
         (max (pred (maxvar M2)) (maxvar N))>=
max (maxvar (subst_rec M1 N 0)) (maxvar (subst_rec M2 N 0))).
eapply2 max_monotonic.
omega.
Qed.

Lemma subst_closed : forall M, maxvar M = 0 -> forall N, subst M N = M.
Proof.
induction M; split_all; subst. omega.
max_out. unfold subst in *; simpl. rewrite IHM1; try omega; rewrite IHM2; try omega; split_all.
Qed.

Ltac closed_tac M := repeat (rewrite (subst_rec_closed M); [| auto]);
                     repeat (rewrite (lift_rec_closed M); [| auto]).

Lemma fold_subst_list:
  forall sigma M N,  App (fold_left subst sigma M) N =
                     fold_left subst sigma (App M (lift (length sigma) N)).
Proof.
  induction sigma; split_all.
  (* 2 *)
  unfold lift; rewrite lift_rec_null. auto.
  (* 1 *)
  rewrite IHsigma. unfold subst. simpl. unfold lift. rewrite subst_rec_lift_rec; try omega. auto.
Qed.

Lemma list_subst_preserves_op:
  forall sigma o, fold_left subst sigma (Op o) = Op o.
  Proof. induction sigma; split_all. unfold subst in *. split_all. Qed.

Lemma list_subst_preserves_app:
  forall sigma M N, fold_left subst sigma (App M N) =
                    App (fold_left subst sigma M) (fold_left subst sigma N).
  Proof. induction sigma; split_all. unfold subst in *. split_all. Qed.

Lemma list_subst_preserves_sf_red:
  forall sigma M N, sf_red M N -> sf_red (fold_left subst sigma M) (fold_left subst sigma N).
Proof.  induction sigma; split_all. eapply2 IHsigma. eapply2 subst_preserves_sf_red. Qed.

Lemma list_subst_lift: forall sigma M, fold_left subst sigma (lift (length sigma) M) = M.
Proof.
  induction sigma; split_all. unfold lift; rewrite lift_rec_null. auto.
unfold lift, subst. rewrite subst_rec_lift_rec; try omega. unfold lift in *. rewrite IHsigma. auto.
Qed.

Lemma lift_rec_preserves_variables: forall M n k, maxvar M >0 -> maxvar (lift_rec M n k) > 0.
Proof.
induction M; split_all.
omega.
assert((maxvar M1 > 0) \/ (maxvar M2 >0)).
gen_case H (maxvar M1). left; omega.
inversion H0; subst.
assert(Nat.max (maxvar (lift_rec M1 n k)) (maxvar (lift_rec M2 n k))  >= maxvar (lift_rec M1 n k)) by eapply2 max_is_max.
assert(maxvar(lift_rec M1 n k) >0) by eapply2 IHM1. omega.
assert(Nat.max (maxvar (lift_rec M1 n k)) (maxvar (lift_rec M2 n k))  >= maxvar (lift_rec M2 n k)) by eapply2 max_is_max.
assert(maxvar(lift_rec M2 n k) >0) by eapply2 IHM2. omega.
Qed.


Set Implicit Arguments.

Require Import Platform.Cito.Syntax.
Require Import Platform.Cito.SyntaxExpr.
Require Import Platform.Cito.GeneralTactics.
Require Import Platform.Cito.Notations3.
Require Import Platform.Cito.SemanticsExpr.
Require Import Platform.Cito.GoodOptimizer.

Require Import Bedrock.StringSet.
Module Import SS := StringSet.
Require Import Platform.Cito.StringSetFacts.
Module SSF := StringSetFacts.
Require Import Platform.Cito.StringSetTactics.

Require Import Platform.Cito.StringMap.
Import StringMap.
Require Import Platform.Cito.StringMapFacts.

Definition const_dec : forall e, {w | e = Const w} + {~ exists w, e = Const w}.
  intros; destruct e; solve [ right; intuition; openhyp; intuition | left; eauto ].
Qed.

Definition const_zero_dec : forall e, {e = Const $0} + {e <> Const $0}.
  intros; destruct e; solve [right; intuition | destruct (weq w $0); intuition ].
Qed.

Ltac f_equal' :=
  match goal with
    | |- (if ?E1 then _ else _) = (if ?E2 then _ else _) => replace E2 with E1; try reflexivity
  end.

Require Import Platform.Cito.Option.

Ltac openhyp' :=
  repeat match goal with
           | H : context [const_dec ?E] |- _ => destruct (const_dec E)
           | |- context [const_dec ?E] => destruct (const_dec E)
           | H : context [const_zero_dec ?E] |- _ => destruct (const_zero_dec E)
           | |- context [const_zero_dec ?E] => destruct (const_zero_dec E)
           | H : context [option_dec ?E] |- _ => destruct (option_dec E)
           | |- context [option_dec ?E] => destruct (option_dec E)
           | H : context [ { _ | _ } ] |- _ => destruct H
         end.

Ltac descend :=
  repeat match goal with
           | [ |- exists x, _ ] => eexists
         end.

Ltac unfold_all :=
  repeat match goal with
           | H := _ |- _ => unfold H in *; clear H
         end.

Definition SET := SS.t.
Definition Map := t W.
Definition empty_set := SS.empty.
Definition empty_map := empty W.
Definition Submap elt m1 m2 := forall k v, @find elt k m1 = Some v -> find k m2 = Some v.
Definition subtract elt m s := @filter elt (fun k _ => negb (SS.mem k s)) m.

Section TopSection.

  Notation "m %%- k" := (remove k m) (at level 60).
  Infix "%<=" := Subset (at level 60).
  Infix "%%<=" := Submap (at level 60).
  Infix "+" := union.
  Infix "-" := subtract.
  Notation "! x" := (singleton x) (at level 100).
  Notation "[]" := (@empty _).
  Open Scope stmt_scope.
  Infix "<-" := Syntax.Assign.

  Fixpoint const_folding_expr (e : Expr) (env : Map) : Expr :=
    match e with
      | Var var =>
        match option_dec (find var env) with
          | inleft (exist w _) => Const w
          | _ => e
        end
      | Const w => e
      | SyntaxExpr.Binop op a b =>
        let a' := const_folding_expr a env in
        let b' := const_folding_expr b env in
        match const_dec a', const_dec b' with
          | inleft (exist wa _),  inleft (exist wb _) => Const (evalBinop op wa wb)
          | _, _ => SyntaxExpr.Binop op a' b'
        end
      | TestE op a b =>
        let a' := const_folding_expr a env in
        let b' := const_folding_expr b env in
        match const_dec a', const_dec b' with
          | inleft (exist wa _),  inleft (exist wb _) => Const (if evalTest op wa wb then $1 else $0)
          | _, _ => TestE op a' b'
        end
    end.

  Fixpoint const_folding (s : Stmt) (map : Map) : Stmt * Map * SET :=
    match s with
      | skip => (skip, map, empty_set)
      | a ;; b =>
        let result_a := const_folding a map in
        let map' := snd (fst result_a) in
        let result_b := const_folding b map' in
        let a' := fst (fst result_a) in
        let b' := fst (fst result_b) in
        let map'' := snd (fst result_b) in
        let written_a := snd result_a in
        let written_b := snd result_b in
        (a' ;; b', map'', written_a + written_b)
      | Syntax.If c t f =>
        let c' := const_folding_expr c map in
        match const_dec c' with
          | inleft (exist w _) =>
            if wneb w $0 then
              const_folding t map
            else
              const_folding f map
          | inright _ =>
            let result_t := const_folding t map in
            let result_f := const_folding f map in
            let t' := fst (fst result_t) in
            let f' := fst (fst result_f) in
            let written_t := snd result_t in
            let written_f := snd result_f in
            (* written vars in branches will no longer have known values *)
            let map' := map - written_t - written_f in
            (Syntax.If c' t' f', map', written_t + written_f)
        end
      | Syntax.While c b =>
        if const_zero_dec (const_folding_expr c map) then
          (skip, map, empty_set)
        else
          let c' := const_folding_expr c [] in
          let result_b := const_folding b [] in
          let b' := fst (fst result_b) in
          let written_b := snd result_b in
          (* written vars in loop body will no longer have known values *)
          let map' := map - written_b in
          (Syntax.While c' b', map', written_b)
      | x <- e =>
        let e' := const_folding_expr e map in
        match const_dec e' with
          | inleft (exist w _) =>
            let map' := add x w map  in
            (x <- w, map', !x)
          | inright _ =>
            let map' := map %%- x in
            (x <- e', map', !x)
        end
      | Syntax.Label x l =>
        let map := map %%- x in
        (s, map, !x)
      | Syntax.Call x f args =>
        let f' := const_folding_expr f map in
        let args' := List.map (fun e => const_folding_expr e map) args in
        match x with
          | Some s =>
            let map := map %%- s in
            (Syntax.Call x f' args', map, !s)
          | None =>
            (Syntax.Call x f' args', map, empty_set)
        end
    end.

  Definition constant_folding s := fst (fst (const_folding s empty_map)).

  Definition optimizer := constant_folding.

  Definition opt : Optimizer := fun s _ => optimizer s.

  Lemma union_same_subset : forall s, s + s %<= s.
    intros; subset_solver.
  Qed.

  Require Import Platform.Cito.GeneralTactics2.
  Require Import Coq.Bool.Bool.
  Require Import Coq.Classes.Morphisms.

  Lemma subtract_none : forall elt (m : t elt) s x, SS.In x s -> find x (m - s) = None.
    unfold subtract; intros.
    eapply not_find_in_iff.
    nintro.
    eapply In_MapsTo in H0; openhyp.
    eapply filter_iff in H0; openhyp.
    eapply negb_true_iff in H1.
    eapply not_mem_iff in H1; intuition.
    unfold Proper.
    unfold respectful.
    intros; subst; eauto.
  Qed.

  Lemma empty_submap : forall elt (m : t elt), [] %%<= m.
    unfold Submap; intros.
    eapply find_2 in H; eapply empty_mapsto_iff in H; intuition.
  Qed.

  Lemma subtract_submap : forall elt (m : t elt) s, m - s %%<= m.
    unfold subtract, Submap.
    intros.
    eapply find_2 in H.
    eapply filter_iff in H.
    openhyp.
    eapply find_1; eauto.
    unfold Proper.
    unfold respectful.
    intros; subst; eauto.
  Qed.

  Lemma subtract_mapsto_iff : forall elt m s k v, @MapsTo elt k v (m - s) <-> (MapsTo k v m /\ ~ SS.In k s).
    unfold subtract.
    split; intros.
    eapply filter_iff in H.
    openhyp.
    split; eauto.
    eapply negb_true_iff in H0.
    eapply not_mem_iff; eauto.
    unfold Proper.
    unfold respectful.
    intros; subst; eauto.
    openhyp.
    eapply filter_iff.
    unfold Proper.
    unfold respectful.
    intros; subst; eauto.
    split; eauto.
    eapply negb_true_iff.
    eapply not_mem_iff; eauto.
  Qed.

  Section HintsSection.

    Hint Resolve empty_iff.
    Hint Unfold Subset.
    Hint Unfold Submap.
    Hint Resolve subtract_none.
    Hint Resolve singleton_iff.
    Hint Resolve union_subset_1.
    Hint Resolve union_subset_2.
    Hint Immediate subset_refl.
    Hint Resolve union_same_subset.
    Hint Resolve empty_submap.
    Hint Resolve subtract_submap.
    Hint Resolve union_iff union_1 union_2 union_3.

    Definition agree_with (v : vals) (m : Map) :=
      forall x w,
        find x m = Some w ->
        Locals.sel v x = w.

    Lemma agree_with_remove : forall local m x e, agree_with local m -> agree_with (upd local x e) (m %%- x).
      unfold agree_with; intros; destruct (string_dec x x0).
      subst.
      eapply find_2 in H0; eapply remove_mapsto_iff in H0; intuition.
      eapply find_2 in H0; eapply remove_mapsto_iff in H0; openhyp.
      rewrite sel_upd_ne.
      eapply H; eauto.
      eapply find_1; eauto.
      eauto.
    Qed.
    Hint Resolve agree_with_remove.

    Lemma agree_with_add : forall local m x w, agree_with local m -> agree_with (upd local x w) (add x w m).
      unfold agree_with; intros; destruct (string_dec x x0).
      subst.
      rewrite sel_upd_eq in *.
      eapply find_2 in H0; eapply add_mapsto_iff in H0; openhyp; intuition.
      eauto.
      rewrite sel_upd_ne in *.
      eapply H; eauto.
      eapply find_1.
      eapply find_2 in H0; eapply add_mapsto_iff in H0; openhyp; intuition.
      eauto.
    Qed.
    Hint Resolve agree_with_add.

    Lemma everything_agree_with_empty_map : forall v, agree_with v empty_map.
      unfold agree_with.
      intros.
      eapply find_2 in H; eapply empty_mapsto_iff in H.
      intuition.
    Qed.
    Hint Resolve everything_agree_with_empty_map.

    Definition agree_except (a b : vals) (s : SET) :=
      forall x,
        Locals.sel a x <> Locals.sel b x -> SS.In x s.

    Lemma agree_except_upd : forall local x w, agree_except local (upd local x w) (!x).
      unfold agree_except.
      intros.
      destruct (string_dec x x0).
      subst.
      eapply singleton_iff; eauto.
      rewrite sel_upd_ne in H.
      intuition.
      eauto.
    Qed.
    Hint Resolve agree_except_upd.

    Lemma agree_except_same : forall local s, agree_except local local s.
      intuition.
    Qed.
    Hint Resolve agree_except_same.

    Lemma agree_except_incl : forall v1 v2 s s', agree_except v1 v2 s -> s %<= s' -> agree_except v1 v2 s'.
      unfold agree_except; eauto.
    Qed.
    Hint Resolve agree_except_incl.

    Lemma agree_except_trans : forall m1 m2 m3 s1 s2, agree_except m1 m2 s1 -> agree_except m2 m3 s2 -> agree_except m1 m3 (s1 + s2).
      unfold agree_except.
      intros.
      destruct (weq (Locals.sel m1 x) (Locals.sel m2 x)).
      destruct (weq (Locals.sel m2 x) (Locals.sel m3 x)).
      intuition.
      eauto.
      eauto.
    Qed.
    Hint Resolve agree_except_trans.

    Lemma agree_with_agree_except_subtract : forall v1 v2 m s, agree_with v1 m -> agree_except v1 v2 s -> agree_with v2 (m - s).
      unfold agree_with, agree_except.
      intros.
      destruct (weq (Locals.sel v1 x) (Locals.sel v2 x)).
      rewrite <- e.
      eapply H.
      eapply find_2 in H1.
      eapply subtract_mapsto_iff in H1.
      openhyp.
      eapply find_1; eauto.
      eapply H0 in n.
      eapply subtract_none with (m := m) in n.
      erewrite H1 in n.
      intuition.
    Qed.
    Hint Resolve agree_with_agree_except_subtract.

  End HintsSection.

  Hint Resolve union_subset_1.
  Hint Resolve union_subset_2.
  Hint Immediate subset_refl.
  Hint Resolve union_same_subset.
  Hint Resolve empty_submap.
  Hint Resolve subtract_submap.

  Hint Resolve agree_with_remove.
  Hint Resolve agree_with_add.
  Hint Resolve everything_agree_with_empty_map.
  Hint Resolve agree_except_upd.
  Hint Resolve agree_except_same.
  Hint Resolve agree_except_trans.
  Hint Resolve agree_with_agree_except_subtract.
  Hint Resolve agree_except_incl.

  Remove Hints WordKey.W_as_OT.eq_trans.
  Remove Hints WordKey.W_as_OT_new.eq_trans.

  Lemma const_folding_expr_correct :
    forall e m local,
      agree_with local m ->
      eval local (const_folding_expr e m) = eval local e.
  Proof.
    induction e; simpl; intuition; openhyp'; simpl in *; eauto.

    symmetry; eauto.

    f_equal.
    erewrite <- (IHe1 m); eauto.
    erewrite e0; eauto.
    erewrite <- (IHe2 m); eauto.
    erewrite e; eauto.

    f_equal; eauto.

    f_equal; eauto.

    f_equal'; f_equal.
    erewrite <- (IHe1 m); eauto.
    erewrite e0; eauto.
    erewrite <- (IHe2 m); eauto.
    erewrite e; eauto.

    f_equal'; f_equal; eauto.

    f_equal'; f_equal; eauto.
  Qed.

  Lemma const_folding_expr_correct' :
    forall e e' m local,
      e' = const_folding_expr e m ->
      agree_with local m ->
      eval local e' = eval local e.
  Proof.
    intros; subst; eapply const_folding_expr_correct; eauto.
  Qed.

  Lemma const_folding_expr_submap_const : forall e m w, const_folding_expr e m = Const w -> forall m', m %%<= m' -> const_folding_expr e m' = Const w.
    induction e; simpl; intuition; openhyp'; simpl in *; try discriminate.

    eapply H0 in e0.
    rewrite e0 in e.
    injection e; intros; subst.
    eauto.

    eapply H0 in e0.
    rewrite e0 in e.
    discriminate.

    eapply IHe1 in e4; eauto.
    eapply IHe2 in e3; eauto.
    rewrite e0 in e4; injection e4; intros; subst.
    rewrite e in e3; injection e3; intros; subst.
    eauto.

    contradict n.
    descend.
    eauto.

    contradict n.
    descend.
    eauto.

    eapply IHe1 in e4; eauto.
    eapply IHe2 in e3; eauto.
    rewrite e0 in e4; injection e4; intros; subst.
    rewrite e in e3; injection e3; intros; subst.
    eauto.

    contradict n.
    descend.
    eauto.

    contradict n.
    descend.
    eauto.

  Qed.
  Hint Resolve const_folding_expr_submap_const.

  Lemma not_const_zero_submap : forall e m m', const_folding_expr e m <> Const $0 -> m' %%<= m -> const_folding_expr e m' <> Const $0.
    intuition eauto.
  Qed.
  Hint Resolve not_const_zero_submap.

  Lemma not_const_zero_empty_map : forall e m, const_folding_expr e m <> Const $0 -> const_folding_expr e empty_map <> Const $0.
    intros.
    eapply not_const_zero_submap; eauto.
    eapply empty_submap.
  Qed.
  Hint Resolve not_const_zero_empty_map.

  Lemma break_pair : forall A B (p : A * B), p = (fst p, snd p).
    intros; destruct p; eauto.
  Qed.

End TopSection.

Ltac rewrite_expr := repeat erewrite const_folding_expr_correct in * by eauto.

Lemma const_folding_expr_correct_list :
  forall es m local,
    agree_with local m ->
    List.map (fun e => eval local (const_folding_expr e m)) es = List.map (eval local) es.
Proof.
  induction es; simpl; intuition; rewrite_expr; f_equal; eauto.
Qed.

Ltac rewrite_expr_list := repeat erewrite map_map in *; repeat erewrite const_folding_expr_correct_list in * by eauto.

Require Import Platform.Cito.ADT.

Module Make (Import E : ADT).

  Module Import GoodOptimizerMake := GoodOptimizer.Make E.
  Require Import Platform.Cito.Semantics.
  Import SemanticsMake.

  Section TopSection.

    Notation "m %%- k" := (remove k m) (at level 60).
    Infix "%<=" := Subset (at level 60).
    Infix "%%<=" := Submap (at level 60).
    Infix "+" := union.
    Infix "-" := subtract.
    Notation "! x" := (singleton x) (at level 100).
    Notation "[]" := empty_map.
    Open Scope stmt_scope.
    Infix "<-" := Syntax.Assign.

    Hint Resolve union_subset_1.
    Hint Resolve union_subset_2.
    Hint Immediate subset_refl.
    Hint Resolve union_same_subset.
    Hint Resolve empty_submap.
    Hint Resolve subtract_submap.

    Hint Resolve agree_with_remove.
    Hint Resolve agree_with_add.
    Hint Resolve everything_agree_with_empty_map.
    Hint Resolve agree_except_upd.
    Hint Resolve agree_except_same.
    Hint Resolve agree_except_trans.
    Hint Resolve agree_with_agree_except_subtract.
    Hint Resolve agree_except_incl.

    Hint Unfold RunsTo.
    Hint Constructors Semantics.RunsTo.
    Hint Unfold Safe.
    Hint Constructors Semantics.Safe.

    Lemma while_case :
      forall fs t v v',
        RunsTo fs t v v' ->
        forall s c b m,
          let result := const_folding s m in
          let s' := fst (fst result) in
          let m' := snd (fst result) in
          let written := snd result in
          s = Syntax.While c b ->
          t = s' ->
          agree_with (fst v) m ->
          (let s := b in
           (* the induction hypothesis from Lemma const_folding_is_backward_simulation' *)

           forall (vs : vals) (heap : Heap) (vs' : vals)
                  (heap' : Heap) (m : Map),
             let result := const_folding s m in
             let s' := fst (fst result) in
             let m' := snd (fst result) in
             let written := snd result in
             RunsTo fs s' (vs, heap) (vs', heap') ->
             agree_with vs m ->
             RunsTo fs s (vs, heap) (vs', heap') /\
             agree_with vs' m' /\
             agree_except vs vs' written

          ) ->
          RunsTo fs s v v' /\
          agree_with (fst v') m' /\
          agree_except (fst v) (fst v') written.
    Proof.
      induction 1; simpl; intros; unfold_all; subst.

      (* skip *)
      simpl in *; openhyp'; simpl in *; intuition.
      econstructor 6.
      erewrite <- const_folding_expr_correct'.
      2 : symmetry; eauto.
      simpl; eauto.
      simpl; eauto.
      econstructor.

      (* seq *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* seq *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* if *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* if *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* while *)
      simpl in *; openhyp'; simpl in *; try discriminate.
      injection H3; intros; subst.
      destruct v; simpl in *.
      destruct v'; simpl in *.
      eapply H5 in H0; eauto; openhyp.
      destruct v''; simpl in *.
      edestruct IHRunsTo2; try reflexivity.
      3 : eauto.
      replace (While (const_folding_expr c _) (fst (fst (const_folding b _)))) with (fst (fst (const_folding (While c b ) (m - snd (const_folding b []))))).
      Focus 2.
      simpl in *; openhyp'; [contradict e; eauto | simpl; eauto ].
      eapply not_const_zero_submap; eauto.
      eauto.
      eauto.
      openhyp.
      simpl in *; openhyp'; [ contradict e; eauto | ]; simpl in *.
      eapply not_const_zero_submap; eauto.
      rewrite_expr.
      intuition eauto.

      (* while *)
      simpl in *; openhyp'; simpl in *; try discriminate.
      injection H1; intros; subst.
      rewrite_expr.
      intuition eauto.

      (* call *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* call *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* label *)
      simpl in *; openhyp'; simpl in *; intuition.

      (* assign *)
      simpl in *; openhyp'; simpl in *; intuition.

    Qed.

    Lemma const_folding_is_backward_simulation :
      forall fs s vs heap vs' heap' m,
        let result := const_folding s m in
        let s' := fst (fst result) in
        let m' := snd (fst result) in
        let written := snd result in
        RunsTo fs s' (vs, heap) (vs', heap') ->
        agree_with vs m ->
        RunsTo fs s (vs, heap) (vs', heap') /\
        agree_with vs' m' /\
        agree_except vs vs' written.
    Proof.
      induction s;
      match goal with
        | |- context [Syntax.While] => solve [intros; split; intros; eapply while_case in H; eauto; openhyp; eauto]
        | |- _ => idtac
      end; simpl; intros.

      (* skip *)
      inversion H; unfold_all; subst; rewrite_expr; eauto.

      (* seq *)
      inversion H; unfold_all; subst.
      destruct v'; simpl in *.
      eapply IHs1 in H3; eauto; openhyp.
      eapply IHs2 in H6; eauto; openhyp.
      eauto 6.

      (* if *)
      openhyp'.

      destruct (Sumbool.sumbool_of_bool (wneb x $0)); rewrite e1 in *; simpl in *.
      eapply IHs1 in H; eauto; openhyp.
      replace x with (eval vs x) in e1 by eauto.
      rewrite <- e0 in e1.
      rewrite_expr.
      eauto.
      eapply IHs2 in H; eauto; openhyp.
      replace x with (eval vs x) in e1 by eauto.
      rewrite <- e0 in e1.
      rewrite_expr.
      eauto.

      simpl in *.
      inversion H; unfold_all; subst.
      rewrite_expr.
      eapply IHs1 in H7; eauto; openhyp.
      intuition eauto.
      rewrite_expr.
      eapply IHs2 in H7; eauto; openhyp.
      split; [econstructor 4 | ]; eauto.

      Focus 3.
      (* assign *)
      openhyp'; simpl in *; inversion H; unfold_all; subst; simpl in *.
      split.
      replace x with (eval vs x) by eauto.
      rewrite <- e0.
      rewrite_expr.
      econstructor; eauto.
      eauto.

      split.
      rewrite_expr.
      econstructor; eauto.
      eauto.

      (* call *)
      destruct o; openhyp'; simpl in *; inversion H; unfold_all; subst; simpl in *.
      split.
      rewrite_expr.
      rewrite_expr_list.
      specialize RunsToCallInternal; intros.
      simpl in *.
      specialize (H1 _ fs (Some s)).
      simpl in *.
      eapply H1; eauto.
      eauto.

      split.
      rewrite_expr.
      rewrite_expr_list.
      specialize RunsToCallForeign; intros.
      simpl in *.
      specialize (H1 _ fs (Some s)).
      simpl in *.
      eapply H1; eauto.
      eauto.

      split.
      rewrite_expr.
      rewrite_expr_list.
      specialize RunsToCallInternal; intros.
      simpl in *.
      specialize (H1 _ fs None).
      simpl in *.
      eapply H1; eauto.
      eauto.

      split.
      rewrite_expr.
      rewrite_expr_list.
      specialize RunsToCallForeign; intros.
      simpl in *.
      specialize (H1 _ fs None).
      simpl in *.
      eapply H1; eauto.
      eauto.

      (* label *)
      openhyp'; simpl in *; inversion H; unfold_all; subst; simpl in *.
      split.
      rewrite_expr.
      econstructor; eauto.
      eauto.
    Qed.

    Lemma PreserveRunsTo_opt : PreserveRunsTo opt.
      unfold PreserveRunsTo, opt, optimizer, constant_folding; intros.
      destruct v.
      destruct v'; simpl in *.
      eapply const_folding_is_backward_simulation in H; openhyp; eauto.
    Qed.

    Lemma const_folding_is_safety_preservation :
      forall fs s vs heap m,
        let result := const_folding s m in
        let s' := fst (fst result) in
        Safe fs s (vs, heap) ->
        agree_with vs m ->
        Safe fs s' (vs, heap).
    Proof.
      induction s.

      Focus 4.
      intros.
      unfold_all.
      eapply
        (Safe_coind
           (fun s' v =>
              (exists c b m,
                 let s := While c b in
                 Safe fs s v /\
                 agree_with (fst v) m /\
                 (let s := b in
                  forall (vs : vals) (heap : Heap) (m : Map),
                    Safe fs s (vs, heap) ->
                    agree_with vs m -> Safe fs (fst (fst (const_folding s m))) (vs, heap)
                 ) /\
                 s' = fst (fst (const_folding s m))) \/
              Safe fs s' v
        )); [ .. | left; descend; intuition eauto ]; clear; simpl; intros; openhyp.

      (* seq *)
      simpl in *; openhyp'; simpl in *; intuition.

      inversion_clear H.
      intuition eauto.

      (* if *)
      simpl in *; openhyp'; simpl in *; intuition.

      inversion H; subst.
      openhyp.
      intuition eauto.
      right; intuition eauto.

      (* while *)
      simpl in *; openhyp'; simpl in *; intuition.
      injection H2; intros; subst.
      rewrite_expr.
      inversion H; unfold_all; subst.
      destruct v; simpl in *.
      left.
      repeat split.
      eauto.
      right.
      eauto.

      intros.
      left.
      destruct v'; simpl in *.
      eapply const_folding_is_backward_simulation in H3; eauto; openhyp.
      descend; intuition.
      simpl in *; openhyp'; [ contradict e; eauto | ]; simpl in *.
      eapply not_const_zero_empty_map; eauto.
      eauto.

      right.
      eauto.

      inversion H; unfold_all; subst.
      intuition eauto.
      right.
      intuition eauto.

      simpl in *; openhyp'; simpl in *; intuition.

      inversion H; unfold_all; subst.
      left.
      descend.
      intuition eauto.
      right.
      descend.
      intuition eauto.

      simpl in *; openhyp'; simpl in *; intuition.
      inversion_clear H; eauto.

      (* skip *)
      eauto.

      (* seq *)
      simpl; intros; inversion H; unfold_all; subst.
      econstructor.
      simpl in *.
      eapply IHs1; eauto.
      intros.
      destruct v'; simpl in *.
      eapply const_folding_is_backward_simulation in H1.
      openhyp.
      eapply IHs2; eauto.
      eauto.

      (* if *)
      simpl; intros; openhyp'.

      destruct (Sumbool.sumbool_of_bool (wneb x $0)); rewrite e1 in *; simpl in *.
      inversion H; subst.
      unfold_all.
      openhyp.
      eauto.
      erewrite <- const_folding_expr_correct' in H1.
      2 : symmetry; eauto.
      simpl in *.
      intuition.
      eauto.
      inversion H; subst.
      unfold_all.
      openhyp.
      erewrite <- const_folding_expr_correct' in H1.
      2 : symmetry; eauto.
      simpl in *.
      intuition.
      eauto.
      eauto.

      simpl in *.
      inversion H; subst.
      unfold_all.
      openhyp.
      econstructor.
      left.
      rewrite_expr.
      intuition eauto.
      eapply IHs1; eauto.
      econstructor.
      right.
      rewrite_expr.
      intuition eauto.
      eapply IHs2; eauto.

      (* call *)
      destruct o; simpl; intros; inversion H; unfold_all; subst.

      econstructor; rewrite_expr; rewrite_expr_list; eauto.
      rewrite map_length; eauto.

      eapply SafeCallForeign; rewrite_expr; eauto; rewrite_expr_list; eauto.

      econstructor; rewrite_expr; rewrite_expr_list; eauto.
      rewrite map_length; eauto.

      eapply SafeCallForeign; rewrite_expr; eauto; rewrite_expr_list; eauto.

      (* assign *)
      simpl; intros; simpl in *; openhyp'; simpl in *; eauto.

      (* label *)
      simpl; intros; simpl in *; openhyp'; simpl in *; eauto.

    Qed.

    Lemma PreserveSafe_opt : PreserveSafe opt.
      unfold PreserveSafe, opt, optimizer, constant_folding; intros.
      destruct v.
      eapply const_folding_is_safety_preservation in H; openhyp; eauto.
    Qed.

    Require Import Platform.Cito.FreeVarsExpr.

    Lemma const_folding_expr_footprint : forall e m, SS.Subset (free_vars (const_folding_expr e m)) (free_vars e).
    Proof.
      induction e; simpl; intros; openhyp'; simpl in *; subset_solver; eauto using subset_trans.
    Qed.
    Hint Resolve const_folding_expr_footprint.

    Lemma const_folding_expr_footprint_list : forall es m, SS.Subset (Union.union_list (List.map free_vars (List.map (fun e => const_folding_expr e m) es))) (Union.union_list (List.map free_vars es)).
    Proof.
      unfold Union.union_list.
      induction es; simpl; intuition eauto.
      subset_solver; eauto using subset_trans.
    Qed.

    Hint Resolve const_folding_expr_footprint_list.

    Require Import Platform.Cito.FreeVars.

    Lemma const_folding_footprint : forall s m, SS.Subset (free_vars (fst (fst (const_folding s m)))) (free_vars s).
    Proof.
      induction s; simpl; intros; openhyp'; simpl in *; subset_solver.
      eauto using subset_trans.
      eauto using subset_trans.
      destruct (Sumbool.sumbool_of_bool (wneb x $0)); rewrite e1 in *; simpl in *.
      eauto using subset_trans.
      eauto using subset_trans.
      eauto using subset_trans.
      eauto using subset_trans.
      eauto using subset_trans.
      eauto using subset_trans.
      eauto using subset_trans.
      destruct o; simpl in *.
      subset_solver; eauto using subset_trans.
      subset_solver; eauto using subset_trans.
      eauto using subset_trans.
    Qed.

    Lemma optimizer_footprint : forall s, SS.Subset (free_vars (optimizer s)) (free_vars s).
      unfold optimizer, constant_folding; intros; eapply const_folding_footprint.
    Qed.

    Open Scope nat.

    Require Import Coq.Arith.Le.
    Require Import Coq.Arith.Max.
    Require Import Platform.Cito.MaxFacts.

    Hint Resolve both_le Le.le_n_S.

    Require Import Platform.Cito.DepthExpr.

    Lemma const_folding_expr_depth : forall e m, depth (const_folding_expr e m) <= depth e.
    Proof.
      induction e; simpl; intuition; openhyp'; simpl in *; eauto.
    Qed.
    Hint Resolve const_folding_expr_depth.

    Lemma const_folding_expr_depth_list : forall es m, le (Max.max_list 0 (List.map depth (List.map (fun e => const_folding_expr e m) es))) (Max.max_list 0 (List.map depth es)).
    Proof.
      unfold Max.max_list.
      induction es; simpl; intuition eauto.
    Qed.

    Hint Resolve const_folding_expr_depth_list.

    Require Import Platform.Cito.Depth.

    Hint Extern 0 (le _ _) => progress (simpl; max_solver).

    Lemma const_folding_depth : forall s m, depth (fst (fst (const_folding s m))) <= depth s.
    Proof.
      induction s; simpl; intuition; openhyp'; simpl in *; eauto.

      destruct (Sumbool.sumbool_of_bool (wneb x $0)); rewrite e1 in *; simpl in *.
      eauto using le_trans.
      eauto using le_trans.
      destruct o; simpl in *.
      max_solver; eauto using le_trans.
      max_solver; eauto using le_trans.
    Qed.

    Lemma optimizer_depth : forall s, depth (optimizer s) <= depth s.
      unfold optimizer, constant_folding; intros; eapply const_folding_depth.
    Qed.

    Import NPeano.Nat.
    Require Import Platform.Cito.GetLocalVars.
    Require Import Platform.Cito.GetLocalVarsFacts.

    Lemma PreserveGoodSize_opt : PreserveGoodSize opt.
      unfold PreserveGoodSize, opt; intros.
      eapply goodSize_weaken; eauto.
      eapply add_le_mono.
      2 : eapply optimizer_depth.
      eapply get_local_vars_cardinal.
      eapply optimizer_footprint; eauto.
    Qed.

    Require Import Platform.Cito.CompileStmtSpec.
    Require Import Platform.Cito.SetoidListFacts.
    Require Import Platform.Cito.GeneralTactics2.

    Require Import Platform.Cito.WellFormed.

    Hint Constructors args_not_too_long.

    Lemma const_folding_wellformed : forall s m, wellformed s -> wellformed (fst (fst (const_folding s m))).
      unfold wellformed.
      induction s; simpl; intuition; openhyp'; inversion_clear H; simpl in *; eauto.
      destruct (Sumbool.sumbool_of_bool (wneb x $0)); rewrite e1 in *; simpl in *; eauto.
      destruct o; simpl in *; eauto; econstructor; eauto; rewrite map_length; eauto.
    Qed.

    Lemma PreserveSynReq_opt : PreserveSynReq opt.
      unfold PreserveSynReq, opt; intros.
      unfold syn_req in *.
      unfold in_scope in *.
      openhyp.
      repeat split; eauto.
      eapply get_local_vars_subset; eauto.
      eapply const_folding_wellformed; eauto.
    Qed.

    Lemma good_optimizer : GoodOptimizer opt.
      unfold GoodOptimizer.
      split.
      eapply PreserveRunsTo_opt.
      split.
      eapply PreserveSafe_opt.
      split.
      eapply PreserveGoodSize_opt.
      eapply PreserveSynReq_opt.
    Qed.

  End TopSection.

End Make.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** RTL function inlining *)

Require Import Coqlib Wfsimpl Maps Errors Integers.
Require Import AST Linking.
Require Import Op Registers RTL.

(** ** Environment of inlinable functions *)

(** We maintain a mapping from function names to their definitions.
  In this mapping, we only include internal functions that are eligible for
  inlining, as determined by the external heuristic
  [should_inline]. *)

Definition funenv : Type := PTree.t function.

Definition size_fenv (fenv: funenv) := PTree_Properties.cardinal fenv.

Parameter should_inline: ident -> function -> bool.

Definition add_globdef (fenv: funenv) (idg: ident * globdef fundef unit) : funenv :=
  match idg with
  | (id, Gfun (Internal f)) =>
      if should_inline id f
      then PTree.set id f fenv
      else PTree.remove id fenv
  | (id, _) =>
      PTree.remove id fenv
  end.

Definition funenv_program (p: program) : funenv :=
  List.fold_left add_globdef p.(prog_defs) (PTree.empty function).

(** State monad *)

(** To construct incrementally the CFG of a function after inlining,
  we use a state monad similar to that used in module [RTLgen].
  It records the current state of the CFG, plus counters to generate
  fresh pseudo-registers and fresh CFG nodes.  It also records the
  stack size needed for the inlined function. *)

Record state : Type := mkstate {
  st_nextreg: positive;                 (**r last used pseudo-register *)
  st_nextnode: positive;                (**r last used CFG node *)
  st_code: code;                        (**r current CFG  *)
  st_stksize: Z                         (**r current stack size *)
}.

(** Monotone evolution of the state. *)

Inductive sincr (s1 s2: state) : Prop :=
  Sincr (NEXTREG: Ple s1.(st_nextreg) s2.(st_nextreg))
        (NEXTNODE: Ple s1.(st_nextnode) s2.(st_nextnode))
        (STKSIZE: s1.(st_stksize) <= s2.(st_stksize)).

Remark sincr_refl: forall s, sincr s s.
Proof.
  intros; constructor; xomega.
Qed.

Lemma sincr_trans: forall s1 s2 s3, sincr s1 s2 -> sincr s2 s3 -> sincr s1 s3.
Proof.
  intros. inv H; inv H0. constructor; xomega.
Qed.

(** Dependently-typed state monad, ensuring that the final state is
  greater or equal (in the sense of predicate [sincr] above) than
  the initial state. *)

Inductive res {A: Type} {s: state}: Type := R (x: A) (s': state) (I: sincr s s').

Definition mon (A: Type) : Type := forall (s: state), @res A s.

(** Operations on this monad. *)

Definition ret {A: Type} (x: A): mon A :=
  fun s => R x s (sincr_refl s).

Definition bind {A B: Type} (x: mon A) (f: A -> mon B): mon B :=
  fun s1 => match x s1 with R vx s2 I1 =>
              match f vx s2 with R vy s3 I2 =>
                R vy s3 (sincr_trans s1 s2 s3 I1 I2)
              end
            end.

Notation "'do' X <- A ; B" := (bind A (fun X => B))
   (at level 200, X ident, A at level 100, B at level 200).

Definition initstate :=
  mkstate 1%positive 1%positive (PTree.empty instruction) 0.

Program Definition set_instr (pc: node) (i: instruction): mon unit :=
  fun s =>
    R tt
      (mkstate s.(st_nextreg) s.(st_nextnode) (PTree.set pc i s.(st_code)) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition add_instr (i: instruction): mon node :=
  fun s =>
    let pc := s.(st_nextnode) in
    R pc
      (mkstate s.(st_nextreg) (Psucc pc) (PTree.set pc i s.(st_code)) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition reserve_nodes (numnodes: positive): mon positive :=
  fun s =>
    R s.(st_nextnode)
      (mkstate s.(st_nextreg) (Pplus s.(st_nextnode) numnodes) s.(st_code) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition reserve_regs (numregs: positive): mon positive :=
  fun s =>
    R s.(st_nextreg)
      (mkstate (Pplus s.(st_nextreg) numregs) s.(st_nextnode) s.(st_code) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition request_stack (sz: Z): mon unit :=
  fun s =>
    R tt
      (mkstate s.(st_nextreg) s.(st_nextnode) s.(st_code) (Zmax s.(st_stksize) sz))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition ptree_mfold {A: Type} (f: positive -> A -> mon unit) (t: PTree.t A): mon unit :=
  fun s =>
    R tt
      (PTree.fold (fun s1 k v => match f k v s1 return _ with R _ s2 _ => s2 end) t s)
      _.
Next Obligation.
  apply PTree_Properties.fold_rec.
  auto.
  apply sincr_refl.
  intros. destruct (f k v a). eapply sincr_trans; eauto.
Qed.

(** ** Inlining contexts *)

(** A context describes how to insert the CFG for a source function into
  the CFG for the function after inlining:
- a source instruction at PC [n] is relocated to PC [n + ctx.(dpc)];
- all pseudo-registers of this instruction are shifted by [ctx.(dreg)];
- all stack references are shifted by [ctx.(dstk)];
- "return" instructions are transformed into "return" or "move" instructions
  as governed by [ctx.(retinfo)].
*)

Record context: Type := mkcontext {
  dpc: positive;                        (**r offset for PCs *)
  dreg: positive;                       (**r offset for pseudo-regs *)
  dstk: Z;                              (**r offset for stack references *)
  mreg: positive;                       (**r max pseudo-reg number *)
  mstk: Z;                              (**r original stack block size *)
  retinfo: option(node * reg)           (**r where to branch on return *)
                                        (**r and deposit return value *)
}.

(** The following functions "shift" (relocate) PCs, registers, operations, etc. *)

Definition shiftpos (p amount: positive) := Ppred (Pplus p amount).

Definition spc (ctx: context) (pc: node) := shiftpos pc ctx.(dpc).

Definition sreg (ctx: context) (r: reg) := shiftpos r ctx.(dreg).

Definition sregs (ctx: context) (rl: list reg) := List.map (sreg ctx) rl.

Definition sros (ctx: context) (ros: reg + ident) := sum_left_map (sreg ctx) ros.

Definition sop (ctx: context) (op: operation) :=
  shift_stack_operation ctx.(dstk) op.

Definition saddr (ctx: context) (addr: addressing) :=
  shift_stack_addressing ctx.(dstk) addr.

Fixpoint sbuiltinarg (ctx: context) (a: builtin_arg reg) : builtin_arg reg :=
  match a with
  | BA x => BA (sreg ctx x)
  | BA_loadstack chunk ofs => BA_loadstack chunk (Ptrofs.add ofs (Ptrofs.repr ctx.(dstk)))
  | BA_addrstack ofs => BA_addrstack (Ptrofs.add ofs (Ptrofs.repr ctx.(dstk)))
  | BA_splitlong hi lo => BA_splitlong (sbuiltinarg ctx hi) (sbuiltinarg ctx lo)
  | _ => a
  end.

Definition sbuiltinres (ctx: context) (a: builtin_res reg) : builtin_res reg :=
  match a with
  | BR x => BR (sreg ctx x)
  | _    => BR_none
  end.

(** The initial context, used to copy the CFG of a toplevel function. *)

Definition initcontext (dpc dreg nreg: positive) (sz: Z) :=
  {| dpc := dpc;
     dreg := dreg;
     dstk := 0;
     mreg := nreg;
     mstk := Zmax sz 0;
     retinfo := None |}.

(** The context used to inline a call to another function. *)

Definition min_alignment (sz: Z) :=
  if zle sz 1 then 1
  else if zle sz 2 then 2
  else if zle sz 4 then 4 else 8.

Definition callcontext (ctx: context)
                      (dpc dreg nreg: positive) (sz: Z)
                      (retpc: node) (retreg: reg) :=
  {| dpc := dpc;
     dreg := dreg;
     dstk := align (ctx.(dstk) + ctx.(mstk)) (min_alignment sz);
     mreg := nreg;
     mstk := Zmax sz 0;
     retinfo := Some (spc ctx retpc, sreg ctx retreg) |}.

(** The context used to inline a tail call to another function. *)

Definition tailcontext (ctx: context) (dpc dreg nreg: positive) (sz: Z) :=
  {| dpc := dpc;
     dreg := dreg;
     dstk := align ctx.(dstk) (min_alignment sz);
     mreg := nreg;
     mstk := Zmax sz 0;
     retinfo := ctx.(retinfo) |}.

(** ** Recursive expansion and copying of a CFG *)

(** Insert "move" instructions to copy the arguments of an inlined
    function into its parameters. *)

Fixpoint add_moves (srcs dsts: list reg) (succ: node): mon node :=
  match srcs, dsts with
  | s1 :: sl, d1 :: dl =>
      do n <- add_instr (Iop Omove (s1 :: nil) d1 succ);
      add_moves sl dl n
  | _, _ =>
      ret succ
  end.

(** To prevent infinite inlining of a recursive function, when we
  inline the body of a function [f], this function is removed from the
  environment of inlinable functions and therefore becomes ineligible
  for inlining.  This decreases the size (number of entries) of the
  environment and guarantees termination.  Inlining is, therefore,
  presented as a well-founded recursion over the size of the environment. *)

Section EXPAND_CFG.

Variable fenv: funenv.

(** The [rec] parameter is the recursor: [rec fenv' P ctx f] copies
  the body of function [f], with inline expansion within, as governed
  by context [ctx].  It can only be called for function environments
  [fenv'] strictly smaller than the current environment [fenv]. *)

Variable rec: forall fenv', (size_fenv fenv' < size_fenv fenv)%nat -> context -> function -> mon unit.

(** Given a register-or-symbol [ros], can we inline the corresponding call? *)

Inductive inline_decision (ros: reg + ident) : Type :=
  | Cannot_inline
  | Can_inline (id: ident) (f: function) (P: ros = inr reg id) (Q: fenv!id = Some f).

Program Definition can_inline (ros: reg + ident): inline_decision ros :=
  match ros with
  | inl r => Cannot_inline _
  | inr id => match fenv!id with Some f => Can_inline _ id f _ _ | None => Cannot_inline _ end
  end.

(** Inlining of a call to function [f].  An appropriate context is
  created, then the CFG of [f] is recursively copied, then moves
  are inserted to copy the arguments of the call to the parameters of [f]. *)

Definition inline_function (ctx: context) (id: ident) (f: function)
                           (P: PTree.get id fenv = Some f)
                           (args: list reg)
                           (retpc: node) (retreg: reg) : mon node :=
  let npc := max_pc_function f in
  let nreg := max_reg_function f in
  do dpc <- reserve_nodes npc;
  do dreg <- reserve_regs nreg;
  let ctx' := callcontext ctx dpc dreg nreg f.(fn_stacksize) retpc retreg in
  do x <- rec (PTree.remove id fenv) (PTree_Properties.cardinal_remove P) ctx' f;
  add_moves (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)).

(** Inlining of a tail call to function [f].  Similar to [inline_function],
  but the new context is different. *)

Definition inline_tail_function (ctx: context) (id: ident) (f: function)
                               (P: PTree.get id fenv = Some f)
                               (args: list reg): mon node :=
  let npc := max_pc_function f in
  let nreg := max_reg_function f in
  do dpc <- reserve_nodes npc;
  do dreg <- reserve_regs nreg;
  let ctx' := tailcontext ctx dpc dreg nreg f.(fn_stacksize) in
  do x <- rec (PTree.remove id fenv) (PTree_Properties.cardinal_remove P) ctx' f;
  add_moves (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)).

(** The instruction generated for a [Ireturn] instruction found in an
  inlined function body. *)

Definition inline_return (ctx: context) (or: option reg) (retinfo: node * reg) :=
  match retinfo, or with
  | (retpc, retreg), Some r => Iop Omove (sreg ctx r :: nil) retreg retpc
  | (retpc, retreg), None   => Inop retpc
  end.

(** Expansion and copying of an instruction.  For most instructions,
  its registers and successor PC are shifted as per the context [ctx],
  then the instruction is inserted in the final CFG at its final position
  [spc ctx pc].

  [Icall] instructions are either replaced by a "goto" to the expansion
  of the called function, or shifted as described above.

  [Itailcall] instructions are similar, with one additional case.  If
  the [Itailcall] occurs in the body of an inlined function, and
  cannot be inlined itself, it must be turned into an [Icall]
  instruction that branches to the return point of the inlined
  function.

  Finally, [Ireturn] instructions within an inlined function are
  turned into a "move" or "goto" that stores the result, if any,
  into the destination register, then branches back to the successor
  of the inlined call. *)

Definition expand_instr (ctx: context) (pc: node) (i: instruction): mon unit :=
  match i with
  | Inop s =>
      set_instr (spc ctx pc) (Inop (spc ctx s))
  | Iop op args res s =>
      set_instr (spc ctx pc)
                (Iop (sop ctx op) (sregs ctx args) (sreg ctx res) (spc ctx s))
  | Iload chunk addr args dst s =>
      set_instr (spc ctx pc)
                (Iload chunk (saddr ctx addr) (sregs ctx args) (sreg ctx dst) (spc ctx s))
  | Istore chunk addr args src s =>
      set_instr (spc ctx pc)
                (Istore chunk (saddr ctx addr) (sregs ctx args) (sreg ctx src) (spc ctx s))
  | Icall sg ros args res s =>
      match can_inline ros with
      | Cannot_inline =>
          set_instr (spc ctx pc)
                    (Icall sg (sros ctx ros) (sregs ctx args) (sreg ctx res) (spc ctx s))
      | Can_inline id f P Q =>
          do n <- inline_function ctx id f Q args s res;
          set_instr (spc ctx pc) (Inop n)
      end
  | Itailcall sg ros args =>
      match can_inline ros with
      | Cannot_inline =>
          match ctx.(retinfo) with
          | None =>
              set_instr (spc ctx pc)
                        (Itailcall sg (sros ctx ros) (sregs ctx args))
          | Some(rpc, rreg) =>
              set_instr (spc ctx pc)
                        (Icall sg (sros ctx ros) (sregs ctx args) rreg rpc)
          end
      | Can_inline id f P Q =>
          do n <- inline_tail_function ctx id f Q args;
          set_instr (spc ctx pc) (Inop n)
      end
  | Ibuiltin ef args res s =>
      set_instr (spc ctx pc)
                (Ibuiltin ef (map (sbuiltinarg ctx) args) (sbuiltinres ctx res) (spc ctx s))
  | Icond cond args s1 s2 =>
      set_instr (spc ctx pc)
                (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2))
  | Ijumptable r tbl =>
      set_instr (spc ctx pc)
                (Ijumptable (sreg ctx r) (List.map (spc ctx) tbl))
  | Ireturn or =>
      match ctx.(retinfo) with
      | None =>
          set_instr (spc ctx pc) (Ireturn (option_map (sreg ctx) or))
      | Some rinfo =>
          set_instr (spc ctx pc) (inline_return ctx or rinfo)
      end
  end.

(** The expansion of a function [f] iteratively expands all its
  instructions, after recording how much stack it needs. *)

Definition expand_cfg_rec (ctx: context) (f: function): mon unit :=
  do x <- request_stack (ctx.(dstk) + ctx.(mstk));
  ptree_mfold (expand_instr ctx) f.(fn_code).

End EXPAND_CFG.

(** Here we "tie the knot" of the recursion, taking the fixpoint
  of [expand_cfg_rec]. *)

Definition expand_cfg := Fixm size_fenv expand_cfg_rec.

(** Start of the recursion: copy and inline function [f] in the
  initial context. *)

Definition expand_function (fenv: funenv) (f: function): mon context :=
  let npc := max_pc_function f in
  let nreg := max_reg_function f in
  do dpc <- reserve_nodes npc;
  do dreg <- reserve_regs nreg;
  let ctx := initcontext dpc dreg nreg f.(fn_stacksize) in
  do x <- expand_cfg fenv ctx f;
  ret ctx.

(** ** Inlining in functions and whole programs. *)

Local Open Scope string_scope.

(** Inlining can increase the size of the function's stack block.  We must
  make sure that the new size does not exceed [Ptrofs.max_unsigned], otherwise
  address computations within the stack would overflow and produce incorrect
  results. *)

Definition transf_function (fenv: funenv) (f: function) : Errors.res function :=
  let '(R ctx s _) := expand_function fenv f initstate in
  if zlt s.(st_stksize) Ptrofs.max_unsigned then
    OK (mkfunction f.(fn_sig)
                   (sregs ctx f.(fn_params))
                   s.(st_stksize)
                   s.(st_code)
                   (spc ctx f.(fn_entrypoint)))
  else
    Error(msg "Inlining: stack too big").

Definition transf_fundef (fenv: funenv) (fd: fundef) : Errors.res fundef :=
  AST.transf_partial_fundef (transf_function fenv) fd.

Definition transf_program (p: program): Errors.res program :=
  let fenv := funenv_program p in
  AST.transform_partial_program (transf_fundef fenv) p.


Inductive Vec (A:Set) : forall n1 n2:nat, Set :=
nil : Vec A 0 0.

Check Vec.
(*
Vec
     : Set -> nat -> nat -> Set

When we have cons, we will obviously need A_R.
We want to get rid of n1 and n2?
Why is that justified?
In the type of Vec, there is absolutely no difference between parameters and indices --
we can write another Vec of the same type where all of them are params or all
of them are indices.
Perhaps the principle is the difference between Sort and Type in the domain of Pi Type.
If so, we will not want to erase the indices_R of the following:

λ x.x : Type -> Type
the translation  is λ x1 x2 xr, xr. the input xr is crucial.

Another example below, which I dont understand.
*)

Inductive Monad  : Type -> Type :=
ret : forall T, Monad T.

(*
If we cannot erase the index here, we will be forced to keep the equalities
and implement the hard things anyway. So there is no advantage of trying
to enforce irrelevance over small type domains in function types, because
that seems ugly to implement, as discussed in this file
*)