Set Implicit Arguments.

Require Import Coq.Lists.List.
Require Import Coq.Relations.Relations.
Require Import Common.Types.
Require Import Bag.TotalOrder.
Require Import Bag.Bag2.
Require Import Common.AllDiff.
Require Import Common.Bisimulation.

Local Open Scope list_scope.
Local Open Scope equiv_scope.
Local Open Scope bag_scope.

Module Type NETWORK_ATOMS.

  Parameter packet : Type.
  Parameter switchId : Type.
  Parameter portId : Type.
  Parameter flowTable : Type.
  Parameter flowMod : Type.

  Inductive fromController : Type :=
  | PacketOut : portId -> packet -> fromController
  | BarrierRequest : nat -> fromController
  | FlowMod : flowMod -> fromController.

  Inductive fromSwitch : Type :=
  | PacketIn : portId -> packet -> fromSwitch
  | BarrierReply : nat -> fromSwitch.

  (** Produces a list of packets to forward out of ports, and a list of packets
      to send to the controller. *)
  Parameter process_packet : flowTable -> portId -> packet ->
    list (portId * packet) * list packet.

  Parameter modify_flow_table : flowMod -> flowTable -> flowTable.

  Parameter packet_le : Relation_Definitions.relation packet.
  Parameter switchId_le : Relation_Definitions.relation switchId.
  Parameter portId_le : Relation_Definitions.relation portId.
  Parameter flowTable_le : Relation_Definitions.relation flowTable.
  Parameter flowMod_le : Relation_Definitions.relation flowMod.
  Parameter fromSwitch_le : Relation_Definitions.relation fromSwitch.
  Parameter fromController_le : Relation_Definitions.relation fromController.

  Declare Instance TotalOrder_packet : TotalOrder packet_le.
  Declare Instance TotalOrder_switchId : TotalOrder switchId_le.
  Declare Instance TotalOrder_portId : TotalOrder portId_le.
  Declare Instance TotalOrder_flowTable : TotalOrder flowTable_le.
  Declare Instance TotalOrder_flowMod : TotalOrder flowMod_le.
  Declare Instance TotalOrder_fromSwitch : TotalOrder fromSwitch_le.
  Declare Instance TotalOrder_fromController : TotalOrder fromController_le.

End NETWORK_ATOMS.

Module Type NETWORK_AND_POLICY <: NETWORK_ATOMS.

  Include Type NETWORK_ATOMS.

  Parameter topo : switchId * portId -> option (switchId * portId).
  Parameter abst_func : switchId -> portId -> packet -> list (portId * packet).

End NETWORK_AND_POLICY.

(** Elements of a Featherweight OpenFlow model. *)
Module Type ATOMS <: NETWORK_AND_POLICY.

  Include NETWORK_AND_POLICY.

  Parameter controller : Type.

  Parameter controller_recv : controller -> switchId -> fromSwitch ->
    controller -> Prop.

  Parameter controller_step : controller -> controller -> Prop.

  Parameter controller_send : controller ->  controller -> switchId ->
    fromController -> Prop.

End ATOMS.

