(* 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                                                     *)
(* définition des adresses d'états produits *)
Fixpoint iad_conv_aux_0 (p : positive) : positive :=
match p with
| xH => 2%positive
| xO p' => xO (xO (iad_conv_aux_0 p'))
| xI p' => xO (xI (iad_conv_aux_0 p'))
end.
Fixpoint iad_conv_aux_1 (p : positive) : positive :=
match p with
| xH => 1%positive
| xO p' => xO (xO (iad_conv_aux_1 p'))
| xI p' => xI (xO (iad_conv_aux_1 p'))
end.
Fixpoint iad_conv_aux_2 (p0 p1 : positive) {struct p1} : positive :=
match p0, p1 with
| xH, xH => 3%positive
| xH, xO p1' => xI (xO (iad_conv_aux_0 p1'))
| xH, xI p1' => xI (xI (iad_conv_aux_0 p1'))
| xO p0', xH => xO (xI (iad_conv_aux_1 p0'))
| xO p0', xO p1' => xO (xO (iad_conv_aux_2 p0' p1'))
| xO p0', xI p1' => xO (xI (iad_conv_aux_2 p0' p1'))
| xI p0', xH => xI (xI (iad_conv_aux_1 p0'))
| xI p0', xO p1' => xI (xO (iad_conv_aux_2 p0' p1'))
| xI p0', xI p1' => xI (xI (iad_conv_aux_2 p0' p1'))
end.
Definition iad_conv (a0 a1 : ad) : ad :=
match a0, a1 with
| N0, N0 => N0
| N0, Npos p1 => Npos (iad_conv_aux_0 p1)
| Npos p0, N0 => Npos (iad_conv_aux_1 p0)
| Npos p0, Npos p1 => Npos (iad_conv_aux_2 p0 p1)
end.
(* surjectivité de iad_conv *)
Definition iad_conv_prop (p : positive) : Prop :=
(exists q : positive, p = iad_conv_aux_0 q) \/
(exists q : positive, p = iad_conv_aux_1 q) \/
(exists q : positive, (exists r : positive, p = iad_conv_aux_2 q r)).
intros.
elim H; intros. elim H0. intros. left. split with (xI x).
simpl in |- *. rewrite <- H1. trivial. elim H0; intros. elim H1. intros.
right. right. split with (xO x). split with 1%positive. simpl in |- *. rewrite H2.
trivial. elim H1. intros. elim H2. intros. right. right.
split with (xO x). split with (xI x0). simpl in |- *. rewrite H3.
trivial.
Qed.
(* fonctions réciproques gauche et droite de iad_conv *)
Inductive ad_couple : Set :=
cpla : ad -> ad -> ad_couple.
Fixpoint iad_conv_inv_0 (p : positive) : ad_couple :=
match p with
| xH => cpla (Npos 1) N0
| xO xH => cpla N0 (Npos 1)
| xI xH => cpla (Npos 1) (Npos 1)
| xO (xO p') =>
match iad_conv_inv_0 p' with
| cpla N0 N0 => cpla N0 N0
| cpla N0 (Npos p1) => cpla N0 (Npos (xO p1))
| cpla (Npos p0) N0 => cpla (Npos (xO p0)) N0
| cpla (Npos p0) (Npos p1) => cpla (Npos (xO p0)) (Npos (xO p1))
end
| xO (xI p') =>
match iad_conv_inv_0 p' with
| cpla N0 N0 => cpla N0 (Npos 1)
| cpla N0 (Npos p1) => cpla N0 (Npos (xI p1))
| cpla (Npos p0) N0 => cpla (Npos (xO p0)) (Npos 1)
| cpla (Npos p0) (Npos p1) => cpla (Npos (xO p0)) (Npos (xI p1))
end
| xI (xO p') =>
match iad_conv_inv_0 p' with
| cpla N0 N0 => cpla (Npos 1) N0
| cpla N0 (Npos p1) => cpla (Npos 1) (Npos (xO p1))
| cpla (Npos p0) N0 => cpla (Npos (xI p0)) N0
| cpla (Npos p0) (Npos p1) => cpla (Npos (xI p0)) (Npos (xO p1))
end
| xI (xI p') =>
match iad_conv_inv_0 p' with
| cpla N0 N0 => cpla (Npos 1) (Npos 1)
| cpla N0 (Npos p1) => cpla (Npos 1) (Npos (xI p1))
| cpla (Npos p0) N0 => cpla (Npos (xI p0)) (Npos 1)
| cpla (Npos p0) (Npos p1) => cpla (Npos (xI p0)) (Npos (xI p1))
end
end.
Definition iad_conv_inv (a : ad) : ad_couple :=
match a with
| N0 => cpla N0 N0
| Npos p => iad_conv_inv_0 p
end.
(* algorithme de calcul d'intersection : calcul de l'état produit *)
(* calcul d'une prec_list produit *)
Fixpoint pl_produit_0 (a : ad) (la pl : prec_list)
(n : nat) {struct n} : prec_list -> prec_list :=
fun l : prec_list =>
match n with
| O => prec_empty
| S m =>
match pl with
| prec_empty => l
| prec_cons a0 la0 ls0 =>
prec_cons (iad_conv a a0) (pl_produit_1 la m la0)
(pl_produit_0 a la ls0 m l)
end
end
with pl_produit_1 (pl0 : prec_list) (n : nat) {struct n} :
prec_list -> prec_list :=
fun pl1 : prec_list =>
match n with
| O => prec_empty
| S m =>
match pl0, pl1 with
| prec_empty, prec_empty => prec_empty
| prec_empty, prec_cons a1 la1 ls1 => prec_empty
| prec_cons a0 la0 ls0, prec_empty => prec_empty
| prec_cons a0 la0 ls0, prec_cons a1 la1 ls1 =>
pl_produit_0 a0 la0 (prec_cons a1 la1 ls1) m
(pl_produit_1 ls0 m (prec_cons a1 la1 ls1))
end
end.
Fixpoint pl_card (pl : prec_list) : nat :=
match pl with
| prec_empty => 1
| prec_cons a la ls => S (pl_card la + pl_card ls)
end.
(* terminaison des fonctions précédantes *)
Definition pl_essence (pl0 pl1 : prec_list) : nat :=
pl_card pl0 + pl_card pl1.
Definition pl_produit (pl0 pl1 : prec_list) : prec_list :=
pl_produit_1 pl0 (pl_essence pl0 pl1) pl1.
(* invariance du résultat de pl_produit lorsqu'on augmente la quantité d'essence *)
Fixpoint pl_prof (pl : prec_list) : nat :=
match pl with
| prec_empty => 0
| prec_cons a la ls => S (max (pl_prof la) (pl_prof ls))
end.
Definition pl_produit_0_incr (p0 p1 : prec_list) : Prop :=
forall (a : ad) (l : prec_list) (n : nat),
pl_essence p0 p1 <= n ->
pl_produit_0 a p0 p1 (pl_essence p0 p1) l = pl_produit_0 a p0 p1 n l.
Definition pl_produit_1_incr (p0 p1 : prec_list) : Prop :=
forall n : nat,
pl_essence p0 p1 <= n ->
pl_produit_1 p0 (pl_essence p0 p1) p1 = pl_produit_1 p0 n p1.
(* passage au produit de la propriété pl_tl_length *)
Definition pl_tl_length_prod_def_0 (pl0 pl1 : prec_list) : Prop :=
forall (l : prec_list) (a : ad) (n m : nat),
pl_essence pl0 pl1 <= m ->
pl_tl_length pl0 n ->
pl_tl_length l (S n) \/ l = prec_empty ->
(pl_tl_length pl1 (S n) -> pl_tl_length (pl_produit_0 a pl0 pl1 m l) (S n)) /\
(pl1 = prec_empty ->
(pl_tl_length l (S n) -> pl_tl_length (pl_produit_0 a pl0 pl1 m l) (S n)) /\
(l = prec_empty -> pl_produit_0 a pl0 pl1 m l = prec_empty)).
Definition pl_tl_length_prod_def_1 (pl0 pl1 : prec_list) : Prop :=
forall n m : nat,
pl_tl_length pl0 n ->
pl_tl_length pl1 n ->
pl_essence pl0 pl1 <= m -> pl_tl_length (pl_produit_1 pl0 m pl1) n.
(* lemmes de conservation des pl_path_incl par passage au pl_produit *)
Fixpoint pl_path_product (p0 p1 : pl_path) {struct p1} : pl_path :=
match p0, p1 with
| pl_path_nil, pl_path_nil => pl_path_nil
| pl_path_nil, pl_path_cons a b => pl_path_nil
| pl_path_cons a b, pl_path_nil => pl_path_nil
| pl_path_cons a0 b0, pl_path_cons a1 b1 =>
pl_path_cons (iad_conv a0 a1) (pl_path_product b0 b1)
end.
Definition pl_produit_path_incl_def_0 (pl0 pl1 : prec_list) :=
forall (n m : nat) (plp0 plp1 : pl_path) (a : ad) (l : prec_list),
pl_path_incl plp0 (prec_cons a pl0 prec_empty) ->
pl_tl_length pl0 n ->
pl_path_incl plp1 pl1 ->
pl_tl_length pl1 (S n) ->
pl_essence pl0 pl1 <= m ->
pl_path_incl (pl_path_product plp0 plp1) (pl_produit_0 a pl0 pl1 m l).
Definition pl_produit_path_incl_def_1 (pl0 pl1 : prec_list) :=
forall (n m : nat) (plp0 plp1 : pl_path),
pl_path_incl plp0 pl0 ->
pl_tl_length pl0 n ->
pl_path_incl plp1 pl1 ->
pl_tl_length pl1 n ->
pl_essence pl0 pl1 <= m ->
pl_path_incl (pl_path_product plp0 plp1) (pl_produit_1 pl0 m pl1).
Definition pl_produit_path_incl_def_2 (pl0 pl1 : prec_list) :=
forall (n m : nat) (plp : pl_path) (a : ad) (l : prec_list),
pl_path_incl plp (pl_produit_0 a pl0 pl1 m l) ->
pl_tl_length pl0 n ->
pl_tl_length pl1 (S n) ->
pl_essence pl0 pl1 <= m ->
(exists plp0 : pl_path,
(exists plp1 : pl_path,
plp = pl_path_product plp0 plp1 /\
pl_path_incl plp0 (prec_cons a pl0 prec_empty) /\
pl_path_incl plp1 pl1)) \/ pl_path_incl plp l.
Definition pl_produit_path_incl_def_3 (pl0 pl1 : prec_list) :=
forall (n m : nat) (plp : pl_path),
pl_path_incl plp (pl_produit_1 pl0 m pl1) ->
pl_tl_length pl0 n ->
pl_tl_length pl1 n ->
pl_essence pl0 pl1 <= m ->
exists plp0 : pl_path,
(exists plp1 : pl_path,
plp = pl_path_product plp0 plp1 /\
pl_path_incl plp0 pl0 /\ pl_path_incl plp1 pl1).
(* calcul de l'état produit *)
Fixpoint s_produit_l (a : ad) (p : prec_list) (s : state) {struct s} :
state :=
match s with
| M0 => M0 prec_list
| M1 a' p' =>
if N.eqb a a' then M1 prec_list a (pl_produit p p') else M0 prec_list
| M2 s0 s1 =>
match a with
| N0 => M2 prec_list (s_produit_l N0 p s0) (M0 prec_list)
| Npos q =>
match q with
| xH => M2 prec_list (M0 prec_list) (s_produit_l N0 p s1)
| xO q' => M2 prec_list (s_produit_l (Npos q') p s0) (M0 prec_list)
| xI q' => M2 prec_list (M0 prec_list) (s_produit_l (Npos q') p s1)
end
end
end.
Definition sproductl_0_def (s : state) : Prop :=
forall (a : ad) (p : prec_list) (c : ad) (r0 r1 : prec_list),
MapGet prec_list (M1 prec_list a p) c = Some r0 ->
MapGet prec_list s c = Some r1 ->
MapGet prec_list (s_produit_l a p s) c = Some (pl_produit r0 r1).
Definition sproductl_1_def (s : state) : Prop :=
forall (a : ad) (p : prec_list) (c : ad) (r : prec_list),
MapGet prec_list (s_produit_l a p s) c = Some r ->
exists r0 : prec_list,
(exists r1 : prec_list,
MapGet prec_list (M1 prec_list a p) c = Some r0 /\
MapGet prec_list s c = Some r1).

Lemma sproductl_1_2 :
forall m : state,
sproductl_1_def m ->
forall m0 : state, sproductl_1_def m0 -> sproductl_1_def (M2 prec_list m m0).