(** This contains the implementation of a [CNF] module
   on lazy literals. *)
Require Import Quote List Ergo Containers.OrderedType.
Require Import BinPos LLazy.
Require Import Containers.Sets.
Require Import Cnf DoubleNegUtils Setoid.
Require Export CNFLazyCommon.
Require Import Omega.

(** * The module [CNFRAW]

   What the CNF module would be if it were operating on raw literals
   instead of well-formed literals. We define smart constructors
   for every logical construct (atomic, or, and, implication and
   equivalence).

   Note that the proxy for [f \/ g] is [[[f;g]]] and its negation
   is [[[~f];[~g]]] which corresponds to intuition, similarly for the
   other logical operators.
   *)
Module CNFRAW.
  Import LLAZY.RAW.
(*   Definition mk_lit idx b := Lit (LITINDEX.L idx b). *)
  Definition mk_lit atom b := Lit (Some atom, b).
  Definition mk_true := ltrue.
  Definition mk_false := lfalse.
  Definition mk_or f g := Proxy
    ((f::g::nil)::nil)
    (((mk_not f)::nil)::((mk_not g)::nil)::nil).
  Definition mk_and f g := Proxy
    ((f::nil)::(g::nil)::nil)
    (((mk_not f)::(mk_not g)::nil)::nil).
  Definition mk_impl f g := mk_or (mk_not f) g.
  Definition mk_iff f g := mk_and (mk_impl f g) (mk_impl g f).
End CNFRAW.

