(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat.
From mathcomp Require Import seq choice fintype.

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

(******************************************************************************)
(* Tuples, i.e., sequences with a fixed (known) length. We define:            *)
(*         n.-tuple T == the type of n-tuples of elements of type T.          *)
(*       [tuple of s] == the tuple whose underlying sequence (value) is s.    *)
(*                       The size of s must be known: specifically, Coq must  *)
(*                       be able to infer a Canonical tuple projecting on s.  *)
(*         in_tuple s == the (size s)-tuple with value s.                     *)
(*            [tuple] == the empty tuple.                                     *)
(* [tuple x1; ..; xn] == the explicit n.-tuple <x1; ..; xn>.                  *)
(*  [tuple E | i < n] == the n.-tuple with general term E (i : 'I_n is bound  *)
(*                       in E).                                               *)
(*        tcast Emn t == the m-tuple t cast as an n-tuple using Emn : m = n.  *)
(* As n.-tuple T coerces to seq t, all seq operations (size, nth, ...) can be *)
(* applied to t : n.-tuple T; we provide a few specialized instances when     *)
(* avoids the need for a default value.                                       *)
(*            tsize t == the size of t (the n in n.-tuple T)                  *)
(*           tnth t i == the i'th component of t, where i : 'I_n.             *)
(*         [tnth t i] == the i'th component of t, where i : nat and i < n     *)
(*                       is convertible to true.                              *)
(*            thead t == the first element of t, when n is m.+1 for some m.   *)
(* Most seq constructors (cons, behead, cat, rcons, belast, take, drop, rot,  *)
(* map, ...) can be used to build tuples via the [tuple of s] construct.      *)
(*   Tuples are actually a subType of seq, and inherit all combinatorial      *)
(* structures, including the finType structure.                               *)
(*   Some useful lemmas and definitions:                                      *)
(*     tuple0 : [tuple] is the only 0.-tuple                                  *)
(*     tupleP : elimination view for n.+1.-tuple                              *)
(*     ord_tuple n : the n.-tuple of all i : 'I_n                             *)
(******************************************************************************)

Section Def.

Variables (n : nat) (T : Type).

Structure tuple_of : Type := Tuple {tval :> seq T; _ : size tval == n}.

Canonical tuple_subType := Eval hnf in [subType for tval].

Implicit Type t : tuple_of.

Definition tsize of tuple_of := n.

Lemma size_tuple t : size t = n.
Proof. exact: (eqP (valP t)). Qed.

Lemma tnth_default t : 'I_n -> T.
Proof. by rewrite -(size_tuple t); case: (tval t) => [|//] []. Qed.

Definition tnth t i := nth (tnth_default t i) t i.

Lemma tnth_nth x t i : tnth t i = nth x t i.
Proof. by apply: set_nth_default; rewrite size_tuple. Qed.

Lemma map_tnth_enum t : map (tnth t) (enum 'I_n) = t.
Proof.
case def_t: {-}(val t) => [|x0 t'].
  by rewrite [enum _]size0nil // -cardE card_ord -(size_tuple t) def_t.
apply: (@eq_from_nth _ x0) => [|i]; rewrite size_map.
  by rewrite -cardE size_tuple card_ord.
move=> lt_i_e; have lt_i_n: i < n by rewrite -cardE card_ord in lt_i_e.
by rewrite (nth_map (Ordinal lt_i_n)) // (tnth_nth x0) nth_enum_ord.
Qed.

Lemma eq_from_tnth t1 t2 : tnth t1 =1 tnth t2 -> t1 = t2.
Proof.
by move/eq_map=> eq_t; apply: val_inj; rewrite /= -!map_tnth_enum eq_t.
Qed.

Definition tuple t mkT : tuple_of :=
  mkT (let: Tuple _ tP := t return size t == n in tP).

Lemma tupleE t : tuple (fun sP => @Tuple t sP) = t.
Proof. by case: t. Qed.

End Def.

Notation "n .-tuple" := (tuple_of n)
  (at level 2, format "n .-tuple") : type_scope.

Notation "{ 'tuple' n 'of' T }" := (n.-tuple T : predArgType)
  (at level 0, only parsing) : form_scope.

Notation "[ 'tuple' 'of' s ]" := (tuple (fun sP => @Tuple _ _ s sP))
  (at level 0, format "[ 'tuple'  'of'  s ]") : form_scope.

Notation "[ 'tnth' t i ]" := (tnth t (@Ordinal (tsize t) i (erefl true)))
  (at level 0, t, i at level 8, format "[ 'tnth'  t  i ]") : form_scope.

Canonical nil_tuple T := Tuple (isT : @size T [::] == 0).
Canonical cons_tuple n T x (t : n.-tuple T) :=
  Tuple (valP t : size (x :: t) == n.+1).

Notation "[ 'tuple' x1 ; .. ; xn ]" := [tuple of x1 :: .. [:: xn] ..]
  (at level 0, format "[ 'tuple' '['  x1 ; '/'  .. ; '/'  xn ']' ]")
  : form_scope.

Notation "[ 'tuple' ]" := [tuple of [::]]
  (at level 0, format "[ 'tuple' ]") : form_scope.

Section CastTuple.

Variable T : Type.

Definition in_tuple (s : seq T) := Tuple (eqxx (size s)).

Definition tcast m n (eq_mn : m = n) t :=
  let: erefl in _ = n := eq_mn return n.-tuple T in t.

Lemma tcastE m n (eq_mn : m = n) t i :
  tnth (tcast eq_mn t) i = tnth t (cast_ord (esym eq_mn) i).
Proof. by case: n / eq_mn in i *; rewrite cast_ord_id. Qed.

Lemma tcast_id n (eq_nn : n = n) t : tcast eq_nn t = t.
Proof. by rewrite (eq_axiomK eq_nn). Qed.

Lemma tcastK m n (eq_mn : m = n) : cancel (tcast eq_mn) (tcast (esym eq_mn)).
Proof. by case: n / eq_mn. Qed.

Lemma tcastKV m n (eq_mn : m = n) : cancel (tcast (esym eq_mn)) (tcast eq_mn).
Proof. by case: n / eq_mn. Qed.

Lemma tcast_trans m n p (eq_mn : m = n) (eq_np : n = p) t:
  tcast (etrans eq_mn eq_np) t = tcast eq_np (tcast eq_mn t).
Proof. by case: n / eq_mn eq_np; case: p /. Qed.

Lemma tvalK n (t : n.-tuple T) : in_tuple t = tcast (esym (size_tuple t)) t.
Proof. by apply: val_inj => /=; case: _ / (esym _). Qed.

Lemma in_tupleE s : in_tuple s = s :> seq T. Proof. by []. Qed.

End CastTuple.

Section SeqTuple.

Variables (n m : nat) (T U rT : Type).
Implicit Type t : n.-tuple T.

Lemma rcons_tupleP t x : size (rcons t x) == n.+1.
Proof. by rewrite size_rcons size_tuple. Qed.
Canonical rcons_tuple t x := Tuple (rcons_tupleP t x).

Lemma nseq_tupleP x : @size T (nseq n x) == n.
Proof. by rewrite size_nseq. Qed.
Canonical nseq_tuple x := Tuple (nseq_tupleP x).

Lemma iota_tupleP : size (iota m n) == n.
Proof. by rewrite size_iota. Qed.
Canonical iota_tuple := Tuple iota_tupleP.

Lemma behead_tupleP t : size (behead t) == n.-1.
Proof. by rewrite size_behead size_tuple. Qed.
Canonical behead_tuple t := Tuple (behead_tupleP t).

Lemma belast_tupleP x t : size (belast x t) == n.
Proof. by rewrite size_belast size_tuple. Qed.
Canonical belast_tuple x t := Tuple (belast_tupleP x t).

Lemma cat_tupleP t (u : m.-tuple T) : size (t ++ u) == n + m.
Proof. by rewrite size_cat !size_tuple. Qed.
Canonical cat_tuple t u := Tuple (cat_tupleP t u).

Lemma take_tupleP t : size (take m t) == minn m n.
Proof. by rewrite size_take size_tuple eqxx. Qed.
Canonical take_tuple t := Tuple (take_tupleP t).

Lemma drop_tupleP t : size (drop m t) == n - m.
Proof. by rewrite size_drop size_tuple. Qed.
Canonical drop_tuple t := Tuple (drop_tupleP t).

Lemma rev_tupleP t : size (rev t) == n.
Proof. by rewrite size_rev size_tuple. Qed.
Canonical rev_tuple t := Tuple (rev_tupleP t).

Lemma rot_tupleP t : size (rot m t) == n.
Proof. by rewrite size_rot size_tuple. Qed.
Canonical rot_tuple t := Tuple (rot_tupleP t).

Lemma rotr_tupleP t : size (rotr m t) == n.
Proof. by rewrite size_rotr size_tuple. Qed.
Canonical rotr_tuple t := Tuple (rotr_tupleP t).

Lemma map_tupleP f t : @size rT (map f t) == n.
Proof. by rewrite size_map size_tuple. Qed.
Canonical map_tuple f t := Tuple (map_tupleP f t).

Lemma scanl_tupleP f x t : @size rT (scanl f x t) == n.
Proof. by rewrite size_scanl size_tuple. Qed.
Canonical scanl_tuple f x t := Tuple (scanl_tupleP f x t).

Lemma pairmap_tupleP f x t : @size rT (pairmap f x t) == n.
Proof. by rewrite size_pairmap size_tuple. Qed.
Canonical pairmap_tuple f x t := Tuple (pairmap_tupleP f x t).

Lemma zip_tupleP t (u : n.-tuple U) : size (zip t u) == n.
Proof. by rewrite size1_zip !size_tuple. Qed.
Canonical zip_tuple t u := Tuple (zip_tupleP t u).

Lemma allpairs_tupleP f t (u : m.-tuple U) : @size rT (allpairs f t u) == n * m.
Proof. by rewrite size_allpairs !size_tuple. Qed.
Canonical allpairs_tuple f t u := Tuple (allpairs_tupleP f t u).

Definition thead (u : n.+1.-tuple T) := tnth u ord0.

Lemma tnth0 x t : tnth [tuple of x :: t] ord0 = x.
Proof. by []. Qed.

Lemma theadE x t : thead [tuple of x :: t] = x.
Proof. by []. Qed.

Lemma tuple0 : all_equal_to ([tuple] : 0.-tuple T).
Proof. by move=> t; apply: val_inj; case: t => [[]]. Qed.

Variant tuple1_spec : n.+1.-tuple T -> Type :=
  Tuple1spec x t : tuple1_spec [tuple of x :: t].

Lemma tupleP u : tuple1_spec u.
Proof.
case: u => [[|x s] //= sz_s]; pose t := @Tuple n _ s sz_s.
by rewrite (_ : Tuple _ = [tuple of x :: t]) //; apply: val_inj.
Qed.

Lemma tnth_map f t i : tnth [tuple of map f t] i = f (tnth t i) :> rT.
Proof. by apply: nth_map; rewrite size_tuple. Qed.

End SeqTuple.

Lemma tnth_behead n T (t : n.+1.-tuple T) i :
  tnth [tuple of behead t] i = tnth t (inord i.+1).
Proof. by case/tupleP: t => x t; rewrite !(tnth_nth x) inordK ?ltnS. Qed.

Lemma tuple_eta n T (t : n.+1.-tuple T) : t = [tuple of thead t :: behead t].
Proof. by case/tupleP: t => x t; apply: val_inj. Qed.

Section TupleQuantifiers.

Variables (n : nat) (T : Type).
Implicit Types (a : pred T) (t : n.-tuple T).

Lemma forallb_tnth a t : [forall i, a (tnth t i)] = all a t.
Proof.
apply: negb_inj; rewrite -has_predC -has_map negb_forall.
apply/existsP/(has_nthP true) => [[i a_t_i] | [i lt_i_n a_t_i]].
  by exists i; rewrite ?size_tuple // -tnth_nth tnth_map.
rewrite size_tuple in lt_i_n; exists (Ordinal lt_i_n).
by rewrite -tnth_map (tnth_nth true).
Qed.

Lemma existsb_tnth a t : [exists i, a (tnth t i)] = has a t.
Proof. by apply: negb_inj; rewrite negb_exists -all_predC -forallb_tnth. Qed.

Lemma all_tnthP a t : reflect (forall i, a (tnth t i)) (all a t).
Proof. by rewrite -forallb_tnth; apply: forallP. Qed.

Lemma has_tnthP a t : reflect (exists i, a (tnth t i)) (has a t).
Proof. by rewrite -existsb_tnth; apply: existsP. Qed.

End TupleQuantifiers.

Arguments all_tnthP {n T a t}.
Arguments has_tnthP {n T a t}.

Section EqTuple.

Variables (n : nat) (T : eqType).

Definition tuple_eqMixin := Eval hnf in [eqMixin of n.-tuple T by <:].
Canonical tuple_eqType := Eval hnf in EqType (n.-tuple T) tuple_eqMixin.

Canonical tuple_predType := PredType (pred_of_seq : n.-tuple T -> pred T).

Lemma memtE (t : n.-tuple T) : mem t = mem (tval t).
Proof. by []. Qed.

Lemma mem_tnth i (t : n.-tuple T) : tnth t i \in t.
Proof. by rewrite mem_nth ?size_tuple. Qed.

Lemma memt_nth x0 (t : n.-tuple T) i : i < n -> nth x0 t i \in t.
Proof. by move=> i_lt_n; rewrite mem_nth ?size_tuple. Qed.

Lemma tnthP (t : n.-tuple T) x : reflect (exists i, x = tnth t i) (x \in t).
Proof.
apply: (iffP idP) => [/(nthP x)[i ltin <-] | [i ->]]; last exact: mem_tnth.
by rewrite size_tuple in ltin; exists (Ordinal ltin); rewrite (tnth_nth x).
Qed.

Lemma seq_tnthP (s : seq T) x : x \in s -> {i | x = tnth (in_tuple s) i}.
Proof.
move=> s_x; pose i := index x s; have lt_i: i < size s by rewrite index_mem.
by exists (Ordinal lt_i); rewrite (tnth_nth x) nth_index.
Qed.

End EqTuple.

Definition tuple_choiceMixin n (T : choiceType) :=
  [choiceMixin of n.-tuple T by <:].

Canonical tuple_choiceType n (T : choiceType) :=
  Eval hnf in ChoiceType (n.-tuple T) (tuple_choiceMixin n T).

Definition tuple_countMixin n (T : countType) :=
  [countMixin of n.-tuple T by <:].

Canonical tuple_countType n (T : countType) :=
  Eval hnf in CountType (n.-tuple T) (tuple_countMixin n T).

Canonical tuple_subCountType n (T : countType) :=
  Eval hnf in [subCountType of n.-tuple T].

Module Type FinTupleSig.
Section FinTupleSig.
Variables (n : nat) (T : finType).
Parameter enum : seq (n.-tuple T).
Axiom enumP : Finite.axiom enum.
Axiom size_enum : size enum = #|T| ^ n.
End FinTupleSig.
End FinTupleSig.

Module FinTuple : FinTupleSig.
Section FinTuple.
Variables (n : nat) (T : finType).

Definition enum : seq (n.-tuple T) :=
  let extend e := flatten (codom (fun x => map (cons x) e)) in
  pmap insub (iter n extend [::[::]]).

Lemma enumP : Finite.axiom enum.
Proof.
case=> /= t t_n; rewrite -(count_map _ (pred1 t)) (pmap_filter (insubK _)).
rewrite count_filter -(@eq_count _ (pred1 t)) => [|s /=]; last first.
  by rewrite isSome_insub; case: eqP=> // ->.
elim: n t t_n => [|m IHm] [|x t] //= {IHm}/IHm; move: (iter m _ _) => em IHm.
transitivity (x \in T : nat); rewrite // -mem_enum codomE.
elim: (fintype.enum T)  (enum_uniq T) => //= y e IHe /andP[/negPf ney].
rewrite count_cat count_map inE /preim /= {1}/eq_op /= eq_sym => /IHe->.
by case: eqP => [->|_]; rewrite ?(ney, count_pred0, IHm).
Qed.

Lemma size_enum : size enum = #|T| ^ n.
Proof.
rewrite /= cardE size_pmap_sub; elim: n => //= m IHm.
rewrite expnS /codom /image_mem; elim: {2 3}(fintype.enum T) => //= x e IHe.
by rewrite count_cat {}IHe count_map IHm.
Qed.

End FinTuple.
End FinTuple.

Section UseFinTuple.

Variables (n : nat) (T : finType).

(* tuple_finMixin could, in principle, be made Canonical to allow for folding *)
(* Finite.enum of a finite tuple type (see comments around eqE in eqtype.v),  *)
(* but in practice it will not work because the mixin_enum projector          *)
(* has been burried under an opaque alias, to avoid some performance issues   *)
(* during type inference.                                                     *)
Definition tuple_finMixin := Eval hnf in FinMixin (@FinTuple.enumP n T).
Canonical tuple_finType := Eval hnf in FinType (n.-tuple T) tuple_finMixin.
Canonical tuple_subFinType := Eval hnf in [subFinType of n.-tuple T].

Lemma card_tuple : #|{:n.-tuple T}| = #|T| ^ n.
Proof. by rewrite [#|_|]cardT enumT unlock FinTuple.size_enum. Qed.

Lemma enum_tupleP (A : {pred T}) : size (enum A) == #|A|.
Proof. by rewrite -cardE. Qed.
Canonical enum_tuple A := Tuple (enum_tupleP A).

Definition ord_tuple : n.-tuple 'I_n := Tuple (introT eqP (size_enum_ord n)).
Lemma val_ord_tuple : val ord_tuple = enum 'I_n. Proof. by []. Qed.

Lemma tuple_map_ord U (t : n.-tuple U) : t = [tuple of map (tnth t) ord_tuple].
Proof. by apply: val_inj => /=; rewrite map_tnth_enum. Qed.

Lemma tnth_ord_tuple i : tnth ord_tuple i = i.
Proof.
apply: val_inj; rewrite (tnth_nth i) -(nth_map _ 0) ?size_tuple //.
by rewrite /= enumT unlock val_ord_enum nth_iota.
Qed.

Section ImageTuple.

Variables (T' : Type) (f : T -> T') (A : {pred T}).

Canonical image_tuple : #|A|.-tuple T' := [tuple of image f A].
Canonical codom_tuple : #|T|.-tuple T' := [tuple of codom f].

End ImageTuple.

Section MkTuple.

Variables (T' : Type) (f : 'I_n -> T').

Definition mktuple := map_tuple f ord_tuple.

Lemma tnth_mktuple i : tnth mktuple i = f i.
Proof. by rewrite tnth_map tnth_ord_tuple. Qed.

Lemma nth_mktuple x0 (i : 'I_n) : nth x0 mktuple i = f i.
Proof. by rewrite -tnth_nth tnth_mktuple. Qed.

End MkTuple.

Lemma eq_mktuple T' (f1 f2 : 'I_n -> T') :
  f1 =1 f2 -> mktuple f1 = mktuple f2.
Proof. by move=> eq_f; apply eq_from_tnth=> i; rewrite !tnth_map eq_f. Qed.

End UseFinTuple.

Notation "[ 'tuple' F | i < n ]" := (mktuple (fun i : 'I_n => F))
  (at level 0, i at level 0,
   format "[ '[hv' 'tuple'  F '/'   |  i  <  n ] ']'") : form_scope.

Arguments eq_mktuple {n T'} [f1] f2 eq_f12.


(** Some results on association lists *)

(* see https://www.cis.upenn.edu/~plclub/metalib/current/html/AssocList.html
   and https://caml.inria.fr/pub/docs/manual-ocaml/libref/List.html#1_Associationlists
   for more global approaches *)

From Coq Require Import Bool.
From Coq Require Export List.
From OLlibs Require Export dectype.

Set Implicit Arguments.
Set Default Proof Using "Type".

(** [remove_assoc] *)

Section RemoveAssoc.

  Variable T1 : DecType.
  Variable T2 : Type.
  Variable x : T1.
  Implicit Type L : list (T1 * T2).

  Definition remove_assoc L := filter (fun '(y, _) => negb (eqb x y)) L.

  Lemma remove_assoc_remove L :
    remove eq_dt_dec x (map fst L) = map fst (remove_assoc L).
  Proof.
  induction L as [|a L IHL]; simpl; [ reflexivity | rewrite IHL ]; destruct a; simpl.
  repeat case_analysis; intuition.
  exfalso; intuition.
  Qed.

  Lemma remove_assoc_notin L y a:
    x <> y -> In (y, a) L -> In (y, a) (remove_assoc L).
  Proof.
  intros; apply filter_In; split; auto.
  now apply negb_true_iff, eqb_neq.
  Qed.

  Lemma snd_remove_assoc L :
    incl (map snd (remove_assoc L)) (map snd L).
  Proof. apply incl_map, incl_filter. Qed.

  Lemma NoDup_remove_assoc_snd L :
    NoDup (map snd L) -> NoDup (map snd (remove_assoc L)).
  Proof.
  induction L as [|a L IHL]; simpl; intros Hnd; [ constructor | destruct a ].
  inversion_clear Hnd as [| ? ? Hnin Hnd2 ].
  case_analysis; intuition.
  constructor; try intros Hin; intuition.
  apply snd_remove_assoc in Hin.
  now apply Hnin.
  Qed.

  Lemma NoDup_remove_assoc_in L y i :
    NoDup (map snd L) -> In (y, i) L -> In i (map snd (remove_assoc L)) ->
    In (y, i) (remove_assoc L).
  Proof.
  intros Hnd Hin1 Hin2.
  apply remove_assoc_notin; [ | apply snd_remove_assoc in Hin2; intuition ].
  intros Heq; symmetry in Heq; subst.
  revert Hnd Hin1 Hin2; clear; induction L as [|(t1, t2) L IHL]; simpl; [ intuition | ].
  intros Hnd Hin1; inversion Hnd as [| ? ? Hnin Hnd2]; case_analysis; intros Hin2.
  - symmetry in Heq; subst.
    apply IHL; intuition.
    exfalso; inversion H; subst.
    apply Hnin.
    now apply snd_remove_assoc in Hin2.
  - destruct Hin2 as [ Heq' | Hin2 ]; subst.
    + destruct Hin1 as [ Hin1 | Hin1 ].
      * inversion Hin1; subst; intuition.
      * apply Hnin; now apply in_map with (f:= snd) in Hin1.
    + apply IHL in Hin2; destruct Hin1 as [Heq'|Hin1]; intuition.
      exfalso; apply Heq; now inversion Heq'.
  Qed.

End RemoveAssoc.

Arguments remove_assoc {_ _} _ _.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal30.

Set Printing Depth 1000.
Definition lfind_eval  l1:=
rev l1.

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero (Cons Zero Nil))).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ (Succ Zero))) (Cons (Succ (Succ (Succ Zero))) Nil))).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil)))).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero Nil)).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons (Succ Zero) Nil))).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)).

