(** * Miscellaneous Well-Foundedness Facts *)
Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import Coq.Setoids.Setoid Coq.Program.Program Coq.Program.Wf Coq.Arith.Wf_nat Coq.Classes.Morphisms Coq.Init.Wf.
Require Import Fiat.Common.Telescope.Core.
Require Import Fiat.Common.Telescope.Instances.
Require Import Fiat.Common.Telescope.Equality.
Require Import Fiat.Common.
Require Import Fiat.Common.Equality.

Set Implicit Arguments.

Local Ltac Fix_eq_t F_ext Rwf :=
  let generalize_if_not_var x :=
      first [ is_var x; fail 1
            | generalize x ] in
  intros;
  unfold Fix;
  rewrite <- Fix_F_eq;
  apply F_ext; intros;
  repeat match goal with
           | [ |- context[Fix_F _ _ ?x] ] => generalize_if_not_var x
           | [ |- context[Fix_F _ _ ?x _] ] => generalize_if_not_var x
         end;
  clear -F_ext Rwf;
  match goal with
    | [ |- forall x : Acc _ ?a, _ ] => induction (Rwf a)
  end;
  intros; rewrite <- !Fix_F_eq;
  apply F_ext; eauto.

Local Ltac Fix_Proper_t Fix_eq wf :=
  change (@flatten_forall_eq_relation) with (@flatten_forall_eq);
  change (@flatten_forall_eq_relation_with_assumption) with (@flatten_forall_eq_with_assumption);
  let H := fresh "H" in
  let a := fresh "a" in
  unfold forall_relation, pointwise_relation, respectful;
  intros ?? H a; repeat intro;
  induction (wf a);
  rewrite !Fix_eq; [ erewrite H; [ reflexivity | .. ] | .. ]; eauto; intros;
  [ etransitivity; [ symmetry; apply H; reflexivity | apply H; eassumption ]; reflexivity
  | etransitivity; [ apply H; eassumption | symmetry; apply H; reflexivity ]; reflexivity ].

