From Hammer Require Import Hammer.

From WeakUpTo Require Export Monotonic.
Set Implicit Arguments.

Section Global.

Variable A: Type.

Section A.

Variables X Y: Type.
Variable TX: reduction_t A X.
Variable TY: reduction_t A Y.

Lemma monotonic_wmonotonic: forall F, monotonic TX TY F -> wmonotonic TX TY F.
Proof. hammer_hook "WeakMonotonic" "WeakMonotonic.monotonic_wmonotonic".
intros F HF; split; auto.
apply (mon_m HF).
intros R HR; apply (mon_t HF HR); auto.
intros R S HR HS HRS HRS'; apply (mon_a HF); auto.
intro l; destruct l; auto.
apply evolve_incl with R; auto.
Qed.

Lemma star_wmon: wmonotonic TX TX (star (X:=X)).
Proof. hammer_hook "WeakMonotonic" "WeakMonotonic.star_wmon".
split.
intros R S H x y XY; induction XY as [ x | w x y XW WY IH ]; auto; apply S_star with w; auto.
intros R HR; unfold simulation_t, evolve_t, evolve_1.
apply diagram_reverse; apply diagram_incl with (Weak TX (T _)) (Weak TX (T _)); auto; apply diagram_reverse.
apply diagram_star; apply diagram_incl with R R; auto; apply weak_strong_t; exact HR.
intros R S HR HS HRS HRS' a; unfold evolve_1.
apply diagram_reverse; apply diagram_incl with (Weak TX (L a)) (Weak TX (L a)); auto; apply diagram_reverse.
intros x x' y Hxx' xRy; cgen Hxx'; cgen x'; induction xRy as [ x | w x y xRw wRy IH ]; intros x' Hxx'.
exists x'; auto.
destruct Hxx' as [ x1 Hxx1 Hx1x' ]; destruct Hx1x' as [ x2 Hx1x2 Hx2x' ].
destruct (weak_strong_t HR _ Hxx1 xRw) as [ w1 Hww1 x1Rw1 ].
destruct (HRS _ _ _ _ Hx1x2 x1Rw1) as [ w2 Hw1w2 x2Rw2 ].
destruct (weak_strong_t HS _ Hx2x' x2Rw2) as [ w' Hw2w' x'Rw' ].
elim IH with w'.
intros y' Hyy' w'Ry'; exists y'; auto; apply S_star with w'; auto.
apply taus_weak with w1; auto; apply weak_taus with w2; auto.
Qed.

Variables F G: function X Y.
Hypothesis HF: wmonotonic TX TY F.
Hypothesis HG: wmonotonic TX TY G.

Lemma Comp_wmon: wmonotonic TX TY (Comp G F).
Proof. hammer_hook "WeakMonotonic" "WeakMonotonic.Comp_wmon".
unfold Comp; split.
intros R S HRS; apply (wmon_m HG); apply (wmon_m HF); exact HRS.
intros R HR; exact (wmon_t HG (wmon_t HF HR)).
intros R S HR HS HRS HRS'; apply (wmon_a HG).
apply (wmon_t HF HR).
apply (wmon_t HF HS).
exact (wmon_a HF HR HS HRS HRS').
apply (wmon_m HF HRS').
Qed.

Lemma Union2_wmon: wmonotonic TX TY (Union2 F G).
Proof. hammer_hook "WeakMonotonic" "WeakMonotonic.Union2_wmon".
unfold Union2; split.
intros R S HRS x y H; destruct H; [ left; apply (wmon_m HF HRS) | right; apply (wmon_m HG HRS) ]; auto.
intros R HR x x' y Hxx' xRy; celim xRy; intro xRy;
[ destruct (wmon_t HF HR _ _ _ Hxx' xRy) as [ y' ]
| destruct (wmon_t HG HR _ _ _ Hxx' xRy) as [ y' ] ];
exists y'; auto; [ left | right ]; auto.
intros R S HR HS HRS HRS' a x x' y Hxx' xRy; celim xRy; intro xRy;
[ destruct (wmon_a HF HR HS HRS HRS' _ _ _ _ Hxx' xRy) as [ y' ]
| destruct (wmon_a HG HR HS HRS HRS' _ _ _ _ Hxx' xRy) as [ y' ] ];
exists y'; auto; [ left | right ]; auto.
Qed.

Section Union.

Variable I: Type.
Variable H: I -> function X Y.
Hypothesis HH: forall i, wmonotonic TX TY (H i).

Lemma Union_wmon: wmonotonic TX TY (Union H).
Proof. hammer_hook "WeakMonotonic" "WeakMonotonic.Union_wmon".
unfold Union; split.
intros R S HRS x y K; destruct K as [ i ]; exists i; apply (wmon_m (HH i) HRS); auto.
intros R HR x x' y Hxx' xRy; destruct xRy as [ i xRy ];
destruct (wmon_t (HH i) HR _ _ _ Hxx' xRy) as [ y' ];
exists y'; auto; exists i; auto.
intros R S HR HS HRS HRS' a x x' y Hxx' xRy; destruct xRy as [ i xRy ];
destruct (wmon_a (HH i) HR HS HRS HRS' _ _ _ _ Hxx' xRy) as [ y' ];
exists y'; auto; exists i; auto.
Qed.

End Union.

End A.

Section B.

Variables X Y: Type.
Variable TX: reduction_t A X.
Variable TY: reduction_t A Y.

Variables F G: function X Y.
Hypothesis HF: wmonotonic TX TY F.
Hypothesis HG: wmonotonic TX TY G.

Lemma UExp_wmon: forall n, wmonotonic TX TY (fun R => UExp F R n).
Proof. hammer_hook "WeakMonotonic" "WeakMonotonic.UExp_wmon".
intro n; induction n as [ | n IH ].
apply (monotonic_wmonotonic (identity_mon TX TY)).
simpl; fold (Union2 (fun R => UExp F R n) (fun R => F (UExp F R n))).
apply Union2_wmon; auto.
fold (Comp F (fun R => UExp F R n)).
apply Comp_wmon; auto.
Qed.
Lemma UIter_wmon: wmonotonic TX TY (UIter F).
Proof. hammer_hook "WeakMonotonic" "WeakMonotonic.UIter_wmon".
unfold UIter.
change (fun R => union (UExp F R)) with (Union (fun n => (fun R => UExp F R n))).
apply Union_wmon; intro i; apply UExp_wmon.
Qed.

End B.

Section C.

Variables X Y: Type.
Variable TX: reduction_t A X.
Variable TY: reduction_t A Y.

Variables F G: function X X.
Hypothesis HF: wmonotonic TX TX F.
Hypothesis HG: wmonotonic TX TX G.

Lemma Chaining_wmon: wmonotonic TX TX (Chain F G).
Proof. hammer_hook "WeakMonotonic" "WeakMonotonic.Chaining_wmon".
unfold Chain; split.
intros R S HRS x y H; destruct H as [ w H1 H2 ]; exists w;
[ apply (wmon_m HF HRS) | apply (wmon_m HG HRS) ]; auto.
intros R HR x x' y Hxx' xRy; destruct xRy as [ w xRw wRy ].
destruct (wmon_t HF HR _ _ _ Hxx' xRw) as [ w' Hww' x'Rw' ].
destruct (weak_strong_t (wmon_t HG HR) _ Hww' wRy) as [ y' Hyy' x'Ry' ].
exists y'; auto; exists w'; auto.
intros R S HR HS HRS HRS' a x x' y Hxx' xRy; destruct xRy as [ w xRw wRy ].
destruct (wmon_a HF HR HS HRS HRS' _ _ _ _ Hxx' xRw) as [ w' Hww' x'Rw' ].
destruct Hww' as [ w1 Hww1 Hw1w' ]; destruct Hw1w' as [ w2 Hw1w2 Hw2w' ].
destruct (weak_strong_t (wmon_t HG HR) _ Hww1 wRy) as [ y1 Hyy1 w1Ry1 ].
destruct (wmon_a HG HR HS HRS HRS' _ _ _ _ Hw1w2 w1Ry1) as [ y2 Hy1y2 w2Ry2 ].
destruct (weak_strong_t (wmon_t HG HS) _ Hw2w' w2Ry2) as [ y' Hy2y' w'Ry' ].
exists y'.
apply taus_weak with y1; auto; apply weak_taus with y2; auto.
exists w'; auto.
Qed.

Variable L: relation Y.
Hypothesis HL: simulation TY TY L.

Lemma chaing_l_wmon: wmonotonic TY TX (chaining_l L).
Proof. hammer_hook "WeakMonotonic" "WeakMonotonic.chaing_l_wmon".
split.
intros R S HRS x y H; destruct H as [ w ]; exists w; auto.
intros R HR x x' y Hxx' xRy; destruct xRy as [ w xRw wRy ].
destruct (HL Hxx' xRw) as [ w' Hww' x'Rw' ].
destruct (weak_strong_t HR _ Hww' wRy) as [ y' Hyy' x'Ry' ].
exists y'; auto; exists w'; auto.
intros R S HR HS HRS HRS' a x x' y Hxx' xRy; destruct xRy as [ w xRw wRy ].
destruct (HL Hxx' xRw) as [ w' Hww' x'Rw' ].
destruct Hww' as [ w1 Hww1 Hw1w' ]; destruct Hw1w' as [ w2 Hw1w2 Hw2w' ].
destruct (weak_strong_t HR _ Hww1 wRy) as [ y1 Hyy1 w1Ry1 ].
destruct (HRS _ _ _ _ Hw1w2 w1Ry1) as [ y2 Hy1y2 w2Ry2 ].
destruct (weak_strong_t HS _ Hw2w' w2Ry2) as [ y' Hy2y' w'Ry' ].
exists y'.
apply taus_weak with y1; auto; apply weak_taus with y2; auto.
exists w'; auto.
Qed.

End C.

End Global.


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

Require Import Bool.
Require Import Sumbool.
Require Import Arith.
Require Import ZArith NArith Nnat Ndec Ndigits.
From IntMap Require Import Allmaps.
Require Import Wf_nat.

Require Import BDDvar_ad_nat.
Require Import bdd1.
Require Import bdd2.
Require Import bdd3.
Require Import bdd4.
Require Import bdd5_1.
Require Import bdd5_2.
Require Import bdd6.

Fixpoint BDDor_1 (cfg : BDDconfig) (memo : BDDor_memo)
 (node1 node2 : ad) (bound : nat) {struct bound} :
 BDDconfig * (ad * BDDor_memo) :=
  match BDDor_memo_lookup memo node1 node2 with
  | Some node => (cfg, (node, memo))
  | None =>
      if N.eqb node1 BDDzero
      then (cfg, (node2, BDDor_memo_put memo BDDzero node2 node2))
      else
       if N.eqb node1 BDDone
       then (cfg, (BDDone, BDDor_memo_put memo BDDone node2 BDDone))
       else
        if N.eqb node2 BDDzero
        then (cfg, (node1, BDDor_memo_put memo node1 BDDzero node1))
        else
         if N.eqb node2 BDDone
         then (cfg, (BDDone, BDDor_memo_put memo node1 BDDone BDDone))
         else
          match bound with
          | O => (initBDDconfig, (BDDzero, initBDDor_memo))
          | S bound' =>
              match BDDcompare (var cfg node1) (var cfg node2) with
              | Datatypes.Eq =>
                  (fst
                     (BDDmake
                        (fst
                           (BDDor_1
                              (fst
                                 (BDDor_1 cfg memo
                                    (low cfg node1)
                                    (low cfg node2) bound'))
                              (snd
                                 (snd
                                    (BDDor_1 cfg memo
                                       (low cfg node1)
                                       (low cfg node2) bound')))
                              (high cfg node1) (high cfg node2) bound'))
                        (var cfg node1)
                        (fst
                           (snd
                              (BDDor_1 cfg memo (low cfg node1)
                                 (low cfg node2) bound')))
                        (fst
                           (snd
                              (BDDor_1
                                 (fst
                                    (BDDor_1 cfg memo
                                       (low cfg node1)
                                       (low cfg node2) bound'))
                                 (snd
                                    (snd
                                       (BDDor_1 cfg memo
                                          (low cfg node1)
                                          (low cfg node2) bound')))
                                 (high cfg node1) (high cfg node2) bound')))),
                  (snd
                     (BDDmake
                        (fst
                           (BDDor_1
                              (fst
                                 (BDDor_1 cfg memo
                                    (low cfg node1)
                                    (low cfg node2) bound'))
                              (snd
                                 (snd
                                    (BDDor_1 cfg memo
                                       (low cfg node1)
                                       (low cfg node2) bound')))
                              (high cfg node1) (high cfg node2) bound'))
                        (var cfg node1)
                        (fst
                           (snd
                              (BDDor_1 cfg memo (low cfg node1)
                                 (low cfg node2) bound')))
                        (fst
                           (snd
                              (BDDor_1
                                 (fst
                                    (BDDor_1 cfg memo
                                       (low cfg node1)
                                       (low cfg node2) bound'))
                                 (snd
                                    (snd
                                       (BDDor_1 cfg memo
                                          (low cfg node1)
                                          (low cfg node2) bound')))
                                 (high cfg node1) (high cfg node2) bound')))),
                  BDDor_memo_put
                    (snd
                       (snd
                          (BDDor_1
                             (fst
                                (BDDor_1 cfg memo (low cfg node1)
                                   (low cfg node2) bound'))
                             (snd
                                (snd
                                   (BDDor_1 cfg memo
                                      (low cfg node1)
                                      (low cfg node2) bound')))
                             (high cfg node1) (high cfg node2) bound')))
                    node1 node2
                    (snd
                       (BDDmake
                          (fst
                             (BDDor_1
                                (fst
                                   (BDDor_1 cfg memo
                                      (low cfg node1)
                                      (low cfg node2) bound'))
                                (snd
                                   (snd
                                      (BDDor_1 cfg memo
                                         (low cfg node1)
                                         (low cfg node2) bound')))
                                (high cfg node1) (high cfg node2) bound'))
                          (var cfg node1)
                          (fst
                             (snd
                                (BDDor_1 cfg memo (low cfg node1)
                                   (low cfg node2) bound')))
                          (fst
                             (snd
                                (BDDor_1
                                   (fst
                                      (BDDor_1 cfg memo
                                         (low cfg node1)
                                         (low cfg node2) bound'))
                                   (snd
                                      (snd
                                         (BDDor_1 cfg memo
                                            (low cfg node1)
                                            (low cfg node2) bound')))
                                   (high cfg node1)
                                   (high cfg node2) bound')))))))
              | Datatypes.Lt =>
                  (fst
                     (BDDmake
                        (fst
                           (BDDor_1
                              (fst
                                 (BDDor_1 cfg memo node1
                                    (low cfg node2) bound'))
                              (snd
                                 (snd
                                    (BDDor_1 cfg memo node1
                                       (low cfg node2) bound'))) node1
                              (high cfg node2) bound'))
                        (var cfg node2)
                        (fst
                           (snd
                              (BDDor_1 cfg memo node1 (low cfg node2) bound')))
                        (fst
                           (snd
                              (BDDor_1
                                 (fst
                                    (BDDor_1 cfg memo node1
                                       (low cfg node2) bound'))
                                 (snd
                                    (snd
                                       (BDDor_1 cfg memo node1
                                          (low cfg node2) bound'))) node1
                                 (high cfg node2) bound')))),
                  (snd
                     (BDDmake
                        (fst
                           (BDDor_1
                              (fst
                                 (BDDor_1 cfg memo node1
                                    (low cfg node2) bound'))
                              (snd
                                 (snd
                                    (BDDor_1 cfg memo node1
                                       (low cfg node2) bound'))) node1
                              (high cfg node2) bound'))
                        (var cfg node2)
                        (fst
                           (snd
                              (BDDor_1 cfg memo node1 (low cfg node2) bound')))
                        (fst
                           (snd
                              (BDDor_1
                                 (fst
                                    (BDDor_1 cfg memo node1
                                       (low cfg node2) bound'))
                                 (snd
                                    (snd
                                       (BDDor_1 cfg memo node1
                                          (low cfg node2) bound'))) node1
                                 (high cfg node2) bound')))),
                  BDDor_memo_put
                    (snd
                       (snd
                          (BDDor_1
                             (fst
                                (BDDor_1 cfg memo node1
                                   (low cfg node2) bound'))
                             (snd
                                (snd
                                   (BDDor_1 cfg memo node1
                                      (low cfg node2) bound'))) node1
                             (high cfg node2) bound'))) node1 node2
                    (snd
                       (BDDmake
                          (fst
                             (BDDor_1
                                (fst
                                   (BDDor_1 cfg memo node1
                                      (low cfg node2) bound'))
                                (snd
                                   (snd
                                      (BDDor_1 cfg memo node1
                                         (low cfg node2) bound'))) node1
                                (high cfg node2) bound'))
                          (var cfg node2)
                          (fst
                             (snd
                                (BDDor_1 cfg memo node1
                                   (low cfg node2) bound')))
                          (fst
                             (snd
                                (BDDor_1
                                   (fst
                                      (BDDor_1 cfg memo node1
                                         (low cfg node2) bound'))
                                   (snd
                                      (snd
                                         (BDDor_1 cfg memo node1
                                            (low cfg node2) bound'))) node1
                                   (high cfg node2) bound')))))))
              | Datatypes.Gt =>
                  (fst
                     (BDDmake
                        (fst
                           (BDDor_1
                              (fst
                                 (BDDor_1 cfg memo
                                    (low cfg node1) node2 bound'))
                              (snd
                                 (snd
                                    (BDDor_1 cfg memo
                                       (low cfg node1) node2 bound')))
                              (high cfg node1) node2 bound'))
                        (var cfg node1)
                        (fst
                           (snd
                              (BDDor_1 cfg memo (low cfg node1) node2 bound')))
                        (fst
                           (snd
                              (BDDor_1
                                 (fst
                                    (BDDor_1 cfg memo
                                       (low cfg node1) node2 bound'))
                                 (snd
                                    (snd
                                       (BDDor_1 cfg memo
                                          (low cfg node1) node2 bound')))
                                 (high cfg node1) node2 bound')))),
                  (snd
                     (BDDmake
                        (fst
                           (BDDor_1
                              (fst
                                 (BDDor_1 cfg memo
                                    (low cfg node1) node2 bound'))
                              (snd
                                 (snd
                                    (BDDor_1 cfg memo
                                       (low cfg node1) node2 bound')))
                              (high cfg node1) node2 bound'))
                        (var cfg node1)
                        (fst
                           (snd
                              (BDDor_1 cfg memo (low cfg node1) node2 bound')))
                        (fst
                           (snd
                              (BDDor_1
                                 (fst
                                    (BDDor_1 cfg memo
                                       (low cfg node1) node2 bound'))
                                 (snd
                                    (snd
                                       (BDDor_1 cfg memo
                                          (low cfg node1) node2 bound')))
                                 (high cfg node1) node2 bound')))),
                  BDDor_memo_put
                    (snd
                       (snd
                          (BDDor_1
                             (fst
                                (BDDor_1 cfg memo (low cfg node1) node2
                                   bound'))
                             (snd
                                (snd
                                   (BDDor_1 cfg memo
                                      (low cfg node1) node2 bound')))
                             (high cfg node1) node2 bound'))) node1 node2
                    (snd
                       (BDDmake
                          (fst
                             (BDDor_1
                                (fst
                                   (BDDor_1 cfg memo
                                      (low cfg node1) node2 bound'))
                                (snd
                                   (snd
                                      (BDDor_1 cfg memo
                                         (low cfg node1) node2 bound')))
                                (high cfg node1) node2 bound'))
                          (var cfg node1)
                          (fst
                             (snd
                                (BDDor_1 cfg memo (low cfg node1) node2
                                   bound')))
                          (fst
                             (snd
                                (BDDor_1
                                   (fst
                                      (BDDor_1 cfg memo
                                         (low cfg node1) node2 bound'))
                                   (snd
                                      (snd
                                         (BDDor_1 cfg memo
                                            (low cfg node1) node2 bound')))
                                   (high cfg node1) node2 bound')))))))
              end
          end
  end.

Lemma BDDor_1_lemma_1 :
 forall (cfg : BDDconfig) (memo : BDDor_memo) (node1 node2 node : ad)
   (bound : nat),
 BDDor_memo_lookup memo node1 node2 = Some node ->
 BDDor_1 cfg memo node1 node2 bound = (cfg, (node, memo)).
Proof.
  intros cfg memo node1 node2 node bound H.  elim bound.  simpl in |- *.  rewrite H.  reflexivity.  intros n H0.  simpl in |- *; rewrite H; reflexivity.
Qed.

Lemma BDDor_1_lemma_zero_1 :
 forall (cfg : BDDconfig) (memo : BDDor_memo) (node1 : ad) (bound : nat),
 BDDor_memo_lookup memo node1 BDDzero = None ->
 BDDor_1 cfg memo node1 BDDzero bound =
 (cfg, (node1, BDDor_memo_put memo node1 BDDzero node1)).
Proof.
  intros cfg memo node1 bound H.  elim bound.  simpl in |- *.  rewrite H.  elim (sumbool_of_bool (N.eqb node1 BDDzero)).
  intro y.  rewrite y.  cut (node1 = BDDzero).  intro H0.  rewrite H0; reflexivity.
  apply Neqb_complete.  assumption.  intro y.  rewrite y.  elim (sumbool_of_bool (N.eqb node1 BDDone)); intro y0.
  rewrite y0.  cut (node1 = BDDone).  intro H0.  rewrite H0; reflexivity.  apply Neqb_complete.
  assumption.  rewrite y0.  reflexivity.  intros n H0.  simpl in |- *.  rewrite H.  elim (sumbool_of_bool (N.eqb node1 BDDzero)).
  intro y.  rewrite y.  cut (node1 = BDDzero).  intro H1.  rewrite H1.  reflexivity.
  apply Neqb_complete; assumption.  intro y.  rewrite y.  elim (sumbool_of_bool (N.eqb node1 BDDone)).
  intro y0.  rewrite y0.  cut (node1 = BDDone).  intro H1.  rewrite H1.  reflexivity.
  apply Neqb_complete.  assumption.  intro y0.  rewrite y0.  reflexivity.
Qed.

Lemma BDDor_1_lemma_one_1 :
 forall (cfg : BDDconfig) (memo : BDDor_memo) (node1 : ad) (bound : nat),
 BDDor_memo_lookup memo node1 BDDone = None ->
 BDDor_1 cfg memo node1 BDDone bound =
 (cfg, (BDDone, BDDor_memo_put memo node1 BDDone BDDone)).
Proof.
  intros cfg memo node1 bound H.  elim bound.  simpl in |- *.  rewrite H.  elim (sumbool_of_bool (N.eqb node1 BDDzero)).
  intro y.  rewrite y.  cut (node1 = BDDzero).  intro H0.  rewrite H0; reflexivity.
  apply Neqb_complete.  assumption.  intro y.  rewrite y.  elim (sumbool_of_bool (N.eqb node1 BDDone)); intro y0.
  rewrite y0.  cut (node1 = BDDone).  intro H0.  rewrite H0; reflexivity.  apply Neqb_complete.
  assumption.  rewrite y0.  reflexivity.  intros n H0.  simpl in |- *.  rewrite H.  elim (sumbool_of_bool (N.eqb node1 BDDzero)).
  intro y.  rewrite y.  cut (node1 = BDDzero).  intro H1.  rewrite H1.  reflexivity.
  apply Neqb_complete; assumption.  intro y.  rewrite y.  elim (sumbool_of_bool (N.eqb node1 BDDone)).
  intro y0.  rewrite y0.  cut (node1 = BDDone).  intro H1.  rewrite H1.  reflexivity.
  apply Neqb_complete.  assumption.  intro y0.  rewrite y0.  reflexivity.
Qed.

Lemma BDDor_1_lemma_zero_2 :
 forall (cfg : BDDconfig) (memo : BDDor_memo) (node2 : ad) (bound : nat),
 BDDor_memo_lookup memo BDDzero node2 = None ->
 BDDor_1 cfg memo BDDzero node2 bound =
 (cfg, (node2, BDDor_memo_put memo BDDzero node2 node2)).
Proof.
  intros cfg memo node2 bound H.  elim bound.  simpl in |- *.  rewrite H.  reflexivity.  intros n H0.  simpl in |- *.  rewrite H.  reflexivity.
Qed.

Lemma BDDor_1_lemma_one_2 :
 forall (cfg : BDDconfig) (memo : BDDor_memo) (node2 : ad) (bound : nat),
 BDDor_memo_lookup memo BDDone node2 = None ->
 BDDor_1 cfg memo BDDone node2 bound =
 (cfg, (BDDone, BDDor_memo_put memo BDDone node2 BDDone)).
Proof.
  intros cfg memo node2 bound H.  elim bound.  simpl in |- *.  rewrite H.  reflexivity.  intros n H0.  simpl in |- *.  rewrite H.  reflexivity.
Qed.

Lemma BDDor_1_lemma_internal_1 :
 forall (cfg : BDDconfig) (memo : BDDor_memo) (node1 node2 : ad)
   (bound bound' : nat),
 BDDor_memo_lookup memo node1 node2 = None ->
 BDDconfig_OK cfg ->
 is_internal_node cfg node1 ->
 is_internal_node cfg node2 ->
 max (nat_of_N (var cfg node1)) (nat_of_N (var cfg node2)) < bound ->
 bound = S bound' ->
 BDDcompare (var cfg node1) (var cfg node2) = Datatypes.Eq ->
 BDDor_1 cfg memo node1 node2 bound =
 (fst
    (BDDmake
       (fst
          (BDDor_1
             (fst (BDDor_1 cfg memo (low cfg node1) (low cfg node2) bound'))
             (snd
                (snd
                   (BDDor_1 cfg memo (low cfg node1) (low cfg node2) bound')))
             (high cfg node1) (high cfg node2) bound'))
       (var cfg node1)
       (fst (snd (BDDor_1 cfg memo (low cfg node1) (low cfg node2) bound')))
       (fst
          (snd
             (BDDor_1
                (fst
                   (BDDor_1 cfg memo (low cfg node1) (low cfg node2) bound'))
                (snd
                   (snd
                      (BDDor_1 cfg memo (low cfg node1)
                         (low cfg node2) bound')))
                (high cfg node1) (high cfg node2) bound')))),
 (snd
    (BDDmake
       (fst
          (BDDor_1
             (fst (BDDor_1 cfg memo (low cfg node1) (low cfg node2) bound'))
             (snd
                (snd
                   (BDDor_1 cfg memo (low cfg node1) (low cfg node2) bound')))
             (high cfg node1) (high cfg node2) bound'))
       (var cfg node1)
       (fst (snd (BDDor_1 cfg memo (low cfg node1) (low cfg node2) bound')))
       (fst
          (snd
             (BDDor_1
                (fst
                   (BDDor_1 cfg memo (low cfg node1) (low cfg node2) bound'))
                (snd
                   (snd
                      (BDDor_1 cfg memo (low cfg node1)
                         (low cfg node2) bound')))
                (high cfg node1) (high cfg node2) bound')))),
 BDDor_memo_put
   (snd
      (snd
         (BDDor_1
            (fst (BDDor_1 cfg memo (low cfg node1) (low cfg node2) bound'))
            (snd
               (snd (BDDor_1 cfg memo (low cfg node1) (low cfg node2) bound')))
            (high cfg node1) (high cfg node2) bound'))) node1 node2
   (snd
      (BDDmake
         (fst
            (BDDor_1
               (fst (BDDor_1 cfg memo (low cfg node1) (low cfg node2) bound'))
               (snd
                  (snd
                     (BDDor_1 cfg memo (low cfg node1) (low cfg node2) bound')))
               (high cfg node1) (high cfg node2) bound'))
         (var cfg node1)
         (fst (snd (BDDor_1 cfg memo (low cfg node1) (low cfg node2) bound')))
         (fst
            (snd
               (BDDor_1
                  (fst
                     (BDDor_1 cfg memo (low cfg node1) (low cfg node2) bound'))
                  (snd
                     (snd
                        (BDDor_1 cfg memo (low cfg node1)
                           (low cfg node2) bound')))
                  (high cfg node1) (high cfg node2) bound'))))))).
Proof.
  intros cfg memo node1 node2 bound bound' H H0 H1 H2 H3 H4 H5.  rewrite H4.  simpl in |- *.  rewrite H.  cut (N.eqb node1 BDDzero = false).  cut (N.eqb node1 BDDone = false).
  cut (N.eqb node2 BDDzero = false).  cut (N.eqb node2 BDDone = false).  intros H6 H7 H8 H9.
  rewrite H6; rewrite H7; rewrite H8; rewrite H9; rewrite H5; reflexivity.
  apply not_true_is_false.  unfold not in |- *.  intro H6.  cut (node2 = BDDone).  intro H7.
  inversion H2.  inversion H8.  inversion H9.  rewrite H7 in H10.  rewrite (config_OK_one cfg H0) in H10; discriminate.
  apply Neqb_complete.  assumption.  apply not_true_is_false.  unfold not in |- *; intro.
  cut (node2 = BDDzero).  intro H7.  inversion H2.  inversion H8.  inversion H9.  rewrite H7 in H10.
  rewrite (config_OK_zero cfg H0) in H10; discriminate.  apply Neqb_complete; assumption.
  apply not_true_is_false.  unfold not in |- *; intro.  cut (node1 = BDDone).  intro H7.
  inversion H1.  inversion H8.  inversion H9.  rewrite H7 in H10.
  rewrite (config_OK_one cfg H0) in H10; discriminate.  apply Neqb_complete; assumption.
  apply not_true_is_false.  unfold not in |- *; intro.  cut (node1 = BDDzero).  intro H7.
  inversion H1.  inversion H8.  inversion H9.  rewrite H7 in H10.  rewrite (config_OK_zero cfg H0) in H10; discriminate.
  apply Neqb_complete; assumption.
Qed.

Lemma BDDor_1_lemma_internal_2 :
 forall (cfg : BDDconfig) (memo : BDDor_memo) (node1 node2 : ad)
   (bound bound' : nat),
 BDDor_memo_lookup memo node1 node2 = None ->
 BDDconfig_OK cfg ->
 is_internal_node cfg node1 ->
 is_internal_node cfg node2 ->
 max (nat_of_N (var cfg node1)) (nat_of_N (var cfg node2)) < bound ->
 bound = S bound' ->
 BDDcompare (var cfg node1) (var cfg node2) = Datatypes.Lt ->
 BDDor_1 cfg memo node1 node2 bound =
 (fst
    (BDDmake
       (fst
          (BDDor_1 (fst (BDDor_1 cfg memo node1 (low cfg node2) bound'))
             (snd (snd (BDDor_1 cfg memo node1 (low cfg node2) bound')))
             node1 (high cfg node2) bound')) (var cfg node2)
       (fst (snd (BDDor_1 cfg memo node1 (low cfg node2) bound')))
       (fst
          (snd
             (BDDor_1 (fst (BDDor_1 cfg memo node1 (low cfg node2) bound'))
                (snd (snd (BDDor_1 cfg memo node1 (low cfg node2) bound')))
                node1 (high cfg node2) bound')))),
 (snd
    (BDDmake
       (fst
          (BDDor_1 (fst (BDDor_1 cfg memo node1 (low cfg node2) bound'))
             (snd (snd (BDDor_1 cfg memo node1 (low cfg node2) bound')))
             node1 (high cfg node2) bound')) (var cfg node2)
       (fst (snd (BDDor_1 cfg memo node1 (low cfg node2) bound')))
       (fst
          (snd
             (BDDor_1 (fst (BDDor_1 cfg memo node1 (low cfg node2) bound'))
                (snd (snd (BDDor_1 cfg memo node1 (low cfg node2) bound')))
                node1 (high cfg node2) bound')))),
 BDDor_memo_put
   (snd
      (snd
         (BDDor_1 (fst (BDDor_1 cfg memo node1 (low cfg node2) bound'))
            (snd (snd (BDDor_1 cfg memo node1 (low cfg node2) bound'))) node1
            (high cfg node2) bound'))) node1 node2
   (snd
      (BDDmake
         (fst
            (BDDor_1 (fst (BDDor_1 cfg memo node1 (low cfg node2) bound'))
               (snd (snd (BDDor_1 cfg memo node1 (low cfg node2) bound')))
               node1 (high cfg node2) bound')) (var cfg node2)
         (fst (snd (BDDor_1 cfg memo node1 (low cfg node2) bound')))
         (fst
            (snd
               (BDDor_1 (fst (BDDor_1 cfg memo node1 (low cfg node2) bound'))
                  (snd (snd (BDDor_1 cfg memo node1 (low cfg node2) bound')))
                  node1 (high cfg node2) bound'))))))).
Proof.
  intros cfg memo node1 node2 bound bound' H H0 H1 H2 H3 H4 H5.  rewrite H4.  simpl in |- *.  rewrite H.  cut (N.eqb node1 BDDzero = false).  cut (N.eqb node1 BDDone = false).
  cut (N.eqb node2 BDDzero = false).  cut (N.eqb node2 BDDone = false).  intros H6 H7 H8 H9.
  rewrite H6; rewrite H7; rewrite H8; rewrite H9; rewrite H5; reflexivity.
  apply not_true_is_false.  unfold not in |- *.  intro H6.  cut (node2 = BDDone).  intro H7.
  inversion H2.  inversion H8.  inversion H9.  rewrite H7 in H10.  rewrite (config_OK_one cfg H0) in H10; discriminate.
  apply Neqb_complete.  assumption.  apply not_true_is_false.  unfold not in |- *; intro.
  cut (node2 = BDDzero).  intro H7.  inversion H2.  inversion H8.  inversion H9.  rewrite H7 in H10.
  rewrite (config_OK_zero cfg H0) in H10; discriminate.  apply Neqb_complete; assumption.
  apply not_true_is_false.  unfold not in |- *; intro.  cut (node1 = BDDone).  intro H7.
  inversion H1.  inversion H8.  inversion H9.  rewrite H7 in H10.
  rewrite (config_OK_one cfg H0) in H10; discriminate.  apply Neqb_complete; assumption.
  apply not_true_is_false.  unfold not in |- *; intro.  cut (node1 = BDDzero).  intro H7.
  inversion H1.  inversion H8.  inversion H9.  rewrite H7 in H10.  rewrite (config_OK_zero cfg H0) in H10; discriminate.
  apply Neqb_complete; assumption.
Qed.

Lemma BDDor_1_lemma_internal_3 :
 forall (cfg : BDDconfig) (memo : BDDor_memo) (node1 node2 : ad)
   (bound bound' : nat),
 BDDor_memo_lookup memo node1 node2 = None ->
 BDDconfig_OK cfg ->
 is_internal_node cfg node1 ->
 is_internal_node cfg node2 ->
 max (nat_of_N (var cfg node1)) (nat_of_N (var cfg node2)) < bound ->
 bound = S bound' ->
 BDDcompare (var cfg node1) (var cfg node2) = Datatypes.Gt ->
 BDDor_1 cfg memo node1 node2 bound =
 (fst
    (BDDmake
       (fst
          (BDDor_1 (fst (BDDor_1 cfg memo (low cfg node1) node2 bound'))
             (snd (snd (BDDor_1 cfg memo (low cfg node1) node2 bound')))
             (high cfg node1) node2 bound')) (var cfg node1)
       (fst (snd (BDDor_1 cfg memo (low cfg node1) node2 bound')))
       (fst
          (snd
             (BDDor_1 (fst (BDDor_1 cfg memo (low cfg node1) node2 bound'))
                (snd (snd (BDDor_1 cfg memo (low cfg node1) node2 bound')))
                (high cfg node1) node2 bound')))),
 (snd
    (BDDmake
       (fst
          (BDDor_1 (fst (BDDor_1 cfg memo (low cfg node1) node2 bound'))
             (snd (snd (BDDor_1 cfg memo (low cfg node1) node2 bound')))
             (high cfg node1) node2 bound')) (var cfg node1)
       (fst (snd (BDDor_1 cfg memo (low cfg node1) node2 bound')))
       (fst
          (snd
             (BDDor_1 (fst (BDDor_1 cfg memo (low cfg node1) node2 bound'))
                (snd (snd (BDDor_1 cfg memo (low cfg node1) node2 bound')))
                (high cfg node1) node2 bound')))),
 BDDor_memo_put
   (snd
      (snd
         (BDDor_1 (fst (BDDor_1 cfg memo (low cfg node1) node2 bound'))
            (snd (snd (BDDor_1 cfg memo (low cfg node1) node2 bound')))
            (high cfg node1) node2 bound'))) node1 node2
   (snd
      (BDDmake
         (fst
            (BDDor_1 (fst (BDDor_1 cfg memo (low cfg node1) node2 bound'))
               (snd (snd (BDDor_1 cfg memo (low cfg node1) node2 bound')))
               (high cfg node1) node2 bound')) (var cfg node1)
         (fst (snd (BDDor_1 cfg memo (low cfg node1) node2 bound')))
         (fst
            (snd
               (BDDor_1 (fst (BDDor_1 cfg memo (low cfg node1) node2 bound'))
                  (snd (snd (BDDor_1 cfg memo (low cfg node1) node2 bound')))
                  (high cfg node1) node2 bound'))))))).
Proof.
  intros cfg memo node1 node2 bound bound' H H0 H1 H2 H3 H4 H5.  rewrite H4.  simpl in |- *.  rewrite H.  cut (N.eqb node1 BDDzero = false).  cut (N.eqb node1 BDDone = false).
  cut (N.eqb node2 BDDzero = false).  cut (N.eqb node2 BDDone = false).  intros H6 H7 H8 H9.
  rewrite H6; rewrite H7; rewrite H8; rewrite H9; rewrite H5; reflexivity.
  apply not_true_is_false.  unfold not in |- *.  intro H6.  cut (node2 = BDDone).  intro H7.
  inversion H2.  inversion H8.  inversion H9.  rewrite H7 in H10.  rewrite (config_OK_one cfg H0) in H10; discriminate.
  apply Neqb_complete.  assumption.  apply not_true_is_false.  unfold not in |- *; intro.
  cut (node2 = BDDzero).  intro H7.  inversion H2.  inversion H8.  inversion H9.  rewrite H7 in H10.
  rewrite (config_OK_zero cfg H0) in H10; discriminate.  apply Neqb_complete; assumption.
  apply not_true_is_false.  unfold not in |- *; intro.  cut (node1 = BDDone).  intro H7.
  inversion H1.  inversion H8.  inversion H9.  rewrite H7 in H10.
  rewrite (config_OK_one cfg H0) in H10; discriminate.  apply Neqb_complete; assumption.
  apply not_true_is_false.  unfold not in |- *; intro.  cut (node1 = BDDzero).  intro H7.
  inversion H1.  inversion H8.  inversion H9.  rewrite H7 in H10.  rewrite (config_OK_zero cfg H0) in H10; discriminate.
  apply Neqb_complete; assumption.
Qed.

Lemma BDDvar_le_max_2 :
 forall x y : BDDvar, BDDvar_le x (BDDvar_max y x) = true.
Proof.
  unfold BDDvar_max in |- *.  unfold BDDvar_le in |- *.  intros x y.  elim (sumbool_of_bool (Nleb y x)).
  intro y0.  rewrite y0.  apply Nleb_refl.  intro y0.  rewrite y0.  apply Nltb_leb_weak.
  assumption.
Qed.

Lemma BDDvar_le_max_1 :
 forall x y : BDDvar, BDDvar_le x (BDDvar_max x y) = true.
Proof.
  intros x y.  elim (sumbool_of_bool (Nleb x y)); unfold BDDvar_max in |- *;
   unfold BDDvar_le in |- *.
  intro y0.  rewrite y0.  assumption.  intro y0.  rewrite y0.  apply Nleb_refl.
Qed.

Lemma BDDor_1_internal :
 forall (cfg : BDDconfig) (memo : BDDor_memo) (node1 node2 : ad)
   (bound : nat),
 BDDconfig_OK cfg ->
 config_node_OK cfg node1 ->
 config_node_OK cfg node2 ->
 BDDor_memo_OK cfg memo ->
 is_internal_node (fst (BDDor_1 cfg memo node1 node2 bound))
   (fst (snd (BDDor_1 cfg memo node1 node2 bound))) ->
 is_internal_node cfg node1 \/ is_internal_node cfg node2.
Proof.
  intros cfg memo node1 node2 bound H H0 H1 H2 H3.  elim H0; intro.  elim H1; intro.  rewrite H4 in H3.  rewrite H5 in H3.
  elim (option_sum _ (BDDor_memo_lookup memo BDDzero BDDzero)).  intro y.  inversion y.
  rewrite (BDDor_1_lemma_1 cfg memo BDDzero BDDzero x bound H6) in H3.  simpl in H3.
  unfold BDDor_memo_OK in H2.  cut
   (bool_fun_eq (bool_fun_of_BDD cfg x)
      (bool_fun_or (bool_fun_of_BDD cfg BDDzero)
         (bool_fun_of_BDD cfg BDDzero))).
  intro H7.  rewrite (proj1 (bool_fun_of_BDD_semantics cfg H)) in H7.  cut (x = BDDzero).
  intro H8.  inversion H3.  inversion H9.  inversion H10.  rewrite H8 in H11.
  rewrite (config_OK_zero cfg H) in H11.  discriminate.  apply BDDunique with (cfg := cfg).
  assumption.  right.  right.  unfold in_dom in |- *.  inversion H3.  inversion H8.  inversion H9.
  rewrite H10.  reflexivity.  left; reflexivity.  apply
   bool_fun_eq_trans with (bf2 := bool_fun_or bool_fun_zero bool_fun_zero).
  assumption.  rewrite (proj1 (bool_fun_of_BDD_semantics cfg H)).  unfold bool_fun_eq in |- *.
  reflexivity.  exact (proj2 (proj2 (proj2 (proj2 (H2 BDDzero BDDzero x H6))))).
  intro y.  rewrite (BDDor_1_lemma_zero_1 cfg memo BDDzero bound y) in H3.  simpl in H3.
  inversion H3.  inversion H6.  inversion H7.  rewrite (config_OK_zero cfg H) in H8.
  discriminate.  elim H5; clear H5; intro.  rewrite H4 in H3.  rewrite H5 in H3.
  elim (option_sum _ (BDDor_memo_lookup memo BDDzero BDDone)).  intro y.  inversion y.
  rewrite (BDDor_1_lemma_1 cfg memo BDDzero BDDone x bound H6) in H3.  simpl in H3.
  unfold BDDor_memo_OK in H2.  cut
   (bool_fun_eq (bool_fun_of_BDD cfg x)
      (bool_fun_or (bool_fun_of_BDD cfg BDDzero) (bool_fun_of_BDD cfg BDDone))).
  intro H7.  rewrite (proj1 (bool_fun_of_BDD_semantics cfg H)) in H7.  rewrite (proj1 (proj2 (bool_fun_of_BDD_semantics cfg H))) in H7.
  cut (x = BDDone).  intro H8.  inversion H3.  inversion H9.  inversion H10.  rewrite H8 in H11.
  rewrite (config_OK_one cfg H) in H11.  discriminate.  apply BDDunique with (cfg := cfg).
  assumption.  right.  right.  unfold in_dom in |- *.  inversion H3.  inversion H8.
  inversion H9.  rewrite H10.  reflexivity.  right; left; reflexivity.
  apply
   bool_fun_eq_trans with (bf2 := bool_fun_or bool_fun_zero bool_fun_one).
  assumption.  rewrite (proj1 (proj2 (bool_fun_of_BDD_semantics cfg H))).
  unfold bool_fun_eq in |- *.  reflexivity.  exact (proj2 (proj2 (proj2 (proj2 (H2 BDDzero BDDone x H6))))).
  intro y.  rewrite (BDDor_1_lemma_one_1 cfg memo BDDzero bound y) in H3.  simpl in H3.
  inversion H3.  inversion H6.  inversion H7.  rewrite (config_OK_one cfg H) in H8.
  discriminate.  right.  apply in_dom_is_internal.  assumption.  elim H4; clear H4; intro.
  rewrite H4 in H3.  elim (option_sum _ (BDDor_memo_lookup memo BDDone node2)).
  intro y.  inversion y.  rewrite (BDDor_1_lemma_1 cfg memo BDDone node2 x bound H5) in H3.
  simpl in H3.  unfold BDDor_memo_OK in H2.  cut (x = BDDone).  intro H6.  rewrite H6 in H3.
  inversion H3.  inversion H7.  inversion H8.  rewrite (config_OK_one cfg H) in H9.
  discriminate.  apply BDDunique with (cfg := cfg).  assumption.  exact (proj1 (proj2 (proj2 (H2 BDDone node2 x H5)))).
  right; left; reflexivity.  apply
   bool_fun_eq_trans
    with
      (bf2 := bool_fun_or (bool_fun_of_BDD cfg BDDone)
                (bool_fun_of_BDD cfg node2)).
  exact (proj2 (proj2 (proj2 (proj2 (H2 BDDone node2 x H5))))).
  rewrite (proj1 (proj2 (bool_fun_of_BDD_semantics cfg H))).  apply
   bool_fun_eq_trans
    with (bf2 := bool_fun_or (bool_fun_of_BDD cfg node2) bool_fun_one).
  apply bool_fun_or_commute.  apply bool_fun_or_one.  intro y.  rewrite (BDDor_1_lemma_one_2 cfg memo node2 bound y) in H3.
  simpl in H3.  inversion H3.  inversion H5.  inversion H6.  rewrite (config_OK_one cfg H) in H7.
  discriminate.  left.  apply in_dom_is_internal.  assumption.
Qed.


(* Correctness proof of the lowering pass *)

Require Export specIR.
Require Export lowering.
Require Export ir_properties.
Require Export internal_simulations.

(* Matching stackframes: a version may have been replaced with its lowered version *)
Inductive match_stackframe: stackframe -> stackframe -> Prop :=
| frame_same: forall sf, match_stackframe sf sf
| frame_lowered:
    forall r v lbl rm vlow
      (LOW: lowering_version v = vlow),
      match_stackframe (Stackframe r v lbl rm) (Stackframe r vlow lbl rm).

(* Generalizing match_stackframe to the entire stack *)
Inductive match_stack: stack -> stack -> Prop :=
| match_nil:
    match_stack nil nil
| match_cons:
    forall s s' sf sf'
      (MS: match_stack s s')
      (MSF: match_stackframe sf sf'),
      match_stack (sf::s) (sf'::s').

Lemma match_stack_same:
  forall s, match_stack s s.
Proof.
  intros. induction s; constructor. auto. apply frame_same.
Qed.

(** * Lowering Properties *)
Lemma base_low_refl_code:
  forall c,
    base_code c ->
    lowering_code c = c.
Proof.
  intros c H. unfold base_code in H. unfold lowering_code.
  unfold PTree.map1. induction c; auto.
  rewrite IHc2. 2: { intros. eapply H with (pc:=(pc~1)%positive). simpl. auto. }
  rewrite IHc1. 2: { intros. eapply H with (pc:=(pc~0)%positive). simpl. auto. }
  destruct o; simpl; auto.
  assert (~is_spec i). { apply H with (pc:=1%positive). simpl. auto. }
  assert (transf_instr i = i). { destruct i; auto. exfalso. apply H0. constructor. }
  rewrite H1. auto.
Qed.

Lemma fn_base_low:
  forall f,
    lowering_version (fn_base f) = fn_base f.
Proof.
  intros f. unfold lowering_version. rewrite base_low_refl_code.
  destruct f; simpl; auto. destruct fn_base; simpl; auto.
  destruct f. simpl. unfold base_version in base_no_spec. auto.
Qed.

Lemma base_low_refl:
  forall v,
    base_version v ->
    lowering_version v = v.
Proof.
  intros v H. unfold lowering_version. unfold base_version in H. rewrite base_low_refl_code; auto.
  destruct v. simpl. auto.
Qed.

Lemma same_params:
  forall f,
    (fn_params f) = (fn_params (lowering_function f)).
Proof.
  intros. unfold lowering_function. destruct (fn_opt f); simpl; auto.
Qed.

Lemma same_entry:
  forall f,
    ver_entry (current_version f) = ver_entry (current_version (lowering_function f)).
Proof.
  intros f. unfold lowering_function. destruct (fn_opt f) eqn:OPT; simpl; auto.
  unfold current_version. rewrite OPT. auto.
Qed.

Lemma lowering_current:
  forall f, lowering_version (current_version f) = current_version (lowering_function f).
Proof.
  intros f. unfold lowering_function. destruct (fn_opt f) eqn:OPT; simpl; auto.
  unfold current_version. rewrite OPT. simpl. auto.
  unfold current_version. rewrite OPT. apply fn_base_low.
Qed.

(** * Match states invariant  *)
(* This proof is a lockstep backward internal simulation.
   Each step of the optimized program is matched with a step of the source.
   No index is needed for the match_states invariant.
   Framestate steps are matched with Nop steps.

<<

       st1 --------------- st2
        |                   |
       t|                   |t
        |                   |
        v                   v
       st1'--------------- st2'

>>
*)

Inductive match_states (p:program) : unit -> specIR.state -> specIR.state -> Prop :=
| lowered_match:
    forall s s' v vlow pc rm ms
      (LOW: lowering_version v = vlow)
      (MATCHSTACK: match_stack s s'),
      (match_states p) tt (State s v pc rm ms) (State s' vlow pc rm ms)
| refl_match:
    forall s s' v pc rm ms
      (MATCHSTACK: match_stack s s'),
      (match_states p) tt (State s v pc rm ms) (State s' v pc rm ms)
| final_match:
    forall retval ms,
      (match_states p) tt (Final retval ms) (Final retval ms).

Inductive order : unit -> unit -> Prop := .
Lemma wfounded:
  well_founded order.
Proof.
  unfold well_founded. intros. destruct a. constructor. intros. inv H.
Qed.

Lemma trans:
  Relation_Definitions.transitive _ order.
Proof.
  unfold Relation_Definitions.transitive. intros. inv H.
Qed.

(** * Code preservation properties  *)
Lemma preserved_code:
  forall v vlow i pc,
    lowering_version v = vlow ->
    (ver_code vlow) # pc = Some i ->
    exists i', (ver_code v) # pc = Some i' /\ transf_instr i' = i.
Proof.
  intros v vlow i pc LOW CODE. unfold lowering_version in LOW. rewrite <- LOW in CODE.
  simpl in CODE. unfold lowering_code in CODE.
  rewrite PTree.gmap1 in CODE. unfold option_map in CODE.
  destruct ((ver_code v)!pc); inv CODE.
  exists i0. split; auto.
Qed.

Lemma code_preserved:
  forall v vlow i pc,
    lowering_version v = vlow ->
    (ver_code v) # pc = Some i ->
    (ver_code vlow) # pc = Some (transf_instr i).
Proof.
  intros v vlow i pc LOW CODE. unfold lowering_version in LOW. rewrite <- LOW. simpl.
  unfold lowering_code. rewrite PTree.gmap1. unfold option_map. rewrite CODE. auto.
Qed.

Lemma base_version_unchanged:
  forall p fid,
    find_base_version fid p = find_base_version fid (lowering p).
Proof.
  intros. unfold find_base_version, lowering, find_function, find_function_list.
  simpl. rewrite PTree.gmap1. unfold option_map.
  destruct ((prog_funlist p)!fid) eqn:FINDF; auto.
  unfold lowering_function. destruct (fn_opt f); auto.
Qed.

Lemma find_function_lowered:
  forall p fid f,
    find_function fid (lowering p) = Some f ->
    exists f', find_function fid p = Some f' /\ lowering_function f' = f.
Proof.
  intros p fid f H. unfold find_function, find_function_list in *. unfold lowering in H. simpl in H.
  rewrite PTree.gmap1 in H. unfold option_map in H.
  destruct ((prog_funlist p)!fid) eqn:FINDF; inv H.
  exists f0. split; auto.
Qed.

Lemma lowered_find_function:
  forall p fid f,
    find_function fid p = Some f ->
    find_function fid (lowering p) = Some (lowering_function f).
Proof.
  unfold find_function, find_function_list, lowering. intros p fid f FINDF. simpl.
  rewrite PTree.gmap1. unfold option_map. rewrite FINDF. auto.
Qed.

(** * Invariant preservation  *)
Lemma match_synth:
  forall p rm sl synthlow p0,
    p0 = lowering p ->
    specIR.synthesize_frame p0 rm sl synthlow ->
    exists synthsrc, specIR.synthesize_frame p rm sl synthsrc /\ match_stack synthsrc synthlow.
Proof.
  intros p rm sl synthlow p0 LOW SYNTH.
  induction SYNTH; intros.
  - exists nil. split; constructor.
  - specialize (IHSYNTH LOW). destruct IHSYNTH as [synthsrc [SYNTH' MATCH]]. exists ((Stackframe r version l update)::synthsrc).
    split. constructor; auto.
    rewrite LOW in FINDV. rewrite <- base_version_unchanged in FINDV. rewrite FINDV. auto.
    constructor; auto. constructor; auto.
Qed.

Lemma synth_match:
  forall p rm sl synth,
    specIR.synthesize_frame p rm sl synth ->
    exists synthlow, specIR.synthesize_frame (lowering p) rm sl synthlow.
Proof.
  intros p rm sl synth SYNTH. induction SYNTH.
  - exists nil. constructor.
  - destruct IHSYNTH as [sylow IHSYNTH].
    rewrite base_version_unchanged in FINDV.
    exists (Stackframe r version l update::sylow). constructor; auto.
Qed.

Lemma app_match:
  forall synth synthlow s slow,
    match_stack s slow ->
    match_stack synth synthlow ->
    match_stack (synth++s) (synthlow++slow).
Proof.
  intros. induction H0.
  - simpl. auto.
  - repeat rewrite <- app_comm_cons. apply match_cons; auto.
Qed.

(* for backward simulations, safety of the source must be shown to be preserved *)
Lemma safe_preserved_state:
  forall p i s v pc rm ms s2,
    match_states p i (State s v pc rm ms) s2 ->
    safe (specir_sem p) (State s v pc rm ms) ->
    exists t, exists s2', specir_step (lowering p) s2 t s2'.
Proof.
  intros p i s v pc rm ms s2 MATCH SAFE. inv MATCH.
  { apply safe_step in SAFE as [nexts [t STEP]]. exists t.
    inv STEP.
    - inv STEP0; eapply code_preserved in CODE; eauto; simpl in CODE; simpl; eauto.
      + exists (State s' (lowering_version v) next rm ms). apply nd_exec_lowered. eapply exec_Nop. eauto.
      + exists (State s' (lowering_version v) next (rm#reg<-v0) ms). apply nd_exec_lowered. eapply exec_Op; eauto.
      + exists (State s' (lowering_version v) next newrm ms). apply nd_exec_lowered. eapply exec_Move; eauto.
      + exists (State s' (lowering_version v) (pc_cond v0 iftrue iffalse) rm ms). apply nd_exec_lowered.
        eapply exec_Cond; eauto.
      + apply lowered_find_function in FINDF. simpl in FINDF.
        exists (State (Stackframe retreg (lowering_version v) next rm ::s') (current_version (lowering_function func)) (ver_entry (current_version (lowering_function func))) newrm ms).
        apply nd_exec_lowered. eapply exec_Call; eauto. unfold lowering_function.
        destruct (fn_opt func); simpl; auto.
      + inv MATCHSTACK. inv MSF.
        * exists (State s'0 fprev next (rmprev#retreg<-retval) ms).
          apply nd_exec_lowered. eapply exec_Return; eauto.
        * exists (State s'0 (lowering_version fprev) next (rmprev#retreg<-retval) ms).
          apply nd_exec_lowered. eapply exec_Return; eauto.
      + inv MATCHSTACK. exists (Final retval ms). apply nd_exec_lowered. eapply exec_Return_Final; eauto.
      + exists (State s' (lowering_version v) next rm ms). apply nd_exec_lowered. eapply exec_Printexpr; eauto.
      + exists (State s' (lowering_version v) next rm ms). apply nd_exec_lowered. eapply exec_Printstring. auto.
      + exists (State s' (lowering_version v) next rm newms). apply nd_exec_lowered. eapply exec_Store; eauto.
      + exists (State s' (lowering_version v) next (rm#reg<-val) ms). apply nd_exec_lowered. eapply exec_Load; eauto.
      + exists (State s' (lowering_version v) next rm ms). apply nd_exec_lowered. eapply exec_Assume_holds; eauto.
      + apply synth_match in SYNTH as [synthlow SYNTH]. rewrite base_version_unchanged in FINDF.
        exists (State (synthlow ++ s') newver la newrm ms). apply nd_exec_lowered. eapply exec_Assume_fails; eauto.
    - exists (State s' (lowering_version v) next rm ms). apply nd_exec_lowered. eapply exec_Nop. inv DEOPT_COND.
      eapply code_preserved in CODE; eauto.
    - exists (State s' (lowering_version v) next rm ms). apply nd_exec_lowered. eapply exec_Nop. inv DEOPT_COND.
      eapply code_preserved in CODE; eauto. }
  { apply safe_step in SAFE as [nexts [t STEP]]. exists t.
    inv STEP.
    - inv STEP0.
      + exists (State s' v next rm ms). apply nd_exec_lowered. eapply exec_Nop. eauto.
      + exists (State s' v next (rm#reg<-v0) ms). apply nd_exec_lowered. eapply exec_Op; eauto.
      + exists (State s' v next newrm ms). apply nd_exec_lowered. eapply exec_Move; eauto.
      + exists (State s' v (pc_cond v0 iftrue iffalse) rm ms). apply nd_exec_lowered. eapply exec_Cond; eauto.
      + apply lowered_find_function in FINDF. simpl in FINDF.
        exists (State (Stackframe retreg v next rm ::s') (current_version (lowering_function func)) (ver_entry (current_version (lowering_function func))) newrm ms).
        apply nd_exec_lowered. eapply exec_Call; eauto. unfold lowering_function.
        destruct (fn_opt func); simpl; auto.
      + inv MATCHSTACK. inv MSF.
        * exists (State s'0 fprev next (rmprev#retreg<-retval) ms).
          apply nd_exec_lowered. eapply exec_Return; eauto.
        * exists (State s'0 (lowering_version fprev) next (rmprev#retreg<-retval) ms).
          apply nd_exec_lowered. eapply exec_Return; eauto.
      + inv MATCHSTACK. exists (Final retval ms). apply nd_exec_lowered. eapply exec_Return_Final; eauto.
      + exists (State s' v next rm ms). apply nd_exec_lowered. eapply exec_Printexpr; eauto.
      + exists (State s' v next rm ms). apply nd_exec_lowered. eapply exec_Printstring. auto.
      + exists (State s' v next rm newms). apply nd_exec_lowered. eapply exec_Store; eauto.
      + exists (State s' v next (rm#reg<-val) ms). apply nd_exec_lowered. eapply exec_Load; eauto.
      + exists (State s' v next rm ms). apply nd_exec_lowered. eapply exec_Assume_holds; eauto.
      + apply synth_match in SYNTH as [synthlow SYNTH]. rewrite base_version_unchanged in FINDF.
        exists (State (synthlow ++ s') newver la newrm ms). apply nd_exec_lowered. eapply exec_Assume_fails; eauto.
    - exists (State s' v next rm ms). inv DEOPT_COND. apply synth_match in SYNTH as [sl' SYNTH].
      eapply nd_exec_Framestate_go_on.
      econstructor; eauto. rewrite <- base_version_unchanged. eauto.
    - exists (State s' v next rm ms). inv DEOPT_COND. apply synth_match in SYNTH as [sl' SYNTH].
      eapply nd_exec_Framestate_go_on.
      econstructor; eauto. rewrite <- base_version_unchanged. eauto. }
Qed.

Lemma safe_preserved_final:
  forall p i v ms s2,
    match_states p i (Final v ms) s2 ->
    exists r, final_state (lowering p) s2 r.
Proof.
  intros p i v ms s2 MATCH. inv MATCH. exists v. constructor.
Qed.

(* Proved directly with a backward simulation *)
Theorem lowering_correct:
  forall p newp,
    lowering p = newp ->
    backward_internal_simulation p newp.
Proof.
  intros. apply Backward_internal_simulation with (bsim_match_states:=match_states p) (bsim_order:=order).
  - apply wfounded.
  - apply trans.
  - unfold reflexive_forge. intros synchro stack r1 s1 ms FORGE.
    destruct synchro; simpl in FORGE; repeat do_ok; simpl.
    + erewrite lowered_find_function; eauto. simpl. rewrite <- same_params. rewrite HDO0. simpl.
      repeat (esplit; eauto). simpl. rewrite <- same_entry. apply lowered_match.
      apply lowering_current. apply match_stack_same.
    + destruct stack; try destruct s; inv FORGE.
      * repeat (esplit; eauto). constructor.
      * repeat (esplit; eauto). simpl. apply refl_match. apply match_stack_same.
    + destruct d. repeat do_ok. simpl. rewrite <- base_version_unchanged. rewrite HDO0. simpl.
      repeat (esplit; eauto). simpl. apply refl_match. apply match_stack_same.
    + inv FORGE. exists r1. exists s1. split; auto. exists tt. destruct r1; simpl.
      * apply refl_match. apply match_stack_same.
      * apply final_match.
  - intros i s1 s2 r MATCH SAFE FINAL.
    inv FINAL. inv MATCH. exists (Final r ms). split. apply star_refl. constructor.

  - intros i s1 s2 MATCH SAFE.  (* safe preserved *)
    inv MATCH.
    + eapply safe_preserved_state in SAFE as [t [s2' STEP]]. 2: constructor; eauto.
      right. exists t. exists s2'. auto.
    + eapply safe_preserved_state in SAFE as [t [s2' STEP]].
      right. exists t. exists s2'. apply STEP. apply refl_match. auto.
    + left. simpl. eapply safe_preserved_final. constructor.

  - intros s2 t s2' STEP i s1 MATCH SAFE. exists tt. inv MATCH.
    +                           (* lowered_match *)
      inv STEP.
      { inv STEP0; eapply preserved_code in CODE as [i' [CODE TRANSF]]; eauto; destruct i'; inv TRANSF.
        - exists (State s v next rm ms). split. (* When Nop in the target comes from Nop in the source *)
            left. apply plus_one. apply nd_exec_lowered. eapply exec_Nop; eauto.
            constructor; auto.
        - exists (State s v next rm ms). split. (* Nop in the target comes from Framestate in the source *)
          left. apply plus_one. apply safe_step in SAFE as [s'' [t STEP]].
          { inv STEP.
            + inv STEP0; rewrite CODE0 in CODE; inv CODE.
            + inv DEOPT_COND. rewrite CODE0 in CODE. inv CODE.
              eapply nd_exec_Framestate_go_on. econstructor; eauto.
            + inv DEOPT_COND. rewrite CODE0 in CODE. inv CODE.
              eapply nd_exec_Framestate_go_on. econstructor; eauto. }
          constructor; auto.
        - exists (State s v next (rm#reg<-v0) ms). split.
          left. apply plus_one. apply nd_exec_lowered. eapply exec_Op; eauto.
          constructor; auto.
        - exists (State s v next newrm ms). split.
          left. apply plus_one. apply nd_exec_lowered. eapply exec_Move; eauto.
          constructor; auto.
        - exists (State s v (pc_cond v0 iftrue iffalse) rm ms). split.
          left. apply plus_one. apply nd_exec_lowered. eapply exec_Cond; eauto.
          constructor; auto.
        - destruct (fn_opt func) eqn:OPT.
          + apply find_function_lowered in FINDF as [f' [FINDF LOW]].
            exists (State (Stackframe retreg v next rm::s) (current_version f') (ver_entry (current_version f')) newrm ms).
            split.
            left. apply plus_one. apply nd_exec_lowered.
            { eapply exec_Call.
              - apply CODE.
              - apply FINDF.
              - auto.
              - apply EVALL.
              - rewrite <- LOW in INIT_REGS. unfold lowering_function in INIT_REGS.
                destruct (fn_opt f'); simpl in INIT_REGS; auto. }
            assert (ver_entry (current_version f') = ver_entry (current_version func)).
            { rewrite <- LOW. unfold lowering_function, current_version.
              destruct (fn_opt f') eqn:OPT'; simpl; auto.
              rewrite OPT'. auto. }
            rewrite H. constructor; auto.
            * rewrite <- LOW. unfold current_version, lowering_function.
              destruct (fn_opt f') eqn:OPT'; simpl; try rewrite OPT'; auto.
              apply fn_base_low.
            * constructor; auto. constructor; auto.
          + exists (State (Stackframe retreg v next rm::s) (current_version func) (ver_entry (current_version func)) newrm ms). split.
            left. apply plus_one. apply nd_exec_lowered.
            unfold find_function, find_function_list, lowering in *. simpl in FINDF.
            rewrite PTree.gmap1 in FINDF. unfold option_map in FINDF. simpl.
            destruct ((prog_funlist p)! fid) eqn:FIND; inv FINDF.
            destruct (fn_opt f) eqn:OPT'. { unfold lowering_function in OPT. rewrite OPT' in OPT. inv OPT. }
            { eapply exec_Call.
              - apply CODE.
              - unfold find_function, find_function_list. rewrite FIND. auto.
              - unfold current_version. unfold lowering_function. rewrite OPT'. rewrite OPT'. auto.
              - apply EVALL.
              - unfold lowering_function in INIT_REGS. rewrite OPT' in INIT_REGS. auto. }
            constructor; auto.
            * unfold current_version. rewrite OPT. apply fn_base_low.
            * constructor; auto. constructor; auto.
        - inv MATCHSTACK. inv MSF.
          + exists (State s1 fprev next (rmprev#retreg<-retval) ms). split.
            left. apply plus_one. apply nd_exec_lowered. eapply exec_Return; eauto.
            apply refl_match. auto.
          + exists (State s1 v0 next (rmprev#retreg<-retval) ms). split.
            left. apply plus_one. apply nd_exec_lowered. eapply exec_Return; eauto.
            constructor; auto.
        - inv MATCHSTACK. exists (Final retval ms). split.
          left. apply plus_one. apply nd_exec_lowered. eapply exec_Return_Final; eauto.
          constructor; auto.
        - exists (State s v next rm ms). split.
          left. apply plus_one. apply nd_exec_lowered. eapply exec_Printexpr; eauto.
          constructor; auto.
        - exists (State s v next rm ms). split.
          left. apply plus_one. apply nd_exec_lowered. eapply exec_Printstring; eauto.
          constructor; eauto.
        - exists (State s v next rm newms). split.
          left. apply plus_one. apply nd_exec_lowered. eapply exec_Store; eauto.
          constructor; auto.
        - exists (State s v next (rm#reg<-val) ms). split.
          left. apply plus_one. apply nd_exec_lowered. eapply exec_Load; eauto.
          constructor; auto.
        - exists (State s v next rm ms). split.
          left. apply plus_one. apply nd_exec_lowered. eapply exec_Assume_holds; eauto.
          constructor; auto.
        - eapply match_synth in SYNTH as [synthsrc [SYNTH MATCH]]; simpl; eauto.
          exists (State (synthsrc++s) newver la newrm ms). split.
          left. apply plus_one. apply nd_exec_lowered. eapply exec_Assume_fails; eauto.
          rewrite base_version_unchanged. auto.
          constructor; auto. unfold find_base_version in FINDF. simpl in FINDF.
          destruct (find_function fa (lowering p)) eqn:FINDF'; inv FINDF. apply fn_base_low.
          apply app_match; auto. }
      * inv DEOPT_COND. unfold lowering_version, lowering_code in CODE. simpl in CODE.
        rewrite PTree.gmap1 in CODE. unfold option_map in CODE.
        destruct ((ver_code v)!pc); inv CODE. destruct i; inv H0.
      * inv DEOPT_COND. unfold lowering_version, lowering_code in CODE. simpl in CODE.
        rewrite PTree.gmap1 in CODE. unfold option_map in CODE.
        destruct ((ver_code v)!pc); inv CODE. destruct i; inv H0.
    + inv STEP.                 (* refl match *)
      { inv STEP0.
        - exists (State s v next rm ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Nop; eauto.
          + apply refl_match; auto.
        - exists (State s v next (rm#reg<-v0) ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Op; eauto.
          + apply refl_match; auto.
        - exists (State s v next newrm ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Move; eauto.
          + apply refl_match; auto.
        - exists (State s v (pc_cond v0 iftrue iffalse) rm ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Cond; eauto.
          + apply refl_match; auto.
        - destruct (fn_opt func) eqn:OPT.
          + apply find_function_lowered in FINDF as [f' [FINDF LOW]].
            exists (State (Stackframe retreg v next rm::s) (current_version f') (ver_entry (current_version f')) newrm ms).
            split.
            left. apply plus_one. apply nd_exec_lowered.
            { eapply exec_Call.
              - apply CODE.
              - apply FINDF.
              - auto.
              - apply EVALL.
              - rewrite <- LOW in INIT_REGS. unfold lowering_function in INIT_REGS.
                destruct (fn_opt f'); simpl in INIT_REGS; auto. }
            assert (ver_entry (current_version f') = ver_entry (current_version func)).
            { rewrite <- LOW. unfold lowering_function, current_version.
              destruct (fn_opt f') eqn:OPT'; simpl; auto.
              rewrite OPT'. auto. }
            rewrite H. constructor; auto.
            * rewrite <- LOW. unfold current_version, lowering_function.
              destruct (fn_opt f') eqn:OPT'; simpl; try rewrite OPT'; auto.
              apply fn_base_low.
            * constructor; auto. constructor; auto.
          + exists (State (Stackframe retreg v next rm::s) (current_version func) (ver_entry (current_version func)) newrm ms). split.
            left. apply plus_one. apply nd_exec_lowered.
            unfold find_function, find_function_list, lowering in *. simpl in FINDF.
            rewrite PTree.gmap1 in FINDF. unfold option_map in FINDF. simpl.
            destruct ((prog_funlist p)! fid) eqn:FIND; inv FINDF.
            destruct (fn_opt f) eqn:OPT'. { unfold lowering_function in OPT. rewrite OPT' in OPT. inv OPT. }
            { eapply exec_Call.
              - apply CODE.
              - unfold find_function, find_function_list. rewrite FIND. auto.
              - unfold current_version. unfold lowering_function. rewrite OPT'. rewrite OPT'. auto.
              - apply EVALL.
              - unfold lowering_function in INIT_REGS. rewrite OPT' in INIT_REGS. auto. }
            constructor; auto.
            * unfold current_version. rewrite OPT. apply fn_base_low.
            * constructor; auto. constructor; auto.
        - inv MATCHSTACK. inv MSF.
          + exists (State s1 fprev next (rmprev#retreg<-retval) ms). split.
            * left. apply plus_one. apply nd_exec_lowered. eapply exec_Return; eauto.
            * apply refl_match. auto.
          + exists (State s1 v0 next (rmprev#retreg<-retval) ms). split.
            * left. apply plus_one. apply nd_exec_lowered. eapply exec_Return; eauto.
            * constructor; auto.
        - inv MATCHSTACK. exists (Final retval ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Return_Final; eauto.
          + apply final_match; auto.
        - exists (State s v next rm ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Printexpr; eauto.
          + apply refl_match; auto.
        - exists (State s v next rm ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Printstring; eauto.
          + apply refl_match; auto.
        - exists (State s v next rm newms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Store; eauto.
          + apply refl_match; auto.
        - exists (State s v next (rm#reg<-val) ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Load; eauto.
          + apply refl_match; auto.
        - exists (State s v next rm ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Assume_holds; eauto.
          + apply refl_match; auto.
        - simpl in SYNTH. eapply match_synth with (p:=p) in SYNTH as [synthsrc [SYNTH MS]].
          exists (State (synthsrc++s) newver la newrm ms). split.
          + left. apply plus_one. apply nd_exec_lowered. eapply exec_Assume_fails; eauto.
            rewrite base_version_unchanged; auto.
          + apply refl_match; auto. apply app_match; auto.
          + auto. }
      { inv DEOPT_COND. eapply match_synth in SYNTH as [synthsrc [SYNTH MS]].
        exists (State s v next rm ms). split.
        - left. apply plus_one. eapply nd_exec_Framestate_go_on. econstructor; eauto.
          rewrite base_version_unchanged. eauto.
        - apply refl_match; auto.
        - simpl. auto. }
      { inv DEOPT_COND. eapply match_synth in SYNTH as [synthsrc [SYNTH MS]].
        exists (State (synthsrc++s) newver la newrm ms). split.
        - left. apply plus_one. eapply nd_exec_Framestate_deopt. econstructor; eauto.
          rewrite base_version_unchanged. eauto.
        - apply refl_match; auto. apply app_match; auto.
        - simpl. auto. }

    +                           (* final_match *)
      inv STEP. inv STEP0.
Qed.


From stdpp Require Import relations sorting.
From Coq Require Import ssreflect.

Declare Scope grammar_scope.
Local Open Scope grammar_scope.

(* Positioned token. *)
Record pos_token (Σ : Type) := {
  token : Σ;
  pos : nat (* line number *) * nat (* column number *);
}.

Arguments token {_}.
Arguments pos {_}.

Notation "a @ p" := {|
  token := a;
  pos := p;
|} (at level 40) : grammar_scope.

Global Instance pos_token_eq_dec Σ `{!EqDecision Σ} : EqDecision (pos_token Σ).
Proof.
  intros [a1 p1] [a2 p2].
  destruct (decide (a1 = a2 ∧ p1 = p2)); [left | right]; naive_solver.
Qed.

Definition pos_token_lt (Σ : Type) : relation (pos_token Σ) := λ pt1 pt2,
  match pos pt1, pos pt2 with (x1, y1), (x2, y2) =>
    (x1 < x2) ∨ (x1 = x2 ∧ y1 < y2)
  end.

Global Instance pos_token_lt_trans Σ : Transitive (pos_token_lt Σ).
Proof.
  intros [? [? ?]] [? [? ?]] [? [? ?]].
  unfold pos_token_lt. simpl. lia.
Qed.

(* Sentence: a list of positioned tokens. *)
Definition sentence (Σ : Type) : Type := list (pos_token Σ).

(* A well-formed sentence: positions are increasing. *)
Definition well_formed {Σ : Type} (w : sentence Σ) : Prop :=
  Sorted (pos_token_lt Σ) w.

(* Layout-free clauses. *)
Inductive lf_clause (Σ N : Type) : Type :=
  | lf_ε
  | lf_atom (a : Σ)
  | lf_unary (A : N)
  | lf_binary (Al Ar : N)
  .

Arguments lf_ε {_} {_}.
Arguments lf_atom {_} {_}.
Arguments lf_unary {_} {_}.
Arguments lf_binary {_} {_}.

Definition check_lf_clause_eq {Σ N} `{!EqDecision Σ} `{!EqDecision N} (α β : lf_clause Σ N) : bool :=
  match α, β with
  | lf_ε, lf_ε => true
  | lf_atom a, lf_atom b => bool_decide (a = b)
  | lf_unary A, lf_unary A' => bool_decide (A = A')
  | lf_binary Al Ar, lf_binary Al' Ar' =>
    bool_decide (Al = Al') && bool_decide (Ar = Ar')
  | _, _ => false
  end.

Lemma check_lf_clause_eq_spec {Σ N} `{!EqDecision Σ} `{!EqDecision N} (α β : lf_clause Σ N) :
  check_lf_clause_eq α β = true ↔ α = β.
Proof.
  destruct α; destruct β => //=.
  all: try rewrite !andb_true_iff.
  all: rewrite !bool_decide_eq_true.
  all: naive_solver.
Qed.

Global Instance lf_clause_eq_dec Σ N `{!EqDecision Σ} `{!EqDecision N} : EqDecision (lf_clause Σ N).
Proof.
  intros α β.
  have ? : check_lf_clause_eq α β = true ↔ α = β by apply check_lf_clause_eq_spec.
  destruct (check_lf_clause_eq α β); [left | right]; naive_solver.
Qed.

(* Layout predicates. *)
Definition unary_predicate (Σ : Type) : Type := {p : sentence Σ → bool & p [] = true}.
Definition app₁ {Σ : Type} (φ : unary_predicate Σ) := projT1 φ.

Definition binary_predicate (Σ : Type) : Type :=
  {p : sentence Σ → sentence Σ → bool & ∀ w1 w2, w1 = [] ∨ w2 = [] → p w1 w2 = true}.
Definition app₂ {Σ : Type} (φ : binary_predicate Σ) := projT1 φ.

(* Layout-sensitive binary normal form. *)
Record grammar (Σ N : Type) := {
  (* start symbol *)
  start : N;
  (* productions *)
  lf_clauses : N → list (lf_clause Σ N);
  lf_clauses_no_dup : ∀ A, NoDup (lf_clauses A);
  unary_clause_predicate : N → N → unary_predicate Σ;
  binary_clause_predicate : N → N → N → binary_predicate Σ;
}.

Arguments lf_clauses {_} {_}.
Arguments lf_clauses_no_dup {_} {_}.
Arguments unary_clause_predicate {_} {_}.
Arguments binary_clause_predicate {_} {_}.

(* Layout-sensitive clauses. *)
Inductive clause (Σ N : Type) : Type :=
  | ε
  | atom (token : Σ)
  | unary (A : N) (φ : unary_predicate Σ)
  | binary (Al Ar : N) (φ : binary_predicate Σ)
  .

Arguments ε {_} {_}.
Arguments atom {_} {_}.
Arguments unary {_} {_}.
Arguments binary {_} {_}.

Definition clauses {Σ N : Type} (G : grammar Σ N) (A : N) : list (clause Σ N) :=
  (λ α, match α with
  | lf_ε => ε
  | lf_atom a => atom a
  | lf_unary B => unary B (unary_clause_predicate G A B)
  | lf_binary Bl Br => binary Bl Br (binary_clause_predicate G A Bl Br)
  end) <$> lf_clauses G A.

Inductive production (Σ N : Type) : Type :=
  mk_production (lhs : N) (rhs : clause Σ N).
Arguments mk_production {_} {_}.
Notation "A ↦ α" := (mk_production A α) (at level 40) : grammar_scope.

Global Instance production_elem_of_grammar Σ N : ElemOf (production Σ N) (grammar Σ N) := λ p G,
  match p with
  | mk_production A α => α ∈ clauses G A
  end.
(* So that one can write "A ↦ α ∈ G". *)

Ltac invert H := inversion H; subst; clear H.

Section clauses.
  Context {Σ N : Type}.
  Context (G : grammar Σ N).

  Lemma elem_of_clauses A α :
    A ↦ α ∈ G → match α with
    | ε => lf_ε ∈ lf_clauses G A
    | atom a => lf_atom a ∈ lf_clauses G A
    | unary B φ => lf_unary B ∈ lf_clauses G A ∧
        φ = unary_clause_predicate G A B
    | binary Bl Br φ => lf_binary Bl Br ∈ lf_clauses G A ∧
        φ = binary_clause_predicate G A Bl Br
    end.
  Proof.
    unfold elem_of, production_elem_of_grammar.
    rewrite elem_of_list_fmap. intros [? [Heq ?]]. destruct α.
    all: case_match => //.
    all: by invert Heq.
  Qed.

  Lemma unary_clause_predicate_unique A B φ φ' :
    A ↦ unary B φ ∈ G →
    A ↦ unary B φ' ∈ G →
    φ = φ'.
  Proof.
    intros Hφ Hφ'. apply elem_of_clauses in Hφ, Hφ'.
    naive_solver.
  Qed.

  Lemma binary_clause_predicate_unique A Bl Br φ φ' :
    A ↦ binary Bl Br φ ∈ G →
    A ↦ binary Bl Br φ' ∈ G →
    φ = φ'.
  Proof.
    intros Hφ Hφ'. apply elem_of_clauses in Hφ, Hφ'.
    naive_solver.
  Qed.
End clauses.

Section parsing.
  Context {Σ N : Type}.

  (* Parse tree. *)
  Inductive tree : Type :=
    | ε_tree (r : N)
    | token_tree (r : N) (pt : pos_token Σ)
    | unary_tree (r : N) (t : tree)
    | binary_tree (r : N) (tl tr : tree)
    .

  Definition root t : N :=
    match t with
    | ε_tree R => R
    | token_tree R _ => R
    | unary_tree R _ => R
    | binary_tree R _ _ => R
    end.

  Fixpoint word t : sentence Σ :=
    match t with
    | ε_tree _ => []
    | token_tree _ tk => [tk]
    | unary_tree _ t' => word t'
    | binary_tree _ t1 t2 => word t1 ++ word t2
    end.

  Context `{!EqDecision Σ} `{!EqDecision N}.

  Fixpoint check_tree_eq t1 t2 : bool :=
    match t1, t2 with
    | ε_tree A, ε_tree A' => bool_decide (A = A')
    | token_tree A tk1, token_tree A' tk2 => bool_decide (A = A' ∧ tk1 = tk2)
    | unary_tree A t1, unary_tree A' t2 =>
      bool_decide (A = A') && check_tree_eq t1 t2
    | binary_tree A tA1 tB1, binary_tree A' tA2 tB2 =>
      bool_decide (A = A') && check_tree_eq tA1 tA2 && check_tree_eq tB1 tB2
    | _, _ => false
    end.

  Lemma check_tree_eq_spec t1 t2 :
    check_tree_eq t1 t2 = true ↔ t1 = t2.
  Proof.
    generalize dependent t2.
    induction t1; destruct t2 => //=.
    all: try rewrite !andb_true_iff.
    all: rewrite !bool_decide_eq_true.
    all: naive_solver.
  Qed.

  Global Instance tree_eq_dec : EqDecision tree.
  Proof.
    intros t1 t2.
    have ? := check_tree_eq_spec t1 t2.
    destruct (check_tree_eq t1 t2); [left | right]; naive_solver.
  Qed.

  Context (G : grammar Σ N).

  (* Parse tree validity. *)
  Inductive tree_valid : tree → Prop :=
    | valid_ε A :
      A ↦ ε ∈ G →
      tree_valid (ε_tree A)
    | valid_token A a p :
      A ↦ atom a ∈ G →
      tree_valid (token_tree A (a @ p))
    | valid_unary A t' φ :
      A ↦ unary (root t') φ ∈ G →
      tree_valid t' →
      app₁ φ (word t') = true →
      tree_valid (unary_tree A t')
    | valid_binary A t1 t2 φ :
      A ↦ binary (root t1) (root t2) φ ∈ G →
      tree_valid t1 →
      tree_valid t2 →
      app₂ φ (word t1) (word t2) = true →
      tree_valid (binary_tree A t1 t2)
    .

  Definition tree_witness t A w := root t = A ∧ word t = w ∧ tree_valid t.

  (* derivation *)
  Definition derive A w : Prop := ∃ t, tree_witness t A w.

End parsing.
Notation "✓{ G } t" := (tree_valid G t) (at level 40, format "'✓{' G '}'  t") : grammar_scope.
Notation "t ▷ A ={ G }=> w" := (tree_witness G t A w) (at level 40) : grammar_scope.
Notation "G ⊨ A => w" := (derive G A w) (at level 65) : grammar_scope.


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

Require Import Bool.
Require Import Sumbool.
Require Import Arith.
Require Import ZArith NArith Nnat Ndec Ndigits.
From IntMap Require Import Allmaps.
Require Import Wf_nat.

Require Import BDDvar_ad_nat.
Require Import bdd1.
Require Import bdd2.
Require Import bdd3.
Require Import bdd4.
Require Import bdd5_1.
Require Import bdd5_2.
Require Import bdd6.
Require Import bdd7.
Require Import BDDdummy_lemma_2.
Require Import BDDdummy_lemma_3.
Require Import BDDdummy_lemma_4.

Lemma BDDor_1_lemma :
 forall (bound : nat) (cfg : BDDconfig) (node1 node2 : ad)
   (memo : BDDor_memo),
 BDDconfig_OK cfg ->
 BDDor_memo_OK cfg memo ->
 config_node_OK cfg node1 ->
 config_node_OK cfg node2 ->
 (is_internal_node cfg node1 ->
  is_internal_node cfg node2 ->
  max (nat_of_N (var cfg node1)) (nat_of_N (var cfg node2)) < bound) ->
 BDDconfig_OK (fst (BDDor_1 cfg memo node1 node2 bound)) /\
 BDDor_memo_OK (fst (BDDor_1 cfg memo node1 node2 bound))
   (snd (snd (BDDor_1 cfg memo node1 node2 bound))) /\
 config_node_OK (fst (BDDor_1 cfg memo node1 node2 bound))
   (fst (snd (BDDor_1 cfg memo node1 node2 bound))) /\
 nodes_preserved cfg (fst (BDDor_1 cfg memo node1 node2 bound)) /\
 BDDvar_le
   (var (fst (BDDor_1 cfg memo node1 node2 bound))
      (fst (snd (BDDor_1 cfg memo node1 node2 bound))))
   (BDDvar_max (var cfg node1) (var cfg node2)) = true /\
 bool_fun_eq
   (bool_fun_of_BDD (fst (BDDor_1 cfg memo node1 node2 bound))
      (fst (snd (BDDor_1 cfg memo node1 node2 bound))))
   (bool_fun_or (bool_fun_of_BDD cfg node1) (bool_fun_of_BDD cfg node2)).
Proof.
intro bound.
apply
 lt_wf_ind
  with
    (P := fun bound : nat =>
          forall (cfg : BDDconfig) (node1 node2 : ad) (memo : BDDor_memo),
          BDDconfig_OK cfg ->
          BDDor_memo_OK cfg memo ->
          config_node_OK cfg node1 ->
          config_node_OK cfg node2 ->
          (is_internal_node cfg node1 ->
           is_internal_node cfg node2 ->
           max (nat_of_N (var cfg node1)) (nat_of_N (var cfg node2)) <
           bound) ->
          BDDconfig_OK (fst (BDDor_1 cfg memo node1 node2 bound)) /\
          BDDor_memo_OK (fst (BDDor_1 cfg memo node1 node2 bound))
            (snd (snd (BDDor_1 cfg memo node1 node2 bound))) /\
          config_node_OK (fst (BDDor_1 cfg memo node1 node2 bound))
            (fst (snd (BDDor_1 cfg memo node1 node2 bound))) /\
          nodes_preserved cfg (fst (BDDor_1 cfg memo node1 node2 bound)) /\
          BDDvar_le
            (var (fst (BDDor_1 cfg memo node1 node2 bound))
               (fst (snd (BDDor_1 cfg memo node1 node2 bound))))
            (BDDvar_max (var cfg node1) (var cfg node2)) = true /\
          bool_fun_eq
            (bool_fun_of_BDD (fst (BDDor_1 cfg memo node1 node2 bound))
               (fst (snd (BDDor_1 cfg memo node1 node2 bound))))
            (bool_fun_or (bool_fun_of_BDD cfg node1)
               (bool_fun_of_BDD cfg node2))).

clear bound.
intro bound.
intro H.
intros cfg node1 node2 memo H0 H1 H2 H3 H4.
elim (option_sum _ (BDDor_memo_lookup memo node1 node2)); intro y.
elim y; clear y.
intros node H5.
rewrite (BDDor_1_lemma_1 cfg memo node1 node2 node bound H5).
simpl in |- *.
unfold BDDor_memo_OK in H1.
split.
assumption.

split.
assumption.

split.
exact (proj1 (proj2 (proj2 (H1 node1 node2 node H5)))).

split.
unfold nodes_preserved in |- *.
intros x l r node0 H6.
assumption.

split.
exact (proj1 (proj2 (proj2 (proj2 (H1 node1 node2 node H5))))).

exact (proj2 (proj2 (proj2 (proj2 (H1 node1 node2 node H5))))).

elim H2; intro.
rewrite H5.

rewrite (BDDor_1_lemma_zero_2 cfg memo node2 bound).
simpl in |- *.
cut
 (bool_fun_eq (bool_fun_of_BDD cfg node2)
    (bool_fun_or (bool_fun_of_BDD cfg BDDzero) (bool_fun_of_BDD cfg node2))).
intro H6.
split.
assumption.

split.
unfold BDDor_memo_OK in |- *.
intros node1' node2' node.
intros H7.
rewrite (BDDor_memo_lookup_semantics memo BDDzero node2 node2 node1' node2')
  in H7.
elim (sumbool_of_bool (N.eqb BDDzero node1' && N.eqb node2 node2')); intro y0.
cut (BDDzero = node1').
cut (node2 = node2').
intros H8 H9.
split.
rewrite <- H9.
left; reflexivity.

split.
rewrite <- H8; assumption.

split.
rewrite y0 in H7.
injection H7.
intro H10.
rewrite <- H10.
assumption.

split.
rewrite y0 in H7.
injection H7; intro.
rewrite <- H10.
rewrite <- H8.
apply BDDvar_le_max_2.

rewrite y0 in H7; injection H7; intro.
rewrite <- H10.
rewrite <- H9.
rewrite <- H8.
assumption.

apply Neqb_complete.
exact (proj2 (andb_prop (N.eqb BDDzero node1') (N.eqb node2 node2') y0)).

apply Neqb_complete.
exact (proj1 (andb_prop (N.eqb BDDzero node1') (N.eqb node2 node2') y0)).

rewrite y0 in H7.
unfold BDDor_memo_OK in H1.
split.
exact (proj1 (H1 node1' node2' node H7)).

split.
exact (proj1 (proj2 (H1 node1' node2' node H7))).

split.
exact (proj1 (proj2 (proj2 (H1 node1' node2' node H7)))).

split.
exact (proj1 (proj2 (proj2 (proj2 (H1 node1' node2' node H7))))).

exact (proj2 (proj2 (proj2 (proj2 (H1 node1' node2' node H7))))).

split.
assumption.

split.
unfold nodes_preserved in |- *; intro.
intros l r node H7.
assumption.

split.
apply BDDvar_le_max_2.

assumption.

rewrite (proj1 (bool_fun_of_BDD_semantics cfg H0)).
apply bool_fun_eq_symm.
apply
 bool_fun_eq_trans
  with (bool_fun_or (bool_fun_of_BDD cfg node2) bool_fun_zero).
apply bool_fun_or_commute.

apply bool_fun_or_zero.

rewrite <- H5; assumption.

elim H5; clear H5; intro.
rewrite H5.
rewrite (BDDor_1_lemma_one_2 cfg memo node2 bound).
simpl in |- *.
cut
 (bool_fun_eq (bool_fun_of_BDD cfg BDDone)
    (bool_fun_or (bool_fun_of_BDD cfg BDDone) (bool_fun_of_BDD cfg node2))).
intro H6.
split.
assumption.

split.
unfold BDDor_memo_OK in |- *.
intros node1' node2' node.
intros H7.
rewrite (BDDor_memo_lookup_semantics memo BDDone node2 BDDone node1' node2')
  in H7.
elim (sumbool_of_bool (N.eqb BDDone node1' && N.eqb node2 node2')); intro y0.
cut (BDDone = node1').
cut (node2 = node2').
intros H8 H9.
split.
rewrite <- H9.
right; left; reflexivity.

split.
rewrite <- H8; assumption.

split.
rewrite y0 in H7.
injection H7.
intro H10.
rewrite <- H10.
right; left; reflexivity.

split.
rewrite y0 in H7.
injection H7; intro.
rewrite <- H10.
rewrite <- H8.
unfold var at 1 in |- *.
rewrite (config_OK_one cfg H0).

unfold BDDzero in |- *.
apply BDDvar_le_z.

rewrite y0 in H7; injection H7; intro.
rewrite <- H10.
rewrite <- H9.
rewrite <- H8.
assumption.

apply Neqb_complete.
exact (proj2 (andb_prop (N.eqb BDDone node1') (N.eqb node2 node2') y0)).

apply Neqb_complete.
exact (proj1 (andb_prop (N.eqb BDDone node1') (N.eqb node2 node2') y0)).

rewrite y0 in H7.
unfold BDDor_memo_OK in H1.
split.
exact (proj1 (H1 node1' node2' node H7)).

split.
exact (proj1 (proj2 (H1 node1' node2' node H7))).

split.
exact (proj1 (proj2 (proj2 (H1 node1' node2' node H7)))).

split.
exact (proj1 (proj2 (proj2 (proj2 (H1 node1' node2' node H7))))).

exact (proj2 (proj2 (proj2 (proj2 (H1 node1' node2' node H7))))).

split.
right; left; reflexivity.

split.
unfold nodes_preserved in |- *; intro.
intros l r node H7.
assumption.

split.
apply BDDvar_le_max_1.

assumption.

rewrite (proj1 (proj2 (bool_fun_of_BDD_semantics cfg H0))).
apply
 bool_fun_eq_trans
  with (bf2 := bool_fun_or (bool_fun_of_BDD cfg node2) bool_fun_one).
apply bool_fun_eq_symm.
apply bool_fun_or_one.

apply bool_fun_or_commute.

rewrite <- H5; assumption.

elim H3; intro.
rewrite H6.
rewrite (BDDor_1_lemma_zero_1 cfg memo node1 bound).
simpl in |- *.
cut
 (bool_fun_eq (bool_fun_of_BDD cfg node1)
    (bool_fun_or (bool_fun_of_BDD cfg node1) (bool_fun_of_BDD cfg BDDzero))).
intro H7.
split.
assumption.

split.
unfold BDDor_memo_OK in |- *.
intros node1' node2' node.
intros H8.
rewrite (BDDor_memo_lookup_semantics memo node1 BDDzero node1 node1' node2')
  in H8.
elim (sumbool_of_bool (N.eqb node1 node1' && N.eqb BDDzero node2')); intro y0.
cut (node1 = node1').
cut (BDDzero = node2').
intros H9 H10.
split.
rewrite <- H10; assumption.

split.
rewrite <- H9; left; reflexivity.

split.
rewrite y0 in H8.
injection H8; intro.

rewrite <- H11; assumption.

split.
rewrite y0 in H8.
injection H8; intro.
rewrite <- H10.
rewrite <- H11.
apply BDDvar_le_max_1.

rewrite <- H9.
rewrite <- H10.
rewrite y0 in H8; injection H8; intro.
rewrite <- H11.
assumption.

apply Neqb_complete.
exact (proj2 (andb_prop (N.eqb node1 node1') (N.eqb BDDzero node2') y0)).

apply Neqb_complete.
exact (proj1 (andb_prop (N.eqb node1 node1') (N.eqb BDDzero node2') y0)).

rewrite y0 in H8.
unfold BDDor_memo_OK in H1.
split.
exact (proj1 (H1 node1' node2' node H8)).

split.
exact (proj1 (proj2 (H1 node1' node2' node H8))).

split.
exact (proj1 (proj2 (proj2 (H1 node1' node2' node H8)))).

split.
exact (proj1 (proj2 (proj2 (proj2 (H1 node1' node2' node H8))))).

exact (proj2 (proj2 (proj2 (proj2 (H1 node1' node2' node H8))))).

split.

assumption.

split.
unfold nodes_preserved in |- *; intro.
intros l r node H8.
assumption.

split.
apply BDDvar_le_max_1.

assumption.

rewrite (proj1 (bool_fun_of_BDD_semantics cfg H0)).
apply bool_fun_eq_symm.
apply bool_fun_or_zero.

rewrite <- H6; assumption.

elim H6.
clear H5 H6.
intro H5.
rewrite H5.
rewrite (BDDor_1_lemma_one_1 cfg memo node1 bound).
simpl in |- *.
cut
 (bool_fun_eq (bool_fun_of_BDD cfg BDDone)
    (bool_fun_or (bool_fun_of_BDD cfg node1) (bool_fun_of_BDD cfg BDDone))).
intro H6.
split.
assumption.

split.
unfold BDDor_memo_OK in |- *.
intros node1' node2' node.
intros H7.
rewrite (BDDor_memo_lookup_semantics memo node1 BDDone BDDone node1' node2')
  in H7.
elim (sumbool_of_bool (N.eqb node1 node1' && N.eqb BDDone node2')); intro y0.
cut (node1 = node1').
cut (BDDone = node2').
intros H8 H9.
intros.

split.
rewrite <- H9; assumption.

split.
rewrite <- H8; right; left; reflexivity.

split.
rewrite y0 in H7.
injection H7.
intro H10.
rewrite <- H10.
right; left; reflexivity.

split.
rewrite y0 in H7.
injection H7; intro.
rewrite <- H10.
rewrite <- H9.
rewrite <- H8.
apply BDDvar_le_max_2.

rewrite y0 in H7; injection H7; intro.
rewrite <- H10.
rewrite <- H9.
rewrite <- H8.
assumption.

apply Neqb_complete.
exact (proj2 (andb_prop (N.eqb node1 node1') (N.eqb BDDone node2') y0)).

apply Neqb_complete.
exact (proj1 (andb_prop (N.eqb node1 node1') (N.eqb BDDone node2') y0)).

rewrite y0 in H7.
unfold BDDor_memo_OK in H1.
split.
exact (proj1 (H1 node1' node2' node H7)).

split.
exact (proj1 (proj2 (H1 node1' node2' node H7))).

split.
exact (proj1 (proj2 (proj2 (H1 node1' node2' node H7)))).

split.
exact (proj1 (proj2 (proj2 (proj2 (H1 node1' node2' node H7))))).

exact (proj2 (proj2 (proj2 (proj2 (H1 node1' node2' node H7))))).

split.
right; left; reflexivity.

split.
unfold nodes_preserved in |- *; intro.
intros l r node H7.
assumption.

split.
apply BDDvar_le_max_2.

assumption.

rewrite (proj1 (proj2 (bool_fun_of_BDD_semantics cfg H0))).
apply bool_fun_eq_symm.
apply bool_fun_or_one.

rewrite <- H5; assumption.

cut (is_internal_node cfg node1).

intros H8 H9.
cut (is_internal_node cfg node2).
intro H7.
elim (nat_sum bound).
intro y0.
elim y0; clear y0.
intro bound'.
intro y0.
cut (max (nat_of_N (var cfg node1)) (nat_of_N (var cfg node2)) < bound).
intro H10.
elim (relation_sum (BDDcompare (var cfg node1) (var cfg node2))); intro y1.
elim y1; clear y1; intro.
apply BDDdummy_lemma_2 with (bound' := bound').
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
apply BDDdummy_lemma_3 with (bound' := bound').
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
cut (BDDcompare (var cfg node2) (var cfg node1) = Datatypes.Lt).
intro y11.
apply BDDdummy_lemma_4 with (bound' := bound').
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
assumption.
apply BDDcompare_sup_inf.
assumption.
apply H4.
assumption.

assumption.

intro y0.
rewrite y0 in H4.
absurd (max (nat_of_N (var cfg node1)) (nat_of_N (var cfg node2)) < 0).
apply lt_n_O.

apply H4.
assumption.

assumption.

apply in_dom_is_internal.
assumption.

apply in_dom_is_internal.
assumption.
Qed.


Require Import sound_include.
Require Import rulesound.

Theorem RuleSound:
  forall (Spec:funspec) (sd : ossched) (I:Inv) (r:retasrt) (ri:asrt)
         (pre:asrt) (s:stmts) (post:asrt) lasrt tid,
    InfRules Spec sd lasrt I r ri pre s post tid ->
    RuleSem Spec sd lasrt I r ri pre s post tid.
Proof.
  introv Hspe.
  inductions Hspe.
  eapply pfalse_rule_sound;eauto.
  eapply pure_split_rule_sound;eauto.
  eapply genv_introret_rule_sound ;eauto.
  eapply genv_introexint_rule_sound ;eauto.
  eapply ret_rule_sound; eauto.
  eapply exitint_rule_sound; eauto.
  eapply rete_rule_sound;eauto.
  eapply call_rule_sound;eauto.
  eapply calle_rule_sound; eauto.
  eapply calle_rule_lvar_sound; eauto.
  eapply conseq_rule_sound;eauto.
  eapply conseq_rule_r_sound;eauto.
  eapply abscsq_rule_sound;eauto.
  eapply seq_rule_sound;eauto.
  eapply if_rule_sound;eauto.
  eapply ift_rule_sound; eauto.
  eapply while_rule_sound; eauto.
  eapply frame_rule_sound;eauto.
  eapply frame_rule_all_sound;eauto.
  eapply retspec_intro_rule_sound;eauto.
  eapply assign_rule_sound;eauto.
  eapply encrit1_rule_sound ;eauto.
  eapply encrit2_rule_sound;eauto.
  eapply excrit1_rule_sound ;eauto.
  eapply excrit2_rule_sound;eauto.
  eapply cli1_rule_sound;eauto.
  eapply cli2_rule_sound;eauto.
  eapply sti1_rule_sound;eauto.
  eapply sti2_rule_sound;eauto.
  eapply switch_rule_sound;eauto.
  eapply switch_dead_rule_sound; eauto.
  eapply checkis_rule_sound;eauto.
  eapply eoi_ieon_rule_sound;eauto.
  eapply eoi_ieoff_rule_sound;eauto.
  eapply ex_intro_rule_sound;eauto.
  eapply disj_rule_sound;eauto.
  eapply task_crt_rule_sound; eauto.
  eapply task_delself_rule_sound; eauto.
  eapply task_delother_rule_sound;eauto.
Qed.

Hint Resolve RuleSound.

Lemma WFFunEnv_imply_WFFuncsSim :
  forall P FSpec sd I lasrt,
    WFFunEnv P FSpec sd lasrt I ->
    WFFuncsSim P FSpec sd lasrt I .
Proof.
  introv Hwfenv.
  unfolds in Hwfenv.
  destruct Hwfenv as [Heqd Hwfenv].
  unfolds.
  split; auto.
  introv Hf.
  lets Hre :  Hwfenv Hf.
  destruct Hre as (d1&d2&s & Hpf & Htm & Hgood & Hforal).
  do 3 eexists; splits; eauto.
Qed.

Lemma  MethSim_to_Methsim' :
  forall P FSpec sd  I s r p ri q lasrt tid,
    GoodI I sd lasrt->
    WFFuncsSim  P FSpec sd lasrt I ->
    RuleSem FSpec sd lasrt I r ri p s q tid->
    (forall o O aop, (o, O, aop) |= p /\ satp o O (CurLINV lasrt tid) ->
                     MethSim P sd (nilcont s) o  aop O lasrt I r ri (lift q) tid).
Proof.
  introv goodi.
  introv Hwf Hrsem Hsat.
  lets Hsim : Hrsem Hsat.
  eapply MethSim_to_Methsim'_aux ; eauto.
Qed.

Lemma WFFunEnv_imply_Methsim' :
  forall P FSpec  sd I lasrt,
    GoodI I sd lasrt->
    WFFunEnv P FSpec sd lasrt I ->
    WFFuncsSim' P FSpec sd lasrt I.
Proof.
  introv GoodI.
  introv Hwf.
  unfolds.
  split.
  destruct Hwf.
  auto.
  introv Hsf.
  lets Hre :  WFFunEnv_imply_WFFuncsSim  Hwf.
  unfolds in Hre.
  destruct Hre as [Heqd Hre].
  lets Hree : Hre Hsf.
  destruct Hree as (d1 & d2 & s & Hpf & Htm & Hgood & Hforall).
  do 3 eexists; splits; eauto.
  introv Hp Hr.
  lets Hof : Hforall Hp Hr.
  eapply MethSim_to_Methsim'; eauto.
  split; auto.
Qed.


Require Import FP.Data.String.
Require Import FP.Data.N.
Require Import FP.Data.Z.
Require Import FP.Structures.Monoid.
Require Import FP.Data.Function.
Require Import FP.Data.List.
Require Import FP.Data.ListStructures.
Require Import FP.Data.GeneralizedList.
Require Import FP.Data.Ascii.
Require Import FP.Structures.Convertible.
Require Import FP.Structures.Additive.
Require Import FP.Structures.Ord.
Require Import FP.Structures.Foldable.
Require Import FP.Data.List.
Require Import FP.Data.Fuel.
Require Import FP.Data.Susp.
Require Import FP.Structures.MonadFix.
Require Import FP.Structures.Functor.
Require Import FP.Structures.Applicative.
Require Import FP.Structures.Monad.
Require Import FP.Data.Option.
Require Import FP.Data.PrettyI.
Require Import FP.Data.StringBuilder.

Import StringNotation.
Import NNotation.
Import SuspNotation.
Import MonadNotation.
Import ApplicativeNotation.
Import FunctorNotation.
Import ZNotation.
Import CharNotation.
Import ListNotation.
Import MonoidNotation.
Import FunctionNotation.
Import AdditiveNotation.
Import OrdNotation.

Inductive tinydoc :=
  | NilTD : tinydoc
  | ConcatTD : string -> tinydoc -> tinydoc
  | LineTD : N -> tinydoc -> tinydoc.

Fixpoint layout (td:tinydoc) : string_builder :=
  match td with
  | NilTD => mk_string_builder ""
  | ConcatTD s td => mk_string_builder s ** layout td
  | LineTD i td => mk_string_builder (convert_to string (newline :: replicate i " "%char)) ** layout td
  end.
Inductive fmode :=
  | Flat
  | Break.

Definition fits : Z -> list (N*fmode*doc) -> fuel bool :=
  mfix2 $ fun fits w ps =>
    if w <! 0%Z then
      ret false
    else
      match ps with
      | [] => ret true
      | (_,_,NilD)::ps => fits w ps
      | (i,m,ConcatD dl dr)::ps => fits w ((i,m,dl)::(i,m,dr)::ps)
      | (i,m,NestD j dn)::ps => fits w ((i+j,m,dn)::ps)
      | (i,m,TextD s)::ps => fits (w - length s) ps
      | (i,Flat,LineD s)::ps => fits (w - length s) ps
      | (i,Break,LineD _)::_ => ret true
      | (i,m,GroupD dg)::ps => fits w ((i,Flat,dg)::ps)
      end.

Definition format : Z -> Z -> list (N*fmode*doc) -> fuel tinydoc :=
  curry $
  mfix2 $ fun format wk ps =>
    let format (w:Z) (k:Z) (ps:list (N*fmode*doc)) := format (w,k) ps in
    let '(w,k) := wk in
    match ps with
    | [] => ret NilTD
    | (i,m,NilD)::ps => format w k ps
    | (i,m,ConcatD dl dr)::ps => format w k ((i,m,dl)::(i,m,dr)::ps)
    | (i,m,NestD j dn)::ps => format w k ((i+j,m,dn)::ps)
    | (i,m,TextD s)::ps => ConcatTD s <$> format w (k + length s) ps
    | (i,Flat,LineD s)::ps => ConcatTD s <$> format w (k + length s) ps
    | (i,Break,LineD s)::ps => LineTD i <$> format w (convert i) ps
    | (i,m,GroupD dg)::ps =>
        b <- fits (w-k) ((i,Flat,dg)::ps) ;;
        if b then
          format w k ((i,Flat,dg)::ps)
        else
          format w k ((i,Break,dg)::ps)
   end.

Definition run_pretty (w:N) (d:doc) : option string :=
  let one_million := 1000000 in
  run_fuel one_million $ begin
    td <- format (convert w) 0%Z [(0,Flat,GroupD d)] ;;
    let nl := mk_string_builder $ convert [newline] in
    ret $ run_string_builder $ nl ** layout td ** nl
  end.

(* example *)

Inductive tree := Node : string -> list tree -> tree.

Fixpoint show_tree (t:tree) : doc :=
  let map_show_trees :=
  fix map_show_trees ts :=
    match ts with
    | [] => []
    | t::ts => show_tree t::map_show_trees ts
    end
  in
  let show_trees :=
  fix show_trees t ts :=
    let tl :=
      match ts with
      | [] => nil_d
      | t::ts => text_d "," `concat_d` line_d `concat_d` show_trees t ts
      end
    in t `concat_d` tl
  in
  let show_bracket :=
  fix show_bracket ts :=
    match ts with
    | [] => nil_d
    | t::ts => text_d "[" `concat_d` nest_d 1 (show_trees t ts) `concat_d` text_d "]"
    end
  in
  let '(Node s ts) := t in
  group_d (text_d s `concat_d` nest_d (convert (length (convert s))) (show_bracket (map_show_trees ts))).

Definition t1 : tree :=
  Node "aaa" [Node "bbb" [Node "ccc" []; Node "ddd" []]; Node "eee" [Node "fff" []; Node "ggg" []]; Node "hhh" []].

(*
Eval compute in
  s <- run_pretty 20 $ show_tree t1 ;;
  ret $ convert [newline] ** s.
*)