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

(**********************************************************************
    Proof of Huffman algorithm: SubstPred.v

    Definition of the substitution in a tree with respect to a cover

    Definition: subst_pred

                                    Laurent.Thery@inria.fr (2003)
 **********************************************************************)

From Huffman Require Import HeightPred.

Section SubstPred.
Variable A : Type.

(* Take two covers an substitute the elements of one by the element of the other *)
Inductive subst_pred :
list (btree A) -> list (btree A) -> btree A -> btree A -> Prop :=
  | subst_pred_id :
      forall (t1 t2 : btree A) (l1 l2 : list (btree A)),
      subst_pred (t1 :: nil) (t2 :: nil) t1 t2
  | subst_pred_node :
      forall (t1 t2 t3 t4 : btree A) (l1 l2 l3 l4 l5 l6 : list (btree A)),
      subst_pred l1 l2 t1 t2 ->
      subst_pred l3 l4 t3 t4 ->
      subst_pred (l1 ++ l3) (l2 ++ l4) (node t1 t3) (node t2 t4).
Hint Resolve subst_pred_id subst_pred_node : core.

(* The first cover of the substitution is an ordered cover *)
Theorem subst_pred_ordered_cover_l :
 forall (t1 t2 : btree A) (l1 l2 : list (btree A)),
 subst_pred l1 l2 t1 t2 -> ordered_cover l1 t1.
Proof using.
intros t1 t2 l1 l2 H; elim H; auto.
Qed.

(* The second cover of the substitution is an ordered cover *)
Theorem subst_pred_ordered_cover_r :
 forall (t1 t2 : btree A) (l1 l2 : list (btree A)),
 subst_pred l1 l2 t1 t2 -> ordered_cover l2 t2.
Proof using.
intros t1 t2 l1 l2 H; elim H; auto.
Qed.

(* The two covers have same length *)
Theorem subst_pred_length :
 forall (t1 t2 : btree A) (l1 l2 : list (btree A)),
 subst_pred l1 l2 t1 t2 -> length l1 = length l2.
Proof using.
intros t1 t2 l1 l2 H; elim H; auto.
intros t0 t3 t4 t5 l0 l3 l4 l5 l6 l7 H0 H1 H2 H3; repeat rewrite length_app; auto.
Qed.

(* An ordered cover can  be completed in a substitution *)
Theorem ordered_cover_subst_pred :
 forall (t1 : btree A) (l1 l2 : list (btree A)),
 ordered_cover l1 t1 ->
 length l1 = length l2 -> exists t2 : btree A, subst_pred l1 l2 t1 t2.
Proof using.
intros t1 l1 l2 H; generalize l2; elim H; clear t1 l1 l2 H.
intros t l l2; case l2.
simpl in |- *; intros; discriminate.
intros b l0; case l0; simpl in |- *; auto.
intros H; exists b; auto.
intros; discriminate.
intros t1 t2 l1 l2 l3 H H0 H1 H2 l0 H3.
case (H0 (first_n l0 (length l1))); auto.
rewrite first_n_length; auto;
 (rewrite <- H3; rewrite length_app; auto with arith).
intros t4 HH1.
case (H2 (skip_n l0 (length l1))); auto.
rewrite skip_n_length; auto;
 (rewrite <- H3; rewrite length_app; rewrite minus_plus; auto with arith).
intros t5 HH2.
exists (node t4 t5); auto.
rewrite <- (first_n_skip_n_app _ (length l1) l0); auto.
Qed.

(* A height predicate can be completed in a substitution *)
Theorem height_pred_subst_pred :
 forall (n : nat) (ln : list nat) (t1 : btree A) (l1 l2 : list (btree A)),
 height_pred n ln l1 t1 ->
 length l1 = length l2 ->
 exists t2 : btree A, height_pred n ln l2 t2 /\ subst_pred l1 l2 t1 t2.
Proof using.
intros n ln t1 l1 l2 H; generalize l2; elim H; clear H n ln t1 l1 l2; auto.
intros n t l2; case l2.
simpl in |- *; intros; discriminate.
intros b l0; case l0; intros; try discriminate; exists b; auto.
intros n ln1 ln2 t1 t2 l1 l2 H H0 H1 H2 l0 H3.
case (H0 (first_n l0 (length l1))); auto.
rewrite first_n_length; auto;
 (rewrite <- H3; rewrite length_app; auto with arith).
intros t4 (HH1, HH2).
case (H2 (skip_n l0 (length l1))); auto.
rewrite skip_n_length; auto;
 (rewrite <- H3; rewrite length_app; rewrite minus_plus; auto with arith).
intros t5 (HH3, HH4).
exists (node t4 t5); rewrite <- (first_n_skip_n_app _ (length l1) l0); auto.
Qed.

End SubstPred.
Arguments subst_pred [A].
Hint Resolve subst_pred_id : core.


Require Export P06.

Hint Constructors is_redblack.
Lemma is_redblack_toblack:
  forall s n, is_redblack s Red n -> is_redblack s Black n.
Proof.
  intros.
  inv H; eauto.
Qed.


(* Notation *)

Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..)
  (at level 200, x binder, y binder, right associativity,
  format "'[ ' '[ ' ∀ x .. y ']' , '/' P ']'") : type_scope.

Notation "∃ x .. y , P" := (exists x, .. (exists y, P) ..)
  (at level 200, x binder, y binder, right associativity,
  format "'[ ' '[ ' ∃ x .. y ']' , '/' P ']'") : type_scope.

Notation "x ∨ y" := (x \/ y) (at level 85, right associativity) : type_scope.

Notation "x ∧ y" := (x /\ y) (at level 80, right associativity) : type_scope.

Notation "x → y" := (x -> y)
  (at level 99, y at level 200, right associativity): type_scope.

Notation "x ↔ y" := (x <-> y) (at level 95, no associativity): type_scope.

Notation "¬ x" := (~x) (at level 75, right associativity) : type_scope.

Notation "x ≠ y" := (x <> y) (at level 70) : type_scope.

Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..)
  (at level 200, x binder, y binder, right associativity,
  format "'[ ' '[ ' 'λ' x .. y ']' , '/' t ']'").

(* Logic *)
Axiom classic : ∀ P : Prop, P ∨ ¬P.

Proposition NNPP : ∀ P, (¬ (¬ P) ↔ P).
Proof. intros; destruct (classic P); tauto. Qed.

Proposition inp : ∀ P Q : Prop, (P ↔ Q) → (¬ P → ¬ Q).
Proof. intros; intro. elim H0. apply H; auto. Qed.

(* Ensemble *)
Parameter Class : Type.

Parameter In : Class → Class → Prop.
Notation "a ∈ A" := (In a A)(at level 70).
Notation "a ∉ A" := (¬ (a ∈ A))(at level 70).

Parameter Classifier : ∀ P : Class → Prop, Class.
Notation "\{ P \}" := (Classifier P)(at level 0).

Axiom ExtAx : ∀ A B : Class, A = B ↔ (∀ x, x ∈ A ↔ x ∈ B).
Ltac AppE := apply ExtAx; split; intros.

Axiom ClaAx : ∀ (x : Class) (P : Class → Prop),
  x ∈ \{ P \} ↔ (P x).
Ltac AppC H := apply -> ClaAx in H; simpl in H.

Parameter ClassifierP : ∀ P : Class → Class → Prop, Class.
Notation "\{\ P \}\" := (ClassifierP P)(at level 0).

Fact ClaI : ∀ x (P : Class → Prop), P x → x ∈ \{ P \}.
Proof. intros x P HP. apply ClaAx; auto. Qed.

Fact ClaE : ∀ x (P : Class → Prop), x ∈ \{ P \} → P x.
Proof. intros x P Hx. apply ClaAx; auto. Qed.

Definition NoEmpty A := ∃ x, x ∈ A.
Notation "⦿ A" := (NoEmpty A) (at level 45).

Definition Empty := \{ λ x, x ≠ x \}.
Notation " ∅ " := Empty.

Fact EmptyNI : ∀ x, x ∉ ∅.
Proof.
  intros x H. AppC H. apply H; auto.
Qed.
Ltac exfalso0 := exfalso; eapply EmptyNI; eauto.

Fact EmptyEq : ∀ x, x = ∅ ↔ ¬ (⦿ x).
Proof.
  split; intros. subst x. intro. destruct H. exfalso0.
  AppE. elim H. exists x0; auto. exfalso0.
Qed.

Fact EmptyNE : ∀ x, x ≠ ∅ ↔ ⦿ x.
Proof.
  intros. pose proof EmptyEq. split; intros.
  - apply inp with (Q := ¬ (⦿ x)) in H0; auto.
    apply -> NNPP in H0; auto.
  - intro. apply H in H1; auto.
Qed.

Definition Singleton x : Class := \{ λ z, z = x \}.
Notation "[ x ]" := (Singleton x) (at level 0, right associativity).

Fact SingI : ∀ x, x ∈ [x].
Proof. intros. apply ClaAx; auto. Qed.

Fact SingE : ∀ x y, x ∈ [y] → x = y.
Proof. intros. AppC H; auto. Qed.

Definition Included A B := ∀ x, x ∈ A → x ∈ B.
Notation "A ⊂ B" := (Included A B)(at level 70).

Fact ReSyTrP : ∀ A B C : Class,
  (A ⊂ A) ∧ (A ⊂ B ∧ B ⊂ A → A = B) ∧ (A ⊂ B ∧ B ⊂ C → A ⊂ C).
Proof.
  intros. split; try red; auto. split; intros.
  - AppE; apply H; auto.
  - destruct H. intros x Hx. apply H in Hx. auto.
Qed.

Definition PowerSet X : Class := \{ λ A, A ⊂ X \}.
Notation " cP( X )" := (PowerSet X)(at level 9, right associativity).

Definition Union A B := \{ λ x, x ∈ A ∨ x ∈ B \}.
Notation "A ⋃ B" := (Union A B)(at level 65, right associativity).

Definition Inter A B := \{ λ x, x ∈ A ∧ x ∈ B \}.
Notation "A ∩ B" := (Inter A B)(at level 60, right associativity).

Definition Setmin A B := \{ λ x, x ∈ A ∧ x ∉ B \}.
Notation "A - B" := (Setmin A B).

(* Basic properties (Union, Inter, Setmin, Sub) *)
Fact Idem : ∀ A, A ⋃ A = A.
Proof. intros. AppE. AppC H; tauto. apply ClaI; auto. Qed.

Fact Idem' : ∀ A, A ∩ A = A.
Proof. intros. AppE. AppC H; tauto. apply ClaI; auto. Qed.

Fact Commu : ∀ A B, A ⋃ B = B ⋃ A.
Proof. intros. AppE; AppC H; apply ClaI; tauto. Qed.

Fact Commu' : ∀ A B, A ∩ B = B ∩ A.
Proof. intros. AppE; AppC H; apply ClaI; tauto. Qed.

Fact Assoc : ∀ A B C, (A ⋃ B) ⋃ C =A ⋃ (B ⋃ C).
Proof.
  intros. AppE; apply ClaI; apply ClaE in H as [].
  - apply ClaE in H as []; auto. right; apply ClaI; auto.
  - right; apply ClaI; auto.
  - left; apply ClaI; auto.
  - apply ClaE in H as []; auto. left; apply ClaI; auto.
Qed.

Fact Distribu : ∀ A B C, (A ⋃ B) ∩ C = (A ∩ C) ⋃ (B ∩ C).
Proof.
  intros. AppE; apply ClaAx.
  - do 2 (AppC H; destruct H).
    + left; apply ClaI; auto. + right; apply ClaI; auto.
  - do 2 (AppC H; destruct H); split; try (apply ClaI; auto); auto.
Qed.

