(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.
Definition implb(x:bool) (y:bool): bool := match (x,
  y) with
  | (true, false) => false
  | (_, _) => true
  end.

Parameter pow2: Z -> Z.

Axiom Power_0 : ((pow2 0%Z) = 1%Z).

Axiom Power_s : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (n + 1%Z)%Z) = (2%Z * (pow2 n))%Z).

Axiom Power_1 : ((pow2 1%Z) = 2%Z).

Axiom Power_sum : forall (n:Z) (m:Z), ((0%Z <= n)%Z /\ (0%Z <= m)%Z) ->
  ((pow2 (n + m)%Z) = ((pow2 n) * (pow2 m))%Z).

Axiom pow2_0 : ((pow2 0%Z) = 1%Z).

Axiom pow2_1 : ((pow2 1%Z) = 2%Z).

Axiom pow2_2 : ((pow2 2%Z) = 4%Z).

Axiom pow2_3 : ((pow2 3%Z) = 8%Z).

Axiom pow2_4 : ((pow2 4%Z) = 16%Z).

Axiom pow2_5 : ((pow2 5%Z) = 32%Z).

Axiom pow2_6 : ((pow2 6%Z) = 64%Z).

Axiom pow2_7 : ((pow2 7%Z) = 128%Z).

Axiom pow2_8 : ((pow2 8%Z) = 256%Z).

Axiom pow2_9 : ((pow2 9%Z) = 512%Z).

Axiom pow2_10 : ((pow2 10%Z) = 1024%Z).

Axiom pow2_11 : ((pow2 11%Z) = 2048%Z).

Axiom pow2_12 : ((pow2 12%Z) = 4096%Z).

Axiom pow2_13 : ((pow2 13%Z) = 8192%Z).

Axiom pow2_14 : ((pow2 14%Z) = 16384%Z).

Axiom pow2_15 : ((pow2 15%Z) = 32768%Z).

Axiom pow2_16 : ((pow2 16%Z) = 65536%Z).

Axiom pow2_17 : ((pow2 17%Z) = 131072%Z).

Axiom pow2_18 : ((pow2 18%Z) = 262144%Z).

Axiom pow2_19 : ((pow2 19%Z) = 524288%Z).

Axiom pow2_20 : ((pow2 20%Z) = 1048576%Z).

Axiom pow2_21 : ((pow2 21%Z) = 2097152%Z).

Axiom pow2_22 : ((pow2 22%Z) = 4194304%Z).

Axiom pow2_23 : ((pow2 23%Z) = 8388608%Z).

Axiom pow2_24 : ((pow2 24%Z) = 16777216%Z).

Axiom pow2_25 : ((pow2 25%Z) = 33554432%Z).

Axiom pow2_26 : ((pow2 26%Z) = 67108864%Z).

Axiom pow2_27 : ((pow2 27%Z) = 134217728%Z).

Axiom pow2_28 : ((pow2 28%Z) = 268435456%Z).

Axiom pow2_29 : ((pow2 29%Z) = 536870912%Z).

Axiom pow2_30 : ((pow2 30%Z) = 1073741824%Z).

Axiom pow2_31 : ((pow2 31%Z) = 2147483648%Z).

Axiom pow2_32 : ((pow2 32%Z) = 4294967296%Z).

Axiom pow2_33 : ((pow2 33%Z) = 8589934592%Z).

Axiom pow2_34 : ((pow2 34%Z) = 17179869184%Z).

Axiom pow2_35 : ((pow2 35%Z) = 34359738368%Z).

Axiom pow2_36 : ((pow2 36%Z) = 68719476736%Z).

Axiom pow2_37 : ((pow2 37%Z) = 137438953472%Z).

Axiom pow2_38 : ((pow2 38%Z) = 274877906944%Z).

Axiom pow2_39 : ((pow2 39%Z) = 549755813888%Z).

Axiom pow2_40 : ((pow2 40%Z) = 1099511627776%Z).

Axiom pow2_41 : ((pow2 41%Z) = 2199023255552%Z).

Axiom pow2_42 : ((pow2 42%Z) = 4398046511104%Z).

Axiom pow2_43 : ((pow2 43%Z) = 8796093022208%Z).

Axiom pow2_44 : ((pow2 44%Z) = 17592186044416%Z).

Axiom pow2_45 : ((pow2 45%Z) = 35184372088832%Z).

Axiom pow2_46 : ((pow2 46%Z) = 70368744177664%Z).

Axiom pow2_47 : ((pow2 47%Z) = 140737488355328%Z).

Axiom pow2_48 : ((pow2 48%Z) = 281474976710656%Z).

Axiom pow2_49 : ((pow2 49%Z) = 562949953421312%Z).

Axiom pow2_50 : ((pow2 50%Z) = 1125899906842624%Z).

Axiom pow2_51 : ((pow2 51%Z) = 2251799813685248%Z).

Axiom pow2_52 : ((pow2 52%Z) = 4503599627370496%Z).

Axiom pow2_53 : ((pow2 53%Z) = 9007199254740992%Z).

Axiom pow2_54 : ((pow2 54%Z) = 18014398509481984%Z).

Axiom pow2_55 : ((pow2 55%Z) = 36028797018963968%Z).

Axiom pow2_56 : ((pow2 56%Z) = 72057594037927936%Z).

Axiom pow2_57 : ((pow2 57%Z) = 144115188075855872%Z).

Axiom pow2_58 : ((pow2 58%Z) = 288230376151711744%Z).

Axiom pow2_59 : ((pow2 59%Z) = 576460752303423488%Z).

Axiom pow2_60 : ((pow2 60%Z) = 1152921504606846976%Z).

Axiom pow2_61 : ((pow2 61%Z) = 2305843009213693952%Z).

Axiom pow2_62 : ((pow2 62%Z) = 4611686018427387904%Z).

Axiom pow2_63 : ((pow2 63%Z) = 9223372036854775808%Z).

Parameter size: Z.

Parameter bv : Type.

Axiom size_positive : (1%Z <  size)%Z.

Parameter nth: bv -> Z -> bool.

Parameter bvzero: bv.

Axiom Nth_zero : forall (n:Z), ((0%Z <= n)%Z /\ (n <  size)%Z) ->
  ((nth bvzero n) = false).

Parameter bvone: bv.

Axiom Nth_one : forall (n:Z), ((0%Z <= n)%Z /\ (n <  size)%Z) -> ((nth bvone
  n) = true).

Definition eq(v1:bv) (v2:bv): Prop := forall (n:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((nth v1 n) = (nth v2 n)).

Axiom extensionality : forall (v1:bv) (v2:bv), (eq v1 v2) -> (v1 = v2).

Parameter bw_and: bv -> bv -> bv.

Axiom Nth_bw_and : forall (v1:bv) (v2:bv) (n:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((nth (bw_and v1 v2) n) = (andb (nth v1 n) (nth v2 n))).

Parameter bw_or: bv -> bv -> bv.

Axiom Nth_bw_or : forall (v1:bv) (v2:bv) (n:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((nth (bw_or v1 v2) n) = (orb (nth v1 n) (nth v2 n))).

Parameter bw_xor: bv -> bv -> bv.

Axiom Nth_bw_xor : forall (v1:bv) (v2:bv) (n:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((nth (bw_xor v1 v2) n) = (xorb (nth v1 n) (nth v2 n))).

Axiom Nth_bw_xor_v1true : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n <  size)%Z) /\ ((nth v1 n) = true)) -> ((nth (bw_xor v1 v2)
  n) = (negb (nth v2 n))).

Axiom Nth_bw_xor_v1false : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n <  size)%Z) /\ ((nth v1 n) = false)) -> ((nth (bw_xor v1 v2)
  n) = (nth v2 n)).

Axiom Nth_bw_xor_v2true : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n <  size)%Z) /\ ((nth v2 n) = true)) -> ((nth (bw_xor v1 v2)
  n) = (negb (nth v1 n))).

Axiom Nth_bw_xor_v2false : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n <  size)%Z) /\ ((nth v2 n) = false)) -> ((nth (bw_xor v1 v2)
  n) = (nth v1 n)).

Parameter bw_not: bv -> bv.

Axiom Nth_bw_not : forall (v:bv) (n:Z), ((0%Z <= n)%Z /\ (n <  size)%Z) ->
  ((nth (bw_not v) n) = (negb (nth v n))).

Parameter lsr: bv -> Z -> bv.

Axiom lsr_nth_low : forall (b:bv) (n:Z) (s:Z), (((0%Z <= n)%Z /\
  (n <  size)%Z) /\ (((0%Z <= s)%Z /\ (s <  size)%Z) /\
  ((n + s)%Z <  size)%Z)) -> ((nth (lsr b s) n) = (nth b (n + s)%Z)).

Axiom lsr_nth_high : forall (b:bv) (n:Z) (s:Z), (((0%Z <= n)%Z /\
  (n <  size)%Z) /\ (((0%Z <= s)%Z /\ (s <  size)%Z) /\
  (size <= (n + s)%Z)%Z)) -> ((nth (lsr b s) n) = false).

Parameter asr: bv -> Z -> bv.

Axiom asr_nth_low : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((0%Z <= s)%Z -> (((n + s)%Z <  size)%Z -> ((nth (asr b
  s) n) = (nth b (n + s)%Z)))).

Axiom asr_nth_high : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((0%Z <= s)%Z -> ((size <= (n + s)%Z)%Z -> ((nth (asr b
  s) n) = (nth b (size - 1%Z)%Z)))).

Parameter lsl: bv -> Z -> bv.

Axiom lsl_nth_high : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((0%Z <= s)%Z -> ((0%Z <= (n - s)%Z)%Z -> ((nth (lsl b s)
  n) = (nth b (n - s)%Z)))).

Axiom lsl_nth_low : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n <  size)%Z) -> ((0%Z <= s)%Z -> (((n - s)%Z <  0%Z)%Z -> ((nth (lsl b s)
  n) = false))).

Parameter to_nat_sub: bv -> Z -> Z -> Z.

Axiom to_nat_sub_zero : forall (b:bv) (j:Z) (i:Z), (((0%Z <= i)%Z /\
  (i <= j)%Z) /\ (j <  size)%Z) -> (((nth b j) = false) -> ((to_nat_sub b j
  i) = (to_nat_sub b (j - 1%Z)%Z i))).

Axiom to_nat_sub_one : forall (b:bv) (j:Z) (i:Z), (((0%Z <= i)%Z /\
  (i <= j)%Z) /\ (j <  size)%Z) -> (((nth b j) = true) -> ((to_nat_sub b j
  i) = ((pow2 (j - i)%Z) + (to_nat_sub b (j - 1%Z)%Z i))%Z)).

Axiom to_nat_sub_high : forall (b:bv) (j:Z) (i:Z), (j <  i)%Z ->
  ((to_nat_sub b j i) = 0%Z).

Axiom to_nat_of_zero2 : forall (b:bv) (i:Z) (j:Z), (((j <  size)%Z /\
  (i <= j)%Z) /\ (0%Z <= i)%Z) -> ((forall (k:Z), ((k <= j)%Z /\
  (i <  k)%Z) -> ((nth b k) = false)) -> ((to_nat_sub b j
  0%Z) = (to_nat_sub b i 0%Z))).

Axiom to_nat_of_zero : forall (b:bv) (i:Z) (j:Z), (((j <  size)%Z /\
  (i <= j)%Z) /\ (0%Z <= i)%Z) -> ((forall (k:Z), ((k <= j)%Z /\
  (i <= k)%Z) -> ((nth b k) = false)) -> ((to_nat_sub b j i) = 0%Z)).

Axiom to_nat_of_one : forall (b:bv) (i:Z) (j:Z), (((j <  size)%Z /\
  (i <= j)%Z) /\ (0%Z <= i)%Z) -> ((forall (k:Z), ((k <= j)%Z /\
  (i <= k)%Z) -> ((nth b k) = true)) -> ((to_nat_sub b j
  i) = ((pow2 ((j - i)%Z + 1%Z)%Z) - 1%Z)%Z)).

Axiom to_nat_sub_footprint : forall (b1:bv) (b2:bv) (j:Z) (i:Z),
  ((j <  size)%Z /\ (0%Z <= i)%Z) -> ((forall (k:Z), ((i <= k)%Z /\
  (k <= j)%Z) -> ((nth b1 k) = (nth b2 k))) -> ((to_nat_sub b1 j
  i) = (to_nat_sub b2 j i))).

Parameter from_int: Z -> bv.

Axiom nth_from_int_high_even : forall (n:Z) (i:Z), (((i <  size)%Z /\
  (0%Z <= i)%Z) /\ ((int.EuclideanDivision.mod1 (int.EuclideanDivision.div n
  (pow2 i)) 2%Z) = 0%Z)) -> ((nth (from_int n) i) = false).

Axiom nth_from_int_high_odd : forall (n:Z) (i:Z), (((i <  size)%Z /\
  (0%Z <= i)%Z) /\
  ~ ((int.EuclideanDivision.mod1 (int.EuclideanDivision.div n (pow2 i))
  2%Z) = 0%Z)) -> ((nth (from_int n) i) = true).

