(*|
#########################################################
Why are logical connectives and booleans separate in Coq?
#########################################################

:Link: https://stackoverflow.com/q/31554453
|*)

(*|
Question
********

I come from a JavaScript/Ruby programming background and am used to
this being how true/false works (in JS):

.. code-block:: javascript

    !true
    // false
    !false
    // true

Then you can use those true/false values with ``&&`` like

.. code-block:: javascript

    var a = true, b = false;
    a && !b;

So *and* and *not* (and other logical/boolean operators) are part of a
single system; it seems like the "logical" system and the "boolean"
system are one and the same.

However, in Coq, logics and booleans are two separate things. Why is
this? The quote/link below demonstrates how a theorem is necessary to
relate them.

    We've already seen several places where analogous structures can
    be found in Coq's computational (``Type``) and logical (``Prop``)
    worlds. Here is one more: the boolean operators ``andb`` and
    ``orb`` are clearly analogs of the logical connectives ``/\`` and
    ``\/``. This analogy can be made more precise by the following
    theorems, which show how to translate knowledge about ``andb`` and
    ``orb``'s behaviors on certain inputs into propositional facts
    about those inputs.
|*)

Theorem andb_prop : forall b c,
    andb b c = true -> b = true /\ c = true.
Admitted. (* .none *)

(*|
http://www.seas.upenn.edu/~cis500/current/sf/Logic.html#lab211

----

**A (Vinz):** Short answer: not everything you can state in Coq is
provable (for example, take the halt problem. Could you prove it
(``True``) or refute it (``False``) or do you need a "gray" state for
this one ?). That's just a tiny part of the explanation, but it should
jump start your thoughts :)
|*)

(*|
Answer
******

*Essentially, Coq has both because they are useful for different
things: booleans correspond to facts that can be checked mechanically
(i.e., with an algorithm), whereas propositions can express more
concepts.*

Strictly speaking, the logical and boolean worlds are not separate in
Coq: the boolean world is a subset of the logical world. In other
words, every statement that you can phrase as a boolean computation
can be viewed as a logical proposition (i.e., something of type
``Prop``): if ``b : bool`` represents a statement, we can assert that
this statement is true by saying ``b = true``, which is of type
``Prop``.

The reason there's more in Coq to logic than just booleans is that the
converse of the previous statement does not hold: *not all logical
facts can be viewed as boolean computations*. Put in a different way,
it is not the case that booleans in normal programming languages such
as Ruby and JavaScript subsume both ``bool`` and ``Prop`` in Coq,
because ``Prop``\ s can express things that booleans in these
languages cannot.

To illustrate this, consider the following Coq predicate:
|*)

Definition commutative {T} (op : T -> T -> T) : Prop :=
  forall x y, op x y = op y x.

(*|
As the name suggests, this predicate asserts that an operator ``op``
is commutative. Many operators in programming languages are
commutative: take multiplication and addition over integers, for
instance. Indeed, in Coq we can prove the following statements (and I
believe those are examples in the Software Foundations book):
|*)

Lemma plus_comm : commutative plus. Proof. (* ... *) Admitted.
Lemma mult_comm : commutative mult. Proof. (* ... *) Admitted.

(*|
Now, try to think how you would translate a predicate like
``commutative`` in a more conventional language. If this seems
difficult, it is not by chance: it is possible to prove that we can't
write a program returning a boolean in these languages to test whether
an operation is commutative or not. You can certainly write *unit
tests* for checking whether this fact is true for particular inputs,
e.g.:

.. code-block:: coq

    2 + 3 == 3 + 2
    4 * 5 == 5 * 4

However, if your operator works with an infinite number of inputs,
these unit tests can only cover a fraction of all possible cases.
Therefore, testing is always necessarily weaker than a complete formal
proof.

You could wonder why we bother having booleans in Coq if ``Prop``\ s
can express everything that booleans can. The reason for that is that
Coq is a *constructive logic*, which is what Vinz was alluding to in
his comment. The most well-known consequence of this fact is that in
Coq we cannot prove the following intuitive principle:
|*)

Definition excluded_middle := forall P : Prop, P \/ ~ P.

(*|
which essentially says that every proposition is either true or false.
"How could this possibly fail?", you might ask yourself. Roughly
speaking, in constructive logics (and Coq in particular), every proof
corresponds to an algorithm we can execute. In particular, when you
prove a statement of the form ``A \/ B`` in a constructive logic, you
can extract an (always terminating) algorithm from that proof that
answers whether ``A`` or ``B`` holds. Hence, if we were able to prove
the above principle, we would have an algorithm that, given some
proposition, tells us whether that proposition is valid or not.
Computability theory shows, however, that this is not possible in
general because of undecidability: if we take ``P`` to mean "program
``p`` halts on input ``x``", the excluded middle would yield a decider
for the `halting problem
<https://en.wikipedia.org/wiki/Halting_problem>`__, which cannot
exist.

Now, what's interesting about booleans in Coq is that by construction
they allow the use of the excluded middle, because they *do*
correspond to an algorithm we can run. Specifically, we can prove the
following:
|*)

Lemma excluded_middle_bool :
  forall b : bool, b = true \/ negb b = true.
Proof. intros b. destruct b; auto. Qed.

(*|
Thus, in Coq it is useful to consider booleans as a special case of
propositions because they allow forms of reasoning that other
propositions do not, namely, case analysis.

Of course, you can think that requiring that every proof correspond to
an algorithm is silly, and indeed most logics allow the principle of
the excluded middle. Examples of proof assistants that follow this
approach by default include `Isabelle/HOL
<https://isabelle.in.tum.de/>`__ and the `Mizar <http://mizar.org/>`__
system. In these systems, we don't have to have a distinction between
booleans and propositions, and they are treated as the same thing.
Isabelle, for instance, has just ``bool``, and no ``Prop``. Coq also
allows you to blur the distinction between booleans and propostions,
by assuming axioms that allow you to perform case analysis on general
propositions. On the other hand, in such a setting, when you write a
function that returns a boolean, you might not obtain something that
you can execute as an algorithm, whereas this is always the case by
default in Coq.
|*)


Require Import util.
Require Import Coq.omega.Omega.
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.Lists.List.
Require Import language.
Require Import semantic.
Require Import state.
Import ListNotations.

Definition assertionB := state -> Prop.

Definition empB : assertionB :=
fun st:state => match st with
                | (stoV,stoB,stoF,hV,hB) => hB = emp_heapB
                end.

Definition point_toB (bk1 bk2:bkexp) : assertionB :=
  fun st:state =>
    match st with
    | (stoV,stoB,stoF,hV,hB) =>
        (match (bkeval stoV stoB stoF bk1),(bkeval stoV stoB stoF bk2) with
         | Some n1, Some n2 => hB = h_updateB emp_heapB n1 n2
         | _,_ => False
        end)
    end.

Notation "e1 '|=>' e2" := (point_toB e1 e2) (at level 60).

Inductive fe : Type :=
| Nil : fe
| Fi  : id -> fe
| Appbk : fe -> bkexp -> fe
| Appfe : fe -> fe -> fe.

Fixpoint feEval stoV stoB stoF feExp : option (list nat) :=
match feExp with
| Nil => Some []
| Fi fid => Some (stoF fid)
| Appbk afe abkexp => (match (feEval stoV stoB stoF afe) with
                      | Some li => (match (bkeval stoV stoB stoF abkexp) with
                                    | Some bk => Some (li ++ [bk])
                                    | None => None
                                    end)
                      | None => None
                      end)
| Appfe fe1 fe2 => (match (feEval stoV stoB stoF fe1),
                          (feEval stoV stoB stoF fe2) with
                    | Some fli1, Some fli2 => Some (fli1 ++ fli2)
                    | _,_ => None
                    end)
end.

Fixpoint allSame (li1 li2:list nat) : Prop :=
  match li1,li2 with
  | [],[] => True
  | x::xl, y::yl => (x = y) /\ (allSame xl yl)
  | _,_ => False
  end.

Definition point_toF (f:id) (feExp:fe) : assertionB :=
  fun st:state =>
    match st with
    | (stoV,stoB,stoF,hV,hB) =>
        let opfeli := (feEval stoV stoB stoF feExp) in
        let opfi := (stoF f) in
        (match opfeli, opfi with
         | Some li1, li2 => allSame li1 li2
         | _,_ => False
         end)
    end.

Definition sep_conjB (p q : assertionB) : assertionB :=
    fun st: state =>
      match st with
      | (stoV,stoB,stoF,hV,hB) =>
        exists hb1, exists hb2,
          disjointB hb1 hb2 /\ h_unionB hb1 hb2 = hB /\
          p (stoV,stoB,stoF,hV,hb1) /\ q (stoV,stoB,stoF,hV,hb2)
      end.
Notation "p '@@' q" := (sep_conjB p q) (at level 70).

Definition sep_disjB (p q: assertionB) : assertionB :=
  fun (st : state) =>
    match st with
    | (stoV,stoB,stoF,hV,hB) =>
      forall hb', disjointB hb' hB -> p (stoV,stoB,stoF, hV, hb') ->
      q (stoV,stoB,stoF,hV,h_unionB hB hb')
    end.
Notation "p '--@' q" := (sep_disjB p q) (at level 80).

Definition s_conjB (p q: assertionB) : assertionB :=
  fun (s: state) => p s /\ q s.
Notation "p '/@\' q" := (s_conjB p q) (at level 75).

Definition s_disjB (p q: assertionB) : assertionB :=
  fun (s: state) => p s \/ q s.
Notation "p '\@/' q" := (s_disjB p q) (at level 78).

Definition s_impB (p q: assertionB) : assertionB :=
  fun (s: state) => p s -> q s.
Notation "p '--->' q" := (s_impB p q) (at level 85).

Definition strongerThanB (p q: assertionB) : Prop :=
  forall s: state, s_impB p q s.
Notation "p '===>' q" := (strongerThanB p q) (at level 90).

Definition bk_eq (bk1 bk2:bkexp) : assertionB :=
  fun st:state =>
    match st with
    | (stoV,stoB,stoF,hV,hB) =>
        (match (bkeval stoV stoB stoF bk1),(bkeval stoV stoB stoF bk2) with
         | Some n1, Some n2 => n1 = n2
         | _,_ => False
        end)
    end.
Notation "e1 '=b=' e2" := (bk_eq e1 e2) (at level 60).

Definition bk_le (bk1 bk2:bkexp) : assertionB :=
  fun st:state =>
    match st with
    | (stoV,stoB,stoF,hV,hB) =>
        (match (bkeval stoV stoB stoF bk1),(bkeval stoV stoB stoF bk2) with
         | Some n1, Some n2 => n1 <= n2
         | _,_ => False
        end)
    end.
Notation "e1 '<b=' e2" := (bk_le e1 e2) (at level 60).


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*i $Id: Zmax.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** THIS FILE IS DEPRECATED. Use [Zminmax] instead. *)

Require Export BinInt Zorder Zminmax.

Open Local Scope Z_scope.

(** [Zmax] is now [Zminmax.Zmax]. Code that do things like
  [unfold Zmin.Zmin] will have to be adapted, and neither
  a [Definition] or a [Notation] here can help much. *)

(** * Characterization of maximum on binary integer numbers *)

Definition Zmax_case := Z.max_case.
Definition Zmax_case_strong := Z.max_case_strong.

Lemma Zmax_spec : forall x y,
  x >= y /\ Zmax x y = x  \/ x < y /\ Zmax x y = y.
Proof.
 intros x y. rewrite Zge_iff_le. destruct (Z.max_spec x y); auto.
Qed.

Lemma Zmax_left : forall n m, n>=m -> Zmax n m = n.
Proof. intros x y. rewrite Zge_iff_le. apply Zmax_l. Qed.

Definition Zmax_right : forall n m, n<=m -> Zmax n m = m := Zmax_r.

(** * Least upper bound properties of max *)

Definition Zle_max_l : forall n m, n <= Zmax n m := Z.le_max_l.
Definition Zle_max_r : forall n m, m <= Zmax n m := Z.le_max_r.

Definition Zmax_lub : forall n m p, n <= p -> m <= p -> Zmax n m <= p
 := Z.max_lub.

Definition Zmax_lub_lt : forall n m p:Z, n < p -> m < p -> Zmax n m < p
 := Z.max_lub_lt.

(** * Compatibility with order *)

Definition Zle_max_compat_r : forall n m p, n <= m -> Zmax n p <= Zmax m p
 := Z.max_le_compat_r.

Definition Zle_max_compat_l : forall n m p, n <= m -> Zmax p n <= Zmax p m
 := Z.max_le_compat_l.

(** * Semi-lattice properties of max *)

Definition Zmax_idempotent : forall n, Zmax n n = n := Z.max_id.
Definition Zmax_comm : forall n m, Zmax n m = Zmax m n := Z.max_comm.
Definition Zmax_assoc : forall n m p, Zmax n (Zmax m p) = Zmax (Zmax n m) p
 := Z.max_assoc.

(** * Additional properties of max *)

Lemma Zmax_irreducible_dec : forall n m, {Zmax n m = n} + {Zmax n m = m}.
Proof. exact Z.max_dec. Qed.

Definition Zmax_le_prime : forall n m p, p <= Zmax n m -> p <= n \/ p <= m
 := Z.max_le.

(** * Operations preserving max *)

Definition Zsucc_max_distr :
  forall n m:Z, Zsucc (Zmax n m) = Zmax (Zsucc n) (Zsucc m)
 := Z.succ_max_distr.

Definition Zplus_max_distr_l : forall n m p:Z, Zmax (p + n) (p + m) = p + Zmax n m
 := Z.plus_max_distr_l.

Definition Zplus_max_distr_r : forall n m p:Z, Zmax (n + p) (m + p) = Zmax n m + p
 := Z.plus_max_distr_r.

(** * Maximum and Zpos *)

Definition Zpos_max : forall p q, Zpos (Pmax p q) = Zmax (Zpos p) (Zpos q)
 := Z.pos_max.

Definition Zpos_max_1 : forall p, Zmax 1 (Zpos p) = Zpos p
 := Z.pos_max_1.

(** * Characterization of Pminus in term of Zminus and Zmax *)

Definition Zpos_minus :
 forall p q, Zpos (Pminus p q) = Zmax 1 (Zpos p - Zpos q)
 := Zpos_minus.

(* begin hide *)
(* Compatibility *)
Notation Zmax1 := Zle_max_l (only parsing).
Notation Zmax2 := Zle_max_r (only parsing).
Notation Zmax_irreducible_inf := Zmax_irreducible_dec (only parsing).
Notation Zmax_le_prime_inf := Zmax_le_prime (only parsing).
(* end hide *)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** Author: Cristina Cornes.
    From: Constructing Recursion Operators in Type Theory
    L. Paulson  JSC (1986) 2, 325-355 *)