(** * The module [CNFLAZY] *)
Module CNFLAZY <: CNFLAZY_INTERFACE.
  (** [CNFLAZY] will be be our [CNF] module on lazy literals.
     We start by including [CNFLAZYCOMMON] which defines the
     module [L] of literals as [LLAZY], and the necessary sets, etc. *)
  Include CNFLAZYCOMMON.

  Import LLAZY. Import CNFRAW.

  Typeclasses Opaque RAW.eq. (* To speed-up rewrite *)

  (** We can now lift the smart constructors of [CNFRAW] to [LLAZY]
     by proving that they build well-formed literals when their
     parameters are well-formed. *)
  Property wf_mk_lit : forall idx b, wf_lit (mk_lit idx b).
  Proof. intro; constructor. Qed.
  Definition mk_lit atom b : formula :=
    mk_literal (mk_lit atom b) (wf_mk_lit atom b).

  Definition mk_true : formula := ltrue.
  Definition mk_false : formula := lfalse.

  Identity Coercion t_of_t_ : RAW.t >-> RAW.t_.

  Lemma mk_not_size :
    forall l, wf_lit l -> RAW.size (RAW.mk_not l) = RAW.size l.
  Proof.
    intros l Hl; destruct l; inversion Hl; simpl; auto.
  Qed.

  (** The constructor [mk_or] and [mk_and] can be lifted
     without issue. [mk_impl] can be defined in terms of
     [mk_or] and [mk_and] so it is straightforward as well.
     *)
  Property wf_mk_or : forall (l l' : t), wf_lit (mk_or l l').
  Proof.
    intros [x Hx] [y Hy]; unfold mk_or; simpl; constructor.
    reflexivity.
    simpl; rewrite !RAW.mk_not_invol; reflexivity.
    simpl; rewrite !mk_not_size; auto; omega.

    intros l t0 Hl Ht0. inversion Hl; subst; try contradiction.
    inversion Ht0; subst; simpl; auto.
    destruct H; subst; simpl; auto; contradiction.
    intros l t0 Hl Ht0. inversion Hl; subst.
    inversion Ht0; simpl in *; subst; simpl; try apply wf_mk_not; intuition.
    destruct H; subst; try contradiction.
    inversion Ht0; simpl in H; subst; simpl; try apply wf_mk_not; intuition.
  Qed.
  Definition mk_or (f g : t) : formula :=
    mk_literal (mk_or f g) (wf_mk_or f g).

  Property wf_mk_and : forall (l l' : t), wf_lit (mk_and l l').
  Proof.
    intros [x Hx] [y Hy]; unfold mk_and; simpl; constructor.
    reflexivity.
    simpl; rewrite !RAW.mk_not_invol; reflexivity.
    simpl; rewrite !mk_not_size; auto; omega.

    intros l t0 Hl Ht0. inversion Hl; subst; try contradiction.
    inversion Ht0; subst; simpl; auto; contradiction.
    destruct H; subst; try contradiction.
    inversion Ht0; subst; simpl; auto; contradiction.
    intros l t0 Hl Ht0. inversion Hl; subst; try contradiction.
    inversion Ht0; subst; simpl; try apply wf_mk_not; auto.
    destruct H; simpl in *; subst; simpl; try apply wf_mk_not; intuition.
  Qed.
  Definition mk_and (f g : t) :=
    mk_literal (mk_and f g) (wf_mk_and f g).

  Property wf_mk_impl : forall (l l' : t), wf_lit (mk_impl l l').
  Proof.
    intros x y; unfold mk_impl; exact (wf_mk_or (mk_not x) y).
  Qed.
  Definition mk_impl (f g : t) :=
    mk_literal (mk_impl f g) (wf_mk_impl f g).

  (** The smart constructor for [mk_iff] is a bit less efficient
     than what we wished. Indeed, one would like to build the proxy
     [[[f;g];[~f;~g]]] for the formula [f <-> g]. But then there is
     no way to choose a second parameter for the proxy that verifies
     the property with [negation]. Namely, [negation] is not involutive
     on such a proxy ; our workaround is thus to use [mk_and] and [mk_impl]
     which is correct but adds a level of proxy.
     *)
  Property wf_mk_iff : forall (l l' : t), wf_lit (mk_iff l l').
  Proof.
    intros x y; unfold mk_iff;
      exact (wf_mk_and (mk_impl _ _) (mk_impl _ _)).
  Qed.
  Definition mk_iff (f g : t) :=
    mk_literal (mk_iff f g) (wf_mk_iff f g).

  (** Finally, the [make] function just takes a formula (ie, a lazy literal)
     [f] and returns the singleton clause [{{f}}]. *)
  Definition make (f : formula) : cset := singleton {f}.
  Property make_1 :
    forall f, make f [=] singleton {f}.
  Proof.
    intro f; reflexivity.
  Qed.

  Definition cfl (ll : list (list L.t)) : cset :=
    (fold_right (fun l cl => add (fold_right add {} l) cl) {} ll).
  Property cfl_1 :
    forall ll, cfl ll [=]
      (fold_right (fun l cl =>
        add (fold_right add {} l) cl) {} ll).
  Proof.
    intros; reflexivity.
  Qed.

  Definition interp : varmaps -> formula -> Prop := interp.

  (** Finally, we define a conversion function that applies our
     smart constructors recursively in order to build a [formula]
     out of a general formula [form].

     We also include a proof that the converted formula is equivalent
     to the original formula.
     *)
  Module Conversion.
    Fixpoint mk_form (f : fform) : formula :=
      match f with
        | FVar idx => mk_lit (LITINDEX.Atom idx) true
        | FNot (FVar idx) => mk_lit (LITINDEX.Atom idx) false
        | FEq s1 s2 => mk_lit (LITINDEX.Equation s1 s2) true
        | FNot (FEq s1 s2) => mk_lit (LITINDEX.Equation s1 s2) false
        | FTrue => mk_true
        | FFalse => mk_false
        | FAnd f g => mk_and (mk_form f) (mk_form g)
        | FOr f g => mk_or (mk_form f) (mk_form g)
        | FNot f => mk_not (mk_form f)
        | FImp f g => mk_impl (mk_form f) (mk_form g)
        | FIff f g => mk_iff (mk_form f) (mk_form g)
      end.

    Lemma mk_not_not :
      forall v f, ~~(interp v f <-> ~interp v (mk_not f)).
    Proof.
      exact mk_not_interp.
    Qed.
    Corollary not_mk_not :
      forall v f, ~~(~(interp v f) <-> interp v (mk_not f)).
    Proof.
      intros v f N.
      apply (mk_not_not v f); intro R; crewrite R N.
      apply (double_not (interp v (mk_not f))); intro R; crewrite R N.
      apply N; reflexivity.
    Qed.

    Ltac aapply H := apply H; try assumption.
    Theorem mk_form_equiv :
      forall v f, Ergo.well_typed_formula v f ->
        ~~(finterp v f <-> interp v (mk_form f)).
    Proof.
      intros v; induction f; unfold interp; simpl;
        try destruct IHf as [IH1 IH2]; intro Hwt; inversion_clear Hwt.
      (* - lits *)
      vm_compute; tauto.
      intro N; apply N; symmetry.
      unfold LLAZY.interp, RAW.interp; simpl.
      apply ModelsRingExt.eq_wt_iff; auto.
      rewrite <- (Term.has_type_is_type_of _ _ _ _ H); exact H.
      rewrite <- (Term.has_type_is_type_of _ _ _ _ H0); exact H0.
      (* - true and false *)
      vm_compute; tauto.
      vm_compute; tauto.
      (* - and *)
      intro N; aapply IHf1; intro IH1; aapply IHf2; intro IH2;
        clear IHf1 IHf2.
      apply N; rewrite IH1; rewrite IH2; clear N IH1 IH2.
      unfold LLAZY.interp; simpl; intuition.
      (* - or *)
      intro N; aapply IHf1; intro IH1; aapply IHf2; intro IH2;
        clear IHf1 IHf2.
      apply N; rewrite IH1; rewrite IH2; clear N IH1 IH2.
      unfold LLAZY.interp; simpl; intuition.
      (* - ~ *)
      intro N; aapply IHf; intro R; crewrite R N.
      apply (mk_not_not v (mk_form f));
        intro R; crewrite R N.
      revert N; destruct f; apply double_not.
      (* - -> *)
      intro N; aapply IHf1; intro IH1; aapply IHf2; intro IH2;
        clear IHf1 IHf2.
      apply (imp_def (finterp v f1) (finterp v f2));
        intro R; crewrite R N; rewrite IH2 in N; rewrite IH1 in N.
      apply (not_mk_not v (mk_form f1)); intro R; crewrite R N.
      apply N; clear IH1 IH2 N.
      unfold CNFRAW.mk_impl, interp, L.interp, RAW.interp; simpl.
      intuition.
      (* - <-> *)
      intro N; aapply IHf1; intro IH1; aapply IHf2; intro IH2;
        clear IHf1 IHf2.
      unfold iff at 2 in N.
      apply (imp_def (finterp v f1) (finterp v f2)); intro R1.
      apply (imp_def (finterp v f2) (finterp v f1)); intro R2.
      crewrite R1 N; crewrite R2 N; rewrite IH1 in N; rewrite IH2 in N.
      apply (not_mk_not v (mk_form f1)); intro R; crewrite R N.
      apply (not_mk_not v (mk_form f2)); intro R; crewrite R N.
      apply N; clear N IH1 IH2.
      unfold CNFRAW.mk_iff, L.interp, RAW.interp; simpl. intuition.
    Qed.

    Corollary cnf :
      forall v f, Ergo.well_typed_formula v f ->
        ~~(finterp v f <-> interp v (mk_form f)).
    Proof.
      exact mk_form_equiv.
    Qed.
  End Conversion.
