(**********************************************************************)
(* 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                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                      Adding.v                                      *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

(*
Add LoadPath ".." as IntensionalLib.
*)
Require Import Arith Omega Max Bool List.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.SF_calculus.SF_Terms.
Require Import IntensionalLib.SF_calculus.SF_Tactics.
Require Import IntensionalLib.SF_calculus.SF_reduction.
Require Import IntensionalLib.SF_calculus.SF_Normal.
Require Import IntensionalLib.SF_calculus.SF_Closed.
Require Import IntensionalLib.SF_calculus.Substitution.
Require Import IntensionalLib.SF_calculus.SF_Eval.
Require Import IntensionalLib.SF_calculus.Star.
Require Import IntensionalLib.SF_calculus.Fixpoints.
Require Import IntensionalLib.SF_calculus.Extensions.
Require Import IntensionalLib.SF_calculus.Equal.
Require Import IntensionalLib.Closure_to_SF.Tagging.

(*  install Bignums !!!
From Bignums Require Import BigN.
*)

Ltac unfold_op := unfold pair, a_op, i_op, id, k_op, f_op, s_op.

Lemma pair_normal: forall M N, normal M -> normal N -> normal (pair M N).
Proof. intros; unfold_op; nf_out. Qed.

Lemma k_op_normal: forall M, normal M -> normal (App (App (Op Fop) (Op Fop)) M).
Proof. intros;  unfold_op; nf_out. Qed.

Ltac nf_out2 :=
match goal with
| |- normal (pair _ _) => apply pair_normal; nf_out2
| |- normal (App (App (Op Fop) (Op Fop)) _) => apply k_op_normal; nf_out2
| _ => nf_out
end.

(* pairing *)

Definition left_projection M := App (App (App (Op Fop) M) M) k_op.
Definition right_projection M := App (App (App (Op Fop) M) M) (App k_op i_op).
Definition fst_projection M := right_projection(left_projection M).
Definition snd_projection M := right_projection M.

Lemma fst_red : forall M N, sf_red (fst_projection (pair M N)) M.
Proof.
intros; unfold fst_projection, left_projection, right_projection.  unfold_op.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. auto. eapply succ_red.
eapply2 f_compound_red. eval_tac. eapply succ_red.
eapply2 f_compound_red. eval_tac. auto. eapply succ_red.
eapply2 f_compound_red. eval_tac. eval_tac.
Qed.

Lemma snd_red : forall M N, sf_red (snd_projection (pair M N)) N.
Proof.
intros; unfold snd_projection, left_projection, right_projection.  unfold_op.
eapply succ_red. eapply2 f_compound_red. eval_tac. eval_tac.
Qed.

Lemma fst_preserves_sf_red:
forall M N, sf_red M N -> sf_red (fst_projection M) (fst_projection N).
Proof.
intros; unfold fst_projection, left_projection, right_projection.
repeat eapply2 preserves_app_sf_red. Qed.

Lemma snd_preserves_sf_red:
forall M N, sf_red M N -> sf_red (snd_projection M) (snd_projection N).
Proof.
intros; unfold snd_projection, left_projection, right_projection.
repeat eapply2 preserves_app_sf_red. Qed.

Lemma subst_rec_preserves_left_projection :
forall M N k, subst_rec (left_projection M) N k = left_projection (subst_rec M N k).
Proof. intros; unfold left_projection. simpl. auto. Qed.

Lemma subst_rec_preserves_right_projection :
forall M N k, subst_rec (right_projection M) N k = right_projection (subst_rec M N k).
Proof. intros; unfold right_projection. simpl. auto. Qed.

Lemma subst_rec_preserves_fst_projection :
forall M N k, subst_rec (fst_projection M) N k = fst_projection (subst_rec M N k).
Proof.
intros; unfold fst_projection. rewrite subst_rec_preserves_right_projection.
rewrite subst_rec_preserves_left_projection. auto.
Qed.

Lemma subst_rec_preserves_snd_projection :
forall M N k, subst_rec (snd_projection M) N k = snd_projection (subst_rec M N k).
Proof.
intros; unfold snd_projection. apply subst_rec_preserves_right_projection.
Qed.

(* substitutions

[| Add x u sigma |] = A add (S (S sigma x) u) -- the order simplifies beta-reduction
add sigma t traverses t, looking for variables.
add sigma i traverses sigma, looking for i.

*)

Definition swap M N := App
  (App (Op Sop)
     (App
        (App (Op Sop)
           (App (App (Op Sop) (App (App (Op Fop) (Op Fop)) (Op Sop)))
              (App (App (Op Sop) (App (App (Op Fop) (Op Fop)) (App (Op Sop) (App (App (Op Fop) (Op Fop)) M))))
                 (App (Op Fop) (Op Fop)))))
        (App (App (Op Fop) (Op Fop)) (App (App (Op Sop) (App (Op Fop) (Op Fop))) (App (Op Fop) (Op Fop))))))
  (App (App (Op Fop) (Op Fop)) N)
.

Lemma swap_val: forall M N, swap M N =
App (App (Op Sop) (star_opt (app_comb (lift 1 M) (Ref 0)))) (App (App (Op Fop) (Op Fop)) N).
Proof.
intros; unfold swap, app_comb; unfold_op.
rewrite star_opt_occurs_true.
2: unfold occurs0; fold occurs0. 2: rewrite ! orb_true_r. 2: cbv; auto.
2: discriminate.
rewrite star_opt_occurs_true.
2: unfold occurs0; fold occurs0. 2: rewrite ! orb_true_r. 2: cbv; auto.
2: discriminate.
rewrite star_opt_occurs_true.
2: unfold occurs0; fold occurs0. 2: rewrite ! orb_true_r. 2: cbv; auto.
2: discriminate.
 rewrite star_opt_eta. 2: auto.
unfold star_opt at 1.
 rewrite star_opt_occurs_false.
2: simpl; unfold lift; rewrite occurs_lift_rec_zero; auto.
unfold_op; unfold lift, subst, subst_rec; fold subst_rec.
rewrite subst_rec_lift_rec; try omega.
rewrite lift_rec_null.
rewrite star_opt_closed; auto.
Qed.

Lemma subst_rec_preserves_swap:
forall M N P k, subst_rec (swap M N) P k = swap (subst_rec M P k) (subst_rec N P k).
Proof. intros; unfold swap, subst_rec; auto. Qed.

Lemma pattern_size_swap:
forall M N, pattern_size(swap M N) = pattern_size M + pattern_size N.
Proof. intros; unfold swap, pattern_size; fold pattern_size; omega.  Qed.

Lemma pattern_size_app_comb:
forall M N, pattern_size(app_comb M N) = pattern_size M + pattern_size N.
Proof. intros; unfold app_comb. unfold_op; unfold  pattern_size; fold pattern_size; omega.  Qed.

Definition star_opt_app_comb M N :=
App
  (App (Op Sop)
     (App (App (Op Sop) (App (App (Op Fop) (Op Fop)) (Op Sop)))
        (App (App (Op Sop) (App (App (Op Fop) (Op Fop)) (App (Op Sop) (App (App (Op Fop) (Op Fop)) M))))
           (App (App (Op Sop) (App (App (Op Fop) (Op Fop)) (App (Op Fop) (Op Fop)))) N))))
  (App (App (Op Fop) (Op Fop)) (App (App (Op Sop) (App (Op Fop) (Op Fop))) (App (Op Fop) (Op Fop)))) .

Lemma star_opt_app_comb_val:
forall M N, occurs0 N = true -> N <> Ref 0 -> star_opt (app_comb (lift 1 M) N) = star_opt_app_comb M (star_opt N).
Proof.
intros; unfold app_comb, lift; unfold_op.
rewrite star_opt_occurs_true. 2 : simpl; rewrite H; rewrite orb_true_r at 1; cbv; auto. 2: discriminate.
rewrite star_opt_occurs_true. 2 : simpl; rewrite H; rewrite orb_true_r at 1; cbv; auto. 2: discriminate.
unfold star_opt at 1.
rewrite star_opt_occurs_true. 2 : simpl; rewrite H; rewrite orb_true_r at 1; cbv; auto. 2: discriminate.
 rewrite star_opt_occurs_false. 2: unfold occurs0; fold occurs0; simpl.
2: rewrite occurs_lift_rec_zero; auto.
rewrite star_opt_occurs_true. 2 : simpl; rewrite H; auto. 2: auto.
rewrite star_opt_closed; auto.
rewrite (star_opt_closed (App (App (Op Sop) (App (Op Fop) (Op Fop))) (App (Op Fop) (Op Fop)))); auto.
unfold_op; unfold subst, subst_rec; fold subst_rec.
rewrite subst_rec_lift_rec; try omega.
rewrite lift_rec_null. auto.
Qed.

Lemma star_opt_app_comb_red:
forall M N P, sf_red (App (star_opt_app_comb M N) P) (app_comb M (App N P)).
Proof.
intros; unfold star_opt_app_comb, app_comb. eval_tac.  eval_tac.  eval_tac.
 eapply2 preserves_app_sf_red.  eapply2 preserves_app_sf_red. eval_tac.  eval_tac.
 eapply2 preserves_app_sf_red. eval_tac. eval_tac. eval_tac.
Qed.

Definition add_fn := star_opt (star_opt
(* recursion argument, ((sigma,x),u)  *)
(extension (app_comb (Ref 1) (Ref 0))
(* tag *)
        (App (extension (app_comb (Ref 1) (Ref 0))
                        (App (App (App (Ref 5) (Ref 4)) (Ref 1))
                             (App (App (Ref 5) (Ref 4)) (Ref 0)))
(* add *)
             (extension (App (App (Op Fop) (App (App (Op Fop) (Ref 2)) (Ref 1))) (Ref 0))
                        (app_comb (Ref 4)
                                  (App (App (Op Fop) (App (App (Op Fop)
                                                               (App (App (Ref 6) (Ref 5)) (Ref 2)))
                                                     (Ref 1)))
                                       (App (App (Ref 6) (Ref 5)) (Ref 0))))
(* var *)
             (App k_op (App (App (App (App equal_comb (Ref 0))
                                     (snd_projection (fst_projection (Ref 2)))) (* y = x *)
                               (snd_projection (Ref 2)))  (* u *)
                          (App (fst_projection (fst_projection (Ref 2)))
                               (app_comb (Ref 1) (Ref 0)))))
                                          (* sigma (var y) *)

 )) (Ref 0))

(* abs *)
(extension (App (App (Op Sop) (star_opt_app_comb (Ref 3)
                         (App (Op Fop) (pair (Ref 2) (Ref 1))))) (App k_op (Ref 0)))
           (App (App (Op Sop) (star_opt_app_comb (Ref 3)
                         (App (Op Fop) (pair (App (App (Ref 5) (Ref 4)) (Ref 2)) (Ref 1))))) (App k_op (Ref 0)))
(* Iop  *)
(fst_projection (fst_projection (Ref 0))))
)).

Definition add M :=  app_comb (app_comb (app_comb omega3 omega3) add_fn) M.

Definition abs sigma x t :=
App (App (Op Sop)  (star_opt_app_comb (app_comb (app_comb omega3 omega3) add_fn)
                         (App (Op Fop) (pair sigma x))))
    (App k_op t) .

Lemma Y3_to_add: forall sigma, sf_red (App (Y3 add_fn) sigma) (add sigma).
Proof.
intros. unfold Y3.
eapply transitive_red.  eapply2 star_opt_beta.
unfold subst; rewrite ! subst_rec_preserves_app_comb.
unfold lift; rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
rewrite ! (subst_rec_closed omega3). 2: unfold omega3; cbv; auto.
unfold subst_rec; fold subst_rec. insert_Ref_out.
unfold lift; rewrite lift_rec_null.
unfold add, add_fn; eapply2 zero_red.
Qed.

Lemma maxvar_add: forall M, maxvar (add M) = maxvar M.
Proof.
unfold add. intros. rewrite ! maxvar_app_comb.
replace (maxvar omega3) with 0 by (unfold omega3; cbv; auto).
replace (maxvar add_fn) with 0. simpl; omega.
unfold add_fn. rewrite ! maxvar_star_opt.
repeat (rewrite maxvar_extension; rewrite ? maxvar_app; rewrite ? maxvar_app_comb).
cbv.  auto.
Qed.

Lemma abs_red :
forall sigma x t u, sf_red (App (abs sigma x t) u)
                           (App (add (pair (pair sigma x) u)) t).
Proof.
intros; unfold abs. eval_tac.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 star_opt_app_comb_red. eval_tac.
eapply2 preserves_app_sf_red.
Qed.

Lemma lift_rec_preserves_Y3: forall M n k, lift_rec (Y3 M) n k = Y3 (lift_rec M n k).
Proof.
intros. unfold Y3.  rewrite lift_rec_preserves_star_opt.
rewrite ! lift_rec_preserves_app_comb.
unfold lift; rewrite lift_lift_rec; try omega.
rewrite ! (lift_rec_closed omega3).  unfold  lift_rec; fold lift_rec. relocate_lt.  auto.
unfold omega3; cbv; auto.
Qed.

Lemma add_red_tag:
forall sigma M N, sf_red (App (add sigma) (tag M N))
                         (App (App (add sigma) M)
                              (App (add sigma) N)).
Proof.
intros. unfold add at 1.
eapply transitive_red. eapply2 app_comb_red.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 app_comb_red. auto.
eapply transitive_red. eapply preserves_app_sf_red.  eapply preserves_app_sf_red.
eapply2 app_comb_red. auto. auto.
eapply transitive_red. eapply preserves_app_sf_red.  eapply2 omega3_omega3. auto.
(* 1 *)
unfold add_fn.
eapply transitive_red. eapply  preserves_app_sf_red.
eapply2 star_opt_beta2. auto.
unfold subst; rewrite ! subst_rec_preserves_extension.
(* an app_comb *)
eapply transitive_red.
 eapply2 extensions_by_matching.
unfold tag, var.
unfold app_comb; unfold_op. eapply2 match_app.
eapply2 match_app. eapply2 match_app.
eapply2 match_app. eapply2 match_app.
(* 1 *)
unfold map, app, length, fold_left, subst.
unfold subst_rec; fold subst_rec.
rewrite ! subst_rec_preserves_extension.
rewrite ! subst_rec_app.
(* an app_comb *)
eapply transitive_red.
 eapply2 extensions_by_matching.
repeat (rewrite ? subst_rec_ref; insert_Ref_out).
unfold lift; rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
unfold app_comb; unfold_op. eapply2 match_app.
eapply2 match_app. eapply2 match_app.
eapply2 match_app. eapply2 match_app.
(* 1 *)
unfold map, app, length, fold_left, subst.
rewrite ! subst_rec_app.
rewrite ! pattern_size_app_comb.
unfold pattern_size; fold pattern_size. unfold plus.
do 6 (rewrite subst_rec_ref at 1; insert_Ref_out; unfold pred).
unfold lift; rewrite 4? subst_rec_lift_rec; try omega.
rewrite lift_rec_preserves_Y3.
(* tidying up *)
rewrite ! lift_rec_lift_rec; try omega. unfold plus.
rewrite ! subst_rec_lift_rec; try omega.
unfold lift; rewrite ! lift_rec_null.
(* 1 *)
do 3 (rewrite subst_rec_ref; insert_Ref_out).
do 7 (rewrite subst_rec_ref at 1; insert_Ref_out).
(rewrite subst_rec_ref at 1; insert_Ref_out).
unfold lift; rewrite ! lift_rec_lift_rec; try omega. unfold plus.
rewrite ! subst_rec_lift_rec; try omega.
unfold lift; rewrite ! lift_rec_null.
unfold subst_rec; fold subst_rec.
(* 1 *)
replace (star_opt (star_opt
(* recursion argument, ((sigma,x),u)  *)
(extension (app_comb (Ref 1) (Ref 0))
(* tag *)
        (App (extension (app_comb (Ref 1) (Ref 0))
                        (App (App (App (Ref 5) (Ref 4)) (Ref 1))
                             (App (App (Ref 5) (Ref 4)) (Ref 0)))
(* add *)
             (extension (App (App (Op Fop) (App (App (Op Fop) (Ref 2)) (Ref 1))) (Ref 0))
                        (app_comb (Ref 4)
                                  (App (App (Op Fop) (App (App (Op Fop)
                                                               (App (App (Ref 6) (Ref 5)) (Ref 2)))
                                                     (Ref 1)))
                                       (App (App (Ref 6) (Ref 5)) (Ref 0))))
(* var *)
             (App k_op (App (App (App (App equal_comb (Ref 0))
                                     (snd_projection (fst_projection (Ref 2)))) (* y = x *)
                               (snd_projection (Ref 2)))  (* u *)
                          (App (fst_projection (fst_projection (Ref 2)))
                               (app_comb (Ref 1) (Ref 0)))))
                                          (* sigma (var y) *)

 )) (Ref 0))

(* abs *)
(extension (App (App (Op Sop) (star_opt_app_comb (Ref 3)
                         (App (Op Fop) (pair (Ref 2) (Ref 1))))) (App k_op (Ref 0)))
           (App (App (Op Sop) (star_opt_app_comb (Ref 3)
                         (App (Op Fop) (pair (App (App (Ref 5) (Ref 4)) (Ref 2)) (Ref 1))))) (App k_op (Ref 0)))
(* Iop  *)
(fst_projection (fst_projection (Ref 0))))
))
)
with add_fn by auto.
apply preserves_app_sf_red;
apply preserves_app_sf_red;
try (eapply2 zero_red; fail);
apply Y3_to_add.
Qed.

Lemma add_red_var_unequal:
forall i u sigma j, program i -> program j -> i <> j ->
matchfail (app_comb (Ref 1) (Ref 0)) j ->
matchfail  (App (App (Op Fop) (App (App (Op Fop) (Ref 2)) (Ref 1))) (Ref 0)) j ->
sf_red (App (add (pair (pair sigma i) u)) (var j)) (App sigma (var j)).
Proof.
intros. unfold_op;  unfold add at 1.
eapply transitive_red. eapply2 app_comb_red.
eapply transitive_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 omega3_omega3. auto.
(* 1 *)
unfold add_fn.
eapply transitive_red.
eapply preserves_app_sf_red.  eapply2 star_opt_beta2. auto.
unfold subst; rewrite ! subst_rec_preserves_extension.
eapply transitive_red. eapply2 extensions_by_matching.
unfold var, var_fn, app_comb; unfold_op.
 eapply2 match_app.
eapply2 match_app. eapply2 match_app.
eapply2 match_app. eapply2 match_app.
(* 1 *)
unfold map, app, length, fold_left, subst.
unfold subst_rec; fold subst_rec.
rewrite ! subst_rec_preserves_extension.
rewrite ! subst_rec_app.
(* not an app_comb *)
eapply transitive_red.
 eapply2 extensions_by_matchfail.
repeat (rewrite ? subst_rec_ref; insert_Ref_out).
unfold lift; rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null. auto.
(* not a pair *)
eapply transitive_red.
 eapply2 extensions_by_matchfail.
repeat (rewrite ? subst_rec_ref; insert_Ref_out).
unfold lift; rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null. auto.
(* 1 *)
rewrite ! (subst_rec_closed k_op); unfold_op; auto.
eapply succ_red. eapply2 f_op_red.
rewrite ! (subst_rec_closed equal_comb); auto.
rewrite ! pattern_size_app_comb.
unfold pattern_size; fold pattern_size. unfold plus.
do 3 (rewrite subst_rec_ref at 1; insert_Ref_out; unfold pred).
unfold lift; rewrite lift_rec_null;
rewrite 4? subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
rewrite ! subst_rec_preserves_snd_projection.
rewrite ! subst_rec_preserves_fst_projection.
do 3 (rewrite subst_rec_ref at 1; insert_Ref_out).
unfold lift; rewrite ! lift_rec_lift_rec; try omega. unfold plus.
rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
(* 1 *)
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. auto.
eapply snd_preserves_sf_red. eapply2 fst_red. eapply2 snd_red.
eapply preserves_app_sf_red.
eapply transitive_red.
eapply fst_preserves_sf_red. eapply2 fst_red. eapply2 fst_red. auto.
(* 1 *)
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply2 zero_red. eapply2 snd_red. auto. eapply2 zero_red.
(* 1 *)
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 unequal_programs. auto. eapply2 zero_red.  eval_tac. eval_tac.
eapply preserves_app_sf_red. auto.
insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null. eapply2 zero_red.
Qed.

Lemma add_red_var_equal:
forall i u sigma, program i ->
matchfail (app_comb (Ref 1) (Ref 0)) i ->
matchfail  (App (App (Op Fop) (App (App (Op Fop) (Ref 2)) (Ref 1))) (Ref 0)) i ->
sf_red (App (add (pair (pair sigma i) u)) (var i)) u.
Proof.
intros. unfold_op;  unfold add at 1.
eapply transitive_red. eapply2 app_comb_red.
eapply transitive_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 omega3_omega3. auto.
(* 1 *)
unfold add_fn.
eapply transitive_red.
eapply preserves_app_sf_red.  eapply2 star_opt_beta2. auto.
unfold subst; rewrite ! subst_rec_preserves_extension.
eapply transitive_red. eapply2 extensions_by_matching.
unfold var, var_fn, app_comb; unfold_op.
 eapply2 match_app.
eapply2 match_app. eapply2 match_app.
eapply2 match_app. eapply2 match_app.
(* 1 *)
unfold map, app, length, fold_left, subst.
unfold subst_rec; fold subst_rec.
rewrite ! subst_rec_preserves_extension.
rewrite ! subst_rec_app.
(* not an app_comb *)
eapply transitive_red.
 eapply2 extensions_by_matchfail.
repeat (rewrite ? subst_rec_ref; insert_Ref_out).
unfold lift; rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null. auto.
(* not a pair *)
eapply transitive_red.
 eapply2 extensions_by_matchfail.
repeat (rewrite ? subst_rec_ref; insert_Ref_out).
unfold lift; rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null. auto.
(* 1 *)
rewrite ! (subst_rec_closed k_op); unfold_op; auto.
eapply succ_red. eapply2 f_op_red.
rewrite ! (subst_rec_closed equal_comb); auto.
rewrite ! pattern_size_app_comb.
unfold pattern_size; fold pattern_size. unfold plus.
do 3 (rewrite subst_rec_ref at 1; insert_Ref_out; unfold pred).
unfold lift; rewrite lift_rec_null;
rewrite 4? subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
rewrite ! subst_rec_preserves_snd_projection.
rewrite ! subst_rec_preserves_fst_projection.
do 3 (rewrite subst_rec_ref at 1; insert_Ref_out).
unfold lift; rewrite ! lift_rec_lift_rec; try omega. unfold plus.
rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
(* 1 *)
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply2 zero_red.
eapply snd_preserves_sf_red. eapply2 fst_red. eapply2 snd_red.
eapply preserves_app_sf_red.
eapply transitive_red.
eapply fst_preserves_sf_red. eapply2 fst_red. eapply2 fst_red. auto.
(* 1 *)
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply2 zero_red. eapply2 snd_red. auto. eapply2 zero_red.
(* 1 *)
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 equal_programs. auto. eapply2 zero_red.  eval_tac.
Qed.

Lemma add_red_abs :
forall sigma x t sigma2,
  sf_red (App (add sigma2) (abs sigma x t))
         (abs (App (add sigma2) sigma) x t).
Proof.
intros. unfold add at 1.
eapply transitive_red. eapply2 app_comb_red.
eapply transitive_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 omega3_omega3. auto.
(* 1 *)
unfold add_fn.
eapply transitive_red.
eapply preserves_app_sf_red.  eapply2 star_opt_beta2. auto.
unfold subst; rewrite ! subst_rec_preserves_extension.
eapply transitive_red. eapply2 extensions_by_matchfail.
(* abs not an app_comb *)
unfold abs, star_opt_app_comb, app_comb; unfold_op.
eapply2 matchfail_compound_l.
eapply2 matchfail_compound_r.
eapply2 matchfail_compound_l.
eapply2 matchfail_compound_r.
eapply2 matchfail_compound_l.
eapply2 matchfail_compound_l.
eapply2 matchfail_op. unfold factorable; eauto. discriminate.
(* an abs *)
eapply transitive_red. eapply2 extensions_by_matching.
unfold abs, star_opt_app_comb, pair.
eapply2 match_app.  eapply2 match_app.
eapply2 match_app. eapply2 match_app.
eapply2 match_app. eapply2 match_app.
eapply2 match_app.  eapply2 match_app.
eapply2 match_app. eapply2 match_app.
eapply2 match_app. eapply2 match_app.
eapply2 program_matching. split; auto.
repeat eapply2 match_app.
eapply2 program_matching. split; auto.
unfold_op. repeat eapply2 match_app.
unfold map, app, length, fold_left, subst.
(* 1 *)
unfold star_opt_app_comb; unfold_op; unfold pattern_size; fold pattern_size.
unfold plus.
rewrite 12?  subst_rec_app.
rewrite 12?  subst_rec_op.
rewrite 12?  subst_rec_app.
rewrite 12?  subst_rec_op.
rewrite 12?  subst_rec_app.
rewrite 12?  subst_rec_op.
rewrite 12?  subst_rec_app.
rewrite 12?  subst_rec_op.
rewrite 12?  subst_rec_app.
rewrite 12?  subst_rec_op.
rewrite 12?  subst_rec_app.
rewrite 12?  subst_rec_op.
rewrite 12?  subst_rec_app.
rewrite 12?  subst_rec_op.
rewrite 12?  subst_rec_app.
rewrite 12?  subst_rec_op.
unfold lift; rewrite ! lift_rec_null.
repeat (rewrite subst_rec_ref; insert_Ref_out).
rewrite 12?  subst_rec_app.
rewrite 12?  subst_rec_op.
rewrite 12?  subst_rec_app.
rewrite 12?  subst_rec_op.
rewrite 12?  subst_rec_app.
rewrite 12?  subst_rec_op.
rewrite 12?  subst_rec_app.
do 12 (rewrite subst_rec_ref at 1; insert_Ref_out).
unfold lift; rewrite ! lift_rec_lift_rec; try omega.
unfold plus.
rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
rewrite 12?  subst_rec_app.
rewrite 12?  subst_rec_op.
rewrite 12?  subst_rec_app.
rewrite 12?  subst_rec_op.
rewrite 12?  subst_rec_app.
rewrite 12?  subst_rec_op.
rewrite 12?  subst_rec_app.
rewrite 12?  subst_rec_op.
repeat (rewrite subst_rec_ref; insert_Ref_out).
unfold lift; rewrite ! lift_rec_lift_rec; try omega.
unfold plus.
rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
unfold abs.
apply preserves_app_sf_red. apply preserves_app_sf_red. auto. 2: eapply2 zero_red.
apply preserves_app_sf_red. apply preserves_app_sf_red. auto. 2: eapply2 zero_red.
apply preserves_app_sf_red. eapply2 zero_red.
apply preserves_app_sf_red. eapply2 zero_red.
apply preserves_app_sf_red. eapply2 zero_red.
apply preserves_app_sf_red. auto.
apply preserves_app_sf_red. 2: auto.
apply preserves_app_sf_red. auto.
apply preserves_app_sf_red. 2: auto.
(* 1 *)
replace ((star_opt
           (star_opt
              (extension (app_comb (Ref 1) (Ref 0))
                 (App
                    (extension (app_comb (Ref 1) (Ref 0))
                       (App (App (App (Ref 5) (Ref 4)) (Ref 1)) (App (App (Ref 5) (Ref 4)) (Ref 0)))
                       (extension (App (App (Op Fop) (App (App (Op Fop) (Ref 2)) (Ref 1))) (Ref 0))
                          (app_comb (Ref 4)
                             (App
                                (App (Op Fop)
                                   (App (App (Op Fop) (App (App (Ref 6) (Ref 5)) (Ref 2))) (Ref 1)))
                                (App (App (Ref 6) (Ref 5)) (Ref 0))))
                          (App (App (Op Fop) (Op Fop))
                             (App
                                (App
                                   (App (App equal_comb (Ref 0))
                                      (snd_projection (fst_projection (Ref 2))))
                                   (snd_projection (Ref 2)))
                                (App (fst_projection (fst_projection (Ref 2)))
                                   (app_comb (Ref 1) (Ref 0))))))) (Ref 0))
                 (extension
                    (App
                       (App (Op Sop)
                          (App
                             (App (Op Sop)
                                (App (App (Op Sop) (App (App (Op Fop) (Op Fop)) (Op Sop)))
                                   (App
                                      (App (Op Sop)
                                         (App (App (Op Fop) (Op Fop))
                                            (App (Op Sop) (App (App (Op Fop) (Op Fop)) (Ref 3)))))
                                      (App
                                         (App (Op Sop)
                                            (App (App (Op Fop) (Op Fop)) (App (Op Fop) (Op Fop))))
                                         (App (Op Fop) (App (App (Op Fop) (Ref 2)) (Ref 1)))))))
                             (App (App (Op Fop) (Op Fop))
                                (App (App (Op Sop) (App (Op Fop) (Op Fop))) (App (Op Fop) (Op Fop))))))
                       (App (App (Op Fop) (Op Fop)) (Ref 0)))
                    (App
                       (App (Op Sop)
                          (App
                             (App (Op Sop)
                                (App (App (Op Sop) (App (App (Op Fop) (Op Fop)) (Op Sop)))
                                   (App
                                      (App (Op Sop)
                                         (App (App (Op Fop) (Op Fop))
                                            (App (Op Sop) (App (App (Op Fop) (Op Fop)) (Ref 3)))))
                                      (App
                                         (App (Op Sop)
                                            (App (App (Op Fop) (Op Fop)) (App (Op Fop) (Op Fop))))
                                         (App (Op Fop)
                                            (App (App (Op Fop) (App (App (Ref 5) (Ref 4)) (Ref 2)))
                                               (Ref 1)))))))
                             (App (App (Op Fop) (Op Fop))
                                (App (App (Op Sop) (App (Op Fop) (Op Fop))) (App (Op Fop) (Op Fop))))))
                       (App (App (Op Fop) (Op Fop)) (Ref 0)))
                    (fst_projection (fst_projection (Ref 0))))))))

with add_fn by auto.
eapply2 Y3_to_add.
Qed.

Ltac nf_out :=
  unfold_op;
  match goal with
    | |- normal ?M =>
      match M with
         | app_comb _ _ => apply app_comb_normal; nf_out
          | App (App (Op _) _) _ => apply nf_compound; [| |auto]; nf_out
          | App (Op _) _ => apply nf_compound; [| |auto]; nf_out
          | _ => try apply nf_op
      end
    | _ => auto
        end.

Lemma add_fn_normal: normal add_fn.
Proof.
eapply2 pattern_normal_zero.
unfold add_fn. replace 0 with (pred (pred 2)) by omega.
repeat apply pattern_normal_star_opt. unfold pred.
apply extension_pattern_normal.
eapply2 pnf_break. 3: cbv; omega.
eapply2 pnf_break. 3: cbv; omega.  3: cbv; eapply2 pnf_normal.
eapply2 pnf_normal. cbv.  nf_out; eapply2 nf_active.
replace (pattern_size (app_comb (Ref 1) (Ref 0)) + 2) with 4 by (cbv; auto).
eapply2 pnf_break.
eapply2 pnf_normal. unfold_op; auto.
2: cbv; auto.
(* 2 *)
apply extension_pattern_normal.
eapply2 pattern_normal_app_comb.
eapply2 pnf_normal.
eapply2 pnf_normal. nf_out. eapply2 nf_active. auto. eapply2 nf_active.
eapply2 pnf_break. 3: cbv; auto.
unfold_op; eapply2 pnf_normal.
eapply2 pnf_break. 3: cbv; auto.
eapply2 pnf_break. 3: cbv; auto.
eapply2 pnf_break. 3: cbv; auto.
eapply2 pnf_break.
eapply2 pnf_normal.
eapply2 equal_comb_normal.
eapply2 pnf_normal.
unfold snd_projection, fst_projection, left_projection, right_projection.
eapply2 pnf_normal. repeat (nf_out; eapply2 nf_active).
eapply2 pnf_normal.
unfold snd_projection, fst_projection, left_projection, right_projection.
repeat (nf_out; eapply2 nf_active).
eapply2 pnf_normal.
unfold app_comb, snd_projection, fst_projection, left_projection, right_projection.
repeat (nf_out; eapply2 nf_active). nf_out. auto. auto.
(* 1 *)
eapply2 pnf_normal. eapply2 extension_normal. unfold star_opt_app_comb; nf_out.
auto. eapply2 nf_active. auto. auto; nf_out. nf_out.
unfold fst_projection, left_projection, right_projection; nf_out.
eapply2 nf_active. repeat (nf_out; eapply2 nf_active).
nf_out.
Qed.

Lemma add_normal: forall f, normal f -> normal (add f).
Proof.
unfold add. intros.  apply app_comb_normal. 2: auto.
apply app_comb_normal. 2: apply add_fn_normal.
apply app_comb_normal; eapply2 omega3_program.
Qed.

Lemma abs_normal:
forall sigma x t, normal sigma -> normal x -> normal t -> normal (abs sigma x t).
Proof.
intros. unfold abs, star_opt_app_comb. unfold_op.
apply nf_compound. 2: nf_out; auto. 2: auto.
apply nf_compound. auto. 2: auto.
apply nf_compound. 2: nf_out; auto. 2: auto.
apply nf_compound. auto. 2: auto.
apply nf_compound. auto. 2: auto.
apply nf_compound. 2: nf_out; auto. 2: auto.
apply nf_compound. auto. 2: auto.
apply nf_compound. auto. 2: auto.
apply nf_compound. auto. 2: auto.
apply nf_compound. auto. 2: auto.
apply app_comb_normal. 2: apply add_fn_normal.
apply app_comb_normal; eapply2 omega3_program.
Qed.

Lemma add_red_add:
forall sigma sigma2 y v,
sf_red (App (add sigma) (add (pair (pair sigma2 y) v)))
        (add (pair (pair (App (add sigma) sigma2) y)
                   (App (add sigma) v))).
Proof.
intros. unfold add at 1.
eapply transitive_red. eapply2 app_comb_red.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 app_comb_red. auto.
eapply transitive_red. eapply preserves_app_sf_red.  eapply preserves_app_sf_red.
eapply2 app_comb_red. auto. auto.
eapply transitive_red. eapply preserves_app_sf_red.  eapply2 omega3_omega3. auto.
(* 1 *)
unfold add_fn.
eapply transitive_red. eapply  preserves_app_sf_red.
eapply2 star_opt_beta2. auto.
unfold subst; rewrite ! subst_rec_preserves_extension.
(* an app_comb *)
eapply transitive_red.
 eapply2 extensions_by_matching.
unfold add.
unfold app_comb; unfold_op. eapply2 match_app.
eapply2 match_app. eapply2 match_app.
eapply2 match_app. eapply2 match_app.
(* 1 *)
unfold map, app, length, fold_left, subst.
unfold subst_rec; fold subst_rec.
rewrite ! subst_rec_preserves_extension.
rewrite ! subst_rec_app.
insert_Ref_out.
(* not a tag *)
eapply transitive_red. apply extensions_by_matchfail.
repeat (rewrite subst_rec_ref; insert_Ref_out).
unfold lift; rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite lift_rec_null.
unfold app_comb. unfold_op.
eapply2 matchfail_compound_l.
eapply2 matchfail_compound_l.
eapply2 matchfail_op. left; eauto. discriminate.
(* 1  not a var *)
rewrite ! subst_rec_preserves_app_comb.
rewrite ! pattern_size_app_comb.
unfold pattern_size; fold pattern_size. unfold plus; fold plus.
repeat (rewrite subst_rec_ref; insert_Ref_out).
unfold lift; rewrite ! lift_rec_null.
eapply transitive_red. eapply extensions_by_matching.
rewrite subst_rec_lift_rec; try omega.
rewrite lift_rec_null.
repeat eapply2 match_app.
unfold map, app, length, fold_left, subst.
rewrite ! subst_rec_preserves_app_comb.
rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
rewrite ! subst_rec_app. rewrite ! subst_rec_op.
do 12 (rewrite subst_rec_ref at 1; insert_Ref_out).
do 12 (rewrite subst_rec_ref at 1; insert_Ref_out).
unfold lift; rewrite ! lift_rec_lift_rec; try omega. unfold plus.
rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
unfold add. apply preserves_app_sf_red.
apply preserves_app_sf_red. auto. 2: auto.
apply preserves_app_sf_red. auto.
unfold pair; apply preserves_app_sf_red. auto.
  apply preserves_app_sf_red.
 apply preserves_app_sf_red. auto.
 apply preserves_app_sf_red. 2: auto.
 apply preserves_app_sf_red. auto.
 apply preserves_app_sf_red. 2: auto.
(* 2 *)
unfold Y3. eapply transitive_red. eapply2 star_opt_beta.
unfold subst. rewrite ! subst_rec_preserves_app_comb.
rewrite ! (subst_rec_closed omega3). 2: cbv; auto.
unfold lift; rewrite subst_rec_lift_rec; try omega.
unfold subst_rec. insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
unfold add_fn; auto.
(* 1 *)
 apply preserves_app_sf_red. 2: auto.
unfold Y3. eapply transitive_red. eapply2 star_opt_beta.
unfold subst. rewrite ! subst_rec_preserves_app_comb.
rewrite ! (subst_rec_closed omega3). 2: cbv; auto.
unfold lift; rewrite subst_rec_lift_rec; try omega.
unfold subst_rec. insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
unfold add_fn; auto.
Qed.

Lemma add_red_empty:
forall sigma,
sf_red (App (add sigma) i_op) (App (fst_projection (fst_projection sigma)) i_op) .
Proof.
intros. unfold add at 1.
eapply transitive_red. eapply2 app_comb_red.
eapply transitive_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 omega3_omega3. auto.
(* 1 *)
unfold add_fn.
eapply transitive_red.
eapply preserves_app_sf_red.  eapply2 star_opt_beta2. auto.
unfold subst; rewrite ! subst_rec_preserves_extension.
eapply transitive_red. eapply2 extensions_by_matchfail.
(* Iop not an app_comb *)
unfold app_comb; unfold_op.
eapply2 matchfail_compound_l.
(* Iop not an abs *)
eapply transitive_red. eapply2 extensions_by_matchfail.
eapply2 matchfail_compound_l.
eapply2 matchfail_compound_r.    unfold_op; auto.
unfold star_opt_app_comb.
eapply2 matchfail_compound_l.
eapply2 matchfail_compound_op.
(* 1 *)
rewrite ! subst_rec_preserves_fst_projection.
 repeat (unfold subst_rec; fold subst_rec; insert_Ref_out).
unfold lift; rewrite ! lift_rec_lift_rec; try omega. unfold plus.
rewrite ! subst_rec_lift_rec; try omega. rewrite ! lift_rec_null.  auto.
Qed.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import syntax_ott
               rules_inf
               rulesb_inf
               Typing_b
               Infrastructure_b
               Infrastructure.

Require Import List. Import ListNotations.
Require Import Strings.String.

Lemma lc_lcb: forall E e t dir A,
 ttyping E e dir A t ->
 lc_exp e ->
 lc_term t.
Proof.
  introv typ H.
  inductions typ; eauto.
  -
    inverts H1.
    pick fresh x.
    forwards*: H.
  - inverts* H.
  - inverts* H.
Qed.

(* Common Lemmas *)
Lemma ttyping_regular_1 : forall e G dir A t,
    ttyping G e dir A t -> lc_exp e.
Proof.
  intros e G dir A t H.
  induction H;
    eauto.
Qed.

Lemma ttyping_regular_2 : forall G e dir T t,
    ttyping G e dir T t -> uniq G.
Proof.
  intros. induction* H.
  pick fresh y.
  assert (uniq ((y, A) :: G)) by auto.
  solve_uniq.
Qed.

Lemma ttyping_weaken : forall G E F e dir T t,
    ttyping (E ++ G) e dir T t ->
    uniq (E ++ F ++ G) ->
    ttyping (E ++ F ++ G) e dir T t.
Proof.
  introv Typ; gen F;
    inductions Typ; introv Ok; autos*.
    + (* abs *)
      pick fresh x and apply ttyp_abs; eauto.
      rewrite_env (([(x, A)] ++ E) ++ F ++ G).
      apply~ H0.
      solve_uniq.
Qed.

Lemma ttyping_weakening : forall (E F : ctx) e dir T t,
    ttyping E e dir T t ->
    uniq (F ++ E) ->
    ttyping (F ++ E) e dir T t.
Proof.
  intros.
  rewrite_env (nil ++ F ++ E).
  apply~ ttyping_weaken.
Qed.

(** Typing is preserved by substitution. *)

Lemma ttfv_in_dom: forall G e dir T t,
    ttyping G e dir T t -> fv_exp e [<=] dom G.
Proof.
  intros G e dir T t H.
  induction H; simpl; try fsetdec.
  - Case "typing_var".
    apply binds_In in H0.
    fsetdec.
  - Case "typing_abs".
    pick fresh x.
    assert (Fx : fv_exp (open_exp_wrt_exp e (e_var_f x)) [<=] dom ([(x,A)] ++ G))
      by eauto.
    simpl in Fx.
    assert (Fy : fv_exp e [<=] fv_exp (open_exp_wrt_exp e (e_var_f x))) by
        eapply fv_exp_open_exp_wrt_exp_lower.
    fsetdec.
Qed.

Lemma ttvalue_no_fv : forall v dir T t,
    ttyping [] v dir T t -> fv_exp v [<=] empty.
Proof.
  intro v.
  pose proof (ttfv_in_dom [] v).
  intuition eauto.
Qed.

Lemma ttsubst_value : forall v dir T t z u,
    ttyping [] v dir T t -> subst_exp u z v = v.
Proof.
  intros v dir T t z u Typ.
  lets* Fv: ttvalue_no_fv Typ.
  forwards*: subst_exp_fresh_eq.
  rewrite Fv.
  fsetdec.
Qed.

Lemma ttyping_subst_1 : forall (E F : ctx) e u uu dir S T (z : atom) t,
    ttyping (F ++ [(z,S)] ++ E) e dir T t ->
    ttyping E u Inf S uu ->
    ttyping (F ++ E) ([z ~> u] e) dir T ([z ~> uu]' t).
Proof.
  intros.
  remember (F ++ [(z,S)] ++ E) as E'.
  generalize dependent F.
  induction H; intros F Eq; subst; simpl; autos*;
    lets Lc  : ttyping_regular_1 H0;
    lets Uni : ttyping_regular_2 H0.
  -
    case_if*.
    substs.
    assert (A = S).
    eapply binds_mid_eq; eauto.
    substs.
    apply~ ttyping_weakening.
    solve_uniq.
  -
    pick fresh x and apply ttyp_abs; eauto.
    rewrite subst_exp_open_exp_wrt_exp_var; auto.
    rewrite subst_term_open_term_wrt_term_var; auto.
    rewrite_env (([(x, A)] ++ F) ++ E).
    apply~ H1.
    forwards*: lc_lcb H0.
Qed.

Lemma ttyping_c_subst_simpl : forall E e u uu t dir S T z,
  ttyping ([(z,S)] ++ E) e dir T t ->
  ttyping E u Inf S uu ->
  ttyping E ([z ~> u] e) dir T ([z ~> uu]' t).
Proof.
  intros E e u uu t dir S T z H1 H2.
  rewrite_env (nil ++ E).
  eapply ttyping_subst_1.
    simpl_env. apply H1.
    apply H2.
Qed.

Lemma ttinference_unique : forall G e t A1 A2,
    ttyping G e Inf A1 t ->
    ttyping G e Inf A2 t->
    A1 = A2.
Proof.
  introv Ty1.
  gen A2.
  inductions Ty1; introv Ty2; try (inverts* Eq); try (inverts* Ty2).
  - (* t_var *)
    forwards*: binds_unique H0 H4.
  - (* t_app *)
    forwards * : IHTy1_1 H5.
    inverts* H.
Qed.

Lemma elaboration_soundness : forall G e t dir A,
    ttyping G e dir A t ->
    Btyping G t A.
Proof.
  introv Ty1.
  inductions Ty1; intros; eauto.
Qed.


From BF Require Import Base Byte VM Token AST.

Inductive comir : Type :=
  | CRight (n : positive) (c : comir)
  | CLeft (n : positive) (c : comir)
  | CAdd (n : byte) (c : comir)
  | COutput (c : comir)
  | CInput (c : comir)
  | CLoop (body : comir) (c : comir)
  | CEnd.

Inductive execute : comir -> vm -> vm -> Prop :=
  | E_CRight n c v v'' :
      execute c (VM.move_right n v) v'' ->
      execute (CRight n c) v v''
  | E_CLeft n c v v' v'' :
      VM.move_left n (Some v) = Some v' ->
      execute c v' v'' ->
      execute (CLeft n c) v v''
  | E_CAdd n c v v'' :
      execute c (VM.add_cell n v) v'' ->
      execute (CAdd n c) v v''
  | E_COutput c v v'' :
      execute c (VM.output v) v'' ->
      execute (COutput c) v v''
  | E_CInput c v v' v'' :
      VM.input v = Some v' ->
      execute c v' v'' ->
      execute (CInput c) v v''
  | E_CLoop body c v v' v'' :
      v.(cell) =? #00 = false ->
      execute body v v' ->
      execute (CLoop body c) v' v'' ->
      execute (CLoop body c) v v''
  | E_CLoop_0 body c v v' :
      v.(cell) =? #00 = true ->
      execute c v v' ->
      execute (CLoop body c) v v'
  | E_CEnd v v' :
      VM.eq v v' = true ->
      execute CEnd v v'.

Definition equiv (i1 i2 : comir) : Prop := forall v v',
  execute i1 v v' <-> execute i2 v v'.

Definition transform_sound (trans : comir -> comir) : Prop := forall c,
  equiv c (trans c).

Fixpoint cons_right (n : positive) (c : comir) : comir :=
  match c with
  | CRight m c' => CRight (n + m) c'
  | CLeft m c' => match n ?= m with
                  | Eq => c'
                  | Lt => CLeft (m - n) c'
                  | Gt => cons_right (n - m) c'
                  end
  | _ => CRight n c
  end%positive.

Definition cons_left (n : positive) (c : comir) : comir :=
  match c with
  | CLeft m c' => CLeft (n + m) c'
  | _ => CLeft n c
  end.

Definition cons_add (n : byte) (c : comir) : comir :=
  match c with
  | CAdd m c' => CAdd (n + m) c'
  | _ => CAdd n c
  end.

Fixpoint lower_ast (a : ast) : comir :=
  match a with
  | ARight a' => CRight 1 (lower_ast a')
  | ALeft a' => CLeft 1 (lower_ast a')
  | AInc a' => CAdd #01 (lower_ast a')
  | ADec a' => CAdd #ff (lower_ast a')
  | AOutput a' => COutput (lower_ast a')
  | AInput a' => CInput (lower_ast a')
  | ALoop body a' => CLoop (lower_ast body) (lower_ast a')
  | AEnd => CEnd
  end.