Require Import Eqdep.

Section WellOrdering.
  Variable A : Type.
  Variable B : A -> Type.

  Inductive WO : Type :=
    sup : forall (a:A) (f:B a -> WO), WO.

  Inductive le_WO : WO -> WO -> Prop :=
    le_sup : forall (a:A) (f:B a -> WO) (v:B a), le_WO (f v) (sup a f).

  Theorem wf_WO : well_founded le_WO.
  Proof.
    unfold well_founded in |- *; intro.
    apply Acc_intro.
    elim a.
    intros.
    inversion H0.
    apply Acc_intro.
    generalize H4; generalize H1; generalize f0; generalize v.
    rewrite H3.
    intros.
    apply (H v0 y0).
    cut (f = f1).
    intros E; rewrite E; auto.
    symmetry  in |- *.
    apply (inj_pair2 A (fun a0:A => B a0 -> WO) a0 f1 f H5).
  Qed.

End WellOrdering.

Section Characterisation_wf_relations.

  (** Wellfounded relations are the inverse image of wellordering types *)
  (*  in course of development                                          *)

  Variable A : Type.
  Variable leA : A -> A -> Prop.

  Definition B (a:A) := {x : A | leA x a}.

  Definition wof : well_founded leA -> A -> WO A B.
  Proof.
    intros.
    apply (well_founded_induction_type H (fun a:A => WO A B)); auto.
    intros x H1.
    apply (sup A B x).
    unfold B at 1 in |- *.
    destruct 1 as [x0].
    apply (H1 x0); auto.
Qed.

End Characterisation_wf_relations.


Require Import Coq.Lists.List.
Require Import Coq.Bool.Bool.
Require Import Aniceto.Graphs.Graph.

Require Import Tid.
Require Import Mid.
Require Import Node.

Require Trace.

Import ListNotations.

Set Implicit Arguments.

Module Expr.
Section Defs.
  Variable A:Type.

  Inductive t :=
  | init: A -> t
  | fork : A -> A -> A -> t
  | join : A -> A -> A -> t
  | seq: A -> A -> t.

  Inductive In: A -> t -> Prop :=
  | in_init:
    forall x,
    In x (init x)
  | in_fork:
    forall w x y z,
    (w = x \/ w = y \/ w = z) ->
    In w (fork x y z)
  | in_join:
    forall x y z w,
    (w = x \/ w = y \/ w = z) ->
    In w (join x y z)
  | in_seq:
    forall x y z,
    (z = x \/ z = y) ->
    In z (seq x y).

  Inductive CEdge: t -> (A * A) -> Prop :=
  | c_edge_fork:
    forall x y z,
    CEdge (fork x y z) (y, z)
  | c_edge_join:
    forall x y z,
    CEdge (join x y z) (x, y)
  | c_edge_seq:
    forall x y,
    CEdge (seq x y) (x, y).

  Definition c_edge (e:t) :=
  match e with
  | fork x y z => Some (y, z)
  | join x y z => Some (x, y)
  | seq x y => Some (x, y)
  | _ => None
  end.

  Lemma some_to_c_edge:
    forall p e,
    (c_edge e) = Some p ->
    CEdge e p.
  Proof.
    intros; destruct e; simpl in *; try inversion H;
    destruct H; try contradiction; subst;
    auto using c_edge_fork, c_edge_join, c_edge_seq.
  Qed.

  Lemma c_edge_to_some:
    forall e p,
    CEdge e p ->
    c_edge e = Some p.
  Proof.
    intros.
    inversion H; subst; simpl; auto.
  Qed.

  Lemma c_edge_fun:
    forall e p p',
    CEdge e p ->
    CEdge e p' ->
    p' = p.
  Proof.
    intros.
    destruct e; inversion H; subst; inversion H0; subst; auto.
  Qed.

  Inductive JEdge: t -> (A * A) -> Prop :=
  | j_edge_def:
    forall x y z,
    JEdge (join x y z) (z, y).

  Lemma j_edge_fun:
    forall e p p',
    JEdge e p ->
    JEdge e p' ->
    p' = p.
  Proof.
    intros.
    destruct e; inversion H; subst; inversion H0; subst; auto.
  Qed.

  Definition j_edge (e:t) :=
  match e with
  | join x y z => Some (z, y)
  | _ => None
  end.

  Lemma some_to_j_edge:
    forall p e,
    j_edge e = Some p ->
    JEdge e p.
  Proof.
    intros; destruct e; simpl in *; try inversion H; subst.
    auto using j_edge_def.
  Qed.

  Lemma j_edge_to_some:
    forall e p,
    JEdge e p ->
    j_edge e = Some p.
  Proof.
    intros.
    inversion H; subst; simpl; auto.
  Qed.

  Inductive FEdge: t -> (A * A) -> Prop :=
  | f_edge_def:
    forall x y z,
    FEdge (fork x y z) (x, y).

  Definition Edge e p := CEdge e p \/ FEdge e p \/ JEdge e p.

  Section Dec.
    Variable a_eq_dec: forall (x y:A), { x = y } + { x <> y }.

    Ltac handle_not :=
    let H := fresh "H" in
    right; unfold not; intros; inversion H; subst; contradiction.

    Definition eq_dec (x y:t):
      { x = y } + { x <> y }.
    Proof.
      destruct x.
      - destruct y; try handle_not.
        destruct (a_eq_dec a a0); subst; auto.
        right; unfold not; intros.
        inversion H; subst; clear H.
        contradiction.
      - destruct y; try handle_not.
        destruct (a_eq_dec a a2); try handle_not.
        subst.
        destruct (a_eq_dec a0 a3); try handle_not; subst.
        destruct (a_eq_dec a4 a1); try handle_not; subst.
        auto.
      - destruct y; try handle_not.
        destruct (a_eq_dec a2 a); try handle_not; subst.
        destruct (a_eq_dec a0 a3); try handle_not; subst.
        destruct (a_eq_dec a1 a4); try handle_not; subst.
        auto.
      - destruct y; try handle_not.
        destruct (a_eq_dec a1 a); try handle_not; subst.
        destruct (a_eq_dec a0 a2); try handle_not; subst.
        auto.
    Defined.

    Let eq_fst x (p:A*A) :=
    let (a,b) := p in if a_eq_dec a x then true else false.

    Let eq_fst_true:
      forall x y z,
      eq_fst x (y, z) = true ->
      y = x.
    Proof.
      unfold eq_fst; intros.
      destruct (a_eq_dec y x); auto.
      inversion H.
    Qed.

    Let eq_fst_false:
      forall x y z,
      eq_fst x (y, z) = false ->
      y <> x.
    Proof.
      unfold eq_fst; intros.
      destruct (a_eq_dec y x); auto.
      inversion H.
    Qed.

    Definition c_edge_out e x : bool :=
    match c_edge e with
    | Some (a, _) => if a_eq_dec x a then true else false
    | _ => false
    end.

    Lemma c_edge_out_true:
      forall e x,
      c_edge_out e x = true ->
      exists y, CEdge e (x, y).
    Proof.
      unfold c_edge_out; intros.
      remember (c_edge e); symmetry in Heqo.
      destruct o. {
        destruct p.
        destruct (a_eq_dec x a). {
          subst.
          eauto using some_to_c_edge.
        }
        inversion H.
      }
      inversion H.
    Qed.

    Lemma c_edge_out_false:
      forall e x,
      c_edge_out e x = false ->
      forall y, ~ CEdge e (x, y).
    Proof.
      unfold c_edge_out; intros.
      remember (c_edge e); symmetry in Heqo.
      destruct o. {
        destruct p.
        unfold not; intros N.
        apply c_edge_to_some in N.
        rewrite N in *.
        inversion Heqo; subst.
        destruct (a_eq_dec a a). {
          inversion H.
        }
        contradiction.
      }
      unfold not; intros N.
      apply c_edge_to_some in N.
      rewrite N in *.
      inversion Heqo.
    Qed.

    Definition c_edge_out_dec t x:
      { forall y, ~ CEdge t (x, y) } + { exists y, CEdge t (x, y) }.
    Proof.
      remember (c_edge_out t x); symmetry in Heqb; destruct b. {
        auto using c_edge_out_true.
      }
      auto using c_edge_out_false.
    Defined.

    Definition j_edge_out e x : bool :=
    match j_edge e with
    | Some (a, _) => if a_eq_dec x a then true else false
    | _ => false
    end.

    Lemma j_edge_out_true:
      forall e x,
      j_edge_out e x = true ->
      exists y, JEdge e (x, y).
    Proof.
      unfold j_edge_out; intros.
      remember (j_edge e); symmetry in Heqo.
      destruct o. {
        destruct p.
        destruct (a_eq_dec x a). {
          subst.
          eauto using some_to_j_edge.
        }
        inversion H.
      }
      inversion H.
    Qed.

    Lemma j_edge_out_false:
      forall e x,
      j_edge_out e x = false ->
      forall y, ~ JEdge e (x, y).
    Proof.
      unfold j_edge_out; intros.
      remember (j_edge e); symmetry in Heqo.
      destruct o. {
        destruct p.
        unfold not; intros N.
        apply j_edge_to_some in N.
        rewrite N in *.
        inversion Heqo; subst.
        destruct (a_eq_dec a a). {
          inversion H.
        }
        contradiction.
      }
      unfold not; intros N.
      apply j_edge_to_some in N.
      rewrite N in *.
      inversion Heqo.
    Qed.

    Definition j_edge_out_dec t x:
      { forall y, ~ JEdge t (x, y) } + { exists y, JEdge t (x, y) }.
    Proof.
      remember (j_edge_out t x); symmetry in Heqb; destruct b. {
        auto using j_edge_out_true.
      }
      auto using j_edge_out_false.
    Defined.

    Definition in_dec x e:
      { In x e } + { ~ In x e }.
    Proof.
      destruct e.
      - destruct (a_eq_dec x a); try handle_not; subst; auto using in_init.
      - destruct (a_eq_dec x a); subst; auto using in_fork.
        destruct (a_eq_dec x a0); subst; auto using in_fork.
        destruct (a_eq_dec x a1); subst; auto using in_fork.
        right; unfold not; intros.
        inversion H; subst.
        destruct H2 as [?|[?|?]]; subst; try contradiction.
      - destruct (a_eq_dec x a); subst; auto using in_join.
        destruct (a_eq_dec x a0); subst; auto using in_join.
        destruct (a_eq_dec x a1); subst; auto using in_join.
        right; unfold not; intros.
        inversion H; subst.
        destruct H2 as [?|[?|?]]; subst; try contradiction.
      - destruct (a_eq_dec x a); subst; auto using in_seq.
        destruct (a_eq_dec x a0); subst; auto using in_seq.
        right; unfold not; intros.
        inversion H; subst.
        destruct H2 as [?|?]; subst; try contradiction.
    Defined.
  End Dec.
End Defs.
End Expr.

