(** A theory of type-aligned lists, using the Coq-Equations plugin *)

Require Import Coq.Bool.Bool.
Require Import Coq.Lists.List.

From Equations Require Import Equations.
Set Equations With UIP.

Require Import Category.Lib.

Set Transparent Obligations.

Open Scope lazy_bool_scope.

Inductive netlist {A : Type} (B : A → A → Type) : A → A → Type :=
  | tfin : ∀ i j : A, B i j → netlist i j
  | tadd : ∀ i j k : A, B i j → netlist j k → netlist i k.

Derive Signature NoConfusion NoConfusionHom Subterm for netlist.

Arguments tfin {A B i j} x.
Arguments tadd {A B i} j {k} x xs.

Notation "x :::: xs" := (tadd _ x xs) (at level 60, right associativity).

Section Netlist.

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

Fixpoint netlist_length {i j} (xs : netlist B i j) : nat :=
  match xs with
  | tfin _ => 1
  | tadd _ _ xs => 1 + netlist_length xs
  end.

Equations netlist_app {i j k} (xs : netlist B i j) (ys : netlist B j k) :
  netlist B i k :=
  netlist_app (tfin x) ys := x :::: ys;
  netlist_app (@tadd _ _ _ x xs) ys := x :::: netlist_app xs ys.

Notation "xs ++++ ys" := (netlist_app xs ys) (at level 60, right associativity).

Equations netlist_uncons {i j} (xs : netlist B i j) :
  { z : A & B i z & option (netlist B z j) }%type :=
  netlist_uncons (tfin x) := existT2 _ _ _ x None;
  netlist_uncons (@tadd _ _ _ x xs) := existT2 _ _ _ x (Some xs).

Equations netlist_map {i j A' C} {f : A → A'}
          (g : ∀ i j : A, B i j → C (f i) (f j))
          (xs : netlist B i j) : netlist C (f i) (f j) :=
  netlist_map g (tfin x) := tfin (g _ _ x);
  netlist_map g (@tadd _ _ _ x xs) := g _ _ x :::: netlist_map g xs.

Import ListNotations.

Equations netlist_mapv {i j C}
          (g : ∀ i j : A, B i j → C)
          (xs : netlist B i j) : list C :=
  netlist_mapv g (tfin x) := [g _ _ x];
  netlist_mapv g (@tadd _ _ _ x xs) := g _ _ x :: netlist_mapv g xs.

Equations netlist_head {i j} (xs : netlist B i j) :
  { z : A & B i z }%type :=
  netlist_head (tfin x) := (_; x);
  netlist_head (@tadd _ _ _ x _) := (_; x).

Equations netlist_tail {i j} (xs : netlist B i j) :
  option { z : A & netlist B z j }%type :=
  netlist_tail (tfin _) := None;
  netlist_tail (@tadd _ _ _ _ xs) := Some (_; xs).

Equations netlist_init {i j} (xs : netlist B i j) :
  option { z : A & netlist B i z }%type :=
  netlist_init (tfin _) := None;
  netlist_init (@tadd _ _ _ x xs) with netlist_init xs := {
    | None => Some (_; tfin x);
    | Some (existT ys) => Some (_; (x :::: ys))
  }.

Equations netlist_last {i j} (xs : netlist B i j) :
  { z : A & B z j }%type :=
  netlist_last (tfin x) := (_; x);
  netlist_last (@tadd _ _ _ _ xs) := netlist_last xs.

Equations netlist_rev (flip : ∀ x y : A, B x y → B y x)
          {i j} (xs : netlist B i j) : netlist B j i :=
  netlist_rev flip (tfin x) := tfin (flip _ _ x);
  netlist_rev flip (@tadd _ _ _ x xs) :=
    netlist_rev flip xs ++++ tfin (flip _ _ x).

Equations netlist_concat {i j} (xs : netlist (netlist B) i j) : netlist B i j :=
  netlist_concat (tfin x) := x;
  netlist_concat (@tadd _ _ _ x xs) := x ++++ netlist_concat xs.

Context `{EqDec A}.
Context `{∀ i j, EqDec (B i j)}.

Import EqNotations.

(* Returns true if [xs] is a sublist of [ys] *)
Equations netlist_incl
          {j k} (xs : netlist B j k)
          {i l} (ys : netlist B i l) : bool :=
  netlist_incl (@tfin _ _ j k x) (@tfin _ _ i l y)
    with (eq_dec j i, eq_dec k l) := {
      | pair (left H1) (left H2)
        with eq_dec x (rew <- [fun y => B _ y] H2 in
                     rew <- [fun x => B x _] H1 in y) := {
          | left _ => true;
          | _ => false
        };
      | _ => false
    };
  netlist_incl (@tfin _ _ j k x) (@tadd _ _ i o _ y ys)
    with (eq_dec j i, eq_dec k o) := {
      | pair (left H1) (left H2)
        with eq_dec x (rew <- [fun y => B _ y] H2 in
                     rew <- [fun x => B x _] H1 in y) := {
          | left _ => true;
          | _ => false
        };
      | _ => netlist_incl (tfin x) ys
    };
  netlist_incl _ (tfin _) := false;
  netlist_incl (@tadd _ _ j m _ x xs) (@tadd _ _ i o _ y ys)
    with (eq_dec j i, eq_dec m o) := {
      | pair (left H1) (left H2) =>
        (eq_dec x (rew <- [fun y => B _ y] H2 in
                   rew <- [fun x => B x _] H1 in y)
           &&& netlist_incl xs ys)
          ||| netlist_incl (x :::: xs) ys;
      | _ => netlist_incl (x :::: xs) ys
    }.

