(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import List.
Require Import ZArith.
Require Import EquivDec.
Require Import RelationClasses.
Require Import Equivalence.
Require Import String.

Require Import Qcert.Utils.Utils.
Require Import Qcert.Data.DataSystem.

Require Import QcertData.
Require Import QcertToSpark.

Import ListNotations.
Local Open Scope list_scope.
Local Open Scope string_scope.
Local Open Scope nstring_scope.

(** Foreign typing, used to build the basic_model *)

Inductive enhanced_type : Set :=
  | enhancedTop : enhanced_type
  | enhancedBottom : enhanced_type
  | enhancedString : enhanced_type
  | enhancedDateTimeFormat : enhanced_type
  | enhancedDateTime : enhanced_type
  | enhancedDateTimeDuration : enhanced_type
  | enhancedDateTimePeriod : enhanced_type
.

Definition enhanced_type_to_string (et:enhanced_type) : string :=
  match et with
  | enhancedTop => "ETop"
  | enhancedBottom => "EBottom"
  | enhancedString => "EString"
  | enhancedDateTimeFormat => "EDateTimeFormat"
  | enhancedDateTime => "EDateTime"
  | enhancedDateTimeDuration => "EDateTimeDuration"
  | enhancedDateTimePeriod => "EDateTimePeriod"
  end.

Definition string_to_enhanced_type (s:string) : option enhanced_type :=
  match s with
  | "ETop"%string => Some enhancedTop
  | "EBottom"%string => Some enhancedBottom
  | "EString"%string => Some enhancedString
  | "EDateTimeFormat"%string => Some enhancedDateTimeFormat
  | "EDateTime"%string => Some enhancedDateTime
  | "EDateTimeDuration"%string => Some enhancedDateTimeDuration
  | "EDateTimePeriod"%string => Some enhancedDateTimePeriod
  | _ => None
  end.

Definition enhanced_type_join (t1 t2:enhanced_type)
  := match t1, t2 with
     | enhancedBottom, _ => t2
     | _, enhancedBottom => t1
     | enhancedString, enhancedString => enhancedString
     | enhancedDateTimeFormat, enhancedDateTimeFormat => enhancedDateTimeFormat
     | enhancedDateTime, enhancedDateTime => enhancedDateTime
     | enhancedDateTimeDuration, enhancedDateTimeDuration => enhancedDateTimeDuration
     | enhancedDateTimePeriod, enhancedDateTimePeriod => enhancedDateTimePeriod
     | _, _ => enhancedTop
     end.

Definition enhanced_type_meet (t1 t2:enhanced_type)
  := match t1, t2 with
     | enhancedTop, _ => t2
     | _, enhancedTop => t1
     | enhancedString, enhancedString => enhancedString
     | enhancedDateTimeFormat, enhancedDateTimeFormat => enhancedDateTimeFormat
     | enhancedDateTime, enhancedDateTime => enhancedDateTime
     | enhancedDateTimeDuration, enhancedDateTimeDuration => enhancedDateTimeDuration
     | enhancedDateTimePeriod, enhancedDateTimePeriod => enhancedDateTimePeriod
     | _, _ => enhancedBottom
     end.

Inductive enhanced_subtype : enhanced_type -> enhanced_type -> Prop :=
| enhanced_subtype_top t : enhanced_subtype t enhancedTop
| enhanced_subtype_bottom t : enhanced_subtype enhancedBottom t
| enhanced_subtype_refl t : enhanced_subtype t t.

Instance enhanced_subtype_pre : PreOrder enhanced_subtype.
Proof.
  constructor; red; intros.
  - destruct x; constructor.
  - inversion H; inversion H0; subst; try constructor; congruence.
Qed.

Instance enhanced_subtype_post : PartialOrder eq enhanced_subtype.
Proof.
  intros x y; split.
  - intros; subst.
    repeat red.
    split; constructor.
  - destruct 1.
    inversion H; inversion H0; congruence.
Qed.

#[refine] Instance enhanced_type_lattice : Lattice enhanced_type eq
  := {
      join := enhanced_type_join
      ; meet := enhanced_type_meet
    }.
Proof.
  - red; intros t1 t2.
    destruct t1; destruct t2; simpl;
      reflexivity.
  - red; intros t1 t2 t3.
    destruct t1; destruct t2; destruct t3; simpl;
      reflexivity.
  - red; intros t1.
    simpl.
    destruct t1; simpl; try reflexivity.
  - red; intros t1 t2.
    destruct t1; destruct t2; simpl;
      reflexivity.
  - red; intros t1 t2 t3.
    destruct t1; destruct t2; destruct t3; simpl;
      reflexivity.
  - red; intros t1.
    destruct t1; simpl;
      reflexivity.
  - red; intros t1 t2.
    destruct t1; destruct t2; simpl;
      reflexivity.
  - red; intros t1 t2.
    destruct t1; destruct t2; simpl;
      reflexivity.
Defined.

Instance enhanced_type_olattice : OLattice eq enhanced_subtype.
Proof.
  constructor.
  split.
  - destruct a; destruct b; inversion 1; simpl; reflexivity.
  - destruct a; destruct b; inversion 1; simpl;
      constructor.
Qed.

Program Instance enhanced_foreign_type : foreign_type
  := mk_foreign_type enhanced_type _ _ _ _ _ _ _.
Next Obligation.
  red.
  unfold equiv, complement.
  intros.
  change ({x = y} + {x <> y}).
  decide equality.
Defined.
Next Obligation.
  destruct a; destruct b; try solve [left; constructor | right; inversion 1].
Defined.


(* (Semi-)Decide conversion in ITT *)

From Coq Require Import Bool String List BinPos Compare_dec Lia.
Require Import Equations.Prop.DepElim.
From Equations Require Import Equations.
From MetaCoq Require Import Ast utils Typing.
From Translation
Require Import util Sorts SAst SLiftSubst Equality SCommon Conversion ITyping
               ITypingInversions ITypingLemmata ContextConversion Uniqueness.

Section Decide.

  Context `{Sort_notion : Sorts.notion}.

  Definition get_or {A B} (x : option A) (get : A -> B) (or : option B) : option B :=
    match x with
    | Some a => Some (get a)
    | None => or
    end.

  Notation "x '>>' a '==>' e '--' b" :=
    (get_or x (fun a => e) b) (at level 100, e at next level, right associativity).

  (* Returns [Some t'] such that [Σ |-i t ▷ t'], or [None] if it cannot be
     reduced.
     Not really applying any strategy except going deeply in the terms.
   *)
  Fixpoint reduce1 (t : sterm) {struct t} : option sterm :=
    match t with
    | sProd n A B =>
      reduce1 A >> A' ==> sProd n A' B --
      reduce1 B >> B' ==> sProd n A B' --
      None
    | sLambda n A B t =>
      reduce1 A >> A' ==> sLambda n A' B t --
      reduce1 B >> B' ==> sLambda n A B' t --
      reduce1 t >> t' ==> sLambda n A B t' --
      None
    | sApp (sLambda n _ _ t) _ _ u =>
      Some (t{ 0 := u })
    | sApp u A B v =>
      reduce1 u >> u' ==> sApp u' A B v --
      reduce1 v >> v' ==> sApp u A B v' --
      reduce1 A >> A' ==> sApp u A' B v --
      reduce1 B >> B' ==> sApp u A B' v --
      None
    | sSum n A B =>
      reduce1 A >> A' ==> sSum n A' B --
      reduce1 B >> B' ==> sSum n A B' --
      None
    (* | sPair *)
    (* | sPi1 *)
    (* | sPi2 *)
    | sEq A u v =>
      reduce1 A >> A' ==> sEq A' u v --
      reduce1 u >> u' ==> sEq A u' v --
      reduce1 v >> v' ==> sEq A u v' --
      None
    | sRefl A u =>
      reduce1 A >> A' ==> sRefl A' u --
      reduce1 u >> u' ==> sRefl A u' --
      None
    (* | sJ *)
    | sTransport _ _ (sRefl _ _) t =>
      Some t
    | sTransport A B p t =>
      reduce1 p >> p' ==> sTransport A B p' t --
      reduce1 t >> t' ==> sTransport A B p t' --
      reduce1 A >> A' ==> sTransport A' B p t --
      reduce1 B >> B' ==> sTransport A B' p t --
      None
    | sHeq A a B b =>
      reduce1 A >> A' ==> sHeq A' a B b --
      reduce1 a >> a' ==> sHeq A a' B b --
      reduce1 B >> B' ==> sHeq A a B' b --
      reduce1 b >> b' ==> sHeq A a B b' --
      None
    | sHeqToEq p =>
      reduce1 p >> p' ==> sHeqToEq p' --
      None
    | sHeqRefl A a =>
      reduce1 A >> A' ==> sHeqRefl A' a --
      reduce1 a >> a' ==> sHeqRefl A a' --
      None
    | sHeqSym p =>
      reduce1 p >> p' ==> sHeqSym p' -- None
    | sHeqTrans p q =>
      reduce1 p >> p' ==> sHeqTrans p' q --
      reduce1 q >> q' ==> sHeqTrans p q' --
      None
    | sHeqTransport p t =>
      reduce1 p >> p' ==> sHeqTransport p' t --
      reduce1 t >> t' ==> sHeqTransport p t' --
      None
    (* | sCongProd *)
    (* | sCongLambda *)
    (* | sCongApp *)
    (* | sCongSum *)
    (* | sCongPair *)
    (* | sCongPi1 *)
    (* | sCongPi2 *)
    (* | sCongEq *)
    (* | sCongRefl *)
    | sEqToHeq p =>
      reduce1 p >> p' ==> sEqToHeq p' -- None
    | sHeqTypeEq A B p =>
      reduce1 p >> p' ==> sHeqTypeEq A B p' --
      reduce1 A >> A' ==> sHeqTypeEq A' B p --
      reduce1 B >> B' ==> sHeqTypeEq A B' p --
      None
    | sProjT1 p =>
      reduce1 p >> p' ==> sProjT1 p' -- None
    | sProjT2 p =>
      reduce1 p >> p' ==> sProjT2 p' -- None
    | sProjTe p =>
      reduce1 p >> p' ==> sProjTe p' -- None
    | _ => None
    end.

  Ltac one_case :=
    lazymatch goal with
    | |- (?d >> _ ==> _ -- _) = _ -> _ =>
      case_eq d ; [
        intros ? ? h ; inversion h ; subst ; clear h ;
        constructor ; solve [ auto ]
      | intros _ ; cbn
      ]
    end.

  Lemma reduce1_sound :
    forall {t u},
      reduce1 t = Some u ->
      t ▷ u.
  Proof.
    intros t u h. revert u h.
    induction t ; intros u h.
    all: try (cbn in h ; discriminate h).
    all: try (revert h ; cbn ; repeat one_case ; discriminate).
    - destruct t1.
      all: try (revert h ; cbn ; repeat one_case ; discriminate).
      cbn in h. inversion h. subst. clear h.
      constructor.
    - destruct t3.
      all: try (revert h ; cbn ; repeat one_case ; discriminate).
      cbn in h. inversion h. subst. clear h.
      constructor.
  Defined.

  (* When it returns [true], we have [Σ |-i u = v].
     It compares the terms first by alpha-conversion, and then reduces the
     first one as much as possible, then the second one.
   *)
  Fixpoint isconv (fuel : nat) (u v : sterm) {struct fuel} : bool :=
    match fuel with
    | 0 => false
    | S fuel =>
      eq_term u v ||
      match reduce1 u with
      | Some u' => isconv fuel u' v
      | None =>
        match reduce1 v with
        | Some v' => isconv fuel u v'
        | None => false
        end
      end
    end.

  Lemma isconv_sound :
    forall {fuel u v},
      isconv fuel u v = true ->
      u ≡ v.
  Proof.
    intros fuel u v h. revert u v h.
    induction fuel ; intros u v h ; try discriminate h.
    cbn in h. apply orb_prop in h. destruct h as [h | h].
    - constructor. unfold eq_term in h.
      destruct (nl_dec (nl u) (nl v)).
      + assumption.
      + discriminate.
    - revert h. case_eq (reduce1 u).
      + intros u' hu h. eapply conv_red_l.
        * eapply reduce1_sound. eassumption.
        * eapply IHfuel. assumption.
      + intros _. case_eq (reduce1 v).
        * intros v' hv h. eapply conv_red_r.
          -- eapply IHfuel. eassumption.
          -- eapply reduce1_sound. assumption.
        * intros _. discriminate.
  Defined.

End Decide.


(*
Copyright © 2006 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import Plot.
Require Import CRtrans.

(* `∗' is used for trival proofs that a some concrete number is less than another *)
Notation star := (@refl_equal _ Lt).
Notation "∗" := star.

Local Open Scope Q_scope.
Local Open Scope uc_scope.
Local Open Scope raster.

(* This file illustrates how to plot funcitons *)
(* PlotQ requires that we plot uniformly continuous functions.
   Therefore we cannot plot (sin : CR -> CR), me must instead
   plot the UniformlyContinuousFunction (sin_uc : Q --> CR). *)
(* Here we plot sin on [-3,3] with range [-1,1] on a 36x12 raster *)
Time Eval vm_compute in PlotQ (- (3)) 3 star (- (1)) 1 star sin_uc 36 12.

(* Here we explore the proof that plots are correct *)
Goal True.
(* Plot_correct is a proof that the plot is correct.*)
(* below we plot exp on [-3, 0] with range [0,1] *)
(* (exp_bound_uc 0) is exp on ]-inf,0] which is one domain where it is uniformly continuous *)
assert (X:=@Plot_correct (-(3)) 0 star 0 1 star
 (exp_bound_uc 0)
 45 15 refl_equal refl_equal).
