From Coq Require Import Strings.String.
From Coq Require Import Lists.List.
Import ListNotations.
From FY Require Export Utils.
From FY Require Export Syntax.
From FY Require Export Semantics.
From FY Require Export Assertion.
From FY Require Export Logic.

Inductive derivable:
    nat -> nat ->
    Assertion 1 -> com -> Assertion 1 -> Type :=
  | H_Skip : forall n (P: Assertion n),
    derivable n n P <{ skip }> P
  | H_App : forall n G (P: Assertion n) m,
    derivable n n (apply_sub n m (geval G) (is1 G) P) <{ q m *= G }> P
  | H_Init : forall n (P: Assertion n),
    derivable (n - 1)%nat n (init_sub n P) <{ new_qubit }> P
  | H_Asgn : forall n (P: Assertion n) x e,
    derivable n n (AssertPreAsgn P x e) <{ x := e }> P
  | H_Meas_0 : forall n m (P: Assertion n) x,
    derivable n n (AssertPreMeas P x 0 m) <{ x :=meas m }> P
  | H_Meas_1 : forall n m (P: Assertion n) x,
    derivable n n (AssertPreMeas P x 1 m) <{ x :=meas m }> P
  | H_Seq : forall np nq nr (P: Assertion np) c
                   (Q: Assertion nq) d (R: Assertion nr),
    derivable np nq P c Q ->
    derivable nq nr Q d R ->
    derivable np nr P <{ c;d }> R
  | H_If : forall np nq (P: Assertion np)
                  (Q: Assertion nq) b c1 c2,
    derivable np nq (AssertPreIfTrue P b) c1 Q ->
    derivable np nq (AssertPreIfTrue P (BNot b)) c2 Q ->
    derivable np nq P <{if b then c1 else c2 end}> Q
  | H_While : forall n (P: Assertion n) b c,
    derivable n n (AssertPreIfTrue P b) c P ->
    derivable n n P <{while b do c end}> (AssertPreIfTrue P (BNot b))
  | H_Weakness : forall np nq np' nq'
         (P: Assertion np) (Q: Assertion nq)
         (P': Assertion np') (Q': Assertion nq') c,
    derivable np nq P c Q ->
    (forall ns (st: State ns), weaker ns np np' st P' P) ->
    (forall ns (st: State ns), weaker ns nq nq' st Q Q') ->
    derivable np' nq' P' c Q'.

Definition valid {np nq} (P : Assertion np) (c : com) (Q : Assertion nq)
      : Prop :=
  forall ns1 ns2  (st1: State ns1) (st2: State ns2),
  (ceval ns1 ns2 c st1 st2) ->
  (Expectation ns1 np st1 P) <= (Expectation ns2 nq st2 Q).

Theorem logic_sound : forall np nq (P: Assertion np) c (Q: Assertion nq),
  derivable np nq P c Q -> valid P c Q.
Proof.
  intros.
  case_eq X.
  - intros. induction X; apply fy_skip.
  - intros. induction X; apply fy_apply.
  - intros. induction X; apply fy_init.
  - intros. induction X; apply fy_assign.
  - intros. induction X; apply fy_measure.
  - intros. induction X; apply fy_measure.
  - intros. induction X. apply fy_sequence with nq0 Q0.
    induction d0. apply fy_skip. apply fy_apply.
    apply fy_init. apply fy_assign. apply fy_measure. apply fy_measure.
Admitted.

Theorem logic_complete: forall np nq (P: Assertion np) c (Q: Assertion nq),
  valid P c Q -> derivable np nq P c Q.
Proof.
Admitted.


Require Import util Aid.
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Import Coq.Logic.FunctionalExtensionality.

(*定义五元组来表示系统状态*)

(*Sv, Sb, Sf*)
Definition storeV := id -> nat.
Definition storeB := id -> nat.
Definition storeF := id -> list nat.

(*Hv,Hb因为可能对应不到值,所以用可选类型*)
Definition heapV := nat -> option nat.
Definition heapB := nat -> option (list (option nat)).

(*定义空堆*)
Definition emp_heapV : heapV :=
  fun (n: nat) => None.

Definition emp_heapB : heapB :=
  fun (n: nat) => None.

(*定义命题 : 在堆的定义域中*)
Definition in_domV (loc: nat) (hv: heapV) : Prop :=
  exists n, hv loc = Some n.

Definition in_domB (bloc: nat) (hb: heapB) : Prop :=
  exists l, hb bloc = Some l.

(*定义命题 : 不在堆的定义域中*)
Definition not_in_domV (loc: nat) (hv: heapV) : Prop :=
  hv loc = None.

Definition not_in_domB (bloc: nat) (hb: heapB) : Prop :=
  hb bloc = None.

(*在定义域的(Some n) + 不在定义域的(None) 为全集*)
Theorem in_not_in_dec_V :
  forall l h, {in_domV l h} + {not_in_domV l h}.
Proof.
  intros l h.
  unfold in_domV, not_in_domV.
  destruct (h l).
  - left. exists n. auto.
  - right. auto.
Qed.

Theorem in_not_in_dec_B :
  forall l h, {in_domB l h} + {not_in_domB l h}.
Proof.
  intros l h.
  unfold in_domB, not_in_domB.
  destruct (h l).
  - left. exists l0. auto.
  - right. auto.
Qed.

(*定义命题:两堆不相交*)
Definition disjointV (h1 h2: heapV) : Prop :=
  forall l, not_in_domV l h1 \/ not_in_domV l h2.

Definition disjointB (h1 h2: heapB) : Prop :=
  forall l, not_in_domB l h1 \/ not_in_domB l h2.

(*heap1 析取 heap2*)
Definition h_unionV (h1 h2: heapV) : heapV :=
  fun l =>
    if (in_not_in_dec_V l h1) then h1 l else h2 l.

Definition h_unionB (h1 h2: heapB) : heapB :=
  fun l =>
    if (in_not_in_dec_B l h1) then h1 l else h2 l.

(* h1 is a subset of h2 *)
Definition h_subsetV (h1 h2: heapV) : Prop :=
  forall loc n, h1 loc = Some n -> h2 loc = Some n.

Definition h_subsetB (h1 h2: heapB) : Prop :=
  forall bloc l, h1 bloc = Some l -> h2 bloc = Some l.

(* store update *)
Definition sV_update (s: storeV) (x: id) (n: nat) : storeV :=
  fun x' => if beq_id x x' then n else s x'.

Definition sB_update (s: storeB) (x: id) (n: nat) : storeB :=
  fun x' => if beq_id x x' then n else s x'.

Definition sF_update (s: storeF) (x: id) (nli: list nat) : storeF :=
  fun x' => if beq_id x x' then nli else s x'.

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

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

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

(* heap update *)
Definition hV_update (h: heapV) (loc: nat) (n: nat) : heapV :=
  fun loc' => if beq_nat loc loc' then Some n else h loc'.

Definition hB_update (h: heapB) (bloc: nat) (l: list (option nat)) : heapB :=
  fun bloc' => if beq_nat bloc bloc' then Some l else h bloc'.

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

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

(* heap remove *)
Definition hV_remove (h:heapV) (l:nat) : heapV :=
fun x => if beq_nat x l then None else h x.

Definition hB_remove (h:heapB) (l:nat) : heapB :=
fun x => if beq_nat x l then None else h x.

(****Some Lemma****)
Lemma sV_update_eq : forall storeV x v,
   (x !sv-> v ; storeV) x = v.