End CNFLAZY.


(* Kindergarten quantum mechanics *)

From mathcomp Require Import all_ssreflect all_algebra.
Require Import lens tpower.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing.Theory.

Section transpose.

Variables (R : comRingType).
Let I := [finType of 'I_2].
Let dI : I := ord0.

Notation idmor n := (idmor I n).
Notation tsquare m := (tmatrix I R m m).
Notation endo n := (mor I R n n).

Notation focus := (focus dI).
Notation curry := (curry dI).

Local Definition sum_enum_indices := sum_enum_indices uniq_enum2 mem_enum2.
Local Definition mem_enum_indices := mem_enum_indices mem_enum2.
Local Definition forall_indicesP := forall_indicesP mem_enum2.

Section cap_cup.
Variables (n : nat) (l : lens (2 + n) 2).

Definition cap :=
  asym_focus dI (R:=R) (p:=0) l (lens_empty n) (inner_prod I 1).
Definition cup :=
  asym_focus dI (R:=R) (m:=0) (lens_empty n) l (inner_coprod I 1).
End cap_cup.

Lemma extract_rev A n m (l1 l2 : lens n m) (v : n.-tuple A) :
  rev l1 = l2 -> [tuple of rev (extract l1 v)] = extract l2 v.
Proof. by move=> Hrev; apply/val_inj; rewrite /= -map_rev Hrev. Qed.

Lemma lens_left_1 n : lens_left 1 n = [lens 0].
Proof. by eq_lens. Qed.

Lemma lens_right_1 n : lens_right n 1 = [lens n].
Proof. by eq_lens; rewrite /= addnOK. Qed.

Lemma lens_comp_rev_left n (l1 l2 : lens (2+n) 2) : rev l1 = l2 ->
  lens_comp l1 (lens_left 1 1) = lens_comp l2 (lothers(lens_left 1 1)).
Proof.
move=> Hrev; apply/lens_inj => /=.
move: (lothers_left 1 1) => /= ->.
by rewrite !enum_ordinalE /= !(tnth_nth ord0) /= -Hrev nth_rev // size_tuple.
Qed.

Lemma cup_sym n (l1 l2 : lens (2+n) 2) :
  rev l1 = l2 -> cup l1 =e cup l2.
Proof.
move=> Hrev T v.
apply/ffunP => vi.
rewrite !(ffunE,tsmorE) !cast_tupleE !(big_pred1 [tuple]); try by case => -[].
rewrite !ffunE -!extract_comp.
rewrite -(lens_comp_rev_left Hrev) -(lens_comp_rev_left (l1:=l2) (l2:=l1));
  last by rewrite -Hrev revK.
rewrite [in RHS]eq_sym.
case H: (_ == _); last by rewrite !scale0r.
rewrite !scale1r !merge_indices_empty.
do 3!f_equal.
apply/lens_inj/eq_filter => /= i.
by rewrite !mem_lensE /= -Hrev mem_rev.
Qed.

Lemma transpose_cup (M : tsquare 1) :
  focus [lens 0] (tsmor M) \v cup (n:=1) [lens 0; 1] =e
  focus [lens 1] (tsmor (transpose_tsquare M)) \v cup [lens 0; 1].
Proof.
move=> T v /=.
apply/ffunP => vi /=.
rewrite /asym_focus_fun !focusE /= /focus_fun.
do! rewrite !(tsmorE,ffunE,sum_ffunE,sum_enum_indices) /= !addr0 !ffunE.
rewrite !lens_left_1.
have -> : lothers [lens 0] = [lens 1] by eq_lens.
rewrite !cast_tupleE /= -!extract_comp.
have -> : lens_comp [lens 0; 1] [lens 0] = [lens 0] :> lens 3 1 by eq_lens.
have -> : lens_comp [lens 0; 1] [lens 1] = [lens 1] :> lens 3 1 by eq_lens.
rewrite !extract_merge !merge_indices_empty /= !extract_merge_disjoint.
rewrite !scalerA -!scalerDl.
f_equal.
have := mem_enum_indices (extract [lens 0] vi).
have := mem_enum_indices (extract [lens 1] vi).
by rewrite !inE => /orP[] /eqP -> /orP[] /eqP -> /=;
   rewrite !(mulr0,addr0,add0r).
all: by rewrite disjoint_has //= /others enum_ordinalE.
Qed.

Lemma cat_2tuple A (x y : A) : [tuple of [tuple x]++[tuple y]] =  [tuple x; y].
Proof. exact/val_inj. Qed.

Lemma straighten : cap [lens 1; 2] \v cup [lens 0; 1] =e idmor 1.
Proof.
move=> T /= v.
rewrite /asym_focus_fun.
apply/ffunP => t /=.
rewrite /inner_prod /inner_coprod /M_inner_prod /M_inner_coprod.
rewrite {1}/uncurry !ffunE /= !tsmorE sum_enum_indices /= !ffunE /=.
rewrite -!cat_2tuple !extract_lens_left.
rewrite !(extract_eq_cast (lothers_left 1 1)) !extract_lens_right /= !linE.
rewrite !tsmorE !sum_enum_indices /= !ffunE /= !addr0.
apply/eqP; move: t; apply/forall_indicesP.
rewrite /= andbT; apply/andP.
(* brute force *)
rewrite !eq_ord_tuple /= /tnth /= /tnth /= /others.
rewrite /in_mem /mem /= !enum_ordinalE /= !linE.
split; apply/eqP/f_equal/eqP;
  by rewrite eq_ord_tuple /= /tnth /= /others !enum_ordinalE.
Qed.

Lemma transpose_focus (M : tsquare 1) :
  tsmor (transpose_tsquare M) =e
  cap [lens 1; 2] \v focus [lens 1] (tsmor M) \v cup [lens 0; 1].
Proof.
rewrite -{2}(transpose_tsquare_involutive M).
move=> T v.
rewrite -comp_morA comp_morE comp_morE.
move: (transpose_cup (transpose_tsquare M) v) => /= <-.
have NM : naturality (tsmor (transpose_tsquare M)) by apply/naturalityP; esplit.
have NIP : naturality (inner_prod I 1 (R:=R)) by apply/naturalityP; esplit.
set mycup := asym_focus_fun dI ([lens] : lens (0+1) 0)
                  ([lens 0; 1] : lens (2+1) 2) (inner_coprod I 1) v.
move: (asym_focusC dI ([lens 1; 2] : lens (2+1) 2) ([lens] : lens (0+1) 0)
                   NM NIP mycup).
rewrite !cast_lensE.
have -> : lothers [lens 1; 2] = [lens 0] by eq_lens.
move=> /= <-.
subst mycup.
move: (straighten v) => /= ->.
have <- : lens_id 1 = lothers [lens] by eq_lens.
by rewrite (focusI dI NM v).
Qed.
End transpose.