(* No plot is seen.  It is hidden in the uncomputed
  PlotQ (- (3)) 0 ∗ 0 1 ∗ (exp_bound_uc 0) 45 15 *)
(* We use patern matchin to extract the parts of the statement we
   wish to normalize *)
match goal with
 [X:ball ?e ?a (@ucFun _ _ _ (_⇱?b⇲_))|-_] => set (E:=e) in X; set (B:=b) in X
end.
(* E is the error; a bound on the distance between our plot and the actual function *)
set (E' := E: Q).
vm_compute in E'.
(* The error is 90/1800 *)
(* B is the plot *)
Time vm_compute in B.
(* The plot is a 45 by 15 raster. *)
(* The plot and error can be reinserted into the statement if you wish *)
unfold E, B in X.
clear E B.
(* end this example *)
split.
Qed.


Require Import Coq.Classes.Morphisms.
Require Import Logic.Syntax.
Require Import Logic.Semantics.
Require Import Logic.BasicProofRules.
Require Import Logic.Automation.

Global Instance Proper_Comp :
  Proper (term_equiv ==> term_equiv ==> eq ==> lentails) Comp.
Proof.
  morphism_intro. breakAbstraction.
  subst. unfold eval_comp; simpl.
  intuition congruence.
Qed.
Global Instance Proper_Comp_lequiv :
  Proper (term_equiv ==> term_equiv ==> eq ==> lequiv) Comp.
Proof.
  morphism_intro.
  split; breakAbstraction;
  subst; unfold eval_comp; simpl;
  intuition congruence.
Qed.
Global Instance Proper_PlusT :
  Proper (term_equiv ==> term_equiv ==> term_equiv) PlusT.
Proof.
  morphism_intro; unfold term_equiv in *;
  simpl; intuition congruence.
Qed.
Global Instance Proper_MinusT :
  Proper (term_equiv ==> term_equiv ==> term_equiv) MinusT.
Proof.
  morphism_intro; unfold term_equiv in *;
  simpl; intuition congruence.
Qed.
Global Instance Proper_MultT :
  Proper (term_equiv ==> term_equiv ==> term_equiv) MultT.
Proof.
  morphism_intro; unfold term_equiv in *;
  simpl; intuition congruence.
Qed.
Global Instance Proper_InvT :
  Proper (term_equiv ==> term_equiv) InvT.
Proof.
  morphism_intro; unfold term_equiv in *;
  simpl; intuition congruence.
Qed.
Global Instance Proper_CosT :
  Proper (term_equiv ==> term_equiv) CosT.
Proof.
  morphism_intro; unfold term_equiv in *;
  simpl; intuition congruence.
Qed.
Global Instance Proper_SinT :
  Proper (term_equiv ==> term_equiv) SinT.
Proof.
  morphism_intro; unfold term_equiv in *;
  simpl; intuition congruence.
Qed.
Global Instance Proper_SqrtT :
  Proper (term_equiv ==> term_equiv) SqrtT.
Proof.
  morphism_intro; unfold term_equiv in *;
  simpl; intuition congruence.
Qed.
Global Instance Proper_ArctanT :
  Proper (term_equiv ==> term_equiv) ArctanT.
Proof.
  morphism_intro; unfold term_equiv in *;
  simpl; intuition congruence.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU 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                                                     *)

(** * A predicate for relating a height list with a cover

- Key definitions: [height_pred]
- Initial author: Laurent.Thery@inria.fr (2003)

*)

From Coq Require Import ArithRing.
From Huffman Require Export AuxLib OrderedCover WeightTree Ordered Prod2List.

Set Default Proof Using "Type".

Section HeightPred.
Variable A : Type.
Variable f : A -> nat.
Variable A_eq_dec : forall a b : A, {a = b} + {a <> b}.

(**
  A predicate that associates an initial height, a list of
  height, a cover and a tree
*)
Inductive height_pred : nat -> list nat -> list (btree A) -> btree A -> Prop :=
  | height_pred_nil :
      forall (n : nat) (t : btree A), height_pred n (n :: []) (t :: []) t
  | height_pred_node :
      forall (n : nat) (ln1 ln2 : list nat) (t1 t2 : btree A)
        (l1 l2 : list (btree A)),
      height_pred (S n) ln1 l1 t1 ->
      height_pred (S n) ln2 l2 t2 ->
      height_pred n (ln1 ++ ln2) (l1 ++ l2) (node t1 t2).
#[local] Hint Resolve height_pred_nil height_pred_node : core.

