Require Import List.
Import ListNotations.
Require Import StructTact.StructTactics.
Require Import StructTact.ListTactics.
Require Import StructTact.ListUtil.

Set Implicit Arguments.

Section dedup.
  Variable A : Type.
  Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}.

  Fixpoint dedup (xs : list A) : list A :=
    match xs with
    | [] => []
    | x :: xs => let tail := dedup xs in
                 if in_dec A_eq_dec x xs then
                   tail
                 else
                   x :: tail
    end.

  Lemma dedup_eliminates_duplicates : forall a l l',
      dedup (a :: l ++ a :: l') = dedup (l ++ a :: l').
  Proof using.
    intros. simpl in *.
    break_match.
    + auto.
    + exfalso. intuition.
  Qed.

  Lemma dedup_In : forall (x : A) xs,
      In x xs ->
      In x (dedup xs).
  Proof using.
    induction xs; intros; simpl in *.
    - intuition.
    - break_if; intuition; subst; simpl; auto.
  Qed.

  Lemma filter_dedup (pred : A -> bool) :
    forall xs (p : A) ys,
      pred p = false ->
      filter pred (dedup (xs ++ ys)) = filter pred (dedup (xs ++ p :: ys)).
  Proof using.
    intros.
    induction xs; simpl; repeat (break_match; simpl);
      auto using f_equal2; try discriminate.
      + exfalso. apply n. apply in_app_iff. apply in_app_or in i. intuition.
      + exfalso. apply n. apply in_app_or in i. intuition.
        * simpl in *. intuition. congruence.
  Qed.

  Lemma dedup_app : forall (xs ys : list A),
      (forall x y, In x xs -> In y ys -> x <> y) ->
      dedup (xs ++ ys) = dedup xs ++ dedup ys.
  Proof using.
    intros. induction xs; simpl; auto.
    repeat break_match.
    - apply IHxs.
      intros. apply H; intuition.
    - exfalso. specialize (H a a).
      apply H; intuition.
      do_in_app. intuition.
    - exfalso. apply n. intuition.
    - simpl. f_equal.
      apply IHxs.
      intros. apply H; intuition.
  Qed.

  Lemma in_dedup_was_in :
    forall xs (x : A),
      In x (dedup xs) ->
      In x xs.
  Proof using.
    induction xs; intros; simpl in *.
    - intuition.
    - break_if; simpl in *; intuition.
  Qed.

  Lemma NoDup_dedup :
    forall (xs : list A),
      NoDup (dedup xs).
  Proof using.
    induction xs; simpl.
    - constructor.
    - break_if; auto.
      constructor; auto.
      intro.
      apply n.
      eapply in_dedup_was_in; eauto.
  Qed.

  Lemma remove_dedup_comm : forall (x : A) xs,
      remove A_eq_dec x (dedup xs) =
      dedup (remove A_eq_dec x xs).
  Proof using.
    induction xs; intros.
    - auto.
    - simpl. repeat (break_match; simpl); auto using f_equal.
      + exfalso. apply n0. apply remove_preserve; auto.
      + exfalso. apply n. eapply in_remove; eauto.
  Qed.

  Lemma dedup_partition :
    forall xs (p : A) ys xs' ys',
      dedup (xs ++ p :: ys) = xs' ++ p :: ys' ->
      remove A_eq_dec p (dedup (xs ++ ys)) = xs' ++ ys'.
  Proof using.
    intros xs p ys xs' ys' H.
    f_apply H (remove A_eq_dec p).
    rewrite remove_dedup_comm, remove_partition in *.
    find_rewrite.
    rewrite remove_partition.

    apply remove_not_in.
    apply NoDup_remove_2.
    rewrite <- H.
    apply NoDup_dedup.
  Qed.

  Lemma dedup_NoDup_id : forall (xs : list A),
      NoDup xs -> dedup xs = xs.
  Proof using.
    induction xs; intros.
    - auto.
    - simpl. invc_NoDup. concludes.
      break_if; congruence.
  Qed.

  Lemma dedup_not_in_cons :
    forall x xs,
      (~ In x xs) ->
      x :: dedup xs = dedup (x :: xs).
  Proof using.
    induction xs; intros.
    - auto.
    - simpl in *. intuition. repeat break_match; intuition.
  Qed.
