Require Export Structure.

Definition ZERO_mixin: Category.mixin_of Empty_set :=
  Category.Mixin Empty_set (Empty_set_rect _)
  (Empty_set_rect _) (Empty_set_rect _)
  (Empty_set_rect _)
  (Empty_set_rect _)
  (Empty_set_rect _).

Canonical ZERO: Category :=
  Category.Pack Empty_set ZERO_mixin.

Definition from_ZERO {C: Category}: ZERO ~> C := {|
  fobj := Empty_set_rect _;
  fmap := Empty_set_rect _;
  fmap_id := Empty_set_rect _;
  fmap_comp := Empty_set_rect _;
|}.

Lemma from_ZERO_unique (C: Category) (F: ZERO ~> C): from_ZERO = F.
Proof.
  fun_eq x y f.
  all: destruct x.
Qed.

Definition CatBot_mixin: BotCategory.mixin_of Cat :=
  BotCategory.Mixin Cat ZERO (@from_ZERO) from_ZERO_unique.

Canonical CatBot: BotCategory :=
  BotCategory.Pack Cat CatBot_mixin.

Definition ZERO_Prod_mixin: ProdCategory.mixin_of 0 :=
  ProdCategory.Mixin 0 (Empty_set_rect _)
  (Empty_set_rect _) (Empty_set_rect _) (Empty_set_rect _)
  (Empty_set_rect _).

Canonical ZERO_Prod: ProdCategory :=
  ProdCategory.Pack 0 ZERO_Prod_mixin.

Definition ZERO_Coprod_mixin: CoprodCategory.mixin_of 0 :=
  CoprodCategory.Mixin 0 (Empty_set_rect _)
  (Empty_set_rect _) (Empty_set_rect _) (Empty_set_rect _)
  (Empty_set_rect _).

Canonical ZERO_Coprod: CoprodCategory :=
  CoprodCategory.Pack 0 ZERO_Coprod_mixin.

Definition coZero2Zero: co 0 ~> 0 := {|
  fobj := Empty_set_rect _: co 0 -> (0: Category);
  fmap := Empty_set_rect _;
  fmap_id := Empty_set_ind _;
  fmap_comp := Empty_set_ind _;
|}.

Lemma toZero_inv_l {C: Category} (F: C ~> 0): ¡ ∘ F = id C.
Proof.
  fun_eq x y f.
  destruct (F x).
  set (F x).
  unfold o.
  destruct o.
Qed.

Lemma toZero_inv_r {C: Category} (F: C ~> 0): F ∘ ¡ = id 0.
Proof.
  fun_eq x y f.
  all: destruct x.
Qed.

Definition toZero_iso_mixin {C: Category} (F: C ~> 0): Isomorphism.mixin_of F :=
  Isomorphism.Mixin _ _ _ F ¡ (toZero_inv_l F) (toZero_inv_r F).

Canonical toZero_iso {C: Category} (F: C ~> 0): C <~> 0 :=
  Isomorphism.Pack F (toZero_iso_mixin F).

Lemma iso_0 (C: Category): C ≃ 0 <-> inhabited (C ~> 0).
Proof.
  split.
  + intros [I].
    constructor.
    exact I.
  + intros [F].
    constructor.
    apply toZero_iso, F.
Qed.


Require Import Coq.Init.Byte.
Require Import Coq.Lists.List.
Require Import Arith.

Module ListNotations.
Notation "[ ]" := nil (format "[ ]") : list_scope.
Notation "[ x ]" := (cons x nil) : list_scope.
Notation "[ x ; y ; .. ; z ]" := (cons x (cons y .. (cons z nil) ..)) : list_scope.
End ListNotations.

Import ListNotations.

Definition address : Type := nat.
Definition time : Type := nat.
Inductive uid : Type :=
  | UID (device fog msg_sender: address)(block_timestamp: time).

Definition DefAdmArr : list address := nil.
Record Token : Type :=
{ UID_t: uid;
user_t: address;
dev_t: address;
fog_t: address; }.

Record Devices : Type :=
{ dev_d: address;
fog_d: address; }.

Inductive Event : Type :=
| AdminAdded (newAdmin msg_sender: address)
| UserDeviceMappingAdded (user device msg_sender fog: address)
| DeviceDoesnotExist (device fog msg_sender: address)
| FogDeviceMapping (fog device msg_sender: address)
| AdminDeleted (admin msg_sender: address)
| UserDeviceAllMappingDeleted (user msg_sender: address)
| FogDeviceAllMappingDeleted (fog msg_sender: address)
| NotAuthenticated (msg_sender: address)
| Authenticated (msg_sender dev fog: address)
| TokenCreated (UID: uid) (msg_sender dev fog: address)
| DefEv.

Definition DefTkArr : list Token := nil.

Definition DefDevArr : list Devices := nil.

Definition DefEvArr : list Event := nil.

Definition total_map (A : Type) := address -> A.

Definition t_empty {A : Type} (v : A) : total_map A :=
  (fun _ => v).

Definition eqb_ad (n m: address): bool :=
  if n=?m then true else false.

Fixpoint eqb n m : bool :=
  match n, m with
    | 0, 0 => true
    | 0, S _ => false
    | S _, 0 => false
    | S n', S m' => eqb n' m'
  end.

Lemma eqb_reflx : forall n, eqb n n = true.
Proof.
  intros. unfold eqb. induction n as [| n'0 IHn'].
  - (* n = 0 *) reflexivity.
  - (* n = S n' *) rewrite -> IHn'. reflexivity. Qed.

Definition t_update {A : Type} (m : total_map A)
                    (x : address) (v : A) :=
  fun x' => if eqb x x' then v else m x'.

Notation "'_' '!->' v" := (t_empty v)
  (at level 100, right associativity).

Definition DefAddress : address := 0.

Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).

Notation "x '!->' v" := (t_update (t_empty DefAdmArr) x v) (at level 100).

Notation "x '|->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).

Notation "x '|->' v" := (t_update (t_empty DefDevArr) x v) (at level 100).