Equations netlist_eq_dec {i j : A} (x y : netlist B i j) : {x = y} + {x ≠ y} :=
  netlist_eq_dec (tfin x) (tfin y) with eq_dec x y := {
    | left _ => in_left;
    | _ => in_right
  };
  netlist_eq_dec (@tfin _ _ _) _ := in_right;
  netlist_eq_dec _ (@tfin _ _ _) := in_right;
  netlist_eq_dec (@tadd _ _ _ m _ x xs) (@tadd _ _ _ o _ y ys)
    with eq_dec m o := {
      | left H with eq_dec x (rew <- [fun x => B _ x] H in y) := {
          | left _ with netlist_eq_dec xs (rew <- [fun x => netlist B x _] H in ys) := {
             | left _ => in_left;
             | _ => in_right
            };
          | _ => in_right
        };
      | _ => in_right
    }.
Next Obligation.
  simpl_eq; intros.
  apply n.
  inv H1.
  apply Eqdep_dec.inj_pair2_eq_dec in H3; [|apply eq_dec].
  apply Eqdep_dec.inj_pair2_eq_dec in H3; [|apply eq_dec].
  assumption.
Defined.
Next Obligation.
  simpl_eq; intros.
  intuition eauto.
  match goal with [ H : _ → False |- _ ] => apply H end.
  inv H1.
  apply Eqdep_dec.inj_pair2_eq_dec in H3; [|apply eq_dec].
  apply Eqdep_dec.inj_pair2_eq_dec in H3; [|apply eq_dec].
  assumption.
Defined.
Next Obligation.
  simpl_eq; intros.
  intuition eauto.
  match goal with [ H : _ → False |- _ ] => apply H end.
  inv H1.
  apply Eqdep_dec.inj_pair2_eq_dec in H3; [|apply eq_dec].
  apply Eqdep_dec.inj_pair2_eq_dec in H3; [|apply eq_dec].
  assumption.
Defined.

Lemma netlist_app_comm_cons {i j k l} (x : B i j)
      (xs : netlist B j k) (ys : netlist B k l) :
  x :::: (xs ++++ ys) = (x :::: xs) ++++ ys.
Proof. now rewrite netlist_app_equation_2. Qed.

Lemma netlist_app_assoc {i j k l}
      (xs : netlist B i j) (ys : netlist B j k) (zs : netlist B k l) :
  (xs ++++ ys) ++++ zs = xs ++++ (ys ++++ zs).
Proof.
  induction xs; auto.
  now rewrite <- !netlist_app_comm_cons, IHxs.
Qed.