End dedup.


Require Import logic.

Definition diamond : muf :=
  fun W '⟨w, R, V⟩ '⟨v, R', V'⟩=>
     R w v /\ R = R' /\ V = V'.

(* In this file we will define a number of examples of dynamic modal
   logics with concrete sets of dynamic operators and their
   corresponding model update functions.

   To achieve this goal we need to define modules that satisfy the
   signature given by the module type DYN. Once we have these modules
   we can apply the functor DynLogic to each of them to obtain the
   corresponding dynamic modal logics.

   We could define our modules directly with the type DYN.
   Unfortunately, this would restrict the interface. If the interface
   is restricted we can no longer access any local definition in the
   module that is not part of the module type.

   The other option is to ignore the type and define our module
   without any type. But we want to be sure that our implementation
   satisfies the module type DYN!

   Thankfully, Coq provides a way to do this by using a transparent
   constraint:

*)

Module SbDyn <: DYN.

Inductive SbDyn := Diamond | Sb.
Definition Dyn := SbDyn.

Import RelationClasses.

Definition rel_minus {W} (R: relation W) (w v: W) : relation W :=
  fun w' v'=>
  (w = w' /\ v = v' -> False) \/ (w <> w' \/ v <> v' -> R w' v').

Definition F (f: Dyn) : muf :=
  match f with
  | Diamond => diamond
  | Sb => fun W '⟨w, R, V⟩ '⟨v, R', V'⟩=>
     R w v /\ R' = rel_minus R w v /\ V' = V
  end.

End SbDyn.

Module SbExample.
Module SbDynLogic := DynLogic SbDyn.
Import SbDynLogic.
Import SbDyn.

Notation "⃟ φ" := (DynDiam Diamond φ)
                     (at level 65, right associativity).

Notation "'⃟sb' φ" := (DynDiam Sb φ)
                     (at level 65, right associativity).

Example valid_in_sb : forall (p:prop) pm, pm |= ⃟sb p ->' ⃟p.
Proof.
  move=>p [ [W R] V] /= w [ [v R'] V'] /=.
  rewrite /Ensembles.In /=.
  move => [ [ ? [ ? ?]] ?].
  eexists ⟨v, _, V⟩.
  by subst.
Qed.

End SbExample.

Module PoisonDyn <: DYN.

Inductive PoisonDyn := Diamond | Poison.
Definition Dyn := PoisonDyn.

Context (poison_atom : prop).
Notation "p∙" := poison_atom.

Definition F (d: Dyn) : muf :=
  match d with
  | Diamond => diamond
  | Poison => fun W '⟨w, R, V⟩ '⟨v, R', V'⟩=>
     R w v /\ R' = R /\ V' = (V ∪ ⦃(p∙, v)⦄)
  end.

End PoisonDyn.

Module PoisonDynLogic := DynLogic PoisonDyn.
Import PoisonDynLogic.
Import PoisonDyn.

Notation "⃟ φ" := (DynDiam Diamond φ)
                     (at level 65, right associativity).

Notation "'⬙' φ" := (DynDiam Poison φ)
                     (at level 65, right associativity).

Let p (n:nat) := ⦃(p∙, n)⦄.

Fixpoint delta n : form :=
  match n with
  | 0 => ⊥'
  | 1 => ⃟p∙
  | S n' => ⃟(~'p∙ /\' delta n')
  end.

Definition V0 : valuation nat := ∅.

Lemma curry : forall P Q R:Prop, (P /\ Q -> R) <-> (P -> Q -> R).
Proof. move=>P Q R. split; tauto. Qed.

Theorem notnot : forall P, (~ (~P)) <-> P.
Proof.
  move=>P.
  split; last by tauto.
  by case: (classic P).