Compute lfind_eval  (Nil).


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2009-03-19 (setoid)
- Adam Koprowski, 2007-04-14

Semi-ring structure.
*)

From Coq Require Export Ring Ring_theory.
From Coq Require Import Relations Max Arith Compare Bool Setoid Morphisms.
From CoLoR Require Import RelDec LogicUtil RelExtras EqUtil NatUtil ZUtil.

(***********************************************************************)
(** Semi-ring structure type *)

Module Type SemiRingType.

  Declare Module Export ES : Eqset_dec.

  Parameters A0 A1 : A.

  Parameter Aplus : A -> A -> A.
  Notation "x + y" := (Aplus x y).

  Global Declare Instance Aplus_mor : Proper (eqA ==> eqA ==> eqA) Aplus.

  Parameter Amult : A -> A -> A.
  Notation "x * y" := (Amult x y).

  Global Declare Instance Amult_mor : Proper (eqA ==> eqA ==> eqA) Amult.

  Parameter A_semi_ring : semi_ring_theory A0 A1 Aplus Amult eqA.

End SemiRingType.

(***********************************************************************)
(** Some derived results about the semi-ring structure *)

Module SemiRing (SR : SemiRingType).

  Export SR.

  Definition Aplus_comm := SRadd_comm A_semi_ring.
  Definition Aplus_assoc := SRadd_assoc A_semi_ring.
  Definition Aplus_0_l := SRadd_0_l A_semi_ring.
  Definition Amult_comm := SRmul_comm A_semi_ring.
  Definition Amult_assoc := SRmul_assoc A_semi_ring.
  Definition Amult_0_l := SRmul_0_l A_semi_ring.
  Definition Amult_1_l := SRmul_1_l A_semi_ring.
  Definition A_plus_mult_distr_l := SRdistr_l A_semi_ring.

  Lemma Aplus_0_r n : n + A0 =A= n.

  Proof. rewrite Aplus_comm. apply Aplus_0_l. Qed.

  Lemma Amult_0_r n : n * A0 =A= A0.

  Proof. rewrite Amult_comm. apply Amult_0_l. Qed.

  Lemma Amult_1_r n : n * A1 =A= n.

  Proof. rewrite Amult_comm. apply Amult_1_l. Qed.

  Lemma A_plus_mult_distr_r m n p : m * (n + p) =A= m * n + m * p.

  Proof.
    rewrite Amult_comm, (Amult_comm m n), (Amult_comm m p).
    apply A_plus_mult_distr_l.
  Qed.

  Global Hint Rewrite Aplus_0_l Aplus_0_r Amult_0_l Amult_0_r
    Amult_1_l Amult_1_r : arith.

  Add Ring Aring : A_semi_ring.