Fact Distribu' : ∀ A B C, A ∩ (B ⋃ C) = A ∩ B ⋃ A ∩ C.
Proof.
  intros. rewrite Commu', Distribu, Commu', (Commu' A C); auto.
Qed.

Fact TwDeMorgan : ∀ A B C, A - (B ∩ C) = (A - B) ⋃ (A - C).
Proof.
  intros. AppE; AppC H; apply ClaI.
  - destruct H, (classic (x ∈ C)).
    + left; apply ClaI. split; auto. intro; elim H0. apply ClaI; tauto.
    + right; apply ClaI. split; auto.
  - destruct H; apply ClaE in H as []; split; auto;
    intro; AppC H1; destruct H1; tauto.
Qed.

Fact UnionNI : ∀ x A B, x ∉ A ⋃ B → x ∉ A /\ x ∉ B.
Proof. intros. split; intro; elim H; apply ClaI; auto. Qed.

Fact InterEm : ∀ A, A ∩ ∅ = ∅.
Proof. intros. AppE. AppC H; tauto. exfalso0. Qed.

Fact SetminId : ∀ X, X - X = ∅.
Proof. intro. AppE. apply ClaE in H; tauto. exfalso0. Qed.

Fact SetminEm : ∀ X, X - ∅ = X.
Proof.
  intro. AppE. apply ClaE in H; tauto.
  apply ClaI. split; auto. intro. exfalso0.
Qed.

Fact SubUnion : ∀ A B, B ⊂ A → A ⋃ B = A.
Proof.
  intros. AppE. apply ClaE in H0 as []; auto. apply ClaI; auto.
Qed.

Fact SubSetmin : ∀ A X, A ⊂ X → X - A ⊂ X.
Proof. intros * Hsub x Hx. apply ClaE in Hx. tauto. Qed.

Fact SubSetmin1 : ∀ A X, A ⊂ X → X - (X - A) = A.
Proof.
  intros. AppE. apply ClaE in H0 as [Hx H0].
  destruct (classic (x ∈ A)); eauto. elim H0. apply ClaI; eauto.
  apply ClaI. split; eauto. intro. apply ClaE in H1; tauto.
Qed.

Fact SetBasicP : ∀ x U A, U ∩ A - [x] = ∅ → x ∉ A → U ∩ A = ∅.
Proof with eauto.
  intros. rewrite <- H. AppE; apply ClaE in H1 as [Hu Ha];
  apply ClaI; split... apply ClaI. split... intro.
  apply ClaE in H1. subst... apply ClaE in Ha. tauto.
Qed.

Fact SetBasicP1 : ∀ A B C,
  A ∈ [C] ⋃ [∅] → B ∈ [C] ⋃ [∅] → A ∩ B ∈ [C] ⋃ [∅].
Proof with eauto.
  intros. apply ClaE in H as []; apply ClaE in H0 as [];
    apply ClaE in H; apply ClaE in H0; subst; apply ClaI.
    rewrite Idem'; left; apply ClaI...
    rewrite InterEm; right; apply ClaI...
    right. rewrite Commu', InterEm. apply ClaI...
    right. rewrite InterEm. apply ClaI...
Qed.

Definition EleU cA := \{ λ z, ∃ y, z ∈ y ∧ y ∈ cA \}.
Notation "∪ cA" := (EleU cA)(at level 66).

Definition EleI cA := \{ λ z, ∀ y, y ∈ cA → z ∈ y \}.
Notation "⋂ cA" := (EleI cA)(at level 66).

Fact EmEleU : ∪∅ = ∅.
Proof. AppE; [| exfalso0]. apply ClaE in H as [y []]. exfalso0. Qed.

Fact SiEleU : ∀ X, ∪[X] = X.
Proof with eauto.
  intro. AppE. apply ClaE in H as [y [Hx Hy]]. apply ClaE in Hy.
  subst... apply ClaI. exists X. split... apply ClaI...
Qed.

Fact EleUP : ∀ a cT, cT ⊂ [a] ⋃ [∅] → ∪cT ∈ [a] ⋃ [∅].
Proof with eauto.
  intros. assert (cT ∈ cP([a] ⋃ [∅])); apply ClaI...
  assert (∀ c d, cP([c] ⋃ [d]) =
    \{ λ Z, Z = ∅ \/ Z = [c] \/ Z = [d] \/ Z = [c] ⋃ [d] \}).
  { intros. AppE.
    - apply ClaI. apply ClaE in H1. destruct (classic (c ∈ x)).
      + destruct (classic (d ∈ x)).
        * right; right; right. apply ReSyTrP... split...
          intros z Hz. subst. apply ClaE in Hz as [];
          apply ClaE in H4; subst...
        * right; left. AppE; [| apply ClaE in H4; subst; auto].
          apply ClaI. pose proof H4. apply H1 in H4. subst.
          apply ClaE in H4 as []; apply ClaE in H4; subst... tauto.
      + destruct (classic (d ∈ x)).
        * right; right; left. AppE; [| apply ClaE in H4; subst; auto].
          apply ClaI. pose proof H4. apply H1 in H4. subst.
          apply ClaE in H4 as []; apply ClaE in H4; subst... tauto.
        * left. AppE; [| exfalso0]. pose proof H4. apply H1 in H4.
          subst. apply ClaE in H4 as []; apply ClaE in H4; subst; tauto...
    - apply ClaE in H1. apply ClaI; intros z Hz.
      destruct H1 as [| [| [| ]]]; subst... exfalso0.
      apply ClaI... apply ClaI... } rewrite H1 in H0; clear H1.
  apply ClaE in H0 as [| [| [| ]]]; subst.
  + assert (∪∅ = ∅).
    { AppE; [| exfalso0]. apply ClaE in H0 as [y [_ Hy]]. exfalso0. }
    rewrite H0. right. apply ClaI...
  + left. rewrite SiEleU. apply ClaI...
  + right. rewrite SiEleU. apply ClaI...
  + assert (∪ [a] ⋃ [∅] = a).
    { AppE. apply ClaE in H0 as [y [Hx Hy]].
      apply ClaE in Hy as []; apply ClaE in H0; subst... exfalso0.
      apply ClaI. exists a. split... apply ClaI. left. apply ClaI... }
    rewrite H0. left; apply ClaI...
Qed.

Fact EleIP : ∀ A cA, A ∈ cA → ⋂cA ⊂ A.
Proof. intros * H x Hx. apply ClaE in Hx. apply Hx; auto. Qed.

(* De Morgan *)
Definition AAr A cA := \{λ z, ∃ Ar, Ar ∈ cA /\ z = A - Ar\}.

Fact AArP : ∀ A cA, cA ≠ ∅ → AAr A cA ≠ ∅.
Proof.
  intros. apply EmptyNE in H as [Ar H]. apply EmptyNE.
  exists (A - Ar). apply ClaI; eauto.
Qed.

Fact DeMorganUI : ∀ A cA, cA ≠ ∅ → (A - ∪cA) = ⋂(AAr A cA).
Proof with eauto.
  intros. AppE.
  - apply ClaE in H0 as [Hx HcA]. apply ClaI. intros.
    apply ClaE in H0 as [B [Hb Heq]]. subst. apply ClaI. split...
    intro. elim HcA. apply ClaI...
  - apply EmptyNE in H as [Ar H]. apply ClaE in H0. apply ClaI.
    assert (A - Ar ∈ AAr A cA). { apply ClaI... }
    apply H0 in H1. apply ClaE in H1 as [Hx H1]. split...
    intro. apply ClaE in H2 as [B [Hb H2]].
    assert (A - B ∈ AAr A cA). { apply ClaI... }
    apply H0 in H3. apply ClaE in H3; tauto.
Qed.

Definition Unorder x y := [x] ⋃ [y].
Notation "[ x | y ] " := (Unorder x y) (at level 0).

Definition Order x y := [ [x] | [x | y] ].
Notation "[ x , y , .. , z ]" :=
  (Order .. (Order x y ) .. z ) (z at level 69).

Axiom ClaAx' : ∀ (x y : Class)(P : Class → Class → Prop),
  [x, y] ∈ \{\ P \}\ ↔ (P x y).
Ltac AppC' H := apply -> ClaAx' in H; simpl in H.

Fact ClaI' : ∀ x y (P : Class → Class → Prop),
  P x y → [x, y] ∈ \{\ P \}\.
Proof. intros x y P HP. apply ClaAx'; auto. Qed.

Fact ClaE' : ∀ x y (P : Class → Class → Prop),
  [x, y] ∈ \{\ P \}\ → P x y.
Proof. intros x y P Hx. apply ClaAx'; auto. Qed.

Definition Cartesian X Y := \{\ λ x y, x ∈ X ∧ y ∈ Y \}\.
Notation " X × Y " := (Cartesian X Y)(at level 2, right associativity).

Definition Relation R X Y := R ⊂ X × Y.

Definition Mapping F X Y : Prop :=
  Relation F X Y ∧ (∀ x, x ∈ X → (∃ y, [x, y] ∈ F)) ∧
  (∀ x y1 y2, [x, y1] ∈ F ∧ [x, y2] ∈ F → y1 = y2 ).
Notation "F : X → Y" := (Mapping F X Y)(at level 10).

Definition Value F x := ⋂ \{λ y, [x, y] ∈ F \}.
Notation "F [ x ]" := (Value F x)(at level 5).

Fact PropertyValue : ∀ F X Y x,
  Mapping F X Y → x ∈ X → [x, F[x]] ∈ F.
Proof with eauto.
  intros. unfold Mapping, Relation in H; destruct H, H1.
  apply H1 in H0 as [y H0]. assert (y = F[x]).
  { AppE. apply ClaI; intros. AppC H4.
    assert (y0 = y). { eapply H2... } subst...
    AppC H3. apply H3. apply ClaI... } subst...
Qed.


Require Import MirrorShard.Expr MirrorShard.SepExpr.
Require Import MirrorShard.Lemma.

Set Implicit Arguments.
Set Strict Implicit.

Module Type SepLemmaType (ST : SepTheory.SepTheory) (SE : SepExpr ST).

  Section typed.
    Variable types : list type.

    Definition sepConcl : Type :=
      (SE.sexpr types * SE.sexpr types)%type.

    Definition Lhs (l : lemma types sepConcl) : SE.sexpr types :=
      fst (Concl l).
    Definition Rhs (l : lemma types sepConcl) : SE.sexpr types :=
      snd (Concl l).

    Definition WellTyped_sepConcl tfuncs tpreds (vars : list tvar) (c : sepConcl) : bool :=
      if SE.WellTyped_sexpr tfuncs tpreds nil vars (fst c)
      then
        SE.WellTyped_sexpr tfuncs tpreds nil vars (snd c)
      else false.

    Definition sepConclD funcs preds (uvars vars : env types) (c : sepConcl) : Prop :=
      SE.himp funcs preds uvars vars (fst c) (snd c).

    Definition sepLemma : Type := lemma types sepConcl.

    Definition WellTyped_sepLemma tfuncs tpreds (l : sepLemma) : bool :=
      WellTyped_lemma (WellTyped_sepConcl tfuncs tpreds) tfuncs l.

    Definition sepLemmaD (funcs : functions types) (preds : SE.predicates types)
      (meta_base var_base : env types) (lem : sepLemma) : Prop :=
      lemmaD (WellTyped_sepConcl (typeof_funcs funcs) (SE.typeof_preds preds))
             (sepConclD funcs preds) funcs meta_base var_base lem.
  End typed.

End SepLemmaType.

Module SepLemma (ST : SepTheory.SepTheory) (SE : SepExpr ST) <: SepLemmaType ST SE.

  Section typed.
    Variable types : list type.

    Definition sepConcl : Type :=
      (SE.sexpr types * SE.sexpr types)%type.

    Definition Lhs (l : lemma types sepConcl) : SE.sexpr types :=
      fst (Concl l).
    Definition Rhs (l : lemma types sepConcl) : SE.sexpr types :=
      snd (Concl l).

    Definition WellTyped_sepConcl tfuncs tpreds (vars : list tvar) (c : sepConcl) : bool :=
      if SE.WellTyped_sexpr tfuncs tpreds nil vars (fst c)
      then
        SE.WellTyped_sexpr tfuncs tpreds nil vars (snd c)
      else false.

    Definition sepConclD funcs preds (uvars vars : env types) (c : sepConcl) : Prop :=
      SE.himp funcs preds uvars vars (fst c) (snd c).

    Definition sepLemma : Type := lemma types sepConcl.

    Definition WellTyped_sepLemma tfuncs tpreds (l : sepLemma) : bool :=
      WellTyped_lemma (WellTyped_sepConcl tfuncs tpreds) tfuncs l.

    Definition sepLemmaD (funcs : functions types) (preds : SE.predicates types)
      (meta_base var_base : env types) (lem : sepLemma) : Prop :=
      lemmaD (WellTyped_sepConcl (typeof_funcs funcs) (SE.typeof_preds preds))
             (sepConclD funcs preds) funcs meta_base var_base lem.
  End typed.

End SepLemma.


Require Import include_frm.
Require Import base_tac.
Require Import int_auto.

Open Scope Z_scope.

Ltac list_destruct H vl n :=
  let v := fresh in
  match n with
    | 0%nat => simp join; tryfalse
    | S ?n' => destruct vl as [ nil | v ]; [ simpl in H; simp join; tryfalse | list_destruct H vl n' ]
  end.

Lemma if_true_false_eq_true_elim :
  forall b : bool,
    (if b then true else false) = true ->
    b = true.
Proof.
  intros.
  destruct b; tryfalse || auto.
Qed.

Lemma if_true_false_eq_true_intro :
  forall b : bool,
    b = true ->
    (if b then true else false) = true.
Proof.
  intros.
  subst b; simpl; auto.
Qed.

Lemma if_true_false_eq_false_elim :
  forall b : bool,
    (if b then true else false) = false ->
    b = false.
Proof.
  intros.
  destruct b; tryfalse || auto.
Qed.

Lemma if_true_false_eq_false_intro :
  forall b : bool,
    b = false ->
    (if b then true else false) = false.
Proof.
  intros.
  subst b; simpl; auto.
Qed.

(* leb_max_true *)

Lemma byte_max_unsigned_val :
  Byte.max_unsigned = 255%Z.
Proof.
  unfold Byte.max_unsigned.
  unfold Byte.modulus.
  unfold two_power_nat, Byte.wordsize.
  unfold shift_nat, Wordsize_8.wordsize.
  unfold nat_rect.
  omega.
Qed.

Lemma int16_max_unsigned_val :
  Int16.max_unsigned = 65535%Z.
Proof.
  unfold Int16.max_unsigned.
  unfold Int16.modulus.
  unfold two_power_nat, Int16.wordsize.
  unfold shift_nat, Wordsize_16.wordsize.
  unfold nat_rect.
  omega.
Qed.

Lemma leb_bytemax_true_elim :
  forall i,
    Int.unsigned i <=? Byte.max_unsigned = true ->
    Int.unsigned i <= 255.
Proof.
  intros.
  rewrite byte_max_unsigned_val in H.
  apply Z.leb_le in H; auto.
Qed.

Lemma leb_int16max_true_elim :
  forall i,
    Int.unsigned i <=? Int16.max_unsigned = true ->
    Int.unsigned i <= 65535.
Proof.
  intros.
  rewrite int16_max_unsigned_val in H.
  apply Z.leb_le in H; auto.
Qed.

Lemma leb_bytemax_true_intro :
  forall i,
    Int.unsigned i <= 255 ->
    Int.unsigned i <=? Byte.max_unsigned = true.
Proof.
  intros.
  rewrite byte_max_unsigned_val.
  apply Z.leb_le; auto.
Qed.

Lemma leb_int16max_true_intro :
  forall i,
    Int.unsigned i <= 65535 ->
    Int.unsigned i <=? Int16.max_unsigned = true.
Proof.
  intros.
  rewrite int16_max_unsigned_val.
  apply Z.leb_le; auto.
Qed.

(* rule type val match *)
Open Scope code_scope.

Lemma rule_type_val_match_int8u_elim :
  forall v,
    rule_type_val_match Int8u v = true ->
    exists i, v = Vint32 i /\ Int.unsigned i <= 255.
Proof.
  intros.
  destruct v; simpl in *; tryfalse.
  exists i; intuition auto.
  apply if_true_false_eq_true_elim in H.
  apply leb_bytemax_true_elim in H; auto.
Qed.

Lemma rule_type_val_match_int16u_elim :
  forall v,
    rule_type_val_match Int16u v = true ->
    exists i, v = Vint32 i /\ Int.unsigned i <= 65535.
Proof.
  intros.
  destruct v; simpl in *; tryfalse.
  exists i; intuition auto.
  apply if_true_false_eq_true_elim in H.
  apply leb_int16max_true_elim in H; auto.
Qed.

Lemma rule_type_val_match_int32u_elim :
  forall v,
    rule_type_val_match Int32 v = true ->
    exists i, v = Vint32 i.
Proof.
  intros.
  destruct v; simpl in *; tryfalse.
  eauto.
Qed.

Lemma rule_type_val_match_ptr_elim :
  forall v t,
    rule_type_val_match (Tptr t) v = true ->
    isptr v.
Proof.
  intros.
  destruct v; simpl in *; tryfalse.
  unfold isptr; auto.
  unfold isptr; intuition eauto.
Qed.

Lemma rule_type_val_match_comptr_elim :
  forall v t,
    rule_type_val_match (Tcom_ptr t) v = true ->
    isptr v.
Proof.
  intros.
  destruct v; simpl in *; tryfalse.
  unfold isptr; auto.
  unfold isptr; intuition eauto.
Qed.

Ltac rule_type_val_match_elim :=
  match goal with
    | H : rule_type_val_match Int8u ?v = true |- _ =>
      let i := fresh "i" in
      apply rule_type_val_match_int8u_elim in H;
        destruct H as [ i [ ? H ]]; subst v;
        rule_type_val_match_elim
    | H : rule_type_val_match Int16u ?v = true |- _ =>
      let i := fresh "i" in
      apply rule_type_val_match_int16u_elim in H;
        destruct H as [ i [ ? H ]]; subst v;
        rule_type_val_match_elim
    | H : rule_type_val_match Int32u ?v = true |- _ =>
      let i := fresh "i" in
      apply rule_type_val_match_int32u_elim in H;
        destruct H as [ i H ]; subst v;
        rule_type_val_match_elim
    | H : rule_type_val_match (Tptr _) _ = true |- _ =>
      apply rule_type_val_match_ptr_elim in H;
        rule_type_val_match_elim
    | H : rule_type_val_match (Tcom_ptr _) _ = true |- _ =>
      apply rule_type_val_match_comptr_elim in H;
        rule_type_val_match_elim
    | _ => idtac
  end.

(* struct type vallist match *)

Lemma struct_type_vallist_match_elim_0:
  forall v1,
    struct_type_vallist_match' dnil v1 -> v1 = nil.
Proof.
  inductions v1; simpl in *; intros; auto; tryfalse.
Qed.

Fixpoint remove_array_struct  (d:decllist) (vl : vallist) {struct d} :=
   match d , vl with
    | dnil, nil  =>  Some nil
    | dcons x t dls , v::vl' =>
      match t with
          | Tarray _  _  => remove_array_struct dls vl'
          | Tstruct _ _ => remove_array_struct dls vl'
          | _ =>
            match remove_array_struct dls vl' with
              | None => None
              | Some ls => Some ((t,v) :: ls)
            end
      end
    | _,_ => None
   end.