Proof.
  intros.
  unfold sV_update.
  rewrite beq_id_refl.
  reflexivity.
Qed.

Lemma sB_update_eq : forall storeB x v,
   (x !sb-> v ; storeB) x = v.
Proof.
  intros.
  unfold sB_update.
  rewrite beq_id_refl.
  reflexivity.
Qed.

Theorem sB_update_neq :forall sB x1 x2 v,
   x1 <> x2
->(x2 !sb-> v ; sB) x1 = sB x1.
Proof.
  intros.
  unfold sB_update.
  apply beq_neq_id in H.
  rewrite beq_comm_id in H.
  rewrite H.
  reflexivity.
Qed.

Lemma sF_update_eq : forall storeF x v,
   (x !sf-> v ; storeF) x = v.
Proof.
  intros.
  unfold sF_update.
  rewrite beq_id_refl.
  reflexivity.
Qed.

Theorem sF_update_neq :forall sF x1 x2 v,
   x1 <> x2
->(x2 !sf-> v ; sF) x1 = sF x1.
Proof.
  intros.
  unfold sF_update.
  apply beq_neq_id in H.
  rewrite beq_comm_id in H.
  rewrite H.
  reflexivity.
Qed.

Lemma hV_update_eq : forall heapV x v,
   (x !hv-> v ; heapV) x = Some v.
Proof.
  intros.
  unfold hV_update.
  rewrite <- beq_nat_refl.
  reflexivity.
Qed.

Lemma hB_update_eq : forall heapB x v,
   (x !hb-> v ; heapB) x = Some v.
Proof.
  intros.
  unfold hB_update.
  rewrite <- beq_nat_refl.
  reflexivity.
Qed.

Theorem hB_update_neq :forall hB x1 x2 v,
   x1 <> x2
->(x2 !hb-> v ; hB) x1 = hB x1.
Proof.
  intros.
  unfold hB_update.
  apply beq_neq in H.
  rewrite beq_comm in H.
  rewrite H.
  reflexivity.
Qed.

Lemma sV_update_shadow : forall storeV x v1 v2,
  (x !sv-> v2 ; x !sv-> v1 ; storeV) = (x !sv-> v2; storeV).
Proof.
  intros.
  apply functional_extensionality.
  intros.
  unfold sV_update.
  destruct (beq_id x x0) eqn:H.
  trivial. trivial.
Qed.

Lemma sB_update_shadow : forall storeB x v1 v2,
  (x !sb-> v2 ; x !sb-> v1 ; storeB) = (x !sb-> v2; storeB).
Proof.
  intros.
  apply functional_extensionality.
  intros.
  unfold sB_update.
  destruct (beq_id x x0) eqn:H.
  trivial. trivial.
Qed.

Lemma sB_update_shadow_3 : forall storeB x y v1 v2 v3,
  (x !sb-> v2 ; y !sb-> v1 ; x !sb-> v3 ;storeB)
= (x !sb-> v2; y !sb-> v1; storeB).
Proof.
  intros.
  apply functional_extensionality.
  intros.
  unfold sB_update.
  destruct (beq_id x x0) eqn:H.
  trivial. trivial.
Qed.

Lemma sV_update_shadow_2 : forall storeV x y v1 v2 v3,
  (x !sv-> v2 ; y !sv-> v1 ; x !sv-> v3 ;storeV)
= (x !sv-> v2; y !sv-> v1; storeV).
Proof.
  intros.
  apply functional_extensionality.
  intros.
  unfold sV_update.
  destruct (beq_id x x0) eqn:H.
  trivial. trivial.
Qed.

Lemma sV_update_shadow_3 : forall storeV x y z v1 v2 v3 v4,
  (x !sv-> v2 ; y !sv-> v1 ; z !sv-> v4 ; x !sv-> v3 ;storeV)
= (x !sv-> v2; y !sv-> v1 ; z !sv-> v4 ; storeV).
Proof.
  intros.
  apply functional_extensionality.
  intros.
  unfold sV_update.
  destruct (beq_id x x0) eqn:H.
  trivial. trivial.
Qed.

Lemma sF_update_shadow : forall storeF x v1 v2,
  (x !sf-> v2 ; x !sf-> v1 ; storeF) = (x !sf-> v2; storeF).
Proof.
  intros.
  apply functional_extensionality.
  intros.
  unfold sF_update.
  destruct (beq_id x x0) eqn:H.
  trivial. trivial.
Qed.

Lemma sF_update_shadow_3 : forall storeF x y v1 v2 v3,
  (x !sf-> v2 ; y !sf-> v1 ; x !sf-> v3 ;storeF)
= (x !sf-> v2; y !sf-> v1; storeF).
Proof.
  intros.
  apply functional_extensionality.
  intros.
  unfold sF_update.
  destruct (beq_id x x0) eqn:H.
  trivial. trivial.
Qed.

Lemma hV_update_shadow : forall heapV x v1 v2,
  (x !hv-> v2 ; x !hv-> v1 ; heapV) = (x !hv-> v2; heapV).
Proof.
  intros.
  apply functional_extensionality.
  intros.
  unfold hV_update.
  destruct (beq_nat x x0) eqn:H.
  trivial. trivial.
Qed.

Lemma hB_update_shadow : forall heapB x v1 v2,
  (x !hb-> v2 ; x !hb-> v1 ; heapB) = (x !hb-> v2; heapB).
Proof.
  intros.
  apply functional_extensionality.
  intros.
  unfold hB_update.
  destruct (beq_nat x x0) eqn:H.
  trivial. trivial.
Qed.

Lemma hB_remove_neq : forall hB x1 x2 v,
   x1 <> x2
-> hB_remove (x2 !hb-> v;hB) x1
   = (x2 !hb-> v; hB_remove hB x1).
Proof.
  intros.
  apply functional_extensionality.
  intros.
  unfold hB_remove.
  destruct (beq_nat x x1) eqn:H1.
  + rewrite beq_eq in H1.
    rewrite H1,hB_update_neq.
    rewrite <- beq_refl.
    trivial. trivial.
  + destruct (beq_nat x x2) eqn:H2.
    - rewrite beq_eq in H2. subst.
      repeat rewrite hB_update_eq. trivial.
    - rewrite beq_neq in H2.
      repeat rewrite hB_update_neq; trivial.
      rewrite H1.
      trivial.
Qed.

(* Lemma hB_remove_eq : forall hB x1 x2 v,
   x1 <> x2
-> (hB_remove (x2 !hb-> v;hB) x1) x2 = Some v.
Proof.
  intros.
  unfold hB_remove.
  apply neq_comm in H.
  rewrite <- beq_neq in H.
  rewrite H.
  apply hB_update_eq.
Qed.

Lemma hB_remove_neq : forall hB x1 x2 x3 v,
   x1 <> x2 -> x3 <> x2
-> (hB_remove (x1 !hb-> v;hB) x3) x2
   = (hB_remove hB x3) x2.
Proof.
  intros.
  unfold hB_remove.
  apply neq_comm in H0.
  rewrite <- beq_neq in H0.
  rewrite H0.
  apply hB_update_neq.
  auto.
Qed. *)

Lemma hB_remove_emp : forall x,
  hB_remove emp_heapB x = emp_heapB.
Proof.
  intros.
  apply functional_extensionality.
  intros.
  unfold hB_remove.
  destruct (beq_nat x0 x) eqn:H1;
  trivial.
Qed.