Axiom nth_from_int_low_even : forall (n:Z), ((int.EuclideanDivision.mod1 n
  2%Z) = 0%Z) -> ((nth (from_int n) 0%Z) = false).

Axiom nth_from_int_low_odd : forall (n:Z), (~ ((int.EuclideanDivision.mod1 n
  2%Z) = 0%Z)) -> ((nth (from_int n) 0%Z) = true).

Axiom pow2i : forall (i:Z), (0%Z <= i)%Z -> ~ ((pow2 i) = 0%Z).

Axiom nth_from_int_0 : forall (i:Z), ((i <  size)%Z /\ (0%Z <= i)%Z) ->
  ((nth (from_int 0%Z) i) = false).

Parameter from_int2c: Z -> bv.

Axiom nth_sign_positive : forall (n:Z), (0%Z <= n)%Z -> ((nth (from_int2c n)
  (size - 1%Z)%Z) = false).

Axiom nth_sign_negative : forall (n:Z), (n <  0%Z)%Z -> ((nth (from_int2c n)
  (size - 1%Z)%Z) = true).

Axiom nth_from_int2c_high_even : forall (n:Z) (i:Z),
  (((i <  (size - 1%Z)%Z)%Z /\ (0%Z <= i)%Z) /\
  ((int.EuclideanDivision.mod1 (int.EuclideanDivision.div n (pow2 i))
  2%Z) = 0%Z)) -> ((nth (from_int2c n) i) = false).

Axiom nth_from_int2c_high_odd : forall (n:Z) (i:Z),
  (((i <  (size - 1%Z)%Z)%Z /\ (0%Z <= i)%Z) /\
  ~ ((int.EuclideanDivision.mod1 (int.EuclideanDivision.div n (pow2 i))
  2%Z) = 0%Z)) -> ((nth (from_int2c n) i) = true).

(* YOU MAY EDIT THE CONTEXT BELOW *)
Open Scope Z_scope.
(* DO NOT EDIT BELOW *)

Theorem nth_from_int2c_low_even : forall (n:Z),
  ((int.EuclideanDivision.mod1 n 2%Z) = 0%Z) -> ((nth (from_int2c n)
  0%Z) = false).
(* YOU MAY EDIT THE PROOF BELOW *)
intros.
rewrite nth_from_int2c_high_even.
auto.
split.
split.
generalize size_positive; omega.
auto with *.
rewrite pow2_0.
SearchAbout Zdiv.
rewrite int.EuclideanDivision.Div_1.
apply H.
Qed.
(* DO NOT EDIT BELOW *)


Require Core Front IR RTL CSE CP FirstOrder.

(** Putting it all together: the final compiler  *)

Definition fesic Phi t  (a : forall Var, Front.action Phi Var t) : RTL.Block Phi t :=
  let x := IR.Compile Phi  t a in
  let x := RTL.Compile Phi t x in
  let x := CSE.Compile Phi t  x in
  let x := CP.Compile Phi t x in                  (* We use the notation BDD.compile in the paper here *)
  let x := CSE.Compile Phi t  x in
  x.

(** The proof of the compiler relies on the so-called PHOAS axiom that
states that programs are really parametric in the choice of the
representations of variables. Past papers on PHOAS discuss the use
of this axiom:
- http://adam.chlipala.net/papers/PhoasICFP08/
- http://adam.chlipala.net/papers/ImpurePOPL10/

Note that we could alleviate our use of this axiom by proving that
compilation preserves a notion of well-formedness, and that every
source program is well-formed. *)

Axiom HWF : forall Phi t p, RTL.WF Phi t p.
Lemma fesic_correct (Phi : Core.state) t a :
  let block := fesic Phi t a in
  forall st,
    RTL.Next Phi st t block =
    Front.Next Phi st a.
Proof.
  unfold fesic. intros.
  repeat
    (first
    [
      rewrite CSE.Compile_correct by apply HWF|
      rewrite CP.Compile_correct by apply HWF]).

  rewrite RTL.Compile_correct.
  rewrite IR.Compile_correct.
  reflexivity.
Qed.

Definition Fesic Phi t src :=
  let x := (fesic Phi t src) in
  let x := FirstOrder.compile Phi t (x _ ) in
  Some x.


Require Import String.
Require Import RoshaskMsg.
Require Import ROSCOQ.message.
Require Import RoshaskTopic.

(**
To run a ROSCoq CPS using roshask, one has to provide some
   ROS(hask) specific implementation details.
   One has to map the payload types for ROSCoq topics to actual ROS message types whose
   Haskell and Coq files have already been generated using the roshask utility.
   Ideally, if one directly used ROS message types in ROSCoq, this mapping will be
   an identity function. However, one may wish to reason about a simplified datatype
   in ROSCoq. For examples, while reasoning, it is painful to worry about
   how data is encoded into bytes.

   One also has to map each topic to the string that represents the
   fully qualified name of the actual ROS topic.

*)

(*Inspired by CompCert. NoDup was not there perhaps.
  Perhaps finiteness of the Topic type is not needed. All we need
  is the finiteness of the collection of subscribed and published topics.
  They are already finite, as they are represented as lists.

  TODO:
  Add
  a NoDup condition in those lists, because the implmentation has to subscribe/publish
  to the topics one by one, and it does not make sense to subscribe/publish
  streams several times on a topic.

  What does roshask do if one tries to publish (or subscribe) multiple
  types on the same topic? What if different types of streams were used
   in the different attempts?
 *)
Definition FiniteC (T:Type) {deq : DecEq T} := {all:list T | NoDup all /\ forall t:T, In t all}.

Class RosHaskImplementable (Topic:Type) `{TopicClass Topic} :=
{
   topicImplType  : Topic -> Type (** Would Set suffice?*);
   topicImplTypeCorrect: forall (t:Topic), ROSMsgType (topicImplType t);
   (**ideally, identity, used when sending a message*)
   toImpl : forall (t:Topic), (topicType t) ->  (topicImplType t) ;
   (**ideally, identity, used when receiving a message*)
   fromImpl : forall (t:Topic), (topicImplType t) ->  (topicType t);

   rosQualName : Topic -> TopicName

}.

(** Given the above (possibly trivial) implementation details, we promise to run a software agent
    in a way specified by [SwSemantics]. *)

Require Import MathClasses.interfaces.monads.

Section RunSwAgent.
  Context (Topic:Type) `{TopicClass Topic} `{RosHaskImplementable Topic}.

  Require Import RoshaskNodeMonad.
  Require Import CoList.

  (** some helper functions *)
  Definition mkMsg (t:Topic) (rospayload : topicImplType t) : Message :=
    (existT _ t (fromImpl t rospayload), defHdr).

  Require Import MathClasses.interfaces.monads.
  Open Scope mc_scope.

  Instance fsldkjfkdsj  (t:Topic):  ROSMsgType (topicImplType t) := topicImplTypeCorrect t.

  Definition subscribeMsgCoList  (t:Topic) : Node (RTopic Message) :=
    strmIn  ← (subscribe (rosQualName t));
    ret (tmap (mkMsg t) strmIn). (* Perhaps define an instance of the  Functor typeclass and just say fmap instead of coMap *)

  Require Import MCInstances.
  Require Export MathClasses.misc.decision.

  Open Scope nat_scope.
  Require Omega.
  Definition subscribeMsgMultiple  (lt: list Topic) (p: 0 < length lt) : Node (RTopic Message).
    induction lt as [|h tlt]; [simpl in p; omega|].
    destruct tlt.
    - exact (subscribeMsgCoList h).
    - assert (0 < Datatypes.length (t :: tlt)) as pl. simpl. omega.
      apply IHtlt in pl.
      exact   (sh ←  subscribeMsgCoList h;
               stl ←  pl;
                ret (asapMerge sh stl)).
  Defined.

  Variable (sw: Process Message (list Message)). (** we are supposed to run this agent(node), using the API exported from roshask *)
    (** move to ROSCOQ.MsgHandler*)

  Variable tpInfo :  @TopicInfo Topic. (** which topics [sw] subscribes/publishes to*)

  Require Import decInstances.
  Require Import MathClasses.interfaces.abstract_algebra.
  Require Import RoshaskMsg.

  Definition updateDepMap `{DecEq A} {B: A -> Type} (init : forall a:A, B a) (a:A) (newb : B a) (x:A) : B x.
    destruct (decide (x≡a)).
    - rewrite e. exact newb.
    - exact (init x).
  Defined.

  Definition delayInMicros (m:Message) : Z :=
    let (num,den) := (delay (snd m)) * delayResolutionSecInv  in
     Zdiv num den.

  Definition delayMessages (rt: RTopic Message) : RTopic Message :=
    delayMsgsRoshask delayInMicros rt.

  (*  Definition TopicChannel := forall t:Topic, option (Chan (topicImplType t)).

  (** update if it was none.*)
  Definition lookupChan (tc : TopicChannel) (t:Topic) : Node ((Chan (topicImplType t))  × TopicChannel) :=
        match tc t with
          | Some c => ret (c, tc)
          | None => nc ← advertiseNewChan (rosQualName t);
                    ret (nc, updateDepMap tc t (Some nc))
        end.

  Definition publishMsgsStep (chans : TopicChannel)(m : Message) : Node TopicChannel :=
        let t := mtopic m in
          p ← lookupChan chans t;
          _ ← publishDelayedMsgOnChan (delayInMicros m) (fst p) (toImpl t (mPayload m));
          ret (snd p).

  Definition initTopicChan : TopicChannel := λ t, None.

  Definition publishMsgs (outMsgs: CoList Message) : Node unit :=
    _ ← coFoldLeft publishMsgsStep outMsgs initTopicChan; ret tt.
*)

  Definition filterTopic (t:Topic)
             (msgs : RTopic Message) : (RTopic (topicImplType t)).
    apply tfilter with (f:= fun m => bool_decide (mtopic m ≡ t));[ | exact msgs].
    intros a p.
    apply bool_decide_true in p.
    rewrite <- p. exact (toImpl (mtopic a) (mPayload a)).
  Defined.

  Fixpoint publishMsgsNoTiming  (lt: list Topic) (msgs: RTopic Message) : Node unit :=
    match lt with
      | nil => ret tt
      | h::tl =>
        _ ← (publish (rosQualName h) ((filterTopic h msgs)));
        publishMsgsNoTiming tl msgs
    end.

  Definition swap {A B: Type} (p: A * B) : B* A := (snd p, fst p).

  Definition procOutMsgs {I O : Type} (p : Process I O)
           (ins : RTopic I) : RTopic O :=
  @foldMapL (State p) I O (curState p) (fun s i => swap (handler p s i)) ins.

  Variable prf : (0 < Datatypes.length (fst tpInfo))%nat.

  Definition runSwNode : Node unit :=
    let (_, pubTopics) := tpInfo in
  inMsgs ← subscribeMsgMultiple (fst tpInfo) prf;
  publishMsgsNoTiming pubTopics (delayMessages (flattenTL (procOutMsgs sw inMsgs))).

End RunSwAgent.


Require Import
  Bank
  Bank_SN
  Bank_Proofs.

From Verdi Require Import
  Verdi
  SeqNum
  SeqNumCorrect.

From InfSeqExt Require Import
  infseq
  exteq.

Set Bullet Behavior "Strict Subproofs".

Section Bank_SN_Proofs.

  (* What about traces?? *)
  Theorem transformed_min_value_invariant :
    forall (net : bank_sn_network) tr,
      step_dup_star (params := bank_sn_multi_params) step_async_init net tr ->
      min_value_invariant_network (revertNetwork net).
  Proof using.
    intros.
    pose proof @true_in_reachable_transform _ bank_multi_params
               (fun net : network => min_value_invariant_network net)
               true_in_reachable_min_value.
    unfold true_in_reachable in *.
    apply H0. unfold reachable. eauto.
  Qed.

End Bank_SN_Proofs.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor Functor.Functor_Ops
        Functor.Representable.Hom_Func.
Require Import Functor.Functor_Extender.
Require Import NatTrans.NatTrans NatTrans.Operations
        NatTrans.Func_Cat NatTrans.NatIso.
Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations
        Ext_Cons.Prod_Cat.Nat_Facts.
Require Import KanExt.Local
        KanExt.LocalFacts.HomToCones
        KanExt.LocalFacts.ConesToHom.

Local Open Scope functor_scope.

(** This module contains facts about local kan extensions involving natural
    isomorphism. *)