Theorem eqb_address_refl : forall s : address, true = eqb s s.
Proof.
  intros s. unfold eqb.
   induction s as [| s'].
  - reflexivity.
  - rewrite <- IHs'. reflexivity.
Qed.

Lemma t_update_eq : forall (A : Type) (m : total_map A) x v,
    (x !-> v ; m) x = v.
Proof.
  intros. unfold t_update.  rewrite <- eqb_address_refl.
  reflexivity.
Qed.

Definition TestAdmArr := DefAdmArr ++ [20].

Definition TestDev := DefDevArr ++ [ (Build_Devices 66 77) ].

Record State : Type :=
{ admins: list address;
  Tokens: list Token;
  events: list Event;
  fog_devices: total_map (list address);
  users_devices: total_map (list Devices);
  msg_sender: address;
  block_timestamp: time;
  last_fun_suc: bool
}.

Inductive Function : Type :=
  | addAdmin (newAdmin: address)
  | addUserDeviceMapping (user device fog: address)
  | addDeviceFogMapping (device fog: address)
  | delAdmin (admin: address)
  | delUser (user: address)
  | delDev (fog: address)
  | requestAuthentication (device fog: address)
  | Seq (f1 f2 : Function).

Fixpoint in_al (l: list address) (e: address) : bool :=
  match l with
  | nil => false
  | h :: t => if eqb h e then true else in_al t e
  end.

Fixpoint in_dl_d (l: list Devices) (dev: address) : bool :=
  match l with
  | nil => false
  | h :: t => if eqb h.(dev_d) dev then true else in_dl_d t dev
  end.

Notation "'ADDA(' a ')'" :=
  (addAdmin a) (at level 80, right associativity).
Notation "'ADDUDM(' a ',' b ',' c ')'" :=
  (addUserDeviceMapping a b c) (at level 80, right associativity).
Notation "'ADDDFM(' a ',' b ')'" :=
  (addDeviceFogMapping a b) (at level 80, right associativity).
Notation "'DELA(' a ')'" :=
  (delAdmin a) (at level 80, right associativity).
Notation "'DELU(' a ')'" :=
  (delUser a) (at level 80, right associativity).
Notation "'DELD(' a ')'" :=
  (delDev a) (at level 80, right associativity).
Notation "'REQAUT(' a ',' b ')'" :=
  (requestAuthentication a b) (at level 80, right associativity).
Notation "f1 ;; f2" :=
  (Seq f1 f2) (at level 80, right associativity).

  Fixpoint remove_ad (x : address) (l : list address) : list address :=
    match l with
      | [] => []
      | y::tl => if (eqb x y) then remove_ad x tl else y::(remove_ad x tl)
    end.

Lemma remove_ad_length_le : forall l x, length (remove_ad x l) <= length l.
  Proof.
    intro l; induction l as [|y l IHl]; simpl; intros x; trivial.
    destruct (eqb x y); simpl.
    + rewrite IHl; constructor; reflexivity.
    + apply (proj1 (Nat.succ_le_mono _ _) (IHl x)).
  Qed.

Reserved Notation "st '=[' f ']=>' st'"
                  (at level 40).
Inductive Step : Function -> State -> State -> Prop :=
  | E_add_Admin : forall st st' newAdmin,
      in_al st.(admins) st.(msg_sender) = true ->
      st'.(admins) =  [newAdmin] ++ st.(admins) ->
      st'.(Tokens) = st.(Tokens) ->
      st'.(events) = [AdminAdded newAdmin st.(msg_sender)] ++ st.(events) ->
      st'.(fog_devices) = st.(fog_devices) ->
      st'.(users_devices) = st.(users_devices) ->
      st'.(last_fun_suc) = true ->
      st =[ ADDA(newAdmin) ]=> st'
  | E_add_UserDeviceMapping_exist : forall st st' user dev fog,
      in_al st.(admins) st.(msg_sender) = true ->
      in_al (st.(fog_devices) fog) dev = true ->
      st'.(admins) = st.(admins) ->
      st'.(Tokens) = st.(Tokens) ->
      st'.(events) = [UserDeviceMappingAdded user dev st.(msg_sender) fog] ++ st.(events) ->
      st'.(fog_devices) = st.(fog_devices) ->
      st'.(users_devices) = (user |-> [Build_Devices dev fog] ++ st.(users_devices) user; st.(users_devices)) ->
      st'.(last_fun_suc) = true ->
      st =[ ADDUDM(user, dev, fog)]=> st'
  | E_add_UserDeviceMapping_not_exist : forall st st' user dev fog,
      in_al st.(admins) st.(msg_sender) = true ->
      in_al (st.(fog_devices) fog) dev = false ->
      st'.(admins) = st.(admins) ->
      st'.(Tokens) = st.(Tokens) ->
      st'.(events) = [DeviceDoesnotExist dev fog st.(msg_sender)] ++ st.(events) ->
      st'.(fog_devices) = st.(fog_devices) ->
      st'.(users_devices) = st.(users_devices) ->
      st'.(last_fun_suc) = false ->
      st =[ ADDUDM(user, dev, fog) ]=> st'
  | E_add_DeviceFogMapping : forall st st' dev fog,
      in_al st.(admins) st.(msg_sender) = true ->
      st'.(admins) = st.(admins) ->
      st'.(Tokens) = st.(Tokens) ->
      st'.(events) = [FogDeviceMapping fog dev st.(msg_sender)] ++ st.(events) ->
      st'.(fog_devices) = (fog |-> [dev] ++ st.(fog_devices) fog; st.(fog_devices)) ->
      st'.(users_devices) = st.(users_devices) ->
      st'.(last_fun_suc) = true ->
      st =[ ADDDFM(dev, fog) ]=> st'
  | E_del_Admin : forall st st' admin,
      in_al st.(admins) st.(msg_sender) = true ->
      2 <=? (length st.(admins)) = true ->
      st'.(admins) = (remove_ad admin (st.(admins))) ->
      1 <=? (length st'.(admins)) = true ->
      st'.(Tokens) = st.(Tokens) ->
      st'.(events) = [AdminDeleted admin st.(msg_sender)] ++ st.(events) ->
      st'.(fog_devices) = st.(fog_devices) ->
      st'.(users_devices) = st.(users_devices) ->
      st'.(last_fun_suc) = true ->
      st =[ DELA(admin) ]=> st'
  | E_del_Admin_fail : forall st st' admin,
      in_al st.(admins) st.(msg_sender) = true ->
      2 <=? (length st.(admins)) = false ->
      st'.(admins) = st.(admins) ->
      st'.(Tokens) = st.(Tokens) ->
      st'.(events) = st.(events) ->
      st'.(fog_devices) = st.(fog_devices) ->
      st'.(users_devices) = st.(users_devices) ->
      st'.(last_fun_suc) = false ->
      st =[ DELA(admin) ]=> st'
  | E_del_User : forall st st' user,
      in_al st.(admins) st.(msg_sender) = true ->
      st'.(admins) = st.(admins) ->
      st'.(Tokens) = st.(Tokens) ->
      st'.(events) = [UserDeviceAllMappingDeleted user st.(msg_sender)] ++ st.(events) ->
      st'.(fog_devices) = st.(fog_devices) ->
      st'.(users_devices) = (user |-> nil; st.(users_devices)) ->
      st'.(last_fun_suc) = true ->
      st =[ DELU(user) ]=> st'
  | E_del_Dev : forall st st' fog,
      in_al st.(admins) st.(msg_sender) = true ->
      st'.(admins) = st.(admins) ->
      st'.(Tokens) = st.(Tokens) ->
      st'.(events) = [FogDeviceAllMappingDeleted fog st.(msg_sender)] ++ st.(events) ->
      st'.(fog_devices) = (fog |-> nil; st.(fog_devices)) ->
      st'.(users_devices) = st.(users_devices) ->
      st'.(last_fun_suc) = true ->
      st =[ DELD(fog) ]=> st'
  | E_req_Auth_not_1 : forall st st' dev fog,
      in_al (st.(fog_devices) fog) dev = false ->
      st'.(admins) = st.(admins) ->
      st'.(Tokens) = st.(Tokens) ->
      st'.(events) = [DeviceDoesnotExist dev fog st.(msg_sender)] ++ st.(events) ->
      st'.(fog_devices) = st.(fog_devices) ->
      st'.(users_devices) = st.(users_devices) ->
      st'.(last_fun_suc) = false ->
      st =[ REQAUT(dev, fog) ]=> st'
  | E_req_Auth_not_2 : forall st st' dev fog,
      in_al (st.(fog_devices) fog) dev = true ->
      in_dl_d (st.(users_devices) st.(msg_sender)) dev = false ->
      st'.(admins) = st.(admins) ->
      st'.(events) = [NotAuthenticated st.(msg_sender)] ++ st.(events) ->
      st'.(fog_devices) = st.(fog_devices) ->
      st'.(users_devices) = st.(users_devices) ->
      st'.(last_fun_suc) = false ->
      st =[ REQAUT(dev, fog) ]=> st'
  | E_req_Auth : forall st st' dev fog,
      in_al (st.(fog_devices) fog) dev = true ->
      in_dl_d (st.(users_devices) st.(msg_sender)) dev = true ->
      st'.(admins) = st.(admins) ->
      st'.(Tokens) = [Build_Token (UID dev fog st.(msg_sender) st.(block_timestamp)) st.(msg_sender) dev fog] ++ st.(Tokens) ->
      st'.(events) = [TokenCreated (UID dev fog st.(msg_sender) st.(block_timestamp)) st.(msg_sender) dev fog;Authenticated st.(msg_sender) dev fog] ++ st.(events) ->
      st'.(fog_devices) = st.(fog_devices) ->
      st'.(users_devices) = st.(users_devices) ->
      st'.(last_fun_suc) = true ->
      st =[ REQAUT(dev, fog) ]=> st'
  | E_Seq : forall f1 f2 st st' st'',
      st =[ f1 ]=> st' ->
      st' =[ f2 ]=> st'' ->
      st =[ f1 ;; f2 ]=> st''

where "st =[ f ]=> st'" := (Step f st st').

Definition st_1 : State := Build_State [15;1] nil [UserDeviceMappingAdded 15 12 1 16]
                           (16 !-> [12]) (15 |-> [{| dev_d := 12; fog_d := 16 |}])15 88 true.
Definition st_2: State := Build_State [15;1] [{| UID_t := (UID 12 16 15 88);
                           user_t := 15; dev_t := 12; fog_t := 16 |}]
                           [TokenCreated (UID 12 16 15 88) 15 12 16;
                           Authenticated 15 12 16;UserDeviceMappingAdded 15 12 1 16]
                           (16 !-> [12]) (15 |-> [{| dev_d := 12; fog_d := 16 |}]) 15 88 true.

Example example_req :
  st_1 =[ REQAUT(12, 16) ]=> st_2.
Proof.
  apply E_req_Auth;reflexivity.
Qed.

Definition st_3 : State := Build_State [22;1] nil [AdminAdded 22 1]
                           (t_empty DefAdmArr) (t_empty DefDevArr) 1 88 true.
Definition st_4 : State := Build_State [22;1] nil [FogDeviceMapping 16 12 1;
                           AdminAdded 22 1] (16 !-> [12]) (t_empty DefDevArr) 1 88 true.
Definition st_5 : State := Build_State [22;1] nil [FogDeviceAllMappingDeleted 16 1;
                            FogDeviceMapping 16 12 1;AdminAdded 22 1]
                            (16 !-> nil;16 !-> [12]) (t_empty DefDevArr) 1 88 true.

Example example_seq :
  st_3 =[ ADDDFM(12, 16);; DELD(16) ]=> st_5.
Proof.
  apply E_Seq with (st_4).
  apply E_add_DeviceFogMapping;reflexivity.
  apply E_del_Dev;reflexivity.
Qed.

Theorem eqb_true : forall n : address,
  eqb n n = true.
Proof.
 unfold eqb. induction n as [|n' IHn'].
  - simpl. reflexivity.
  - apply IHn'.
Qed.

Fixpoint in_dl_d_f (l: list Devices) (dev fog: address) : bool :=
  match l with
  | nil => false
  | h :: t => if andb (eqb h.(dev_d) dev) (eqb h.(fog_d) fog) then true else in_dl_d_f t dev fog
  end.

Axiom Fog_devices_add : forall st st' dev fog,
     st =[ ADDDFM(dev, fog) ]=> st' ->
     st'.(last_fun_suc) = true ->
     st'.(fog_devices) = (fog |-> [dev] ++ st.(fog_devices) fog; st.(fog_devices)).

Theorem Device_fog_mapping_suc : forall st st' dev fog,
  st =[ ADDDFM(dev, fog) ]=> st' ->
  st'.(last_fun_suc) = true ->
  in_al (st'.(fog_devices) fog) dev = true.
Proof.
  intros. apply Fog_devices_add in H.
  + rewrite H; unfold in_al; simpl.
  unfold t_update.
  assert (HM1 : eqb fog fog = true).
  { rewrite eqb_reflx. reflexivity. }
  assert (HM2 : eqb dev dev = true).
  { rewrite eqb_reflx. reflexivity. }
  rewrite HM1,HM2.
  reflexivity.
 + assumption.
Qed.

Axiom User_device_add : forall st st' dev fog user,
     st =[ ADDUDM(user, dev, fog) ]=> st' ->
     st'.(last_fun_suc) = true ->
     st'.(users_devices) = (user |-> [Build_Devices dev fog] ++ st.(users_devices) user; st.(users_devices)).

Theorem User_device_mapping_suc : forall st st' dev fog user,
  st =[ ADDUDM(user, dev, fog) ]=> st' ->
  st'.(last_fun_suc) = true ->
  in_dl_d_f (st'.(users_devices) user) dev fog = true.
Proof.
  intros. apply User_device_add in H.
  + rewrite H; unfold in_dl_d_f; simpl.
  unfold t_update.
  assert (HM1 : eqb user user = true).
  { rewrite eqb_reflx. reflexivity. }
  assert (HM2 : (dev_d {| dev_d := dev; fog_d := fog |}) = dev).
  { reflexivity. }
  assert (HM3 : (fog_d {| dev_d := dev; fog_d := fog |}) = fog).
  { reflexivity. }
  assert (HM4 : eqb dev dev = true).
  { rewrite eqb_reflx. reflexivity. }
  assert (HM5 : eqb fog fog = true).
  { rewrite eqb_reflx. reflexivity. }
  rewrite HM1,HM2,HM3,HM4,HM5.
  reflexivity.
 + assumption.
Qed.

Definition eqb_uid (u1 u2: uid): bool :=
  match u1 with
   | UID dev1 fog1 msg_sender1 block_timestamp1 => match u2 with
     | UID dev2 fog2 msg_sender2 block_timestamp2 =>
        andb (andb (eqb dev1 dev2)
             (eqb fog1 fog2))
        (andb (eqb msg_sender1 msg_sender2)
             (eqb block_timestamp1 block_timestamp2))
      end
  end.

Definition eqb_t (t1 t2: Token) :=
  if ( andb (andb (eqb_uid t1.(UID_t) t2.(UID_t))
             (eqb t1.(user_t) t2.(user_t)))
        (andb (eqb t1.(dev_t) t2.(dev_t))
             (eqb t1.(fog_t) t2.(fog_t))))then true else false.

Fixpoint in_tl (l: list Token) (token: Token) : bool :=
  match l with
  | nil => false
  | h :: t => if (eqb_t h token) then true else in_tl t token
  end.

Axiom Token_add : forall st st' dev fog,
     st =[ REQAUT(dev, fog) ]=> st' ->
     st'.(last_fun_suc) = true ->
     st'.(Tokens) = [Build_Token (UID dev fog st.(msg_sender)
         st.(block_timestamp)) st.(msg_sender) dev fog] ++ st.(Tokens).

Lemma eqb_uid_reflx : forall n, eqb_uid n n = true.
Proof.
  intros. unfold eqb_uid. destruct n eqn:E.
  assert (HM1 : eqb device device = true).
  { rewrite eqb_reflx. reflexivity. }
  assert (HM2 : eqb fog fog = true).
  { rewrite eqb_reflx. reflexivity. }
  assert (HM3 : eqb msg_sender0 msg_sender0 = true).
  { rewrite eqb_reflx. reflexivity. }
  assert (HM4 : eqb block_timestamp0 block_timestamp0 = true).
  { rewrite eqb_reflx. reflexivity. }
  rewrite HM1,HM2,HM3,HM4.
  reflexivity.
Qed.

Lemma eqb_t_reflx : forall a b c d,
     (eqb_t  {|  UID_t := a; user_t := b; dev_t := c; fog_t := d |}
      {|  UID_t := a; user_t := b; dev_t := c; fog_t := d |}) = true.
Proof.
  intros. unfold eqb_t.
  assert (HM1 : (UID_t {| UID_t := a; user_t := b; dev_t := c; fog_t := d |}) = a).
  { reflexivity. }
  assert (HM2 : (user_t {| UID_t := a; user_t := b; dev_t := c; fog_t := d |}) = b).
  { reflexivity. }
  assert (HM3 : (dev_t {| UID_t := a; user_t := b; dev_t := c; fog_t := d |}) = c).
  { reflexivity. }
  assert (HM4 : (fog_t {| UID_t := a; user_t := b; dev_t := c; fog_t := d |}) = d).
  { reflexivity. }
  rewrite HM1,HM2,HM3,HM4.
  assert (HM5 : eqb_uid a a = true).
  { rewrite eqb_uid_reflx. reflexivity. }
  assert (HM6 : eqb b b = true).
  { rewrite eqb_reflx. reflexivity. }
  assert (HM7 : eqb c c = true).
  { rewrite eqb_reflx. reflexivity. }
  assert (HM8 : eqb d d = true).
  { rewrite eqb_reflx. reflexivity. }
  rewrite HM5,HM6,HM7,HM8; reflexivity.
Qed.

Theorem Request_Auth_suc : forall st st' dev fog,
st =[ REQAUT(dev, fog) ]=> st' ->
st'.(last_fun_suc) = true ->
in_tl st'.(Tokens) (Build_Token (UID dev fog st.(msg_sender) st.(block_timestamp)) st.(msg_sender) dev fog) = true.
Proof.
  intros.
  apply Token_add in H.
  + rewrite H; unfold in_tl; simpl.
  unfold t_update.
  assert (HM1 : (eqb_t
    {| UID_t := UID dev fog (msg_sender st) (block_timestamp st);
      user_t := msg_sender st;
      dev_t := dev;
      fog_t := fog |}
    {| UID_t := UID dev fog (msg_sender st) (block_timestamp st);
      user_t := msg_sender st;
      dev_t := dev;
      fog_t := fog |}) = true).
  { apply eqb_t_reflx. }
  rewrite HM1; reflexivity.
 + assumption.
Qed.

Axiom Has_Auth : forall st st' dev fog,
      in_al (st.(fog_devices) fog) dev = true ->
      in_dl_d (st.(users_devices) st.(msg_sender)) dev = true ->
      st =[ REQAUT(dev, fog) ]=> st' ->
      st'.(last_fun_suc) = true.

Theorem Has_Auth_Request_Auth_suc : forall st st' dev fog,
      in_al (st.(fog_devices) fog) dev = true ->
      in_dl_d (st.(users_devices) st.(msg_sender)) dev = true ->
      st =[ REQAUT(dev, fog) ]=> st' ->
      in_tl st'.(Tokens) (Build_Token (UID dev fog st.(msg_sender) st.(block_timestamp)) st.(msg_sender) dev fog) = true.
Proof.
  intros. apply Request_Auth_suc.
  - assumption.
  - apply (@Has_Auth st st' dev fog); assumption.
Qed.

Axiom Admin_del : forall st st' admin,
     st =[ DELA(admin) ]=> st' ->
     st'.(last_fun_suc) = true ->
      (st'.(admins) = remove_ad admin st.(admins)) /\
     (1 <=? (length st'.(admins)) = true).

Theorem Del_Admin_suc : forall st st' admin,
      st =[ DELA(admin) ]=> st' ->
      st'.(last_fun_suc) = true ->
      length st'.(admins) <= length st.(admins).
Proof.
   intros. apply Admin_del in H.
  + destruct H; rewrite H; apply remove_ad_length_le.
  + assumption.
Qed.

Theorem Admin_num_safe: forall st st' admin,
      st =[ DELA(admin) ]=> st' ->
      st'.(last_fun_suc) = true ->
      1 <=? (length st'.(admins)) = true.
Proof.
   intros. apply Admin_del in H.
  + destruct H; rewrite H1; reflexivity.
  + assumption.
Qed.


From iris.algebra Require Import gmap.
From iris.algebra Require cofe_solver.
From iris.base_logic Require Export base_logic.
From iris.prelude Require Import options.

(** In this file we construct the type [iProp] of propositions of the Iris
logic. This is done by solving the following recursive domain equation:

  iProp ≈ uPred (∀ i : gid, gname -fin-> (Σ i) iProp)

where:

  Σ : gFunctors  := lists of locally constractive functors
  i : gid        := indexes addressing individual functors in [Σ]
  γ : gname      := ghost variable names

The Iris logic is parametrized by a list of locally contractive functors [Σ]
from the category of COFEs to the category of CMRAs. These functors are
instantiated with [iProp], the type of Iris propositions, which allows one to
construct impredicate CMRAs, such as invariants and stored propositions using
the agreement CMRA. *)

(** * Locally contractive functors *)
(** The type [gFunctor] bundles a functor from the category of COFEs to the
category of CMRAs with a proof that it is locally contractive. *)
Structure gFunctor := GFunctor {
  gFunctor_F :> rFunctor;
  gFunctor_map_contractive : rFunctorContractive gFunctor_F;
}.
Global Arguments GFunctor _ {_}.
Existing Instance gFunctor_map_contractive.
Add Printing Constructor gFunctor.

(** The type [gFunctors] describes the parameters [Σ] of the Iris logic: lists
of [gFunctor]s.

Note that [gFunctors] is isomorphic to [list gFunctor], but defined in an
alternative way to avoid universe inconsistencies with respect to the universe
monomorphic [list] type. *)
Definition gFunctors := { n : nat & fin n → gFunctor }.

Definition gid (Σ : gFunctors) := fin (projT1 Σ).
Definition gFunctors_lookup (Σ : gFunctors) : gid Σ → gFunctor := projT2 Σ.

Definition gname := positive.
Canonical Structure gnameO := leibnizO gname.

(** The resources functor [iResF Σ A := ∀ i : gid, gname -fin-> (Σ i) A]. *)
Definition iResF (Σ : gFunctors) : urFunctor :=
  discrete_funURF (λ i, gmapURF gname (gFunctors_lookup Σ i)).

(** We define functions for the empty list of functors, the singleton list of
functors, and the append operator on lists of functors. These are used to
compose [gFunctors] out of smaller pieces. *)
Module gFunctors.
  Definition nil : gFunctors := existT 0 (fin_0_inv _).

  Definition singleton (F : gFunctor) : gFunctors :=
    existT 1 (fin_S_inv (λ _, gFunctor) F (fin_0_inv _)).

  Definition app (Σ1 Σ2 : gFunctors) : gFunctors :=
    existT (projT1 Σ1 + projT1 Σ2) (fin_plus_inv _ (projT2 Σ1) (projT2 Σ2)).
End gFunctors.

Coercion gFunctors.singleton : gFunctor >-> gFunctors.
Notation "#[ ]" := gFunctors.nil (format "#[ ]").
Notation "#[ Σ1 ; .. ; Σn ]" :=
  (gFunctors.app Σ1 .. (gFunctors.app Σn gFunctors.nil) ..).

(** * Subfunctors *)
(** In order to make proofs in the Iris logic modular, they are not done with
respect to some concrete list of functors [Σ], but are instead parametrized by
an arbitrary list of functors [Σ] that contains at least certain functors. For
example, the lock library is parameterized by a functor [Σ] that should have
the functors corresponding to the heap and the exclusive monoid to manage to
lock invariant.

The contraints to can be expressed using the type class [subG Σ1 Σ2], which
expresses that the functors [Σ1] are contained in [Σ2]. *)
Class subG (Σ1 Σ2 : gFunctors) := in_subG i :
  { j | gFunctors_lookup Σ1 i = gFunctors_lookup Σ2 j }.

(** Avoid trigger happy type class search: this line ensures that type class
search is only triggered if the arguments of [subG] do not contain evars. Since
instance search for [subG] is restrained, instances should persistently have [subG] as
their first parameter to avoid loops. For example, the instances [subG_authΣ]
and [auth_discrete] otherwise create a cycle that pops up arbitrarily. *)
Global Hint Mode subG ! + : typeclass_instances.

Lemma subG_inv Σ1 Σ2 Σ : subG (gFunctors.app Σ1 Σ2) Σ → subG Σ1 Σ * subG Σ2 Σ.
Proof.
  move=> H; split.
  - move=> i; move: H=> /(_ (Fin.L _ i)) [j] /=. rewrite fin_plus_inv_L; eauto.
  - move=> i; move: H=> /(_ (Fin.R _ i)) [j] /=. rewrite fin_plus_inv_R; eauto.
Qed.

Global Instance subG_refl Σ : subG Σ Σ.
Proof. move=> i; by exists i. Qed.
Global Instance subG_app_l Σ Σ1 Σ2 : subG Σ Σ1 → subG Σ (gFunctors.app Σ1 Σ2).
Proof.
  move=> H i; move: H=> /(_ i) [j ?].
  exists (Fin.L _ j). by rewrite /= fin_plus_inv_L.
Qed.
Global Instance subG_app_r Σ Σ1 Σ2 : subG Σ Σ2 → subG Σ (gFunctors.app Σ1 Σ2).
Proof.
  move=> H i; move: H=> /(_ i) [j ?].
  exists (Fin.R _ j). by rewrite /= fin_plus_inv_R.
Qed.

(** * Solution of the recursive domain equation *)
(** We first declare a module type and then an instance of it so as to seal all of
the construction, this way we are sure we do not use any properties of the
construction, and also avoid Coq from blindly unfolding it. *)
Module Type iProp_solution_sig.
  Parameter iPrePropO : gFunctors → ofe.
  Global Declare Instance iPreProp_cofe {Σ} : Cofe (iPrePropO Σ).

  Definition iResUR (Σ : gFunctors) : ucmra :=
    discrete_funUR (λ i,
      gmapUR gname (rFunctor_apply (gFunctors_lookup Σ i) (iPrePropO Σ))).
  Notation iProp Σ := (uPred (iResUR Σ)).
  Notation iPropO Σ := (uPredO (iResUR Σ)).
  Notation iPropI Σ := (uPredI (iResUR Σ)).

  Parameter iProp_unfold: ∀ {Σ}, iPropO Σ -n> iPrePropO Σ.
  Parameter iProp_fold: ∀ {Σ}, iPrePropO Σ -n> iPropO Σ.
  Parameter iProp_fold_unfold: ∀ {Σ} (P : iProp Σ),
    iProp_fold (iProp_unfold P) ≡ P.
  Parameter iProp_unfold_fold: ∀ {Σ} (P : iPrePropO Σ),
    iProp_unfold (iProp_fold P) ≡ P.
End iProp_solution_sig.

Module Export iProp_solution : iProp_solution_sig.
  Import cofe_solver.
  Definition iProp_result (Σ : gFunctors) :
    solution (uPredOF (iResF Σ)) := solver.result _.
  Definition iPrePropO (Σ : gFunctors) : ofe := iProp_result Σ.
  Global Instance iPreProp_cofe {Σ} : Cofe (iPrePropO Σ) := _.

  Definition iResUR (Σ : gFunctors) : ucmra :=
    discrete_funUR (λ i,
      gmapUR gname (rFunctor_apply (gFunctors_lookup Σ i) (iPrePropO Σ))).
  Notation iProp Σ := (uPred (iResUR Σ)).
  Notation iPropO Σ := (uPredO (iResUR Σ)).

  Definition iProp_unfold {Σ} : iPropO Σ -n> iPrePropO Σ :=
    ofe_iso_1 (iProp_result Σ).
  Definition iProp_fold {Σ} : iPrePropO Σ -n> iPropO Σ :=
    ofe_iso_2 (iProp_result Σ).
  Lemma iProp_fold_unfold {Σ} (P : iProp Σ) : iProp_fold (iProp_unfold P) ≡ P.
  Proof. apply ofe_iso_21. Qed.
  Lemma iProp_unfold_fold {Σ} (P : iPrePropO Σ) : iProp_unfold (iProp_fold P) ≡ P.
  Proof. apply ofe_iso_12. Qed.
End iProp_solution.

(** * Properties of the solution to the recursive domain equation *)
Lemma iProp_unfold_equivI {Σ} (P Q : iProp Σ) :
  iProp_unfold P ≡ iProp_unfold Q ⊢@{iPropI Σ} P ≡ Q.
Proof.
  rewrite -{2}(iProp_fold_unfold P) -{2}(iProp_fold_unfold Q). apply: f_equivI.
Qed.


(* Finite maps for labels *)

Require Import LabelMap.
Require Import Ascii NArith String OrderedType FSetAVL.

Module StringKey.
  Definition t := string.

  Definition eq := @eq t.
  Definition lt (s1 s2 : t) := string_lt s1 s2 = true.

  Theorem eq_refl : forall x : t, eq x x.
    congruence.
  Qed.

  Theorem eq_sym : forall x y : t, eq x y -> eq y x.
    congruence.
  Qed.

  Theorem eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
    congruence.
  Qed.

  Section hide_hints.
    Hint Resolve string_lt_trans.
    Hint Rewrite string_lt_irrel : LabelMap.
    Hint Immediate string_tail_neq.
    Hint Resolve string_lt_sym.
    Hint Rewrite string_lt_irrel : LabelMap.

    Theorem lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
      unfold lt; intuition (congruence || eauto).
    Qed.

    Theorem lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
      unfold lt, eq; intuition; subst; autorewrite with LabelMap in *; discriminate.
    Qed.

    Definition compare' (x y : t) : comparison :=
      if string_lt x y
        then Datatypes.Lt
        else if string_dec x y
          then Datatypes.Eq
          else Gt.

    Definition compare (x y : t) : Structures.OrderedType.Compare lt eq x y.
      refine (match compare' x y as c return c = compare' x y -> Structures.OrderedType.Compare lt eq x y with
                | Datatypes.Lt => fun _ => Structures.OrderedType.LT _
                | Datatypes.Eq => fun _ => Structures.OrderedType.EQ _
                | Gt => fun _ => Structures.OrderedType.GT _
              end (refl_equal _)); abstract (unfold compare', eq, lt in *;
                repeat match goal with
                         | [ H : context[if ?E then _ else _] |- _ ] => let Heq := fresh "Heq" in case_eq E; (intros ? Heq || intro Heq);
                           rewrite Heq in H; try discriminate
                       end; intuition).
    Defined.

    Definition eq_dec x y : { eq x y } + { ~ eq x y }.
      refine (if string_dec x y then left _ _ else right _ _);
        abstract (unfold eq in *; destruct x; destruct y; simpl in *; congruence).
    Defined.
  End hide_hints.
End StringKey.

Module String_as_OT := StringKey.

Require Import OrdersAlt.
Module String_as_OT_new := Update_OT String_as_OT.
Require Import Equalities.
Module String_as_UDT := Make_UDT String_as_OT.


Require Import VST.floyd.proofauto.
Require Import pile.
Require Import spec_stdlib.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Global Open Scope funspec_scope.

Definition tlist := Tstruct _list noattr.
Definition tpile := Tstruct _pile noattr.

Fixpoint listrep (sigma: list Z) (x: val) : mpred :=
 match sigma with
 | h::hs =>
    EX y:val,
       !! (0 <= h <=  Int.max_signed) &&
      data_at Ews tlist (Vint (Int.repr h), y) x
     * malloc_token Ews tlist x
     *  listrep hs y
 | nil =>
    !! (x = nullval) && emp
 end.

Lemma listrep_local_facts:
  forall sigma p,
   listrep sigma p |--
   !! (is_pointer_or_null p
      /\ (p=nullval <-> sigma=nil)
       /\ Forall (Z.le 0) sigma).
Proof.
intros.
revert p; induction sigma;
  unfold listrep; fold listrep; intros.
  entailer!; intuition.
Intros y. entailer!.
split.
split; intro. subst p. destruct H0; contradiction. discriminate.
constructor; auto. omega.
Qed.

Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sigma p,
   listrep sigma p |-- valid_pointer p.
Proof.
 destruct sigma; unfold listrep; fold listrep;
 intros; entailer!; auto with valid_pointer.
Qed.

Hint Resolve listrep_valid_pointer : valid_pointer.

Definition pilerep (sigma: list Z) (p: val) : mpred :=
  EX x:val, data_at Ews tpile x p
             * listrep sigma x.

Definition pile_freeable (p: val) : mpred :=
            malloc_token Ews tpile p.

Lemma pilerep_local_facts:
  forall sigma p,
   pilerep sigma p |-- !! (isptr p /\ Forall (Z.le 0) sigma).
Proof.
intros.
unfold pilerep.
Intros q.
entailer!.
Qed.

Hint Resolve pilerep_local_facts : saturate_local.

Lemma pilerep_valid_pointer:
  forall sigma p,
   pilerep sigma p |-- valid_pointer p.
Proof.
 intros.
 unfold pilerep. Intros x.
 entailer!; auto with valid_pointer.
Qed.
Hint Resolve pilerep_valid_pointer : valid_pointer.

Local Open Scope assert.

Definition surely_malloc_spec :=
  DECLARE _surely_malloc
   WITH t:type, gv: globals
   PRE [ tuint ]
       PROP (0 <= sizeof t <= Int.max_unsigned;
                complete_legal_cosu_type t = true;
                natural_aligned natural_alignment t = true)
       (LAMBDAx [gv] [Vint (Int.repr (sizeof t))]
       (SEP (mem_mgr gv)))
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP (mem_mgr gv; malloc_token Ews t p * data_at_ Ews t p).

Definition Pile_new_spec :=
 DECLARE _Pile_new
 WITH gv: globals
 PRE [ ] PROP() (LAMBDAx [gv] [] (SEP(mem_mgr gv)))
 POST[ tptr tpile ]
   EX p: val,
      PROP() LOCAL(temp ret_temp p)
      SEP(pilerep nil p; pile_freeable p; mem_mgr gv).

Definition Pile_add_spec :=
 DECLARE _Pile_add
 WITH p: val, n: Z, sigma: list Z, gv: globals
 PRE [ tptr tpile, tint  ]
    PROP(0 <= n <= Int.max_signed)
    (LAMBDAx [gv] [p; Vint (Int.repr n)]
    (SEP(pilerep sigma p; mem_mgr gv)))
 POST[ tvoid ]
    PROP() LOCAL()
    SEP(pilerep (n::sigma) p; mem_mgr gv).

Definition sumlist : list Z -> Z := List.fold_right Z.add 0.

Definition Pile_count_spec :=
 DECLARE _Pile_count
 WITH p: val, sigma: list Z
 PRE [ tptr tpile  ]
    PROP(0 <= sumlist sigma <= Int.max_signed)
    (LAMBDAx [] [p]
    (SEP (pilerep sigma p)))
 POST[ tint ]
      PROP()
      LOCAL(temp ret_temp (Vint (Int.repr (sumlist sigma))))
      SEP(pilerep sigma p).

Definition Pile_free_spec :=
 DECLARE _Pile_free
 WITH p: val, sigma: list Z, gv: globals
 PRE [ tptr tpile  ]
    PROP()
    (LAMBDAx [gv] [p]
    (SEP(pilerep sigma p; pile_freeable p; mem_mgr gv)))
 POST[ tvoid ]
     PROP() LOCAL() SEP(mem_mgr gv).

Definition ispecs := [surely_malloc_spec].
Definition specs := [Pile_new_spec; Pile_add_spec; Pile_count_spec; Pile_free_spec].

(*Clients -- apile.v and onepile.v -- also need these lemmas:*)
Lemma pile_new_aux gx x ret:
(EX p : val, PROP ( )  LOCAL (temp ret_temp p)  SEP (pilerep [] p; pile_freeable p; mem_mgr x))%assert (make_ext_rval gx ret)
  |-- !! is_pointer_or_null (force_val ret).
Proof.
 rewrite exp_unfold. Intros p.
 rewrite <- insert_local.
 rewrite lower_andp.
 apply derives_extract_prop; intro.
 destruct H; unfold_lift in H. rewrite retval_ext_rval in *.
 subst p. renormalize. entailer!.
Qed.

Lemma pile_count_aux gx l v ret:
  (PROP ( )  LOCAL (temp ret_temp (Vint (Int.repr (sumlist l))))  SEP (pilerep l v)) (make_ext_rval gx ret)
  |-- !! is_int I32 Signed (force_val ret).
Proof.
 rewrite <- insert_local.
 rewrite lower_andp.
 apply derives_extract_prop; intro.
 destruct H; unfold_lift in H. rewrite retval_ext_rval in *.
 rewrite <- H. renormalize.
Qed.


(** This file introduces some of the new features of Coq 8.6 *)

From Coq Require Import Arith List Omega Bool Program.Tactics.

(** * Multi-goal, multi-success typeclasses eauto engine *)

(* See Coq86typeclasses for a more detailed demonstration. *)

Class pred (n : nat) : Prop := {}.
Instance pred0 : pred 0 := {}.
(** pred1 has priority over pred0 *)
Instance pred1 : pred 1 := {}.
Class pred2 (n : nat) : Prop := {}.
(** There is not [pred2 1] instance *)
Instance pred20 : pred2 0 := {}.

Goal exists x : nat, pred x /\ pred2 x.
  eexists. split.
  (** The resolution can backtrack across goals, *)
  Set Typeclasses Debug.
  (** Here using two different calls to resolution on two different
      goals, using the multiple successes of the first call to find
      pred0 *)
  all:[> typeclasses eauto .. ].
  Undo.
  (** Here using a multi-goal call *)
  all:typeclasses eauto.
  Show Proof.
Qed.

(** * Goal selectors *)

Goal exists n : nat, pred n /\ pred2 n /\ True.
  eexists.
  split; [|split].
  (** Applies the multi-goal tactic to the list of goals *)
  1-2:typeclasses eauto.
  exact I.
  Undo 2.
  2-3:cycle 1.
  1,3:typeclasses eauto.
  (* Same result, selection of non-contiguous range *)
  exact I.
Qed.

(** * Irrefutable patterns in binders *)

Module IrrefutablePatterns.

  Definition fst {A B} '((a, b) : _ * B) : A := a.
  Definition snd {A B} '((a, b) : A * B) := b.

  Record myrec := makemy { somebool : bool; somenat : nat }.

  Lemma eta_my : forall '(makemy b n), b = true \/ b = false.
    intros [[|] n]; auto.
  Qed.

  Definition map_pair (l : list (nat * nat)) : list nat :=
    map (fun '(pair x _) => x) l.

End IrrefutablePatterns.

(** * Keyed Unification *)

Module KeyedUnification.
  (** The purpose of Keyed Unification is to allow [rewrite] to see subterms to rewrite
      up to controlable reduction. The strategy is to match the lhs or rhs of the lemma
      with a subterm in the goal or hypothesis, by finding an applicative subterm whose
      head is equivalent to the head in the lemma and the use full unification on the
      arguments, whether they are closed or not. *)
  Set Keyed Unification.

  Section foo.
    Variable f : nat -> nat.

    Definition g := f.

    Variable lem : g 0 = 0.

    Goal f 0 = 0.
    Proof.
      Fail rewrite lem.
      (** Found no subterm matching "g 0" in the current goal. *)
    Abort.

    Declare Equivalent Keys @g @f.
    (** Now f and g are considered equivalent heads for subterm selection *)
    Goal f 0 = 0.
    Proof.
      rewrite lem.
      reflexivity.
    Qed.

    Print Equivalent Keys.
  End foo.
End KeyedUnification.

(** Unification constraint handling *)

Module UnifConstraints.

  (** This option governs the automating solving of remaining unification constraints
      at each ".". Unification can use heuristics to solve these remaining constraints. *)
  Set Solve Unification Constraints. (* The default *)

  Goal forall n : nat, True /\ True /\ True \/ n = n.
    (** This higher-order unification constraint does not have a unique solution. *)
    intros n. Fail refine (nat_rect _ _ _ n).
    Unset Solve Unification Constraints.
    (** This lets the constraint float. *)
    refine (nat_rect _ _ _ n).
    (** This forces constraint solving, here failing *)
    Fail solve_constraints.
    (** If we remove the spurious dependency of the predicate on [n]: *)
    Undo 2.
    simple refine (nat_rect _ _ _ n). (* simple refine does not shelve dependent subgoals *)
    Set Printing Existential Instances.
    clear n. intros n. (* We must use an intro here to let the unifier solve
                          the higher-order problem *)
    solve_constraints.
    all:simpl.
  Admitted.
End UnifConstraints.


(***********************************************************************

Copyright (c) 2014 Jonathan Leivent

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

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

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

***********************************************************************)

(*

A slight reformularization of gaptree.v.  Move the gap bits to the
parents, because that might simplify things enough to make proofs more
automatic.

Well, maybe only for insertion, mostly.  It's hitting some Coq bugs
with respect to automation - specifically, 3381, but also 3378 - which
are making it hard to get automation to work in cases where it has
done so before, as in avl.v and redblack.v.

*)

Require Import common.
Typeclasses eauto := 9.

(* Some common tactic abbreviations: *)
Ltac ec := econstructor.
Ltac ea := eassumption.
Ltac re := reflexivity.
Ltac sh := simplify_hyps.

Context {A : Set}.
Context {ordA : Ordered A}.

Notation EL := (## (list A)).

Inductive Gap : Set :=
| G1 : Gap
| G0 : Gap.

(* We'll use option Gaps because leaves don't have gaps, but still
need to provide something as an index. *)
Notation EG := (## (option Gap)).
Notation SG0 := #(Some G0).
Notation SG1 := #(Some G1).

Definition gS := fun (g : Gap) =>
match g with
| G1 => ES
| G0 => fun n => n
end.

Ltac gsplit g := destruct g; simpl in *; sh.

Lemma gS0{g n}(e : #0 = gS g n) : n=#0 /\ g=G0.
Proof.
  gsplit g. tauto.
Qed.

Hint Extern 5 => match goal with H: ?n=S ?n |- _ =>
                                 contradict (n_Sn n H) end.
Hint Extern 5 => match goal with H: ?n=ES ?n |- _ =>
                                 exfalso; unerase; contradict (n_Sn n H) end.
Hint Extern 5 => match goal with H: S ?n=?n |- _ =>
                                 symmetry in H; contradict (n_Sn n H) end.
Hint Extern 5 => match goal with H: ES ?n=?n |- _ =>
                                 symmetry in H; exfalso; unerase; contradict (n_Sn n H) end.

Lemma ES0{n}(e : #0 = ES n) : False.
Proof. discriminate_erasable. Qed.

Hint Extern 5 => match goal with H: #0=ES _ |- _ =>
                                 exfalso; contradict(ES0 H) end.
Hint Extern 5 => match goal with H: ES _ = #0 |- _ =>
                                 exfalso; symmetry in H; contradict (ES0 H) end.

Lemma gSn{g n}(e : n = gS g n) : g=G0.
Proof.
  destruct g; simpl in e; eauto.
Qed.

Lemma gSS{g n}(e : ES n = gS g n) : g=G1.
Proof.
  destruct g; simpl in e; eauto.
Qed.

Ltac dogs :=
  repeat match goal with
           | H : _ = gS G0 _ |- _ => simpl gS in H; sh
           | H : gS G0 _ = _ |- _ => simpl gS in H; sh
           | H : _ = gS G1 _ |- _ => simpl gS in H; sh
           | H : gS G1 _ = _ |- _ => simpl gS in H; sh
           | H : _ = gS _ _ |- _ => first [apply gS0 in H|apply gSn in H|apply gSS in H]; sh
           | H : gS _ _ = _ |- _ => symmetry in H;
                                    first [apply gS0 in H|apply gSn in H|apply gSS in H]; sh
         end.

Hint Extern 2 (_ = gS ?G _) => (unify G G0 + unify G G1); simpl gS.
Hint Extern 2 (gS ?G _ = _) => (unify G G0 + unify G G1); simpl gS.
Hint Extern 10 (gS ?X _ = gS ?Y _) =>
(re + (unify X G0; unify Y G1) + (unify X G1; unify Y G0)); solve[simpl;re].
Hint Extern 0 (ES _ = ES _) => f_equal.

Lemma sgsg{g1 g2 : Gap}(e : #(Some g1)<>#(Some g2)) : g1<>g2.
Proof. intro. subst. contradict e. re. Qed.

Lemma nG1{g}(e : g<>G1) : g=G0.
Proof. destruct g; sh. re. Qed.

Lemma nG0{g}(e : g<>G0) : g=G1.
Proof. destruct g; sh. re. Qed.

Lemma nesym{T}{x y : T}(ne : x<>y) : y<>x.
Proof. intro. subst. contradict ne. re. Qed.

Hint Extern 5 => match goal with H : #(Some ?G1)<>#(Some ?G2) |- _ =>
                                 apply sgsg in H end.

Hint Extern 5 => match goal with H : _<>G1 |- _ => apply nG1 in H; sh end.
Hint Extern 5 => match goal with H : _<>G0 |- _ => apply nG0 in H; sh end.
Hint Extern 5 => match goal with H : G1<>_ |- _ => apply nesym in H; apply nG1 in H; sh end.
Hint Extern 5 => match goal with H : G0<>_ |- _ => apply nesym in H; apply nG0 in H; sh end.
Hint Extern 2 (_ \/ _) => (ea + left + right).
Hint Extern 10 (~(_=_)) => intro; sh.

(* The gaptree type exposes the gaps of each child as indices in the
parent to make the "gapee" and "avlish" props easier to work with. *)

Inductive gaptree : forall (logap rogap : EG)(height : EN)(contents : EL), Set :=
| Leaf : gaptree #None #None #0 []
| Node{ho hl fl hr fr gll glr grl grr}
      (gl : Gap)(tl : gaptree gll glr hl fl)(d : A)(gr : Gap)(tr : gaptree grl grr hr fr)
      {okl : ho=gS gl hl}{okr : ho=gS gr hr}{x : hl=#0 -> hr=#0 -> ho=#0}
      {s : Esorted (fl++^d++fr)} (*contents are properly sorted*)
  : gaptree #(Some gl) #(Some gr) (ES ho) (fl++^d++fr).

Hint Constructors gaptree.

(************************************************************************)

(*some prettifying tactic notation*)

Tactic Notation
  "Recurse" hyp(t) "=" "Node" ident(gl) ident(tl) ident(d) ident(gr) ident(tr)
  "[" ident(xl) "|" ident(xr) "]"
  := induction t as [ |? ? ? ? ? ? ? ? ? gl tl xl d gr tr xr]; [zauto| ].

Tactic Notation "Compare" hyp(x) hyp(y) := case (compare_spec x y); intros; subst.

Ltac Call x := let Q := fresh in assert (Q:=x); xinv Q.

(************************************************************************)

Section Find.

  Inductive findResult(x : A) : forall (contents : EL), Set :=
  | Found{fl fr} : findResult x (fl++^x++fr)
  | NotFound{f}{ni : ENotIn x f} : findResult x f.

  Hint Constructors findResult.

  Definition find(x : A){gl gr h f}(t : gaptree gl gr h f) : findResult x f.
  Proof.
    Recurse t = Node gl tl d gr tr [GoLeft|GoRight].
    Compare x d.
    - (*x=d*) eauto.
    - (*x<d*) xinv GoLeft. all:zauto.
    - (*x>d*) xinv GoRight. all:zauto.
  Qed.

End Find.

(************************************************************************)

(*Only Esorted and lt props are needed when solving Esorted props - so
convert all rbtree hyps into Esorted hyps prior to solving Esorted
(sorted, when unerased) props. *)

Definition Sof{gl gr h f}(t : gaptree gl gr h f) : Esorted f.
Proof. destruct t. all:unerase. all:eauto. Qed.

Ltac SofAll :=
  repeat match goal with
             H : gaptree _ _ _ _ |- _ => apply Sof in H
         end.

Ltac solve_esorted := SofAll; unerase; solve_sorted.
Ltac se := solve_esorted.

Hint Extern 20 (Esorted _) => solve_esorted.

(************************************************************************)

Lemma leaf1{gl gr f}(t : gaptree gl gr #0 f) : gl=#None /\ gr=#None /\ f=[].
 Proof. xinv t. Qed.

Ltac leaves :=
  match goal with
    | H:gaptree _ _ #0 _ |- _ => apply leaf1 in H; simplify_hyps
  end.

Ltac leaf_nil_cleanup :=
  repeat match goal with
           | H: ?F=[] |- _ => rewrite H in *
         end.

Hint Extern 1 => leaves.

Definition isLeaf{gl gr h f}(t : gaptree gl gr h f) : {h=#0} + {h<>#0}.
Proof. xinv t. intros. right. intro. simplify_hyps. Qed.

Inductive gapnode(h : EN)(f : EL) : Set :=
| Gapnode{gl gr}(t : gaptree gl gr h f) : gapnode h f.

Hint Constructors gapnode.

Section insertion.

  (* Gapee: one child has (or can have) a gap while the other doesn't.  *)
  Notation gapee gl gr h := (h=#0 \/ gl<>gr) (only parsing).

  Inductive ires(gl gr : EG) : EN -> EN ->  Set :=
  | ISameH{h} : ires gl gr h h
  | Higher{h} : gapee gl gr h -> ires gl gr h (ES h).

  Inductive insertResult(x : A)
  : forall(inH : EN)(contents : EL), Set :=
  | FoundByInsert{h fl fr} : insertResult x h (fl++^x++fr)
  | Inserted{gl gr hi ho fl fr}
      (t : gaptree gl gr ho (fl++^x++fr))(i : ires gl gr hi ho)
      : insertResult x hi (fl++fr).

  Hint Extern 1 (insertResult _ #0 []) =>
    rewrite <- Eapp_nil_l; eapply Inserted; [econstructor|].

  Hint Constructors insertResult ires.
  Hint Extern 100 (ires _ _ _ _) => match goal with |- context[gS G0 _] => simpl end.
  Hint Extern 100 (ires _ _ _ _) => match goal with |- context[gS G1 _] => simpl end.

  Definition iRotateRight{gll glr h fl fr grl grr}
             (tl : gaptree gll glr (ES (ES h)) fl)(d : A)(tr : gaptree grl grr h fr)
             (s : Esorted (fl++^d++fr))(H : gll <> glr)
  : gapnode (ES (ES h)) (fl++ ^ d ++ fr).
  Proof.
    xinv tl. intros tll tlr **.
    gsplit gr.
    - zauto.
    - xinv tlr. intros.
      (*zauto alone used to work here, but no longer*)
      rewrite ?Eapp_assoc.
      rewrite group3Eapp.
      zauto.
  Qed.

  Definition ign2ins{hi fl x fr}(i : gapnode hi (fl++^x++fr))
  : insertResult x hi (fl++fr).
  Proof.
    destruct i. eauto.
  Defined.

  Hint Resolve ign2ins iRotateRight.

  Definition iFitLeft{hl fl0 fr0 gll glr x gl gr grl grr hr fr}
             (t : gaptree gll glr (ES hl) (fl0 ++ ^ x ++ fr0))
             (d : A)(tr : gaptree grl grr hr fr)(H : lt x d)(okr : gS gl hl = gS gr hr)
             (s : Esorted ((fl0 ++ fr0) ++ ^ d ++ fr))(H0 : gapee gll glr hl)
  : insertResult x (ES (gS gl hl)) ((fl0 ++ fr0) ++ ^ d ++ fr).
  Proof.
    gsplit gl.
    - zauto.
    - gsplit gr. all:zauto.
  Qed.

  Hint Extern 100 (_=_) => match goal with G : Gap |- _ => gsplit G end.

  Definition iRotateLeft{gll glr h fl grl grr fr}
             (tl : gaptree gll glr h fl)(d : A)(tr : gaptree grl grr (ES (ES h)) fr)
             (s : Esorted(fl++^d++fr))(H : grl<>grr)
  : gapnode (ES (ES h)) (fl++^d++fr).
  Proof.
    xinv tr. intros trl trr **.
    gsplit gl.
    - zauto.
    - xinv trl. intros.
      rewrite ?Eapp_assoc. rewrite group3Eapp. zauto.
  Qed.

  Hint Resolve iRotateLeft.

  Definition iFitRight{gll glr hl fl grl grr hr fr0 x fr1 gl gr}
             (tl : gaptree gll glr hl fl)(d: A)(tr : gaptree grl grr (ES hr)(fr0++^x++fr1))
             (s : Esorted (fl++^d++fr0++fr1))(H : lt d x)
             (H0 : gapee grl grr hr)(okl : gS gl hl = gS gr hr)
  : insertResult x (ES (gS gl hl)) ((fl++^d++fr0)++fr1).
  Proof.
    gsplit gr.
    - zauto.
    - gsplit gl. all:zauto.
  Qed.

  Hint Resolve iFitLeft iFitRight.

  Definition insert(x : A){gl gr h f}(t : gaptree gl gr h f)
  : insertResult x h f.
  Proof.
    Recurse t = Node gl tl d gr tr [GoLeft|GoRight].
    - Compare x d.
      + (*x=d*) eauto.
      + (*x<d*)
        xinv GoLeft.
        * zauto.
        * intros t i. xinv i. all:zauto.
      + (*x>d*)
        xinv GoRight.
        * zauto.
        * intros t i. xinv i.
          { zauto. }
          { intro. rewrite group3Eapp. eauto. }
  Qed.

End insertion.

Section deletion.

  Inductive dres: forall (hi ho : EN), Set :=
  | DSameH{h} : dres h h
  | Lower{h} : dres (ES h) h.

  Hint Constructors dres.

  Inductive delout (*intermediate result for delmin and delete*)
  : forall (inH : EN)(contents : EL), Set :=
  | Delout {hi ho f}(t: gapnode ho f){dr: dres hi ho} : delout hi f.

  Hint Constructors delout.

  (* "AVLish" is the condition of being AVL-like - at least one child *)
  (* doesn't have a gap.*)
  Definition avlish(gl gr : EG) := gl=SG0 \/ gr=SG0.

  Inductive tryLowerResult: EG -> EG -> EN -> EL -> Set :=
  | lowered{h f}(t : gaptree SG0 SG0 (ES h) f) : tryLowerResult SG1 SG1 (ES (ES h)) f
  | lowerFailed{gl gr h f}: avlish gl gr -> tryLowerResult gl gr h f.

  Hint Constructors tryLowerResult.

  Hint Unfold avlish.

  (* If a node's children both have gaps, the node can be lowered by 1. *)
  Definition tryLowering{gl gr h f}(t : gaptree gl gr (ES h) f)
  : tryLowerResult gl gr (ES h) f.
  Proof.
    generalize_eqs t.
    case t.
    - intros H. discriminate_erasable.
    - intros ho hl fl hr fr gll glr grl grr gl0 tl d gr0 tr okl okr x s H.
      gsplit gl0.
      + gsplit gr0.
        * eauto.
        * eauto.
      + eauto.
  Qed.

  Definition gflip(g : Gap) :=
    match g with G0=>G1|G1=>G0 end.

  Definition dRotateLeft{gl0 gr0 ho fl grl grr fr}
             (tl : gaptree gl0 gr0 ho fl)(d : A)(tr : gaptree grl grr (ES (ES ho)) fr)
             (s : Esorted (fl ++ ^ d ++ fr))(H : avlish grl grr)
  : gapnode (ES (ES (ES ho))) (fl ++ ^ d ++ fr).
  Proof.
    unfold avlish in H.
    generalize_eqs tr.
    destruct tr as [|ho0 hl fl0 hr fr0 gll glr grl0 grr0 gl trl d0 gr trr ok1 ok2 x sr] eqn:E; clear E.
    { intro. sh. }
    intro.
    gsplit gr.
    - assert (gl=G0) by (sh;re). subst.
      simpl gS in ok2. subst.
      xinv trl. intros tl0 tr0 okl okr x0 s0. subst.
      rewrite ?Eapp_assoc. rewrite group3Eapp. ec. ec. ec. ea. ea. re.
      (*zauto here runs into bug 3381*)
      eauto. eauto. se. ec.
      ea. ea. re. zauto. intros. subst. leaves. dogs. re. se.
      instantiate (1:=G1). simpl. re. instantiate(1:=G1). simpl. f_equal. f_equal. ea.
      simpl gS. intros. zauto. se.
    - rewrite group3Eapp. ec. ec. ec. ea. ea. 5:ea. 6:instantiate (1:=G1);zauto.
      4:se. 6:se. instantiate(1:=gflip gl). 2:zauto. 2:zauto.
      2:instantiate (1:=gl). 2:gsplit gl; re. 2:intros;sh.
      gsplit gl; re.
  Qed.

  Inductive delminResult
  : forall (inH : EN)(contents : EL), Set :=
  | NoMin : delminResult #0 []
  | MinDeleted{hi f}(m : A)(dr : delout hi f) : delminResult hi (^m++f).

  Hint Constructors delminResult.

  Definition dFitLeft{gl0 gr0 ho f grl grr hr fr gl gr}
             (tl : gaptree gl0 gr0 ho f)(d : A)(tr : gaptree grl grr hr fr)
             (s : Esorted (f ++ ^ d ++ fr))(ok : gS gl (ES ho) = gS gr hr)(H : hr <> # 0)
  : delout (ES (gS gl (ES ho))) (f ++ ^ d ++ fr).
  Proof.
    gsplit gl.
    - assert (hr=ES (gS (gflip gr) ho)) by (gsplit gr; re). subst.
      gsplit gr.
      + ec. ec. ec. ea. ea. re. zauto. zauto. se. ec.
      + Call (tryLowering tr).
        * intro t. clear tr.
          ec. ec. ec. ea. ea. re. zauto. zauto. se. ec.
        * intro A. ec. 2:eapply DSameH. eapply dRotateLeft; ea.
    - ec. 2:ec. ec. ec. ea. ea. instantiate (1:=G1). re. ea.
      intros. subst. sh. se.
  Qed.

  Definition delmin{gl gr h f}(t : gaptree gl gr h f) : delminResult h f.
  Proof.
    Recurse t = Node gl tl d gr tr [GoLeft|GoRight].
    xinv GoLeft.
    - rewrite Eapp_nil_l.
      ec. ec. ec. ea. rewrite okl.
      assert (gr=G0).
      { gsplit gr. gsplit gl. unerase. injection okl. intros ->.
        specialize (x eq_refl eq_refl). unerase_hyp x. discriminate x. re. } subst.
      simpl in okl. subst. ec.
    - intro dl. xinv dl. rewrite ?Eapp_assoc.
      intros [? ? t] dr. xinv dr.
      + eauto.
      + case (isLeaf tr); intros; subst.
        * leaves.
          assert (ho=#0/\gl=G0/\gr=G1).
          { clear s. gsplit gl; gsplit gr. unerase. eauto. } sh. leaves. simpl gS.
          ec. ec. ec. ec. ec. ec. re. 2:zauto. re. se. ec.
        * ec. eapply dFitLeft. ea. ea. se. ea. ea.
  Qed.

  Definition dRotateRight{gll glr ho gl0 gr0 f fl}
             (tl : gaptree gll glr (ES (ES ho)) fl)(d : A)(tr : gaptree gl0 gr0 ho f)
             (s : Esorted (fl ++ ^ d ++ f))(H : avlish gll glr)
  : gapnode (ES (ES (ES ho))) (fl ++ ^ d ++ f).
  Proof.
    unfold avlish in H.
    generalize_eqs tl.
    destruct tl as [|ho0 hl fl0 hr fr0 gll glr grl0 grr0 gl tll d0 gr tlr ok1 ok2 x sr] eqn:E; clear E.
    { intro. sh. }
    intro.
    gsplit gl.
    - assert (gr=G0) by (sh;re). subst.
      simpl gS in ok2. subst.
      xinv tlr. intros tl0 tr0 okl okr x0 s0. subst.
      rewrite ?Eapp_assoc. rewrite group3Eapp. ec. ec. ec. ea. ea. re.
      (*zauto here runs into bug 3381*)
      eauto. eauto. se. ec.
      ea. ea. re. zauto. intros. subst. leaves. dogs. re. se.
      instantiate (1:=G1). simpl. re. instantiate(1:=G1). simpl. f_equal. f_equal. ea.
      simpl gS. intros. zauto. se.
    - rewrite ?Eapp_assoc. ec. ec. ea. ec. ea. ea. 5:instantiate(1:=G1);zauto.
      4:se. 6:se. zauto. instantiate(1:=gflip gr). 2:zauto.
      2:instantiate(1:=gr). 2:gsplit gr;re. 2:intros;sh.
      gsplit gr; re.
  Qed.

  Definition dFitRight{gll glr hl fl gl0 gr0 ho f gl gr}
             (tl : gaptree gll glr hl fl)(d : A)(tr : gaptree gl0 gr0 ho f)
             (s : Esorted (fl ++ ^ d ++ f))(okr : gS gl hl = gS gr (ES ho))(H : hl <> # 0)
  : delout (ES (gS gl hl)) (fl ++ ^ d ++ f).
  Proof.
    gsplit gr.
    - assert (hl=ES (gS (gflip gl) ho)) by (gsplit gl; re). subst.
      gsplit gl.
      + ec. ec. ec. ea. ea. re. zauto. zauto. se. ec.
      + Call (tryLowering tl).
        * intro t. clear tl.
          ec. ec. ec. ea. ea. re. zauto. zauto. se. ec.
        * intro A. ec. 2:eapply DSameH. eapply dRotateRight; ea.
    - ec. 2:ec. ec. ec. ea. ea. re. instantiate (1:=G1). ea.
      intros. subst. sh. se.
  Qed.

  Inductive delmaxResult
  : forall (inH : EN)(contents : EL), Set :=
  | NoMax : delmaxResult #0 []
  | MaxDeleted{hi f}(m : A)(dr : delout hi f) : delmaxResult hi (f++^m).

  Hint Constructors delmaxResult.

  Definition delmax{gl gr h f}(t : gaptree gl gr h f) : delmaxResult h f.
  Proof.
    Recurse t = Node gl tl d gr tr [GoLeft|GoRight].
    xinv GoRight.
    - rewrite Eapp_nil_r.
      ec. ec. ec. ea. rewrite okr.
      assert (gl=G0).
      { clear s. gsplit gl. gsplit gr. unerase. injection okr. intros ->.
        specialize (x eq_refl eq_refl). unerase_hyp x. discriminate x. re. } subst.
      simpl in okr. subst. ec.
    - intro dl. xinv dl. rewrite group3Eapp.
      intros [? ? t] dr. xinv dr.
      + eauto.
      + case (isLeaf tl); intros; subst.
        * leaves.
          assert (ho=#0/\gr=G0/\gl=G1).
          { clear s. gsplit gl; gsplit gr. unerase. injection okr. eauto. } sh. leaves. simpl gS.
          ec. ec. ec. ec. ec. ec. re. 2:zauto. re. se. ec.
        * ec. eapply dFitRight. ea. ea. se. ea. ea.
  Qed.

  Definition delMinOrMax{gll glr hl fl grl grr hr fr gl gr}
             (tl : gaptree gll glr hl fl)(d : A)(tr : gaptree grl grr hr fr)
             (s : Esorted (fl ++ ^ d ++ fr))(ok : gS gl hl = gS gr hr)
             (x0 : hl = # 0 -> hr = # 0 -> gS gl hl = # 0)
  : delout (ES (gS gl hl)) (fl ++ fr).
  Proof.
    gsplit gl; gsplit gr.
    - Call (delmin tr).
      { specialize (x0 eq_refl eq_refl). sh. }
      intro X. xinv X. intros [? ? t'] r. xinv r.
      + ec. ec. ec. ea. ea. 3:ea. instantiate (1:=G1). zauto. instantiate (1:=G1). zauto. se. ec.
      + ec. ec. ec. ea. ea. 5:eapply Lower. zauto. instantiate(1:=G1). re. zauto. se.
    - Call (delmin tr). intro X. xinv X. intros [? ? t'] r. xinv r.
      + ec. ec. ec. ea. ea. instantiate (1:=G1). re. zauto. zauto. se. ec.
      + ec. ec. ec. ea. ea. instantiate (1:=G0). re. zauto. zauto. se. ec.
    - Call (delmax tl). intro X. xinv X. intros [? ? t'] r. xinv r.
      + rewrite ?Eapp_assoc. ec. ec. ec. ea. ea. re. zauto. zauto. se. ec.
      + rewrite ?Eapp_assoc. ec. ec. ec. ea. ea. re. re. zauto. se. ec.
    - Call (delmin tr).
      { rewrite Eapp_nil_r. ec. leaves. leaves. ec. ec. ec. }
      intro X. xinv X. intros [? ? t'] r. xinv r.
      + ec. ec. ec. ea. ea. re. re. zauto. se. ec.
      + ec. ec. ec. ea. ea. re. zauto. zauto. se. ec.
  Qed.

  Inductive deleteResult(x : A)(hi :EN)
  : forall(contents : EL), Set :=
  | DelNotFound{f}{ni : ENotIn x f} : deleteResult x hi f
  | Deleted{fl fr}
           (dr : delout hi (fl++fr)) : deleteResult x hi (fl++^x++fr).

  Hint Constructors deleteResult.

  Definition delete(x : A){gl gr h f}(t : gaptree gl gr h f) : deleteResult x h f.
  Proof.
    Recurse t = Node gl tl d gr tr [GoLeft|GoRight].
    Compare x d.
    - eapply Deleted.
      eapply delMinOrMax. all:ea.
    - xinv GoLeft.
      + eauto.
      + intro X. xinv X. intros [? ? t'] r.
        rewrite ?Eapp_assoc.
        eapply Deleted.
        rewrite <- Eapp_assoc.
        xinv r; intros; subst.
        * zauto.
        * case (isLeaf tr); intros; subst.
          { leaves.
            assert (ho=#0/\gl=G0/\gr=G1).
            { clear s. gsplit gl; gsplit gr. unerase. eauto. } sh. leaves. simpl gS.
            ec. ec. ec. leaf_nil_cleanup. ec. ec. re. 2:zauto. re. se. ec. }
          { eapply dFitLeft. all:try ea. se. }
    - xinv GoRight.
      + eauto.
      + intro X. xinv X. intros [? ? t'] r.
        rewrite group3Eapp.
        eapply Deleted.
        rewrite ?Eapp_assoc.
        xinv r; intros; subst.
        * zauto.
        * case (isLeaf tl); intros; subst.
          { leaves.
            assert (ho=#0/\gr=G0/\gl=G1).
            { clear s. gsplit gr; gsplit gl. unerase. injection okr. eauto. } sh. leaves. simpl gS.
            ec. ec. ec. ec. leaf_nil_cleanup. ec. re. 2:zauto. re. se. ec. }
          { eapply dFitRight. all:try ea. se. }
  Qed.

End deletion.

Require Import Arith Omega Min Max Psatz natsind.

(*unS is a proven-safe pred function - so we don't have to worry about
OCaml's pred function having a different semantics (Z-style
go-negative) from Coq's (N-style stop-at-0).*)

Definition unS(n : nat){pn}(H : ES pn=#n) : {n' : nat | pn=#n'}.
Proof.
  destruct n.
  - sh.
  - exists n. change (#(S n)) with (ES #n) in H. sh. re.
Defined.

Definition g2h{ph g h}(H : ES (gS g h) = #ph) : {h' : nat | #h'=h}.
Proof.
  destruct g; simpl in H.
  - elim (unS _ H). intros hm1 H2. elim (unS _ H2). intros hm2 ->. eexists. re.
  - elim (unS _ H). intros hm1 ->. eexists. re.
Qed.

Ltac ses := match goal with
                |- context[#(S ?X)] => change (#(S X)) with (ES #X) end.

Section joining.

  (* Join takes two trees sorted with respect to each other and a
  "middle" element, and combines them all into a single tree - it acts
  like a generalized tree node constructor that doesn't care that the
  heights of the two tree args match in any way.  It is a foundational
  function needed for the sets library.  Note that the version here
  demonstrates the same AVL-like qualities (no G1G1 nodes are added,
  each join does at most 1 rotate then stops propagating changes up
  the tree) as does gaptree insert.

  The implementation of join is split in half - joinle is for when the
  left tree's height is <= the right tree's height, joinge for when it
  is >=.  This split is done so that join can use structural induction
  on the higher tree.  As seen in sets.v, we now have a general
  measured recursion scheme based on erased nats that could be used
  here to keep join as a single function.  However, not much gets
  simplified by doing so (I tried it).

*)

  Inductive jres(gl gr: EG)(hil hih : EN) : EN -> Set :=
  | JSameH : jres gl gr hil hih hih
  | JHigher : (hil<>hih -> gl<>gr) -> jres gl gr hil hih (ES hih).

  Inductive joinResult(hil hih : EN)(f : EL) : Set :=
  | JoinResult(h : nat){gl gr} : gaptree gl gr #h f -> jres gl gr hil hih #h -> joinResult hil hih f.

  Hint Constructors joinResult jres.

  Definition joinle(h1 : nat){g1l g1r f1}(t1 : gaptree g1l g1r # h1 f1)(d : A)
             (h2: nat){g2l g2r f2}(t2 : gaptree g2l g2r # h2 f2)
             (s : Esorted (f1 ++ ^ d ++ f2))(H : h1 <= h2)
  : joinResult #h1 #h2 (f1++^d++f2).
  Proof.
    generalize_eqs_vars t2.
    induction t2 eqn:E.
    - intros t1 h2 s H H0. sh.
      assert (h1=0) by omega. subst. leaves.
      ec. instantiate (1:=1). ses. ec. ec. ec.
      eauto. eauto. tauto. ea. ec. tauto.
    - intros t1 h2 s0 H H0. clear E IHg2. subst ho.
      case (eq_nat_dec h1 h2).
      + intros H1. subst.
        ec. instantiate (1:=S h2). ses. ec. ea. ea. eauto. eauto. tauto. ea. ec. tauto.
      + intros H1. assert (h1<h2) as H2 by omega. clear H H1.
        case (eq_nat_dec (S h1) h2).
        * intros H. subst. clear H2.
          ec. instantiate (1:=S(S h1)). ses. ec. ea. ea.
          instantiate(1:=G1). re. rewrite H0. eauto. rewrite H0. tauto. se. ec. eauto.
        * intros H. assert (S h1<h2) as H1 by omega. clear H H2.
          destruct gl eqn:E.
          { simpl gS in *.
            elim (unS h2 H0). intros h2m1 Hh2m1. elim (unS h2m1 Hh2m1). intros h2m2 Hh2m2.
            eelim (IHg1 g1 eq_refl t1 h2m2 _ _ Hh2m2). intros h ? ? g j. clear IHg1.
            destruct j.
            - rewrite group3Eapp. ec. instantiate (1:=h2). rewrite <-H0. ec. ea. ea.
              instantiate (1:=gl). subst. simpl. re. ea. intros H H2. rewrite H in g.
              apply leaf1 in g. destruct g as (? & ? & Fnil). exfalso. unerase.
              symmetry in Fnil. contradict Fnil.
              change (f1 ++ [d] ++ fl)%list with (f1++d::fl)%list.
              apply app_cons_not_nil.
              se. ec.
            - rewrite group3Eapp. ec. instantiate (1:=h2). rewrite <-H0. ec. ea. ea.
              instantiate (1:=G0). simpl. unerase. omega. ea. eauto. se. ec. }
          { simpl gS in *.
            elim (unS h2 H0). intros h2m1 Hh2m1.
            eelim (IHg1 g1 eq_refl t1 h2m1 _ _ Hh2m1). intros h ? ? g j. clear IHg1.
            destruct j as [|X].
            - rewrite group3Eapp. ec. instantiate (1:=h2). rewrite <-H0. ec. ea. ea.
              instantiate (1:=G0). simpl. ea. ea. rewrite Hh2m1. tauto. se. ec.
            - rewrite <-Hh2m1 in *.
              destruct gr.
              + simpl gS in *. subst.
                elim (iRotateRight g d0 g2). intros gl gr t. rewrite group3Eapp.
                ec. instantiate (1:=h2). rewrite <-H0. ea.
                ec. se. apply X. unerase. omega.
              + simpl gS in *. subst.
                rewrite group3Eapp. ec. instantiate (1:=S h2). ses. ec. ea. ea.
                eauto. instantiate (1:=G1). simpl. eauto. eauto. se. ec. intro. eauto. }
  Grab Existential Variables.
  { se. }
  { unerase; omega. }
  { se. }
  { unerase; omega. }
  Qed.

  Definition joinge(h1 : nat){g1l g1r f1}(t1 : gaptree g1l g1r# h1 f1)(d : A)
             (h2: nat){g2l g2r f2}(t2 : gaptree g2l g2r # h2 f2)
             (s : Esorted (f1 ++ ^ d ++ f2))(H : h1 >= h2)
  : joinResult #h2 #h1 (f1++^d++f2).
  Proof.
    generalize_eqs_vars t1.
    induction t1 eqn:E.
    - intros h1 t2 s H H0. sh.
      assert (h2=0) by omega. subst. leaves.
      ec. instantiate (1:=1). ses. ec. ec. ec.
      eauto. eauto. tauto. ea. ec. tauto.
    - intros h1 t2 s0 H H0. clear E IHg1. subst ho.
      case (eq_nat_dec h1 h2).
      + intros H1. subst.
        ec. instantiate (1:=S h2). ses. ec. ea. ea. eauto. eauto. tauto. ea. ec. tauto.
      + intros H1. assert (h1>h2) as H2 by omega. clear H H1.
        case (eq_nat_dec (S h2) h1).
        * intros H. subst. clear H2.
          ec. instantiate (1:=S(S h2)). ses. ec. ea. ea.
          rewrite H0. eauto. instantiate(1:=G1). re. rewrite H0. tauto. se. ec. eauto.
        * intros H. assert (S h2<h1) as H1 by omega. clear H H2.
          rewrite okr in H0.
          destruct gr eqn:E.
          { simpl gS in *.
            elim (unS h1 H0). intros h1m1 Hh1m1. elim (unS h1m1 Hh1m1). intros h1m2 Hh1m2.
            eelim (IHg2 g2 eq_refl h1m2 t2 _ _ Hh1m2). intros h ? ? g j. clear IHg2.
            destruct j.
            - rewrite ?Eapp_assoc. ec. instantiate (1:=h1). rewrite <-H0. ec. ea. ea.
              symmetry in okr. exact okr.
              instantiate (1:=gr). subst. simpl. re. intros H H2. rewrite H2 in g.
              apply leaf1 in g. destruct g as (? & ? & Fnil). exfalso. unerase.
              symmetry in Fnil. contradict Fnil.
              change (fr ++ [d] ++ f2)%list with (fr++d::f2)%list.
              apply app_cons_not_nil.
              se. ec.
            - rewrite ?Eapp_assoc. ec. instantiate (1:=h1). rewrite <-H0. ec. ea. ea.
              symmetry in okr. exact okr.
              instantiate (1:=G0). simpl. unerase. omega. eauto. se. ec. }
          { simpl gS in *.
            elim (unS h1 H0). intros h1m1 Hh1m1.
            eelim (IHg2 g2 eq_refl h1m1 t2 _ _ Hh1m1). intros h ? ? g j. clear IHg2.
            destruct j as [|X].
            - rewrite ?Eapp_assoc. ec. instantiate (1:=h1). rewrite <-H0. ec. ea. ea.
              symmetry in okr. exact okr.
              instantiate (1:=G0). simpl. ea. rewrite Hh1m1. tauto. se. ec.
            - rewrite <-Hh1m1 in *.
              destruct gl.
              + simpl gS in *. subst.
                elim (iRotateLeft g1 d0 g). intros gl gr t. rewrite ?Eapp_assoc.
                ec. instantiate (1:=h1). rewrite <-H0. ea.
                ec. se. apply X. unerase. omega.
              + simpl gS in *. subst.
                rewrite ?Eapp_assoc. ec. instantiate (1:=S h1). ses. ec. ea. ea.
                instantiate (1:=G1). simpl. eauto. eauto. eauto. se. ec. intro. eauto. }
  Grab Existential Variables.
  { se. }
  { unerase; omega. }
  { se. }
  { unerase; omega. }
  Qed.

  Definition join(h1 : nat){g1l g1r f1}(t1 : gaptree g1l g1r# h1 f1)(d : A)
             (h2: nat){g2l g2r f2}(t2 : gaptree g2l g2r # h2 f2)
             (s : Esorted (f1 ++ ^ d ++ f2))
  : joinResult #(min h1 h2) #(max h1 h2) (f1++^d++f2).
  Proof.
    case (lt_dec h1 h2); intro.
    - assert (min h1 h2=h1) as H0.
      { apply min_l. omega. }
      rewrite H0.
      assert (max h1 h2=h2) as H1.
      { apply max_r. omega. }
      rewrite H1.
      eapply joinle. ea. ea. ea. omega.
    - assert (min h1 h2=h2) as H0.
      { apply min_r. omega. }
      rewrite H0.
      assert (max h1 h2=h1) as H1.
      { apply max_l. omega. }
      rewrite H1.
      eapply joinge. ea. ea. ea. omega.
  Qed.

End joining.

Require tctree.

(* Glue logic to instantiate the Tree typeclass using gaptrees *)

Inductive gaphtree(f : EL) : Set := (* gaptree with height of root *)
Gaphtree(h : nat){gl gr}(t : gaptree gl gr #h f) : gaphtree f.

Instance gaphtree_tree : tctree.Tree A := { tree := gaphtree }.
{ ec. apply Leaf. }
{ intros f [? ? ? t]. xinv t. eauto. }
{ intros f [? ? ? t]. generalize_eqs t. destruct t eqn:E.
  - ec. re.
  - intros H. subst.
    elim (g2h H). intros hl' <-. generalize H. rewrite okr. intro Hr. elim (g2h Hr). intros hr' <-.
    eapply tctree.BreakNode. 3:re. ec. ea. ec. ea. }
{ intros x f [? ? ? t].
  Call (insert x t).
  - ec. re.
  - intros t0 i. simple inversion i.
    + subst. subst ho. eapply tctree.Inserted. ec. ea. re.
    + intro. subst. eapply tctree.Inserted. ec. ea. re. }
{ intros fl [? ? ? tl] d fr [? ? ? tr] s.
  elim (join _ tl d _ tr s). intros h1 gl1 gr1 g j.
  ec. ea. }
{ intros f [? ? ? t].
  Call (delmin t).
  - ec. re.
  - intros dr.
    xinv dr.
    intros t0 dr0.
    xinv dr0.
    + destruct t0. eapply tctree.DelminNode. ec. 2:re. ea.
    + destruct t0. eelim (unS h);[|ea]. intros ho' ->.
      eapply tctree.DelminNode. ec. 2:re. ea. }
{ intros f [? ? ? t].
  Call (delmax t).
  - ec. re.
  - intros dr.
    xinv dr.
    intros t0 dr0.
    xinv dr0.
    + destruct t0. eapply tctree.DelmaxNode. ec. 2:re. ea.
    + destruct t0. eelim (unS h);[|ea]. intros ho' ->.
      eapply tctree.DelmaxNode. ec. 2:re. ea. }
{ intros x f [? ? ? t].
  Call (delete x t).
  - ec. ea.
  - intros dr.
    xinv dr.
    intros t0 dr0.
    xinv dr0.
    + destruct t0. eapply tctree.Deleted. ec. 2:re. ea.
    + destruct t0. eelim (unS h);[|ea]. intros ho' ->.
      eapply tctree.Deleted. ec. 2:re. ea. }
Defined.

Set Printing Width 114.
Require Import ExtrOcamlBasic.
Extraction Inline ign2ins.
Extraction Implicit iFitLeft [x].
Extraction Implicit iFitRight [x].
Extract Inductive delout => "( * )" [ "(,)" ].
Extract Inlined Constant eq_nat_dec => "(=)".
Extract Inlined Constant lt_dec => "(<)".
Extract Inlined Constant plus => "(+)".
Extract Inlined Constant pred => "FAIL unchecked use of pred".
Extract Inlined Constant unS => "pred".
Extraction "gaptreeb.ml" find insert delmin delmax delete join gaphtree_tree.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.
Require Import Logic.HoareLogic.ImperativeLanguage.
Require Import Logic.HoareLogic.BigStepSemantics.
Require Import Logic.HoareLogic.ConcurrentSemantics_Angelic.
Require Import Logic.HoareLogic.HoareLogic.

(***************************************)
(* Type Classes                        *)
(***************************************)

Class GuardedHoareTriple
      (L: Language)
      (P: ProgrammingLanguage)
      (HLan: Language): Type :=
{
  Assertion := @expr L;
  guard: Type;
  triple: guard ->
          Assertion ->
          cmd ->
          Assertion ->
          @expr HLan
}.

Definition triple_valid
           {L: Language}
           {P: ProgrammingLanguage}
           {HLan: Language}
           {TI: Semantics HLan unit_MD}
           (t: @expr HLan): Prop :=
  @satisfies _ _ TI tt t.

(*
Notation "|==  x" := (triple_valid x) (at level 71, no associativity) : hoare_logic.
(* This notation has been used. *)
 *)
Declare Scope guarded_hoare_logic.
Notation "{{ Inv }} {{ P }} c {{ Q }}" := (triple Inv P c Q) (at level 80, no associativity) : guarded_hoare_logic.