Section Defs.
  Variable A:Type.

  Definition computation_graph := (list (Expr.t A)).

  Definition Edge (cg:computation_graph) p :=
  Exists (fun e => Expr.Edge e p) cg.

  Definition CEdge (l:computation_graph) p :=
  Exists (fun e => Expr.CEdge e p) l.

  Definition JEdge (l:computation_graph) p :=
  Exists (fun e => Expr.JEdge e p) l.

  Definition HB l := Reaches (Edge l).
  Definition CONTINUE l := Reaches (Edge l).

  Definition In x : computation_graph -> Prop := Exists (fun e=>Expr.In x e).

  Inductive Leaf (x:A) l :=
  | leaf_def:
    (forall y, ~ CEdge l (x, y)) ->
    In x l ->
    Leaf x l.

  Variable a_eq_dec: forall (x y:A), { x = y } + { x <> y }.

  Definition is_in x l :=
  existsb (fun e => if Expr.in_dec a_eq_dec x e then true else false) l.

  Lemma is_in_true:
    forall x l,
    is_in x l = true ->
    In x l.
  Proof.
    unfold is_in; intros.
    apply existsb_exists in H.
    destruct H as (e, (Hi, Hx)).
    destruct (Expr.in_dec a_eq_dec x e). {
      apply Exists_exists.
      eauto.
    }
    inversion Hx.
  Qed.

  Lemma is_in_false:
    forall x l,
    is_in x l = false ->
    ~ In x l.
  Proof.
    unfold is_in, not; intros.
    apply List.existsb_Forall in H.
    rewrite Forall_forall in H.
    unfold In in *.
    rewrite Exists_exists in *.
    destruct H0 as (e, (Hi, Hii)).
    apply H in Hi.
    destruct (Expr.in_dec a_eq_dec x e). {
      inversion Hi.
    }
    contradiction.
  Qed.

  Definition in_dec x l:
    { In x l } + { ~ In x l }.
  Proof.
    remember (is_in x l).
    symmetry in Heqb.
    destruct b. {
      auto using is_in_true.
    }
    auto using is_in_false.
  Defined.

  Definition c_edge_out x l :=
  existsb (fun e => Expr.c_edge_out a_eq_dec e x) l.

  Lemma c_edge_out_true:
    forall x l,
    c_edge_out x l = true ->
    exists y, CEdge l (x, y).
  Proof.
    unfold c_edge_out; intros.
    apply existsb_exists in H.
    destruct H as (e, (Hi, Hii)).
    apply Expr.c_edge_out_true in Hii.
    unfold CEdge.
    destruct Hii as (y, He).
    exists y.
    apply Exists_exists.
    eauto.
  Qed.

  Lemma c_edge_out_false:
    forall x l,
    c_edge_out x l = false ->
    forall y, ~ CEdge l (x, y).
  Proof.
    unfold c_edge_out, not; intros.
    apply List.existsb_Forall in H.
    rewrite Forall_forall in H.
    unfold CEdge in *.
    rewrite Exists_exists in H0.
    destruct H0 as (e, (Hi, Hii)).
    apply H in Hi.
    eapply Expr.c_edge_out_false in Hi.
    eauto.
  Qed.

  Definition c_edge_out_dec l x:
    { forall y, ~ CEdge l (x, y) } + { exists y, CEdge l (x, y) }.
  Proof.
    remember (c_edge_out x l).
    symmetry in Heqb; destruct b. {
      auto using c_edge_out_true.
    }
    auto using c_edge_out_false.
  Defined.

  Definition is_leaf (x: A) l := is_in x l && negb (c_edge_out x l).

  Lemma is_leaf_true:
    forall x l,
    is_leaf x l = true ->
    Leaf x l.
  Proof.
    unfold is_leaf; intros.
    rewrite andb_true_iff in *.
    destruct H.
    rewrite negb_true_iff in *.
    apply is_in_true in H.
    apply leaf_def; eauto using c_edge_out_false.
  Qed.

  Lemma is_leaf_false:
    forall x l,
    is_leaf x l = false ->
    ~ Leaf x l.
  Proof.
    unfold is_leaf, not; intros.
    rewrite andb_false_iff in *.
    inversion H0; subst; clear H0.
    destruct H. {
      apply is_in_false in H.
      contradiction.
    }
    rewrite negb_false_iff in *.
    apply c_edge_out_true in H.
    destruct H.
    apply H1 in H.
    contradiction.
  Qed.

  Definition leaf_dec x l :
    { Leaf x l } + { ~ Leaf x l }.
  Proof.
    remember (is_leaf x l); symmetry in Heqb; destruct b. {
      auto using is_leaf_true.
    }
    auto using is_leaf_false.
  Defined.

  Definition j_edge_out x l :=
  existsb (fun e => Expr.j_edge_out a_eq_dec e x) l.

  Definition j_edge_out_dec l x:
    { forall y, ~ JEdge l (x, y) } + { exists y, JEdge l (x, y) }.
  Proof.
    remember (j_edge_out x l).
    symmetry in Heqb; destruct b; unfold j_edge_out in *. {
      apply existsb_exists in Heqb.
      right.
      destruct Heqb as (e, (Hi, Hii)).
      apply Expr.j_edge_out_true in Hii.
      unfold JEdge.
      destruct Hii as (y, He).
      exists y.
      apply Exists_exists.
      eauto.
    }
    left.
    unfold not; intros.
    apply List.existsb_Forall in Heqb.
    rewrite Forall_forall in Heqb.
    unfold JEdge in *.
    rewrite Exists_exists in H.
    destruct H as (e, (Hi, Hii)).
    apply Heqb in Hi.
    eapply Expr.j_edge_out_false in Hi.
    eauto.
  Defined.

  Inductive Running (x:A) l :=
  | running_def:
    (forall y, ~ JEdge l (x, y)) ->
    Leaf x l ->
    Running x l.

  Definition is_running x l: bool :=
  negb (j_edge_out x l) && is_leaf x l.

  Definition running_dec x l:
    { Running x l } + { ~ Running x l }.
  Proof.
    destruct (leaf_dec x l). {
      destruct (j_edge_out_dec l x). {
        auto using running_def.
      }
      right; unfold not; intros;
      inversion H.
      destruct e as (?, He).
      apply H0 in He; contradiction.
    }
    right; unfold not; intros;
    inversion H.
    contradiction.
  Defined.

  Inductive CG: computation_graph -> Prop :=
  | cg_nil:
    CG []
  | cg_init:
    forall x l,
    CG l ->
    ~ In x l ->
    CG ((Expr.init x)::l)
  | cg_fork:
    forall x y z l,
    CG l ->
    Running y l ->
    ~ In x l ->
    ~ In z l ->
    CG ((Expr.fork x y z)::l)
  | cg_join:
    forall x y z l,
    CG l ->
    Running x l ->
    Leaf z l ->
    ~ In y l ->
    CG ((Expr.join x y z)::l)
  | cg_seq:
    forall x y l,
    CG l ->
    Running x l ->
    ~ In y l ->
    CG ((Expr.seq x y)::l).

  Lemma cg_inv_cons:
    forall e l,
    CG (e :: l) ->
    CG l.
  Proof.
    intros.
    inversion H; subst; clear H; auto.
  Qed.

  Definition cg_dec l:
    { CG l } + { ~ CG l }.
  Proof.
    induction l. {
      auto using cg_nil.
    }
    destruct IHl. {
      destruct a.
      - destruct (in_dec a l). {
          right; unfold not; intros N; inversion N; subst; contradiction.
        }
        auto using cg_init.
      - destruct (running_dec a0 l). {
          destruct (in_dec a l). {
            right; unfold not; intros N; inversion N; subst; contradiction.
          }
          destruct (in_dec a1 l). {
            right; unfold not; intros N; inversion N; subst; contradiction.
          }
          auto using cg_fork.
        }
        right; unfold not; intros N; inversion N; subst; contradiction.
      - destruct (running_dec a l). {
          destruct (in_dec a0 l). {
            right; unfold not; intros N; inversion N; subst; contradiction.
          }
          destruct (leaf_dec a1 l). {
            auto using cg_join.
          }
          right; unfold not; intros N; inversion N; subst; contradiction.
        }
        right; unfold not; intros N; inversion N; subst; contradiction.
      - destruct (running_dec a l). {
          destruct (in_dec a0 l). {
            right; unfold not; intros N; inversion N; subst; contradiction.
          }
          auto using cg_seq.
        }
        right; unfold not; intros N; inversion N; subst; contradiction.
    }
    right; unfold not; intros N.
    inversion N; subst; try contradiction.
  Defined.

  Definition is_cg l :=
  if cg_dec l then true else false.

  Lemma is_cg_true:
    forall l,
    is_cg l = true ->
    CG l.
  Proof.
    unfold is_cg; intros.
    destruct (cg_dec l); auto.
    inversion H.
  Qed.
End Defs.

Module Examples.

  Goal CG [
    Expr.join 6 7 5;
    Expr.join 2 6 4;
    Expr.fork 5 3 4;
    Expr.fork 3 1 2;
    Expr.init 1
  ].
  Proof.
    assert (is_cg Peano_dec.eq_nat_dec [
      Expr.join 6 7 5;
      Expr.join 2 6 4;
      Expr.fork 5 3 4;
      Expr.fork 3 1 2;
      Expr.init 1
   ] = true). {
      compute.
      trivial.
    }
    apply is_cg_true in H.
    auto.
  Qed.

  Goal CG [
    Expr.seq 8 11;   (* (h, rd(a, g)) *)
    Expr.seq 5 10;   (* (g, rd(b, h)) *)
    Expr.seq 7 9;    (* (f, wr(b, h)) *)
    Expr.fork 8 6 7; (* (f, async h) *)
    Expr.seq 4 6;    (* (f, wr(a, g)) *)
    Expr.fork 5 3 4; (* (f, async g) *)
    Expr.seq 2 3;    (* (f, new y) *)
    Expr.seq 1 2;    (* (f, new x) *)
    Expr.init 1      (* (f, init) *)
  ].
  Proof.
    assert (is_cg Peano_dec.eq_nat_dec [
    Expr.seq 8 11;   (* (h, rd(a, g)) *)
    Expr.seq 5 10;   (* (g, rd(b, h)) *)
    Expr.seq 7 9;    (* (f, wr(b, h)) *)
    Expr.fork 8 6 7; (* (f, async h) *)
    Expr.seq 4 6;    (* (f, wr(a, g)) *)
    Expr.fork 5 3 4; (* (f, async g) *)
    Expr.seq 2 3;    (* (f, new y) *)
    Expr.seq 1 2;    (* (f, new x) *)
    Expr.init 1      (* (f, init) *)
   ] = true). {
      compute.
      trivial.
    }
    apply is_cg_true in H.
    auto.
  Qed.
End Examples.