End SemiRing.

(***********************************************************************)
(** Natural numbers as a semi-ring *)

Module Nat <: SetA.
  Definition A := nat.
End Nat.

Module Nat_Eqset := Eqset_def Nat.

Module Nat_Eqset_dec <: Eqset_dec.
  Module Export Eq := Nat_Eqset.
  Definition eqA_dec := dec_beq beq_nat_ok.
End Nat_Eqset_dec.

Module NSemiRingT <: SemiRingType.

  Module Export ES := Nat_Eqset_dec.

  Definition A0 := 0.
  Definition A1 := 1.

  Definition Aplus := plus.

  Global Instance Aplus_mor : Proper (eqA ==> eqA ==> eqA) Aplus.

  Proof. intros a b ab c d cd. rewrite ab, cd. refl. Qed.

  Definition Amult := mult.

  Global Instance Amult_mor : Proper (eqA ==> eqA ==> eqA) Amult.

  Proof. intros a b ab c d cd. rewrite ab, cd. refl. Qed.

  Definition A_semi_ring := natSRth.

End NSemiRingT.

Module NSemiRing := SemiRing NSemiRingT.

(***********************************************************************)
(** BigN natural numbers as a semi-ring *)

From Bignums Require Import BigN.

Module BigNat_Eqset <: Eqset.
  Definition A := bigN.
  Definition eqA := BigN.eq.
  Global Instance eqA_Equivalence : Equivalence eqA.
  Proof.
    unfold eqA. constructor.
    unfold Reflexive. refl.
    unfold Symmetric. hyp.
    unfold Transitive. intros. trans y; hyp.
  Qed.
