(* Test des definitions inductives imbriquees *)

Require Import List.

Inductive X : Set :=
    cons1 : list X -> X.

Inductive Y : Set :=
    cons2 : list (Y * Y) -> Y.

(* Test inductive types with local definitions (arity) *)

Inductive eq1 : forall A:Type, let B:=A in A -> Prop :=
  refl1 : eq1 True I.

Check
 fun (P : forall A : Type, let B := A in A -> Type) (f : P True I) (A : Type) =>
   let B := A in
     fun (a : A) (e : eq1 A a) =>
       match e in (eq1 A0 B0 a0) return (P A0 a0) with
       | refl1 => f
       end.

Inductive eq2 (A:Type) (a:A)
  : forall B C:Type, let D:=(A*B*C)%type in D -> Prop :=
  refl2 : eq2 A a unit bool (a,tt,true).

(* Check inductive types with local definitions (parameters) *)

Inductive A (C D : Prop) (E:=C) (F:=D) (x y : E -> F) : E -> Set :=
    I : forall z : E, A C D x y z.

Check
  (fun C D : Prop =>
   let E := C in
   let F := D in
   fun (x y : E -> F) (P : forall c : C, A C D x y c -> Type)
     (f : forall z : C, P z (I C D x y z)) (y0 : C)
     (a : A C D x y y0) =>
   match a as a0 in (A _ _ _ _ _ _ y1) return (P y1 a0) with
   | I x0 => f x0
   end).

Record B (C D : Set) (E:=C) (F:=D) (x y : E -> F) : Set :=  {p : C; q : E}.

Check
  (fun C D : Set =>
   let E := C in
   let F := D in
   fun (x y : E -> F) (P : B C D x y -> Type)
     (f : forall p0 q0 : C, P (Build_B C D x y p0 q0))
     (b : B C D x y) =>
   match b as b0 return (P b0) with
   | Build_B x0 x1 => f x0 x1
   end).

(* Check inductive types with local definitions (constructors) *)

Inductive I1 : Set := C1 (_:I1) (_:=0).

Check (fun x:I1 =>
  match x with
  | C1 i n => (i,n)
  end).