Module Type MACHINE.

  Declare Module Atoms : ATOMS.
  Import Atoms.

  Existing Instances TotalOrder_packet TotalOrder_switchId TotalOrder_portId
    TotalOrder_flowTable TotalOrder_flowMod TotalOrder_fromSwitch
    TotalOrder_fromController.

  (* Field names have two purposes. Coq creates selectors with these names,
     and also uses them to generate variable names in proofs. We spend
     more time in FwOF proofs, so we pick short names here. *)
  Record switch := Switch {
    swId : switchId;
    pts : list portId;
    tbl : flowTable;
    inp : bag (PairOrdering portId_le packet_le);
    outp :  bag (PairOrdering portId_le packet_le);
    ctrlm : bag fromController_le;
    switchm : bag fromSwitch_le
  }.

  Inductive switch_le : switch -> switch -> Prop :=
  | SwitchLe : forall sw1 sw2,
      switchId_le (swId sw1) (swId sw2) ->
      switch_le sw1 sw2.

  (* TODO(arjun): fix *)
  Declare Instance TotalOrder_switch : TotalOrder switch_le.

  Record dataLink := DataLink {
    src : switchId * portId;
    pks : list packet;
    dst : switchId * portId
  }.

  Record openFlowLink := OpenFlowLink {
    of_to : switchId;
    of_switchm : list fromSwitch;
    of_ctrlm : list fromController
  }.

  Definition observation := (switchId * portId * packet) %type.

  (* NOTE(arjun): Ask me in person why exactly I picked these levels. *)
  Reserved Notation "SwitchStep[ sw ; obs ; sw0 ]"
    (at level 70, no associativity).
  Reserved Notation "ControllerOpenFlow[ c ; l ; obs ; c0 ; l0 ]"
    (at level 70, no associativity).
  Reserved Notation "TopoStep[ sw ; link ; obs ; sw0 ; link0 ]"
    (at level 70, no associativity).
  Reserved Notation "SwitchOpenFlow[ s ; l ; obs ; s0 ; l0 ]"
    (at level 70, no associativity).

  Inductive NotBarrierRequest : fromController -> Prop :=
  | PacketOut_NotBarrierRequest : forall pt pk,
      NotBarrierRequest (PacketOut pt pk)
  | FlowMod_NotBarrierRequest : forall fm,
      NotBarrierRequest (FlowMod fm).

  (** Devices of the same type do not interact in a single
      step. Therefore, we never have to permute the lists below. If we
      instead had just one list of all devices, we would have to worry
      about permuting the list or define symmetric step-rules. *)
  Record state := State {
    switches : bag switch_le;
    links : list dataLink;
    ofLinks : list openFlowLink;
    ctrl : controller
  }.

  Inductive step : state -> option observation -> state -> Prop :=
  | PktProcess : forall swId pts tbl pt pk inp outp ctrlm switchm outp'
                        pksToCtrl,
    process_packet tbl pt pk = (outp', pksToCtrl) ->
    SwitchStep[
      Switch swId pts tbl ({|(pt,pk)|} <+> inp) outp ctrlm switchm;
      Some (swId,pt,pk);
      Switch swId pts tbl inp (from_list outp' <+> outp)
        ctrlm (from_list (map (PacketIn pt) pksToCtrl) <+> switchm)
    ]
  | ModifyFlowTable : forall swId pts tbl inp outp fm ctrlm switchm,
    SwitchStep[
      Switch swId pts tbl inp outp ({|FlowMod fm|} <+> ctrlm) switchm;
      None;
      Switch swId pts (modify_flow_table fm tbl) inp outp ctrlm switchm
    ]
  (** We add the packet to the output-buffer, even if its port is invalid.
      Packets with invalid ports will simply accumulate in the output buffer,
      since the SendDataLink rule only pulls out packets with valid ports.
      This is reasonable for now. The right fix is to add support for OpenFlow
      errors. *)
  | SendPacketOut : forall pt pts swId tbl inp outp pk ctrlm switchm,
    SwitchStep[
      Switch swId pts tbl inp outp  ({|PacketOut pt pk|} <+> ctrlm) switchm;
      None;
      Switch swId pts tbl inp ({| (pt,pk) |} <+> outp) ctrlm switchm
    ]
  | SendDataLink : forall swId pts tbl inp pt pk outp ctrlm switchm pks dst,
    TopoStep[
      Switch swId pts tbl inp ({|(pt,pk)|} <+> outp) ctrlm switchm;
      DataLink (swId,pt) pks dst;
      None;
      Switch swId pts tbl inp outp ctrlm switchm;
      DataLink (swId,pt) (pk :: pks) dst
    ]
  | RecvDataLink : forall swId pts tbl inp outp ctrlm switchm src pks pk pt,
    TopoStep[
      Switch swId pts tbl inp outp ctrlm switchm;
      DataLink src  (pks ++ [pk]) (swId,pt);
      None;
      Switch swId pts tbl ({|(pt,pk)|} <+> inp) outp ctrlm switchm;
      DataLink src pks (swId,pt)
    ]
  | Step_controller : forall sws links ofLinks ctrl ctrl',
    controller_step ctrl ctrl' ->
    step (State sws links ofLinks ctrl)
         None
         (State sws links ofLinks ctrl')
  | ControllerRecv : forall ctrl msg ctrl' swId fromSwitch fromCtrl,
    controller_recv ctrl swId msg ctrl' ->
    ControllerOpenFlow[
      ctrl;
      OpenFlowLink swId (fromSwitch ++ [msg]) fromCtrl;
      None;
      ctrl';
      OpenFlowLink swId fromSwitch fromCtrl
    ]
  | ControllerSend : forall ctrl msg ctrl' swId fromSwitch fromCtrl,
    controller_send ctrl ctrl' swId msg ->
    ControllerOpenFlow[
      ctrl ;
      (OpenFlowLink swId fromSwitch fromCtrl);
      None;
      ctrl';
      (OpenFlowLink swId fromSwitch (msg :: fromCtrl)) ]
  | SendToController : forall swId pts tbl inp outp ctrlm msg switchm fromSwitch
      fromCtrl,
    SwitchOpenFlow[
      Switch swId pts tbl inp outp ctrlm ({| msg |} <+> switchm);
      OpenFlowLink swId fromSwitch fromCtrl;
      None;
      Switch swId pts tbl inp outp ctrlm switchm;
      OpenFlowLink swId (msg :: fromSwitch) fromCtrl
    ]
  | RecvBarrier : forall swId pts tbl inp outp switchm fromSwitch fromCtrl
      xid,
    SwitchOpenFlow[
      Switch swId pts tbl inp outp empty switchm;
      OpenFlowLink swId fromSwitch (fromCtrl ++ [BarrierRequest xid]);
      None;
      Switch swId pts tbl inp outp empty
             ({| BarrierReply xid |} <+> switchm);
      OpenFlowLink swId fromSwitch fromCtrl
    ]
  | RecvFromController : forall swId pts tbl inp outp ctrlm switchm
      fromSwitch fromCtrl msg,
    NotBarrierRequest msg ->
    SwitchOpenFlow[
      Switch swId pts tbl inp outp ctrlm switchm;
      OpenFlowLink swId fromSwitch (fromCtrl ++ [msg]);
      None;
      Switch swId pts tbl inp outp ({| msg |} <+> ctrlm) switchm;
      OpenFlowLink swId fromSwitch fromCtrl
    ]
      where
  "ControllerOpenFlow[ c ; l ; obs ; c0 ; l0 ]" :=
    (forall sws links ofLinks ofLinks',
      step (State sws links (ofLinks ++ l :: ofLinks') c)
           obs
           (State sws links (ofLinks ++ l0 :: ofLinks') c0))
    and
  "TopoStep[ sw ; link ; obs ; sw0 ; link0 ]" :=
    (forall sws links links0 ofLinks ctrl,
      step
      (State (({|sw|}) <+> sws) (links ++ link :: links0) ofLinks ctrl)
      obs
      (State (({|sw0|}) <+> sws) (links ++ link0 :: links0) ofLinks ctrl))
    and
  "SwitchStep[ sw ; obs ; sw0 ]" :=
    (forall sws links ofLinks ctrl,
      step
        (State (({|sw|}) <+> sws) links ofLinks ctrl)
        obs
        (State (({|sw0|}) <+> sws) links ofLinks ctrl))
    and
  "SwitchOpenFlow[ sw ; of ; obs ; sw0 ; of0 ]" :=
    (forall sws links ofLinks ofLinks0 ctrl,
      step
        (State (({|sw|}) <+> sws) links (ofLinks ++ of :: ofLinks0) ctrl)
        obs
        (State (({|sw0|}) <+> sws) links (ofLinks ++ of0 :: ofLinks0) ctrl)).

  Definition swPtPks : Type :=
    bag (PairOrdering (PairOrdering switchId_le portId_le)
                      packet_le).

  Definition abst_state := swPtPks.

  Definition transfer (sw : switchId) (ptpk : portId * packet) :=
    match ptpk with
      | (pt,pk) =>
        match topo (sw,pt) with
          | Some (sw',pt') =>
            @singleton _
               (PairOrdering
                  (PairOrdering switchId_le portId_le) packet_le)
               (sw',pt',pk)
          | None => {| |}
        end
    end.

  Definition select_packet_out (sw : switchId) (msg : fromController) :=
    match msg with
      | PacketOut pt pk => transfer sw (pt,pk)
      | _ => {| |}
    end.

  Definition select_packet_in (sw : switchId) (msg : fromSwitch) :=
    match msg with
      | PacketIn pt pk => unions (map (transfer sw) (abst_func sw pt pk))
      | _ => {| |}
    end.

  Definition FlowTableSafe (sw : switchId) (tbl : flowTable) : Prop :=
    forall pt pk forwardedPkts packetIns,
      process_packet tbl pt pk = (forwardedPkts, packetIns) ->
      unions (map (transfer sw) forwardedPkts) <+>
      unions (map (select_packet_in sw) (map (PacketIn pt) packetIns)) =
      unions (map (transfer sw) (abst_func sw pt pk)).

  Inductive NotFlowMod : fromController -> Prop :=
  | NotFlowMod_BarrierRequest : forall n, NotFlowMod (BarrierRequest n)
  | NotFlowMod_PacketOut : forall pt pk, NotFlowMod (PacketOut pt pk).

  Inductive FlowModSafe : switchId -> flowTable -> bag fromController_le -> Prop :=
  | NoFlowModsInBuffer : forall swId tbl ctrlm,
      (forall msg, In msg (to_list ctrlm) -> NotFlowMod msg) ->
      FlowTableSafe swId tbl ->
      FlowModSafe swId tbl ctrlm
  | OneFlowModsInBuffer : forall swId tbl ctrlm f,
      (forall msg, In msg (to_list ctrlm) -> NotFlowMod msg) ->
      FlowTableSafe swId tbl ->
      FlowTableSafe swId (modify_flow_table f tbl) ->
      FlowModSafe swId tbl (({|FlowMod f|}) <+> ctrlm).

  Definition FlowTablesSafe (sws : bag switch_le) : Prop :=
    forall swId pts tbl inp outp ctrlm switchm,
      In (Switch swId pts tbl inp outp ctrlm switchm) (to_list sws) ->
      FlowModSafe swId tbl ctrlm.

  Definition SwitchesHaveOpenFlowLinks (sws : bag switch_le) ofLinks :=
    forall sw,
      In sw (to_list sws) ->
      exists ofLink,
        In ofLink ofLinks /\
        swId sw = of_to ofLink.

End MACHINE.

Module Type ATOMS_AND_CONTROLLER.

  Declare Module Machine : MACHINE.
  Import Machine.
  Import Atoms.

  Parameter relate_controller : controller -> swPtPks.

  Parameter ControllerRemembersPackets :
    forall (ctrl ctrl' : controller),
      controller_step ctrl ctrl' ->
      relate_controller ctrl = relate_controller ctrl'.

  Parameter P : bag switch_le -> list openFlowLink -> controller -> Prop.

  Parameter P_entails_FlowTablesSafe : forall sws ofLinks ctrl,
    P sws ofLinks ctrl ->
    SwitchesHaveOpenFlowLinks sws ofLinks ->
    FlowTablesSafe sws.

  Parameter step_preserves_P : forall sws0 sws1 links0 links1 ofLinks0 ofLinks1
    ctrl0 ctrl1 obs,
    AllDiff of_to ofLinks0 ->
    AllDiff swId (to_list sws0) ->
    step (State sws0 links0 ofLinks0 ctrl0)
         obs
         (State sws1 links1 ofLinks1 ctrl1) ->
    P sws0 ofLinks0 ctrl0 ->
    P sws1 ofLinks1 ctrl1.

  Parameter ControllerSendForgetsPackets : forall ctrl ctrl' sw msg,
    controller_send ctrl ctrl' sw msg ->
    relate_controller ctrl = select_packet_out sw msg <+>
    relate_controller ctrl'.

  Parameter ControllerRecvRemembersPackets : forall ctrl ctrl' sw msg,
    controller_recv ctrl sw msg ctrl' ->
    relate_controller ctrl' = select_packet_in sw msg <+>
    (relate_controller ctrl).

  (** If [(sw,pt,pk)] is a packet in the controller's abstract state,
      then the controller will eventually emit the packet. *)
  Parameter ControllerLiveness : forall sw pt pk ctrl0 sws0 links0
                                        ofLinks0,
    In (sw,pt,pk) (to_list (relate_controller ctrl0)) ->
    exists  ofLinks10 ofLinks11 ctrl1 swTo ptTo switchmLst ctrlmLst,
      (multistep
         step (State sws0 links0 ofLinks0 ctrl0) nil
         (State sws0 links0
                (ofLinks10 ++
                 (OpenFlowLink swTo switchmLst
                  (PacketOut ptTo pk :: ctrlmLst)) ::
                 ofLinks11)
                ctrl1)) /\
      select_packet_out swTo (PacketOut ptTo pk) = ({|(sw,pt,pk)|}).

  (** If [m] is a message from the switch to the controller, then the controller
      will eventually consume [m], adding its packet-content to its state. *)
  Parameter ControllerRecvLiveness : forall sws0 links0 ofLinks0 sw switchm0 m
    ctrlm0 ofLinks1 ctrl0,
     exists ctrl1,
      (multistep
         step
         (State
            sws0 links0
            (ofLinks0 ++ (OpenFlowLink sw (switchm0 ++ [m]) ctrlm0) :: ofLinks1)
            ctrl0)
         nil
         (State
            sws0 links0
            (ofLinks0 ++ (OpenFlowLink sw switchm0 ctrlm0) :: ofLinks1)
            ctrl1)) /\
       exists (lps : swPtPks),
         (select_packet_in sw m) <+> lps = relate_controller ctrl1.

End ATOMS_AND_CONTROLLER.

Module Type RELATION_DEFINITIONS.

  Declare Module AtomsAndController : ATOMS_AND_CONTROLLER.
  Import AtomsAndController.
  Import Machine.
  Import Atoms.

  Definition affixSwitch (sw : switchId) (ptpk : portId * packet) :=
    match ptpk with
      | (pt,pk) => (sw,pt,pk)
    end.

  Definition ConsistentDataLinks (links : list dataLink) : Prop :=
    forall (lnk : dataLink),
      In lnk links ->
      topo (src lnk) = Some (dst lnk).

  Definition LinkHasSrc (sws : bag switch_le) (link : dataLink) : Prop :=
    exists switch,
      In switch (to_list sws) /\
      fst (src link) = swId switch /\
      In (snd (src link)) (pts switch).

  Definition LinkHasDst (sws : bag switch_le) (link : dataLink) : Prop :=
    exists switch,
      In switch (to_list sws) /\
      fst (dst link) = swId switch /\
      In (snd (dst link)) (pts switch).

  Definition LinksHaveSrc (sws : bag switch_le) (links : list dataLink) :=
    forall link, In link links -> LinkHasSrc sws link.

  Definition LinksHaveDst (sws : bag switch_le) (links : list dataLink) :=
    forall link, In link links -> LinkHasDst sws link.

  Definition UniqSwIds (sws : bag switch_le) := AllDiff swId (to_list sws).

  Definition ofLinkHasSw (sws : bag switch_le) (ofLink : openFlowLink) :=
    exists sw,
      In sw (to_list sws) /\
      of_to ofLink = swId sw.

  Definition OFLinksHaveSw (sws : bag switch_le) (ofLinks : list openFlowLink) :=
    forall ofLink, In ofLink ofLinks -> ofLinkHasSw sws ofLink.

  Definition DevicesFromTopo (devs : state) :=
    forall swId0 swId1 pt0 pt1,
      Some (swId0,pt0) = topo (swId1,pt1) ->
      exists sw0 sw1 lnk,
        (* TODO(arjun): might as well be lists now. *)
        In sw0 (to_list (switches devs)) /\
        In sw1 (to_list (switches devs)) /\
        In lnk (links devs) /\
        swId sw0 = swId0 /\
        swId sw1 = swId1 /\
        src lnk = (swId1,pt1) /\
        dst lnk = (swId0, pt0).

  Definition NoBarriersInCtrlm (sws : bag switch_le) :=
    forall sw,
      In sw (to_list sws) ->
      forall m,
        In m (to_list (ctrlm sw)) ->
        NotBarrierRequest m.

  Record concreteState := ConcreteState {
    devices : state;
    concreteState_flowTableSafety : FlowTablesSafe (switches devices);
    concreteState_consistentDataLinks : ConsistentDataLinks (links devices);
    linksHaveSrc : LinksHaveSrc (switches devices) (links devices);
    linksHaveDst : LinksHaveDst (switches devices) (links devices);
    uniqSwIds : UniqSwIds (switches devices);
    ctrlP : P (switches devices) (ofLinks devices) (ctrl devices);
    uniqOfLinkIds : AllDiff of_to (ofLinks devices);
    ofLinksHaveSw : OFLinksHaveSw (switches devices) (ofLinks devices);
    devicesFromTopo : DevicesFromTopo devices;
    swsHaveOFLinks : SwitchesHaveOpenFlowLinks (switches devices) (ofLinks devices);
    noBarriersInCtrlm : NoBarriersInCtrlm (switches devices)
  }.

  Implicit Arguments ConcreteState [].

  Definition concreteStep (st : concreteState) (obs : option observation)
    (st0 : concreteState) :=
    step (devices st) obs (devices st0).

  Inductive abstractStep : abst_state -> option observation -> abst_state ->
    Prop :=
  | AbstractStep : forall sw pt pk lps,
    abstractStep
      ({| (sw,pt,pk) |} <+> lps)
      (Some (sw,pt,pk))
      (unions (map (transfer sw) (abst_func sw pt pk)) <+> lps).

  Definition relate_switch (sw : switch) : abst_state :=
    match sw with
      | Switch swId _ tbl inp outp ctrlm switchm =>
        from_list (map (affixSwitch swId) (to_list inp)) <+>
        unions (map (transfer swId) (to_list outp)) <+>
        unions (map (select_packet_out swId) (to_list ctrlm)) <+>
        unions (map (select_packet_in swId) (to_list switchm))
    end.

  Definition relate_dataLink (link : dataLink) : abst_state :=
    match link with
      | DataLink _ pks (sw,pt) =>
        from_list (map (fun pk => (sw,pt,pk)) pks)
    end.

  Definition relate_openFlowLink (link : openFlowLink) : abst_state :=
    match link with
      | OpenFlowLink sw switchm ctrlm =>
        unions (map (select_packet_out sw) ctrlm) <+>
        unions (map (select_packet_in sw) switchm)
    end.

  Definition relate (st : state) : abst_state :=
    unions (map relate_switch (to_list (switches st))) <+>
    unions (map relate_dataLink (links st)) <+>
    unions (map relate_openFlowLink (ofLinks st)) <+>
    relate_controller (ctrl st).

  Definition bisim_relation : relation concreteState abst_state :=
    fun (st : concreteState) (ast : abst_state) =>
      ast = (relate (devices st)).

End RELATION_DEFINITIONS.

Module Type RELATION.

  Declare Module RelationDefinitions : RELATION_DEFINITIONS.
  Import RelationDefinitions.
  Import AtomsAndController.
  Import Machine.
  Import Atoms.

  Parameter simpl_multistep : forall (st1 : concreteState) (devs2 : state) obs,
    multistep step (devices st1) obs devs2 ->
    exists (st2 : concreteState),
      devices st2 = devs2 /\
      multistep concreteStep st1 obs st2.

  Parameter simpl_weak_sim : forall st1 devs2 sw pt pk lps,
    multistep step (devices st1) [(sw,pt,pk)] devs2 ->
    relate (devices st1) = ({| (sw,pt,pk) |} <+> lps) ->
    abstractStep
      ({| (sw,pt,pk) |} <+> lps)
      (Some (sw,pt,pk))
      (unions (map (transfer sw) (abst_func sw pt pk)) <+> lps) ->
   exists st2 : concreteState,
     inverse_relation
       bisim_relation
       (unions (map (transfer sw) (abst_func sw pt pk)) <+> lps)
       st2 /\
     multistep concreteStep st1 [(sw,pt,pk)] st2.

End RELATION.

Module Type WEAK_SIM_1.

  Declare Module Relation : RELATION.
  Import Relation.
  Import RelationDefinitions.
  Import AtomsAndController.
  Import Machine.
  Import Atoms.

  Parameter weak_sim_1 : weak_simulation concreteStep abstractStep bisim_relation.

End WEAK_SIM_1.

Module Type WEAK_SIM_2.

  Declare Module Relation : RELATION.
  Import Relation.
  Import RelationDefinitions.
  Import AtomsAndController.
  Import Machine.
  Import Atoms.

  Parameter weak_sim_2 :
    weak_simulation abstractStep concreteStep (inverse_relation bisim_relation).

End WEAK_SIM_2.


Require Import Mem.
Require Import Prog.
Require Import List.
Require Import Array.
Require Import Pred.
Require Import FunctionalExtensionality.
Require Import Word.
Require Import WordAuto.
Require Import Omega.
Require Import Ring.
Require Import SepAuto.
Require Import ListUtils.
Require Import ListPred.

Set Implicit Arguments.

(**
 * This module is meant to generalize separation logic to arbitrary functions
 * from some address-like thing to some value-like thing.  The motivating use
 * case is in files: we want to think of the disk as a mapping from inode numbers
 * to file objects, where each file object includes metadata and the entire file
 * contents.  Current separation logic is not quite good enough, because we want
 * to have values that are bigger than a 512-byte block.
 *)

(**
 * list2nmem is meant to convert a list representation of files into a memory-like
 * object that maps inode numbers (list positions) into files (or None, if the
 * inode number is too big).  [list2nmem] always uses [nat] as the index.
 *)
Definition list2nmem (A: Type) (l: list A) : (@mem nat eq_nat_dec A) :=
  fun a => selN (map (@Some A) l) a None.

Notation "[[[ NS ':::' P ]]]" := [[ (P)%pred (list2nmem NS) ]]%pred : pred_scope.
Notation "【 NS '‣‣' P 】" := [[ (P)%pred (list2nmem NS) ]]%pred : pred_scope.

Theorem list2nmem_oob : forall A (l : list A) i,
  i >= length l
  -> (list2nmem l) i = None.
Proof.
  unfold list2nmem; intros.
  rewrite selN_oob; auto.
  rewrite map_length; auto.
Qed.

Theorem list2nmem_inbound: forall A F (l : list A) i x,
  (F * i |-> x)%pred (list2nmem l)
  -> i < length l.
Proof.
  intros.
  destruct (lt_dec i (length l)); auto; exfalso.
  apply not_lt in n.
  apply list2nmem_oob in n.
  apply ptsto_valid' in H.
  rewrite H in n.
  inversion n.
Qed.

Theorem list2nmem_sel: forall A F (l: list A) i x def,
  (F * i |-> x)%pred (list2nmem l)
  -> x = selN l i def.
Proof.
  intros.
  assert (i < length l).
  eapply list2nmem_inbound; eauto.
  unfold list2nmem in H.
  apply ptsto_valid' in H.
  erewrite selN_map in H by auto.
  inversion H; eauto.
Qed.

Lemma listupd_memupd: forall A l i (v : A),
  i < length l
  -> list2nmem (updN l i v) = Mem.upd (list2nmem l) i v.
Proof.
  intros.
  apply functional_extensionality; intro.
  unfold list2nmem, Mem.upd.
  autorewrite with core lists.

  destruct (eq_nat_dec x i).
  subst; erewrite selN_updN_eq; auto.
  rewrite map_length; auto.

  erewrite selN_updN_ne; auto.
Qed.

Theorem list2nmem_updN: forall A F (l: list A) i x y,
  (F * i |-> x)%pred (list2nmem l)
  -> (F * i |-> y)%pred (list2nmem (updN l i y)).
Proof.
  intros.
  rewrite listupd_memupd; auto.
  apply sep_star_comm.
  apply sep_star_comm in H.
  eapply ptsto_upd; eauto.
  eapply list2nmem_inbound; eauto.
Qed.

Lemma list2nmem_updN_selN : forall A F (l : list A) a v1 def,
  (F * a |-> v1)%pred (list2nmem (updN l a v1)) ->
  (F * a |-> selN l a def)%pred (list2nmem l).
Proof.

  intros.
  destruct (lt_dec a (length l)).

  eapply list2nmem_updN with (y := selN l a def) in H.
  rewrite updN_twice in H.
  rewrite updN_selN_eq in H; auto.
  apply list2nmem_inbound in H.
  rewrite length_updN in H.
  congruence.
Qed.

Theorem listapp_memupd: forall A l (a : A),
  list2nmem (l ++ a :: nil) = Mem.upd (list2nmem l) (length l) a.
Proof.
  intros.
  apply functional_extensionality; intro.
  unfold list2nmem, Mem.upd.

  destruct (lt_dec x (length l)).
  - subst; rewrite selN_map with (default' := a).
    destruct (eq_nat_dec x (length l)); subst.
    + rewrite selN_last; auto.
    + rewrite selN_map with (default' := a); auto.
      rewrite selN_app; auto.
    + rewrite app_length; simpl; omega.
  - destruct (eq_nat_dec x (length l)).
    + subst; erewrite selN_map with (default' := a).
      rewrite selN_last; auto.
      rewrite app_length; simpl; omega.
    + repeat erewrite selN_oob with (def := None); try rewrite map_length; auto.
      omega.
      rewrite app_length; simpl; intuition.
Qed.

Theorem listapp_meminsert: forall A l (a : A),
  list2nmem (l ++ a :: nil) = Mem.insert (list2nmem l) (length l) a.
Proof.
  intros.
  apply functional_extensionality; intro.
  unfold list2nmem, Mem.insert.

  destruct (lt_dec x (length l)).
  - subst; rewrite selN_map with (default' := a) by ( rewrite app_length; omega ).
    destruct (eq_nat_dec x (length l)); subst.
    + rewrite selN_last; auto.
      rewrite selN_oob by ( rewrite map_length; omega ); auto.
    + rewrite selN_map with (default' := a); auto.
      rewrite selN_app; auto.
  - destruct (eq_nat_dec x (length l)).
    + subst; erewrite selN_map with (default' := a) by ( rewrite app_length; simpl; omega ).
      rewrite selN_last; auto.
      rewrite selN_oob by ( rewrite map_length; omega ); auto.
    + repeat erewrite selN_oob with (def := None); try rewrite map_length; auto.
      omega.
      rewrite app_length; simpl; intuition.
Qed.

Theorem list2nmem_app: forall A (F : @pred _ _ A) l a,
  F (list2nmem l)
  -> (F * (length l) |-> a)%pred (list2nmem (l ++ a :: nil)).
Proof.
  intros.
  erewrite listapp_memupd; eauto.
  apply ptsto_upd_disjoint; auto.
  unfold list2nmem, selN.
  rewrite selN_oob; auto.
  rewrite map_length.
  omega.
Qed.

Theorem list2nmem_arrayN_app: forall A (F : @pred _ _ A) l l',
  F (list2nmem l) ->
  (F * arrayN (@ptsto _ eq_nat_dec A) (length l) l') %pred (list2nmem (l ++ l')).
Proof.
  intros.
  generalize dependent F.
  generalize dependent l.
  induction l'; intros; simpl.
  - rewrite app_nil_r.
    apply emp_star_r.
    apply H.
  - apply sep_star_assoc.
    assert (Happ := list2nmem_app F l a H).
    assert (IHla := IHl' (l ++ a :: nil) (sep_star F (ptsto (length l) a)) Happ).
    replace (length (l ++ a :: nil)) with (S (length l)) in IHla.
    replace ((l ++ a :: nil) ++ l') with (l ++ a :: l') in IHla.
    apply IHla.
    rewrite <- app_assoc; reflexivity.
    rewrite app_length; simpl.
    symmetry; apply Nat.add_1_r.
Qed.

Theorem list2nmem_removelast_is : forall A l (def : A),
  l <> nil
  -> list2nmem (removelast l) =
     fun i => if (lt_dec i (length l - 1)) then Some (selN l i def) else None.
Proof.
  intros; apply functional_extensionality; intros.
  destruct (lt_dec x (length l - 1)); unfold list2nmem.
  - rewrite selN_map with (default' := def).
    rewrite selN_removelast by omega; auto.
    rewrite length_removelast by auto; omega.
  - rewrite selN_oob; auto.
    rewrite map_length.
    rewrite length_removelast by auto.
    omega.
Qed.

Theorem list2nmem_removelast_list2nmem : forall A (l : list A) (def : A),
  l <> nil
  -> list2nmem (removelast l) =
     fun i => if (eq_nat_dec i (length l - 1)) then None else (list2nmem l) i.
Proof.
  intros; apply functional_extensionality; intros.
  erewrite list2nmem_removelast_is with (def := def) by eauto.
  unfold list2nmem.
  destruct (lt_dec x (length l - 1));
  destruct (eq_nat_dec x (length l - 1)); subst; intuition.
  omega.
  erewrite selN_map with (default' := def); auto.
  omega.
  erewrite selN_oob; auto.
  rewrite map_length.
  omega.
Qed.

Lemma mem_disjoint_either: forall AT AEQ V (m1 m2 : @mem AT AEQ V) a v,
  mem_disjoint m1 m2
  -> m1 a = Some v -> m2 a = None.
Proof.
  unfold mem_disjoint; intros; firstorder.
  pose proof (H a); firstorder.
  pose proof (H1 v); firstorder.
  destruct (m2 a); auto.
  pose proof (H2 v0); firstorder.
Qed.

Theorem list2nmem_removelast: forall A F (l : list A) v,
  l <> nil
  -> (F * (length l - 1) |-> v)%pred (list2nmem l)
  -> F (list2nmem (removelast l)).
Proof.
  unfold_sep_star; unfold ptsto; intuition; repeat deex.
  assert (m1 = list2nmem (removelast l)); subst; auto.
  apply functional_extensionality; intros.
  rewrite list2nmem_removelast_list2nmem; auto.

  destruct (eq_nat_dec x (length l - 1)); subst.
  apply mem_disjoint_comm in H0.
  eapply mem_disjoint_either; eauto.

  rewrite H1; unfold mem_union.
  destruct (m1 x); subst; simpl; auto.
  apply eq_sym; apply H5; auto.
Qed.

Lemma list2nmem_except_last : forall T (l : list T) x,
  mem_except (list2nmem (l ++ x::nil)) (length l) = list2nmem l.
Proof.
  unfold mem_except, list2nmem.
  intros.
  eapply functional_extensionality; cbn; intros a.
  destruct Nat.eq_dec.
  rewrite selN_oob; auto.
  autorewrite with lists. omega.
  rewrite map_app; cbn.
  destruct (lt_dec a (length l)).
  rewrite selN_app; eauto.
  autorewrite with lists; eauto.
  repeat rewrite selN_oob; auto.
  all: autorewrite with lists; cbn; omega.
Qed.

Theorem list2nmem_array: forall  A (l : list A),
  arrayN (@ptsto _ eq_nat_dec A) 0 l (list2nmem l).
Proof.
  induction l using rev_ind; intros; firstorder; simpl.
  erewrite listapp_memupd; try omega.
  eapply arrayN_app_memupd; try omega.
  eauto.
Qed.

Theorem list2nmem_array': forall  A (l l' : list A),
  l = l' ->
  arrayN (@ptsto _ eq_nat_dec A) 0 l' (list2nmem l).
Proof.
  intros; subst; apply list2nmem_array.
Qed.

Theorem list2nmem_arrayN_firstn_skipn: forall A (l:list A) n,
  (arrayN (@ptsto _ eq_nat_dec A) 0 (firstn n l) *
   arrayN (@ptsto _ eq_nat_dec A) n (skipn n l))%pred (list2nmem l).
Proof.
  intros.
  case_eq (lt_dec n (length l)); intros.
  - rewrite <- firstn_skipn with (l := l) (n := n) at 3.
    replace n with (length (firstn n l)) at 2.
    apply list2nmem_arrayN_app.
    apply list2nmem_array.
    apply firstn_length_l; omega.
  - rewrite firstn_oob by omega.
    rewrite skipn_oob by omega.
    eapply pimpl_apply.
    cancel.
    apply list2nmem_array.
Qed.

Lemma listpred_ptsto_list2nmem: forall T t (l : list T),
  listpred (fun a => a |->?)%pred t (list2nmem l) ->
  Permutation.Permutation t (seq 0 (length l)).
Proof.
  unfold list2nmem.
  intros.
  eapply Permutation.NoDup_Permutation.
  eapply listpred_nodup; eauto.
  decide equality.
  intuition.
  eapply ptsto_conflict; eauto.
  apply seq_NoDup.
  split; intros.
  eapply listpred_remove in H; eauto.
  destruct_lift H.
  eapply ptsto_valid in H.
  eapply in_seq.
  destruct (lt_dec x (length l)); try omega.
  rewrite selN_oob in H by (autorewrite with lists; omega).
  congruence.
  intros.
  eauto using ptsto_conflict.
  destruct (In_dec Nat.eq_dec x t).
  eapply listpred_remove in H; eauto.
  eauto using ptsto_conflict.
  eapply listpred_ptsto_notindomain in H; eauto.
  cbv [notindomain list2nmem] in *.
  denote seq as Hs.
  eapply in_seq in Hs.
  erewrite selN_map in * by omega.
  congruence.
Unshelve.
  all: try exact Nat.eq_dec.
  destruct l; cbn in *; eauto; omega.
Qed.

Lemma arrayN_ptsto_linked: forall S V t l,
  arrayN (ptsto (V:=S)) 0 l =p=> listpred (fun a => exists v, a |-> v) t ->
  @listpred _ _ Nat.eq_dec V (fun a => a |->?) (seq 0 (length l)) =p=> listpred (fun a => a |->?) t.
Proof.
  intros.
  pose proof list2nmem_array as Hp.
  eapply H in Hp.
  eapply listpred_permutation.
  eapply listpred_ptsto_list2nmem; auto.
Qed.

(* Alternative variants of [list2nmem] that are more induction-friendly *)
Definition list2nmem_off (A: Type) (start : nat) (l: list A) : (nat -> option A) :=
  fun a => if lt_dec a start then None
                             else selN (map (@Some A) l) (a - start) None.

Theorem list2nmem_off_eq : forall A (l : list A), list2nmem l = list2nmem_off 0 l.
Proof.
  unfold list2nmem, list2nmem_off; intros.
  apply functional_extensionality; intros.
  rewrite <- minus_n_O.
  reflexivity.
Qed.

Fixpoint list2nmem_fix (A : Type) (start : nat) (l : list A) : (nat -> option A) :=
  match l with
  | nil => fun a => None
  | h :: l' => fun a => if eq_nat_dec a start then Some h else list2nmem_fix (S start) l' a
  end.

Lemma list2nmem_fix_below : forall (A : Type) (l : list A) start a,
  a < start -> list2nmem_fix start l a = None.
Proof.
  induction l; auto; simpl; intros.
  destruct (eq_nat_dec a0 start); [omega |].
  apply IHl; omega.
Qed.

Theorem list2nmem_fix_off_eq : forall A (l : list A) n,
  list2nmem_off n l = list2nmem_fix n l.
Proof.
  induction l; intros; apply functional_extensionality; intros.
  unfold list2nmem_off; destruct (lt_dec x n); auto.

  unfold list2nmem_off; simpl in *.

  destruct (lt_dec x n).
  destruct (eq_nat_dec x n); [omega |].
  rewrite list2nmem_fix_below by omega.
  auto.

  destruct (eq_nat_dec x n).
  rewrite e; replace (n-n) with (0) by omega; auto.

  assert (x - n <> 0) by omega.
  destruct (x - n) eqn:Hxn; try congruence.

  rewrite <- IHl.
  unfold list2nmem_off.

  destruct (lt_dec x (S n)); [omega |].
  f_equal; omega.
Qed.

Theorem list2nmem_fix_eq : forall A (l : list A),
  list2nmem l = list2nmem_fix 0 l.
Proof.
  intros.
  rewrite list2nmem_off_eq.
  eapply list2nmem_fix_off_eq.
Qed.

Theorem list2nmem_off_app_union : forall A (a b : list A) start,
  list2nmem_off start (a ++ b) = @mem_union _ eq_nat_dec A (list2nmem_off start a)
                                                           (list2nmem_off (start + length a) b).
Proof.
  intros.
  repeat rewrite list2nmem_fix_off_eq.
  generalize dependent b.
  generalize dependent start.
  induction a; simpl; intros; apply functional_extensionality; intros.
  - unfold mem_union. rewrite <- plus_n_O. auto.
  - unfold mem_union in *.
    destruct (eq_nat_dec x start); eauto.
    rewrite IHa.
    replace (S start + length a0) with (start + S (length a0)) by omega.
    auto.
Qed.

Theorem list2nmem_off_disjoint : forall A (a b : list A) sa sb,
  (sb >= sa + length a \/ sa >= sb + length b) ->
  @mem_disjoint _ eq_nat_dec A (list2nmem_off sa a) (list2nmem_off sb b).
Proof.
  unfold mem_disjoint, list2nmem_off, not; intros; repeat deex;
    destruct (lt_dec a0 sa); destruct (lt_dec a0 sb); try congruence;
    apply selN_map_some_range in H0;
    apply selN_map_some_range in H2;
    omega.
Qed.

Lemma list2nmem_nil_array : forall A (l : list A) start,
  arrayN (@ptsto _ eq_nat_dec A) start l (list2nmem nil) -> l = nil.
Proof.
  destruct l; simpl; auto.
  unfold_sep_star; unfold ptsto, list2nmem; simpl; intros.
  repeat deex.
  unfold mem_union in H0.
  apply equal_f with (start) in H0.
  rewrite H2 in H0.
  congruence.
Qed.

Lemma list2nmem_array_nil : forall A (l : list A) start,
  arrayN (@ptsto _ eq_nat_dec A) start nil (list2nmem_fix start l) -> l = nil.
Proof.
  destruct l; simpl; auto.
  unfold list2nmem, emp; intros.
  pose proof (H start).
  destruct (eq_nat_dec start start); simpl in *; congruence.
Qed.

Theorem list2nmem_array_eq': forall A (l' l : list A) start,
  arrayN (@ptsto _ eq_nat_dec A) start l (list2nmem_fix start l')
  -> l' = l.
Proof.
  induction l'; simpl; intros.
  - erewrite list2nmem_nil_array; eauto.
  - destruct l.
    + eapply list2nmem_array_nil with (start:=start).
      auto.
    + simpl in *.
      unfold sep_star in H; rewrite sep_star_is in H; unfold sep_star_impl in H.
      repeat deex.
      unfold ptsto in H1; destruct H1.
      f_equal.
      * eapply equal_f with (start) in H0 as H0'.
        unfold mem_union in H0'.
        rewrite H1 in H0'.
        destruct (eq_nat_dec start start); congruence.
      * apply IHl' with (start:=S start); eauto; try omega.
        assert (m2 = list2nmem_fix (S start) l'); subst; auto.

        apply functional_extensionality; intros.
        unfold mem_union in H0.
        apply equal_f with x in H0.
        destruct (eq_nat_dec x start).

        rewrite list2nmem_fix_below by omega.
        eapply mem_disjoint_either.
        eauto.
        rewrite <- e in H1.
        eauto.

        rewrite H0.
        rewrite H2; auto.
Qed.

Theorem list2nmem_array_eq: forall A (l' l : list A),
  arrayN (@ptsto _ eq_nat_dec A) 0 l (list2nmem l')
  -> l' = l.
Proof.
  intros; eapply list2nmem_array_eq' with (start:=0); try rewrite <- plus_n_O; eauto.
  erewrite <- list2nmem_fix_eq; eauto.
Qed.

Theorem list2nmem_array_mem_eq : forall V (l : list V) m,
  arrayN (@ptsto _ eq_nat_dec V) 0 l m ->
  m = list2nmem l.
Proof.
  intros.
  apply functional_extensionality.
  intros.
  destruct (lt_dec x (length l)).
  - destruct l; [ simpl in *; omega | ].
    eapply isolateN_fwd with (i := x) in H; auto.

    assert (m x = Some (selN (v :: l) x v)).
    eapply ptsto_valid.
    pred_apply. cancel.

    assert (list2nmem (v :: l) x = Some (selN (v :: l) x v)).
    eapply ptsto_valid.
    pose proof (list2nmem_array (v :: l)).
    pred_apply. rewrite arrayN_isolate with (i := x) by auto. cancel.

    congruence.
  - eapply arrayN_oob with (i := x) in H; try omega.
    rewrite list2nmem_oob with (i := x); try omega.
    auto.
Qed.

Theorem list2nmem_array_app_eq: forall A (l l' : list A) a,
  (arrayN (@ptsto _ eq_nat_dec A) 0 l * (length l) |-> a)%pred (list2nmem l')
  -> l' = (l ++ a :: nil).
Proof.
  intros.
  rewrite list2nmem_array_eq with (l':=l') (l:=l++a::nil); eauto.
  pred_apply.
  rewrite <- isolateN_bwd with (vs:=l++a::nil) (i:=length l) by
    ( rewrite app_length; simpl; omega ).
  rewrite firstn_app2 by auto.
  replace (S (length l)) with (length (l ++ a :: nil)) by (rewrite app_length; simpl; omega).
  rewrite skipn_oob by omega; simpl.
  instantiate (1:=a).
  rewrite selN_last by auto.
  cancel.
Qed.

Lemma list2nmem_some_bound' : forall A (m : list A) start off a,
  list2nmem_fix start m off = Some a
  -> off + 1 <= start + length m.
Proof.
  induction m; simpl; intros.
  congruence.
  destruct (Nat.eq_dec off start).
  omega.
  replace (start + S (length m)) with (S start + length m) by omega.
  eapply IHm.
  eauto.
Qed.

Lemma list2nmem_some_bound : forall A (m : list A) off a,
  list2nmem m off = Some a
  -> off + 1 <= length m.
Proof.
  intros.
  rewrite list2nmem_fix_eq in H.
  apply list2nmem_some_bound' in H.
  omega.
Qed.

Theorem list2nmem_arrayN_bound : forall A (l m : list A) off F,
  (F * arrayN (@ptsto _ eq_nat_dec A) off l)%pred (list2nmem m)
  -> l = nil \/ off + length l <= length m.
Proof.
  induction l; simpl; intros.
  intuition.
  right.
  apply sep_star_assoc in H as H'.
  apply IHl in H'.
  intuition.
  subst. simpl.
  apply sep_star_comm in H.
  apply sep_star_assoc in H.
  apply ptsto_valid in H.
  apply list2nmem_some_bound in H.
  omega.
Qed.

Theorem list2nmem_arrayN_length : forall A (l m : list A) F,
  (F * arrayN (@ptsto _ eq_nat_dec A) 0 l)%pred (list2nmem m)
  -> length l <= length m.
Proof.
  intros.
  apply list2nmem_arrayN_bound in H; destruct H; auto.
  rewrite H; simpl; omega.
Qed.

Theorem list2nmem_ptsto_bound : forall A (l : list A) off v F,
  (F * off |-> v)%pred (list2nmem l)
  -> off < length l.
Proof.
  intros.
  assert ((F * arrayN (@ptsto _ eq_nat_dec A) off (v :: nil))%pred (list2nmem l)).
  pred_apply; cancel.
  apply list2nmem_arrayN_bound in H0. intuition; try congruence.
  simpl in *; omega.
Qed.

Definition arrayN_ex A VP pts (vs : list A) i : @pred _ _ VP :=
  (arrayN pts 0 (firstn i vs) *
   arrayN pts (i + 1) (skipn (S i) vs))%pred.

Lemma arrayN_ex_one: forall V VP (pts : _ -> _ -> @pred _ _ VP) (l : list V),
    List.length l = 1 ->
    arrayN_ex pts l 0 <=p=> emp.
Proof.
  destruct l.
  simpl; intros.
  congruence.
  destruct l.
  simpl. intros.
  unfold arrayN_ex.
  simpl.
  split; cancel.
  simpl. intros.
  congruence.
Qed.

Theorem arrayN_except : forall T V (vs : list T) (def : T) i (pts: _ -> _ -> @pred _ _ V),
  i < length vs
  -> arrayN pts 0 vs <=p=>
    (arrayN_ex pts vs i) * (pts i (selN vs i def)).
Proof.
  intros; unfold arrayN_ex.
  erewrite arrayN_isolate with (default := def); eauto.
  simpl.
  unfold piff; split; cancel.
Qed.

Theorem arrayN_except_upd : forall V T vs (v : T) i (pts : nat -> T -> @pred _ _ V),
  i < length vs
  -> arrayN pts 0 (updN vs i v) <=p=>
    (arrayN_ex pts vs i) * (pts i v).
Proof.
  intros; unfold arrayN_ex.
  erewrite isolate_fwd_upd; eauto.
  simpl.
  unfold piff; split; cancel.
Qed.

Theorem arrayN_ex_updN_eq : forall T A l i (v : A) (pts : _ -> _ -> @pred _ _ T),
  arrayN_ex pts (updN l i v) i <=p=>
  arrayN_ex pts l i.
Proof.
  unfold arrayN_ex; intros; autorewrite with core lists;
  split; simpl; rewrite skipn_updN; eauto.
Qed.

Theorem arrayN_mem_upd_none : forall V vs i m (v d : V) (p : nat -> V -> pred),
  m i = None ->
  i < length vs ->
  arrayN_ex p vs i m ->
  p i (selN vs i d) (fun a => if eq_nat_dec a i then Some v else None) ->
  arrayN p 0 vs (Mem.upd m i v).
Proof.
  intros.
  edestruct arrayN_except as [_ H']; eauto; apply H'; clear H'.
  unfold_sep_star.
  repeat eexists; eauto.
  cbv [Mem.upd mem_union].
  apply functional_extensionality.
  intros x. destruct eq_nat_dec; subst.
  destruct m; congruence.
  destruct (m x); congruence.
  intro; repeat deex.
  destruct eq_nat_dec; congruence.
Qed.

Theorem list2nmem_array_pick : forall V l (def : V) i,
  i < length l
  -> (arrayN_ex (@ptsto _ eq_nat_dec V) l i * i |-> selN l i def)%pred (list2nmem l).
Proof.
  intros.
  eapply arrayN_except; eauto.
  eapply list2nmem_array; eauto.
Qed.

Theorem list2nmem_array_updN : forall V ol nl (v : V) i,
  (arrayN_ex (@ptsto _ eq_nat_dec V) ol i * i |-> v)%pred (list2nmem nl)
  -> i < length ol
  -> nl = updN ol i v.
Proof.
  intros.
  eapply list2nmem_array_eq; autorewrite with core lists; auto.
  pred_apply.
  rewrite isolate_fwd_upd; auto.
  cancel.
Qed.

Theorem list2nmem_array_removelast_eq : forall V (nl ol : list V),
  (arrayN_ex (@ptsto _ eq_nat_dec V) ol (length ol - 1))%pred (list2nmem nl)
  -> length ol > 0
  -> nl = removelast ol.
Proof.
  unfold arrayN_ex; intros.
  destruct ol.
  inversion H0.

  eapply list2nmem_array_eq with (l' := nl); eauto.
  pred_apply.
  rewrite firstn_removelast_eq; auto.
  rewrite skipn_oob by omega.
  unfold arrayN at 2.
  clear H; cancel.
Qed.

Theorem list2nmem_array_exis : forall V l (def : V) i,
  (arrayN_ex (@ptsto _ eq_nat_dec V) l i * i |-> selN l i def)%pred (list2nmem l)
  -> (arrayN_ex (@ptsto _ eq_nat_dec V) l i * i |->?)%pred (list2nmem l).
Proof.
  intros; pred_apply; cancel.
Qed.

Lemma list2nmem_ptsto_cancel : forall V i (def : V) l, i < length l ->
  (arrayN_ex (@ptsto _ eq_nat_dec V) l i * i |-> selN l i def)%pred (list2nmem l).
Proof.
  intros.
  assert (arrayN (@ptsto _ eq_nat_dec V) 0 l (list2nmem l)) as Hx by eapply list2nmem_array.
  pred_apply; erewrite arrayN_except; eauto.
Qed.

Lemma list2nmem_ptsto_cancel_pair : forall A B i (def : A * B) l,
  i < length l ->
  (arrayN_ex (@ptsto _ eq_nat_dec (A * B)) l i *
    i |-> (fst (selN l i def), snd (selN l i def)))%pred (list2nmem l).
Proof.
  intros.
  assert (arrayN (@ptsto _ eq_nat_dec (A * B)) 0 l (list2nmem l)) as Hx by eapply list2nmem_array.
  pred_apply; erewrite arrayN_except; eauto.
  rewrite <- surjective_pairing.
  cancel.
Qed.

Lemma list2nmem_sel_for_eauto : forall V A i (v v' : V) l def,
  (A * i |-> v)%pred (list2nmem l)
  -> v' = selN l i def
  -> v' = v.
Proof.
  intros.
  apply list2nmem_sel with (def:=def) in H.
  congruence.
Qed.

Lemma arrayN_combine' : forall A VP (pts : _ -> _ -> @pred _ _ VP) (a b : list A) start,
  arrayN pts start a * arrayN pts (start + length a) b <=p=> arrayN pts start (a ++ b).
Proof.
  induction a; simpl; intros.
  - replace (start + 0) with start by omega.
    split; cancel.
  - rewrite sep_star_assoc.
    apply piff_star_l.
    replace (start + S (length a0)) with (S start + length a0) by omega.
    apply IHa.
Qed.

Lemma arrayN_combine : forall A VP (pts : _ -> _ -> @pred _ _ VP) (a b : list A) start off,
  off = start + length a ->
  arrayN pts start a * arrayN pts off b <=p=> arrayN pts start (a ++ b).
Proof.
  intros; subst.
  apply arrayN_combine'.
Qed.

Lemma arrayN_list2nmem : forall A (def : A) (a b : list A) F off,
  (F * arrayN (@ptsto _ eq_nat_dec A) off a)%pred (list2nmem b) ->
  a = firstn (length a) (skipn off b).
Proof.
  induction a; simpl; intros; auto.
  rewrite skipn_selN_skipn with (def:=def).
  f_equal.
  eapply list2nmem_sel.
  pred_apply. cancel.
  eapply IHa.
  pred_apply. cancel.
  eapply list2nmem_ptsto_bound.
  pred_apply. cancel.
Qed.

Theorem list2nmem_ptsto_end_eq : forall A (F : @pred _ _ A) l a a',
  (F * (length l) |-> a)%pred (list2nmem (l ++ a' :: nil)) ->
  a = a'.
Proof.
  intros.
  apply list2nmem_sel with (def:=a) in H.
  rewrite selN_last in H; auto.
Qed.

Theorem list2nmem_arrayN_end_eq : forall A (F : @pred _ _ A) l l' l'' (def:A),
  length l' = length l'' ->
  (F * arrayN (@ptsto _ eq_nat_dec A) (length l) l')%pred (list2nmem (l ++ l'')) ->
  l' = l''.
Proof.
  intros.
  apply arrayN_list2nmem in H0.
  rewrite skipn_app in H0.
  rewrite firstn_oob in H0.
  auto.
  omega.
  exact def.
Qed.

Theorem list2nmem_off_arrayN: forall A (l : list A) off,
  arrayN (@ptsto _ eq_nat_dec A) off l (list2nmem_off off l).
Proof.
  intros; rewrite list2nmem_fix_off_eq.
  generalize dependent off; induction l; simpl; intros.
  - firstorder.
  - apply sep_star_comm. eapply ptsto_upd_disjoint; eauto.
    apply list2nmem_fix_below.
    omega.
Qed.

Theorem list2nmem_arrayN_app_iff : forall A (F : @pred _ _ A) l l',
  (F * arrayN (@ptsto _ eq_nat_dec A) (length l) l')%pred (list2nmem (l ++ l')) ->
  F (list2nmem l).
Proof.
  intros.
  rewrite list2nmem_off_eq in *.
  rewrite list2nmem_off_app_union in H.
  eapply septract_sep_star.
  2: unfold septract; eexists; intuition.
  4: pred_apply' H; cancel.
  apply strictly_exact_to_exact_domain.
  apply arrayN_strictly_exact.
  apply list2nmem_off_disjoint; intuition.
  apply list2nmem_off_arrayN.
Qed.

Lemma mem_except_list2nmem_oob : forall A (l : list A) a,
  a >= length l ->
  mem_except (list2nmem l) a = list2nmem l.
Proof.
  unfold mem_except, list2nmem; intros.
  apply functional_extensionality; intro.
  destruct (Nat.eq_dec x a); subst; simpl; auto.
  erewrite selN_oob; auto.
  autorewrite with lists in *; omega.
Qed.

Lemma list2nmem_sel_inb : forall A (l : list A) a def,
  a < length l ->
  list2nmem l a = Some (selN l a def).
Proof.
  induction l using rev_ind; intros.
  inversion H.
  rewrite listapp_memupd.

  destruct (Nat.eq_dec a (length l)); subst.
  rewrite upd_eq; auto.
  rewrite selN_last; auto.
  rewrite upd_ne; auto.
  rewrite app_length in H; simpl in H.
  erewrite IHl by omega.
  rewrite selN_app1 by omega; auto.
Qed.

Lemma sep_star_reorder_helper1 : forall AT AEQ V (a b c d : @pred AT AEQ V),
  (a * ((b * c) * d)) <=p=> (a * b * d) * c.
Proof.
  intros; split; cancel.
Qed.

Lemma list2nmem_arrayN_updN : forall V F a vl l i (v : V),
  (F * arrayN (@ptsto _ eq_nat_dec V) a vl)%pred (list2nmem l) ->
  i < length vl ->
  (F * arrayN (@ptsto _ eq_nat_dec V) a (updN vl i v))%pred (list2nmem (updN l (a + i) v)).
Proof.
  intros.
  rewrite arrayN_isolate with (i:=i) (default := v) by (rewrite length_updN; auto).
  rewrite selN_updN_eq by auto.
  rewrite firstn_updN_oob by auto.
  rewrite skipN_updN' by auto.
  apply sep_star_reorder_helper1.
  eapply list2nmem_updN with (x := selN vl i v).
  apply sep_star_reorder_helper1.
  rewrite <- arrayN_isolate; auto.
Qed.

Lemma listmatch_ptsto_list2nmem_inbound : forall VT al vl (F : @pred _ _ VT) m ,
  (F * listmatch (fun a v => a |-> v) al vl)%pred (list2nmem m) ->
  Forall (fun a => a < length m) al.
Proof.
  induction al; intros.
  apply Forall_nil.
  unfold listmatch in H; destruct vl; destruct_lift H.
  inversion H1.
  apply Forall_cons.
  eapply list2nmem_ptsto_bound.
  pred_apply; cancel.
  eapply IHal with (vl := vl).
  pred_apply.
  unfold listmatch; cancel.
Qed.

Lemma list2nmem_inj' : forall A (a b : list A) n,
  list2nmem_off n a = list2nmem_off n b ->
  a = b.
Proof.
  intros.
  repeat rewrite list2nmem_fix_off_eq in H.
  revert H. revert a b n.
  induction a; destruct b; simpl; firstorder.
  eapply equal_f with (x := n) in H; simpl in H.
  destruct (Nat.eq_dec n n); congruence.
  eapply equal_f with (x := n) in H.
  destruct (Nat.eq_dec n n); congruence.
  erewrite IHa with (b := b) (n := S n).
  eapply equal_f with (x := n) in H.
  destruct (Nat.eq_dec n n); try congruence.

  apply functional_extensionality; intros.
  destruct (Nat.eq_dec x n); subst.
  repeat rewrite list2nmem_fix_below; auto.
  eapply equal_f with (x0 := x) in H.
  destruct (Nat.eq_dec x n); try congruence.
Qed.

Lemma list2nmem_inj : forall A (a b : list A),
  list2nmem a = list2nmem b ->  a = b.
Proof.
  intros.
  apply list2nmem_inj' with (n := 0).
  repeat rewrite <- list2nmem_off_eq; auto.
Qed.

(* crashes *)

Require Import PredCrash AsyncDisk.
Import ListNotations.

Lemma list2nmem_crash_xform : forall vl vsl (F : rawpred),
  possible_crash_list vsl vl ->
  F (list2nmem vsl) ->
  crash_xform F (list2nmem (synced_list vl)).
Proof.
  induction vl using rev_ind; simpl; intuition.
  unfold crash_xform, possible_crash; eexists; intuition.
  setoid_rewrite length_nil in H0; auto.
  apply possible_crash_list_length in H; auto.

  unfold crash_xform, possible_crash.
  eexists; intuition. eauto.
  destruct H as [H Hx].
  destruct (lt_eq_lt_dec a (length vl)).
  destruct s.
  assert (a < length vsl).
  rewrite H; autorewrite with lists; simpl; omega.

  right.
  exists (selN vsl a ($0, nil)).
  exists (selN vl a $0); intuition.
  apply selN_map; auto.
  unfold list2nmem, synced_list.
  erewrite selN_map.
  rewrite selN_combine, selN_app1, repeat_selN; auto.
  autorewrite with lists; simpl; omega.
  autorewrite with lists; auto.
  rewrite combine_length_eq; autorewrite with lists; simpl; omega.
  specialize (Hx a H1).
  rewrite selN_app1 in Hx; auto.

  right; subst.
  eexists; exists x; intuition.
  autorewrite with lists in H; simpl in H.
  unfold list2nmem; erewrite selN_map by omega; eauto.
  unfold list2nmem; rewrite synced_list_app.
  erewrite selN_map, selN_app2.
  rewrite synced_list_length, Nat.sub_diag; auto.
  rewrite synced_list_length; auto.
  rewrite app_length, synced_list_length; simpl; omega.
  rewrite app_length in H; simpl in H.
  assert (length vl < length vsl) as Hy by omega.
  specialize (Hx (length vl) Hy).
  rewrite selN_app2, Nat.sub_diag in Hx by omega; simpl in Hx.
  unfold vsmerge; eauto.

  left; split.
  rewrite app_length in H; simpl in H.
  unfold list2nmem; erewrite selN_oob; auto.
  rewrite map_length; omega.
  unfold list2nmem; erewrite selN_oob; auto.
  rewrite map_length, synced_list_length, app_length; simpl; omega.
  Unshelve. all: eauto.
Qed.

Lemma crash_xform_list2nmem_possible_crash_list : forall vl (F : rawpred),
  crash_xform F (list2nmem vl) ->
  exists vsl, F (list2nmem vsl) /\ possible_crash_list vsl (map fst vl).
Proof.
  unfold crash_xform.
  induction vl using rev_ind; intros; auto.
  exists nil; deex.
  replace (list2nmem nil) with m'; auto.
  apply functional_extensionality; intro.
  specialize (H1 x).
  destruct H1; destruct H.
  rewrite H; auto.
  deex; unfold list2nmem in H; simpl in *; congruence.
  unfold possible_crash_list; intuition.
  inversion H.

  deex.

  (* Figure out [m' (length vl)] *)
  case_eq (m' (length vl)); [ intro p | ]; intro Hp.
  specialize (IHvl (pred_except F (length vl) p)).
  rewrite listapp_memupd in H1.

  pose proof (possible_crash_upd_mem_except H1) as Hx.
  rewrite mem_except_list2nmem_oob in Hx by auto.
  specialize (H1 (length vl)); destruct H1.
  contradict H; rewrite upd_eq by auto.
  intuition congruence.
  repeat deex.

  eapply pred_except_mem_except in H0 as Hy.
  destruct IHvl as [ ? Hz ].
  eexists; eauto.
  destruct Hz as [ Hz [ Heq HP ] ].
  rewrite map_length in Heq.

  unfold pred_except in Hz.
  rewrite <- Heq in Hz.
  rewrite <- listapp_meminsert in Hz; intuition.
  eexists; split; eauto.

  split; autorewrite with lists; simpl; intros.
  repeat rewrite app_length; omega.
  destruct (lt_dec i (length x0)); repeat rewrite map_app.
  setoid_rewrite selN_app1; try rewrite map_length; try omega.
  apply HP; auto.
  setoid_rewrite selN_app2; try rewrite map_length; try omega.
  rewrite <- Heq; replace (i - length x0) with 0 by omega; simpl.
  rewrite upd_eq in H by auto.
  destruct x; inversion H; subst; simpl.
  rewrite Hp in H1; inversion H1; subst.
  eauto.
  eauto.

  specialize (H1 (length vl)); destruct H1.
  destruct H; contradict H1.
  rewrite listapp_memupd, upd_eq; auto; congruence.
  repeat deex; congruence.
Qed.

Lemma crash_xform_list2nmem_synced : forall vl (F : rawpred),
  crash_xform F (list2nmem vl) ->
  map snd vl = repeat (@nil valu) (length vl).
Proof.
  unfold crash_xform.
  induction vl using rev_ind; intros; auto.
  deex; rewrite map_app.

  pose proof (H1 (length vl)) as Hx; destruct Hx.
  destruct H as [ H Hx ]; contradict Hx.
  rewrite listapp_memupd, upd_eq by auto; congruence.
  repeat deex; auto.
  rewrite listapp_memupd, upd_eq in H by auto; inversion H; subst.

  erewrite IHvl; simpl.
  rewrite app_length; simpl.
  rewrite <- repeat_app_tail.
  f_equal; omega.
  exists (mem_except m' (length vl)).
  intuition.

  apply pred_except_mem_except; eauto.
  replace (list2nmem vl) with (mem_except (list2nmem (vl ++ [(v', nil)])) (length vl)).
  apply possible_crash_mem_except; eauto.
  rewrite listapp_memupd.
  rewrite <- mem_except_upd.
  rewrite mem_except_list2nmem_oob; auto.
Qed.

Lemma crash_xform_list2nmem_list_eq : forall F vsl vl,
  crash_xform F (list2nmem vsl) ->
  possible_crash_list vsl vl ->
  vsl = synced_list vl.
Proof.
  intros.
  destruct H0 as [Heq Hx].
  apply crash_xform_list2nmem_synced in H.
  apply list_selN_ext with (default := ($0, nil)); intros.
  rewrite synced_list_length; auto.
  rewrite synced_list_selN.
  specialize (Hx _ H0); unfold vsmerge in Hx.
  rewrite surjective_pairing at 1.
  erewrite <- selN_map with (f := snd) in * by auto.
  rewrite H in *.
  rewrite repeat_selN in * by auto.
  simpl in *; intuition.
  rewrite <- H1; simpl; auto.
  Unshelve. all: eauto.
Qed.

Lemma possible_crash_list2nmem_cons : forall l l' x y,
  possible_crash (list2nmem (x :: l)) (list2nmem (y :: l'))
  -> possible_crash (list2nmem l) (list2nmem l').
Proof.
  intros.
  unfold possible_crash; intros.
  destruct (le_dec (length l) a);
  destruct (le_dec (length l') a).
  left.
  split;
  apply list2nmem_oob; omega.

  unfold possible_crash in H;
  specialize (H (S a)); intuition.
  unfold possible_crash in H;
  specialize (H (S a)); intuition.

  unfold possible_crash in H;
  specialize (H (S a)); intuition.
Qed.

Lemma possible_crash_list2nmem_length : forall l l',
  possible_crash (list2nmem l) (list2nmem l')
  -> length l = length l'.
Proof.
  induction l; destruct l'; intros; simpl; auto.

  unfold possible_crash in H.
  specialize (H 0); intuition.
  inversion H1.
  repeat deex.
  inversion H0.

  unfold possible_crash in H.
  specialize (H 0); intuition.
  inversion H.
  repeat deex.
  inversion H.

  erewrite IHl; eauto.
  eapply possible_crash_list2nmem_cons; eauto.
Qed.

Lemma possible_crash_list2nmem_vssync : forall a d m,
  possible_crash (list2nmem (vssync d a)) m ->
  possible_crash (list2nmem d) m.
Proof.
  unfold vssync; intros.
  destruct (lt_dec a (length d)).
  rewrite listupd_memupd in H by auto.
  eapply possible_crash_upd_nil; eauto.
  apply list2nmem_sel_inb; auto.
  rewrite updN_oob in H; auto; omega.
Qed.

Lemma possible_crash_list2nmem_vssync_vecs : forall al d m,
  possible_crash (list2nmem (vssync_vecs d al)) m ->
  possible_crash (list2nmem d) m.
Proof.
  induction al using rev_ind; simpl; auto; intros.
  rewrite vssync_vecs_app in H.
  apply IHal.
  eapply possible_crash_list2nmem_vssync; eauto.
Qed.

Lemma crash_xform_diskIs_vssync_vecs : forall al d,
  crash_xform (diskIs (list2nmem (vssync_vecs d al))) =p=>
  crash_xform (diskIs (list2nmem d)).
Proof.
  intros.
  rewrite crash_xform_diskIs; cancel.
  rewrite <- crash_xform_diskIs_r; eauto.
  eapply possible_crash_list2nmem_vssync_vecs; eauto.
Qed.

Lemma setlen_singleton : forall T l (v : T),
  setlen l 1 v = [ selN (setlen l 1 v) 0 v ].
Proof.
  unfold setlen.
  destruct l; simpl in *; congruence.
Qed.

Lemma setlen_singleton_ptsto : forall (l : list valuset),
  let l' := setlen l 1 ($0, nil) in
  (0 |-> selN l' 0 ($0, nil))%pred (list2nmem l').
Proof.
  intros; subst l'.
  eapply arrayN_one.
  rewrite <- setlen_singleton.
  apply list2nmem_array.
Qed.

Lemma ptsto_0_list2nmem_mem_eq : forall V v (d : list V),
  (0 |-> v)%pred (list2nmem d) -> d = [v].
Proof.
  intros.
  apply list2nmem_inj.
  eapply ptsto_complete. eauto.
  unfold ptsto, list2nmem; simpl; intuition.
  destruct a'; try congruence.
Qed.

Lemma ptsto_a_list2nmem_a0 : forall V v (d : list V) a,
  (a |-> v)%pred (list2nmem d) -> a = 0.
Proof.
  destruct a; eauto.
  intros; exfalso.
  unfold list2nmem, ptsto in *; intuition.
  destruct d.
  {
    simpl in *.
    congruence.
  }
  {
    assert (S a = 0 -> False) by omega.
    specialize (H1 0 H); simpl in *.
    congruence.
  }
Qed.

Lemma ptsto_a_list2nmem_mem_eq : forall V v (d : list V) a,
  (a |-> v)%pred (list2nmem d) -> d = [v].
Proof.
  intros.
  eapply ptsto_a_list2nmem_a0 in H as H'; subst.
  eapply ptsto_0_list2nmem_mem_eq; eauto.
Qed.

Theorem arrayN_pimpl : forall V m (F : @pred addr addr_eq_dec V) l,
  F m ->
  arrayN (@ptsto _ _ _) 0 l m ->
  arrayN (@ptsto _ _ _) 0 l =p=> F.
Proof.
  unfold pimpl; intros.
  eapply list2nmem_array_mem_eq in H0.
  eapply list2nmem_array_mem_eq in H1.
  congruence.
Qed.

Lemma pred_except_ptsto_pimpl : forall V (l : list V) off v F,
  (F * off |-> v)%pred (list2nmem l) ->
  pred_except (arrayN (@ptsto _ _ _) 0 l) off v =p=> F.
Proof.
  unfold pimpl; intros.
  apply pred_except_ptsto_pimpl in H.
  apply H.
  pred_apply.
  apply pred_except_pimpl_proper; auto.
  unfold pimpl; intros.
  apply list2nmem_array_mem_eq in H1; subst.
  firstorder.
Qed.

Lemma arrayN_notindomain_before : forall V (l : list V) start off,
  off < start ->
  arrayN (@ptsto _ _ V) start l =p=> notindomain off.
Proof.
  induction l; simpl; intros.
  apply emp_pimpl_notindomain.
  eapply sep_star_notindomain.
  eapply ptsto_notindomain; omega.
  eauto.
Qed.

Lemma arrayN_notindomain_after : forall V (l : list V) start off,
  start + length l <= off ->
  arrayN (@ptsto _ _ V) start l =p=> notindomain off.
Proof.
  induction l; simpl; intros.
  apply emp_pimpl_notindomain.
  eapply sep_star_notindomain.
  eapply ptsto_notindomain; omega.
  eapply IHl; omega.
Qed.

Lemma arrayN_ex_notindomain : forall V (l : list V) off,
  arrayN_ex (@ptsto _ _ V) l off ⇨⇨ notindomain off.
Proof.
  unfold arrayN_ex; intros.
  apply sep_star_notindomain.
  apply arrayN_notindomain_after.
  rewrite firstn_length. simpl. apply Min.le_min_l.
  apply arrayN_notindomain_before.
  omega.
Qed.

Theorem arrayN_ex_pred_except : forall V (l : list V) off def,
  off < length l ->
  arrayN_ex (@ptsto _ _ _) l off =p=>
  pred_except (arrayN (@ptsto _ _ _) 0 l) off (selN l off def).
Proof.
  intros.
  rewrite arrayN_except with (i := off) by omega.
  rewrite <- pred_except_sep_star_ptsto_notindomain; auto.
  apply arrayN_ex_notindomain.
Qed.

Lemma arrayN_ex_frame_pimpl : forall V (l : list V) off v F,
  (F * off |-> v)%pred (list2nmem l) ->
  arrayN_ex (@ptsto _ _ _) l off =p=> F.
Proof.
  intros.
  eapply pimpl_trans; [ | eapply pred_except_ptsto_pimpl; eauto ].
  eapply list2nmem_sel with (def := v) in H as H'; rewrite H'.
  apply arrayN_ex_pred_except.
  eapply list2nmem_ptsto_bound; eauto.
Qed.


(** * Definition of grammar for expressions involving parentheses *)
Require Import Fiat.Parsers.ContextFreeGrammar.Notations.

Definition paren_expr_grammar : grammar Ascii.ascii :=
  [[[ "expr" ::== "number" || "(" "expr" ")";;
      "number" ::== [0-9] || [0-9] "number"
  ]]].


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import RunAux.Spec.
Require Import RunComplete.Specs.complete_hvc_exit.
Require Import RunComplete.LowSpecs.complete_hvc_exit.
Require Import RunComplete.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       get_rec_last_run_info_esr_spec
       set_rec_regs_spec
       get_rec_run_gprs_spec
       reset_last_run_info_spec
    .

  Lemma complete_hvc_exit_spec_exists:
    forall habd habd'  labd rec
           (Hspec: complete_hvc_exit_spec rec habd = Some habd')
            (Hrel: relate_RData habd labd),
    exists labd', complete_hvc_exit_spec0 rec labd = Some labd' /\ relate_RData habd' labd'.
    Proof.
      intros. destruct Hrel. destruct rec. Local Transparent Z.add.
      unfold complete_hvc_exit_spec, complete_hvc_exit_spec0 in *.
      repeat autounfold in *. simpl in *.
      hsimpl_hyp Hspec; inv Hspec; simpl_query_oracle; extract_prop_dec;
        repeat destruct_con; simpl in *; srewrite; repeat simpl_update_reg;
          repeat (simpl_htarget; grewrite; simpl in * ).
      unfold ref_accessible in *. autounfold.
      repeat (grewrite; try rewrite ZMap.gss; try rewrite ZMap.set2; simpl; grewrite; simpl).
      eexists; split. reflexivity. constructor. repeat (repeat simpl_field; repeat swap_fields).
      repeat simpl_update_reg. reflexivity.
      eexists; split. reflexivity. constructor. reflexivity.
    Qed.

End Refine.


Require Import Coq.Init.Peano.
Require Import Notations.
Require Import Coq.Lists.List.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.omega.Omega.
Require Import Coq.Arith.Le.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Numbers.NatInt.NZMul.
Require Import Coq.Structures.OrdersFacts.
Require Import Coq.ZArith.Znat.
Require Import Coq.QArith.QArith_base.
Require Import  Coq.QArith.QOrderedType.
Require Import QArith_base Equalities Orders OrdersTac.
Require Import Coq.Sorting.Permutation.
Require Import Wf.
Require Import Lexicographic_Product.
Require Import Qreduction.
Require Import Coq.Bool.Bool.
Require Import Inverse_Image.
Require Import Coq.Bool.Sumbool.
Require Import Coq.Sorting.Mergesort.
Import ListNotations.
Require Import Coq.Program.Basics.
Require Import Coq.Arith.Wf_nat.
Require Import Program.
Require Import  Recdef.
Add LoadPath "/home/users/u5711205/Modular-STVCalculi/".
Require Export Parameters.
Require Import FrameBase.
Add LoadPath "/home/users/u5711205/Modular-STVCalculi/ActSTV".
Require Export Instantiation.
Import Instantiate.
Import M.
Import QSort.

(*Module Act.*)

Section ACT.

Definition ACT_InitStep (prem :Machine_States) (conc :Machine_States): Prop :=
 exists ba ba',
  ((prem = (initial  ba)) /\
  (ba' = (Filter ba)) /\
  (conc = state  (ba', [nty], nas, (nbdy, nbdy), emp_elec , all_hopeful))).

Definition ACT_count (prem: Machine_States) (conc: Machine_States) : Prop :=
 exists ba t nt p np bl h e,                (** count the ballots requiring attention **)
  prem = state (ba, t, p, bl, e, h) /\     (* if we are in an intermediate state of the count *)
  [] <> ba /\                                        (* and there are ballots requiring attention *)
  (forall c, if (cand_in_dec c (proj1_sig h))
      then
  (exists l,
    np(c) = p(c) ++ [l] /\
    (forall b, In (proj1_sig (fst b)) (map (fun (d:ballot) => (proj1_sig (fst d))) l) <->
                                                               fcc ba (proj1_sig h) c b) /\
    (nt (c) = SUM (np(c))))
      else ((nt c) = (hd nty t) c) /\ (np c) = (p c)) /\
  conc = state ([], nt :: t, np, bl, e, h).

Definition ACT_hwin (prem: Machine_States) (conc: Machine_States) : Prop :=
  exists w ba t p bl e h,
   prem = state (ba, t, p, bl, e, h) /\
   length (proj1_sig e) + length (proj1_sig h) <= st /\
   w = (proj1_sig e) ++ (proj1_sig h) /\
   conc = winners (w).

Definition ACT_ewin (prem: Machine_States) (conc: Machine_States) : Prop :=
  exists w ba t p bl e h,                    (** elected win **)
   prem = state (ba, t, p, bl, e, h) /\   (* if at any time *)
   length (proj1_sig e) = st /\             (* we have as many elected candidates as seats *)
   w = (proj1_sig e) /\                        (* and the winners are precisely the electeds *)
   conc = winners (w).                      (* they are declared the winners *)

Definition ACT_elim (prem: Machine_States) (conc: Machine_States) : Prop :=
  exists nba t p np bl2 e h nh,
   prem = state ([], t, p, ([], bl2), e, h) /\
   length (proj1_sig e) + length (proj1_sig h) > st /\
   (forall c, In c (proj1_sig h) -> (hd nty t(c) < quota)%Q) /\
   exists c,
     ((forall d, In d (proj1_sig h) -> (hd nty t(c) <= hd nty t(d)))%Q /\
     eqe c (proj1_sig nh) (proj1_sig h) /\
     nba = flat_map (fun x => x) (p c) /\
     np(c)=[] /\
     (forall d, d <> c -> np (d) = p (d)) /\
   conc = state (nba, t, np, ([], []), e, nh)).

Definition ACT_TransferElected (prem: Machine_States) (conc: Machine_States) : Prop :=
 exists nba t p np bl nbl h e,
  prem = state ([], t, p, bl, e, h) /\
  (length (proj1_sig e) < st) /\
  (forall c, In c (proj1_sig h) -> ((hd nty t) c < quota)%Q) /\
  exists l c bl2,
   (bl = (c :: l,bl2) /\
   nbl = (l,bl2) /\
   nba = last (p c) [] /\ np(c) = [] /\
     (forall d, d <> c -> np(d) = p(d))) /\
   conc = state (nba, t, np, nbl, e, h).

 (*
 Definition CADE_elect
  (prem: Machine_States) (conc: Machine_States) : Prop :=
   exists nba t p np bl nbl  nh h e ne,
   (1) prem = state ([], t, p, bl, e, h) /\
   (2) exists c,
   (3)  length (proj1_sig e) + 1 <= st /\
   (4)  In c (proj1_sig h) /\ (hd nty t (c) >= quota)%Q /\
   (5)  eqe c (proj1_sig e) (proj1_sig ne) /\
   (6)  (forall d, In d (proj1_sig nh) <->
         In d cand_all /\ (~ In d (proj1_sig ne))) /\
   (7)  (forall d, In d cand_all -> (np d = [])) /\
   (8)  (fst nbl = []) /\
   (9)  (nba = Append_All cand_all p) /\
   (10) conc = state (nba, t, np, nbl, ne, nh).
 *)

 Definition ACT_Elect (prem: Machine_States) (conc: Machine_States) : Prop :=
  exists (nba: list ballot) t p np (bl nbl: (list cand) * (list cand)) nh h e ne,
    prem = state ([], t, p, bl, e, h) /\
    exists l,
     (l <> [] /\
     length l <= st - length (proj1_sig e) /\
     (forall c, In c l -> In c (proj1_sig h) /\ (hd nty t (c) >= quota)%Q) /\
     ordered (hd nty t) l /\
     Leqe l (proj1_sig nh) (proj1_sig h) /\
     Leqe l (proj1_sig e) (proj1_sig ne) /\
     (forall c, In c l -> ((np c) = map (map (fun (b : ballot) =>
      (fst b, (Qred (snd b * (Update_transVal c p (hd nty t))))%Q))) [(last (p c) [])])) /\
     (forall c, ~ In c l -> np (c) = p (c)) /\
     fst nbl = (fst bl) ++ l) /\ (nba = []) /\
   conc = state ([], t, np, nbl, ne, nh).

(* (e ne: {l : list cand | length l <= st })
Definition ACT_TransferElected2 (prem: Machine_States) (conc: Machine_States) :=
 exists nba t p np bl nbl h e,
  prem = state ([], t, p, bl, e, h) /\
    (length (proj1_sig e) < st) /\
    (forall c, In c (proj1_sig h) -> ((hd nty t) c < quota)%Q) /\
    exists l c,
     (bl = (c :: l, []) /\
     nbl = (l, []) /\
     nba = concat (p c) /\
     concat (p c') = [] /\
     np(c) = [] /\
     (forall d, d <> c -> np(d) = p(d))) /\
   conc = state (nba, t, np, nbl, e, h).
*)

Definition ACT_TransferElim (prem: Machine_States) (conc: Machine_States) :=
 exists nba t p np bl nbl h e,
  prem = state ([], t, p, bl, e, h) /\
    (length (proj1_sig e) < st) /\
    (forall c, In c (proj1_sig h) -> ((hd nty t) c < quota)%Q) /\
    exists bl1 c' l',
     (bl = (bl1, c'::l') /\
    (*(match  (concat (np c')) with
        [] => nbl = (bl1, l')
       | _ => nbl = (bl1, c'::l')
      end) /\*)
      (concat (p c') <> []) /\
      nbl = (bl1, c'::l') /\
      let x:= (groupbysimple _ (sort (concat (p c')))) in
       (nba = last x []) /\
       np c' = (removelast x) /\
       (*/\
       (match concat (np c') with [] => (nbl = (bl1,l')) | _ => (nbl = (bl1,c'::l')) end) *)
       (forall d, d <> c' -> np(d) = p(d))) /\
   conc = state (nba, t, np, nbl, e, h).

Lemma ACTInitStep_SanityCheck_App : SanityCheck_Initial_App ACT_InitStep.
Proof.
 unfold SanityCheck_Initial_App.
 intros.
 exists (state (Filter ba, [nty], nas, (nbdy, nbdy), emp_elec, all_hopeful)).
 split. auto.
 unfold ACT_InitStep.
 exists ba.
 exists (Filter ba).
 split. assumption.
 split;auto.
Qed.

Lemma ACTInitStep_SanityCheck_Red: SanityCheck_Initial_Red ACT_InitStep.
 unfold SanityCheck_Initial_Red.
 intros.
 unfold ACT_InitStep in H.
 destruct H as [ba [ba' H1]].
 exists ba. exists ba'. exists [nty]. exists nas. exists (nbdy, nbdy). exists emp_elec. exists all_hopeful.
 split;auto.
 intuition.
 intuition.
Qed.

Hypothesis Bl_hopeful_NoIntersect : forall j: Machine_States, forall ba t p bl e h, j = state (ba,t,p,bl,e,h) ->
 (forall c, In c (snd bl) -> ~ In c (proj1_sig h)) * (forall c, In c (fst bl) -> ~ In c (snd bl)).

Lemma ACTCount_SanityCheck_App : SanityCheck_Count_App ACT_count.
Proof.
 unfold SanityCheck_Count_App.
 intros.
 exists (state ([], (fun (c:cand) =>  if (cand_in_dec c (proj1_sig h)) then SUM (p (c) ++ [list_is_first_hopeful c (proj1_sig h) ba]) else (hd nty t) c) :: t, fun (c:cand) => (if (cand_in_dec c (proj1_sig h)) then (p (c) ++ [list_is_first_hopeful c (proj1_sig h) ba]) else (p c)), bl, e, h)).
 unfold ACT_count.
 exists ba.
 exists t.
 exists ((fun (c:cand) =>  if (cand_in_dec c  (proj1_sig h)) then SUM (p (c) ++ [list_is_first_hopeful c (proj1_sig h) ba]) else ((hd nty t) c))).
 exists p.
 exists (fun (c:cand) => (if (cand_in_dec c (proj1_sig h)) then (p (c) ++ [list_is_first_hopeful c (proj1_sig h) ba]) else (p c))).
 exists bl.
 exists h.
 exists e.
 split; auto.
 split; auto.
 split.
 intro c.
 destruct (cand_in_dec c (proj1_sig h)).
 exists (list_is_first_hopeful c (proj1_sig h) ba).
 split; auto.
 split.
 intro b.
 apply (listballot_fcc ba t p bl e h quota c i b).
 simpl.
 destruct (cand_in_dec c (proj1_sig h)). auto.
 contradict n. assumption.
 simpl.
 destruct (cand_in_dec c (proj1_sig h)).
 contradict n. assumption.
 auto. auto.
Qed.

Lemma ACTCount_SanityCheck_Red: SanityCheck_Count_Red ACT_count.
 Proof.
 unfold SanityCheck_Count_Red.
 intros.
 unfold ACT_count in H.
 destruct H as [ba [t [nt [ p0 [np [bl [h [e H1]]]]]]]].
 destruct H1 as [H11 [H12 [H13 H14]]].
 assert (old_new_pile_equal_bl: forall c, In c (snd bl) -> p0 c = np c).
 specialize (Bl_hopeful_NoIntersect p ba t p0 bl e h H11).
 intros c0  Hyp.
 destruct Bl_hopeful_NoIntersect as [NoIntersect1 NoIntersect2].
 specialize (NoIntersect1 c0 Hyp).
 specialize (H13 c0).
 destruct (cand_in_dec c0 (proj1_sig h)).
 contradict NoIntersect1.
 assumption.
 intuition.
 exists ba; exists ([]: list ballot); exists t. exists nt; exists p0.
 exists np; exists bl; exists e; exists h. split. intuition.
 split; intuition.
 specialize (list_nonempty ballot ba). intro Hyp.
 intuition.
 destruct H as [b [l Hyp1]].
 rewrite Hyp1.
 simpl.
 omega.
 assert (hyp2: forall c, In c (snd bl) -> length (concat (p0 c)) = length (concat (np c))).
 intros.
 specialize (old_new_pile_equal_bl c0 H).
 rewrite old_new_pile_equal_bl.
 reflexivity.
 specialize (map_ext_in (fun c0 => length (concat (p0 c0))) (fun c0 => length (concat (np c0))) (snd bl) hyp2).
 intro.
 rewrite H. auto.
Qed.

Lemma  ACTHwin_SanityCheck_App : SanityCheck_Hwin_App ACT_hwin.
Proof.
 unfold SanityCheck_Hwin_App.
 intros.
 unfold ACT_hwin.
 exists (winners ((proj1_sig e) ++ (proj1_sig h))).
 exists ((proj1_sig e) ++ (proj1_sig h)).
 exists ba; exists t; exists p; exists bl; exists e; exists h.
 auto.
Qed.

Lemma ACTHwin_SanityCheck_Red : SanityCheck_Hwin_Red ACT_hwin.
Proof.
 unfold SanityCheck_Hwin_Red.
 intros.
 unfold ACT_hwin in H.
 destruct H as [w [ba [t [p [bl [e [h H1]]]]]]].
 exists w; exists ba; exists t; exists p; exists bl; exists e; exists h.
 intuition.
Qed.

Lemma ACTEwin_SanityCheck_App : SanityCheck_Ewin_App ACT_ewin.
Proof.
 unfold SanityCheck_Ewin_App.
 intros.
 unfold ACT_ewin.
 exists (winners (proj1_sig e)).
 exists (proj1_sig e). exists ba. exists t. exists p. exists bl. exists e. exists h.
 intuition.
Qed.

Lemma ACTEwin_SanityCheck_Red : SanityCheck_Ewin_Red ACT_ewin.
Proof.
 unfold SanityCheck_Ewin_Red.
 intros.
 unfold ACT_ewin in H.
 destruct H as [w [ba [t [p [bl [e [h H1]]]]]]].
 exists w. exists ba. exists t. exists p. exists bl. exists e. exists h.
 intuition.
 rewrite <- H0.
 assumption.
Qed.

Lemma ACTElim_SanityCheck_App : SanityCheck_Elim_App ACT_elim.
Proof.
 unfold SanityCheck_Elim_App.
 intros.
 unfold ACT_elim.
 specialize (list_min cand (proj1_sig h) (hd nty t)). intro min_hopeful.
 destruct min_hopeful.
 rewrite e0 in H0.
 destruct H0 as [H01 H02].
 destruct e.
 simpl in H01.
 omega.
 destruct s as [min [s1 s2]].
 specialize (remc_nodup (proj1_sig h) min (proj2_sig h) s1);intro H'1.
 exists (state (flat_map (fun x => x) (p min), t, fun d => if (cand_eq_dec d min) then [] else (p d),
                                                ([], []), e, exist _ (remc min (proj1_sig h)) H'1)).
 exists (flat_map (fun x => x) (p min)).
 exists t. exists p. exists (fun d => if (cand_eq_dec d min) then [] else (p d)). exists bl2. exists e. exists h.
 exists (exist _ (remc min (proj1_sig h)) H'1).
 intuition.
(* exists bl2.
 intuition.
 simpl.*)
 exists min.
 intuition.
 apply (remc_ok min (proj1_sig h) (proj2_sig h) s1).
 destruct (cand_eq_dec min min) as [i | j]. reflexivity.
 contradict j. auto.
 destruct (cand_eq_dec d min) as [i | j]. contradiction i. reflexivity.

 exists min.
 intuition.
 apply (remc_ok min (proj1_sig h) (proj2_sig h) s1).
 destruct (cand_eq_dec min min) as [i | j]. auto. contradict j. reflexivity.
 destruct (cand_eq_dec d min) as [i | j]. contradiction. auto.
Qed.

Lemma ACTElim_SanityCheck_Red : SanityCheck_Elim_Red ACT_elim.
 Proof.
 unfold SanityCheck_Elim_Red.
 intros.
 unfold ACT_elim in H.
 destruct H as [nba [t [p [np [bl2 [e [h [nh  H1]]]]]]]].
 destruct H1 as [H11 [H12 [H13 H14]]].
 destruct H14 as [weakest H141].
 exists nba. exists t. exists p. exists np. exists e. exists h. exists nh.  exists bl2. exists ([]: list cand).
 intuition.
 unfold eqe in H1.
 destruct H1 as [l1 [l2 [H' [H'' [H''' H'''']]]]].
 rewrite H'.
 rewrite H''.
 assert (Hyp : length (l1 ++ [weakest] ++ l2) = (length l1 + (length ([weakest] ++ l2)))% nat).
 simpl.
 rewrite (app_length).
 simpl. auto.
 rewrite Hyp.
 simpl.
 rewrite (app_length). omega.
(* exists ([]: list cand).
 exists ([]: list cand).
 intuition. *)
Qed.

Lemma ACT_TransferElected_SanityCheck_App : SanityCheck_TransferElected_App ACT_TransferElected.
Proof.
 unfold SanityCheck_TransferElected_App.
 intros.
 destruct H0 as [H1 [H2 [H3 H4]]].
 specialize (list_nonempty_type cand bl1 H2). intro Hyp. destruct Hyp as [head [tail Hyp1]].
 exists (state (last (p head) [], t, fun d => if (cand_eq_dec d head) then [] else (p d), (tail,bl2), e, h)).
 unfold ACT_TransferElected. exists (last (p head) []). exists t. exists p.
 exists (fun d => if (cand_eq_dec d head) then [] else (p d)).
 exists (head::tail, (bl2: list cand)). exists (tail, (bl2: list cand)). exists h. exists e. rewrite Hyp1 in H. simpl in H.
 intuition.
 exists tail. exists head. exists bl2.
 intuition.
 destruct (cand_eq_dec head head) as [i | j]. reflexivity. contradict j. auto.
 destruct (cand_eq_dec d head) as [i | j]. contradiction i. reflexivity.

exists tail. exists head. exists bl2. intuition.
destruct (cand_eq_dec head head) as [i | j]. auto. contradict j. reflexivity.
destruct (cand_eq_dec d head) as [i |j]. contradiction. auto.
Qed.

Lemma ACT_TransferElected_SanityCheck_Red : SanityCheck_TransferElected_Red ACT_TransferElected.
Proof.
 unfold SanityCheck_TransferElected_Red.
 intros.
 unfold ACT_TransferElected in H.
 destruct H as [nba [t [p [np [bl [nbl [h [e H1]]]]]]]].
 destruct H1 as [H11 [H12 [H13 H14]]].
 destruct H14 as [l [candid [bl2 H141]]].
 destruct H141 as [H1411 H1412].
 destruct H1411 as [H3 [H4 H5]].
 exists nba. exists t. exists p. exists np. exists bl. exists nbl. exists h. exists e.
 intuition.
 rewrite H3.
 rewrite H4.
 simpl.
(* left. *)
 omega.
 assert (Leneq: forall d, In d bl2 -> length (concat (p d)) = length (concat (np d))).
 intros d Assum.
 specialize (Bl_hopeful_NoIntersect premise [] t p bl e h).
 intuition.
 assert (Hypos: d <> candid). intro HypoAux. specialize (b candid). rewrite H3 in b. simpl in b.
 apply b. left;auto. rewrite HypoAux in Assum. auto.
 specialize (H2 d Hypos). rewrite H2. reflexivity.
 specialize (map_ext_in (fun c => length (concat (p c))) (fun c => length (concat (np c))) bl2 Leneq).
 intro H0. rewrite H3. simpl.  rewrite H4. simpl. rewrite H0. auto.
Qed.

Lemma ACT_Elect_SanityCheck_App : SanityCheck_Elect_App ACT_Elect.
Proof.
 unfold SanityCheck_Elect_App.
 intros premise t p bl e h H X.
 unfold ACT_Elect.
 specialize (constructing_electable_first).
 intro H1.
 destruct X as [c [X1 X2]].
 assert (Hyp: length (proj1_sig e) < st).
 omega.
 specialize (H1 e (hd nty t) h quota Hyp (proj2_sig h)).
 destruct H1 as [listElected H11].
 destruct H11 as [H111 [H112 [H113 [H114 H115]]]].
 specialize (Removel_nodup listElected (proj1_sig h) (proj2_sig h)). intro NoDupH.
 assert (Assum: length ((proj1_sig e) ++ listElected) <= st).
 rewrite app_length.
 omega.
 exists (state ([], t, fun c => update_pile_ManualACT p (hd nty t) listElected quota c,
((fst bl) ++ listElected, snd bl), exist _ ((proj1_sig e) ++ listElected) Assum,
                                   exist _ (Removel listElected (proj1_sig h)) NoDupH)).
 exists ([]: list ballot).  exists t. exists p. exists (fun x => update_pile_ManualACT p (hd nty t) listElected quota x).
 exists bl. exists ((fst bl) ++ listElected, snd bl). exists (exist _ (Removel listElected (proj1_sig h)) NoDupH).
 exists h. exists e. exists (exist (fun v => length v <= st) ((proj1_sig e) ++ listElected) Assum).
 split. auto.
 exists listElected.
 intuition.
 assert (NonEmptyElected: length listElected = 0).
 rewrite H2.
 simpl. reflexivity.
 assert (VacantSeat: length (listElected) < st - (length (proj1_sig e))).
 rewrite app_length in Assum.
 rewrite NonEmptyElected in Assum.
 omega.
 specialize (H115 c).
 intuition.
 rewrite H2 in H3.
 inversion H3.
 simpl.
 unfold Leqe.
 apply Permutation_App.
 apply (nodup_permutation).
 intros candid HypCand.
 specialize (H111 candid HypCand).
 intuition.
 assumption.
 apply (proj2_sig h).
 simpl.
 unfold Leqe.
 apply Permutation_refl.
 unfold update_pile_ManualACT.
 destruct (cand_in_dec c0 listElected) as [i |j].
 trivial.
 contradict j. assumption.
 unfold update_pile_ManualACT.
 destruct (cand_in_dec c0 listElected) as [i |j].
 contradict i.
 assumption.
 auto.
Qed.

Lemma subList_CandAll : forall l, incl l cand_all.
Proof.
 intro l.
 unfold incl.
 intros.
   apply (cand_finite a).
Qed.

Hypothesis noDup_elect : forall j: Machine_States, forall ba t p bl e h,
  j = state (ba,t,p,bl,e,h) -> NoDup (proj1_sig e).

Variable A : Type.

 Inductive Add (a:Cand) : list Cand -> list Cand -> Prop :=
    | Add_head l : Add a l (a::l)
    | Add_cons x l l' : Add a l l' -> Add a (x::l) (x::l').

Lemma Add_app a l1 l2 : Add a (l1++l2) (l1++a::l2).
  Proof.
   induction l1; simpl; now constructor.
  Qed.

 Lemma Add_inv a l : In a l -> exists l', Add a l' l.
  Proof.
   intro Ha. destruct (in_split _ _ Ha) as (l1 & l2 & ->).
   exists (l1 ++ l2). apply Add_app.
  Qed.

  Lemma Add_length a l l' : Add a l l' -> length l' = S (length l).
  Proof.
   induction 1; simpl; auto with arith.
  Qed.

  Lemma Add_in a l l' : Add a l l' ->
   forall x, In x l' <-> In x (a::l).
  Proof.
   induction 1; intros; simpl in *; rewrite ?IHAdd; tauto.
  Qed.

  Lemma incl_Add_inv a l u v :
    ~In a l -> incl (a::l) v -> Add a u v -> incl l u.
  Proof.
   intros Ha H AD y Hy.
   assert (Hy' : In y (a::u)).
   { rewrite <- (Add_in a u v AD). apply H; simpl; auto. }
   destruct Hy'; [ subst; now elim Ha | trivial ].
  Qed.

 Lemma NoDup_incl_length (l: list Cand) l' :
    NoDup l -> incl l l' -> length l <= length l'.
  Proof.
   intros N. revert l'. induction N as [|a l Hal N IH]; simpl.
   - auto with arith.
   - intros l' H.
     destruct (Add_inv a l') as (l'', AD). { apply H; simpl; auto. }
     rewrite (Add_length a l'' l' AD). apply le_n_S. apply IH.
     now apply incl_Add_inv with a l'.
  Qed.

Lemma ACT_Elect_SanityCheck_Red : SanityCheck_Elect_Red ACT_Elect.
Proof.
 unfold SanityCheck_Elect_Red.
 intros premise conclusion H.
 unfold ACT_Elect in H.
 destruct H as [nba [t [p [np [bl [nbl [nh [h [e [ne H1]]]]]]]]]].
 exists nba. exists t. exists p; exists np. exists bl. exists nbl. exists e. exists ne. exists nh. exists h.
 destruct H1 as [H11 H12].
 destruct H12 as [l H121].
 intuition.
 unfold Leqe in H6.
 specialize (Permutation_length H6). intro Permut_length.
 assert (lem: forall n m k, k <= n -> m <= n -> m < k -> (n - k < n - m)).
  intros. omega.
 apply lem.
 specialize (noDup_elect (state([],t,np,nbl,ne,nh)) [] t np nbl ne nh eq_refl).
 apply (NoDup_incl_length (` ne) cand_all).
 auto.
 apply subList_CandAll.
 specialize (noDup_elect (state([],t,p,bl,e,h)) [] t p bl e h eq_refl).
 apply (NoDup_incl_length (` e) cand_all).
 auto.
 apply subList_CandAll.

 rewrite Permut_length.
 rewrite  app_length.
 specialize (list_nonempty_type cand l H1). intro X.
 destruct X as [c [l' HX]].
 rewrite HX. (*Search (_ - _  < _).
 Require Import Psatz. Require Import Coq.omega.PreOmega. zify.*)
 simpl.
 omega.
 rewrite H.
 assumption.
(* unfold Leqe in H5.
 specialize (Permutation_length H5). intro H8.
 rewrite H8.
 rewrite app_length.
 specialize (list_nonempty_type cand l H1). intro X.
 destruct X as [c [l' HX]].
 rewrite HX.
 simpl.
 omega.*)
Qed.

(*
Lemma ACTTran2_SanityCheck_App : SanityCheck_Transfer2_App ACT_TransferElected2.
Proof.
 unfold SanityCheck_Transfer2_App.
 intros.
 unfold ACT_TransferElected2.
 destruct H0 as [H1 [H2 [H3 H4]]].
 specialize (list_nonempty_type cand bl1 H2). intro Nonempty_bl.
 destruct Nonempty_bl as [Headbl1 [Tailbl1 bl1None]].

 exists (state (concat (p Headbl1), t, fun x => if (cand_eq_dec x Headbl1) then [] else p x,
                (Tailbl1, bl2), e, h)).
 exists (concat (p Headbl1)).
 exists t. exists p. exists (fun x => if (cand_eq_dec x Headbl1) then [] else (p x)).
 exists (Headbl1:: Tailbl1, c:: bl2). exists (Tailbl1,bl2). exists h. exists e.
 rewrite bl1None in H.
 intuition.
 exists Tailbl1. exists Headbl1. exists c. exists bl2.
 intuition.
 destruct (cand_eq_dec Headbl1 Headbl1) as [i | j].
 reflexivity.
 contradict j.  auto.
 destruct (cand_eq_dec d Headbl1) as [i | j].
 contradict i.
 auto.
 reflexivity.
Qed.

Lemma ACTTran2_SanityCheck_Red : SanityCheck_Transfer_Red ACT_TransferElected2.
Proof.
 unfold SanityCheck_Transfer_Red.
 intros.
 unfold ACT_TransferElected2 in H.
 destruct H as [nba [t [p [np [bl [nbl [h [e H1]]]]]]]].
 destruct H1 as [H11 [H12 [H13 H14]]].
 destruct H14 as [Tbl1 [Hbl1 [Hbl2 [Tbl2 H15]]]].
 exists nba.
 exists t. exists p. exists np. exists bl. exists nbl. exists h. exists e.
 destruct H15 as [H15 H152].
 destruct H15 as [HH1 HH2].
 destruct HH2 as [HH21 [HH22 [HH23 [HH24 HH25]]]].
 assert (Hypo: forall d, In d Tbl2 -> p (d) = np (d)).
 intros d Hy.
 assert (hypos: d <> Hbl1). intro contHypos. rewrite contHypos in Hy.
 specialize (Bl_hopeful_NoIntersect (state ([],t,p,bl, e,h)) [] t p bl e h (eq_refl)).
 destruct Bl_hopeful_NoIntersect as [i j].
 specialize (j Hbl1).
 rewrite HH1 in j.
 assert (hyu: In Hbl1 (fst (Hbl1:: Tbl1, Hbl2:: Tbl2))).
 simpl. left;auto.
 specialize (j hyu).
 apply j.
 simpl.
 right;assumption.
 specialize (HH25 d hypos).
 auto.
 split.  auto.
 split. left. rewrite HH1. rewrite HH21.
 simpl. rewrite HH23.
 assert (Leneq: forall d, In d Tbl2 -> length (concat (p d)) = length (concat (np d))).
 intros d he.
 specialize (Hypo d he). rewrite Hypo. auto.
 specialize (map_ext_in (fun c => length (concat (p c))) (fun d => length (concat (np d))) Tbl2 Leneq).
 intro map_equal.
 rewrite map_equal.
 simpl.
 omega.
 auto.
Qed.
*)

Hypothesis Bl_NoDup : forall j: Machine_States, forall ba t p bl e h,
  j = state (ba,t,p,bl,e,h) -> NoDup (snd bl).

Lemma ACT_TransferRemoved_SanityCheck_App : SanityCheck_TransferRemoved_App ACT_TransferElim.
Proof.
 unfold SanityCheck_TransferRemoved_App.
 intros.
 (* destruct H0 as [H1 [H2 [H3 H4]]]. *)
destruct H0 as [H1 [H2 H3]].
 unfold ACT_TransferElim.
 exists (state (((last (groupbysimple _ (sort (concat (p c)))) []): list ballot),
 t, fun d => if (cand_eq_dec d c) then (removelast (groupbysimple _ (sort (concat (p c))))) else p d, (bl1, c::bl2), e, h)).
 exists (last (groupbysimple _ (sort (concat (p c)))) []).
 exists t. exists p. exists (fun d => if (cand_eq_dec d c)
   then (removelast ((groupbysimple _ (sort (concat (p c))))))  else p d).
 exists (bl1,c::bl2).
 exists (bl1, c::bl2).
exists h. exists e. intuition.
  exists bl1. exists c. exists bl2. intuition.
(*specialize (list_nonempty_type cand bl1 H2). intro Nbl1.
 destruct Nbl1 as [Hbl1 [Tbl1 bl1N]].
 exists Tbl1. exists Hbl1. exists c. exists bl2.
 rewrite bl1N.
 intuition. *)
 destruct (cand_eq_dec c c) as [i | j]. simpl. trivial.
 contradict j. reflexivity.
 destruct (cand_eq_dec d c) as [i |j]. simpl. trivial.
 contradiction i. reflexivity.
Qed.

Lemma concat_app : forall (A:Type) (l1: list (list A)) l2, concat (l1 ++ l2) = concat l1 ++ concat l2.
Proof.
  intros.
  induction l1 as [|x l1 IH]. induction l2. simpl.
  reflexivity. simpl. auto.
  simpl. rewrite IH; apply app_assoc.
Qed.

Lemma ACT_TransferRemoved_SanityCheck_Red: SanityCheck_TransferRemoved_Red ACT_TransferElim.
Proof.
 unfold SanityCheck_TransferRemoved_Red.
 intros.
 unfold ACT_TransferElim in H.
 destruct H as [nba [t [p [np [bl [nbl [h [e H1]]]]]]]].
 destruct H1 as [H11 [H12 [H13 H14]]].
 destruct H14 as [bl1 [Hbl2 [Tbl2 H15]]].
 (*destruct H14 as [bl1 [c' [l' H15]]].*)
 destruct H15 as [H151 H152].
 destruct H151 as [K1 [K11 K2]].
 destruct K2 as [K21 [K22 [K23 K24]]].
 exists nba. exists t. exists p. exists np. exists bl. exists nbl. exists h. exists e.
 split. assumption.
 split. rewrite K1. rewrite K21. simpl. auto.
 rewrite K1. rewrite K21. simpl.

 assert (Tbl2_NoDup: NoDup (Hbl2 :: Tbl2)).
 specialize (Bl_NoDup (state ([],t,p,bl,e,h)) [] t p bl e h (eq_refl)).
 rewrite K1 in Bl_NoDup.
 simpl in Bl_NoDup.
 assumption.
 assert (Hbl2_notInTail: ~ In Hbl2 Tbl2).
 intro Cont.
 inversion Tbl2_NoDup.
 apply H1. assumption.
 assert (Piles_eq_Tbl2: forall d, In d Tbl2 -> p d = np d).
 intros d InTbl2.
 assert (not_eq_d: d <> Hbl2).
 intro cont. rewrite cont in InTbl2. apply Hbl2_notInTail. assumption.
 specialize (K24 d not_eq_d).
 auto.
 assert (Len_piles_eq: forall d, In d Tbl2 -> length (concat (p d)) = length (concat (np d))).
 intros d Hy.
 specialize (Piles_eq_Tbl2 d Hy).
 rewrite Piles_eq_Tbl2. auto.
 specialize (map_ext_in (fun c => length (concat (p c))) (fun c => length (concat (np c))) Tbl2 Len_piles_eq).
 intro nice.
 rewrite nice.
 (* rewrite K24.*)
 rewrite K23.
 assert (Hypo: (groupbysimple _ (sort (concat (p Hbl2)))) <> []).
 apply groupbysimple_not_empty.
 apply sherin.
 auto.
 assert (Hypo2: groupbysimple _ (sort (concat (p Hbl2))) =
(removelast (groupbysimple _ (sort (concat (p Hbl2))))) ++ [last (groupbysimple _ (sort (concat (p Hbl2)))) []]).
 apply app_removelast_last.
 assumption.
 assert (Hypo222: concat (groupbysimple _ (sort (concat (p Hbl2)))) =
                  concat ((removelast (groupbysimple _ (sort (concat (p Hbl2)))))
                            ++
                            [last (groupbysimple _ (sort (concat (p Hbl2)))) []])).
 apply f_equal. assumption.
 rewrite concat_app in Hypo222.

 assert (Hypo22: length (concat (groupbysimple _ (sort (concat (p Hbl2))))) =
 (length (concat (removelast (groupbysimple _ (sort (concat (p Hbl2)))))) +
  length (concat [last (groupbysimple _ (sort (concat (p Hbl2)))) []]))%nat).
 rewrite <- app_length. apply f_equal. auto.
 assert (Hypolen : length
            (concat (groupbysimple {v : list cand | NoDup v /\ [] <> v} (sort (concat (p Hbl2))))) =
                   length (concat (p Hbl2))).
 rewrite <- concat_rat. auto.
 rewrite <- Hypolen.
 rewrite  Hypo22.
 simpl.
 assert (Hlen : forall (A : Type) (l : list A),
            l <> []  -> 0 < length l).
 intros. destruct l. contradiction H. auto. simpl. omega.
 specialize (groupby_notempty _ (sort (concat (p Hbl2)))). intros.
 pose proof (sortedList_notempty (concat (p Hbl2)) K11).
 specialize (H H0).
 specialize (Hlen _ _ H).
 rewrite app_nil_r. split.
 apply Nat.add_lt_mono_r.
 apply NPeano.Nat.lt_add_pos_r. trivial. rewrite <- K21.
 auto.
Qed.

Variable bs: list ballot.

Definition ActSTV := (mkSTV
    (ACT_InitStep) (ACTInitStep_SanityCheck_App) (ACTInitStep_SanityCheck_Red)
    (ACT_count) (ACTCount_SanityCheck_App) (ACTCount_SanityCheck_Red)
    (ACT_TransferElected) (ACT_TransferElected_SanityCheck_App) (ACT_TransferElected_SanityCheck_Red)
   (* (ACT_TransferElected2) (ACTTran2_SanityCheck_App) (ACTTran2_SanityCheck_Red) *)
    (ACT_TransferElim) (ACT_TransferRemoved_SanityCheck_App) (ACT_TransferRemoved_SanityCheck_Red)
    (ACT_Elect) (ACT_Elect_SanityCheck_App) (ACT_Elect_SanityCheck_Red)
    (ACT_elim) (ACTElim_SanityCheck_App) (ACTElim_SanityCheck_Red)
    (ACT_hwin) (ACTHwin_SanityCheck_App) (ACTHwin_SanityCheck_Red)
    (ACT_ewin) (ACTEwin_SanityCheck_App) (ACTEwin_SanityCheck_Red)).

Lemma init_stages_R_initial : ~ State_final (initial (Filter bs)).
Proof.
 intro.
 unfold State_final in H.
 destruct H.
 inversion H.
Qed.

Definition Act_Termination := M.Termination bs (initial (Filter bs)) init_stages_R_initial ActSTV.

End ACT.

(*End Act.*)

Extraction Language Haskell.
Extraction "Act.hs" Act_Termination.

(*End Act.*)


(* -*- company-coq-local-symbols: (("|=" . ?⊨) ("=|" . ?⫤) ("->>" . ?↠) ("=~" . ?≈) ("<|" . ?⟨) ("|>" . ?⟩) ); -*- *)
Set Warnings "-notation-overridden".

Require Import Prelude.Prelude.

Require Import Defs.Embed.
Require Import Defs.Substs.

(*** Notation, tactics etc*)
Ltac LC_ind LC :=
    let LC' := fresh "LC__ty" in
    induction LC as [LC' | ?]; [induction LC' | idtac].

Ltac inv_LC :=
  repeat match goal with
    | [ H : lc_Ty (T_SkVar_b _) |- _ ] => inverts H
    | [ H : lc_DTy (DT_SkVar_b _) |- _ ] => inverts H

    | [ H : lc_Ty (T_Fun _ _) |- _ ] => inverts H
    | [ H : lc_DTy (DT_Fun _ _) |- _ ] => inverts H

    | [ H : lc_Sch (S_Mono _) |- _ ] => inverts H
    | [ H : lc_DSch (DS_Mono _) |- _ ] => inverts H
  end.

(*** Sch <-> DSch & Ty <-> DTy LC *)
Theorem emb_Ty_lc : forall (dty : DTy),
    lc_Ty  (emb_Ty dty)
  <-> lc_DTy dty.
Proof. split; intros LC; induction dty; inverts LC; crush. Qed.
Corollary emb_Ty_lc2 : forall (dty : DTy),
    lc_Ty  (emb_Ty dty)
  -> lc_DTy dty.
Proof. apply emb_Ty_lc. Qed.
Corollary emb_Ty_lc1 : forall (dty : DTy),
    lc_DTy dty
  -> lc_Ty  (emb_Ty dty).
Proof. apply emb_Ty_lc. Qed.
#[export] Hint Resolve emb_Ty_lc1 emb_Ty_lc2 : slow.

#[export] Hint Extern 4 (lc_Ty (emb_Ty _)) => apply emb_Ty_lc : core.

Theorem embed_Sch_lc : forall (dsch : DSch),
    lc_Sch  (emb_Sch dsch)
  <-> lc_DSch dsch.
Proof.
  split.
  - introv LC. dependent induction LC. emb_auto. apply emb_Ty_lc in H. crush.
    (assert (EMB: exists dsch', dsch = DS_Forall dsch')). emb_auto. exists. crush.
    destruct EMB as [dsch' EMB]. subst. simpl in *. inverts x.
    constructor. intros. eapply (H0 dskA). rewrite embed_Sch_open_comm. crush.
  - introv LC. induction LC. constructor. apply emb_Ty_lc. assumption.
    constructor. fold emb_Sch. intros skA.
    forwards IH: H0 skA. rewrite embed_Sch_open_comm in IH. crush.
Qed.

Corollary embed_Sch_lc1 : forall (dsch : DSch),
    lc_Sch  (emb_Sch dsch)
  -> lc_DSch dsch.
Proof. apply embed_Sch_lc. Qed.
Corollary embed_Sch_lc2 : forall (dsch : DSch),
    lc_DSch dsch
  -> lc_Sch  (emb_Sch dsch).
Proof. apply embed_Sch_lc. Qed.
#[export] Hint Resolve embed_Sch_lc1 embed_Sch_lc2 : slow.

Theorem lc_Sch_mono : forall (ty : Ty),
    lc_Sch (S_Mono ty)
  <-> lc_Ty ty.
Proof. split. inversion 1. auto. auto. Qed.
#[export] Hint Rewrite lc_Sch_mono : core.
Theorem lc_DSch_mono : forall (dty : DTy),
    lc_DSch (DS_Mono dty)
  <-> lc_DTy dty.
Proof. split. inversion 1. auto. auto. Qed.
#[export] Hint Rewrite lc_DSch_mono : core.

(*** LC/substs *)
Theorem lc_Sch_subst_exvar_Sch : forall (sch : Sch) (ty : Ty) (exA : exvar),
    lc_Sch sch
  -> lc_Ty ty
  -> lc_Sch (subst_exvar_Sch ty exA sch).
Proof.
  introv LC__sch LC__ty.
  LC_ind LC__sch; default_simp.
  - constructor. constructor.
    forwards: IHLC__ty0_1. eassumption. inverts H. assumption.
    forwards: IHLC__ty0_2. eassumption. inverts H. assumption.
  - simpl. constructor. intros. simpl.
    forwards: H0 skA. rewrite subst_exvar_Sch_open_Sch_wrt_Ty in H1; crush.
Qed.

Corollary lc_Sch_subst_exvar_Sch' : forall (exA : exvar) (sch : Sch) (ty : Ty),
    lc_Sch sch
  -> lc_Sch (S_Mono ty)
  -> lc_Sch (subst_exvar_Sch ty exA sch).
Proof. intros. inv_LC. apply lc_Sch_subst_exvar_Sch; eauto. Qed.

Theorem lc_Sch_open_Sch_wrt_Ty : forall (sch : Sch) (skA : skvar) (ty : Ty),
    lc_Sch sch
  -> lc_Ty ty
  -> lc_Sch (open_Sch_wrt_Ty (close_Sch_wrt_Ty skA sch) ty).
Proof.
  introv LC__sch LC__ty. rewrite <- subst_skvar_Sch_spec. eauto using subst_skvar_Sch_lc_Sch.
Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

Require Import BuiltIn.

Definition func : forall (a:Type) (b:Type), Type.
intros a b.
exact (a -> b).
Defined.

Definition infix_at: forall {a:Type} {a_WT:WhyType a}
  {b:Type} {b_WT:WhyType b}, (a -> b) -> a -> b.
intros a aWT b bWT f x.
exact (f x).
Defined.

Definition pred (a: Type) := func a bool.