End BigNat_Eqset.

Module BigNat_Eqset_dec <: Eqset_dec.
  Module Export Eq := BigNat_Eqset.
  Lemma eqA_dec : forall x y, {eqA x y}+{~eqA x y}.
  Proof.
    unfold eqA. unfold BigN.eq. intros. apply (dec_beq beq_Z_ok).
  Defined.
End BigNat_Eqset_dec.

Module BigNSemiRingT <: SemiRingType.

  Module Export ES := BigNat_Eqset_dec.

  Definition A0 := BigN.zero.
  Definition A1 := BigN.one.

  Definition Aplus := BigN.add.

  Global Instance Aplus_mor : Proper (eqA ==> eqA ==> eqA) Aplus.

  Proof. intros a b ab c d cd. rewrite ab, cd. refl. Qed.

  Definition Amult := BigN.mul.

  Global Instance Amult_mor : Proper (eqA ==> eqA ==> eqA) Amult.

  Proof. intros a b ab c d cd. rewrite ab, cd. refl. Qed.

  Definition A_semi_ring := BigNring.

End BigNSemiRingT.

Module BigNSemiRing := SemiRing BigNSemiRingT.

(***********************************************************************)
(** Integers as a semi-ring *)

From Coq Require Import ZArith.

Module Int <: SetA.
  Definition A := Z.