(* Check implicit parameters of inductive types (submitted by Pierre
  Casteran and also implicit in #338) *)

Set Implicit Arguments.
Unset Strict Implicit.

CoInductive LList (A : Set) : Set :=
  | LNil : LList A
  | LCons : A -> LList A -> LList A.

Implicit Arguments LNil [A].

Inductive Finite (A : Set) : LList A -> Prop :=
  | Finite_LNil : Finite LNil
  | Finite_LCons :
      forall (a : A) (l : LList A), Finite l -> Finite (LCons a l).

(* Check positivity modulo reduction (cf bug #983) *)

Record P:Type := {PA:Set; PB:Set}.

Definition F (p:P) := (PA p) -> (PB p).

Inductive I_F:Set := c : (F (Build_P nat I_F)) -> I_F.


Set Implicit Arguments.
Require Import TLC.LibLN.
Require Import GFSubKernelUnionInter.

(*

RS is the declarative specification of subtyping, which
includes the built-in Sym rule.

*)

Inductive RS : env -> Mode -> typ -> typ -> Prop :=
| RSInt : forall m E, okt E -> RS E m typ_int typ_int
| RSTB1 : forall A m E, okt E -> wft E A -> RS E m A (mode_to_sub m)
| RSFun : forall A B C D m E, RS E (flip m) A C -> RS E m B D -> RS E m (typ_arrow A B) (typ_arrow C D)
| RSVarRefl : forall E X m, okt E -> wft E (typ_fvar X) -> RS E m (typ_fvar X) (typ_fvar X)
| RSVarBnd : forall E X m T F, binds X (bind_tRel m T) E -> RS E m T F -> RS E m (typ_fvar X) F
| RSAll : forall E L m1 m2 T1 T2 T3, wft E T1 ->
    ( forall X, X \notin L ->
                RS (E&(X !: m1 <>: T1)) m2 (T2 open_tt_var X) (T3 open_tt_var X)) ->
    RS E m2 (typ_all m1 T1 T2) (typ_all m1 T1 T3)
| RSLeft  : forall A B C E m, RS E m A C -> wft E B -> RS E m (choose m A B) C
| RSRight : forall A B C E m, RS E m B C -> wft E A -> RS E m (choose m A B) C
| RSBoth  : forall A B C E m, RS E m A B -> RS E m A C -> RS E m A (choose m B C)
| RSSym : forall m A B E, RS E (flip m) B A -> RS E m A B.

Hint Constructors RS.

Lemma flip_flip : forall m, flip (flip m) = m.
  destruct m; simpl; eauto.
Defined.

Lemma invSym : forall m A B E, RS E m A B -> RS E (flip m) B A.
  intros.
  rewrite <- (flip_flip m) in H.
  apply RSSym in H.
  auto.
Defined.

Lemma sound : forall m A B E, R E m A B -> RS E m A B.
  intros.
  induction H; eauto.
  - apply RSSym.
    apply RSSym in IHR.
    rewrite flip_flip. eauto.
  - apply RSSym.
    apply invSym in IHR.
    eauto.
  - apply RSSym.
    apply invSym in IHR.
    eauto.
  - apply RSSym.
    apply invSym in IHR1.
    apply invSym in IHR2.
    eauto.
Defined.

Lemma complete : forall m A B E, RS E m A B -> R E m A B.
  intros.
  induction H; eauto.
  - apply SVarBnd with (T := T); eauto.
  - apply SAll with (L := L); auto.
  - apply sym2.
    auto.
Defined.

(*

R2 an algorithmic version that exploits duality for economy
of code.

*)

Inductive R2 : env -> bool -> Mode -> typ -> typ -> Prop :=
| R2Int : forall b m E, okt E -> R2 E b m typ_int typ_int
| R2TB1 : forall b A m E, okt E -> wft E A -> R2 E b m A (mode_to_sub m)
| R2Fun : forall b A B C D m E,
    R2 E true (flip m) A C ->
    R2 E true m B D ->
    R2 E b m (typ_arrow A B) (typ_arrow C D)
| R2VarRefl : forall E X m b, okt E -> wft E (typ_fvar X) -> R2 E b m (typ_fvar X) (typ_fvar X)
| R2VarBnd : forall E X m T F b, binds X (bind_tRel m T) E -> R2 E true m T F -> R2 E b m (typ_fvar X) F
| R2All : forall E L m1 m2 T1 T2 T3 b, wft E T1 ->
    ( forall X, X \notin L ->
                R2 (E&(X !: m1 <>: T1)) true m2 (T2 open_tt_var X) (T3 open_tt_var X)) ->
    R2 E b m2 (typ_all m1 T1 T2) (typ_all m1 T1 T3)
| R2Left  : forall A B C E m b, R2 E true m A C -> wft E B -> R2 E b m (choose m A B) C
| R2Right : forall A B C E m b, R2 E true m B C -> wft E A -> R2 E b m (choose m A B) C
| R2Both  : forall A B C E m b, R2 E true m A B -> R2 E true m A C -> R2 E b m A (choose m B C)
| R2Sym : forall m A B E,
    R2 E false (flip m) B A -> R2 E true m A B.

Hint Constructors R2.

(* Soundness of R2 *)

Require Import Program.Equality.

Lemma R2_false : forall m A B E, R2 E false m A B -> R2 E true m A B.
  intros.
  dependent induction H; eauto.
Defined.

Lemma invR2 : forall b m A B E, R2 E b m A B -> R2 E true (flip m) B A.
  intros.
  induction H; eauto.
  - apply R2Sym. rewrite flip_flip. eauto.
  - apply R2Sym. rewrite flip_flip. eauto.
  - apply R2Sym. rewrite flip_flip. eauto.
  - apply R2Sym. rewrite flip_flip. eauto.
  - apply R2Sym. rewrite flip_flip. eauto.
  - apply R2_false. auto.
Defined.

Lemma completeR : forall m A B E, R E m A B -> R2 E true m A B.
  intros.
  induction H; eauto.
  - apply invR2 in IHR.
    apply R2Sym.
    rewrite flip_flip in *.
    eauto.
  - apply R2Sym.
    apply R2Left.
    apply (@invR2 true).
    auto. auto.
  - apply R2Sym.
    apply R2Right.
    apply (@invR2 true).
    auto. auto.
  - apply R2Sym.
    apply R2Both.
    apply (@invR2 true).
    auto.
    apply (@invR2 true).
    auto.
Defined.

Lemma soundR : forall m b A B E, R2 E b m A B -> R E m A B.
  intros.
  induction H; eauto.
  - apply SVarBnd with (T := T); eauto.
  - apply SAll with (L := L); auto.
  - apply sym2. auto.
Defined.


From RL Require Export TraceThm.

From Coq Require Import
     QArith
     Psatz
     Lia
     Lqa
     List.

From ITree Require Import
     ITree
     ITreeFacts
     Traces.

Import ListNotations.
Import ITreeNotations.
Import MonadNotation.
Open Scope monad_scope.

Definition EnvF A B := (A -> B -> A).

Definition inductive_invariant {S A: Type} (phi: S -> Prop) (env: EnvF S A) :=
  forall (s: S) (a: A) (s': S), phi s -> env s a = s' -> phi s'.

Definition safe {S A: Type} (env: itree rlE unit) (init: S -> Prop) (phi: S -> Prop):= forall (tr: @trace rlE unit),
    @state_trace S actionE tr ->
    @trace_init S A init tr ->
    @trace_end S A phi tr ->
    not (is_trace env tr).

(* The safety proof := iv + init -> iv -> not phi. *)

Inductive safety_package {S A: Type} : (EnvF S A) -> (S -> Prop) -> (S -> Prop) -> (S -> Prop) -> Prop :=
| SafetyPackage: forall (envf:EnvF S A) (init phi iv: S -> Prop),
    inductive_invariant iv envf ->
    (forall s: S, (init s -> iv s) /\ (iv s -> not (phi s))) ->
    safety_package envf init phi iv.

(* A safety package can rebuild a proof. *)

Definition auto_safety_proof {S A: Type} (envf: EnvF S A) (init: S -> Prop) (phi: S -> Prop) (iv: S -> Prop):
           safety_package envf init phi iv -> safe (env_generator envf) init phi.
Proof.
  assert (safety_package envf init phi iv -> safe (env_generator envf) iv phi).
  {
  intros.
  inversion H; subst. clear H.
  unfold safe, env_generator. intros.
  unfold not. intros.
  apply env_trace_is_step_trace in H4.
  induction H4; try inv_trace_end; try inv_trace_init.
  - remember (H1 s). clear Heqa1. destruct a1. clear H3.
    apply (H0 s a (f s a)) in H5; auto.
    remember (H1 (f s a)). clear Heqa1. destruct a1.
    apply H4; auto.
  - apply IHstep_trace; auto.
    + do 3 (apply decrease_state_trace in H). auto.
    + assert (iv (f s a)).
      destruct (H1 s). apply H0 with s a; auto.
      do 2 (apply decrease_state_trace in H).
      inv_dep H; try inv_trace_end; auto.
      * constructor; auto.
      * inversion H4.
      * inversion H4.
  }
  intros.
  inversion H0; subst.
  clear H1.
  apply H in H0. clear H.
  unfold safe. unfold safe in H0.
  intros.
  apply H0; auto.
  clear H0. clear H. clear H3.
  induction H1.
  - constructor. destruct (H2 s). auto.
Qed.

(* Mountain Car *)

Definition StateT := prod Q Q.

Inductive ActionT : Type :=
| Left
| NoAction
| Right.

Definition force := 1#1000.
Definition gravity := 3#1000.

(* approximate cos in Q *)
Definition cos (x: Q) :=
  1 - (x^2)/(2#1) + (x^4)/(24#1) - (x^6)/(720#1).

(* ref: https://github.com/openai/gym/blob/master/gym/envs/classic_control/mountain_car.py#L44 *)
Definition mountaincar_env_body : EnvF StateT ActionT :=
  fun state action =>
    let acc :=
        match action with
        | Left => - force
        | NoAction => 0
        | Right => force
        end in
    match state with
    | (pos, vel) =>
      let acc' := acc + cos((3#1) * pos) * (-gravity) in
      let vel' := vel + acc' in
      let pos' := pos + vel' in
      (pos', vel')
    end.

Definition mountaincar_env : itree rlE unit := env_generator mountaincar_env_body.

Definition mc_phi (s: StateT) :=
  let (pos, vel) := s in pos <= -(1#1).

Definition mc_init (s: StateT) :=
  let (pos, vel) := s in pos >= -(3#5) /\ pos <= -(2#5) /\ vel = 0.

Definition mc_potential (s: StateT) : Q:=
  let (pos, vel) := s in
  if Qle_bool vel 0
  then pos - (vel * vel) / (2#1) / (force + gravity)
  else pos.

Definition mc_iv := fun s => mc_potential s > -1#1.

Lemma mc_inductive_invariant : inductive_invariant mc_iv mountaincar_env_body.
Proof.
Admitted.

Lemma mc_P1: forall s, (mc_init s -> mc_iv s) /\ (mc_iv s -> not (mc_phi s)).
Proof.
  unfold mc_init, mc_iv, mc_potential, mc_phi. intros. destruct s. split.
  - intros. destruct H. destruct H0. subst. cbn. unfold force. unfold gravity. admit.
  - intros. admit.
Admitted.

Definition mc_safe: safety_package mountaincar_env_body mc_init mc_phi mc_iv.
Proof.
  constructor.
  apply mc_inductive_invariant. apply mc_P1.
Qed.
(* road *)

Definition StateT1 := prod Q Q.

Inductive ActionT1 : Type :=
| Forward
| Backward.

Definition road_init (s: StateT1) :=
  let (pos, vel) := s in pos <= -(2#5) /\ pos >= -(3#5) /\ vel = 0.

Definition road_phi (s: StateT1) :=
  let (pos, vel) := s in pos <= -(1#1).

Definition road_env_body : EnvF StateT1 ActionT1 :=
  fun state action =>
    let acc :=
        match action with
        | Forward => - force
        | Backward => force
        end in
    match state with
    | (pos, vel) =>
      let vel' := vel + acc in
      let pos' := pos + vel' in
      (pos', vel')
    end.

Definition road_env : itree rlE unit := env_generator road_env_body.

Definition road_potential (s: StateT1) : Q:=
  match s with
  | (pos, vel) => if Qle_bool vel 0 then pos - (vel * vel) / (2#1) / force else pos
  end.

Definition road_iv (s: StateT1) := road_potential s > -1#1.

Lemma road_inductive_invariant : inductive_invariant road_iv road_env_body.
Proof.
Admitted.

Lemma road_P1: forall s, (road_init s -> road_iv s) /\ (road_iv s -> not (road_phi s)).
Proof.
  unfold road_init, road_iv, road_potential, road_phi. intros. destruct s. split.
  - intros. destruct H. destruct H0.
Admitted.

Definition road_safe: safety_package road_env_body road_init road_phi road_iv.
Proof.
  constructor.
  apply road_inductive_invariant. apply road_P1.
Qed.

(* Two Dimension Road *)

Definition StateT2 := prod (prod Q Q) (prod Q Q).

Inductive ActionT2 : Type :=
| GoLeft
| GoRight
| GoNoAction
| GoForward
| GoBackward.

Definition twoDroad_env_body : EnvF StateT2 ActionT2 :=
  fun state action =>
    let (acc1, acc2) :=
        match action with
        | GoLeft => (0, -force)
        | GoRight => (0, force)
        | GoNoAction => (0, 0)
        | GoForward => (force, 0)
        | GoBackward => (-force, 0)
        end in
    match state with
      | ((pos1, vel1), (pos2, vel2)) =>
      let vel1' := vel1 + acc1 in
      let pos1' := pos1 + vel1' in
      let vel2' := vel2 + acc2 in
      let pos2' := pos2 + vel2' in
       ((pos1', vel1'), (pos2', vel2'))
    end.

Definition twoDroad_env : itree rlE unit := env_generator twoDroad_env_body.

Definition twoDroad_init (s: StateT2) :=
  match s with
  | (_, (pos2, vel2)) => pos2 <= -(2#5) /\ pos2 >= -(3#5) /\ vel2 = 0
  end.

Definition twoDroad_phi (s: StateT2) :=
  match s with
  | (_, (pos2, vel2)) => pos2 > -(1#1)
  end.

Definition twoDroad_iv (s: StateT2) :=
  match s with
  | (_, s) => road_potential s > -1#1
  end.

Definition twoDroad_safe: safe twoDroad_env twoDroad_init twoDroad_phi.
Proof. Admitted.

(* Refine relatoin *)

Definition state_map (s: StateT) : StateT1 :=
  let (pos, vel) := s in (pos, (1#2)*vel).

(* Is not required to be a injection *)

Definition action_map (a : ActionT) : ActionT1 :=
  match a with
  | Left => Forward
  | NoAction => Backward
  | Right => Backward
  end.

(* Intuitive definition of refinement *)

(* env2 refines env1: *)
Definition env_refine {S1 S2 A1 A2: Type}
           (env1: itree rlE unit) (env2: itree rlE unit)
           (init1: S1 -> Prop) (init2: S2 -> Prop)
           (phi1: S1 -> Prop) (phi2: S2 -> Prop) :=
  @safe S2 A2 env2 init2 phi2 -> @safe S1 A1 env1 init1 phi1.

(* Refinement should be a relation between two package. *)

Definition package_refine {S1 S2 A1 A2: Type}
           (env1: EnvF S1 A1) (env2: EnvF S2 A2)
           (init1: S1 -> Prop) (init2: S2 -> Prop)
           (phi1: S1 -> Prop) (phi2: S2 -> Prop)
           (iv1: S1 -> Prop) (iv2: S2 -> Prop):=
  @safety_package S2 A2 env2 init2 phi2 iv2 -> @safety_package S1 A1 env1 init1 phi1 iv1.

Definition envf_refine {S1 S2 A1 A2: Type}
           (smap: S1 -> S2) (amap: A1 -> A2)
           (env1: EnvF S1 A1) (env2: EnvF S2 A2)
           (init1: S1 -> Prop) (init2: S2 -> Prop)
           (phi1: S1 -> Prop) (phi2: S2 -> Prop)
           (iv1: S1 -> Prop) (iv2: S2 -> Prop) :=
  (forall s, (phi1 s -> phi2 (smap s)) /\ (init1 s -> init2 (smap s)) /\ (iv2 (smap s) <-> iv1 s)) /\
  (forall (s s': S1) (a: A1), ((iv2 (smap s) -> env2 (smap s) (amap a) = (smap s') -> iv2 (smap s')) ->
    (iv1 s -> env1 s a = s' -> iv1 s'))).

Lemma envf_refine_to_env_refine {S1 S2 A1 A2: Type} :
  forall (envf1: EnvF S1 A1) (envf2: EnvF S2 A2)
    (init1: S1 -> Prop) (init2: S2 -> Prop)
    (phi1: S1 -> Prop) (phi2: S2 -> Prop)
    (iv1: S1 -> Prop) (iv2: S2 -> Prop)
    (smap: S1 -> S2) (amap: A1 -> A2),
        envf_refine smap amap envf1 envf2 init1 init2 phi1 phi2 iv1 iv2 ->
    package_refine envf1 envf2 init1 init2 phi1 phi2 iv1 iv2.
Proof.
  intros.
  unfold package_refine. intros.
  inversion H0; subst. clear H0.
  unfold envf_refine in H.
  destruct H.
  constructor.
  - unfold inductive_invariant. intros s a s'. apply H0. apply H1.
  - intros. remember (H2 (smap s)). clear H2 Heqa. destruct a. remember (H s). clear H Heqa.
    destruct a. destruct H4.
    split.
    + intros. rewrite <- H5. auto.
    + unfold not. intros. apply H3. rewrite H5. auto. auto.
Qed.

Lemma envf_refine_example: envf_refine
                             state_map action_map
                             mountaincar_env_body road_env_body
                             mc_init road_init
                             mc_phi road_phi
                             mc_iv road_iv.
Proof.
  unfold envf_refine.
  split; intros.
  - split.
    + unfold mc_phi, road_phi, state_map. destruct s. nra.
    + split.
      * unfold mc_init, road_init, state_map. destruct s. intros. destruct H. destruct H0.
        split; auto. split; auto. subst. admit.
      * unfold road_iv, state_map, mc_iv. destruct s. unfold road_potential, mc_potential. remember (Qle_bool q0 0) as HB.
        destruct HB. assert (true = Qle_bool ((1 # 2) * q0) 0). admit. rewrite <- H. admit.
        assert (false = Qle_bool ((1 # 2) * q0) 0). admit. rewrite <- H. reflexivity.
  - destruct s, s'. unfold action_map; destruct a.
    unfold mc_init, road_init, state_map, action_map in H.
    unfold road_env_body in H.
    unfold mountaincar_env_body in H1.
    inversion H1. clear H1. subst.
    unfold road_iv, road_potential in H.
Admitted.

(* Bad refine relation *)

(* Map a small domain to a large co-domain: check if it is a surjection *)

(* state_map2 is not a surjection *)
Definition state_map2 (s: StateT) : StateT2 := ((0, 0), s).

Definition action_map2 (a : ActionT) : ActionT2 :=
  match a with
  | Left => GoLeft
  | NoAction => GoNoAction
  | Right => GoRight
  end.


Theorem imp: forall (P Q : Prop),
  forall (_:P), Q <-> (P -> Q).
Proof.
  intros.
  split.
  intros. apply H0.
  intros. apply H0. apply H.
Qed.

Theorem imp': forall (P Q : Prop),
  forall (_:P), Q <-> (P -> Q).
Proof.
  tauto.
Qed.

(** omega *)


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export lemma__NCdistinct.
Require Export lemma__collinearorder.
Require Export lemma__collinearparallel.
Require Export lemma__extension.
Require Export lemma__inequalitysymmetric.
Require Export lemma__parallelsymmetric.
Require Export logic.
Require Export proposition__28A.
Definition proposition__28D : forall B D E G H, (euclidean__axioms.BetS E G H) -> ((euclidean__defs.CongA E G B G H D) -> ((euclidean__defs.OS B D G H) -> (euclidean__defs.Par G B H D))).
Proof.
intro B.
intro D.
intro E.
intro G.
intro H.
intro H0.
intro H1.
intro H2.
assert (* Cut *) (euclidean__axioms.nCol G H B) as H3.
- assert (exists X U V, (euclidean__axioms.Col G H U) /\ ((euclidean__axioms.Col G H V) /\ ((euclidean__axioms.BetS B U X) /\ ((euclidean__axioms.BetS D V X) /\ ((euclidean__axioms.nCol G H B) /\ (euclidean__axioms.nCol G H D)))))) as H3 by exact H2.
assert (exists X U V, (euclidean__axioms.Col G H U) /\ ((euclidean__axioms.Col G H V) /\ ((euclidean__axioms.BetS B U X) /\ ((euclidean__axioms.BetS D V X) /\ ((euclidean__axioms.nCol G H B) /\ (euclidean__axioms.nCol G H D)))))) as __TmpHyp by exact H3.
destruct __TmpHyp as [x H4].
destruct H4 as [x0 H5].
destruct H5 as [x1 H6].
destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
exact H15.
- assert (* Cut *) (euclidean__axioms.nCol G H D) as H4.
-- assert (exists X U V, (euclidean__axioms.Col G H U) /\ ((euclidean__axioms.Col G H V) /\ ((euclidean__axioms.BetS B U X) /\ ((euclidean__axioms.BetS D V X) /\ ((euclidean__axioms.nCol G H B) /\ (euclidean__axioms.nCol G H D)))))) as H4 by exact H2.
assert (exists X U V, (euclidean__axioms.Col G H U) /\ ((euclidean__axioms.Col G H V) /\ ((euclidean__axioms.BetS B U X) /\ ((euclidean__axioms.BetS D V X) /\ ((euclidean__axioms.nCol G H B) /\ (euclidean__axioms.nCol G H D)))))) as __TmpHyp by exact H4.
destruct __TmpHyp as [x H5].
destruct H5 as [x0 H6].
destruct H6 as [x1 H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
exact H17.
-- assert (* Cut *) (euclidean__axioms.neq H D) as H5.
--- assert (* Cut *) ((euclidean__axioms.neq G H) /\ ((euclidean__axioms.neq H D) /\ ((euclidean__axioms.neq G D) /\ ((euclidean__axioms.neq H G) /\ ((euclidean__axioms.neq D H) /\ (euclidean__axioms.neq D G)))))) as H5.
---- apply (@lemma__NCdistinct.lemma__NCdistinct G H D H4).
---- destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
exact H8.
--- assert (* Cut *) (euclidean__axioms.neq D H) as H6.
---- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric H D H5).
---- assert (* Cut *) (euclidean__axioms.neq G B) as H7.
----- assert (* Cut *) ((euclidean__axioms.neq G H) /\ ((euclidean__axioms.neq H B) /\ ((euclidean__axioms.neq G B) /\ ((euclidean__axioms.neq H G) /\ ((euclidean__axioms.neq B H) /\ (euclidean__axioms.neq B G)))))) as H7.
------ apply (@lemma__NCdistinct.lemma__NCdistinct G H B H3).
------ destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
exact H12.
----- assert (* Cut *) (euclidean__axioms.neq B G) as H8.
------ apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric G B H7).
------ assert (* Cut *) (exists A, (euclidean__axioms.BetS B G A) /\ (euclidean__axioms.Cong G A G B)) as H9.
------- apply (@lemma__extension.lemma__extension B G G B H8 H7).
------- destruct H9 as [A H10].
destruct H10 as [H11 H12].
assert (* Cut *) (euclidean__axioms.BetS A G B) as H13.
-------- apply (@euclidean__axioms.axiom__betweennesssymmetry B G A H11).
-------- assert (* Cut *) (exists C, (euclidean__axioms.BetS D H C) /\ (euclidean__axioms.Cong H C H D)) as H14.
--------- apply (@lemma__extension.lemma__extension D H H D H6 H5).
--------- destruct H14 as [C H15].
destruct H15 as [H16 H17].
assert (* Cut *) (euclidean__axioms.BetS C H D) as H18.
---------- apply (@euclidean__axioms.axiom__betweennesssymmetry D H C H16).
---------- assert (* Cut *) (euclidean__defs.Par A B C D) as H19.
----------- apply (@proposition__28A.proposition__28A A B C D E G H H13 H18 H0 H1 H2).
----------- assert (* Cut *) (euclidean__axioms.Col D H C) as H20.
------------ right.
right.
right.
right.
left.
exact H16.
------------ assert (* Cut *) (euclidean__axioms.Col C D H) as H21.
------------- assert (* Cut *) ((euclidean__axioms.Col H D C) /\ ((euclidean__axioms.Col H C D) /\ ((euclidean__axioms.Col C D H) /\ ((euclidean__axioms.Col D C H) /\ (euclidean__axioms.Col C H D))))) as H21.
-------------- apply (@lemma__collinearorder.lemma__collinearorder D H C H20).
-------------- destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
exact H26.
------------- assert (* Cut *) (euclidean__axioms.neq H D) as H22.
-------------- assert (* Cut *) ((euclidean__axioms.neq G H) /\ ((euclidean__axioms.neq H D) /\ ((euclidean__axioms.neq G D) /\ ((euclidean__axioms.neq H G) /\ ((euclidean__axioms.neq D H) /\ (euclidean__axioms.neq D G)))))) as H22.
--------------- apply (@lemma__NCdistinct.lemma__NCdistinct G H D H4).
--------------- destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
exact H5.
-------------- assert (* Cut *) (euclidean__defs.Par A B H D) as H23.
--------------- apply (@lemma__collinearparallel.lemma__collinearparallel A B H C D H19 H21 H22).
--------------- assert (* Cut *) (euclidean__defs.Par H D A B) as H24.
---------------- apply (@lemma__parallelsymmetric.lemma__parallelsymmetric A B H D H23).
---------------- assert (* Cut *) (euclidean__axioms.Col B G A) as H25.
----------------- right.
right.
right.
right.
left.
exact H11.
----------------- assert (* Cut *) (euclidean__axioms.Col A B G) as H26.
------------------ assert (* Cut *) ((euclidean__axioms.Col G B A) /\ ((euclidean__axioms.Col G A B) /\ ((euclidean__axioms.Col A B G) /\ ((euclidean__axioms.Col B A G) /\ (euclidean__axioms.Col A G B))))) as H26.
------------------- apply (@lemma__collinearorder.lemma__collinearorder B G A H25).
------------------- destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
exact H31.
------------------ assert (* Cut *) (euclidean__defs.Par H D G B) as H27.
------------------- apply (@lemma__collinearparallel.lemma__collinearparallel H D G A B H24 H26 H7).
------------------- assert (* Cut *) (euclidean__defs.Par G B H D) as H28.
-------------------- apply (@lemma__parallelsymmetric.lemma__parallelsymmetric H D G B H27).
-------------------- exact H28.
Qed.


Require Import LogRelFI.PseudoType.

Require Coq.Arith.PeanoNat.
Require Import Coq.Bool.Bool.

Module B := Coq.Init.Datatypes.

Require Import RecTypes.Contraction.

Require Import Coq.micromega.Lia.

Inductive SimplePContr : PTy → Prop :=
  | SimpContrPUnit : SimplePContr ptunit
  | SimpContrPBool : SimplePContr ptbool
  | SimpContrPArrow {τ τ'} : SimplePContr τ → SimplePContr τ' → SimplePContr (ptarr τ τ')
  | SimpContrPSum {τ τ'} : SimplePContr τ → SimplePContr τ' → SimplePContr (ptsum τ τ')
  | SimpContrPProd {τ τ'} : SimplePContr τ → SimplePContr τ' → SimplePContr (ptprod τ τ')
  | SimpContrPEmulDV {n p τ} : SimpleContr τ → SimplePContr (pEmulDV n p τ).


(** A nominal representation of STLC terms.

    This version looks a lot like we expect a representation of
    the lambda calculus to look like. Unlike the LN version,
    the syntax does not distinguish between bound and free
    variables and abstractions include the name of binding
    variables.  *)

(*************************************************************)
(** * Imports                                                *)
(*************************************************************)

(** Some of our proofs are by induction on the *size* of
    terms. We'll use Coq's [omega] tactic to easily dispatch
    reasoning about natural numbers. *)
Require Export Omega.

(** We will use the [atom] type from the metatheory library to
    represent variable names. *)
Require Export Metalib.Metatheory.

(** Although we are not using LNgen, some of the tactics from
    its library are useful for automating reasoning about
    names (i.e. atoms).  *)
Require Export Metalib.LibLNgen.

(** Some fresh atoms *)
Notation X := (fresh nil).
Notation Y := (fresh (X :: nil)).
Notation Z := (fresh (X :: Y :: nil)).

Lemma YneX : Y <> X.
Proof.
  pose proof Atom.fresh_not_in (X :: nil) as H.
  apply elim_not_In_cons in H.
  auto.
Qed.

(*************************************************************)
(** * A nominal representation of terms                      *)
(*************************************************************)

Inductive n_exp : Set :=
 | n_var (x:atom)
 | n_abs (x:atom) (t:n_exp)
 | n_app (t1:n_exp) (t2:n_exp).

(** For example, we can encode the expression [(\X.Y X)] as below.  *)

Definition demo_rep1 := n_abs X (n_app (n_var Y) (n_var X)).

(** For example, we can encode the expression [(\Z.Y Z)] as below.  *)

Definition demo_rep2 := n_abs Z (n_app (n_var Y) (n_var Z)).

(** As usual, the free variable function needs to remove the
    bound variable in the [n_abs] case. *)
Fixpoint fv_nom (n : n_exp) : atoms :=
  match n with
  | n_var x => {{x}}
  | n_abs x n => remove x (fv_nom n)
  | n_app t1 t2 => fv_nom t1 `union` fv_nom t2
  end.

(** The tactics for reasoning about lists and sets of atoms are useful here
    too. *)

Example fv_nom_rep1 : fv_nom demo_rep1 [=] {{ Y }}.
Proof.
  pose proof YneX.
  simpl.
  fsetdec.
Qed.

(** What makes this a *nominal* representation is that our
    operations are based on the following swapping function for
    names.  Note that this operation is symmetric: [x] becomes
    [y] and [y] becomes [x]. *)

Definition swap_var (x:atom) (y:atom) (z:atom) :=
  if (z == x) then y else if (z == y) then x else z.

(** The main insight of nominal representations is that we can
    rename variables, without capture, using a simple
    structural induction. Note how in the [n_abs] case we swap
    all variables, both bound and free.

    For example:

      (swap x y) (\z. (x y)) = \z. (y x))

      (swap x y) (\x. x) = \y.y

      (swap x y) (\y. x) = \x.y

*)
Fixpoint swap (x:atom) (y:atom) (t:n_exp) : n_exp :=
  match t with
  | n_var z     => n_var (swap_var x y z)
  | n_abs z t1  => n_abs (swap_var x y z) (swap x y t1)
  | n_app t1 t2 => n_app (swap x y t1) (swap x y t2)
  end.

(** Because swapping is a simple, structurally recursive
    function, it is highly automatable using the [default_simp]
    tactic from LNgen library.

    This tactic "simplifies" goals using a combination of
    common proof steps, including case analysis of all disjoint
    sums in the goal. Because atom equality returns a sumbool,
    this makes this tactic useful for reasoning by cases about
    atoms.

    For more information about the [default_simp] tactic, see
    [metalib/LibDefaultSimp.v].

    WARNING: this tactic is not always safe. It's a power tool
    and can put your proof in an irrecoverable state. *)

Example swap1 : forall x y z, x <> z -> y <> z ->
    swap x y (n_abs z (n_app (n_var x)(n_var y))) = n_abs z (n_app (n_var y) (n_var x)).
Proof.
  intros. simpl; unfold swap_var; default_simp.
Qed.

Example swap2 : forall x y, x <> y ->
    swap x y (n_abs x (n_var x)) = n_abs y (n_var y).
Proof.
  intros. simpl; unfold swap_var; default_simp.
Qed.

Example swap3 : forall x y, x <> y ->
     swap x y (n_abs y (n_var x)) = n_abs x (n_var y).
Proof.
  intros. simpl; unfold swap_var; default_simp.
Qed.

(** We define the "alpha-equivalence" relation that declares
    when two nominal terms are equivalent (up to renaming of
    bound variables).

    Note the two different rules for [n_abs]: either the
    binders are the same and we can directly compare the
    bodies, or the binders differ, but we can swap one side to
    make it look like the other.  *)

Inductive aeq : n_exp -> n_exp -> Prop :=
 | aeq_var : forall x,
     aeq (n_var x) (n_var x)
 | aeq_abs_same : forall x t1 t2,
     aeq t1 t2 -> aeq (n_abs x t1) (n_abs x t2)
 | aeq_abs_diff : forall x y t1 t2,
     x <> y ->
     x `notin` fv_nom t2 ->
     aeq t1 (swap y x t2) ->
     aeq (n_abs x t1) (n_abs y t2)
 | aeq_app : forall t1 t2 t1' t2',
     aeq t1 t1' -> aeq t2 t2' ->
     aeq (n_app t1 t2) (n_app t1' t2').

Hint Constructors aeq.

Example aeq1 : forall x y, x <> y -> aeq (n_abs x (n_var x)) (n_abs y (n_var y)).
Proof.
  intros.
  eapply aeq_abs_diff; auto.
  simpl; unfold swap_var; default_simp.
Qed.

Lemma aeq_refl : forall n, aeq n n.
Proof.
  induction n; auto.
Qed.

(*************************************************************)
(** ** Properties about swapping                             *)
(*************************************************************)

(** Now let's look at some simple properties of swapping. *)

Lemma swap_id : forall n x,
    swap x x n = n.
Proof.
  induction n; simpl; unfold swap_var;  default_simp.
Qed.

(** Demo: We will need the next two properties later in the tutorial,
    so we show that even though there are many cases to consider,
    [default_simp] can find these proofs. *)

Lemma fv_nom_swap : forall z y n,
  z `notin` fv_nom n ->
  y `notin` fv_nom (swap y z n).
Proof.
  (* WORKED IN CLASS *)
  induction n; intros; simpl; unfold swap_var; default_simp.
Qed.
Lemma shuffle_swap : forall w y n z,
    w <> z -> y <> z ->
    (swap w y (swap y z n)) = (swap w z (swap w y n)).
Proof.
  (* WORKED IN CLASS *)
  induction n; intros; simpl; unfold swap_var; default_simp.
Qed.
(*************************************************************)
(** ** Exercises                                             *)
(*************************************************************)

(** *** Recommended Exercise: [swap] properties

    Prove the following properties about swapping, either
    explicitly (by destructing [x == y]) or automatically
    (using [default_simp]).  *)

Lemma swap_symmetric : forall t x y,
    swap x y t = swap y x t.
Proof.
  (* FILL IN HERE *) Admitted.

Lemma swap_involutive : forall t x y,
    swap x y (swap x y t) = t.
Proof.
  (* FILL IN HERE *) Admitted.

(** *** Challenge exercises: equivariance

    Equivariance is the property that all functions and
    relations are preserved under swapping.  Show that this
    holds for the various functions and relations below.

    (Hint: [default_simp] will be slow and sometimes
    ineffective on *some* of these properties. If it puts
    you in an dead-end state, you'll need to prove the
    lemm another way. *)

Lemma swap_var_equivariance : forall v x y z w,
    swap_var x y (swap_var z w v) =
    swap_var (swap_var x y z) (swap_var x y w) (swap_var x y v).
Proof.
  (* FILL IN HERE *) Admitted.

Lemma swap_equivariance : forall t x y z w,
    swap x y (swap z w t) = swap (swap_var x y z) (swap_var x y w) (swap x y t).
Proof.
  (* FILL IN HERE *) Admitted.

Lemma notin_fv_nom_equivariance : forall x0 x y t ,
  x0 `notin` fv_nom t ->
  swap_var x y x0  `notin` fv_nom (swap x y t).
Proof.
  (* FILL IN HERE *) Admitted.

(* HINT: For a helpful fact about sets of atoms, check AtomSetImpl.union_1 *)

Lemma in_fv_nom_equivariance : forall x y x0 t,
  x0 `in` fv_nom t ->
  swap_var x y x0 `in` fv_nom (swap x y t).
Proof.
  (* FILL IN HERE *) Admitted.

(*************************************************************)
(** * An abstract machine for cbn evaluation                 *)
(*************************************************************)

(** The advantage of named terms is an efficient operational
    semantics! Compared to LN or de Bruijn representation, we
    don't need always need to modify terms (such as via open or
    shifting) as we traverse binders. Instead, as long as the
    binder is "sufficiently fresh" we can use the name as is,
    and only rename (via swapping) when absolutely
    necessary. *)

(** Below, we define an operational semantics based on an
    abstract machine. As before, it will model execution as a
    sequence of small-step transitions. However, transition
    will be between _machine configurations_, not just
    expressions.

    Our abstract machine configurations have three components

    - the current expression being evaluated the heap (aka
    - environment): a mapping between variables and expressions
    - the stack: the evaluation context of the current
    - expression

    Because we have a heap, we don't need to use substitution
    to define our semantics. To implement [x ~> e] we add a
    definition that [x] maps to [e] in the heap and then look
    up the definition when we get to [x] during evaluation.  *)

Definition heap := list (atom * n_exp).

Inductive frame : Set := | n_app2 : n_exp -> frame.
Notation  stack := (list frame).

Definition configuration := (heap * n_exp * stack)%type.

(** The (small-step) semantics is a _function_ from
    configurations to configurations, until completion or
    error. *)

Inductive Step a := Error    : Step a
                  | Done     : Step a
                  | TakeStep : a -> Step a.

Definition isVal (t : n_exp) :=
  match t with
  | n_abs _ _ => true
  | _         => false
  end.

Definition machine_step (avoid : atoms) (c : configuration) : Step configuration :=
  match c with
    (h, t, s) =>
    if isVal t then
      match s with
      | nil => Done _
      | n_app2 t2 :: s' =>
        match t with
        | n_abs x t1 =>
          (* if the bound name [x] is not fresh, we need to rename it *)
          if AtomSetProperties.In_dec x avoid  then
            let (y,_) := atom_fresh avoid in
             TakeStep _ ((y,t2)::h, swap x y t1, s')
          else
            TakeStep _ ((x,t2)::h, t1, s')
        | _ => Error _ (* non-function applied to argument *)
        end
      end
    else match t with
         | n_var x => match get x h with
                     | Some t1 => TakeStep _ (h, t1, s)
                     | None    => Error _ (* Unbound variable *)
                     end
         | n_app t1 t2 => TakeStep _ (h, t1, n_app2 t2 :: s)
         | _ => Error _ (* unreachable (value in nonValueStep) *)
         end
  end.

Definition initconf (t : n_exp) : configuration := (nil,t,nil).

(** Example: evaluation of  "(\y. (\x. x) y) 3"

<<
     machine                                       corresponding term

      {}, (\y. (\x. x) y) 3, nil                   (\y. (\x. x) y) 3
  ==> {}, (\y. (\x. x) y), n_app2 3 :: nil         (\y. (\x. x) y) 3
  ==> {y -> 3}, (\x.x) y, nil                      (\x. x) 3
  ==> {y -> 3}, (\x.x), n_app2 y :: nil            (\x. x) 3
  ==> {x -> y, y -> 3}, x, nil                     3
  ==> {x -> y, y -> 3}, y, nil                     3
  ==> {x -> y, y -> 3}, 3, nil                     3
  ==> Done
>>

(Note that the machine takes extra steps compared to the
substitution semantics.)

We will prove that this machine implements the substitution
semantics in the next section.

*)

(** ** Recommended Exercise [values_are_done]

    Show that values don't step using this abstract machine.
    (This is a simple proof.)
*)

Lemma values_are_done : forall D t,
    isVal t = true -> machine_step D (initconf t) = Done _.
Proof.
(* FILL IN HERE *) Admitted.

(*************************************************************)
(** * Size based reasoning                                   *)
(*************************************************************)

(** Some properties about nominal terms require calling the
    induction hypothesis not on a direct subterm, but on one
    that has first had a swapping applied to it.

    However, swapping names does not change the size of terms,
    so that means we can prove such properties by induction on
    that size.  *)

Fixpoint size (t : n_exp) : nat :=
  match t with
  | n_var x => 1
  | n_abs x t => 1 + size t
  | n_app t1 t2 => 1 + size t1 + size t2
  end.

Lemma swap_size_eq : forall x y t,
    size (swap x y t) = size t.
Proof.
  induction t; simpl; auto.
Qed.

Hint Rewrite swap_size_eq.

(** ** Capture-avoiding substitution *)

(** We need to use size to define capture avoiding
    substitution. Because we sometimes swap the name of the
    bound variable, this function is _not_ structurally
    recursive. So, we add an extra argument to the function
    that decreases with each recursive call. *)

Fixpoint subst_rec (n:nat) (t:n_exp) (u :n_exp) (x:atom)  : n_exp :=
  match n with
  | 0 => t
  | S m => match t with
          | n_var y =>
            if (x == y) then u else t
          | n_abs y t1 =>
            if (x == y) then t
            else
              (* rename to avoid capture *)
              let (z,_) :=
                  atom_fresh (fv_nom u `union` fv_nom t `union` {{x}}) in
                 n_abs z (subst_rec m (swap y z t1) u x)
          | n_app t1 t2 =>
            n_app (subst_rec m t1 u x) (subst_rec m t2 u x)
          end
  end.

(** Our real substitution function uses the size of the size of the term
    as that extra argument. *)
Definition subst (u : n_exp) (x:atom) (t:n_exp) :=
  subst_rec (size t) t u x.

(** This next lemma uses course of values induction [lt_wf_ind] to prove that
    the size of the term [t] is enough "fuel" to completely calculate a
    substitution. Providing larger numbers produces the same result. *)
Lemma subst_size : forall n (u : n_exp) (x:atom) (t:n_exp),
    size t <= n -> subst_rec n t u x = subst_rec (size t) t u x.
Proof.
  intro n. eapply (lt_wf_ind n). clear n.
  intros n IH u x t SZ.
  destruct t; simpl in *; destruct n; try omega.
  - default_simp.
  - default_simp.
    rewrite <- (swap_size_eq x0 x1).
    rewrite <- (swap_size_eq x0 x1) in SZ.
    apply IH. omega. omega.
  - simpl.
    rewrite (IH n); try omega.
    rewrite (IH n); try omega.
    rewrite (IH (size t1 + size t2)); try omega.
    rewrite (IH (size t1 + size t2)); try omega.
    auto.
Qed.

(** ** Challenge Exercise [subst]

    Use the definitions above to prove the following results about the
    nominal substitution function.  *)

Lemma subst_eq_var : forall u x,
    subst u x (n_var x) = u.
Proof.
  (* FILL IN HERE *) Admitted.

Lemma subst_neq_var : forall u x y,
    x <> y ->
    subst u x (n_var y) = n_var y.
Proof.
  (* FILL IN HERE *) Admitted.

Lemma subst_app : forall u x t1 t2,
    subst u x (n_app t1 t2) = n_app (subst u x t1) (subst u x t2).
Proof. (* FILL IN HERE *) Admitted.

Lemma subst_abs : forall u x y t1,
    subst u x (n_abs y t1) =
       if (x == y) then (n_abs y t1)
       else let (z,_) := atom_fresh (fv_nom u `union` fv_nom (n_abs y t1) `union` {{x}}) in
       n_abs z (subst u x (swap y z t1)).
Proof. (* FILL IN HERE *) Admitted.

(** ** Challenge Exercise [subst properties]

    Now show the following property by induction on the size of terms. *)

Lemma subst_same_aux : forall n, forall t y, size t <= n -> aeq (subst (n_var y) y t)  t.
Proof.
  intro n. induction n.
  intros t y SZ. destruct t; simpl in SZ; omega.
  intros t y SZ. destruct t; simpl in SZ.
(* FILL IN HERE *) Admitted.

Lemma subst_same : forall t y, aeq (subst (n_var y) y t)  t.
Proof.
  intros.
  apply subst_same_aux with (n := size t). auto.
Qed.

Lemma subst_fresh_eq_aux : forall n, forall (x : atom) t u, size t <= n ->
  x `notin` fv_nom t -> aeq (subst u x t) t.
Proof. (* FILL IN HERE *) Admitted.

Lemma subst_fresh_eq : forall (x : atom) t u,  x `notin` fv_nom t -> aeq (subst u x t) t.
Proof.
  intros. apply subst_fresh_eq_aux with (n := size t). omega. auto.
Qed.


Require Import DASL List.

Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition orb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

(* This is heavily inspired by Paulien de Wind's M.Sc. Thesis: "Modal Logic in Coq", University of Amsterdam, 2001.
And the work of Pierre Lescanne, which can be found here: http://perso.ens-lyon.fr/pierre.lescanne/COQ/
 *)

Record frame : Type := {
  W : Set;
  Rk : DASL.Agents -> W -> W -> Prop;
  Rb : DASL.Agents -> W -> W -> Prop
}.

Check frame.

Check Build_frame.

Record model : Type := {
  F : frame;
  Val : (W F) -> Atoms -> Prop;
  Agents: DASL.Agents
}.

Fixpoint satisfies (M : model) (x : (W (F M))) (phi : prop) {struct phi} : Prop :=
  match phi with
  | _|_ => False
  | (atm atom) => (Val M x atom)
  | (imp phi1 phi2) => (satisfies M x phi1) -> (satisfies M x phi2)
  | (negp phi') => (~ (satisfies M x phi'))
  | (K a phi') => (forall y : (W (F M)), (Rk (F M) a x y) -> (satisfies M y phi'))
  | (B a phi') => (forall y : (W (F M)), (Rb (F M) a x y) -> (satisfies M y phi'))
  end.

Notation "M x |== phi" := (satisfies M x phi) (at level 80).

Definition Model_satisfies (M : model) (phi : prop) := forall (w : (W (F M))),
  satisfies M w phi .

Notation "M |= phi" := (Model_satisfies M phi) (at level 80).

Definition Frame_validity (F : frame) (phi : prop) := forall (Val : (W F) -> Atoms -> Prop) (Ags : DASL.Agents),
  (Model_satisfies (Build_model F Val Ags) phi).

Notation "F ||= phi" := (Frame_validity F phi) (at level 80).

Definition valid (phi : prop) := forall (F : frame),
  (Frame_validity F phi).

Definition reflexive_Rk_frame (F : frame) : Prop :=
  forall (w : (W F)) (ags : DASL.Agents), (Rk F ags w w).

Definition serial_Rb_frame (F : frame) : Prop :=
  forall (w : (W F)) (ags : DASL.Agents),
    exists (y : (W F)), (Rb F ags w y).

Definition euclidean_Rb_frame (F : frame) : Prop :=
  forall (w x y : (W F)) (ags : DASL.Agents),
    (Rb F ags w x) ->
    (Rb F ags w y) ->
    (Rb F ags x y).

Definition Rb_subset_Rk (F : frame) : Prop :=
  forall (w x : (W F)) (a : DASL.Agents),
  (Rb F a w x) ->
  (Rk F a w x).

Definition Rb_subset_Rb_compose_Rk (F : frame) : Prop :=
  forall (w x y : (W F)) (a :  DASL.Agents),
  (Rb F a w x) ->
  (Rk F a x y) ->
  (Rb F a w y).

Lemma K_is_refl : forall (phi : prop) (F : frame) (a : DASL.Agents),
  (reflexive_Rk_frame F) ->
  F ||= ((K a phi) ==> phi).
Proof.
  intros.
  unfold reflexive_Rk_frame in H.
  unfold Frame_validity.
    intros.
    unfold Model_satisfies.
      intros. pose proof H w; clear H. pose proof H0 a; clear H0.
      unfold satisfies.
        intros. pose proof H0 w; clear H0. simpl in H1. pose proof H1 H; clear H1.
        auto.
Qed.

Hint Resolve K_is_refl.

Lemma B_is_serial : forall (phi : prop) (F : frame) (a : DASL.Agents),
  (serial_Rb_frame F) ->
  F ||= ((B a phi) ==> NOT (B a (NOT phi))).
Proof.
  intros.
  unfold serial_Rb_frame in H.
  unfold Frame_validity.
    intros.
    unfold Model_satisfies.
      intros. pose proof H w; clear H. pose proof H0 a; clear H0.
      unfold satisfies.
        destruct H.
        intros. pose proof H0 x; clear H0. simpl in H1. pose proof H1 H; clear H1. simpl. unfold not.
        intros.
        pose proof H1 x H; clear H1. pose proof H2 H0. assumption.
Qed.

Hint Resolve B_is_serial.

Lemma B_is_euclidean : forall (phi : prop) (F : frame) (a : DASL.Agents),
  (euclidean_Rb_frame F) ->
  F ||= (NOT (B a phi) ==> B a (NOT (B a phi))).
Proof.
  intros; unfold euclidean_Rb_frame in H;
    unfold Frame_validity;
      intros; unfold Model_satisfies;
          intros; unfold satisfies; unfold NOT; unfold not;
            intros; contradiction H0;
              intro x; intros; pose proof H2 x; clear H2;
                pose proof H w; clear H; pose proof H2 y; clear H2; pose proof H x; clear H;
                pose proof H2 a H1; clear H2; pose proof H H3; clear H; pose proof H4 H2; assumption.
Qed.

Hint Resolve B_is_euclidean.

Lemma KB_is_Rb_subset_Rk : forall (phi : prop) (F : frame) (a : DASL.Agents),
  (Rb_subset_Rk F) ->
  F ||= (K a phi ==> B a phi).
Proof.
  intros; unfold Rb_subset_Rk in H;
    unfold Frame_validity;
      intros; unfold Model_satisfies;
        intros; unfold satisfies; intro H0; intro x;
          pose proof H0 x; clear H0; intro;
          pose proof H w x a H0; clear H;
          pose proof H1 H2; clear H1; assumption.
Qed.

Hint Resolve KB_is_Rb_subset_Rk.

Lemma B_BK_is_Rb_subset_Rb_compose_Rk : forall (phi : prop) (F : frame) (a : DASL.Agents),
  (Rb_subset_Rb_compose_Rk F) ->
  F ||= (B a phi ==> B a (K a phi)).
Proof.
  unfold Rb_subset_Rb_compose_Rk; intros;
  unfold Frame_validity; intros; unfold Model_satisfies; intros; unfold satisfies;
  intro H0; intro x; intro H1; intro y;
    pose proof H w x y a H1; clear H; intro H3;
    pose proof H2 H3; clear H2;
    pose proof H0 y H; clear H0;
    assumption.
Qed.

Hint Resolve B_BK_is_Rb_subset_Rb_compose_Rk.

Lemma Hilbert_K_Frame_Valid : forall (p q : prop) (F : frame) (a : DASL.Agents),
  F ||= (p ==> q ==> p).
Proof.
  intros p q F a.
  repeat (try unfold Frame_validity; intros; try unfold Model_satisfies; intros; try unfold satisfies; intros; assumption).
Qed.

Hint Resolve Hilbert_K_Frame_Valid.

Lemma Hilbert_S_Frame_Valid : forall (p q r : prop) (F : frame) (a : DASL.Agents),
  F ||= ((p==>q==>r)==>(p==>q)==>(p==>r)).
Proof.
  intros p q r F a.

  repeat (try unfold Frame_validity;
              intros; try unfold Model_satisfies;
              intros; try unfold satisfies;
              intros; try pose proof H H1; clear H;
                      try pose proof H0 H1; clear H0;
                      try pose proof H2 H;
          assumption).
Qed.

Hint Resolve Hilbert_S_Frame_Valid.

Axiom base_double_negation : forall p,
  not (not p) <-> p.

Hint Resolve base_double_negation.

Lemma Classic_NOTNOT_Frame_Valid : forall (p : prop) (F : frame) (a : DASL.Agents),
  F ||= ((NOT (NOT p)) ==> p).
Proof.
  intros p F a.
   repeat (try unfold Frame_validity;
              intros; try unfold Model_satisfies;
              intros; try unfold satisfies;
              intros; try unfold NOT in H;
                      try rewrite base_double_negation in H;
                      try assumption).
Qed.

Hint Resolve Classic_NOTNOT_Frame_Valid.

Lemma MP_Frame_Valid : forall (p q : prop) (F : frame) (a : DASL.Agents),
  F ||= (p ==> q) ->
  F ||= p ->
  F ||= q.
Proof.
  intros p q F a.
  unfold Frame_validity.
  unfold Model_satisfies.
  unfold satisfies.
  intros.
  pose proof H Val0 Ags; clear H.
  pose proof H0 Val0 Ags; clear H0.
  pose proof H w; clear H.
  pose proof H1 w H0; clear H1. assumption.
Qed.

Hint Resolve MP_Frame_Valid.

Lemma K_Nec_Frame_Valid : forall (p : prop) (F : frame) (a : DASL.Agents),
  F ||= p ->
  F ||= K a p.
Proof.
  intros p F a.
  unfold Frame_validity; unfold Model_satisfies; unfold satisfies; intros.
  pose proof H Val0 Ags y; clear H. assumption.
Qed.

Hint Resolve K_Nec_Frame_Valid.

Lemma K_K_Frame_Valid : forall (p q : prop) (F : frame) (a : DASL.Agents),
  F ||= (K a p ==> K a (p ==> q) ==> K a q).
Proof.
  intros p q F a.
  unfold Frame_validity; unfold Model_satisfies; unfold satisfies. intros.
  pose proof H0 y H1; clear H0.
  pose proof H y H1; clear H. pose proof H2 H0; assumption.
Qed.

Hint Resolve K_K_Frame_Valid.

Lemma B_K_Frame_Valid : forall (p q : prop) (F : frame) (a : DASL.Agents),
  F ||= (B a p ==> B a (p ==> q) ==> B a q).
Proof.
  intros p q F a.
  unfold Frame_validity; unfold Model_satisfies; unfold satisfies. intros.
  pose proof H0 y H1; clear H0.
  pose proof H y H1; clear H. pose proof H2 H0; assumption.
Qed.

Hint Resolve B_K_Frame_Valid.

Definition DASL_Frame (F : frame) : Prop :=
  reflexive_Rk_frame F /\
  serial_Rb_frame F /\
  euclidean_Rb_frame F /\
  Rb_subset_Rk F /\
  Rb_subset_Rb_compose_Rk F.

Theorem DASL_Soundness : forall (phi : prop) (F : frame) (a : DASL.Agents),
  DASL_Frame F ->
  |-- phi ->
  F ||= phi.
Proof.
   intros phi F.
    unfold DASL_Frame.
    intros. destruct H; destruct H1; destruct H2; destruct H3.
    induction H0; eauto.
Qed.

Inductive schema : Type :=
  | SProp : prop -> schema
  | SAnd : schema -> schema -> schema
  | SOr : schema -> schema -> schema
  | SImp : schema -> schema -> schema
  | SNeg : schema -> schema
  | SK : DASL.Agents -> schema -> schema
  | SB : DASL.Agents -> schema -> schema.

Notation "\ p" := (SNeg p) (at level 70, right associativity).
Infix "=s=>" := SImp (right associativity, at level 85).

Infix "|s|" := SOr (right associativity, at level 75).

Infix "&s&" := SAnd (right associativity, at level 75).

Axiom and_simp_left : forall (phi1 phi2 : prop) (F : frame),
  F ||= (phi1 & phi2) ->
  F ||= phi1.

Axiom and_simp_right : forall (phi1 phi2 : prop) (F : frame),
  F ||= (phi1 & phi2) ->
  F ||= phi2.

Fixpoint normal_form (phi : schema) : schema :=
  match phi with
  | SProp phi'=> SProp phi'
  | SAnd phi1 phi2 => SAnd (normal_form phi1) (normal_form phi2)
  | SOr phi1 phi2 => SOr (normal_form phi1) (normal_form phi2)
  | SImp phi1 phi2 => SOr (SNeg (normal_form phi1)) (normal_form phi2)
  | SNeg phi' => SNeg (normal_form phi')
  | SK a phi' => SK a (normal_form phi')
  | SB a phi' => SB a (normal_form phi')
  end.

Definition basic_schema (phi : schema) : Prop :=
  match phi with
  | SProp p => True
  | _ => False
  end.

Fixpoint negative_formula (phi : schema) : Prop :=
  match phi with
  | SProp p => False
  | SAnd phi1 phi2 => (negative_formula phi1) /\ (negative_formula phi2)
  | SOr phi1 phi2 => (negative_formula phi1) /\ (negative_formula phi2)
  | SImp phi1 phi2 => (negative_formula phi1) /\ (negative_formula phi2)
  | SNeg phi' => not (negative_formula phi')
  | SK a phi' => negative_formula phi'
  | SB a phi' => negative_formula phi'
  end.

Fixpoint positive_formula (phi : schema) : Prop :=
  match phi with
  | SProp p => True
  | SAnd phi1 phi2 => (positive_formula phi1) /\ (positive_formula phi2)
  | SOr phi1 phi2 => (positive_formula phi1) /\ (positive_formula phi2)
  | SImp phi1 phi2 => (positive_formula phi1) /\ (positive_formula phi2)
  | SNeg phi' => not (positive_formula phi')
  | SK a phi' => positive_formula phi'
  | SB a phi' => positive_formula phi'
  end.

Fixpoint boxed_formula (phi : schema) : Prop :=
  match phi with
  | SProp p => True
  | SAnd phi1 phi2 => False
  | SOr phi1 phi2 => False
  | SImp phi1 phi2 => False
  | SNeg phi' => False
  | SK a phi' => boxed_formula phi'
  | SB a phi' => boxed_formula phi'
  end.

Fixpoint s_a_component (phi : schema) : Prop :=
  match phi with
  | SProp p => True
  | SAnd phi1 phi2 => (s_a_component phi1) /\ (s_a_component phi2)
  | SOr phi1 phi2 => (s_a_component phi1) /\ (s_a_component phi2)
  | SImp phi1 phi2 => not (s_a_component phi1) /\ (s_a_component phi2)
  | SNeg phi' => match phi' with
                 | SProp p => True
                 | SAnd p1 p2 => positive_formula p1 /\ positive_formula p2
                 | SOr p1 p2 => positive_formula p1 /\ positive_formula p2
                 | SImp p1 p2 => negative_formula p1 /\ positive_formula p2
                 | SNeg p' => s_a_component p'
                 | SK a p' => not (s_a_component p')
                 | SB a p' => not (s_a_component p')
                 end
  | SK a phi' => boxed_formula phi'
  | SB a phi' => boxed_formula phi'
  end.

Fixpoint sahlqvist_antecedent (phi : schema) : Prop :=
  s_a_component (normal_form phi).

Definition sahlqvist_implication (phi psi : schema) : Prop :=
  sahlqvist_antecedent (phi) /\ positive_formula (psi).

Fixpoint prop_in_schema (phi : prop) (psi : schema) : Prop :=
  match psi with
    | SProp psi' => phi = psi'
    | SAnd psi1 psi2 => (prop_in_schema phi psi1) \/ (prop_in_schema phi psi2)
    | SOr psi1 psi2 => (prop_in_schema phi psi1) \/ (prop_in_schema phi psi2)
    | SImp psi1 psi2 => (prop_in_schema phi psi1) \/ (prop_in_schema phi psi2)
    | SNeg psi' => (prop_in_schema phi psi')
    | SK a psi' => (prop_in_schema phi psi')
    | SB a psi' => (prop_in_schema phi psi')
  end.

Fixpoint share_prop_letter (phi psi : schema) {struct phi} : Prop :=
  match phi with
    | SProp phi' => match psi with
                      | SProp psi' => phi' = psi'
                      | SAnd psi1 psi2 => (prop_in_schema phi' psi1) \/ (prop_in_schema phi' psi2)
                      | SOr psi1 psi2 => (prop_in_schema phi' psi1) \/ (prop_in_schema phi' psi2)
                      | SImp psi1 psi2 => (prop_in_schema phi' psi1) \/ (prop_in_schema phi' psi2)
                      | SNeg psi' => (prop_in_schema phi' psi')
                      | SK a psi' => (prop_in_schema phi' psi')
                      | SB a psi' => (prop_in_schema phi' psi')
                    end
    | SAnd phi1 phi2 => (share_prop_letter phi1 psi) \/ (share_prop_letter phi2 psi)
    | SOr phi1 phi2 => (share_prop_letter phi1 psi) \/ (share_prop_letter phi2 psi)
    | SImp phi1 phi2 => (share_prop_letter phi1 psi) \/ (share_prop_letter phi2 psi)
    | SNeg phi' => (share_prop_letter phi' psi)
    | SK a phi' => (share_prop_letter phi' psi)
    | SB a phi' => (share_prop_letter phi' psi)
  end.

Example shared_and : forall (p q : prop),
share_prop_letter ((SProp p) &s& (SProp q)) (SProp p).
Proof.
intros. simpl. intuition.
Qed.

Example not_shared_and : forall (p q r : prop),
p <> r /\ q <> r ->
~ share_prop_letter ((SProp p) &s& (SProp q)) (SProp r).
Proof.
intros. unfold not. simpl. intuition.
Qed.

Theorem share_prop_letter_correct : forall (p q : prop),
  share_prop_letter (SProp p) (SProp q) <->
  p = q.
Proof.
intros. split; intros; simpl in H; auto.
Qed.

Fixpoint sahlqvist_formula (phi : schema) : Prop :=
  match phi with
    | SProp phi'=> True
    | SAnd phi1 phi2 => (sahlqvist_formula phi1) /\ (sahlqvist_formula phi2)
    | SOr phi1 phi2 => not (share_prop_letter phi1 phi2) /\ (sahlqvist_formula phi1) /\ (sahlqvist_formula phi2)
    | SImp phi1 phi2 => (sahlqvist_implication phi1 phi2)
    | SNeg phi' => ~ (positive_formula phi')
    | SK a phi' => sahlqvist_formula phi'
    | SB a phi' => sahlqvist_formula phi'
  end.

Lemma sahlqvist_antecedent_p_and_q : forall (p q : prop),
  sahlqvist_antecedent (SAnd (SProp p) (SProp q)).
Proof.
  intros. simpl; auto.
Qed.

(* Fixpoint sahlqvist_formula (phi : prop) {struct phi} : Prop :=
  match phi with
  | _|_ => True
  | (atm atom) => True
  | (negp p') => sahlqvist_formula p'
  | (imp p1 p2) => (sahlqvist_antecedent p1) /\ (positive_formula p2)
  | (K a p') => sahlqvist_formula p'
  | (B a p') => sahlqvist_formula p'
  end.
 *)
Lemma K_T_is_sahlqvist : forall (phi : prop) (a : DASL.Agents),
  sahlqvist_formula (SK a (SProp phi) =s=> (SProp phi)).
Proof.
  intros. simpl. unfold sahlqvist_implication; split; unfold positive_formula; simpl; intuition.
Qed.

Hint Resolve K_T_is_sahlqvist.

Ltac sahlqvist_reduce := simpl; try (unfold sahlqvist_implication; split);
  try (unfold positive_formula; simpl; intuition);
  try (unfold sahlqvist_antecedent; simpl; intuition; unfold normal_form).

Ltac not_sahlqvist := try (unfold sahlqvist_formula; unfold sahlqvist_implication; simpl; intuition).

Lemma B_Serial_is_sahlqvist : forall (phi : prop) (a : DASL.Agents),
  sahlqvist_formula (SB a (SProp phi) =s=> \ (SB a (\ SProp phi))).
Proof.
  intros; sahlqvist_reduce.
Qed.

Hint Resolve B_Serial_is_sahlqvist.

Lemma B_5_is_sahlqvist : forall (phi : prop) (a : DASL.Agents),
  sahlqvist_formula (\ (SB a (\ SB a (SProp phi))) =s=> (SB a (SProp phi))).
Proof.
intros; sahlqvist_reduce.
Qed.

Hint Resolve B_5_is_sahlqvist.

Example Lob_not_sahlqvist : forall (phi : prop) (a : DASL.Agents),
  ~ sahlqvist_formula (SK a (SK a (SProp phi) =s=> (SProp phi)) =s=> SK a (SProp phi)).
Proof.
intros. unfold not. not_sahlqvist.
Qed.

Lemma K_B_is_sahlqvist : forall (phi : prop) (a : DASL.Agents),
  sahlqvist_formula (SK a (SProp phi) =s=> SB a (SProp phi)).
Proof.
  intros; sahlqvist_reduce.
Qed.

Hint Resolve K_B_is_sahlqvist.

Lemma B_BK_is_sahlqvist : forall (phi : prop) (a : DASL.Agents),
  sahlqvist_formula (SB a (SProp phi) =s=> SB a (SK a (SProp phi))).
Proof.
  intros; sahlqvist_reduce.
Qed.

Hint Resolve B_BK_is_sahlqvist.

(* Lemma Hilbert_K_is_sahlqvist : forall (p q : prop) (a : DASL.Agents),
  sahlqvist_formula (normal_form ((SProp p) =s=> (SProp q) =s=> (SProp p))).
Proof.
  intros. simpl; auto.
Qed.

Hint Resolve Hilbert_K_is_sahlqvist.

Lemma Hilbert_S_is_sahlqvist : forall (p q r : prop),
  sahlqvist_formula (normal_form (((SProp p) =s=> (SProp q) =s=> (SProp r)) =s=>
                    ((SProp p) =s=> (SProp q)) =s=>
                    ((SProp p) =s=> (SProp r)))).
Proof.
intros. simpl; auto.
Qed.

Hint Resolve Hilbert_S_is_sahlqvist. *)

Example McKinsey_not_sahlqvist : forall (phi : prop) (a : DASL.Agents),
  ~ sahlqvist_formula (SK a (SNeg (SK a (SNeg (SProp phi)))) =s=> SNeg (SK a (SNeg (SK a (SProp phi))))).
Proof.
intros; not_sahlqvist.
Qed.

Lemma Classic_NOTNOT_is_sahlqvist : forall (p : prop),
  sahlqvist_formula (SNeg (SNeg (SProp p)) =s=> (SProp p)).
Proof.
intros; sahlqvist_reduce.
Qed.

Hint Resolve Classic_NOTNOT_is_sahlqvist.

Example Church_Rosser_is_sahlqvist : forall (phi : prop) (a : DASL.Agents),
  sahlqvist_formula (\ (SK a (\ (SK a (SProp phi)))) =s=> (SK a (\ (SK a (\ (SProp phi)))))).
Proof.
  intros; sahlqvist_reduce.
Qed.

Example Brouwer_is_sahlqvist : forall (phi : prop) (a : DASL.Agents),
  sahlqvist_formula ((SProp phi) =s=> \ (SK a (\ (SK a (SProp phi))))).
Proof.
  intros; sahlqvist_reduce.
Qed.

Example Brouwer_is_not_sahlqvist : forall (phi : prop) (a : DASL.Agents),
  ~ ( sahlqvist_formula ((SProp phi) =s=> \ (SK a (\ (SK a (SProp phi))))) ).
Proof.
intros; not_sahlqvist. Abort.

Example Very_simple_Blackburn: forall (p : prop) (a : DASL.Agents),
  sahlqvist_formula (((SProp p) &s& (\ (SK a (\ (\ (SK a (\ (SProp p)))))))) =s=>
    (\ (SK a (\ (SProp p))))).
Proof.
intros; sahlqvist_reduce.
Qed.

Example sahlqvist_Blackburn_example_1 : forall (phi : prop) (a : DASL.Agents),
  sahlqvist_formula (SK a ((SProp phi) =s=> (\ (SK a (\ (SProp phi)))))).
Proof.
  intros; sahlqvist_reduce.
Qed.

Fixpoint schema_to_prop (phi : schema) : prop :=
  match phi with
  | SProp phi' => phi'
  | SAnd phi1 phi2 => (schema_to_prop phi1) & (schema_to_prop phi2)
  | SOr phi1 phi2 => (schema_to_prop phi1) V (schema_to_prop phi2)
  | SImp phi1 phi2 => (schema_to_prop phi1) ==> (schema_to_prop phi2)
  | SNeg phi' => ! (schema_to_prop phi')
  | SK a phi' => K a (schema_to_prop phi')
  | SB a phi' => B a (schema_to_prop phi')
  end.

Fixpoint prop_to_schema (phi : prop) : schema :=
  match phi with
  | _|_ => SProp (_|_)
  | (atm atom) => SProp (atm atom)
  | (imp phi1 phi2) => (prop_to_schema phi1) =s=> (prop_to_schema phi2)
  | (negp phi') => SNeg (prop_to_schema phi')
  | (K a phi') => SK a (prop_to_schema phi')
  | (B a phi') => SB a (prop_to_schema phi')
  end.

Inductive Stheorem : schema -> Prop :=
   |SHilbert_K: forall p q : prop, Stheorem ((SProp p) =s=> (SProp q) =s=> (SProp p))
   |SHilbert_S: forall p q r : prop, Stheorem (((SProp p)=s=>(SProp q)=s=>(SProp r))=s=>((SProp p)=s=>(SProp q))=s=>((SProp p)=s=>(SProp r)))
   |SClassic_NOTNOT : forall p : prop, Stheorem ((\ (\ (SProp p))) =s=> (SProp p))
   |SMP : forall p q : prop, Stheorem ((SProp p) =s=> (SProp q)) -> Stheorem (SProp p) -> Stheorem (SProp q)
   |SK_Nec : forall (a : DASL.Agents) (p : prop), Stheorem (SProp p) -> Stheorem (SK a (SProp p))
   |SK_K : forall (a : DASL.Agents) (p q : prop), Stheorem (SK a (SProp p) =s=> SK a ((SProp p) =s=> (SProp q)) =s=> SK a (SProp q))
   |SK_T : forall (a : DASL.Agents) (p : prop), Stheorem (SK a (SProp p) =s=> (SProp p))
   |SB_K : forall (a : DASL.Agents) (p q : prop), Stheorem (SB a (SProp p) =s=> SB a ((SProp p) =s=> (SProp q)) =s=> SB a (SProp q))
   |SB_Serial : forall (a : DASL.Agents) (p : prop), Stheorem (SB a (SProp p) =s=> \ (SB a (\ (SProp p))))
   |SB_5 : forall (a : DASL.Agents) (p : prop), Stheorem (\ (SB a (SProp p)) =s=> SB a (\ (SB a (SProp p))))
   |SK_B : forall (a : DASL.Agents) (p : prop), Stheorem (SK a (SProp p) =s=> SB a (SProp p))
   |SB_BK : forall (a : DASL.Agents) (p : prop), Stheorem (SB a (SProp p) =s=> SB a (SK a (SProp p))).

Notation "|s-" := Stheorem (at level 80).
Check Build_frame.
Check frame.

Definition DASL_Axioms (p q r : prop) (a : DASL.Agents) :=
(SK a (SProp p) =s=> SK a ((SProp p) =s=> (SProp q)) =s=> SK a (SProp q))
:: (SK a (SProp p) =s=> (SProp p))
:: (SB a (SProp p) =s=> SB a ((SProp p) =s=> (SProp q)) =s=> SB a (SProp q))
:: (SB a (SProp p) =s=> \ (SB a (\ (SProp p))))
:: (\ (SB a (\ (SB a (SProp p)))) =s=> SB a (SProp p))
:: (SK a (SProp p) =s=> SB a (SProp p))
:: (SB a (SProp p) =s=> SB a (SK a (SProp p)))
:: nil.

Fixpoint Complete_via_Sahlqvist (l : list schema) : Prop :=
  match l with
  | nil => True
  | (l' :: els) => sahlqvist_formula (l') /\ Complete_via_Sahlqvist (els)
  end.

Axiom sahlqvist_is_canonical : forall (phi : schema) (F1 F2 : frame),
  sahlqvist_formula phi ->
    (F1 ||= (schema_to_prop phi) <->
    |-- (schema_to_prop phi)) /\
    (F2 ||= (schema_to_prop phi) <-> F2 = F1).

Ltac sahlqvist_complete_list :=
  match goal with [ |- ?P1 (?P2 _ _ _ _) ] => unfold P2; repeat (constructor; auto; sahlqvist_reduce) end.

Theorem DASL_Axioms_Complete : forall (p q r : prop) (a : DASL.Agents),
  Complete_via_Sahlqvist (DASL_Axioms p q r a).
Proof.
intros; sahlqvist_complete_list.
Qed.

Lemma schema_to_prop_completeness : forall (phi : schema),
  |s- phi ->
  |-- schema_to_prop phi.
Proof.
intros.
induction H; simpl; try constructor.
simpl in IHStheorem1.
simpl in IHStheorem2. pose proof MP p q IHStheorem1; auto.
simpl in IHStheorem; auto.
Qed.

Lemma prop_to_schema_completeness : forall (phi : schema),
  |-- schema_to_prop phi ->
  |s- phi.
Proof.
intros. induction phi. simpl in H. induction H. Focus 7. simpl. induction p; simpl. Abort.

Theorem weak_subjective_evidential_restraint_not_sahlqvist:  forall (phi : prop) (a : DASL.Agents),
   (sahlqvist_formula (SB a (SProp phi) =s=> (\ (SB a (\ (SK a (SProp phi))))))).
Proof.
  intros; sahlqvist_reduce.
Qed.

Definition KDiamond (phi : schema) (a : DASL.Agents) :=
  SNeg (SK a (SNeg phi)).
Hint Resolve KDiamond.
Notation "<K>" := KDiamond.

Fixpoint standard_translation (p : schema) (M : model) (x : W (F M)) {struct p} : Prop :=
  match p with
  | SProp p' => satisfies M x p'
  | SAnd p1 p2 => (standard_translation p1 M x) /\ (standard_translation p2 M x)
  | SOr p1 p2 =>  (standard_translation p1 M x) \/ (standard_translation p2 M x)
  | SImp p1 p2 => ~(standard_translation p1 M x) \/ (standard_translation p2 M x)
  | SNeg p' => ~(standard_translation p' M x)
  | SK a p' => forall (y : W (F M)), (Rk (F M) a x y) -> (standard_translation p' M y)
  | SB a p' => forall (y : W (F M)), (Rb (F M) a x y) -> (standard_translation p' M y)
  end.

Example T_Refl : forall (phi : prop) (M : model) (x : W (F M)) (a : DASL.Agents),
  standard_translation ((SK a (SProp phi)) =s=> (SProp phi)) M x
= ~(forall (y : W (F M)), (Rk (F M) a x y) -> satisfies M y phi)
   \/ (satisfies M x phi).
Proof.
intros. simpl. reflexivity.
Qed.

Example Blackburn_ST_Example_1 : forall (phi psi : prop) (M : model) (x : W (F M)) (a : DASL.Agents),
  standard_translation (\ (SK a (\ ((SK a (SProp phi) =s=> (SProp psi)))))) M x
= exists (y : W (F M)), ((Rk (F M) a x y) /\
  ~ (forall (y0 : W (F M)), (~ (Rk (F M) a y y0) \/ satisfies M y0 phi) \/ satisfies M y psi)).
Proof.
intros phi psi M x a. simpl. simpl. intuition. reflexivity. unfold standard_translation.

Example T_Refl' : forall (phi : prop) (M : model) (x : W (F M)) (a : DASL.Agents),
  standard_translation ((SK a (SProp phi)) =s=> (SProp phi)) M x
-> reflexive_Rk_frame (F M).
Proof.
unfold reflexive_Rk_frame. intros. unfold standard_translation in H. destruct H.
(*    Left *)
  unfold not in H. contradiction H. intros. unfold satisfies in H. simpl in H.
intuition.

(*
Definition serial_Rb_frame (F : frame) : Prop :=
  forall (w : (W F)) (ags : DASL.Agents),
    exists (y : (W F)), (Rb F ags w y).

Inductive prop : Type :=
   | atm : Atoms -> prop
   | imp : prop -> prop -> prop
   | negp : prop -> prop
   | falsum : prop
   | K : Agents -> prop -> prop
   | B : Agents -> prop -> prop.
Schema
  | SProp : prop -> schema
  | SAnd : schema -> schema -> schema
  | SOr : schema -> schema -> schema
  | SImp : schema -> schema -> schema
  | SNeg : schema -> schema
  | SK : DASL.Agents -> schema -> schema
  | SB : DASL.Agents -> schema -> schema.
*)

Theorem DASL_Completeness : forall (phi : schema) (F : frame) (val: (W F) -> Atoms -> Prop) (a : DASL.Agents),
  DASL_Frame F ->
  F ||= (schema_to_prop phi) ->
  |-- (schema_to_prop phi).
Proof.
Abort.


(* QuickChick Prelude *)
Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

Require Import String List. Open Scope string.

From QuickChick Require Import QuickChick Tactics.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.
Import QcDefaultNotation. Open Scope qc_scope.

Set Bullet Behavior "Strict Subproofs".

(* End prelude *)

(* IMPORTS *)
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.lia.Lia.
Require Import Coq.Lists.List.
Import ListNotations.

(* LEO: Update Map *)
Require Import Maps.
(* /IMPORTS *)

Module AExp.

Inductive aexp' : Type :=
  | ANum : nat -> aexp'
  | APlus : aexp' -> aexp' -> aexp'
  | AMinus : aexp' -> aexp' -> aexp'
  | AMult : aexp' -> aexp' -> aexp'.

Derive (Arbitrary, Show) for aexp'.
Derive (Sized, CanonicalSized) for aexp'.
Derive SizeMonotonic for aexp' using genSaexp'.
Derive SizedMonotonic for aexp'.
Derive SizedCorrect for aexp' using genSaexp' and SizeMonotonicaexp'.

Instance dec_eq_aex (x y : aexp') : Dec (x = y).
constructor; unfold decidable; repeat decide equality. Defined.

(* AEC Reviewer example *)
Inductive aexpEq : aexp' -> aexp' -> Prop :=
 | ANumEq : forall n1 n2, n1 = n2 -> aexpEq (ANum n1) (ANum n2).

Instance dec_aexpEq (x y : aexp') : Dec (aexpEq x y).
constructor; unfold decidable. destruct x; destruct y;
try solve [right => H; inversion H; eauto].
destruct ((n = n0)?) eqn:Eq; destruct dec; try solve [inversion Eq].
- left; econstructor; eauto.
- right => H; inversion H; eauto.
Defined.

Conjecture aexpEq_refl : forall x, aexpEq x x.
QuickChick aexpEq_refl.

Derive ArbitrarySizedSuchThat for (fun x => aexpEq x x').
Derive SizedProofEqs for (fun x => aexpEq x x').
Derive SizeMonotonicSuchThatOpt for (fun x => aexpEq x x').
Derive GenSizedSuchThatSizeMonotonicOpt for (fun x => aexpEq x x').
Derive GenSizedSuchThatCorrect for (fun x => aexpEq x x').

Conjecture aexpEq_eq : forall x x', aexpEq x x' -> x = x'.
QuickChick aexpEq_eq.
(* End Reviwer example *)

Inductive bexp' : Type :=
  | BTrue : bexp'
  | BFalse : bexp'
  | BEq : aexp' -> aexp' -> bexp'
  | BLe : aexp' -> aexp' -> bexp'
  | BNot : bexp' -> bexp'
  | BAnd : bexp' -> bexp' -> bexp'.

Derive (Arbitrary, Show) for bexp'.
Derive (Sized, CanonicalSized) for bexp'.
Derive SizeMonotonic for bexp' using genSbexp'.
Derive SizedMonotonic for bexp'.
Derive SizedCorrect for bexp' using genSbexp' and SizeMonotonicbexp'.

Instance dec_eq_bexp (x y : bexp') : Dec (x = y).
constructor; unfold decidable; repeat decide equality. Defined.

Fixpoint aeval (a : aexp') : nat :=
  match a with
  | ANum n => n
  | APlus a1 a2 => (aeval a1) + (aeval a2)
  | AMinus a1 a2  => (aeval a1) - (aeval a2)
  | AMult a1 a2 => (aeval a1) * (aeval a2)
  end.

Fixpoint beval (b : bexp') : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval a1) (aeval a2)
  | BLe a1 a2   => leb (aeval a1) (aeval a2)
  | BNot b1     => negb (beval b1)
  | BAnd b1 b2  => andb (beval b1) (beval b2)
  end.

Fixpoint optimize_0plus (a:aexp') : aexp' :=
  match a with
  | ANum n =>
      ANum n
  | APlus (ANum 0) e2 =>
      optimize_0plus e2
  | APlus e1 e2 =>
      APlus (optimize_0plus e1) (optimize_0plus e2)
  | AMinus e1 e2 =>
      AMinus (optimize_0plus e1) (optimize_0plus e2)
  | AMult e1 e2 =>
      AMult (optimize_0plus e1) (optimize_0plus e2)
  end.

End AExp.

Import AExp.

Theorem optimize_0plus_sound: forall a,
  aeval (optimize_0plus a) = aeval a.
Admitted. (* QuickChick optimize_0plus_sound. *)

Theorem silly1 : forall ae, aeval ae = aeval ae.
Admitted. (* QuickChick silly1. *)

Theorem silly2 : forall (P : Prop), P -> P.
Admitted. (* Higher order *)

Lemma foo : forall n, leb 0 n = true.
Admitted. (* QuickChick foo. *)

Tactic Notation "simpl_and_try" tactic(c) :=
  simpl;
  try c.

Module aevalR_first_try.

Inductive aevalR : aexp' -> nat -> Prop :=
  | E_ANum  : forall (n: nat),
      aevalR (ANum n) n
  | E_APlus : forall (e1 e2: aexp') (n1 n2: nat),
      aevalR e1 n1 ->
      aevalR e2 n2 ->
      aevalR (APlus e1 e2) (n1 + n2)
  | E_AMinus: forall (e1 e2: aexp') (n1 n2: nat),
      aevalR e1 n1 ->
      aevalR e2 n2 ->
      aevalR (AMinus e1 e2) (n1 - n2)
  | E_AMult : forall (e1 e2: aexp') (n1 n2: nat),
      aevalR e1 n1 ->
      aevalR e2 n2 ->
      aevalR (AMult e1 e2) (n1 * n2).

Notation "e '\\' n"
         := (aevalR e n)
            (at level 50, left associativity)
         : type_scope.

End aevalR_first_try.

(** In fact, Coq provides a way to use this notation in the
    definition of [aevalR] itself.  This reduces confusion by avoiding
    situations where we're working on a proof involving statements in
    the form [e \\ n] but we have to refer back to a definition
    written using the form [aevalR e n].

    We do this by first "reserving" the notation, then giving the
    definition together with a declaration of what the notation
    means. *)

Module AExpR.
Reserved Notation "e '\\' n" (at level 50, left associativity).

Inductive aevalR : aexp' -> nat -> Prop :=
  | E_ANum : forall (n:nat),
      (ANum n) \\ n
  | E_APlus : forall (e1 e2: aexp') (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (APlus e1 e2) \\ (n1 + n2)
  | E_AMinus : forall (e1 e2: aexp') (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (AMinus e1 e2) \\ (n1 - n2)
  | E_AMult :  forall (e1 e2: aexp') (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (AMult e1 e2) \\ (n1 * n2)

  where "e '\\' n" := (aevalR e n) : type_scope.

Theorem aeval_iff_aevalR : forall a n,
  (a \\ n) <-> aeval a = n.
Admitted. (* OUT-OF-SCOPE ? *)
End AExpR.

Definition state := total_map.

Definition empty_state : state := t_empty 0.

(* Zoe: Changing the name of this to aexp because the name clash breaks derivation*)
(* TODO: Fix the above at some point *)
Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp               (* <----- NEW *)
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Definition W : id := Id "W".
Definition X : id := Id "X".
Definition Y : id := Id "Y".
Definition Z : id := Id "Z".
(* For better testing *)
(* Instance gid : Gen id := {| arbitrary := elems [W; X; Y; Z] |}. *)

Derive (Arbitrary, Show) for aexp.
Derive (Sized, CanonicalSized) for aexp.
Derive SizedMonotonic for aexp.
Derive SizeMonotonic for aexp using genSaexp.
Derive SizedCorrect for aexp using genSaexp and SizeMonotonicaexp.

Instance dec_eq_aex (x y : aexp) : Dec (x = y).
constructor; unfold decidable; repeat decide equality. Defined.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Derive (Arbitrary, Show) for bexp.
Derive (Sized, CanonicalSized) for bexp.
Derive SizeMonotonic for bexp using genSbexp.
Derive SizedMonotonic for bexp.
Derive SizedCorrect for bexp using genSbexp and SizeMonotonicbexp.

Instance dec_eq_bexp (x y : bexp) : Dec (x = y).
constructor; unfold decidable; repeat decide equality. Defined.

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => t_lookup st x                                (* <----- NEW *)
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2  => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2   => leb (aeval st a1) (aeval st a2)
  | BNot b1     => negb (beval st b1)
  | BAnd b1 b2  => andb (beval st b1) (beval st b2)
  end.

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com.

Derive (Arbitrary, Show) for com.
Derive (Sized, CanonicalSized) for com.
Derive SizeMonotonic for com using genScom.
Derive SizedMonotonic for com.
Derive SizedCorrect for com using genScom and SizeMonotoniccom.

Instance dec_eq_com (x y : com) : Dec (x = y).
constructor; unfold decidable; repeat decide equality. Defined.

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).

Definition fact_in_coq : com :=
  Z ::= AId X;;
  Y ::= ANum 1;;
  WHILE BNot (BEq (AId Z) (ANum 0)) DO
    Y ::= AMult (AId Y) (AId Z);;
    Z ::= AMinus (AId Z) (ANum 1)
  END.

Definition plus2 : com :=
  X ::= (APlus (AId X) (ANum 2)).

Definition XtimesYinZ : com :=
  Z ::= (AMult (AId X) (AId Y)).

Definition subtract_slowly_body : com :=
  Z ::= AMinus (AId Z) (ANum 1) ;;
  X ::= AMinus (AId X) (ANum 1).

Definition subtract_slowly : com :=
  WHILE BNot (BEq (AId X) (ANum 0)) DO
    subtract_slowly_body
  END.

Definition subtract_3_from_5_slowly : com :=
  X ::= ANum 3 ;;
  Z ::= ANum 5 ;;
  subtract_slowly.

Definition loop : com :=
  WHILE BTrue DO
    SKIP
  END.

Reserved Notation "c1 '/' st '\\' st'"
                  (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st \\ st
  | E_Ass  : forall st m d a1 n x,
      aeval st a1 = n ->
      st = (m, d) ->
      (x ::= a1) / st \\ (((x,n) :: m), d)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st  \\ st' ->
      c2 / st' \\ st'' ->
      (c1 ;; c2) / st \\ st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      c1 / st \\ st' ->
      (IFB b THEN c1 ELSE c2 FI) / st \\ st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      c2 / st \\ st' ->
      (IFB b THEN c1 ELSE c2 FI) / st \\ st'
  | E_WhileEnd : forall b st c,
      beval st b = false ->
      (WHILE b DO c END) / st \\ st
  | E_WhileLoop : forall st st' st'' b c,
      beval st b = true ->
      c / st \\ st' ->
      (WHILE b DO c END) / st' \\ st'' ->
      (WHILE b DO c END) / st \\ st''

  where "c1 '/' st '\\' st'" := (ceval c1 st st').

Theorem ceval_deterministic: forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Admitted. (* OUT-OF-SCOPE *)

Theorem loop_never_stops : forall st st',
  ~(loop / st \\ st').
Admitted. (* Gave Up *)

Inductive sinstr : Type :=
| SPush : nat -> sinstr
| SLoad : id -> sinstr
| SPlus : sinstr
| SMinus : sinstr
| SMult : sinstr.


Require Import Bool.
From recross Require Import util regexp.

Theorem chars_in_re : forall re c s,
  s =~ re ->
  In c s ->
  In c (re_chars re).
Proof.
  intros. induction H; cbn in *.
  - destruct H0.
  - apply H0.
  - destruct H0 as [| []]. now subst.
  - destruct H0.
  - apply in_app_iff in H0 as [].
    + now apply IHre_match1.
    + now apply IHre_match2.
  - apply in_app_iff. apply in_app_iff in H0 as [].
    + left. now apply IHre_match1.
    + right. now apply IHre_match2.
  - apply in_app_iff. left. now apply IHre_match.
  - apply in_app_iff. right. now apply IHre_match.
  - apply in_app_iff. left. now apply IHre_match1.
Qed.

Theorem is_void_true : forall re,
  is_void re = true -> re <=> Void.
Proof.
  split; generalize dependent s.
  - induction re; cbn in *; intros; try intuition.
    + destruct cs.
      * invert H0. destruct (in_nil H3).
      * discriminate.
    + invert H0.
      apply orb_true_iff in H as [].
      * apply (IHre1 H _) in H4. invert H4.
      * apply (IHre2 H _) in H5. invert H5.
    + apply andb_true_iff in H as [H1 H2].
      invert H0.
      * apply (IHre1 H1 _) in H4. invert H4.
      * apply (IHre2 H2 _) in H4. invert H4.
    + invert H0.
      apply orb_true_iff in H as [].
      * now apply (IHre1 H).
      * now apply (IHre2 H).
  - intros. invert H0.
Qed.

(* Not iff, because of And *)
Theorem is_void_false : forall re,
  (exists s, s =~ re) -> is_void re = false.
Proof.
  induction re; cbn; intros [s]; try reflexivity.
  - invert H.
  - invert H. destruct cs.
    + invert H2.
    + reflexivity.
  - invert H. apply orb_false_iff. split.
    + apply IHre1. now exists s1.
    + apply IHre2. now exists s2.
  - apply andb_false_iff. invert H.
    + left. apply IHre1. now exists s.
    + right. apply IHre2. now exists s.
  - invert H. apply orb_false_iff. split.
    + apply IHre1. now exists s.
    + apply IHre2. now exists s.
Qed.

Theorem is_nil_true : forall re,
  is_nil re = true -> re <=> Nil.
Proof.
  split; generalize dependent s.
  - induction re; cbn in *; intros; try intuition.
    + invert H0.
      * apply MNil.
      * apply (is_void_true _ H) in H2. invert H2.
    + invert H0.
      apply andb_true_iff in H as [H1 H2].
      apply (IHre1 H1 _) in H4. invert H4.
      apply (IHre2 H2 _) in H5. invert H5. apply MNil.
    + apply andb_true_iff in H as [H1 H2].
      invert H0; [now apply (IHre1 H1 ) | now apply (IHre2 H2)].
    + invert H0.
      apply andb_true_iff in H as [H1 H2].
      now apply (IHre1 H1).
  - induction re; cbn in *; intros; try intuition;
    invert H0.
    + apply MStar0.
    + apply andb_true_iff in H as [H1 H2].
      rewrite <- (app_nil_r _).
      apply MCat; [apply (IHre1 H1) | apply (IHre2 H2)]; apply MNil.
    + apply andb_true_iff in H as [H1 H2].
      apply MAltL, (IHre1 H1 _), MNil.
    + apply andb_true_iff in H as [H1 H2].
      apply MAnd.
      * now apply IHre1, MNil.
      * now apply IHre2, MNil.
Qed.

Lemma is_nil_matches_nil : forall re,
  is_nil re = true -> matches_nil re = true.
Proof.
  induction re; cbn; intros; try discriminate; try reflexivity;
  apply andb_true_iff in H as [H1 H2];
  try (apply andb_true_iff; split); try (apply orb_true_iff; left);
  try apply IHre2, H2; apply IHre1, H1.
Qed.

Theorem matches_nil_true : forall re,
  matches_nil re = true <-> [] =~ re.
Proof.
  split.
  - induction re; cbn; intros; try discriminate.
    + apply MNil.
    + apply MStar0.
    + apply andb_true_iff in H as [H1 H2].
      rewrite <- (app_nil_r _). apply MCat.
      apply IHre1, H1. apply IHre2, H2.
    + apply orb_true_iff in H as [].
      apply MAltL, IHre1, H. apply MAltR, IHre2, H.
    + apply andb_true_iff in H as [H1 H2].
      apply MAnd.
      apply IHre1, H1. apply IHre2, H2.
  - induction re; cbn; intros; try reflexivity;
    try apply andb_true_iff; try apply orb_true_iff;
    invert H.
    + apply app_eq_nil in H0 as []. subst.
      split. now apply IHre1. now apply IHre2.
    + left. now apply IHre1.
    + right. now apply IHre2.
    + split. now apply IHre1. now apply IHre2.
Qed.

Theorem matches_nil_false : forall re,
  matches_nil re = false -> ~ ([] =~ re).
Proof.
  unfold not.
  induction re; cbn; intros; try discriminate;
  invert H0; try (apply app_eq_nil in H1 as []; subst);
  try apply andb_false_iff in H as [];
  try apply orb_false_iff in H as [];
  try (now apply IHre1); try (now apply IHre2).
Qed.

Lemma Void_not : forall s,
  ~ (s =~ Void).
Proof.
  unfold not. intros. inversion H. Qed.

Lemma Nil_nil : forall s,
  s =~ Nil <-> s = [].
Proof.
  split; intros. now invert H. subst. apply MNil. Qed.

Lemma Class0 : Class [] <=> Void.
Proof.
  split; intros; now invert H. Qed.

Lemma Class1 : forall c,
  Class [c] <=> Char c.
Proof.
  split; intros; invert H.
  - invert H2. apply MChar. invert H.
  - apply MClass, in_eq. Qed.

Lemma Class1_Alt : forall c cs,
  Class (c :: cs) <=> Alt (Char c) (Class cs).
Proof.
  split; intros; invert H; invert H2.
  - apply MAltL, MChar.
  - now apply MAltR, MClass.
  - apply MClass, in_eq.
  - now apply MClass, in_cons. Qed.

Lemma ClassN : forall cs,
  Class cs <=> fold_right (fun c => Alt (Char c)) Void cs.
Proof.
  split; intros;
  induction cs; cbn; try now invert H.
  - invert H. invert H2.
    + apply MAltL, MChar.
    + now apply MAltR, IHcs, MClass.
  - invert H.
    + now apply Class1_Alt, MAltL.
    + now apply Class1_Alt, MAltR, IHcs.
Qed.

Lemma Star1 : forall re s,
  s =~ re -> s =~ Star re.
Proof.
  intros. rewrite <- (app_nil_r _). now apply MStarApp, MStar0. Qed.

Lemma Star_Void : Star Void <=> Nil.
Proof.
  split; intros.
  - invert H. apply MNil. invert H1.
  - invert H. apply MStar0. Qed.

Lemma Star_Nil : Star Nil <=> Nil.
Proof.
  split; intros.
  - dependent induction H.
    + apply MNil.
    + invert H. now apply IHre_match2.
  - invert H. apply MStar0.
Qed.

Lemma Star_app : forall re s1 s2,
  s1 =~ Star re ->
  s2 =~ Star re ->
  s1 ++ s2 =~ Star re.
Proof.
  intros. dependent induction H; intros.
  - assumption.
  - rewrite <- app_assoc. now apply MStarApp, IHre_match2.
Qed.

Lemma Star_concat : forall re ss,
  (forall s, In s ss -> s =~ re) ->
  concat ss =~ Star re.
Proof.
  intros. induction ss.
  - apply MStar0.
  - cbn. apply MStarApp.
    + apply H. now left.
    + apply IHss. intros. apply H. now right.
Qed.

Lemma Star_split : forall re s,
  s =~ Star re ->
  exists ss,
    s = concat ss /\ forall s', In s' ss -> s' =~ re.
Proof.
  intros. dependent induction H.
  - exists []. split.
    + reflexivity.
    + intros. invert H.
  - assert (Star re = Star re) by reflexivity.
    apply IHre_match2 in H1 as [ss []]. subst.
    exists (s1 :: ss). split. reflexivity.
    intros. invert H1.
    + assumption.
    + apply H2, H3.
Qed.

Lemma Star_idemp : forall re,
  Star (Star re) <=> Star re.
Proof.
  split; intros.
  - dependent induction H.
    + apply MStar0.
    + now apply Star_app, IHre_match2.
  - dependent induction H.
    + apply MStar0.
    + apply MStarApp. now apply Star1. now apply IHre_match2.
Qed.

Lemma Star_Alt_Nil_l : forall re,
  Star (Alt Nil re) <=> Star re.
Proof.
  split; intros;
  dependent induction H; try apply MStar0.
  - invert H.
    + invert H3. now apply IHre_match2.
    + now apply MStarApp, IHre_match2.
  - apply MStarApp.
    + now apply MAltR.
    + now apply IHre_match2.
Qed.

Lemma Star_Alt_Nil_r : forall re,
  Star (Alt re Nil) <=> Star re.
Proof.
  split; intros;
  dependent induction H; try apply MStar0.
  - invert H.
    + now apply MStarApp, IHre_match2.
    + invert H3. now apply IHre_match2.
  - apply MStarApp.
    + now apply MAltL.
    + now apply IHre_match2.
Qed.

Lemma Cat_Void_l : forall re,
  Cat Void re <=> Void.
Proof.
  split; intros; invert H. invert H3. Qed.

Lemma Cat_Void_r : forall re,
  Cat re Void <=> Void.
Proof.
  split; intros; invert H. invert H4. Qed.

Lemma Cat_Nil_l : forall re,
  Cat Nil re <=> re.
Proof.
  split; intros.
  - invert H. now invert H3.
  - rewrite <- (app_nil_l _). apply MCat. apply MNil. assumption. Qed.

Lemma Cat_Nil_r : forall re,
  Cat re Nil <=> re.
Proof.
  split; intros.
  - invert H. invert H4. now rewrite app_nil_r.
  - rewrite <- (app_nil_r _). now apply MCat, MNil. Qed.

Lemma Cat_Char_l : forall re c s,
  c :: s =~ Cat (Char c) re <-> s =~ re.
Proof.
  split; intros.
  - invert H. invert H3. now invert H0.
  - replace (c :: s) with ([c] ++ s) by reflexivity.
    apply MCat. apply MChar. assumption. Qed.

Lemma Cat_Char_r : forall re c s,
  s ++ [c] =~ Cat re (Char c) <-> s =~ re.
Proof.
  split; intros.
  - invert H. invert H4. apply app_inv_tail_iff in H0. now subst.
  - now apply MCat, MChar. Qed.

Lemma Cat_Class_l : forall re c cs s,
  In c cs ->
  c :: s =~ Cat (Class cs) re <-> s =~ re.
Proof.
  split; intros.
  - invert H0. invert H4. now invert H1.
  - replace (c :: s) with ([c] ++ s) by reflexivity.
    apply MCat. now apply MClass. assumption. Qed.

Lemma Cat_Class_r : forall re c cs s,
  In c cs ->
  s ++ [c] =~ Cat re (Class cs) <-> s =~ re.
Proof.
  split; intros.
  - invert H0. invert H5. apply app_inj_tail_iff in H1 as []. now subst.
  - now apply MCat, MClass. Qed.

Lemma Cat_Star : forall re,
  Cat (Star re) (Star re) <=> Star re.
Proof.
  split; intros.
  - invert H. now apply Star_app.
  - rewrite <- (app_nil_r _). now apply MCat, MStar0. Qed.

Lemma Cat_Alt_distr_l : forall re1 re2 re3,
  Cat re1 (Alt re2 re3) <=> Alt (Cat re1 re2) (Cat re1 re3).
Proof.
  split; intros.
  - invert H; invert H4. now apply MAltL, MCat. now apply MAltR, MCat.
  - invert H; invert H2. now apply MCat, MAltL. now apply MCat, MAltR.
Qed.

Lemma Cat_Alt_distr_r : forall re1 re2 re3,
  Cat (Alt re1 re2) re3 <=> Alt (Cat re1 re3) (Cat re2 re3).
Proof.
  split; intros.
  - invert H; invert H3. now apply MAltL, MCat. now apply MAltR, MCat.
  - invert H; invert H2; apply MCat; try assumption.
    now apply MAltL. now apply MAltR.
Qed.

Lemma Cat_And_distr_l : forall re1 re2 re3 s,
  s =~ Cat re1 (And re2 re3) -> s =~ And (Cat re1 re2) (Cat re1 re3).
Proof.
  intros. invert H. invert H4. apply MAnd; now apply MCat. Qed.

Lemma Cat_And_distr_r : forall re1 re2 re3 s,
  s =~ Cat (And re1 re2) re3 -> s =~ And (Cat re1 re3) (Cat re2 re3).
Proof.
  intros. invert H. invert H3. apply MAnd; now apply MCat. Qed.

Lemma Cat_nil : forall re1 re2,
  [] =~ Cat re1 re2 <-> [] =~ re1 /\ [] =~ re2.
Proof.
  split; intros.
  - split; invert H; apply app_eq_nil in H0 as []; now subst.
  - invert H. rewrite <- (app_nil_r _). now apply MCat. Qed.

Lemma Alt_or : forall re1 re2 s,
  s =~ Alt re1 re2 <-> s =~ re1 \/ s =~ re2.
Proof.
  split; intros.
  - invert H; [left | right]; assumption.
  - destruct H; [apply MAltL | apply MAltR]; assumption. Qed.

Lemma Alt_comm : forall re1 re2,
  Alt re1 re2 <=> Alt re2 re1.
Proof.
  split; intros; (invert H; [now apply MAltR | now apply MAltL]). Qed.

Lemma Alt_assoc : forall re1 re2 re3,
  Alt re1 (Alt re2 re3) <=> Alt (Alt re1 re2) re3.
Proof.
  split; intros.
  - invert H. now apply MAltL, MAltL.
    invert H2. now apply MAltL, MAltR. now apply MAltR.
  - invert H. invert H2. now apply MAltL.
    now apply MAltR, MAltL. now apply MAltR, MAltR.
Qed.

Lemma Alt_Void_l : forall re,
  Alt Void re <=> re.
Proof.
  split; intros. now invert H. now apply MAltR. Qed.

Lemma Alt_Void_r : forall re,
  Alt re Void <=> re.
Proof.
  intros. now rewrite Alt_comm, Alt_Void_l. Qed.

Lemma Alt_Nil_l : forall re,
  matches_nil re = true -> Alt Nil re <=> re.
Proof.
  split; intros.
  - invert H0. invert H3. now apply matches_nil_true. assumption.
  - now apply MAltR. Qed.

Lemma Alt_Nil_r : forall re,
  matches_nil re = true -> Alt re Nil <=> re.
Proof.
  intros. now rewrite Alt_comm, Alt_Nil_l. Qed.

Lemma Alt_Class : forall cs1 cs2,
  Alt (Class cs1) (Class cs2) <=> Class (cs1 ++ cs2).
Proof.
  split; intros.
  - invert H; invert H2;
    apply MClass; apply in_app_iff; [now left | now right].
  - invert H; apply in_app_iff in H2 as [];
    [apply MAltL | apply MAltR]; now apply MClass.
Qed.

Lemma And_comm : forall re1 re2,
  And re1 re2 <=> And re2 re1.
Proof.
  split; intros; invert H; now apply MAnd. Qed.

Lemma And_assoc : forall re1 re2 re3,
  And re1 (And re2 re3) <=> And (And re1 re2) re3.
Proof.
  split; intros.
  - invert H. invert H4. repeat apply MAnd; assumption.
  - invert H. invert H3. repeat apply MAnd; assumption. Qed.

Lemma And_Void_l : forall re,
  And Void re <=> Void.
Proof.
  split; intros. now invert H. now apply MAnd. Qed.

Lemma And_Void_r : forall re,
  And re Void <=> Void.
Proof.
  intros. now rewrite And_comm, And_Void_l. Qed.

Lemma And_Nil_true_l : forall re,
  matches_nil re = true -> And Nil re <=> Nil.
Proof.
  split; intros.
  - invert H0. invert H4. apply MNil.
  - invert H0. apply MAnd. apply MNil. now apply matches_nil_true in H. Qed.

Lemma And_Nil_true_r : forall re,
  matches_nil re = true -> And re Nil <=> Nil.
Proof.
  intros. now rewrite And_comm, And_Nil_true_l. Qed.

Lemma And_Nil_false_l : forall re,
  matches_nil re = false -> And Nil re <=> Void.
Proof.
  split; intros.
  - invert H0. invert H4. exfalso. now apply (matches_nil_false _ H).
  - invert H0. Qed.

Lemma And_Nil_false_r : forall re,
  matches_nil re = false -> And re Nil <=> Void.
Proof.
  intros. now rewrite And_comm, And_Nil_false_l. Qed.

Lemma And_Alt_distr_l : forall re1 re2 re3,
  And re1 (Alt re2 re3) <=> Alt (And re1 re2) (And re1 re3).
Proof.
  split; intros.
  - invert H. invert H4. now apply MAltL, MAnd. now apply MAltR, MAnd.
  - invert H; invert H2. now apply MAnd, MAltL. now apply MAnd, MAltR.
Qed.

Lemma And_Alt_distr_r : forall re1 re2 re3,
  And (Alt re1 re2) re3 <=> Alt (And re1 re3) (And re2 re3).
Proof.
  split; intros.
  - invert H. invert H3. now apply MAltL, MAnd. now apply MAltR, MAnd.
  - invert H; invert H2; apply MAnd; try assumption.
    now apply MAltL. now apply MAltR.
Qed.

Lemma str_matches_regexp_of_str : forall s s',
  s' =~ regexp_of_string s <-> s' = list_ascii_of_string s.
Proof.
  split; generalize dependent s'.
  - induction s; intros.
    + now invert H.
    + destruct s.
      * now invert H.
      * invert H. invert H3. cbn. f_equal. now apply IHs.
  - induction s; intros; subst.
    + apply MNil.
    + destruct s.
      * apply MChar.
      * cbn. now apply Cat_Char_l, IHs.
Qed.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import Ics WaterTank.

Module Parameters.
  Definition tankMax := 100.
  Definition sensorAccuracy := 5.

  Theorem sensorAccuracy_positive : 0 <= sensorAccuracy.
  Proof.
    unfold sensorAccuracy; omega.
  Qed.

  Definition fillRate := 3.
  Definition emptyRate := 2.

  Definition minFill := 1.
  Definition maxFill := 3.
  Definition minEmpty := 1.
  Definition maxEmpty := 2.

  Theorem fillBounds : minFill <= maxFill.
  Proof.
    unfold minFill, maxFill; omega.
  Qed.

  Theorem emptyBounds : minEmpty <= maxEmpty.
  Proof.
    unfold minEmpty, maxEmpty; omega.
  Qed.
End Parameters.

Module D := Deterministic(Parameters).
Module N := Nondeterministic(Parameters).

(** Let's take the extra step to OCaml code via extraction. *)

Module Det.
  Import D.

  Definition new : Z -> cRep impl'.
    extractConstructor impl' "new".
  Defined.

  Definition update : cRep impl' -> Z -> cRep impl' * unit.
    extractMethod impl' "update".
  Defined.

  Definition timestep : cRep impl' -> Z -> cRep impl' * action.
    extractMethod impl' "timestep".
  Defined.
End Det.

Module Nondet.
  Import N.

  Definition new : Z -> cRep impl'.
    extractConstructor impl' "new".
  Defined.

  Definition update : cRep impl' -> Z -> cRep impl' * unit.
    extractMethod impl' "update".
  Defined.

  Definition timestep : cRep impl' -> request -> cRep impl' * action.
    extractMethod impl' "timestep".
  Defined.
End Nondet.

Recursive Extraction Det Nondet.


Require Import List.

Theorem app_cons_not_nil : forall A (x y:list A) (a:A), nil <> x ++ a :: y.
Proof.
  unfold not.
  intros.
  induction x.
    discriminate H.

    discriminate H.
Qed.