(** Any two naturally isomorphic functors have the same kan extensions –
stated with hom functor definition of local kan extensions. *)
Section Hom_Local_Right_KanExt_Iso.
  Context {C C' : Category} {p : C –≻ C'}
          {D : Category} {F F' : C –≻ D}
          (N : (F' ≃ F)%natiso)
          (hlrke : Hom_Local_Right_KanExt p F).

  Definition Hom_Local_Right_KanExt_Iso : Hom_Local_Right_KanExt p F' :=
    {|
      HLRKE := hlrke;
      HLRKE_Iso :=
        (
          (HLRKE_Iso hlrke)
            ∘ (
              (Fix_Bi_Func_2_object_NatIso (Hom_Func (Func_Cat C D)) N)
               ∘_h (NatTrans_id_Iso (Left_Functor_Extender p D)^op)
            )
        )%isomorphism%natiso

    |}.

End Hom_Local_Right_KanExt_Iso.

(** Any two naturally isomorphic functors have the same kan extensions –
stated with cones definition of local kan extensions. *)
Section Local_Right_KanExt_Iso.
  Context {C C' : Category}
          {p : C –≻ C'}
          {D : Category}
          {F F' : C –≻ D}
          (N : (F' ≃ F)%natiso)
          (hlrke : Local_Right_KanExt p F).

  Definition Local_Right_KanExt_Iso : Local_Right_KanExt p F' :=
    Hom_Local_Right_KanExt_to_Local_Right_KanExt
      (Hom_Local_Right_KanExt_Iso
         N
         (Local_Right_KanExt_to_Hom_Local_Right_KanExt hlrke)
      ).

End Local_Right_KanExt_Iso.

(** If a functor is naturally isomorphic to the local right kan extension then
it also is local right kan extensions *)
Section Iso_Hom_Local_Right_KanExt.
  Context {C C' : Category}
          {p : C –≻ C'}
          {D : Category}
          {F : C –≻ D}
          {hlrke hlrke' : C' –≻ D}
          (N : (hlrke ≃ hlrke')%natiso)
          (ihlrke : Hom_Local_Right_KanExt_Isomorphism p F hlrke).

  Definition Iso_Hom_Local_Right_KanExt : Hom_Local_Right_KanExt p F :=
    {|
      HLRKE := hlrke';
      HLRKE_Iso :=
        ((Fix_Bi_Func_2_object_NatIso (Hom_Func (Func_Cat C' D)) N)
           ∘ ihlrke)%isomorphism
    |}.

End Iso_Hom_Local_Right_KanExt.

(** If a functor is naturally isomorphic to the local left kan extension then
it also is local left kan extensions – proven using duality. *)
Section Iso_Local_Right_KanExt.
  Context {C C' : Category}
          {p : C –≻ C'}
          {D : Category}
          {F : C –≻ D}
          {hlrke hlrke' : C' –≻ D}
          (N : (hlrke ≃ hlrke')%natiso)
          (ihlrke : is_Local_Right_KanExt p F hlrke).

  Definition  Iso_Local_Right_KanExt : is_Local_Right_KanExt p F hlrke' :=
    Local_Right_KanExt_is_Local_Right_KanExt
      _
      _
      (
        Hom_Local_Right_KanExt_to_Local_Right_KanExt
          (Iso_Hom_Local_Right_KanExt
             N
             (HLRKE_Iso
                (Local_Right_KanExt_to_Hom_Local_Right_KanExt
                   (is_Local_Right_KanExt_Local_Right_KanExt _ _ ihlrke)
                )
             )
          )
      ).

End Iso_Local_Right_KanExt.

(** Kan extension along any two naturally isomorphic functors is the same –
stated with hom functor definition of local kan extensions. *)
Section Hom_Local_Right_KanExt_Iso_along.
  Context {C C' : Category} {p p' : C –≻ C'}
          (N : (p' ≃ p )%natiso)
          {D : Category} {F : C –≻ D}
          (hlrke : Hom_Local_Right_KanExt p F).

  Program Definition Hom_Local_Right_KanExt_Iso_along
    : Hom_Local_Right_KanExt p' F :=
    {|
      HLRKE := hlrke;
      HLRKE_Iso :=
        (
          (HLRKE_Iso hlrke)
            ∘ (
              (NatTrans_id_Iso
                 (@Fix_Bi_Func_2
                    _ (Func_Cat C D) _ F (Hom_Func (Func_Cat C D))))
                ∘_h ((Left_Functor_Extender_Iso N D)^op)
            )
        )%isomorphism%natiso
    |}.

End Hom_Local_Right_KanExt_Iso_along.

(** Any two naturally isomorphic functors have the same kan extensions –
stated with cones definition of local kan extensions. *)
Section Local_Right_KanExt_Iso_along.
  Context {C C' : Category} {p p' : C –≻ C'}
          (N : (p' ≃ p)%natiso)
          {D : Category} {F : C –≻ D}
          (hlrke : Local_Right_KanExt p F).

  Definition Local_Right_KanExt_Iso_along : Local_Right_KanExt p' F :=
    Hom_Local_Right_KanExt_to_Local_Right_KanExt
      (Hom_Local_Right_KanExt_Iso_along
         N
         (Local_Right_KanExt_to_Hom_Local_Right_KanExt hlrke)
      ).

End Local_Right_KanExt_Iso_along.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Basic_Cons.Main.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat.
From Categories Require Import Coq_Cats.Type_Cat.Facts.
From Categories Require Import Algebras.Main.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat.
From Categories Require Import Cat.Facts.

Program Definition term_id : (Type_Cat –≻ (Type_Cat × Type_Cat))%functor :=
{|
  FO := fun a => (@CCC_term Type_Cat _, a);
  FA := fun a b f => (@id _ (@CCC_term Type_Cat _), f)
|}.

Definition S_nat_func : (Type_Cat –≻ Type_Cat)%functor :=
  ((+ᶠⁿᶜ Type_Cat _) ∘ term_id)%functor.

(* S_nat_func defined *)

Definition S_nat_alg_cat := Algebra_Cat S_nat_func.

Program Definition nat_alg : Algebra S_nat_func :=
{|
  Alg_Carrier := nat;
  Constructors :=
    fun x =>
      match x with
        | inl a => 0
        | inr n => S n
      end
|}.

(* morphism from nat_alg to another alg *)
Program Definition nat_alg_morph alg' : Algebra_Hom nat_alg alg' :=
  {|
    Alg_map :=
      fun x =>
        (fix f (n : nat) :=
        match n with
        | O => (Constructors alg') (inl tt)
        | S n' => (Constructors alg') (inr (f n'))
        end) x
  |}.

Next Obligation. (* alg_map_com *)
Proof.
  extensionality x.
  destruct x as [|[]]; cbn; trivial.
  repeat apply f_equal.
  match goal with [A : unit |- _] => destruct A; trivial end.
Qed.

Program Definition nat_alg_init : (𝟘_ S_nat_alg_cat)%object :=
  {|
    terminal := nat_alg;
    t_morph := nat_alg_morph
  |}.

Next Obligation.
Proof.
  destruct d as [algc algcons].
  destruct f as [f_morph f_com].
  destruct g as [g_morph g_com].
  apply Algebra_Hom_eq_simplify.
  extensionality x.
  simpl.
  induction x.
  {
    assert(H1 := equal_f f_com (inl tt)); cbv in H1; rewrite <- H1.
    assert(H2 := equal_f g_com (inl tt)); cbv in H2; rewrite <- H2.
    trivial.
  }
  {
    assert(H1 := equal_f f_com (inr x)); cbv in H1; rewrite <- H1.
    assert(H2 := equal_f g_com (inr x)); cbv in H2; rewrite <- H2.
    rewrite IHx.
    trivial.
  }
Qed.

CoInductive CoNat : Set :=
  | CoO : CoNat
  | CoS : CoNat -> CoNat
.

CoInductive CoNat_eq : CoNat -> CoNat -> Prop :=
  | CNOeq : CoNat_eq CoO CoO
  | CNSeq : forall (n n' : CoNat), CoNat_eq n n' -> CoNat_eq (CoS n) (CoS n')
.

Axiom CoNat_eq_eq : forall (n n' : CoNat), CoNat_eq n n' -> n = n'.

Definition S_nat_coalg_cat := @CoAlgebra_Cat Type_Cat S_nat_func.

Program Definition CoNat_coalg : @CoAlgebra Type_Cat S_nat_func :=
{|
  Alg_Carrier := CoNat;
  Constructors :=
    fun x : CoNat =>
       match x return unit + CoNat  with
       | CoO => inl tt
       | CoS x' => inr x'
       end
|}.

(* morphism from another alg to CoNat_coalg *)
Program Definition CoNat_coalg_morph coalg' : CoAlgebra_Hom CoNat_coalg coalg'
  :=
{|
  Alg_map :=
    cofix f (x : Alg_Carrier coalg') : CoNat :=
      match Constructors coalg' x return CoNat with
      | inl _ => CoO
      | inr s => CoS (f s)
      end
|}.

Next Obligation. (* coalg_map_com *)
Proof.
  extensionality x; cbn.
  destruct (Constructors coalg' x) as [x'|x']; cbn; trivial.
  replace x' with tt; trivial.
  cbn in *.
  match goal with [A : unit |- _] => destruct A; trivial end.
Qed.

(* CoNat_coalg_morph defined *)

(* The following two lemmas help go around Bug 5215. *)

Lemma inl_inr A B (x : A) (y : B) : inl x = inr y → False.
Proof.
  inversion 1.
Qed.

Lemma inr_inl A B (x : A) (y : B) : inr x = inl y → False.
Proof.
  inversion 1.
Qed.

Program Definition CoNat_alg_term : (𝟘_ S_nat_coalg_cat)%object :=
{|
  terminal := CoNat_coalg;
  t_morph := CoNat_coalg_morph
|}.

Next Obligation.
Proof.
  apply Algebra_Hom_eq_simplify.
  extensionality x; simpl.
  apply CoNat_eq_eq; revert x.
  cofix H.
  intros x.
  assert(H1 := equal_f (@Alg_map_com _ _ _ _ f) x); cbn in H1.
  assert(H2 := equal_f (@Alg_map_com _ _ _ _ g) x); cbn in H2.
  destruct (Constructors d x); destruct ((Alg_map f) x);
    destruct ((Alg_map g) x); try constructor;
      repeat match goal with
               H : _ = _ |- _ =>
               try (apply inl_inr in H || apply inr_inl in H); tauto
             end.
  inversion H1; inversion H2.
  trivial.
Qed.


Require Import Coq.micromega.Lia.
Require Import Coq.Arith.Arith.
Require Import Coq.Lists.List.
Require Export Crypto.Util.FixCoqMistakes.
Import ListNotations.
Local Set Implicit Arguments.
Local Open Scope list_scope.

Module List.
  Lemma filter_Forall_eq A f ls : @Forall A (fun x => f x = true) ls -> filter f ls = ls.
  Proof.
    induction 1; cbn; [ reflexivity | destruct f ]; try congruence.
  Qed.

  Lemma filter_length_le A f ls : List.length (@filter A f ls) <= List.length ls.
  Proof. induction ls; cbn; [ reflexivity | destruct f ]; cbn; auto with arith. Qed.

  Lemma filter_eq_length_eq A f ls : List.length (filter f ls) = List.length ls -> @filter A f ls = ls.
  Proof.
    induction ls; cbn; [ reflexivity | destruct f ]; cbn; intro; try apply f_equal; eauto with arith.
    pose proof (filter_length_le f ls).
    lia.
  Qed.

  Lemma Forall2_filter_same A B P f g lsA lsB
    : @Forall2 A B (fun a b => match f a, g b with
                               | true, true => P a b
                               | false, false => True
                               | true, false | false, true => False
                               end)
              lsA lsB
      -> Forall2 P (filter f lsA) (filter g lsB).
  Proof.
    induction 1; cbn; [ constructor | ].
    destruct f, g; try constructor; auto; try (exfalso; assumption).
  Qed.
End List.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *         Copyright INRIA, CNRS and contributors             *)
(* <O___,, * (see version control and CREDITS file for authors & dates) *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * Finite map library *)

(** This file proposes an implementation of the non-dependent interface
 [FMapInterface.S] using lists of pairs ordered (increasing) with respect to
 left projection. *)

Require Import Fairness.FMapInterface.
Require Import FunInd.

Set Implicit Arguments.
Unset Strict Implicit.

Module Raw (X:OrderedType).

Module Import MX := OrderedTypeFacts X.
Module Import PX := KeyOrderedType X.

Definition key := X.t.
Definition t (elt:Type) := list (X.t * elt).

Section Elt.
Variable elt : Type.

Notation eqk := (eqk (elt:=elt)).
Notation eqke := (eqke (elt:=elt)).
Notation ltk := (ltk (elt:=elt)).
Notation MapsTo := (MapsTo (elt:=elt)).
Notation In := (In (elt:=elt)).
Notation Sort := (sort ltk).
Notation Inf := (lelistA (ltk)).

(** * [empty] *)

Definition empty : t elt := nil.

Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m.

Lemma empty_1 : Empty empty.
Proof.
 unfold Empty,empty.
 intros a e.
 intro abs.
 inversion abs.
Qed.
#[local]
Hint Resolve empty_1 : core.

Lemma empty_sorted : Sort empty.
Proof.
 unfold empty; auto.
Qed.

(** * [is_empty] *)

Definition is_empty (l : t elt) : bool := if l then true else false.

Lemma is_empty_1 :forall m, Empty m -> is_empty m = true.
Proof.
 unfold Empty, PX.MapsTo.
 intros m.
 case m;auto.
 intros (k,e) l inlist.
 absurd (InA eqke (k, e) ((k, e) :: l)); auto with ordered_type.
Qed.

Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
Proof.
 intros m.
 case m;auto.
 intros p l abs.
 inversion abs.
Qed.

(** * [mem] *)

Function mem (k : key) (s : t elt) {struct s} : bool :=
 match s with
  | nil => false
  | (k',_) :: l =>
     match X.compare k k' with
      | LT _ => false
      | EQ _ => true
      | GT _ => mem k l
     end
 end.

Lemma mem_1 : forall m (Hm:Sort m) x, In x m -> mem x m = true.
Proof.
 intros m Hm x; generalize Hm; clear Hm.
 functional induction (mem x m);intros sorted belong1;trivial.

 inversion belong1. inversion H.

 absurd (In x ((k', _x) :: l));try assumption.
 apply Sort_Inf_NotIn with _x;auto.

 apply IHb.
 elim (sort_inv sorted);auto.
 elim (In_inv belong1);auto.
 intro abs.
 absurd (X.eq x k'); auto with ordered_type.
Qed.

Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m.
Proof.
 intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo.
 functional induction (mem x m); intros sorted hyp;try ((inversion hyp);fail).
 exists _x; auto with ordered_type.
 induction IHb; auto.
 exists x0; auto.
 inversion_clear sorted; auto.
Qed.

(** * [find] *)

Function find (k:key) (s: t elt) {struct s} : option elt :=
 match s with
  | nil => None
  | (k',x)::s' =>
     match X.compare k k' with
      | LT _ => None
      | EQ _ => Some x
      | GT _ => find k s'
     end
 end.

Lemma find_2 :  forall m x e, find x m = Some e -> MapsTo x e m.
Proof.
 intros m x. unfold PX.MapsTo.
 functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto with ordered_type.
Qed.

Lemma find_1 :  forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e.
Proof.
 intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo.
 functional induction (find x m);simpl; subst; try clear H_eq_1.

 inversion 2.

 inversion_clear 2.
 clear e1;compute in H0; destruct H0;order.
 clear e1;generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order.

 clear e1;inversion_clear 2.
 compute in H0; destruct H0; intuition congruence.
 generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order.

 clear e1; do 2 inversion_clear 1; auto.
 compute in H2; destruct H2; order.
Qed.

(** * [add] *)

Function add (k : key) (x : elt) (s : t elt) {struct s} : t elt :=
 match s with
  | nil => (k,x) :: nil
  | (k',y) :: l =>
     match X.compare k k' with
      | LT _ => (k,x)::s
      | EQ _ => (k,x)::l
      | GT _ => (k',y) :: add k x l
     end
 end.

Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m).
Proof.
 intros m x y e; generalize y; clear y.
 unfold PX.MapsTo.
 functional induction (add x e m);simpl;auto with ordered_type.
Qed.

Lemma add_2 : forall m x y e e',
  ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
Proof.
 intros m x  y e e'.
 generalize y e; clear y e; unfold PX.MapsTo.
 functional induction (add x e' m) ;simpl;auto;  clear e0.
 subst;auto.

 intros y' e'' eqky';  inversion_clear 1;  destruct H0; simpl in *.
 order.
 auto.
 auto.
 intros y' e'' eqky'; inversion_clear 1; intuition.
Qed.

Lemma add_3 : forall m x y e e',
  ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
Proof with auto with ordered_type.
 intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo.
 functional induction (add x e' m);simpl; intros.
 apply (In_inv_3 H0)...
 apply (In_inv_3 H0)...
 constructor 2; apply (In_inv_3 H0)...
 inversion_clear H0; auto.
Qed.

Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt),
  Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m).
Proof.
 induction m.
 simpl; intuition.
 intros.
 destruct a as (x'',e'').
 inversion_clear H.
 compute in H0,H1.
 simpl; case (X.compare x x''); intuition.
Qed.
#[local]
Hint Resolve add_Inf : core.

Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m).
Proof.
 induction m.
 simpl; intuition.
 intros.
 destruct a as (x',e').
 simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto.
 constructor; auto.
 apply Inf_eq with (x',e'); auto.
Qed.

(** * [remove] *)

Function remove (k : key) (s : t elt) {struct s} : t elt :=
 match s with
  | nil => nil
  | (k',x) :: l =>
     match X.compare k k' with
      | LT _ => s
      | EQ _ => l
      | GT _ => (k',x) :: remove k l
     end
 end.

Lemma remove_1 : forall m (Hm:Sort m) x y, X.eq x y -> ~ In y (remove x m).
Proof.
 intros m Hm x y; generalize Hm; clear Hm.
 functional induction (remove x m);simpl;intros;subst.

 red; inversion 1; inversion H1.

 apply Sort_Inf_NotIn with x0; auto.
 clear e0;constructor; compute; order.

 clear e0;inversion_clear Hm.
 apply Sort_Inf_NotIn with x0; auto.
 apply Inf_eq with (k',x0);auto; compute; apply X.eq_trans with x; auto with ordered_type.

 clear e0;inversion_clear Hm.
 assert (notin:~ In y (remove x l)) by auto.
 intros (x1,abs).
 inversion_clear abs.
 compute in H2; destruct H2; order.
 apply notin; exists x1; auto.
Qed.

Lemma remove_2 : forall m (Hm:Sort m) x y e,
  ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
Proof.
 intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
 functional induction (remove x m);subst;auto;
   match goal with
     | [H: X.compare _ _ = _ |- _ ] => clear H
     | _ => idtac
   end.

 inversion_clear 3; auto.
 compute in H1; destruct H1; order.

 inversion_clear 1; inversion_clear 2; auto.
Qed.

Lemma remove_3 : forall m (Hm:Sort m) x y e,
  MapsTo y e (remove x m) -> MapsTo y e m.
Proof.
 intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
 functional induction (remove x m);subst;auto.
 inversion_clear 1; inversion_clear 1; auto.
Qed.

Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt),
  Inf (x',e') m -> Inf (x',e') (remove x m).
Proof.
 induction m.
 simpl; intuition.
 intros.
 destruct a as (x'',e'').
 inversion_clear H.
 compute in H0.
 simpl; case (X.compare x x''); intuition.
 inversion_clear Hm.
 apply Inf_lt with (x'',e''); auto.
Qed.
#[local]
Hint Resolve remove_Inf : core.

Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m).
Proof.
 induction m.
 simpl; intuition.
 intros.
 destruct a as (x',e').
 simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto.
Qed.

(** * [elements] *)

Definition elements (m: t elt) := m.

Lemma elements_1 : forall m x e,
  MapsTo x e m -> InA eqke (x,e) (elements m).
Proof.
 auto.
Qed.

Lemma elements_2 : forall m x e,
  InA eqke (x,e) (elements m) -> MapsTo x e m.
Proof.
 auto.
Qed.

Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m).
Proof.
 auto.
Qed.

Lemma elements_3w : forall m (Hm:Sort m), NoDupA eqk (elements m).
Proof.
 intros.
 apply Sort_NoDupA.
 apply elements_3; auto.
Qed.

(** * [fold] *)

Function fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) {struct m} :  A :=
  match m with
   | nil => acc
   | (k,e)::m' => fold f m' (f k e acc)
  end.

Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A),
  fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
Proof.
 intros; functional induction (fold f m i); auto.
Qed.

(** * [equal] *)

Function equal (cmp:elt->elt->bool)(m m' : t elt) {struct m} : bool :=
  match m, m' with
   | nil, nil => true
   | (x,e)::l, (x',e')::l' =>
      match X.compare x x' with
       | EQ _ => cmp e e' && equal cmp l l'
       | _    => false
      end
   | _, _ => false
  end.

Definition Equivb cmp m m' :=
  (forall k, In k m <-> In k m') /\
  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).

Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp,
  Equivb cmp m m' -> equal cmp m m' = true.
Proof with auto with ordered_type.
 intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'.
 functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb;
 intuition; subst.
 match goal with H: X.compare _ _ = _ |- _ => clear H end.
 assert (cmp_e_e':cmp e e' = true).
  apply H1 with x...
 rewrite cmp_e_e'; simpl.
 apply IHb; auto.
 inversion_clear Hm; auto.
 inversion_clear Hm'; auto.
 unfold Equivb; intuition.
 destruct (H0 k).
 assert (In k ((x,e) ::l)).
  destruct H as (e'', hyp); exists e''...
 destruct (In_inv (H2 H4)); auto.
 inversion_clear Hm.
 elim (Sort_Inf_NotIn H6 H7).
 destruct H as (e'', hyp); exists e''; auto.
 apply MapsTo_eq with k; auto; order.
 destruct (H0 k).
 assert (In k ((x',e') ::l')).
  destruct H as (e'', hyp); exists e''...
 destruct (In_inv (H3 H4)); auto.
 inversion_clear Hm'.
 elim (Sort_Inf_NotIn H6 H7).
 destruct H as (e'', hyp); exists e''; auto.
 apply MapsTo_eq with k; auto; order.
 apply H1 with k; destruct (X.eq_dec x k)...

 destruct (X.compare x x') as [Hlt|Heq|Hlt]; try contradiction; clear y.
 destruct (H0 x).
 assert (In x ((x',e')::l')).
  apply H; auto.
  exists e...
 destruct (In_inv H3).
 order.
 inversion_clear Hm'.
 assert (Inf (x,e) l').
 apply Inf_lt with (x',e'); auto.
 elim (Sort_Inf_NotIn H5 H7 H4).

 destruct (H0 x').
 assert (In x' ((x,e)::l)).
  apply H2; auto.
  exists e'...
 destruct (In_inv H3).
 order.
 inversion_clear Hm.
 assert (Inf (x',e') l).
  apply Inf_lt with (x,e); auto.
 elim (Sort_Inf_NotIn H5 H7 H4).

 destruct m;
 destruct m';try contradiction.

 clear H1;destruct p as (k,e).
 destruct (H0 k).
 destruct H1.
 exists e...
 inversion H1.

 destruct p as (x,e).
 destruct (H0 x).
 destruct H.
 exists e...
 inversion H.

 destruct p;destruct p0;contradiction.
Qed.

Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp,
  equal cmp m m' = true -> Equivb cmp m m'.
Proof with auto with ordered_type.
 intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'.
 functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb;
  intuition; try discriminate; subst;
  try match goal with H: X.compare _ _ = _ |- _ => clear H end.

 inversion H0.

 inversion_clear Hm;inversion_clear Hm'.
 destruct (andb_prop _ _ H); clear H.
 destruct (IHb H1 H3 H6).
 destruct (In_inv H0).
 exists e'; constructor; split; trivial; apply X.eq_trans with x; auto.
 destruct (H k).
 destruct (H9 H8) as (e'',hyp).
 exists e''...

 inversion_clear Hm;inversion_clear Hm'.
 destruct (andb_prop _ _ H); clear H.
 destruct (IHb H1 H3 H6).
 destruct (In_inv H0).
 exists e; constructor; split; trivial; apply X.eq_trans with x'...
 destruct (H k).
 destruct (H10 H8) as (e'',hyp).
 exists e''...

 inversion_clear Hm;inversion_clear Hm'.
 destruct (andb_prop _ _ H); clear H.
 destruct (IHb H2 H4 H7).
 inversion_clear H0.
 destruct H9; simpl in *; subst.
 inversion_clear H1.
 destruct H9; simpl in *; subst; auto.
 elim (Sort_Inf_NotIn H4 H5).
 exists e'0; apply MapsTo_eq with k; auto; order.
 inversion_clear H1.
 destruct H0; simpl in *; subst; auto.
 elim (Sort_Inf_NotIn H2 H3).
 exists e0; apply MapsTo_eq with k; auto; order.
 apply H8 with k; auto.
Qed.

(** This lemma isn't part of the spec of [Equivb], but is used in [FMapAVL] *)

Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) ->
  eqk x y -> cmp (snd x) (snd y) = true ->
  (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)).
Proof.
 intros.
 inversion H; subst.
 inversion H0; subst.
 destruct x; destruct y; compute in H1, H2.
 split; intros.
 apply equal_2; auto.
 simpl.
 elim_comp.
 rewrite H2; simpl.
 apply equal_1; auto.
 apply equal_2; auto.
 generalize (equal_1 H H0 H3).
 simpl.
 elim_comp.
 rewrite H2; simpl; auto.
Qed.

Variable elt':Type.

(** * [map] and [mapi] *)

Fixpoint map (f:elt -> elt') (m:t elt) : t elt' :=
  match m with
   | nil => nil
   | (k,e)::m' => (k,f e) :: map f m'
  end.

Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' :=
  match m with
   | nil => nil
   | (k,e)::m' => (k,f k e) :: mapi f m'
  end.

End Elt.
Section Elt2.
(* A new section is necessary for previous definitions to work
   with different [elt], especially [MapsTo]... *)

Variable elt elt' : Type.

(** Specification of [map] *)

Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'),
  MapsTo x e m -> MapsTo x (f e) (map f m).
Proof.
 intros m x e f.
 (* functional induction map elt elt' f m.  *) (* Marche pas ??? *)
 induction m.
 inversion 1.

 destruct a as (x',e').
 simpl.
 inversion_clear 1.
 constructor 1.
 unfold eqke in *; simpl in *; intuition congruence.
 unfold MapsTo in *; auto.
Qed.

Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'),
  In x (map f m) -> In x m.
Proof.
 intros m x f.
 (* functional induction map elt elt' f m. *) (* Marche pas ??? *)
 induction m; simpl.
 intros (e,abs).
 inversion abs.

 destruct a as (x',e).
 intros hyp.
 inversion hyp. clear hyp.
 inversion H; subst; rename x0 into e'.
 exists e; constructor.
 unfold eqke in *; simpl in *; intuition.
 destruct IHm as (e'',hyp).
 exists e'; auto.
 exists e''.
 constructor 2; auto.
Qed.

Lemma map_lelistA : forall (m: t elt)(x:key)(e:elt)(e':elt')(f:elt->elt'),
  lelistA (@ltk elt) (x,e) m ->
  lelistA (@ltk elt') (x,e') (map f m).
Proof.
 induction m; simpl; auto.
 intros.
 destruct a as (x0,e0).
 inversion_clear H; auto.
Qed.

#[local]
Hint Resolve map_lelistA : core.

Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'),
  sort (@ltk elt') (map f m).
Proof.
 induction m; simpl; auto.
 intros.
 destruct a as (x',e').
 inversion_clear Hm.
 constructor; auto.
 exact (map_lelistA _ _ H0).
Qed.

(** Specification of [mapi] *)

Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'),
  MapsTo x e m ->
  exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m).
Proof.
 intros m x e f.
 (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
 induction m.
 inversion 1.

 destruct a as (x',e').
 simpl.
 inversion_clear 1.
 exists x'.
 destruct H0; simpl in *.
 split.
 auto with ordered_type.
 constructor 1.
 unfold eqke in *; simpl in *; intuition congruence.
 destruct IHm as (y, hyp); auto.
 exists y; intuition.
Qed.

Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'),
  In x (mapi f m) -> In x m.
Proof.
 intros m x f.
 (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
 induction m; simpl.
 intros (e,abs).
 inversion abs.

 destruct a as (x',e).
 intros hyp.
 inversion hyp. clear hyp.
 inversion H; subst; rename x0 into e'.
 exists e; constructor.
 unfold eqke in *; simpl in *; intuition.
 destruct IHm as (e'',hyp).
 exists e'; auto.
 exists e''.
 constructor 2; auto.
Qed.

Lemma mapi_lelistA : forall (m: t elt)(x:key)(e:elt)(f:key->elt->elt'),
  lelistA (@ltk elt) (x,e) m ->
  lelistA (@ltk elt') (x,f x e) (mapi f m).
Proof.
 induction m; simpl; auto.
 intros.
 destruct a as (x',e').
 inversion_clear H; auto.
Qed.

#[local]
Hint Resolve mapi_lelistA : core.

Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'),
  sort (@ltk elt') (mapi f m).
Proof.
 induction m; simpl; auto.
 intros.
 destruct a as (x',e').
 inversion_clear Hm; auto.
Qed.

End Elt2.
Section Elt3.

(** * [map2] *)

Variable elt elt' elt'' : Type.
Variable f : option elt -> option elt' -> option elt''.

Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) :=
  match o with
   | Some e => (k,e)::l
   | None => l
  end.

Fixpoint map2_l (m : t elt) : t elt'' :=
  match m with
   | nil => nil
   | (k,e)::l => option_cons k (f (Some e) None) (map2_l l)
  end.

Fixpoint map2_r (m' : t elt') : t elt'' :=
  match m' with
   | nil => nil
   | (k,e')::l' => option_cons k (f None (Some e')) (map2_r l')
  end.

Fixpoint map2 (m : t elt) : t elt' -> t elt'' :=
  match m with
   | nil => map2_r
   | (k,e) :: l =>
      fix map2_aux (m' : t elt') : t elt'' :=
        match m' with
         | nil => map2_l m
         | (k',e') :: l' =>
            match X.compare k k' with
             | LT _ => option_cons k (f (Some e) None) (map2 l m')
             | EQ _ => option_cons k (f (Some e) (Some e')) (map2 l l')
             | GT _ => option_cons k' (f None (Some e')) (map2_aux l')
            end
        end
  end.

Notation oee' := (option elt * option elt')%type.

Fixpoint combine (m : t elt) : t elt' -> t oee' :=
  match m with
   | nil => map (fun e' => (None,Some e'))
   | (k,e) :: l =>
      fix combine_aux (m':t elt') : list (key * oee') :=
        match m' with
         | nil => map (fun e => (Some e,None)) m
         | (k',e') :: l' =>
            match X.compare k k' with
             | LT _ => (k,(Some e, None))::combine l m'
             | EQ _ => (k,(Some e, Some e'))::combine l l'
             | GT _ => (k',(None,Some e'))::combine_aux l'
            end
        end
  end.

Definition fold_right_pair (A B C:Type)(f: A->B->C->C)(l:list (A*B))(i:C) :=
  List.fold_right (fun p => f (fst p) (snd p)) i l.

Definition map2_alt m m' :=
  let m0 : t oee' := combine m m' in
  let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in
  fold_right_pair (option_cons (A:=elt'')) m1 nil.

Lemma map2_alt_equiv : forall m m', map2_alt m m' = map2 m m'.
Proof.
 unfold map2_alt.
 induction m.
 simpl; auto; intros.
 (* map2_r *)
 induction m'; try destruct a; simpl; auto.
 rewrite IHm'; auto.
 (* fin map2_r *)
 induction m'; destruct a.
 simpl; f_equal.
 (* map2_l *)
 clear IHm.
 induction m; try destruct a; simpl; auto.
 rewrite IHm; auto.
 (* fin map2_l *)
 destruct a0.
 simpl.
 destruct (X.compare t0 t1); simpl; f_equal.
 apply IHm.
 apply IHm.
 apply IHm'.
Qed.

Lemma combine_lelistA :
  forall m m' (x:key)(e:elt)(e':elt')(e'':oee'),
  lelistA (@ltk elt) (x,e) m ->
  lelistA (@ltk elt') (x,e') m' ->
  lelistA (@ltk oee') (x,e'') (combine m m').
Proof.
 induction m.
 intros.
 simpl.
 exact (map_lelistA _ _ H0).
 induction m'.
 intros.
 destruct a.
 replace (combine ((t0, e0) :: m) nil) with
             (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto.
 exact (map_lelistA _ _ H).
 intros.
 simpl.
 destruct a as (k,e0); destruct a0 as (k',e0').
 destruct (X.compare k k').
 inversion_clear H; auto.
 inversion_clear H; auto.
 inversion_clear H0; auto.
Qed.
#[local]
Hint Resolve combine_lelistA : core.

Lemma combine_sorted :
  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'),
  sort (@ltk oee') (combine m m').
Proof.
 induction m.
 intros; clear Hm.
 simpl.
 apply map_sorted; auto.
 induction m'.
 intros; clear Hm'.
 destruct a.
 replace (combine ((t0, e) :: m) nil) with
             (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto.
 apply map_sorted; auto.
 intros.
 simpl.
 destruct a as (k,e); destruct a0 as (k',e').
 destruct (X.compare k k') as [Hlt|Heq|Hlt].
 inversion_clear Hm.
 constructor; auto.
 assert (lelistA (ltk (elt:=elt')) (k, e') ((k',e')::m')) by auto.
 exact (combine_lelistA _ H0 H1).
 inversion_clear Hm; inversion_clear Hm'.
 constructor; auto.
 assert (lelistA (ltk (elt:=elt')) (k, e') m') by (apply Inf_eq with (k',e'); auto).
 exact (combine_lelistA _ H0 H3).
 inversion_clear Hm; inversion_clear Hm'.
 constructor; auto.
 change (lelistA (ltk (elt:=oee')) (k', (None, Some e'))
                 (combine ((k,e)::m) m')).
 assert (lelistA (ltk (elt:=elt)) (k', e) ((k,e)::m)) by auto.
 exact (combine_lelistA _  H3 H2).
Qed.

Lemma map2_sorted :
  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'),
  sort (@ltk elt'') (map2 m m').
Proof.
 intros.
 rewrite <- map2_alt_equiv.
 unfold map2_alt.
 assert (H0:=combine_sorted Hm Hm').
 set (l0:=combine m m') in *; clearbody l0.
 set (f':= fun p : oee' => f (fst p) (snd p)).
 assert (H1:=map_sorted (elt' := option elt'') H0 f').
 set (l1:=map f' l0) in *; clearbody l1.
 clear f' f H0 l0 Hm Hm' m m'.
 induction l1.
 simpl; auto.
 inversion_clear H1.
 destruct a; destruct o; auto.
 simpl.
 constructor; auto.
 clear IHl1.
 induction l1.
 simpl; auto.
 destruct a; destruct o; simpl; auto.
 inversion_clear H0; auto.
 inversion_clear H0.
 red in H1; simpl in H1.
 inversion_clear H.
 apply IHl1; auto.
 apply Inf_lt with (t1, None (A:=elt'')); auto.
Qed.

Definition at_least_one (o:option elt)(o':option elt') :=
  match o, o' with
   | None, None => None
   | _, _  => Some (o,o')
  end.

Lemma combine_1 :
  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key),
  find x (combine m m') = at_least_one (find x m) (find x m').
Proof.
 induction m.
 intros.
 simpl.
 induction m'.
 intros; simpl; auto.
 simpl; destruct a.
 simpl; destruct (X.compare x t0); simpl; auto.
 inversion_clear Hm'; auto.
 induction m'.
 (* m' = nil *)
 intros; destruct a; simpl.
 destruct (X.compare x t0) as [Hlt| |Hlt]; simpl; auto.
 inversion_clear Hm; clear H0 Hlt Hm' IHm t0.
 induction m; simpl; auto.
 inversion_clear H.
 destruct a.
 simpl; destruct (X.compare x t0); simpl; auto.
 (* m' <> nil *)
 intros.
 destruct a as (k,e); destruct a0 as (k',e'); simpl.
 inversion Hm; inversion Hm'; subst.
 destruct (X.compare k k'); simpl;
  destruct (X.compare x k);
   elim_comp || destruct (X.compare x k'); simpl; auto.
 rewrite IHm; auto; simpl; elim_comp; auto.
 rewrite IHm; auto; simpl; elim_comp; auto.
 rewrite IHm; auto; simpl; elim_comp; auto.
 change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')).
 rewrite IHm'; auto.
 simpl find; elim_comp; auto.
 change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')).
 rewrite IHm'; auto.
 simpl find; elim_comp; auto.
 change (find x (combine ((k, e) :: m) m') =
         at_least_one (find x m) (find x m')).
 rewrite IHm'; auto.
 simpl find; elim_comp; auto.
Qed.

Definition at_least_one_then_f (o:option elt)(o':option elt') :=
  match o, o' with
   | None, None => None
   | _, _  => f o o'
  end.

Lemma map2_0 :
  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key),
  find x (map2 m m') = at_least_one_then_f (find x m) (find x m').
Proof.
 intros.
 rewrite <- map2_alt_equiv.
 unfold map2_alt.
 assert (H:=combine_1 Hm Hm' x).
 assert (H2:=combine_sorted Hm Hm').
 set (f':= fun p : oee' => f (fst p) (snd p)).
 set (m0 := combine m m') in *; clearbody m0.
 set (o:=find x m) in *; clearbody o.
 set (o':=find x m') in *; clearbody o'.
 clear Hm Hm' m m'.
 generalize H; clear H.
 match goal with |- ?m=?n -> ?p=?q =>
   assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end.
 induction m0; simpl in *; intuition.
 destruct o; destruct o'; simpl in *; try discriminate; auto.
 destruct a as (k,(oo,oo')); simpl in *.
 inversion_clear H2.
 destruct (X.compare x k) as [Hlt|Heq|Hlt]; simpl in *.
 (* x < k *)
 destruct (f' (oo,oo')); simpl.
 elim_comp.
 destruct o; destruct o'; simpl in *; try discriminate; auto.
 destruct (IHm0 H0) as (H2,_); apply H2; auto.
 rewrite <- H.
 case_eq (find x m0); intros; auto.
 assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))).
  red; auto.
 destruct (Sort_Inf_NotIn H0 (Inf_lt H4 H1)).
 exists p; apply find_2; auto.
 (* x = k *)
 assert (at_least_one_then_f o o' = f oo oo').
  destruct o; destruct o'; simpl in *; inversion_clear H; auto.
 rewrite H2.
 unfold f'; simpl.
 destruct (f oo oo'); simpl.
 elim_comp; auto.
 destruct (IHm0 H0) as (_,H4); apply H4; auto.
 case_eq (find x m0); intros; auto.
 assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))).
  red; auto with ordered_type.
 destruct (Sort_Inf_NotIn H0 (Inf_eq (eqk_sym H5) H1)).
 exists p; apply find_2; auto.
 (* k < x *)
 unfold f'; simpl.
 destruct (f oo oo'); simpl.
 elim_comp; auto.
 destruct (IHm0 H0) as (H3,_); apply H3; auto.
 destruct (IHm0 H0) as (H3,_); apply H3; auto.

 (* None -> None *)
 destruct a as (k,(oo,oo')).
 simpl.
 inversion_clear H2.
 destruct (X.compare x k) as [Hlt|Heq|Hlt].
 (* x < k *)
 unfold f'; simpl.
 destruct (f oo oo'); simpl.
 elim_comp; auto.
 destruct (IHm0 H0) as (_,H4); apply H4; auto.
 case_eq (find x m0); intros; auto.
 assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))).
  red; auto.
 destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)).
 exists p; apply find_2; auto.
 (* x = k *)
 discriminate.
 (* k < x *)
 unfold f'; simpl.
 destruct (f oo oo'); simpl.
 elim_comp; auto.
 destruct (IHm0 H0) as (_,H4); apply H4; auto.
 destruct (IHm0 H0) as (_,H4); apply H4; auto.
Qed.

(** Specification of [map2] *)

Lemma map2_1 :
  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key),
  In x m \/ In x m' ->
  find x (map2 m m') = f (find x m) (find x m').
Proof.
 intros.
 rewrite map2_0; auto.
 destruct H as [(e,H)|(e,H)].
 rewrite (find_1 Hm H).
 destruct (find x m'); simpl; auto.
 rewrite (find_1 Hm' H).
 destruct (find x m); simpl; auto.
Qed.

Lemma map2_2 :
  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key),
  In x (map2 m m') -> In x m \/ In x m'.
Proof.
 intros.
 destruct H as (e,H).
 generalize (map2_0 Hm Hm' x).
 rewrite (find_1 (map2_sorted Hm Hm') H).
 generalize (@find_2 _ m x).
 generalize (@find_2 _ m' x).
 destruct (find x m);
   destruct (find x m'); simpl; intros.
 left; exists e0; auto.
 left; exists e0; auto.
 right; exists e0; auto.
 discriminate.
Qed.

End Elt3.
End Raw.

Module Make (X: OrderedType) <: S with Module E := X.
Module Raw := Raw X.
Module E := X.

Definition key := E.t.

Record slist (elt:Type) :=
  {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}.
Definition t (elt:Type) : Type := slist elt.

Section Elt.
 Variable elt elt' elt'':Type.

 Implicit Types m : t elt.
 Implicit Types x y : key.
 Implicit Types e : elt.

 Definition empty : t elt := Build_slist (Raw.empty_sorted elt).
 Definition is_empty m : bool := Raw.is_empty (this m).
 Definition add x e m : t elt := Build_slist (Raw.add_sorted (sorted m) x e).
 Definition find x m : option elt := Raw.find x (this m).
 Definition remove x m : t elt := Build_slist (Raw.remove_sorted (sorted m) x).
 Definition mem x m : bool := Raw.mem x (this m).
 Definition map f m : t elt' := Build_slist (Raw.map_sorted (sorted m) f).
 Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_sorted (sorted m) f).
 Definition map2 f m (m':t elt') : t elt'' :=
   Build_slist (Raw.map2_sorted f (sorted m) (sorted m')).
 Definition elements m : list (key*elt) := @Raw.elements elt (this m).
 Definition cardinal m := length (this m).
 Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f (this m) i.
 Definition equal cmp m m' : bool := @Raw.equal elt cmp (this m) (this m').

 Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e (this m).
 Definition In x m : Prop := Raw.PX.In x (this m).
 Definition Empty m : Prop := Raw.Empty (this m).

 Definition Equal m m' := forall y, find y m = find y m'.
 Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
         (forall k, In k m <-> In k m') /\
         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
 Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp (this m) (this m').

 Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt.
 Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt.
 Definition lt_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.ltk elt.

 Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m.
 Proof. intros m; exact (@Raw.PX.MapsTo_eq elt (this m)). Qed.

 Lemma mem_1 : forall m x, In x m -> mem x m = true.
 Proof. intros m; exact (@Raw.mem_1 elt (this m) (sorted m)). Qed.
 Lemma mem_2 : forall m x, mem x m = true -> In x m.
 Proof. intros m; exact (@Raw.mem_2 elt (this m) (sorted m)). Qed.

 Lemma empty_1 : Empty empty.
 Proof. exact (@Raw.empty_1 elt). Qed.

 Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
 Proof. intros m; exact (@Raw.is_empty_1 elt (this m)). Qed.
 Lemma is_empty_2 :  forall m, is_empty m = true -> Empty m.
 Proof. intros m; exact (@Raw.is_empty_2 elt (this m)). Qed.

 Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m).
 Proof. intros m; exact (@Raw.add_1 elt (this m)). Qed.
 Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
 Proof. intros m; exact (@Raw.add_2 elt (this m)). Qed.
 Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
 Proof. intros m; exact (@Raw.add_3 elt (this m)). Qed.

 Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m).
 Proof. intros m; exact (@Raw.remove_1 elt (this m) (sorted m)). Qed.
 Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
 Proof. intros m; exact (@Raw.remove_2 elt (this m) (sorted m)). Qed.
 Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m.
 Proof. intros m; exact (@Raw.remove_3 elt (this m) (sorted m)). Qed.

 Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e.
 Proof. intros m; exact (@Raw.find_1 elt (this m) (sorted m)). Qed.
 Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
 Proof. intros m; exact (@Raw.find_2 elt (this m)). Qed.

 Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
 Proof. intros m; exact (@Raw.elements_1 elt (this m)). Qed.
 Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
 Proof. intros m; exact (@Raw.elements_2 elt (this m)). Qed.
 Lemma elements_3 : forall m, sort lt_key (elements m).
 Proof. intros m; exact (@Raw.elements_3 elt (this m) (sorted m)). Qed.
 Lemma elements_3w : forall m, NoDupA eq_key (elements m).
 Proof. intros m; exact (@Raw.elements_3w elt (this m) (sorted m)). Qed.

 Lemma cardinal_1 : forall m, cardinal m = length (elements m).
 Proof. intros; reflexivity. Qed.

 Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A),
        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
 Proof. intros m; exact (@Raw.fold_1 elt (this m)). Qed.

 Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true.
 Proof. intros m m'; exact (@Raw.equal_1 elt (this m) (sorted m) (this m') (sorted m')). Qed.
 Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'.
 Proof. intros m m'; exact (@Raw.equal_2 elt (this m) (sorted m) (this m') (sorted m')). Qed.

 End Elt.

 Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
        MapsTo x e m -> MapsTo x (f e) (map f m).
 Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' (this m)). Qed.
 Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
        In x (map f m) -> In x m.
 Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' (this m)). Qed.

 Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
        (f:key->elt->elt'), MapsTo x e m ->
        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
 Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' (this m)). Qed.
 Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
        (f:key->elt->elt'), In x (mapi f m) -> In x m.
 Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' (this m)). Qed.

 Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
	(x:key)(f:option elt->option elt'->option elt''),
	In x m \/ In x m' ->
        find x (map2 f m m') = f (find x m) (find x m').
 Proof.
 intros elt elt' elt'' m m' x f;
 exact (@Raw.map2_1 elt elt' elt'' f (this m) (sorted m) (this m') (sorted m') x).
 Qed.
 Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
	(x:key)(f:option elt->option elt'->option elt''),
        In x (map2 f m m') -> In x m \/ In x m'.
 Proof.
 intros elt elt' elt'' m m' x f;
 exact (@Raw.map2_2 elt elt' elt'' f (this m) (sorted m) (this m') (sorted m') x).
 Qed.

End Make.

Module Make_ord (X: OrderedType)(D : OrderedType) <:
Sord with Module Data := D
        with Module MapS.E := X.

Module Data := D.
Module MapS := Make(X).
Import MapS.

Module MD := OrderedTypeFacts(D).
Import MD.

Definition t := MapS.t D.t.

Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end.

Fixpoint eq_list (m m' : list (X.t * D.t)) : Prop :=
  match m, m' with
   | nil, nil => True
   | (x,e)::l, (x',e')::l' =>
      match X.compare x x' with
       | EQ _ => D.eq e e' /\ eq_list l l'
       | _       => False
      end
   | _, _ => False
  end.

Definition eq m m' := eq_list (this m) (this m').

Fixpoint lt_list (m m' : list (X.t * D.t)) : Prop :=
  match m, m' with
   | nil, nil => False
   | nil, _  => True
   | _, nil  => False
   | (x,e)::l, (x',e')::l' =>
      match X.compare x x' with
       | LT _ => True
       | GT _ => False
       | EQ _ => D.lt e e' \/ (D.eq e e' /\ lt_list l l')
      end
  end.

Definition lt m m' := lt_list (this m) (this m').

Lemma eq_equal : forall m m', eq m m' <-> equal cmp m m' = true.
Proof.
 intros (l,Hl); induction l.
 intros (l',Hl'); unfold eq; simpl.
 destruct l'; unfold equal; simpl; intuition.
 intros (l',Hl'); unfold eq.
 destruct l'.
 destruct a; unfold equal; simpl; intuition.
 destruct a as (x,e).
 destruct p as (x',e').
 unfold equal; simpl.
 destruct (X.compare x x') as [Hlt|Heq|Hlt]; simpl; intuition.
 unfold cmp at 1.
 MD.elim_comp; clear H; simpl.
 inversion_clear Hl.
 inversion_clear Hl'.
 destruct (IHl H (Build_slist H3)).
 unfold equal, eq in H5; simpl in H5; auto.
 destruct (andb_prop _ _ H); clear H.
 generalize H0; unfold cmp.
 MD.elim_comp; auto; intro; discriminate.
 destruct (andb_prop _ _ H); clear H.
 inversion_clear Hl.
 inversion_clear Hl'.
 destruct (IHl H (Build_slist H3)).
 unfold equal, eq in H6; simpl in H6; auto.
Qed.

Lemma eq_1 : forall m m', Equivb cmp m m' -> eq m m'.
Proof.
 intros.
 generalize (@equal_1 D.t m m' cmp).
 generalize (@eq_equal m m').
 intuition.
Qed.

Lemma eq_2 : forall m m', eq m m' -> Equivb cmp m m'.
Proof.
 intros.
 generalize (@equal_2 D.t m m' cmp).
 generalize (@eq_equal m m').
 intuition.
Qed.

Lemma eq_refl : forall m : t, eq m m.
Proof.
 intros (m,Hm); induction m; unfold eq; simpl; auto.
 destruct a.
 destruct (X.compare t0 t0) as [Hlt|Heq|Hlt]; auto.
 apply (MapS.Raw.MX.lt_antirefl Hlt); auto.
 split.
 apply D.eq_refl.
 inversion_clear Hm.
 apply (IHm H).
 apply (MapS.Raw.MX.lt_antirefl Hlt); auto.
Qed.

Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
Proof.
 intros (m,Hm); induction m;
 intros (m', Hm'); destruct m'; unfold eq; simpl;
 try destruct a as (x,e); try destruct p as (x',e'); auto.
 destruct (X.compare x x')  as [Hlt|Heq|Hlt]; MapS.Raw.MX.elim_comp; intuition.
 inversion_clear Hm; inversion_clear Hm'.
 apply (IHm H0 (Build_slist H4)); auto.
Qed.

Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
Proof.
 intros (m1,Hm1); induction m1;
 intros (m2, Hm2); destruct m2;
 intros (m3, Hm3); destruct m3; unfold eq; simpl;
 try destruct a as (x,e);
 try destruct p as (x',e');
 try destruct p0 as (x'',e''); try contradiction; auto.
 destruct (X.compare x x') as [Hlt|Heq|Hlt];
  destruct (X.compare x' x'') as [Hlt'|Heq'|Hlt'];
   MapS.Raw.MX.elim_comp; intuition.
 apply D.eq_trans with e'; auto.
 inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
 apply (IHm1 H1 (Build_slist H6) (Build_slist H8)); intuition.
Qed.

Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
Proof.
 intros (m1,Hm1); induction m1;
 intros (m2, Hm2); destruct m2;
 intros (m3, Hm3); destruct m3; unfold lt; simpl;
 try destruct a as (x,e);
 try destruct p as (x',e');
 try destruct p0 as (x'',e''); try contradiction; auto.
 destruct (X.compare x x') as [Hlt|Heq|Hlt];
  destruct (X.compare x' x'') as [Hlt'|Heq'|Hlt'];
   MapS.Raw.MX.elim_comp; intuition.
 left; apply D.lt_trans with e'; auto.
 left; apply lt_eq with e'; auto.
 left; apply eq_lt with e'; auto.
 right.
 split.
 apply D.eq_trans with e'; auto.
 inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
 apply (IHm1 H2 (Build_slist H6) (Build_slist H8)); intuition.
Qed.

Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.
Proof.
 intros (m1,Hm1); induction m1;
 intros (m2, Hm2); destruct m2; unfold eq, lt; simpl;
 try destruct a as (x,e);
 try destruct p as (x',e'); try contradiction; auto.
 destruct (X.compare x x') as [Hlt|Heq|Hlt]; auto.
 intuition.
 exact (D.lt_not_eq H0 H1).
 inversion_clear Hm1; inversion_clear Hm2.
 apply (IHm1 H0 (Build_slist H5)); intuition.
Qed.

Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto with ordered_type.

Definition compare : forall m1 m2, Compare lt eq m1 m2.
Proof.
 intros (m1,Hm1); induction m1;
 intros (m2, Hm2); destruct m2;
  [ apply EQ | apply LT | apply GT | ]; cmp_solve.
 destruct a as (x,e); destruct p as (x',e').
 destruct (X.compare x x');
  [ apply LT | | apply GT ]; cmp_solve.
 destruct (D.compare e e');
  [ apply LT | | apply GT ]; cmp_solve.
 assert (Hm11 : sort (Raw.PX.ltk (elt:=D.t)) m1).
  inversion_clear Hm1; auto.
 assert (Hm22 : sort (Raw.PX.ltk (elt:=D.t)) m2).
  inversion_clear Hm2; auto.
 destruct (IHm1 Hm11 (Build_slist Hm22));
  [ apply LT | apply EQ | apply GT ]; cmp_solve.
Qed.

End Make_ord.


Set Warnings "-notation-overridden,-parsing".
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Import ListNotations.

Require Import SF_Maps.
Require Import SF_Hoare.
Require Import SF_Equiv.

Require Import OBFS_opaque_predicate.
Require Import SF_Imp_Switch.

Print option.

(* ----------------------------------------------------------------------------------------------------------------- *)

(* Reformulating the if-statement flattening with Imppp2 and the new switching behaviour.  We make a few other changes

   1. Instead of building `getters` to break apart a program, we'll construct them from the ground up with
      preprocess_program and transformed_program functions.  This should make proofs more natural?

   2. This way, `preprocess_program` can also add dummy SWITCH assignments to the beginning and end of every
      program.  Maybe now we can finally prove cequiv proper? *)

Definition swVar : string := "swVar".

Definition preprocess_program header cond c1 c2 footer : com :=
  swVar ::= 0 ;;
  header ;;
  IFB cond THEN
    c1
  ELSE
    c2
  FI ;;
  footer ;;
  swVar ::= 5.

Definition transform_program header cond c1 c2 footer : com :=
  swVar ::= 0 ;;
  WHILE (swVar <= 4) DO
    SWITCH swVar [
      (0, header ;;
          swVar ::= 1) ;
      (1, IFB cond THEN
            swVar ::= 2
          ELSE
            swVar ::= 3
          FI) ;
      (2, c1 ;;
          swVar ::= 4) ;
      (3, c2 ;;
          swVar ::= 4) ;
      (4, footer ;;
          swVar ::= 5)
    ]
  END.

(* Same WorldEater example from before *)

Definition WorldEater : com :=
  IFB (X = 0) THEN
    SKIP
  ELSE
    X ::= 1
  FI.

Definition PreprocessWorldEater := preprocess_program SKIP (X = 0) SKIP (X ::= 1) SKIP.
Definition TransWorldEater := transform_program SKIP (X = 0) SKIP (X ::= 1) SKIP.

Compute PreprocessWorldEater.

Compute TransWorldEater.

Definition cequiv (c1 c2 : com) : Prop :=
  forall (st st' : state),
    (c1 / st \\ st') <-> (c2 / st \\ st').

(* Lemma: updating a variable twice is same as just updating the second value. *)

Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x,
    m & {x --> v1 ; x --> v2} = m & {x --> v2}.
Proof.
    intros A m v1 v2 x.  apply functional_extensionality.
    intro x0.  unfold t_update.  destruct (beq_string x x0) eqn:Heq.
    - reflexivity.
    - reflexivity.
  Qed.

(* Lemma we need: updating two different variables in a different order is the same thing. *)

Lemma t_update_comm : forall A (m: total_map A) v1 v2 x y,
    x <> y -> m & {x --> v1 ; y --> v2} = m & {y --> v2; x --> v1}.
  Proof.
    intros.  apply functional_extensionality.  intros.
    unfold t_update.  destruct (beq_string y x0) eqn:Heq.
    - destruct (beq_string x x0) eqn:Heq2.
      + rewrite beq_string_true_iff in *.  rewrite <- Heq2 in Heq.
        symmetry in Heq.  apply H in Heq.  inversion Heq.
      + auto.
    - destruct (beq_string x x0) eqn:Heq2.
      + auto.
      + auto.
  Qed.

(* Bona fide command equivalence of the example program and its transformed state, not just Hoare logic! *)

Example WorldEaterTransEquiv : cequiv PreprocessWorldEater TransWorldEater.
  Proof.
    unfold cequiv.  intros.  split.

      (* (I) Original -> Transformed. *)
      - unfold WorldEater, TransWorldEater.  unfold preprocess_program, transform_program.
        intro H.

      (* Break apart sequencing in hypothesis. *)
      inversion H; subst.  inversion H5; subst.  inversion H7; subst.  inversion H9; subst.

      (* Assert initial and final values of swVar *)
      assert (A0 : aeval st'0 swVar = 0).  inversion H2.  subst.  auto.
      assert (A5 : aeval st' swVar = 5).  inversion H11.  subst.  auto.

      (* Law of excluded middle: X is 0 or X is nonzero at point of branching statement *)
      destruct (beval (st'0 & {swVar --> 1}) (X = 0)) eqn:LEM.

        (* (I.i Case 1: X = 0. *)
        + eapply E_Seq.  apply H2.  eapply E_WhileTrue.
            * unfold beval.  rewrite A0.  auto.
            * eapply E_Switch.  auto.  rewrite A0.  simpl.  auto.  eapply E_Seq.
              apply E_Skip.  apply E_Ass.  auto.
            * simpl.  eapply E_WhileTrue.
              -- unfold beval.  simpl.  auto.
              -- eapply E_Switch.  auto.  simpl.  auto.  apply E_IfTrue.  assumption.
                 apply E_Ass.  auto.
              -- eapply E_WhileTrue.
                 ++ auto.
                 ++ eapply E_Switch.  auto.  simpl.  auto.  eapply E_Seq.  apply E_Skip.
                    apply E_Ass.  auto.
                 ++ simpl.  eapply E_WhileTrue.
                    ** auto.
                    ** eapply E_Switch.  auto.  simpl.  auto.  eapply E_Seq.  apply E_Skip.
                       apply E_Ass.  auto.
                    ** simpl.
                       assert (sameState : st'0 &
                         {swVar --> 1; swVar --> 2; swVar --> 4; swVar --> 5} = st').
                       { apply ceval_deterministic with
                         ((IFB X = 0 THEN SKIP ELSE X ::= 1 FI);; SKIP;; swVar ::= 5) st'0.
                             2: auto.  eapply E_Seq.  apply E_IfTrue.  auto.  apply E_Skip.
                                assert (sameState' : st'0 &
                                        {swVar --> 1; swVar --> 2; swVar --> 4; swVar --> 5}
                                         = st'0 & {swVar --> 5}).
                                  { rewrite t_update_shadow.  rewrite t_update_shadow.
                                    rewrite t_update_shadow.  auto. }
                                rewrite sameState'.  eapply E_Seq.  apply E_Skip.
                                apply E_Ass.  auto.  inversion H3.  subst.  auto. }
                       rewrite sameState.  eapply E_WhileFalse.
                       --- unfold beval.  rewrite A5.  auto.

         (* I.ii Case 2: X =/= 0 *)
         + eapply E_Seq.  apply H2.  eapply E_WhileTrue.
            * unfold beval.  rewrite A0.  auto.
            * eapply E_Switch.  auto.  rewrite A0.  simpl.  auto.  eapply E_Seq.
              apply E_Skip.  apply E_Ass.  auto.
            * simpl.  eapply E_WhileTrue.
              -- unfold beval.  simpl.  auto.
              -- eapply E_Switch.  auto.  simpl.  auto.  apply E_IfFalse.  assumption.
                 apply E_Ass.  auto.
              -- eapply E_WhileTrue.
                 ++ auto.
                 ++ eapply E_Switch.  auto.  simpl.  auto.  eapply E_Seq.  apply E_Ass.
                    auto.  apply E_Ass.  auto.
                 ++ simpl.  eapply E_WhileTrue.
                    ** auto.
                    ** eapply E_Switch.  auto.  simpl.  auto.  eapply E_Seq.
                       apply E_Skip.  apply E_Ass.  auto.
                    ** simpl.
                       assert (sameState : st'0 &
                               {swVar --> 1; swVar --> 3; X --> 1; swVar --> 4; swVar --> 5} = st').
                       { apply ceval_deterministic with
                         ((IFB X = 0 THEN SKIP ELSE X ::= 1 FI);; SKIP;; swVar ::= 5) st'0.
                             2: auto.  eapply E_Seq.  apply E_IfFalse.  auto.
                                apply E_Ass.  auto.  simpl.  eapply E_Seq.  apply E_Skip.
                                assert (sameState' :
                                  st'0 & {swVar --> 1; swVar --> 3; X --> 1; swVar --> 4; swVar --> 5} =
                                  st'0 & {X --> 1; swVar --> 5}).
                                  { rewrite t_update_shadow.  rewrite t_update_shadow.
                                    rewrite t_update_comm.  rewrite t_update_shadow.
                                    rewrite t_update_comm.  auto.  unfold not.  intro.
                                    inversion H0.  unfold not.  intro.  inversion H0. }
                                rewrite sameState'.  apply E_Ass.  auto.
                                inversion H3.  subst.  auto. }
                       rewrite sameState.  eapply E_WhileFalse.
                       --- unfold beval.  rewrite A5.  auto.

      (* (II) Transformed -> Original. *)
      - unfold TransWorldEater, WorldEater.  unfold transform_program, preprocess_program.  intro H.
        apply E_Seq with (st & {swVar --> 0}).  apply E_Ass.  auto.  eapply E_Seq.  apply E_Skip.

        (* Invoke LEM at this point *)
        destruct (beval (st & {swVar --> 0}) (X = 0)) eqn:LEM.

          (* II.i Case 1: X = 0 *)

          + eapply E_Seq.  apply E_IfTrue.  auto.  apply E_Skip.  eapply E_Seq.  apply E_Skip.
            assert (sameState : st & {swVar --> 0 ; swVar --> 5} = st').
            { apply ceval_deterministic with ((swVar ::= 0;;
              WHILE swVar <= 4
              DO SWITCH swVar
                [(0, SKIP;; swVar ::= 1);
                  (1, IFB X = 0 THEN swVar ::= 2 ELSE swVar ::= 3 FI);
                  (2, SKIP;; swVar ::= 4);
                  (3, X ::= 1;; swVar ::= 4);
                  (4, SKIP;; swVar ::= 5)] END)) st.
              2: auto.
              assert (sameState : st & {swVar --> 0; swVar --> 5} =
                st & {swVar --> 0 ; swVar --> 1 ; swVar --> 2 ; swVar --> 4 ; swVar --> 5}).
              { repeat (rewrite t_update_shadow).  auto. }
              rewrite sameState.  apply E_Seq with (st & {swVar --> 0}).
              apply E_Ass.  auto.

              (* While Loop *)
              eapply E_WhileTrue.  auto.  apply E_Switch with 0 (SKIP;; swVar ::= 1).
              auto.  auto.  eapply E_Seq.  apply E_Skip.  apply E_Ass.  auto.  simpl.

              eapply E_WhileTrue.  auto.
              apply E_Switch with 1 (IFB X = 0 THEN swVar ::= 2 ELSE swVar ::= 3 FI).
              auto.  auto.  apply E_IfTrue.  auto.  apply E_Ass.  auto.  simpl.

              eapply E_WhileTrue.  auto.  apply E_Switch with 2 (SKIP;; swVar ::= 4).
              auto.  auto.  eapply E_Seq.  apply E_Skip.  apply E_Ass.  auto.  simpl.

              eapply E_WhileTrue.  auto.  apply E_Switch with 4 (SKIP;; swVar ::= 5).
              auto.  auto.  eapply E_Seq.  apply E_Skip.  apply E_Ass.  auto.  simpl.

              eapply E_WhileFalse.  auto. }

              (* Now finish off the original program *)
              rewrite <- sameState.   apply E_Ass.  auto.

          (* II.ii Case 2: X =/= 0 *)

          + eapply E_Seq.  apply E_IfFalse.  auto.  apply E_Ass.  auto.  simpl.
            assert (sameState : st & {swVar --> 0 ; X --> 1 ; swVar --> 5} = st').
            { apply ceval_deterministic with ((swVar ::= 0;;
              WHILE swVar <= 4
              DO SWITCH swVar
                [(0, SKIP;; swVar ::= 1);
                  (1, IFB X = 0 THEN swVar ::= 2 ELSE swVar ::= 3 FI);
                  (2, SKIP;; swVar ::= 4);
                  (3, X ::= 1;; swVar ::= 4);
                  (4, SKIP;; swVar ::= 5)] END)) st.
              2: auto.
              assert (sameState : st & {swVar --> 0; X --> 1 ; swVar --> 5} =
                st & {swVar --> 0 ; swVar --> 1 ; swVar --> 3 ; X --> 1 ; swVar --> 4 ; swVar --> 5}).
              { repeat (rewrite t_update_shadow).  rewrite t_update_comm.
                rewrite t_update_shadow.  symmetry.  rewrite t_update_comm.
                rewrite t_update_shadow.  auto.  intro H0; inversion H0.
                intro H0; inversion H0. }
              rewrite sameState.

              apply E_Seq with (st & {swVar --> 0}).  apply E_Ass.  auto.

              (* While Loop *)
              eapply E_WhileTrue.  auto.  apply E_Switch with 0 (SKIP;; swVar ::= 1).
              auto.  auto.  eapply E_Seq.  apply E_Skip.  apply E_Ass.  auto.  simpl.

              eapply E_WhileTrue.  auto.
              apply E_Switch with 1 (IFB X = 0 THEN swVar ::= 2 ELSE swVar ::= 3 FI).
              auto.  auto.  apply E_IfFalse.  auto.  apply E_Ass.  auto.  simpl.

              eapply E_WhileTrue.  auto.
              apply E_Switch with 3 (X ::= 1 ;; swVar ::= 4).  auto.  auto.
              eapply E_Seq.  apply E_Ass.  auto.  apply E_Ass.  auto.  simpl.

              eapply E_WhileTrue.  auto.  apply E_Switch with 4 (SKIP;; swVar ::= 5).
              auto.  auto.  eapply E_Seq.  apply E_Skip.  apply E_Ass.  auto.  simpl.

              eapply E_WhileFalse.  auto. }

              (* Now finish off the original program *)
              rewrite <- sameState.  eapply E_Seq.  apply E_Skip.  apply E_Ass.  auto.
  Qed.

(* Generalize to the arbitrary case.

   We need to know that c1 and c2 don't use the switchVar in any way.  Actually expressing this is
   very messy, so let's come up with something else that encompasses the right idea - the notion of evaluation of a program being invariant
   from the state of a particular variable.  In other words, if the only thing about the state that changes is the value of some particular
   variable X, this has no impact on the rest of the state when evaluating this program.

   We also have to this invariance for the boolean guard condition - IE, the IF statement's evaluation also doesn't depend on swVar.
*)

Definition eval_invariant c X :=
  forall n st st', c / st \\ st' <-> c / st & { X --> n } \\ st' & { X --> n }.

Definition beval_invariant b X :=
  forall n st, beval st b = beval (st & { X --> n }) b.

(* Lemma: evaluation invariance implies evaluation independence *)

Lemma eval_inv_imp_eval_ind : forall c X n st st',
  eval_invariant c X ->
  c / st & { X --> n } \\ st' ->
  c / st \\ st'.
  Proof.
    intros.
      assert (c / (st & {X --> n}) & {X --> n} \\ st' & {X --> n}).
      apply H.  apply H0.  rewrite t_update_shadow in H1.  unfold eval_invariant in H.
      rewrite <- H in H1.  auto.
  Qed.

Theorem AllTransEquiv : forall header cond c1 c2 footer,
  eval_invariant c1 swVar -> eval_invariant c2 swVar ->
  eval_invariant footer swVar -> beval_invariant cond swVar ->
  cequiv (preprocess_program header cond c1 c2 footer)
    (transform_program header cond c1 c2 footer).
  Proof.
    unfold cequiv.   intros header cond c1 c2 footer HI1 HI2 HIf HB st st'.  split.

      (* (I) Preprocessed -> Transformed. *)
      - unfold preprocess_program, transform_program.  intro H.

      (* Break apart sequencing in hypothesis. *)
      inversion H; subst.  inversion H5; subst.
      inversion H7; subst.  inversion H9; subst.

      (* Assert initial and final values of swVar *)
      assert (A0 : aeval st'0 swVar = 0).  inversion H2.  subst.  auto.
      assert (A5 : aeval st' swVar = 5).  inversion H11.  subst.  auto.

      (* Law of excluded middle: cond is T or F at point of branching statement *)
      destruct (beval st'1 cond) eqn:LEM.

        (* I.i Case 1: cond is true *)
        + eapply E_Seq.  apply H2.  eapply E_WhileTrue.
            * unfold beval.  rewrite A0.  auto.
            * eapply E_Switch.  auto.  rewrite A0.  simpl.  auto.  eapply E_Seq.  simpl.
              apply H3.  apply E_Ass.  auto.
            * simpl.  eapply E_WhileTrue.
              -- unfold beval.  simpl.  auto.
              -- eapply E_Switch.  auto.  simpl.  auto.  apply E_IfTrue.  rewrite <- HB.
                 assumption.  apply E_Ass.  auto.
              -- eapply E_WhileTrue.
                 ++ auto.
                 ++ eapply E_Switch.  auto.  simpl.  auto.
                    apply E_Seq with (st'2 & { swVar --> 2 }).
                    simpl.  inversion H4.  rewrite t_update_shadow.
                    unfold eval_invariant in HI1.  rewrite <- HI1.  assumption.
                    rewrite H13 in LEM.  inversion LEM.  apply E_Ass.  auto.
                 ++ simpl.  eapply E_WhileTrue.
                    ** auto.
                    ** eapply E_Switch.  auto.  simpl.  auto.
                       apply E_Seq with (st'3 & { swVar --> 4 }).
                       rewrite t_update_shadow.  unfold eval_invariant in HIf.
                       rewrite <- HIf.  assumption.  apply E_Ass.  auto.
                    ** simpl.  rewrite t_update_shadow.
                       assert (sameState : st'3 & {swVar --> 5} = st').
                       { apply ceval_deterministic with
                           ((IFB cond THEN c1 ELSE c2 FI);; footer;; swVar ::= 5) st'1.
                             2: auto.  eapply E_Seq.  apply E_IfTrue.  auto.  simpl.
                                inversion H4.  apply H14.  rewrite H13 in LEM.
                                inversion LEM.  eapply E_Seq.  apply H6.  apply E_Ass.
                                auto. }
                       rewrite sameState.  eapply E_WhileFalse.
                       --- unfold beval.  rewrite A5.  auto.

         (* I.ii Case 2: X =/= 0 *)
         + eapply E_Seq.  apply H2.  eapply E_WhileTrue.
            * unfold beval.  rewrite A0.  auto.
            * eapply E_Switch.  auto.  rewrite A0.  simpl.  auto.  eapply E_Seq.
              apply H3.  apply E_Ass.  auto.
            * simpl.  eapply E_WhileTrue.
              -- unfold beval.  simpl.  auto.
              -- eapply E_Switch.  auto.  simpl.  auto.  apply E_IfFalse.  rewrite <- HB.
                 assumption.  apply E_Ass.  auto.
              -- eapply E_WhileTrue.
                 ++ auto.
                 ++ eapply E_Switch.  auto.  simpl.  auto.
                    apply E_Seq with (st'2 & { swVar --> 3 } ).  inversion H4.
                    rewrite H13 in LEM.  inversion LEM.  simpl.  rewrite t_update_shadow.
                    unfold eval_invariant in HI2.  rewrite <- HI2.  auto.
                    apply E_Ass.  auto.
                 ++ simpl.  eapply E_WhileTrue.
                    ** auto.
                    ** eapply E_Switch.  auto.  simpl.  auto.
                       apply E_Seq with (st'3 & {swVar --> 4 }).  rewrite t_update_shadow.
                       unfold eval_invariant in HIf.  rewrite <- HIf.  assumption.
                       apply E_Ass.  auto.
                    ** simpl.  rewrite t_update_shadow.
                       assert (sameState : st'3 & {swVar --> 5} = st').
                       { apply ceval_deterministic with
                           ((IFB cond THEN c1 ELSE c2 FI);; footer;; swVar ::= 5) st'1.
                             2: auto.  eapply E_Seq.  apply E_IfFalse.  auto.  simpl.
                             inversion H4.  rewrite H13 in LEM.  inversion LEM.
                             apply H14.  eapply E_Seq.  apply H6.  apply E_Ass.  auto. }
                       rewrite sameState.  eapply E_WhileFalse.
                       --- unfold beval.  rewrite A5.  auto.

       (* (II) Transformed -> Preprocessed. *)
      - unfold transform_program, preprocess_program.  intro H.
        apply E_Seq with (st & {swVar --> 0}).  apply E_Ass.  auto.

        (* Header isn't just SKIP anymore, so we have some work to do... *)

        inversion H.  subst.

        assert (sameState : st & {swVar --> 0} = st'0).
        { apply ceval_deterministic with (swVar ::= 0) st.  apply E_Ass.  auto.  auto. }
        subst.

        inversion H5.  subst.  simpl in H6.  inversion H6.  subst.  inversion H4.  subst.
        simpl in H7.  inversion H7.  rewrite <- H1 in H11.  inversion H11.  subst.
        eapply E_Seq.  apply H9.

        assert (sameState : st'1 & {swVar --> 1} = st'0).
        { apply ceval_deterministic with (swVar ::= 1) st'1.  apply E_Ass.  auto.  auto. }
        subst.

        (* Invoke LEM at this point *)
        destruct (beval st'1 cond) eqn:LEM.

          (* II.i Case 1: cond is true *)

            (* Fetch effects of c1 out of hypothesis...
               break down hypotheses to go through two iterations of while-switch. *)
            + inversion H8.  inversion H12.  subst.  inversion H10.  subst.
              simpl in H14.  inversion H14.  subst.  inversion H18.  subst.
              2: { rewrite <- HB in H19.  rewrite H19 in LEM.  inversion LEM. }

              assert (sameState : st'0 = st'1 & { swVar --> 1 ; swVar --> 2 }).
              { apply ceval_deterministic with (swVar ::= 2) (st'1 & {swVar --> 1}).
                auto.  apply E_Ass.  auto. }

              subst.  inversion H15.  subst.  inversion H17.  subst.  inversion H16.
              subst.  simpl in H21.  subst.  inversion H21.  subst.  inversion H25.
              subst.  rewrite t_update_shadow in H17.

              assert (c1 / st'1 \\ st'2).
              { apply eval_inv_imp_eval_ind with swVar 2.  auto.  auto. }

              eapply E_Seq.  apply E_IfTrue.  auto.  apply H0.

              (* Footer and close it off *)

              assert (sameState : st'0 = st'2 & { swVar --> 4 }).
              { apply ceval_deterministic with (swVar ::= 4) st'2.  auto.  apply E_Ass.
                auto. }
              subst.  inversion H22.  subst.  inversion H28.  inversion H27.  subst.
              simpl in H34.  inversion H34.  subst.  inversion H37.  subst.

              assert (footer / st'2 \\ st'3).
              { apply eval_inv_imp_eval_ind with swVar 4.  auto.  auto. }
              subst.

              inversion H30.  subst.
              assert (footer / st'2 \\ st'3).
              { apply eval_inv_imp_eval_ind with swVar 4.  auto.  auto. }

              eapply E_Seq.  apply H1.  apply H32.

              (* Impossible case of while loop true *)

              subst.  assert (sameState : st'0 = st'3 & { swVar --> 5 } ).
              { apply ceval_deterministic with (swVar ::= 5) st'3.
                auto.  apply E_Ass.  auto. }
                subst.  inversion H31.

           (* II.ii Case 2: cond is false *)

             (* Fetch effects of c2 out of hypothesis...
                break down hypotheses to go through two iterations of while-switch. *)
             + inversion H8.  inversion H12.  subst.  inversion H10.  subst.
               simpl in H14.  inversion H14.  subst.  inversion H18.  subst.
               rewrite <- HB in H19.  rewrite H19 in LEM.  inversion LEM.

               assert (sameState : st'0 = st'1 & { swVar --> 1 ; swVar --> 3 }).
               { apply ceval_deterministic with (swVar ::= 3) (st'1 & {swVar --> 1}).
                 auto.  apply E_Ass.  auto. }

               subst.  inversion H15.  subst.  inversion H17.  subst.  inversion H16.
               subst.  simpl in H21.  subst.  inversion H21.  subst.  inversion H25.
               subst.  rewrite t_update_shadow in H17.

               assert (c2 / st'1 \\ st'2).
               { apply eval_inv_imp_eval_ind with swVar 3.  auto.  auto. }

               eapply E_Seq.  apply E_IfFalse.  auto.  apply H0.

               (* Footer and close it off *)

               assert (sameState : st'0 = st'2 & { swVar --> 4 }).
               { apply ceval_deterministic with (swVar ::= 4) st'2.  auto.
                 apply E_Ass.  auto. }
               subst.  inversion H22.  subst.  inversion H28.  inversion H27.  subst.
               simpl in H34.  inversion H34.  subst.  inversion H37.  subst.

               assert (footer / st'2 \\ st'3).
               { apply eval_inv_imp_eval_ind with swVar 4.  auto.  auto. }

               inversion H30.  subst.
               assert (footer / st'2 \\ st'3).
               { apply eval_inv_imp_eval_ind with swVar 4.  auto.  auto. }

               eapply E_Seq.  apply H1.  apply H32.

               (* Impossible case of while loop true *)

               subst.  assert (sameState : st'0 = st'3 & { swVar --> 5 } ).
               { apply ceval_deterministic with (swVar ::= 5) st'3.
                 auto.  apply E_Ass.  auto. }
                 subst.  inversion H31.
  Qed.