Section Props.
  Import Trace.

  Definition action := (tid * op) % type.

  Definition trace := list action.

  Definition actions := MN.t action.

  Inductive TaskOf n x (a:actions) : Prop :=
  | task_of_def:
    forall o,
    MN.MapsTo n (x, o) a ->
    TaskOf n x a.

  Inductive Trace: trace -> computation_graph node -> actions -> Prop :=
  | trace_nil:
    Trace [] [] (MN.empty action)
  | trace_init:
    forall x n cg a t,
    Trace t cg a ->
    Trace ((x, INIT)::t) (Expr.init n :: cg) (MN.add n (x,INIT) a)
  | trace_mem:
    forall t cg x n n' m r a,
    Trace t cg a ->
    TaskOf n x a ->
    Trace ((x, MEM r m)::t) (Expr.seq n n' :: cg) (MN.add n (x, MEM r m) a)
  | cg_future:
    forall x y t cg nx nx' ny a,
    Trace t cg a ->
    TaskOf nx x a ->
    Trace ((x, FUTURE y)::t) (Expr.fork ny nx nx'::cg)
      (MN.add ny (y, INIT) (MN.add nx' (x, FUTURE y) a))
  | trace_join:
    forall nx ny nx' t cg a x y,
    Trace t cg a ->
    TaskOf nx x a ->
    TaskOf ny y a ->
    Trace ((x, FUTURE y)::t) (Expr.join nx nx' ny::cg)
      (MN.add nx' (x, FORCE y) a).

  Definition known_sets := MN.t (list tid).

  Section KnownSet.
    Variable a: actions.

    Inductive KnownSet: computation_graph node -> known_sets -> Prop :=
    | known_set_nil:
      KnownSet [] (MN.empty (list tid))
    | known_set_init:
      forall cg ks n,
      KnownSet cg ks ->
      KnownSet (Expr.init n :: cg) (MN.add n nil ks)
    | known_set_mem:
      forall cg ks n n',
      KnownSet cg ks ->
      KnownSet (Expr.seq n n' :: cg) ks
    | known_set_fork:
      forall cg ks y l nx ny nx',
      KnownSet cg ks ->
      TaskOf ny y a ->
      MN.MapsTo nx l ks ->
      KnownSet (Expr.fork ny nx nx' :: cg) (MN.add ny l (MN.add nx' (y::l) ks))
    | known_set_join:
      forall cg ks lx ly nx ny nx',
      KnownSet cg ks ->
      MN.MapsTo nx lx ks ->
      MN.MapsTo ny ly ks ->
      KnownSet (Expr.fork nx nx' ny :: cg) (MN.add nx' (ly ++ lx) ks).
  End KnownSet.
End Props.


From Ordinal Require Import sflib Basics.
From Ordinal Require Export Ordinal Arithmetic.

Require Import Coq.Classes.RelationClasses Coq.Classes.Morphisms.

Set Implicit Arguments.
Set Primitive Projections.

Module Hessenberg.
  Section ADD.
    Program Let _add: Ord.t * Ord.t -> Ord.t :=
      Fix (double_rel_well_founded Ord.lt_well_founded Ord.lt_well_founded) (fun _ => Ord.t)
          (fun o0o1 add =>
             match o0o1 with
             | (o0, o1) =>
                 Ord.union
                   (match o1 with
                    | @Ord.build X1 os1 => Ord.build (fun x1 => @add (o0, os1 x1) _)
                    end)
                   (match o0 with
                    | @Ord.build X0 os0 => Ord.build (fun x0 => @add (os0 x0, o1) _)
                    end)
             end).
    Next Obligation.
      right. econs. reflexivity.
    Qed.
    Next Obligation.
      left. econs. reflexivity.
    Qed.

    Definition add (o0 o1: Ord.t): Ord.t :=
      _add (o0, o1).

    Let _add_red (o0o1: Ord.t * Ord.t)
      :
      Ord.eq
        (_add o0o1)
        (match o0o1 with
         | (o0, o1) =>
             Ord.union
               (match o1 with
                | @Ord.build X1 os1 => Ord.build (fun x1 => _add (o0, os1 x1))
                end)
               (match o0 with
                | @Ord.build X0 os0 => Ord.build (fun x0 => _add (os0 x0, o1))
                end)
         end).
    Proof.
      unfold _add. rewrite Fix_equiv; ss.
      { destruct o0o1 as [[] []]. ss. reflexivity. }
      { i. ss. destruct x as [[] []].
        eapply Ord.eq_union.
        { split.
          { econs. i. exists a0. eapply H. }
          { econs. i. exists a0. eapply H. }
        }
        { split.
          { econs. i. exists a0. eapply H. }
          { econs. i. exists a0. eapply H. }
        }
      }
    Qed.

    Lemma add_red X0 (os0: X0 -> Ord.t) X1 (os1: X1 -> Ord.t)
      :
      Ord.eq
        (add (@Ord.build X0 os0) (@Ord.build X1 os1))
        (Ord.union
           (Ord.build (fun x1 => add (@Ord.build X0 os0) (os1 x1)))
           (Ord.build (fun x0 => add (os0 x0) (@Ord.build X1 os1)))).
    Proof.
      unfold add. apply _add_red.
    Qed.
    Global Opaque add.

    Lemma add_supremum o0 o1 o
          (LE0: forall o2 (LT: Ord.lt o2 o0), Ord.lt (add o2 o1) o)
          (LE1: forall o2 (LT: Ord.lt o2 o1), Ord.lt (add o0 o2) o)
      :
      Ord.le (add o0 o1) o.
    Proof.
      destruct o0, o1. rewrite add_red.
      apply Ord.union_spec.
      { eapply Ord.build_supremum. i. eapply LE1. eapply Ord.build_upperbound. }
      { eapply Ord.build_supremum. i. eapply LE0. eapply Ord.build_upperbound. }
    Qed.

    Lemma le_add_l o0 o1 o2 (LE: Ord.le o0 o1)
      :
      Ord.le (add o0 o2) (add o1 o2).
    Proof.
      revert o0 LE. pattern o1, o2. revert o1 o2.
      eapply (double_well_founded_induction Ord.lt_well_founded Ord.lt_well_founded).
      i. dup LE. inv LE. destruct b1.
      rewrite add_red. rewrite add_red.
      eapply Ord.le_union.
      { econs. i. exists a0. eapply IHR; auto. econs. reflexivity. }
      { econs. i. specialize (LE1 a0). des.
        exists a1. eapply IHL; auto. econs. reflexivity. }
    Qed.

    Lemma le_add_r o0 o1 o2 (LE: Ord.le o1 o2)
      :
      Ord.le (add o0 o1) (add o0 o2).
    Proof.
      revert o1 LE. pattern o0. pattern o2. revert o0 o2.
      eapply (double_well_founded_induction Ord.lt_well_founded Ord.lt_well_founded).
      i. dup LE. inv LE. destruct a1.
      rewrite add_red. rewrite add_red.
      eapply Ord.le_union.
      { econs. i. specialize (LE1 a0). des.
        exists a1. eapply IHR; auto. econs. reflexivity. }
      { econs. i. exists a0. eapply IHL; auto. econs. reflexivity. }
    Qed.

    Lemma eq_add_l o0 o1 o2 (EQ: Ord.eq o0 o1)
      :
      Ord.eq (add o0 o2) (add o1 o2).
    Proof.
      econs.
      { eapply le_add_l. eapply EQ. }
      { eapply le_add_l. eapply EQ. }
    Qed.

    Lemma eq_add_r o0 o1 o2 (EQ: Ord.eq o1 o2)
      :
      Ord.eq (add o0 o1) (add o0 o2).
    Proof.
      econs.
      { eapply le_add_r. eapply EQ. }
      { eapply le_add_r. eapply EQ. }
    Qed.

    Global Program Instance add_eq_proper: Proper (Ord.eq ==> Ord.eq ==> Ord.eq) (add).
    Next Obligation.
      ii.
      etransitivity.
      - eapply eq_add_l; eauto.
      - eapply eq_add_r; eauto.
    Qed.

    Global Program Instance add_le_proper: Proper (Ord.le ==> Ord.le ==> Ord.le) (add).
    Next Obligation.
      ii.
      etransitivity.
      - eapply le_add_l; eauto.
      - eapply le_add_r; eauto.
    Qed.

    Lemma lt_add_l o0 o1 o2 (LT: Ord.lt o0 o1)
      :
      Ord.lt (add o0 o2) (add o1 o2).
    Proof.
      inv LT. destruct o2. rewrite add_red. eapply Ord.lt_le_lt.
      2:{ eapply Ord.union_r. }
      { eapply Ord.le_lt_lt.
        { rewrite LE. reflexivity. }
        { econs. reflexivity. }
      }
    Qed.

    Lemma lt_add_r o0 o1 o2 (LT: Ord.lt o1 o2)
      :
      Ord.lt (add o0 o1) (add o0 o2).
    Proof.
      inv LT. destruct o0. rewrite add_red. eapply Ord.lt_le_lt.
      2:{ eapply Ord.union_l. }
      { eapply Ord.le_lt_lt.
        { rewrite LE. reflexivity. }
        { econs. reflexivity. }
      }
    Qed.

    Lemma add_spec o0 o1 o2
          (SUP0: forall o (LT: Ord.lt o o0), Ord.lt (add o o1) o2)
          (SUP1: forall o (LT: Ord.lt o o1), Ord.lt (add o0 o) o2)
      :
      Ord.le (add o0 o1) o2.
    Proof.
      destruct o0, o1. rewrite add_red. eapply Ord.union_spec.
      { eapply Ord.build_supremum. i. eapply SUP1. econs. reflexivity. }
      { eapply Ord.build_supremum. i. eapply SUP0. econs. reflexivity. }
    Qed.

    Lemma add_comm o0 o1
      :
      Ord.eq (add o0 o1) (add o1 o0).
    Proof.
      revert o0 o1.
      cut (forall o0 o1, Ord.le (add o0 o1) (add o1 o0)).
      { i. split; eauto. }
      i. pattern o0, o1. revert o0 o1.
      eapply (double_well_founded_induction Ord.lt_well_founded Ord.lt_well_founded).
      i. destruct a1, b1. rewrite add_red. rewrite add_red.
      rewrite Ord.union_comm. eapply Ord.le_union.
      { econs. i. exists a0. eapply IHL. econs. reflexivity. }
      { econs. i. exists a0. eapply IHR. econs. reflexivity. }
    Qed.

    Lemma add_assoc o0 o1 o2
      :
      Ord.eq (add (add o0 o1) o2) (add o0 (add o1 o2)).
    Proof.
      revert o0 o1 o2.
      cut (forall o0 o1o2, (fun o0 o1o2 => (add (add o0 (fst o1o2)) (snd o1o2) == add o0 (add (fst o1o2) (snd o1o2)))%ord) o0 o1o2).
      { i. eapply (H o0 (o1, o2)). }
      eapply (double_well_founded_induction Ord.lt_well_founded (double_rel_well_founded Ord.lt_well_founded Ord.lt_well_founded)).
      intros o0 [o1 o2] IH0 IH12. ss.
      assert (IH1: forall o (LT: (o < o1)%ord), (add (add o0 o) o2 == add o0 (add o o2))%ord).
      { i. eapply (IH12 (o, o2)). left. auto. }
      assert (IH2: forall o (LT: (o < o2)%ord), (add (add o0 o1) o == add o0 (add o1 o))%ord).
      { i. eapply (IH12 (o1, o)). right. auto. }
      clear IH12. destruct o0, o1, o2.
      rewrite add_red. rewrite add_red.
      rewrite Ord.union_build. rewrite Ord.union_build.
      rewrite add_red. rewrite add_red.
      rewrite Ord.union_build. rewrite Ord.union_build. split.
      { econs.
        { i. destruct a0 as [|[]].
          { exists (inl (inl a)). ss. rewrite <- IH2.
            { rewrite add_red. rewrite Ord.union_build. reflexivity. }
            { econs. reflexivity. }
          }
          { exists (inl (inr a)). ss.
            eapply IH1. econs. reflexivity. }
          { exists (inr a). ss. rewrite IH0.
            { rewrite add_red. rewrite Ord.union_build. reflexivity. }
            { econs. reflexivity. }
          }
        }
      }
      { econs.
        { i. destruct a0 as [[]|].
          { exists (inl a). ss. rewrite <- IH2.
            { rewrite add_red. rewrite Ord.union_build. reflexivity. }
            { econs. reflexivity. }
          }
          { exists (inr (inl a)). ss.
            eapply IH1. econs. reflexivity. }
          { exists (inr (inr a)). ss. rewrite IH0.
            { rewrite add_red. rewrite Ord.union_build. reflexivity. }
            { econs. reflexivity. }
          }
        }
      }
    Qed.

    Lemma add_base_l o0 o1
      :
      Ord.le o0 (add o0 o1).
    Proof.
      revert o1. pattern o0. revert o0.
      eapply (well_founded_induction Ord.lt_well_founded).
      i. destruct x. eapply Ord.build_supremum. i.
      eapply Ord.le_lt_lt.
      { eapply H. econs. reflexivity. }
      { eapply lt_add_l. econs. reflexivity. }
    Qed.

    Lemma add_base_r o0 o1
      :
      Ord.le o1 (add o0 o1).
    Proof.
      rewrite add_comm. eapply add_base_l.
    Qed.

    Lemma arith_add_larger o0 o1
      :
      Ord.le (OrdArith.add o0 o1) (add o0 o1).
    Proof.
      revert o0. pattern o1. revert o1.
      eapply (well_founded_induction Ord.lt_well_founded).
      i. destruct x. rewrite OrdArith.add_build. eapply Ord.union_spec.
      { eapply add_base_l. }
      { eapply Ord.join_supremum. i. eapply Ord.S_supremum.
        eapply Ord.le_lt_lt.
        { eapply H. econs. reflexivity. }
        { eapply lt_add_r. econs. reflexivity. }
      }
    Qed.

    Lemma add_O_r o
      :
      Ord.eq (add o Ord.O) o.
    Proof.
      pattern o. revert o. eapply (well_founded_induction Ord.lt_well_founded).
      intros o IH. split.
      { eapply add_spec.
        { i. rewrite IH; auto. }
        { i. exfalso. eapply Ord.lt_StrictOrder. eapply Ord.lt_le_lt.
          { eapply LT. }
          { eapply Ord.O_bot. }
        }
      }
      { eapply add_base_l. }
    Qed.

    Lemma add_O_l o
      :
      Ord.eq (add Ord.O o) o.
    Proof.
      rewrite add_comm. eapply add_O_r.
    Qed.

    Lemma add_S_r o0 o1
      :
      Ord.eq (add o0 (Ord.S o1)) (Ord.S (add o0 o1)).
    Proof.
      revert o1. pattern o0. revert o0.
      eapply (well_founded_induction Ord.lt_well_founded). i.
      split.
      { eapply add_spec.
        { i. rewrite H; auto. eapply Ord.lt_S. eapply lt_add_l; auto. }
        { i. eapply Ord.le_lt_lt; [|eapply Ord.S_lt].
          eapply Ord.S_supremum in LT. eapply le_add_r.
          eapply Ord.le_S_rev; auto.
        }
      }
      { eapply Ord.S_supremum. eapply lt_add_r. eapply Ord.S_lt. }
    Qed.

    Lemma add_S_l o0 o1
      :
      Ord.eq (add (Ord.S o0) o1) (Ord.S (add o0 o1)).
    Proof.
      rewrite add_comm. rewrite add_S_r. rewrite add_comm. reflexivity.
    Qed.

    Lemma arith_add_from_nat o (n: nat)
      :
      Ord.eq (add o n) (OrdArith.add o n).
    Proof.
      revert o. induction n; i.
      { rewrite Ord.from_nat_O.
        rewrite add_O_r. rewrite OrdArith.add_O_r. reflexivity.
      }
      { rewrite Ord.from_nat_S.
        rewrite add_S_r. rewrite OrdArith.add_S. rewrite IHn. reflexivity.
      }
    Qed.

    Lemma add_from_nat n0 n1:
      Ord.eq (n0 + n1) (add (Ord.from_nat n0) (Ord.from_nat n1)).
    Proof.
      induction n1; ss.
      { rewrite PeanoNat.Nat.add_0_r.
        symmetry. eapply add_O_r. }
      { rewrite PeanoNat.Nat.add_succ_r.
        rewrite Ord.from_nat_S.
        rewrite Ord.from_nat_S.
        rewrite add_S_r.
        eapply Ord.eq_S. auto.
      }
    Qed.

    Lemma add_lt_l o0 o1 (LT: Ord.lt Ord.O o1): Ord.lt o0 (add o0 o1).
    Proof.
      eapply Ord.lt_le_lt.
      2:{ eapply arith_add_larger. }
      eapply OrdArith.add_lt_l. auto.
    Qed.

    Lemma add_lt_r o0 o1 (LT: Ord.lt Ord.O o0): Ord.lt o1 (add o0 o1).
    Proof.
      rewrite add_comm. apply add_lt_l; auto.
    Qed.
  End ADD.
End Hessenberg.

Global Opaque Hessenberg.add.

Infix "⊕" := Hessenberg.add (at level 80, right associativity) : ord_scope.

(* following: *)
(* https://arxiv.org/pdf/1501.05747.pdf *)
(* (INTERMEDIATE ARITHMETIC OPERATIONS ON ORDINAL NUMBERS - HARRY ALTMAN) *)
Module Jacobsthal.
  Section MULT.
    Definition mult (o0: Ord.t): forall (o1: Ord.t), Ord.t := Ord.orec Ord.O (Hessenberg.add o0).

    Let _mult_gen_le := Hessenberg.add_base_r.
    Let _mult_gen_mon := Hessenberg.le_add_r.

    Lemma arith_mult_larger o0 o1
      :
      Ord.le (OrdArith.mult o0 o1) (mult o0 o1).
    Proof.
      Local Transparent OrdArith.mult.
      eapply Ord.orec_mon.
      { reflexivity. }
      { i. rewrite LE. rewrite Hessenberg.add_comm.
        eapply Hessenberg.arith_add_larger.
      }
    Qed.

    Lemma mult_O_r o: Ord.eq (mult o Ord.O) Ord.O.
    Proof.
      eapply (@Ord.orec_O Ord.O (Hessenberg.add o)); auto.
    Qed.

    Lemma mult_S o0 o1: Ord.eq (mult o0 (Ord.S o1)) (Hessenberg.add o0 (mult o0 o1)).
    Proof.
      eapply (@Ord.orec_S Ord.O (Hessenberg.add o0)); auto.
    Qed.

    Lemma mult_join o A (os: A -> Ord.t):
      Ord.eq (mult o (Ord.join os)) (Ord.join (fun a => mult o (os a))).
    Proof.
      transitivity (Ord.union Ord.O (Ord.join (fun a => mult o (os a)))).
      { eapply (@Ord.orec_join Ord.O (Hessenberg.add _)); eauto. }
      { eapply Ord.union_max. eapply Ord.O_bot. }
    Qed.

    Lemma mult_build o A (os: A -> Ord.t)
      :
      Ord.eq (mult o (Ord.build os)) (Ord.join (fun a => Hessenberg.add o (mult o (os a)))).
    Proof.
      transitivity (Ord.union Ord.O (Ord.join (fun a => Hessenberg.add o (mult o (os a))))).
      { eapply (@Ord.orec_build Ord.O (Hessenberg.add _)); eauto. }
      { eapply Ord.union_max. eapply Ord.O_bot. }
     Qed.

    Lemma mult_union o0 o1 o2
      :
      Ord.eq (mult o0 (Ord.union o1 o2)) (Ord.union (mult o0 o1) (mult o0 o2)).
    Proof.
      eapply Ord.orec_union; auto.
    Qed.

    Lemma le_mult_r o0 o1 o2 (LE: Ord.le o1 o2)
      :
      Ord.le (mult o0 o1) (mult o0 o2).
    Proof.
      eapply Ord.le_orec; auto.
    Qed.

    Lemma eq_mult_r o0 o1 o2 (EQ: Ord.eq o1 o2)
      :
      Ord.eq (mult o0 o1) (mult o0 o2).
    Proof.
      split.
      - eapply le_mult_r; eauto. eapply EQ.
      - eapply le_mult_r; eauto. eapply EQ.
    Qed.

    Lemma le_mult_l o0 o1 o2 (LE: Ord.le o0 o1)
      :
      Ord.le (mult o0 o2) (mult o1 o2).
    Proof.
      eapply (@Ord.orec_mon Ord.O (Hessenberg.add o0) Ord.O (Hessenberg.add o1)); auto.
      { reflexivity. }
      { i. transitivity (Hessenberg.add o0 o4).
        { eapply Hessenberg.le_add_r; auto. }
        { eapply Hessenberg.le_add_l; auto. }
      }
    Qed.

    Lemma eq_mult_l o0 o1 o2 (EQ: Ord.eq o0 o1)
      :
      Ord.eq (mult o0 o2) (mult o1 o2).
    Proof.
      split.
      - eapply le_mult_l; eauto. eapply EQ.
      - eapply le_mult_l; eauto. eapply EQ.
    Qed.

    Lemma lt_mult_r o0 o1 o2 (LT: Ord.lt o1 o2) (POS: Ord.lt Ord.O o0)
      :
      Ord.lt (mult o0 o1) (mult o0 o2).
    Proof.
      eapply Ord.S_supremum in LT.
      eapply Ord.lt_le_lt.
      2: { eapply le_mult_r. eapply LT. }
      eapply Ord.lt_eq_lt.
      { eapply mult_S. }
      eapply Hessenberg.add_lt_r. auto.
    Qed.

    Lemma mult_O_l o: Ord.eq (mult Ord.O o) Ord.O.
    Proof.
      induction o. etransitivity.
      { eapply mult_build. }
      { split.
        - eapply Ord.join_supremum. i.
          transitivity (mult Ord.O (os a)); auto.
          { eapply Hessenberg.add_O_l. }
          { eapply H. }
        - eapply Ord.O_bot. }
    Qed.

    Lemma mult_1_r o: Ord.eq (mult o (Ord.S Ord.O)) o.
    Proof.
      etransitivity.
      { eapply mult_S. }
      etransitivity.
      { eapply Hessenberg.eq_add_r. eapply mult_O_r. }
      eapply Hessenberg.add_O_r.
    Qed.

    Lemma mult_1_l o: Ord.eq (mult (Ord.S Ord.O) o) o.
    Proof.
      transitivity (Ord.orec Ord.O Ord.S o).
      2: { symmetry. eapply Ord.orec_of_S. }
      split.
      { eapply Ord.orec_mon.
        { reflexivity. }
        { i. etransitivity.
          { eapply Hessenberg.add_S_l. }
          { apply Ord.le_S. transitivity o0; auto.
            eapply Hessenberg.add_O_l.
          }
        }
      }
      { eapply Ord.orec_mon.
        { reflexivity. }
        { i. etransitivity.
          { apply Ord.le_S. eapply LE. }
          transitivity (Ord.S (Hessenberg.add Ord.O o1)); auto.
          { apply Ord.le_S. eapply Hessenberg.add_O_l. }
          { eapply Hessenberg.add_S_l. }
        }
      }
    Qed.

    Global Program Instance mult_eq_proper: Proper (Ord.eq ==> Ord.eq ==> Ord.eq) (mult).
    Next Obligation.
      ii.
      etransitivity.
      - eapply eq_mult_l; eauto.
      - eapply eq_mult_r; eauto.
    Qed.

    Global Program Instance add_le_proper: Proper (Ord.le ==> Ord.le ==> Ord.le) (mult).
    Next Obligation.
      ii.
      etransitivity.
      - eapply le_mult_l; eauto.
      - eapply le_mult_r; eauto.
    Qed.

    Lemma mult_from_nat n0 n1:
      Ord.eq (n0 * n1) (mult (Ord.from_nat n0) (Ord.from_nat n1)).
    Proof.
      induction n1; ss.
      { rewrite PeanoNat.Nat.mul_0_r.
        symmetry. eapply mult_O_r. }
      { rewrite PeanoNat.Nat.mul_succ_r.
        rewrite Ord.from_nat_S.
        rewrite mult_S.
        rewrite Hessenberg.add_from_nat.
        rewrite Hessenberg.add_comm. rewrite IHn1. reflexivity.
      }
    Qed.
  End MULT.
End Jacobsthal.

Global Opaque Jacobsthal.mult.

Infix "×" := Jacobsthal.mult (at level 80, right associativity) : ord_scope.


Require Import init.

Require Export linear_grade.
Require Import linear_transformation_space.

Require Import set.
Require Import unordered_list.

(* begin hide *)
Section LinearExtend.

Context {U V1 V2} `{
    UP : Plus U,
    UZ : Zero U,
    UN : Neg U,
    @PlusComm U UP,
    @PlusLid U UP UZ,
    @PlusLinv U UP UZ UN,
    UM : Mult U,
    UO : One U,
    @MultAssoc U UM,
    @MultLid U UM UO,

    VP1 : Plus V1,
    VZ1 : Zero V1,
    VN1 : Neg V1,
    VPC1 : @PlusComm V1 VP1,
    VPA1 : @PlusAssoc V1 VP1,
    VPZ1 : @PlusLid V1 VP1 VZ1,
    @PlusLinv V1 VP1 VZ1 VN1,

    SM1 : ScalarMult U V1,
    @ScalarId U V1 UO SM1,
    @ScalarLdist U V1 VP1 SM1,
    @ScalarRdist U V1 UP VP1 SM1,
    @ScalarComp U V1 UM SM1,

    VP2 : Plus V2,
    VZ2 : Zero V2,
    VN2 : Neg V2,
    VPC2 : @PlusComm V2 VP2,
    VPA2 : @PlusAssoc V2 VP2,
    @PlusLid V2 VP2 VZ2,
    @PlusLinv V2 VP2 VZ2 VN2,

    SM2 : ScalarMult U V2,
    @ScalarId U V2 UO SM2,
    @ScalarLdist U V2 VP2 SM2,
    @ScalarRdist U V2 UP VP2 SM2,
    @ScalarComp U V2 UM SM2
}.

Context `{VG : @GradedSpace U V1 VP1 VPC1 VPA1 VZ1 VPZ1 SM1}.

(* end hide *)
Definition linear_extend_plus_base (f_base : ∀ i a, of_grade i a → V2) :=
    ∀ (u v : V1) (i : grade_I) (H1 : of_grade i u) (H2 : of_grade i v),
    f_base i (u + v) (of_grade_plus u v i H1 H2) =
    f_base i u H1 + f_base i v H2.
Definition linear_extend_scalar_base (f_base : ∀ i a, of_grade i a → V2) :=
    ∀ a v i (H : of_grade i v),
    f_base i (a · v) (of_grade_scalar a v i H) = a · f_base i v H.

Variable f_base : ∀ i a, of_grade i a → V2.
Variable f_plus_base' : linear_extend_plus_base f_base.
Variable f_scalar_base' : linear_extend_scalar_base f_base.

(* begin hide *)
Lemma linear_extend_base_eq : ∀ i u v H1 H2,
    u = v → f_base i u H1 = f_base i v H2.
Proof.
    intros i u v iu iv uv.
    subst v.
    rewrite (proof_irrelevance iu iv).
    reflexivity.
Qed.

Theorem f_scalar_base : ∀ i a v H1 H2, f_base i (a · v) H1 = a · f_base i v H2.
Proof.
    intros i a v avi vi.
    pose proof (f_scalar_base' a v i vi) as eq.
    rewrite (proof_irrelevance _ avi) in eq.
    exact eq.
Qed.

Theorem linear_extend_zero_base : ∀ i H, f_base i 0 H = 0.
Proof.
    intros i i0.
    pose proof (scalar_lanni 0).
    pose proof i0 as i0'.
    rewrite <- (scalar_lanni 0) in i0'.
    pose proof (f_scalar_base i _ _ i0' i0) as eq.
    rewrite scalar_lanni in eq.
    rewrite <- eq.
    apply linear_extend_base_eq.
    rewrite scalar_lanni.
    reflexivity.
Qed.

Theorem f_plus_base : ∀ i u v H1 H2 H3,
    f_base i (u + v) H1 = f_base i u H2 + f_base i v H3.
Proof.
    intros i u v uvi ui vi.
    pose proof (f_plus_base' u v i ui vi) as eq.
    rewrite (proof_irrelevance _ uvi) in eq.
    exact eq.
Qed.

(* end hide *)
Definition linear_extend (v : V1) :=
    ulist_sum (ulist_image
        (λ x, f_base (ex_val [|x]) [x|] (ex_proof [|x])) (grade_decomposition v)).

Let f := linear_extend.

Theorem linear_extend_zero : f 0 = 0.
Proof.
    unfold f, linear_extend.
    rewrite grade_decomposition_zero.
    rewrite ulist_image_end.
    apply ulist_sum_end.
Qed.

Theorem linear_extend_plus : ∀ u v, f (u + v) = f u + f v.
Proof.
    intros u.
    induction u as [|a u i ai ui IHu] using grade_induction; intros.
    1: {
        rewrite linear_extend_zero.
        do 2 rewrite plus_lid.
        reflexivity.
    }
    rewrite (plus_comm a u).
    rewrite <- plus_assoc.
    do 2 rewrite IHu.
    rewrite <- plus_assoc.
    apply lplus.
    clear u ui IHu.
    classic_case (0 = a) as [a_z|a_nz].
    1: {
        subst a.
        rewrite linear_extend_zero.
        do 2 rewrite plus_lid.
        reflexivity.
    }
    unfold f, linear_extend.
    assert (homogeneous a) as a_homo by (exists i; exact ai).
    assert (ex_val a_homo = i) as i_homo.
    {
        apply (of_grade_unique _ _ _ a_nz).
        -   exact (ex_proof a_homo).
        -   exact ai.
    }
    rewrite (grade_decomposition_homo [a|a_homo] a_nz).
    rewrite ulist_image_add, ulist_sum_add.
    rewrite ulist_image_end, ulist_sum_end, plus_rid.
    classic_case (0 = grade_project v i) as [vi_z|vi_nz].
    -   assert (grade_decomposition (a + v) =
            [a|a_homo] ː grade_decomposition v) as eq.
        {
            apply grade_decomposition_unique.
            -   rewrite ulist_image_add, ulist_sum_add.
                apply lplus.
                apply grade_decomposition_eq.
            -   rewrite ulist_image_add, ulist_unique_add.
                split; [>|apply grade_decomposition_uni].
                intros contr.
                apply image_in_ulist in contr as [a' [a_eq a'_in]].
                cbn in a_eq.
                pose proof (in_grade_decomposition_project _ _ a'_in)
                    as [i' i'_eq].
                assert (i = i') as eq.
                {
                    apply (of_grade_unique [a'|]).
                    -   apply (in_grade_decomposition_nz v).
                        exact a'_in.
                    -   rewrite <- i_homo.
                        rewrite <- a_eq.
                        exact (ex_proof [|a']).
                    -   rewrite i'_eq.
                        apply grade_project_grade.
                }
                subst i'.
                rewrite <- i'_eq in vi_z.
                apply in_grade_decomposition_nz in a'_in.
                contradiction.
            -   rewrite ulist_prop_add; split.
                +   exact a_nz.
                +   apply grade_decomposition_nz.
        }
        rewrite eq.
        rewrite ulist_image_add, ulist_sum_add.
        reflexivity.
    -   pose proof (grade_project_in _ _ vi_nz) as vi_in.
        apply in_ulist_split in vi_in as [l l_eq].
        rewrite l_eq.
        cbn.
        unfold ex_val at 2, ex_proof at 2.
        destruct (ex_to_type _) as [i' ai']; cbn.
        assert (i = i').
        {
            apply (of_grade_unique _ _ _ a_nz); assumption.
        }
        subst i'.
        classic_case (0 = a + grade_project v i) as [b_z|b_nz].
        +   assert (grade_decomposition (a + v) = l) as eq.
            {
                apply grade_decomposition_unique.
                -   rewrite (grade_decomposition_eq v).
                    rewrite l_eq.
                    rewrite ulist_image_add, ulist_sum_add; cbn.
                    rewrite plus_assoc.
                    rewrite <- b_z.
                    apply plus_lid.
                -   pose proof (grade_decomposition_uni v) as v_uni.
                    rewrite l_eq in v_uni.
                    rewrite ulist_image_add, ulist_unique_add in v_uni.
                    apply v_uni.
                -   pose proof (grade_decomposition_nz v) as v_nz.
                    rewrite l_eq in v_nz.
                    rewrite ulist_prop_add in v_nz.
                    apply v_nz.
            }
            rewrite eq.
            rewrite ulist_image_add, ulist_sum_add.
            rewrite plus_assoc.
            cbn.
            unfold ex_val at 2, ex_proof at 2.
            destruct (ex_to_type _) as [i' vi']; cbn.
            assert (i = i').
            {
                apply (of_grade_unique _ _ _ vi_nz).
                -   apply grade_project_grade.
                -   exact vi'.
            }
            subst i'.
            rewrite <- (f_plus_base _ _ _ (of_grade_plus _ _ _ ai' vi')).
            replace (f_base i (a + grade_project v i) _) with
                (f_base i 0 (of_grade_zero i)).
            2: apply linear_extend_base_eq; exact b_z.
            rewrite linear_extend_zero_base.
            rewrite plus_lid.
            reflexivity.
        +   assert (homogeneous (a + grade_project v i)) as b_homo.
            {
                exists i.
                apply of_grade_plus.
                -   exact ai.
                -   apply grade_project_grade.
            }
            assert (grade_decomposition (a + v) = [_|b_homo] ː l) as eq.
            {
                apply grade_decomposition_unique.
                -   rewrite ulist_image_add, ulist_sum_add; cbn.
                    rewrite (grade_decomposition_eq v) at 1.
                    rewrite l_eq.
                    rewrite ulist_image_add, ulist_sum_add; cbn.
                    apply plus_assoc.
                -   rewrite ulist_image_add, ulist_unique_add; cbn.
                    split.
                    +   intros contr.
                        pose proof (grade_decomposition_uni v) as v_uni.
                        rewrite l_eq in v_uni.
                        rewrite ulist_image_add, ulist_unique_add in v_uni.
                        apply (land v_uni); cbn.
                        assert (ex_val (grade_project_homo v i) = ex_val b_homo)
                            as eq.
                        {
                            rewrite_ex_val i1 i1_eq.
                            rewrite_ex_val i2 i2_eq.
                            apply (of_grade_unique (a + grade_project v i)).
                            -   exact b_nz.
                            -   apply of_grade_plus; [>|exact i1_eq].
                                assert (i = i1) as eq.
                                {
                                    apply (of_grade_unique _ _ _ vi_nz).
                                    -   apply grade_project_grade.
                                    -   exact i1_eq.
                                }
                                subst i1.
                                exact ai.
                            -   exact i2_eq.
                        }
                        rewrite eq.
                        exact contr.
                    +   pose proof (grade_decomposition_uni v) as v_uni.
                        rewrite l_eq in v_uni.
                        rewrite ulist_image_add, ulist_unique_add in v_uni.
                        apply v_uni.
                -   rewrite ulist_prop_add.
                    split; [>exact b_nz|].
                    pose proof (grade_decomposition_nz v) as v_nz.
                    rewrite l_eq in v_nz.
                    rewrite ulist_prop_add in v_nz.
                    apply v_nz.
            }
            rewrite eq.
            do 2 rewrite ulist_image_add, ulist_sum_add.
            rewrite plus_assoc.
            apply rplus.
            cbn.
            unfold ex_val at 2, ex_proof at 2.
            destruct (ex_to_type _) as [i' vi']; cbn.
            assert (i = i').
            {
                apply (of_grade_unique _ _ _ vi_nz).
                -   apply grade_project_grade.
                -   exact vi'.
            }
            subst i'.
            rewrite <- (f_plus_base _ _ _ (of_grade_plus _ _ _ ai' vi')).
            unfold ex_val, ex_proof.
            destruct (ex_to_type _) as [i' bi']; cbn.
            assert (i = i').
            {
                apply (of_grade_unique _ _ _ b_nz).
                -   apply of_grade_plus; assumption.
                -   exact bi'.
            }
            subst i'.
            apply linear_extend_base_eq.
            reflexivity.
Qed.

Theorem linear_extend_scalar : ∀ a v, f (a · v) = a · f v.
Proof.
    intros a v.
    induction v as [|u v i ui vi IHv] using grade_induction.
    1: {
        rewrite scalar_ranni.
        rewrite linear_extend_zero.
        rewrite scalar_ranni.
        reflexivity.
    }
    rewrite scalar_ldist.
    do 2 rewrite linear_extend_plus.
    rewrite scalar_ldist.
    rewrite IHv.
    apply rplus.
    clear v vi IHv.
    classic_case (0 = u) as [u_z|u_nz].
    1: {
        subst u.
        rewrite linear_extend_zero.
        do 2 rewrite scalar_ranni.
        apply linear_extend_zero.
    }
    unfold f, linear_extend.
    rewrite (grade_decomposition_of_grade u i u_nz ui).
    rewrite ulist_image_add, ulist_sum_add.
    rewrite ulist_image_end, ulist_sum_end, plus_rid.
    cbn.
    unfold ex_val, ex_proof.
    destruct (ex_to_type _) as [i' ui']; cbn.
    assert (i = i').
    {
        apply (of_grade_unique _ _ _ u_nz); assumption.
    }
    subst i'.
    rewrite <- (f_scalar_base _ _ _ (of_grade_scalar a _ _ ui')).
    classic_case (0 = a · u) as [au_z|au_nz].
    1: {
        rewrite <- au_z at 1.
        rewrite grade_decomposition_zero.
        rewrite ulist_image_end, ulist_sum_end.
        rewrite <- (linear_extend_zero_base i (of_grade_zero i)).
        apply linear_extend_base_eq.
        exact au_z.
    }
    pose proof (homo_scalar a u (ex_intro _ i ui)) as au_homo.
    rewrite (grade_decomposition_homo [_|au_homo] au_nz).
    rewrite ulist_image_add, ulist_sum_add.
    rewrite ulist_image_end, ulist_sum_end.
    cbn.
    rewrite plus_rid.
    destruct (ex_to_type _) as [i' aui']; cbn.
    assert (i = i').
    {
        apply (of_grade_unique _ _ _ au_nz).
        -   apply of_grade_scalar.
            exact ui.
        -   exact aui'.
    }
    subst i'.
    apply linear_extend_base_eq.
    reflexivity.
Qed.

Theorem linear_extend_homo : ∀ i v H, f v = f_base i v H.
Proof.
    intros i v iv; cbn.
    unfold f, linear_extend.
    classic_case (0 = v) as [v_z|v_nz].
    -   subst v.
        rewrite grade_decomposition_zero.
        rewrite ulist_image_end, ulist_sum_end.
        symmetry; apply linear_extend_zero_base.
    -   assert (homogeneous v) as v_homo by (exists i; exact iv).
        change v with [[v|v_homo]|] at 1.
        rewrite grade_decomposition_homo by exact v_nz.
        rewrite ulist_image_add, ulist_sum_add.
        rewrite ulist_image_end, ulist_sum_end.
        cbn.
        rewrite plus_rid.
        unfold ex_val, ex_proof.
        destruct (ex_to_type v_homo) as [i' vi']; cbn.
        assert (i = i').
        {
            apply (of_grade_unique _ _ _ v_nz); assumption.
        }
        subst i'.
        apply linear_extend_base_eq.
        reflexivity.
Qed.

(* begin hide *)
End LinearExtend.

Section BilinearExtend.

Context {U V1 V2} `{
    UP : Plus U,
    UZ : Zero U,
    UN : Neg U,
    @PlusComm U UP,
    @PlusLid U UP UZ,
    @PlusLinv U UP UZ UN,
    UM : Mult U,
    UO : One U,
    @MultAssoc U UM,
    @MultLid U UM UO,

    VP1 : Plus V1,
    VZ1 : Zero V1,
    VN1 : Neg V1,
    VPC1 : @PlusComm V1 VP1,
    VPA1 : @PlusAssoc V1 VP1,
    VPZ1 : @PlusLid V1 VP1 VZ1,
    @PlusLinv V1 VP1 VZ1 VN1,

    SM1 : ScalarMult U V1,
    @ScalarId U V1 UO SM1,
    @ScalarLdist U V1 VP1 SM1,
    @ScalarRdist U V1 UP VP1 SM1,
    @ScalarComp U V1 UM SM1,

    VP2 : Plus V2,
    VZ2 : Zero V2,
    VN2 : Neg V2,
    VPC2 : @PlusComm V2 VP2,
    VPA2 : @PlusAssoc V2 VP2,
    @PlusLid V2 VP2 VZ2,
    @PlusLinv V2 VP2 VZ2 VN2,

    SM2 : ScalarMult U V2,
    @ScalarId U V2 UO SM2,
    @ScalarLdist U V2 VP2 SM2,
    @ScalarRdist U V2 UP VP2 SM2,
    @ScalarComp U V2 UM SM2
}.

Context `{VG : @GradedSpace U V1 VP1 VPC1 VPA1 VZ1 VPZ1 SM1}.

(* end hide *)
Definition bilinear_extend_ldist_base
    (op : ∀ i j a b, of_grade i a → of_grade j b → V2) :=
    ∀ u v w i j (H1 : of_grade i u) (H2 : of_grade j v) (H3 : of_grade j w),
    op i j u (v + w) H1 (of_grade_plus v w j H2 H3) =
    op i j u v H1 H2 + op i j u w H1 H3.
Definition bilinear_extend_rdist_base
    (op : ∀ i j a b, of_grade i a → of_grade j b → V2) :=
    ∀ u v w i j (H1 : of_grade i u) (H2 : of_grade i v) (H3: of_grade j w),
    op i j (u + v) w (of_grade_plus u v i H1 H2) H3 =
    op i j u w H1 H3 + op i j v w H2 H3.
Definition bilinear_extend_lscalar_base
    (op : ∀ i j a b, of_grade i a → of_grade j b → V2) :=
    ∀ a u v i j (H1 : of_grade i u) (H2 : of_grade j v),
    op i j (a · u) v (of_grade_scalar a u i H1) H2 = a · op i j u v H1 H2.
Definition bilinear_extend_rscalar_base
    (op : ∀ i j a b, of_grade i a → of_grade j b → V2) :=
    ∀ a u v i j (H1 : of_grade i u) (H2 : of_grade j v),
    op i j u (a · v) H1 (of_grade_scalar a v j H2) = a · op i j u v H1 H2.

Variable op : ∀ i j a b, of_grade i a → of_grade j b → V2.

Variable op_ldist' : bilinear_extend_ldist_base op.
Variable op_rdist' : bilinear_extend_rdist_base op.
Variable op_lscalar' : bilinear_extend_lscalar_base op.
Variable op_rscalar' : bilinear_extend_rscalar_base op.

(* begin hide *)
Lemma bilinear_extend_base_leq : ∀ i j u v w H1 H2 H3,
    u = v → op i j u w H1 H3 = op i j v w H2 H3.
Proof.
    intros i j u v w iu iv jw eq.
    subst v.
    rewrite (proof_irrelevance iu iv).
    reflexivity.
Qed.

Lemma bilinear_extend_base_req : ∀ i j u v w H1 H2 H3,
    v = w → op i j u v H1 H2 = op i j u w H1 H3.
Proof.
    intros i j u v w iu jv jw eq.
    subst v.
    rewrite (proof_irrelevance jv jw).
    reflexivity.
Qed.

Lemma op_ldist : ∀ i j u v w H1 H2 H3 H4,
    op i j u (v + w) H1 H2 = op i j u v H1 H3 + op i j u w H1 H4.
Proof.
    intros i j u v w iu jvw jv jw.
    rewrite <- op_ldist'.
    rewrite (proof_irrelevance (of_grade_plus _ _ _ _ _) jvw).
    reflexivity.
Qed.

Lemma op_rdist : ∀ i j u v w H1 H2 H3 H4,
    op i j (u + v) w H1 H2 = op i j u w H3 H2 + op i j v w H4 H2.
Proof.
    intros i j u v w iuv jw iu iv.
    rewrite <- op_rdist'.
    rewrite (proof_irrelevance (of_grade_plus _ _ _ _ _) iuv).
    reflexivity.
Qed.

Lemma op_lscalar : ∀ i j a u v H1 H2 H3,
    op i j (a · u) v H1 H3 = a · op i j u v H2 H3.
Proof.
    intros i j a u v iau iu jv.
    rewrite <- op_lscalar'.
    rewrite (proof_irrelevance (of_grade_scalar _ _ _ _) iau).
    reflexivity.
Qed.

Lemma op_rscalar : ∀ i j a u v H1 H2 H3,
    op i j u (a · v) H1 H2 = a · op i j u v H1 H3.
Proof.
    intros i j a u v iu jav jv.
    rewrite <- op_rscalar'.
    rewrite (proof_irrelevance (of_grade_scalar _ _ _ _) jav).
    reflexivity.
Qed.

Lemma bilinear_extend_lanni_base : ∀ i j v H1 H2, op i j 0 v H1 H2 = 0.
Proof.
    intros i j v i0 jv.
    pose (op' i u H1 j v H2 := op j i v u H2 H1).
    change (op i j 0 v i0 jv) with (op' j v jv i 0 i0).
    apply linear_extend_zero_base.
    unfold op'.
    clear i i0 op'.
    unfold linear_extend_scalar_base.
    intros a u i iu.
    apply op_lscalar.
Qed.

Lemma bilinear_extend_ranni_base : ∀ i j v H1 H2, op i j v 0 H1 H2 = 0.
Proof.
    intros i j v iv j0.
    pose (op' i u H1 j v H2 := op i j u v H1 H2).
    change (op i j v 0 iv j0) with (op' i v iv j 0 j0).
    apply linear_extend_zero_base.
    clear j j0.
    unfold linear_extend_scalar_base, op'.
    intros a u j vj.
    apply op_rscalar.
Qed.

Section BilinearBase.

Context i a (ia : of_grade i a).

Let f1_base := λ j v jv, op i j a v ia jv.

Lemma bilinear_extend_base_plus : linear_extend_plus_base f1_base.
Proof.
    intros u v j ju jv.
    unfold f1_base.
    apply op_ldist.
Qed.

Lemma bilinear_extend_base_scalar : linear_extend_scalar_base f1_base.
Proof.
    intros α v j jv.
    unfold f1_base.
    apply op_rscalar.
Qed.

Definition bilinear_extend_base := linear_extend f1_base.

End BilinearBase.

Let TP := linear_func_plus V1 V2.
Let TZ := linear_func_zero V1 V2.
Let TN := linear_func_neg V1 V2.
Let TPC := linear_func_plus_comm V1 V2.
Let TPA := linear_func_plus_assoc V1 V2.
Let TPZ := linear_func_plus_lid V1 V2.
Let TPN := linear_func_plus_linv V1 V2.
Let TSM := linear_func_scalar V1 V2.
Let TSMO := linear_func_scalar_id V1 V2.
Let TSML := linear_func_scalar_ldist V1 V2.
Let TSMR := linear_func_scalar_rdist V1 V2.
Let TSMC := linear_func_scalar_comp V1 V2.
Local Existing Instances TP TZ TN TPC TPA TPZ TPN TSM TSMO TSML TSMR TSMC.

Let f_base := bilinear_extend_base.

Lemma bilinear_extend_plus_base : linear_extend_plus_base f_base.
Proof.
    intros u v i iu iv.
    unfold f_base, bilinear_extend_base.
    apply functional_ext.
    intros x.
    unfold plus at 2; cbn.
    unfold linear_extend.
    remember (grade_decomposition x) as l.
    clear Heql x.
    induction l using ulist_induction.
    1: {
        do 3 rewrite ulist_image_end.
        rewrite ulist_sum_end.
        rewrite plus_rid.
        reflexivity.
    }
    do 3 rewrite ulist_image_add, ulist_sum_add.
    rewrite IHl.
    do 2 rewrite plus_assoc.
    apply rplus.
    rewrite <- plus_assoc.
    rewrite (plus_comm _ (op _ _ v _ _ _)).
    rewrite plus_assoc.
    apply rplus.
    clear IHl l.
    apply op_rdist.
Qed.

Lemma bilinear_extend_scalar_base : linear_extend_scalar_base f_base.
Proof.
    intros a v i vi.
    unfold f_base, bilinear_extend_base.
    apply functional_ext.
    intros x.
    unfold scalar_mult at 2; cbn.
    unfold linear_extend.
    remember (grade_decomposition x) as l.
    clear Heql x.
    induction l using ulist_induction.
    1: {
        do 2 rewrite ulist_image_end.
        rewrite ulist_sum_end.
        rewrite scalar_ranni.
        reflexivity.
    }
    do 2 rewrite ulist_image_add, ulist_sum_add.
    rewrite IHl.
    rewrite scalar_ldist.
    apply rplus.
    apply op_lscalar.
Qed.

(* end hide *)
Definition bilinear_extend := linear_extend f_base.
Let f := bilinear_extend.

Theorem bilinear_extend_ldist : ∀ u v w, f u (v + w) = f u v + f u w.
Proof.
    intros u v w.
    unfold f, bilinear_extend.
    unfold linear_extend.
    remember (grade_decomposition u) as l.
    clear Heql.
    induction l using ulist_induction.
    1: {
        rewrite ulist_image_end, ulist_sum_end.
        unfold zero; cbn.
        rewrite plus_lid.
        reflexivity.
    }
    rewrite ulist_image_add, ulist_sum_add.
    unfold plus at 1 4 5; cbn.
    rewrite IHl; clear IHl.
    do 2 rewrite plus_assoc.
    apply rplus.
    rewrite <- plus_assoc.
    rewrite (plus_comm _ (f_base _ [a|] _ _)).
    rewrite plus_assoc.
    apply rplus.
    clear l u.
    unfold f_base, bilinear_extend_base.
    apply linear_extend_plus.
    -   unfold linear_extend_plus_base; apply bilinear_extend_base_plus.
    -   unfold linear_extend_scalar_base; apply bilinear_extend_base_scalar.
Qed.

Theorem bilinear_extend_rdist : ∀ u v w, f (u + v) w = f u w + f v w.
Proof.
    intros u v w.
    unfold f, bilinear_extend.
    rewrite linear_extend_plus.
    -   reflexivity.
    -   unfold linear_extend_plus_base; apply bilinear_extend_plus_base.
    -   unfold linear_extend_scalar_base; apply bilinear_extend_scalar_base.
Qed.

Theorem bilinear_extend_lscalar : ∀ a u v, f (a · u) v = a · f u v.
Proof.
    intros a u v.
    unfold f, bilinear_extend.
    rewrite linear_extend_scalar.
    -   reflexivity.
    -   unfold linear_extend_plus_base; apply bilinear_extend_plus_base.
    -   unfold linear_extend_scalar_base; apply bilinear_extend_scalar_base.
Qed.

Theorem bilinear_extend_rscalar : ∀ a u v, f u (a · v) = a · f u v.
Proof.
    intros a u v.
    unfold f, bilinear_extend, linear_extend.
    remember (grade_decomposition u) as l.
    clear Heql u.
    induction l using ulist_induction.
    1: {
        rewrite ulist_image_end, ulist_sum_end.
        unfold zero; cbn.
        rewrite scalar_ranni.
        reflexivity.
    }
    rewrite ulist_image_add, ulist_sum_add.
    unfold plus at 1 2; cbn.
    rewrite IHl; clear IHl.
    rewrite scalar_ldist.
    apply rplus.
    (* This makes a huge speed difference for some reason *)
    unfold f_base, bilinear_extend_base.
    apply linear_extend_scalar.
    -   unfold linear_extend_plus_base; apply bilinear_extend_base_plus.
    -   unfold linear_extend_scalar_base; apply bilinear_extend_base_scalar.
Qed.
Theorem bilinear_extend_lanni : ∀ v, f 0 v = 0.
Proof.
    intros v.
    rewrite <- (scalar_lanni 0).
    rewrite bilinear_extend_lscalar.
    apply scalar_lanni.
Qed.

Theorem bilinear_extend_ranni : ∀ v, f v 0 = 0.
Proof.
    intros v.
    rewrite <- (scalar_lanni 0).
    rewrite bilinear_extend_rscalar.
    apply scalar_lanni.
Qed.

Theorem bilinear_extend_homo : ∀ i j u v H1 H2, f u v = op i j u v H1 H2.
Proof.
    intros i j u v iu jv.
    classic_case (0 = u) as [u_z|u_nz].
    2: classic_case (0 = v) as [v_z|v_nz].
    -   subst u.
        rewrite bilinear_extend_lanni_base.
        apply bilinear_extend_lanni.
    -   subst v.
        rewrite bilinear_extend_ranni_base.
        apply bilinear_extend_ranni.
    -   unfold f.
        unfold bilinear_extend.
        rewrite (linear_extend_homo f_base bilinear_extend_scalar_base _ _ iu).
        unfold f_base.
        unfold bilinear_extend_base.
        pose proof (linear_extend_homo (λ j v jv, op i j u v iu jv)) as eq.
        prove_parts eq.
        1: apply bilinear_extend_base_scalar.
        apply (eq _ _ jv).
Qed.
(* begin hide *)

End BilinearExtend.
(* end hide *)


Require Export Containers.OrderedTypeEx SetoidList.
Require Export Morphisms.

(** This file defines the interface of typeclass-based
   finite multisets, also called finite bags *)

(** * Pointwise-equality for multisets

   We define pointwise equality for any structure with a membership
   predicate [In : elt -> container -> Prop], and prove it is an
   equivalence relation. This is required for the sets' interface.
   *)
Section MEqual.
  Variable container : Type.
  Variable elt : Type.
  Variable Mult : elt -> container -> nat.
  Definition MEqual_pw (s s' : container) : Prop :=
    forall a : elt, Mult a s = Mult a s'.
  Program Definition MEqual_pw_Equivalence : Equivalence MEqual_pw :=
    Build_Equivalence _ _ _ _ _.
  Next Obligation.
    constructor; auto.
  Qed.
  Next Obligation.
    firstorder.
  Qed.
  Next Obligation.
    repeat intro; rewrite H. apply H0.
  Qed.
End MEqual.
Hint Unfold MEqual_pw.

(** * [FBag] : the interface of bags

   We define the class [FBag] of structures that implement finite
   bags. An instance of [FBag] for an ordered type [A] contains the
   type [bag A] of sets of elements of type [A]. It also contains all
   the operations that these sets support : insertion, membership,
   etc. The specifications of these operations are in a different
   class (see below).
   *)
Class FBag `{OrderedType A} := {
  (** The container type *)
  bag : Type;

  (** The specification of all bag operations is done
     with respect to the multiplicity function. *)
  Mult : A -> bag -> nat;

  (** Bag Operations  *)
  empty : bag;
  is_empty : bag -> bool;
  mem : A -> bag -> bool;

  add : A -> bag -> bag;
  singleton : A -> bag;
  remove : A -> bag -> bag;
  union : bag -> bag -> bag;
  inter : bag -> bag -> bag;
  diff : bag -> bag -> bag;

  equal : bag -> bag -> bool;
  subbag : bag -> bag -> bool;

  fold : forall {B : Type}, (A -> nat -> B -> B) -> bag -> B -> B;
  for_all : (A -> bool) -> bag -> bool;
  exists_ : (A -> bool) -> bag -> bool;
  filter : (A -> bool) -> bag -> bag;
  partition : (A -> bool) -> bag -> bag * bag;

  cardinal : bag -> nat;
  elements : bag -> list (A * nat);
  choose :  bag -> option A;
  min_elt :  bag -> option A;
  max_elt :  bag -> option A;

  (** Bags should be ordered types as well, in order to be able *)
  (*  to use bags in containers. *)
  FBag_OrderedType :>
    SpecificOrderedType _ (MEqual_pw bag A Mult) (MEqual_pw_Equivalence _ _ _)
}.
Implicit Arguments bag [[H] [FBag]].

(** Bag notations (see below) are interpreted in scope [bag_scope],
   delimited with key [scope]. We bind it to the type [bag] and to
   other operations defined in the interface. *)
Delimit Scope bag_scope with bag.
Bind Scope bag_scope with bag.
Arguments Scope In [type_scope _ _ _ bag_scope].
Arguments Scope Mult [type_scope _ _ _ bag_scope].
Arguments Scope is_empty [type_scope _ _ bag_scope].
Arguments Scope mem [type_scope _ _ _ bag_scope].
Arguments Scope add [type_scope _ _ _ bag_scope].
Arguments Scope remove [type_scope _ _ _ bag_scope].
Arguments Scope union [type_scope _ _ bag_scope bag_scope].
Arguments Scope inter [type_scope _ _ bag_scope bag_scope].
Arguments Scope diff [type_scope _ _ bag_scope bag_scope].
Arguments Scope equal [type_scope _ _ bag_scope bag_scope].
Arguments Scope subbag [type_scope _ _ bag_scope bag_scope].
Arguments Scope fold [type_scope _ _ _ _ bag_scope _].
Arguments Scope for_all [type_scope _ _ _ _ bag_scope].
Arguments Scope exists_ [type_scope _ _ _ _ bag_scope].
Arguments Scope filter [type_scope _ _ _ _ bag_scope].
Arguments Scope partition [type_scope _ _ _ _ bag_scope].
Arguments Scope cardinal [type_scope _ _ bag_scope].
Arguments Scope elements [type_scope _ _ bag_scope].
Arguments Scope choose [type_scope _ _ bag_scope].
Arguments Scope min_elt [type_scope _ _ bag_scope].
Arguments Scope max_elt [type_scope _ _ bag_scope].

(** All projections should be made opaque for tactics using [delta]-conversion,
   otherwise the underlying instances may appear during proofs, which then
   causes several problems (notations not being used, unification failures...).
   This doesnt stop computation with [compute] or [vm_compute] though, which is
   exactly what we want.
*)
Global Opaque
  bag In empty is_empty mem add singleton remove
  union inter diff equal subbag fold
  for_all exists_ filter partition cardinal elements choose
  FBag_OrderedType.

(** There follow definitions of predicates about bags expressable
   in terms of [Mult], and which are not provided by the [FBag] class. *)
Definition In `{FBag elt} a s :=
  exists n, Mult a s = S n.
Definition Equal `{FBag elt} s s' :=
  forall a : elt, Mult a s = Mult a s'.
Definition Subbag `{FBag elt} s s' :=
  forall a : elt, Mult a s <= Mult a s'.
Definition Empty `{FBag elt} s :=
  forall a : elt, ~ In a s.
Definition MEmpty `{FBag elt} s :=
  forall a : elt, Mult a s = 0.
Definition For_all `{FBag elt} (P : elt -> Prop) s :=
  forall x, In x s -> P x.
Definition Exists `{FBag elt} (P : elt -> Prop) s :=
  exists x, In x s /\ P x.

(** We also define a couple of notations for bag-related operations.
   These notations can be used to avoid ambiguity when dealing
   simultaneously with operations on lists and bags that have
   similar names ([mem], [In], ...). *)
Notation "s [=] t" := (Equal s t) (at level 70, no associativity) : bag_scope.
Notation "s [<=] t" := (Subbag s t) (at level 70, no associativity) : bag_scope.
Notation "v '\In' S" := (In v S)(at level 70, no associativity) : bag_scope.
Notation "v # S" := (Mult v S)(at level 70, no associativity) : bag_scope.

Notation "'{||}'" := (empty)(at level 0, no associativity) : bag_scope.
Notation "'{|' v '|}'" := (singleton v) : bag_scope.
Notation "'{|' v ';' S '|}'" := (add v S)(v at level 99) : bag_scope.
Notation "'{|' S '~' v '|}'" := (remove v S)(S at level 99) : bag_scope.
Notation "v '\in' S" := (mem v S)(at level 70, no associativity) : bag_scope.
Notation "S '++' T" := (union S T) : bag_scope.
Notation "S '\' T" := (diff S T) (at level 60, no associativity) : bag_scope.

Set Implicit Arguments.
Unset Strict Implicit.

(** * [FBagSpecs] : finite bags' specification

   We provide the specifications of bag operations in a separate class
   [FBagSpecs] parameterized by an [FBag] instance.
   *)
Class FBagSpecs_Mult `(FBag A) := {
  Mult_1 : forall s (x y : A), x === y -> Mult x s = Mult y s
(*   In_1 : forall s (x y : A), x === y -> In x s -> In y s *)
}.
Class FBagSpecs_mem `(FBag A) := {
  mem_1 : forall s x, In x s -> mem x s = true;
  mem_2 : forall s x, mem x s = true -> In x s
}.
Class FBagSpecs_equal `(FBag A) := {
  equal_1 : forall s s', Equal s s' -> equal s s' = true;
  equal_2 : forall s s',  equal s s' = true -> Equal s s'
}.
Class FBagSpecs_subbag `(FBag A) := {
  subbag_1 : forall s s', Subbag s s' -> subbag s s' = true;
  subbag_2 : forall s s', subbag s s' = true -> Subbag s s'
}.
Class FBagSpecs_empty `(FBag A) := {
  empty_1 : MEmpty empty
}.
Class FBagSpecs_is_empty `(FBag A) := {
  is_empty_1 : forall s, MEmpty s -> is_empty s = true;
  is_empty_2 : forall s, is_empty s = true -> MEmpty s
}.
Class FBagSpecs_add `(FBag A) := {
  add_mult : forall s (x y : A), Mult x (add y s) =
    if x == y then S (Mult x s) else Mult x s
(*   add_1 : forall s (x y : A), x === y -> In y (add x s); *)
(*   add_2 : forall s x y, In y s -> In y (add x s); *)
(*   add_3 : forall s (x y : A), x =/= y -> In y (add x s) -> In y s *)
}.
Class FBagSpecs_remove `(FBag A) := {
  remove_mult : forall s (x y : A), Mult x (remove y s) =
    if x == y then pred (Mult x s) else Mult x s
(*   remove_1 : forall s (x y : A), x === y -> ~ In y (remove x s); *)
(*   remove_2 : forall s (x y : A), *)
(*     x =/= y -> In y s -> In y (remove x s); *)
(*   remove_3 : forall s x y, In y (remove x s) -> In y s *)
}.
Class FBagSpecs_singleton `(FBag A) := {
  singleton_mult : forall s (x y : A), Mult x s =
    if x == y then 1 else 0
(*   singleton_1 : forall (x y : A), In y (singleton x) -> x === y; *)
(*   singleton_2 : forall (x y : A), x === y -> In y (singleton x) *)
}.
Class FBagSpecs_union `(FBag A) := {
  union_mult : forall s s' x, Mult x (union s s') = Mult x s + Mult x s'
(*   union_1 : forall s s' x, *)
(*     In x (union s s') -> In x s \/ In x s'; *)
(*   union_2 : forall s s' x, In x s -> In x (union s s'); *)
(*   union_3 : forall s s' x, In x s' -> In x (union s s') *)
}.
Require Import Min.
Class FBagSpecs_inter `(FBag A) := {
  inter_mult : forall s s' x, Mult x (inter s s') = min (Mult x s) (Mult x s')
(*   inter_1 : forall s s' x, In x (inter s s') -> In x s; *)
(*   inter_2 : forall s s' x, In x (inter s s') -> In x s'; *)
(*   inter_3 : forall s s' x, *)
(*     In x s -> In x s' -> In x (inter s s') *)
}.
Class FBagSpecs_diff `(FBag A) := {
  diff_mult : forall s s' x, Mult x (diff s s') = Mult x s - Mult x s'
(*   diff_1 : forall s s' x, In x (diff s s') -> In x s; *)
(*   diff_2 : forall s s' x, In x (diff s s') -> ~ In x s'; *)
(*   diff_3 : forall s s' x, *)
(*     In x s -> ~ In x s' -> In x (diff s s') *)
}.
Class FBagSpecs_fold `(FBag A) := {
  fold_1 : forall s (B : Type) (i : B) (f : A -> nat -> B -> B),
      fold f s i = fold_left (fun a en => f (fst en) (snd en) a) (elements s) i
}.
Class FBagSpecs_cardinal `(FBag A) := {
  cardinal_1 : forall s, cardinal s = length (elements s)
}.
Class FBagSpecs_filter `(FBag A) := {
  filter_mult_1 : forall s x f `{Morphism _ (_eq ==> @eq bool) f},
    In x (filter f s) -> Mult x (filter f s) = Mult x s;
  filter_mult_2 : forall s x f `{Morphism _ (_eq ==> @eq bool) f},
    In x (filter f s) -> f x = true;
  filter_mult_3 : forall s x f `{Morphism _ (_eq ==> @eq bool) f},
    f x = true -> Mult x s = Mult x (filter f s)
(*   filter_1 : forall s x f `{Morphism _ (_eq ==> @eq bool) f}, *)
(*     In x (filter f s) -> In x s; *)
(*   filter_2 : forall s x f `{Morphism _ (_eq ==> @eq bool) f}, *)
(*     In x (filter f s) -> f x = true; *)
(*   filter_3 : forall s x f `{Morphism _ (_eq ==> @eq bool) f}, *)
(*     In x s -> f x = true -> In x (filter f s) *)
}.
Class FBagSpecs_for_all `(FBag A) := {
  for_all_1 : forall s f `{Morphism _ (_eq ==> @eq bool) f},
    For_all (fun x => f x = true) s -> for_all f s = true;
  for_all_2 : forall s f `{Morphism _ (_eq ==> @eq bool) f},
    for_all f s = true -> For_all (fun x => f x = true) s
}.
Class FBagSpecs_exists `(FBag A) := {
  exists_1 : forall s f `{Morphism _ (_eq ==> @eq bool) f},
    Exists (fun x => f x = true) s -> exists_ f s = true;
  exists_2 : forall s f `{Morphism _ (_eq ==> @eq bool) f},
    exists_ f s = true -> Exists (fun x => f x = true) s
}.
Class FBagSpecs_partition `(FBag A) := {
  partition_1 : forall s f `{Morphism _ (_eq ==> @eq bool) f},
    Equal (fst (partition f s)) (filter f s);
  partition_2 : forall s f `{Morphism _ (_eq ==> @eq bool) f},
    Equal (snd (partition f s)) (filter (fun x => negb (f x)) s)
}.
Class FBagSpecs_elements `(FBag A) := {
  elements_1 : forall s x, In x s -> InA _eq (x, Mult x s) (elements s);
  elements_2 : forall s x n, InA _eq (x, n) (elements s) -> Mult x s =  n;
  elements_3 : forall s, sort _lt (elements s);
  elements_3w : forall s, NoDupA _eq (elements s)
}.
Class FBagSpecs_choose `(FBag A) := {
  choose_1 : forall s x, choose s = Some x -> In x s;
  choose_2 : forall s, choose s = None -> Empty s;
  choose_3 : forall s s' x y,
    choose s = Some x -> choose s' = Some y -> Equal s s' -> x === y
}.
Class FBagSpecs_min_elt `(FBag A) := {
  min_elt_1 : forall s x, min_elt s = Some x -> In x s;
  min_elt_2 : forall s x y,
    min_elt s = Some x -> In y s -> ~ y <<< x;
  min_elt_3 : forall s, min_elt s = None -> Empty s
}.
Class FBagSpecs_max_elt `(FBag A) := {
  max_elt_1 : forall s x, max_elt s = Some x -> In x s;
  max_elt_2 : forall s x y,
    max_elt s = Some x -> In y s -> ~ x <<< y;
  max_elt_3 : forall s, max_elt s = None -> Empty s
}.

Class FBagSpecs `(F : FBag A) := {
  FFBagSpecs_Mult :> FBagSpecs_Mult F;
  FFBagSpecs_mem :> FBagSpecs_mem F;
  FFBagSpecs_equal :> FBagSpecs_equal F;
  FFBagSpecs_subbag :> FBagSpecs_subbag F;
  FFBagSpecs_empty :> FBagSpecs_empty F;
  FFBagSpecs_is_empty :> FBagSpecs_is_empty F;
  FFBagSpecs_add :> FBagSpecs_add F;
  FFBagSpecs_remove :> FBagSpecs_remove F;
  FFBagSpecs_singleton :> FBagSpecs_singleton F;
  FFBagSpecs_union :> FBagSpecs_union F;
  FFBagSpecs_inter :> FBagSpecs_inter F;
  FFBagSpecs_diff :> FBagSpecs_diff F;
  FFBagSpecs_fold :> FBagSpecs_fold F;
  FFBagSpecs_cardinal :> FBagSpecs_cardinal F;
  FFBagSpecs_filter :> FBagSpecs_filter F;
  FFBagSpecs_for_all :> FBagSpecs_for_all F;
  FFBagSpecs_exists :> FBagSpecs_exists F;
  FFBagSpecs_partition :> FBagSpecs_partition F;
  FFBagSpecs_elements :> FBagSpecs_elements F;
  FFBagSpecs_choose :> FBagSpecs_choose F;
  FFBagSpecs_min_elt :> FBagSpecs_min_elt F;
  FFBagSpecs_max_elt :> FBagSpecs_max_elt F
}.
(* About FBagSpecs. *)

(* Because of a bug (or limitation, depending on your leniency)
   of interaction between hints and implicit typeclasses parameters
   we define aliases to add as hints. *)
Definition zmem_1 `{H : @FBagSpecs A HA F} :=
  @mem_1 _ _ _ (@FFBagSpecs_mem _ _ _ H).
Definition zequal_1 `{H : @FBagSpecs A HA F} :=
  @equal_1 _ _ _ (@FFBagSpecs_equal _ _ _ H).
Definition zsubbag_1 `{H : @FBagSpecs A HA F} :=
  @subbag_1 _ _ _ (@FFBagSpecs_subbag _ _ _ H).
Definition zempty_1 `{H : @FBagSpecs A HA F} :=
  @empty_1 _ _ _ (@FFBagSpecs_empty _ _ _ H).
Definition zis_empty_1 `{H : @FBagSpecs A HA F} :=
  @is_empty_1 _ _ _ (@FFBagSpecs_is_empty _ _ _ H).
Definition zchoose_1 `{H : @FBagSpecs A HA F} :=
  @choose_1 _ _ _ (@FFBagSpecs_choose _ _ _ H).
Definition zchoose_2 `{H : @FBagSpecs A HA F} :=
  @choose_2 _ _ _ (@FFBagSpecs_choose _ _ _ H).
Definition zadd_mult `{H : @FBagSpecs A HA F} :=
  @add_mult _ _ _ (@FFBagSpecs_add _ _ _ H).
Definition zremove_mult `{H : @FBagSpecs A HA F} :=
  @remove_mult _ _ _ (@FFBagSpecs_remove _ _ _ H).
Definition zsingleton_mult `{H : @FBagSpecs A HA F} :=
  @singleton_mult _ _ _ (@FFBagSpecs_singleton _ _ _ H).
Definition zunion_mult `{H : @FBagSpecs A HA F} :=
  @union_mult _ _ _ (@FFBagSpecs_union _ _ _ H).
Definition zinter_mult `{H : @FBagSpecs A HA F} :=
  @inter_mult _ _ _ (@FFBagSpecs_inter _ _ _ H).
Definition zdiff_mult `{H : @FBagSpecs A HA F} :=
  @diff_mult _ _ _ (@FFBagSpecs_diff _ _ _ H).
Definition zfold_1 `{H : @FBagSpecs A HA F} :=
  @fold_1 _ _ _ (@FFBagSpecs_fold _ _ _ H).
Definition zfilter_mult_3 `{H : @FBagSpecs A HA F} :=
  @filter_mult_3 _ _ _ (@FFBagSpecs_filter _ _ _ H).
Definition zfor_all_1 `{H : @FBagSpecs A HA F} :=
  @for_all_1 _ _ _ (@FFBagSpecs_for_all _ _ _ H).
Definition zexists_1 `{H : @FBagSpecs A HA F} :=
  @exists_1 _ _ _ (@FFBagSpecs_exists _ _ _ H).
Definition zpartition_1 `{H : @FBagSpecs A HA F} :=
  @partition_1 _ _ _ (@FFBagSpecs_partition _ _ _ H).
Definition zpartition_2 `{H : @FBagSpecs A HA F} :=
  @partition_2 _ _ _ (@FFBagSpecs_partition _ _ _ H).
Definition zelements_1 `{H : @FBagSpecs A HA F} :=
  @elements_1 _ _ _ (@FFBagSpecs_elements _ _ _ H).
Definition zelements_3w `{H : @FBagSpecs A HA F} :=
  @elements_3w _ _ _ (@FFBagSpecs_elements _ _ _ H).
Definition zelements_3 `{H : @FBagSpecs A HA F} :=
  @elements_3 _ _ _ (@FFBagSpecs_elements _ _ _ H).

Definition zMult_1 `{H : @FBagSpecs A HA F} :=
  @Mult_1 _ _ _ (@FFBagSpecs_Mult _ _ _ H).
Definition zmem_2 `{H : @FBagSpecs A HA F} :=
  @mem_2 _ _ _ (@FFBagSpecs_mem _ _ _ H).
Definition zequal_2 `{H : @FBagSpecs A HA F} :=
  @equal_2 _ _ _ (@FFBagSpecs_equal _ _ _ H).
Definition zsubbag_2 `{H : @FBagSpecs A HA F} :=
  @subbag_2 _ _ _ (@FFBagSpecs_subbag _ _ _ H).
Definition zis_empty_2 `{H : @FBagSpecs A HA F} :=
  @is_empty_2 _ _ _ (@FFBagSpecs_is_empty _ _ _ H).
Definition zfor_all_2 `{H : @FBagSpecs A HA F} :=
  @for_all_2 _ _ _ (@FFBagSpecs_for_all _ _ _ H).
Definition zexists_2 `{H : @FBagSpecs A HA F} :=
  @exists_2 _ _ _ (@FFBagSpecs_exists _ _ _ H).
Definition zelements_2 `{H : @FBagSpecs A HA F} :=
  @elements_2 _ _ _ (@FFBagSpecs_elements _ _ _ H).
Definition zmin_elt_1 `{H : @FBagSpecs A HA F} :=
  @min_elt_1 _ _ _ (@FFBagSpecs_min_elt _ _ _ H).
Definition zmin_elt_2 `{H : @FBagSpecs A HA F} :=
  @min_elt_2 _ _ _ (@FFBagSpecs_min_elt _ _ _ H).
Definition zmin_elt_3 `{H : @FBagSpecs A HA F} :=
  @min_elt_3 _ _ _ (@FFBagSpecs_min_elt _ _ _ H).
Definition zmax_elt_1 `{H : @FBagSpecs A HA F} :=
  @max_elt_1 _ _ _ (@FFBagSpecs_max_elt _ _ _ H).
Definition zmax_elt_2 `{H : @FBagSpecs A HA F} :=
  @max_elt_2 _ _ _ (@FFBagSpecs_max_elt _ _ _ H).
Definition zmax_elt_3 `{H : @FBagSpecs A HA F} :=
  @max_elt_3 _ _ _ (@FFBagSpecs_max_elt _ _ _ H).

Hint Resolve @zmem_1 @zequal_1 @zsubbag_1 @zempty_1
  @zis_empty_1 @zchoose_1 @zchoose_2 @zadd_mult @zremove_mult
  @zsingleton_mult @zunion_mult @zinter_mult @zdiff_mult
  @zfold_1 @zfilter_mult_3 @zfor_all_1 @zexists_1
    @zpartition_1 @zpartition_2 @zelements_1 @zelements_3w @zelements_3
    : bag.
Hint Immediate @zMult_1 @zmem_2 @zequal_2 @zsubbag_2 @zis_empty_2
  @zfor_all_2 @zexists_2 @zelements_2
  @zmin_elt_1 @zmin_elt_2 @zmin_elt_3 @zmax_elt_1 @zmax_elt_2 @zmax_elt_3
  : bag.
Typeclasses Opaque bag.


Require Import Coq.Strings.Ascii.

Require Import Hapsl.Ascii.Equality.

Import AsciiEqualityNotations.

(* Returns true if a given ASCII character is lower case, otherwise returns
   false. *)
Definition is_lower (c : ascii) : bool :=
  (c >=_a "a") && (c <=_a "z").

(* Returns true if a given ASCII character is upper case, otherwise returns
   false. *)
Definition is_upper (c : ascii) : bool :=
  (c >=_a "A") && (c <=_a "Z").

(* Returns true if a given ASCII character is a digit, otherwise returns
   false. *)
Definition is_digit (c : ascii) : bool :=
  (c >=_a "0") && (c <=_a "9").

(* Returns true if a given ASCII character is neither a digit, upper case letter
   nor lower case letter. Otherwise returns false. *)
Definition is_other (c : ascii) : bool :=
  negb ((is_lower c) || (is_upper c) || (is_digit c)).

(* Returns true if two given ASCII characters belong to the same character
   class, otherwise returns false. *)
Definition is_same_class (c1 c2 : ascii) : bool :=
  ((is_lower c1) && (is_lower c2))
  || ((is_upper c1) && (is_upper c2))
  || ((is_digit c1) && (is_digit c2))
  || ((is_other c1) && (is_other c2)).

(* Converts an upper case ASCII characer to lower case. For any other character
   returns it unchanged. *)
Definition to_lower (c : ascii) : ascii :=
  let n := nat_of_ascii c in
    if is_upper c then
      ascii_of_nat (n + 32)
    else
      c.

(* Converts a lower case ASCII character to upper case. For any other character
   returns it unchanged. *)
Definition to_upper (c : ascii) : ascii :=
  let n := nat_of_ascii c in
    if is_lower c then
      ascii_of_nat (n - 32)
    else
      c.