End Int.

Module Int_Eqset := Eqset_def Int.

Module Int_Eqset_dec <: Eqset_dec.
  Module Export Eq := Int_Eqset.
  Definition eqA_dec := dec_beq beq_Z_ok.
End Int_Eqset_dec.

Module ZSemiRingT <: SemiRingType.

  Module Export ES := Int_Eqset_dec.

  Definition A0 := 0%Z.
  Definition A1 := 1%Z.

  Definition Aplus := Zplus.

  Global Instance Aplus_mor : Proper (eqA ==> eqA ==> eqA) Aplus.

  Proof. intros a b ab c d cd. rewrite ab, cd. refl. Qed.

  Definition Amult := Zmult.

  Global Instance Amult_mor : Proper (eqA ==> eqA ==> eqA) Amult.

  Proof. intros a b ab c d cd. rewrite ab, cd. refl. Qed.

  Lemma A_semi_ring : semi_ring_theory A0 A1 Aplus Amult eqA.

  Proof.
    constructor.
    exact Zplus_0_l.
    exact Zplus_comm.
    exact Zplus_assoc.
    exact Zmult_1_l.
    exact Zmult_0_l.
    exact Zmult_comm.
    exact Zmult_assoc.
    exact Zmult_plus_distr_l.
  Qed.