Qed.

Lemma sat_and st φ ψ: st |= (φ /\' ψ) <-> st|=φ /\ st|=ψ.
Proof.
  split.
  - rewrite /= -curry.
    fold (not (st |= φ /\ st |= ψ )).
    fold (not (not (st |= φ /\ st |= ψ ))).
    by rewrite notnot.
  - move=>[Hφ Hψ].
    simpl.
    by apply.
Qed.

Ltac cycle_one_step :=
  split_ands; try by [];
  rewrite sat_and;
  split; first by (
  simpl;
  move=>?;
  mrun (T.select (_ ∈ _) >>= inversion);
  [mrun (T.select (_ ∈ V0) >>= inversion)
  | mrun (T.select (_ ∈ p _) >>= inversion)]).

Ltac cycle_end :=
  split_ands; try by [];
  simpl;
  by apply Union_intror.

Definition R_cycle2 : relation nat := fun n m=>
  ((n == 0) && (m == 1)) ||
  ((n == 1) && (m == 2)) ||
  ((n == 2) && (m == 1)).

Example cycle2 : ⟨0, R_cycle2, V0⟩ |= ⬙ (delta 2).
Proof.
  pose R := R_cycle2.
  pose V1 := V0 ∪ p 1.
  exists ⟨1, R, V1⟩.
  split_ands; try by [].
  exists ⟨2, R, V1⟩.
  cycle_one_step.
  exists ⟨1, R, V1⟩.
  cycle_end.
Qed.

Definition R_cycle1 : relation nat := fun n m=>
  ((n == 0) && (m == 1)) ||
  ((n == 1) && (m == 1)).

Example cycle1 : ⟨0, R_cycle1, V0⟩ |= ⬙ (delta 1).
Proof.
  pose R := R_cycle1.
  pose V1 := V0 ∪ p 1.
  exists ⟨1, R, V1⟩.
  split_ands; try by [].
  exists ⟨1, R, V1⟩.
  cycle_end.
Qed.

Definition R_cycle4 : relation nat := fun n m=>
  ((n == 0) && (m == 1)) ||
  ((n == 1) && (m == 2)) ||
  ((n == 2) && (m == 2)) ||
  ((n == 2) && (m == 1)).

Example cycle4 : ⟨0, R_cycle4, V0⟩ |= ⬙ (delta 3).
Proof.
  pose R := R_cycle4.
  pose V1 := V0 ∪ p 1.
  exists ⟨1, R, V1⟩.
  split_ands; try by [].
  exists ⟨2, R, V1⟩.
  cycle_one_step.
  exists ⟨2, R, V1⟩.
  cycle_one_step.
  exists ⟨1, R, V1⟩.
  cycle_end.
Qed.

Definition Rcycle := fun n m=>
  ((n == 0) && (m == 0)).

Example cycle' : ⟨0, Rcycle, ∅⟩ |= ⬙ p∙.
Proof.
  exists ⟨0, Rcycle, V0 ∪ p 0⟩.
  cycle_end.
Qed.


Require Import PslBase.Base PslBase.Bijection PslBase.FiniteTypes.FinTypes.
Require Import Coq.Vectors.Fin.

Instance Fin_eq_dec n : eq_dec (Fin.t n).
Proof.
  intros; hnf.
  destruct (eqb x y) eqn:E.
  - left. now eapply eqb_eq.
  - right. intros H. eapply eqb_eq in H. congruence.
Defined.

Definition all_Fin n := nat_rec (fun n0 : nat => list (t n0)) [] (fun (n0 : nat) (IHn : list (t n0)) => F1 :: map FS IHn) n.

Lemma in_undup_iff (X: eqType) (A: list X) x : x el A <-> x el (undup A).
Proof.
  now rewrite undup_id_equi.
Qed.

(* (** * finTypes from Lists  *) *)
(* (* Conversion of lists over eqTypes to finite types *) *)
(* (* *) *)

(** * Pure predicates  *)
(* taken from the development of Herditarily finite sets by Prof. Smolka and Kathrin Stark. *)
(* *)

Definition pure (X:Type) (p: X -> Prop) {D:forall x, dec (p x)} x := if Dec (p x) then True else False.
Arguments pure {X} p {D} x.

Lemma pure_equiv  (X:Type) (p: X -> Prop) {D:forall x, dec (p x)} x : p x <-> pure p x.
Proof.
  unfold pure. now dec.
Qed.

Lemma pure_impure  (P: Prop) (_: dec P) (norm: if Dec (P) then True else False) : P.
Proof.
  dec; tauto.
Qed.
Ltac impurify H := pose proof (pure_impure H) as impureH; try (clear H; rename impureH into H).

Lemma purify (X: Type) (p: X -> Prop) (D:forall x, dec (p x)) x (px: p x): pure p x.
Proof.
  now  apply pure_equiv.
Qed.

Arguments purify {X} {p} {D} {x} px.

Lemma pure_eq (X: Type) (p: X -> Prop) (D: forall x, dec (p x)) x (p1 p2: pure p x) : p1 = p2.
Proof.
  unfold pure in *.  dec.
  + now destruct p1, p2.
  + contradiction p1.
Qed.

(* (** * Definition of subtypes *) *)

Definition subtype {X:Type} (p: X -> Prop) {D: forall x, dec (p x)} := { x:X | pure p x}.
Arguments subtype {X} p {D}.

Lemma subtype_extensionality (X: Type) (p: X -> Prop)  {D: forall x, dec (p x)} (x x': subtype p) : proj1_sig x = proj1_sig x' <-> x = x'.
Proof.
  split.
  - intros H. destruct x, x'. cbn in H. subst x0. f_equal. apply pure_eq.
  - congruence.
Qed.

Instance subType_eq_dec X (_:eq_dec X) (p: X -> Prop) (_: forall x, dec (p x)): eq_dec (subtype p).
Proof.
  intros y z. destruct y as [x p1], z as  [x' p2]. decide (x=x').
  - left.  now apply subtype_extensionality.
  - right. intro H. apply n. now inv H.
Qed.

(* Lemma proj1_sig_fun (X: eqType) (p: X -> Prop) (x x': X) (p1: p x) (p2: p x'): exist p x p1 = exist p x' p2 -> x = x'. *)
(* Proof. *)
(*   intro E. change x with (proj1_sig (exist p x p1)). change x' with (proj1_sig (exist p x' p2)). *)
(*   now inv E. *)
(* Qed. *)