Context `{∀ i j, Setoid (B i j)}.

Equations netlist_equiv {i j : A} (x y : netlist B i j) : Type :=
  netlist_equiv (@tfin _ _ x) (@tfin _ _ y) := x ≈ y;
  netlist_equiv (@tfin _ _ _) _ := False;
  netlist_equiv _ (@tfin _ _ _) := False;
  netlist_equiv (@tadd _ _ _ m _ x xs) (@tadd _ _ _ o _ y ys)
    with eq_dec m o := {
      | left H =>
         equiv x (rew <- [fun x => B _ x] H in y) *
         netlist_equiv xs (rew <- [fun x => netlist B x _] H in ys);
      | right _ => False
    }.

#[export] Program Instance netlist_equiv_Equivalence {i j} :
  Equivalence (@netlist_equiv i j).
Next Obligation.
  repeat intro.
  induction x; simpl.
  - rewrite netlist_equiv_equation_1.
    reflexivity.
  - rewrite netlist_equiv_equation_4.
    rewrite EqDec.peq_dec_refl.
    split.
    + apply Equivalence_Reflexive.
    + apply IHx.
Qed.
Next Obligation.
  repeat intro.
  induction x; simpl.
  - dependent elimination y as [tfin _]; auto.
    rewrite netlist_equiv_equation_1 in *.
    now symmetry.
  - dependent elimination y as [tadd _ y ys]; auto.
    rewrite netlist_equiv_equation_4 in *.
    destruct (eq_dec j _); [|contradiction].
    subst.
    rewrite EqDec.peq_dec_refl.
    destruct X.
    split.
    + now apply Equivalence_Symmetric.
    + apply IHx, n.
Qed.
Next Obligation.
  repeat intro.
  induction x; simpl.
  - dependent elimination y as [tfin _]; auto.
    induction z; simpl.
    + rewrite netlist_equiv_equation_1 in *.
      now etransitivity; eauto.
    + now rewrite netlist_equiv_equation_2.
  - dependent elimination y as [tadd _ y ys]; auto.
    simpl; intros.
    dependent elimination z as [tadd _ z zs]; auto.
    rewrite netlist_equiv_equation_4 in *.
    destruct (eq_dec j _); [|contradiction].
    destruct (eq_dec _ _); [|contradiction].
    subst.
    rewrite EqDec.peq_dec_refl.
    destruct X, X0.
    split.
    + transitivity y; auto.
    + eapply IHx; eauto.
Qed.

#[export] Program Instance netlist_Setoid {i j} : Setoid (netlist B i j) := {
  equiv := netlist_equiv;
  setoid_equiv := netlist_equiv_Equivalence;
}.

#[export] Program Instance netlist_cons_respects {i j k} :
  Proper (equiv ==> equiv ==> equiv) (@tadd A B i j k).
Next Obligation.
  repeat intro.
  simpl in *.
  rewrite netlist_equiv_equation_4.
  now rewrite EqDec.peq_dec_refl.
Qed.

#[export] Program Instance netlist_app_respects {i j k} :
  Proper (equiv ==> equiv ==> equiv) (@netlist_app i j k).
Next Obligation.
  repeat intro.
  generalize dependent k.
  induction x; intros; dependent elimination y.
  - rewrite !netlist_app_equation_1.
    rewrite netlist_equiv_equation_1 in X.
    now rewrite X, X0.
  - contradiction.
  - contradiction.
  - rewrite <- !netlist_app_comm_cons.
    rewrite netlist_equiv_equation_4 in *.
    unfold netlist_equiv_clause_4 in *.
    destruct (eq_dec j j1); [|contradiction].
    subst.
    destruct X.
    split; auto.
    apply IHx.
    + exact n0.
    + exact X0.
Qed.

#[export] Program Instance netlist_EqDec {i j} : @EqDec (netlist B i j) := {
  eq_dec := netlist_eq_dec
}.

End Netlist.

Notation "xs ++++ ys" := (netlist_app xs ys) (at level 60, right associativity).

Section NetlistProofs.

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

Lemma netlist_app_length {i j k} (xs : netlist B i j) (ys : netlist B j k) :
  netlist_length (xs ++++ ys) = (netlist_length xs + netlist_length ys)%nat.
Proof.
  induction xs; auto.
  rewrite <- netlist_app_comm_cons; simpl.
  now rewrite IHxs.
Qed.

Lemma netlist_concat_tadd {i j k} (x : netlist B i j) (xs : netlist (netlist B) j k) :
  netlist_concat (x :::: xs) = x ++++ netlist_concat xs.
Proof. reflexivity. Qed.

End NetlistProofs.

Lemma netlist_concat_app {A : Type} {B : A → A → Type} {i j k}
      (xs : netlist (netlist B) i j) (ys : netlist (netlist B) j k) :
  netlist_concat (xs ++++ ys) = netlist_concat xs ++++ netlist_concat ys.
Proof.
  induction xs; auto.
  rewrite <- netlist_app_comm_cons; simpl.
  rewrite !netlist_concat_equation_2.
  rewrite IHxs.
  now rewrite netlist_app_assoc.
Qed.

Section NetlistProofsRev.

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

Variables flip : ∀ x y : A, B x y → B y x.

Lemma netlist_rev_unit {i j k} (xs : netlist B i j) (x : B j k) :
  netlist_rev flip (xs ++++ tfin x) = flip _ _ x :::: netlist_rev flip xs.
Proof.
  induction xs; auto; simpl.
  rewrite <- netlist_app_comm_cons; simpl.
  rewrite netlist_rev_equation_2.
  now rewrite IHxs.
Qed.

Lemma netlist_rev_app_distr {i j k} (xs : netlist B i j) (ys : netlist B j k) :
  netlist_rev flip (xs ++++ ys) = netlist_rev flip ys ++++ netlist_rev flip xs.
Proof.
  generalize dependent i.
  induction xs; simpl; intros; auto.
  rewrite <- netlist_app_comm_cons; simpl.
  rewrite !netlist_rev_equation_2.
  rewrite IHxs.
  now rewrite <- netlist_app_assoc.
Qed.

Hypothesis flip_involutive : ∀ (i j : A) (x : B i j),
  flip _ _ (flip _ _ x) = x.

Lemma netlist_rev_involutive {i j} (xs : netlist B i j) :
  netlist_rev flip (netlist_rev flip xs) = xs.
Proof using A B flip flip_involutive.
  induction xs; simpl; auto.
  - rewrite !netlist_rev_equation_1.
    now rewrite flip_involutive.
  - rewrite netlist_rev_equation_2.
    rewrite netlist_rev_app_distr.
    rewrite IHxs.
    rewrite netlist_rev_equation_1.
    now rewrite flip_involutive.
Qed.

Lemma netlist_rev_length {i j} (xs : netlist B i j) :
  netlist_length (netlist_rev flip xs) = netlist_length xs.
Proof.
  induction xs; auto; simpl.
  rewrite netlist_rev_equation_2.
  rewrite netlist_app_length, IHxs; simpl.
  apply PeanoNat.Nat.add_1_r.
Qed.

End NetlistProofsRev.

Section NetlistProofsInj.

(* Dependending on the choice of A, this can be either
      Eqdep.EqdepTheory.inj_pair2  (incurs axiom)
   or Eqdep_dec.inj_pair2_eq_dec   (when A is decidable)
*)
Hypothesis inj_pair2 :
  ∀ (U : Type) (P : U → Type) (p : U) (x y : P p),
    (p; x) = (p; y) → x = y.

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

Lemma netlist_cons_uncons
      {i m j} (xs : netlist B i j) (y : B i m) ys :
  netlist_uncons xs = existT2 _ _ _ y (Some ys) → xs = y :::: ys.
Proof using A B inj_pair2.
  destruct xs; simpl; intros.
  - inversion H.
  - inversion H; subst; clear H.
    apply inj_pair2 in H2; auto.
    apply inj_pair2 in H3; auto.
    now rewrite H2, H3.
Qed.

End NetlistProofsInj.

Section Sublist.

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

Context `{EqDec A}.
Context `{∀ i j, EqDec (B i j)}.

Import EqNotations.

Fixpoint netlist_find_sublist
         {j k} (xs : netlist B j k)
         {i l} (ys : netlist B i l) :
  option ((netlist B i j + { i = j}) *
          (netlist B k l + { k = l})) :=
  match xs, ys with
  | @tfin _ _ j k x, @tfin _ _ i l y =>
    match eq_dec i j, eq_dec k l with
    | left H1, left H2 =>
      match eq_dec x (rew <- [fun y => B _ y] H2 in
                      rew [fun x => B x _] H1 in y) with
      | left _ => Some (inright H1, inright H2)
      | _ => None
      end
    | _, _ => None
    end
  | @tfin _ _ j k x, @tadd _ _ i o _ y ys =>
    match eq_dec i j, eq_dec k o with
    | left H1, left H2 =>
      match eq_dec x (rew <- [fun y => B _ y] H2 in
                      rew [fun x => B x _] H1 in y) with
      | left _ =>
        Some (inright H1,
              inleft (rew <- [fun x => netlist B x _] H2 in ys))
      | _ => None
      end
    | _, _ =>
      match netlist_find_sublist (tfin x) ys with
      | None => None
      | Some (inright H, zs) =>
        Some (inleft (rew [fun y => netlist B _ y] H in tfin y), zs)
      | Some (inleft ys, zs) =>
        Some (inleft (y :::: ys), zs)
      end
    end
  | _, tfin _ => None
  | @tadd _ _ j m k x xs, @tadd _ _ i o l y ys =>
    match eq_dec i j, eq_dec m o with
    | left H1, left H2 =>
      match eq_dec x (rew [fun x => B x _] H1 in
                      rew <- [fun x => B _ x] H2 in y) with
      | left _ =>
        match netlist_find_sublist xs ys with
        | Some (inright H, cs) =>
          Some (inright H1, cs)
        | _ =>
          match netlist_find_sublist (x :::: xs) ys with
          | None => None
          | Some (inright H, zs) =>
            Some (inleft (rew [fun y => netlist B _ y] H in tfin y), zs)
          | Some (inleft ys, zs) =>
            Some (inleft (y :::: ys), zs)
          end
        end
      | _ =>
        match netlist_find_sublist (x :::: xs) ys with
        | None => None
        | Some (inright H, zs) =>
          Some (inleft (rew [fun y => netlist B _ y] H in tfin y), zs)
        | Some (inleft ys, zs) =>
          Some (inleft (y :::: ys), zs)
        end
      end
    | _, _  =>
      match netlist_find_sublist (x :::: xs) ys with
      | None => None
      | Some (inright H, zs) =>
        Some (inleft (rew [fun y => netlist B _ y] H in tfin y), zs)
      | Some (inleft ys, zs) =>
        Some (inleft (y :::: ys), zs)
      end
    end
  end.

End Sublist.

Section SublistProofsInj.

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

Context `{EqDec A}.
Context `{∀ i j, EqDec (B i j)}.

Import EqNotations.

Open Scope signature_scope.

Ltac cleanup H post IHf Heqo :=
  inv H;
  specialize (IHf _ _ _ _ _ Heqo); simpl in IHf;
  destruct post; subst;
  try rewrite netlist_app_comm_cons.

Lemma netlist_find_sublist_app
      {j k} (g : netlist B j k)
      {i l} (f : netlist B i l) {pre post} :
  netlist_find_sublist g f = Some (pre, post)
      → match pre, post with
         | inright H1, inright H2  =>
           f = rew <- [fun x => netlist B x _] H1 in
               rew [fun x => netlist B _ x] H2 in g
         | inleft pre, inright H2  =>
           f = pre ++++ rew [fun x => netlist B _ x] H2 in g
         | inright H1, inleft post =>
           f = rew <- [fun x => netlist B x _] H1 in g ++++ post
         | inleft pre, inleft post =>
           f = pre ++++ g ++++ post
         end.
Proof.
  intros.
  generalize dependent k.
  generalize dependent j.
  induction f; intros; simpl in H1.
  - destruct g.
    + destruct (eq_dec i i0); [|discriminate]; subst.
      destruct (eq_dec j0 j); [|discriminate]; subst.
      destruct (eq_dec b0 _); [|discriminate]; subst.
      inversion H1; now subst.
    + discriminate.
  - destruct g.
    + destruct (eq_dec i i0); subst.
      * destruct (eq_dec j0 j); subst.
        ** destruct (eq_dec b0 _); [|discriminate]; subst.
           inversion H1; now subst.
        ** destruct (netlist_find_sublist _ _) eqn:?; [|discriminate].
           destruct p.
           destruct s; subst;
           now cleanup H1 post IHf Heqo.
      * destruct (netlist_find_sublist _ _) eqn:?; [|discriminate].
        destruct p.
        destruct s; subst;
        now cleanup H1 post IHf Heqo.
    + destruct (eq_dec i i0); subst. {
        destruct (eq_dec j0 j); subst. {
          destruct (eq_dec b0 _). {
            subst.
            destruct (netlist_find_sublist g f) eqn:?. {
              destruct p.
              destruct s; subst.
              - simpl_eq.
                destruct (netlist_find_sublist (_ :::: g) f) eqn:?; [|discriminate].
                destruct p.
                destruct s; subst;
                now cleanup H1 post IHf Heqo0.
              - cleanup H1 post IHf Heqo; auto;
                simpl_eq;
                now dependent elimination e.
            }
            destruct (netlist_find_sublist (_ :::: g) f) eqn:?; [|discriminate].
            destruct p.
            destruct s; subst;
            now cleanup H1 post IHf Heqo0; auto.
          }
          destruct (netlist_find_sublist (_ :::: g) f) eqn:?; [|discriminate].
          destruct p.
          destruct s; subst;
          now cleanup H1 post IHf Heqo; auto.
        }
        destruct (netlist_find_sublist (_ :::: g) f) eqn:?; [|discriminate].
        destruct p.
        destruct s; subst;
        now cleanup H1 post IHf Heqo; auto.
      }
      destruct (netlist_find_sublist (_ :::: g) f) eqn:?; [|discriminate].
      destruct p.
      destruct s; subst;
      now cleanup H1 post IHf Heqo; auto.
Qed.

End SublistProofsInj.

Definition nat_triple (i j : nat) : Type := ((nat * nat) * nat)%type.

Open Scope nat_scope.

Definition my_list : netlist nat_triple 0 4 :=
  tadd 1 ((0, 1), 100)
        (tadd 2 ((1, 2), 200)
               (tadd 3 ((2, 3), 300)
                      (tfin ((3, 4), 400)))).

Example netlist_find_sublist_nat_ex1 :
  ∀ H : ∀ i j : nat, EqDec (nat_triple i j),
  @netlist_find_sublist
    nat nat_triple PeanoNat.Nat.eq_dec _
    1 3 (tadd 2 ((1, 2), 200) (tfin ((2, 3), 300)))
    0 4 my_list
    = Some (inleft (tfin ((0, 1), 100)), inleft (tfin (3, 4, 400))).
Proof.
  intros; simpl; simpl_eq.
  now rewrite !EqDec.peq_dec_refl.
Qed.

Reserved Infix "<+>" (at level 42, right associativity).

Class ISemigroup {A : Type} (B : A → A → Type) := {
  isappend {i j k : A} : B i j → B j k → B i k
    where "x <+> y" := (isappend x y);

  isappend_assoc {i j k l} {x : B i j} {y : B j k} {z : B k l} :
    (x <+> y) <+> z = x <+> (y <+> z)
}.

Infix "<+>" := isappend (at level 42, right associativity).

#[export]
Instance netlist_ISemigroup {A} {B : A → A → Type} : ISemigroup (netlist B) := {
  isappend := @netlist_app A B;
  isappend_assoc := @netlist_app_assoc A B
}.


(* 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                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                                                                          *)
(****************************************************************************)
(*                               Opposite.v                                 *)
(****************************************************************************)
(* G. Huet - V5.8  Nov. 1994 *)
(*    ported V5.10 June 1995 *)

Require Import Bool.
Require Import Words.
Require Import Alternate.

(************)
(* Opposite *)
(************)

Inductive opposite : word -> word -> Prop :=
    opp : forall (u v : word) (b : bool), opposite (bit b u) (bit (negb b) v).

Hint Resolve opp.

Lemma not_opp_empty_r : forall u : word, ~ opposite u empty.
Proof.
unfold not in |- *; intros u op.
inversion op.
Qed.

Lemma not_opp_empty_l : forall u : word, ~ opposite empty u.
Proof.
unfold not in |- *; intros u op.
inversion op.
Qed.

Lemma not_opp_same :
 forall (u v : word) (b : bool), ~ opposite (bit b u) (bit b v).
Proof.
unfold not in |- *; intros u v b op.
inversion op.
apply (no_fixpoint_negb b); trivial.
Qed.

Lemma alt_neg_opp :
 forall (u v : word) (b : bool),
 odd u -> alt b u -> odd v -> alt (negb b) v -> opposite u v.
Proof.
simple induction u.
intros v b odd_empty; absurd (odd empty); trivial.
intros b u' H v; elim v.
intros b' H1 H2 odd_empty.
absurd (odd empty); trivial.
intros b' v' H' b'' H1 H2 H3 H4.
elim (alt_eq (negb b'') b' v'); trivial.
elim (alt_eq b'' b u'); trivial.
Qed.

Lemma alt_not_opp :
 forall (u v : word) (b : bool), alt b u -> alt b v -> ~ opposite u v.
Proof.
simple induction u.
intros; apply not_opp_empty_l.
intros b u' H v; elim v.
intros; apply not_opp_empty_r.
intros b' v' H1 b'' H2 H3.
elim (alt_eq b'' b' v'); trivial.
elim (alt_eq b'' b u'); trivial.
apply not_opp_same.
Qed.


Require Export CoqRecon.Semantics.DeclTyping CoqRecon.Semantics.Reduce.

Section Canon.
  Variable v : term.

  Hypothesis Hv : value v.

  Lemma canon_abs : forall t t',
      ∅ ⊨ v ∴ t → t' -> exists x e, v = λ x ⇒ e.
  Proof.
    intros t t' Ht; inv Hv; inv Ht; eauto.
  Qed.

  Lemma canon_nat : ∅ ⊨ v ∴ TNat -> exists n : nat, v = n.
  Proof.
    intros Ht; inv Hv; inv Ht; eauto.
  Qed.

  Lemma canon_bool : ∅ ⊨ v ∴ TBool -> exists b : bool, v = b.
  Proof.
    intros Ht; inv Hv; inv Ht; eauto.
  Qed.
End Canon.

Section Progress.
  Local Hint Constructors value : core.
  Local Hint Constructors rd : core.

  Theorem prog : forall e t,
      ∅ ⊨ e ∴ t -> value e \/ exists e', e -->  e'.
  Proof.
    intro e;
      induction e as
        [ x
        | x e IHe
        | e1 IHe1 e2 IHe2
        | n | b
        | e1 IHe1 e2 IHe2 e3 IHe3
        | o e1 IHe1 e2 IHe2
        | x e1 IHe1 e2 IHe2 ];
      intros t Ht; inv Ht; simpl;
        repeat match goal with
               | H: op_typs _ _ _ |- _ => inv H
               | IH: (forall t, ?g ⊨ ?e ∴ t -> _), H : ?g ⊨ ?e ∴ ?t
                 |- _ => pose proof IH t H as [? | [? ?]]; clear IH
               | H: ∅ ⊨ ?v ∴ _ → _, Hv: value ?v
                 |- _ => pose proof canon_abs v Hv _ _ H as (? & ? & ?);
                         clear Hv; subst; simpl
               | H: ∅ ⊨ ?v ∴ TNat, Hv: value ?v
                 |- _ => pose proof canon_nat v Hv H as (? & ?);
                         clear Hv; subst; simpl
               | H: ∅ ⊨ ?v ∴ TBool, Hv: value ?v
                 |- _ => pose proof canon_bool v Hv H as (? & ?);
                         clear Hv; subst; simpl
               | H: bound _ _ ∅ |- _ => unfold bound, "∅" in H; discriminate
               | H: _ ⊨ Bool ?b ∴ TBool
                 |- context [Cond (Bool ?b) _ _ -->  _] => destruct b; clear H
               end; eauto.
  Qed.
End Progress.

Section Sub.
  Local Hint Constructors typing : core.
  Hint Rewrite (@bind_same string typ) : core.

  Lemma weakening : forall g e t,
      g ⊨ e ∴ t -> forall g', inclu g g' -> g' ⊨ e ∴ t.
  Proof.
    unfold inclu, bound;
      intros g e t Hget; induction Hget;
        intros g' HI; unfold bound in *;
          simpl in *; eauto.
    - constructor. firstorder.
    - constructor.
      apply IHHget; intuition.
      unfold bind in *; repeat dispatch_eqdec; auto.
    - econstructor; eauto.
      apply IHHget2; intuition.
      unfold bind in *; repeat dispatch_eqdec; auto.
  Qed.

  Lemma empty_ctx : forall e t,
      ∅ ⊨ e ∴ t -> forall g, g ⊨ e ∴ t.
  Proof.
    intros e t H g.
    apply weakening with (g' := g) in H; auto.
    unfold incl, bound, "∅". discriminate.
  Qed.

  Local Hint Resolve empty_ctx : core.

  Lemma sub_lemma : forall e e' t t' x g,
      (x ↦ t';; g) ⊨ e ∴ t -> ∅ ⊨ e' ∴ t' -> g ⊨ ⟦x:=e'⟧ e ∴ t.
  Proof.
    intro e;
      induction e as
        [ x
        | x e IHe
        | e1 IHe1 e2 IHe2
        | n | b
        | e1 IHe1 e2 IHe2 e3 IHe3
        | o e1 IHe1 e2 IHe2
        | x e1 IHe1 e2 IHe2 ];
      intros e' t t' y g He He'; inv He; simpl;
        unfold bound in *; eauto.
    - dispatch_eqdec.
      + rewrite bind_sound in H0; inv H0; auto.
      + rewrite bind_complete in H0; auto.
    - dispatch_eqdec; autorewrite with core in *; eauto.
      rewrite bind_diff_comm in H2 by auto; eauto.
    - dispatch_eqdec; autorewrite with core in *; eauto.
      rewrite bind_diff_comm in H4 by auto; eauto.
  Qed.
End Sub.

Section Preservation.
  Local Hint Constructors typing : core.
  Local Hint Constructors op_typs : core.
  Local Hint Resolve sub_lemma : core.

  Theorem preservation : forall e e',
      e -->  e' -> forall t, ∅ ⊨ e ∴ t -> ∅ ⊨ e' ∴ t.
  Proof.
    intros e e' Hee'; induction Hee'; intros t Ht; inv Ht;
      repeat match goal with
             | H: op_typs _ _ _ |- _ => inv H
             | H: _ ⊨ λ _ ⇒ _ ∴ _ |- _ => inv H
             | H: _ ⊨ Bool _ ∴ TNat |- _ => inv H
             | H: _ ⊨ Nat _ ∴ TBool |- _ => inv H
             end; eauto.
  Qed.
End Preservation.

Section EvalRd.
  Lemma eval_complete : forall e e',
    e -->  e' -> eval e = Some e'.
  Proof.
    intros e e' Hee'; induction Hee'; maybe_simpl; eauto.
    - rewrite IHHee'. destruct e1; eauto. inv Hee'.
    - rewrite IHHee'. destruct e1; eauto. inv Hee'.
    - rewrite IHHee'.
      destruct o; maybe_simpl; eauto;
        destruct e2; eauto; inv Hee'.
    - rewrite IHHee'.
      destruct o; maybe_simpl; eauto;
        destruct e2; eauto; inv Hee'.
    - rewrite IHHee'.
      destruct o; destruct e1;
        maybe_simpl; eauto;
          destruct e2; eauto; inv Hee'.
  Qed.

  Local Hint Constructors rd : core.

  Ltac unwind :=
    match goal with
    | H: match eval ?e with
         | Some _ => Some _
         | None   => None
         end = Some _ |- _ =>
      assert (exists e', eval e = Some e')
        by (destruct (eval e) as [? |] eqn:? ;
            try discriminate; eauto);
      match goal with
      | Hex: (exists e', eval ?e = Some e') |- _ =>
        destruct Hex as [? ?];
        match goal with
        | Heq: eval ?e = Some ?e' |- _ =>
          rewrite Heq in H
        end
      end
    end.

  Lemma eval_sound : forall e e',
      eval e = Some e' -> e -->  e'.
  Proof.
    intro e;
      induction e as
        [ x
        | x e IHe
        | e1 IHe1 e2 IHe2
        | n | b
        | e1 IHe1 e2 IHe2 e3 IHe3
        | o e1 IHe1 e2 IHe2
        | x e1 IHe1 e2 IHe2 ];
      intros e' Heval; simpl in *;
        maybe_simpl_hyp Heval; try discriminate.
    - destruct e1;
        maybe_simpl_hyp Heval;
        try discriminate;
        try unwind; inv Heval; eauto.
    - destruct e1;
        maybe_simpl_hyp Heval;
        try discriminate;
        try unwind; inv Heval; eauto.
      destruct b; inv H0; eauto.
    - destruct o; destruct e1;
        maybe_simpl_hyp Heval;
        try discriminate;
        try unwind; try (inv Heval; eauto; assumption);
          destruct e2; try discriminate;
            try unwind; inv Heval; eauto.
    - inv Heval; eauto.
  Qed.
End EvalRd.


Set Implicit Arguments.
Require Import TLC.LibTactics.
Require Import TLC.LibListSort.
Require Import TLC.LibListZ.
(* Load the CFML library, with time credits. *)
Require Import CFML.CFLibCredits.
Require Pervasives_ml.
Require Array_ml.
Require Import Pervasives_proof.
Require Import ArrayCredits_proof.
(* Load the big-O library. *)
Require Import Dominated.
Require Import UltimatelyGreater.
Require Import Monotonic.
Require Import LibZExtra.
Require Import DominatedNary.
Require Import LimitNary.
Require Import Generic.
(* Load the custom CFML tactics with support for big-Os *)
Require Import CFMLBigO.
(* Load the CF definitions. *)
Require Import Lcs_ml.

Inductive InL {A:Type} (y:A) : list A -> Prop :=
  | InHead : forall xs:list A, InL y (cons y xs)
  | InTail : forall (x:A) (xs:list A), InL y xs -> InL y (cons x xs).

Inductive SubSeq {A:Type} : list A -> list A -> Prop :=
 | SubNil : forall l:list A, SubSeq nil l
 | SubCons1 : forall (x:A) (l1 l2:list A), SubSeq l1 l2 -> SubSeq l1 (x::l2)
 | SubCons2 : forall (x:A) (l1 l2:list A), SubSeq l1 l2 -> SubSeq (x::l1) (x::l2).

Definition Lcs {A: Type} l l1 l2 :=
  SubSeq l l1 /\ SubSeq l l2 /\
  (forall l': list A, SubSeq l' l1 /\ SubSeq l' l2 -> length l' <= length l).

Ltac auto_tilde ::= try solve [ auto with maths | false; math ].

Definition ZZle (p1 p2 : Z * Z) :=
  let (x1, y1) := p1 in
  let (x2, y2) := p2 in
  1 <= x1 <= x2 /\ 0 <= y1 <= y2.

(* ATTENTION: INCOMPLETE, WON'T COMPILE, SHOULD BE COMMENTED OUT *)
Lemma lcs_spec:
  specO
    (product_filterType Z_filterType Z_filterType)
    ZZle
  ( fun cost =>
  forall (l1 l2 : list int) p1 p2,
  app lcs [p1 p2]
  PRE (\$(cost (LibListZ.length l1, LibListZ.length l2)) \*
  p1 ~> Array l1 \* p2 ~> Array l2)
  POST (fun p => Hexists (l : list int), p ~> Array l (*\* \[Lcs l l1 l2]*))
  )
  (fun '(n,m) => n * m).
Proof.
  xspecO_refine straight_line. xcf.
  xpay.  xapp~. intros. xapp~. intros. rewrite <- H. rewrite <- H0. xapp~. intros.
  xapp~. intros.
  xseq. weaken.
  xfor_inv (fun (i:int) =>
    Hexists (x0 : list (array (list int)))
    (x1 : list (list (list int))),
    p1 ~> Array l1 \* p2 ~> Array l2 \* c ~> Array x0 \* x0__ ~> Array x \*
    \[index x0 n /\ forall i1 : int, 0 <= i1 <= n -> index x1[i1] m /\
    (\[] ==> x0[i1] ~> Array x1[i1])]).
    3: {
  hsimpl_credits. split. rewrite H2. apply index_make.
  apply~ int_index_prove. intros. split. remember (make (n+1) x) as x0_.
  assert (index x0_[i1] m). rewrite Heqx0_. rewrite read_make.
  rewrite H1. apply index_make. apply~ int_index_prove. apply~ int_index_prove.
  rewrite Heqx0_ in H4. apply H4. rewrite read_make. rewrite H2. rewrite read_make.
  hsimpl. admit. apply~ int_index_prove. apply~ int_index_prove.
    }
  math. intros.
  {
    xpull. intros.
    xpay. weaken.
  xfor_inv (fun (i:int) =>
    Hexists (x0 : list (array (list int)))
    (x1 : list (list (list int))),
    p1 ~> Array l1 \* p2 ~> Array l2 \* c ~> Array x0 \* x0__ ~> Array x \*
    \[index x0 n /\ forall i1 : int, 0 <= i1 <= n -> index x1[i1] m /\
    (\[] ==> (x0[i1] ~> Array x1[i1]))]).
    math. intros. {
      xpull. intros. xpay. xapps~. apply~ int_index_prove.
      xapps~. apply~ int_index_prove. xret. intros. xif.
      {
        destruct H6 as [H6 H7].
        xapps~. apply~ int_index_prove.
        xapps~.
        rewrite index_eq_inbound in H6.
        apply~ int_index_prove. assert (H9 := H7).
        specialize (H7 (i-1)).
        destruct H7 as [H7 H8]. math.
        xapps~. Focus 2.
        xchange H8. hsimpl. rewrite index_eq_inbound in H7.
        apply~ int_index_prove. xret. intros. xapp~.
        rewrite index_eq_inbound in H6. apply~ int_index_prove.
        intros. xapp~. Focus 2. specialize (H9 i).
        destruct H9 as [H9 H99]. math. rewrite H11.
        xchange H99. hsimpl. specialize (H9 i).
        destruct H9 as [H9 H99]. math.
        rewrite index_eq_inbound in H9. apply~ int_index_prove.
        hsimpl. split; auto.
      }
      {
        destruct H6 as [H6 H7].
        xapps~. rewrite index_eq_inbound in H6. apply~ int_index_prove.
        xapps~. 2: {
          specialize (H7 i). destruct H7 as [H7 H8].
          math. xchange H8. hsimpl.
        }
        {
          specialize (H7 i). destruct H7 as [H7 H8].
          math. rewrite index_eq_inbound in H7.
          apply~ int_index_prove.
        }
        xret. intros. xapp~.
        rewrite index_eq_inbound in H6. apply~ int_index_prove.
        intros. xapp~.
        2: {rewrite H9.
          specialize (H7 (i-1)). destruct H7 as [H7 H10].
          math. xchange H10. hsimpl.
        } intros.
        { specialize (H7 (i-1)). destruct H7 as [H7 H10].
          math. rewrite index_eq_inbound in H7.
          apply~ int_index_prove.
        } intros. xret. intros. xif. {
          xapp~.
          rewrite index_eq_inbound in H6. apply~ int_index_prove.
          intros. xapp~. 2: {
            rewrite H12.
            specialize (H7 (i-1)). destruct H7 as [_ H7].
            math. xchange H7. hsimpl.
          }
          {
            specialize (H7 (i-1)). destruct H7 as [H7 _]. math.
            rewrite index_eq_inbound in H7. apply~ int_index_prove.
          }
          intros. xapp~.
          rewrite index_eq_inbound in H6. apply~ int_index_prove.
          intros. xapp~. 2: {
            rewrite H14. hsimpl.
          }
          {
            specialize (H7 i). destruct H7 as [H7 _]. math.
            rewrite index_eq_inbound in H7. apply~ int_index_prove.
          }
          hsimpl. split; auto.
        }
        xapp~.
        rewrite index_eq_inbound in H6. apply~ int_index_prove.
        intros. xapp~. 2: {
          rewrite H12. hsimpl.
        }
        {
          specialize (H7 i). destruct H7 as [H7 _]. math.
          rewrite index_eq_inbound in H7. apply~ int_index_prove.
        }
        intros. xapp~.
        rewrite index_eq_inbound in H6. apply~ int_index_prove.
        intros. xapp~. 2: {
          rewrite H12. rewrite H14. hsimpl.
        }
        {
          specialize (H7 i). destruct H7 as [H7 _]. math.
          rewrite index_eq_inbound in H7. apply~ int_index_prove.
        }
        hsimpl. split; auto.
      }
    }
    hsimpl. split; auto. destruct H4 as [H4 _]. assumption.
    apply H4. hsimpl. apply H6.
    (* match goal with |- cumul _ _ (fun _ => ?x) <= _ => ring_simplify x end.  *)
    reflexivity.
  }
  reflexivity.
  (* xpull. hsimpl_credits. split. rewrite H2. apply index_make.
  apply~ int_index_prove. intros. split. admit. admit.
  match goal with |- cumul _ _ (fun _ => ?x) <= _ => ring_simplify x end.
  rewrite H. rewrite H0.
  sets n1: (length l1). sets m1: (length l2). reflexivity.  *)
  xpull. intros. xapp~. destruct H3 as [H3 H4]. assumption.
  intros. xapp~. 2: {
    destruct H3 as [H3 H5]. specialize (H5 n).
    destruct H5. math. rewrite H4. xchange H6. hsimpl.
  }
  {
    destruct H3 as [H3 H5]. specialize (H5 n).
    apply H5. math.
  }
  intros. xapp~.
  cleanup_cost.
  { equates 1; swap 1 2.
    { instantiate (1 := (fun '(x, y) => _)). apply fun_ext_1. intros [x y].
      rewrite !cumul_const'. rew_cost. reflexivity. }
    intros [x1 y1] [x2 y2] [H1 H2]. math_nia. }

  apply_nary dominated_sum_distr_nary; swap 1 2.
  dominated.

  apply_nary dominated_sum_distr_nary.
  { apply_nary dominated_sum_distr_nary.
    { apply dominated_transitive with (fun '(x, y) => 1 * y).
      - (* TODO: improve using some setoid rewrite instances? *)
        apply dominated_eq. intros [? ?]. math.
      - apply_nary dominated_mul_nary; dominated.
    }
    { apply dominated_transitive with (fun '(x, y) => x * 1).
      - (* TODO: improve using some setoid rewrite instances? *)
        apply dominated_eq. intros [? ?]. math.
      - apply_nary dominated_mul_nary; dominated.
    }
  }
  { eapply dominated_transitive.
    apply dominated_product_swap.
    apply Product.dominated_big_sum_bound_with.
    { apply filter_universe_alt. intros. rewrite~ <-cumul_nonneg. math_lia. }
    { monotonic. }
    { limit.  }
    simpl. dominated.

    now repeat apply_nary dominated_sum_distr_nary; dominated.
    repeat apply_nary dominated_sum_distr_nary; dominated.
    etransitivity. apply Product.dominated_big_sum_bound_with.
    intros. apply filter_universe_alt. math_lia.
    monotonic. limit. dominated. apply_nary dominated_sum_distr_nary; dominated.
Admitted.