Fixpoint  rule_type_val_match_list (x: list (type * val)){struct x} : Prop:=
  match x with
      | nil => True
      | (t,v)::vl =>  rule_type_val_match t v = true/\
                      rule_type_val_match_list vl
  end.

Lemma struct_array_rm_type_val_match:
  forall d v v',
    remove_array_struct d v = Some v' ->
    struct_type_vallist_match' d  v ->
                 rule_type_val_match_list v'.

Proof.
 inductions d; inductions v; intros;simpl in *; auto; tryfalse.
 inverts H. simpl; auto.
 destruct t;simp join ;eauto.
 remember ( remove_array_struct d v) as Hr.
 destruct Hr; tryfalse.
 inverts H.
 apply eq_sym in HeqHr.
 lets Hd : IHd  HeqHr H1.
 simpl;splits; auto.
 remember ( remove_array_struct d v) as Hr.
 destruct Hr; tryfalse.
 remember ( remove_array_struct d v) as Hr.
 destruct Hr; tryfalse.
 inverts H.
 apply eq_sym in HeqHr.
 lets Hd : IHd  HeqHr H1.
 simpl;splits; auto.
remember ( remove_array_struct d v) as Hr.
 destruct Hr; tryfalse.
 inverts H.
 apply eq_sym in HeqHr.
 lets Hd : IHd  HeqHr H1.
 simpl;splits; auto.
remember ( remove_array_struct d v) as Hr.
 destruct Hr; tryfalse.
 inverts H.
 apply eq_sym in HeqHr.
 lets Hd : IHd  HeqHr H1.
 simpl;splits; auto.
 remember ( remove_array_struct d v) as Hr.
 destruct Hr; tryfalse.
 inverts H.
 apply eq_sym in HeqHr.
 lets Hd : IHd  HeqHr H1.
 simpl;splits; auto.
  remember ( remove_array_struct d v) as Hr.
 destruct Hr; tryfalse.
 inverts H.
 apply eq_sym in HeqHr.
 lets Hd : IHd  HeqHr H1.
 simpl;splits; auto.
Qed.

Lemma struct_type_vallist_match_elim_1 :
  forall x t v,
    struct_type_vallist_match'  (dcons x t dnil)   v ->
    exists v1 ,
      v = v1 :: nil.