Fixpoint raise_ast (c : comir) : ast :=
  match c with
  | CRight n c' => AST.cons_right n (raise_ast c')
  | CLeft n c' => AST.cons_left n (raise_ast c')
  | CAdd n c' => AST.cons_add n (raise_ast c')
  | COutput c' => AOutput (raise_ast c')
  | CInput c' => AInput (raise_ast c')
  | CLoop body c' => ALoop (raise_ast body) (raise_ast c')
  | CEnd => AEnd
  end.

Fixpoint combine (c : comir) : comir :=
  match c with
  | CRight n c' => cons_right n (combine c')
  | CLeft n c' => cons_left n (combine c')
  | CAdd n c' => cons_add n (combine c')
  | COutput c' => COutput (combine c')
  | CInput c' => CInput (combine c')
  | CLoop body c' => CLoop (combine body) (combine c')
  | CEnd => CEnd
  end.

Example test_execute : forall a,
  parse (lex ",>+++[-<++>]<-.") = Some a ->
  execute (lower_ast a) (VM.make [#02]) (VM [] #07 [] [#07] [] VM.norm_nil).
Proof.
  intros. inversion H; subst; clear H.
  repeat (apply E_CRight
       || (eapply E_CLeft; [reflexivity |])
       || apply E_CAdd
       || apply E_COutput
       || (eapply E_CInput; [reflexivity |])
       || (eapply E_CLoop; [reflexivity | |])
       || (eapply E_CLoop_0; [reflexivity |])
       || (apply E_CEnd; apply VM.eq_refl)).
  apply E_CEnd. reflexivity.
Qed.

Theorem lower_ast_sound : forall a v v',
  AST.execute a v v' <-> execute (lower_ast a) v v'.
Proof.
  split.
  - intros. induction H; cbn; econstructor; eassumption.
  - generalize dependent v'; generalize dependent v.
    induction a; cbn; intros;
    try (inversion H; subst; econstructor; try apply IHa; eassumption).
    dependent induction H.
    + eapply E_ALoop. assumption. apply IHa1. eassumption.
      apply IHexecute2. apply IHa2. apply IHa1. reflexivity.
    + apply E_ALoop_0, IHa2; assumption.
Qed.

Ltac destruct_compare n m :=
  destruct (n ?= m)%positive eqn:Hcomp;
  [rewrite Pos.compare_eq_iff in Hcomp; subst
  | rewrite Pos.compare_lt_iff in Hcomp
  | rewrite Pos.compare_gt_iff in Hcomp].

Theorem cons_right_correct : forall c n v v',
  execute (cons_right n c) v v' <-> execute (CRight n c) v v'.
Proof.
  split;
  generalize dependent v'; generalize dependent v; generalize dependent n.
  - induction c; cbn; intros; try assumption.
    + inversion H; subst.
      apply E_CRight, E_CRight. rewrite VM.move_right_add. assumption.
    + destruct_compare n0 n.
      * eapply E_CRight, E_CLeft. apply VM.move_right_left_refl. assumption.
      * inversion H; subst.
        eapply E_CRight, E_CLeft. rewrite VM.move_right_left_lt.
        eassumption. apply Hcomp. assumption.
      * apply IHc in H. inversion H; subst.
        eapply E_CRight, E_CLeft. apply VM.move_right_left_gt.
        apply Hcomp. assumption.
  - induction c; cbn; intros; try assumption;
    inversion H; inversion H4; subst.
    + rewrite VM.move_right_add in H9.
      apply E_CRight. assumption.
    + destruct_compare n0 n.
      * rewrite VM.move_right_left_refl in H7. inversion H7; subst. assumption.
      * rewrite VM.move_right_left_lt in H7.
        eapply E_CLeft. eassumption. assumption. apply Hcomp.
      * rewrite VM.move_right_left_gt in H7. inversion H7; subst.
        apply IHc. apply E_CRight. assumption. assumption.
Qed.

Theorem cons_left_correct : forall c n v v',
  execute (cons_left n c) v v' <-> execute (CLeft n c) v v'.
Proof.
  split;
  generalize dependent v'; generalize dependent v; generalize dependent n.
  - destruct c; cbn; intros; try assumption.
    inversion H; subst.
    rewrite Pos.add_comm, <- VM.move_left_add in H2.
    apply VM.move_left_split in H2 as [v'1 []].
    eapply E_CLeft, E_CLeft; eassumption.
  - destruct c; cbn; intros; try assumption.
    inversion H; inversion H5; subst.
    rewrite Pos.add_comm. eapply E_CLeft. rewrite <- VM.move_left_add.
    rewrite H2. eassumption. assumption.
Qed.

Theorem cons_add_correct : forall c n v v',
  execute (cons_add n c) v v' <-> execute (CAdd n c) v v'.
Proof.
  split.
  - destruct c; cbn; intros; try assumption.
    inversion H; subst.
    apply E_CAdd, E_CAdd. rewrite VM.add_add. assumption.
  - destruct c; cbn; intros; try assumption.
    inversion H; inversion H4; subst.
    apply E_CAdd. rewrite <- VM.add_add. assumption.
Qed.

Theorem combine_sound :
  transform_sound combine.
Proof.
  unfold transform_sound, equiv.
  split.
  - intros. induction H; cbn;
    try (econstructor; eassumption).
    + rewrite cons_right_correct. apply E_CRight. assumption.
    + rewrite cons_left_correct. eapply E_CLeft; eassumption.
    + rewrite cons_add_correct. apply E_CAdd. assumption.
  - generalize dependent v'; generalize dependent v.
    induction c; intros; cbn in *.
    + rewrite cons_right_correct in H. inversion H; subst.
      apply E_CRight, IHc. assumption.
    + rewrite cons_left_correct in H. inversion H; subst.
      eapply E_CLeft. eassumption. apply IHc. assumption.
    + rewrite cons_add_correct in H. inversion H; subst.
      apply E_CAdd, IHc. assumption.
    + inversion H; subst. constructor. apply IHc. assumption.
    + inversion H; subst. econstructor. eassumption. apply IHc. assumption.
    + dependent induction H.
      * eapply E_CLoop. assumption. apply IHc1. eassumption.
        apply IHexecute2; try assumption. reflexivity.
      * apply E_CLoop_0, IHc2; assumption.
    + assumption.
Qed.

Theorem lower_ast_combine_sound : forall a v v',
  AST.execute a v v' -> execute (combine (lower_ast a)) v v'.
Proof.
  intros. apply lower_ast_sound, combine_sound in H. assumption.
Qed.


Require Import Util LengthEq AllInRel Map Envs IL AutoIndTac MoreList.
Require Export DecSolve BlockType.

Set Implicit Arguments.
Inductive mutual_block {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C} (R:A1->A2->A3->A4->B->C->Prop)
: nat -> list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C -> Prop :=
  | CS_nil n : mutual_block R n nil nil nil nil nil nil
  | CS_cons a1 a2 a3 a4 b c n AL1 AL2 AL3 AL4 L L' :
      mutual_block R (S n) AL1 AL2 AL3 AL4 L L'
      -> n = block_n b
      -> n = block_n c
      -> R a1 a2 a3 a4 b c
      -> mutual_block R n (a1::AL1) (a2::AL2) (a3::AL3) (a4::AL4) (b::L) (c::L').

Lemma mutual_block_zero {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C} (R:A1->A2->A3->A4->B->C->Prop)
      AL1 AL2 AL3 AL4 (L:list B) (L':list C) n b i
: mutual_block R i AL1 AL2 AL3 AL4 L L' -> get L n b -> block_n b = (n+i).
Proof.
  intros. general induction H2. inv H1; eauto.
  inv H1; eauto. erewrite IHget; eauto. omega.
Qed.

Lemma mutual_block_length {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C} (R:A1->A2->A3->A4->B->C->Prop)
      AL1 AL2 AL3 AL4 (L1:list B) (L2:list C) i
: mutual_block R i AL1 AL2 AL3 AL4 L1 L2 -> ❬AL1❭ = ❬L1❭ /\ ❬AL2❭ = ❬L1❭ /\ ❬AL3❭ = ❬L1❭  /\ ❬AL4❭ = ❬L1❭ /\ ❬L2❭ = ❬L1❭.
Proof.
  intros. general induction H1; dcr; simpl; eauto.
  repeat split; omega.
Qed.

Lemma mutual_block_get {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C} (R:A1->A2->A3->A4->B->C->Prop)
      AL1 AL2 AL3 AL4 (L1:list B) (L2:list C) i n b
: mutual_block R i AL1 AL2 AL3 AL4 L1 L2 -> get L1 n b ->
  exists a1 a2 a3 a4 c, get AL1 n a1 /\ get AL2 n a2 /\ get AL3 n a3 /\ get AL4 n a4
                   /\ get L2 n c /\ R a1 a2 a3 a4 b c.
Proof.
  intros. general induction H2; inv H1; eauto 20 using get.
  edestruct IHget; dcr; eauto 20 using get.
Qed.

Lemma mutual_block_get_A1 {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C} (R:A1->A2->A3->A4->B->C->Prop)
      AL1 AL2 AL3 AL4 (L1:list B) (L2:list C) i n a1
: mutual_block R i AL1 AL2 AL3 AL4 L1 L2 -> get AL1 n a1 ->
  exists a2 a3 a4 b c, get AL2 n a2 /\ get AL3 n a3 /\ get AL4 n a4 /\
                   get L1 n b /\ get L2 n c /\ R a1 a2 a3 a4 b c.
Proof.
  intros. general induction H2; inv H1; eauto 20 using get.
  edestruct IHget; dcr; eauto 20 using get.
Qed.

Lemma mutual_approx k {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C}
      (R:list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C ->
         A1 -> A2 -> A3 -> A4 -> B -> C -> Prop)
      AL1 AL2 AL3 AL4 AL1' AL2' AL3' AL4' F1 F2 L1 L2
  : length AL1' = length F1
    -> length AL1' = length AL2'
    -> length AL2' = length AL3'
    -> length AL3' = length AL4'
    -> length F1 = length F2
    -> (forall n a1 a2 a3 a4 b b', get AL1' n a1 -> get AL2' n a2 -> get AL3' n a3 -> get AL4' n a4
                             -> get F1 n b -> get F2 n b' -> R AL1 AL2 AL3 AL4 L1 L2 a1 a2 a3 a4 b b')
    -> (forall i b, get F1 i b -> k + i = block_n b)
    -> (forall i b, get F2 i b -> k + i = block_n b)
    -> mutual_block (R AL1 AL2 AL3 AL4 L1 L2) k AL1' AL2' AL3' AL4' F1 F2.
Proof.
  intros. length_equify.
  general induction H1; eauto using @mutual_block.
  econstructor; eauto using get. eapply IHlength_eq; eauto 20 using get.
  intros. exploit H7. econstructor 2. eauto. omega.
  intros. exploit H8. econstructor 2. eauto. omega.
  exploit H7; eauto using get. omega.
  exploit H8; eauto using get. omega.
Qed.

Inductive inRel {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C}
          (R:list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C ->
             A1 -> A2 -> A3 -> A4 -> B -> C -> Prop)
: list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C -> Prop :=
  | LPM_nil : inRel R nil nil nil nil nil nil
  | LPM_app AL1 AL2 AL3 AL4 AL1' AL2' AL3' AL4' L1 L2 L1' L2' :
      inRel R AL1 AL2 AL3 AL4 L1 L2
      -> mutual_block (R (AL1'++AL1) (AL2'++AL2) (AL3'++AL3) (AL4'++AL4) (L1'++L1) (L2'++L2))
                     0 AL1' AL2' AL3' AL4' L1' L2'
      -> inRel R (AL1'++AL1) (AL2'++AL2) (AL3'++AL3) (AL4'++AL4) (L1'++L1) (L2'++L2).
Lemma inRel_less {A1 A2 A3 A4:Type} {B} `{BlockType B} {C} `{BlockType C}
      (R:list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C ->
         A1 -> A2 -> A3 -> A4 -> B -> C -> Prop)
      AL1 AL2 AL3 AL4 (L:list B) (L':list C) n b
: inRel R AL1 AL2 AL3 AL4 L L' -> get L n b -> block_n b <= n.
Proof.
  intros. general induction H1.
  eapply get_app_cases in H3; destruct H3; dcr.
  erewrite mutual_block_zero; eauto. omega.
  rewrite IHinRel; try eapply H4. omega.
Qed.

Lemma inRel_drop {A1 A2 A3 A4:Type} {B} `{BlockType B} {C} `{BlockType C}
      (R:list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C ->
         A1 -> A2 -> A3 -> A4 -> B -> C -> Prop)
      AL1 AL2 AL3 AL4 (L:list B) (L':list C) n b
: inRel R AL1 AL2 AL3 AL4 L L'
  -> get L n b
  -> inRel R
          (drop (n - block_n b) AL1)
          (drop (n - block_n b) AL2)
          (drop (n - block_n b) AL3)
          (drop (n - block_n b) AL4)
          (drop (n - block_n b) L)
          (drop (n - block_n b) L').
Proof.
  intros. general induction H1; simpl; eauto; isabsurd.
  - eapply get_app_cases in H3; destruct H3; dcr.
    + exploit (mutual_block_zero H2 H3); eauto.
      rewrite H4. orewrite (n - (n + 0)= 0). simpl; econstructor; eauto.
    + exploit (inRel_less H1 H4); eauto.
      exploit (mutual_block_length H2); dcr.
      specialize (IHinRel _ _ H4).
      repeat (rewrite drop_app_gen; [| omega]).
      assert (REO:forall m, block_n b <= n - ❬L1'❭ -> m = ❬L1'❭
                       -> n - block_n b - m = n - ❬L1'❭ - block_n b). {
        intros. omega.
      }
      repeat (rewrite REO; eauto).
Qed.

Lemma inRel_nth {A1 A2 A3 A4:Type} {B} `{BlockType B} {C} `{BlockType C}
      (R:list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C ->
         A1 -> A2 -> A3 -> A4 -> B -> C -> Prop)
      AL1 AL2 AL3 AL4 (L:list B) (L':list C) n b
: inRel R AL1 AL2 AL3 AL4 L L' -> get L n b ->
  exists a1:A1, exists a2:A2, exists a3:A3, exists a4:A4, exists c:C,
            get AL1 n a1 /\ get AL2 n a2 /\ get AL3 n a3 /\ get AL4 n a4 /\ get L' n c
            /\ R (drop (n - block_n b) AL1) (drop (n - block_n b) AL2) (drop (n - block_n b) AL3) (drop (n - block_n b) AL4) (drop (n - block_n b) L) (drop (n - block_n b) L') a1 a2 a3 a4 b c.
Proof.
  intros. general induction H1; isabsurd.
  eapply get_app_cases in H3; destruct H3; dcr.
  - exploit (mutual_block_zero H2 H3); eauto. rewrite H4.
    orewrite (n - (n + 0) = 0). simpl.
    edestruct (mutual_block_get H2 H3); dcr.
    eauto 20 using get_app, get.
  - edestruct IHinRel; eauto; dcr.
    pose proof (mutual_block_length H2); dcr.
    do 5 eexists.
    repeat split; try (eapply get_app_right; [ | eauto ]; omega).
    exploit (inRel_less H1 H4); eauto.
    repeat (rewrite drop_app_gen; [| omega]).
    assert (REO:forall m, block_n b <= n - ❬L1'❭ -> m = ❬L1'❭
                     -> n - block_n b - m = n - ❬L1'❭ - block_n b). {
      intros. omega.
    }
    repeat (rewrite REO; eauto).
Qed.

Lemma inRel_nth_A1 {A1 A2 A3 A4:Type} {B} `{BlockType B} {C} `{BlockType C}
      (R:list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C ->
         A1 -> A2 -> A3 -> A4 -> B -> C -> Prop)
      AL1 AL2 AL3 AL4 (L:list B) (L':list C) n a1
: inRel R AL1 AL2 AL3 AL4 L L' -> get AL1 n a1 ->
  exists a2:A2, exists a3:A3, exists a4:A4, exists b:B, exists c:C,
            get AL2 n a2 /\ get AL3 n a3 /\ get AL4 n a4 /\ get L n b /\ get L' n c
            /\ R (drop (n - block_n b) AL1) (drop (n - block_n b) AL2) (drop (n - block_n b) AL3) (drop (n - block_n b) AL4) (drop (n - block_n b) L) (drop (n - block_n b) L') a1 a2 a3 a4 b c.
Proof.
  intros. general induction H1; isabsurd.
  eapply get_app_cases in H3; destruct H3; dcr.
  - edestruct (mutual_block_get_A1 H2 H3); dcr.
    exploit (mutual_block_zero H2 H8); eauto.
    eexists x, x0, x1, x2, x3.
    rewrite H4.
    orewrite (n - (n + 0) = 0). simpl.
    eauto 20 using get_app, get.
  - edestruct IHinRel; eauto; dcr.
    pose proof (mutual_block_length H2); dcr.
    do 5 eexists.
    repeat split; try (eapply get_app_right; [ | eauto ]; omega).
    exploit (inRel_less H1 H9); eauto.
    repeat (rewrite drop_app_gen; [| omega]).
    assert (REO:forall m, block_n x2 <= n - ❬AL1'❭ -> m = ❬AL1'❭
                     -> n - block_n x2 - m = n - ❬AL1'❭ - block_n x2). {
      intros. omega.
    }
    repeat (rewrite REO; eauto); try congruence.
Qed.

Tactic Notation "inRel_invs" :=
  match goal with
  | [ H : inRel ?R ?A1 ?A2 ?A3 ?A4 ?B ?C, H' : get ?A1 ?n ?b |- _ ] =>
    let InR := fresh "InR" in
    let G := fresh "G" in
    let GetL := fresh "GetL" in
    edestruct (inRel_nth_A1 H H') as [? [? [? [? [? [? [? [? [GetL [? ]]]]] ]]]]];
    let X'' := fresh "H" in
    pose proof (inRel_drop H GetL) as X'';
    repeat get_functional
  end.

Lemma mutual_block_map_A3 {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C}
      (R:list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C ->
         A1 -> A2 -> A3 -> A4 -> B -> C -> Prop)
      AL1' AL1 AL2' AL2 AL3' AL3 AL4' AL4 L1' L1 L2' L2 n (f: A3 -> A3)
      (Rf: forall AL1 AL2 AL3 AL4 L1 L2 a1 a2 a3 a4 b1 b2,
          R AL1 AL2 AL3 AL4 L1 L2 a1 a2 a3 a4 b1 b2 ->
          R AL1 AL2 (f ⊝ AL3) AL4 L1 L2 a1 a2 (f a3) a4 b1 b2 )
  : mutual_block
      (R AL1 AL2 AL3 AL4 L1 L2) n AL1' AL2' AL3' AL4' L1' L2'
    -> mutual_block (R AL1 AL2 (f ⊝ AL3) AL4 L1 L2) n AL1' AL2' (f ⊝ AL3') AL4' L1' L2'.
Proof.
  intros. general induction H1; eauto using @mutual_block.
  simpl. econstructor; eauto.
Qed.

Lemma inRel_map_A3 {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C}
      (R:list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C ->
         A1 -> A2 -> A3 -> A4 -> B -> C -> Prop)
      AL1 AL2 AL3 AL4 L1 L2 (f: A3 -> A3)
      (Rf: forall AL1 AL2 AL3 AL4 L1 L2 a1 a2 a3 a4 b1 b2,
          R AL1 AL2 AL3 AL4 L1 L2 a1 a2 a3 a4 b1 b2 ->
          R AL1 AL2 (f ⊝ AL3) AL4 L1 L2 a1 a2 (f a3) a4 b1 b2 )
  : inRel R AL1 AL2 AL3 AL4 L1 L2
    -> inRel R AL1 AL2 (f ⊝ AL3) AL4 L1 L2.
Proof.
  intros IR.
  general induction IR; simpl in *; eauto using @inRel.
  - rewrite List.map_app. econstructor; eauto.
    rewrite <- List.map_app.
    eapply mutual_block_map_A3; eauto.
Qed.

Lemma inRel_length  {A1 A2 A3 A4} {B} `{BlockType B} {C} `{BlockType C}
      (R:list A1 -> list A2 -> list A3 -> list A4 -> list B -> list C ->
         A1 -> A2 -> A3 -> A4 -> B -> C -> Prop)
      AL1 AL2 AL3 AL4 L1 L2
  : inRel R AL1 AL2 AL3 AL4 L1 L2 -> length AL1 = length AL2 /\ length AL2 = length AL3
                                   /\ length AL3 = length AL4 /\ length L1 = length L2.
Proof.
  intros. general induction H1; dcr; simpl; eauto.
  repeat rewrite app_length.
  exploit (mutual_block_length H2); eauto; dcr; omega.
Qed.


Lemma extends_get':
  forall A (E E' : env A),
    extends E E' ->
    forall x v,
      get x E  = Some v ->
      get x E' = Some v.
Proof.
  intros.
  unfold extends, binds in H.
  induction E'; auto.
Qed.


(* 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                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(* Peter Aczel's Encoding of CZF *)

(* Using the same definition "Ens" of sets, we can developp Peter Aczel's   *)
(* encoding of "Constructive Type Theory" (CZF).                            *)
(* It is basically a simillar developement, but this time, the propositions *)
(* are objects of type "Type", i.e. are on the same level (resp. above) the *)
(* sets. The advantage is that we can extract the constructive witness of an*)
(* existential proof. The drawbacks are:                                    *)
(*  - no definition of the powerset                                         *)
(*  - complicated difference between bounded and unbounded quantification   *)
(*  - excluded middle is now much more "dangerous"                          *)

Require Import Sets.
Require Import Axioms.

Definition EQC : Ens -> Ens -> Type.
simple induction 1; intros A f eq1.
simple induction 1; intros B g eq2.
refine (prod_t _ _).
exact (forall x : A, depprod _ (fun y : B => eq1 x (g y))).
exact (forall y : B, depprod _ (fun x : A => eq1 x (g y))).
Defined.

(* APPARTENANCE *)

Definition CIN : Ens -> Ens -> Type.
simple induction 2.
intros.
exact (depprod _ (fun y : A => EQC X (e y))).
Defined.

(* INCLUSION *)

Definition CINC : Ens -> Ens -> Type.
intros E1 E2.
exact (forall E : Ens, CIN E E1 -> CIN E E2).
Defined.

(* EQ EST UNE RELATION D'EQUIVALENCE *)

Theorem EQC_refl : forall E : Ens, EQC E E.
simple induction E.
intros A f HR.
simpl in |- *.
split; intros.
exists x; auto with zfc.

exists y; auto with zfc.
Qed.

Theorem EQC_tran : forall E1 E2 E3 : Ens, EQC E1 E2 -> EQC E2 E3 -> EQC E1 E3.
simple induction E1; simple induction E2; simple induction E3; simpl in |- *;
 intros.
split; (elim X2; intros; elim X3; intros).
elim (a x); intros.
elim (a0 x0); intros.
exists x1.
apply X with (e0 x0); auto with zfc.
elim (b0 y); intros.
elim (b x); intros.
exists x0.
apply X with (e0 x); auto with zfc.
Qed.

Theorem EQC_sym : forall E1 E2 : Ens, EQC E1 E2 -> EQC E2 E1.
simple induction E1; simple induction E2; simpl in |- *; intros.
elim X1; intros; split; intros.
elim (b x); intros.
exists x0; auto with zfc.
elim (a y); intros; exists x; auto with zfc.
Qed.

Theorem EQC_INC : forall E E' : Ens, EQC E E' -> CINC E E'.
simple induction E; simple induction E'; simpl in |- *; intros;
 unfold CINC in |- *; simpl in |- *.
elim X1; intros.
elim X2; intros.
elim (a x); intros.
exists x0; apply EQC_tran with (e x); auto with zfc.
Qed.

Hint Resolve EQC_sym EQC_refl EQC_INC: zfc.

Theorem CINC_EQC : forall E E' : Ens, CINC E E' -> CINC E' E -> EQC E E'.
simple induction E; simple induction E'; unfold CINC in |- *; simpl in |- *;
 intros; split; intros.
apply X1.
exists x; auto with zfc.
cut (depprod A (fun x : A => EQC (e0 y) (e x)));
 try (simple induction 1; intros x p; exists x; auto with zfc).
apply X2; exists y; auto with zfc.
Qed.

Hint Resolve CINC_EQC: zfc.

Theorem CIN_sound_left :
 forall E E' E'' : Ens, EQC E E' -> CIN E E'' -> CIN E' E''.
simple induction E''; simpl in |- *; intros.
elim X1; intros y p; exists y.
apply EQC_tran with E; auto with zfc.
Qed.

Theorem CIN_sound_right :
 forall E E' E'' : Ens, EQC E' E'' -> CIN E E' -> CIN E E''.
simple induction E'; simple induction E''; simpl in |- *; intros.
elim X1; intros Xl Xr; elim X2; intros y p; elim (Xl y); intros y0 p0;
 exists y0; apply EQC_tran with (e y); auto with zfc.
Qed.

Theorem CINC_refl : forall E : Ens, CINC E E.
unfold CINC in |- *; auto with zfc.
Qed.

Theorem CINC_tran :
 forall E E' E'' : Ens, CINC E E' -> CINC E' E'' -> CINC E E''.
unfold CINC in |- *; auto with zfc.
Qed.

Theorem CINC_sound_left :
 forall E E' E'' : Ens, EQC E E' -> CINC E E'' -> CINC E' E''.
simple induction E''; unfold CINC in |- *; simpl in |- *;
 intros A f XR e X1 E0 i; apply X1.
apply CIN_sound_right with E'; auto with zfc.
Qed.

Theorem CINC_sound_right :
 forall E E' E'' : Ens, EQC E' E'' -> CINC E E' -> CINC E E''.
simple induction E'; simple induction E''; unfold CINC in |- *; simpl in |- *;
 intros.
elim (X2 E0); try assumption; intros.
elim X1; intros XA XB; elim (XA x); intros.
exists x0; apply EQC_tran with (e x); auto with zfc.
Qed.

Theorem tout_vide_est_VideC :
 forall E : Ens, (forall E' : Ens, CIN E' E -> F) -> EQC E Vide.
 unfold Vide in |- *; simple induction E; simpl in |- *; intros A e X H;
  split.
intros; elim (H (e x)); auto with zfc.
exists x; auto with zfc.
simple induction y.
Qed.

Theorem Paire_sound_leftC :
 forall A A' B : Ens, EQC A A' -> EQC (Paire A B) (Paire A' B).
unfold Paire in |- *.
simpl in |- *.
intros; split.
simple induction x.
exists true; auto with zfc.

exists false; auto with zfc.

simple induction y; simpl in |- *.
exists true; auto with zfc.

exists false; auto with zfc.
Qed.

Theorem Paire_sound_rightC :
 forall A B B' : Ens, EQC B B' -> EQC (Paire A B) (Paire A B').
unfold Paire in |- *; simpl in |- *; intros; split.
simple induction x.
exists true; auto with zfc.
exists false; auto with zfc.
simple induction y.
exists true; auto with zfc.
exists false; auto with zfc.
Qed.

Theorem CIN_Paire_left : forall E E' : Ens, CIN E (Paire E E').
unfold Paire in |- *; simpl in |- *; exists true; simpl in |- *;
 auto with zfc.
Qed.

Theorem CIN_Paire_right : forall E E' : Ens, CIN E' (Paire E E').
unfold Paire in |- *; simpl in |- *; exists false; simpl in |- *;
 auto with zfc.
Qed.

Inductive sum_t (A B : Type) : Type :=
  | inl_t : A -> sum_t A B
  | inr_t : B -> sum_t A B.
Hint Resolve inl_t inr_t: zfc.

Theorem Paire_CIN :
 forall E E' A : Ens, CIN A (Paire E E') -> sum_t (EQC A E) (EQC A E').
unfold Paire in |- *; simpl in |- *; simple induction 1; intros b; elim b;
 simpl in |- *; auto with zfc.
Qed.

Hint Resolve CIN_Paire_left CIN_Paire_right: zfc.

(* Singleton *)

Theorem CIN_Sing : forall E : Ens, CIN E (Sing E).
unfold Sing in |- *; auto with zfc.
Qed.

Theorem CIN_Sing_EQ : forall E E' : Ens, CIN E (Sing E') -> EQC E E'.
unfold Sing in |- *; intros E E' H; elim (Paire_CIN E' E' E);
 auto with zfc.
Qed.

Theorem EQC_EQ : forall E E' : Ens, EQC E E' -> EQ E E'.
simple induction E; intros A f ra; simple induction E'; intros B g rb;
 simpl in |- *; simple induction 1; intros H1 H2; split.
intros a; elim (H1 a); intros b; intros; exists b; auto with zfc.
intros b; elim (H2 b); intros a; intros; exists a; auto with zfc.
Qed.

Theorem CIN_IN : forall E E' : Ens, CIN E E' -> IN E E'.
simple induction E; intros A f ra; simple induction E'; intros B g rb;
 simple induction 1; intros a; unfold IN in |- *; exists a;
 auto with zfc.
apply EQC_EQ; auto with zfc.
Qed.

Theorem EQC_EXType :
 forall E E' : Ens,
 EQC E E' ->
 forall a : pi1 E,
 depprod (pi1 E') (fun b : pi1 E' => EQC (pi2 E a) (pi2 E' b)).
simple induction E; simple induction E'; simpl in |- *.
intros.
elim X1; intros.
elim (a0 a); intros.
exists x; auto with zfc.

Defined.

Theorem CIN_EXType :
 forall E E' : Ens,
 CIN E' E -> depprod (pi1 E) (fun a : pi1 E => EQC E' (pi2 E a)).
simple induction E; simpl in |- *.
intros A f r.
simple induction 1; simpl in |- *.
intros.
exists x; auto with zfc.
Qed.

Theorem CIN_Union :
 forall E E' E'' : Ens, CIN E' E -> CIN E'' E' -> CIN E'' (Union E).

simple induction E; intros A f r.
intros.
simpl in |- *.
elim (CIN_EXType (sup A f) E' X).
intros x e.
cut (EQC (pi2 (sup A f) x) E'); auto with zfc.
intros e1.
cut (CIN E'' (pi2 (sup A f) x)).
intros i1.
elim (CIN_EXType _ _ i1).
intros x0 e2.
simpl in x0.
exists (dep_i A (fun x : A => pi1 (f x)) x x0).
simpl in |- *.
exact e2.
apply CIN_sound_right with E'; auto with zfc.
Qed.

Theorem CIN_CINC_Union : forall E E' : Ens, CIN E' E -> CINC E' (Union E).
unfold CINC in |- *; simple induction E; intros A f r.
unfold Union in |- *.
intros.
simpl in |- *.
elim (CIN_EXType (sup A f) E' X).
intro.
simpl in x.
intros.
simpl in p.
elim (CIN_EXType E' E0 X0).
cut (CIN E0 (f x)).
intros.
elim (CIN_EXType _ _ X1).
simpl in |- *.
intros.
exists (dep_i A (fun x : A => pi1 (f x)) x x1); auto with zfc.

apply CIN_sound_right with E'; auto with zfc.
Qed.

(* idem depprod *)

Inductive depprod' (A : Type) (P : A -> Type) : Type :=
    dep_i' : forall x : A, P x -> depprod' A P.

Theorem Union_CIN :
 forall E E' : Ens,
 CIN E' (Union E) ->
 depprod' _ (fun E1 : Ens => prod_t (CIN E1 E) (CIN E' E1)).
simple induction E; unfold Union in |- *; simpl in |- *; intros A f r.
simple induction 1.
simple induction x.
intros a b; simpl in |- *.
intros.
exists (f a).
split.
exists a; auto with zfc.

apply CIN_sound_left with (pi2 (f a) b); auto with zfc.
simpl in |- *.
generalize b; elim (f a); simpl in |- *.
intros.
exists b0; auto with zfc.
Qed.

Theorem Union_soundC :
 forall E E' : Ens, EQC E E' -> EQC (Union E) (Union E').
unfold Union in |- *.
simpl in |- *.
simple induction E; intros A f r; simple induction E'; intros A' f' r'.
simpl in |- *.
intros.
elim X; intros.
split.
simple induction x.
intros.
elim (a x0).
intros.
elim (EQC_EXType (f x0) (f' x1) p0 p).
intros.
exists (dep_i A' (fun x : A' => pi1 (f' x)) x1 x2).
simpl in |- *.
auto with zfc.

simple induction y; intros.
elim (b x); intros.
cut (EQC (f' x) (f x0)); auto with zfc.
intros e.
elim (EQC_EXType (f' x) (f x0) e p); intros.
exists (dep_i A (fun x0 : A => pi1 (f x0)) x0 x1).
simpl in |- *; auto with zfc.
Qed.

Theorem Union_monC :
 forall E E' : Ens, CINC E E' -> CINC (Union E) (Union E').
unfold CINC in |- *; intros.
elim (Union_CIN E E0 X0); intros.
apply CIN_Union with x; elim p; intros; auto with zfc.
Qed.

(* surprinsingly, the predicative and impredicative definitions of the   *)
(* intersection do not seem equivalent.                                  *)
(* to be checked...                                                      *)