Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Init.Nat.
From Coq Require Import omega.Omega.
From Coq Require Import Lists.List.
Import ListNotations.

Require Import Maps.
Require Import Imp.

(* A Toy Language *)

Inductive tm : Type :=
  | C : nat -> tm
  | P : tm -> tm -> tm.

Fixpoint evalF (t : tm) : nat :=
  match t with
  | C n => n
  | P a1 a2 => evalF a1 + evalF a2
  end.

Reserved Notation " t '\\' n " (at level 50, left associativity).

Inductive eval : tm -> nat -> Prop :=
  | E_Const : forall n, C n \\ n
  | E_Plus : forall t1 t2 n1 n2,
    t1 \\ n1 ->
    t2 \\ n2 ->
    P t1 t2 \\ (n1 + n2)
  where "t '\\' n" := (eval t n).

Module SimpleArith1.

Reserved Notation "t '==>' t'" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
    P (C n1) (C n2) ==> C (n1 + n2)
  | ST_Plus1 : forall t1 t1' t2,
    t1 ==> t1' ->
    P t1 t2 ==> P t1' t2
  | ST_Plus2 : forall n1 t2 t2',
    t2 ==> t2' ->
    P (C n1) t2 ==> P (C n1) t2'
  where "t '==>' t'" := (step t t').

Example test_step_1 :
  P (P (C 0) (C 3))
    (P (C 2) (C 4))
  ==>
  P (C (0 + 3))
    (P (C 2) (C 4)).
Proof.
  apply ST_Plus1.
  apply ST_PlusConstConst.
Qed.

Example test_step_2 :
  P (C 0)
    (P (C 2) (P (C 0) (C 3)))
  ==>
  P (C 0)
    (P (C 2) (C (0 + 3))).
Proof.
  apply ST_Plus2. apply ST_Plus2.
  apply ST_PlusConstConst.
Qed.

End SimpleArith1.

(* Relations *)

Definition relation (X : Type) := X -> X -> Prop.

Definition deterministic {X : Type} (R : relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Module SimpleArith2.
Import SimpleArith1.

Theorem step_deterministic : deterministic step.
Proof.
  unfold deterministic. intros.
  generalize dependent y2.
  induction H; intros.
  - inversion H0.
    + reflexivity.
    + subst. inversion H3.
    + subst. inversion H3.
  - inversion H0.
    + subst. inversion H.
    + rewrite <- (IHstep t1'0).
      * reflexivity.
      * apply H4.
    + rewrite <- H1 in H. inversion H.
  - inversion H0.
    + rewrite <- H3 in H. inversion H.
    + inversion H4.
    + rewrite <- (IHstep t2'0).
      * reflexivity.
      * apply H4.
Qed.

End SimpleArith2.

Ltac solve_by_inverts n :=
  match goal with | H : ?T |- _ =>
  match type of T with Prop =>
    solve [
      inversion H;
      match n with (S (S (?n'))) => subst; solve_by_inverts (S n') end]
  end end.

Ltac solve_by_invert := solve_by_inverts 1.

Module SimpleArith3.
Import SimpleArith1.

Theorem step_deterministic_alt : deterministic step.
Proof.
  unfold deterministic. intros x y1 y2 Hy1 Hy2.
  generalize dependent y2.
  induction Hy1; intros;
    inversion Hy2; subst; try solve_by_invert.
  - reflexivity.
  - apply IHHy1 in H2. rewrite H2. reflexivity.
  - apply IHHy1 in H2. rewrite H2. reflexivity.
Qed.

End SimpleArith3.

(* Values *)

Inductive value : tm -> Prop :=
  | v_const : forall n, value (C n).

Reserved Notation "t '==>' t'" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
    P (C n1) (C n2) ==> C (n1 + n2)
  | ST_Plus1 : forall t1 t1' t2,
    t1 ==> t1' ->
    P t1 t2 ==> P t1' t2
  | ST_Plus2 : forall v1 t2 t2',
    value v1 ->
    t2 ==> t2' ->
    P v1 t2 ==> P v1 t2'
  where " t '==>' t' " := (step t t').

(* Exercise *)
Theorem step_deterministic : deterministic step.
Proof.
  unfold deterministic.
  intros x y1 y2 Hy1 Hy2.
  generalize dependent y2.
  induction Hy1; intros; inversion Hy2; subst; try solve_by_invert.
  - reflexivity.
  - apply IHHy1 in H2. rewrite H2. reflexivity.
  - inversion Hy2; subst.
    + inversion H1. subst. inversion Hy1.
    + inversion H1. subst. inversion Hy1.
  - inversion Hy2; subst.
    + inversion H. subst. try solve_by_invert.
    + inversion H. subst. try solve_by_invert.
  - apply IHHy1 in H4. rewrite H4. reflexivity.
Qed.

(* Strong Progress and Normal Forms *)

(* Strong Progress: if t is a term, then either t is a value,
   or else there exists a term t' such that t ==> t' *)

Theorem strong_progress : forall t,
  value t \/ (exists t', t ==> t').
Proof.
  intros. induction t.
  - left. apply v_const.
  - right. inversion IHt1.
    + inversion IHt2.
      * inversion H. inversion H0.
        exists (C (n + n0)). apply ST_PlusConstConst.
      * inversion H0.
        exists (P t1 x). apply ST_Plus2.
        apply H. apply H1.
    + inversion H. exists (P x t2). apply ST_Plus1.
      apply H0.
Qed.

Definition normal_form {X : Type} (R : relation X) (t : X) : Prop :=
  ~ exists t', R t t'.

Lemma value_is_nf : forall v,
  value v -> normal_form step v.
Proof.
  unfold normal_form. intros.
  inversion H. intros contra.
  inversion contra. inversion H1.
Qed.

Lemma nf_is_value : forall v,
  normal_form step v -> value v.
Proof.
  unfold normal_form. intros.
  assert (G : value v \/ exists t', v ==> t').
  { apply strong_progress. }
  inversion G.
  - apply H0.
  - exfalso. apply H. apply H0.
Qed.

Corollary nf_same_as_value : forall t,
  normal_form step t <-> value t.
Proof.
  intros. split.
  apply nf_is_value.
  apply value_is_nf.
Qed.

(* TODO : Exercises *)

(* Multi-Step Reduction *)

Inductive multi {X : Type} (R : relation X) : relation X :=
  | multi_refl : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
    R x y ->
    multi R y z ->
    multi R x z.

Notation " t '==>*' t' " := (multi step t t') (at level 40).

Theorem multi_R : forall (X : Type) (R : relation X) (x y : X),
  R x y -> (multi R) x y.
Proof.
  intros.
  apply multi_step with y. apply H. apply multi_refl.
Qed.

Theorem multi_trans : forall (X : Type) (R : relation X) (x y z : X),
  multi R x y ->
  multi R y z ->
  multi R x z.
Proof.
  intros X R x y z Rxy Ryz.
  induction Rxy.
  - apply Ryz.
  - apply multi_step with y.
    apply H. apply IHRxy. apply Ryz.
Qed.

(* Examples *)

Lemma test_multistep_1 :
  P (P (C 0) (C 3))
    (P (C 2) (C 4))
  ==>*
  C ((0 + 3) + (2 + 4)).
Proof.
  apply multi_step with (P (C (0 + 3)) (P (C 2) (C 4))).
  apply ST_Plus1. apply ST_PlusConstConst.
  apply multi_step with (P (C (0 + 3)) (C ( 2 + 4))).
  apply ST_Plus2. apply v_const.
  apply ST_PlusConstConst.
  apply multi_R.
  apply ST_PlusConstConst.
Qed.

(* Exercises TODO *)

(* Normal Forms Again *)

Definition step_normal_form := normal_form step.

Definition normal_form_of (t t' : tm) :=
  (t ==>* t' /\ step_normal_form t').

Definition normalizing {X : Type} (R : relation X) :=
  forall t, exists t',
      (multi R) t t' /\ normal_form R t'.

Lemma multistep_congr_1 : forall t1 t1' t2,
  t1 ==>* t1' ->
  P t1 t2 ==>* P t1' t2.
Proof.
  intros.
  induction H.
  - apply multi_refl.
  - eapply multi_step with (P y t2).
    apply ST_Plus1. apply H.
    apply IHmulti.
Qed.

(* Exercise *)

Lemma multistep_congr_2 : forall t1 t2 t2',
  value t1 ->
  t2 ==>* t2' ->
  P t1 t2 ==>* P t1 t2'.
Proof.
  intros t1 t2 t2' Hvalt1 Ht2step.
  induction Ht2step.
  - apply multi_refl.
  - apply multi_step with (P t1 y).
    apply ST_Plus2.
    apply Hvalt1. apply H.
    apply IHHt2step.
Qed.

Theorem step_normalizing : normalizing step.
Proof.
  unfold normalizing.
  induction t.
  - exists (C n). split.
    + apply multi_refl.
    + rewrite nf_same_as_value. apply v_const.
  - destruct IHt1 as [t1' [H11 H12]].
    destruct IHt2 as [t2' [H21 H22]].
    rewrite nf_same_as_value in H12.
    rewrite nf_same_as_value in H22.
    inversion H12 as [n1 H].
    inversion H22 as [n2 H'].
    rewrite <- H in H11.
    rewrite <- H' in H21.
    exists (C (n1 + n2)). split.
    + apply multi_trans with (P (C n1) t2).
      * apply multistep_congr_1. apply H11.
      * apply multi_trans with (P (C n1) (C n2)).
        { apply multistep_congr_2. apply v_const. apply H21. }
        { apply multi_R. apply ST_PlusConstConst. }
    + rewrite nf_same_as_value. apply v_const.
Qed.

(* Equivalence of Big-Step and Small-Step *)

Theorem eval_multistep : forall t n,
  t \\ n -> t ==>* C n.
Proof.
  intros.
  induction H.
  - apply multi_refl.
  - apply multi_trans with (P (C n1) t2).
    + apply multistep_congr_1. apply IHeval1.
    + apply multi_trans with (P (C n1) (C n2)).
      * apply multistep_congr_2. apply v_const. apply IHeval2.
      * apply multi_R. apply ST_PlusConstConst.
Qed.

(* Exercises *)

Lemma step_eval : forall t t' n,
  t ==> t' ->
  t' \\ n ->
  t \\ n.
Proof.
Admitted.

Theorem multistep_eval : forall t t',
  normal_form_of t t' -> exists n, t' = C n /\ t \\ n.
Proof.
Admitted.

(* Small-Step Imp *)

Inductive aval : aexp -> Prop :=
  | av_num : forall n, aval (ANum n).

Reserved Notation " t '/' st '-->a' t' "
         (at level 40, st at level 39).

Inductive astep : state -> aexp -> aexp -> Prop :=
  | AS_Id : forall st i,
      (AId i) / st -->a ANum (st i)
  | AS_Plus1 : forall st a1 a1' a2,
      a1 / st -->a a1' ->
      (APlus a1 a2) / st -->a (APlus a1' a2)
  | AS_Plus2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st -->a a2' ->
      (APlus v1 a2) / st -->a (APlus v1 a2')
  | AS_Plus : forall st n1 n2,
      APlus (ANum n1) (ANum n2) / st -->a ANum (n1 + n2)
  | AS_Minus1 : forall st a1 a1' a2,
      a1 / st -->a a1' ->
      (AMinus a1 a2) / st -->a (AMinus a1' a2)
  | AS_Minus2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st -->a a2' ->
      (AMinus v1 a2) / st -->a (AMinus v1 a2')
  | AS_Minus : forall st n1 n2,
      (AMinus (ANum n1) (ANum n2)) / st -->a (ANum (minus n1 n2))
  | AS_Mult1 : forall st a1 a1' a2,
      a1 / st -->a a1' ->
      (AMult a1 a2) / st -->a (AMult a1' a2)
  | AS_Mult2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st -->a a2' ->
      (AMult v1 a2) / st -->a (AMult v1 a2')
  | AS_Mult : forall st n1 n2,
      (AMult (ANum n1) (ANum n2)) / st -->a (ANum (mult n1 n2))
where " t '/' st '-->a' t' " := (astep st t t').

Reserved Notation " t '/' st '-->b' t' "
                  (at level 40, st at level 39).

Inductive bstep : state -> bexp -> bexp -> Prop :=
  | BS_Eq1 : forall st a1 a1' a2,
      a1 / st -->a a1' ->
      (BEq a1 a2) / st -->b (BEq a1' a2)
  | BS_Eq2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st -->a a2' ->
      (BEq v1 a2) / st -->b (BEq v1 a2')
  | BS_Eq : forall st n1 n2,
      (BEq (ANum n1) (ANum n2)) / st -->b
      (if (n1 =? n2) then BTrue else BFalse)
  | BS_LtEq1 : forall st a1 a1' a2,
      a1 / st -->a a1' ->
      (BLe a1 a2) / st -->b (BLe a1' a2)
  | BS_LtEq2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st -->a a2' ->
      (BLe v1 a2) / st -->b (BLe v1 a2')
  | BS_LtEq : forall st n1 n2,
      (BLe (ANum n1) (ANum n2)) / st -->b
              (if (n1 <=? n2) then BTrue else BFalse)
  | BS_NotStep : forall st b1 b1',
      b1 / st -->b b1' ->
      (BNot b1) / st -->b (BNot b1')
  | BS_NotTrue : forall st,
      (BNot BTrue) / st -->b BFalse
  | BS_NotFalse : forall st,
      (BNot BFalse) / st -->b BTrue
  | BS_AndTrueStep : forall st b2 b2',
      b2 / st -->b b2' ->
      (BAnd BTrue b2) / st -->b (BAnd BTrue b2')
  | BS_AndStep : forall st b1 b1' b2,
      b1 / st -->b b1' ->
      (BAnd b1 b2) / st -->b (BAnd b1' b2)
  | BS_AndTrueTrue : forall st,
      (BAnd BTrue BTrue) / st -->b BTrue
  | BS_AndTrueFalse : forall st,
      (BAnd BTrue BFalse) / st -->b BFalse
  | BS_AndFalse : forall st b2,
      (BAnd BFalse b2) / st -->b BFalse
where " t '/' st '-->b' t' " := (bstep st t t').

Reserved Notation " t '/' st '-->' t' '/' st' "
         (at level 40, st at level 39, t' at level 39).

Inductive cstep : (com * state) -> (com * state) -> Prop :=
  | CS_AssStep : forall st i a a',
      a / st -->a a' ->
      (i ::= a) / st --> (i ::= a') / st
  | CS_Ass : forall st i n,
      (i ::= (ANum n)) / st --> SKIP / (i !-> n ; st)
  | CS_SeqStep : forall st c1 c1' st' c2,
      c1 / st --> c1' / st' ->
      (c1 ;; c2) / st --> (c1' ;; c2) / st'
  | CS_SeqFinish : forall st c2,
      (SKIP ;; c2) / st --> c2 / st
  | CS_IfStep : forall st b b' c1 c2,
      b / st -->b b' ->
      IFB b THEN c1 ELSE c2 FI / st
      -->
      (IFB b' THEN c1 ELSE c2 FI) / st
  | CS_IfTrue : forall st c1 c2,
      IFB BTrue THEN c1 ELSE c2 FI / st --> c1 / st
  | CS_IfFalse : forall st c1 c2,
      IFB BFalse THEN c1 ELSE c2 FI / st --> c2 / st
  | CS_While : forall st b c1,
      WHILE b DO c1 END / st
      -->
      (IFB b THEN c1;; WHILE b DO c1 END ELSE SKIP FI) / st
where " t '/' st '-->' t' '/' st' " := (cstep (t,st) (t',st')).

(* Concurrent Imp *)

(* A Small-Step Stack Machine *)

(* A normalize Tactic *)

Hint Constructors step value.

Example step_example1 :
  (P (C 3) (P (C 3) (C 4)))
    ==>* (C 10).
Proof.
  eapply multi_step. eauto. simpl.
  eapply multi_step. eauto. simpl.
  constructor.
Qed.

Tactic Notation "print_goal" :=
  match goal with |- ?x => idtac x end.

Tactic Notation "normalize" :=
  repeat (print_goal; eapply multi_step;
          [ (eauto 10; fail) | (instantiate; simpl)]);
  apply multi_refl.

Example step_example2 :
  (P (C 3) (P (C 3) (C 4)))
    ==>* (C 10).
Proof.
  normalize.
Qed.


Require Import Coq.Classes.Equivalence.
From Quotient Require Import quotient Construction.function_util.
Open Scope equiv_scope.

Section Equalizer.

  Context {A : Type}.
  Context {B : Type}.

  Variable (f1 f2 : B -> A).

  Record isEqualizer {C : Type} (g : C -> B) :=
    {
      equalizer_equal : (f_comp f1 g) === (f_comp f2 g);

      equalizer_univ :
        forall {C' : Type} (g' : C' -> B),
          (f_comp f1 g') === (f_comp f2 g') ->
          { u : C' -> C | g' === (f_comp g u) /\ (forall u' : C' -> C, g' === (f_comp g u') -> u' === u) }
    }.

  Record equalizer :=
    {
      equalizer_set :> Type;
      equalizer_fun :> equalizer_set -> B;

      equalizer_isequalizer : isEqualizer equalizer_fun
    }.

  Lemma equalizer_mono : forall {C : Type} (g : C -> B), isEqualizer g -> mono g.
  Proof.
    intros C g isE.
    destruct isE as [eeq euniv].
    intros X h1 h2 eqgh.
    specialize (euniv X).
    assert(eqh1f : f_comp f1 (f_comp g h1) === f_comp f2 (f_comp g h1)).
    {
      rewrite <- f_comp_assoc.
      rewrite eeq.
      reflexivity.
    }
    assert(eqh2f : f_comp f1 (f_comp g h2) === f_comp f2 (f_comp g h2)).
    {
      rewrite <- f_comp_assoc.
      rewrite eeq.
      reflexivity.
    }
    destruct (euniv _ eqh1f) as [u1 [eqg1 g1unv]].
    destruct (euniv _ eqh2f) as [u2 [eqg2 g2unv]].
    cut (u1 === u2).
    {
      intro equ.
      transitivity u1.
      {
        apply g1unv.
        reflexivity.
      }
      rewrite equ.
      symmetry.
      apply g2unv.
      reflexivity.
    }
    apply g2unv.
    rewrite <- eqg1.
    symmetry.
    assumption.
  Qed.

End Equalizer.

Lemma isEqualizer_symmetry :
  forall {A B C : Type} (f1 f2 : B -> A) (g : C -> B),
    isEqualizer f1 f2 g -> isEqualizer f2 f1 g.
Proof.
  intros A B C f1 f2 g isH.
  destruct isH as [isHex isHunq].
  split.
  rewrite isHex.
  reflexivity.
  intros C' g' eqH.
  symmetry in eqH.
  apply (isHunq _ _ eqH).
Qed.

Definition equalizer_exists := forall (B A : Type) (f1 f2 : B -> A), equalizer f1 f2.


(**
N-Queens

finTypeの使い方を確かめるために、8クィーン問題の盤面の記述を試みる。
実際には4×4盤面を扱う。
*)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq.
Require Import fintype finfun finset fingroup perm.
(* perm は順列ではなく、置換のパッケージである。 *)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* 行または列をしめす、0〜3の値を 'I_4型で定義する。 *)
Definition p0 : 'I_4. Proof. have : 0 < 4 by []. apply Ordinal. Defined.
Definition p1 : 'I_4. Proof. have : 1 < 4 by []. apply Ordinal. Defined.
Definition p2 : 'I_4. Proof. have : 2 < 4 by []. apply Ordinal. Defined.
Definition p3 : 'I_4. Proof. have : 3 < 4 by []. apply Ordinal. Defined.

(* 同じ行(列)は「=」が成立する。 *)
Goal p1 = p1.
Proof.
    by [].
Qed.

(* 違う行(列)は「<>」が成立する。 *)
Goal p1 <> p2.
Proof.
  by [].
Qed.

(* 蛇足： set について *)
Compute [set p0; p1; p2; p3] \in {set 'I_4}.
Check [:: p0; p1; p2; p3] : seq 'I_4.

(* tpermの引数は置換後の値 *)
(*
盤面は、列に対して、駒のいる行を返す置換、として定義する。
4-Queensの場合の解は、列(0,1,2,3)に対して、行(1,3,0,2)の置換になっている。

 0 1 2 3   列
 1 3 0 2   行
|-|-|Q|-|
|Q|-|-|-|
|-|-|-|Q|
|-|Q|-|-|
*)

(* 上記の置換が次のように記述できる。置換なので'I_4 -> 'I_4の型である。 *)
Definition board1 : 'I_4 -> 'I_4 :=
  (tperm p2 p3) \o (tperm p0 p2) \o (tperm p0 p1).

(* tperm _ _ は、{perm T}型だが、コアーションが効いているのだ *)
Check (tperm p2 p3) : {perm 'I_4}.
Check (tperm p2 p3) : 'S_4.
(* Coercionが効いている。 *)
Check fun_of_perm (tperm p2 p3) : 'I_4 -> 'I_4.

(* tperm についての補題 *)
Check tpermL.                               (* (tperm x y) y = x *)
Check tpermR.                               (* (tperm x y) y = x *)
Check tpermD.                               (* (tperm x y) z = z *)

(* tpermの引数を置換後の値で書く場合 *)
(* 列(0,1,2,3)に対して、行(1,3,0,2)がえられることを確認する *)
(* tpermDを使う場所を間違えると解けなくなる。 *)
Goal board1 p0 = p1.
Proof.
  rewrite /board1 /=.
  rewrite ?tpermR ?tpermL.
  rewrite [(tperm _ _) p1]tpermD => //=.
  rewrite [(tperm _ _) p1]tpermD => //=.
Qed.

Goal board1 p1 = p3.
Proof.
  rewrite /board1 /=.
  rewrite ?tpermR ?tpermL.
  by [].
Qed.

Goal board1 p2 = p0.
Proof.
  rewrite /board1 /=.
  rewrite ?tpermR ?tpermL.
  rewrite [(tperm _ _) p2]tpermD => //=.
  rewrite ?tpermR ?tpermL.
  rewrite [(tperm _ _) p0]tpermD => //=.
Qed.

Goal board1 p3 = p2.
Proof.
  rewrite /board1 /=.
  rewrite ?tpermR ?tpermL.
  rewrite [(tperm _ _) p3]tpermD => //=.
  rewrite [(tperm _ _) p3]tpermD => //=.
  rewrite ?tpermR ?tpermL.
  by [].
Qed.

(* tpermの引数を置換前の値で書く場合 *)
(* 置換としてはおなじ。 *)
Definition board2 :=
  (tperm p0 p1) \o (tperm p1 p2) \o (tperm p1 p3).

Check tpermL.                               (* (tperm x y) y = x *)
Check tpermR.                               (* (tperm x y) y = x *)
Check tpermD.                               (* (tperm x y) z = z *)

Goal board2 p0 = p1.
Proof.
  rewrite /board2 /=.
  rewrite [(tperm _ _) p0]tpermD //=.
  rewrite [(tperm _ _) p0]tpermD //=.
  by rewrite ?tpermR ?tpermL.
Qed.

Goal board2 p1 = p3.
Proof.
  rewrite /board2 /=.
  rewrite ?tpermR ?tpermL.
  rewrite [(tperm _ _) p3]tpermD //=.
  rewrite [(tperm _ _) p3]tpermD //=.
Qed.

Goal board2 p2 = p0.
Proof.
  rewrite /board2 /=.
  rewrite [(tperm _ _) p2]tpermD //=.
  by rewrite ?tpermR ?tpermL.
Qed.

Goal board2 p3 = p2.
Proof.
  rewrite /board2 /=.
  rewrite ?tpermR ?tpermL.
  by rewrite [(tperm _ _) p2]tpermD //=.
Qed.

(* ふたつの盤面が同じであることを示す。 *)
Goal board1 =1 board2.
Proof.
  case.
  admit.
Qed.

(* (p列, b p行)の駒と、(q列, b q行)の駒が、
筋にいるとき真となる命題を定義する。 *)
Definition attacked (b : 'I_4 -> 'I_4)  (p q : 'I_4) :=
    p = q \/
    b p = b q \/
    b p + p = b q + q \/
    b p + q = b q + q.

(* (p0, p1)の駒と、(p1, p3)の駒が、筋にないこと示す。 *)
Goal ~ attacked board1 p0 p1.
Proof.
  rewrite /attacked /board1.
  case; case; case => /= H.
  - by [].
  - rewrite ?tpermL ?tpermR in H.
    rewrite [(tperm _ _) p1]tpermD //= in H.
    rewrite [(tperm _ _) p1]tpermD //= in H.
    by rewrite ?tpermL ?tpermR in H.
  - rewrite ?tpermL ?tpermR in H.
    rewrite [(tperm _ _) p1]tpermD //= in H.
    rewrite [(tperm _ _) p1]tpermD //= in H.
    by rewrite ?tpermL ?tpermR in H.
  - rewrite ?tpermL ?tpermR in H.
    rewrite [(tperm _ _) p1]tpermD //= in H.
    rewrite [(tperm _ _) p1]tpermD //= in H.
    by rewrite ?tpermL ?tpermR in H.
Qed.

(* (p行, b p列)の駒と、(q行, b q列)の駒が、
筋にいるとき真となる命題を定義する。 bool版 *)
Definition attacked' (b : 'I_4 -> 'I_4)  (p q : 'I_4) : bool :=
    (p == q) ||
    (b p == b q) ||
    (b p + p == b q + q) ||
    (b p + q == b q + q).

Definition consistent (b : 'I_4 -> 'I_4) :=
  [forall p : 'I_4, forall q : 'I_4, ~~ attacked' b p q].

Goal consistent board1.
Proof.
  rewrite /consistent /attacked'.
  apply/forallP => p.
  Check negb_exists.
  rewrite -negb_exists.
  apply/negP=> H.
  move/existsP in H.
  case: H.
  move=> q.
  admit.
Qed.

(* END *)


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma rev_append : forall (x y : lst), rev (append x y) = append (rev y) (rev x).
Proof.
   intros.
   induction x.
   - simpl. rewrite append_nil. reflexivity.
   - simpl. rewrite IHx. rewrite append_assoc. reflexivity.
Qed.

Lemma rev_rev : forall (x : lst), rev (rev x) = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite rev_append. simpl. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (append (rev x) (rev y))) (append y x).
Proof.
   induction x.
   - intros. simpl. rewrite rev_rev. rewrite append_nil. reflexivity.
   - intros. simpl. rewrite rev_append. simpl. rewrite (eq_refl : Cons n Nil = rev (Cons n Nil)). rewrite IHx. lfind. Admitted.


From Coq Require Import ssreflect ssrfun ssrbool.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import List.
Import ListNotations.
Require Import String.
Open Scope string_scope.
Require Import Coq.Program.Basics.
Open Scope program_scope.

Require Import bol.
Require Import fol.
Require Import sql.
Require Import boltofol.
Require Import boltosql.
Require Import foltotptp.

Definition sampleOntology : bolOntology :=
  SIGNATURE
    CON "professor" ;;
    CON "lecturer" ;;
    CON "course" ;;

    REL "teaches" ;;
    REL "taughtat" ;;
    REL "responsiblefor" ;;
    PROP "ects" TYPE bolInt ;;
    PROP "hard" TYPE bolBool ;;

    IND "fr" ;;
    IND "wuv" ;;
    IND "fau" ;;
  END
  THEORY
    "wuv" HAS 5 OF "ects" ;;
    "wuv" IS-NOT "hard" ;;

    "wuv" IS-A "course" ;;

    "wuv" <."taughtat".> "fau" ;;

    "fr" IS-A "lecturer" ;;
    "fr" <."teaches" ; "taughtat".> "fau" ;;  (* FR teaches at least one course at FAU *)
    "lecturer" <<= ("course" forall "teaches") ;; (* lecturers only teach courses, nothing else *)
  END.

Definition sampleQuery: bolQuery :=
  (sampleOntology, "wuv" IS-A "course").

Definition bolToTPTP := folToTPTP ∘ bolToFol.
Definition bolQueryToTPTP := tptpQueryToString ∘ folQueryToTPTP ∘ bolQueryToFol.

Compute (bolQueryToFol sampleQuery).
Compute (bolQueryToTPTP sampleQuery).

Compute (prettyPrintSqlSystem (sqlSemantics sampleOntology)).

(* Question:

   with logics there is usually a nice distinction between signature and theory, right? (or perhaps not if you take MMT itself as a logic?)

   I don't see why "ind IS-A concept" should be part of the signature. Isn't it more natural (also for the derivation calculus!) to be a formula? In fact, some derivation rules need to add such things to the context. But adding to a signature seems strange.

   However, in SQL the distinction matters. If you specify an ontology with "ind IS-A concept", then the table for "concept" should contain "ind" (i.e., an INSERT INTO should have been generated) whereas as a formula no INSERT INTO should be generated.
*)

(* Design Decisions

(1) Formalize contexts as lists

    not as (Decl -> Type) * (Formula -> Type) functions as that doesn't allow generating fresh names

*)

(* Issues:

   TPTP has strict naming conventions: function and predicate symbols must adhere to regex [a-z]+ while quantified variables must adhere to [A-Z]+.

   Hence, I changed the name generation in boltofol, but ideally, we want to do alpha-renaming on FOL formulae within foltotptp.

   However, that would require an alpha-renaming machinery to be implemented for fol.
*)