(* (** * Subtypes from lists *) *)

(* Lemma in_undup_iff (X: eqType) (A: list X) x : x el A <-> x el (undup A). *)
(* Proof. *)
(*   now rewrite undup_id_equi. *)
(* Qed. *)

Fixpoint toSubList (X: Type) (A: list X) (p: X -> Prop) (D:forall x, dec (p x))  : list (subtype p) :=
  match A with
  | nil => nil
  | cons x A' => match Dec (p x) with
                | left px => (exist  _ x (purify px)) :: toSubList A' D
                | right _ => toSubList  A' _ end
  end.

Arguments toSubList {X} A p {D}.

Lemma toSubList_count (X: eqType) (p: X -> Prop) (A: list X) (_:forall x, dec (p x)) x:
  count (toSubList A p) x = count A (proj1_sig x).
Proof.
  induction A.
  - reflexivity.
  - cbn. decide (p a).
    + simpl. dec.
      * congruence.
      * now rewrite <- subtype_extensionality in e.
      * change a with (proj1_sig (exist (pure p) a (purify p0)))  in e. now rewrite subtype_extensionality in e.
      * exact IHA.
    + destruct x.  cbn. dec.
      * subst a. now impurify p0.
      * exact IHA.
Qed.

(* Lemma subType_enum_ok (X:finType) (p: X -> Prop) (_: forall x, dec (p x)) x: *)
(*   count (toSubList (elem X) p) x = 1. *)
(* Proof. *)
(*   rewrite toSubList_count. apply enum_ok. *)
(* Qed. *)