Lemma hB_remove_work : forall hB x v,
   not_in_domB x hB
-> hB_remove (x !hb-> v;hB) x = hB.
Proof.
  intros.
  apply functional_extensionality.
  intros.
  unfold hB_remove.
  destruct (beq_nat x0 x) eqn:H1.
  - rewrite beq_eq in H1. subst. auto.
  - rewrite beq_neq in H1.
    rewrite hB_update_neq; auto.
Qed.

(*定义五元组*)
Definition state : Type := (storeV * storeB * storeF * heapV * heapB).

(*定义状态转换*)
Inductive ext_state : Type :=
|  St: state -> ext_state    (* normal state *)
| Abt: ext_state.            (* abort *)


Require Import FP.Core.
Require Import FP.Data.Unit.

Class Monad (m:qtype -> qtype) :=
  { ret : forall {A}, dom (A ⇒ m A)
  ; bind : forall {A B}, dom (m A ⇒ (A ⇒ m B) ⇒ m B)
  ; bind_ret_kon : forall {A} (aM:dom (m A)), bind ∙ aM ∙ ret ≃  aM
  ; bind_ret_arg : forall {A B} (a:dom A) (k:dom (A ⇒ m B)), bind ∙ (ret ∙ a) ∙ k ≃ k ∙ a
  ; bind_associativity : forall {A B C} (aM:dom (m A)) (k₁:dom (A ⇒ m B)) (k₂:dom (B ⇒ m C)),
      bind ∙ (bind ∙ aM ∙ k₁) ∙ k₂ ≃ bind ∙ aM ∙ (λ a → bind ∙ (k₁ ∙ a) ∙ k₂)
  }.
Global Opaque ret.
Global Opaque bind.

Notation "e >>= k" := (bind ∙ e ∙ k).
Notation "x ← e₁  ;; e₂" := (bind ∙ e₁ ∙ (λ x → e₂)).

Ltac MonadRewrite :=
  match goal with
  | |- ⟨ ?aM >>= ret IN _ |_| _ ⟩ => ReplaceBy (bind_ret_kon aM)
  | |- ⟨ ret ∙ ?a >>= ?k IN _ |_| _ ⟩ => ReplaceBy (bind_ret_arg a k)
  | |- ⟨ bind ∙ (bind ∙ ?aM ∙ ?k₁) ∙ ?k₂ IN _ |_| _ ⟩ => ReplaceBy (bind_associativity aM k₁ k₂)
  end.

Section Monad.
  Context {m} `{! Monad m }.

  Definition extend {A B} : dom ((A ⇒ m B) ⇒ (m A ⇒ m B)) := λ f aM → bind ∙ aM ∙ f.

  Definition mcompose {A B C} : dom ((B ⇒ m C) ⇒ (A ⇒ m B) ⇒ (A ⇒ m C)) := λ g f a →
    bind ∙ (f ∙ a) ∙ g.
  Definition mmap {A B} : dom ((A ⇒ B) ⇒ (m A ⇒ m B)) := λ f aM →
    a ← aM ;;
    ret $ f ∙ a.

  Definition seq {A B} : dom (m A ⇒ m B ⇒ m B) := λ aM bM → _ ← aM ;; bM.

  Definition kret {A B} : dom ((A ⇒ B) ⇒ (A ⇒ m B)) := λ f → ret ⊙ f.
End Monad.
Notation "k =<< e" := (extend ∙ k ∙ e).
Notation "g m⊙ f" := (mcompose ∙ g ∙ f).
Notation "e₁  ;; e₂" := (_ ← e₁ ;; e₂).

Section Laws.
  Context {m} `{! Monad m }.

  Definition mcompose_associativity {A B C D}
  (h:dom (C ⇒ m D)) (g:dom (B ⇒ m C)) (f:dom (A ⇒ m B)) : ((h m⊙ g) m⊙ f) ≃ (h m⊙ (g m⊙ f)).
  Proof.
    Re fail || MonadRewrite.
  Qed.

  Definition mcompose_left_unit {A B} (f:dom (A ⇒ m B)) : (ret m⊙ f) ≃ f.
  Proof.
    Re fail || MonadRewrite.
  Qed.

  Definition mcompose_right_unit {A B} (f:dom (A ⇒ m B)) : (f m⊙ ret) ≃ f.
  Proof.
    Re fail || MonadRewrite.
  Qed.
End Laws.

Ltac KleisliRewrite :=
  match goal with
  | |- ⟨ (?h m⊙ ?g) m⊙ ?f IN _ |_| _ ⟩ => ReplaceBy (mcompose_associativity h g f)
  | |- ⟨ ret m⊙ ?f IN _ |_| _ ⟩ => ReplaceBy (mcompose_left_unit f)
  | |- ⟨ ?f m⊙ ret IN _ |_| _ ⟩ => ReplaceBy (mcompose_right_unit f)
  end.

Ltac KleisliUnassoc :=
  match goal with
  | |- ⟨ ?h m⊙ ?g m⊙ ?f IN _ |_| _ ⟩ => ReplaceBy (symmetry (mcompose_associativity h g f))
  end.

Class MonadPlus m `{! Monad m } :=
  { mzero : forall {A}, dom (m A)
  ; mplus : forall {A}, dom (m A ⇒ m A ⇒ m A)
  ; mplus_mzero_left : forall {A} (aM:dom (m A)), mplus ∙ mzero ∙ aM ≃ aM
  ; mplus_mzero_right : forall {A} (aM:dom (m A)), mplus ∙ aM ∙ mzero ≃ aM
  ; mplus_distributivity : forall {A B} (aM₁ aM₂:dom (m A)) (k:dom (A ⇒ m B)),
      bind ∙ (mplus ∙ aM₁ ∙ aM₂) ∙ k ≃ mplus ∙ (bind ∙ aM₁ ∙ k) ∙ (bind ∙ aM₂ ∙ k)
  ; bind_mzero_left : forall {A B} (k:dom (A ⇒ m B)), bind ∙ mzero ∙ k ≃ mzero
  ; bind_mzero_right : forall {A B} (aM:dom (m A)), bind ∙ aM ∙ (λ _ → mzero (A:=B)) ≃ mzero
  }.
Ltac MonadPlusRewrite :=
  match goal with
  | |- ⟨ mzero >>= ?k IN _ |_| _ ⟩ => ReplaceBy (bind_mzero_left k)
  end.

Notation "e₁ m+ e₂" := (mplus ∙ e₁ ∙ e₂).

Class MonadMorphism m₁ m₂ `{! Monad m₁ ,! Monad m₁ } :=
  { promote : forall {A}, dom (m₁ A ⇒ m₂ A) }.

Class MonadState S m `{! Monad m } :=
  { get : dom (m S)
  ; put : dom (S ⇒ m unit)
  }.

Class MonadRet t :=
  { mret : forall {m} `{! Monad m }, forall {A}, dom (m A ⇒ t m A)
  }.
Global Opaque mret.


From Cat Require Import Cat.
From Cat.Universal Require Import Initial Terminal Product Equalizer.

Set Implicit Arguments.