Proof.
  intros;  simpl; subst.
  destruct v; simpl struct_type_vallist_match' in H; tryfalse.
  destruct t;simp join;
  match goal with
    | H : context[struct_type_vallist_match'] |- _ =>
      apply struct_type_vallist_match_elim_0 in H;subst;
      do 1 eexists; eauto
  end.
Qed.

Lemma struct_type_vallist_match_elim_2 :
  forall x1 t1 x2 t2 v ,
    struct_type_vallist_match'  (dcons x1 t1 (dcons x2 t2 dnil))  v ->
    exists v1 v2 ,
      v = v1::v2 :: nil.
Proof.
  intros;  simpl; subst.
  destruct v; simpl struct_type_vallist_match' in H; tryfalse.
  destruct t1;simp join;
  match goal with
    | H : context[struct_type_vallist_match'] |- _ =>
     eapply struct_type_vallist_match_elim_1 in H; eauto ;simp join; do 3 eexists;auto
  end.
Qed.

Lemma struct_type_vallist_match_elim_3 :
  forall x1 t1 x2 t2  x3 t3 v,
    struct_type_vallist_match' (dcons x1 t1 (dcons x2 t2 (dcons x3 t3 dnil)))  v ->
    exists v1 v2 v3,
      v = v1 ::  v2:: v3 :: nil.
Proof.
  intros;  simpl.
  destruct v; simpl struct_type_vallist_match' in H; tryfalse.
  destruct t1;simp join;
  match goal with
    | H : context[struct_type_vallist_match'] |- _ =>
      apply struct_type_vallist_match_elim_2 in H ; auto ; simp join
  end;
  do 3 eexists; eauto.
Qed.

Lemma struct_type_vallist_match_elim_4 :
  forall x1 t1 x2 t2  x3 t3 x4 t4 v,
    struct_type_vallist_match'(dcons x1 t1 (dcons x2 t2 (dcons x3 t3 (dcons x4 t4 dnil))))  v ->
    exists v1 v2 v3 v4,
      v = v1 ::  v2:: v3 :: v4 :: nil.
Proof.
  intros;  simpl.
  destruct v; simpl struct_type_vallist_match' in H; tryfalse.
  destruct t1;simp join;
  match goal with
    | H : context[struct_type_vallist_match'] |- _ =>
      apply struct_type_vallist_match_elim_3 in H;auto; simp join
  end;
  do 4 eexists; eauto.
Qed.

Lemma struct_type_vallist_match_elim_5 :
  forall x1 t1 x2 t2  x3 t3 x4 t4 x5 t5 v,
    struct_type_vallist_match'(dcons x1 t1 (dcons x2 t2 (dcons x3 t3 (dcons x4 t4 (dcons x5 t5 dnil)))))  v ->
    exists v1 v2 v3 v4 v5,
      v = v1 ::  v2:: v3 :: v4 :: v5 :: nil.
Proof.
  intros;  simpl.
  destruct v; simpl struct_type_vallist_match' in H; tryfalse.
  destruct t1;simp join;
  match goal with
    | H : context[struct_type_vallist_match'] |- _ =>
      apply struct_type_vallist_match_elim_4 in H;auto;simp join
  end;
  do 5 eexists; eauto.
Qed.

Lemma struct_type_vallist_match_elim_6:
  forall x1 t1 x2 t2  x3 t3 x4 t4 x5 t5 x6 t6 v,
    struct_type_vallist_match'(dcons x1 t1 (dcons x2 t2 (dcons x3 t3 (dcons x4 t4 (dcons x5 t5 (dcons x6 t6 dnil))))))  v ->
    exists v1 v2 v3 v4 v5 v6,
      v = v1 ::  v2:: v3 :: v4 :: v5 ::v6:: nil.
Proof.
  intros;  simpl.
  destruct v; simpl struct_type_vallist_match' in H; tryfalse.
  destruct t1;simp join;
  match goal with
    | H : context[struct_type_vallist_match'] |- _ =>
      apply struct_type_vallist_match_elim_5 in H;auto;simp join
  end;
  do 6 eexists; eauto.
Qed.

Lemma struct_type_vallist_match_elim_7:
  forall x1 t1 x2 t2 x3 t3 x4 t4 x5 t5 x6 t6 x7 t7 v,
    struct_type_vallist_match'(dcons x7 t7 (dcons x1 t1 (dcons x2 t2 (dcons x3 t3 (dcons x4 t4 (dcons x5 t5 (dcons x6 t6 dnil)))))))  v ->
    exists v1 v2 v3 v4 v5 v6 v7,
      v = v7:: v1 ::  v2:: v3 :: v4 :: v5 ::v6:: nil.
Proof.
  intros;  simpl.
  destruct v; simpl struct_type_vallist_match' in H; tryfalse.
  destruct t7;simp join;
  match goal with
    | H : context[struct_type_vallist_match'] |- _ =>
      apply struct_type_vallist_match_elim_6 in H;auto; simp join
  end;
  do 7 eexists;  eauto.
Qed.

Lemma struct_type_vallist_match_elim_8 :
  forall x1 t1 x2 t2 x3 t3 x4 t4 x5 t5 x6 t6 x7 t7 x8 t8 v,
    struct_type_vallist_match'(dcons x8 t8 (dcons x7 t7 (dcons x1 t1 (dcons x2 t2 (dcons x3 t3 (dcons x4 t4 (dcons x5 t5 (dcons x6 t6 dnil))))))) ) v ->
    exists v1 v2 v3 v4 v5 v6 v7 v8,
      v = v8 ::v7:: v1 ::  v2:: v3 :: v4 :: v5 ::v6:: nil.
Proof.
  intros;  simpl.
  destruct v; simpl struct_type_vallist_match' in H; tryfalse.
  destruct t8;simp join;
  match goal with
    | H : context[struct_type_vallist_match'] |- _ =>
      apply struct_type_vallist_match_elim_7 in H;auto;simp join
  end;
  do 8 eexists;  eauto.
Qed.

Lemma struct_type_vallist_match_elim_9 :
  forall x1 t1 x2 t2 x3 t3 x4 t4 x5 t5 x6 t6 x7 t7 x8 t8 x9 t9 v,
    struct_type_vallist_match'(dcons x9 t9 (dcons x8 t8 (dcons x7 t7 (dcons x1 t1 (dcons x2 t2 (dcons x3 t3 (dcons x4 t4 (dcons x5 t5 (dcons x6 t6 dnil))))))))) v ->
    exists v1 v2 v3 v4 v5 v6 v7 v8 v9,
      v = v9 ::v8 ::v7:: v1 ::  v2:: v3 :: v4 :: v5 ::v6:: nil.
Proof.
  intros;  simpl.
  destruct v; simpl struct_type_vallist_match' in H; tryfalse.
  destruct t9;simp join;
  match goal with
    | H : context[struct_type_vallist_match'] |- _ =>
      apply struct_type_vallist_match_elim_8 in H;auto; simp join
  end;
  do 9 eexists;  eauto.
Qed.

Lemma struct_type_vallist_match_elim_10 :
  forall x1 t1 x2 t2 x3 t3 x4 t4 x5 t5 x6 t6 x7 t7 x8 t8 x9 t9 x10 t10 v,
    struct_type_vallist_match'(dcons x10 t10 (dcons x9 t9 (dcons x8 t8 (dcons x7 t7 (dcons x1 t1 (dcons x2 t2 (dcons x3 t3 (dcons x4 t4 (dcons x5 t5 (dcons x6 t6 dnil)))))))))) v ->
    exists v1 v2 v3 v4 v5 v6 v7 v8 v9 v10,
      v = v10::v9 ::v8 ::v7:: v1 ::  v2:: v3 :: v4 :: v5 ::v6:: nil.
Proof.
  intros;  simpl.
  destruct v; simpl struct_type_vallist_match' in H; tryfalse.
  destruct t10; simp join;
  match goal with
    | H : context[struct_type_vallist_match'] |- _ =>
      apply struct_type_vallist_match_elim_9 in H;auto; simp join
  end;
  do 10 eexists;  eauto.
Qed.

Lemma struct_type_vallist_match_elim_11 :
  forall x1 t1 x2 t2 x3 t3 x4 t4 x5 t5 x6 t6 x7 t7 x8 t8 x9 t9 x10 t10 x11 t11 v,
    struct_type_vallist_match'(dcons x11 t11(dcons x10 t10 (dcons x9 t9 (dcons x8 t8 (dcons x7 t7 (dcons x1 t1 (dcons x2 t2 (dcons x3 t3 (dcons x4 t4 (dcons x5 t5 (dcons x6 t6 dnil))))))))))) v ->
    exists v1 v2 v3 v4 v5 v6 v7 v8 v9 v10,
      exists v11,
        v =v11:: v10::v9 ::v8 ::v7:: v1 ::  v2:: v3 :: v4 :: v5 ::v6:: nil.
Proof.
  intros;  simpl.
  destruct v; simpl struct_type_vallist_match' in H; tryfalse.
  destruct t11;simp join;
  match goal with
    | H : context[struct_type_vallist_match'] |- _ =>
      apply struct_type_vallist_match_elim_10 in H;auto; simp join
  end;
  do 11 eexists;  eauto.
Qed.

Lemma struct_type_vallist_match_elim_12 :
  forall x1 t1 x2 t2 x3 t3 x4 t4 x5 t5 x6 t6 x7 t7 x8 t8 x9 t9 x10 t10 x11 t11 x12 t12 v,
    struct_type_vallist_match'(dcons x12 t12 (dcons x11 t11(dcons x10 t10 (dcons x9 t9 (dcons x8 t8 (dcons x7 t7 (dcons x1 t1 (dcons x2 t2 (dcons x3 t3 (dcons x4 t4 (dcons x5 t5 (dcons x6 t6 dnil)))))))))))) v ->
    exists v1 v2 v3 v4 v5 v6 v7 v8 v9 v10,
      exists v11 v12,
        v =v12::v11:: v10::v9 ::v8 ::v7:: v1 ::  v2:: v3 :: v4 :: v5 ::v6:: nil.
Proof.
  intros;  simpl.
  destruct v; simpl struct_type_vallist_match' in H; tryfalse.
  destruct t12;simp join;
  match goal with
    | H : context[struct_type_vallist_match'] |- _ =>
      apply struct_type_vallist_match_elim_11 in H;auto; simp join
  end;
  do 12 eexists;  eauto; repeat (splits; auto).
Qed.

Lemma struct_type_vallist_match_elim_13 :
  forall x1 t1 x2 t2 x3 t3 x4 t4 x5 t5 x6 t6 x7 t7 x8 t8 x9 t9 x10 t10 x11 t11 x12 t12 x13 t13 v,
    struct_type_vallist_match'(dcons x13 t13 (dcons x12 t12 (dcons x11 t11(dcons x10 t10 (dcons x9 t9 (dcons x8 t8 (dcons x7 t7 (dcons x1 t1 (dcons x2 t2 (dcons x3 t3 (dcons x4 t4 (dcons x5 t5 (dcons x6 t6 dnil))))))))))))) v ->
    exists v1 v2 v3 v4 v5 v6 v7 v8 v9 v10,
      exists v11 v12 v13,
        v =v13 ::v12::v11:: v10::v9 ::v8 ::v7:: v1 ::  v2:: v3 :: v4 :: v5 ::v6:: nil.
Proof.
  intros;  simpl.
  destruct v; simpl struct_type_vallist_match' in H; tryfalse.
  destruct t13;simp join;
  match goal with
    | H : context[struct_type_vallist_match'] |- _ =>
      apply struct_type_vallist_match_elim_12 in H;auto;simp join
  end;
  do 13 eexists;  eauto; repeat (splits; auto).
Qed.

Ltac listlen x :=
  match x with
    | dnil => constr:0%nat
    | dcons _ _ ?x' => let y := listlen x' in
                       constr:(S y)
  end.

Ltac struct_type_vallist_match_elim :=
  match goal with
    | H : struct_type_vallist_match ?t _ |- _  =>
      try unfold t in H; simpl struct_type_vallist_match in H;
      match type of H with
        | struct_type_vallist_match' ?t' _  =>
          let Hr := fresh in let Hp := fresh in
          match listlen t' with
            | 0%nat => lets Hr : struct_type_vallist_match_elim_0  H
            | 1%nat => lets Hr : struct_type_vallist_match_elim_1  H
            | 2%nat => lets Hr : struct_type_vallist_match_elim_2  H
            | 3%nat => lets Hr : struct_type_vallist_match_elim_3  H
            | 4%nat => lets Hr : struct_type_vallist_match_elim_4  H
            | 5%nat => lets Hr : struct_type_vallist_match_elim_5  H
            | 6%nat => lets Hr : struct_type_vallist_match_elim_6  H
            | 7%nat => lets Hr : struct_type_vallist_match_elim_7  H
            | 8%nat => lets Hr : struct_type_vallist_match_elim_8  H
            | 9%nat => lets Hr : struct_type_vallist_match_elim_9  H
            | 10%nat => lets Hr : struct_type_vallist_match_elim_10  H
            | 11%nat => lets Hr : struct_type_vallist_match_elim_11  H
            | 12%nat => lets Hr : struct_type_vallist_match_elim_12  H
            | 13%nat => lets Hr : struct_type_vallist_match_elim_13  H
            | _ => fail 1
          end;
            [ simp join; lets Hp : struct_array_rm_type_val_match H;
              simpl remove_array_struct; eauto; clear H; unfold rule_type_val_match_list in Hp; simp join;
             struct_type_vallist_match_elim
            | (simpl; auto) .. ]
      end
    | _ => rule_type_val_match_elim
  end.

(* type val match *)

Lemma type_val_match_int8u_elim :
  forall v,
    type_val_match Int8u v = true ->
    exists i, v = Vint32 i /\ Int.unsigned i <= 255.
Proof.
  intros.
  destruct v; simpl in *; tryfalse.
  exists i; intuition auto.
  apply if_true_false_eq_true_elim in H.
  apply leb_bytemax_true_elim in H; auto.
Qed.

Lemma type_val_match_int16u_elim :
  forall v,
    type_val_match Int16u v = true ->
    exists i, v = Vint32 i /\ Int.unsigned i <= 65535.
Proof.
  intros.
  destruct v; simpl in *; tryfalse.
  exists i; intuition auto.
  apply if_true_false_eq_true_elim in H.
  apply leb_int16max_true_elim in H; auto.
Qed.

Lemma type_val_match_int32u_elim :
  forall v,
    type_val_match Int32u v = true ->
    exists i, v = Vint32 i.
Proof.
  intros.
  destruct v; simpl in *; tryfalse.
  eauto.
Qed.

Lemma type_val_match_ptr_elim :
  forall v t,
    type_val_match (Tptr t) v = true ->
    isptr v.
Proof.
  intros.
  destruct v; simpl in *; tryfalse.
  unfold isptr; auto.
  unfold isptr; eauto.
Qed.

Lemma type_val_match_comptr_elim :
  forall v t,
    type_val_match (Tcom_ptr t) v = true ->
    isptr v.
Proof.
  intros.
  destruct v; simpl in *; tryfalse.
  unfold isptr; auto.
  unfold isptr; eauto.
Qed.

Ltac type_val_match_elim :=
  match goal with
    | H : type_val_match Int8u ?v = true |- _ =>
      let i := fresh "i" in
      apply type_val_match_int8u_elim in H;
        destruct H as [ i [ ? H ]]; subst v;
        type_val_match_elim
    | H : type_val_match Int16u ?v = true |- _ =>
      let i := fresh "i" in
      apply type_val_match_int16u_elim in H;
        destruct H as [ i [ ? H ]]; subst v;
        type_val_match_elim
    | H : type_val_match Int32u ?v = true |- _ =>
      let i := fresh "i" in
      apply type_val_match_int32u_elim in H;
        destruct H as [ i H ]; subst v;
        type_val_match_elim
    | H : type_val_match (Tptr _) _ = true |- _ =>
      apply type_val_match_ptr_elim in H;
        type_val_match_elim
    | H : type_val_match (Tcom_ptr _) _ = true |- _ =>
      apply type_val_match_comptr_elim in H;
        type_val_match_elim
    | _ => idtac
  end.

Lemma true_if_else_true:
  forall x, x =true -> (if x then true else false) = true.
Proof.
  intros.
  rewrite H.
  auto.
Qed.

Ltac rtmatch_solve:=
  apply true_if_else_true;
  apply Zle_is_le_bool;
  try rewrite byte_max_unsigned_val;
  try rewrite max_unsigned_val;
  try omega.

Close Scope Z_scope.


Require Import TestSuite.admit.
(* -*- coq-prog-args: ("-indices-matter") -*- *)
(* File reduced by coq-bug-finder from original input, then from 8760 lines to 7519 lines, then from 7050 lines to 909 lines, then from 846 lines to 578 lines, then from 497 lines to 392 lines, then from 365 lines to 322 lines, then from 252 lines to 205 lines, then from 215 lines to 204 lines, then from 210 lines to 182 lines, then from 175 lines to 157 lines *)
Set Universe Polymorphism.
Axiom admit : forall {T}, T.
Set Implicit Arguments.
Generalizable All Variables.
Reserved Notation "g 'o' f" (at level 40, left associativity).
Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "a = b" := (@paths _ a b) : type_scope.
Arguments idpath {A a} , [A] a.
Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) : forall x, f x = g x := fun x => match h with idpath => idpath end.
Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { equiv_inv : B -> A }.
Delimit Scope equiv_scope with equiv.
Local Open Scope equiv_scope.
Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope.
Class Funext := { isequiv_apD10 :> forall (A : Type) (P : A -> Type) f g, IsEquiv (@apD10 A P f g) }.
Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, P x) : (forall x, f x = g x) -> f = g := (@apD10 A P f g)^-1.
Record PreCategory :=
  { object :> Type;
    morphism : object -> object -> Type;
    compose : forall s d d', morphism d d' -> morphism s d -> morphism s d' where "f 'o' g" := (compose f g);
    associativity : forall x1 x2 x3 x4 (m1 : morphism x1 x2) (m2 : morphism x2 x3) (m3 : morphism x3 x4), (m3 o m2) o m1 = m3 o (m2 o m1)
  }.
Bind Scope category_scope with PreCategory.
Bind Scope morphism_scope with morphism.
Infix "o" := (@compose _ _ _ _) : morphism_scope.
Delimit Scope functor_scope with functor.
Record Functor (C D : PreCategory) :=
  { object_of :> C -> D;
    morphism_of : forall s d, morphism C s d -> morphism D (object_of s) (object_of d) }.
Bind Scope functor_scope with Functor.
Notation "F '_1' m" := (@morphism_of _ _ F _ _ m) (at level 10, no associativity) : morphism_scope.
Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) := { morphism_inverse : morphism C d s }.
Local Notation "m ^-1" := (morphism_inverse (m := m)) : morphism_scope.
Class Isomorphic {C : PreCategory} s d :=
  { morphism_isomorphic :> morphism C s d;
    isisomorphism_isomorphic :> IsIsomorphism morphism_isomorphic }.
Coercion morphism_isomorphic : Isomorphic >-> morphism.
Definition isisomorphism_inverse `(@IsIsomorphism C x y m) : IsIsomorphism m^-1 := {| morphism_inverse := m |}.

Global Instance isisomorphism_compose `(@IsIsomorphism C y z m0) `(@IsIsomorphism C x y m1) : IsIsomorphism (m0 o m1).
Admitted.
Infix "<~=~>" := Isomorphic (at level 70, no associativity) : category_scope.
Definition composef C D E (G : Functor D E) (F : Functor C D) : Functor C E
  := Build_Functor
       C E
       (fun c => G (F c))
       (fun _ _ m => @morphism_of _ _ G _ _ (@morphism_of _ _ F _ _ m)).
Infix "o" := composef : functor_scope.
Delimit Scope natural_transformation_scope with natural_transformation.

Local Open Scope morphism_scope.
Record NaturalTransformation C D (F G : Functor C D) :=
  { components_of :> forall c, morphism D (F c) (G c);
    commutes : forall s d (m : morphism C s d), components_of d o F _1 m = G _1 m o components_of s }.

Definition composet C D (F F' F'' : Functor C D) (T' : NaturalTransformation F' F'') (T : NaturalTransformation F F')
: NaturalTransformation F F''
  := Build_NaturalTransformation F F'' (fun c => T' c o T c) admit.
Infix "o" := composet : natural_transformation_scope.
Section path_natural_transformation.
  Context `{Funext}.
  Variable C : PreCategory.
  Variable D : PreCategory.
  Variables F G : Functor C D.
  Section path.
    Variables T U : NaturalTransformation F G.
    Lemma path'_natural_transformation
    : components_of T = components_of U
      -> T = U.
      admit.
    Defined.
    Lemma path_natural_transformation
    : (forall x, components_of T x = components_of U x)
      -> T = U.
    Proof.
      intros.
      apply path'_natural_transformation.
      apply path_forall; assumption.
    Qed.
  End path.
End path_natural_transformation.
Ltac path_natural_transformation :=
  repeat match goal with
           | _ => intro
           | _ => apply path_natural_transformation; simpl
         end.

Local Open Scope natural_transformation_scope.
Definition associativityt `{fs : Funext}
           C D F G H I
           (V : @NaturalTransformation C D F G)
           (U : @NaturalTransformation C D G H)
           (T : @NaturalTransformation C D H I)
: (T o U) o V = T o (U o V).
Proof.
  path_natural_transformation.
  apply associativity.
Qed.
Definition functor_category `{Funext} (C D : PreCategory) : PreCategory
  := @Build_PreCategory (Functor C D) (@NaturalTransformation C D) (@composet C D) (@associativityt _ C D).
Notation "C -> D" := (functor_category C D) : category_scope.
Definition NaturalIsomorphism `{Funext} (C D : PreCategory) F G := @Isomorphic (C -> D) F G.
Infix "<~=~>" := NaturalIsomorphism : natural_transformation_scope.
Global Instance isisomorphism_compose' `{Funext}
       `(T' : @NaturalTransformation C D F' F'')
       `(T : @NaturalTransformation C D F F')
       `{@IsIsomorphism (C -> D) F' F'' T'}
       `{@IsIsomorphism (C -> D) F F' T}
: @IsIsomorphism (C -> D) F F'' (T' o T)%natural_transformation
  := @isisomorphism_compose (C -> D) _ _ T' _ _ T _.
Section lemmas.
  Context `{Funext}.
  Variable C : PreCategory.
  Variable F : C -> PreCategory.
  Context
    {w y z}
    {f : Functor (F w) (F z)} {f0 : Functor (F w) (F y)}
    {f2 : Functor (F y) (F z)}
    {f5 : Functor (F w) (F z)}
    {n2 : f <~=~> (f2 o f0)%functor}.
  Lemma p_composition_of_coherent_iso_for_rewrite__isisomorphism_helper' XX
  : @IsIsomorphism
      (F w -> F z) f5 f
      (n2 ^-1 o XX)%natural_transformation.
  Proof.
    eapply isisomorphism_compose'.
    eapply isisomorphism_inverse. (* Toplevel input, characters 22-43:
Error:
In environment
H : Funext
C : PreCategory
F : C -> PreCategory
w : C
y : C
z : C
f : Functor (F w) (F z)
f0 : Functor (F w) (F y)
f2 : Functor (F y) (F z)
f5 : Functor (F w) (F z)
n2 : f <~=~> (f2 o f0)%functor
XX : NaturalTransformation f5 (f2 o f0)
Unable to unify
 "{|
  object := Functor (F w) (F z);
  morphism := NaturalTransformation (D:=F z);
  compose := composet (D:=F z);
  associativity := associativityt (D:=F z) |}" with
 "{|
  object := Functor (F w) (F z);
  morphism := NaturalTransformation (D:=F z);
  compose := composet (D:=F z);
  associativity := associativityt (D:=F z) |}". *)


Require Export monoidalgroupoid.

Section FMG.

Private Inductive FMG (X : Type) : Type :=
  | e : FMG X
  | iota : X -> FMG X
  | m : FMG X -> FMG X -> FMG X.
Global Arguments e {X}.
Global Arguments iota {X} _.
Global Arguments m {X} _ _.
Context (X : Type).

Definition mm {x x' y y' : FMG X}
  (p : x = x') (q : y = y')
  : m x y = m x' y'
  := ap011 m p q.

Axiom alpha : @IsAssociative (FMG X) m.
Axiom lambda : @IsLeftUnital (FMG X) e m.
Axiom rho : @IsRightUnital (FMG X) e m.
Axiom pentagon : IsPentagonCoherent m alpha.
Axiom triangle : IsTriangleCoherent e m alpha lambda rho.
Axiom T_FMG : IsTrunc 1 (FMG X).

Section FMG_ind.

Context
  (P : FMG X -> Type)
  (e' : P e)
  (iota' : forall x : X, P (iota x))
  (m' : forall (a b : FMG X), P a -> P b -> P (m a b)).
Global Arguments m' {a} {b} _ _.

Definition mm'
  {a1 a2 b1 b2 : FMG X} {p : a1 = a2} {q : b1 = b2}
  {a1' : P a1} {a2' : P a2} {b1' : P b1} {b2' : P b2}
  (p' : transport P p a1' = a2') (q' : transport P q b1' = b2')
  : transport P (mm p q) (m' a1' b1') = m' a2' b2'.
Proof.
  induction p, q, p', q'; constructor.
Defined.

Fixpoint FMG_ind
  (alpha' : forall (a b c : FMG X) (a' : P a) (b' : P b) (c' : P c),
    transport P (alpha a b c) (m' (m' a' b') c') = m' a' (m' b' c'))
  (lambda' : forall (b : FMG X) (b' : P b),
    transport P (lambda b) (m' e' b') = b')
  (rho' : forall (a : FMG X) (a' : P a),
    transport P (rho a) (m' a' e') = a')
  (pentagon' : forall (a b c d : FMG X) (a' : P a) (b' : P b) (c' : P c) (d' : P d),
    concat_D
      (alpha' _ _ _ (m' a' b') c' d')
      (alpha' _ _ _ a' b' (m' c' d'))
    = ap (fun z => transport P z (m' (m' (m' a' b') c') d')) (pentagon a b c d)
      @ concat_D
          (concat_D
            (mm' (alpha' _ _ _ a' b' c') (transport_1 P d'))
            (alpha' _ _ _ a' (m' b' c') d'))
          (mm' (transport_1 P a') (alpha' _ _ _ b' c' d')))
  (triangle' : forall (a b : FMG X) (a' : P a) (b' : P b),
    concat_D
      (alpha' _ _ _ a' e' b')
      (mm' (transport_1 P a') (lambda' _ b'))
    = ap (fun z => transport P z (m' (m' a' e') b')) (triangle a b)
      @ mm' (rho' _ a') (transport_1 P b'))
  (T' : forall (w : FMG X), IsTrunc 1 (P w))
  (w : FMG X) : P w
  := match w with
    | e => e'
    | iota x => iota' x
    | m a b => m' (FMG_ind alpha' lambda' rho' pentagon' triangle' T' a) (FMG_ind alpha' lambda' rho' pentagon' triangle' T' b) end.

Section Axioms.

Context
  (alpha' : forall (a b c : FMG X) (a' : P a) (b' : P b) (c' : P c),
    transport P (alpha a b c) (m' (m' a' b') c') = m' a' (m' b' c'))
  (lambda' : forall (b : FMG X) (b' : P b),
    transport P (lambda b) (m' e' b') = b')
  (rho' : forall (a : FMG X) (a' : P a),
    transport P (rho a) (m' a' e') = a')
  (pentagon' : forall (a b c d : FMG X) (a' : P a) (b' : P b) (c' : P c) (d' : P d),
    concat_D
      (alpha' _ _ _ (m' a' b') c' d')
      (alpha' _ _ _ a' b' (m' c' d'))
    = ap (fun z => transport P z (m' (m' (m' a' b') c') d')) (pentagon a b c d)
      @ concat_D
          (concat_D
            (mm' (alpha' _ _ _ a' b' c') (transport_1 P d'))
            (alpha' _ _ _ a' (m' b' c') d'))
          (mm' (transport_1 P a') (alpha' _ _ _ b' c' d')))
  (triangle' : forall (a b : FMG X) (a' : P a) (b' : P b),
    concat_D
      (alpha' _ _ _ a' e' b')
      (mm' (transport_1 P a') (lambda' _ b'))
    = ap (fun z => transport P z (m' (m' a' e') b')) (triangle a b)
      @ mm' (rho' _ a') (transport_1 P b'))
  (T' : forall (w : FMG X), IsTrunc 1 (P w)).

Let FMG_ind' := FMG_ind alpha' lambda' rho' pentagon' triangle' T'.

Axiom FMG_ind_beta_alpha
  : forall (a b c : FMG X),
    apD FMG_ind' (alpha a b c) = alpha' _ _ _ (FMG_ind' a) (FMG_ind' b) (FMG_ind' c).

Axiom FMG_ind_beta_lambda
  : forall (b : FMG X),
    apD FMG_ind' (lambda b) = lambda' _ (FMG_ind' b).

Axiom FMG_ind_beta_rho
  : forall (a : FMG X),
    apD FMG_ind' (rho a) = rho' _ (FMG_ind' a).

(* Axioms for pentagon and triangle omitted *)

End Axioms.

End FMG_ind.

Section FMG_ind_trunc.

Context
  (P : FMG X -> Type)
  (e' : P e)
  (iota' : forall x : X, P (iota x))
  (m' : forall (a b : FMG X), P a -> P b -> P (m a b)).
Global Arguments m' {a} {b} _ _.

Definition FMG_ind_to_set
  (alpha' : forall (a b c : FMG X) (a' : P a) (b' : P b) (c' : P c),
    transport P (alpha a b c) (m' (m' a' b') c') = m' a' (m' b' c'))
  (lambda' : forall (b : FMG X) (b' : P b),
    transport P (lambda b) (m' e' b') = b')
  (rho' : forall (a : FMG X) (a' : P a),
    transport P (rho a) (m' a' e') = a')
  (T' : forall (w : FMG X), IsTrunc 0 (P w))
  : forall w : FMG X, P w.
Proof.
  refine (FMG_ind P e' iota' (@m') alpha' lambda' rho' _ _ _);
  intros; apply T'.
Defined.

Definition FMG_ind_to_prop
  (T' : forall (w : FMG X), IsTrunc (-1) (P w))
  : forall w : FMG X, P w.
Proof.
  refine (FMG_ind_to_set _ _ _ _);
    intros; apply T'.
Defined.

End FMG_ind_trunc.

Section FMG_ind_paths.

Definition FMG_ind_to_paths_in_gpd
  (P : Type)
  (f f' : FMG X -> P)
  (e' : f e = f' e)
  (iota' : forall x : X, f (iota x) = f' (iota x))
  (m' : forall a b : FMG X, f a = f' a -> f b = f' b -> f (m a b) = f' (m a b))
  (alpha' : forall (a b c : FMG X) (a' : f a = f' a) (b' : f b = f' b) (c' : f c = f' c),
    m' (m a b) c (m' a b a' b') c' @ ap f' (alpha a b c)
    = ap f (alpha a b c) @ m' a (m b c) a' (m' b c b' c'))
  (lambda' : forall (b : FMG X) (b' : f b = f' b),
     m' e b e' b' @ ap f' (lambda b) = ap f (lambda b) @ b')
  (rho' : forall (a : FMG X) (a' : f a = f' a),
    m' a e a' e' @ ap f' (rho a) = ap f (rho a) @ a')
  (T' : IsTrunc 1 P)
  : forall w : FMG X, f w = f' w.
Proof.
  srapply (@FMG_ind_to_set (fun w => f w = f' w) e' iota' m');
  intros; simpl;
  refine (transport_paths_FlFr _ _ @ _);
  refine (concat_pp_p _ _ _ @ _); apply moveR_Vp.
  + apply alpha'.
  + apply lambda'.
  + apply rho'.
Defined.

Definition FMG_ind_to_paths_in_set
  (P : Type)
  (f f' : FMG X -> P)
  (e' : f e = f' e)
  (iota' : forall x : X, f (iota x) = f' (iota x))
  (m' : forall a b : FMG X, f a = f' a -> f b = f' b -> f (m a b) = f' (m a b))
  (T' : IsTrunc 0 P)
  : forall w : FMG X, f w = f' w.
Proof.
  srapply (@FMG_ind_to_prop (fun w => f w = f' w) e' iota' m').
Defined.

Definition FMG_ind_to_2paths_in_gpd
  (P : Type)
  (f f' : FMG X -> P)
  (p p' : forall a : FMG X, f a = f' a)
  (e' : p e = p' e)
  (iota' : forall x : X, p (iota x) = p' (iota x))
  (m' : forall a b : FMG X, p a = p' a -> p b = p' b -> p (m a b) = p' (m a b))
  (T' : IsTrunc 1 P)
  : forall w : FMG X, p w = p' w.
Proof.
  srapply (@FMG_ind_to_prop (fun w => p w = p' w) e' iota' m').
Defined.

Definition FMG_ind_to_fam_paths_in_gpd
  `{Funext}
  (B C : Type)
  (f f' : FMG X -> B -> C)
  (e' : forall (b : B), f e b = f' e b)
  (iota' : forall (x : X) (b : B), f (iota x) b = f' (iota x) b)
  (m' : forall (a b : FMG X)
    (a' : forall c : B, f a c = f' a c)
    (b' : forall c : B, f b c = f' b c)
    (q : B),
    f (m a b) q = f' (m a b) q)
  (alpha' : forall (a b c : FMG X)
    (a' : forall z : B, f a z = f' a z)
    (b' : forall z : B, f b z = f' b z)
    (c' : forall z : B, f c z = f' c z)
    (q : B),
    m' (m a b) c (m' a b a' b') c' q @ ap (fun z : FMG X => f' z q) (alpha a b c)
    = ap (fun z : FMG X => f z q) (alpha a b c) @ m' a (m b c) a' (m' b c b' c') q)
  (lambda' : forall (b : FMG X)
    (b' : forall z : B, f b z = f' b z)
    (q : B),
    m' e b e' b' q @ ap (fun a : FMG X => f' a q) (lambda b)
    = ap (fun a : FMG X => f a q) (lambda b) @ b' q)
  (rho' : forall (a : FMG X)
    (a' : forall z : B, f a z = f' a z)
    (q : B),
    m' a e a' e' q @ ap (fun a0 : FMG X => f' a0 q) (rho a)
    = ap (fun a0 : FMG X => f a0 q) (rho a) @ a' q)
  (T' : IsTrunc 1 C)
  : forall (a : FMG X) (b : B), f a b = f' a b.
Proof.
  srefine (@FMG_ind_to_set (fun a => forall b : B, f a b = f' a b) e' iota' m' _ _ _ _);
  simpl; intros;
  apply path_forall; intro q;
  refine (transport_forall' f f' _ _ _ @ _); apply moveR_Vp.
  + apply alpha'.
  + apply lambda'.
  + apply rho'.
Defined.

End FMG_ind_paths.

Section FMG_rec.

Context
  (A : Type)
  (e' : A)
  (iota' : X -> A)
  (m' : A -> A -> A)
  (alpha' : @IsAssociative A m')
  (lambda' : @IsLeftUnital A e' m')
  (rho' : @IsRightUnital A e' m')
  (pentagon' : IsPentagonCoherent m' alpha')
  (triangle' : IsTriangleCoherent e' m' alpha' lambda' rho')
  (T' : IsTrunc 1 A).

Lemma mm'_transport_const
  {a1 a2 b1 b2 : FMG X} (p : a1 = a2) (q : b1 = b2)
  {a1' a2' b1' b2' : A}
  (p' : a1' = a2') (q' : b1' = b2')
  : mm' (fun _ => A) (fun _ => fun _ => m') (transport_const p a1' @ p') (transport_const q b1' @ q')
    = transport_const (mm p q) (m' a1' b1') @ ap011 m' p' q'.
Proof.
  induction p, q, p', q'; constructor.
Defined.

Definition FMG_rec_pentagon
  : forall (a b c d : FMG X) (a' b' c' d' : A),
    concat_D
      (transport_const (alpha (m a b) c d) (m' (m' (m' a' b') c') d') @ alpha' (m' a' b') c' d')
      (transport_const (alpha a b (m c d)) (m' (m' a' b') (m' c' d')) @ alpha' a' b' (m' c' d'))
    = ap (fun z : m (m (m a b) c) d = m a (m b (m c d)) => transport (fun _ : FMG X => A) z (m' (m' (m' a' b') c') d')) (pentagon a b c d)
      @ concat_D
          (concat_D
            (mm' (fun _ : FMG X => A) (fun _ _ : FMG X => m') (transport_const (alpha a b c) (m' (m' a' b') c') @ alpha' a' b' c') (transport_1 (fun _ : FMG X => A) d'))
            (transport_const (alpha a (m b c) d) (m' (m' a' (m' b' c')) d') @ alpha' a' (m' b' c') d'))
        (mm' (fun _ : FMG X => A) (fun _ _ : FMG X => m') (transport_1 (fun _ : FMG X => A) a') (transport_const (alpha b c d) (m' (m' b' c') d') @ alpha' b' c' d')).
Proof.
  intros.
  rewrite transport_1_const, transport_1_const,
    mm'_transport_const, mm'_transport_const,
    concat_D_const_p, concat_D_const_p, concat_D_const_p.
  refine (whiskerL _ (pentagon' a' b' c' d') @ _).
  refine (_ @ concat_pp_p _ _ _); apply whiskerR.
  exact (transport_const_pq _ _)^.
Defined.

Definition FMG_rec_triangle
  : forall (a b : FMG X) (a' b' : A),
    concat_D
      (transport_const (alpha a e b) (m' (m' a' e') b') @ alpha' a' e' b')
      (mm' (fun _ : FMG X => A) (fun _ _ : FMG X => m') (transport_1 (fun _ : FMG X => A) a') (transport_const (lambda b) (m' e' b') @ lambda' b'))
    = ap (fun z : m (m a e) b = m a b => transport (fun _ : FMG X => A) z (m' (m' a' e') b')) (triangle a b)
      @ mm' (fun _ : FMG X => A) (fun _ _ : FMG X => m') (transport_const (rho a) (m' a' e') @ rho' a') (transport_1 (fun _ : FMG X => A) b').
Proof.
  intros.
  rewrite transport_1_const, transport_1_const,
    mm'_transport_const, mm'_transport_const,
    concat_D_const_p.
  refine (whiskerL _ (triangle' a' b') @ _).
  refine (_ @ concat_pp_p _ _ _); apply whiskerR.
  exact (transport_const_pq _ _)^.
Defined.

Definition FMG_rec
  : FMG X-> A.
Proof.
  srapply (@FMG_ind (fun _ => A) e' iota' (fun _ => fun _ => m')); hnf.
  + intros. exact (transport_const _ _ @ alpha' a' b' c').
  + intros. exact (transport_const _ _ @ lambda' b').
  + intros. exact (transport_const _ _ @ rho' a').
  + hnf. exact FMG_rec_pentagon.
  + hnf. exact FMG_rec_triangle.
Defined.

Definition FMG_rec_beta_alpha
  : forall a b c : FMG X,
    ap FMG_rec (alpha a b c) = alpha' (FMG_rec a) (FMG_rec b) (FMG_rec c).
Proof.
  intros.
  eapply (cancelL (transport_const (alpha a b c) _)).
  refine ((apD_const _ (alpha a b c))^ @ _).
  unfold FMG_rec.
  srapply @FMG_ind_beta_alpha.
Defined.

Definition FMG_rec_beta_lambda
  : forall b : FMG X,
    ap FMG_rec (lambda b) = lambda' (FMG_rec b).
Proof.
  intros.
  eapply (cancelL (transport_const (lambda b) _)).
  refine ((apD_const _ (lambda b))^ @ _).
  srapply @FMG_ind_beta_lambda.
Defined.

Definition FMG_rec_beta_rho
  : forall a : FMG X,
    ap FMG_rec (rho a) = rho' (FMG_rec a).
Proof.
  intros.
  eapply (cancelL (transport_const (rho a) _)).
  refine ((apD_const _ (rho a))^ @ _).
  srapply @FMG_ind_beta_rho.
Defined.

End FMG_rec.

Section FMG_rec_trunc.

Lemma FMG_rec_to_set
  (A : Type)
  (e' : A)
  (iota' : X -> A)
  (m' : A -> A -> A)
  (alpha' : @IsAssociative A m')
  (lambda' : @IsLeftUnital A e' m')
  (rho' : @IsRightUnital A e' m')
  (T' : IsTrunc 0 A)
  : FMG X -> A.
Proof.
  refine (@FMG_rec A e' iota' m' alpha' lambda' rho' _ _ _);
  [unfold IsPentagonCoherent | unfold IsTriangleCoherent];
  intros; apply T'.
Defined.

Lemma FMG_rec_to_prop
  (A : Type)
  (e' : A)
  (iota' : X -> A)
  (m' : A -> A -> A)
  (T' : IsTrunc (-1) A)
  : FMG X -> A.
Proof.
  srapply (@FMG_rec_to_set A e' iota' m');
  [unfold IsAssociative | unfold IsLeftUnital | unfold IsRightUnital];
  intros; apply T'.
Defined.

End FMG_rec_trunc.

End FMG.

Arguments mm {X} {_} {_} {_} {_} p q.

Arguments alpha {X} _ _ _.
Arguments lambda {X} _.
Arguments rho {X} _.
Arguments pentagon {X} _ _ _ _.
Arguments triangle {X} _ _.
Arguments T_FMG {X} _ _ _ _ _ _.

Definition FMG_MG (X : Type) {T_X : IsHSet X} : MonoidalGroupoid
  := Build_MonoidalGroupoid (FMG X) T_FMG e m alpha lambda rho pentagon triangle.

Lemma FMG_rec_MonoidalFunctor (X : Type) (T_X : IsHSet X)
  (M : MonoidalGroupoid) (iota' : X -> M)
  : MonoidalFunctor (FMG_MG X) M.
Proof.
  srefine (let fmgrec := (FMG_rec X M mg_e iota' mg_m mg_alpha mg_lambda mg_rho mg_pentagon mg_triangle mgtrunc) in
    @Build_MonoidalFunctor (FMG_MG X) M fmgrec _ _ _ _ _);
  try constructor;
  intros; simpl;
  refine (_ @ (concat_1p _)^).
  + refine (concat_p1 _ @ _).
    exact (FMG_rec_beta_alpha X M mg_e iota' mg_m mg_alpha mg_lambda mg_rho mg_pentagon mg_triangle mgtrunc a b c)^.
  + exact (FMG_rec_beta_lambda X M mg_e iota' mg_m mg_alpha mg_lambda mg_rho mg_pentagon mg_triangle mgtrunc b)^.
  + exact (FMG_rec_beta_rho X M mg_e iota' mg_m mg_alpha mg_lambda mg_rho mg_pentagon mg_triangle mgtrunc a)^.
Defined.

Section Redefinitions.

Context {X : Type} {T_X : IsHSet X}.

Definition alpha_FMG_natural {a b c a' b' c' : FMG X} (pa : a = a') (pb : b = b') (pc : c = c')
  := @alpha_natural (FMG_MG X) a b c a' b' c' pa pb pc.

Definition lambda_FMG_natural {b b' : FMG X} (pb : b = b')
  := @lambda_natural (FMG_MG X) b b' pb.

Definition rho_FMG_natural {a a' : FMG X} (pa : a = a')
  := @rho_natural (FMG_MG X) a a' pa.

Definition rho_FMG_a_e (a : FMG X)
  := @rho_a_e (FMG_MG X) a.

Definition lambda_FMG_e_b (b : FMG X)
  := @lambda_e_b (FMG_MG X) b.

Definition alpha_lambda_FMG (a b : FMG X)
  := @alpha_lambda (FMG_MG X) a b.

Definition alpha_rho_FMG (a b : FMG X)
  := @alpha_rho (FMG_MG X) a b.

Definition lambda_rho_FMG_e
  := @lambda_rho_e (FMG_MG X).

End Redefinitions.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*   Assia.Mahboubi@inria.fr, Laurence.Rideau@inria.fr       *)
(*  Laurent.Thery@inria.fr  &all    Inria, 2006              *)
(*************************************************************)

Unset Boxed Definitions.
Unset Boxed Values.

 (*Require Import Qabs_rec.
  Require Import CAD_rec.*)
(*Require Import CAD.*)
Require Import Qabs.
Require Import Utils.
Require Import CAD_types.

Set  Implicit Arguments.

Module MK_UP_DIM(Q:RAT_STRUCT).

  Module QFUNS:= RAT_FUNS Q.
  Module QINT := RAT_INT_OPS Q.
  Import Q.
  Import QFUNS.
  Import QINT.

  Section UP_DIM.

    (* coefficients *)
    Variable C:Set.
    Let Coef := Pol1 C.
    Let cdeg := @Pol_deg C.

    (*information retained for bern coefs *)
    Let cInfo := build_Info C.

    Let cmk_Info := @mk_build_Info C.

    Variable bern:Set.

    (* type of cell_points at the level n *)
    Variable cell_point_low : Set.

    Let path := next_path Rat C bern cell_point_low.
    Let crpoint_of_cell(z:path):= snd z.
    Let ccell_point_proj(z:path):=fst z.

    Variable cmkCad : Set -> Set.
    Variable cmkCad_map : forall C D:Set,
      (cell_point_low -> C -> (cell_point_low * D)) -> cmkCad C -> cmkCad D.

    Variable CAD_n : Cad Rat C bern cell_point_low cmkCad.

    Let c0 := Pol_0 CAD_n.
    Let c1 := Pol_1 CAD_n.
    Let cadd := Pol_add CAD_n.
    Let cmult_base_cst := Pol_mul_Rat CAD_n.
    Let cmul := Pol_mul CAD_n.
    Let csub := Pol_sub CAD_n.
    Let copp := Pol_opp CAD_n.
    Let cof_Rat := Pol_of_Rat CAD_n.
    Let cis_Rat := Pol_is_Rat CAD_n.
    Let cof_pos(p:positive) := cof_Rat (rof_pos p).
    Let czero_test := Pol_zero_test CAD_n.
    Let cbase_cst_sign := Pol_base_cst_sign CAD_n.
    Let cpow := Pol_pow CAD_n.
    Let cdiv_base_cst :=  Pol_div_Rat CAD_n.
    Let cdiv := Pol_div CAD_n.
    Let cgcd_gcd_free := Pol_gcd_gcd_free CAD_n.
    Let csquare_free := Pol_square_free CAD_n.
    Let ccell_refine := path_refine CAD_n.
    Let clow_bound := Pol_low_bound CAD_n.
    Let cvalue_bound := Pol_value_bound CAD_n.
    Let cInfo_of_Pol := Info_of_Pol CAD_n.
    Let clow_sign := Pol_low_sign CAD_n.
    Let csign_at := Pol_sign_at CAD_n.
    Let ccad := Pol_cad CAD_n.

    Let cPol_of_Info(info:cInfo) := fst5 info.

(*    Load Gen_functor.*)

Load Pol_on_Coef.
Load Pol_on_Coef_on_Rat.
Load Bern.
Load Alg.

  (*Are now available:
     Pol_add :Pol -> Pol->Pol
     Pol_mul :Pol->Pol->Pol
     Pol_sub :Pol->Pol->Pol
     Pol_opp :Pol->Pol
     Pol_div:Pol->Pol->Pol
     Pol_zero_test : Pol->bool
     mk_PX := Pol ->positive -> Coef -> Pol
     Pol_of_pos := positive -> Pol
     Pol_pow := Pol -> N -> Pol
     Pol_subres_list := Pol -> Pol-> list Pol
     Pol_subres_coef_list := Pol -> Pol -> list Coef
     Pol_gcd := Pol -> Pol -> Pol
     Pol_square_free := Pol -> Pol
     Pol_deriv := Pol -> Pol
     Pol_eval := Pol -> Coef -> Coef.
     Pol_trunc : Pol  -> list Pol
     Pol_mk_coef :
     Pol_mkPc :=
     Pol_is_base_cst
     Pol_mult_base_cst
     Pol_div_base_cst
     Pol_partial_eval
     Pol_trunc
     Pol_bern_coefs
     Pol_bern_split+....*)

    (*

    Let Cad_up := mkCad_up Rat Coef cInfo mkCad.

    Let map_Cad_n := @map_Cad_up Rat rmin req Coef cInfo cell_point
      mkCad min_cell_point_list map_Cad (Minf Coef cInfo r0).

*)

    Let mk_cell_point(z:cell_point_low)(r:mkRpoint Rat C bern):=(z,r).

  (* Equality test over coefs in normal forms *)
    Let ceq(P Q:Coef):= czero_test (P -- Q).

    Let Pol_base_cst_sign(P:Pol):Sign:=
      match P with
	|Pc c => cbase_cst_sign c
	|PX _ _ _ => None
      end.

    (****************************************************************)
    (**Bounds for the roots of a Pol above a cell and sign at infty**)
    (****************************************************************)

    (* P=p0+...+pnX^n, c(P)=(n+1)*(sum p_i^2)/(p_n^2) (1) majorizes the abs values
    of the roots of P *)

    (* Sum of the squares of the coefficents *)
    Let  sum_square_coef:=
      fix sum_square_val_coef (P:Pol):Coef:=
	match P with
	  |Pc p => p **  p
	  |PX P' i p => (p ** p) ++ sum_square_val_coef P'
	end.

   (* Bounds on the values of the numerator in (1) above z *)
    Let Pol_num_bound(P:Pol)(z:path):=
      let n:= sum_square_coef P in
	cvalue_bound z n.

    (* c(P) above z*)
    Let Pol_bound(P:Pol)(z:path):=
      let (dP, den) := Pol_deg_coefdom P in
	let (a,b):= (Pol_num_bound P z)  in
	  let (c,d) := (cvalue_bound z (den ** den)) in
	    let (res,_) :=  rdiv_int a b c d in
	      rprod (radd (rof_N dP)  r1) res.

    (* Upper bound for the roots of P above z *)
    Let  Pol_up_bound(P:Pol)(z:path):=
      radd (Pol_bound P z) r1.

    Let Pol_info_up_bound(z:path)(i:Info):=
      let (P,_,_,_,sinfo):=i in
	match sinfo with
	  |Some _ => r0
	  |None => Pol_up_bound P z
	end.

    (* Lower bound for the roots of P above z *)
    Let  Pol_low_bound(P:Pol)(z:path):=
      ropp (radd (Pol_bound P z) r1).

    Let Pol_info_low_bound(z:path)(i:Info):=
      let (P,_,_,_,sinfo):=i in
	match sinfo with
	  |Some _ => r0
	  |None => Pol_low_bound P z
	end.

  (* Sign of P in -infty above z, also computes a refinement of z *)
    Let Pol_low_sign(z:path)(P Pbar:Pol)(n:nat):=
      let z' := ccell_point_proj z in
      let r := crpoint_of_cell z in
      let m:= Pol_low_bound P z in
      let P_atm := (Pol_partial_eval P m) in
      let Pbar_atm := Pol_partial_eval Pbar m in
      let dPbar_atm := cdeg Pbar_atm in
      let (z',s) := clow_sign z' P_atm Pbar_atm n in
      let (z, res) :=
	csign_at
	(cmk_Info P_atm Pbar_atm  dPbar_atm s None) (mk_cell_point z' r) n in
	(z, (P, (snd res))).

    Let Pol_low_sign_for_upper(z:path)(P Pbar:Pol)(n:nat):=
      let (z, slow):=(Pol_low_sign z P Pbar n) in
	(z, snd slow).

  (************************************************************)
  (**          Roots isolation above a cell_point            **)
  (************************************************************)

  (** Sign determination at a rational point above the cell_point z **)

    Let Pol_eval_sign_at_isol(P Pbar:Pol)(z:path)(c:Rat)(n:nat):=
      let Pbar_at_c := Pol_partial_eval Pbar c in
      let P_at_c := Pol_partial_eval P c in
      let dPbar_at_c := cdeg Pbar_at_c in
      let (_,s):= clow_sign (ccell_point_proj z) P_at_c Pbar_at_c n in
	csign_at (cmk_Info P_at_c Pbar_at_c dPbar_at_c s  None) z n.

  (** z is a cell_point, a a rational, computes the pair (P, sign P(z,a))
   from an Info **)
    Let Pol_info_eval_sign(n:nat)(a:Rat)(z:path)(u:Info):=
      let (P,freeP, dfreeP, lowsing, infosign):=u in
	match infosign with
	  |Some s => (P,infosign)
	  |None => (P,snd (snd (Pol_eval_sign_at_isol P freeP z a n)))
      end.

  (** While mapping sign determination over a list l of coef,
    refines successively the cell_point z **)

    Let csign_at_refine(z:path)(l:list cInfo)(n:nat):
      path*list (Coef*Sign):=
      let sign_refine :=
	fix sign_refine(l:list cInfo)(res:path*list (Coef *Sign))
	  {struct l}:path*list (Coef*Sign):=
	  match l with
	    |nil => res
	    |hd :: tl =>
	      let (z', s):= csign_at hd z n in
		sign_refine tl (z', (s::(snd res)))
	  end in
	  sign_refine l (z,nil).

  (** Isolation of roots of P over ]c d[ above z **)

    Let root_isol1(P:Pol)(Pbar:Pol):=
      fix root_isol1(r:path*(list (Rpoint*(list (Pol*Sign)))))
	(c d:Rat)(blist: list cInfo)(n:nat){struct n}:
	path*(list (Rpoint *(list (Pol*Sign)))):=
	let (z,res):=r in
	  if rlt d c
	    then (z,nil)
	    else
	      let (z,Vb) := csign_at_refine z blist n in
		let test := op_sign_changes (map (fun x => snd x) Vb) in
		  match test  with
		    |None => (z,(Alg_root (Five c d P Pbar blist), (P,None)::nil)::res)
		    |Some O => (z,res)
		|Some 1 =>
		  let (z, sP_c):=Pol_eval_sign_at_isol P Pbar z c n in
		  let (z, sP_d):=Pol_eval_sign_at_isol P Pbar z d n in
		    match  (sign_mult (snd sP_c) (snd sP_d)) with
		      |None => (z,(Alg_root (Five c d  P Pbar  blist), (P,None)::nil)::res)
                      |Some Eq =>
			match n with
			  |O=> (z,(Alg_root (Five c d P Pbar blist), (P,None)::nil)::res)
			  |S n' =>
                            let mid := rdiv (radd d c)  (2 # 1) in
                            let (b', b''):= Pol_bern_split blist c d mid in
			    let (z,res'):= root_isol1 (z,res) c  mid  b' n' in
			    let (z,sP_mid) := Pol_eval_sign_at_isol Pbar Pbar z mid n in
			      match  snd sP_mid  with
				|None =>
				  (z,
				    (Alg_root (Five c d P Pbar blist), (P,snd sP_mid)::nil)
				    :: res')
				|Some Eq =>
				  root_isol1 (z,((Root Coef cInfo mid,(P, snd sP_mid)::nil)::res'))
				  mid d b'' n'
				|_ => root_isol1 (z,res')  mid d b'' n'

		      end
			end
                      |_ =>
			(z,(Alg_root (Five c d P Pbar blist), (P,(Some Eq))::nil)::res)
		    end
		    |_ =>
		      match n with
			|O => (z,(Alg_root (Five c d P Pbar blist), (P,None)::nil)::res)
			|S n' =>
			  let mid := rdiv (radd d c)  (2 # 1) in
			  let (b', b''):= Pol_bern_split blist c d mid  in
			  let (z,res'):= root_isol1 (z,res) c  mid  b' n' in
			  let (z, sP_mid) :=Pol_eval_sign_at_isol Pbar Pbar z mid n in
			    match  snd sP_mid with
			      |None =>
				(z,(Alg_root (Five c d P Pbar blist),(P, snd sP_mid)::nil)
				  ::res)
			      |Some Eq =>
				root_isol1
				(z,((Root Coef cInfo mid, (P,snd sP_mid)::nil)::res')) mid d b'' n'
			      |_ =>
				root_isol1 (z,res')  mid d b'' n'
			    end
		      end
		  end.

    (** isolation of the roots of P over the real line above z **)

    Let root_isol
      (P:Pol)(z:path)(Pbar:Pol)(degPbar:N)(lbound ubound:Rat)(n:nat):=
      let (z, sign):=(Pol_low_sign z P Pbar n) in
	root_isol1 P Pbar
	(z,((Minf Coef cInfo lbound, (P,snd sign)::nil)::nil))
	lbound ubound (Pol_bern_coefs Pbar lbound ubound degPbar) n.

    (** isolation of the roots of P over ]c d[ above z
      WARNING, do not add Minf, and so returns the  empty list if P has a cst sign over ]cd[**)

    Let root_isol_int(P:Pol)(z:path)(Pbar:Pol)(degPbar:N)
      (c d:Rat)(n:nat) :=
      root_isol1  P Pbar
      (z,nil) c d (Pol_bern_coefs Pbar c d degPbar) n.

    (** Sign of Q at a root of P above z which is not a root of Q
	 None means n was not large enough
        Returns a cell_point to remember the possible refinements of z which
	may be computed **)

    Let sign_at_non_com(z:path)(Q Qbar:Pol):=
      fix sign_at_non_com(a b:Rat)(P Pbar:Pol)
	(bern bernQ:list cInfo) (n:nat){struct n}: (cell_point_up*(Pol* Sign)):=
	let (z,Vb) := csign_at_refine z bernQ n in
	let test := op_sign_changes (map (fun x => snd x) Vb) in
	  match test with
	    |None => ((z, Alg_root (Five a b P Pbar bern)),(Q, None))
       	    |Some O =>
	      let (z, sQ_a):=Pol_eval_sign_at_isol Q Qbar z a n in
		((z,Alg_root (Five a b P Pbar bern)), (Q,snd sQ_a))
	    | _ =>
	      let mid := rdiv (radd a b)  (2 # 1) in
	      let (z, sPbar_mid) := Pol_eval_sign_at_isol Pbar Pbar z mid n in
		match snd sPbar_mid with
		  |None =>((z,Alg_root (Five a b P Pbar bern)), (Q, None))
		  |Some Eq =>
		    let (z, sQ_mid):= Pol_eval_sign_at_isol Q Qbar z mid n in
		      ((z, Alg_root (Five a b P Pbar bern)),(Q,snd sQ_mid))
		  |_ =>
		    match n with
		      |O => ((z,Alg_root (Five a b P Pbar bern)), (Q, None))
		      |S m =>
			let (z,sP_bar_mid):=Pol_eval_sign_at_isol P Pbar z mid n in
			let (z,sPbar_a):=Pol_eval_sign_at_isol P Pbar z a n in
			match (sign_mult (snd sPbar_mid) (snd sPbar_a)) with
			  |None => ((z,Alg_root (Five a b P Pbar bern)), (Q, None))
			  | Some Lt  =>
			    let (bern',_) := Pol_bern_split bern a b mid  in
			    let (bernQ',_) := Pol_bern_split bernQ a b mid  in
			      sign_at_non_com a mid P Pbar bern' bernQ' m
			  |_ =>
			    let (_,bern'') := Pol_bern_split bern a b mid  in
			    let (_,bernQ'') := Pol_bern_split bernQ a b mid  in
			      sign_at_non_com mid b P Pbar bern'' bernQ'' m
			end
		    end
		end
	  end.

      (** refines [ab] which contains a unique root of P and G=gcd P Q
	to a intervalle which isolates for Q **)

    Let sign_at_com:=
      fix sign_at_com (z:path)(a b:Rat)(P Pbar G Gbar:Pol)
	(bernG bernQ:list cInfo)(n:nat){struct n}:
	cell_point_up*Sign:=
	let (z,Vb) := csign_at_refine z bernQ n in
	let test := op_sign_changes  (map (fun x => snd x) Vb) in
	  match test with
	    |None => ((z,Alg_root (Five a b G Gbar bernG)), None)
	    |Some O => ((z,Alg_root (Five a b G Gbar bernG)), None) (*never!*)
	    |Some 1 => ((z,Alg_root (Five a b G Gbar bernG)), (Some Eq))
	    | _ =>
	      let mid := rdiv (radd a b)  (2 # 1) in
	      let (z, sPbar_mid) := Pol_eval_sign_at_isol Pbar Pbar z mid n in
		match (snd sPbar_mid) with
                  |None => ((z, Alg_root (Five a b G Gbar bernG)), None)
		  |Some Eq => ((z,Root Coef cInfo mid), (Some Eq))
		  | _ =>
		    match n with
			  |O => ((z,Alg_root (Five a b G Gbar bernG)), None)
		      |S n' =>
			let (z, sPbar_a):= Pol_eval_sign_at_isol Pbar Pbar z a n in
			match (sign_mult (snd sPbar_mid) (snd sPbar_a)) with
                          |None =>  ((z, Alg_root (Five a b G Gbar bernG)), None)
			  |Some Lt =>
			    let (bernG',_):=Pol_bern_split bernG a b mid  in
			    let (bernQ',_):= Pol_bern_split bernQ a b mid in
			      sign_at_com z a mid P Pbar G Gbar bernG' bernQ' n'
			  |_ =>
			    let (_,bernG''):=Pol_bern_split bernG a b mid in
			    let (_,bernQ''):=Pol_bern_split bernQ a b mid  in
			      sign_at_com z mid b P Pbar G Gbar bernG'' bernQ'' n'
			end
		    end
		end
	  end.

   (** refines an AlgRoot a b P Pbar ... of P to determine the sign of Q
       ie up to the point where G=gcd P Q has either a unique root or no root **)

    Let pair_refine (z:path)(Q Qbar:Pol)(dQbar:N):=
      fix pair_refine(a b:Rat)(P Pbar G:Pol)
	(bern bernG:list cInfo)(n:nat){struct n}:
	cell_point_up*(Pol*Sign):=
	let (z,Vb) := csign_at_refine z bernG n in
	let test := op_sign_changes (map (fun x => snd x) Vb) in
	  match test with
            |None => ((z,Alg_root (Five a b P Pbar bern)),(Q, None))
	    |Some O =>
	      let bernQ := Pol_bern_coefs Qbar a b dQbar in
		sign_at_non_com z Q Qbar a b P Pbar bern bernQ n
	    |Some 1 =>
	      let bernQ := Pol_bern_coefs Qbar a b dQbar in
	      let Gbar := Pol_square_free G in
	      let res :=  sign_at_com z a b P Pbar G Gbar bernG bernQ n in
		(fst res, (Q, snd res))
	    |_ =>
	      let mid := rdiv (radd a b) (2 # 1) in
	      let (z, sPbar_mid) := Pol_eval_sign_at_isol Pbar Pbar z mid n in
		match (snd sPbar_mid) with
		  |None => ((z,Alg_root (Five a b P Pbar bern)), (Q, None))
		  |Some Eq =>
		    let (z,sQbar_mid):=Pol_eval_sign_at_isol Q Qbar z mid n in
		      ((z,Root Coef cInfo mid), (Q, snd sQbar_mid))
		  |_ =>
		    match n with
		      |O => ((z,Alg_root (Five a b P Pbar bern)),(Q, None))
		      |S m =>
			let (z,sPbar_a) := Pol_eval_sign_at_isol Pbar Pbar z a n in
			match (sign_mult (snd sPbar_a) (snd sPbar_mid)) with
			  |None =>  ((z, Alg_root (Five a b P Pbar bern)),(Q, None))
			  |Some Lt =>
              		    let (bern',_):=Pol_bern_split bern a b mid in
              		    let (bernG',_):=Pol_bern_split bernG a b mid in
              			pair_refine a mid P Pbar G bern' bernG' m
             		  |_ =>
			    let (_,bern''):=Pol_bern_split bern a b mid in
			    let (_,bernG''):=Pol_bern_split bernG a b mid in
			      pair_refine
			      mid b P Pbar G bern'' bernG'' m
			end
		    end
		end
	  end.

    (** Sign of Q at a cell_point_up, previous failures are propagated **)
    Let sign_at_root(Q Qbar:Pol)(dQbar:N)(low:Sign)(t:cell_point_up)(n:nat):
      cell_point_up*Sign:=
      let (z,r):=t in
      match r with
	|Minf  _ => (t, low)
	|Root r =>
	  let (res_z, res_sign) := Pol_eval_sign_at_isol Q Qbar z r n in
	  ((res_z, Root Coef cInfo r), snd res_sign)
	|Between b =>
	  let (res_z, res_sign) := Pol_eval_sign_at_isol Q Qbar z b n in
	  ((res_z,Between Coef cInfo b), snd res_sign)
	|Alg_root (Five a b P Pbar bern) =>
	  let Pbar := Pol_square_free P in
	  let G := Pol_gcd Q P in
	  let dG := Pol_deg G in
	  let bernG :=Pol_bern_coefs G a b dG in
	  let (res_z,res_s) :=  (pair_refine z Q Qbar dQbar a b P Pbar G bern bernG  n) in
	    (res_z, (snd res_s))

      end.

   (* t is the current column : a root and the signs already computed,
    sign_list_at_root adds the sign of Q on top of these signs, and has
    possibly refined the root encoding for this purpose **)

    Let  sign_list_at_root(Q Qbar:Pol)(dQbar:N)(low:Sign)(t:cell_point_up*(list (Pol*Sign)))(n:nat):
      cell_point_up*(list (Pol * Sign)) :=
      let (root, sign_list) :=  t in
	match sign_list with
	  |nil =>
	    let (root_res, sign_res):= sign_at_root Q Qbar dQbar low root n in
	      (root_res, (Q,sign_res)::nil)
	      |(_,None) :: _ => (root, (Q,None) :: sign_list)
	  |_ :: _ =>
	    let (root_res, sign_res):= sign_at_root Q Qbar dQbar  low root n in
	      (root_res, (Q,sign_res)::sign_list)
	end.

    (** finds the sign colon at b, b is between two roots and the sign column
    correspond to the root just smaller than b is lsign.
     evaluates only if necessary  **)

    (* c'est tres maladroit de recalculer Pbar mais comment faire?*)
    Let fill_sign_between(n:nat)(b:Rat) :=
      fix fill_sign_between(z:path)(lsign:list (Pol*Sign))
	{struct lsign}:list(Pol* Sign) :=
	match lsign with
	  |nil => nil
	  |shd::stl =>
	    match shd with
	      | (_ , None) => shd ::(fill_sign_between z stl)
	      | (P,Some s) =>
		match s with
		  |Eq =>
		    let (z, sP_b) := Pol_eval_sign_at_isol P (Pol_square_free P) z b n in
		    (P,(snd sP_b))::(fill_sign_between z stl)
		  |_ => shd :: (fill_sign_between z stl)
		end
	    end
	end.

     (** Sign table for the family P::lP,  over ]low,up[
       P(low) has sign lowsign, P(up) has sign upsign
       l contains the relevant sign table for lP .
      also computes a refinement of z **)

    Let add_roots(P:Pol)(freeP:Pol)(dfreeP:N)
      (lP:list Info)(n:nat) :=
      fix add_roots(z:path)(l:list (Rpoint*(list (Pol*Sign))))
	(low up:Rat)(lowsign upsign:Sign){struct l}:
	path * (list (Rpoint*(list (Pol*Sign)))) :=
	match l with	  |nil => (z,l)
	  |hd :: tl =>
	    let (rpt, prev_slist):=hd in
	      match rpt with
		|Between _ =>
		  let (z,resP) := root_isol_int P z freeP dfreeP  low up n in
		  let (z,slow):= Pol_low_sign z P freeP n in
		    (z,(add_to_cst_list resP prev_slist)@
		      ((Between Coef cInfo low, (P,snd slow)::prev_slist)::nil))
		|Minf _ =>
		  let (z,resP) := root_isol_int P z freeP dfreeP  low up n in
		  let (z,slow):= Pol_low_sign z P freeP n in
		    (z,(add_to_cst_list resP prev_slist)@
		      ((Minf Coef cInfo low, (P,snd slow)::prev_slist)::nil))
		|Root r =>
		  if orb (rlt up r) (rzero_test (rsub r up))
		    then
		      let (z, sign_table_low_r):=add_roots z tl low r lowsign upsign in
		      (z,(rpt,  (P,upsign)::prev_slist)::sign_table_low_r)
		    else
		      let (z, sP_r) := Pol_eval_sign_at_isol P freeP z r n in
		      let (z,resP) := root_isol_int P z freeP dfreeP r up n in
		       let prev_next_sign := fill_sign_between n (rdiv (radd r up) (2 # 1))
			 z prev_slist  in
		       let res_r_up := (add_to_cst_list resP prev_next_sign) in
		       let (z,table_low_r):= (add_roots z tl low r  lowsign (snd sP_r)) in
			 (z,res_r_up @
			 ((Root Coef cInfo r, (P,snd sP_r):: prev_slist)::table_low_r))
		|Alg_root (Five a b Q Qbar bern) =>
		  let (zup,refine) := sign_list_at_root P freeP dfreeP lowsign ((z,rpt),prev_slist) n in
		  let (z,rpt):=zup in
		    match rpt  with
		      |Between _ => (z,l) (*should never happen *)
		      |Minf _  => (z,(Minf Coef cInfo low, (P,None) :: prev_slist):: tl) (*should never happen*)
		      |Root r =>
			if orb (rlt up r) (rzero_test (rsub r up))
			  then
			    let (z,sign_tabl_low_r) := add_roots z tl low r lowsign upsign in
			    (z,(rpt,refine)::sign_tabl_low_r)
			  else
			    let signP_r :=
			      match refine with
				|nil => (P,None)
				|s :: tl => s
			      end in
			      let prev_next_sign :=
				fill_sign_between n (rdiv (radd r up) (2#1)) z prev_slist in
			      let (z,resP) := (root_isol_int P z freeP dfreeP r up n) in
			      let res_r_up := (add_to_cst_list resP prev_next_sign) in
			      let (z,sign_table_low_r):= (add_roots z tl low r  lowsign  (snd signP_r)) in
				(z, res_r_up @((rpt,refine):: sign_table_low_r))
		      |Alg_root (Five a' b' Q' Qbar' bern') =>
			if orb (rlt up a') (rzero_test (rsub a' up))
			  then
			    let (z,sign_table_low_a'):= add_roots z tl  low a' lowsign upsign in
			      (z,(rpt,refine)::sign_table_low_a')
			  else
			    let (z, sPa') := Pol_eval_sign_at_isol P freeP z a' n in
			    let (z, sPb' ):= Pol_eval_sign_at_isol P freeP z b' n in
			    let prev_next_sign :=
			      fill_sign_between n (rdiv (radd b' up) (2#1)) z prev_slist  in
			    let (z,resP) := (root_isol_int P z freeP dfreeP b' up n) in
			    let res_b'_up := (add_to_cst_list resP prev_next_sign) in
			      match  (snd sPb'),(snd sPa') with
				|None, _ => (z,l)
				|_,None => (z,l)
				|Some Eq, Some Eq =>
				  let prev_a'_sign := map (Pol_info_eval_sign n a' z) lP in
				  let (z,sign_table_low_a'):= add_roots z tl low a' lowsign (snd sPa') in
				    (z,res_b'_up @
				    ((Root Coef cInfo b', (P,(Some Eq))::prev_next_sign)::
				      (rpt,refine) ::
				      (Root Coef cInfo a', (P,(Some Eq))::prev_a'_sign):: sign_table_low_a'))
				|Some Eq, Some _  =>
				  let (z,sign_table_low_a'):=add_roots z tl low a' lowsign (snd sPa' ) in
				  (z,res_b'_up @
				  ((Root Coef cInfo b', (P,(Some Eq))::prev_next_sign)::
				    (rpt,refine)::sign_table_low_a'))
				|Some _, Some Eq =>
				  let prev_a'_sign := map (Pol_info_eval_sign n a' z) lP in
				  let (z,sign_table_low_a'):=add_roots z tl low a' lowsign (snd sPa') in
				    (z,res_b'_up@
				    ((rpt,refine) ::
				      (Root Coef cInfo  a', (P,(Some Eq))::prev_a'_sign)::sign_table_low_a'))
				|Some _, Some _ =>
				  let (z,sign_table_low_a'):=add_roots z tl low a' lowsign (snd sPa') in
				  (z, res_b'_up @ ((rpt,refine)::sign_table_low_a'))
			      end
		    end
	      end
	end.

     (*head is the biggest root, computes the isolating list and a refinemet of z *)
    Let family_root(glow gup:Rat) :=
      fix family_roots(z:path)(Pol_list : list Info)(n:nat)
	{struct Pol_list}:(path * (list (Rpoint*(list (Pol*Sign))))):=
	match Pol_list with
	  |nil => (z,nil)
	  |i :: tl =>
	    let (P,Pbar,dPbar, slow, sinfo):= i in
	      match sinfo with
		|Some s =>
		  match tl with
		    |nil => (z,(Minf Coef cInfo r0, (P, sinfo)::nil)::nil)
		    |_ =>
		      let (z,prev) := family_roots z tl n in
			(z, add_cst_sign prev P sinfo)
		  end
		|None =>
		  match tl with
		    |nil => root_isol P z Pbar dPbar glow gup n
		    |_ =>
		      let (z,sup) := (Pol_eval_sign_at_isol P Pbar z gup n) in
		      let (z,prev) := family_roots z tl n in
			add_roots  P Pbar dPbar tl n z prev glow gup slow (snd sup)
		  end
	      end
	end.

   (** sign table above z for the family up to "up",included.
	up is not a root
	 head corresponds to the smallest root
	 gup and glow are the points considered as +infty and -infty for
	 the whole family above z.
     Takes the result of family roots and adds one point per non singleton cell**)

    Let sign_table1(z:path)(glow gup:Rat)(n:nat):=
      fix sign_table1(isol_list : list (Rpoint*(list (Pol*Sign))))
	(up:Rat)
	(res:list (Rpoint*(list (Pol*Sign)))){struct isol_list}:
	list (Rpoint*(list (Pol*Sign))):=
	match isol_list with
	  |nil => res
	  |hd::tl =>
	    let (rpt,hdSign):=hd in
	      match rpt with
		|Between _ => res (*should never happen *)
		|Minf _ =>
		  match (tail res) with
		    |nil => res
		    |_ => (Between Coef cInfo glow, hdSign)::res
		  end
		|Root r =>
		    match (tail res) with
		      |nil =>
			let bet := rdiv (radd r up) (2 # 1) in
			 sign_table1 tl r ((rpt, hdSign) ::res)
		      |_ =>
			let bet := rdiv (radd r up) (2 # 1) in
			  sign_table1 tl r
			  ((rpt, hdSign) ::
			    ((Between Coef cInfo bet,fill_sign_between n bet z hdSign)::res))
		    end
		  |Alg_root (Five a b _ _ _) =>
		    match (tail res) with
		      |nil =>
			let bet := rdiv (radd b up) (2#1) in
			  sign_table1 tl a
			  ((rpt, hdSign) ::res)
		      |_ =>
			let bet := rdiv (radd b up) (2#1) in
			  sign_table1 tl a
			  ((rpt, hdSign)
			    ::((Between Coef cInfo bet,fill_sign_between n bet z hdSign) ::res))
		    end
	      end
	end.

  (** sign_table for the list of Pols on the real line above z *)
  Let sign_table(z:path)(Pol_list:list Info)(n:nat):=
  let up := rmax_list (map (Pol_info_up_bound z) Pol_list) in
  let low := rmin_list (map (Pol_info_low_bound z) Pol_list) in
  let up_signs := map (Pol_info_eval_sign n up z) Pol_list in
  let (z,roots) := family_root low up z Pol_list n in
    (z,(sign_table1 z low up n roots up ((Between Coef cInfo up, up_signs)::nil))).

  (************************************************************)
  (**             Subresultant Elimination                   **)
  (************************************************************)

  (** Each element of llP is the list of truncations of a Pol in the
    initial list.
   For each R in each tr(P), computes the subres coefs sr_j(R, dR/dX)
   where X is the current variable *)

  Let subres_der_flat:=
  fix subres_der_flat(llP:list (list Pol))(res:list Coef)
    {struct llP}: list Coef:=
    match llP with
      |nil => nil
      |lP :: llP' =>
	let subres_der_ac :=
	  fix subres_der_ac(l:list Pol)(res:list Coef){struct l}:
	    list Coef :=
	    match l with
	      | nil => res
	      | P :: l' =>
		subres_der_ac l' ((Pol_subres_coef_list P (Pol_deriv P)) @ res)
	    end in
	    subres_der_ac lP (subres_der_flat llP' res)
    end.

  (** Each element of llP is the list of truncations of a Pol in the
    initial list.
    Computes all the sr_j(R,S) where R
    is in tr(P) and S in tr(Q) *)

  Let subres_flat :=
  fix subres_flat(llP:list (list Pol))(res: list Coef)
    {struct llP}:list Coef :=
    match llP with
      |nil => res
      |lP :: llP' =>
	match llP' with
	  |nil => res
	  |lQ :: _ =>
	    let subres_peer:=
	      fix subres_peer (u v:list Pol)(res:list Coef)
		{struct u}:
		list Coef:=
		match u with
		  |nil => res
		  |R :: u' =>
		    let dr := Pol_deg R in
		      let subres := (fun x =>
			let dx := Pol_deg x in
			  match (Ncompare dr dx) with
			    |Lt => Pol_subres_coef_list x R
			    |_ => Pol_subres_coef_list R x
			  end) in
		      subres_peer u' v ((flat_map subres v) @ res)
		end in
		subres_flat llP'
		((flat_map (fun x => subres_peer lP x nil) llP')@res)
	end
    end.

  (** Projection of the family l of polys by subresultant
  elimination.
  Multiple occurences are cleaned **)

  Let elim(l:list Pol) :=
    let l_tr_coef := map Pol_trunc l in
    let l_tr := map (fun u => fst u) l_tr_coef in
    let l_coef := flat_map (fun u => snd u) l_tr_coef in
    let subres_der := subres_der_flat l_tr l_coef in
      clean_list ceq (subres_flat l_tr subres_der).

  (************************************************************)
  (**        Non-degenerated forms above a path        **)
  (************************************************************)

  (** Leading coef(s) of a Pol can vanish above a given cell_point.

  The non degenerated form of a Pol above a given cell_point is its
   relevant truncation, for which vanishing coefs ahave been removed, and
  the sign of the leding coef has been proved to be <>Eq

    The computation of the non-deg forms of the Pols in the list may
  demand refinement of the cell_point to get sharp enough bounds
  on the Pols's values. Hence the following functions also
  returns the cell_point *)

  (** Sign of a coef:
  either the one of a base cst
  or a sign to find in the column of signs already computed **)

  Let sign_find(c:Coef):=
    match (cbase_cst_sign c) with
      |Some s => fun x => Some s
      |_ =>
	fix sign_find(sign_list:list (Coef*Sign)):Sign :=
	  match sign_list with
	    |nil => None
	    |s::stl =>
	      if (czero_test  (c -- (fst s))) then (snd s) else sign_find stl
	  end
    end.

  (** If P has a leading coeficient none zero above z, computes the
      normal form of PX P i c.
      Also returns the non-deg leading coef and its sign.
      WARNING : not in "normal form above z" with respect to power index *)

  Let mkPX_above(P:Pol)(infodom:Coef*Sign)(i:positive)(c:Coef)
    (sign_col:list (Coef*Sign)):=
    match P with
      |PX _ _ _ => (PX P i c,infodom)
      |Pc p =>
	let (domP,sign_domP):= infodom in
	  match sign_domP with
	    |None=>(PX P i c,infodom) (*should never happen, else n too small*)
	    |Some Eq =>
              let c_sign :=sign_find c sign_col in
		match c_sign with
                  |Some Eq => (Pc c0,(c0, Some Eq))
                  |_ => (Pc c,(c,c_sign))
		end
	    |Some _ => (PX P i c,infodom)
	  end
    end.

  (** Non degenerated form of P above a cell for which the sign column
  for the elim family is sign_col.
  Also returns the non-deg leading coef and its sign *)

  Let Pol_non_deg (sign_col:list (Coef*Sign)) :=
  fix Pol_non_deg (P:Pol):Pol*(Coef*Sign):=
    match P with
      |Pc c =>
        let c_sign := sign_find  c sign_col in
          match c_sign with
            |None => (Pc c, (c,None))
            |Some Eq => (Pc c0, (c0, Some Eq))
            |Some _ => (Pc c, (c, c_sign))
          end
      |PX P i p =>
        let (P, infodom):=Pol_non_deg P in
          mkPX_above P infodom i p sign_col
    end.

(*BUG????????*)

  (** Info for the non degenerated form of P above cell_point,
   computes couple (refinement for z, Info) *)
  Let Pol_non_deg_info(z:path)
    (sign_col:list (Coef*Sign))(P:Pol)(n:nat):=
    let (P, infodom):=Pol_non_deg sign_col P in
    let (_, domsign) := infodom in
      match P, domsign with
	|_, None => (z, (Five P P N0 None None))
	|Pc _, _ =>
	  let Pbar := Pol_square_free P in
	  let dPbar := Pol_deg P in
	  (z,(Five P Pbar dPbar domsign domsign))
	|_,Some Eq=>
	  (z,(Five P0 P0 N0 (Some Eq) (Some Eq)))
	|_,_ =>
            let Pbar := Pol_square_free P in
            let dPbar := Pol_deg Pbar in
	    (*let (z, Pbar_sign) := Pol_low_sign z P Pbar n in*)
	      let u:=Pol_low_sign z P Pbar n in
	      let Pbar_sign := snd u in
	      let z := fst u in
	      (z, (Five P Pbar (Pol_deg Pbar) (snd Pbar_sign) None))
	end.

  (** the Coef c is known to be non zero at z,
   refines z to get sharp bound on the values of c:
  ie to isolates the values form 0 *)
  Let cell_refine_for(c:Coef):=
    fix cell_refine_for(z:path)(n:nat){struct n}:option path:=
      let (a,b) := cvalue_bound z c in
	match rsign (rprod a b) with
	  |Gt => Some z
	  |_ =>
            match n with

              |O => None
              |S n => let z' := ccell_refine z n in
		match z' with
		  |None => None
		  |Some z' => cell_refine_for z' n
		end
            end
	end.

(*
  Let non_deg1:=
    fix non_deg(l:list Pol)(cad_col:cell_point*(list (Coef*Sign)))(n:nat)
      (res:(list Info)*(cell_point*(list(Coef*Sign)))){struct l}:
      (list Info)*(cell_point*(list(Coef*Sign))):=
      match l with
	|nil => res
	|P::Pol_tl=>
          let (z, u) := Pol_non_deg_info cad_col P n in
          let (info_pol, info_dom):=u in
          let (dom, dom_sign) := info_dom in
          let (z,info_pol) :=
            (match dom_sign with
               |None => (z, info_pol)
               |Some Eq => (z, info_pol)
               |Some _ =>
                 let P:= Pol_of_Info info_pol in
                 let zres:= cell_refine_for dom z n in
                   match zres with
                     |None => (z, Five P P N0 None None)
                     |Some z =>(z, info_pol)
                   end
             end) in
            let new_cad_col :=(z, sign_col) in
              non_deg Pol_tl new_cad_col n (info_pol::(fst res), new_cad_col)
      end.
*)

  Let non_deg1(cad_col:list (Coef*Sign)):=
    fix non_deg(l:list Pol)(z:path)(n:nat)
      (res:(list Info)){struct l}:path*(list Info):=
      match l with
	|nil => (z,res)
	|P::Pol_tl=>
          let (info_pol,info_dom) := Pol_non_deg cad_col P in
	  let (z,i):=Pol_non_deg_info z cad_col P n in
          let (dom, dom_sign) := info_dom in
	  let (z,i):=
	    (match dom_sign with
	      |None => (z,i)
	      |Some Eq => (z,i)
	      |_ =>
		let P:=Pol_of_Info i in
		let zop := cell_refine_for dom z n in
		  match zop with
		    |None => (z, Five P P N0 None None)
		    |Some z => (z, i)
		  end
	    end) in
	    non_deg Pol_tl z n (i::res)
      end.

  (** Computes the list of Info for the non degenerated forms of the pols of
  the list *)
  Let non_deg(z:path)(cad_col:(list (Coef*Sign)))
    (l:list Pol)(n:nat):=
    non_deg1 cad_col l  z n nil.

  (************************************************************)
  (********       Lifting phase of the real CAD        ********)
  (************************************************************)

  Let one_table_up(l:list Pol)(n:nat)
    (zcol:path*(list (Coef * Sign))):=
    let (z,col):=zcol in
    let (z,l'):=non_deg z col l n in
    sign_table z l' n.

(*

  Let one_table_up_push(l:list Pol)(n:nat)
    (zcol:path*(list (Coef * Sign))):=
    let (z,l):=one_table_up l n zcol in
    let aux := fun rlsign:Rpoint *(list (Pol*Sign)) =>
      let (r,lsign):=rlsign in
	((z, r),lsign) in
	map aux l.
 *)

    Let one_table_up_map(l:list Pol)(n:nat)
    (p:path)(col : list (Coef * Sign)):
    path * (list (Rpoint * (list (Pol * Sign)))) :=
    one_table_up l n (p,col).

  Let Pol_cad(l:list Pol)(n:nat) :=
    let cad := ccad (elim l) n in
      @next_mkCad_map
      Rat C bern cell_point_low cmkCad cmkCad_map
      (list (Coef*Sign)) (list (Rpoint * (list (Pol * Sign))))
      (one_table_up_map l n) cad .

(*

  Let one_table_up_push(l:list Pol)(n:nat)
    (zcol:cell_point*(list (Coef * Sign))):=
    let (z,l):=one_table_up l n zcol in
    let aux := fun rlsign:Rpoint *(list (Pol*Sign)) =>
      let (r,lsign):=rlsign in
	((z, r),lsign) in
	map aux l.

  Let one_table_up_map(l:list Pol)(n:nat)
    (zcol_list:list (cell_point*(list (Coef*Sign)))):=
    map (one_table_up_push l n) zcol_list.

Let Pol_cad(l:list Pol)(n:nat) :=
    let cad := ccad (elim l) n in
      @cCad_map
      (list (cell_point*(list (Coef*Sign)))) (list (list (cell_point_up *(list (Pol*Sign)))))
      (one_table_up_map l n) cad .
*)
  (************************************************************)
  (*****         Misc. for upper dimension               ******)
  (************************************************************)

(*  Let mk_Cad_type(x:Set) := cmk_Cad_type (list x).

  Let Cad_map(A B:Set)(c:mk_Cad_type A)(f:A ->B):=
    @cCad_map (list A) (list B) c (fun x:list A => map f x).

*)
  (** Builds an Info from a Pol P, low sign is not computed **)
    Let Info_of_Pol(info_sign:Sign)(P:Pol):=
      let Pbar := Pol_square_free P in
      let dPbar := Pol_deg Pbar in
	match info_sign with
	  |Some _ => Five P Pbar dPbar info_sign info_sign
	  |_ => Five P Pbar dPbar None None
	end.

(*
    Let Pol_sign_at_for_upper(c:Info)(z:cell_point_up)(n:nat):=
      let (P,Pbar, dPbar, slow):=c in
	snd (sign_at_root P Pbar dPbar z n)

*)

    (* in the version of Pol_sign_at for upper dim,
   we evaluate to determine
  the sign a -inty because this -infty may not be coherent with the pol
  (a bern coef for example) we ar computing the sign of*)
    Let Pol_sign_at_for_upper(i:Info)(t:cell_point_up)(n:nat):=
     let (Q, Qbar, dQbar, _,_):= i in
     let (z,rpt):=t in
      match rpt with
	|Minf m =>
	  let (res_z, res_sign) := Pol_eval_sign_at_isol Q Qbar z m n in
	     ((res_z, rpt),(Q,snd res_sign))

	|Root r =>
	  let (res_z, res_sign) := Pol_eval_sign_at_isol Q Qbar z r n in
	    ((res_z, rpt),(Q,snd res_sign))
	|Between b =>
	  let (res_z, res_sign) := Pol_eval_sign_at_isol Q Qbar z b n in
	   ((res_z,rpt), (Q,snd res_sign))
	|Alg_root (Five a b P Pbar bern) =>
	  let Pbar := Pol_square_free P in
	  let G := Pol_gcd Q P in
	  let dG := Pol_deg G in
	  let bernG :=Pol_bern_coefs G a b dG in
	  let (res_z, res_sign) :=
	    pair_refine z Q Qbar dQbar a b P Pbar G bern bernG  n in
	    (res_z,(Q,snd res_sign))

      end.

  (************************************************************)
  (******   Building of the parametric record         *********)
  (************************************************************)

  Let mkCad := next_mkCad Rat C bern cmkCad.
(*    Let mkCad := @mkCad_up cmkCad.**)

  Definition CAD_make := @mk_cad Rat Coef cInfo path mkCad
    P0 P1
    Pol_add
    Pol_mult_base_cst
    Pol_mul
    Pol_sub
    Pol_opp
    Pol_of_Rat
    Pol_is_base_cst
    Pol_zero_test
    Pol_base_cst_sign
    Pol_pow
    Pol_div_base_cst
    Pol_div
    Pol_gcd_gcd_free
    Pol_square_free
    cell_refine
    Pol_low_bound
    Pol_value_bound
    Info_of_Pol
    Pol_low_sign_for_upper
    Pol_sign_at_for_upper
    Pol_cad.

End UP_DIM.

End MK_UP_DIM.