Notation "'Subtype' p"  := (finTypeC (EqType (subtype p))) (at level 5).

(* Instance finTypeC_sub (X:finType) (p: X -> Prop) (_:forall x, dec (p x)): Subtype p. *)
(* Proof. *)
(*   econstructor.  apply subType_enum_ok. *)
(* Defined. *)

(** * finTypes from Lists  *)
(* Conversion of lists over eqTypes to finite types *)
(* *)
Lemma enum_ok_fromList (X: eqType) (A: list X) x : count (undup (toSubList A (fun x => x el A))) x = 1.
Proof.
  apply dupfreeCount.
  - apply dupfree_undup.
  - rewrite <- in_undup_iff. apply countIn. cbn in *.
    rewrite toSubList_count.
    destruct x as [x p]. cbn. apply InCount. now impurify p.
Qed.

Instance fromListC (X: eqType) (A: list X) : Subtype (fun x => x el A).
Proof.
econstructor. intros [x p]. apply enum_ok_fromList.
Defined.

(* (* Canonical Structure finType_fromList (X: eqType) (A: list X) := FinType (EqSubType (fun x => x el A)). *) *)

(* (* Lemma finType_fromList_correct (X: eqType) (A: list X) : *) *)
(* (*   map (@proj1_sig _ _) (elem (finType_fromList A)) === A. *) *)
(* (* Proof. *) *)
(* (*   cbn. split. *) *)
(* (*   -  intros x H. destruct (in_map_iff (@proj1_sig _ _) (undup (toSubList A (fun x => x el A))) x) as [H0 _]. *) *)
(* (*      specialize (H0 H). destruct H0 as [[y p] [E _]]. cbn in *. subst y. now impurify p. *) *)
(* (*   - intros x H. apply in_map_iff. *) *)
(* (*     eexists. Unshelve. Focus 2. *) *)
(* (*     + exists x. unfold pure. now dec. *) *)
(* (*     + cbn. split; auto. apply countIn with (A:= undup (toSubList A _)). rewrite enum_ok_fromList. omega. *) *)
(* (* Qed. *) *)

(*   Definition finType_of := {x : X | x el A}. *)

(*   Lemma eqType_finType_of : eq_dec finType_of. *)
(*   Proof. *)
(*     eapply subType_eq_dec. *)

  (* Lemma enum_ok_fromList (X: eqType) (A: list X) x : count (undup (toSubList A (fun x => x el A))) x = 1. *)
  (* Proof. *)
  (*   apply dupfreeCount. *)
  (*   - apply dupfree_undup. *)
  (*   - rewrite <- in_undup. apply countIn. rewrite toSubList_count. *)
  (*     destruct x as [x p]. cbn. apply InCount. now impurify p. *)
  (* Qed. *)

(* Instance fromListC (X: eqType) (A: list X) : finTypeC (EqSubType (fun x => x el A)). *)
(* Proof. *)
(* econstructor. intros [x p]. apply enum_ok_fromList. *)
(* Defined. *)

(* Canonical Structure finType_fromList (X: eqType) (A: list X) := FinType (EqSubType (fun x => x el A)). *)

(* Lemma finType_fromList_correct (X: eqType) (A: list X) : *)
(*   map (@proj1_sig _ _) (elem (finType_fromList A)) === A. *)
(* Proof. *)
(*   cbn. split. *)
(*   -  intros x H. destruct (in_map_iff (@proj1_sig _ _) (undup (toSubList A (fun x => x el A))) x) as [H0 _]. *)
(*      specialize (H0 H). destruct H0 as [[y p] [E _]]. cbn in *. subst y. now impurify p. *)
(*   - intros x H. apply in_map_iff. *)
(*     eexists. Unshelve. Focus 2. *)
(*     + exists x. unfold pure. now dec. *)
(*     + cbn. split; auto. apply countIn with (A:= undup (toSubList A _)). rewrite enum_ok_fromList. omega. *)
(* Qed.  *)