Section FixV.
  Context A (B : A -> Telescope)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a, flattenT (B a) Type).

  Local Notation FixV := (@Fix A R Rwf (fun a : A => flatten_forall (P a))).

  Section F.
    Context (F : forall x : A, (forall y : A, R y x -> flatten_forall (P y)) -> flatten_forall (P x)).

    Definition FixV_eq
               (F_ext : forall x (f g : forall y, R y x -> flatten_forall (P y)),
                          (forall y (p : R y x), flatten_forall_eq (f y p) (g y p))
                          -> flatten_forall_eq (@F x f) (@F x g))
    : forall a, flatten_forall_eq (@FixV F a) (@F a (fun y (_ : R y a) => @FixV F y)).
    Proof. Fix_eq_t F_ext Rwf. Defined.

    Definition FixV_eq_with_assumption
               Q
               (F_ext : forall x (f g : forall y, R y x -> flatten_forall (P y)),
                          (forall y (p : R y x), flatten_forall_eq_with_assumption (Q y) (f y p) (g y p))
                          -> flatten_forall_eq_with_assumption (Q x) (@F x f) (@F x g))
    : forall a, flatten_forall_eq_with_assumption (Q a) (@FixV F a) (@F a (fun y (_ : R y a) => @FixV F y)).
    Proof. Fix_eq_t F_ext Rwf. Defined.

    Definition FixV_rect
               (Q : forall a, flattenT (Telescope_append (B a) (P a)) Type)
               (H0 : forall x, (forall y, R y x -> flatten_append_forall (@Q y) (@FixV F y))
                              -> flatten_append_forall (@Q x) (@F x (fun (y : A) (_ : R y x) => @FixV F y)))
               (F_ext : forall x (f g : forall y, R y x -> flatten_forall (@P y)),
                          (forall y (p : R y x), flatten_forall_eq (f y p) (g y p))
                          -> flatten_forall_eq (@F x f) (@F x g))
               a
    : flatten_append_forall (@Q a) (@FixV F a).
    Proof.
      induction (Rwf a).
      eapply flatten_append_forall_Proper; auto with nocore.
      symmetry; eapply FixV_eq; auto with nocore.
    Defined.
  End F.

  Global Instance FixV_Proper_eq
  : Proper
      ((forall_relation
          (fun a =>
             (forall_relation
                (fun a' =>
                   pointwise_relation
                     _
                     (flatten_forall_eq_relation)))
               ==> flatten_forall_eq_relation))
         ==> (forall_relation (fun a => flatten_forall_eq_relation)))
      FixV.
  Proof. Fix_Proper_t @FixV_eq Rwf. Qed.

  Global Instance FixV_Proper_eq_with_assumption
         Q
  : Proper
      ((forall_relation
          (fun a : A =>
             (forall_relation
                (fun a' : A =>
                   pointwise_relation
                     (R a' a)
                     (flatten_forall_eq_relation_with_assumption (Q a'))))
               ==> flatten_forall_eq_relation_with_assumption (Q a)))
         ==> (forall_relation (fun a => flatten_forall_eq_relation_with_assumption (Q a))))
      FixV.
  Proof. Fix_Proper_t @FixV_eq_with_assumption Rwf. Qed.
End FixV.

Arguments FixV_Proper_eq {A B R Rwf P} _ _ _ _.
Arguments FixV_Proper_eq_with_assumption {A B R Rwf P} _ _ _ _ _.

Local Arguments flatten_forall / _ _.
Local Arguments flattenT / _ _.
Local Arguments flatten_forall_eq / _ _ _ _.
Local Arguments flatten_forall_eq_relation / _ _ _ _.
Local Arguments flatten_forall_eq_with_assumption / _ _ _ _ _.
Local Arguments flatten_forall_eq_relation_with_assumption / _ _ _ _ _.
Local Arguments flatten_append_forall / _ _ _ _.

Local Notation type_of x := ((fun T (y : T) => T) _ x).

Section FixVTransfer.
  Context A (B B' : A -> Telescope)
          (f0 : forall a, flattenT_sig (B a) -> flattenT_sig (B' a))
          (g0 : forall a, flattenT_sig (B' a) -> flattenT_sig (B a))
          (sect : forall a x, g0 a (f0 a x) = x)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a, flattenT (B a) Type).

  Let P' : forall a, flattenT (B' a) Type
    := fun a => flattenT_unapply (fun x => flattenT_apply (P a) (g0 _ x)).

  Local Notation FixV := (@Fix A R Rwf (fun a : A => flatten_forall (P a))).
  Local Notation FixV' := (@Fix A R Rwf (fun a : A => flatten_forall (P' a))).

  Section F.
    Context (F : forall x : A, (forall y : A, R y x -> flatten_forall (P y)) -> flatten_forall (P x)).

    Let transfer
    : forall y,
        flatten_forall
          (flattenT_unapply
             (fun x : flattenT_sig (B y) => flattenT_apply (P' y) (f0 y x)))
        -> flatten_forall (P y).
    Proof.
      intro y.
      refine (flatten_forall_eq_rect
                (transitivity
                   ((_ : Proper (pointwise_relation _ _ ==> _) flattenT_unapply)
                      _ _
                      (fun x' => transitivity
                                   (symmetry (flattenT_apply_unapply _ _))
                                   (f_equal (flattenT_apply _) (sect _ _))))
                   (symmetry (flattenT_unapply_apply _)))).
    Defined.

    Let transfer'
    : forall a,
        flatten_forall (P a)
        -> flatten_forall (P' a).
    Proof.
      intro a.
      refine (fun f' => flatten_forall_unapply (fun x' => flatten_forall_apply f' (g0 _ x'))).
    Defined.

    Let untransfer'
    : forall a,
        flatten_forall (P' a)
        -> flatten_forall (P a).
    Proof.
      intro a.
      refine (fun f' => _).
      refine (transfer
                _
                (flatten_forall_unapply (fun x => flatten_forall_apply f' (f0 _ x)))).
    Defined.

    Let F' : forall x : A, (forall y : A, R y x -> flatten_forall (P' y)) -> flatten_forall (P' x)
      := fun a F' => transfer' _ (@F a (fun y pf => transfer _ (flatten_forall_unapply (fun x => flatten_forall_apply (F' y pf) (f0 _ x))))).

    Context (F_ext : forall x (f g : forall y, R y x -> flatten_forall (P y)),
                       (forall y (p : R y x), flatten_forall_eq (f y p) (g y p))
                       -> flatten_forall_eq (@F x f) (@F x g)).

    Lemma F'_ext
    : forall x (f g : forall y, R y x -> flatten_forall (P' y)),
        (forall y (p : R y x), flatten_forall_eq (f y p) (g y p))
        -> flatten_forall_eq (@F' x f) (@F' x g).
    Proof.
      intros x f' g' IH.
      subst F' transfer transfer'; cbv beta.
      apply (_ : Proper (forall_relation _ ==> _) flatten_forall_unapply); intro.
      apply flatten_forall_apply_Proper.
      apply F_ext; intros.
      refine ((_ : Proper (flatten_forall_eq ==> _) (@flatten_forall_eq_rect _ _ _ _)) _ _ _).
      apply (_ : Proper (forall_relation _ ==> _) flatten_forall_unapply); intro.
      apply flatten_forall_apply_Proper.
      apply IH.
    Qed.

    Definition FixV_transfer_eq
               a
    : flatten_forall_eq (@FixV F a) (untransfer' _ (@FixV' F' a)).
    Proof.
      induction (Rwf a).
      rewrite FixV_eq by eauto with nocore.
      etransitivity_rev _.
      { unfold transfer, untransfer'; cbv beta.
        apply flatten_forall_eq_rect_Proper, flatten_forall_unapply_Proper; intro.
        apply flatten_forall_apply_Proper.
        rewrite FixV_eq by auto using F'_ext with nocore.
        reflexivity. }
      etransitivity.
      { apply F_ext; intros.
        set_evars.
        match goal with
          | [ H : forall y r, flatten_forall_eq _ _ |- _ ] => rewrite H by assumption
        end.
        match goal with
          | [ |- ?R ?a (?e ?x ?y) ]
            => revert x y
        end.
        match goal with
          | [ H := ?e |- _ ] => is_evar e; subst H
        end.
        match goal with
          | [ |- forall x y, ?R (@?LHS x y) (?RHS x y) ]
            => unify LHS RHS; cbv beta
        end.
        reflexivity. }
      lazymatch goal with
        | [ |- context[FixV' ?F _] ]
          => generalize (FixV' F)
      end.
      subst F'; cbv beta.
      subst untransfer' transfer transfer'; cbv beta.
      intro.
      rewrite flatten_forall_eq_rect_trans.
      match goal with
        | [ |- context[flatten_forall_eq_rect
                            (flattenT_unapply_Proper ?P ?Q ?H)
                            (flatten_forall_unapply ?f)] ]
          => rewrite (@flatten_forall_eq_rect_flattenT_unapply_Proper _ P Q H f)
      end.
      etransitivity_rev _.
      { apply flatten_forall_eq_rect_Proper.
        apply flatten_forall_unapply_Proper; intro.
        match goal with
          | [ |- context[@transitivity _ (@eq ?A) ?P _ _ _ _ _] ]
            => change (@transitivity _ (@eq ?A) P) with (@eq_trans A)
        end.
        match goal with
          | [ |- context[@symmetry _ (@eq ?A) ?P _ _ _] ]
            => change (@symmetry _ (@eq ?A) P) with (@eq_sym A)
        end.
        set_evars.
        rewrite @transport_pp.
        match goal with
          | [ |- context G[eq_rect _ (fun T => T) (flatten_forall_apply (flatten_forall_unapply ?k) ?x0) _ (eq_sym (flattenT_apply_unapply ?f1 ?x0))] ]
            => let H := fresh in
               pose proof (@eq_rect_symmetry_flattenT_apply_unapply _ f1 x0 k) as H;
                 cbv beta in H |- *;
                 let RHS := match type of H with _ = ?RHS => constr:(RHS) end in
                 let LHS := match type of H with ?LHS = _ => constr:(LHS) end in
                 let G' := context G[LHS] in
                 change G';
                   rewrite H;
                   clear H
        end.
        match goal with
          | [ |- context[f_equal _ ?p] ]
            => destruct p; unfold f_equal; simpl @eq_rect
        end.
        subst_body.
        reflexivity. }
      rewrite flatten_forall_eq_rect_symmetry_flattenT_unapply_apply.
      apply F_ext; intros.
      reflexivity.
    Qed.
  End F.
End FixVTransfer.

Section Fix_rect.
  Context (A : Type).
  Local Notation T := (fun _ : A => bottom).

  Let Fix_rect' := @FixV_rect A T.
  Let Fix_rect'T := Eval simpl in type_of Fix_rect'.

  Let Fix_Proper_eq' := @FixV_Proper_eq A T.
  Let Fix_Proper_eq'T := Eval simpl in type_of Fix_Proper_eq'.

  Let Fix_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T.
  Let Fix_Proper_eq_with_assumption'T := Eval simpl in type_of Fix_Proper_eq_with_assumption'.

  Definition Fix_rect : Fix_rect'T := Fix_rect'.
  Definition Fix_Proper_eq : Fix_Proper_eq'T := Fix_Proper_eq'.
  Definition Fix_Proper_eq_with_assumption : Fix_Proper_eq_with_assumption'T := Fix_Proper_eq_with_assumption'.
End Fix_rect.

Arguments Fix_Proper_eq {A R Rwf P} _ _ _ _.
Arguments Fix_Proper_eq_with_assumption {A R Rwf P} _ _ _ _ _ _.
Global Existing Instance Fix_Proper_eq.
Global Existing Instance Fix_Proper_eq_with_assumption.

(** A variant of [Fix] that has a nice [Fix_eq] for functions which
    doesn't require [functional_extensionality]. *)
(* Following code generated by the following Python script:
<<
ALPHA = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
alpha = ALPHA.lower()
for fixn in range(1, 11):
    print(r"""Section Fix%(fixn)d.""" % locals())
    def make_forall(n, pat, skip_forall=0):
        mycur = ''
        if n > skip_forall + 1:
            mycur += 'forall ' + ' '.join(alpha[skip_forall:n-1]) + ', '
        mycur2 = ''
        if n > 1:
            mycur2 += ' ' + ' '.join(alpha[:n-1])
        return mycur + (pat % mycur2)

    cur = '  Context A'
    for j in range(1, fixn + 1):
        cur += ' (%s : ' % ALPHA[j]
        cur += make_forall(j, '%s%%s -> Type)' % ALPHA[j-1])
    print(cur)
    print(r"""          (R : A -> A -> Prop) (Rwf : well_founded R)""")
    cur = "          (P : "
    cur += make_forall(j+1, '%s%%s -> Type).' % ALPHA[j])
    print(cur)
    print("")
    cur = "  Local Notation Fix%d := (@Fix A R Rwf (fun a : A => %s))."
    cur = cur % (j, make_forall(j+2, '@P%s', skip_forall=1))
    print(cur)
    def make_tele(chars, final, append=''):
        if chars:
            return '(fun %s => tele _ %s)' % (chars[0], make_tele(chars[1:], final, append + ' ' + chars[0]))
        else:
            return '(fun _ : %s%s => bottom)' % (final, append)
    print('  Local Notation T := %s.' % make_tele(alpha[:fixn], '@' + ALPHA[fixn]))
    fix_underscores = ' '.join('_' for i in range(fixn + 4))
    letters = ' '.join(ALPHA[:fixn+1])
    preletters = ' '.join(ALPHA[:fixn])
    print(r"""
  Let Fix%(fixn)d_eq' := @FixV_eq A T R Rwf P.
  Let Fix%(fixn)d_eq'T := Eval simpl in type_of Fix%(fixn)d_eq'.

  Let Fix%(fixn)d_rect' := @FixV_rect A T R Rwf P.
  Let Fix%(fixn)d_rect'T := Eval simpl in type_of Fix%(fixn)d_rect'.

  Let Fix%(fixn)d_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix%(fixn)d_Proper_eq'T := Eval simpl in type_of Fix%(fixn)d_Proper_eq'.

  Let Fix%(fixn)d_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix%(fixn)d_Proper_eq_with_assumption'T := Eval simpl in type_of Fix%(fixn)d_Proper_eq_with_assumption'.

  Definition Fix%(fixn)d_eq : Fix%(fixn)d_eq'T := Fix%(fixn)d_eq'.
  Definition Fix%(fixn)d_rect : Fix%(fixn)d_rect'T := Fix%(fixn)d_rect'.
  Definition Fix%(fixn)d_Proper_eq : Fix%(fixn)d_Proper_eq'T := Fix%(fixn)d_Proper_eq'.
  Definition Fix%(fixn)d_Proper_eq_with_assumption : Fix%(fixn)d_Proper_eq_with_assumption'T := Fix%(fixn)d_Proper_eq_with_assumption'.
End Fix%(fixn)d.

Arguments Fix%(fixn)d_Proper_eq {%(letters)s R Rwf P} %(fix_underscores)s.
Arguments Fix%(fixn)d_Proper_eq_with_assumption {%(letters)s R Rwf P} _ _ %(fix_underscores)s.
Global Existing Instance Fix%(fixn)d_Proper_eq.
Global Existing Instance Fix%(fixn)d_Proper_eq_with_assumption.
""" % locals())
>> *)
Section Fix1.
  Context A (B : A -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a, B a -> Type).

  Local Notation Fix1 := (@Fix A R Rwf (fun a : A => forall b, @P a b)).
  Local Notation T := (fun a => tele _ (fun _ : @B a => bottom)).

  Let Fix1_eq' := @FixV_eq A T R Rwf P.
  Let Fix1_eq'T := Eval simpl in type_of Fix1_eq'.

  Let Fix1_rect' := @FixV_rect A T R Rwf P.
  Let Fix1_rect'T := Eval simpl in type_of Fix1_rect'.

  Let Fix1_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix1_Proper_eq'T := Eval simpl in type_of Fix1_Proper_eq'.

  Let Fix1_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix1_Proper_eq_with_assumption'T := Eval simpl in type_of Fix1_Proper_eq_with_assumption'.

  Definition Fix1_eq : Fix1_eq'T := Fix1_eq'.
  Definition Fix1_rect : Fix1_rect'T := Fix1_rect'.
  Definition Fix1_Proper_eq : Fix1_Proper_eq'T := Fix1_Proper_eq'.
  Definition Fix1_Proper_eq_with_assumption : Fix1_Proper_eq_with_assumption'T := Fix1_Proper_eq_with_assumption'.
End Fix1.

Arguments Fix1_Proper_eq {A B R Rwf P} _ _ _ _ _.
Arguments Fix1_Proper_eq_with_assumption {A B R Rwf P} _ _ _ _ _ _ _.
Global Existing Instance Fix1_Proper_eq.
Global Existing Instance Fix1_Proper_eq_with_assumption.

Section Fix2.
  Context A (B : A -> Type) (C : forall a, B a -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b, C a b -> Type).

  Local Notation Fix2 := (@Fix A R Rwf (fun a : A => forall b c, @P a b c)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun _ : @C a b => bottom))).

  Let Fix2_eq' := @FixV_eq A T R Rwf P.
  Let Fix2_eq'T := Eval simpl in type_of Fix2_eq'.

  Let Fix2_rect' := @FixV_rect A T R Rwf P.
  Let Fix2_rect'T := Eval simpl in type_of Fix2_rect'.

  Let Fix2_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix2_Proper_eq'T := Eval simpl in type_of Fix2_Proper_eq'.

  Let Fix2_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix2_Proper_eq_with_assumption'T := Eval simpl in type_of Fix2_Proper_eq_with_assumption'.

  Definition Fix2_eq : Fix2_eq'T := Fix2_eq'.
  Definition Fix2_rect : Fix2_rect'T := Fix2_rect'.
  Definition Fix2_Proper_eq : Fix2_Proper_eq'T := Fix2_Proper_eq'.
  Definition Fix2_Proper_eq_with_assumption : Fix2_Proper_eq_with_assumption'T := Fix2_Proper_eq_with_assumption'.
End Fix2.

Arguments Fix2_Proper_eq {A B C R Rwf P} _ _ _ _ _ _.
Arguments Fix2_Proper_eq_with_assumption {A B C R Rwf P} _ _ _ _ _ _ _ _.
Global Existing Instance Fix2_Proper_eq.
Global Existing Instance Fix2_Proper_eq_with_assumption.

Section Fix3.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c, D a b c -> Type).

  Local Notation Fix3 := (@Fix A R Rwf (fun a : A => forall b c d, @P a b c d)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun _ : @D a b c => bottom)))).

  Let Fix3_eq' := @FixV_eq A T R Rwf P.
  Let Fix3_eq'T := Eval simpl in type_of Fix3_eq'.

  Let Fix3_rect' := @FixV_rect A T R Rwf P.
  Let Fix3_rect'T := Eval simpl in type_of Fix3_rect'.

  Let Fix3_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix3_Proper_eq'T := Eval simpl in type_of Fix3_Proper_eq'.

  Let Fix3_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix3_Proper_eq_with_assumption'T := Eval simpl in type_of Fix3_Proper_eq_with_assumption'.

  Definition Fix3_eq : Fix3_eq'T := Fix3_eq'.
  Definition Fix3_rect : Fix3_rect'T := Fix3_rect'.
  Definition Fix3_Proper_eq : Fix3_Proper_eq'T := Fix3_Proper_eq'.
  Definition Fix3_Proper_eq_with_assumption : Fix3_Proper_eq_with_assumption'T := Fix3_Proper_eq_with_assumption'.
End Fix3.

Arguments Fix3_Proper_eq {A B C D R Rwf P} _ _ _ _ _ _ _.
Arguments Fix3_Proper_eq_with_assumption {A B C D R Rwf P} _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix3_Proper_eq.
Global Existing Instance Fix3_Proper_eq_with_assumption.

Section Fix4.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d, E a b c d -> Type).

  Local Notation Fix4 := (@Fix A R Rwf (fun a : A => forall b c d e, @P a b c d e)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun _ : @E a b c d => bottom))))).

  Let Fix4_eq' := @FixV_eq A T R Rwf P.
  Let Fix4_eq'T := Eval simpl in type_of Fix4_eq'.

  Let Fix4_rect' := @FixV_rect A T R Rwf P.
  Let Fix4_rect'T := Eval simpl in type_of Fix4_rect'.

  Let Fix4_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix4_Proper_eq'T := Eval simpl in type_of Fix4_Proper_eq'.

  Let Fix4_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix4_Proper_eq_with_assumption'T := Eval simpl in type_of Fix4_Proper_eq_with_assumption'.

  Definition Fix4_eq : Fix4_eq'T := Fix4_eq'.
  Definition Fix4_rect : Fix4_rect'T := Fix4_rect'.
  Definition Fix4_Proper_eq : Fix4_Proper_eq'T := Fix4_Proper_eq'.
  Definition Fix4_Proper_eq_with_assumption : Fix4_Proper_eq_with_assumption'T := Fix4_Proper_eq_with_assumption'.
End Fix4.

Arguments Fix4_Proper_eq {A B C D E R Rwf P} _ _ _ _ _ _ _ _.
Arguments Fix4_Proper_eq_with_assumption {A B C D E R Rwf P} _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix4_Proper_eq.
Global Existing Instance Fix4_Proper_eq_with_assumption.

Section Fix5.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type) (F : forall a b c d, E a b c d -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d e, F a b c d e -> Type).

  Local Notation Fix5 := (@Fix A R Rwf (fun a : A => forall b c d e f, @P a b c d e f)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun e => tele _ (fun _ : @F a b c d e => bottom)))))).

  Let Fix5_eq' := @FixV_eq A T R Rwf P.
  Let Fix5_eq'T := Eval simpl in type_of Fix5_eq'.

  Let Fix5_rect' := @FixV_rect A T R Rwf P.
  Let Fix5_rect'T := Eval simpl in type_of Fix5_rect'.

  Let Fix5_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix5_Proper_eq'T := Eval simpl in type_of Fix5_Proper_eq'.

  Let Fix5_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix5_Proper_eq_with_assumption'T := Eval simpl in type_of Fix5_Proper_eq_with_assumption'.

  Definition Fix5_eq : Fix5_eq'T := Fix5_eq'.
  Definition Fix5_rect : Fix5_rect'T := Fix5_rect'.
  Definition Fix5_Proper_eq : Fix5_Proper_eq'T := Fix5_Proper_eq'.
  Definition Fix5_Proper_eq_with_assumption : Fix5_Proper_eq_with_assumption'T := Fix5_Proper_eq_with_assumption'.
End Fix5.

Arguments Fix5_Proper_eq {A B C D E F R Rwf P} _ _ _ _ _ _ _ _ _.
Arguments Fix5_Proper_eq_with_assumption {A B C D E F R Rwf P} _ _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix5_Proper_eq.
Global Existing Instance Fix5_Proper_eq_with_assumption.

Section Fix6.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type) (F : forall a b c d, E a b c d -> Type) (G : forall a b c d e, F a b c d e -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d e f, G a b c d e f -> Type).

  Local Notation Fix6 := (@Fix A R Rwf (fun a : A => forall b c d e f g, @P a b c d e f g)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun e => tele _ (fun f => tele _ (fun _ : @G a b c d e f => bottom))))))).

  Let Fix6_eq' := @FixV_eq A T R Rwf P.
  Let Fix6_eq'T := Eval simpl in type_of Fix6_eq'.

  Let Fix6_rect' := @FixV_rect A T R Rwf P.
  Let Fix6_rect'T := Eval simpl in type_of Fix6_rect'.

  Let Fix6_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix6_Proper_eq'T := Eval simpl in type_of Fix6_Proper_eq'.

  Let Fix6_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix6_Proper_eq_with_assumption'T := Eval simpl in type_of Fix6_Proper_eq_with_assumption'.

  Definition Fix6_eq : Fix6_eq'T := Fix6_eq'.
  Definition Fix6_rect : Fix6_rect'T := Fix6_rect'.
  Definition Fix6_Proper_eq : Fix6_Proper_eq'T := Fix6_Proper_eq'.
  Definition Fix6_Proper_eq_with_assumption : Fix6_Proper_eq_with_assumption'T := Fix6_Proper_eq_with_assumption'.
End Fix6.

Arguments Fix6_Proper_eq {A B C D E F G R Rwf P} _ _ _ _ _ _ _ _ _ _.
Arguments Fix6_Proper_eq_with_assumption {A B C D E F G R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix6_Proper_eq.
Global Existing Instance Fix6_Proper_eq_with_assumption.

Section Fix7.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type) (F : forall a b c d, E a b c d -> Type) (G : forall a b c d e, F a b c d e -> Type) (H : forall a b c d e f, G a b c d e f -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d e f g, H a b c d e f g -> Type).

  Local Notation Fix7 := (@Fix A R Rwf (fun a : A => forall b c d e f g h, @P a b c d e f g h)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun e => tele _ (fun f => tele _ (fun g => tele _ (fun _ : @H a b c d e f g => bottom)))))))).

  Let Fix7_eq' := @FixV_eq A T R Rwf P.
  Let Fix7_eq'T := Eval simpl in type_of Fix7_eq'.

  Let Fix7_rect' := @FixV_rect A T R Rwf P.
  Let Fix7_rect'T := Eval simpl in type_of Fix7_rect'.

  Let Fix7_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix7_Proper_eq'T := Eval simpl in type_of Fix7_Proper_eq'.

  Let Fix7_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix7_Proper_eq_with_assumption'T := Eval simpl in type_of Fix7_Proper_eq_with_assumption'.

  Definition Fix7_eq : Fix7_eq'T := Fix7_eq'.
  Definition Fix7_rect : Fix7_rect'T := Fix7_rect'.
  Definition Fix7_Proper_eq : Fix7_Proper_eq'T := Fix7_Proper_eq'.
  Definition Fix7_Proper_eq_with_assumption : Fix7_Proper_eq_with_assumption'T := Fix7_Proper_eq_with_assumption'.