Class isPullback
  (C : Cat) {A B X : Ob C} (f : Hom A X) (g : Hom B X)
  (P : Ob C) (pullL : Hom P A) (pullR : Hom P B)
  (triple : forall {Γ : Ob C} (a : Hom Γ A) (b : Hom Γ B), a .> f == b .> g -> Hom Γ P)
  : Prop :=
{
  ok : pullL .> f == pullR .> g;
  triple_pullL :
    forall (Γ : Ob C) (a : Hom Γ A) (b : Hom Γ B) (H : a .> f == b .> g),
      triple a b H .> pullL == a;
  triple_pullR :
    forall (Γ : Ob C) (a : Hom Γ A) (b : Hom Γ B) (H : a .> f == b .> g),
      triple a b H .> pullR == b;
  equiv_pullback :
    forall (Γ : Ob C) (x y : Hom Γ P),
      x .> pullL == y .> pullL -> x .> pullR == y .> pullR -> x == y;
}.

#[export] Hint Mode isPullback ! ! ! ! ! ! ! ! ! ! : core.
#[export] Hint Mode isPullback ! ! ! ! ! - - - - - : core.

Lemma equiv_pullback' :
  forall
    {C : Cat} {A B X : Ob C} {f : Hom A X} {g : Hom B X}
    {P : Ob C} {pullL : Hom P A} {pullR : Hom P B}
    {triple : forall {Γ : Ob C} (a : Hom Γ A) (b : Hom Γ B), a .> f == b .> g -> Hom Γ P}
    {isP : isPullback C f g P pullL pullR (@triple)}
    {Γ : Ob C} (x y : Hom Γ P),
      x == y <-> x .> pullL == y .> pullL /\ x .> pullR == y .> pullR.
Proof.
  split.
  - now intros ->.
  - now intros []; apply equiv_pullback.
Qed.

Section isPullback.

Context
  {C : Cat} {A B X : Ob C} {f : Hom A X} {g : Hom B X}
  {P : Ob C} {pullL : Hom P A} {pullR : Hom P B}
  {triple : forall {Γ : Ob C} (a : Hom Γ A) (b : Hom Γ B), a .> f == b .> g -> Hom Γ P}
  {isP : isPullback C f g P pullL pullR (@triple)}
  [Γ : Ob C] [a : Hom Γ A] [b : Hom Γ B] [H : a .> f == b .> g].

Arguments triple {Γ} _ _.

Lemma triple_universal :
  forall h : Hom Γ P,
    triple a b H == h <-> a == h .> pullL /\ b == h .> pullR.
Proof.
  now intros; rewrite equiv_pullback', triple_pullL, triple_pullR.
Qed.

Lemma triple_unique :
  forall h : Hom Γ P,
    h .> pullL == a -> h .> pullR == b -> h == triple a b H.
Proof.
  now intros; rewrite equiv_pullback', triple_pullL, triple_pullR.
Qed.

Lemma triple_ok :
  triple pullL pullR ok == id P.
Proof.
  now rewrite equiv_pullback', triple_pullL, triple_pullR, !comp_id_l.
Qed.

Lemma comp_triple :
  forall {Y : Ob C} {h : Hom Y Γ},
    h .> triple a b H == triple (h .> a) (h .> b) (wut_l h H).
Proof.
  now intros; rewrite equiv_pullback', !comp_assoc, !triple_pullL, !triple_pullR.
Qed.

End isPullback.

Ltac pullback_simpl :=
  repeat (rewrite
    ?comp_triple, ?equiv_pullback', ?triple_pullL, ?triple_pullR, ?triple_ok,
    ?comp_id_l, ?comp_id_r, ?comp_assoc).

Lemma isPullback_uiso :
  forall
    (C : Cat) (A B X : Ob C) (f : Hom A X) (g : Hom B X)
    (P1 : Ob C) (pullL1 : Hom P1 A) (pullR1 : Hom P1 B)
    (triple1 : forall (Γ : Ob C) (a : Hom Γ A) (b : Hom Γ B), a .> f == b .> g -> Hom Γ P1)
    (P2 : Ob C) (pullL2 : Hom P2 A) (pullR2 : Hom P2 B)
    (triple2 : forall (Γ : Ob C) (a : Hom Γ A) (b : Hom Γ B), a .> f == b .> g -> Hom Γ P2),
      isPullback C f g P1 pullL1 pullR1 triple1 ->
      isPullback C f g P2 pullL2 pullR2 triple2 ->
        exists!! f : Hom P1 P2, isIso f /\ f .> pullL2 == pullL1 /\ f .> pullR2 == pullR1.
Proof.
  intros * H1 H2.
  exists (triple2 _ pullL1 pullR1 ok).
  repeat split.
  - exists (triple1 P2 pullL2 pullR2 ok).
    now rewrite !equiv_pullback', !comp_assoc, !triple_pullL, !triple_pullR, !comp_id_l.
  - now rewrite triple_pullL.
  - now rewrite triple_pullR.
  - intros u (HIso & Heql & Heqr).
    now rewrite equiv_pullback', triple_pullL, triple_pullR.
Qed.

Lemma isPullback_iso :
  forall
    (C : Cat) (A B X : Ob C) (f : Hom A X) (g : Hom B X)
    (P1 : Ob C) (pullL1 : Hom P1 A) (pullR1 : Hom P1 B)
    (triple1 : forall (Γ : Ob C) (a : Hom Γ A) (b : Hom Γ B), a .> f == b .> g -> Hom Γ P1)
    (P2 : Ob C) (pullL2 : Hom P2 A) (pullR2 : Hom P2 B)
    (triple2 : forall (Γ : Ob C) (a : Hom Γ A) (b : Hom Γ B), a .> f == b .> g -> Hom Γ P2),
      isPullback C f g P1 pullL1 pullR1 triple1 ->
      isPullback C f g P2 pullL2 pullR2 triple2 ->
        P1 ~ P2.
Proof.
  now intros * H1 H2; destruct (isPullback_uiso H1 H2) as [i []]; exists i.
Qed.

Section Pullback_lemmas.

Context
  {C : Cat} {A B X : Ob C} {f : Hom A X} {g : Hom B X}
  {P : Ob C} {pullL : Hom P A} {pullR : Hom P B}
  {triple : forall {Γ : Ob C} (a : Hom Γ A) (b : Hom Γ B), a .> f == b .> g -> Hom Γ P}
  {HisP : isPullback C f g P pullL pullR (@triple)}.

Lemma isMono_pullL :
  isMono g -> isMono pullL.
Proof.
  unfold isMono; intros H Y h1 h2 Heq.
  apply equiv_pullback; [easy |].
  apply H.
  now rewrite !comp_assoc, <- ok, <- !comp_assoc, Heq.
Qed.

Lemma isMono_pullR :
  isMono f -> isMono pullR.
Proof.
  unfold isMono; intros * H Y h1 h2 Heq.
  apply equiv_pullback; [| easy].
  apply H.
  now rewrite !comp_assoc, ok, <- !comp_assoc, Heq.
Qed.

Lemma isIso_pullL :
  isIso g -> isIso pullL.