End ZSemiRingT.

Module ZSemiRing := SemiRing ZSemiRingT.

(***********************************************************************)
(** BigZ integers as a semi-ring *)

From Bignums Require Import BigZ.

Module BigInt_Eqset <: Eqset.
  Definition A := bigZ.
  Definition eqA := BigZ.eq.
  Global Instance eqA_Equivalence : Equivalence eqA.
  Proof.
    unfold eqA. constructor.
    unfold Reflexive. refl.
    unfold Symmetric. hyp.
    unfold Transitive. intros. trans y; hyp.
  Qed.
End BigInt_Eqset.

Module BigInt_Eqset_dec <: Eqset_dec.
  Module Export Eq := BigInt_Eqset.
  Lemma eqA_dec : forall x y, {eqA x y}+{~eqA x y}.
  Proof.
    unfold eqA. unfold BigZ.eq. intros. apply (dec_beq beq_Z_ok).
  Defined.
End BigInt_Eqset_dec.

Module BigZSemiRingT <: SemiRingType.

  Module Export ES := BigInt_Eqset_dec.

  Definition A0 := BigZ.zero.
  Definition A1 := BigZ.one.

  Definition Aplus := BigZ.add.

  Global Instance Aplus_mor : Proper (eqA ==> eqA ==> eqA) Aplus.

  Proof. intros a b ab c d cd. rewrite ab, cd. refl. Qed.

  Definition Amult := BigZ.mul.

  Global Instance Amult_mor : Proper (eqA ==> eqA ==> eqA) Amult.

  Proof. intros a b ab c d cd. rewrite ab, cd. refl. Qed.

  Lemma A_semi_ring : semi_ring_theory A0 A1 Aplus Amult eqA.

  Proof.
    constructor.
    exact (Radd_0_l BigZring).
    exact (Radd_comm BigZring).
    exact (Radd_assoc BigZring).
    exact (Rmul_1_l BigZring).
    exact BigZ.mul_0_l.
    exact (Rmul_comm BigZring).
    exact (Rmul_assoc BigZring).
    exact BigZ.mul_add_distr_r.
  Qed.

End BigZSemiRingT.

Module BigZSemiRing := SemiRing BigZSemiRingT.

(***********************************************************************)
(** Arctic semi-ring over naturals with minus infinity and
    plus-max operations *)

Inductive ArcticDom : Type :=
| Pos (n : nat)
| MinusInf.

Definition beq_ArcticDom x y :=
  match x, y with
    | Pos x', Pos y' => beq_nat x' y'
    | MinusInf, MinusInf => true
    | _, _ => false
  end.

Lemma beq_ArcticDom_ok : forall x y, beq_ArcticDom x y = true <-> x = y.

Proof.
unfold beq_ArcticDom. destruct x; destruct y; simpl; try (intuition; discr).
rewrite beq_nat_ok. intuition. inversion H. refl.
Qed.

Definition is_finite v :=
  match v with
    | MinusInf => false
    | _ => true
  end.

Lemma is_finite_ok : forall v, is_finite v = true <-> v <> MinusInf.

Proof.
  intro. destruct v; simpl; intuition. discr.
Qed.

Module Arctic <: SetA.
  Definition A := ArcticDom.
End Arctic.

Module Arctic_Eqset := Eqset_def Arctic.

Module Arctic_Eqset_dec <: Eqset_dec.
  Module Export Eq := Arctic_Eqset.
  Definition eqA_dec := dec_beq beq_ArcticDom_ok.
End Arctic_Eqset_dec.

Module ArcticSemiRingT <: SemiRingType.

  Module Export ES := Arctic_Eqset_dec.

  Definition A0 := MinusInf.
  Definition A1 := Pos 0.

  (* max is a <+> operation in the semi-ring *)
  Definition Aplus m n :=
    match m, n with
    | MinusInf, n => n
    | m, MinusInf => m
    | Pos m, Pos n => Pos (max m n)
    end.

  Global Instance Aplus_mor : Proper (eqA ==> eqA ==> eqA) Aplus.

  Proof. intros a b ab c d cd. rewrite ab, cd. refl. Qed.

  (* plus is a <*> operation in the semi-ring *)
  Definition Amult m n :=
    match m, n with
    | MinusInf, _ => MinusInf
    | _, MinusInf => MinusInf
    | Pos m, Pos n => Pos (m + n)
    end.

  Global Instance Amult_mor : Proper (eqA ==> eqA ==> eqA) Amult.

  Proof. intros a b ab c d cd. rewrite ab, cd. refl. Qed.

  Lemma A_plus_comm m n : Aplus m n = Aplus n m.

  Proof.
    unfold Aplus. destruct m; destruct n; trivial. rewrite max_comm. trivial.
  Qed.

  Lemma A_plus_assoc m n p : Aplus m (Aplus n p) = Aplus (Aplus m n) p.

  Proof.
    unfold Aplus. destruct m; destruct n; destruct p; trivial.
    rewrite max_assoc. trivial.
  Qed.

  Lemma A_mult_comm m n : Amult m n = Amult n m.

  Proof.
    unfold Amult. destruct m; destruct n; trivial. rewrite plus_comm. trivial.
  Qed.

  Lemma A_mult_assoc m n p : Amult m (Amult n p) = Amult (Amult m n) p.

  Proof.
    unfold Amult. destruct m; destruct n; destruct p; trivial.
    rewrite plus_assoc. trivial.
  Qed.

  Import Compare. Import Max.

  Lemma A_mult_plus_distr m n p :
    Amult (Aplus m n) p = Aplus (Amult m p) (Amult n p).

  Proof.
    unfold Amult, Aplus. destruct m; destruct n; destruct p; trivial.
    destruct (le_dec n n0).
    rewrite !max_l. trivial. auto with arith. trivial.
    rewrite !max_r. trivial. auto with arith. trivial.
  Qed.

  Lemma A_semi_ring : semi_ring_theory A0 A1 Aplus Amult eqA.

  Proof.
    constructor; intros.
    compute; trivial.
    apply A_plus_comm.
    apply A_plus_assoc.
    destruct n; compute; trivial.
    compute; trivial.
    apply A_mult_comm.
    apply A_mult_assoc.
    apply A_mult_plus_distr.
  Qed.

  Lemma arctic_plus_notInf_left a b : a <> MinusInf -> Aplus a b <> MinusInf.

  Proof. destruct a. destruct b; discr. auto. Qed.

  Lemma arctic_mult_notInf a b :
    a <> MinusInf -> b <> MinusInf -> Amult a b <> MinusInf.

  Proof. destruct a; auto. destruct b; auto. discr. Qed.