End Fix7.

Arguments Fix7_Proper_eq {A B C D E F G H R Rwf P} _ _ _ _ _ _ _ _ _ _ _.
Arguments Fix7_Proper_eq_with_assumption {A B C D E F G H R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix7_Proper_eq.
Global Existing Instance Fix7_Proper_eq_with_assumption.

Section Fix8.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type) (F : forall a b c d, E a b c d -> Type) (G : forall a b c d e, F a b c d e -> Type) (H : forall a b c d e f, G a b c d e f -> Type) (I : forall a b c d e f g, H a b c d e f g -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d e f g h, I a b c d e f g h -> Type).

  Local Notation Fix8 := (@Fix A R Rwf (fun a : A => forall b c d e f g h i, @P a b c d e f g h i)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun e => tele _ (fun f => tele _ (fun g => tele _ (fun h => tele _ (fun _ : @I a b c d e f g h => bottom))))))))).

  Let Fix8_eq' := @FixV_eq A T R Rwf P.
  Let Fix8_eq'T := Eval simpl in type_of Fix8_eq'.

  Let Fix8_rect' := @FixV_rect A T R Rwf P.
  Let Fix8_rect'T := Eval simpl in type_of Fix8_rect'.

  Let Fix8_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix8_Proper_eq'T := Eval simpl in type_of Fix8_Proper_eq'.

  Let Fix8_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix8_Proper_eq_with_assumption'T := Eval simpl in type_of Fix8_Proper_eq_with_assumption'.

  Definition Fix8_eq : Fix8_eq'T := Fix8_eq'.
  Definition Fix8_rect : Fix8_rect'T := Fix8_rect'.
  Definition Fix8_Proper_eq : Fix8_Proper_eq'T := Fix8_Proper_eq'.
  Definition Fix8_Proper_eq_with_assumption : Fix8_Proper_eq_with_assumption'T := Fix8_Proper_eq_with_assumption'.
End Fix8.

Arguments Fix8_Proper_eq {A B C D E F G H I R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _.
Arguments Fix8_Proper_eq_with_assumption {A B C D E F G H I R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix8_Proper_eq.
Global Existing Instance Fix8_Proper_eq_with_assumption.

Section Fix9.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type) (F : forall a b c d, E a b c d -> Type) (G : forall a b c d e, F a b c d e -> Type) (H : forall a b c d e f, G a b c d e f -> Type) (I : forall a b c d e f g, H a b c d e f g -> Type) (J : forall a b c d e f g h, I a b c d e f g h -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d e f g h i, J a b c d e f g h i -> Type).

  Local Notation Fix9 := (@Fix A R Rwf (fun a : A => forall b c d e f g h i j, @P a b c d e f g h i j)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun e => tele _ (fun f => tele _ (fun g => tele _ (fun h => tele _ (fun i => tele _ (fun _ : @J a b c d e f g h i => bottom)))))))))).

  Let Fix9_eq' := @FixV_eq A T R Rwf P.
  Let Fix9_eq'T := Eval simpl in type_of Fix9_eq'.

  Let Fix9_rect' := @FixV_rect A T R Rwf P.
  Let Fix9_rect'T := Eval simpl in type_of Fix9_rect'.

  Let Fix9_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix9_Proper_eq'T := Eval simpl in type_of Fix9_Proper_eq'.

  Let Fix9_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix9_Proper_eq_with_assumption'T := Eval simpl in type_of Fix9_Proper_eq_with_assumption'.

  Definition Fix9_eq : Fix9_eq'T := Fix9_eq'.
  Definition Fix9_rect : Fix9_rect'T := Fix9_rect'.
  Definition Fix9_Proper_eq : Fix9_Proper_eq'T := Fix9_Proper_eq'.
  Definition Fix9_Proper_eq_with_assumption : Fix9_Proper_eq_with_assumption'T := Fix9_Proper_eq_with_assumption'.
End Fix9.

Arguments Fix9_Proper_eq {A B C D E F G H I J R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _ _.
Arguments Fix9_Proper_eq_with_assumption {A B C D E F G H I J R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix9_Proper_eq.
Global Existing Instance Fix9_Proper_eq_with_assumption.

Section Fix10.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type) (F : forall a b c d, E a b c d -> Type) (G : forall a b c d e, F a b c d e -> Type) (H : forall a b c d e f, G a b c d e f -> Type) (I : forall a b c d e f g, H a b c d e f g -> Type) (J : forall a b c d e f g h, I a b c d e f g h -> Type) (K : forall a b c d e f g h i, J a b c d e f g h i -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d e f g h i j, K a b c d e f g h i j -> Type).

  Local Notation Fix10 := (@Fix A R Rwf (fun a : A => forall b c d e f g h i j k, @P a b c d e f g h i j k)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun e => tele _ (fun f => tele _ (fun g => tele _ (fun h => tele _ (fun i => tele _ (fun j => tele _ (fun _ : @K a b c d e f g h i j => bottom))))))))))).

  Let Fix10_eq' := @FixV_eq A T R Rwf P.
  Let Fix10_eq'T := Eval simpl in type_of Fix10_eq'.

  Let Fix10_rect' := @FixV_rect A T R Rwf P.
  Let Fix10_rect'T := Eval simpl in type_of Fix10_rect'.

  Let Fix10_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix10_Proper_eq'T := Eval simpl in type_of Fix10_Proper_eq'.

  Let Fix10_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix10_Proper_eq_with_assumption'T := Eval simpl in type_of Fix10_Proper_eq_with_assumption'.

  Definition Fix10_eq : Fix10_eq'T := Fix10_eq'.
  Definition Fix10_rect : Fix10_rect'T := Fix10_rect'.
  Definition Fix10_Proper_eq : Fix10_Proper_eq'T := Fix10_Proper_eq'.
  Definition Fix10_Proper_eq_with_assumption : Fix10_Proper_eq_with_assumption'T := Fix10_Proper_eq_with_assumption'.
End Fix10.