(** The cover is an ordered cover *)
Theorem height_pred_ordered_cover :
 forall (n : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
 height_pred n ln l t -> ordered_cover l t.
Proof.
intros n ln t l H; elim H; simpl in |- *; auto.
Qed.

(** The height list is never empty *)
Theorem height_pred_not_nil1 :
 forall (n : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
 height_pred n ln l t -> ln <> [].
Proof.
intros n ln t l H; elim H; simpl in |- *; auto.
intros; discriminate.
intros n0 ln1 ln2 t1 t2 l1 l2 H0; case ln1; simpl in |- *; auto.
intros; discriminate.
Qed.

(** The cover list is never empty *)
Theorem height_pred_not_nil2 :
 forall (n : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
 height_pred n ln l t -> l <> [].
Proof.
intros n ln t l H; elim H; simpl in |- *; auto.
intros; discriminate.
intros n0 ln1 ln2 t1 t2 l1 l2 H0; case l1; simpl in |- *; auto.
intros; discriminate.
Qed.

(* The height and cover lists have same length *)
Theorem height_pred_length :
 forall (n : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
 height_pred n ln l t -> length ln = length l.
Proof.
intros n ln t l H; elim H; simpl in |- *; auto.
intros; repeat rewrite app_length; auto with arith.
Qed.

(**
  The height and cover list gives a simple relation between
  weight_tree, sum_leaves and the product of the two lists
*)
Theorem height_pred_weight :
 forall (n : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
 height_pred n ln l t ->
 n * sum_leaves f t + weight_tree f t = prod2list f ln l.
Proof.
intros n ln t l H; elim H; simpl in |- *; auto.
intros n0 ln1 ln2 t1 t2 l1 l2 H0 H1 H2 H3.
rewrite prod2list_app; auto with arith.
rewrite <- H3; rewrite <- H1; ring.
apply height_pred_length with (1 := H0); auto.
Qed.

(** Ordered covers can be completed with a height list *)
Theorem ordered_cover_height_pred :
 forall (n : nat) (t : btree A) (l : list (btree A)),
 ordered_cover l t -> exists ln : list nat, height_pred n ln l t.
Proof.
intros n t l H; generalize n; elim H; clear n t l H.
intros t l n; exists (n :: []); auto.
intros t1 t2 l1 l2 l3 H H0 H1 H2 n.
case (H0 (S n)); intros ln1 HH1.
case (H2 (S n)); intros ln2 HH2.
exists (ln1 ++ ln2); auto.
Qed.

(** Elements in the height list are always larger than the initial height *)
Theorem height_pred_larger :
 forall (n n1 : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
 height_pred n ln l t -> In n1 ln -> n <= n1.
Proof.
intros n n1 ln t l H; generalize n1; elim H; clear H n ln t l n1;
 auto with arith.
intros n t n1 [H2| H2]; [ rewrite H2 | case H2 ]; auto.
intros n ln1 ln2 t1 t2 l1 l2 H H0 H1 H2 n1 H3; apply Nat.le_trans with (S n);
 auto with arith.
case in_app_or with (1 := H3); auto.
Qed.

(**
  In the height list is not a singleton, all its element are
  strictly larger than the initial height
*)
Theorem height_pred_larger_strict :
 forall (n n1 : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
 height_pred n ln l t -> In n1 ln -> n < n1 \/ ln = n :: [] /\ l = t :: [].
Proof.
intros n n1 ln t l H; generalize n1; elim H; clear H n ln t l n1; auto.
intros n ln1 ln2 t1 t2 l1 l2 H H0 H1 H2 n1 H3; left;
 apply Nat.lt_le_trans with (S n); auto.
case in_app_or with (1 := H3).
intros H4; apply height_pred_larger with (1 := H); auto.
intros H4; apply height_pred_larger with (1 := H1); auto.
Qed.

(** There always a larger element that the initial height in the heigh list *)
Theorem height_pred_larger_ex :
 forall (n : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
 height_pred n ln l t -> exists n1, In n1 ln /\ n <= n1.
Proof.
intros n ln t l H; elim H; clear H n ln t l.
intros n t; exists n; auto with datatypes.
intros n ln1 ln2 t1 t2 l1 l2 H (n1, (HH1, HH2)) H1 H2.
exists n1; auto with datatypes arith.
Qed.

Lemma height_pred_disj_larger_aux :
  forall (n : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
  height_pred n ln l t ->
  forall ln1 ln2 a,
  ln = ln1 ++ a :: ln2 ->
  (forall n1 : nat, In n1 ln1 -> n1 < a) ->
  (forall n1 : nat, In n1 ln2 -> n1 <= a) ->
  (exists ln3, ln2 = a :: ln3) \/ ln = n :: [] /\ l = t :: [].
Proof.
intros n ln t l H; elim H; clear H n ln t l.
intros n t l ln1 ln2 a; case ln1; simpl in |- *; auto.
intros n ln1 ln2 t1 t2 l1 l2 H H0 H1 H2 ln0 ln3 a H3 H4 H5.
case app_inv_app with (1 := H3).
intros (ln4, H7); auto.
cut (ln3 = ln4 ++ ln2);
 [ intros E1
 | apply app_inv_head with (l := ln0 ++ a :: []); repeat rewrite app_ass;
    simpl in |- *; rewrite <- H3; rewrite H7; rewrite app_ass;
    auto ].
case H0 with (1 := H7); auto; clear H0 H2.
intros n1 H8; apply H5; rewrite E1; auto with datatypes.
intros (ln5, HH); left; exists (ln5 ++ ln2).
apply trans_equal with (1 := E1); rewrite HH; auto.
intros (HH1, HH2).
cut (ln0 = [] /\ ln4 = [] /\ a = S n);
 [ intros (HH3, (HH4, HH5))
 | generalize HH1; rewrite H7; case ln0; simpl in |- *;
    [ case ln4; try (intros; discriminate); (intros HH6; injection HH6; auto)
    | intros n0 l; case l; simpl in |- *; intros; discriminate ] ].
generalize E1 H1; case ln2; simpl in |- *; auto; clear E1 H1.
intros E1 H1; case height_pred_not_nil2 with (1 := H1); auto.
generalize (height_pred_length _ _ _ _ H1); case l2; simpl in |- *; auto;
 intros; discriminate.
intros n0 ln5 E1 H1; case height_pred_larger_strict with (n1 := n0) (1 := H1);
 simpl in |- *; auto with datatypes.
intros HH6; contradict HH6; apply Nat.le_ngt; rewrite <- HH5; apply H5;
 rewrite E1; auto with datatypes.
intros (H8, H9); left; exists []; injection H8.
intros HH7 HH8; rewrite HH5; rewrite <- HH8; rewrite <- HH7; rewrite E1;
 rewrite HH4; auto.
intros (ln4, H7); auto.
cut (ln0 = ln1 ++ ln4);
 [ intros E1
 | apply app_inv_tail with (l := a :: ln3); rewrite <- H3; rewrite H7;
    rewrite app_ass; auto ].
case H2 with (1 := H7); auto.
intros n1 H6; apply H4; rewrite E1; auto with datatypes.
intros (HH1, HH2).
cut (ln3 = [] /\ ln4 = [] /\ a = S n);
 [ intros (HH3, (HH4, HH5))
 | generalize HH1; rewrite H7; case ln4; simpl in |- *;
    [ case ln3; try (intros; discriminate); (intros HH6; injection HH6; auto)
    | intros n0 l; case l; simpl in |- *; intros; discriminate ] ].
case height_pred_larger_ex with (1 := H); auto.
intros n1; rewrite <- HH5; intros (HH6, HH7).
contradict HH7; apply Nat.lt_nge; apply H4; rewrite E1; auto with datatypes.
Qed.

(** The first maximum height in the list is immediately repeated once *)
Theorem height_pred_disj_larger :
 forall (n a : nat) (ln1 ln2 : list nat) (t : btree A) (l : list (btree A)),
 height_pred n (ln1 ++ a :: ln2) l t ->
 (forall n1 : nat, In n1 ln1 -> n1 < a) ->
 (forall n1 : nat, In n1 ln2 -> n1 <= a) ->
 (exists ln3, ln2 = a :: ln3) \/
 (ln1 = [] /\ a = n /\ ln2 = []) /\ l = t :: [].
Proof.
intros n a ln1 ln2 t l H H0 H1;
 case
  height_pred_disj_larger_aux
   with (a := a) (ln1 := ln1) (ln2 := ln2) (1 := H);
 auto; case ln1; simpl in |- *;
 [ intros (HH1, HH2); injection HH1; auto
 | intros n0 l1; case l1; simpl in |- *; intuition; try discriminate ].
Qed.

Lemma height_pred_disj_larger2_aux :
  forall (n : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
  height_pred n ln l t ->
  forall ln1 ln2 a,
  ln = ln1 ++ a :: ln2 ->
  (exists n1, In n1 ln1 /\ a <= n1) \/
  (exists n1, In n1 ln2 /\ a <= n1) \/ ln = n :: [] /\ l = t :: [].
Proof.
intros n ln t l H; elim H; clear H n ln t l.
intros n t l ln1 ln2 a; case ln1; simpl in |- *; auto.
intros n ln1 ln2 t1 t2 l1 l2 H H0 H1 H2 ln0 ln3 a H3.
case app_inv_app with (1 := H3).
intros (ln4, H4); auto.
cut (ln3 = ln4 ++ ln2);
 [ intros E1
 | apply app_inv_head with (l := ln0 ++ a :: []); repeat rewrite app_ass;
    simpl in |- *; rewrite <- H3; rewrite H4; rewrite app_ass;
    auto ].
case H0 with (1 := H4); auto; intros [(n1, (HH1, HH2))| (HH1, HH2)]; auto;
 clear H0 H2.
right; left; exists n1; split; auto; rewrite E1; auto with datatypes.
cut (ln0 = [] /\ ln4 = [] /\ a = S n);
 [ intros (HH3, (HH4, HH5))
 | generalize HH1; rewrite H4; case ln0; simpl in |- *;
    [ case ln4; try (intros; discriminate); (intros HH6; injection HH6; auto)
    | intros n0 l; case l; simpl in |- *; intros; discriminate ] ].
case height_pred_larger_ex with (1 := H1); auto.
intros n1; rewrite <- HH5; intros (HM1, HM2).
right; left; exists n1; split; auto; rewrite E1; auto with datatypes.
intros (ln4, H4); auto.
cut (ln0 = ln1 ++ ln4);
 [ intros E1
 | apply app_inv_tail with (l := a :: ln3); rewrite <- H3; rewrite H4;
    rewrite app_ass; auto ].
case H2 with (1 := H4); auto; clear H0 H2.
intros (n1, (HH1, HH2)); left; exists n1; split; auto; rewrite E1;
 auto with datatypes.
intros [HH1| (HH1, HH2)]; auto.
cut (ln3 = [] /\ ln4 = [] /\ a = S n);
 [ intros (HH3, (HH4, HH5))
 | generalize HH1; rewrite H4; case ln4; simpl in |- *;
    [ case ln3; try (intros; discriminate); (intros HH6; injection HH6; auto)
    | intros n0 l; case l; simpl in |- *; intros; discriminate ] ].
case height_pred_larger_ex with (1 := H); auto.
intros n1; rewrite <- HH5; intros (HM1, HM2).
left; exists n1; split; auto; rewrite E1; auto with datatypes.
Qed.

(** There is no strict maximum in a list *)
Theorem height_pred_disj_larger2 :
 forall (n a : nat) (ln1 ln2 : list nat) (t : btree A) (l : list (btree A)),
 height_pred n (ln1 ++ a :: ln2) l t ->
 (exists n1, In n1 ln1 /\ a <= n1) \/
 (exists n1, In n1 ln2 /\ a <= n1) \/
 (ln1 = [] /\ a = n /\ ln2 = []) /\ l = t :: [].
Proof.
intros n a ln1 ln2 t l H;
 case
  height_pred_disj_larger2_aux
   with (a := a) (ln1 := ln1) (ln2 := ln2) (1 := H);
 auto.
intros [H1| (H1, H2)]; auto.
generalize H1 H2; case ln1; simpl in |- *;
 [ intros H3; injection H3; auto with datatypes | idtac ].
intros H0 H4 H5; repeat right; auto.
intros n0 l0; case l0; simpl in |- *; intros; discriminate.
Qed.

Theorem height_pred_shrink_aux :
  forall (n : nat) (ln : list nat) (t : btree A) (l : list (btree A)),
  height_pred n ln l t ->
  forall l1 l2 ln1 ln2 a b t1 t2,
  ln = ln1 ++ a :: b :: ln2 ->
  (forall n1 : nat, In n1 ln1 -> n1 < a) ->
  (forall n1 : nat, In n1 (b :: ln2) -> n1 <= a) ->
  length ln1 = length l1 ->
  l = l1 ++ t1 :: t2 :: l2 ->
  height_pred n (ln1 ++ pred a :: ln2) (l1 ++ node t1 t2 :: l2) t.
Proof.
intros n ln t l H; elim H; clear n ln t l H; auto.
intros n t l1 l2 ln1 ln2 a b t1 t2; case ln1;
 try (simpl in |- *; intros; discriminate).
intros n0 l0; case l0; try (simpl in |- *; intros; discriminate).
intros n ln1 ln2 t1 t2 l1 l2 H H0 H1 H2 l0 l3 ln0 ln3 a b t0 t3 H3 H4 H5 H6
 H7.
cut (length ln1 = length l1);
 [ intros Eq2 | apply height_pred_length with (1 := H) ].
cut (length ln2 = length l2);
 [ intros Eq3 | apply height_pred_length with (1 := H1) ].
cut (length ln3 = length l3);
 [ intros Eq4
 | apply Nat.add_cancel_l with (length (ln0 ++ a :: b :: []));
    rewrite <- app_length; rewrite app_ass; simpl in |- *;
    rewrite <- H3; repeat rewrite app_length; simpl in |- *;
    rewrite Eq2; rewrite Eq3; rewrite <- app_length;
    rewrite H7; repeat rewrite app_length; simpl in |- *;
    repeat rewrite (fun x y => Nat.add_comm x (S y));
    simpl in |- *; rewrite Nat.add_comm; auto ].
case app_inv_app2 with (1 := H3); auto.
intros (ln4, Hp1).
cut (ln3 = ln4 ++ ln2);
 [ intros E1
 | apply app_inv_head with (l := ln0 ++ a :: b :: []);
    repeat rewrite app_ass; simpl in |- *; rewrite <- H3;
    rewrite Hp1; repeat rewrite app_ass; auto ].
replace (ln0 ++ pred a :: ln3) with ((ln0 ++ pred a :: ln4) ++ ln2);
 [ idtac | rewrite app_ass; rewrite E1; auto ].
cut (l3 = firstn (length ln4) l3 ++ l2).
intros HH;
 replace (l0 ++ node t0 t3 :: l3) with
  ((l0 ++ node t0 t3 :: firstn (length ln4) l3) ++ l2);
 [ idtac | pattern l3 at 2 in |- *; rewrite HH; rewrite app_ass; auto ].
apply height_pred_node; auto.
apply H0 with (1 := Hp1); auto.
intros n1 HH1; (apply H5; auto).
simpl in HH1; case HH1; intros H9; try rewrite H9; auto with datatypes.
rewrite E1; auto with datatypes.
apply app_inv_tail with (l := l2).
repeat rewrite app_ass; apply trans_equal with (1 := H7); auto.
pattern l3 at 1 in |- *; rewrite HH; auto.
apply sym_equal;
 apply trans_equal with (2 := firstn_skipn (length ln4) l3).
apply f_equal2 with (f := app (A:=btree A)); auto.
apply trans_equal with (skipn (length l1 - length l1) l2).
rewrite Nat.sub_diag; simpl in |- *; auto.
rewrite <- skipn_le_app1; auto.
rewrite H7.
rewrite <- Eq2; rewrite Hp1.
rewrite skipn_le_app1.
rewrite app_length.
rewrite H6.
rewrite <- Nat.add_comm.
rewrite Nat.add_sub. simpl in |- *; auto.
rewrite <- H6; rewrite app_length; simpl in |- *; auto with arith.
intros [(ln4, HH)| (HH1, HH2)].
cut (ln0 = ln1 ++ ln4);
 [ intros E1
 | apply app_inv_tail with (l := a :: b :: ln3); rewrite <- H3; rewrite HH;
    rewrite app_ass; auto ].
cut (l0 = l1 ++ skipn (length l1) l0).
intros Eq1; rewrite Eq1; rewrite E1; repeat rewrite app_ass.
apply height_pred_node; auto.
apply H2 with (b := b); auto.
intros n1 H8; apply H4; (rewrite E1; auto with datatypes).
rewrite skipn_length; rewrite <- Eq2; rewrite <- H6;
 rewrite <- skipn_length; rewrite E1; rewrite skipn_le_app2;
 auto; rewrite skipn_all; simpl in |- *; auto.
apply app_inv_head with (l := l1).
rewrite <- app_ass; rewrite <- Eq1; auto.
apply sym_equal;
 apply trans_equal with (2 := firstn_skipn (length l1) l0).
apply f_equal2 with (f := app (A:=btree A)); auto.
apply trans_equal with (firstn (length l1) (l1 ++ l2)).
rewrite firstn_le_app1; auto; rewrite Nat.sub_diag; simpl in |- *;
 auto with datatypes.
rewrite H7; rewrite firstn_le_app2; auto.
rewrite <- H6; rewrite <- Eq2; rewrite E1; rewrite app_length;
 auto with arith.
rewrite HH1 in H; case height_pred_disj_larger2 with (1 := H); simpl in |- *;
 auto.
intros (n1, (HH3, HH4)); contradict HH4; auto with arith.
intros [(n1, (HH3, HH4))| ((HH3, (HH4, HH5)), HH6)]; [ case HH3 | idtac ].
case height_pred_larger_strict with (1 := H1) (n1 := b); auto.
rewrite HH2; auto with datatypes.
rewrite <- HH4; intros HH7; contradict HH7; apply Nat.le_ngt;
 auto with arith datatypes.
intros (H8, H9); rewrite HH4; rewrite HH3; simpl in |- *.
cut (l0 = []); [ intros HM1; rewrite HM1 | idtac ].
cut (ln3 = []); [ intros HM2; rewrite HM2 | idtac ].
replace l3 with (nil (A:=btree A)); simpl in |- *; auto.
rewrite HH6 in H7; rewrite H9 in H7; rewrite HM1 in H7; simpl in H7;
 injection H7.
intros Ht1 Ht2 Ht3; rewrite Ht2; rewrite Ht3; auto.
generalize Eq4; rewrite HM2; case l3; simpl in |- *; auto; intros;
 discriminate.
rewrite HH2 in H8; injection H8; auto.
generalize H6; rewrite HH3; case l0; simpl in |- *; auto; intros;
 discriminate.
Qed.

(**
  A cover can be shrunk at the first maximum of the height while
  preserving the height list
*)
Theorem height_pred_shrink :
 forall (n a b : nat) (ln1 ln2 : list nat) (t t1 t2 : btree A)
   (l1 l2 : list (btree A)),
 height_pred n (ln1 ++ a :: b :: ln2) (l1 ++ t1 :: t2 :: l2) t ->
 (forall n1 : nat, In n1 ln1 -> n1 < a) ->
 (forall n1 : nat, In n1 (b :: ln2) -> n1 <= a) ->
 length ln1 = length l1 ->
 height_pred n (ln1 ++ pred a :: ln2) (l1 ++ node t1 t2 :: l2) t.
Proof.
intros n a b ln1 ln2 t t1 t2 l1 l2 H H0 H1 H2;
 apply height_pred_shrink_aux with (1 := H) (b := b);
 auto.
Qed.

(**
  Given a tree and its associated code it is possible to build
  a height list (the length of the codes) and a cover (the leaves)
  that are related
*)
Theorem height_pred_compute_code :
 forall (n : nat) (t : btree A),
 height_pred n (map (fun x => length (snd x) + n) (compute_code t))
   (map (fun x => leaf (fst x)) (compute_code t)) t.
Proof.
intros n t; generalize n; elim t; clear t n; simpl in |- *; auto.
intros b H b0 H0 n.
repeat rewrite map_app.
cut
 (forall (b : bool) l,
  map (fun x : A * list bool => length (snd x) + n)
    (map (fun v : A * list bool => let (a1, b1) := v in (a1, b :: b1)) l) =
  map (fun x : A * list bool => length (snd x) + S n) l);
 [ intros E1 | idtac ].
cut
 (forall b l,
  map (fun x : A * list bool => leaf (fst x))
    (map (fun v : A * list bool => let (a1, b1) := v in (a1, b :: b1)) l) =
  map (fun x : A * list bool => leaf (fst x)) l); [ intros E2 | idtac ].
apply height_pred_node; repeat rewrite E1; repeat rewrite E2; auto.
intros b1 l; elim l; simpl in |- *; auto.
intros a; case a; simpl in |- *; auto.
intros a0 l0 l1 H1; apply f_equal2 with (f := cons (A:=btree A)); auto.
intros b1 l; elim l; simpl in |- *; auto.
intros a; case a; simpl in |- *; auto.
intros a0 l0 l1 H1; apply f_equal2 with (f := cons (A:=nat)); auto.
Qed.

(**
  A consequence of the previous theorem, the weight of the tree
  is exactly the encoding of the message of the corresponding code
*)
Theorem weight_tree_compute :
 forall (m : list A) t,
 distinct_leaves t ->
 (forall a : A, f a = number_of_occurrences A_eq_dec a m) ->
 length (encode A_eq_dec (compute_code t) m) = weight_tree f t.
Proof.
intros m t H0 H.
rewrite frequency_length; auto.
apply trans_equal with (0 * sum_leaves f t + weight_tree f t); auto.
rewrite height_pred_weight with (1 := height_pred_compute_code 0 t).
unfold prod2list in |- *.
rewrite
 fold_left_eta
               with
               (f :=
                 fun (a : nat) (b : A * list bool) =>
                 a + number_of_occurrences A_eq_dec (fst b) m * length (snd b))
              (f1 :=
                fun (a : nat) (b : A * list bool) =>
                a + (fun b => f (fst b) * length (snd b)) b);
 auto.
rewrite <-
 (fold_left_map _ _ (fun a b : nat => a + b) _ 0 (compute_code t)
    (fun b : A * list bool => f (fst b) * length (snd b)))
 .
rewrite fold_left_eta with (f := fun a b : nat => a + b) (f1 := plus); auto.
apply f_equal3 with (f := fold_left (A:=nat) (B:=nat)); auto.
elim (compute_code t); simpl in |- *; auto.
intros a l H1; apply f_equal2 with (f := cons (A:=nat)); auto with arith.
ring.
apply btree_unique_prefix2; auto.
Qed.

End HeightPred.
Arguments height_pred [A].
#[export] Hint Resolve height_pred_nil height_pred_node : core.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                              ElementTemp.v                               *)
(****************************************************************************)

Require Export ElementComb.
Require Export Basic_composition_rules.
Require Import Identity.

Set Implicit Arguments.
Unset Strict Implicit.

(** Describing the temporal parts of the circuit using co-induction **)

Definition RLATCH2 (rd : Stream bool) := RLATCH rd (n:=2).

Definition DMUX4T2FFC_AUX := S_map2 dmux4t2ffc.

Definition DMUX4T2FFC (d : Stream (d_list bool 4))
  (y outputDisable : Stream bool) (old : d_list bool 2) :=
  RLATCH2 outputDisable (Stream_to_dlist (DMUX4T2FFC_AUX y d)) old.

Definition DMUX4T2 := S_map2 Dmux4t2.

Definition DMUX2B4CA11_AUX (y outputDisable : Stream bool)
  (d : Stream (d_list (d_list bool 4) 2))
  (old_mux : d_list (d_list bool 2) 2) :=
  List2
    (dlist_to_Stream
       (DMUX4T2FFC (S_Fst_of_l2 d) y outputDisable (Fst_of_l2 old_mux)))
    (dlist_to_Stream
       (DMUX4T2FFC (S_Scd_of_l2 d) y outputDisable (Scd_of_l2 old_mux))).

Definition DMUX2B4CA11 (old_mux : d_list (d_list bool 2) 2)
  (outputDisable : Stream bool) (grant : Stream (d_list bool 2))
  (d : Stream (d_list (d_list bool 4) 2)) :=
  DMUX4T2 (S_Fst_of_l2 grant)
    (dlist_to_Stream
       (DMUX2B4CA11_AUX (S_Scd_of_l2 grant) outputDisable d old_mux)).

Definition DATASWITCHC_AUX (i : nat) (H : 0 < i) (H' : i <= 7)
  (outputDisable : Stream bool) (grant : Stream (d_list bool 2))
  (d : Stream (d_list (d_list bool 8) 4))
  (old_mux : d_list (d_list bool 2) 2) :=
  DMUX2B4CA11 old_mux outputDisable grant
    (dlist_to_Stream
       (List2 (S_map (list_of_nth (i:=i) (n:=8) H (le_leS H') (n0:=4)) d)
          (S_map
             (list_of_nth (i:=S i) (n:=8) (lt_O_Sn i) (le_n_S i 7 H') (n0:=4))
             d))).

Definition DATASWITCHC (outputDisable : Stream bool)
  (grant : Stream (d_list bool 2)) (d : Stream (d_list (d_list bool 8) 4))
  (old_mux : d_list (d_list (d_list bool 2) 2) 4) :=
  dlist_to_Stream
    (List4
       (DATASWITCHC_AUX lt_O_1 le_1_7 outputDisable grant d
          (Fst_of_l4 old_mux))
       (DATASWITCHC_AUX lt_O_3 le_3_7 outputDisable grant d
          (Scd_of_l4 old_mux))
       (DATASWITCHC_AUX lt_O_5 le_5_7 outputDisable grant d
          (Thd_of_l4 old_mux))
       (DATASWITCHC_AUX lt_O_7 le_7_7 outputDisable grant d
          (Fth_of_l4 old_mux))).

Definition DATASWITCH_N_AUX (i : nat) (H : 0 < i) (H' : i <= 4)
  (outputDisable : Stream (d_list bool 4))
  (grant : Stream (d_list (d_list bool 2) 4))
  (d : Stream (d_list (d_list bool 8) 4))
  (old_mux : d_list (d_list bool 2) 8) :=
  DATASWITCHC (S_Nth (i:=i) H H' outputDisable) (S_Nth (i:=i) H H' grant) d
    (Fold_List (n:=2) (m:=4) old_mux).

Definition DATASWITCH_N (outputDisable : Stream (d_list bool 4))
  (grant : Stream (d_list (d_list bool 2) 4))
  (d : Stream (d_list (d_list bool 8) 4))
  (old_mux : d_list (d_list (d_list bool 2) 8) 4) :=
  S_map (d_map (Unfold_List (n:=2) (m:=4)) (n:=4))
    (dlist_to_Stream
       (List4
          (DATASWITCH_N_AUX lt_O_1 le_1_4 outputDisable grant d
             (Fst_of_l4 old_mux))
          (DATASWITCH_N_AUX lt_O_2 le_2_4 outputDisable grant d
             (Scd_of_l4 old_mux))
          (DATASWITCH_N_AUX lt_O_3 le_3_4 outputDisable grant d
             (Thd_of_l4 old_mux))
          (DATASWITCH_N_AUX lt_O_4 le_4_4 outputDisable grant d
             (Fth_of_l4 old_mux)))).

(** The structure of TIMING is exactly a Moore automaton **)

Definition Timing_Aux (e : bool * d_list bool 4) (l : d_list bool 2) :=
  let (fs, act) := e in Timing fs act l.

Definition Out_Struct_Timing (_ : bool * d_list bool 4)
  (l : d_list bool 2) := d_Head l.

Definition Structure_TIMING := Mealy Timing_Aux Out_Struct_Timing.

(** The structure of OUTDIS is a Mealy automaton **)

Definition Trans_outdis (i : d_list bool 4 * (bool * bool))
  (old_jk : bool) :=
  let (req, p) := i in
  let (fs, routeEnable) := p in Jk fs (outdis req routeEnable) old_jk.

Definition Out_outdis (_ : d_list bool 4 * (bool * bool))
  (old_jk : bool) := old_jk.

Definition Structure_Outdis := Mealy Trans_outdis Out_outdis.

(** The structure of ARBITER_XY is a Mealy automaton **)

Definition Trans_ArbiterXY (i : d_list bool 4 * bool)
  (old_xy : d_list bool 2) :=
  let (req, routeEnable) := i in
  List2
    (JkE (Fst_of_l2 (Arbx (Scd_of_l2 old_xy) req))
       (Scd_of_l2 (Arbx (Scd_of_l2 old_xy) req)) (Fst_of_l2 old_xy)
       routeEnable)
    (JkE (Fst_of_l2 (Arby (Fst_of_l2 old_xy) req))
       (Scd_of_l2 (Arby (Fst_of_l2 old_xy) req)) (Scd_of_l2 old_xy)
       routeEnable).

Definition Out_ArbiterXY (_ : d_list bool 4 * bool)
  (old_xy : d_list bool 2) := old_xy.

Definition Structure_ArbiterXY := Mealy Trans_ArbiterXY Out_ArbiterXY.

(** The structure of ARBITER is a PC of Structure_Outdis and Structure_ArbiterXY **)

Definition f_arbiter (i : bool * (bool * d_list bool 4)) :=
  let (fs, p) := i in
  let (routeEnable, req) := p in (req, routeEnable, (req, (fs, routeEnable))).

Definition output_arbiter (l : d_list bool 2 * bool) :=
  let (o1, o2) := l in List3 (Fst_of_l2 o1) (Scd_of_l2 o1) o2.

Definition TransPC_arbiter := Trans_PC Trans_ArbiterXY Trans_outdis f_arbiter.

Definition OutPC_arbiter :=
  Out_PC Out_ArbiterXY Out_outdis f_arbiter output_arbiter.

Definition Structure_ARBITER :=
  PC Trans_ArbiterXY Trans_outdis Out_ArbiterXY Out_outdis f_arbiter
    output_arbiter.

(** Parallel composition of two arbiters with the PC rule **)

Definition f_two_arbiters (i : bool * (bool * d_list (d_list bool 4) 2)) :=
  let (fs, p) := i in
  let (routeEnable, req2) := p in
  (fs, (routeEnable, Fst_of_l2 req2), (fs, (routeEnable, Scd_of_l2 req2))).

Definition output_two_arbiters (o : d_list bool 3 * d_list bool 3) := o.

Definition Trans_Struct_two_arbiters :=
  Trans_PC TransPC_arbiter TransPC_arbiter f_two_arbiters.

Definition Out_Struct_two_arbiters :=
  Out_PC OutPC_arbiter OutPC_arbiter f_two_arbiters output_two_arbiters.

Definition Structure_TWO_ARBITERS :=
  PC TransPC_arbiter TransPC_arbiter OutPC_arbiter OutPC_arbiter
    f_two_arbiters output_two_arbiters.

(** Parallel composition of four arbiters with the PC rule **)

Definition f_four_arbiters (i : bool * (bool * d_list (d_list bool 4) 4)) :=
  let (fs, p) := i in
  let (routeEnable, req) := p in
  (fs, (routeEnable, Two_Fst_of_l4 req),
  (fs, (routeEnable, Two_last_of_l4 req))).

Definition output_four_arbiters
  (o : d_list bool 3 * d_list bool 3 * (d_list bool 3 * d_list bool 3)) := o.

Definition Trans_Struct_four_arbiters :=
  Trans_PC Trans_Struct_two_arbiters Trans_Struct_two_arbiters
    f_four_arbiters.

Definition Out_Struct_four_arbiters :=
  Out_PC Out_Struct_two_arbiters Out_Struct_two_arbiters f_four_arbiters
    output_four_arbiters.

Definition Structure_FOUR_ARBITERS :=
  PC Trans_Struct_two_arbiters Trans_Struct_two_arbiters
    Out_Struct_two_arbiters Out_Struct_two_arbiters f_four_arbiters
    output_four_arbiters.

(** PRIORITY_DECODE should be a Mealy automaton too **)

Definition Trans_priority_decode
  (e : d_list bool 4 * (d_list bool 4 * d_list (d_list bool 2) 4))
  (_ : d_list (d_list bool 4) 4) :=
  let (act, p) := e in
  let (pri, route) := p in Priority_Decode_Less_Pause act pri route.

Definition Out_priority_decode
  (_ : d_list bool 4 * (d_list bool 4 * d_list (d_list bool 2) 4))
  (reg : d_list (d_list bool 4) 4) := reg.

Definition Structure_PRIORITY_DECODE :=
  Mealy Trans_priority_decode Out_priority_decode.

(* Parallel composition of TIMING and PRIORITY_DECODE *)

Section Timing_and_PDecode.

 Let Input_vector_type :=
   (bool * (d_list bool 4 * (d_list bool 4 * d_list (d_list bool 2) 4)))%type.

 Let f_tp (i : Input_vector_type) :=
   let (fs, t) := i in
   let (act, p) := t in
   let (pri, route) := p in (fs, act, (act, (pri, route))).

 Let output_tp (out : bool * d_list (d_list bool 4) 4) := out.

 Definition TransPC_Timing_PDecode :=
   Trans_PC Timing_Aux Trans_priority_decode f_tp.

 Definition OutPC_Timing_PDecode :=
   Out_PC Out_Struct_Timing Out_priority_decode f_tp output_tp.

 Definition Structure_TIMING_PDECODE (i : Stream Input_vector_type)
   (l : d_list bool 2) (reg : d_list (d_list bool 4) 4) :=
   PC Timing_Aux Trans_priority_decode Out_Struct_Timing Out_priority_decode
     f_tp output_tp i (l, reg).

 Definition States_TIMING_PDECODE (i : Stream Input_vector_type)
   (l : d_list bool 2) (reg : d_list (d_list bool 4) 4) :=
   States_PC Timing_Aux Trans_priority_decode f_tp i (l, reg).

End Timing_and_PDecode.

(* Parallel composition of IDENTITY and TIMING_PDECODE *)

Section Identity_and_TimingPDecode.

 Let Input_vector_type :=
   (bool * (d_list bool 4 * (d_list bool 4 * d_list (d_list bool 2) 4)))%type.

 Let f_tpi (i : Input_vector_type) :=
   let (fs, t) := i in
   let (act, p) := t in
   let (pri, route) := p in (fs, (fs, (act, (pri, route)))).

 Let output_tpi (out : bool * (bool * d_list (d_list bool 4) 4)) := out.

 Definition TransPC_TimingPDecode_Id :=
   Trans_PC (Trans_id (Input_type:=bool)) TransPC_Timing_PDecode f_tpi.

 Definition OutPC_TimingPDecode_Id :=
   Out_PC (Out_id (Input_type:=bool)) OutPC_Timing_PDecode f_tpi output_tpi.

 Definition Structure_TIMINGPDECODE_ID (i : Stream Input_vector_type)
   (id : state_id) (old : d_list bool 2 * d_list (d_list bool 4) 4) :=
   PC (Trans_id (Input_type:=bool)) TransPC_Timing_PDecode
     (Out_id (Input_type:=bool)) OutPC_Timing_PDecode f_tpi output_tpi i
     (id, old).

 Definition States_TIMINGPDECODE_ID (i : Stream Input_vector_type)
   (id : state_id) (old : d_list bool 2 * d_list (d_list bool 4) 4) :=
   States_PC (Trans_id (Input_type:=bool)) TransPC_Timing_PDecode f_tpi i
     (id, old).

End Identity_and_TimingPDecode.

(* Series composition of TIMINGPDECODE_ID and FOUR_ARBITERS *)

Section Arbitration_Structure.

  Let Input_vector_type :=
    (bool * (d_list bool 4 * (d_list bool 4 * d_list (d_list bool 2) 4)))%type.

  Definition TransSC_Arbitration :=
    Trans_SC TransPC_TimingPDecode_Id Trans_Struct_four_arbiters
      OutPC_TimingPDecode_Id.

  Definition OutSC_Arbitration :=
    Out_SC OutPC_TimingPDecode_Id Out_Struct_four_arbiters.

  Definition Structure_ARBITRATION (i : Stream Input_vector_type)
    (old_tpi : state_id * (d_list bool 2 * d_list (d_list bool 4) 4))
    (old_arbiters : d_list bool 2 * bool * (d_list bool 2 * bool) *
                    (d_list bool 2 * bool * (d_list bool 2 * bool))) :=
    SC TransPC_TimingPDecode_Id Trans_Struct_four_arbiters
      OutPC_TimingPDecode_Id Out_Struct_four_arbiters i
      (old_tpi, old_arbiters).

  Definition StatesSC_ARBITRATION (i : Stream Input_vector_type)
    (old_tpi : state_id * (d_list bool 2 * d_list (d_list bool 4) 4))
    (old_arbiters : d_list bool 2 * bool * (d_list bool 2 * bool) *
                    (d_list bool 2 * bool * (d_list bool 2 * bool))) :=
    States_SC TransPC_TimingPDecode_Id Trans_Struct_four_arbiters
      OutPC_TimingPDecode_Id i (old_tpi, old_arbiters).

End Arbitration_Structure.


(*
vim: set fenc=utf-8 ff=unix sts=2 sw=2 et ft=coq :
*)
(*
Copyright (C) 2016-2019 Philip H. Smith

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.
*)

Require Import Way.StaleAtoms.
Require Import Way.Tactics.

Require Import Way.Open.
Require Import Way.Preterm.

(* A preterm is locally closed if every bound variable refers to some abstraction.

Local closure is the only criterion needed to establish a preterm as a term, so the type
here is named "term".

A proof of local closure reflects the shape of its preterm, with two key differences.

First, we transform abstraction bodies before demanding local closure of the result.  The
transformation is to open a "sufficiently fresh" free variable for the new bound variable.
This bound variable will therefore not appear in the preterm of the required subproof.
Since abstraction annotations should not refer to the new abstraction variable, no
substitution is performed on them.

Second, there is no local closure constructor for bound variables.

If all bound variables properly refer to some abstraction, then by the first point they
will all be replaced by free variables by the time we consider the proof of their local
closure.  Any bound variables that remain must be dangling.

By the second point, preterms with dangling bound variables will be unable to prove local
closure, due to the lack of a suitable constructor.  Preterms without dangling bound
variables will have no need of one.

"Sufficiently fresh" means exclusion from an arbitrary list of free variables, but think
"free variables of the abstraction body".  Leaving it unspecified here makes proofs
somewhat easier later, per the "cofinite induction" pattern.
*)
Inductive term : preterm -> Set :=

| free_variable : forall (a : atom), term (free_variable a)

| product :
  forall (l : list atom) (p q : preterm), term p ->
  (fresh (a : l), term (open_free a q)) ->
  term (product p q)

| abstraction :
  forall (l : list atom) (p q : preterm), term p ->
  (fresh (a : l), term (open_free a q)) ->
  term (abstraction p q)

| application : forall (p q : preterm), term p -> term q -> term (application p q)

| type : forall (n : nat), term (type n).

Hint Resolve free_variable application type : way.

Hint Extern 7 (term (Preterm.product _ _)) =>
  let stale := stale_atoms in apply (Term.product stale) : way.

Hint Extern 7 (term (Preterm.abstraction _ _)) =>
  let stale := stale_atoms in apply (Term.abstraction stale) : way.

Module Examples.

Import Aliases.

Example omega : term Preterm.Examples.omega.
Proof.
  unfold Preterm.Examples.omega; infer.
Defined.

Example polymorphic_identity : term Preterm.Examples.polymorphic_identity.
Proof.
  unfold Preterm.Examples.polymorphic_identity; infer.
Defined.

Example fvar_is_term : forall (a : atom), term (fvar a).
Proof.
  infer.
Defined.

Example prod_can_be_term : term (prod (type 0) (bvar 0)).
Proof.
  infer.
Defined.

Example prod_can_be_not_term : notT (term (prod (type 0) (bvar 1))).
Proof.
  intro H;
  inversion H as [ | stale ? ? ? CFH | | | ];
  subst;
  destruct (fresh_atom stale) as [a Hfresh];
  pose proof (CFH a Hfresh) as Himpossible;
  infer.
Defined.

Example abs_can_be_term : term (abs (type 0) (bvar 0)).
Proof.
  infer.
Defined.

Example abs_can_be_not_term : notT (term (abs (type 0) (bvar 1))).
Proof.
  intro H;
  inversion H as [ | | stale ? ? ? CFH | | ];
  subst;
  destruct (fresh_atom stale) as [a Hfresh];
  pose proof (CFH a Hfresh) as Himpossible;
  infer.
Defined.

Example app_can_be_term : forall (a : atom), term (app (fvar a) (fvar a)).
Proof.
  infer.
Defined.

Example app_can_be_not_term : notT (term (app (bvar 0) (bvar 0))).
Proof.
  infer.
Defined.

Example type_is_term : term (type 0).
Proof.
  infer.
Defined.

End Examples.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import List.
From LegacyRing Require Import LegacyRing.
Require Export LegacyField_Compl.
Require Export LegacyField_Theory.

(**** Interpretation A --> ExprA ****)

Ltac get_component a s := eval cbv beta iota delta [a] in (a s).

Ltac body_of s := eval cbv beta iota delta [s] in s.

Ltac mem_assoc var lvar :=
  match constr:(lvar) with
  | nil => constr:(false)
  | ?X1 :: ?X2 =>
      match constr:(X1 = var) with
      | (?X1 = ?X1) => constr:(true)
      | _ => mem_assoc var X2
      end
  end.

Ltac number lvar :=
  let rec number_aux lvar cpt :=
    match constr:(lvar) with
    | (@nil ?X1) => constr:(@nil (prod X1 nat))
    | ?X2 :: ?X3 =>
        let l2 := number_aux X3 (S cpt) in
        constr:((X2,cpt) :: l2)
    end
  in number_aux lvar 0.

Ltac build_varlist FT trm :=
  let rec seek_var lvar trm :=
    let AT := get_component A FT
    with AzeroT := get_component Azero FT
    with AoneT := get_component Aone FT
    with AplusT := get_component Aplus FT
    with AmultT := get_component Amult FT
    with AoppT := get_component Aopp FT
    with AinvT := get_component Ainv FT in
    match constr:(trm) with
    | AzeroT => lvar
    | AoneT => lvar
    | (AplusT ?X1 ?X2) =>
        let l1 := seek_var lvar X1 in
        seek_var l1 X2
    | (AmultT ?X1 ?X2) =>
        let l1 := seek_var lvar X1 in
        seek_var l1 X2
    | (AoppT ?X1) => seek_var lvar X1
    | (AinvT ?X1) => seek_var lvar X1
    | ?X1 =>
        let res := mem_assoc X1 lvar in
        match constr:(res) with
        | true => lvar
        | false => constr:(X1 :: lvar)
        end
    end in
  let AT := get_component A FT in
  let lvar := seek_var (@nil AT) trm in
  number lvar.

Ltac assoc elt lst :=
  match constr:(lst) with
  | nil => fail
  | (?X1,?X2) :: ?X3 =>
      match constr:(elt = X1) with
      | (?X1 = ?X1) => constr:(X2)
      | _ => assoc elt X3
      end
  end.

Ltac interp_A FT lvar trm :=
  let AT := get_component A FT
  with AzeroT := get_component Azero FT
  with AoneT := get_component Aone FT
  with AplusT := get_component Aplus FT
  with AmultT := get_component Amult FT
  with AoppT := get_component Aopp FT
  with AinvT := get_component Ainv FT in
  match constr:(trm) with
  | AzeroT => constr:(EAzero)
  | AoneT => constr:(EAone)
  | (AplusT ?X1 ?X2) =>
      let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in
      constr:(EAplus e1 e2)
  | (AmultT ?X1 ?X2) =>
      let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in
      constr:(EAmult e1 e2)
  | (AoppT ?X1) =>
      let e := interp_A FT lvar X1 in
      constr:(EAopp e)
  | (AinvT ?X1) => let e := interp_A FT lvar X1 in
                   constr:(EAinv e)
  | ?X1 => let idx := assoc X1 lvar in
           constr:(EAvar idx)
  end.

(************************)
(*    Simplification    *)
(************************)

(**** Generation of the multiplier ****)

Ltac remove e l :=
  match constr:(l) with
  | nil => l
  | e :: ?X2 => constr:(X2)
  | ?X2 :: ?X3 => let nl := remove e X3 in constr:(X2 :: nl)
  end.

Ltac union l1 l2 :=
  match constr:(l1) with
  | nil => l2
  | ?X2 :: ?X3 =>
      let nl2 := remove X2 l2 in
      let nl := union X3 nl2 in
      constr:(X2 :: nl)
  end.

Ltac raw_give_mult trm :=
  match constr:(trm) with
  | (EAinv ?X1) => constr:(X1 :: nil)
  | (EAopp ?X1) => raw_give_mult X1
  | (EAplus ?X1 ?X2) =>
      let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in
      union l1 l2
  | (EAmult ?X1 ?X2) =>
      let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in
      eval compute in (app l1 l2)
  | _ => constr:(@nil ExprA)
  end.

Ltac give_mult trm :=
  let ltrm := raw_give_mult trm in
  constr:(mult_of_list ltrm).

(**** Associativity ****)

Ltac apply_assoc FT lvar trm :=
  let t := eval compute in (assoc trm) in
  match constr:(t = trm) with
  | (?X1 = ?X1) => idtac
  | _ =>
      rewrite <- (assoc_correct FT trm); change (assoc trm) with t
  end.

(**** Distribution *****)

Ltac apply_distrib FT lvar trm :=
  let t := eval compute in (distrib trm) in
  match constr:(t = trm) with
  | (?X1 = ?X1) => idtac
  | _ =>
      rewrite <- (distrib_correct FT trm);
       change (distrib trm) with t
  end.

(**** Multiplication by the inverse product ****)

Ltac grep_mult := match goal with
                  | id:(interp_ExprA _ _ _ <> _) |- _ => id
                  end.

Ltac weak_reduce :=
  match goal with
  |  |- context [(interp_ExprA ?X1 ?X2 _)] =>
      cbv beta iota zeta
       delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list X1 X2 A Azero
             Aone Aplus Amult Aopp Ainv]
  end.

Ltac multiply mul :=
  match goal with
  |  |- (interp_ExprA ?FT ?X2 ?X3 = interp_ExprA ?FT ?X2 ?X4) =>
      let AzeroT := get_component Azero FT in
      cut (interp_ExprA FT X2 mul <> AzeroT);
       [ intro; (let id := grep_mult in apply (mult_eq FT X3 X4 mul X2 id))
       | weak_reduce;
          (let AoneT := get_component Aone ltac:(body_of FT)
           with AmultT := get_component Amult ltac:(body_of FT) in
           try
             match goal with
             |  |- context [(AmultT _ AoneT)] => rewrite (AmultT_1r FT)
             end; clear FT X2) ]
  end.

Ltac apply_multiply FT lvar trm :=
  let t := eval compute in (multiply trm) in
  match constr:(t = trm) with
  | (?X1 = ?X1) => idtac
  | _ =>
      rewrite <- (multiply_correct FT trm);
       change (multiply trm) with t
  end.

(**** Permutations and simplification ****)

Ltac apply_inverse mul FT lvar trm :=
  let t := eval compute in (inverse_simplif mul trm) in
  match constr:(t = trm) with
  | (?X1 = ?X1) => idtac
  | _ =>
      rewrite <- (inverse_correct FT trm mul);
       [ change (inverse_simplif mul trm) with t | assumption ]
  end.
(**** Inverse test ****)

Ltac strong_fail tac := first [ tac | fail 2 ].

Ltac inverse_test_aux FT trm :=
  let AplusT := get_component Aplus FT
  with AmultT := get_component Amult FT
  with AoppT := get_component Aopp FT
  with AinvT := get_component Ainv FT in
  match constr:(trm) with
  | (AinvT _) => fail 1
  | (AoppT ?X1) =>
      strong_fail ltac:(inverse_test_aux FT X1; idtac)
  | (AplusT ?X1 ?X2) =>
      strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2)
  | (AmultT ?X1 ?X2) =>
      strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2)
  | _ => idtac
  end.

Ltac inverse_test FT :=
  let AplusT := get_component Aplus FT in
  match goal with
  |  |- (?X1 = ?X2) => inverse_test_aux FT (AplusT X1 X2)
  end.

(**** Field itself ****)

Ltac apply_simplif sfun :=
  match goal with
  |  |- (interp_ExprA ?X1 ?X2 ?X3 = interp_ExprA _ _ _) =>
  sfun X1 X2 X3
  end;
   match goal with
   |  |- (interp_ExprA _ _ _ = interp_ExprA ?X1 ?X2 ?X3) =>
   sfun X1 X2 X3
   end.

Ltac unfolds FT :=
  match get_component Aminus FT with
  | Some ?X1 => unfold X1
  | _ => idtac
  end;
  match get_component Adiv FT with
  | Some ?X1 => unfold X1
  | _ => idtac
  end.

Ltac reduce FT :=
  let AzeroT := get_component Azero FT
  with AoneT := get_component Aone FT
  with AplusT := get_component Aplus FT
  with AmultT := get_component Amult FT
  with AoppT := get_component Aopp FT
  with AinvT := get_component Ainv FT in
  (cbv beta iota zeta delta -[AzeroT AoneT AplusT AmultT AoppT AinvT] ||
     compute).

Ltac field_gen_aux FT :=
  let AplusT := get_component Aplus FT in
  match goal with
  |  |- (?X1 = ?X2) =>
      let lvar := build_varlist FT (AplusT X1 X2) in
      let trm1 := interp_A FT lvar X1 with trm2 := interp_A FT lvar X2 in
      let mul := give_mult (EAplus trm1 trm2) in
      cut
        (let ft := FT in
         let vm := lvar in interp_ExprA ft vm trm1 = interp_ExprA ft vm trm2);
        [ compute; auto
        | intros ft vm; apply_simplif apply_distrib;
           apply_simplif apply_assoc; multiply mul;
           [ apply_simplif apply_multiply;
              apply_simplif ltac:(apply_inverse mul);
              (let id := grep_mult in
               clear id; weak_reduce; clear ft vm; first
              [ inverse_test FT; legacy ring | field_gen_aux FT ])
           | idtac ] ]
  end.

Ltac field_gen FT :=
  unfolds FT; (inverse_test FT; legacy ring) || field_gen_aux FT.

(*****************************)
(*    Term Simplification    *)
(*****************************)

(**** Minus and division expansions ****)

Ltac init_exp FT trm :=
  let e :=
   (match get_component Aminus FT with
    | Some ?X1 => eval cbv beta delta [X1] in trm
    | _ => trm
    end) in
  match get_component Adiv FT with
  | Some ?X1 => eval cbv beta delta [X1] in e
  | _ => e
  end.

(**** Inverses simplification ****)

Ltac simpl_inv trm :=
  match constr:(trm) with
  | (EAplus ?X1 ?X2) =>
      let e1 := simpl_inv X1 with e2 := simpl_inv X2 in
      constr:(EAplus e1 e2)
  | (EAmult ?X1 ?X2) =>
      let e1 := simpl_inv X1 with e2 := simpl_inv X2 in
      constr:(EAmult e1 e2)
  | (EAopp ?X1) => let e := simpl_inv X1 in
                   constr:(EAopp e)
  | (EAinv ?X1) => SimplInvAux X1
  | ?X1 => constr:(X1)
  end
 with SimplInvAux trm :=
  match constr:(trm) with
  | (EAinv ?X1) => simpl_inv X1
  | (EAmult ?X1 ?X2) =>
      let e1 := simpl_inv (EAinv X1) with e2 := simpl_inv (EAinv X2) in
      constr:(EAmult e1 e2)
  | ?X1 => let e := simpl_inv X1 in
           constr:(EAinv e)
  end.

(**** Monom simplification ****)

Ltac map_tactic fcn lst :=
  match constr:(lst) with
  | nil => lst
  | ?X2 :: ?X3 =>
      let r := fcn X2 with t := map_tactic fcn X3 in
      constr:(r :: t)
  end.

Ltac build_monom_aux lst trm :=
  match constr:(lst) with
  | nil => eval compute in (assoc trm)
  | ?X1 :: ?X2 => build_monom_aux X2 (EAmult trm X1)
  end.

Ltac build_monom lnum lden :=
  let ildn := map_tactic ltac:(fun e => constr:(EAinv e)) lden in
  let ltot := eval compute in (app lnum ildn) in
  let trm := build_monom_aux ltot EAone in
  match constr:(trm) with
  | (EAmult _ ?X1) => constr:(X1)
  | ?X1 => constr:(X1)
  end.

Ltac simpl_monom_aux lnum lden trm :=
  match constr:(trm) with
  | (EAmult (EAinv ?X1) ?X2) =>
      let mma := mem_assoc X1 lnum in
      match constr:(mma) with
      | true =>
          let newlnum := remove X1 lnum in
          simpl_monom_aux newlnum lden X2
      | false => simpl_monom_aux lnum (X1 :: lden) X2
      end
  | (EAmult ?X1 ?X2) =>
      let mma := mem_assoc X1 lden in
      match constr:(mma) with
      | true =>
          let newlden := remove X1 lden in
          simpl_monom_aux lnum newlden X2
      | false => simpl_monom_aux (X1 :: lnum) lden X2
      end
  | (EAinv ?X1) =>
      let mma := mem_assoc X1 lnum in
      match constr:(mma) with
      | true =>
          let newlnum := remove X1 lnum in
          build_monom newlnum lden
      | false => build_monom lnum (X1 :: lden)
      end
  | ?X1 =>
      let mma := mem_assoc X1 lden in
      match constr:(mma) with
      | true =>
          let newlden := remove X1 lden in
          build_monom lnum newlden
      | false => build_monom (X1 :: lnum) lden
      end
  end.

Ltac simpl_monom trm := simpl_monom_aux (@nil ExprA) (@nil ExprA) trm.

Ltac simpl_all_monomials trm :=
  match constr:(trm) with
  | (EAplus ?X1 ?X2) =>
      let e1 := simpl_monom X1 with e2 := simpl_all_monomials X2 in
      constr:(EAplus e1 e2)
  | ?X1 => simpl_monom X1
  end.

(**** Associativity and distribution ****)

Ltac assoc_distrib trm := eval compute in (assoc (distrib trm)).

(**** The tactic Field_Term ****)

Ltac eval_weak_reduce trm :=
  eval
   cbv beta iota zeta
    delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list A Azero Aone Aplus
          Amult Aopp Ainv] in trm.

Ltac field_term FT exp :=
  let newexp := init_exp FT exp in
  let lvar := build_varlist FT newexp in
  let trm := interp_A FT lvar newexp in
  let tma := eval compute in (assoc trm) in
  let tsmp :=
   simpl_all_monomials
    ltac:(assoc_distrib ltac:(simpl_all_monomials ltac:(simpl_inv tma))) in
  let trep := eval_weak_reduce (interp_ExprA FT lvar tsmp) in
  (replace exp with trep; [ legacy ring trep | field_gen FT ]).


Require Import Setoid.
Require Import DepList Memory.
Require Import Word.

Require Import List.

Module Type Heap.

  Parameter addr : Type.

  Parameter mem : Type.

  Parameter mem_get : mem -> addr -> option B.
  Parameter mem_set : mem -> addr -> B -> option mem.

  Parameter mem_acc : mem -> addr -> Prop.

  Parameter mem_get_acc : forall m p,
    mem_acc m p <->
    exists v, mem_get m p = Some v.

  Parameter mem_set_acc : forall m p,
    mem_acc m p <->
    forall v, exists m', mem_set m p v = Some m'.

  Parameter mem_acc_dec : forall m p,
    mem_acc m p \/ ~mem_acc m p.

  (** mem writes persist **)
  Parameter mem_get_set_eq : forall m p v' m',
    mem_set m p v' = Some m' ->
    mem_get m' p = Some v'.

  (** mem writes don't overwrite elsewhere **)
  Parameter mem_get_set_neq : forall m p p' v' m',
    p <> p' ->
    mem_set m p' v' = Some m' ->
    mem_get m' p = mem_get m p.

  (** mem writes don't modify permissions **)
  Parameter mem_set_perm : forall m p v m',
    mem_set m p v = Some m' ->
    (forall p, mem_acc m p -> mem_acc m' p).

  Parameter footprint_w : addr -> addr * addr * addr * addr.

  Parameter footprint_disjoint : forall p a b c d,
    footprint_w p = (a,b,c,d) ->
    a <> b /\ a <> c /\ a <> d /\ b <> c /\ b <> d /\ c <> d.

  Parameter addr_dec : forall a b : addr, {a = b} + {a <> b}.

  Parameter all_addr : list addr.

  Parameter NoDup_all_addr : NoDup all_addr.

End Heap.

Module HeapTheory (B : Heap).
  Import B.

  Definition smem' dom : Type := hlist (fun _ : addr => option B) dom.

  Fixpoint smem_emp' (ls : list addr) : smem' ls :=
    match ls with
      | nil => HNil
      | a :: b => HCons None (smem_emp' b)
    end.
  Fixpoint disjoint' dom : smem' dom -> smem' dom -> Prop :=
    match dom with
      | nil => fun _ _ => True
      | a :: b => fun m1 m2 =>
           (hlist_hd m1 = None \/ hlist_hd m2 = None)
        /\ disjoint' _ (hlist_tl m1) (hlist_tl m2)
    end.
  Fixpoint join' dom : smem' dom -> smem' dom -> smem' dom :=
    match dom with
      | nil => fun _ _ => HNil
      | a :: b => fun m1 m2 =>
        HCons
        match hlist_hd m1 with
          | None => hlist_hd m2
          | Some x => Some x
        end
        (join' _ (hlist_tl m1) (hlist_tl m2))
    end.

  Fixpoint relevant' (ls : list addr) : smem' ls -> list addr :=
    match ls with
      | nil => fun _ => nil
      | a :: b => fun x =>
        match hlist_hd x with
          | None => relevant' _ (hlist_tl x)
          | Some _ => a :: relevant' _ (hlist_tl x)
        end
    end.

  Fixpoint smem_get' dom : addr -> smem' dom -> option B :=
    match dom as dom return addr -> smem' dom -> option B with
      | nil => fun _ _ => None
      | a :: b => fun a' m =>
        if addr_dec a a' then
          hlist_hd m
        else
          smem_get' b a' (hlist_tl m)
    end.

  Fixpoint smem_set' dom : addr -> B -> smem' dom -> option (smem' dom) :=
    match dom as dom return addr -> B -> smem' dom -> option (smem' dom) with
      | nil => fun _ _ _ => None
      | a :: b => fun p v m =>
        if addr_dec a p then
          match hlist_hd m with
            | None => None
            | Some _ => Some (HCons (Some v) (hlist_tl m))
          end
        else
          match smem_set' b p v (hlist_tl m) with
            | None => None
            | Some tl => Some (HCons (hlist_hd m) tl)
          end
    end.

  Fixpoint satisfies' dom (sm : smem' dom) (m : B.mem) : Prop :=
    match sm with
      | HNil => True
      | HCons p _ a b =>
        match a with
          | None => True
          | Some x =>
               B.mem_get m p = Some x /\ mem_acc m p
        end /\ satisfies' _ b m
    end.

  Definition smem : Type := smem' all_addr.

  Definition smem_emp : smem := smem_emp' all_addr.

  Definition smem_get := @smem_get' all_addr.

  Definition smem_set := @smem_set' all_addr.

  Definition smem_get_word (implode : B * B * B * B -> W) (p : addr) (m : smem)
    : option W :=
    let '(a,b,c,d) := footprint_w p in
    match smem_get a m , smem_get b m , smem_get c m , smem_get d m with
      | Some a , Some b , Some c , Some d =>
        Some (implode (a,b,c,d))
      | _ , _ , _ , _ => None
    end.

  Definition smem_set_word (explode : W -> B * B * B * B) (p : addr) (v : W)
    (m : smem) : option smem :=
    let '(a,b,c,d) := footprint_w p in
    let '(av,bv,cv,dv) := explode v in
    match smem_set d dv m with
      | None => None
      | Some m => match smem_set c cv m with
                    | None => None
                    | Some m => match smem_set b bv m with
                                  | None => None
                                  | Some m => smem_set a av m
                                end
                  end
    end.

  Definition disjoint (m1 m2 : smem) : Prop :=
    disjoint' _ m1 m2.

  Definition join (m1 m2 : smem) : smem :=
    join' _ m1 m2.

  Definition split (m ml mr : smem) : Prop :=
    disjoint ml mr /\ m = join ml mr.

  Definition semp (m : smem) : Prop :=
    m = smem_emp.

  Definition satisfies (m : smem) (m' : B.mem) : Prop :=
    satisfies' _ m m'.

  Definition relevant (sm : smem) := relevant' _ sm.

  Global Instance EqDec_addr : EquivDec.EqDec addr (@eq addr) := addr_dec.

  Local Hint Resolve mem_get_set_eq mem_get_set_neq : memory.

  Lemma smem_set_not_in : forall l m p v,
    ~In p l -> smem_set' l p v m = None.
  Proof.
    induction l; simpl; auto.
      intros.
      destruct (addr_dec a p); subst; intuition.
      rewrite IHl; auto.
  Qed.

  Ltac simp ext :=
    intros; simpl in *;
    repeat (instantiate;
      match goal with
        | [ H : prod _ _ |- _ ] => destruct H
        | [ H : context [ footprint_w ?X ] |- _ ] =>
          destruct (footprint_w X)
        | [ H : Some _ = Some _ |- _ ] =>
          inversion H; clear H; try subst
        | [ H : _ = _ |- _ ] => rewrite H in *
        | [ H : NoDup (_ :: _) |- _ ] =>
          inversion H; clear H; subst
        | [ H : context [ addr_dec ?A ?B ] |- _ ] =>
          destruct (addr_dec A B); subst
        | [ |- context [ addr_dec ?A ?B ] ] =>
          destruct (addr_dec A B); subst
        | [ H : match ?X with
                  | Some _ => _
                  | None => _
                end = _ |- _ ] =>
          generalize dependent H; case_eq X; intros
        | [ H : match ?X with
                  | Some _ => _
                  | None => _
                end |- _ ] =>
          generalize dependent H; case_eq X; intros
        | [ H : satisfies' (_ :: _) ?M _ |- _ ] =>
          match M with
            | HCons _ _ => fail 1
            | _ => rewrite (hlist_eta _ M) in H
          end
        | [ |- satisfies' (_ :: _) ?M _ ] =>
          match M with
            | HCons _ _ => fail 1
            | _ => rewrite (hlist_eta _ M)
          end
        | [ H : smem' nil |- _ ] =>
          rewrite (hlist_nil_only _ H) in *
        | [ H : exists x, _ |- _ ] => destruct H
        | [ H : _ /\ _ |- _ ] => destruct H
        | [ |- _ ] => congruence
        | [ |- _ ] => ext
      end; simpl in *); eauto 10 with memory.

  Theorem satisfies_get : forall m m',
    satisfies m m' ->
    forall p v,
      smem_get p m = Some v ->
      mem_get m' p = Some v.
  Proof.
    unfold satisfies, smem_get, smem.
    induction all_addr; simp intuition.
  Qed.

  Lemma satisfies_set_not_in : forall l m sm p v,
    satisfies' l sm m ->
    ~In p l ->
    forall m', mem_set m p v = Some m' ->
    satisfies' l sm m'.
  Proof.
    induction l; try solve [ simp intuition ].
      simp auto.
      destruct (addr_dec a p); destruct (in_dec addr_dec p l); subst; try solve [ intuition ].

      split; eauto. erewrite mem_get_set_neq; eauto.
      split; eauto. eapply mem_set_perm; eauto.
  Qed.

  Local Hint Resolve mem_set_perm satisfies_set_not_in : memory.

  Theorem satisfies_set : forall sm m,
    satisfies sm m ->
    forall p v sm',
      smem_set p v sm = Some sm' ->
      exists m',
      mem_set m p v = Some m' /\ satisfies sm' m'.
  Proof.
    unfold satisfies, smem_set, smem_get, smem, relevant.
    generalize NoDup_all_addr.
    induction all_addr; simp auto.
      destruct (proj1 (mem_set_acc _ _) H2 v). rewrite H3. eexists; split; eauto.
      erewrite mem_get_set_eq; eauto with memory.

      Focus.
      eapply IHl in H1; eauto.
      destruct H1; eexists; intuition; eauto with memory.
      erewrite mem_get_set_neq; eauto.

      Focus.
      eapply IHl in H1; eauto. destruct H1; eexists; intuition eauto.
  Qed.

  Theorem satisfies_get_word : forall i m m',
    satisfies m m' ->
    forall p v,
      smem_get_word i p m = Some v ->
      mem_get_word addr mem footprint_w mem_get i p m' = Some v.
  Proof.
    unfold mem_get_word, smem_get_word; simp intuition.
    repeat erewrite satisfies_get by eauto. auto.
  Qed.

  Lemma smem_set_get_neq : forall p m m' a b,
    smem_set a b m = Some m' ->
    a <> p ->
    smem_get p m' = smem_get p m.
  Proof.
    unfold smem, smem_get, smem_set.
    induction all_addr; simp intuition.
  Qed.

  Lemma smem_set_get_eq : forall m m' a b,
    smem_set a b m = Some m' ->
    smem_get a m' = Some b.
  Proof.
    unfold smem, smem_get, smem_set.
    induction all_addr; simp intuition.
  Qed.

  Lemma smem_set_get_word_eq : forall i e m m' a b,
    (forall x, i (e x) = x) ->
    smem_set_word e a b m = Some m' ->
    smem_get_word i a m' = Some b.
  Proof.
    unfold smem_get_word, smem_set_word; intros.
    generalize (footprint_disjoint a).
    generalize dependent H0. case_eq (e b). simp intuition.
    specialize (H2 _ _ _ _ (refl_equal _)). simp intuition.
    repeat ((erewrite smem_set_get_eq; [ | repeat rewrite smem_set_get_neq by auto; eassumption ])
      || (erewrite smem_set_get_neq by eauto)). simp intuition.
  Qed.

  Lemma split_smem_get : forall a b c p v,
    split a b c ->
      (smem_get p b = Some v \/ smem_get p c = Some v) ->
      smem_get p a = Some v.
  Proof.
    unfold smem, split, disjoint, join, smem_get, smem.
    induction all_addr; simp intuition.
  Qed.

  Lemma split_smem_get_word : forall i a b c p v,
    split a b c ->
      (smem_get_word i p b = Some v \/ smem_get_word i p c = Some v) ->
      smem_get_word i p a = Some v.
  Proof.
    unfold smem_get_word. simp intuition;
    repeat (erewrite split_smem_get by eauto); auto.
  Qed.

  Theorem satisfies_set_word : forall sm m,
    satisfies sm m ->
    forall e p v sm',
      smem_set_word e p v sm = Some sm' ->
      exists m',
           mem_set_word addr mem footprint_w mem_set e p v m = Some m'
        /\ satisfies sm' m'.
  Proof.
    unfold smem_set_word, mem_set_word, smem_get_word; intros.
    simp intuition. destruct (e v); simp intuition.
    repeat match goal with
             | [ H : satisfies _ _ |- _ ] =>
               eapply satisfies_set in H; eauto; destruct H as [ ? [ ? ? ] ]
             | [ H : _ = _ |- _ ] => rewrite H
           end.
    exists x2. intuition eauto.
  Qed.

  Lemma smem_set_get_valid : forall m p v v',
    smem_get p m = Some v' ->
    smem_set p v m <> None.
  Proof.
    unfold smem_get, smem_set, smem.
    induction all_addr; simp intuition.
  Qed.

  Lemma smem_set_get_valid_word : forall i e m p v v',
    smem_get_word i p m = Some v' ->
    smem_set_word e p v m <> None.
  Proof.
    unfold smem_get_word, smem_set_word.
    intros. generalize (footprint_disjoint p).
    intros; destruct (e v); simp intuition;
    specialize (H0 _ _ _ _ (refl_equal _)); simp intuition;
    (eapply smem_set_get_valid; [ | eauto ];
      repeat (erewrite smem_set_get_neq; [ | solve [ eauto ] | solve [ eauto ] ]); eauto).
  Qed.

  Lemma split_set : forall a b,
    disjoint a b ->
    forall p v a',
    smem_set p v a = Some a' ->
      disjoint a' b /\
      smem_set p v (join a b) = Some (join a' b).
  Proof.
    unfold smem, disjoint, join, smem_set, smem.
    induction all_addr; simpl; intros; try congruence.
      destruct (addr_dec a p); subst.
      destruct H. destruct H; rewrite H in *; try congruence.
        destruct (hlist_hd a0); try congruence.
        inversion H0; auto.

      generalize dependent H0.
      case_eq (smem_set' l p v (hlist_tl a0)); intros; try congruence.
        inversion H1; clear H1; subst.
        eapply IHl in H0. 2: destruct H; eauto.
        simp intuition.
  Qed.

  Lemma split_set_word : forall a b,
    disjoint a b ->
    forall i p v a',
    smem_set_word i p v a = Some a' ->
      disjoint a' b /\
      smem_set_word i p v (join a b) = Some (join a' b).
  Proof.
    unfold smem_set_word.
    intros. destruct (i v); simp fail.
    repeat match goal with
      | [ H : smem_set _ _ _ = Some _ |- _ ] =>
        eapply split_set in H; [ rewrite (proj2 H) | eauto ]
    end; tauto.
  Qed.

  Ltac unfold_all :=
    unfold smem, split, join, disjoint, smem_emp, semp;
    unfold smem, split, join, disjoint, smem_emp, semp.
  Ltac break :=
    simpl; intros; try reflexivity;
      repeat (simpl in *; match goal with
                            | [ H : HCons _ _ = HCons _ _ |- _ ] =>
                              inversion H; clear H
                            | [ H : _ /\ _ |- _ ] => destruct H
                            | [ H : @existT _ _ _ _ = @existT _ _ _ _ |- _ ] =>
                              eapply (@Eqdep_dec.inj_pair2_eq_dec _ (list_eq_dec B.addr_dec)) in H
                            | [ H : @existT _ _ _ _ = @existT _ _ _ _ |- _ ] =>
                              eapply (@Eqdep_dec.inj_pair2_eq_dec _ B.addr_dec) in H
                            | [ H : _ = _ |- _ ] => rewrite H in *
                          end).

  Lemma disjoint_join : forall a b, disjoint a b -> join a b = join b a.
  Proof.
    unfold_all; induction a; break; f_equal; intuition; subst.
      destruct (hlist_hd b0); reflexivity.
      rewrite H1. destruct b; reflexivity.
  Qed.

  Lemma disjoint_comm : forall ml mr, disjoint ml mr -> disjoint mr ml.
  Proof.
    unfold_all; induction ml; break; intuition.
  Qed.

  Hint Resolve disjoint_join disjoint_comm : disjoint.

  Lemma split_assoc : forall b a c d e, split a b c -> split c d e ->
    split a (join d b) e.
  Proof.
    unfold_all; induction b; break; eauto.
    edestruct IHb. split; try eassumption. reflexivity. split; try eassumption.
    reflexivity.
    intuition; break; auto. destruct (hlist_hd d); auto.
    destruct (hlist_hd d); try congruence.
  Qed.

  Lemma split_comm : forall ml m mr, split m ml mr -> split m mr ml.
  Proof.
    unfold_all. induction ml; break; eauto. edestruct IHml.
    split; try eassumption. reflexivity.
    intuition; subst. rewrite H3. destruct (hlist_hd mr); auto.
    rewrite H4. rewrite H3. destruct b; auto.
  Qed.

  Lemma disjoint_split_join : forall a b, disjoint a b -> split (join a b) a b.
  Proof.
    unfold split, disjoint; intros; intuition.
  Qed.

  Lemma split_split_disjoint : forall b a c d e,
    split a b c -> split b d e -> disjoint c d.
  Proof.
    unfold_all. induction b; break. subst. split.
    intuition; destruct (hlist_hd c); eauto. destruct (hlist_hd d); auto.
    eapply IHb. split; auto. split; auto. auto.
  Qed.

  Lemma hlist_destruct : forall T (F : T -> Type) a b (m : hlist F (a :: b)),
    exists A, exists B, m = HCons A B.
  Proof.
    intros.
    refine (match m as m in hlist _ ls return
              match ls as ls return hlist _ ls -> Type with
                | nil => fun _ => unit
                | a :: b => fun m => exists A : F a, exists B : hlist F b, m = HCons A B
              end m
              with
              | HNil => tt
              | HCons _ _ _ _ => _
            end).
    do 2 eexists; reflexivity.
  Qed.
  Lemma hlist_nil : forall T (F : T -> Type) (m : hlist F nil), m = HNil.
  Proof.
    intros.
    refine (match m as m in hlist _ ls return
              match ls as ls return hlist _ ls -> Type with
                | nil => fun m => m = HNil
                | _ :: _ => fun _ => unit
              end m
              with
              | HNil => _
              | _ => tt
            end). reflexivity.
  Qed.

  Lemma split_semp : forall b a c,
    split a b c -> semp b -> a = c.
  Proof.
    unfold_all. unfold semp, smem_emp. unfold_all.
    induction b; simpl; intros; subst; auto.
    rewrite hlist_nil. rewrite (hlist_nil _ _ a). reflexivity.
    destruct (hlist_destruct _ _ _ _ a).
    destruct (hlist_destruct _ _ _ _ c).
    destruct H1. destruct H2. subst. specialize (IHb x2 x3).
    rewrite IHb; break; intuition; auto.
  Qed.

  Lemma semp_smem_emp : semp smem_emp.
  Proof.
    unfold semp, smem_emp; auto.
  Qed.

  Lemma split_a_semp_a : forall a,
    split a smem_emp a.
  Proof.
    unfold_all. induction a; simpl; intuition. rewrite <- H0. reflexivity.
  Qed.

  Lemma cons_not_in : forall T (a : T) b ls,
    a :: b = ls ->
    ~ In a ls ->
    forall P, P.
  Proof.
    intros; subst. exfalso; eapply H0. firstorder.
  Qed.

  Lemma relevant_in : forall a l b,
    In a (relevant' l b) ->
    In a l.
  Proof.
    induction l; auto; intros.
      rewrite (hlist_eta _ b) in H. simpl in H.
      destruct (hlist_hd b). destruct H. subst. firstorder.
      simpl in *. right. eapply IHl; eauto.
      right. eapply IHl; eauto.
  Qed.

  Lemma relevant_not_in : forall a l b,
    ~In a l ->
    ~In a (relevant' l b).
  Proof.
    intros. intro. eapply H. eapply relevant_in; eauto.
  Qed.

  Lemma relevant_eq : forall a b c,
    relevant a = relevant b ->
    satisfies a c ->
    satisfies b c ->
    a = b.
  Proof.
    unfold relevant, satisfies, smem. generalize NoDup_all_addr.
    induction all_addr; simpl; intros.
      rewrite (hlist_nil_only _ a). rewrite (hlist_nil_only _ b); auto.

      rewrite (hlist_eta _ a0) in *. rewrite (hlist_eta _ a0) in H1.
      rewrite (hlist_eta _ b) in *. rewrite (hlist_eta _ b) in H2.
      simpl in *.
      destruct (hlist_hd a0); destruct (hlist_hd b); intuition.
        rewrite H2 in H3. inversion H3; subst. inversion H0;  f_equal. eapply IHl; eauto.
          inversion H; auto.

        eapply cons_not_in. eassumption.
        eapply relevant_not_in. inversion H; auto.

        eapply cons_not_in. symmetry. eassumption.
        eapply relevant_not_in. inversion H; auto.

        f_equal; eauto. inversion H. eapply IHl; eauto.
  Qed.

  (** memoryIn **)
  Section memoryIn.
    Variable m : mem.

    Fixpoint memoryIn' (ls : list addr) : smem' ls :=
      match ls with
        | nil => HNil
        | l :: ls => HCons (mem_get m l) (memoryIn' ls)
      end.

    Definition memoryIn : smem := memoryIn' all_addr.
  End memoryIn.

  Theorem smem_set_relevant : forall p v sm sm',
    smem_set p v sm = Some sm' ->
    relevant sm = relevant sm'.
  Proof.
    unfold relevant, smem_set.
    induction all_addr; simpl; intros; auto.
      destruct (addr_dec a p); subst; auto.
      destruct (hlist_hd sm); try congruence.
      inversion H; clear H; subst. simpl. reflexivity.

      revert H. case_eq (smem_set' l p v (hlist_tl sm)); intros; try congruence.
      inversion H0; clear H0; subst; simpl in *.
      destruct (hlist_hd sm); eauto. f_equal; eauto.
  Qed.

  Theorem smem_set_word_relevant : forall ex p v sm sm',
    smem_set_word ex p v sm = Some sm' ->
    relevant sm = relevant sm'.
  Proof.
    unfold smem_set_word; intros.
    destruct (footprint_w p) as [ [ [ ? ? ] ? ] ? ].
    destruct (ex v) as [ [ [ ? ? ] ? ] ? ].
    repeat match goal with
             | [ H : match ?X with
                       | Some _ => _
                       | None => _
                     end = Some _ |- _ ] => revert H; case_eq X; intros; try congruence
             | [ H : smem_set _ _ _ = Some _ |- _ ] =>
               eapply smem_set_relevant in H
           end.
    congruence.
  Qed.

  Theorem satisfies_memoryIn : forall m,
    satisfies (memoryIn m) m.
  Proof.
    unfold satisfies, memoryIn. generalize all_addr.
    induction l; simpl; auto.
    intuition. destruct (mem_acc_dec m a).
    generalize (proj1 (mem_get_acc _ _) H). intro. destruct H0. rewrite H0. auto.
    case_eq (mem_get m a); intuition; auto.
    eapply mem_get_acc. eauto.
  Qed.

(*
Fixpoint memoryInUpto (width init : nat) (m : word width -> option B)
  : hlist (fun _ => option B) (allWordsUpto width init) :=
  match init with
    | O => HNil
    | S init' =>
      let w := natToWord width init' in
      let v := m w in
      HCons v (memoryInUpto (width := width) init' m)
  end.

Definition memoryIn_def (width : nat) :=
  memoryInUpto (width := width) (pow2 width).

Theorem fcong : forall A (B : A -> Type) (f g : forall x, B x) x,
  f = g
  -> f x = g x.
  congruence.
Defined.

Module Type ALL_WORDS.
  Parameter allWords : forall width : nat, list (word width).

  Axiom allWords_eq : allWords = allWords_def.

  Parameter memoryIn : forall width, (word width -> option B) -> hlist (fun _ : word width => option B) (allWords width).

  Axiom memoryIn_eq : forall width,
    memoryIn (width := width)
    = match fcong (fun width => list (word width)) width (sym_eq allWords_eq) in _ = L return _ -> hlist _ L with
        | refl_equal => memoryIn_def (width := width)
      end.
End ALL_WORDS.

Module AllWords : ALL_WORDS.
  Definition allWords := allWords_def.

  Theorem allWords_eq : allWords = allWords_def.
    reflexivity.
  Defined.

  Definition memoryIn := memoryIn_def.

  Theorem memoryIn_eq : forall width,
    memoryIn (width := width)
    = match fcong (fun width => list (word width)) width (sym_eq allWords_eq) in _ = L return _ -> hlist _ L with
        | refl_equal => memoryIn_def (width := width)
      end.
    reflexivity.
  Qed.
End AllWords.
*)

End HeapTheory.