End ArcticSemiRingT.

Module ArcticSemiRing := SemiRing ArcticSemiRingT.

(***********************************************************************)
(** Arctic semi-ring over integers with minus infinity and
    plus-max operations *)

From CoLoR Require Import ZUtil.

Inductive ArcticBZDom : Type :=
| Fin (z : Z)
| MinusInfBZ.

Definition beq_ArcticBZDom x y :=
  match x, y with
    | Fin x', Fin y' => beq_Z x' y'
    | MinusInfBZ, MinusInfBZ => true
    | _, _ => false
  end.

Lemma beq_ArcticBZDom_ok x y : beq_ArcticBZDom x y = true <-> x = y.

Proof.
  unfold beq_ArcticBZDom. destruct x; destruct y; simpl; try (intuition; discr).
  rewrite beq_Z_ok. intuition. subst. refl. inversion H. refl.
Qed.

Module ArcticBZ <: SetA.
  Definition A := ArcticBZDom.
End ArcticBZ.

Module ArcticBZ_Eqset := Eqset_def ArcticBZ.

Module ArcticBZ_Eqset_dec <: Eqset_dec.
  Module Export Eq := ArcticBZ_Eqset.
  Definition eqA_dec := dec_beq beq_ArcticBZDom_ok.
End ArcticBZ_Eqset_dec.

Module ArcticBZSemiRingT <: SemiRingType.

  Module Export ES := ArcticBZ_Eqset_dec.

  Definition A0 := MinusInfBZ.
  Definition A1 := Fin 0.

  (* max is a <+> operation in the semi-ring *)
  Definition Aplus m n :=
    match m, n with
    | MinusInfBZ, n => n
    | m, MinusInfBZ => m
    | Fin m, Fin n => Fin (Z.max m n)
    end.

  Global Instance Aplus_mor : Proper (eqA ==> eqA ==> eqA) Aplus.

  Proof. intros a b ab c d cd. rewrite ab, cd. refl. Qed.

  (* plus is a <*> operation in the semi-ring *)
  Definition Amult m n :=
    match m, n with
    | MinusInfBZ, _ => MinusInfBZ
    | _, MinusInfBZ => MinusInfBZ
    | Fin m, Fin n => Fin (m + n)
    end.

  Global Instance Amult_mor : Proper (eqA ==> eqA ==> eqA) Amult.

  Proof. intros a b ab c d cd. rewrite ab, cd. refl. Qed.

  Lemma A_plus_comm m n : Aplus m n = Aplus n m.

  Proof.
    unfold Aplus. destruct m; destruct n; trivial. rewrite Z.max_comm. refl.
  Qed.

  Lemma A_plus_assoc m n p : Aplus m (Aplus n p) = Aplus (Aplus m n) p.

  Proof.
    unfold Aplus. destruct m; destruct n; destruct p; trivial.
    rewrite Z.max_assoc. refl.
  Qed.

  Lemma A_mult_comm m n : Amult m n = Amult n m.

  Proof.
    unfold Amult. destruct m; destruct n; trivial. rewrite Zplus_comm. refl.
  Qed.

  Lemma A_mult_assoc m n p : Amult m (Amult n p) = Amult (Amult m n) p.

  Proof.
    unfold Amult. destruct m; destruct n; destruct p; trivial.
    rewrite Zplus_assoc. refl.
  Qed.

  Lemma A_mult_plus_distr m n p :
    Amult (Aplus m n) p = Aplus (Amult m p) (Amult n p).

  Proof.
    unfold Amult, Aplus. destruct m; destruct n; destruct p; trivial.
    rewrite Zplus_max_distr_r.
    destruct (Zmax_irreducible_inf z z0); rewrite e; refl.
  Qed.

  Lemma A_semi_ring : semi_ring_theory A0 A1 Aplus Amult eqA.

  Proof.
    constructor; intros.
    compute; trivial.
    apply A_plus_comm.
    apply A_plus_assoc.
    destruct n; unfold eqA; refl.
    unfold eqA. trivial.
    apply A_mult_comm.
    apply A_mult_assoc.
    apply A_mult_plus_distr.
  Qed.

  Lemma arctic_plus_notInf_left a b :
    a <> MinusInfBZ -> Aplus a b <> MinusInfBZ.

  Proof. destruct a. destruct b; discr. auto. Qed.

  Lemma arctic_mult_notInf a b :
    a <> MinusInfBZ -> b <> MinusInfBZ -> Amult a b <> MinusInfBZ.

  Proof. destruct a; auto. destruct b; auto. discr. Qed.

End ArcticBZSemiRingT.

Module ArcticBZSemiRing := SemiRing ArcticBZSemiRingT.

(***********************************************************************)
(** Tropical semi-ring over naturals with plus infinity and
    plus-min operations *)

Inductive TropicalDom : Type :=
| TPos (n : nat)
| PlusInf.

Definition tropical_is_finite v :=
  match v with
  | PlusInf => false
  | _ => true
  end.

Lemma tropical_is_finite_ok v : tropical_is_finite v = true <-> v <> PlusInf.

Proof. destruct v; simpl; intuition. discr. Qed.

Definition beq_TropicalDom x y :=
  match x, y with
  | TPos x', TPos y' => beq_nat x' y'
  | PlusInf, PlusInf => true
  | _, _ => false
  end.