Arguments Fix10_Proper_eq {A B C D E F G H I J K R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _ _ _.
Arguments Fix10_Proper_eq_with_assumption {A B C D E F G H I J K R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix10_Proper_eq.
Global Existing Instance Fix10_Proper_eq_with_assumption.


(** * Fresh Constants *)

Set Implicit Arguments.

Require Import Coq.Arith.Max.
Require Export sublist.
Require Import language_syntax.

(** Remember that [constants] play the role of [parameters].
   In particular, we will show that fresh constants are as good as
   fresh parameters. *)

(** [new] chooses a fresh one which does not belong to lists. *)

Definition new (l:list name) : name := S (fold_right max 0 l).

Lemma new_no_zero : forall (l:list name), new l <> 0.
Proof.
  unfold new; intros; auto with arith.
Qed.

Lemma IN_less : forall (n:name)(l:list name),
  IN_name n l ->
  n < new l.
Proof.
  unfold new; induction l; simpl; intro H; [elim H | ].
  case_var; auto with arith.
  apply lt_le_trans with (m:= S (fold_right max 0 l)); eauto 2 with arith.
Qed.

Lemma new_fresh : forall l : list name, (new l) # l.
Proof.
  intros l H.
  elim (lt_irrefl (new l)).
  apply IN_less; exact H.
Qed.

(** Freshness for a term *)

(*
Lemma fresh_out_t : forall (t : trm),
  (new (oc_t t)) # (oc_t t).
Proof.
  intro t.
  exact (new_fresh (oc_t t)).
Qed.

(** Freshness for a formula *)

Lemma fresh_out_f : forall (A :fml),
  (new (oc A)) # (oc A).
Proof.
  intros A.
  exact (new_fresh (oc A)).
Qed.

(** Choosing a fresh variable for a context *)

Definition fresh_out (Ga:list fml) : name := new (oc_c Ga).

(** Freshness for a context *)

Definition fresh (x:name)(Ga:list fml) : Prop :=
  x # (oc_c Ga).

Lemma fresh_out_spec : forall (Ga : list fml),
  fresh (fresh_out Ga) Ga.
Proof.
  unfold fresh; unfold fresh_out; intros Ga.
  exact (new_fresh (oc_c Ga)).
Qed.

Lemma fresh_fml_peel : forall a A Ga,
  fresh a (A::Ga) ->
  a # (oc A).
Proof.
  unfold fresh; simpl; intros; auto with datatypes.
Qed.

Lemma fresh_peel : forall a A Ga,
  fresh a (A::Ga) ->
  fresh a Ga.
Proof.
  unfold fresh; simpl; intros; auto with datatypes.
Qed.
*)

(** Two tactics in dealing with [~ In]. *)

Ltac destruct_notin :=
  match goal with
    | H : ~ (IN ?decA ?x (?l ++ ?m)) |- _  =>
      destruct (notIN_app_1 decA x l m H); clear H; destruct_notin
    | H : ?x = new ?L |- _ =>
      let Hnew := fresh "Hnew" in
      generalize (new_fresh L); intro Hnew; rewrite <- H in Hnew;
        clear H; destruct_notin
    | x := ?l |- _ =>
      assert (x = l); auto; clearbody x; destruct_notin
    | _ => idtac
  end.

Ltac solve_notin :=
  intros;
  destruct_notin;
  repeat first [ apply notIN_app_2
               | apply notIN_cons_3
               | apply notIN_singleton_1
               | apply notIN_empty_1
               ];
  auto;
  try tauto;
  fail "Not solvable by [solve_notin]; try [destruct_notin]".


(**
群の公理の完備化によって、autorewriteで自動証明をする。

@suharahiromichi
 *)

Variable gp : Type.
Variable addg : gp -> gp -> gp.
Variable oppg : gp -> gp.
Variable O : gp.

Notation "a + b" := (addg a b)(at level 50, left associativity).
Notation "a - b" := (addg a (oppg b))(at level 50, left associativity).
Notation "- a" := (oppg a)(at level 35, right associativity).

Section gproup.
  Variable a b c : gp.

  (* 公理 *)
  Axiom a1 : O + a = a.
  Axiom a2 : (- a) + a = O.
  Axiom a3 : (a + b) + c = a + (b + c).

  (* Knuth-Bendix 完備化アルゴリズムで追加された等式 *)
  Axiom r1 : -a + (a + b) = b.
  Axiom r2 : a + O = a.
  Axiom r3 : a + -a = O.
  Axiom r4 : a + (-a + b) = b.
  Axiom r5 : -O = O.
  Axiom r6 : - -a = a.
  Axiom r7 : -(b + a) = -a + -b.
End gproup.

Hint Rewrite a1 a2 a3 r1 r2 r3 r4 r5 r6 r7 : group.

Variable a b c d : gp.

Goal -a + (a + b) = b.
Proof.
  (* 公理のみで手動で証明する例。 *)
  rewrite <- a3.
  rewrite a2, a1.
  reflexivity.

  (* 完備化された等式を -> だけ使って、自動証明する。 *)
  Restart.
  autorewrite with group.
  reflexivity.
Qed.

Goal a + b + - b = a.
Proof.
  autorewrite with group.
  reflexivity.
Qed.

Goal a - b + c - c + b - a = O.
Proof.
  autorewrite with group.
  reflexivity.
Qed.

(**
# HOAS
*)
From elpi Require Import elpi.

(* Axiom 専用の print コマンド *)

Elpi Command print.
Elpi Accumulate lp:{{
main [str Name] :-
        coq.locate Name (const Const),
        coq.env.const Const none Type,    % 値はなく、型だけ存在する。
        coq.say "Type=" Type.
}}.
Elpi Typecheck.
Elpi print "a1".
(**
```
prod `a` {{gp}}
  c0 \ app [{{@eq}},
            {{gp}},
            app	[{{addg}}, {{O}}, c0],
            c0]
```
*)

(* Axiom を定義する例 *)
Elpi Command new_ax.
Elpi Accumulate lp:{{
main [str Name] :-
        Bo = (prod `a` {{gp}}
              c0 \ app [{{@eq}}, {{gp}},        % @eq としてください。
                        app	[{{addg}}, {{O}}, c0],
                        c0]),
        coq.say "Bo=" Bo,
        coq.env.add-axiom Name Bo Ax,
        coq.say "Ax=" Ax.
}}.
Elpi Typecheck.
Elpi new_ax "a1'".

Check a1.
Check a1'.

(* サブタームのコンテキストを取得する *)
Elpi Command test.
Elpi Accumulate lp:{{
equation (prod `a` {{gp}}
              c0 \ app [{{@eq}}, {{gp}},        % @eq としてください。
                        app	[{{addg}}, {{O}}, c0],
                        c0]).
main [trm S] :-
        equation T,
        pi x\ copy S x => std.spy (copy T (Ctx x)),
        coq.say "Ctx=" Ctx,
        T = Ctx S.       % テスト。コンテキストにサブタームを入れると戻る。
}}.
Elpi Typecheck.
Elpi test (O).

(**
# 参考文献

[1] 書き換えと計算機 Jacques gparrigue 2005年8月11～13日

[2] Proof Summit 2017

[3] Tutorial on the HOAS for Coq terms

https://lpcic.github.io/coq-elpi/tutorial_coq_elpi_HOAS.html
*)

(* END *)


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

(* * Main undecidability results for Minsky machines *)

Require Import Undecidability.Synthetic.Undecidability.

From Undecidability.StackMachines Require Import BSM BSM_undec.
From Undecidability.MinskyMachines Require Import MM Reductions.BSM_MM.

Lemma MM_HALTS_ON_ZERO_undec : undecidable MM_HALTS_ON_ZERO.
Proof.
  apply (undecidability_from_reducibility BSM_undec).
  apply BSM_MM_HALTS_ON_ZERO.
Qed.

Lemma MM_HALTING_undec : undecidable MM_HALTING.
Proof.
  apply (undecidability_from_reducibility BSM_undec).
  apply BSM_MM_HALTING.
Qed.


Require Import String.
Require Import List.
Require Import Bool.Bool.
Import ListNotations.

Module Datalog.

(* Datalog Types *)

(* Datalog is a decidable subset of prolog, whose core use is to take
   Atoms as an input, and materialize the logical consequences of rules
   applied to them.
 *)

(* First we need to define the building blocks of datalog, Terms. *)
Inductive tm : Type :=
  (* A term is either a constant  *)
  | tm_const : string -> tm
  (* Or a variable. *)
  | tm_var : string -> tm
.

(* A substitution is a tuple whose constituents are terms.
  A (X, Y) substitution means that X is substituted by Y
 *)

Definition substitution := list (tm * tm).

(* It's commonplace for constants to have an uppercase-non-single-letter name
   and variables usually have uppercase single-letter names *)

(* Atoms are just conjunctions of terms with a symbol *)
Inductive atom : Type :=
  (* They can be ground, if all terms are constants *)
  | atom_ground : string -> list tm -> atom
  (* Or regular, if else *)
  | atom_regular : string -> list tm -> atom
.

(* A atom is well formed IF it is regular, OR if it is ground AND all of its terms are constant. *)
Definition is_const t := match t with tm_const _ => True | _ => False end.

Inductive well_formed : atom -> Prop :=
  | well_formed_ground : forall sym l,
      Forall is_const l ->
      well_formed (atom_ground sym l)
  | well_formed_regular : forall sym l,
      well_formed (atom_regular sym l)
.

(* A rule is a clause that has a body, a list of atoms, and a head, a single regular atom.

   ancestor(X, Y), ancestor(Y, Z) -> ancestor(X, Z)

   It reads as "if ancestor(X, Y) and ancestor(Y, Z) are true, then  so does ancestor(X, Z) "

   the left-hand side is called the body, and the right-hand side is the head of the rule.

   This is the last part of datalog syntax.
 *)

Inductive cl : Type :=
  | cl_rule : atom -> list atom -> cl
.

(* A Knowledge base is a list of atoms. It is extensional if all of its atoms are ground and well formed. *)
Definition KnowledgeBase := list atom.

Definition is_ground' a := match a with atom_ground _ _ => True | _ => False end.

Inductive is_extensional : KnowledgeBase ->  Prop :=
| ext_nil :
    is_extensional []
| ext_cons : forall l : list atom,
    Forall (fun a => is_ground' a /\ well_formed a) l ->
    is_extensional l
.

(* Core logic *)

Definition eqb_string (x y : string) : bool := if string_dec x y then true else false.

Definition eqb_term (lterm : tm) (rterm: tm) : bool :=
  match lterm, rterm with
  | tm_var _, tm_const _ => false
  | tm_const _, tm_var _ => false
  | tm_var lvalue, tm_var rvalue => eqb_string lvalue rvalue
  | tm_const lvalue, tm_const rvalue => eqb_string lvalue rvalue
  end.

Fixpoint eqb_term_list (l1 l2 : list tm) : bool :=
  match l1, l2 with
  | nil, nil => true
  | h :: l, h' :: r => if eqb_term h h' then eqb_term_list l r else false
  | _, _ => false
  end.

Definition eqb_atom (latom : atom) (ratom : atom) : bool :=
  match latom, ratom with
  | atom_ground sym l1, atom_ground sym' l2  => if eqb_string sym sym' then eqb_term_list l1 l2 else false
  | atom_regular sym l1, atom_regular sym' l2 => if eqb_string sym sym' then eqb_term_list l1 l2 else false
  | _, _ => false
  end.

Fixpoint getValue (s : substitution) (t1 : tm) : option tm :=
  match s with
  | nil => None
  | (t, t') :: l => if eqb_term t t1 then Some t' else getValue l t1
  end.

Fixpoint make_term_substitution (l1 l2 : list tm)(s : substitution) : option substitution :=
  match l1, l2 with
  | nil, nil => Some s
  | (tm_const h) :: l, (tm_const h') :: r => if eqb_string h h' then make_term_substitution l r s else None
  | h :: l, h' :: r => match getValue s h with
                    | Some t => if eqb_term h' t then make_term_substitution l r s else None
                    | None => make_term_substitution l r (s ++ [(h, h')])
                    end
  | _, _ => None
  end.

Definition make_atom_substitution (a1 a2 : atom) : option substitution :=
  match a1, a2 with
  | atom_regular sym l1, atom_ground sym' l2 => if eqb_string sym sym' then make_term_substitution l1 l2 [] else None
  | _, _ => None
  end.

Fixpoint substitute_term (l1 acc : list tm) (s : substitution) : list tm :=
  match l1 with
  | nil => acc
  | h :: l => let value_lookup := match getValue s h with
                                | Some t => t
                                | None => h
                                end in
              substitute_term l (acc ++ [value_lookup]) s
  end.

Lemma subs_t_empty acc s : substitute_term [] acc s = acc.
Proof.
  easy.
Qed.

Fixpoint is_ground (l : list tm) : bool :=
  match l with
  | [tm_const _] => true
  | (tm_const _) :: l => is_ground l
  | _ => false
  end.

Definition substitute_atom (a1 : atom) (s : substitution) : option atom :=
  match a1 with
  | atom_regular sym l1 => Some (
      let substitution_attempt := substitute_term l1 [] s in
        if is_ground substitution_attempt
          then atom_ground sym substitution_attempt
          else atom_regular sym substitution_attempt
      )
  | _ => None
  end.

(* In this function we iterate over the knowledge base
   and, for every atom in it, try to make a substitution
   with some regular atom.

   For instance,

   Let's say that we have this regular atom: ancestor(X, jumala)

   Now, we have a knowledge base like this:

   [ ancestor(adam, jumala), ancestor(eve, adam), ancestor(vanasarvik, jumala) ]

   calling subsitute_step will generate the following substitutions:

   [ [(X, adam)], [(X, vanasarvik)] ]

 *)

Fixpoint substitution_step (kb : KnowledgeBase) (a1 : atom) (acc : list substitution): list substitution :=
  match kb with
  | nil => acc
  | h :: l =>  let augmentation_attempt := make_atom_substitution a1 h in
             match augmentation_attempt with
             | Some s => substitution_step l a1 (acc ++ [s])
             | None => substitution_step l a1 acc
             end
  end.

(* Now that we have a function that generates substitutions, we can finally make use of them.

   The next function uses substitution_step to possibly generate more substitutions.

   This is done by iterating over a list of substitutions, and, for each, attempting to make a fresh atom
   that will have new substitutions derived from it, by running substitution_step against it.

   Building up on the previous example, let us have the following RDF triple as the regular atom:

   T(X, Y, PLlab)

   With substitutions:

   [ (X, student) ],

   [ (X, professor) ],

   With the following kb:

   [ T(student, takesClassesFrom, PLlab), T(professor, worksAt, PLlab)  ]

   The first iteration of eval_atom will:

   1. make a fresh atom with the first substitution, yielding T(student, Y, PLlab)

   2. call substitution_step on it, yielding the substitution [ (Y, takesClassesFrom) ]

   On the second it will do the same, but with worksAt.

   Thus, the final output would be [ [("X", "student"), ("Y", "takesClassesFrom")] ; [("X", professor), ("Y", "worksAt")] ]

 *)

Fixpoint eval_atom (kb : KnowledgeBase) (a1 : atom) (ls acc : list substitution) : list substitution :=
  match ls, acc with
  | nil, _ => acc
  | h :: l, _ => match substitute_atom a1 h with
            (* If the atom is not ground, then there is a substitution  *)
            | Some a => let new_substitutions := substitution_step kb a [] in
                       eval_atom kb a1 l (acc ++ (map (fun x => h ++ x) new_substitutions))
            (* Else, skip this substitution *)
            | None => eval_atom kb a1 l acc
            end
  end.

(*
  In eval_body all we do is walk through the rule's body in order to get all substitutions.

  Given the following list of atoms:

  ancestor(X, Y), ancestor(Y, Z)

  And knowledge base:

  [ (adam, jumala) ; (vanasarvik, jumala) ; (eve, adam) ; (jumala, cthulu) ]

  We should get the following long list of substitutions:

  [ [ (X, adam) ; (X, vanasarvik) ; (X, eve) ; (X, jumala) ; (Y, jumala) ; (Y, adam) ; (Y, cthulu) ] ;
  [ (Y, adam) ; (Y, vanasarvik) ; (Y, eve) ; (Y, jumala) ; (Z, jumala) ; (Z, adam) ; (Z, cthulu) ] ]

 *)
Fixpoint eval_body (kb : KnowledgeBase) (l1 : list atom) (ls : list substitution) : list substitution :=
  match l1 with
  | nil => ls
  | h :: l => let atom_evaluation := eval_atom kb h ls [] in
                  eval_body kb l atom_evaluation
  end.

(*

  Evaluating a rule is quite straightforward.

  We will evaluate the body of the rule, and then attempt to use the substitutions to generate new atoms.

  The function substitute_head does nothing special.

  It is the same as substitute_atom, except that instead of returning an option, and acting on a signle substitution
  it takes in a list of substitutions and applies them to a single atom.

  For instance, evaluating the rule ancestor(X, Y), ancestor(Y, Z) -> ancestor(X, Z)
  over the same knowledge base will yield the following substitutions:

  [[(X, adam), (Y, jumala), (Z, cthulu)];
   [(X, eve), (Y, adam), (Z, jumala)];
   [(X, vanasarvik), (Y, jumala), (Z, cthulu)]]

  Which will be substituted against ancestor(X, Z), deriving the following facts:

  [ancestor(adam, cthulu),
   ancestor(eve, jumala),
   ancestor(vanasarvik, cthulu)]

 *)

Fixpoint substitute_head (head : atom) (substitutions: list substitution) ( acc : KnowledgeBase ): KnowledgeBase :=
  match substitutions with
  | nil => acc
  | h :: l => match substitute_atom head h with
            | Some fresh_atom => substitute_head head l (acc ++ [fresh_atom])
            | None => substitute_head head l (acc)
            end
  end.

Compute substitute_head (atom_regular "Y" [tm_var "X";tm_const "Y"]) [[]] [].

Definition eval_rule (kb : KnowledgeBase) (r : cl) : KnowledgeBase :=
  match r with
  | cl_rule head [] => []
  | cl_rule head body =>
      let substitutions := eval_body kb body [[]] in
      (substitute_head head substitutions [])
  end.

Compute eval_rule [] (cl_rule (atom_regular "Y" [tm_var "X";tm_const "Y"]) [atom_regular "Y" [tm_var "X";tm_const "Y"]]).

(* A datalog rule MUST have all of the terms in its head show up in the body, otherwise eval_rule will not yield only ground atoms!! *)

Fixpoint is_term_in_term_list (l : list tm) (t : tm) : bool :=
  match l with
  | nil => false
  | h :: l' => if eqb_term t h then true else is_term_in_term_list l' t
  end.

Fixpoint is_there_some_true (l : list bool) : bool :=
  match l with
  | nil => false
  | h :: l' => if h then true else is_there_some_true l'
  end.

Fixpoint is_it_all_true (l : list bool) : bool :=
  match l with
  | nil => true
  | h :: l' => if h then is_it_all_true l' else false
  end.

Inductive atom_contains (term:tm) : atom -> Prop :=
  | regular_containts l sym : In term l -> atom_contains term (atom_regular sym l)
  | ground_containts l sym : In term l -> atom_contains term (atom_ground sym l)
.

Inductive is_datalog_rule : cl -> Prop :=
  regular_datalog : forall sym head_terms body,
    Forall (fun term => Exists (atom_contains term) body) head_terms
    -> is_datalog_rule (cl_rule (atom_regular sym head_terms) body).

(* A datalog rule MUST have all of the terms in its head show up in the body, otherwise eval_rule will not yield only ground atoms!! *)
Definition is_datalog_rule_dec (r : cl) : bool :=
  match r with
  | cl_rule (atom_regular _ l) body =>
      let body_check := map (fun term =>
                               map (fun x =>
                                      match x with
                                      | atom_regular sym l | atom_ground sym l => is_term_in_term_list l term
                                      end ) body ) l in
      let head_check := map (fun term_truth_list => is_there_some_true term_truth_list) body_check in
      is_it_all_true head_check
  | cl_rule (atom_ground  _ _) _    => false
  end.

Fixpoint eqb_kb (kb1 kb2 : KnowledgeBase) : bool :=
  match kb1, kb2 with
  | nil, nil => true
  | h :: l, h' :: l' => if eqb_atom h h' then eqb_kb l l' else false
  | _, _ => false
  end.

Fixpoint has (kb : KnowledgeBase) (a : atom) : bool :=
  match kb with
  | nil => false
  | h :: l => if eqb_atom h a then true else has l a
  end.

Fixpoint distinct (kb : KnowledgeBase) (acc : KnowledgeBase) : KnowledgeBase :=
  match kb, acc with
  | nil, _ => []
  | h :: l, acc => match has acc h with
                 | true => distinct l acc
                 | false => h :: (distinct l (h :: acc))
                 end
  end.

(* Fixpoint calculate_minimal_model (kb : KnowledgeBase) (r : cl)
   : KnowledgeBase :=
   let clean_kb := distinct kb [] in
   let evaluation := eval_rule clean_kb r in
   match evaluation with
   | nil => kb
   | _ => calculate_minimal_model (clean_kb ++ evaluation) r
   end. *)

(* Examples *)

Compute eqb_term (tm_const "Professor") (tm_var "Professor").
Compute eqb_term (tm_var "Professor") (tm_const "Professor").
Compute eqb_term (tm_const "Professor") (tm_const "Professor").
Compute eqb_term (tm_var "Professor") (tm_var "Professor").
Compute eqb_term (tm_const "X") (tm_const "Y").
Compute eqb_term (tm_var "X") (tm_const "Y").

Example example_regular_atom := atom_regular "ancestor" [ tm_var "X"; tm_var "Y" ].
Example example_ground_atom := atom_ground "ancestor" [ tm_const "Frederick"; tm_const "Roderick" ].
Example example_regular_atom_two := atom_regular "ancestor" [ tm_var "X" ; tm_const "Roderick" ].
Example example_regular_atom_three := atom_regular "ancestor" [ tm_var "Y" ; tm_var "Z" ].
(* [(tm_var "X", tm_const "Frederick"), (tm_var "Y", tm_const "Roderick")] *)
Example example_substitution := match (make_atom_substitution example_regular_atom example_ground_atom) with
                                   | Some s => s
                                   | None => []
                                   end.
(* [(tm_var "X", tm_const "Frederick")] *)
Example example_substitution_two := match (make_atom_substitution example_regular_atom_two example_ground_atom) with
                                       | Some s => s
                                       | None => []
                                       end.

Compute substitute_atom example_regular_atom example_substitution.

Compute substitute_atom example_regular_atom_three example_substitution.

Example example_ground_atom_two := atom_ground "ancestor" [ tm_const "adam" ; tm_const "jumala"].
Example example_ground_atom_three := atom_ground "ancestor" [ tm_const "eve" ; tm_const "adam"].
Example example_ground_atom_four := atom_ground "ancestor" [ tm_const "vanasarvik" ; tm_const "jumala"].

Example example_kb := [ example_ground_atom_two; example_ground_atom_three; example_ground_atom_four ].

Compute substitution_step example_kb (atom_regular "ancestor" [ tm_var "X" ; tm_const "jumala" ]) [].

Example example_ground_atom_five := atom_ground "T" [ tm_const "student" ; tm_const "takesClassesFrom" ; tm_const "PLlab"].
Example example_ground_atom_six := atom_ground "T" [ tm_const "professor" ; tm_const "worksAt" ; tm_const "PLlab"].

Example example_regular_atom_four := atom_regular "T" [ tm_var "X" ; tm_var "Y" ; tm_const "PLlab" ].

Example example_substitution_three := [ (tm_var "X", tm_const "student") ].
Example example_substitution_four := [ (tm_var "X", tm_const "professor") ].
Example example_substitution_list := [ example_substitution_three ; example_substitution_four ].

Example example_kb_two := [ example_ground_atom_five ; example_ground_atom_six ].

Compute eval_atom example_kb_two example_regular_atom_four example_substitution_list [].

Example example_ground_atom_seven := atom_ground "ancestor" [ tm_const "jumala" ; tm_const "cthulu" ].

Example example_kb_three := [ example_ground_atom_two ; example_ground_atom_three ; example_ground_atom_four ; example_ground_atom_seven ].

Compute example_kb_three.

Example example_kb_four := [example_ground_atom_two ; (atom_ground "ancestor" [(tm_var "X");(tm_const "Y")]) ; example_ground_atom_four ; example_ground_atom_seven].

Compute eval_body example_kb_three [(atom_regular "ancestor" [ tm_var "X" ; tm_var "Y"]);(atom_regular "ancestor" [ tm_var "Y" ; tm_var "Z"])] [[]].

Example previous_substitutions := eval_body example_kb_three [atom_regular "ancestor" [ tm_var "X" ; tm_var "Y" ] ; atom_regular "ancestor" [ tm_var "Y" ; tm_var "Z" ]] [[]].

Compute previous_substitutions.

Example example_rule_body := [atom_regular "ancestor" [ tm_var "X" ; tm_var "Y"] ; atom_regular "ancestor" [ tm_var "Y" ; tm_var "Z"] ].
Example example_rule_head := atom_regular "ancestor" [ tm_var "X" ; tm_var "Z"].

Definition example_rule := cl_rule example_rule_head example_rule_body.

Compute substitute_head example_rule_head previous_substitutions [].

Example not_datalog_rule := cl_rule (atom_regular "ancestor" [tm_var "X"; tm_var "W"]) example_rule_body.

Compute is_datalog_rule not_datalog_rule.

Compute is_datalog_rule example_rule.

(* Notice how not all atoms in the head are somewhere in the body *)
Compute eval_rule example_kb_three (cl_rule (atom_regular "ancestor" [tm_var "X"; tm_var "W"]) example_rule_body).

Compute eval_rule example_kb_three example_rule.

Compute eval_rule (example_kb_three ++ (eval_rule example_kb_three example_rule)) example_rule.

Compute eval_rule (eval_rule (example_kb_three ++ (eval_rule example_kb_three example_rule)) example_rule) example_rule.

(* Borrowed theorems (not mine) *)

Theorem eqb_string_refl : forall s : string, true = eqb_string s s.
Proof.
  intros s. unfold eqb_string.
  destruct (string_dec s s) as [Hs_eq | Hs_not_eq].
  - reflexivity.
  - destruct Hs_not_eq. reflexivity.
Qed.

Theorem eqb_string_true_iff : forall x y : string,
  eqb_string x y = true <-> x = y.
Proof.
  intros x y.
  unfold eqb_string.
  destruct (string_dec x y) as [Hs_eq | Hs_not_eq].
  - rewrite Hs_eq. split. reflexivity. reflexivity.
  - split.
    + intros contra. discriminate contra.
    + intros H. exfalso. apply Hs_not_eq. apply H.
Qed.

Theorem eqb_string_false_iff : forall x y : string,
  eqb_string x y = false <-> ~(x = y).
Proof.
  intros x y.
  rewrite <- eqb_string_true_iff.
  rewrite not_true_iff_false.
  reflexivity.
Qed.

(* Core logic theorems *)

Theorem eqb_string_sym : forall s s' : string,
    eqb_string s s' = eqb_string s' s.
Proof.
  intros.
  unfold eqb_string.
  destruct (string_dec s s').
  destruct (string_dec s' s).
  auto.
  exfalso.
  apply n.
  auto.
  destruct (string_dec s' s).
  exfalso.
  apply n.
  auto.
  auto.
Qed.

Theorem eqb_term_sym : forall t t' : tm,
    eqb_term t t' = eqb_term t' t.
Proof.
  intros.
  induction t, t'; simpl.
  apply eqb_string_sym.
  auto.
  auto.
  apply eqb_string_sym.
Qed.

Lemma var_const_ineq : forall v1 v2 : string,
    eqb_term (tm_var v1) (tm_const v2) = false.
Proof.
  trivial.
Qed.

Lemma const_var_ineq : forall v1 v2 : string,
    eqb_term (tm_const v1) (tm_var v2) = false.
Proof.
  trivial.
Qed.

Theorem eqb_term_list_sym : forall t t' :  list tm,
    eqb_term_list t t' = eqb_term_list t' t.
Proof.
  intros.
  generalize dependent t'.
  induction t; intros.
  - destruct t'.
    auto.
    auto.
  - destruct t'.
    auto.
    assert (H1: eqb_term a t0 = eqb_term t0 a).
    apply eqb_term_sym.
    simpl.
    destruct (eqb_term a t0).
    destruct (eqb_term t0 a).
    specialize IHt with t'.
    apply IHt.
    discriminate.
    rewrite H1.
    destruct (eqb_term t0 a).
    discriminate.
    auto.
Qed.

Theorem eqb_atom_sym : forall a a' : atom,
    eqb_atom a a' = eqb_atom a' a.
Proof.
  intros.
  destruct a, a'; simpl.
  - rewrite eqb_term_list_sym.
    rewrite eqb_string_sym.
    auto.
  - auto.
  - auto.
  - rewrite eqb_term_list_sym.
    rewrite eqb_string_sym.
    auto.
Qed.

Lemma regular_ground_ineq : forall (sym1 sym2 : string) (l1 l2 : list tm),
    eqb_atom (atom_ground sym1 l1) (atom_regular sym2 l2) = false.
Proof.
  trivial.
Qed.

Lemma ground_regular_ineq : forall (sym1 sym2 : string) (l1 l2 : list tm),
    eqb_atom (atom_ground sym1 l1) (atom_regular sym2 l2) = false.
Proof.
  trivial.
Qed.

Theorem extensional_kb_three : is_extensional example_kb_three.
Proof.
  try repeat constructor.
Qed.

Theorem not_extensional_kb_four : not (is_extensional example_kb_four).
Proof.
  unfold not.
  intros.
  inversion H.
  subst.
  inversion H0.
  subst.
  inversion H4.
  subst.
  destruct H5.
  inversion H2.
  subst.
  inversion H7.
  subst.
  contradiction H9.
Qed.

Lemma is_it_all_true_map_Forall A p r: is_it_all_true (map p r) = true <-> @Forall A (fun x => p x = true) r.
Proof.
  split; induction r; intros; try trivial.
  + simpl in H. constructor. destruct (p a). trivial. inversion H.
    apply IHr. destruct (p a). apply H. inversion H.
  + simpl. inversion H. subst. rewrite H2. apply IHr, H3.
Qed.

Lemma is_there_some_true_map_Exists A p r:
  is_there_some_true (map p r) = true <-> @Exists A (fun x => p x = true) r.
Proof.
  split; induction r; intros.
  + simpl in H. inversion H.
  + simpl in H. destruct (p a) eqn:E. constructor 1. trivial.
    constructor 2. apply IHr, H.
  + inversion H.
  + simpl; inversion H; subst. rewrite H1. trivial.
    destruct (p a). trivial. apply IHr, H1.
Qed.

Lemma eqb_term_eq : forall t1 t2,
    eqb_term t1 t2 = true <-> t1 = t2.
Proof.
  intros t1.
  destruct t1.
  - simpl.
    destruct t2.
    -- unfold eqb_string.
       destruct (string_dec s s0).
       rewrite e.
       constructor 1.
       --- auto.
       --- auto.
       --- constructor 1.
           ---- intros.
                discriminate.
           ---- intros.
                inversion H.
                contradiction H1.
    -- constructor 1.
       --- intros.
           discriminate H.
       --- intros.
           discriminate H.
  - simpl.
    destruct t2.
    -- constructor 1.
       discriminate.
       discriminate.
    -- unfold eqb_string.
       destruct (string_dec s s0).
       --- rewrite e.
           constructor 1.
           auto.
           auto.
       --- constructor 1.
           discriminate.
           intros.
           exfalso.
           apply n.
           injection H.
           intros.
           apply H0.
Qed.

Lemma eqb_term_neq : forall t1 t2,
    eqb_term t1 t2 = false <-> t1 <> t2.
Proof.
  intros t1.
  induction t1.
  - simpl.
    destruct t2 eqn:E.
    -- unfold eqb_string.
       destruct (string_dec s s0).
       --- constructor 1.
           ---- discriminate.
           ---- intros H.
                elim H.
                rewrite e.
                auto.
       --- constructor 1.
           ---- intros H.
                unfold not.
                intros.
                inversion H0.
                contradiction.
           ---- intros.
                trivial.
    -- constructor 1.
       --- discriminate.
       --- auto.
  - constructor 1.
    intros H.
    unfold eqb_term in H.
    -- destruct t2 eqn:E.
       --- discriminate.
       --- unfold eqb_string in H.
           destruct (string_dec s s0).
           ---- discriminate.
           ---- unfold not.
                intros.
                apply n.
                inversion H0.
                auto.
    -- intros.
       destruct t2.
       --- auto.
       --- intuition.
           simpl.
           unfold eqb_string.
           destruct (string_dec s s0).
           elim H.
           rewrite e.
           auto.
           auto.
Qed.

Lemma gval_in_forward : forall s t1,
    In t1 (map fst s) ->
    (exists t2, Some t2 = getValue s t1).
Proof.
  intros.
  generalize dependent t1.
  induction s.
  - contradiction.
  - intros.
    destruct H.
    -- destruct a.
       assert (t = t1).
       easy.
       simpl.
       rewrite <- eqb_term_eq in H0.
       rewrite H0.
       exists t0.
       easy.
    -- destruct a eqn:Ea.
       unfold getValue.
       destruct (eqb_term t t1).
       --- exists t0. easy.
       --- fold getValue.
           apply IHs.
           easy.
Qed.

Lemma gval_in_backward : forall s t1,
    (exists t2, Some t2 = getValue s t1) ->
    In t1 (map fst s).
Proof.
  intros.
  generalize dependent t1.
  induction s.
  - intros.
    simpl.
    destruct H.
    discriminate.
  - simpl.
    destruct a eqn:eA.
    subst.
    intros t1.
    simpl.
    intros H.
    destruct H.
    destruct (eqb_term t t1) eqn:eE.
    -- left.
       apply eqb_term_eq in eE.
       easy.
    -- right.
       apply IHs.
       exists x.
       easy.
Qed.

Theorem gval_in : forall s t1,
    In t1 (map fst s) <->
    (exists t2, Some t2 = getValue s t1).
Proof.
  constructor 1.
  - apply gval_in_forward.
  - apply gval_in_backward.
Qed.

Lemma is_in_term_list_In l term:
  is_term_in_term_list l term = true <-> In term l.
Proof.
  induction l.
  - simpl.
    constructor 1.
    intros.
    discriminate.
    -- intros.
       inversion H.
  - destruct (eqb_term term a) eqn:E.
    -- simpl.
       rewrite E.
       constructor 1.
       --- intros H.
           left.
           rewrite eqb_term_eq in E.
           auto.
       --- trivial.
    -- simpl.
       rewrite E.
       constructor 1.
       --- right.
           apply IHl.
           auto.
       --- intros H.
           destruct H.
           ---- rewrite eqb_term_neq in E.
                elim E.
                subst.
                auto.
           ---- apply IHl.
                auto.
Qed.

Lemma map_fusion {A B C} f g xs: @map B C f (@map A B g xs) = @map A C (fun x => f (g x)) xs.
Proof.
  induction xs. trivial. simpl. rewrite IHxs. reflexivity.
Qed.

Lemma atom_contains_dec x term:
      match x with
        | atom_ground _ l | atom_regular _ l => is_term_in_term_list l term
      end = true <-> atom_contains term x.
Proof.
  generalize dependent term.
  - induction x.
    -- constructor 1.
       intuition.
       --- rewrite is_in_term_list_In in H.
           constructor.
           auto.
       --- intros.
           inversion H.
           subst.
           rewrite is_in_term_list_In.
           auto.
    -- intros.
       constructor.
       --- constructor.
           apply is_in_term_list_In.
           auto.
       --- intros H.
           inversion H.
           subst.
           rewrite <- is_in_term_list_In in H1.
           auto.
Qed.

Lemma rewrite_forall_cond {A} p q xs: (forall x, p x <-> q x) -> @Forall A p xs <-> @Forall A q xs.
Proof.
  induction xs; intros; split; intros; try trivial; inversion H0; subst.
  + constructor. apply H. trivial. apply (IHxs H), H4.
  + constructor. apply H. trivial. apply (IHxs H), H4.
Qed.

Lemma rewrite_exists_cond {A} p q xs: (forall x, p x <-> q x) -> @Exists A p xs <-> @Exists A q xs.
Proof.
  induction xs; intros; split; intros; try trivial; inversion H0; subst.
  + constructor. apply H. trivial.
  + inversion H0. constructor 1 . apply H. trivial.  constructor 2. apply (IHxs H), H3.
  + constructor. apply H. trivial.
  + inversion H0. constructor 1 . apply H. trivial.  constructor 2. apply (IHxs H), H3.
Qed.

Lemma is_datalog_rule_correct r: is_datalog_rule_dec r = true <-> is_datalog_rule r.
Proof.
 split; intros H.
  - destruct r, a. + simpl in H. inversion H.
    + apply regular_datalog.
    eapply rewrite_forall_cond. intros.
    eapply rewrite_exists_cond. intros.
    apply iff_sym. apply atom_contains_dec.
    eapply rewrite_forall_cond. intros.
    apply iff_sym, is_there_some_true_map_Exists.
    rewrite <- is_it_all_true_map_Forall.
    rewrite <- map_fusion.
    apply H.
  - induction H. simpl.
    rewrite map_fusion.
    apply is_it_all_true_map_Forall.
    eapply rewrite_forall_cond. intros.
    apply is_there_some_true_map_Exists.
    simpl.
    eapply rewrite_forall_cond. intros.
    eapply rewrite_exists_cond. intros.
    apply atom_contains_dec.
    apply H.
Qed.

Lemma sub_step_empty_kb a1 : substitution_step [] a1 [] = [].
Proof.
  simpl.
  auto.
Qed.

Lemma eval_atom_empty_kb a1 ls : eval_atom [] a1 ls [] = [].
Proof.
  induction ls.
  - auto.
  - destruct (substitute_atom).
    -- auto.
    -- apply a.
    -- simpl.
       destruct (substitute_atom a1 a).
       apply IHls.
       apply IHls.
    -- simpl.
       destruct (substitute_atom a1 a).
       apply IHls.
       apply IHls.
Qed.

Lemma eval_body_empty_body kb s: eval_body kb [] s = s.
Proof.
  simpl.
  auto.
Qed.

Lemma eval_body_empty_kb_and_s l : eval_body [] l [] = [].
Proof.
  induction l.
  auto.
  simpl.
  apply IHl.
Qed.

Lemma eval_rule_empty_kb r : eval_rule [] r = [].
Proof.
  destruct r.
  generalize dependent a.
  destruct l.
  - auto.
  - unfold eval_rule.
    simpl.
    destruct (substitute_atom a []).
    rewrite eval_body_empty_kb_and_s.
    auto.
    rewrite eval_body_empty_kb_and_s.
    auto.
Qed.

Example keeb0 := [ atom_ground "X" [tm_const "yee";tm_const "haa"]; atom_ground  "Y" [tm_const "yee";tm_const "haa"] ].
Example keeb1 := [ atom_ground "X" [tm_const "yee";tm_const "haa"]; atom_ground  "Y" [tm_const "yee";tm_const "haa"] ].
Compute eval_rule keeb0 example_rule.
Compute eval_body [ example_ground_atom_two; example_ground_atom_four ] example_rule_body [[]].

Definition is_var t := match t with tm_var _ => True | _ => False end.

Lemma annoying_lemma : forall l s, is_ground (tm_const s :: l) = false -> is_ground l = false.
Proof.
  induction l.
  - intros.
    easy.
  - unfold is_ground.
    destruct a eqn:eA.
    auto.
    auto.
Qed.

Lemma exists_is_var : forall l, (Exists is_var l \/ l = []) <-> is_ground l = false.
Proof.
  intros.
  induction l.
  - constructor 1.
    -- easy.
    -- intros H.
       right.
       auto.
  - constructor 1.
    -- intros H.
       destruct H.
       --- simpl.
           destruct l.
           ---- destruct a eqn:eA.
                inversion H.
                subst.
                easy.
                subst.
                easy.
                easy.
           ---- destruct a eqn:eA.
                apply IHl.
                inversion H.
                subst.
                easy.
                left.
                apply H1.
                easy.
       --- rewrite H.
           easy.
    -- intros H.
       left.
       destruct a.
       --- simpl in *.
           destruct l. congruence.
           ---- intuition.
                easy.
       --- constructor.
           easy.
Qed.

Lemma forall_is_const : forall l, (Forall is_const l /\ l <> []) <-> is_ground l = true.
Proof.
  intros.
  induction l.
  simpl in *.
  - constructor.
    easy.
    easy.
  - constructor; intros H.
    -- destruct H; intuition eauto; try solve [easy]; subst.
       destruct a; intuition eauto; try solve [easy]; subst.
       destruct l; intuition eauto; try solve [easy]; subst.
       --- destruct H3.
           inversion H.
           subst.
           apply H5.
           inversion H.
           subst.
           easy.
           easy.
       --- simpl.
           inversion H.
           easy.
    -- destruct a; intuition eauto; try solve [easy]; subst.
       destruct l; intuition eauto; try solve [easy]; subst.
       --- constructor; try solve [easy].
       --- constructor; try solve [easy].
Qed.

Lemma submarine : forall (a : atom),
  is_ground' a /\ well_formed a <->
  (exists l1 l2 s sym, ( l1 <> [] /\ l2 <> []) /\
  ( Forall (fun term => In term (map fst s) /\ is_var term ) l1 ) /\
  ( Forall (fun term => In term (map snd s) /\ is_const term ) l2 ) /\
  ( Some a = substitute_atom (atom_regular sym l1) s )).
Proof.
Admitted.

(* Now for the grand theorem! *)
Theorem final_theorem : forall (kb : KnowledgeBase) (r : cl),
    is_extensional kb -> is_datalog_rule r -> is_extensional (eval_rule kb r).
Proof.
  destruct 1.
  - intros H.
    rewrite eval_rule_empty_kb.
    constructor.
  - intro Hr.
    destruct l.
    -- rewrite eval_rule_empty_kb.
       constructor.
    -- destruct r.
       simpl.
       destruct l0.
       --- constructor.
       --- destruct (substitute_head a0) eqn:E.
           ---- constructor.
           ---- constructor.
                constructor.
                inversion H.
                inversion Hr.
                subst.
                simpl in E.
                apply submarine.
                inversion Hr.
                subst.
                intuition; eauto.
                simpl.
Admitted.


(** A finite endomorphism, as defined in the [SymbComp.FinMod]
    library, is exactly the same thing as an endomorphism that can be
    described by a list of successive updates ("send [a] to [b]")
    applied to the identity map. In this theory, we prove this fact.
*)

Require Import Lists.List.
Require Import Program.Basics.

Require Import Top.FinSet.Distinct.
Require Import Top.FinSet.FinMod.
Require Import Top.FinSet.FinSet.
Require Import Top.FinSet.NatMap.
Require Import Top.FinSet.ProjSet.

Set Implicit Arguments.

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

  (** * Updating a map

      The first thing to describe is the process of updating an
      existing map at a single point. This needs the domain of the map
      to be decidable (since the updated map works by checking whether
      it's argument is equal to the place it was updated).

   *)

  Section UpdMap.
    Definition upd_map {B : Type} (p : A * B) (f : A -> B) (a : A) : B :=
      match decA a (fst p) with
      | left _ => snd p
      | right _ => f a
      end.

    Lemma upd_map_elim {B : Type} a a' b (f : A -> B) P
      : (a' = a -> P b) ->
        (a' <> a -> P (f a')) ->
        P (upd_map (a, b) f a').
    Proof.
      intros H0 H1.
      unfold upd_map. simpl.
      destruct (decA a' a); auto.
    Qed.

    Lemma upd_map_at {B : Type} a b (f : A -> B)
      : upd_map (a, b) f a = b.
    Proof.
      apply upd_map_elim; first [ reflexivity | contradiction ].
    Qed.

    Lemma upd_map_not_at {B : Type} a a' b (f : A -> B)
      : a' <> a -> upd_map (a, b) f a' = f a'.
    Proof.
      apply upd_map_elim; first [ reflexivity | contradiction ].
    Qed.

    (**

        At this point, we fix some map [f : A -> B] which is a finite
        modification of some other map [i : A -> B]. We want to prove
        that updating it with a pair doesn't stop it being a finite
        mo. To do so, we try to define a map from [mod_dom i f + unit] to
        [mod_dom i (upd_map p f)] which will induce the surjection in the
        underlying sets. The idea is that the image of [tt] in [unit]
        is [fst p], together with a proof that it's in the domain. Of
        course, it might be that [fst p = snd p], in which case it's
        not in the domain. To deal with this, we actually map to
        [option (mod_dom i (upd_map p f))] and allow ourselves to map to
        [None] in that case.

     *)

    Variable B : Type.
    Variable f : A -> B.
    Variable i : A -> B.
    Variable p : A * B.

    Hypothesis decB : forall x y : B, {x = y} + {x <> y}.

    Local Definition map_a (a : A) : option (mod_dom i (upd_map p f)) :=
      match decB (upd_map p f a) (i a) with
      | left eqH => None
      | right neqH => Some (exist _ a neqH)
      end.

    Local Definition proj0 (x : mod_dom i f + unit) : A :=
      match x with
      | inl x => md_elt x
      | inr tt => fst p
      end.

    Local Definition proj1 : mod_dom i (upd_map p f) -> A :=
      md_elt (f := upd_map p f).

    Local Definition top_map (x : mod_dom i f + unit)
      : option (mod_dom i (upd_map p f)) :=
      match x with
      | inl (exist _ a H) => map_a a
      | inr tt => map_a (fst p)
      end.

    Local Definition bot_map (a : A) : option A := option_map proj1 (map_a a).

    Local Lemma nat_left : is_nat_map (md_elt (f:=f)) proj0 (inl, id).
    Proof.
      unfold is_nat_map; intro a; auto.
    Qed.

    Local Lemma finite_proj0 : fin_mod i f -> FiniteProj proj0.
    Proof.
      unfold FiniteProj.
      destruct 1 as [ l H ].
      exists (cons (inr tt) (map inl l)).
      unfold FullProj. intro x.
      destruct x as [ d | ].
      - apply in_proj_cons.
        unfold proj0 at 2.
        unfold FullProj in H. specialize (H d).
        apply (in_proj_map (exist (is_nat_map (md_elt (f := f)) proj0)
                                  (inl, id) nat_left)).
        apply H.
      - apply in_proj_eq; destruct u; reflexivity.
    Qed.

    Local Lemma natH x : option_map proj1 (top_map x) = bot_map (proj0 x).
    Proof.
      unfold bot_map; apply f_equal.
      destruct x as [ d | u ].
      - destruct d; auto.
      - destruct u; auto.
    Qed.

    Ltac dec_equal :=
      unfold map_a;
      repeat (match goal with
              | [ |- context [decA ?X ?Y]] =>
                case (decA X Y)
              | [ |- context [decB ?X ?Y]] =>
                case (decB X Y)
              | _ => reflexivity
              | _ => contradiction
              end).

    Local Lemma surjH (d' : mod_dom i (upd_map p f))
      : exists a : mod_dom i f + unit,
        bot_map (proj0 a) = Some (proj1 d').
    Proof.
      destruct d' as [ a H ]; unfold mod_elt in H; simpl.
      case (decA (fst p) a).
      - intro fstH.
        exists (inr tt).
        simpl. unfold bot_map, map_a.
        case (decB (upd_map p f (fst p)) (i (fst p))).
        + rewrite <- fstH in H. contradiction.
        + simpl. rewrite fstH. tauto.
      - intro rstH.
        assert (not_H_a: a <> fst p); auto.
        assert (IH: upd_map p f a = f a);
          unfold upd_map; dec_equal.
        assert (aH: mod_elt i f a);
          unfold mod_elt in H; unfold mod_elt. rewrite <- IH; auto.
        exists (inl (exist _ a aH)).
        unfold bot_map; dec_equal.
    Qed.

    (**

        We can finally prove the lemma that we wanted. Note that we
        use the [finite_surj_option] lemma from the FinMod library.
        This avoids some of the faffing around with option types that
        we'd need otherwise.

     *)
    Lemma fin_mod_upd_map
      : fin_mod i f -> fin_mod i (upd_map p f).
    Proof.
      intro feH.
      unfold fin_endo.
      apply (finite_surj_option proj1 top_map bot_map (finite_proj0 feH)).
      - exact natH.
      - exact surjH.
    Qed.
  End UpdMap.

  (** * List maps

      With the results of the previous section, it now just takes a
      quick induction to define the function described by a list of
      pairs and to see that it is a finite modification of the
      underlying map.
   *)
  Section ListMap.
    Variable B : Type.
    Variable i : A -> B.
    Hypothesis decB : forall x y : B, {x = y} + {x <> y}.

    Fixpoint list_map (l : list (A * B)) : A -> B :=
      match l with
      | nil => i
      | cons p l => upd_map p (list_map l)
      end.

    Lemma list_map_nil : list_map nil = i.
    Proof. reflexivity. Qed.

    Lemma list_map_cons p l : list_map (cons p l) = upd_map p (list_map l).
    Proof. reflexivity. Qed.

    Lemma list_map_is_fin_mod l : fin_mod i (list_map l).
    Proof.
      induction l as [ | pr l IH ].
      - simpl. apply fin_mod_i.
      - unfold list_map. fold list_map.
        apply (fin_mod_upd_map); tauto.
    Qed.

    Lemma list_map_app_in l1 l2 a
      : In a (map fst l1) -> list_map (l1 ++ l2) a = list_map l1 a.
    Proof.
      induction l1 as [ | p l1 IH ]; try contradiction.
      destruct p as [ pa pb ]; simpl.
      destruct (decA pa a) as [ -> | neH ].
      - rewrite ! upd_map_at; auto.
      - destruct 1 as [ | inH ]; try contradiction.
        specialize (IH inH); clear inH.
        rewrite ! upd_map_not_at; auto.
    Qed.

    Lemma list_map_app_not_in l1 l2 a
      : ~ In a (map fst l1) -> list_map (l1 ++ l2) a = list_map l2 a.
    Proof.
      induction l1 as [ | p l1 IH ]; auto.
      destruct p as [ pa pb ]; simpl.
      destruct (decA pa a) as [ -> | neH ]; try tauto.
      rewrite ! upd_map_not_at; auto.
    Qed.

    Section FinIsList.
      Variable f : A -> B.
      Hypothesis finH : fin_mod i f.

      Local Definition list_graph (l : list A) : list (A * B) :=
        map (fun a => (a, f a)) l.

      Local Lemma list_map_list_graph_cons a l a'
        : list_map (list_graph (a :: l)) a' =
          upd_map (a, f a) (list_map (list_graph l)) a'.
      Proof.
        reflexivity.
      Qed.

      Local Lemma ev_list_graph_off_dom l a
        : f a = i a -> list_map (list_graph l) a = i a.
      Proof.
        intro eqH.
        induction l as [ | a' l IH ]; auto.
        rewrite list_map_list_graph_cons.
        apply upd_map_elim.
        - intro aH; rewrite <- aH, eqH. exact eq_refl.
        - intro. exact IH.
      Qed.

      Local Lemma fm_graph_is_list_map (l : list (mod_dom i f))
        : FullProj (md_elt (f := f)) l ->
          forall a,
            f a = list_map (list_graph (map (md_elt (f := f)) l)) a.
      Proof.
        unfold FullProj; intros fullH a.
        set (ul := map (md_elt (f := f)) l).
        case (decB (f a) (i a)).
        + intro eqA; rewrite (ev_list_graph_off_dom ul eqA); tauto.
        + intro neH.
          specialize (fullH (exist _ a neH)).
          rename fullH into inProjH.
          induction l as [ | d l IH ]; try contradiction.
          simpl in inProjH.
          unfold ul. rewrite map_cons.
          rewrite list_map_list_graph_cons.
          destruct (decA (md_elt d) a) as [ deqH | dneH ].
          * rewrite deqH, upd_map_at; exact eq_refl.
          * simpl in IH.
            destruct inProjH; try contradiction.
            specialize (IH H); clear H.
            rewrite (upd_map_not_at _ _ (not_eq_sym dneH)).
            apply IH.
      Qed.

      Local Lemma in_md_elt_graph_imp_neq p (l : list (mod_dom i f))
        : In p (list_graph (map (md_elt (f := f)) l)) ->
          f (fst p) <> i (fst p).
      Proof.
        induction l as [ | md l IH ]; try contradiction.
        revert IH.
        unfold list_graph.
        rewrite !map_map, map_cons.
        intro IH.
        destruct 1 as [ <- | inH ]; auto.
        unfold md_elt; apply proj2_sig.
      Qed.

      Definition fin_mod_list_graph : list (A * B) :=
        list_graph (map md_elt (proj1_sig finH)).

      Definition fin_mod_list_map : A -> B :=
        list_map fin_mod_list_graph.

      Lemma fin_mod_is_list_map
        : forall a, f a = fin_mod_list_map a.
      Proof.
        apply fm_graph_is_list_map, proj2_sig.
      Qed.

      Lemma fin_mod_moves_list_elts
        : forall p, In p fin_mod_list_graph -> f (fst p) <> i (fst p).
      Proof.
        eauto using in_md_elt_graph_imp_neq.
      Qed.

      Lemma in_fin_mod_list_graph a
        : f a <> i a -> In (a, f a) fin_mod_list_graph.
      Proof.
        intro neH.
        apply (in_map (fun x => (x, f x))).
        destruct finH as [ ds fullH ]; simpl.
        apply (fullH (exist _ a neH)).
      Qed.
    End FinIsList.

    Lemma list_map_rem_dups' seen l a
      : ~ In a seen ->
        list_map l a = list_map (rem_dups_under fst decA seen l) a.
    Proof.
      revert seen.
      induction l as [ | [ x y ] l IH ]; auto.
      intros seen unseenH.
      simpl; unfold upd_map; simpl.
      case_eq (search A decA x seen); intro searchH.
      - destruct (decA a x) as [ <- | neH ]; auto.
        contradiction (search_imp_in _ _ _ _ searchH).
      - simpl; unfold upd_map; simpl.
        destruct (decA a x) as [ <- | neH ]; auto.
        apply IH; intro inH; destruct inH; auto.
    Qed.

    Lemma list_map_rem_dups l a
      : list_map l a = list_map (rem_dups_under fst decA nil l) a.
    Proof.
      apply list_map_rem_dups'; auto.
    Qed.

  End ListMap.
End decA.

Arguments list_map_rem_dups' {A} decA {B} i {seen} l a.
Arguments list_map_rem_dups {A} decA {B} i l a.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	                    Category ONE                  		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export Category.

Set Implicit Arguments.
Unset Strict Implicit.

(* The category One *)

Inductive One_ob : Type :=
    Obone : One_ob.

Inductive One_mor : One_ob -> One_ob -> Type :=
    Id_Obone : One_mor Obone Obone.

 Section equal_one_mor.

 Variable a b : One_ob.

 Definition Equal_One_mor (f g : One_mor a b) := True.

 Lemma Equal_One_mor_equiv : Equivalence Equal_One_mor.
 Proof.
 unfold Equal_One_mor in |- *; apply Build_Equivalence;
  [ trivial | apply Build_Partial_equivalence ]; red in |- *;
  trivial.
 Qed.

 Canonical Structure One_mor_setoid : Setoid := Equal_One_mor_equiv.

 End equal_one_mor.

Definition Comp_One_mor (a : One_ob) :=
  let () as x
      return
        (forall b c : One_ob,
         One_mor_setoid x b -> One_mor_setoid b c -> One_mor_setoid x c) :=
      a in
  fun b c =>
  let () as x
      return
        (One_mor_setoid Obone b ->
         One_mor_setoid b x -> One_mor_setoid Obone x) := c in
  fun _ _ => Id_Obone.

Lemma Comp_One_mor_congl : Congl_law Comp_One_mor.
Proof.
unfold Congl_law, Comp_One_mor in |- *; simpl in |- *;
 unfold Equal_One_mor in |- *; trivial.
Qed.

Lemma Comp_One_mor_congr : Congr_law Comp_One_mor.
Proof.
unfold Congr_law, Comp_One_mor in |- *; simpl in |- *;
 unfold Equal_One_mor in |- *; trivial.
Qed.

Definition Comp_One := Build_Comp Comp_One_mor_congl Comp_One_mor_congr.

Lemma Assoc_One : Assoc_law Comp_One.
Proof.
unfold Assoc_law in |- *; simpl in |- *.
unfold Comp_One, Equal_One_mor in |- *; trivial.
Qed.

Definition Id_One (a : One_ob) : One_mor_setoid a a :=
  let () as x return (One_mor x x) := a in Id_Obone.

Lemma Idl_One : Idl_law Comp_One Id_One.
Proof.
unfold Idl_law in |- *; simpl in |- *.
unfold Comp_One, Id_One, Equal_One_mor in |- *; trivial.
Qed.

Lemma Idr_One : Idr_law Comp_One Id_One.
Proof.
unfold Idr_law in |- *; simpl in |- *.
unfold Comp_One, Id_One, Equal_One_mor in |- *; trivial.
Qed.

Canonical Structure One := Build_Category Assoc_One Idl_One Idr_One.