Proof.
  unfold isIso; intros (g' & Heq1 & Heq2).
  unshelve esplit.
  - apply (triple A (id A) (f .> g')).
    abstract (now rewrite comp_assoc, Heq2, comp_id_l, comp_id_r).
  - pullback_simpl; repeat split; [easy | | easy].
    now rewrite <- comp_assoc, ok, comp_assoc, Heq1, comp_id_r.
Qed.

Lemma isIso_pullR :
  isIso f -> isIso pullR.
Proof.
  unfold isIso; intros (f' & Heq1 & Heq2).
  unshelve esplit.
  - apply (triple B (g .> f') (id B)).
    abstract (now rewrite comp_assoc, Heq2, comp_id_l, comp_id_r).
  - pullback_simpl; repeat split; [| easy | easy].
    now rewrite <- comp_assoc, <- ok, comp_assoc, Heq1, comp_id_r.
Qed.

End Pullback_lemmas.

Lemma isPullback_id_l :
  forall {C : Cat} {A B : Ob C} (g : Hom B A),
    isPullback C (id A) g B g (id B) (fun Γ _ b _ => b).
Proof.
  split; intros.
  - now rewrite comp_id_l, comp_id_r.
  - now rewrite <- H, comp_id_r.
  - now rewrite comp_id_r.
  - now rewrite !comp_id_r in H0.
Qed.

Lemma isPullback_id_r :
  forall {C : Cat} {A B : Ob C} (f : Hom A B),
    isPullback C f (id B) A (id A) f (fun Γ a _ _ => a).
Proof.
  split; intros.
  - now rewrite comp_id_l, comp_id_r.
  - now rewrite comp_id_r.
  - now rewrite H, comp_id_r.
  - now rewrite !comp_id_r in H.
Qed.

Lemma isPullback_comp :
  forall
    {C : Cat} {A A' B X : Ob C} {f : Hom A X} {g : Hom B X} {h : Hom A' A}
    {P : Ob C} {pullL : Hom P A} {pullR : Hom P B}
    {triple : forall {Γ : Ob C} (a : Hom Γ A) (b : Hom Γ B), a .> f == b .> g -> Hom Γ P}
    (HisP : isPullback C f g P pullL pullR (@triple))
    {Q : Ob C} {pullL' : Hom Q A'} {pullR' : Hom Q P}
    {triple' : forall {Γ : Ob C} (a : Hom Γ A') (b : Hom Γ P), a .> h == b .> pullL -> Hom Γ Q}
    (HisQ : isPullback C h pullL Q pullL' pullR' (@triple')),
      isPullback C (h .> f) g Q pullL' (pullR' .> pullR)
        (fun Γ x y H => triple' x (triple (x .> h) y (unassoc_l H)) ltac:(now rewrite triple_pullL)).
Proof.
  split.
  - now rewrite <- comp_assoc, ok, !comp_assoc, ok.
  - now intros; rewrite triple_pullL.
  - now intros; rewrite <- comp_assoc, !triple_pullR.
  - intros * Heq1 Heq2.
    rewrite !equiv_pullback'.
    repeat split; [easy | |].
    + now rewrite !comp_assoc, <- ok, <- !comp_assoc, Heq1.
    + now rewrite !comp_assoc, Heq2.
Qed.

Lemma isPullback_comp' :
  forall
    {C : Cat} {A A' B X : Ob C} {f : Hom A X} {g : Hom B X} {h : Hom A' A}
    {P : Ob C} {pullL : Hom P A} {pullR : Hom P B}
    {triple : forall {Γ : Ob C} (a : Hom Γ A) (b : Hom Γ B), a .> f == b .> g -> Hom Γ P}
    (HisP : isPullback C f g P pullL pullR (@triple))
    {Q : Ob C} {pullL' : Hom Q A'} {pullR' : Hom Q P}
    {triple' : forall {Γ : Ob C} (a' : Hom Γ A') (b : Hom Γ P), a' .> h == b .> pullL -> Hom Γ Q},
      isPullback C (h .> f) g Q pullL' (pullR' .> pullR)
        (fun Γ a' b H =>
          triple' a' (triple (a' .> h) b (unassoc_l H)) ltac:(now rewrite triple_pullL)) ->
        isPullback C h pullL Q pullL' pullR' (@triple').
Proof.
  intros * HisP; split.
  - admit.
  - intros Γ a' b Heq; destruct HisP.
    assert (Heq' : a' .> (h .> f) == (b .> pullR) .> g).
    {
      now rewrite <- comp_assoc, Heq, comp_assoc, ok.
    }
    rewrite <- (triple_pullL0 Γ a' (b .> pullR) Heq') at 2.
    assert (Heq'' : b == triple Γ (a' .> h) (b .> pullR) (unassoc_l Heq')).
    {
      apply equiv_pullback.
      - now rewrite <- Heq, triple_pullL.
      - now rewrite triple_pullR.
    }
    admit.
  - admit.
Abort.

Lemma isProduct_isPullback :
  forall
    (C : Cat) (ht : HasTerm C) (A B : Ob C)
    (P : Ob C) (pullL : Hom P A) (pullR : Hom P B)
    (triple : forall {Γ : Ob C} (a : Hom Γ A) (b : Hom Γ B),
      a .> delete A == b .> delete B -> Hom Γ P),
      isPullback C (delete A) (delete B) P pullL pullR (@triple) ->
        isProduct C P pullL pullR (fun Γ a b => triple a b (equiv_terminal _)).
Proof.
  split; intros.
  - now rewrite triple_pullL.
  - now rewrite triple_pullR.
  - now apply equiv_pullback.
Qed.

Lemma isPullback_isProduct :
  forall
    (C : Cat) (ht : HasTerm C) (A B : Ob C)
    (P : Ob C) (outl : Hom P A) (outr : Hom P B)
    (fpair : forall {Γ : Ob C} (a : Hom Γ A) (b : Hom Γ B), Hom Γ P),
      isProduct C P outl outr (@fpair) ->
        isPullback C (delete A) (delete B) P outl outr (fun Γ a b _ => fpair a b).
Proof.
  split; intros.
  - now apply equiv_terminal.
  - now rewrite fpair_outl.
  - now rewrite fpair_outr.
  - now apply equiv_product.
Qed.

Lemma isPullback_isProduct' :
  forall
    (C : Cat) (ht : HasTerm C) (A B : Ob C)
    (P : Ob C) (outl : Hom P A) (outr : Hom P B)
    (fpair : forall {Γ : Ob C} (a : Hom Γ A) (b : Hom Γ B), Hom Γ P),
      isProduct C P outl outr (@fpair)
        <->
      isPullback C (delete A) (delete B) P outl outr (fun Γ a b _ => fpair a b).
Proof.
  split.
  - split; intros.
    + now apply equiv_terminal.
    + now rewrite fpair_outl.
    + now rewrite fpair_outr.
    + now apply equiv_product.
  - split; intros.
    + rewrite (triple_pullL (isPullback := H)); [easy |].
      now apply equiv_terminal.
    + rewrite (triple_pullR (isPullback := H)); [easy |].
      now apply equiv_terminal.
    + now apply equiv_pullback.
Qed.

Lemma isEqualizer_isPullback
  (C : Cat) (A X : Ob C) (f g : Hom A X)
  (P : Ob C) (pull : Hom P A)
  (triple : forall {Γ : Ob C} (a1 a2 : Hom Γ A), a1 .> f == a2 .> g -> Hom Γ P) :
    isPullback C f g P pull pull (@triple) ->
      isEqualizer C f g P pull (fun Γ a Heq => triple a a Heq).
Proof.
  split; intros.
  - now apply ok.
  - now apply triple_pullL.
  - now apply equiv_pullback.
Qed.

Lemma isEqualizer_isPullback'
  (C : Cat) (A B X : Ob C) (f : Hom A X) (g : Hom B X)
  (P : Ob C) (pullL : Hom P A) (pullR : Hom P B)
  (triple : forall {Γ : Ob C} (a : Hom Γ A) (b : Hom Γ B), a .> f == b .> g -> Hom Γ P) :
    isPullback C f g P pullL pullR (@triple) ->
      isEqualizer C (pullL .> f) (pullR .> g) P (id P)
        (fun Γ x Heq => triple (x .> pullL) (x .> pullR)
            ltac:(now rewrite !comp_assoc)).
Proof.
  split.
  - now rewrite ok.
  - now intros; rewrite equiv_pullback', comp_id_r, triple_pullL, triple_pullR.
  - now intros * Heq; rewrite !comp_id_r in Heq.
Qed.

Lemma isPullback_isEqualizer_isProduct :
  forall
    (C : Cat) (A B X : Ob C) (f : Hom A X) (g : Hom B X)
    (AB : Ob C) (outl : Hom AB A) (outr : Hom AB B)
    (fpair : forall {Γ : Ob C} (a : Hom Γ A) (b : Hom Γ B), Hom Γ AB)
    (HisP : isProduct C AB outl outr (@fpair))
    (E : Ob C) (equalize : Hom E AB)
    (factorize : forall {E' : Ob C} (e : Hom E' AB),
      e .> (outl .> f) == e .> (outr .> g) -> Hom E' E)
    (HisEq : isEqualizer C (outl .> f) (outr .> g) E equalize (@factorize)),
      isPullback C f g E (equalize .> outl) (equalize .> outr)
        (fun Γ a b Heq => factorize (fpair a b)
          ltac:(now rewrite <- !comp_assoc, fpair_outl, fpair_outr)).
Proof.
  split; intros.
  - now rewrite !comp_assoc, Equalizer.ok.
  - now rewrite <- comp_assoc, factorize_equalize, fpair_outl.
  - now rewrite <- comp_assoc, factorize_equalize, fpair_outr.
  - now rewrite equiv_equalizer', equiv_product', !comp_assoc.
Qed.

Class HasPullbacks (C : Cat) : Type :=
{
  pullback : forall {A B X : Ob C}, Hom A X -> Hom B X -> Ob C;
  pullL : forall {A B X : Ob C} {f : Hom A X} {g : Hom B X}, Hom (pullback f g) A;
  pullR : forall {A B X : Ob C} {f : Hom A X} {g : Hom B X}, Hom (pullback f g) B;
  triple :
    forall {A B X : Ob C} [f : Hom A X] [g : Hom B X] {Γ : Ob C} (a : Hom Γ A) (b : Hom Γ B),
      a .> f == b .> g -> Hom Γ (pullback f g);
  HasPullbacks_isPullback :>
    forall {A B X : Ob C} (f : Hom A X) (g : Hom B X),
      isPullback C f g (pullback f g) (@pullL _ _ _ f g) (@pullR _ _ _ f g) (@triple A B X f g);
}.

Arguments pullback [C _ A B X] _ _.
Arguments pullL    {C _ A B X f g}.
Arguments pullR    {C _ A B X f g}.
Arguments triple   [C _ A B X f g Γ] _ _ _.

Definition commutator
  {C : Cat} {hp : HasPullbacks C} {A B X : Ob C} {f : Hom A X} {g : Hom B X}
  : Hom (pullback f g) (pullback g f)
  := triple pullR pullL (symmetry ok).

Lemma commutator_idem :
  forall {C : Cat} {hp : HasPullbacks C} {A B X : Ob C} (f : Hom A X) (g : Hom B X),
    commutator .> commutator == id (pullback f g).
Proof.
  unfold commutator; intros.
  apply equiv_pullback.
  - now rewrite comp_assoc, triple_pullL, triple_pullR, comp_id_l.
  - now rewrite comp_assoc, triple_pullR, triple_pullL, comp_id_l.
Qed.

Lemma isIso_commutator :
  forall {C : Cat} {hp : HasPullbacks C} {A B X : Ob C} (f : Hom A X) (g : Hom B X),
    isIso (commutator (f := f) (g := g)).
Proof.
  red; intros.
  exists commutator.
  now split; apply commutator_idem.
Qed.

Lemma pullback_comm :
  forall {C : Cat} {hp : HasPullbacks C} {A B X : Ob C} (f : Hom A X) (g : Hom B X),
    pullback f g ~ pullback g f.
Proof.
  red; intros.
  exists commutator.
  now now apply isIso_commutator.
Qed.

#[refine]
#[local]
Instance HasPullbacks_HasProducts_HasEqualizers
  {C : Cat} (hp : HasProducts C) (he : HasEqualizers C) : HasPullbacks C :=
{
  pullback := fun A B X f g => @equalizer _ _ (product A B) X (outl .> f) (outr .> g);
  pullL    := fun A B X f g => equalize (outl .> f) (outr .> g) .> outl;
  pullR    := fun A B X f g => equalize (outl .> f) (outr .> g) .> outr;
  triple   := fun A B X f g Γ a b Heq => factorize (fpair a b) _;
}.
Proof.
  - now rewrite <- !comp_assoc, fpair_outl, fpair_outr.
  - split; intros.
    + now rewrite !comp_assoc, Equalizer.ok.
    + now rewrite <- comp_assoc, factorize_equalize, fpair_outl.
    + now rewrite <- comp_assoc, factorize_equalize, fpair_outr.
    + now rewrite equiv_equalizer', equiv_product', !comp_assoc.
Defined.


(************************************************************************************)
(**                                                                                *)
(**                             The SQLEngines Library                              *)
(**                                                                                *)
(**            LRI, CNRS & Université Paris-Sud, Université Paris-Saclay            *)
(**                                                                                *)
(**                        Copyright 2016-2019 : FormalData                         *)
(**                                                                                *)
(**         Authors: Véronique Benzaken                                             *)
(**                  Évelyne Contejean                                              *)
(**                  Chantal Keller                                                 *)
(**                  Eunice-Raquel Martins                                          *)
(**                                                                                *)
(************************************************************************************)

Require Import List VectorDef Bvector.
Require Import OrderedSet.
Require Import Signatures SeqScan.

Set Implicit Arguments.

Module BitmapIndexScan.

  Section BitmapIndexScan.

    Variable o1 o2 : Type.
    Variable O1 : Oeset.Rcd o1.
    Variable O2 : Oeset.Rcd o2.
    Variable proj : o1 -> o2.
    Hypothesis proj_eq :
      forall x y, Oeset.compare O1 x y = Eq -> Oeset.compare O2 (proj x) (proj y) = Eq.
    Variable P : o2 -> o2 -> bool.
    Hypothesis P_eq_1 : forall x1 x2 y, Oeset.compare O2 x1 x2 = Eq -> P x1 y = P x2 y.
    Hypothesis P_eq_2 : forall x y1 y2, Oeset.compare O2 y1 y2 = Eq -> P x y1 = P x y2.

    Record containers : Type := mk_containers
      {
        (* the number of elements in the relation *)
        size : nat;
        (* all the elements of the relation *)
        collection : Vector.t o1 size;
        (* a bitmap associated to every index *)
        bitmap : o2 -> Bvector size;
        (* each bitmap associates to true exactly the elements matching
           the corresponding index *)
        coherent : forall n x0, nth (bitmap x0) n = P x0 (proj (nth collection n))
      }.

    Program Definition dummy_containers : containers :=
      @mk_containers O (Vector.nil o1) (fun _ => Bnil) _.
    Next Obligation.
      inversion n.
    Qed.

    Definition c1 : containers -> list o1 := fun c => to_list (collection c).

    Definition C1 := SeqScan.build O1.

    Definition i : containers -> o2 -> Cursor.cursor C1 :=
      fun c x0 => let col := List.rev (fold_left2 (fun acc (b:bool) y => if b then (y::acc)%list else acc) List.nil (bitmap c x0) (collection c)) in
                  SeqScan.mk_cursor List.nil col col.

    Lemma fold_left2_rem n (l1:t bool n) (l2:t o1 n) : forall acc0,
        (fold_left2 (fun acc (b:bool) y => if b then (y::acc)%list else acc%list) acc0 l1 l2) = ((List.rev (List.map snd (List.filter fst (to_list (map2 pair l1 l2))))) ++ acc0)%list.
    Proof.
      apply (rect2 (fun m t1 t2 => forall acc0 : list o1,
                        fold_left2
                          (fun (acc : list o1) (b : bool) (y : o1) =>
                             if b then (y :: acc)%list else acc) acc0 t1 t2 =
                        (List.rev (List.map snd (filter fst (to_list (map2 pair t1 t2)))) ++ acc0)%list)); auto.
      intros m v1 v2 IH b y acc.
      change (
          fold_left2
            (fun (acc0 : list o1) (b0 : bool) (y0 : o1) =>
               if b0 then (y0 :: acc0)%list else acc0)
            (if b then (y :: acc)%list else acc) v1 v2 =
          (List.rev
            (List.map snd (filter fst ((b,y)::(to_list (map2 pair v1 v2)))%list)) ++
            acc)%list
        ). simpl.
      rewrite IH. case b; auto.
      simpl. now rewrite <- app_assoc.
    Qed.

    Lemma i_collection c x : comparelA (Oeset.compare O1) (Cursor.collection (i c x)) (filter (fun y => P x (proj y)) (c1 c)) = Eq.
    Proof.
      unfold c1. destruct c as [size col bitmap coh]. simpl.
      rewrite fold_left2_rem, app_nil_r, rev_involutive.
      assert (H:forall (n : Fin.t size), (bitmap x)[@n] = P x (proj col[@n])) by auto.
      clear coh. revert H. generalize (bitmap x). intro b.
      apply (rect2 (fun n0 v1 v2 => (forall n : Fin.t n0, v1[@n] = P x (proj v2[@n])) ->
                                    comparelA (Oeset.compare O1) (List.map snd (filter fst (to_list (map2 pair v1 v2))))
                                              (filter (fun y => P x (proj y)) (to_list v2)) = Eq)).
      - reflexivity.
      - intros n v1 v2 IH b' y coh.
        change (
            comparelA (Oeset.compare O1)
                      (List.map snd (filter fst ((b',y)::(to_list (map2 pair v1 v2)))%list))
                      (filter (fun y0 : o1 => P x (proj y0)) (y::(to_list v2))%list) = Eq
          ). simpl.
        assert (H:forall n0 : Fin.t n, v1[@n0] = P x (proj v2[@n0])) by (intro m; apply (coh (Fin.FS m))).
        apply IH in H. clear IH.
        generalize (coh Fin.F1). clear coh. simpl. case (P x (proj y)); intro Heq; subst b'.
        + simpl. now rewrite Oeset.compare_eq_refl.
        + auto.
    Qed.

    Lemma i_visited c x : Cursor.visited (i c x) = List.nil. Proof. reflexivity. Qed.

    Lemma i_coherent c x : Cursor.coherent (i c x). Proof. reflexivity. Qed.

    Definition build : Index.Rcd O1 O2.
      apply Index.mk_R with proj P C1 containers c1 i.
      - apply proj_eq.
      - apply P_eq_1.
      - apply P_eq_2.
      - exact dummy_containers.
      - apply i_collection.
      - apply i_visited.
      - apply i_coherent.
    Defined.

  End BitmapIndexScan.

End BitmapIndexScan.


Definition naive_player_small_board (brd: board) (mk: mark): cell :=
  match brd with
    | mk_board B _ _ _ _ _ _ _ _ => C00
    | mk_board _ B _ _ _ _ _ _ _ => C01
    | mk_board _ _ B _ _ _ _ _ _ => C02
    | mk_board _ _ _ B _ _ _ _ _ => C10
    | mk_board _ _ _ _ B _ _ _ _ => C11
    | mk_board _ _ _ _ _ B _ _ _ => C12
    | mk_board _ _ _ _ _ _ B _ _ => C20
    | mk_board _ _ _ _ _ _ _ B _ => C21
    | mk_board _ _ _ _ _ _ _ _ B => C22
    | _ => C00
  end.

Fixpoint do_naive_player_free_move (brds: list board) (outcomes: list outcome) (cells: list cell) (mk: mark): move :=
  match brds, outcomes, cells with
    | b::t1, o::t2, c::t3 =>
      match o with
        | incomplete => mk_move (c) (naive_player_small_board b mk) mk
        | _ => do_naive_player_free_move t1 t2 t3 mk
      end
    | _, _,_ => first_move
  end.

Definition naive_player_free_move (brd: macro_board) (mk: mark): move :=
  match brd with
    | mk_macro_board
        brd00 brd01 brd02
        brd10 brd11 brd12
        brd20 brd21 brd22 =>
      let brds := ([brd00; brd01; brd02;
                    brd10; brd11; brd12;
                    brd20; brd21; brd22]) in
      do_naive_player_free_move brds (evaluate_boards brds) [C00;C01;C02;C10;C11;C12;C20;C21;C22] mk
  end.

Definition naive_player (brd: macro_board) (last_mv: move): move :=
  let c := match last_mv with
                | first_move => C00
                | mk_move _ c2 _ => c2
  end in
  let mk := match last_mv with
                   | first_move => X
                   | mk_move _ _ mk =>
                 match mk with
                   | X => O
                   | O => X
                   | _ => B
                 end
  end in
  let small_brd := (get_board brd c) in
  match evaluate_board (small_brd) with
    | malformed => first_move
    | incomplete => mk_move c (naive_player_small_board small_brd mk) mk
    | tie | Xwins | Owins => naive_player_free_move brd mk
  end.


Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

From ExtLib Require Import
     RelDec.
From Coq Require Import
     Ascii
     List
     NArith
     String
     ZArith.
From mathcomp Require Import
     ssrbool
     ssreflect
     ssrnat.
From QuickChick Require Import Checker.

Set Bullet Behavior "Strict Subproofs".

(* Class wrapper around "decidable" *)
(* begin decidable_class *)
    Class Dec (P : Prop) : Type := { dec : decidable P }.
(* end decidable_class *)

Class DecOpt (P : Prop) := { decOpt : nat -> option bool }.

Axiom checkable_size_limit : nat.
Extract Constant checkable_size_limit => "10000".

Require Import Generators Producer.
(* Discard tests that run further than the limit *)
(* For proofs, the size parameter will need to be taken into account
   to prove limit results. We just add it to the large, practical constant.
 *)
#[global] Instance decOpt__checkable {P} `{DecOpt P} : Checkable P :=
  {| checker _ :=
       sized (fun s =>
                match decOpt (checkable_size_limit + s) with
                | Some b => checker b
                | None => checker tt
                end
             )
  |}.

#[global] Instance dec_decOpt {P} `{Dec P} : DecOpt P :=
  {| decOpt := fun _ => match @dec P _ with
                        | left  _ => Some true
                        | right _ => Some false
                        end |}.

(* Note: maybe this should become thunked? *)
Definition checker_backtrack (l : list (unit -> option bool)) : option bool :=
  let fix aux l b :=
      match l with
      | t :: ts =>
        match t tt with
        | Some true  => Some true
        | Some false => aux ts b
        | None => aux ts true
        end
      | nil => if b then None else Some false
      end
  in aux l false.

(* BCP: If I understand correctly, removing "Global" everywhere would
   change nothing... Or? *)

(* Additional Checkable instance *)
#[global] Instance testDec {P} `{H : Dec P} : Checkable P.
Proof.
  constructor.
  destruct H.
  destruct dec0.
  - intros; exact (checker true).
  - intros; exact (checker false).
Defined.

#[global] Instance Checkable_opt {p} `{Checkable p} : Checkable (option p) :=
  { checker m :=
      match m with
      | Some x => checker x
      | None => checker tt
      end
  }.

#[global] Instance Dec_neg {P} {H : Dec P} : Dec (~ P).
Proof.
  constructor. unfold decidable.
  destruct H as [D]; destruct D; auto.
Defined.

#[global] Instance Dec_conj {P Q} {H : Dec P} {I : Dec Q} : Dec (P /\ Q).
Proof.
  constructor. unfold decidable.
  destruct H as [D]; destruct D;
    destruct I as [D]; destruct D; auto;
      right; intro; destruct H; contradiction.
Defined.

#[global] Instance Dec_disj {P Q} {H : Dec P} {I : Dec Q} : Dec (P \/ Q).
Proof.
  constructor. unfold decidable.
  destruct H as [D]; destruct D;
    destruct I as [D]; destruct D; auto;
      right; intro; destruct H; contradiction.
Defined.

(* BCP: Not clear this is a good idea, but... *)
(* Leo: Should be ok with really low priority *)
#[global] Instance Dec_impl {P Q} {H : Dec P} {I : Dec Q} : Dec (P -> Q) | 100.
Proof.
  constructor. unfold decidable.
  destruct H as [D]. destruct D; destruct I as [D]; destruct D; auto.
  left. intros. contradiction.
Defined.

#[global] Instance Dec_In {A} (Eq: forall (x y : A), Dec (x = y))
         (x : A) (l : list A) : Dec (In x l) :=
  {| dec := in_dec (fun x' y' => @dec _ (Eq x' y')) x l |}.

Class Dec_Eq (A : Type) :=
  {
    dec_eq : forall (x y : A), decidable (x = y)
  }.

Theorem dec_if_dec_eq {A} (x y: A): Dec (x = y) -> {x = y} + {x <> y}.
Proof.
  intros. inversion H as [D].
  unfold decidable in D. assumption.
Defined.

#[global]
Hint Resolve dec_if_dec_eq: eq_dec.

Ltac dec_eq :=
  repeat match goal with
         | [ |- _ ] => solve [auto with eq_dec]
         | [ |- Dec _ ] => constructor
         | [ |- Dec_Eq _ ]  => constructor
         | [ |- context[decidable _] ] => unfold decidable

         | [ H: context[decidable _] |- _ ] => unfold decidable in H

         | [ |- forall x y, {x = y} + {x <> y} ] => decide equality
         | [ |- {?x = ?y} + {?x <> ?y} ] =>
           multimatch goal with
             | [ H: forall x y, Dec _ |- _ ] => apply H
             | [ H: Dec_Eq _ |- _ ] => apply H
             | [ |- _ ] => decide equality
           end
         end.

#[global] Instance Dec_Eq_implies_DecEq {A} `{H : Dec_Eq A} (x y : A) : Dec (x = y).
Proof.
constructor.
dec_eq.
Defined.

#[global] Instance Dec_Eq_implies_RelDecEq {A} `{Dec_Eq A} : RelDec (@eq A) :=
  {| rel_dec x y :=
       match dec_eq x y with
       | left  _ => true
       | right _ => false
       end
  |}.

(* Lifting common decidable instances *)
#[global] Instance Dec_eq_unit : Dec_Eq unit.
Proof. dec_eq. Defined.

#[global] Instance Dec_eq_bool : Dec_Eq bool.
Proof. dec_eq. Defined.

#[global] Instance Dec_eq_nat : Dec_Eq nat.
Proof. dec_eq. Defined.

#[global] Instance Dec_eq_Z : Dec_Eq Z.
Proof. dec_eq. Defined.

#[global] Instance Dec_eq_N : Dec_Eq N.
Proof. dec_eq. Defined.

#[global] Instance Dec_eq_opt (A : Type) `{Dec_Eq A} : Dec_Eq (option A).
Proof. dec_eq. Defined.

#[global] Instance Dec_eq_prod (A B : Type) `{Dec_Eq A} `{Dec_Eq B} : Dec_Eq (A * B).
Proof. dec_eq. Defined.

#[global] Instance Dec_eq_sum (A B : Type) `{Dec_Eq A} `{Dec_Eq B} : Dec_Eq (A + B).
Proof. dec_eq. Defined.

#[global] Instance Dec_eq_list (A : Type) `{Dec_Eq A} : Dec_Eq (list A).
Proof. dec_eq. Defined.

#[global] Instance list_Dec_Eq X (_ : Dec_Eq X) : Dec_Eq (list X).
Proof. dec_eq. Defined.

#[global]
Hint Resolve ascii_dec: eq_dec.
#[global]
Hint Resolve string_dec: eq_dec.

#[global] Instance Dec_eq_ascii : Dec_Eq ascii.
Proof. dec_eq. Defined.

#[global] Instance Dec_eq_string : Dec_Eq string.
Proof. dec_eq. Defined.

(* Everything that uses the Decidable Class *)
Require Import DecidableClass.

#[global] Instance dec_class_dec P (H : Decidable P): Dec P.
Proof.
  constructor; destruct H; destruct Decidable_witness.
  - left; auto.
    apply Decidable_spec; auto.
  - right => H; eauto.
    apply Decidable_spec in H.
    inversion H.
Defined.

(*
Example foo (m n : nat) :=
  match @dec (m = n) _ with
    | left  _ => 0
    | right _ => 1
  end.

(* Eval compute in foo 0 1. *)
Example bar (m n : nat) :=
  if (m=n)? then 0 else 1.

(* Eval compute in bar 0 1. *)
*)

(* Not sure about the level or binding, but good idea *)
Notation "P '?'" := (match (@dec P _) with
                       | left _ => true
                       | right _ => false
                     end) (at level 100).

Notation "P '??' n" := (@decOpt P _ n) (at level 100).

Definition implicationOpt (m : option bool) (p : unit -> option bool) : option bool :=
  match m with
  | Some true => p tt
  | Some false => None
  | None => None
  end.

Notation "x ?==>? y" :=
  (implicationOpt (Some x) (fun tt => y))
    (at level 55, right associativity).

Notation "x ==>? y" :=
  (implicationOpt x (fun tt => y))
    (at level 55, right associativity).

#[global] Hint Resolve Dec_eq_unit : eq_dec.
#[global] Hint Resolve Dec_eq_bool : eq_dec.
#[global] Hint Resolve Dec_eq_nat : eq_dec.
#[global] Hint Resolve Dec_eq_Z : eq_dec.
#[global] Hint Resolve Dec_eq_N : eq_dec.
#[global] Hint Resolve Dec_eq_opt : eq_dec.
#[global] Hint Resolve Dec_eq_prod : eq_dec.
#[global] Hint Resolve Dec_eq_sum : eq_dec.
#[global] Hint Resolve Dec_eq_list : eq_dec.
#[global] Hint Resolve Dec_eq_ascii : eq_dec.
#[global] Hint Resolve Dec_eq_string : eq_dec.