Lemma beq_TropicalDom_ok x y : beq_TropicalDom x y = true <-> x = y.

Proof.
  unfold beq_TropicalDom. destruct x; destruct y; simpl; try (intuition; discr).
  rewrite beq_nat_ok. intuition. inversion H. refl.
Qed.

Module Tropical <: SetA.
  Definition A := TropicalDom.
End Tropical.

Module Tropical_Eqset := Eqset_def Tropical.

Module Tropical_Eqset_dec <: Eqset_dec.
  Module Export Eq := Tropical_Eqset.
  Definition eqA_dec := dec_beq beq_TropicalDom_ok.
End Tropical_Eqset_dec.

Module TropicalSemiRingT <: SemiRingType.

  Module Export ES := Tropical_Eqset_dec.

  Definition A0 := PlusInf.
  Definition A1 := TPos 0.

  (* min is a <+> operation in the semi-ring *)
  Definition Aplus m n :=
    match m, n with
    | PlusInf, n => n
    | m, PlusInf => m
    | TPos m, TPos n => TPos (min m n)
    end.

  Global Instance Aplus_mor : Proper (eqA ==> eqA ==> eqA) Aplus.

  Proof. intros a b ab c d cd. rewrite ab, cd. refl. Qed.

  (* plus is a <*> operation in the semi-ring *)
  Definition Amult m n :=
    match m, n with
    | PlusInf, _ => PlusInf
    | _, PlusInf => PlusInf
    | TPos m, TPos n => TPos (m + n)
    end.

  Global Instance Amult_mor : Proper (eqA ==> eqA ==> eqA) Amult.

  Proof. intros a b ab c d cd. rewrite ab, cd. refl. Qed.

  Lemma A_plus_comm m n : Aplus m n = Aplus n m.

  Proof.
    unfold Aplus. destruct m; destruct n; trivial. rewrite min_comm. trivial.
  Qed.

  Lemma A_plus_assoc m n p : Aplus m (Aplus n p) = Aplus (Aplus m n) p.

  Proof.
    unfold Aplus. destruct m; destruct n; destruct p; trivial.
    rewrite min_assoc. trivial.
  Qed.

  Lemma A_mult_comm m n : Amult m n = Amult n m.

  Proof.
    unfold Amult. destruct m; destruct n; trivial. rewrite plus_comm. trivial.
  Qed.

  Lemma A_mult_assoc m n p : Amult m (Amult n p) = Amult (Amult m n) p.

  Proof.
    unfold Amult. destruct m; destruct n; destruct p; trivial.
    rewrite plus_assoc. trivial.
  Qed.

  Import Compare. Import Min.

  Lemma A_mult_plus_distr m n p :
    Amult (Aplus m n) p = Aplus (Amult m p) (Amult n p).

  Proof.
    unfold Amult, Aplus. destruct m; destruct n; destruct p; trivial.
    destruct (le_dec n0 n).
    rewrite !min_l. trivial. auto with arith. trivial.
    rewrite !min_r. trivial. auto with arith. trivial.
  Qed.

  Lemma A_semi_ring : semi_ring_theory A0 A1 Aplus Amult eqA.

  Proof.
    constructor; intros.
    compute; trivial.
    apply A_plus_comm.
    apply A_plus_assoc.
    destruct n; compute; trivial.
    compute; trivial.
    apply A_mult_comm.
    apply A_mult_assoc.
    apply A_mult_plus_distr.
  Qed.

  Lemma tropical_plus_notInf_left a b :
    a <> PlusInf -> Aplus a b <> PlusInf.

  Proof. destruct a. destruct b; discr. auto. Qed.

  Lemma tropical_mult_notInf a b :
    a <> PlusInf -> b <> PlusInf -> Amult a b <> PlusInf.

  Proof. destruct a; auto. destruct b; auto. discr. Qed.

End TropicalSemiRingT.

Module TropicalSemiRing := SemiRing TropicalSemiRingT.

(***********************************************************************)
(** Semi-ring of booleans with 'or' and 'and' *)

Module Bool <: SetA.
  Definition A := bool.
End Bool.

Module Bool_Eqset := Eqset_def Bool.

Module Bool_Eqset_dec <: Eqset_dec.
  Module Export Eq := Bool_Eqset.
  Definition eqA_dec := bool_dec.
End Bool_Eqset_dec.

Module BSemiRingT <: SemiRingType.

  Module Export ES := Bool_Eqset_dec.

  Definition A0 := false.
  Definition A1 := true.

  Definition Aplus := orb.

  Global Instance Aplus_mor : Proper (eqA ==> eqA ==> eqA) Aplus.

  Proof. intros a b ab c d cd. rewrite ab, cd. refl. Qed.

  Definition Amult := andb.

  Global Instance Amult_mor : Proper (eqA ==> eqA ==> eqA) Amult.

  Proof. intros a b ab c d cd. rewrite ab, cd. refl. Qed.

  Lemma A_semi_ring : semi_ring_theory A0 A1 Aplus Amult eqA.

  Proof.
    constructor; intros.
    apply orb_false_l.
    apply orb_comm.
    apply orb_assoc.
    apply andb_true_l.
    apply andb_false_l.
    apply andb_comm.
    apply andb_assoc.
    apply andb_orb_distrib_l.
  Qed.

End BSemiRingT.

Module BSemiRing := SemiRing BSemiRingT.


(* admittedly, i looked up the solution *)

Lemma andb_t_f : andb true false = false.
Proof. reflexivity. Qed.

Lemma andb_f_t : andb false true = false.
Proof. reflexivity. Qed.

Theorem andb_eq_orb :
    forall (b c : bool),
    (andb b c = orb b c) ->
    b = c.
Proof.
    intros b c H.
    - destruct b.
     + destruct c.
      -- reflexivity.
      -- rewrite <- andb_t_f. rewrite -> H. reflexivity.
     + destruct c.
      -- rewrite <- andb_f_t. rewrite -> H. reflexivity.
      -- reflexivity.
Qed.