diff --git a/config/tests.config b/config/tests.config index a5762df7d9..e9feff8472 100644 --- a/config/tests.config +++ b/config/tests.config @@ -14,4 +14,11 @@ exclude = examples/MEE-CBC examples/old examples/old/list-ddh !examples/incomple okdirs = examples/MEE-CBC [test-unit] -okdirs = tests tests/exception +okdirs = !tests +exclude = tests/tc-ko tests/exception !tests/require_test + +[test-exception] +okdirs = tests/exception + +[test-tc-ko] +kodirs = !tests/tc-ko diff --git a/doc/typeclasses-inference.md b/doc/typeclasses-inference.md new file mode 100644 index 0000000000..0c641d3f76 --- /dev/null +++ b/doc/typeclasses-inference.md @@ -0,0 +1,202 @@ +# Typeclass inference — design + +Companion to [typeclasses.md](typeclasses.md). Covers what the unifier +does when it encounters a `\`TcCtt(uid, ty, tc)` problem, why the current +single-axis approach is insufficient for multi-parameter typeclasses, +and the strategy framework that resolves this. + +--- + +## Background — `\`TcCtt` problems + +Whenever the typer needs a typeclass witness, it generates a problem of +the form + +``` +TcCtt (uid, ty, tc) +``` + +meaning "find a witness for `ty : tc`, and bind it to the witness +univar `uid`". The unifier's job is to either resolve `uid` to a +concrete `tcwitness` or report failure. + +Three things vary: + +1. **`ty`** — the carrier. Can be ground (`int`), abstract (`Tvar a`, + `Tconstr abs_p _`), or a univar (`Tunivar u`). +2. **`tc.tc_args`** — the type-class's auxiliary type parameters, for + parametric typeclasses like `('a, 'b) embed`. Each can be ground or + contain univars. +3. **The environment** — `tvtc` for `Tvar` carriers, the typeclass + declaration for `Tconstr abs_p`, and the instance database for + ground carriers. + +The current resolver is in `ecUnify.ml`, in the `\`TcCtt` arm of +`unify_core`. + +## Catalog of inference modes + +Every TcCtt problem falls into one of these shapes. Each row says what +information the resolver has and what it should produce. + +| # | Carrier `ty` | `tc.args` | Status today | Resolver action | +|----|---------------------------|--------------------------|---------------------------|----------------------------------------------------------------| +| 1 | ground | ground | works | `EcTypeClass.infer env ty tc` → `TCIConcrete` | +| 2 | ground | partly univar | partly works | `infer` already pattern-matches instance args, fills univars | +| 3 | univar | ground | **fails** (parks forever) | walk instances, find unique match by `tc.args`, unify carrier | +| 4 | univar | partly univar | parks | wait — too underdetermined to infer either side | +| 5 | `Tvar a`, `a ∈ tvtc` | any | works | walk `tvtc[a]`'s ancestors, return `TCIAbstract { Var a; .. }` | +| 6 | `Tconstr abs_p _` | any | works | walk decl's `tcs`, return `TCIAbstract { Abs abs_p; .. }` | +| 7 | ground tuple/fun | any | upstream rejects instance | (n/a) — but `subst_tcw` has a latent `assert false` | +| 8 | `Tvar a`, `a ∉ tvtc` | any | failure | error: "unconstrained type variable" | + +Modes #1, #2, #5, #6 are covered. Mode #3 is the bare-op gap. Modes #4 +and #7 are deferred (#4 has no inference to do; #7 is upstream). + +A future row would add *e.g.*: + +| ? | `Fapp` carrier (HO) | any | not designed | escape hatch / explicit tvi | + +## Why the current resolver doesn't cover Mode #3 + +The resolver's flow: + +``` +if TyUni.Suid.is_empty deps then + (* Mode #1, #2, #5, #6 *) + resolve and bind uid +else + (* Mode #3, #4 *) + for each univar in deps, register uid in byunivar map + wait for the univar to resolve +``` + +When `ty = Tunivar u`, `deps = {u}`. The resolver parks the problem. +It re-fires only when `u` is bound by some other equation. For Mode #3 +there is no such equation — the carrier's only constraint is the +typeclass itself. + +The fix is to attempt **forward inference** in this case: if `tc.args` +are ground and exactly one instance of `tc` matches, bind `u` to its +`tci_type`. + +## Strategy framework (Phase 2) + +Replace the single big `\`TcCtt` arm with a list of strategies. Each +strategy is: + +```ocaml +type tcw_strategy = { + name : string; + applicable : tcenv -> tcuni -> ty -> typeclass -> bool; + apply : EcEnv.env -> ucore -> tcuni -> ty -> typeclass + -> ucore * tcw_result; + triggers : tcw_trigger list; +} + +and tcw_result = + | Resolved of tcwitness + | Stuck (* park, retry on triggers *) + | Failed of failure_reason + | NoSuchInstance + +and tcw_trigger = + | OnUnivarResolved of tyuni (* re-fire when this tyuni binds *) + | OnTcUniResolved of tcuni (* re-fire when this tcuni binds *) +``` + +The dispatcher iterates strategies in priority order, stops on the +first non-`Stuck` result. + +Today's resolver becomes a list of strategies: + +| Priority | Strategy | Mode | +|----------|--------------------|------| +| 1 | `tvar_via_tvtc` | #5 | +| 2 | `abs_via_decl` | #6 | +| 3 | `infer_by_carrier` | #1, #2 | +| 4 *new* | `infer_by_args` | #3 | +| 5 | `defer` | #4 | + +Behaviour with strategies 1-3 + 5 is identical to today's resolver; +adding strategy 4 closes Mode #3. + +The `triggers` field is what lets us avoid the current implicit +re-seeding (which today re-pushes every parked problem at the start of +every `unify_core` call). With explicit triggers we only re-fire what +the latest binding could have made progress on. This is performance +hygiene; not strictly required for correctness. + +## By-args strategy (Phase 3) + +``` +applicable(tcenv, uid, ty, tc): + ty is Tunivar u AND + tc.args contains no univars + +apply(env, uc, uid, ty, tc): + candidates = + [ inst | inst ∈ TcInstance.get_all env, + inst.tci_instance = `General (tgp, _), + tgp.tc_name = tc.tc_name, + etyargs_match env (List.fst inst.tci_params) + ~patterns:tgp.tc_args ~etyargs:tc.tc_args + succeeds with map M ] + + match candidates: + | [] -> NoSuchInstance + | [inst, M] -> let carrier = subst M inst.tci_type in + unify env uc ty carrier ; + Resolved (TCIConcrete { path = inst_path; + etyargs = subst M inst.tci_params; + lift = 0 }) + | _ :: _ :: _-> Stuck (* multiple matches; later info may decide *) +``` + +**Soundness:** we only commit when the match is unique. With multiple +matches we stay parked; if no further constraint disambiguates, the +final close-time check raises an "ambiguous TC instance" error +(distinguishable from "no instance" by carrying the candidate list). + +**Triggers:** none for now. The strategy is monotone — once a +candidate is excluded it stays excluded, since we only act when +`tc.args` are already ground. (Future: if `tc.args` start univar, +register `OnTcUniResolved` triggers.) + +**Risk surface:** +- A user's instance-DB shape can change ("which instances are visible") + via imports/cloning. The strategy must use whatever + `TcInstance.get_all` returns at the moment the strategy fires — + consistent with how current Mode #1 already works. +- Picking a non-canonical "exactly one" must be robust against import + order. `etyargs_match` is structural; we are safe. + +## Test matrix (Phase 3) + +``` +tests/tc/multi-param-bare-ops.ec + - bare op, unique instance → resolves + - two competing instances → "ambiguous TC instance" error + - args still univar at start, + resolved later by usage → eventually resolves (deferred) + - no matching instance → "no instance" error +``` + +Plus the existing `tests/tc/`, `theories/`, and `tests/` regression +sweeps to ensure single-parameter TC behaviour does not change. + +## Future work (Phase 4-5) + +- **Functional dependencies** in TC syntax: `class ('a, 'b) embed | 'a 'b -> embed` + declares the dependency explicitly. The By-args strategy is then + *justified by the declaration*, not by enumeration. Also enables + duplicate-instance detection at instance-binding time. + +- **Anticipated future rows in the catalog:** + - TC arg inference from operator bodies (axiom RHSs that mention TC ops). + - Inference through hypotheses introduced by `intros`. + - `Tglob` / module-type carriers. + - Coercion across same-named ops in different TCs. + +Each new gap follows the same recipe: add a row, add a test, add a +strategy, route diagnostics through the same `Failed` path. diff --git a/doc/typeclasses.md b/doc/typeclasses.md new file mode 100644 index 0000000000..7b15679c23 --- /dev/null +++ b/doc/typeclasses.md @@ -0,0 +1,328 @@ +# Typeclasses — current status + +Status snapshot of the typeclass implementation on the `deploy-tc` branch. +Every feature listed under "Implemented" is exercised by a test under +[`tests/tc/`](../tests/tc/); pointers given inline. + +--- + +## Implemented + +### 1. Declaration + +A typeclass declares a set of operators and axioms parameterised over a +single carrier type, optionally inheriting from a parent class: + +``` +type class addmonoid = { + op idm : addmonoid + op (+) : addmonoid -> addmonoid -> addmonoid + + axiom addmA : associative (+) + axiom addmC : commutative (+) + axiom add0m : left_id idm (+) +}. + +type class group <: addmonoid = { + op opp : group -> group + axiom addmN : forall (x : group), opp x + x = idm +}. +``` + +- The carrier is referenced by the typeclass name itself inside the body + (`addmonoid`, `group`). +- Operators in the body are abstract; a concrete instance must realise + them. +- Axioms must have all their type/typeclass variables bound; underconstrained + axioms (`axiom foo : zero = zero`, where the carrier is left free) are + rejected with a clear `axiom 'foo' is type-ambiguous` message. + ([tests/tc/grandparent-op.ec](../tests/tc/grandparent-op.ec)) +- Inheritance is by `<:`. Multiple ancestors form a chain via `tc_prt`. +- See: [tests/tc/basic.ec](../tests/tc/basic.ec), + [tests/tc/inheritance.ec](../tests/tc/inheritance.ec). + +### 2. Multi-parameter typeclasses + +A typeclass may take leading type parameters in addition to the carrier: + +``` +type class ['a, 'b] embed = { + op proj : embed -> 'a + op inj : 'b -> embed + axiom dummy : true +}. +``` + +The carrier is still `embed`; `'a` and `'b` are auxiliary type parameters +of the class. +See: [tests/tc/multi-param.ec](../tests/tc/multi-param.ec). + +### 3. Instances + +An `instance` declaration realises a typeclass at a specific type: + +``` +op zero_int : int = 0. +op plus_int : int -> int -> int = Int.( + ). + +instance addmonoid as int_inst with int + op idm = zero_int + op (+) = plus_int. + +realize addmA by rewrite /plus_int; smt(). +realize addmC by rewrite /plus_int; smt(). +realize add0m by rewrite /plus_int /zero_int; smt(). +``` + +For a multi-parameter typeclass, the leading parameters are bound +positionally: + +``` +instance (int, bool) embed as pair_inst with (int * bool) + op proj = proj_pair + op inj = inj_pair. + +realize dummy by trivial. +``` + +- The instance name (`as int_inst`) is optional; an auto-generated name + is used otherwise. +- Multiple named instances for the same typeclass at different carrier + types coexist. + ([tests/tc/multi-instance.ec](../tests/tc/multi-instance.ec)) +- Each axiom must be discharged via `realize`. + +### 4. Polymorphic ops and lemmas over typeclasses + +``` +op double ['a <: addmonoid] (x : 'a) : 'a = x + x. + +lemma idm_idem ['a <: addmonoid] (x : 'a) : idm + x = x. +proof. by apply add0m. qed. +``` + +Operators and lemmas can be parameterised by a type variable constrained +by a typeclass; they are usable at any type with a matching instance. + +A type-parameter can also be constrained by a parametric typeclass that +references earlier type-parameters: + +``` +lemma round_trip + ['a, 'b, 'c <: ('a, 'b) embed] + (x : 'a) (y : 'b) : + proj<:'a, 'b, 'c> (inj<:'a, 'b, 'c> y) = x => + proj<:'a, 'b, 'c> (inj<:'a, 'b, 'c> y) = x. +proof. by apply proj_inj. qed. +``` + +### 5. Instantiation at use sites + +Explicit positional instantiation: + +``` +apply (idm_idem<:int> 5). +``` + +When a tparam is constrained by a typeclass and the user-supplied type +does not satisfy it, the diagnostic is clear: + +``` +type int does not satisfy typeclass constraint addmonoid +``` + +(Formerly produced a confusing "int doesn't match int" unification +diff.) +See: [tests/tc/explicit-tvi.ec](../tests/tc/explicit-tvi.ec). + +When the constraint references earlier tparams (`'c <: ('a, 'b) embed`), +the user-supplied bindings for `'a, 'b` are substituted before the +instance lookup, so a multi-parameter `apply +(round_trip<:int, bool, (int * bool)>)` works. +See: [tests/tc/multi-param.ec](../tests/tc/multi-param.ec). + +### 6. Sections + +The `declare type t <: tc.` form abstracts a TC-constrained carrier +inside a section. Operators and lemmas using `t` survive section close +as TC-polymorphic forms: + +``` +section. + declare type t <: addmonoid. + + op double (x : t) : t = x + x. + + lemma double_idm : double idm = idm. + proof. by rewrite /double add0m. qed. +end section. + +(* After close: *) +op test ['a <: addmonoid] (x : 'a) : 'a = double x. +``` + +See: [tests/tc/section.ec](../tests/tc/section.ec), +[tests/tc/declare-type.ec](../tests/tc/declare-type.ec). + +### 7. Cloning abstract theories + +An abstract theory parametrised by a TC-constrained carrier can be +cloned with a concrete instance carrier; the substitution threads +through TC witnesses, and the cloned operators reduce via the matching +instance: + +``` +abstract theory T. + type t <: addmonoid. + op double (x : t) : t = x + x. +end T. + +clone T as TI with type t = int. + +(* TI.double zero_int reduces to plus_int zero_int zero_int. *) +``` + +See: [tests/tc/clone-with-instance.ec](../tests/tc/clone-with-instance.ec), +[tests/tc/clone.ec](../tests/tc/clone.ec). + +### 8. Reduction (`delta_tc`) + +The reduction info exposes a `delta_tc` flag. When set, TC operators +applied at concrete (non-abstract) carriers reduce to the corresponding +instance body. When the witness was substituted to `\`Abs ` +(e.g. via theory cloning), the reducer infers the matching instance +on-the-fly. + +### 9. SMT integration + +When `smt()` (or `smt(...)`) is called over a goal whose context contains +type parameters constrained by typeclasses, every axiom of those +typeclasses (and their ancestors, deduplicated) is automatically added +to the Why3 task. This means `smt()` (no hints) closes goals over +abstract carriers that previously required `smt(addmA addmC add0m ...)`. + +For concrete carriers, the `delta_tc` pre-reduction in the SMT init +collapses TC operators to their instance bodies before translation. + +See: [tests/tc/smt.ec](../tests/tc/smt.ec). + +### 10. Diamond and multi-level inheritance + +``` +type class base = { ... } +type class tc1 <: base = { ... } +type class tc2 <: base = { ... } +type class tc3 <: tc1 = { ... } +``` + +The ancestor walk reaches `base` from `tc3` (lift = 2) without +duplication. SMT auto-axiom inclusion deduplicates by axiom path. + +See: [tests/tc/diamond.ec](../tests/tc/diamond.ec). + +### 11. Pretty-printing + +`type t.` prints as `type t.` for unconstrained abstract types and as +`type t <: addmonoid.` when constrained. Empty etyarg/witness brackets +are elided: `int[int_inst]` instead of `int[int_inst[]]`, +`addmonoid` instead of `addmonoid[]`. The `<:tc>` suffix on operators +appears only when the witness is a non-trivial reference (univar +placeholders, abstract carriers, parametric instances). + +--- + +## Known limitations + +### Polymorphic-body bare ops on parametric-carrier typeclasses + +Inside a polymorphic body — say a lemma `['a, 'b, 'c <: ('a, 'b) embed] +... proj (inj y) ...` — bare ops still need explicit tvi +(`proj<:'a, 'b, 'c>`). The carrier is a type parameter, not a concrete +type, so the By-args strategy (which picks an instance from the +database) does not fire. At ground call sites the carrier is inferred +automatically; see [tests/tc/multi-param-bare-ops.ec](../tests/tc/multi-param-bare-ops.ec) +and [doc/typeclasses-inference.md](typeclasses-inference.md). + +### Tuple/function carriers in instance declarations + +Parser-side, `instance ... with (int * bool)` is accepted; the +resulting carrier type does flow through. But the upstream "carrier" +typing path does not currently accept declaring an instance directly on +a Tuple or Tfun type unless wrapped — see the `assert false` in +`subst_tcw` ([src/ecSubst.ml:226](../src/ecSubst.ml#L226)) which is +guarded behind an upstream rejection. This is a latent issue if upstream +loosens. + +### Reverse-rewrite of bare-metavariable lemmas + +A pattern like `rewrite -{1 2 3}mulrr` where `mulrr : forall x, x*x = x` +picks the first (largest) successful unification of `x`, which often +yields fewer occurrences than the user expects. Workaround: explicit +arg, `rewrite -{1 2 3}(mulrr (x + x))`. This is a pre-existing +matcher behaviour, not TC-specific (reproduces on `main` without +typeclasses); fix would touch the rewrite engine more broadly. + +--- + +## Examples in `examples/tcstdlib/` and `examples/typeclasses/` + +- [TcMonoid.ec](../examples/tcstdlib/TcMonoid.ec) — compiles cleanly. +- [TcRing.ec](../examples/tcstdlib/TcRing.ec) — compiles cleanly. +- [examples/typeclasses/monoidtc.ec](../examples/typeclasses/monoidtc.ec) + and + [examples/typeclasses/typeclass.ec](../examples/typeclasses/typeclass.ec) + — compile cleanly. + +--- + +## Files of interest + +| Concern | File | +|-------------------------------|-------------------------------| +| AST: `tcwitness`, etyargs | [src/ecAst.ml](../src/ecAst.ml) | +| Typeclass declarations | [src/ecScope.ml `add_class`](../src/ecScope.ml) | +| Instance declarations | [src/ecScope.ml `add_instance`](../src/ecScope.ml) | +| TC inference / ancestor walk | [src/ecTypeClass.ml](../src/ecTypeClass.ml) | +| Unifier `\`TcCtt` resolution | [src/ecUnify.ml](../src/ecUnify.ml) | +| Section close | [src/ecSection.ml `generalize_*`](../src/ecSection.ml) | +| Theory clone replay | [src/ecTheoryReplay.ml](../src/ecTheoryReplay.ml) | +| Reduction (`delta_tc`) | [src/ecReduction.ml](../src/ecReduction.ml) | +| SMT auto-axiom inclusion | [src/ecSmt.ml `trans_tc_axioms`](../src/ecSmt.ml) | +| Pretty-printing | [src/ecPrinting.ml](../src/ecPrinting.ml) | +| Tvi diagnostic | [src/ecProofTyping.ml `pf_check_tvi`](../src/ecProofTyping.ml) | + +--- + +## Test suite + +Positive tests are under [`tests/tc/`](../tests/tc/) (scenario `unit`); +negative regression tests — files that must fail compilation with a +specific diagnostic — are under [`tests/tc-ko/`](../tests/tc-ko/) +(scenario `tc-ko`). + +| File | What it covers | +|----------------------------|-------------------------------------------------| +| `basic.ec` | Minimal class + instance + lemma | +| `clone.ec` | Cloning a theory containing a TC declaration | +| `clone-with-instance.ec` | Cloning an abstract theory with TC carrier | +| `declare-type.ec` | Section closure with `declare type t <: tc` | +| `diamond.ec` | Diamond inheritance + SMT auto-axioms | +| `explicit-tvi.ec` | Explicit `<:int>` and bare apply | +| `grandparent-op.ec` | Underconstrained-axiom diagnostic + workarounds | +| `inheritance.ec` | Two-level subclass chain | +| `instance.ec` | Multiple ops/axioms in an instance | +| `multi-instance.ec` | Two named instances for one TC at different types | +| `multi-param.ec` | `('a, 'b) embed` + polymorphic lemma + instance | +| `multi-param-bare-ops.ec` | Bare-op carrier inference for multi-param TCs | + +Negative tests under `tests/tc-ko/`: + +| File | Asserted error message | +|------------------------------|-------------------------------------------------| +| `bad-tvi.ec` | `type int does not satisfy typeclass constraint addmonoid` | +| `underconstrained-axiom.ec` | `axiom 'tc3_extra' is type-ambiguous: ...` | +| `ambiguous-instance.ec` | `ambiguous typeclass instance for embed; candidates: ...` | +| `parametric.ec` | Parametric TC `['a <: tc] action` | +| `print.ec` | `print` does not crash on TC entities | +| `section.ec` | Typeclass declared inside a section | +| `smt.ec` | SMT over abstract carriers (with/without hints) | diff --git a/dune-project b/dune-project index 85f142616e..ec8d76f29d 100644 --- a/dune-project +++ b/dune-project @@ -24,4 +24,5 @@ (why3 (and (>= 1.8.0) (< 1.9))) yojson (zarith (>= 1.10)) -)) + ) +) diff --git a/examples/tcalgebra/TcBigalg.ec b/examples/tcalgebra/TcBigalg.ec new file mode 100644 index 0000000000..e81f864059 --- /dev/null +++ b/examples/tcalgebra/TcBigalg.ec @@ -0,0 +1,359 @@ +pragma +implicits. + +(* -------------------------------------------------------------------- *) +require import AllCore List StdOrder. +require import TcMonoid TcRing TcBigop. + +import IntOrder. + +(* ==================================================================== *) +(* Big sums over an additive group. Mirrors *) +(* [theories/algebra/Bigalg.ec:BigZModule] but as a TC section on *) +(* [addgroup] carriers. *) +(* ==================================================================== *) +section. +declare type t <: addgroup. + +(* -------------------------------------------------------------------- *) +lemma sumrD ['a] (P : 'a -> bool) (F1 F2 : 'a -> t) (r : 'a list) : + (big P F1 r) + (big P F2 r) = big P (fun x => F1 x + F2 x) r. +proof. by rewrite big_split. qed. + +(* -------------------------------------------------------------------- *) +lemma sumrN ['a] (P : 'a -> bool) (F : 'a -> t) (r : 'a list) : + - (big P F r) = big P (fun x => -(F x)) r. +proof. +apply/(big_endo oppr0 opprD). +qed. + +(* -------------------------------------------------------------------- *) +lemma sumrB ['a] (P : 'a -> bool) (F1 F2 : 'a -> t) (r : 'a list) : + (big P F1 r) - (big P F2 r) = big P (fun x => F1 x - F2 x) r. +proof. by rewrite sumrN sumrD; apply/eq_bigr => /=. qed. + +(* -------------------------------------------------------------------- *) +lemma sumr_const ['a] (P : 'a -> bool) (x : t) (s : 'a list) : + big P (fun _ => x) s = intmul x (count P s). +proof. by rewrite big_const intmulpE 1:count_ge0 // -iteropE. qed. + +lemma sumri_const (k : t) (n m : int) : + n <= m => bigi predT (fun _ => k) n m = intmul k (m - n). +proof. by move=> h; rewrite sumr_const count_predT size_range /#. qed. + +(* -------------------------------------------------------------------- *) +lemma sumr_undup ['a] (P : 'a -> bool) (F : 'a -> t) (s : 'a list) : + big P F s = big P (fun a => intmul (F a) (count (pred1 a) s)) (undup s). +proof. +rewrite big_undup; apply/eq_bigr => x _ /=. +by rewrite intmulpE ?count_ge0 iteropE. +qed. + +(* -------------------------------------------------------------------- *) +lemma telescoping_sum (F : int -> t) (m n : int) : + m <= n => F m - F n = bigi predT (fun i => F i - F (i+1)) m n. +proof. +move=> /ler_eqVlt [<<- | hmn]. ++ by rewrite big_geq 1:// subrr. +rewrite -sumrB (@big_ltn m n F) 1:// /=. +have heq: n = n - 1 + 1 by ring. +rewrite heq (@big_int_recr (n-1) m) 1:/# -heq /=. +rewrite (@big_reindex _ _ (fun x => x - 1) (fun x => x + 1) (range m (n - 1))) //. +have ->: (transpose Int.(+) 1) = ((+) 1). ++ by apply: fun_ext => x; ring. +have ->: predT \o transpose Int.(+) (-1) = predT by done. +by rewrite /(\o) /= -(@range_addl m n 1) (@addrC _ (F n)) subr_add2r. +qed. + +lemma telescoping_sum_down (F : int -> t) (m n : int) : + m <= n => F n - F m = bigi predT (fun i => F (i+1) - F i) m n. +proof. +move=> hmn; have /= := telescoping_sum (fun i => -F i) _ _ hmn. +by rewrite opprK addrC => ->; apply eq_big => //= i _; rewrite opprK addrC. +qed. + +end section. + +(* ==================================================================== *) +(* Big sums over a [comring] carrier. Mirrors *) +(* [theories/algebra/Bigalg.ec:BigComRing.BAdd] (additive view). *) +(* ==================================================================== *) +section. +declare type t <: comring. + +(* -------------------------------------------------------------------- *) +lemma sumr_1 ['a] (P : 'a -> bool) (s : 'a list) : + bigA P (fun _ => oner<:t>) s = ofint (count P s). +proof. by apply/sumr_const. qed. + +(* -------------------------------------------------------------------- *) +lemma mulr_suml ['a] (P : 'a -> bool) (F : 'a -> t) (s : 'a list) (x : t) : + (bigA P F s) * x = bigA P (fun i => F i * x) s. +proof. by rewrite big_distrl //; (apply/mul0r || apply/mulrDl). qed. + +lemma mulr_sumr ['a] (P : 'a -> bool) (F : 'a -> t) (s : 'a list) (x : t) : + x * (bigA P F s) = bigA P (fun i => x * F i) s. +proof. by rewrite big_distrr //; (apply/mulr0 || apply/mulrDr). qed. + +lemma divr_suml ['a] (P : 'a -> bool) (F : 'a -> t) (s : 'a list) (x : t) : + (bigA P F s) / x = bigA P (fun i => F i / x) s. +proof. by rewrite mulr_suml; apply/eq_bigr. qed. + +(* -------------------------------------------------------------------- *) +lemma sum_pair_dep ['a 'b] (u : 'a -> t) (v : 'a -> 'b -> t) (J : ('a * 'b) list) : + uniq J => + bigA predT (fun (ij : 'a * 'b) => u ij.`1 * v ij.`1 ij.`2) J + = bigA predT + (fun i => u i * bigA predT + (fun ij : _ * _ => v ij.`1 ij.`2) + (filter (fun ij : _ * _ => ij.`1 = i) J)) + (undup (unzip1 J)). +proof. +move=> uqJ; rewrite big_pair // &(eq_bigr) => /= a _. +by rewrite mulr_sumr !big_filter &(eq_bigr) => -[a' b] /= ->>. +qed. + +lemma sum_pair ['a 'b] (u : 'a -> t) (v : 'b -> t) (J : ('a * 'b) list) : + uniq J => + bigA predT (fun (ij : 'a * 'b) => u ij.`1 * v ij.`2) J + = bigA predT + (fun i => u i * bigA predT v + (unzip2 (filter (fun ij : _ * _ => ij.`1 = i) J))) + (undup (unzip1 J)). +proof. +move=> uqJ; rewrite (@sum_pair_dep u (fun _ => v)) // &(eq_bigr) /=. +by move=> a _ /=; congr; rewrite big_map predT_comp /(\o). +qed. + +(* -------------------------------------------------------------------- *) +lemma mulr_big ['a 'b] + (P : 'a -> bool) (Q : 'b -> bool) (f : 'a -> t) (g : 'b -> t) + (r : 'a list) (s : 'b list) : + bigA P f r * bigA Q g s + = bigA P (fun x => bigA Q (fun y => f x * g y) s) r. +proof. +elim: r s => [|x r ih] s; first by rewrite big_nil mul0r. +rewrite !big_cons; case: (P x) => Px; last by rewrite ih. +by rewrite mulrDl -ih mulr_sumr. +qed. + +(* -------------------------------------------------------------------- *) +lemma mulr_const_cond ['a] p (s : 'a list) (c : t) : + bigM<:'a, t> p (fun _ => c) s = exp c (count p s). +proof. +rewrite big_const -iteropE /exp. +by rewrite IntOrder.ltrNge count_ge0. +qed. + +lemma mulr_const ['a] (s : 'a list) (c : t) : + bigM<:'a, t> predT (fun _ => c) s = exp c (size s). +proof. by rewrite mulr_const_cond count_predT. qed. + +(* -------------------------------------------------------------------- *) +lemma subrXX (x y : t) n : 0 <= n => + exp x n - exp y n = (x - y) * (bigiA predT (fun i => exp x (n - 1 - i) * exp y i) 0 n). +proof. +case: n => [|n ge0_n _]; first by rewrite !expr0 big_geq // subrr mulr0. +rewrite mulrBl !(big_distrr mulr0 mulrDr). +rewrite big_int_recl // big_int_recr //= !expr0 /=. +rewrite !(mulr1, mul1r) -!exprS // opprD !addrA; congr. +rewrite -addrA sumrB /= big_seq big1 ?addr0 //=. +move=> i /mem_range rg_i; rewrite mulrA -exprS 1:/# mulrCA. +by rewrite -exprS 1:/# subr_eq0; do 2! congr => /#. +qed. + +end section. + +(* ==================================================================== *) +(* Big sums / products under an ordered domain. Mirrors *) +(* [theories/algebra/Bigalg.ec:BigOrder]. *) +(* ==================================================================== *) +require import TcNumber. + +section. +declare type t <: tcrealdomain. + +lemma ler_sum ['a] (P : 'a -> bool) (F1 F2 : 'a -> t) s : + (forall a, P a => F1 a <= F2 a) + => (bigA P F1 s <= bigA P F2 s). +proof. +apply: (@big_ind2 (fun (x y : t) => x <= y)) => //=. + by apply/ler_add. +qed. + +lemma sumr_ge0 ['a] (P : 'a -> bool) (F : 'a -> t) s : + (forall a, P a => zero <= F a) + => zero <= bigA P F s. +proof. +move=> h; apply: (@big_ind (fun (x : t) => zero <= x)) => //=. + by apply/addr_ge0. +qed. + +lemma sub_ler_sum ['a] (P1 P2 : 'a -> bool) (F1 F2 : 'a -> t) s : + (forall x, P1 x => P2 x) => + (forall x, P1 x => F1 x <= F2 x) => + (forall x, P2 x => !P1 x => zero <= F2 x) => + bigA P1 F1 s <= bigA P2 F2 s. +proof. +move => sub_P1_P2 le_F1_F2 pos_F2; rewrite (@bigID P2 _ P1). +have -> : predI P2 P1 = P1 by smt(). +by rewrite -(addr0 (bigA P1 F1 s)) ler_add ?ler_sum // sumr_ge0 /#. +qed. + +lemma sumr_norm ['a] P (F : 'a -> t) s : + (forall x, P x => zero <= F x) => + bigA P (fun x => `|F x|) s = bigA P F s. +proof. +by move=> ge0_F; apply: eq_bigr => /= a Pa; rewrite ger0_norm /#. +qed. + +lemma ler_sum_seq ['a] (P : 'a -> bool) (F1 F2 : 'a -> t) s : + (forall a, mem s a => P a => F1 a <= F2 a) + => (bigA P F1 s <= bigA P F2 s). +proof. +move=> h; rewrite !(@big_seq_cond P). +by rewrite ler_sum=> //= x []; apply/h. +qed. + +lemma sumr_ge0_seq ['a] (P : 'a -> bool) (F : 'a -> t) s : + (forall a, mem s a => P a => zero <= F a) + => zero <= bigA P F s. +proof. +move=> h; rewrite !(@big_seq_cond P). +by rewrite sumr_ge0=> //= x []; apply/h. +qed. + +lemma prodr_ge0 ['a] (P : 'a -> bool) (F : 'a -> t) (s : 'a list) : + (forall a, P a => zero <= F a) + => zero <= bigM P F s. +proof. +move=> h; apply: (@big_ind (fun (x : t) => zero <= x)) => //=. + by apply/mulr_ge0. +qed. + +lemma prodr_gt0 ['a] (P : 'a -> bool) (F : 'a -> t) (s : 'a list) : + (forall a, P a => zero < F a) + => zero < bigM P F s. +proof. +move=> h; apply: (@big_ind (fun (x : t) => zero < x)) => //=. + by apply/mulr_gt0. +qed. + +lemma ler_prod ['a] (P : 'a -> bool) (F1 F2 : 'a -> t) s : + (forall a, P a => zero <= F1 a <= F2 a) + => (bigM P F1 s <= bigM P F2 s). +proof. +move=> h; elim: s => [|x s ih]; first by rewrite !big_nil lerr. +rewrite !big_cons; case: (P x)=> // /h [ge0F1x leF12x]. +by apply/ler_pmul=> //; apply/prodr_ge0=> a /h []. +qed. + +lemma prodr_ge0_seq ['a] (P : 'a -> bool) (F : 'a -> t) (s : 'a list) : + (forall a, mem s a => P a => zero <= F a) + => zero <= bigM P F s. +proof. +move=> h; rewrite !(@big_seq_cond P). +by rewrite prodr_ge0=> //= x []; apply/h. +qed. + +lemma prodr_gt0_seq ['a] (P : 'a -> bool) (F : 'a -> t) (s : 'a list) : + (forall a, mem s a => P a => zero < F a) + => zero < bigM P F s. +proof. +move=> h; rewrite !(@big_seq_cond P). +by rewrite prodr_gt0=> //= x []; apply/h. +qed. + +lemma ler_prod_seq ['a] (P : 'a -> bool) (F1 F2 : 'a -> t) s : + (forall a, mem s a => P a => zero <= F1 a <= F2 a) + => (bigM P F1 s <= bigM P F2 s). +proof. +move=> h; rewrite !(@big_seq_cond P). +by rewrite ler_prod=> //= x []; apply/h. +qed. + +lemma big_normr ['a] P (F : 'a -> t) s : + `|bigA P F s| <= bigA P (fun x => `|F x|) s. +proof. +elim: s => [|x s ih]; first by rewrite !big_nil normr0. +rewrite !big_cons /=; case: (P x) => // Px. +have /ler_trans := ler_norm_add (F x) (bigA P F s); apply. +by rewrite ler_add2l. +qed. + +lemma gt0_prodr_seq ['a] (P : 'a -> bool) (F : 'a -> t) (s : 'a list) : + (forall (a : 'a), a \in s => P a => zero <= F a) => + zero < bigM P F s => + (forall (a : 'a), a \in s => P a => zero < F a). +proof. +elim: s => // x s IHs F_ge0; rewrite big_cons. +have {IHs} IHs := IHs _; first by smt(). +case: (P x) => [Px F_big_gt0 a a_x_s Pa| nPx /IHs]; 2:smt(). +smt(pmulr_gt0 prodr_ge0_seq). +qed. + +lemma prodr_eq0 ['a] P (F : 'a -> t) s : + (exists x, P x /\ x \in s /\ F x = zero) + <=> bigM<:'a, t> P F s = zero. +proof. split. ++ case=> x [# Px x_in_s z_Fx]; rewrite (@big_rem _ _ _ x) //. + by rewrite Px /= z_Fx mul0r. ++ elim: s => [|x s ih] /=; 1: by rewrite big_nil oner_neq0. + rewrite big_cons /=; case: (P x) => Px; last first. + - by move/ih; case=> y [# Py ys z_Fy]; exists y; rewrite Py ys z_Fy. + rewrite mulf_eq0; case=> [z_Fx|]; first by exists x. + by move/ih; case=> y [# Py ys z_Fy]; exists y; rewrite Py ys z_Fy. +qed. + +lemma ler_pexpn2r n (x y : t) : + 0 < n => zero <= x => zero <= y => (exp x n <= exp y n) <=> (x <= y). +proof. +move=> gt0_n ge0_x ge0_y; split => [|h]; last first. +- by apply/ler_pexp=> //; apply/ltzW. +case: (x = zero) => [->>|nz_x]. +- by rewrite expr0n 1:ltzW. +rewrite -subr_ge0 subrXX 1:ltzW // pmulr_lge0 ?subr_ge0 //=. +rewrite {2}(_ : n = n - 1 + 1) 1:#ring big_int_recr /= 1:/#. +rewrite expr0 /= ltr_spaddr ?mul1r; 1: by rewrite expr_gt0 ltr_neqAle /#. +by rewrite sumr_ge0 => /= i _; rewrite mulr_ge0 ?expr_ge0. +qed. + +lemma sum_expr (p : t) n : 0 <= n => + (oner - p) * bigiA predT (fun i => exp p i) 0 n = oner - exp p n. +proof. +move=> hn; have /eq_sym := subrXX oner p n hn. +rewrite expr1z // => <-; congr. +by apply: eq_big_int => i _ /=; rewrite expr1z mul1r. +qed. + +lemma sum_expr_le (p : t) n : + 0 <= n + => zero <= p < oner + => (oner - p) * bigiA predT (fun i => exp p i) 0 n <= oner. +proof. +move=> ge0_n [ge0_p lt1_p]; rewrite sum_expr //. +by rewrite ler_subl_addr ler_paddr // expr_ge0. +qed. + +lemma sum_iexpr_le (p : t) n : zero <= p < oner => + exp (oner - p) 2 * bigiA predT (fun i => ofint i * exp p i) 0 n <= oner. +proof. +case=> [ge0_p lt1_p]; elim/natind: n => [n le0_n|n ge0_n ih]. ++ by rewrite big_geq // mulr0. +rewrite big_ltn 1:/# /= ofint0 mul0r add0r. +pose F := fun j => exp p j + p * ((ofint<:t> j - oner) * exp p (j - 1)). +rewrite (@eq_big_int _ _ _ F) => /= [i [gt0_i lti]|]. +- by rewrite /F mulrCA -expr_pred 1:/# mulrBl mul1r addrC subrK. +rewrite -sumrD -mulr_sumr mulrDr. +apply: (ler_trans ((oner - p) + p)); last by rewrite lerr_eq subrK. +apply: ler_add. +- rewrite expr2 -mulrA ler_pimulr 1:subr_ge0 1:ltrW //. + have le := sum_expr_le p (n+1) _ _ => //; first move=> /#. + rewrite &(ler_trans _ _ le) ler_wpmul2l 1:subr_ge0 1:ltrW //. + by rewrite (@big_ltn 0) 1:/# /= expr0 ler_paddl. +rewrite mulrCA ler_pimulr // &(ler_trans _ _ ih). +rewrite ler_wpmul2l; first by rewrite expr_ge0 subr_ge0 ltrW. +rewrite &(lerr_eq) (@big_addn 0 _ 1) &(eq_big_int) /=. +by move=> i [ge0_i _]; rewrite ofintS // addrAC subrr add0r. +qed. + +end section. diff --git a/examples/tcalgebra/TcBigop.ec b/examples/tcalgebra/TcBigop.ec new file mode 100644 index 0000000000..e66c0cca0b --- /dev/null +++ b/examples/tcalgebra/TcBigop.ec @@ -0,0 +1,607 @@ +(* This API has been mostly inspired from the [bigop] library of the + * ssreflect Coq extension. *) + +pragma +implicits. + +(* -------------------------------------------------------------------- *) +require import AllCore List Ring TcMonoid. + +(* -------------------------------------------------------------------- *) +section. +declare type t <: monoid. + +(* Section-local infix [+] for [mop] at carrier [t]. Defined as a direct + alias for [mop<:t>] (NOT [fun x y => mop x y]) so that partial + applications like [(+) x] keep their curried-op shape rather than + becoming a [fun y => ...] lambda. Inside section only; downstream + code sees abstract [mop]. *) +local abbrev (+) = mop<:t>. + +(* -------------------------------------------------------------------- *) +op big (P : 'a -> bool) (F : 'a -> t) (r : 'a list) = + foldr mop idm (map F (filter P r)). + +(* -------------------------------------------------------------------- *) +abbrev bigi (P : int -> bool) (F : int -> t) i j = + big P F (range i j). + +(* -------------------------------------------------------------------- *) +lemma big_nil (P : 'a -> bool) (F : 'a -> t): big P F [] = idm. +proof. by []. qed. + +(* -------------------------------------------------------------------- *) +lemma big_cons (P : 'a -> bool) (F : 'a -> t) x s: + big P F (x :: s) = if P x then F x + big P F s else big P F s. +proof. by rewrite {1}/big /= (@fun_if (map F)); case (P x). qed. + +lemma big_consT (F : 'a -> t) x s: + big predT F (x :: s) = F x + big predT F s. +proof. by apply/big_cons. qed. + +(* -------------------------------------------------------------------- *) +lemma big_rec (K : t -> bool) r P (F : 'a -> t): + K idm => (forall i x, P i => K x => K (F i + x)) => K (big P F r). +proof. + move=> K0 Kop; elim: r => //= i r; rewrite big_cons. + by case (P i) => //=; apply/Kop. +qed. + +lemma big_ind (K : t -> bool) r P (F : 'a -> t): + (forall x y, K x => K y => K (x + y)) + => K idm => (forall i, P i => K (F i)) + => K (big P F r). +proof. + move=> Kop Kidx K_F; apply/big_rec => //. + by move=> i x Pi Kx; apply/Kop => //; apply/K_F. +qed. + +lemma big_rec2: + forall (K : t -> t -> bool) r P (F1 F2 : 'a -> t), + K idm idm + => (forall i y1 y2, P i => K y1 y2 => K (F1 i + y1) (F2 i + y2)) + => K (big P F1 r) (big P F2 r). +proof. + move=> K r P F1 F2 KI KF; elim: r => //= i r IHr. + by rewrite !big_cons; case (P i) => ? //=; apply/KF. +qed. + +lemma big_ind2: + forall (K : t -> t -> bool) r P (F1 F2 : 'a -> t), + (forall x1 x2 y1 y2, K x1 x2 => K y1 y2 => K (x1 + y1) (x2 + y2)) + => K idm idm + => (forall i, P i => K (F1 i) (F2 i)) + => K (big P F1 r) (big P F2 r). +proof. + move=> K r P F1 F2 Kop KI KF; apply/big_rec2 => //. + by move=> i x1 x2 Pi Kx1x2; apply/Kop => //; apply/KF. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_endo (f : t -> t): + f idm = idm + => (forall (x y : t), f (x + y) = f x + f y) + => forall r P (F : 'a -> t), + f (big P F r) = big P (f \o F) r. +proof. + (* FIXME: should be a consequence of big_morph *) + move=> fI fM; elim=> //= i r IHr P F; rewrite !big_cons. + by case (P i) => //=; rewrite 1?fM IHr. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_map ['a 'b] (h : 'b -> 'a) (P : 'a -> bool) F s: + big P F (map h s) = big (P \o h) (F \o h) s. +proof. by elim: s => // x s; rewrite map_cons !big_cons=> ->. qed. + +lemma big_mapT ['a 'b] (h : 'b -> 'a) F s: (* -> big_map_predT *) + big predT F (map h s) = big predT (F \o h) s. +proof. by rewrite big_map. qed. + +(* -------------------------------------------------------------------- *) +lemma big_comp ['a] (h : t -> t) (P : 'a -> bool) F s: + h idm = idm => morphism_2 h (+) (+) => + h (big P F s) = big P (h \o F) s. +proof. + move=> Hidm Hh;elim: s => // x s; rewrite !big_cons => <-. + by rewrite /(\o) -Hh;case (P x) => //. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_nth x0 (P : 'a -> bool) (F : 'a -> t) s: + big P F s = bigi (P \o (nth x0 s)) (F \o (nth x0 s)) 0 (size s). +proof. by rewrite -{1}(@mkseq_nth x0 s) /mkseq big_map. qed. + +(* -------------------------------------------------------------------- *) +lemma big_const (P : 'a -> bool) x s: + big P (fun i => x) s = iter (count P s) ((+) x) idm. +proof. + elim: s=> [|y s ih]; [by rewrite iter0 | rewrite big_cons /=]. + by rewrite ih; case (P y) => //; rewrite addzC iterS // count_ge0. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_seq1 (F : 'a -> t) x: big predT F [x] = F x. +proof. by rewrite big_cons big_nil mop0m. qed. + +(* -------------------------------------------------------------------- *) +lemma big_mkcond (P : 'a -> bool) (F : 'a -> t) s: + big P F s = big predT (fun i => if P i then F i else idm) s. +proof. + elim: s=> // x s ih; rewrite !big_cons -ih /predT /=. + by case (P x)=> //; rewrite mop0. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_filter (P : 'a -> bool) F s: + big predT F (filter P s) = big P F s. +proof. by elim: s => //= x s; case (P x)=> //; rewrite !big_cons=> -> ->. qed. + +(* -------------------------------------------------------------------- *) +lemma big_filter_cond (P1 P2 : 'a -> bool) F s: + big P2 F (filter P1 s) = big (predI P1 P2) F s. +proof. by rewrite -big_filter -(@big_filter _ _ s) predIC filter_predI. qed. + +(* -------------------------------------------------------------------- *) +lemma eq_bigl (P1 P2 : 'a -> bool) (F : 'a -> t) s: + (forall i, P1 i <=> P2 i) + => big P1 F s = big P2 F s. +proof. by move=> h; rewrite /big (eq_filter h). qed. + +(* -------------------------------------------------------------------- *) +lemma eq_bigr (P : 'a -> bool) (F1 F2 : 'a -> t) s: + (forall i, P i => F1 i = F2 i) + => big P F1 s = big P F2 s. +proof. (* FIXME: big_rec2 *) + move=> eqF; elim: s=> // x s; rewrite !big_cons=> <-. + by case (P x)=> // /eqF <-. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_distrl ['a] (op_ : t -> t -> t) (P : 'a -> bool) F s u: + left_zero idm op_ + => left_distributive op_ (+) + => op_ (big P F s) u = big P (fun a => op_ (F a) u) s. +proof. + move=> mulm1 mulmDl; pose G := fun x => op_ x u. + move: (big_comp G P) => @/G /= -> //. + by rewrite mulm1. by move=> t1 t2; rewrite mulmDl. +qed. + +lemma big_distrr ['a] (op_ : t -> t -> t) (P : 'a -> bool) F s u: + right_zero idm op_ + => right_distributive op_ (+) + => op_ u (big P F s) = big P (fun a => op_ u (F a)) s. +proof. + move=> mul1m mulmDr; pose G := fun x => op_ u x. + move: (big_comp G P) => @/G /= -> //. + by rewrite mul1m. by move=> t1 t2; rewrite mulmDr. +qed. + +lemma big_distr ['a 'b] (op_ : t -> t -> t) + (P1 : 'a -> bool) (P2 : 'b -> bool) F1 s1 F2 s2 : + commutative op_ + => left_zero idm op_ + => left_distributive op_ (+) + => op_ (big P1 F1 s1) (big P2 F2 s2) = + big P1 (fun a1 => big P2 (fun a2 => op_ (F1 a1) (F2 a2)) s2) s1. +proof. + move=> mulmC mulm1 mulmDl; rewrite big_distrl //. + apply/eq_bigr=> i _ /=; rewrite big_distrr //. + by move=> x; rewrite mulmC mulm1. + by move=> x y z; rewrite !(mulmC x) mulmDl. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_andbC (P Q : 'a -> bool) (F : 'a -> t) s: + big (fun x => P x /\ Q x) F s = big (fun x => Q x /\ P x) F s. +proof. by apply/eq_bigl=> i. qed. + +(* -------------------------------------------------------------------- *) +lemma eq_big (P1 P2 : 'a -> bool) (F1 F2 : 'a -> t) s: + (forall i, P1 i <=> P2 i) + => (forall i, P1 i => F1 i = F2 i) + => big P1 F1 s = big P2 F2 s. +proof. by move=> /eq_bigl <- /eq_bigr <-. qed. + +(* -------------------------------------------------------------------- *) +lemma congr_big r1 r2 P1 P2 (F1 F2 : 'a -> t): + r1 = r2 + => (forall x, P1 x <=> P2 x) + => (forall i, P1 i => F1 i = F2 i) + => big P1 F1 r1 = big P2 F2 r2. +proof. by move=> <-; apply/eq_big. qed. + +(* -------------------------------------------------------------------- *) +lemma big_hasC (P : 'a -> bool) (F : 'a -> t) s: !has P s => + big P F s = idm. +proof. + rewrite -big_filter has_count -size_filter. + by rewrite ltz_def size_ge0 /= => /size_eq0 ->. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_pred0_eq (F : 'a -> t) s: big pred0 F s = idm. +proof. by rewrite big_hasC // has_pred0. qed. + +(* -------------------------------------------------------------------- *) +lemma big_pred0 (P : 'a -> bool) (F : 'a -> t) s: + (forall i, P i <=> false) => big P F s = idm. +proof. by move=> h; rewrite -(@big_pred0_eq F s); apply/eq_bigl. qed. + +(* -------------------------------------------------------------------- *) +lemma big_cat (P : 'a -> bool) (F : 'a -> t) s1 s2: + big P F (s1 ++ s2) = big P F s1 + big P F s2. +proof. + rewrite !(@big_mkcond P); elim: s1 => /= [|i s1 ih]. + by rewrite (@big_nil P F) mop0. + by rewrite !big_cons /(predT i) /= ih mopA. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_catl (P : 'a -> bool) (F : 'a -> t) s1 s2: !has P s2 => + big P F (s1 ++ s2) = big P F s1. +proof. by rewrite big_cat => /big_hasC ->; rewrite mop0m. qed. + +(* -------------------------------------------------------------------- *) +lemma big_catr (P : 'a -> bool) (F : 'a -> t) s1 s2: !has P s1 => + big P F (s1 ++ s2) = big P F s2. +proof. by rewrite big_cat => /big_hasC ->; rewrite mop0. qed. + +(* -------------------------------------------------------------------- *) +lemma big_rcons (P : 'a -> bool) (F : 'a -> t) s x: + big P F (rcons s x) = if P x then big P F s + F x else big P F s. +proof. + by rewrite -cats1 big_cat big_cons big_nil; case: (P x); rewrite !mop0m. +qed. + +(* -------------------------------------------------------------------- *) +lemma eq_big_perm (P : 'a -> bool) (F : 'a -> t) s1 s2: + perm_eq s1 s2 => big P F s1 = big P F s2. +proof. + move=> /perm_eqP; rewrite !(@big_mkcond P). + elim s1 s2 => [|i s1 ih1] s2 eq_s12. + + case: s2 eq_s12=> // i s2 h. + by have := h (pred1 i)=> //=; smt(count_ge0). + have r2i: mem s2 i by rewrite -has_pred1 has_count -eq_s12 #smt:(count_ge0). + have/splitPr [s3 s4] ->> := r2i. + rewrite big_cat !big_cons /(predT i) /=. + rewrite mopCAm; congr; rewrite -big_cat; apply/ih1=> a. + by have := eq_s12 a; rewrite !count_cat /= addzCA => /addzI. +qed. + +(* -------------------------------------------------------------------- *) +lemma eq_big_perm_map (F : 'a -> t) s1 s2: + perm_eq (map F s1) (map F s2) => big predT F s1 = big predT F s2. +proof. +by move=> peq; rewrite -!(@big_map F predT idfun) &(eq_big_perm). +qed. + +(* -------------------------------------------------------------------- *) +lemma big_seq_cond (P : 'a -> bool) (F : 'a -> t) s: + big P F s = big (fun i => mem s i /\ P i) F s. +proof. by rewrite -!(@big_filter _ _ s); congr; apply/eq_in_filter. qed. + +(* -------------------------------------------------------------------- *) +lemma big_seq (F : 'a -> t) s: + big predT F s = big (fun i => mem s i) F s. +proof. by rewrite big_seq_cond; apply/eq_bigl. qed. + +(* -------------------------------------------------------------------- *) +lemma big_rem (P : 'a -> bool) (F : 'a -> t) s x: mem s x => + big P F s = (if P x then F x else idm) + big P F (rem x s). +proof. + by move/perm_to_rem/eq_big_perm=> ->; rewrite !(@big_mkcond P) big_cons. +qed. + +(* -------------------------------------------------------------------- *) +lemma bigD1 (F : 'a -> t) s x: mem s x => uniq s => + big predT F s = F x + big (predC1 x) F s. +proof. by move=> /big_rem-> /rem_filter->; rewrite big_filter. qed. + +(* -------------------------------------------------------------------- *) +lemma bigD1_cond P (F : 'a -> t) s x: P x => mem s x => uniq s => + big P F s = F x + big (predI P (predC1 x)) F s. +proof. +move=> Px sx uqs; rewrite -big_filter (@bigD1 _ _ x) ?big_filter_cond //. + by rewrite mem_filter Px. by rewrite filter_uniq. +qed. + +(* -------------------------------------------------------------------- *) +lemma bigD1_cond_if P (F : 'a -> t) s x: uniq s => big P F s = + (if mem s x /\ P x then F x else idm) + big (predI P (predC1 x)) F s. +proof. +case: (mem s x /\ P x) => [[Px sx]|Nsx]; rewrite ?mop0 /=. + by apply/bigD1_cond. +move=> uqs; rewrite big_seq_cond eq_sym big_seq_cond; apply/eq_bigl=> i /=. +by case: (i = x) => @/predC1 @/predI [->>|]. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_split (P : 'a -> bool) (F1 F2 : 'a -> t) s: + big P (fun i => F1 i + F2 i) s = big P F1 s + big P F2 s. +proof. + elim: s=> /= [|x s ih]; 1: by rewrite !big_nil mop0m. + rewrite !big_cons ih; case: (P x) => // _. + by rewrite mopCAm -!mopA mopCAm. +qed. + +(* -------------------------------------------------------------------- *) +lemma bigID (P : 'a -> bool) (F : 'a -> t) (a : 'a -> bool) s: + big P F s = big (predI P a) F s + big (predI P (predC a)) F s. +proof. +rewrite !(@big_mkcond _ F) -big_split; apply/eq_bigr => i _ /=. +by rewrite /predI /predC; case: (a i); rewrite ?mop0m ?mop0. +qed. + +(* -------------------------------------------------------------------- *) +lemma bigU ['a] (P Q : 'a -> bool) (F : 'a -> t) s : (forall x, !(P x /\ Q x)) => + big (predU P Q) F s = big P F s + big Q F s. +proof. +move=> dj_PQ; rewrite (@bigID (predU _ _) _ P). +by congr; apply: eq_bigl => /#. +qed. + +(* -------------------------------------------------------------------- *) +lemma bigEM ['a] (P : 'a -> bool) (F : 'a -> t) s : + big predT F s = big P F s + big (predC P) F s. +proof. by rewrite -bigU 1:/#; apply: eq_bigl => /#. qed. + +(* -------------------------------------------------------------------- *) +lemma big_reindex ['a 'b] + (P : 'a -> bool) (F : 'a -> t) (f : 'b -> 'a) (f' : 'a -> 'b) (s : 'a list) : + (forall x, x \in s => f (f' x) = x) + => big P F s = big (P \o f) (F \o f) (map f' s). +proof. +by move => /eq_in_map id_ff'; rewrite -big_map -map_comp id_ff' id_map. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_pair_pswap ['a 'b] (p : 'a * 'b -> bool) (f : 'a * 'b -> t) s : + big<:'a * 'b> p f s + = big<:'b * 'a> (p \o pswap) (f \o pswap) (map pswap s). +proof. by apply/big_reindex; case. qed. + +(* -------------------------------------------------------------------- *) +lemma eq_big_seq (F1 F2 : 'a -> t) s: + (forall x, mem s x => F1 x = F2 x) + => big predT F1 s = big predT F2 s. +proof. by move=> eqF; rewrite !big_seq; apply/eq_bigr. qed. + +(* -------------------------------------------------------------------- *) +lemma congr_big_seq (P1 P2: 'a -> bool) (F1 F2 : 'a -> t) s: + (forall x, mem s x => P1 x = P2 x) => + (forall x, mem s x => P1 x => P2 x => F1 x = F2 x) + => big P1 F1 s = big P2 F2 s. +proof. + move=> eqP eqH; rewrite big_mkcond eq_sym big_mkcond eq_sym. + apply/eq_big_seq=> x x_in_s /=; rewrite eqP //. + by case (P2 x)=> // P2x; rewrite eqH // eqP. +qed. + +(* -------------------------------------------------------------------- *) +lemma big1_eq (P : 'a -> bool) s: big P (fun (x : 'a) => idm) s = idm. +proof. + rewrite big_const; elim/natind: (count _ _)=> n. + by move/iter0<:t> => ->. + by move/iterS<:t> => -> ->; rewrite mop0m. +qed. + +(* -------------------------------------------------------------------- *) +lemma big1 (P : 'a -> bool) (F : 'a -> t) s: + (forall i, P i => F i = idm) => big P F s = idm. +proof. by move/eq_bigr=> ->; apply/big1_eq. qed. + +(* -------------------------------------------------------------------- *) +lemma big1_seq (P : 'a -> bool) (F : 'a -> t) s: + (forall i, P i /\ (mem s i) => F i = idm) => big P F s = idm. +proof. by move=> eqF1; rewrite big_seq_cond big_andbC big1. qed. + +(* -------------------------------------------------------------------- *) +lemma big_eq_idm_filter ['a] (P : 'a -> bool) (F : 'a -> t) s : + (forall (x : 'a), !P x => F x = idm) => big predT F s = big P F s. +proof. +by move=> eq1; rewrite (@bigEM P) (@big1 (predC _)) // mop0m. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_flatten (P : 'a -> bool) (F : 'a -> t) rr : + big P F (flatten rr) = big predT (fun s => big P F s) rr. +proof. +elim: rr => /= [|r rr ih]; first by rewrite !big_nil. +by rewrite flatten_cons big_cat big_cons -ih. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_pair ['a 'b] (F : 'a * 'b -> t) (s : ('a * 'b) list) : uniq s => + big predT F s = + big predT (fun a => + big predT F (filter (fun xy : _ * _ => xy.`1 = a) s)) + (undup (map fst s)). +proof. +move=> /perm_eq_pair /eq_big_perm /(_ predT F) ->. +by rewrite big_flatten big_map. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_nseq_cond (P : 'a -> bool) (F : 'a -> t) n x : + big P F (nseq n x) = if P x then iter n ((+) (F x)) idm else idm. +proof. +elim/natind: n => [n le0_n|n ge0_n ih]; first by rewrite ?(nseq0_le, iter0). +by rewrite nseqS // big_cons ih; case: (P x) => //; rewrite iterS. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_nseq (F : 'a -> t) n x : + big predT F (nseq n x) = iter n ((+) (F x)) idm. +proof. by apply/big_nseq_cond. qed. + +(* -------------------------------------------------------------------- *) +lemma big_undup ['a] (P : 'a -> bool) (F : 'a -> t) s : + big P F s = big P (fun a => iter (count (pred1 a) s) ((+) (F a)) idm) (undup s). +proof. +have <- := eq_big_perm P F _ _ (perm_undup_count s). +rewrite big_flatten big_map (@big_mkcond P); apply/eq_big => //=. +by move=> @/(\o) /= x _; apply/big_nseq_cond. +qed. + +(* -------------------------------------------------------------------- *) +lemma exchange_big (P1 : 'a -> bool) (P2 : 'b -> bool) (F : 'a -> 'b -> t) s1 s2: + big P1 (fun a => big P2 (F a) s2) s1 = + big P2 (fun b => big P1 (fun a => F a b) s1) s2. +proof. + elim: s1 s2 => [|a s1 ih] s2; first by rewrite big_nil big1_eq. + rewrite big_cons ih; case: (P1 a)=> h; rewrite -?big_split; + by apply/eq_bigr=> x _ /=; rewrite big_cons h. +qed. + +(* -------------------------------------------------------------------- *) +lemma partition_big ['a 'b] (px : 'a -> 'b) P Q (F : 'a -> t) s s' : + uniq s' + => (forall x, mem s x => P x => mem s' (px x) /\ Q (px x)) + => big P F s = big Q (fun x => big (fun y => P y /\ px y = x) F s) s'. +proof. +move=> uq_s'; elim: s => /~= [|x xs ih] hm. + by rewrite big_nil big1_eq. +rewrite big_cons; case: (P x) => /= [Px|PxN]; last first. + rewrite ih //; 1: by move=> y y_xs; apply/hm; rewrite y_xs. + by apply/eq_bigr=> i _ /=; rewrite big_cons /= PxN. +have := hm x; rewrite Px /= => -[s'_px Qpx]; apply/eq_sym. +rewrite (@bigD1_cond _ _ _ (px x)) //= big_cons /= Px /=. +rewrite -mopA; congr; apply/eq_sym; rewrite ih. + by move=> y y_xs; apply/hm; rewrite y_xs. +rewrite (@bigD1_cond _ _ _ (px x)) //=; congr. +apply/eq_bigr=> /= i [Qi @/predC1]; rewrite eq_sym => ne_pxi. +by rewrite big_cons /= ne_pxi. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_allpairs (f : 'a -> 'b -> 'c) (F : 'c -> t) s u: + big predT F (allpairs<:'a, 'b, 'c> f s u) + = big predT (fun x => big predT (fun y => F (f x y)) u) s. +proof. +elim: s u => [|x s ih] u //=. +by rewrite allpairs_consl big_cat ih big_consT big_map. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_int_cond m n P (F : int -> t): + bigi P F m n = bigi (fun i => m <= i < n /\ P i) F m n. +proof. by rewrite big_seq_cond; apply/eq_bigl=> i /=; rewrite mem_range. qed. + +(* -------------------------------------------------------------------- *) +lemma big_int m n (F : int -> t): + bigi predT F m n = bigi (fun i => m <= i < n) F m n. +proof. by rewrite big_int_cond. qed. + +(* -------------------------------------------------------------------- *) +lemma congr_big_int (m1 n1 m2 n2 : int) P1 P2 (F1 F2 : int -> t): + m1 = m2 => n1 = n2 + => (forall i, m1 <= i < n2 => P1 i = P2 i) + => (forall i, P1 i /\ (m1 <= i < n2) => F1 i = F2 i) + => bigi P1 F1 m1 n1 = bigi P2 F2 m2 n2. +proof. + move=> <- <- eqP12 eqF12; rewrite big_seq_cond (@big_seq_cond P2). + by apply/eq_big=> i /=; rewrite mem_range #smt:(). +qed. + +(* -------------------------------------------------------------------- *) +lemma eq_big_int (m n : int) (F1 F2 : int -> t): + (forall i, m <= i < n => F1 i = F2 i) + => bigi predT F1 m n = bigi predT F2 m n. +proof. by move=> eqF; apply/congr_big_int. qed. + +(* -------------------------------------------------------------------- *) +lemma big_ltn_cond (m n : int) P (F : int -> t): m < n => + let x = bigi P F (m+1) n in + bigi P F m n = if P m then F m + x else x. +proof. by move/range_ltn=> ->; rewrite big_cons. qed. + +(* -------------------------------------------------------------------- *) +lemma big_ltn (m n : int) (F : int -> t): m < n => + bigi predT F m n = F m + bigi predT F (m+1) n. +proof. by move/big_ltn_cond=> /= ->. qed. + +(* -------------------------------------------------------------------- *) +lemma big_geq (m n : int) P (F : int -> t): n <= m => + bigi P F m n = idm. +proof. by move/range_geq=> ->; rewrite big_nil. qed. + +(* -------------------------------------------------------------------- *) +lemma big_addn (m n a : int) P (F : int -> t): + bigi P F (m+a) n + = bigi (fun i => P (i+a)) (fun i => F (i+a)) m (n-a). +proof. +rewrite range_addl big_map; apply/eq_big. + by move=> i /=; rewrite /(\o) addzC. +by move=> i /= _; rewrite /(\o) addzC. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_int1 n (F : int -> t): bigi predT F n (n+1) = F n. +proof. by rewrite big_ltn 1:/# big_geq // mop0m. qed. + +(* -------------------------------------------------------------------- *) +lemma big_cat_int (n m p : int) P (F : int -> t): m <= n => n <= p => + bigi P F m p = (bigi P F m n) + (bigi P F n p). +proof. by move=> lemn lenp; rewrite -big_cat -range_cat. qed. + +(* -------------------------------------------------------------------- *) +lemma big_int_recl (n m : int) (F : int -> t): m <= n => + bigi predT F m (n+1) = F m + bigi predT (fun i => F (i+1)) m n. +proof. by move=> lemn; rewrite big_ltn 1?big_addn /= 1:/#. qed. + +(* -------------------------------------------------------------------- *) +lemma big_int_recr (n m : int) (F : int -> t): m <= n => + bigi predT F m (n+1) = bigi predT F m n + F n. +proof. by move=> lemn; rewrite (@big_cat_int n) ?big_int1 //#. qed. + +(* -------------------------------------------------------------------- *) +lemma big_int_recl_cond (n m : int) P (F : int -> t): m <= n => + bigi P F m (n+1) = + (if P m then F m else idm) + + bigi (fun i => P (i+1)) (fun i => F (i+1)) m n. +proof. +by move=> lemn; rewrite big_mkcond big_int_recl //= -big_mkcond. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_int_recr_cond (n m : int) P (F : int -> t): m <= n => + bigi P F m (n+1) = + bigi P F m n + (if P n then F n else idm). +proof. by move=> lemn; rewrite !(@big_mkcond P) big_int_recr. qed. + +(* -------------------------------------------------------------------- *) +lemma bigi_split_odd_even (n : int) (F : int -> t) : 0 <= n => + bigi predT (fun i => F (2 * i) + F (2 * i + 1)) 0 n + = bigi predT F 0 (2 * n). +proof. +move=> ge0_n; rewrite big_split; pose rg := range 0 n. +rewrite -(@big_mapT (fun i => 2 * i)). +rewrite -(@big_mapT (fun i => 2 * i + 1)). +rewrite -big_cat &(eq_big_perm) &(uniq_perm_eq) 2:&(range_uniq). +- rewrite cat_uniq !map_inj_in_uniq /= ~-1:/# range_uniq /=. + apply/hasPn => _ /mapP[y] /= [_ ->]. + by apply/negP; case/mapP=> ? [_] /#. +move=> x; split. +- rewrite mem_cat; case=> /mapP[y] /=; + case=> /mem_range y_rg -> {x}; apply/mem_range; + by smt(). +move/mem_range => x_rg; rewrite mem_cat. +have: forall (i : int), exists j, i = 2 * j \/ i = 2 * j + 1 by smt(). +- case/(_ x) => y [] ->>; [left | right]; apply/mapP=> /=; + by exists y; (split; first apply/mem_range); smt(). +qed. + +end section. + +(* ==================================================================== *) +(* Display wrappers: [bigA] for additive contexts, [bigM] for + multiplicative ones. Both unfold to [big] so all the lemmas above + apply transparently. The flavor tag on the carrier ([addmonoid] + vs [mulmonoid]) drives which wrapper the printer folds back to. *) +(* ==================================================================== *) +abbrev bigA ['a, 't <: addmonoid] P (F : 'a -> 't) r = big P F r. +abbrev bigM ['a, 't <: mulmonoid] P (F : 'a -> 't) r = big P F r. + +abbrev bigiA ['t <: addmonoid] (P : int -> bool) (F : int -> 't) i j = bigA P F (range i j). +abbrev bigiM ['t <: mulmonoid] (P : int -> bool) (F : int -> 't) i j = bigM P F (range i j). diff --git a/examples/tcalgebra/TcBinomial.ec b/examples/tcalgebra/TcBinomial.ec new file mode 100644 index 0000000000..d12a24fe42 --- /dev/null +++ b/examples/tcalgebra/TcBinomial.ec @@ -0,0 +1,177 @@ +(* -------------------------------------------------------------------- *) +require import AllCore List. +require import TcMonoid TcRing TcBigop TcBigalg TcInt TcNumber TcReal. + +(* ==================================================================== *) +(* TC port of [theories/algebra/Binomial.ec]. *) +(* ==================================================================== *) + +(* -------------------------------------------------------------------- *) +op fact (n : int) = bigiM predT idfun 1 (n+1). + +lemma fact0 (n : int) : n <= 0 => fact n = 1. +proof. +move=> le0n; rewrite /fact /bigiM /bigM range_geq /#. +qed. + +lemma factS (n : int) : 0 <= n => fact (n+1) = (n+1) * (fact n). +proof. +move=> ge0_n; rewrite /fact /bigiM /bigM rangeSr 1:/# -cats1 big_cat big_seq1 /=. +by rewrite mulrC. +qed. + +lemma fact1 : fact 1 = 1. +proof. by rewrite -{1}[1]add0r factS //= fact0. qed. + +(* -------------------------------------------------------------------- *) +op bin1 (s : int list) = + 1 :: (map (fun i => nth 0 s i + nth 0 s (i+1)) (range 0 (size s))). + +op bin (n k : int) : int = + if n < 0 \/ k < 0 then 0 else nth 0 (iter n bin1 [1]) k. + +(* -------------------------------------------------------------------- *) +lemma size_bin1 (s : int list) : size (bin1 s) = 1 + size s. +proof. by rewrite /bin1 /= size_map size_range /#. qed. + +lemma size_bin (s : int list) n : 0 <= n => + size (iter n bin1 s) = n + size s. +proof. +elim: n => [|n ge0_n ih]; first by rewrite iter0. +by rewrite iterS // size_bin1 ih; ring. +qed. + +(* -------------------------------------------------------------------- *) +lemma binp (n k : int) : + 0 <= n => 0 <= k => bin n k = nth 0 (iter n bin1 [1]) k. +proof. by rewrite /bin !ltrNge=> -> ->. qed. + +lemma bin_lt0l (n m : int) : n < 0 => bin n m = 0. +proof. by move=> @/bin ->. qed. + +lemma bin_lt0r (n m : int) : m < 0 => bin n m = 0. +proof. by move=> @/bin ->. qed. + +lemma bin0 (n : int) : 0 <= n => bin n 0 = 1. +proof. +move=> ge0_n; rewrite binp //; elim/natind: n ge0_n=> n h. ++ by rewrite iter0. ++ by move=> ih; rewrite iterS. +qed. + +lemma binn (n : int) : 0 <= n => bin n n = 1. +proof. +move=> ge0_n; rewrite binp //; pose s := iter _ _ _. +have sz_s: size s = n + 1 by rewrite size_bin. +rewrite (_ : n = n + 1 - 1) // -sz_s nth_last /s. +elim: {s sz_s} n ge0_n 0; first by rewrite iter0. +move=> i ge0_i ih k; rewrite iterS //. +pose s := iter _ _ _; rewrite /bin1 /=. +pose F i := nth 0 s i + nth 0 s (i + 1). +have ->: 1 = F ((size s) - 1). ++ by rewrite /F nth_last ih nth_default. +rewrite last_map (rangeSr _ (size s - 1)) 1:size_bin //. +by rewrite last_rcons. +qed. + +lemma bin0n (m : int) : bin 0 m = b2i (m = 0). +proof. by rewrite /bin iter0 //=; case: (m = 0). qed. + +lemma binSn n m : 0 <= n => 0 <= m => + bin (n + 1) (m + 1) = bin n (m + 1) + bin n m. +proof. +move=> ge0_n ge0_m; rewrite binp 1,2:/# iterS //. +pose s := iter n bin1 [1]; rewrite /bin1 -nth_behead //=. +case: (m < size s) => [lt_m_s|/lerNgt gt_m_s]; last first. ++ rewrite nth_default. + * by rewrite size_map size_range /#. + by rewrite !binp // ~-1:/# !nth_default ~-1://#. +rewrite (nth_map 0) 1:size_range /=; first by smt(size_ge0). +by rewrite !nth_range //= !binp //#. +qed. + +lemma ge0_bin (n k : int) : 0 <= bin n k. +proof. +case: (n < 0 \/ k < 0) => [@/bin ->//|]. +rewrite negb_or => -[/lezNgt ge0_n /lezNgt ge0_k]. +elim: n ge0_n k ge0_k => [|n ge0_n ih] k ge0_k. ++ by rewrite bin0n b2i_ge0. +case: k ge0_k => [|k ge0_k _]; 1: rewrite bin0 //#. +have h1 := ih (k+1) _; first by smt(). +have h2 := ih k _; first by smt(). +by rewrite binSn //; smt(). +qed. + +lemma bin_gt (n k : int) : n < k => bin n k = 0. +proof. +move=> lt_nk; rewrite /bin; case _: (_ \/ _) => //=. +rewrite negb_or => -[ge0_n ge0_k]. +by rewrite nth_out // size_bin /#. +qed. + +(* ==================================================================== *) +(* Binomial theorem on a [comring] carrier. Mirrors the legacy *) +(* [BinomialCoeffs] abstract theory but as a [section] over [t <: *) +(* comring]: the [clone Bigalg.BigComRing as BCR with ...] dance *) +(* disappears since [TcBigalg]'s lemmas are already polymorphic. *) +(* ==================================================================== *) +section. +declare type t <: comring. + +lemma binomial (x y : t) n : 0 <= n => exp (x + y) n = + bigiA predT (fun i => intmul (exp x i * exp y (n - i)) (bin n i)) 0 (n + 1). +proof. +elim: n => [|i ge0_i ih]. ++ by rewrite big_int1 /= !expr0 mul1r bin0 // mulr1z. +rewrite exprS // ih /= mulrDl 2!mulr_sumr. +rewrite (big_addn 1 _ (-1)) /= (big_int_recr (i+1)) 1:/# /=. +pose s1 := bigi _ _ _ _; rewrite binn // mulr1z. +rewrite !expr0 mulr1 -exprS // addrAC. +apply: eq_sym; rewrite (big_int_recr (i+1)) 1:/# /=. +rewrite binn 1:/# mulr1z !expr0 mulr1; congr. +apply: eq_sym; rewrite (big_int_recl _ 0) //=. +rewrite bin0 // mulr1z !expr0 mul1r -exprS // addrCA addrC; apply: eq_sym. +rewrite (big_int_recl _ 0) //= bin0 1:/# mulr1z !expr0 mul1r addrC. +congr; apply: eq_sym; rewrite /s1 => {s1}. +rewrite !(big_addn 1 _ (-1)) /= -big_split /=. +rewrite !big_seq &(eq_bigr) => /= j /mem_range rg_j. +rewrite mulrnAr ?ge0_bin mulrA -exprS 1:/# /= addrC. +rewrite mulrnAr ?ge0_bin mulrCA -exprS 1:/#. +rewrite addrAC opprB addrA. +by rewrite -mulrDz; congr; rewrite (binSn i (j-1)) 1,2:/#. +qed. + +end section. + +(* ==================================================================== *) +(* Specialisation at [real]: the binomial theorem with the real-valued *) +(* binomial coefficient written via [%r]. Mirrors [BCR.binomial]. *) +(* ==================================================================== *) +(* TC equivalent of [RField.intmulr]: at carrier [real], [intmul x c = + x * c%r]. Proved here since the legacy lives in [Real.ec:RField]. *) +lemma intmulr_real (x : real) (c : int) : intmul x c = x * c%r. +proof. +have h: forall cp, 0 <= cp => intmul x cp = x * cp%r. ++ elim=> /= [|cp ge0_cp ih]; first by rewrite mulr0z. + by rewrite mulrS // ih fromintD mulrDr mulr1 addrC. +case: (lezWP c 0) => [le0c|_ /h //]. +rewrite -{2}(@oppzK c) fromintN mulrN -h 1:/#. +by rewrite mulrNz opprK. +qed. + +(* The TC abbrev [(^) ['a <: comring]] and the legacy [(^) : real -> + int -> real] are both in scope here (the latter from [Real.ec] via + [AllCore]); they overlap at the [real] carrier. Until the legacy + algebra hierarchy is removed, write [exp] explicitly to pin the + TC version — required for [exact h] to align with [binomial<:real>]'s + TC [exp]. *) +lemma binomial_r (x y : real) n : 0 <= n => exp (x + y) n = + bigiA predT (fun i => (bin n i)%r * (exp x i * exp y (n - i))) 0 (n + 1). +proof. +move=> ge0_n. +have h := binomial<:real> x y n ge0_n. +rewrite (_ : exp (x + y) n = + bigiA predT (fun i => intmul (exp x i * exp y (n - i)) (bin n i)) 0 (n + 1)); + first by exact h. +by apply: eq_bigr => /= k _; rewrite intmulr_real mulrC mulrA. +qed. diff --git a/examples/tcalgebra/TcInt.ec b/examples/tcalgebra/TcInt.ec new file mode 100644 index 0000000000..1097f6d29c --- /dev/null +++ b/examples/tcalgebra/TcInt.ec @@ -0,0 +1,78 @@ +pragma +implicits. + +(* -------------------------------------------------------------------- *) +require import Core. +require import TcMonoid TcRing. +require import Int. +require CoreInt. + +(* ==================================================================== *) +(* Canonical [int] instance for the [TcMonoid] / [TcRing] hierarchy. + Mirrors [theories/algebra/Ring.ec:IntID]. *) +(* ==================================================================== *) + +(* Named wrappers for [int]'s [unit] / [invr]: the TC instance form + requires an op-name on the rhs of [op X = …], not an inline lambda. *) +op int_unit (z : int) : bool = z = 1 \/ z = -1. +op int_invr (z : int) : int = z. + +(* -------------------------------------------------------------------- *) +(* Declaring [idomain] synthesises [comring] (and the rest of the + chain) along the way, so we don't need a separate [instance comring + with int] — declaring both would create duplicate comring witnesses + for [int] and break op-name resolution downstream. *) +instance idomain with int reducible + op zero = 0 + op (+) = CoreInt.add + op [-] = CoreInt.opp + op oner = 1 + op ( * ) = CoreInt.mul + op invr = int_invr + op unit = int_unit + + proof mopA<:addmonoid> by smt() + proof mopC<:addmonoid> by smt() + proof mop0<:addmonoid> by smt() + proof addrN by smt() + proof oner_neq0 by smt() + proof mopA<:mulmonoid> by smt() + proof mopC<:mulmonoid> by smt() + proof mop0<:mulmonoid> by smt() + proof mulrDl by smt() + proof mulVr by smt(@CoreInt) + proof unitP by smt() + proof unitout by smt() + proof mulf_eq0 by smt(). + +op _spacer1 : int = 0. + +(* ==================================================================== *) +(* int-specific corollaries that sit on top of the [comring] / + [idomain] instances. Mirrors the lemmas under [Ring.ec:IntID]. *) +(* ==================================================================== *) + +(* int's abstract [intmul] coincides with concrete int multiplication. *) +lemma intmulz (z c : int) : intmul z c = Int.( * ) z c. +proof. +have h: forall cp, 0 <= cp => intmul z cp = Int.( * ) z cp. + elim=> /= [|cp ge0_cp ih]; first by rewrite mulr0z. + by rewrite mulrS // ih /#. +smt(opprK mulrNz opprK). +qed. + +(* Parity of [exp x n] for [x : int] tracks parity of [x] when [n > 0]. *) +lemma poddX (n x : int) : + 0 < n => odd (exp x n) = odd x. +proof. +rewrite ltz_def => - [] + ge0_n; elim: n ge0_n => // + + _ _. +elim=> [|n ge0_n ih]; first by rewrite expr1. +by rewrite exprS ?addz_ge0 // oddM ih andbb. +qed. + +lemma oddX (n x : int) : + 0 <= n => odd (exp x n) = (odd x \/ n = 0). +proof. +rewrite lez_eqVlt; case: (n = 0) => [->// _|+ h]. ++ by rewrite expr0 odd1. ++ by case: h => [<-//|] /poddX ->. +qed. diff --git a/examples/tcalgebra/TcMonoid.ec b/examples/tcalgebra/TcMonoid.ec new file mode 100644 index 0000000000..f91decfde9 --- /dev/null +++ b/examples/tcalgebra/TcMonoid.ec @@ -0,0 +1,114 @@ +require import Int. + +(* ==================================================================== *) +(* Abstract monoid: where all the lemmas live, written once. Names use + the neutral [mop]/[idm] vocabulary and the [m] (monoid) suffix so + downstream additive ([addmonoid]) and multiplicative ([mulmonoid]) + subclasses can introduce conventional ring-theoretic spellings + without ambiguity at multi-monoid carriers like [comring]. *) +(* ==================================================================== *) +type class monoid = { + op idm : monoid + op mop : monoid -> monoid -> monoid + + axiom mopA : associative mop + axiom mopC : commutative mop + axiom mop0 : left_id idm mop +}. + +(* -------------------------------------------------------------------- *) +section. +declare type t <: monoid. + +lemma mop0m: right_id idm<:t> mop. +proof. by move=> x; rewrite mopC mop0. qed. + +lemma mopCAm: left_commutative mop<:t>. +proof. by move=> x y z; rewrite !mopA (mopC x). qed. + +lemma mopACm: right_commutative mop<:t>. +proof. by move=> x y z; rewrite -!mopA (mopC y). qed. + +lemma mopACAm: interchange mop<:t> mop. +proof. by move=> x y z t; rewrite -!mopA (mopCAm y). qed. + +lemma iteropE n (x : t): iterop n mop x idm = iter n (mop x) idm. +proof. +elim/natcase n => [n le0_n|n ge0_n]. ++ by rewrite ?(iter0, iterop0). ++ by rewrite iterSr // mop0m iteropS. +qed. +end section. + +(* ==================================================================== *) +(* Additive flavor of [monoid]. Renames [idm]/[mop] to [zero]/[(+)] at + every [addmonoid] carrier. Below, section lemmas re-export the + monoid lemmas under [add]-prefixed names; because [`a <: addmonoid] + has exactly one [monoid] view, [mopA]/[mopC]/[mop0]/[mop0m]/... + resolve unambiguously here without explicit selectors. *) +(* ==================================================================== *) +type class addmonoid <: (monoid with idm = zero, mop = (+)) = {}. + +(* Manual abbrevs replace the auto-imported renamed ops. *) +abbrev (+) ['a <: addmonoid] = mop<:'a>. +abbrev zero ['a <: addmonoid] = idm<:'a>. + +section. +declare type t <: addmonoid. + +lemma addmA: associative (+)<:t>. +proof. by apply: mopA. qed. + +lemma addmC: commutative (+)<:t>. +proof. by apply: mopC. qed. + +lemma add0m: left_id zero<:t> (+). +proof. by apply: mop0. qed. + +lemma addm0: right_id zero<:t> (+). +proof. by apply: mop0m. qed. + +lemma addmCA: left_commutative (+)<:t>. +proof. by apply: mopCAm. qed. + +lemma addmAC: right_commutative (+)<:t>. +proof. by apply: mopACm. qed. + +lemma addmACA: interchange (+)<:t> (+). +proof. by apply: mopACAm. qed. +end section. + +(* ==================================================================== *) +(* Multiplicative flavor of [monoid]. Symmetric to [addmonoid]: renames + [idm]/[mop] to [oner]/[( * )]. Section lemmas use [mul]-prefixed + names and [1m] for left-identity. Unambiguous at [`a <: mulmonoid]. *) +(* ==================================================================== *) +type class mulmonoid <: (monoid with idm = oner, mop = ( * )) = {}. + +abbrev ( * ) ['a <: mulmonoid] = mop<:'a>. +abbrev oner ['a <: mulmonoid] = idm<:'a>. + +section. +declare type t <: mulmonoid. + +lemma mulmA: associative ( * )<:t>. +proof. by apply: mopA. qed. + +lemma mulmC: commutative ( * )<:t>. +proof. by apply: mopC. qed. + +lemma mul1m: left_id oner<:t> ( * ). +proof. by apply: mop0. qed. + +lemma mulm1: right_id oner<:t> ( * ). +proof. by apply: mop0m. qed. + +lemma mulmCA: left_commutative ( * )<:t>. +proof. by apply: mopCAm. qed. + +lemma mulmAC: right_commutative ( * )<:t>. +proof. by apply: mopACm. qed. + +lemma mulmACA: interchange ( * )<:t> ( * ). +proof. by apply: mopACAm. qed. +end section. diff --git a/examples/tcalgebra/TcNumber.ec b/examples/tcalgebra/TcNumber.ec new file mode 100644 index 0000000000..6cdae90cd3 --- /dev/null +++ b/examples/tcalgebra/TcNumber.ec @@ -0,0 +1,1517 @@ +pragma +implicits. + +(* -------------------------------------------------------------------- *) +require import Core Int AlgTactic StdRing. +require import TcMonoid TcRing. +require import TcInt. + +(* -------------------------------------------------------------------- *) +pred homo2 ['a 'b] (op_ : 'a -> 'b) (aR : 'a rel) (rR : 'b rel) = + forall x y, aR x y => rR (op_ x) (op_ y). + +pred mono2 ['a 'b] (op_ : 'a -> 'b) (aR : 'a rel) (rR : 'b rel) = + forall x y, rR (op_ x) (op_ y) <=> aR x y. + +lemma mono2W f (aR : 'a rel) (rR : 'b rel) : + mono2 f aR rR => homo2 f aR rR. +proof. by move=> + x y - ->. qed. + +lemma monoLR ['a 'b] f g (aR : 'a rel) (rR : 'b rel) : + cancel g f => mono2 f aR rR => forall x y, + rR (f x) y <=> aR x (g y). +proof. by move=> can_gf mf x y; rewrite -{1}[y]can_gf mf. qed. + +lemma monoRL ['a 'b] f g (aR : 'a rel) (rR : 'b rel) : + cancel g f => mono2 f aR rR => forall x y, + rR x (f y) <=> aR (g x) y. +proof. by move=> can_gf mf x y; rewrite -{1}can_gf mf. qed. + +(* ==================================================================== *) +(* Real-closed domain: ordered integral domain with norm. Mirrors *) +(* [theories/algebra/Number.ec:RealDomain] but as a TC class on top *) +(* of [idomain]. *) +(* ==================================================================== *) +type class tcrealdomain <: idomain = { + op "`|_|" : tcrealdomain -> tcrealdomain + op ( <= ) : tcrealdomain -> tcrealdomain -> bool + op ( < ) : tcrealdomain -> tcrealdomain -> bool + op minr : tcrealdomain -> tcrealdomain -> tcrealdomain + op maxr : tcrealdomain -> tcrealdomain -> tcrealdomain + + axiom ler_norm_add : + forall (x y : tcrealdomain), `|x + y| <= `|x| + `|y| + axiom addr_gt0 : + forall (x y : tcrealdomain), zero<:tcrealdomain> < x => zero < y => zero < x + y + axiom norm_eq0 : + forall (x : tcrealdomain), `|x| = zero<:tcrealdomain> => x = zero + axiom ger_leVge : + forall (x y : tcrealdomain), + zero<:tcrealdomain> <= x => zero <= y => (x <= y) \/ (y <= x) + axiom normrM : + forall (x y : tcrealdomain), `|x * y| = `|x| * `|y| + axiom ler_def : + forall (x y : tcrealdomain), x <= y <=> `|y - x| = y - x + axiom ltr_def : + forall (x y : tcrealdomain), x < y <=> (y <> x) /\ x <= y + axiom real_axiom : + forall (x : tcrealdomain), zero<:tcrealdomain> <= x \/ x <= zero + axiom minrE : + forall (x y : tcrealdomain), minr x y = if x <= y then x else y + axiom maxrE : + forall (x y : tcrealdomain), maxr x y = if y <= x then x else y +}. + +(* -------------------------------------------------------------------- *) +section. +declare type t <: tcrealdomain. + +(* -------------------------------------------------------------------- *) +(* Sign / positivity / order reflexivity *) +(* -------------------------------------------------------------------- *) + +lemma ger0_def (x : t): (zero <= x) <=> (`|x| = x). +proof. by rewrite ler_def subr0. qed. + +lemma subr_ge0 (x y : t): (zero <= x - y) <=> (y <= x). +proof. by rewrite ger0_def -ler_def. qed. + +lemma oppr_ge0 (x : t): (zero <= -x) <=> (x <= zero). +proof. by rewrite -sub0r subr_ge0. qed. + +lemma ler01: zero<:t> <= oner. +proof. +have n1_nz: `|oner<:t>| <> zero. ++ apply/(contraNneq _ _ (oner_neq0<:t>)) => /norm_eq0->; trivial. +by rewrite ger0_def -(inj_eq (mulfI _ n1_nz)) -normrM !mulr1. +qed. + +lemma ltr01: zero<:t> < oner. +proof. by rewrite ltr_def oner_neq0 ler01. qed. + +hint exact : ler01 ltr01. + +lemma ltrW (x y : t): x < y => x <= y. +proof. by rewrite ltr_def. qed. + +lemma lerr (x : t): x <= x. +proof. +have n2: `|ofint<:t> 2| = ofint 2. + rewrite -ger0_def (@ofintS 1) // ofint1 ltrW //. + by rewrite addr_gt0 ?ltr01. +rewrite ler_def subrr -(inj_eq (addrI `|zero<:t>|)) /= addr0. +by rewrite -mulr2z -mulr_intr -n2 -normrM mul0r. +qed. + +hint exact : lerr. + +lemma lerr_eq (x y : t): x = y => x <= y. +proof. by move=> ->; rewrite lerr. qed. + +lemma ltrr (x : t): !(x < x). +proof. by rewrite ltr_def. qed. + +lemma ltr_neqAle (x y : t): + (x < y) <=> (x <> y) /\ (x <= y). +proof. by rewrite ltr_def eq_sym. qed. + +lemma ler_eqVlt (x y : t): + (x <= y) <=> (x = y) \/ (x < y). +proof. by rewrite ltr_neqAle; case: (x = y)=> // ->; rewrite lerr. qed. + +lemma lt0r (x : t): + (zero < x) <=> (x <> zero) /\ (zero <= x). +proof. by rewrite ltr_def. qed. + +lemma le0r (x : t): + (zero <= x) <=> (x = zero) \/ (zero < x). +proof. by rewrite ler_eqVlt eq_sym. qed. + +lemma addr_ge0 (x y : t): + zero <= x => zero <= y => zero <= x + y. +proof. +rewrite le0r; case=> [->|gt0x]; rewrite ?add0r // le0r. +by case=> [->|gt0y]; rewrite ltrW ?addr0 ?addr_gt0. +qed. + +lemma lt0r_neq0 (x : t): + zero < x => (x <> zero). +proof. by rewrite lt0r; case (_ = _). qed. + +lemma ltr0_neq0 (x : t): + zero < x => (x <> zero). +proof. by rewrite lt0r; case: (_ = _). qed. + +lemma gtr_eqF (x y : t): + y < x => (x <> y). +proof. by rewrite ltr_def => -[]. qed. + +lemma ltr_eqF (x y : t): + x < y => (x <> y). +proof. by rewrite eq_sym=> /gtr_eqF ->. qed. + +lemma ler0n n : 0 <= n => zero<:t> <= ofint n. +proof. +elim: n => [|n ih h]; first by rewrite ofint0 lerr. +by rewrite ofintS // addr_ge0 // ?ler01. +qed. + +lemma ltr0Sn n : 0 <= n => zero<:t> < ofint (n + 1). +proof. +elim: n=> /= [|n ge0n ih]; first by rewrite ofint1 ltr01. +by rewrite (@ofintS (n+1)) // ?(addz_ge0, addr_gt0) // ltr01. +qed. + +lemma ltr0n n : 0 <= n => (zero<:t> < ofint n) = (0 < n). +proof. +elim: n => [|n ge0n _]; first by rewrite ofint0 ltrr. +by rewrite ltr0Sn // ltz_def addz_ge0 ?addz1_neq0. +qed. + +lemma pnatr_eq0 n : 0 <= n => (ofint<:t> n = zero) <=> (n = 0). +proof. +elim: n => [|n ge0n _]; rewrite ?ofint0 // gtr_eqF. + by apply: ltr0Sn. by rewrite addz1_neq0. +qed. + +lemma pmulr_rgt0 (x y : t): + zero < x => (zero < x * y) <=> (zero < y). +proof. +rewrite !ltr_def !ger0_def normrM mulf_eq0 negb_or. +by case=> ^nz_x -> -> /=; have /inj_eq -> := mulfI _ nz_x. +qed. + +lemma pmulr_rge0 (x y : t): + zero < x => (zero <= x * y) <=> (zero <= y). +proof. +rewrite !le0r mulf_eq0; case: (y = _) => //= ^lt0x. +by move/lt0r_neq0=> -> /=; apply/pmulr_rgt0. +qed. + +lemma normr_idP (x : t): (`|x| = x) <=> (zero <= x). +proof. by rewrite ger0_def. qed. + +lemma ger0_norm (x : t): zero <= x => `|x| = x. +proof. by apply/normr_idP. qed. + +lemma normr0: `|zero<:t>| = zero. +proof. by apply/ger0_norm/lerr. qed. + +lemma normr1: `|oner<:t>| = oner. +proof. by apply/ger0_norm/ler01. qed. + +lemma normr_nat n : 0 <= n => `|ofint<:t> n| = ofint n. +proof. by move=> n_0ge; rewrite ger0_norm // ler0n. qed. + +lemma normr0_eq0 (x : t): `|x| = zero => x = zero. +proof. by apply/norm_eq0. qed. + +lemma normr0P (x : t): (`|x| = zero) <=> (x = zero). +proof. by split=> [/norm_eq0|->] //; rewrite normr0. qed. + +lemma normrX_nat n (x : t) : 0 <= n => `|exp x n| = exp `|x| n. +proof. +elim: n=> [|n ge0_n ih]; first by rewrite !expr0 normr1. +by rewrite !exprS //= normrM ih. +qed. + +lemma normrN1: `|-oner<:t>| = oner. +proof. +have: exp `|-oner<:t>| 2 = oner. + by rewrite -normrX_nat -1?signr_odd // odd2 expr0 normr1. +rewrite sqrf_eq1=> -[->//|]; rewrite -ger0_def le0r oppr_eq0. +by rewrite oner_neq0 /= => /(addr_gt0 _ _ ltr01); rewrite addrN ltrr. +qed. + +lemma normrZ (x y : t) : zero <= x => `| x * y | = x * `| y |. +proof. by move=> ge0; rewrite normrM ger0_norm. qed. + +lemma normrN (x : t): `|- x| = `|x|. +proof. by rewrite -mulN1r normrM normrN1 mul1r. qed. + +lemma distrC (x y : t): `|x - y| = `|y - x|. +proof. by rewrite -opprB normrN. qed. + +lemma ler0_def (x : t): (x <= zero) <=> (`|x| = - x). +proof. by rewrite ler_def sub0r normrN. qed. + +lemma normr_unit : forall (x : t), unit x => unit `|x|. +proof. +move=> x; rewrite !unitrP => -[y yx]. +by exists `|y|; rewrite -normrM yx normr1. +qed. + +lemma ler0_norm (x : t): x <= zero => `|x| = - x. +proof. +move=> x_le0; rewrite eq_sym -(@ger0_norm (-x)). + by rewrite oppr_ge0. by rewrite normrN. +qed. + +lemma unit_normr (x : t): unit (`|x|) => unit x. +proof. +case: (real_axiom x) => [le0n|len0]. + by move: (normr_idP x); rewrite le0n /= => ->. +by rewrite ler0_norm // unitrN. +qed. + +lemma normrV : forall (x : t), `|invr x| = invr `|x|. +proof. +move=>x. +case: (unit x) => ux. ++ apply/(@mulrI `|x|); 1: by apply/normr_unit. + by rewrite -normrM !mulrV ?normr_unit // normr1. +rewrite !unitout //; apply: contra ux. +by apply unit_normr. +qed. + +lemma normr_id (x : t): `| `|x| | = `|x|. +proof. +have nz2: ofint<:t> 2 <> zero by rewrite pnatr_eq0. +apply: (mulfI _ nz2); rewrite -{1}normr_nat // -normrM. +rewrite mulr_intl mulr2z ger0_norm // -{2}normrN. +by rewrite -normr0 -(@subrr x) ler_norm_add. +qed. + +lemma normr_ge0 (x : t): zero <= `|x|. +proof. by rewrite ger0_def normr_id. qed. + +lemma gtr0_norm (x : t): zero < x => `|x| = x. +proof. by move/ltrW/ger0_norm. qed. + +lemma ltr0_norm (x : t): x < zero => `|x| = - x. +proof. by move/ltrW/ler0_norm. qed. + +lemma subr_gt0 (x y : t): (zero < y - x) <=> (x < y). +proof. by rewrite !ltr_def subr_eq0 subr_ge0. qed. + +lemma subr_le0 (x y : t): (y - x <= zero) <=> (y <= x). +proof. by rewrite -subr_ge0 opprB add0r subr_ge0. qed. + +lemma subr_lt0 (x y : t): (y - x < zero) <=> (y < x). +proof. by rewrite -subr_gt0 opprB add0r subr_gt0. qed. + +lemma ler_asym (x y : t): x <= y <= x => x = y. +proof. +rewrite !ler_def distrC -opprB -addr_eq0 => -[->]. +by rewrite -mulr2z -mulr_intl mulf_eq0 subr_eq0 pnatr_eq0. +qed. + +lemma eqr_le (x y : t): (x = y) <=> (x <= y <= x). +proof. by split=> [->|/ler_asym]; rewrite ?lerr. qed. + +lemma ltr_trans (y x z : t): x < y => y < z => x < z. +proof. +move=> le_xy le_yz; rewrite -subr_gt0 -(@subrK z y). +by rewrite -addrA addr_gt0 ?subr_gt0. +qed. + +lemma ler_lt_trans (y x z : t): x <= y => y < z => x < z. +proof. by rewrite !ler_eqVlt => -[-> //|/ltr_trans h]; apply/h. qed. + +lemma ltr_le_trans (y x z : t): x < y => y <= z => x < z. +proof. by rewrite !ler_eqVlt => lxy [<- //|lyz]; apply (@ltr_trans y). qed. + +lemma ler_trans (y x z : t): x <= y => y <= z => x <= z. +proof. +rewrite !ler_eqVlt => -[-> //|lxy] [<-|]. + by rewrite lxy. by move/(ltr_trans _ _ _ lxy) => ->. +qed. + +lemma ltr_asym (x y : t): ! (x < y < x). +proof. by apply/negP=> -[/ltr_trans hyx /hyx]; rewrite ltrr. qed. + +lemma ler_anti (x y : t): x <= y <= x => x = y. +proof. by rewrite -eqr_le. qed. + +lemma ltr_le_asym (x y : t): ! (x < y <= x). +proof. +rewrite andaE ltr_neqAle -andbA -!andaE. +by rewrite -eqr_le eq_sym; case: (_ = _). +qed. + +lemma ler_lt_asym (x y : t): + ! (x <= y < x). +proof. by rewrite andaE andbC -andaE ltr_le_asym. qed. + +lemma ltr_geF (x y : t): x < y => ! (y <= x). +proof. by move=> xy; apply/negP => /(ltr_le_trans _ _ _ xy); rewrite ltrr. qed. + +lemma ler_gtF (x y : t): x <= y => ! (y < x). +proof. by move=> le_xy; apply/negP=> /ltr_geF. qed. + +lemma ltr_gtF (x y : t): x < y => ! (y < x). +proof. by move/ltrW/ler_gtF. qed. + +lemma normr_le0 (x : t): (`|x| <= zero) <=> (x = zero). +proof. by rewrite -normr0P eqr_le normr_ge0. qed. + +lemma normr_lt0 (x : t): ! (`|x| < zero). +proof. by rewrite ltr_neqAle normr_le0 normr0P; case: (_ = _). qed. + +lemma normr_gt0 (x : t): (zero < `|x|) <=> (x <> zero). +proof. by rewrite ltr_def normr0P normr_ge0; case: (_ = _). qed. + +lemma normrX n (x : t) : `|exp x n| = exp `|x| n. +proof. +case (0 <= n); [by apply normrX_nat|]. +rewrite -ltzNge -{1}(invrK x) exprV => ltn0. +rewrite normrX_nat; [by rewrite oppz_ge0 ltzW|]. +case: (unit x) => [unitx|Nunitx]. + by rewrite normrV // exprV. +move: (unit_normr x) => /contra; rewrite Nunitx /=. +move => unitNx; rewrite invr_out //. +by rewrite -{1}(@invr_out `|_|) // exprV. +qed. + +(*-------------------------------------------------------------------- *) +hint rewrite normrE : normr_id normr0 normr1 normrN1. +hint rewrite normrE : normr_ge0 normr_lt0 normr_le0 normr_gt0. +hint rewrite normrE : normrN. + +(* -------------------------------------------------------------------- *) +lemma mono_inj (f : t -> t) : mono2 f (<=) (<=) => injective f. +proof. by move=> mf x y; rewrite eqr_le !mf -eqr_le. qed. + +lemma nmono_inj (f : t -> t) : mono2 f (fun y x => x <= y) (<=) => injective f. +proof. by move=> mf x y; rewrite eqr_le !mf -eqr_le. qed. + +lemma lerW_mono (f : t -> t) : mono2 f (<=) (<=) => mono2 f (<) (<). +proof. +move=> mf x y; rewrite !ltr_neqAle mf. +by rewrite inj_eq //; apply/mono_inj. +qed. + +lemma lerW_nmono (f : t -> t) : + mono2 f (fun y x => x <= y) (<=) + => mono2 f (fun y x => x < y) (<). +proof. +move=> mf x y; rewrite !ltr_neqAle mf eq_sym. +by rewrite inj_eq //; apply/nmono_inj. +qed. + +(* -------------------------------------------------------------------- *) +lemma ler_opp2 (x y : t): (-x <= -y) <=> (y <= x). +proof. by rewrite -subr_ge0 opprK addrC subr_ge0. qed. + +lemma ltr_opp2 (x y : t): (-x < -y) <=> (y < x). +proof. by rewrite lerW_nmono //; apply/ler_opp2. qed. + +lemma ler_oppr (x y : t): (x <= - y) <=> (y <= - x). +proof. by rewrite (monoRL opprK ler_opp2). qed. + +hint rewrite lter_opp2 : ler_opp2 ltr_opp2. + +lemma ltr_oppr (x y : t): (x < - y) <=> (y < - x). +proof. by rewrite (monoRL opprK (:@lerW_nmono _ ler_opp2)). qed. + +lemma ler_oppl (x y : t): + (- x <= y) <=> (- y <= x). +proof. by rewrite (monoLR opprK ler_opp2). qed. + +lemma ltr_oppl (x y : t): + (- x < y) <=> (- y < x). +proof. by rewrite (monoLR opprK (:@lerW_nmono _ ler_opp2)). qed. + +lemma oppr_gt0 (x : t): (zero < - x) <=> (x < zero). +proof. by rewrite ltr_oppr oppr0. qed. + +lemma oppr_le0 (x : t): (- x <= zero) <=> (zero <= x). +proof. by rewrite ler_oppl oppr0. qed. + +lemma oppr_lt0 (x : t): (- x < zero) <=> (zero < x). +proof. by rewrite ltr_oppl oppr0. qed. + +hint rewrite oppr_gte0 : oppr_ge0 oppr_gt0. +hint rewrite oppr_lte0 : oppr_le0 oppr_lt0. +hint rewrite oppr_cp0 : oppr_ge0 oppr_gt0 oppr_le0 oppr_lt0. +hint rewrite lter_oppE : oppr_le0 oppr_lt0 oppr_ge0 oppr_gt0. +hint rewrite lter_oppE : ler_opp2 ltr_opp2. + +(* -------------------------------------------------------------------- *) +lemma ler_leVge (x y : t): + x <= zero => y <= zero => (x <= y) \/ (y <= x). +proof. by rewrite -!oppr_ge0 => /(ger_leVge _) h /h; rewrite !ler_opp2 orbC. qed. + +lemma ler_add2l (x y z : t) : (x + y <= x + z) <=> (y <= z). +proof. by rewrite -subr_ge0 opprD addrAC addNKr addrC subr_ge0. qed. + +lemma ler_add2r (x y z : t) : (y + x <= z + x) <=> (y <= z). +proof. by rewrite !(@addrC _ x) ler_add2l. qed. + +lemma ltr_add2r (z x y : t): (x + z < y + z) <=> (x < y). +proof. by apply/(@lerW_mono (fun u => u + z) (:@ler_add2r z)). qed. + +lemma ltr_add2l (z x y : t): (z + x < z + y) <=> (x < y). +proof. by apply/(@lerW_mono (fun u => z + u) (:@ler_add2l z)). qed. + +hint rewrite ler_add2 : ler_add2l ler_add2r. +hint rewrite ltr_add2 : ltr_add2l ltr_add2r. +hint rewrite lter_add2 : ler_add2l ler_add2r ltr_add2l ltr_add2r. + +lemma ler_add (x y z u : t): + x <= y => z <= u => x + z <= y + u. +proof. by move=> xy zt; rewrite (@ler_trans (y + z)) ?lter_add2. qed. + +lemma ler_lt_add (x y z u : t): + x <= y => z < u => x + z < y + u. +proof. by move=> xy zt; rewrite (@ler_lt_trans (y + z)) ?lter_add2. qed. + +lemma ltr_le_add (x y z u : t): + x < y => z <= u => x + z < y + u. +proof. by move=> xy zt; rewrite (@ltr_le_trans (y + z)) ?lter_add2. qed. + +lemma ltr_add (x y z u : t): x < y => z < u => x + z < y + u. +proof. by move=> xy zt; rewrite ltr_le_add // ltrW. qed. + +lemma ler_sub (x y z u : t): + x <= y => u <= z => x - z <= y - u. +proof. by move=> xy tz; rewrite ler_add ?lter_opp2. qed. + +lemma ler_lt_sub (x y z u : t): + x <= y => u < z => x - z < y - u. +proof. by move=> xy zt; rewrite ler_lt_add ?lter_opp2. qed. + +lemma ltr_le_sub (x y z u : t): + x < y => u <= z => x - z < y - u. +proof. by move=> xy zt; rewrite ltr_le_add ?lter_opp2. qed. + +lemma ltr_sub (x y z u : t): + x < y => u < z => x - z < y - u. +proof. by move=> xy tz; rewrite ltr_add ?lter_opp2. qed. + +lemma ler_subl_addr (x y z : t): + (x - y <= z) <=> (x <= z + y). +proof. by rewrite (monoLR (:@addrK y) (:@ler_add2r (-y))). qed. + +lemma ltr_subl_addr (x y z : t): + (x - y < z) <=> (x < z + y). +proof. by rewrite (monoLR (:@addrK y) (:@ltr_add2r (-y))). qed. + +lemma ler_subr_addr (x y z : t): + (x <= y - z) <=> (x + z <= y). +proof. by rewrite (monoLR (:@addrNK z) (:@ler_add2r z)). qed. + +lemma ltr_subr_addr (x y z : t): + (x < y - z) <=> (x + z < y). +proof. by rewrite (monoLR (:@addrNK z) (:@ltr_add2r z)). qed. + +hint rewrite ler_sub_addr : ler_subl_addr ler_subr_addr. +hint rewrite ltr_sub_addr : ltr_subl_addr ltr_subr_addr. +hint rewrite lter_sub_addr : ler_subl_addr ler_subr_addr. +hint rewrite lter_sub_addr : ltr_subl_addr ltr_subr_addr. + +lemma ler_subl_addl (x y z : t): + (x - y <= z) <=> (x <= y + z). +proof. by rewrite lter_sub_addr addrC. qed. + +lemma ltr_subl_addl (x y z : t): + (x - y < z) <=> (x < y + z). +proof. by rewrite lter_sub_addr addrC. qed. + +lemma ler_subr_addl (x y z : t): + (x <= y - z) <=> (z + x <= y). +proof. by rewrite lter_sub_addr addrC. qed. + +lemma ltr_subr_addl (x y z : t): + (x < y - z) <=> (z + x < y). +proof. by rewrite lter_sub_addr addrC. qed. + +hint rewrite ler_sub_addl : ler_subl_addl ler_subr_addl. +hint rewrite ltr_sub_addl : ltr_subl_addl ltr_subr_addl. +hint rewrite lter_sub_addl : ler_subl_addl ler_subr_addl. +hint rewrite lter_sub_addl : ltr_subl_addl ltr_subr_addl. + +lemma ler_addl (x y : t): (x <= x + y) <=> (zero <= y). +proof. by rewrite -{1}(@addr0 x) lter_add2. qed. + +lemma ltr_addl (x y : t): (x < x + y) <=> (zero < y). +proof. by rewrite -{1}(@addr0 x) lter_add2. qed. + +lemma ler_addr (x y : t): (x <= y + x) <=> (zero <= y). +proof. by rewrite -{1}(@add0r x) lter_add2. qed. + +lemma ltr_addr (x y : t): (x < y + x) <=> (zero < y). +proof. by rewrite -{1}(@add0r x) lter_add2. qed. + +lemma ger_addl (x y : t): (x + y <= x) <=> (y <= zero). +proof. by rewrite -{2}(@addr0 x) lter_add2. qed. + +lemma gtr_addl (x y : t): (x + y < x) <=> (y < zero). +proof. by rewrite -{2}(@addr0 x) lter_add2. qed. + +lemma ger_addr (x y : t): (y + x <= x) <=> (y <= zero). +proof. by rewrite -{2}(@add0r x) lter_add2. qed. + +lemma gtr_addr (x y : t): (y + x < x) <=> (y < zero). +proof. by rewrite -{2}(@add0r x) lter_add2. qed. + +hint rewrite cpr_add : ler_addl ler_addr ger_addl ger_addl. +hint rewrite cpr_add : ltr_addl ltr_addr gtr_addl gtr_addl. + +lemma ler_paddl (y x z : t): + zero <= x => y <= z => y <= x + z. +proof. by move=> ??; rewrite -(@add0r y) ler_add. qed. + +lemma ltr_paddl (y x z : t): + zero <= x => y < z => y < x + z. +proof. by move=> ??; rewrite -(@add0r y) ler_lt_add. qed. + +lemma ltr_spaddl (y x z : t): + zero < x => y <= z => y < x + z. +proof. by move=> ??; rewrite -(@add0r y) ltr_le_add. qed. + +lemma ltr_spsaddl (y x z : t): + zero < x => y < z => y < x + z. +proof. by move=> ??; rewrite -(@add0r y) ltr_add. qed. + +lemma ler_naddl (y x z : t): + x <= zero => y <= z => x + y <= z. +proof. by move=> ??; rewrite -(@add0r z) ler_add. qed. + +lemma ltr_naddl (y x z : t): + x <= zero => y < z => x + y < z. +proof. by move=> ??; rewrite -(@add0r z) ler_lt_add. qed. + +lemma ltr_snaddl (y x z : t): + x < zero => y <= z => x + y < z. +proof. by move=> ??; rewrite -(@add0r z) ltr_le_add. qed. + +lemma ltr_snsaddl (y x z : t): + x < zero => y < z => x + y < z. +proof. by move=> ??; rewrite -(@add0r z) ltr_add. qed. + +lemma ler_paddr (y x z : t): + zero <= x => y <= z => y <= z + x. +proof. by move=> ??; rewrite (@addrC _ x) ler_paddl. qed. + +lemma ltr_paddr (y x z : t): + zero <= x => y < z => y < z + x. +proof. by move=> ??; rewrite (@addrC _ x) ltr_paddl. qed. + +lemma ltr_spaddr (y x z : t): + zero < x => y <= z => y < z + x. +proof. by move=> ??; rewrite (@addrC _ x) ltr_spaddl. qed. + +lemma ltr_spsaddr (y x z : t): + zero < x => y < z => y < z + x. +proof. by move=> ??; rewrite (@addrC _ x) ltr_spsaddl. qed. + +lemma ler_naddr (y x z : t): + x <= zero => y <= z => y + x <= z. +proof. by move=> ??; rewrite (@addrC _ x) ler_naddl. qed. + +lemma ltr_naddr (y x z : t): + x <= zero => y < z => y + x < z. +proof. by move=> ??; rewrite (@addrC _ x) ltr_naddl. qed. + +lemma ltr_snaddr (y x z : t): + x < zero => y <= z => y + x < z. +proof. by move=> ??; rewrite (@addrC _ x) ltr_snaddl. qed. + +lemma ltr_snsaddr (y x z : t): + x < zero => y < z => y + x < z. +proof. by move=> ??; rewrite (@addrC _ x) ltr_snsaddl. qed. + +(* -------------------------------------------------------------------- *) +lemma paddr_eq0 (x y : t): + zero <= x => zero <= y => (x + y = zero) <=> (x = zero) /\ (y = zero). +proof. +rewrite le0r=> -[->|hx]; first by rewrite add0r. +by rewrite (gtr_eqF hx) /= => hy; rewrite gtr_eqF // ltr_spaddl. +qed. + +lemma naddr_eq0 (x y : t): + x <= zero => y <= zero => (x + y = zero) <=> (x = zero) /\ (y = zero). +proof. +by move=> lex0 ley0; rewrite -oppr_eq0 opprD paddr_eq0 ?oppr_cp0 // !oppr_eq0. +qed. + +lemma addr_ss_eq0 (x y : t): + (zero <= x) /\ (zero <= y) \/ + (x <= zero) /\ (y <= zero) => + (x + y = zero) <=> (x = zero) /\ (y = zero). +proof. by case=> -[]; [apply: paddr_eq0 | apply: naddr_eq0]. qed. + +(* -------------------------------------------------------------------- *) +lemma ler_pmul2l (x : t) : + zero < x => forall y z, (x * y <= x * z) <=> (y <= z). +proof. +move=> x_gt0 y z /=; rewrite -subr_ge0 -mulrBr. +by rewrite pmulr_rge0 // subr_ge0. +qed. + +lemma ltr_pmul2l (x : t) : + zero < x => forall y z, (x * y < x * z) <=> (y < z). +proof. by move=> x_gt0; apply/lerW_mono/ler_pmul2l. qed. + +hint rewrite lter_pmul2l : ler_pmul2l ltr_pmul2l. + +lemma ler_pmul2r (x : t) : + zero < x => forall y z, (y * x <= z * x) <=> (y <= z). +proof. by move=> x_gt0 y z /=; rewrite !(@mulrC _ x) ler_pmul2l. qed. + +lemma ltr_pmul2r (x : t) : + zero < x => forall y z, (y * x < z * x) <=> (y < z). +proof. by move=> x_gt0; apply/lerW_mono/ler_pmul2r. qed. + +hint rewrite lter_pmul2r : ler_pmul2r ltr_pmul2r. + +lemma ler_nmul2l (x : t) : + x < zero => forall y z, (x * y <= x * z) <=> (z <= y). +proof. by move=> x_lt0 y z /=; rewrite -ler_opp2 -!mulNr ler_pmul2l ?oppr_gt0. qed. + +lemma ltr_nmul2l (x : t) : + x < zero => forall y z, (x * y < x * z) <=> (z < y). +proof. by move=> x_lt0; apply/lerW_nmono/ler_nmul2l. qed. + +hint rewrite lter_nmul2l : ler_nmul2l ltr_nmul2l. + +lemma ler_nmul2r (x : t) : + x < zero => forall y z, (y * x <= z * x) <=> (z <= y). +proof. by move=> x_lt0 y z /=; rewrite !(@mulrC _ x) ler_nmul2l. qed. + +lemma ltr_nmul2r (x : t) : + x < zero => forall y z, (y * x < z * x) <=> (z < y). +proof. by move=> x_lt0; apply/lerW_nmono/ler_nmul2r. qed. + +hint rewrite lter_nmul2r : ler_nmul2r ltr_nmul2r. + +(* -------------------------------------------------------------------- *) +lemma ler_wpmul2l (x : t) : + zero <= x => forall y z, y <= z => x * y <= x * z. +proof. +rewrite le0r => -[-> y z|/ler_pmul2l/mono2W ? //]. + by rewrite !mul0r lerr. +qed. + +lemma ler_wpmul2r (x : t) : + zero <= x => forall y z, y <= z => y * x <= z * x. +proof. by move=> x_ge0 y z leyz; rewrite !(@mulrC _ x) ler_wpmul2l. qed. + +lemma ler_wnmul2l (x : t) : + x <= zero => forall y z, y <= z => x * z <= x * y. +proof. +by move=> x_le0 y z leyz; rewrite -!(@mulrNN x) ler_wpmul2l ?lter_oppE. +qed. + +lemma ler_wnmul2r (x : t) : + x <= zero => forall y z, y <= z => z * x <= y * x. +proof. +by move=> x_le0 y z leyz; rewrite -!(@mulrNN _ x) ler_wpmul2r ?lter_oppE. +qed. + +(* -------------------------------------------------------------------- *) +lemma ler_pmul (x1 y1 x2 y2 : t): + zero <= x1 => zero <= x2 => x1 <= y1 => x2 <= y2 => x1 * x2 <= y1 * y2. +proof. +move=> x1ge0 x2ge0 le_xy1 le_xy2; have y1ge0 := ler_trans _ _ _ x1ge0 le_xy1. +have le1 := ler_wpmul2r _ x2ge0 _ _ le_xy1. +have le2 := ler_wpmul2l _ y1ge0 _ _ le_xy2. +by apply/(ler_trans _ le1 le2). +qed. + +lemma ltr_pmul (x1 y1 x2 y2 : t): + zero <= x1 => zero <= x2 => x1 < y1 => x2 < y2 => x1 * x2 < y1 * y2. +proof. +move=> x1ge0 x2ge0 lt_xy1 lt_xy2; apply/(@ler_lt_trans (y1 * x2)). + by apply/ler_wpmul2r/ltrW. +by apply/ltr_pmul2l=> //; apply/(ler_lt_trans _ x1ge0). +qed. + +(* -------------------------------------------------------------------- *) +lemma ler_total (x y : t) : (x <= y) \/ (y <= x). +proof. +have := real_axiom y; have := real_axiom x. +case: (zero <= x)=> /= [x_ge0|x_nge0 x_le0]; last first. + case: (zero <= y)=> /=; first by move/(ler_trans _ _ _ x_le0)=> ->. + by move=> _ /(ler_leVge _ _ x_le0). +by case=> [/(ger_leVge _ _ x_ge0) //| /ler_trans ->]. +qed. + +lemma ltr_total (x y : t) : x <> y => (x < y) \/ (y < x). +proof. by rewrite !ltr_def (@eq_sym _ y) => -> /=; apply: ler_total. qed. + +lemma ltrNge (x y : t): (x < y) <=> !(y <= x). +proof. +rewrite ltr_def; have := ler_total x y. +by case: (x <= y)=> //=; rewrite eqr_le => ->. +qed. + +lemma lerNgt (x y : t): (x <= y) <=> !(y < x). +proof. by rewrite ltrNge. qed. + +(* -------------------------------------------------------------------- *) +lemma pmulr_gt0 (x y : t) : zero <= x => zero <= y => + zero < x * y <=> zero < x /\ zero < y. +proof. +move=> x_ge0 y_ge0; split; last by smt(pmulr_rgt0). +smt (pmulr_rgt0 ltrNge ler_anti mul0r ltrr). +qed. + +(* -------------------------------------------------------------------- *) +lemma leVge (x y : t) : (x <= y) \/ (y <= x). +proof. exact ler_total. qed. + +lemma leVgt (x y : t) : (x <= y) \/ (y < x). +proof. by case: (x <= y) => // /ltrNge. qed. + +(* -------------------------------------------------------------------- *) +lemma ltrN10: -oner<:t> < zero. +proof. by rewrite oppr_lt0 ltr01. qed. + +lemma lerN10: -oner<:t> <= zero. +proof. by rewrite oppr_le0 ler01. qed. + +lemma ltr0N1: !(zero<:t> < -oner). +proof. by rewrite ler_gtF // lerN10. qed. + +lemma ler0N1: !(zero<:t> <= -oner). +proof. by rewrite ltr_geF // ltrN10. qed. + +lemma pmulr_rlt0 (x y : t): + zero < x => (x * y < zero) <=> (y < zero). +proof. +by move=> x_gt0; rewrite -oppr_gt0 -mulrN pmulr_rgt0 // oppr_gt0. +qed. + +lemma pmulr_rle0 (x y : t): + zero < x => (x * y <= zero) <=> (y <= zero). +proof. +by move=> x_gt0; rewrite -oppr_ge0 -mulrN pmulr_rge0 // oppr_ge0. +qed. + +lemma pmulr_lgt0 (x y : t): + zero < x => (zero < y * x) <=> (zero < y). +proof. by move=> x_gt0; rewrite mulrC pmulr_rgt0. qed. + +lemma pmulr_lge0 (x y : t): + zero < x => (zero <= y * x) <=> (zero <= y). +proof. by move=> x_gt0; rewrite mulrC pmulr_rge0. qed. + +lemma pmulr_llt0 (x y : t): + zero < x => (y * x < zero) <=> (y < zero). +proof. by move=> x_gt0; rewrite mulrC pmulr_rlt0. qed. + +lemma pmulr_lle0 (x y : t): + zero < x => (y * x <= zero) <=> (y <= zero). +proof. by move=> x_gt0; rewrite mulrC pmulr_rle0. qed. + +lemma nmulr_rgt0 (x y : t): + x < zero => (zero < x * y) <=> (y < zero). +proof. by move=> x_lt0; rewrite -mulrNN pmulr_rgt0 lter_oppE. qed. + +lemma nmulr_rge0 (x y : t): + x < zero => (zero <= x * y) <=> (y <= zero). +proof. by move=> x_lt0; rewrite -mulrNN pmulr_rge0 lter_oppE. qed. + +lemma nmulr_rlt0 (x y : t): + x < zero => (x * y < zero) <=> (zero < y). +proof. by move=> x_lt0; rewrite -mulrNN pmulr_rlt0 lter_oppE. qed. + +lemma nmulr_rle0 (x y : t): + x < zero => (x * y <= zero) <=> (zero <= y). +proof. by move=> x_lt0; rewrite -mulrNN pmulr_rle0 lter_oppE. qed. + +lemma nmulr_lgt0 (x y : t): + x < zero => (zero < y * x) <=> (y < zero). +proof. by move=> x_lt0; rewrite mulrC nmulr_rgt0. qed. + +lemma nmulr_lge0 (x y : t): + x < zero => (zero <= y * x) <=> (y <= zero). +proof. by move=> x_lt0; rewrite mulrC nmulr_rge0. qed. + +lemma nmulr_llt0 (x y : t): + x < zero => (y * x < zero) <=> (zero < y). +proof. by move=> x_lt0; rewrite mulrC nmulr_rlt0. qed. + +lemma nmulr_lle0 (x y : t): + x < zero => (y * x <= zero) <=> (zero <= y). +proof. by move=> x_lt0; rewrite mulrC nmulr_rle0. qed. + +lemma mulr_ge0 (x y : t): + zero <= x => zero <= y => zero <= x * y. +proof. by move=> x_ge0 y_ge0; rewrite -(mulr0 x) ler_wpmul2l. qed. + +lemma mulr_le0 (x y : t): + x <= zero => y <= zero => zero <= x * y. +proof. by move=> x_le0 y_le0; rewrite -(mulr0 x) ler_wnmul2l. qed. + +lemma mulr_ge0_le0 (x y : t): + zero <= x => y <= zero => x * y <= zero. +proof. by move=> x_le0 y_le0; rewrite -(mulr0 x) ler_wpmul2l. qed. + +lemma mulr_le0_ge0 (x y : t): + x <= zero => zero <= y => x * y <= zero. +proof. by move=> x_le0 y_le0; rewrite -(mulr0 x) ler_wnmul2l. qed. + +lemma mulr_gt0 (x y : t): + zero < x => zero < y => zero < x * y. +proof. by move=> x_gt0 y_gt0; rewrite pmulr_rgt0. qed. + +(* -------------------------------------------------------------------- *) +lemma ger_pmull (x y : t) : zero < y => (x * y <= y) <=> (x <= oner). +proof. by move=> hy; rewrite -{2}(mul1r y) ler_pmul2r. qed. + +lemma gtr_pmull (x y : t) : zero < y => (x * y < y) <=> (x < oner). +proof. by move=> hy; rewrite -{2}(mul1r y) ltr_pmul2r. qed. + +lemma ger_pmulr (x y : t) : zero < y => (y * x <= y) <=> (x <= oner). +proof. by move=> hy; rewrite -{2}(mulr1 y) ler_pmul2l. qed. + +lemma gtr_pmulr (x y : t) : zero < y => (y * x < y) <=> (x < oner). +proof. by move=> hy; rewrite -{2}(mulr1 y); rewrite ltr_pmul2l. qed. + +lemma ler_pmull (x y : t) : zero < y => (y <= x * y) <=> (oner <= x). +proof. by move=> hy; rewrite -{1}(mul1r y) ler_pmul2r. qed. + +lemma ltr_pmull (x y : t) : zero < y => (y < x * y) <=>(oner < x). +proof. by move=> hy; rewrite -{1}(mul1r y) ltr_pmul2r. qed. + +lemma ler_pmulr (x y : t) : zero < y => (y <= y * x) <=>(oner <= x). +proof. by move=> hy; rewrite -{1}(mulr1 y) ler_pmul2l. qed. + +lemma ltr_pmulr (x y : t) : zero < y => (y < y * x) <=>(oner < x). +proof. by move=> hy; rewrite -{1}(mulr1 y) ltr_pmul2l. qed. + +lemma ger_nmull (x y : t) : y < zero => (x * y <= y) = (oner <= x). +proof. by move=> hy; rewrite -{2}(mul1r y) ler_nmul2r. qed. + +lemma gtr_nmull (x y : t) : y < zero => (x * y < y) = (oner < x). +proof. by move=> hy; rewrite -{2}(mul1r y) ltr_nmul2r. qed. + +lemma ger_nmulr (x y : t) : y < zero => (y * x <= y) = (oner <= x). +proof. by move=> hy; rewrite -{2}(mulr1 y) ler_nmul2l. qed. + +lemma gtr_nmulr (x y : t) : y < zero => (y * x < y) = (oner < x). +proof. by move=> hy; rewrite -{2}(mulr1 y) ltr_nmul2l. qed. + +lemma ler_nmull (x y : t) : y < zero => (y <= x * y) <=> (x <= oner). +proof. by move=> hy; rewrite -{1}(mul1r y) ler_nmul2r. qed. + +lemma ltr_nmull (x y : t) : y < zero => (y < x * y) <=> (x < oner). +proof. by move=> hy; rewrite -{1}(mul1r y) ltr_nmul2r. qed. + +lemma ler_nmulr (x y : t) : y < zero => (y <= y * x) <=> (x <= oner). +proof. by move=> hy; rewrite -{1}(mulr1 y) ler_nmul2l. qed. + +lemma ltr_nmulr (x y : t) : y < zero => (y < y * x) <=> (x < oner). +proof. by move=> hy; rewrite -{1}(mulr1 y) ltr_nmul2l. qed. + +(* -------------------------------------------------------------------- *) +lemma ler_pemull (x y : t) : zero <= y => oner <= x => y <= x * y. +proof. by move=> hy hx; rewrite -{1}(mul1r y) ler_wpmul2r. qed. + +lemma ler_nemull (x y : t) : y <= zero => oner <= x => x * y <= y. +proof. by move=> hy hx; rewrite -{2}(mul1r y) ler_wnmul2r. qed. + +lemma ler_pemulr (x y : t) : zero <= y => oner <= x => y <= y * x. +proof. by move=> hy hx; rewrite -{1}(mulr1 y) ler_wpmul2l. qed. + +lemma ler_nemulr (x y : t) : y <= zero => oner <= x => y * x <= y. +proof. by move=> hy hx; rewrite -{2}(mulr1 y) ler_wnmul2l. qed. + +lemma ler_pimull (x y : t) : zero <= y => x <= oner => x * y <= y. +proof. by move=> hy hx; rewrite -{2}(mul1r y) ler_wpmul2r. qed. + +lemma ler_nimull (x y : t) : y <= zero => x <= oner => y <= x * y. +proof. by move=> hy hx; rewrite -{1}(mul1r y) ler_wnmul2r. qed. + +lemma ler_pimulr (x y : t) : zero <= y => x <= oner => y * x <= y. +proof. by move=> hy hx; rewrite -{2}(mulr1 y) ler_wpmul2l. qed. + +lemma ler_nimulr (x y : t) : y <= zero => x <= oner => y <= y * x. +proof. by move=> hx hy; rewrite -{1}(mulr1 y) ler_wnmul2l. qed. + +(* -------------------------------------------------------------------- *) +lemma mulr_ile1 (x y : t): + zero <= x => zero <= y => x <= oner => y <= oner => x * y <= oner. +proof. by move=> ????; rewrite (@ler_trans y) ?ler_pimull. qed. + +lemma mulr_ilt1 (x y : t): + zero <= x => zero <= y => x < oner => y < oner => x * y < oner. +proof. by move=> ????; rewrite (@ler_lt_trans y) ?ler_pimull // ?ltrW. qed. + +hint rewrite mulr_ilte1 : mulr_ile1 mulr_ilt1. +hint rewrite mulr_cp1 : mulr_ile1 mulr_ilt1. + +(* -------------------------------------------------------------------- *) +lemma mulr_ege1 (x y : t) : oner <= x => oner <= y => oner <= x * y. +proof. +by move=> le1x le1y; rewrite (@ler_trans y) ?ler_pemull // (ler_trans _ ler01). +qed. + +lemma mulr_egt1 (x y : t) : oner < x => oner < y => oner < x * y. +proof. +by move=> le1x lt1y; rewrite (@ltr_trans y) // ltr_pmull // (ltr_trans _ ltr01). +qed. + +hint rewrite mulr_egte1 : mulr_ege1 mulr_egt1. +hint rewrite mulr_cp1 : mulr_ege1 mulr_egt1. + +(* -------------------------------------------------------------------- *) +lemma invr_gt0 (x : t) : (zero < invr x) <=> (zero < x). +proof. +case: (unit x) => [ux|nux]; last by rewrite invr_out. +by split=> /ltr_pmul2r <-; rewrite mul0r (mulrV, mulVr) ?ltr01. +qed. + +lemma invr_ge0 (x : t) : (zero <= invr x) <=> (zero <= x). +proof. by rewrite !le0r invr_gt0 invr_eq0. qed. + +lemma invr_lt0 (x : t) : (invr x < zero) <=> (x < zero). +proof. by rewrite -oppr_cp0 -invrN invr_gt0 oppr_cp0. qed. + +lemma invr_le0 (x : t) : (invr x <= zero) <=> (x <= zero). +proof. by rewrite -oppr_cp0 -invrN invr_ge0 oppr_cp0. qed. + +(* -------------------------------------------------------------------- *) +lemma divr_ge0 (x y : t) : zero <= x => zero <= y => zero <= x / y. +proof. by move=> x_ge0 y_ge0; rewrite mulr_ge0 ?invr_ge0. qed. + +lemma divr_gt0 (x y : t) : zero < x => zero < y => zero < x / y. +proof. by move=> x_gt0 y_gt0; rewrite pmulr_rgt0 ?invr_gt0. qed. + +(* -------------------------------------------------------------------- *) +lemma ler_pinv : + forall (x y : t), unit x => zero < x => unit y => zero < y => + (invr y <= invr x) <=> (x <= y). +proof. +move=> x y Ux hx Uy hy; rewrite -(ler_pmul2l hx) -(ler_pmul2r hy). +by rewrite !(divrr, mulrVK) // mul1r. +qed. + +lemma ler_ninv : + forall (x y : t), unit x => x < zero => unit y => y < zero => + (invr y <= invr x) <=> (x <= y). +proof. +move=> x y Ux hx Uy hy; rewrite -(ler_nmul2l hx) -(ler_nmul2r hy). +by rewrite !(divrr, mulrVK) // mul1r. +qed. + +lemma ltr_pinv : + forall (x y : t), unit x => zero < x => unit y => zero < y => + (invr y < invr x) <=> (x < y). +proof. +move=> x y Ux hx Uy hy; rewrite -(ltr_pmul2l hx) -(ltr_pmul2r hy). +by rewrite !(divrr, mulrVK) // mul1r. +qed. + +lemma ltr_ninv : + forall (x y : t), unit x => x < zero => unit y => y < zero => + (invr y < invr x) <=> (x < y). +proof. +move=> x y Ux hx Uy hy; rewrite -(ltr_nmul2l hx) -(ltr_nmul2r hy). +by rewrite !(divrr, mulrVK) // mul1r. +qed. + +(* -------------------------------------------------------------------- *) +lemma invr_gt1 (x : t) : unit x => zero < x => (oner < invr x) <=> (x < oner). +proof. by move=> Ux gt0_x; rewrite -{1}invr1 ltr_pinv ?unitr1 ?ltr01. qed. + +lemma invr_ge1 (x : t) : unit x => zero < x => (oner <= invr x) <=> (x <= oner). +proof. by move=> Ux gt0_x; rewrite -{1}invr1 ler_pinv ?unitr1 ?ltr01. qed. + +hint rewrite invr_gte1 : invr_ge1 invr_gt1. +hint rewrite invr_cp1 : invr_ge1 invr_gt1. + +lemma invr_le1 (x : t) : unit x => zero < x => (invr x <= oner) <=> (oner <= x). +proof. by move=> ux hx; rewrite -invr_ge1 ?invr_gt0 ?unitrV // invrK. qed. + +lemma invr_lt1 (x : t) : unit x => zero < x => (invr x < oner) <=> (oner < x). +proof. by move=> ux hx; rewrite -invr_gt1 ?invr_gt0 ?unitrV // invrK. qed. + +hint rewrite invr_lte1 : invr_le1 invr_lt1. +hint rewrite invr_cp1 : invr_le1 invr_lt1. + +(* -------------------------------------------------------------------- *) +lemma expr_ge0 n (x : t) : zero <= x => zero <= exp x n. +proof. +move=> ge0_x; elim/intwlog: n. ++ by move=> n; rewrite exprN invr_ge0. ++ by rewrite expr0 ler01. ++ by move=> n ge0_n ge0_e; rewrite exprS // mulr_ge0. +qed. + +lemma expr_gt0 n (x : t) : zero < x => zero < exp x n. +proof. by rewrite !lt0r expf_eq0 => -[->/=]; apply/expr_ge0. qed. + +hint rewrite expr_gte0 : expr_ge0 expr_gt0. + +lemma exprn_ile1 n (x : t) : 0 <= n => zero <= x <= oner => exp x n <= oner. +proof. +move=> nge0 [xge0 xle1]; elim: n nge0; 1: by rewrite expr0. +by move=> n ge0_n ih; rewrite exprS // mulr_ile1 ?expr_ge0. +qed. + +lemma exprn_ilt1 n (x : t) : + 0 <= n => zero <= x < oner => (exp x n < oner) <=> (n <> 0). +proof. +move=> nge0 [xge0 xlt1]; case: n nge0; 1: by rewrite expr0 ltrr. +move=> n nge0 _; rewrite addz_neq0 //=; elim: n nge0; 1: by rewrite expr1. +by move=> n nge0 ih; rewrite exprS 1:addz_ge0 // mulr_ilt1 ?expr_ge0. +qed. + +hint rewrite exprn_ilte1 : exprn_ile1 exprn_ilt1. +hint rewrite exprn_cp1 : exprn_ile1 exprn_ilt1. + +lemma exprn_ege1 n (x : t) : 0 <= n => oner <= x => oner <= exp x n. +proof. +move=> nge0 xge1; elim: n nge0 => [|n nge0 ih]; 1: by rewrite expr0. +by rewrite exprS // mulr_ege1. +qed. + +lemma exprn_egt1 n (x : t) : 0 <= n => oner < x => (oner < exp x n) <=> (n <> 0). +proof. +move=> nge0 xgt1; case: n nge0 => [|n nge0 _]; 1: by rewrite expr0 ltrr. +elim: n nge0 => [|n ge0n]; 1: by rewrite expr1. +rewrite !addz1_neq0 ?addz_ge0 //= => ih. +by rewrite (@exprS _ (n+1)) 1:addz_ge0 // mulr_egt1. +qed. + +hint rewrite exprn_egte1 : exprn_ege1 exprn_egt1. +hint rewrite exprn_cp1 : exprn_ege1 exprn_egt1. + +lemma ler_iexpr (x : t) n : 0 < n => zero <= x <= oner => exp x n <= x. +proof. +rewrite ltz_def => -[nz_n ge0_n]; case: n ge0_n nz_n => // n ge0_n _ _. +by case=> xge0 xlt1; rewrite exprS // ler_pimulr // exprn_ile1. +qed. + +lemma ltr_iexpr (x : t) n : 0 <= n => zero < x < oner => (exp x n < x <=> 1 < n). +proof. +move=> nge0 [xgt0 xlt1]; case: n nge0 => /= [|n nge0 _]. ++ by rewrite expr0 ltrNge ltrW. +case: n nge0 => /= [|n nge0 _]; first by rewrite expr1 ltrr. +rewrite (@ltz_add2r 1 0 (n+1)) -lez_add1r /= lez_addr nge0 /=. +rewrite (@exprS _ (n+1)) 1:addz_ge0 // gtr_pmulr //. +by rewrite exprn_ilt1 ?(addz_neq0, addz_ge0) // ltrW. +qed. + +hint rewrite lter_iexpr : ler_iexpr ltr_iexpr. +hint rewrite lter_expr : ler_iexpr ltr_iexpr. + +lemma ler_eexpr (x : t) n : 0 < n => oner <= x => x <= exp x n. +proof. +rewrite ltz_def => -[nz_n ge0_n]; case: n ge0_n nz_n => //=. +move=> n ge0_n _ _ ge1_x; rewrite exprS //. +by rewrite ler_pemulr 2:exprn_ege1 // &(@ler_trans oner) ?ler01. +qed. + +lemma ltr_eexpr (x : t) n : 0 <= n => oner < x => (x < exp x n <=> 1 < n). +proof. +move=> ge0_n lt1_x; case: n ge0_n; 1: by rewrite expr0 ltrNge ltrW. +move=> + + _; case=> /= [|n ge0_n _]; first by rewrite expr1 ltrr. +rewrite (@ltz_add2r 1 0 (n+1)) -lez_add1r /= lez_addr ge0_n /=. +rewrite (@exprS _ (n+1)) 1:addz_ge0 // ltr_pmulr 1:&(@ltr_trans oner) //. +by rewrite exprn_egt1 // ?(addz_neq0, addz_ge0). +qed. + +hint rewrite lter_eexpr : ler_eexpr ltr_eexpr. +hint rewrite lter_expr : ler_eexpr ltr_eexpr. + +lemma ler_wiexpn2l (x : t) : zero <= x <= oner => + forall m n, 0 <= n <= m => exp x m <= exp x n. +proof. +move=> [xge0 xle1] m n [ge0_n le_nm]; have ->: m = (m - n) + n by ring. +by rewrite exprD_nneg 1:subz_ge0 // ler_pimull ?(expr_ge0, exprn_ile1) ?subz_ge0. +qed. + +lemma ler_weexpn2l (x : t) : oner <= x => + forall m n, 0 <= m <= n => exp x m <= exp x n. +proof. +move=> ge1_x m n [ge0_m le_mn]; have ->: n = (n - m) + m by ring. +rewrite exprD_nneg 1:subz_ge0 // ler_pemull ?(expr_ge0, exprn_ege1) //. ++ by rewrite (@ler_trans oner). + by rewrite subz_ge0. +qed. + +lemma ler_weexpn2r (x : t) : oner < x => + forall m n, 0 <= m => 0 <= n => exp x m <= exp x n => m <= n. +proof. +move => lt1x m n le0m le0n; rewrite -implybNN -ltrNge -ltzNge ltzE => le_m; apply (ltr_le_trans (exp x (n + 1))). ++ by rewrite exprS //; apply ltr_pmull => //; apply/expr_gt0/(ler_lt_trans oner). +by apply ler_weexpn2l; [apply ltrW|split => //; apply addz_ge0]. +qed. + +lemma ieexprn_weq1 (x : t) n : 0 <= n => zero <= x => + (exp x n = oner) <=> (n = 0 || x = oner). +proof. +case: n => [|n ge0_n _] ge0_x; first by rewrite expr0. +rewrite !addz_neq0 //=; split=> [|->]; last by rewrite expr1z. +case: (x = oner) => [->//|/ltr_total [] hx] /=. ++ by rewrite ltr_eqF // exprn_ilt1 // (addz_ge0, addz_neq0). ++ by rewrite gtr_eqF // exprn_egt1 // (addz_ge0, addz_neq0). +qed. + +lemma ieexprIn (x : t) : zero < x => x <> oner => + forall m n, 0 <= m => 0 <= n => exp x m = exp x n => m = n. +proof. +(* FIXME: wlog *) +move=> gt0_x neq1_x m n; pose P := fun m n => 0 <= m => 0 <= n => + exp x m = exp x n => m = n; rewrite -/(P m n). +have: (forall m n, (m <= n)%Int => P m n) => P m n. ++ move=> ih; case: (lez_total m n); first by apply/ih. + by move/ih=> @/P h *; rewrite -h // eq_sym. +apply=> {m n} m n le_mn ge0_m ge0_n {P}. +have ->: n = m + (n - m) by ring. +rewrite exprD_nneg 2:subz_ge0 // -{1}(mulr1 (exp x m)). +have h/h{h} := mulfI (exp x m) _; first by rewrite expf_eq0 gtr_eqF. +by rewrite eq_sym ieexprn_weq1 1?(subz_ge0, ltrW) //#. +qed. + +lemma ler_pexp n (x y : t) : + 0 <= n => zero <= x <= y => exp x n <= exp y n. +proof. +move=> h; elim/intind: n h x y => [|n ge0_n ih] x y [ge0_x le_xy]. ++ by rewrite !expr0. ++ by rewrite !exprS // ler_pmul // ?expr_ge0 ?ih. +qed. + +lemma ge0_sqr (x : t) : zero <= exp x 2. +proof. +rewrite expr2; case: (zero <= x); first by move=> h; apply/mulr_ge0. +by rewrite lerNgt /= => /ltrW le0_x; apply/mulr_le0. +qed. + +(* -------------------------------------------------------------------- *) +lemma ler_norm_sub (x y : t): + `|x - y| <= `|x| + `|y|. +proof. by rewrite -(@normrN y) ler_norm_add. qed. + +lemma ler_dist_add (z x y : t): + `|x - y| <= `|x - z| + `|z - y|. +proof. +apply/(ler_trans _ _ (:@ler_norm_add (x-z) (z-y))). +by rewrite addrA addrNK lerr. +qed. + +lemma ler_sub_norm_add (x y : t): + `|x| - `|y| <= `|x + y|. +proof. +rewrite -{1}(@addrK y x) lter_sub_addl; + rewrite (ler_trans _ (:@ler_norm_add (x+y) (-y))) //. +by rewrite addrC normrN lerr. +qed. + +lemma ler_sub_dist (x y : t): + `|x| - `|y| <= `|x - y|. +proof. by rewrite -(@normrN y) ler_sub_norm_add. qed. + +lemma ler_dist_dist (x y : t): + `| `|x| - `|y| | <= `|x - y|. +proof. +case: (`|x| <= `|y|); last first. + rewrite -ltrNge=> /ltrW le_yx; + by rewrite ger0_norm ?ler_sub_dist // subr_ge0. +move=> le_xy; rewrite ler0_norm ?subr_le0 //. +by rewrite distrC opprB ler_sub_dist. +qed. + +lemma ler_dist_norm_add (x y : t): + `| `|x| - `|y| | <= `|x + y|. +proof. by rewrite -(@opprK y) normrN ler_dist_dist. qed. + +lemma ler_nnorml (x y : t): y < zero => ! (`|x| <= y). +proof. by move=> y_lt0; rewrite ltr_geF // (ltr_le_trans _ y_lt0) ?normr_ge0. qed. + +lemma ltr_nnorml (x y : t): y <= zero => ! (`|x| < y). +proof. by move=> y_le0; rewrite ler_gtF // (ler_trans _ y_le0) ?normr_ge0. qed. + +lemma eqr_norm_id (x : t): (`|x| = x) <=> (zero <= x). +proof. by rewrite ger0_def. qed. + +lemma eqr_normN (x : t): (`|x| = - x) <=> (x <= zero). +proof. by rewrite ler0_def. qed. + +lemma normE (n : t) : + `|n| = if zero <= n then n else -n. +proof. +move: (real_axiom n); rewrite or_andr => -[le0n|[Nle0n len0]]. ++ by rewrite le0n /= eqr_norm_id. +by rewrite Nle0n /= eqr_normN. +qed. + +(* -------------------------------------------------------------------- *) +lemma ler_norm (x : t) : x <= `|x|. +proof. +case: (zero <= x); first by move/ger0_norm=> ->; apply/lerr. +move/ltrNge=> /ltrW ^h /ler0_norm ->; apply/(ler_trans zero)=> //. +by rewrite oppr_ge0. +qed. + +lemma eqr_norml (x y : t) : (`|x| = y) <=> ((x = y) \/ (x = -y)) /\ (zero <= y). +proof. +split=> [|[]]; last by case=> -> h; rewrite ?normrN ger0_norm. +move=> <-; rewrite normr_ge0 /=; case: (x <= zero) => [|/ltrNge]. + by move/ler0_norm=> ->; rewrite opprK. +by move/gtr0_norm=> ->. +qed. + +(* -------------------------------------------------------------------- *) +lemma ler_norml (x y : t) : (`|x| <= y) <=> (- y <= x <= y). +proof. +have h: forall (z : t), zero <= z => (z <= y) <=> (- y <= z <= y). + move=> z ge0_z; case: (z <= y)=> //= le_zy; apply/(ler_trans zero)=> //. + by rewrite oppr_le0 (ler_trans z). +case: (zero <= x) => [^ge0_x /h|/ltrNge/ltrW ge0_x]; first by rewrite ger0_norm. +rewrite -(opprK x) normrN ler_opp2 andaE andbC ler_oppl h. + by rewrite normr_ge0. by rewrite ger0_norm // oppr_ge0. +qed. + +lemma ltr_normr (x y : t) : (x < `|y|) <=> (x < y) \/ (x < - y). +proof. by rewrite ltrNge ler_norml andaE negb_and -!ltrNge ltr_oppr orbC. qed. + +lemma ltr_norml : forall (x y : t), (`|x| < y) <=> (- y < x < y). +proof. +have h: + (forall (x y : t), zero <= x => (`|x| < y) <=> (- y < x < y)) + => forall (x y : t), (`|x| < y) <=> (- y < x < y). ++ move=> wlog x y; case: (leVge zero x) => [/wlog|hx]; 1: by apply. + rewrite -(opprK x) normrN wlog ?oppr_ge0 //. + by rewrite !ltr_opp2 !andaE andbC opprK. +apply/h=> x y hx; rewrite ger0_norm //; case: (x < y) => //= le_xy. +by rewrite (ltr_le_trans _ _ hx) oppr_lt0 (ler_lt_trans _ hx). +qed. + +lemma ler_normr (x y : t) : (x <= `|y|) <=> (x <= y) \/ (x <= - y). +proof. +by rewrite lerNgt ltr_norml // andaE negb_and !lerNgt orbC ltr_oppl. +qed. + +(* -------------------------------------------------------------------- *) +lemma maxrC (x y : t) : maxr x y = maxr y x. +proof. by rewrite !maxrE lerNgt ler_eqVlt; case: (x = y); case: (x < y). qed. + +lemma maxrA (x y z: t): maxr (maxr x y) z = maxr x (maxr y z). +proof. +rewrite !maxrE. +case (y <= x); case (z <= y); case (z <= x) => // + [/#||/#|/#|]. +- smt(ler_trans). +- smt(ltr_trans ltrNge). +qed. + +lemma maxrl (x y : t) : x <= maxr x y. +proof. by rewrite maxrE; case: (y <= x) => [_|/ltrNge/ltrW]. qed. + +lemma maxrr (x y : t) : y <= maxr x y. +proof. by rewrite maxrC maxrl. qed. + +lemma ler_maxr (x y : t) : x <= y => maxr x y = y. +proof. by rewrite maxrE lerNgt ler_eqVlt => -> /#. qed. + +lemma ler_maxl (x y : t) : y <= x => maxr x y = x. +proof. by rewrite maxrC &(ler_maxr). qed. + +lemma maxr_ub (x y : t) : x <= maxr x y /\ y <= maxr x y. +proof. by rewrite maxrl maxrr. qed. + +lemma ler_maxrP (m n1 n2 : t) : (maxr n1 n2 <= m) <=> (n1 <= m) /\ (n2 <= m). +proof. +split; last by case=> le1 le2; rewrite maxrE; case: (n2 <= n1). +rewrite maxrE; case: (n2 <= n1). +* by move=> le_21 le_n1m; rewrite (ler_trans _ le_21 le_n1m). +* rewrite lerNgt /= => /ltrW le_12 le_n1m. + by rewrite (ler_trans _ le_12 le_n1m). +qed. + +lemma ltr_maxrP (m n1 n2 : t) : (maxr n1 n2 < m) <=> (n1 < m) /\ (n2 < m). +proof. +split; last by case=> le1 le2; rewrite maxrE; case: (n2 <= n1). +rewrite maxrE; case: (n2 <= n1). +* by move=> le_21 lt_n1m; rewrite (ler_lt_trans _ le_21 lt_n1m). +* rewrite lerNgt /= => lt_12 lt_n1m. + by rewrite (ltr_trans _ lt_12 lt_n1m). +qed. + +lemma ler_maxr_trans (x1 x2 y1 y2 : t) : + x1 <= x2 => y1 <= y2 => maxr x1 y1 <= maxr x2 y2. +proof. + by move=> hx hy; rewrite ler_maxrP; case (maxr_ub x2 y2) => hx' hy'; split; + [apply: ler_trans hx' | apply: ler_trans hy']. +qed. + +lemma ler_norm_maxr (x1 x2 : t) : + zero <= x1 => + zero <= x2 => + `| x1 - x2 | <= maxr x1 x2. +proof. + rewrite maxrE normE; case: (x2 <= x1). + + rewrite subr_ge0 => -> /= *; apply ler_subr_addr. + by rewrite opprK ler_addl. + rewrite ler_subr_addr add0r => -> /=. + by rewrite opprB -ler_subr_addr opprK ler_addl. +qed. + +(* -------------------------------------------------------------------- *) +lemma minrC (x y : t) : minr x y = minr y x. +proof. by rewrite !minrE lerNgt ler_eqVlt; case: (y = x); case: (y < x). qed. + +lemma minrA (x y z : t) : minr (minr x y) z = minr x (minr y z). +proof. +rewrite !minrE. +case (x <= y); case (y <= z); case (x <= z) => // + [/#||/#|/#|]. +- smt(ler_trans). +- smt(ltr_trans ltrNge). +qed. + +lemma minrl (x y : t) : minr x y <= x. +proof. by rewrite minrE; case: (x <= y) => [_|/ltrNge/ltrW]. qed. + +lemma minrr (x y : t) : minr x y <= y. +proof. by rewrite minrC minrl. qed. + +lemma ler_minl (x y : t) : x <= y => minr x y = x. +proof. by rewrite minrE lerNgt => ->. qed. + +lemma ler_minr (x y : t) : y <= x => minr x y = y. +proof. by rewrite minrC &(ler_minl). qed. + +lemma minr_lb (x y : t) : minr x y <= x /\ minr x y <= y. +proof. by rewrite minrl minrr. qed. + +end section. + +(* ==================================================================== *) +(* Real-closed field: a [tcrealdomain] where every nonzero element is *) +(* invertible (the field axiom). Mirrors *) +(* [theories/algebra/Number.ec:RealField]. We extend [tcrealdomain] *) +(* (single parent) and add the field axiom locally rather than *) +(* multi-inherit from [tcrealdomain & field]: under multi-parent *) +(* inheritance, both parent paths reach [comring] / [idomain] *) +(* without renamings, leaving [invr]'s parent-DAG witness ambiguous *) +(* across applications and breaking proof terms downstream. *) +(* ==================================================================== *) +type class tcrealfield <: tcrealdomain & field = {}. + +(* -------------------------------------------------------------------- *) +section. +declare type t <: tcrealfield. + +(* -------------------------------------------------------------------- *) +lemma lef_pinv (x y : t) : + zero < x => zero < y => (invr y <= invr x) <=> (x <= y). +proof. by move=> hx hy; apply/ler_pinv => //; apply/unitfP/gtr_eqF. qed. + +lemma lef_ninv (x y : t) : + x < zero => y < zero => (invr y <= invr x) <=> (x <= y). +proof. by move=> hx hy; apply/ler_ninv => //; apply/unitfP/ltr_eqF. qed. + +lemma ltf_pinv (x y : t) : + zero < x => zero < y => (invr y < invr x) <=> (x < y). +proof. by move=> hx hy; apply/ltr_pinv => //; apply/unitfP/gtr_eqF. qed. + +lemma ltf_ninv (x y : t) : + x < zero => y < zero => (invr y < invr x) <=> (x < y). +proof. by move=> hx hy; apply/ltr_ninv => //; apply/unitfP/ltr_eqF. qed. + +(* -------------------------------------------------------------------- *) +lemma ler_pdivl_mulr (z x y : t) : + zero < z => (x <= y / z) <=> (x * z <= y). +proof. by move=> z_gt0; rewrite -(@ler_pmul2r z) // mulrVK ?unitfP ?gtr_eqF. qed. + +lemma ltr_pdivl_mulr (z x y : t) : + zero < z => (x < y / z) <=> (x * z < y). +proof. by move=> z_gt0; rewrite -(@ltr_pmul2r z) // mulrVK ?unitfP ?gtr_eqF. qed. + +hint rewrite lter_pdivl_mulr : ler_pdivl_mulr ltr_pdivl_mulr. + +(* -------------------------------------------------------------------- *) +lemma ler_pdivr_mulr (z x y : t) : + zero < z => (y / z <= x) <=> (y <= x * z). +proof. by move=> z_gt0; rewrite -(@ler_pmul2r z) // mulrVK ?unitfP ?gtr_eqF. qed. + +lemma ltr_pdivr_mulr (z x y : t) : + zero < z => (y / z < x) <=> (y < x * z). +proof. by move=> z_gt0; rewrite -(@ltr_pmul2r z) // mulrVK ?unitfP ?gtr_eqF. qed. + +hint rewrite lter_pdivr_mulr : ler_pdivr_mulr ltr_pdivr_mulr. + +(* -------------------------------------------------------------------- *) +lemma ler_pdivl_mull (z x y : t) : + zero < z => (x <= invr z * y) <=> (z * x <= y). +proof. by move=> z_gt0; rewrite mulrC ler_pdivl_mulr ?(@mulrC z). qed. + +lemma ltr_pdivl_mull (z x y : t) : + zero < z => (x < invr z * y) <=> (z * x < y). +proof. by move=> z_gt0; rewrite mulrC ltr_pdivl_mulr ?(@mulrC z). qed. + +hint rewrite lter_pdivl_mull : ler_pdivl_mull ltr_pdivl_mull. + +(* -------------------------------------------------------------------- *) +lemma ler_pdivr_mull (z x y : t) : + zero < z => (invr z * y <= x) <=> (y <= z * x). +proof. by move=> z_gt0; rewrite mulrC ler_pdivr_mulr ?(@mulrC z). qed. + +lemma ltr_pdivr_mull (z x y : t) : + zero < z => (invr z * y < x) <=> (y < z * x). +proof. by move=> z_gt0; rewrite mulrC ltr_pdivr_mulr ?(@mulrC z). qed. + +hint rewrite lter_pdivr_mull : ler_pdivr_mull ltr_pdivr_mull. + +(* -------------------------------------------------------------------- *) +lemma ler_ndivl_mulr (z x y : t) : + z < zero => (x <= y / z) <=> (y <= x * z). +proof. by move=> z_lt0; rewrite -(@ler_nmul2r z) // mulrVK ?unitfP ?ltr_eqF. qed. + +lemma ltr_ndivl_mulr (z x y : t) : + z < zero => (x < y / z) <=> (y < x * z). +proof. by move=> z_lt0; rewrite -(@ltr_nmul2r z) // mulrVK ?unitfP ?ltr_eqF. qed. + +hint rewrite lter_ndivl_mulr : ler_ndivl_mulr ltr_ndivl_mulr. + +(* -------------------------------------------------------------------- *) +lemma ler_ndivr_mulr (z x y : t) : + z < zero => (y / z <= x) <=> (x * z <= y). +proof. by move=> z_lt0; rewrite -(@ler_nmul2r z) // mulrVK ?unitfP ?ltr_eqF. qed. + +lemma ltr_ndivr_mulr (z x y : t) : + z < zero => (y / z < x) <=> (x * z < y). +proof. by move=> z_lt0; rewrite -(@ltr_nmul2r z) // mulrVK ?unitfP ?ltr_eqF. qed. + +hint rewrite lter_ndivr_mulr : ler_ndivr_mulr ltr_ndivr_mulr. + +(* -------------------------------------------------------------------- *) +lemma ler_ndivl_mull (z x y : t) : + z < zero => (x <= invr z * y) <=> (y <= z * x). +proof. by move=> z_lt0; rewrite mulrC ler_ndivl_mulr ?(@mulrC z). qed. + +lemma ltr_ndivl_mull (z x y : t) : + z < zero => (x < invr z * y) <=> (y < z * x). +proof. by move=> z_lt0; rewrite mulrC ltr_ndivl_mulr ?(@mulrC z). qed. + +hint rewrite lter_ndivl_mull : ler_ndivl_mull ltr_ndivl_mull. + +(* -------------------------------------------------------------------- *) +lemma ler_ndivr_mull (z x y : t) : + z < zero => (invr z * y <= x) <=> (z * x <= y). +proof. by move=> z_lt0; rewrite mulrC ler_ndivr_mulr ?(@mulrC z). qed. + +lemma ltr_ndivr_mull (z x y : t) : + z < zero => (invr z * y < x) <=> (z * x < y). +proof. by move=> z_lt0; rewrite mulrC ltr_ndivr_mulr ?(@mulrC z). qed. + +hint rewrite lter_ndivr_mull : ler_ndivr_mull ltr_ndivr_mull. + +end section. + +(* ==================================================================== *) +(* Canonical [int] instance for [tcrealdomain]. Mirrors *) +(* [theories/algebra/Number.ec]'s int specialisation. *) +(* ==================================================================== *) +instance tcrealdomain with int reducible + op "`|_|" = CoreInt.absz + op (<=) = CoreInt.le + op (<) = CoreInt.lt + op minr = Int.min + op maxr = Int.max + + proof ler_norm_add by smt() + proof addr_gt0 by smt() + proof norm_eq0 by smt() + proof ger_leVge by smt() + proof normrM by smt() + proof ler_def by smt() + proof ltr_def by smt() + proof real_axiom by smt() + proof minrE by smt() + proof maxrE by smt(). diff --git a/examples/tcalgebra/TcPoly.ec b/examples/tcalgebra/TcPoly.ec new file mode 100644 index 0000000000..e7d26c5496 --- /dev/null +++ b/examples/tcalgebra/TcPoly.ec @@ -0,0 +1,986 @@ +(* -------------------------------------------------------------------- *) +require import AllCore Finite Distr DList List IntMin StdBigop StdOrder. +require Subtype. +require import TcMonoid TcRing TcBigop TcBigalg TcInt. +(*---*) import Bigint IntOrder. + +(* ==================================================================== *) +(* Univariate polynomials over a [comring] coefficient algebra. Mirrors *) +(* [theories/algebra/Poly.ec:PolyComRing] but as a section over [c] *) +(* with TC instances accumulating: once [poly : addgroup] is registered *) +(* in Phase 3, every [bigA] / [bigZModule] lemma applies to polynomial *) +(* sums; once [poly : comring] in Phase 5, every [bigA]/[bigM] lemma *) +(* in TcBigalg applies. No "BigPoly" clone needed. *) +(* ==================================================================== *) + +section. +declare type c <: comring. + +(* -------------------------------------------------------------------- *) +(* prepoly = sequence-of-coeffs predicate; poly = subtype thereof *) +(* -------------------------------------------------------------------- *) +type prepoly = int -> c. + +op ispoly (p : prepoly) = + (forall i, i < 0 => p i = zero<:c>) + /\ (exists d, forall i, d < i => p i = zero<:c>). + +subtype poly = { p : prepoly | ispoly p } + rename "to_poly", "of_poly". + +realize inhabited. +proof. by exists (fun _ => zero<:c>). qed. + +(* -------------------------------------------------------------------- *) +op "_.[_]" (p : poly) (i : int) = (of_poly p) i. + +lemma lt0_coeff p i : i < 0 => p.[i] = zero<:c>. +proof. +by move=> lt0_i; rewrite /"_.[_]"; case: (of_polyP p) => /(_ _ lt0_i). +qed. + +(* -------------------------------------------------------------------- *) +(* Degree machinery *) +(* -------------------------------------------------------------------- *) +op deg (p : poly) = + argmin idfun (fun i => forall j, i <= j => p.[j] = zero<:c>). + +lemma degP p i : + 0 < i + => p.[i-1] <> zero<:c> + => (forall j, i <= j => p.[j] = zero<:c>) + => deg p = i. +proof. +move=> ge0_i nz_p_iB1 degi @/deg; apply: argmin_eq => /=. +- by apply/ltrW. - by apply: degi. +move=> j [ge0_j lt_ji]; rewrite negb_forall /=. +by exists (i-1); apply/negP => /(_ _); first by move=> /#. +qed. + +lemma deg_leP p i : 0 <= i => + (forall j, i <= j => p.[j] = zero<:c>) => deg p <= i. +proof. +move=> ge0_i; apply: contraLR; rewrite lerNgt /= => lei. +by have @{1}/deg /argmin_min /=: 0 <= i < deg p by done. +qed. + +lemma gedeg_coeff (p : poly) (i : int) : deg p <= i => p.[i] = zero<:c>. +proof. +move=> le_p_i; pose P p i := forall j, i <= j => p.[j] = zero<:c>. +case: (of_polyP p) => [_ [d hd]]; move: (argminP idfun (P p)). +move/(_ (max (d+1) 0) _ _) => /=; first exact: maxrr. +- by move=> j le_d_j; apply: hd => /#. +by apply; apply: le_p_i. +qed. + +lemma ge0_deg p : 0 <= deg p. +proof. rewrite /deg &(ge0_argmin). qed. + +(* -------------------------------------------------------------------- *) +abbrev lc (p : poly) = p.[deg p - 1]. + +(* -------------------------------------------------------------------- *) +(* prepoly-level constructors *) +(* -------------------------------------------------------------------- *) +op prepolyC (a : c ) : prepoly = fun i => if i = 0 then a else zero<:c>. +op prepolyXn (k : int ) : prepoly = fun i => if 0 <= k /\ i = k then oner<:c> else zero<:c>. +op prepolyD (p q : poly) : prepoly = fun i => p.[i] + q.[i]. +op prepolyN (p : poly) : prepoly = fun i => - p.[i]. + +op prepolyM (p q : poly) : prepoly = fun k => + bigiA<:c> predT (fun i => p.[i] * q.[k-i]) 0 (k+1). + +op prepolyZ (z : c) (p : poly) : prepoly = fun k => + z * p.[k]. + +(* -------------------------------------------------------------------- *) +(* ispoly closure *) +(* -------------------------------------------------------------------- *) +lemma ispolyC (a : c) : ispoly (prepolyC a). +proof. +split=> @/prepolyC [c' ?|]; first by rewrite ltr_eqF. +by exists 0 => c' gt1_c'; rewrite gtr_eqF. +qed. + +lemma ispolyXn (k : int) : ispoly (prepolyXn k). +proof. +split=> @/prepolyXn [c' lt0_c|]. ++ by case: (0 <= k) => //= ge0_k; rewrite ltr_eqF //#. ++ by exists k => c' gt1_c'; rewrite gtr_eqF. +qed. + +lemma ispolyN (p : poly) : ispoly (prepolyN p). +proof. +split=> @/prepolyN [c' lt0_c|]; first by rewrite oppr_eq0 lt0_coeff. +by exists (deg p) => c' => /ltrW /gedeg_coeff ->; rewrite oppr0. +qed. + +lemma ispolyD (p q : poly) : ispoly (prepolyD p q). +proof. +split=> @/prepolyD [c' lt0_c|]; first by rewrite !lt0_coeff // addr0. +by exists (1 + max (deg p) (deg q)) => c' le; rewrite !gedeg_coeff ?addr0 //#. +qed. + +lemma ispolyM (p q : poly) : ispoly (prepolyM p q). +proof. +split => @/prepolyM [c' lt0_c|]; 1: by rewrite big_geq //#. +exists (deg p + deg q + 1) => c' ltc; rewrite big_seq big1 //= => i. +rewrite mem_range => -[gt0_i lt_ic]; case: (p.[i] = zero<:c>). +- by move=> ->; rewrite mul0r. +move/(contra _ _ (gedeg_coeff p i)); rewrite lerNgt /= => lt_ip. +by rewrite mulrC gedeg_coeff ?mul0r //#. +qed. + +lemma ispolyZ z p : ispoly (prepolyZ z p). +proof. +split => @/prepolyZ [c' lt0_c|]; 1: by rewrite lt0_coeff //mulr0. +by exists (deg p + 1) => c' gtc; rewrite gedeg_coeff ?mulr0 //#. +qed. + +lemma poly_eqP (p q : poly) : p = q <=> (forall i, 0 <= i => p.[i] = q.[i]). +proof. +split=> [->//|eq_coeff]; apply/of_poly_inj/fun_ext => i. +case: (i < 0) => [lt0_i|/lerNgt /=]; last by apply: eq_coeff. +by rewrite -/"_.[_]" !lt0_coeff. +qed. + +(* -------------------------------------------------------------------- *) +(* poly-level constructors *) +(* -------------------------------------------------------------------- *) +op polyC a = to_polyd (prepolyC a). +op polyXn k = to_polyd (prepolyXn k). +op polyN p = to_polyd (prepolyN p). +op polyD p q = to_polyd (prepolyD p q). +op polyM p q = to_polyd (prepolyM p q). +op polyZ z p = to_polyd (prepolyZ z p). + +abbrev poly0 : poly = polyC zero<:c>. +abbrev poly1 : poly = polyC oner<:c>. +abbrev polyX : poly = polyXn 1. +abbrev X : poly = polyXn 1. +abbrev ( + ) (p q : poly) : poly = polyD p q. +abbrev [ - ] (p : poly) : poly = polyN p. +abbrev ( * ) (p q : poly) : poly = polyM p q. +abbrev ( ** ) z (p : poly) : poly = polyZ z p. + +abbrev ( - ) (p q : poly) : poly = p + (-q). + +(* -------------------------------------------------------------------- *) +(* Coefficient formulas *) +(* -------------------------------------------------------------------- *) +lemma coeffE p k : ispoly p => (to_polyd p).[k] = p k. +proof. by move=> ?; rewrite /"_.[_]" to_polydK. qed. + +lemma polyCE a k : (polyC a).[k] = if k = 0 then a else zero<:c>. +proof. by rewrite coeffE 1:ispolyC. qed. + +lemma polyXE k : X.[k] = if k = 1 then oner<:c> else zero<:c>. +proof. by rewrite coeffE 1:ispolyXn. qed. + +lemma poly0E k : poly0.[k] = zero<:c>. +proof. by rewrite polyCE if_same. qed. + +lemma polyNE p k : (-p).[k] = - p.[k]. +proof. by rewrite coeffE 1:ispolyN. qed. + +lemma polyDE p q k : (p + q).[k] = p.[k] + q.[k]. +proof. by rewrite coeffE 1:ispolyD. qed. + +lemma polyME p q k : (p * q).[k] = + bigiA<:c> predT (fun i => p.[i] * q.[k-i]) 0 (k+1). +proof. by rewrite coeffE 1:ispolyM. qed. + +lemma polyMXE p k : (p * X).[k] = p.[k-1]. +proof. +case: (k < 0) => [lt0_k|]; first by rewrite !lt0_coeff //#. +rewrite ltrNge => /= ge0_k; rewrite polyME; move: ge0_k. +rewrite ler_eqVlt => -[<-|gt0_k] /=. +- by rewrite big_int1 /= polyXE /= mulr0 lt0_coeff. +rewrite (@bigD1<:c, int> _ _ (k-1)) ?mem_range 1:/# 1:range_uniq /=. +rewrite opprB addrCA /= polyXE /= mulr1 big1 // ?addr0 //. +move=> i @/predC1 nei /=; rewrite polyXE. +case: (k - i = 1) => [/#|_ /=]; first by rewrite mulr0. +qed. + +lemma polyZE z p k : (z ** p).[k] = z * p.[k]. +proof. by rewrite coeffE 1:ispolyZ. qed. + +hint rewrite coeffpE : poly0E polyDE polyNE polyME polyZE. + +(* -------------------------------------------------------------------- *) +(* polyC properties *) +(* -------------------------------------------------------------------- *) +lemma polyCN (a : c) : polyC (- a) = - (polyC a). +proof. +apply/poly_eqP=> i ge0_i; rewrite !(coeffpE, polyCE). +by case: (i = 0) => // _; rewrite oppr0. +qed. + +lemma polyCD (a1 a2 : c) : polyC (a1 + a2) = polyC a1 + polyC a2. +proof. +apply/poly_eqP=> i ge0_i; rewrite !(coeffpE, polyCE). +by case: (i = 0) => // _; rewrite addr0. +qed. + +lemma polyCM (a1 a2 : c) : polyC (a1 * a2) = polyC a1 * polyC a2. +proof. +apply/poly_eqP=> i ge0_i; rewrite !(coeffpE, polyCE). +case: (i = 0) => [->|ne0_i]; first by rewrite big_int1 /= !polyCE. +rewrite big_seq big1 ?addr0 //= => j /mem_range rg_j. +rewrite !polyCE; case: (j = 0) => [->>/=|]; last by rewrite mul0r. +by rewrite ne0_i /= mulr0. +qed. + +(* -------------------------------------------------------------------- *) +(* ZModule axioms on poly. Mirrors original [clone Ring.ZModule as *) +(* ZPoly] but as standalone lemmas; will feed into the [addgroup] *) +(* instance in Phase 3. *) +(* -------------------------------------------------------------------- *) +lemma polyD_addrA (p q r : poly) : p + (q + r) = (p + q) + r. +proof. by apply/poly_eqP=> i ge0_i; rewrite !coeffpE addrA. qed. + +lemma polyD_addrC (p q : poly) : p + q = q + p. +proof. by apply/poly_eqP=> i ge0_i; rewrite !coeffpE addrC. qed. + +lemma polyD_add0r (p : poly) : poly0 + p = p. +proof. by apply/poly_eqP=> i ge0_i; rewrite !coeffpE add0r. qed. + +lemma polyD_addNr (p : poly) : (-p) + p = poly0. +proof. by apply/poly_eqP=> i ge0_i; rewrite !coeffpE addNr. qed. + +(* -------------------------------------------------------------------- *) +(* Scaling lemmas *) +(* -------------------------------------------------------------------- *) +lemma scale0p p : zero<:c> ** p = poly0. +proof. by apply/poly_eqP=> i ge0_i; rewrite !coeffpE mul0r. qed. + +lemma scalep0 a : a ** poly0 = poly0. +proof. by apply/poly_eqP=> i ge0_i; rewrite !coeffpE mulr0. qed. + +lemma scale1p p : oner<:c> ** p = p. +proof. by apply/poly_eqP=> i ge0_i; rewrite !coeffpE mul1r. qed. + +lemma scalep1 (a : c) : a ** poly1 = polyC a. +proof. +apply/poly_eqP=> i ge0_i; rewrite !coeffpE !polyCE. +by case: (i = 0) => _; [rewrite mulr1|rewrite mulr0]. +qed. + +lemma scaleNp (a : c) p : (-a) ** p = - (a ** p). +proof. by apply/poly_eqP=> i ge0_i; rewrite !coeffpE mulNr. qed. + +lemma scalepN (a : c) p : a ** (-p) = - (a ** p). +proof. by apply/poly_eqP=> i ge0_i; rewrite !coeffpE mulrN. qed. + +lemma scalepA (a1 a2 : c) p : a1 ** (a2 ** p) = (a1 * a2) ** p. +proof. by apply/poly_eqP=> i ge0_i; rewrite !coeffpE mulrA. qed. + +lemma scalepDr (a : c) p q : a ** (p + q) = (a ** p) + (a ** q). +proof. by apply/poly_eqP=> i ge0_i; rewrite !coeffpE mulrDr. qed. + +lemma scalepBr (a : c) p q : a ** (p - q) = (a ** p) - (a ** q). +proof. by rewrite scalepDr scalepN. qed. + +lemma scalepDl (a1 a2 : c) p : (a1 + a2) ** p = (a1 ** p) + (a2 ** p). +proof. by apply/poly_eqP=> i ge0_i; rewrite !coeffpE mulrDl. qed. + +lemma scalepBl (a1 a2 : c) p : (a1 - a2) ** p = (a1 ** p) - (a2 ** p). +proof. by rewrite scalepDl scaleNp. qed. + +lemma scalepE (a : c) p : a ** p = polyC a * p. +proof. +apply/poly_eqP=> i ge0_i; rewrite !coeffpE /=. +rewrite big_int_recl //= polyCE /=. +rewrite big_seq big1 ?addr0 //= => j /mem_range. +by case=> ge0_j _; rewrite polyCE addz1_neq0 //= mul0r. +qed. + +(* -------------------------------------------------------------------- *) +(* Multiplication: extended coefficient formulas, then the ComRing *) +(* axioms (associativity / commutativity / unit / distributivity). *) +(* Mirrors original [Poly.ec] lines 418-498. *) +(* -------------------------------------------------------------------- *) +lemma polyMEw M p q k : k <= M => + (p * q).[k] = bigiA<:c> predT (fun i => p.[i] * q.[k-i]) 0 (M+1). +proof. +move=> le_kM; case: (k < 0) => [lt0_k|/lerNgt ge0_k]. ++ rewrite lt0_coeff // big_seq big1 //= => i. + by case/mem_range=> [ge0_i lt_iM]; rewrite (lt0_coeff q) ?mulr0 //#. +rewrite (@big_cat_int (k+1)) 1,2:/# -polyME. +rewrite big_seq big1 2:addr0 //= => i /mem_range. +by case=> [lt_ki lt_iM]; rewrite (lt0_coeff q) ?mulr0 //#. +qed. + +lemma polyM_mulrC : commutative polyM. +proof. +move=> p q; apply: poly_eqP => k ge0_k; rewrite !polyME. +pose F j := k - j; rewrite (@big_reindex _ _ F F) 1:/#. +rewrite predT_comp /(\o) /=; pose s := map _ _. +apply: (eq_trans _ _ _ (eq_big_perm _ _ _ (range 0 (k+1)) _)). ++ rewrite uniq_perm_eq 2:&(range_uniq) /s. + * rewrite map_inj_in_uniq 2:&(range_uniq) => x y. + by rewrite !mem_range /F /#. + * move=> x; split => [/mapP[y []]|]; 1: by rewrite !mem_range /#. + rewrite !mem_range => *; apply/mapP; exists (F x). + by rewrite !mem_range /F /#. ++ by apply: eq_bigr => /= i _ @/F; rewrite mulrC /#. +qed. + +lemma polyMEwr M p q k : k <= M => + (p * q).[k] = bigiA<:c> predT (fun i => p.[k-i] * q.[i]) 0 (M+1). +proof. +rewrite -{1}polyM_mulrC => /polyMEw ->; apply: eq_bigr. +by move=> i _ /=; rewrite mulrC. +qed. + +lemma polyMEr p q k : + (p * q).[k] = bigiA<:c> predT (fun i => p.[k-i] * q.[i]) 0 (k+1). +proof. by rewrite (@polyMEwr k). qed. + +lemma polyM_mulrA : associative polyM. +proof. +move=> p q r; apply: poly_eqP => k ge0_k. +have ->: (p * (q * r)).[k] = + bigiA<:c> predT (fun i => + bigiA<:c> predT (fun j => p.[i] * q.[k - i - j] * r.[j]) 0 (k+1) + ) 0 (k+1). ++ rewrite polyME !big_seq &(eq_bigr) => /= i. + case/mem_range => g0_i lt_i_Sk; rewrite (@polyMEwr k) 1:/#. + by rewrite mulr_sumr &(eq_bigr) => /= j _; rewrite mulrA. +have ->: ((p * q) * r).[k] = + bigiA<:c> predT (fun i => + bigiA<:c> predT (fun j => p.[j] * q.[k - i - j] * r.[i]) 0 (k+1) + ) 0 (k+1). ++ rewrite polyMEr !big_seq &(eq_bigr) => /= i. + case/mem_range => ge0_i lt_i_Sk; rewrite (@polyMEw k) 1:/#. + by rewrite mulr_suml &(eq_bigr). +rewrite exchange_big &(eq_bigr) => /= i _. +by rewrite &(eq_bigr) => /= j _ /#. +qed. + +lemma polyM_mul1r : left_id poly1 polyM. +proof. +move=> p; apply: poly_eqP => i ge0_i. +rewrite polyME big_int_recl //= polyCE /= mul1r. +rewrite big_seq big1 -1:?addr0 //=. +move=> j; rewrite mem_range=> -[ge0_j _]; rewrite polyCE. +by rewrite addz1_neq0 //= mul0r. +qed. + +lemma polyM_mul0r p : poly0 * p = poly0. +proof. +apply/poly_eqP=> i _; rewrite poly0E polyME. +by rewrite big1 //= => j _; rewrite poly0E mul0r. +qed. + +lemma polyM_mulrDl : left_distributive polyM polyD. +proof. +move=> p q r; apply: poly_eqP => i ge0_i; rewrite !(polyME, polyDE). +by rewrite -big_split &(eq_bigr) => /= j _; rewrite polyDE mulrDl. +qed. + +lemma polyM_oner_neq0 : poly1 <> poly0. +proof. by apply/negP => /poly_eqP /(_ 0); rewrite !polyCE /= oner_neq0<:c>. qed. + +end section. + +(* -------------------------------------------------------------------- *) +(* Wrappers needed by [instance]: its [op X = name] clause requires a *) +(* qualified ident on the rhs (not an [abbrev]). *) +(* -------------------------------------------------------------------- *) +op poly_zero ['c <: comring] : 'c poly = polyC zero<:'c>. +op poly_one ['c <: comring] : 'c poly = polyC oner<:'c>. + +(* ==================================================================== *) +(* Phase 3: register [poly] as an [addgroup] over a [comring] *) +(* coefficient. Once this lands, every [bigA] / [bigZModule] lemma *) +(* polymorphic over [addmonoid] applies at carrier ['c poly]. *) +(* ==================================================================== *) +instance addgroup with ['c <: comring] ('c poly) + op zero = poly_zero<:'c> + op (+) = polyD<:'c> + op [-] = polyN<:'c> + + proof mopA<:addmonoid> by apply polyD_addrA + proof mopC<:addmonoid> by apply polyD_addrC + proof mop0<:addmonoid> by (move=> p; rewrite -/(poly_zero<:'c>); apply polyD_add0r) + proof addrN by (move=> p; rewrite polyD_addrC -/(poly_zero<:'c>); apply polyD_addNr). + +(* ==================================================================== *) +(* Phase 5: register [poly] as a [comring] over a [comring] coefficient.*) +(* Mirrors [Ring.ec:ComRingDflInv]: when no structural inverse is *) +(* available (here, because the structural "constant with invertible *) +(* coefficient" characterisation only holds when [c] has no zero *) +(* divisors, i.e. [c : idomain]), use [choiceb] to pick a left inverse *) +(* if any exists, fall back to the element itself otherwise. The three *) +(* obligations [mulVr] / [unitP] / [unitout] discharge from [choicebP] *) +(* and [choiceb_dfl] alone — no ring axioms needed. *) +(* ==================================================================== *) +op poly_unit ['c <: comring] (p : 'c poly) : bool = + exists q, polyM q p = poly_one<:'c>. + +op poly_invr ['c <: comring] (p : 'c poly) : 'c poly = + choiceb (fun q => polyM q p = poly_one<:'c>) p. + +instance comring with ['c <: comring] ('c poly) + op zero = poly_zero<:'c> + op (+) = polyD<:'c> + op [-] = polyN<:'c> + op oner = poly_one<:'c> + op ( * ) = polyM<:'c> + op invr = poly_invr<:'c> + op unit = poly_unit<:'c> + + proof mopA<:addmonoid> by apply polyD_addrA + proof mopC<:addmonoid> by apply polyD_addrC + proof mop0<:addmonoid> by (move=> p; rewrite -/(poly_zero<:'c>); apply polyD_add0r) + proof addrN by (move=> p; rewrite polyD_addrC -/(poly_zero<:'c>); apply polyD_addNr) + proof oner_neq0 by (rewrite -/(poly_one<:'c>) -/(poly_zero<:'c>); apply polyM_oner_neq0) + proof mopA<:mulmonoid> by apply polyM_mulrA + proof mopC<:mulmonoid> by apply polyM_mulrC + proof mop0<:mulmonoid> by (move=> p; rewrite -/(poly_one<:'c>); apply polyM_mul1r) + proof mulrDl by apply polyM_mulrDl + proof mulVr by (move=> p hu; rewrite /poly_invr<:'c>; + have := choicebP (fun q => polyM q p = poly_one<:'c>) p hu; + by rewrite /=) + proof unitP by (move=> p q heq; rewrite /poly_unit<:'c>; by exists q) + proof unitout by (move=> p; rewrite /poly_unit<:'c> /poly_invr<:'c> negb_exists => hne; + by apply choiceb_dfl => q; apply hne). + +(* ==================================================================== *) +(* Phase 6: higher-level theory of polynomials over a [comring] *) +(* coefficient. Mirrors [theories/algebra/Poly.ec] from [degC] *) +(* (line 296) onwards: degree arithmetic, multiplicative degree, *) +(* X^i / polyXn, polysumE / polyE / polywE, peval, polyL constructor. *) +(* ==================================================================== *) +section. +declare type c <: comring. + +(* -------------------------------------------------------------------- *) +(* Degree of constants, leading coefficient, [poly0]/[poly1] degrees. *) +(* -------------------------------------------------------------------- *) +lemma degC (a : c) : deg (polyC a) = if a = zero<:c> then 0 else 1. +proof. +case: (a = zero<:c>) => [->|nz_a]; last first. +- apply: degP => //=; first by rewrite polyCE. + by move=> i ge1_i; rewrite polyCE gtr_eqF //#. +rewrite /deg; apply: argmin_eq => //=. +- by move=> j _; rewrite poly0E. +- by move=> j; apply: contraL => _ /#. +qed. + +lemma degC_le (a : c) : deg (polyC a) <= 1. +proof. by rewrite degC; case: (a = zero<:c>). qed. + +lemma lcC (a : c) : lc (polyC a) = a. +proof. by rewrite polyCE degC; case: (a = zero<:c>) => [->|]. qed. + +lemma lc0 : lc poly0<:c> = zero<:c>. +proof. by apply: lcC. qed. + +lemma lc1 : lc poly1<:c> = oner<:c>. +proof. by apply: lcC. qed. + +lemma deg0 : deg poly0<:c> = 0. +proof. by rewrite degC. qed. + +lemma deg1 : deg poly1<:c> = 1. +proof. +apply: degP => //=; first by rewrite polyCE /= oner_neq0. +by move=> i ge1_i; rewrite polyCE gtr_eqF //#. +qed. + +lemma deg_eq0 (p : c poly) : (deg p = 0) <=> (p = poly0). +proof. +split=> [z_degp|->]; last by rewrite deg0. +apply/poly_eqP=> i ge0_i; rewrite poly0E. +by apply/gedeg_coeff; rewrite z_degp. +qed. + +lemma degX : deg X<:c> = 2. +proof. +apply/degP=> //=; first by rewrite polyXE /= oner_neq0. +by move=> i ge2_i; rewrite polyXE gtr_eqF //#. +qed. + +lemma nz_polyX : X<:c> <> poly0. +proof. by rewrite -deg_eq0 degX. qed. + +lemma lcX : lc X<:c> = oner<:c>. +proof. by rewrite degX /= polyXE. qed. + +lemma deg_ge1 (p : c poly) : (1 <= deg p) <=> (p <> poly0). +proof. by rewrite -deg_eq0 eqr_le ge0_deg /= (lerNgt _ 0) /#. qed. + +lemma deg_gt0 (p : c poly) : (0 < deg p) <=> (p <> poly0). +proof. by rewrite -deg_ge1 /#. qed. + +lemma deg_eq1 (p : c poly) : + (deg p = 1) <=> (exists a, a <> zero<:c> /\ p = polyC a). +proof. +split=> [eq1_degp|[a [nz_a ->>]]]; last first. ++ by apply: degP => //= => [|i ge1_i]; rewrite polyCE //= gtr_eqF /#. +have pC: forall i, 1 <= i => p.[i] = zero<:c>. ++ by move=> i ge1_i; apply: gedeg_coeff; rewrite eq1_degp. +exists p.[0]; split; last first. ++ apply/poly_eqP => i /ler_eqVlt -[<<-|]; first by rewrite polyCE. + by move=> gt0_i; rewrite polyCE gtr_eqF //= &(pC) /#. +apply: contraL eq1_degp => z_p0; suff ->: p = poly0 by rewrite deg0. +apply/poly_eqP=> i; rewrite poly0E => /ler_eqVlt [<<-//|]. +by move=> gt0_i; apply: pC => /#. +qed. + +lemma lc_eq0 (p : c poly) : (lc p = zero<:c>) <=> (p = poly0). +proof. +case: (p = poly0) => [->|] /=; first by rewrite lc0. +rewrite -deg_eq0 eqr_le ge0_deg /= -ltrNge => gt0_deg. +pose P i := forall j, (i <= j)%Int => p.[j] = zero<:c>. +apply/negP => zp; have h: 0 <= deg p - 1 < argmin idfun P. ++ rewrite /P /argmin -/(deg p); smt(ge0_deg). +have := argmin_min idfun P (deg p - 1) h. +move=> @/idfun /= j /ler_eqVlt [<<-//| ltj]. +by apply: gedeg_coeff => /#. +qed. + +(* -------------------------------------------------------------------- *) +(* Degree of additive operations. *) +(* -------------------------------------------------------------------- *) +lemma degN (p : c poly) : deg (-p) = deg p. +proof. +rewrite /deg; congr; apply/fun_ext => /= i; apply/eq_iff. +by split=> + j - /(_ j); rewrite polyNE oppr_eq0. +qed. + +lemma lcN (p : c poly) : lc (-p) = - lc p. +proof. by rewrite degN polyNE. qed. + +lemma degD (p q : c poly) : deg (p + q) <= max (deg p) (deg q). +proof. +apply: deg_leP; [by smt(ge0_deg) | move=> i /ler_maxrP[le1 le2]]. +by rewrite polyDE !gedeg_coeff ?addr0. +qed. + +lemma degB (p q : c poly) : deg (p - q) <= max (deg p) (deg q). +proof. by rewrite -(degN q) &(degD). qed. + +lemma degDl (p q : c poly) : deg q < deg p => deg (p + q) = deg p. +proof. +move=> le_pq; have gt0_p: 0 < deg p. +- by apply/(ler_lt_trans _ _ _ _ le_pq)/ge0_deg. +apply: degP=> //. +- rewrite polyDE (gedeg_coeff q) 1:/#. + by rewrite addr0 lc_eq0 -deg_eq0 gtr_eqF. +- move=> i le_pi; rewrite polyDE !gedeg_coeff ?addr0 //. + by apply/ltrW/(ltr_le_trans _ _ _ le_pq). +qed. + +lemma lcDl (p q : c poly) : deg q < deg p => lc (p + q) = lc p. +proof. +move=> ^lt_pq /degDl ->; rewrite polyDE. +by rewrite addrC gedeg_coeff ?add0r //#. +qed. + +lemma degDr (p q : c poly) : deg p < deg q => deg (p + q) = deg q. +proof. by move=> h; rewrite (addrC<:c poly> p q); apply degDl. qed. + +lemma lcDr (p q : c poly) : deg p < deg q => lc (p + q) = lc q. +proof. by move=> h; rewrite (addrC<:c poly> p q); apply lcDl. qed. + +(* -------------------------------------------------------------------- *) +(* Multiplicative degree. *) +(* -------------------------------------------------------------------- *) +lemma mul_lc (p q : c poly) : + lc p * lc q = (p * q).[deg p + deg q - 2]. +proof. +case: (p = poly0) => [->|nz_p]. +- by rewrite mul0r<:c poly> !poly0E mul0r. +case: (q = poly0) => [->|nz_q]. +- by rewrite polyM_mulrC polyM_mul0r !poly0E mulr0. +have ->: deg p + deg q - 2 = (deg p - 1) + (deg q - 1) by ring. +pose cp := deg p - 1; pose cq := deg q - 1. +rewrite polyME (bigD1 _ _ cp) ?range_uniq //=. +- rewrite mem_range subr_ge0 deg_ge1 nz_p /= -addrA. + by rewrite ltr_addl ltzS /cq subr_ge0 deg_ge1. +rewrite addrAC subrr /= big_seq_cond big1 ?addr0 //=. +move=> i [/mem_range [ge0_i lt] @/predC1 nei]. +case: (i < deg p) => [lt_ip| /lerNgt le_pi]; last first. +- by rewrite gedeg_coeff // mul0r. +by rewrite (gedeg_coeff q) ?mulr0 //#. +qed. + +(* -------------------------------------------------------------------- *) +lemma degM_le (p q : c poly) : p <> poly0 => q <> poly0 => + deg (p * q) + 1 <= deg p + deg q. +proof. +move=> nz_p nz_q; rewrite addrC -ler_subr_addl &(deg_leP). +- by move: nz_p nz_q; rewrite -!deg_eq0 !eqr_le !ge0_deg /= -!ltrNge /#. +move=> i lei; rewrite polyME big_seq big1 //=. +move=> j /mem_range [ge0_j /ltzS le_ij]. +case: (j < deg p) => [lt_jp|/lerNgt le_pk]. +- by rewrite mulrC gedeg_coeff ?mul0r //#. +- by rewrite gedeg_coeff ?mul0r //#. +qed. + +(* -------------------------------------------------------------------- *) +lemma degM_proper (p q : c poly) : + lc p * lc q <> zero<:c> => deg (p * q) = (deg p + deg q) - 1. +proof. +case: (p = poly0) => [->|nz_p]; first by rewrite lc0 !mul0r. +case: (q = poly0) => [->|nz_q]; first by rewrite lc0 !mulr0. +move=> nz_lc. +have ub := degM_le _ _ nz_p nz_q. +have lb : deg p + deg q - 1 <= deg (p * q). +- rewrite lerNgt /=; apply/negP => lt_pq. + apply nz_lc; rewrite mul_lc gedeg_coeff //#. +smt(). +qed. + +(* -------------------------------------------------------------------- *) +lemma lcM_proper (p q : c poly) : + lc p * lc q <> zero<:c> => lc (p * q) = lc p * lc q. +proof. by move=> reg; rewrite degM_proper //= -mul_lc. qed. + +(* -------------------------------------------------------------------- *) +lemma degZ_le (a : c) (p : c poly) : deg (a ** p) <= deg p. +proof. +case: (a = zero<:c>) => [->|nz_a]; 1: by rewrite scale0p deg0 ge0_deg. +case: (p = poly0) => [->|nz_p]; 1: by rewrite scalep0 deg0. +have nz_cp : polyC a <> poly0. +- by apply/negP => /(congr1 deg); rewrite deg0 degC nz_a. +rewrite scalepE -(ler_add2r 1); move/ler_trans: (degM_le _ _ nz_cp nz_p). +by apply; rewrite degC nz_a /= addrC. +qed. + +(* -------------------------------------------------------------------- *) +lemma degZ_lreg (a : c) (p : c poly) : lreg a => deg (a ** p) = deg p. +proof. +case: (p = poly0) => [->|^nz_p]; 1: by rewrite scalep0 deg0. +rewrite -deg_gt0 => gt0_dp lreg_a; apply/degP => // => [|i gei]. +- by rewrite polyZE mulrI_eq0 // lc_eq0. +- by rewrite gedeg_coeff // &(ler_trans (deg p)) // &(degZ_le). +qed. + +(* -------------------------------------------------------------------- *) +lemma lcZ_lreg (a : c) (p : c poly) : lreg a => lc (a ** p) = a * lc p. +proof. by move=> reg_a; rewrite degZ_lreg // polyZE. qed. + +(* -------------------------------------------------------------------- *) +(* polyXn / [exp X i] theory. *) +(* -------------------------------------------------------------------- *) +lemma polyCX (a : c) i : 0 <= i => exp (polyC a) i = polyC (exp a i). +proof. +elim: i => [|i ge0_i ih]; first by rewrite !expr0. +by rewrite !exprS // ih polyCM. +qed. + +(* -------------------------------------------------------------------- *) +lemma degXn_le (p : c poly) i : + p <> poly0 => 0 <= i => deg (exp p i) <= i * (deg p - 1) + 1. +proof. +move=> nz_p; elim: i => [|i ge0_i ih]; first by rewrite !expr0 deg1. +rewrite exprS // mulrDl /= addrAC !addrA ler_subr_addl (addrC 1). +case: (exp p i = poly0) => [->|nz_pX]. +- by rewrite mulr0 deg0 /=; rewrite -deg_gt0 in nz_p => /#. +apply: (ler_trans (deg p + deg (exp p i))); 1: by apply: degM_le. +by rewrite addrC &(ler_add2r). +qed. + +(* -------------------------------------------------------------------- *) +lemma lreg_lc (p : c poly) : lreg (lc p) => lreg p. +proof. +move/mulrI_eq0=> reg_p; apply/mulrI0_lreg => q. +apply: contraLR=> nz_q; rewrite -lc_eq0. +by rewrite lcM_proper reg_p lc_eq0. +qed. + +(* -------------------------------------------------------------------- *) +lemma degXn_proper (p : c poly) i : + lreg (lc p) => 0 <= i => deg (exp p i) = i * (deg p - 1) + 1. +proof. +move=> lreg_p; elim: i => [|i ge0_i ih]; first by rewrite expr0 deg1. +rewrite exprS // degM_proper; last by rewrite ih #ring. +by rewrite mulrI_eq0 // lc_eq0 lreg_neq0 // &(lregXn) // &(lreg_lc). +qed. + +(* -------------------------------------------------------------------- *) +lemma lcXn_proper (p : c poly) i : + lreg (lc p) => 0 <= i => lc (exp p i) = exp (lc p) i. +proof. +move=> reg_p; elim: i => [|i ge0_i ih]; 1: by rewrite !expr0 lc1. +rewrite !exprS // degM_proper /=; last by rewrite -mul_lc ih. +by rewrite mulrI_eq0 // lreg_neq0 // ih lregXn. +qed. + +(* -------------------------------------------------------------------- *) +lemma deg_polyXn i : 0 <= i => deg (exp X<:c> i) = i + 1. +proof. +move=> ge0_i; rewrite degXn_proper //. +- by rewrite lcX &(lreg1). +- by rewrite degX #ring. +qed. + +(* -------------------------------------------------------------------- *) +lemma lc_polyXn i : 0 <= i => lc (exp X<:c> i) = oner<:c>. +proof. +move=> ge0_i; rewrite lcXn_proper ?lcX //. +- by apply: lreg1. +- by rewrite expr1z. +qed. + +(* -------------------------------------------------------------------- *) +lemma deg_polyXnDC i (a : c) : 0 < i => deg (exp X<:c> i + polyC a) = i + 1. +proof. by move=> ge0_i; rewrite degDl 1?degC deg_polyXn 1:ltrW //#. qed. + +(* -------------------------------------------------------------------- *) +lemma lc_polyXnDC i (a : c) : 0 < i => lc (exp X<:c> i + polyC a) = oner<:c>. +proof. +move=> gti_0; rewrite lcDl ?lc_polyXn // -1:ltrW //. +- by rewrite degC deg_polyXn 1:ltrW //#. +qed. + +(* -------------------------------------------------------------------- *) +lemma polyXnE i k : + 0 <= i => (exp X<:c> i).[k] = if k = i then oner<:c> else zero<:c>. +proof. +move=> ge0_i; elim: i ge0_i k => [|i ge0_i ih] k. +- by rewrite expr0 polyCE. +- by rewrite exprS // (mulrC<:c poly>) polyMXE ih /#. +qed. + +(* -------------------------------------------------------------------- *) +(* Sums of polys. *) +(* -------------------------------------------------------------------- *) +lemma polysumE ['a] (P : 'a -> bool) (F : 'a -> c poly) (s : 'a list) k : + (bigA P F s).[k] = bigA P (fun i => (F i).[k]) s. +proof. +elim: s => /= [|x s ih]; first by rewrite !big_nil poly0E. +rewrite !big_cons -ih /=. +by rewrite -polyDE -(fun_if (fun q : c poly => q.[k])). +qed. + +(* -------------------------------------------------------------------- *) +lemma polyE (p : c poly) : + p = bigiA predT (fun i => p.[i] ** exp X<:c> i) 0 (deg p). +proof. +apply/poly_eqP=> i ge0_i; rewrite polysumE /=; case: (i < deg p). +- move=> lt_i_dp; rewrite (bigD1 _ _ i) ?(mem_range, range_uniq) //=. + rewrite !(coeffpE, polyXnE) //= mulr1 big1_seq ?addr0 //=. + move=> @/predC1 j [ne_ji /mem_range [ge0_j _]]. + by rewrite !(coeffpE, polyXnE) // (eq_sym i j) ne_ji /= mulr0. +- move=> /lerNgt ge_i_dp; rewrite gedeg_coeff //. + rewrite big_seq big1 //= => j /mem_range [ge0_j lt_j]. + by rewrite !(coeffpE, polyXnE) // (_ : i <> j) ?mulr0 //#. +qed. + +(* -------------------------------------------------------------------- *) +lemma polywE n (p : c poly) : deg p <= n => + p = bigiA predT (fun i => p.[i] ** exp X<:c> i) 0 n. +proof. +move=> le_pn; rewrite (big_cat_int (deg p)) // ?ge0_deg. +rewrite {1}polyE; pose r := bigA _ _ _. +pose d := bigA _ _ _; suff ->: d = poly0. +- by apply/poly_eqP=> i ge0_i; rewrite polyDE poly0E addr0. +rewrite /d big_seq big1 => //= i /mem_range [gei _]. +by rewrite gedeg_coeff // scale0p. +qed. + +(* -------------------------------------------------------------------- *) +lemma deg_sum ['a] (P : 'a -> bool) (F : 'a -> c poly) (r : 'a list) k : + 0 <= k + => (forall x, P x => deg (F x) <= k) + => deg (bigA P F r) <= k. +proof. +move=> ge0_k le; elim: r => [|x r ih]; 1: by rewrite big_nil deg0. +rewrite big_cons; case: (P x) => // Px. +by rewrite &(ler_trans _ _ _ (degD _ _)) ler_maxrP ih le. +qed. + +(* -------------------------------------------------------------------- *) +(* Polynomial evaluation. *) +(* -------------------------------------------------------------------- *) +op peval (p : c poly) (a : c) = + bigiA<:c> predT (fun i => p.[i] * exp a i) 0 (deg p + 1). + +abbrev root (p : c poly) (a : c) = peval p a = zero<:c>. + +(* -------------------------------------------------------------------- *) +(* polyL: build a polynomial from a coefficient list. *) +(* -------------------------------------------------------------------- *) +op prepolyL (a : c list) : int -> c = fun i => nth zero<:c> a i. + +lemma isprepolyL a : ispoly (prepolyL a). +proof. +split=> [i lt0_i|]; first by rewrite /prepolyL nth_neg. +exists (size a) => i gti; rewrite /prepolyL nth_out //. +by apply/negP => -[_]; rewrite ltrNge /= ltrW. +qed. + +op polyL (a : c list) : c poly = to_polyd (prepolyL a). + +lemma polyLE a i : (polyL a).[i] = nth zero<:c> a i. +proof. by rewrite coeffE 1:isprepolyL. qed. + +lemma degL_le a : deg (polyL a) <= size a. +proof. +apply: deg_leP; first exact: size_ge0. +by move=> i gei; rewrite polyLE nth_out //#. +qed. + +lemma degL a : + last zero<:c> a <> zero<:c> => deg (polyL a) = size a. +proof. +move=> nz; apply/degP. +- by case: a nz => //= x s _; rewrite addrC ltzS size_ge0. +- by rewrite polyLE nth_last. +- move=> i sza; rewrite gedeg_coeff //. + by apply: (ler_trans (size a)) => //; apply: degL_le. +qed. + +lemma inj_polyL a1 a2 : + size a1 = size a2 => polyL a1 = polyL a2 => a1 = a2. +proof. +move=> eq_sz /poly_eqP eq; apply: (eq_from_nth zero<:c>)=> //. +by move=> i [+ _] - /eq; rewrite !polyLE. +qed. + +lemma surj_polyL p n : + deg p <= n => exists s, size s = n /\ p = polyL s. +proof. +move=> len; exists (map (fun i => p.[i]) (range 0 n)); split. +- by rewrite size_map size_range /=; smt(ge0_deg). +apply/poly_eqP=> i ge0_i; rewrite polyLE; case: (i < n). +- by move=> lt_in; rewrite (nth_map 0) ?size_range ?nth_range //#. +- rewrite ltrNge /= => le_ni; rewrite gedeg_coeff // 1:/#. + by rewrite nth_out // size_map size_range /#. +qed. + +end section. + +(* ==================================================================== *) +(* Phase 7: idomain extension. Mirrors [theories/algebra/Poly.ec:Poly] *) +(* (the idomain-coefficient phase). Adds the multiplicativity of [deg] *) +(* and [lc], the no-zero-divisor property, and the structural *) +(* characterisation lemmas [unitE]/[polyVE] bridging the choiceb-based *) +(* [poly_unit]/[poly_invr] (committed at Phase 5) to the structural *) +(* "deg=1 with invertible constant" form available when [c : idomain]. *) +(* ==================================================================== *) +section. +declare type c <: idomain. + +(* -------------------------------------------------------------------- *) +lemma degM (p q : c poly) : p <> poly0 => q <> poly0 => + deg (p * q) = deg p + deg q - 1. +proof. +rewrite -!lc_eq0 -!lregP => reg_p reg_q. +by rewrite &(degM_proper) mulf_eq0 negb_or -!lregP. +qed. + +(* -------------------------------------------------------------------- *) +lemma lcM (p q : c poly) : lc (p * q) = lc p * lc q. +proof. +case: (p = poly0) => [->|nz_p]; first by rewrite polyM_mul0r !lc0 mul0r. +case: (q = poly0) => [->|nz_q]. +- by rewrite polyM_mulrC polyM_mul0r !lc0 mulr0. +by rewrite lcM_proper // mulf_eq0 !lc_eq0 !(nz_p, nz_q). +qed. + +(* -------------------------------------------------------------------- *) +(* No zero divisors at the poly level (the [mulf_eq0] axiom one would *) +(* need to register [idomain with ('c poly)]). *) +(* -------------------------------------------------------------------- *) +lemma polyM_mulf_eq0 (p q : c poly) : + p * q = poly0 <=> p = poly0 \/ q = poly0. +proof. +split; last by case=> ->; rewrite ?polyM_mul0r // polyM_mulrC polyM_mul0r. +apply: contraLR; rewrite negb_or => -[nz_p nz_q]; apply/negP. +move/(congr1 (fun r : c poly => deg r + 1)) => /=; rewrite deg0 degM //=. +by rewrite gtr_eqF // -lez_add1r ler_add deg_ge1. +qed. + +(* -------------------------------------------------------------------- *) +(* Structural characterisation of [poly_unit] / [poly_invr] when *) +(* [c : idomain]. Bridges the choiceb-based forms committed at Phase 5 *) +(* to the deg=1-with-invertible-constant form usable in proofs. The *) +(* underlying ops (poly_unit, poly_invr) remain as registered; *) +(* downstream code rewrites with these equivalences. *) +(* -------------------------------------------------------------------- *) +lemma unitE (p : c poly) : + poly_unit p <=> deg p = 1 /\ unit p.[0]. +proof. +rewrite /poly_unit; split. +- case=> q pMqE. + have nz_p : p <> poly0. + - apply/negP=> ->>; have := pMqE; rewrite polyM_mulrC polyM_mul0r => /eq_sym. + by move/(congr1 (fun r : c poly => r.[0])) => /=; + rewrite poly0E polyCE /=; smt(oner_neq0). + have nz_q : q <> poly0. + - apply/negP=> ->>; have := pMqE; rewrite polyM_mul0r => /eq_sym. + by move/(congr1 (fun r : c poly => r.[0])) => /=; + rewrite poly0E polyCE /=; smt(oner_neq0). + have /(congr1 deg) : polyM q p = poly1 by exact pMqE. + rewrite deg1 degM //= => sum_eq. + have ge1_p : 1 <= deg p by rewrite deg_ge1. + have ge1_q : 1 <= deg q by rewrite deg_ge1. + have [dq_eq dp_eq] : deg q = 1 /\ deg p = 1 by smt(). + split=> //. + move/poly_eqP: pMqE => /(_ 0 _) //; rewrite polyCE /=. + by rewrite polyME big_int1 /= => /unitP. +- case=> dp_eq1 unit_p0; case/deg_eq1: dp_eq1 => a [nz_a ->>]. + exists (polyC (invr a)); apply/poly_eqP=> i ge0_i. + rewrite polyCE polyME; case: (i = 0) => [->>|ne0_i] /=. + - rewrite big_int1 /= !polyCE /= mulVr //. + by move: unit_p0; rewrite polyCE. + rewrite big_seq big1 ?addr0 //= => j /mem_range [ge0_j _]. + rewrite !polyCE; case: (j = 0) => [->>/=|/= _]. + - by rewrite ne0_i /= mulr0. + - by rewrite mul0r. +qed. + +(* -------------------------------------------------------------------- *) +(* Structural value of [poly_invr] for unit polynomials over an + idomain coefficient: [poly_invr (polyC a) = polyC (invr a)] when + [unit a]. The choiceb's witness [q : q * polyC a = poly1] is + uniquely [polyC (invr a)] modulo invertibility, which suffices for + pointwise equality. *) +(* -------------------------------------------------------------------- *) +lemma polyVE (a : c) : unit a => poly_invr (polyC a) = polyC (invr a). +proof. +move=> ua; rewrite /poly_invr. +have ex_q : exists q, polyM q (polyC a) = poly_one<:c>. +- exists (polyC (invr a)); apply/poly_eqP=> i ge0_i. + rewrite polyME /poly_one polyCE; case: (i = 0) => [->>|nei] /=. + - by rewrite big_int1 /= !polyCE /= mulVr. + rewrite big_seq big1 ?addr0 //= => j /mem_range [ge0_j _]. + rewrite !polyCE; case: (j = 0) => [->>/=|/= _]. + - by rewrite nei /= mulr0. + - by rewrite mul0r. +have := choicebP (fun q => polyM q (polyC a) = poly_one<:c>) (polyC a) ex_q. +move=> /= choice_eq. +(* Both [choiceb …] and [polyC (invr a)] are left inverses of [polyC a]; + uniqueness via no-zero-divisors yields equality. *) +pose q := choiceb (fun q => polyM q (polyC a) = poly_one<:c>) (polyC a). +have qE : polyM q (polyC a) = poly_one<:c> by exact choice_eq. +apply/poly_eqP=> i ge0_i. +have polyC_invr_eq : polyM (polyC (invr a)) (polyC a) = poly_one<:c>. +- apply/poly_eqP=> j ge0_j; rewrite polyME /poly_one polyCE. + case: (j = 0) => [->>|nej] /=. + - by rewrite big_int1 /= !polyCE /= mulVr. + rewrite big_seq big1 ?addr0 //= => k /mem_range [ge0_k _]. + rewrite !polyCE; case: (k = 0) => [->>/=|/= _]. + - by rewrite nej /= mulr0. + - by rewrite mul0r. +have eq2 : polyM q (polyC a) = polyM (polyC (invr a)) (polyC a) + by rewrite qE -polyC_invr_eq. +(* Cancel [polyC a] on the right: it has [unit] coeff, so it's [lreg]. *) +have nz_a : a <> zero<:c>. +- apply/negP=> a0; have h := mulVr a ua; rewrite a0 mulr0 in h. + by move: h => /eq_sym; smt(oner_neq0). +have lreg_pCa : lreg (polyC a). +- apply lreg_lc; rewrite lcC; apply/lregP/nz_a. +have inj_pCa : injective (fun y : c poly => polyM y (polyC a)). +- by move=> x y; rewrite (polyM_mulrC x) (polyM_mulrC y) => /lreg_pCa. +have q_eq : q = polyC (invr a) by apply: inj_pCa. +by rewrite q_eq. +qed. + +end section. diff --git a/examples/tcalgebra/TcPolySmokeTest.ec b/examples/tcalgebra/TcPolySmokeTest.ec new file mode 100644 index 0000000000..e3eac87311 --- /dev/null +++ b/examples/tcalgebra/TcPolySmokeTest.ec @@ -0,0 +1,98 @@ +(* ==================================================================== *) +(* Smoke test for TcPoly: instantiate the parametric polynomial *) +(* library at carrier [int] (which is registered as [idomain] via *) +(* TcInt) and exercise representative lemmas from each phase. Confirms *) +(* the registered instances flow end-to-end through TC reduction. *) +(* ==================================================================== *) +require import AllCore List. +require import TcMonoid TcRing TcBigop TcBigalg TcInt. +require import TcPoly. + +(* -------------------------------------------------------------------- *) +(* Phase 1-2: constructors / coefficient formulas. *) +lemma test_polyCE (a : int) (k : int) : + (polyC<:int> a).[k] = if k = 0 then a else 0. +proof. by rewrite polyCE. qed. + +lemma test_polyXE (k : int) : + (X<:int>).[k] = if k = 1 then 1 else 0. +proof. by rewrite polyXE. qed. + +(* -------------------------------------------------------------------- *) +(* Phase 4: multiplication on int polys. *) +lemma test_mulrA (p q r : int poly) : + polyM p (polyM q r) = polyM (polyM p q) r. +proof. by apply polyM_mulrA. qed. + +lemma test_mulrC (p q : int poly) : polyM p q = polyM q p. +proof. by apply polyM_mulrC. qed. + +(* -------------------------------------------------------------------- *) +(* Phase 6a: degree arithmetic on int polys. *) +lemma test_degC (a : int) : + deg (polyC<:int> a) = if a = 0 then 0 else 1. +proof. by rewrite degC. qed. + +lemma test_deg0 : deg poly0<:int> = 0. +proof. by rewrite deg0. qed. + +lemma test_deg1 : deg poly1<:int> = 1. +proof. by rewrite deg1. qed. + +lemma test_degX : deg X<:int> = 2. +proof. by rewrite degX. qed. + +(* -------------------------------------------------------------------- *) +(* Phase 6c: polyXn / X^i theory. *) +lemma test_deg_polyXn (i : int) : 0 <= i => deg (exp X<:int> i) = i + 1. +proof. by apply deg_polyXn. qed. + +lemma test_lc_polyXn (i : int) : 0 <= i => lc (exp X<:int> i) = 1. +proof. by apply lc_polyXn. qed. + +(* -------------------------------------------------------------------- *) +(* Phase 7: idomain-only lemmas — multiplicativity of [deg] / [lc]. *) +lemma test_degM (p q : int poly) : + p <> poly0 => q <> poly0 => deg (polyM p q) = deg p + deg q - 1. +proof. by apply degM. qed. + +lemma test_lcM (p q : int poly) : lc (polyM p q) = lc p * lc q. +proof. by apply lcM. qed. + +lemma test_polyM_mulf_eq0 (p q : int poly) : + polyM p q = poly0 <=> p = poly0 \/ q = poly0. +proof. by apply polyM_mulf_eq0. qed. + +(* -------------------------------------------------------------------- *) +(* Concrete computation through the convolution: coefficient at index 0 + of [(X + polyC 1) * (X + polyC (-1))] equals -1. Spot-check that + [polyM] reduces correctly through the registered comring chain. *) +lemma test_polyM_at_0 : + (polyM<:int> (polyD X (polyC 1)) (polyD X (polyC (-1)))).[0] = -1. +proof. +by rewrite polyME big_int1 /= !(polyDE, polyXE, polyCE) /=. +qed. + +(* -------------------------------------------------------------------- *) +(* polyL constructor on int. *) +lemma test_polyLE (xs : int list) (k : int) : + (polyL xs).[k] = nth 0 xs k. +proof. by rewrite polyLE. qed. + +(* -------------------------------------------------------------------- *) +(* Class lemmas at carrier [int poly] — exercises the parametric Path B *) +(* path through the unifier's flush + matcher's drain. *) +(* -------------------------------------------------------------------- *) +lemma test_addrC_at_int_poly (p q : int poly) : p + q = q + p. +proof. by apply (addrC<:int poly>). qed. + +lemma test_addrA_at_int_poly (p q r : int poly) : + p + (q + r) = (p + q) + r. +proof. by apply (addrA<:int poly>). qed. + +lemma test_mulrC_at_int_poly (p q : int poly) : p * q = q * p. +proof. by apply (mulrC<:int poly>). qed. + +lemma test_mulrA_at_int_poly (p q r : int poly) : + p * (q * r) = (p * q) * r. +proof. by apply (mulrA<:int poly>). qed. diff --git a/examples/tcalgebra/TcReal.ec b/examples/tcalgebra/TcReal.ec new file mode 100644 index 0000000000..4df9c3700e --- /dev/null +++ b/examples/tcalgebra/TcReal.ec @@ -0,0 +1,74 @@ +pragma +implicits. + +(* -------------------------------------------------------------------- *) +require import Core. +require import TcMonoid TcRing TcNumber. +require import Real. +require CoreReal. + +(* ==================================================================== *) +(* Canonical [real] instance for the [TcMonoid] / [TcRing] hierarchy. + Mirrors [theories/datatypes/Real.ec:RField] (a [Ring.Field] clone in + the legacy world). The TC declaration synthesises the comring / + idomain / addgroup / addmonoid / mulmonoid / monoid ancestors along + the way so a single [instance field] is enough. *) +(* ==================================================================== *) + +(* Named wrapper for [real]'s [unit]: the TC instance form requires an + op-name on the rhs of [op X = …], not an inline lambda. *) +op real_unit (x : real) : bool = x <> 0%r. + +(* -------------------------------------------------------------------- *) +instance idomain with real reducible + op zero = 0%r + op (+) = CoreReal.add + op [-] = CoreReal.opp + op oner = 1%r + op ( * ) = CoreReal.mul + op invr = CoreReal.inv + op unit = real_unit + + proof mopA<:addmonoid> by smt() + proof mopC<:addmonoid> by smt() + proof mop0<:addmonoid> by smt() + proof addrN by smt() + proof oner_neq0 by smt() + proof mopA<:mulmonoid> by smt() + proof mopC<:mulmonoid> by smt() + proof mop0<:mulmonoid> by smt() + proof mulrDl by smt() + proof mulVr by smt() + proof unitP by smt() + proof unitout by smt() + proof mulf_eq0 by smt(). + +(* -------------------------------------------------------------------- *) +(* Order and field structure on top of [idomain with real]. Mirrors + [theories/algebra/StdOrder.ec:RealOrder] and the [Number.RealField] + level of the legacy hierarchy. *) +op real_norm = Real."`|_|". +op real_le = CoreReal.le. +op real_lt = CoreReal.lt. +op real_min = fun (x y : real) => if x <= y then x else y. +op real_max = fun (x y : real) => if y <= x then x else y. + +instance tcrealdomain with real reducible + op "`|_|" = real_norm + op (<=) = real_le + op (<) = real_lt + op minr = real_min + op maxr = real_max + + proof ler_norm_add by smt() + proof addr_gt0 by smt() + proof norm_eq0 by smt() + proof ger_leVge by smt() + proof normrM by smt() + proof ler_def by smt() + proof ltr_def by smt() + proof real_axiom by smt() + proof minrE by smt() + proof maxrE by smt(). + +instance tcrealfield with real reducible + proof unitfP by smt(). diff --git a/examples/tcalgebra/TcRing.ec b/examples/tcalgebra/TcRing.ec new file mode 100644 index 0000000000..230c822d48 --- /dev/null +++ b/examples/tcalgebra/TcRing.ec @@ -0,0 +1,907 @@ +pragma +implicits. + +(* -------------------------------------------------------------------- *) +require import Core Int IntDiv. +require import TcMonoid. + +(* ==================================================================== *) +(* Additive group: extends [addmonoid] with negation. Carrier of all + ZModule lemmas in the original [theories/algebra/Ring.ec]. *) +(* ==================================================================== *) +type class addgroup <: addmonoid = { + op [-] : addgroup -> addgroup + + axiom addrN : right_inverse zero<:addgroup> [-] (+)<:addgroup> +}. + +(* -------------------------------------------------------------------- *) +section. +declare type t <: addgroup. + +(* Re-export the inherited addmonoid axioms under the conventional + ring-theoretic names. *) +lemma addrA: associative (+)<:t>. +proof. exact addmA. qed. + +lemma addrC: commutative (+)<:t>. +proof. exact addmC. qed. + +lemma add0r: left_id zero<:t> (+)<:t>. +proof. exact add0m. qed. + +(* The original [Ring.ec] takes [addNr] as the additive group axiom and + derives [addrN] from it; here we take [addrN] (right inverse) and + derive [addNr] (left inverse) instead. *) +lemma addNr: left_inverse zero<:t> [-] (+)<:t>. +proof. by move=> x; rewrite addrC addrN. qed. + +abbrev (-) (x y : t) = x + -y. + +lemma addr0: right_id zero<:t> (+). +proof. exact addm0. qed. + +lemma addrCA: left_commutative (+)<:t>. +proof. exact addmCA. qed. + +lemma addrAC: right_commutative (+)<:t>. +proof. exact addmAC. qed. + +lemma addrACA: interchange (+)<:t> (+). +proof. exact addmACA. qed. + +lemma subrr (x : t): x - x = zero. +proof. by rewrite addrN. qed. + +hint simplify subrr. + +lemma addKr: left_loop ([-]<:t>) (+). +proof. by move=> x y; rewrite addrA addNr add0r. qed. + +lemma addNKr: rev_left_loop ([-]<:t>) (+). +proof. by move=> x y; rewrite addrA addrN add0r. qed. + +lemma addrK: right_loop ([-]<:t>) (+). +proof. by move=> x y; rewrite -addrA addrN addr0. qed. + +lemma addrNK: rev_right_loop ([-]<:t>) (+). +proof. by move=> x y; rewrite -addrA addNr addr0. qed. + +lemma subrK (x y : t): (x - y) + y = x. +proof. by rewrite addrNK. qed. + +lemma addrI: right_injective (+)<:t>. +proof. by move=> x y z h; rewrite -(@addKr x z) -h addKr. qed. + +lemma addIr: left_injective (+)<:t>. +proof. by move=> x y z h; rewrite -(@addrK x z) -h addrK. qed. + +lemma opprK: involutive ([-]<:t>). +proof. by move=> x; apply (@addIr (-x)); rewrite addNr addrN. qed. + +lemma oppr_inj : injective ([-]<:t>). +proof. by move=> x y eq; apply/(addIr (-x)); rewrite subrr eq subrr. qed. + +lemma oppr0 : -zero<:t> = zero. +proof. by rewrite -(@addr0 (-zero)) addNr. qed. + +lemma oppr_eq0 (x : t) : (- x = zero) <=> (x = zero). +proof. by rewrite (inv_eq opprK) oppr0. qed. + +lemma subr0 (x : t): x - zero = x. +proof. by rewrite oppr0 addr0. qed. + +lemma sub0r (x : t): zero - x = - x. +proof. by rewrite add0r. qed. + +lemma opprD (x y : t): -(x + y) = -x + -y. +proof. by apply (@addrI (x + y)); rewrite addrA addrN addrAC addrK addrN. qed. + +lemma opprB (x y : t): -(x - y) = y - x. +proof. by rewrite opprD opprK addrC. qed. + +lemma subrACA: interchange (fun (x y : t) => x - y) (+). +proof. by move=> x y z u; rewrite addrACA opprD. qed. + +lemma subr_eq (x y z : t): + (x - z = y) <=> (x = y + z). +proof. +move: (can2_eq (fun x, x - z) (fun x, x + z) _ _ x y) => //=. ++ by move=> {x} x /=; rewrite addrNK. ++ by move=> {x} x /=; rewrite addrK. +qed. + +lemma subr_eq0 (x y : t): (x - y = zero) <=> (x = y). +proof. by rewrite subr_eq add0r. qed. + +lemma addr_eq0 (x y : t): (x + y = zero) <=> (x = -y). +proof. by rewrite -(@subr_eq0 x) opprK. qed. + +lemma eqr_opp (x y : t): (- x = - y) <=> (x = y). +proof. by apply/(@can_eq _ _ opprK x y). qed. + +lemma eqr_oppLR (x y : t) : (- x = y) <=> (x = - y). +proof. by apply/(@inv_eq _ opprK x y). qed. + +lemma eqr_sub (x y z u : t) : (x - y = z - u) <=> (x + u = z + y). +proof. +rewrite -{1}(addrK u x) -{1}(addrK y z) -!addrA. +by rewrite (addrC (-u)) !addrA; split=> [/addIr /addIr|->//]. +qed. + +lemma subr_add2r (z x y : t): (x + z) - (y + z) = x - y. +proof. by rewrite opprD addrACA addrN addr0. qed. +end section. + +(* -------------------------------------------------------------------- *) +(* [intmul x n] is [n] copies of [x] folded with [+]; for negative [n] + it is [-(intmul x (-n))]. Foundational for [ofint] and for + characterizing ring exponents. *) +op intmul ['a <: addgroup] (x : 'a) (n : int) = + if n < 0 + then -(iterop (-n) (+) x zero) + else (iterop n (+) x zero). + +(* -------------------------------------------------------------------- *) +section. +declare type t <: addgroup. + +lemma intmulpE (x : t) (c : int) : 0 <= c => + intmul x c = iterop c (+) x zero. +proof. by rewrite /intmul lezNgt => ->. qed. + +lemma mulr0z (x : t): intmul x 0 = zero. +proof. by rewrite /intmul /= iterop0. qed. + +lemma mulr1z (x : t): intmul x 1 = x. +proof. by rewrite /intmul /= iterop1. qed. + +lemma mulr2z (x : t): intmul x 2 = x + x. +proof. by rewrite /intmul /= (@iteropS 1) // (@iterS 0) // iter0. qed. + +lemma mulrNz (x : t) (n : int): intmul x (-n) = -(intmul x n). +proof. +case: (n = 0)=> [->|nz_c]; first by rewrite oppz0 mulr0z oppr0. +rewrite /intmul oppz_lt0 oppzK ltz_def nz_c lezNgt /=. +by case: (n < 0); rewrite ?opprK. +qed. + +lemma mulrS (x : t) (n : int): 0 <= n => + intmul x (n+1) = x + intmul x n. +proof. +move=> ge0n; rewrite !intmulpE 1:addz_ge0 //. +by rewrite !iteropE iterS. +qed. + +lemma mulNrz (x : t) (n : int) : intmul (-x) n = - (intmul x n). +proof. +elim/intwlog: n => [n h| | n ge0_n ih]. ++ by rewrite -(@oppzK n) !(@mulrNz _ (- n)) h. ++ by rewrite !mulr0z oppr0. ++ by rewrite !mulrS // ih opprD. +qed. + +lemma mulNrNz (x : t) (n : int) : intmul (-x) (-n) = intmul x n. +proof. by rewrite mulNrz mulrNz opprK. qed. + +lemma mulrSz (x : t) (n : int) : intmul x (n + 1) = x + intmul x n. +proof. +case: (0 <= n) => [/mulrS ->//|]; rewrite -ltzNge => gt0_n. +case: (n = -1) => [->/=|]; 1: by rewrite mulrNz mulr1z mulr0z subrr. +move=> neq_n_N1; rewrite -!(@mulNrNz x). +rewrite (_ : -n = -(n+1) + 1) 1:/# mulrS 1:/#. +by rewrite addrA subrr add0r. +qed. + +lemma mulrDz (x : t) (n m : int) : intmul x (n + m) = intmul x n + intmul x m. +proof. +wlog: n m / 0 <= m => [wlog|]. ++ case: (0 <= m) => [/wlog|]; first by apply. + rewrite -ltzNge => lt0_m; rewrite (_ : n + m = -(-m - n)) 1:/#. + by rewrite mulrNz addzC wlog 1:/# !mulrNz -opprD opprK. +elim: m => /= [|m ge0_m ih]; first by rewrite mulr0z addr0. +by rewrite addzA !mulrSz ih addrCA. +qed. +end section. + +(* ==================================================================== *) +(* Commutative ring: addgroup + multiplicative commutative monoid + + distributivity. Multi-parent factory inheritance: comring inherits + from [addgroup] and from [mulmonoid] (with [idm := oner] and + [(+) := ( * )]). The locally-declared [oner] / [( * )] are aliases + for the inherited mulmonoid ops; the multiplicative + associativity / commutativity / left-id axioms ([mulrA] / [mulrC] + / [mul1r]) are kept as axioms in the class body so they're + available under conventional ring-theoretic names downstream. *) +(* ==================================================================== *) +type class comring <: addgroup & mulmonoid = { + (* Additive structure inherited from [addgroup -> addmonoid -> + (monoid with idm = zero, mop = (+))]. + Multiplicative structure inherited from + [mulmonoid -> (monoid with idm = oner, mop = ( * ))]. + The monoid axioms [mopA] / [mopC] / [mop0] are obligations of + BOTH chain paths; at instance-declaration time discharge them + twice with label-disambiguated [proof mopA<:addmonoid>] and + [proof mopA<:mulmonoid>] clauses. *) + op invr : comring -> comring + op unit : comring -> bool + + axiom oner_neq0 : oner <> zero<:comring> + axiom mulrDl : left_distributive ( * ) (+)<:comring> + axiom mulVr : left_inverse_in unit oner invr ( * ) + axiom unitP : forall (x y : comring), y * x = oner => unit x + axiom unitout : forall (x : comring), !unit x => invr x = x +}. + +(* -------------------------------------------------------------------- *) +section. +declare type t <: comring. + +abbrev (/) (x y : t) = x * (invr y). + +(* Re-export the inherited mulmonoid-view monoid lemmas under + the conventional ring-theoretic names. Going through + [mulm*] (defined at `'a <: mulmonoid`) avoids the comring-level + ambiguity between the addmonoid and mulmonoid views. *) +lemma mulrA: associative ( * )<:t>. +proof. by apply: mulmA. qed. + +lemma mulrC: commutative ( * )<:t>. +proof. by apply: mulmC. qed. + +lemma mul1r: left_id oner<:t> ( * )<:t>. +proof. by apply: mul1m. qed. + +lemma mulr1: right_id oner<:t> ( * ). +proof. by move=> x; rewrite mulrC mul1r. qed. + +lemma mulrCA: left_commutative ( * )<:t>. +proof. by move=> x y z; rewrite !mulrA (@mulrC x y). qed. + +lemma mulrAC: right_commutative ( * )<:t>. +proof. by move=> x y z; rewrite -!mulrA (@mulrC y z). qed. + +lemma mulrACA: interchange ( * )<:t> ( * ). +proof. by move=> x y z u; rewrite -!mulrA (mulrCA y). qed. + +lemma mulrSl (x y : t) : (x + oner) * y = x * y + y. +proof. by rewrite mulrDl mul1r. qed. + +lemma mulrDr: right_distributive ( * )<:t> (+). +proof. by move=> x y z; rewrite mulrC mulrDl !(@mulrC _ x). qed. + +lemma mul0r: left_zero zero<:t> ( * ). +proof. by move=> x; apply: (@addIr (oner * x)); rewrite -mulrDl !add0r mul1r. qed. + +lemma mulr0: right_zero zero<:t> ( * ). +proof. by move=> x; apply: (@addIr (x * oner)); rewrite -mulrDr !add0r mulr1. qed. + +lemma mulrN (x y : t): x * (- y) = - (x * y). +proof. by apply: (@addrI (x * y)); rewrite -mulrDr !addrN mulr0. qed. + +lemma mulNr (x y : t): (- x) * y = - (x * y). +proof. by apply: (@addrI (x * y)); rewrite -mulrDl !addrN mul0r. qed. + +lemma mulrNN (x y : t): (- x) * (- y) = x * y. +proof. by rewrite mulrN mulNr opprK. qed. + +lemma mulN1r (x : t): (-oner) * x = -x. +proof. by rewrite mulNr mul1r. qed. + +lemma mulrN1 (x : t): x * -oner = -x. +proof. by rewrite mulrN mulr1. qed. + +lemma mulrBl: left_distributive ( * )<:t> (fun (x y : t) => x - y). +proof. by move=> x y z; rewrite mulrDl !mulNr. qed. + +lemma mulrBr: right_distributive ( * )<:t> (fun (x y : t) => x - y). +proof. by move=> x y z; rewrite mulrDr !mulrN. qed. + +(* -------------------------------------------------------------------- *) +(* Multiplicative-inverse / unit theory. *) +(* -------------------------------------------------------------------- *) + +lemma mulrV: right_inverse_in unit<:t> oner invr ( * ). +proof. by move=> x /mulVr; rewrite mulrC. qed. + +lemma divrr (x : t): unit x => x / x = oner. +proof. by apply/mulrV. qed. + +lemma invr_out (x : t): !unit x => invr x = x. +proof. by apply/unitout. qed. + +lemma unitrP (x : t): unit x <=> (exists y, y * x = oner). +proof. by split=> [/mulVr<- |]; [exists (invr x) | case=> y /unitP]. qed. + +lemma mulKr: left_loop_in unit<:t> invr ( * ). +proof. by move=> x un_x y; rewrite mulrA mulVr // mul1r. qed. + +lemma mulrK: right_loop_in unit<:t> invr ( * ). +proof. by move=> y un_y x; rewrite -mulrA mulrV // mulr1. qed. + +lemma mulVKr: rev_left_loop_in unit<:t> invr ( * ). +proof. by move=> x un_x y; rewrite mulrA mulrV // mul1r. qed. + +lemma mulrVK: rev_right_loop_in unit<:t> invr ( * ). +proof. by move=> y nz_y x; rewrite -mulrA mulVr // mulr1. qed. + +lemma mulrI: right_injective_in unit<:t> ( * ). +proof. by move=> x Ux; have /can_inj h := mulKr _ Ux. qed. + +lemma mulIr: left_injective_in unit<:t> ( * ). +proof. by move=> x /mulrI h y1 y2; rewrite !(@mulrC _ x) => /h. qed. + +lemma unitrE (x : t): unit x <=> (x / x = oner). +proof. +split=> [Ux|xx1]; 1: by apply/divrr. +by apply/unitrP; exists (invr x); rewrite mulrC. +qed. + +lemma invrK: involutive invr<:t>. +proof. +move=> x; case: (unit x)=> Ux; 2: by rewrite !invr_out. +rewrite -(mulrK _ Ux (invr (invr x))) -mulrA. +rewrite (@mulrC x) mulKr //; apply/unitrP. +by exists x; rewrite mulrV. +qed. + +lemma invr_inj: injective invr<:t>. +proof. by apply: (can_inj _ _ invrK). qed. + +lemma unitrV (x : t): unit (invr x) <=> unit x. +proof. by rewrite !unitrE invrK mulrC. qed. + +lemma unitr1: unit<:t> oner. +proof. by apply/unitrP; exists oner; rewrite mulr1. qed. + +lemma invr1: invr oner<:t> = oner. +proof. by rewrite -{2}(mulVr _ unitr1) mulr1. qed. + +lemma div1r (x : t) : oner / x = invr x. +proof. by rewrite mul1r. qed. + +lemma divr1 (x : t) : x / oner = x. +proof. by rewrite invr1 mulr1. qed. + +lemma unitr0: !unit zero<:t>. +proof. by apply/negP=> /unitrP [y]; rewrite mulr0 eq_sym oner_neq0. qed. + +lemma invr0: invr zero<:t> = zero. +proof. by rewrite invr_out ?unitr0. qed. + +lemma unitrN1: unit<:t> (-oner). +proof. by apply/unitrP; exists (-oner); rewrite mulrNN mulr1. qed. + +lemma invrN1: invr<:t> (-oner) = -oner. +proof. by rewrite -{2}(divrr unitrN1) mulN1r opprK. qed. + +lemma unitrMl (x y : t) : unit y => (unit (x * y) <=> unit x). +proof. +move=> uy; case: (unit x)=> /=; last first. ++ apply/contra=> uxy; apply/unitrP; exists (y * invr (x * y)). + apply/(mulrI (invr y)); first by rewrite unitrV. + rewrite !mulrA mulVr // mul1r; apply/(mulIr y)=> //. + by rewrite -mulrA mulVr // mulr1 mulVr. +move=> ux; apply/unitrP; exists (invr y * invr x). +by rewrite -!mulrA mulKr // mulVr. +qed. + +lemma unitrMr (x y : t) : unit x => (unit (x * y) <=> unit y). +proof. +move=> ux; split=> [uxy|uy]; last by rewrite unitrMl. +by rewrite -(mulKr _ ux y) unitrMl ?unitrV. +qed. + +lemma unitrM (x y : t) : unit (x * y) <=> (unit x /\ unit y). +proof. +case: (unit x) => /=; first by apply: unitrMr. +apply: contra => /unitrP[z] zVE; apply/unitrP. +by exists (y * z); rewrite mulrAC (@mulrC y) (@mulrC _ z). +qed. + +lemma unitrN (x : t) : unit (-x) <=> unit x. +proof. by rewrite -mulN1r unitrMr // unitrN1. qed. + +lemma invrM (x y : t) : unit x => unit y => invr (x * y) = invr y * invr x. +proof. +move=> Ux Uy; have Uxy: unit (x * y) by rewrite unitrMl. +by apply: (mulrI _ Uxy); rewrite mulrV ?mulrA ?mulrK ?mulrV. +qed. + +lemma invrN (x : t) : invr (- x) = - (invr x). +proof. +case: (unit x) => ux; last by rewrite !invr_out ?unitrN. +by rewrite -mulN1r invrM ?unitrN1 // invrN1 mulrN1. +qed. + +lemma invr_neq0 (x : t) : x <> zero => invr x <> zero. +proof. +move=> nx0; case: (unit x)=> Ux; last by rewrite invr_out ?Ux. +by apply/negP=> x'0; move: Ux; rewrite -unitrV x'0 unitr0. +qed. + +lemma invr_eq0 (x : t) : (invr x = zero) <=> (x = zero). +proof. by apply/iff_negb; split=> /invr_neq0; rewrite ?invrK. qed. + +lemma invr_eq1 (x : t) : (invr x = oner) <=> (x = oner). +proof. by rewrite (inv_eq invrK) invr1. qed. + +end section. + +(* -------------------------------------------------------------------- *) +(* Embedding of [int] into a [comring]: [ofint n = intmul oner n]. *) +op ofint ['a <: comring] (n : int) : 'a = intmul oner n. + +(* -------------------------------------------------------------------- *) +section. +declare type t <: comring. + +lemma ofint0 : ofint<:t> 0 = zero. +proof. by apply/mulr0z. qed. + +lemma ofint1 : ofint<:t> 1 = oner. +proof. by apply/mulr1z. qed. + +lemma ofintS (i : int) : 0 <= i => ofint<:t> (i + 1) = oner + ofint i. +proof. by apply/mulrS. qed. + +lemma ofintN (i : int) : ofint<:t> (-i) = - (ofint i). +proof. by apply/mulrNz. qed. + +(* -------------------------------------------------------------------- *) +(* Interaction between additive [intmul] and multiplicative [( * )]. *) +lemma mulrnAl (x y : t) (n : int) : 0 <= n => + (intmul x n) * y = intmul (x * y) n. +proof. +elim: n => [|n ge0n ih]; rewrite !(mulr0z, mulrS) ?mul0r //. +by rewrite mulrDl ih. +qed. + +lemma mulrnAr (x y : t) (n : int) : 0 <= n => + x * (intmul y n) = intmul (x * y) n. +proof. +elim: n => [|n ge0n ih]; rewrite !(mulr0z, mulrS) ?mulr0 //. +by rewrite mulrDr ih. +qed. + +lemma mulrzAl (x y : t) (z : int) : (intmul x z) * y = intmul (x * y) z. +proof. +case: (lezWP 0 z)=> [|_] le; first by rewrite mulrnAl. +by rewrite -oppzK mulrNz mulNr mulrnAl -?mulrNz // oppz_ge0. +qed. + +lemma mulrzAr (x y : t) (z : int) : x * (intmul y z) = intmul (x * y) z. +proof. +case: (lezWP 0 z)=> [|_] le; first by rewrite mulrnAr. +by rewrite -oppzK mulrNz mulrN mulrnAr -?mulrNz // oppz_ge0. +qed. + +lemma mul1r0z (x : t) : x * ofint 0 = zero. +proof. by rewrite ofint0 mulr0. qed. + +lemma mul1r1z (x : t) : x * ofint 1 = x. +proof. by rewrite ofint1 mulr1. qed. + +lemma mul1r2z (x : t) : x * ofint 2 = x + x. +proof. by rewrite /ofint mulr2z mulrDr mulr1. qed. + +lemma mulr_intl (x : t) (z : int) : (ofint z) * x = intmul x z. +proof. by rewrite mulrzAl mul1r. qed. + +lemma mulr_intr (x : t) (z : int) : x * (ofint z) = intmul x z. +proof. by rewrite mulrzAr mulr1. qed. +end section. + +(* -------------------------------------------------------------------- *) +(* Multiplicative exponentiation. Mirrors [intmul] on the additive side + but folds with [( * )] starting at [oner], inverting for negative + exponents. *) +op exp ['a <: comring] (x : 'a) (n : int) = + if n < 0 + then invr (iterop (-n) ( * ) x oner) + else iterop n ( * ) x oner. + +(* -------------------------------------------------------------------- *) +section. +declare type t <: comring. + +lemma expr0 (x : t) : exp x 0 = oner. +proof. by rewrite /exp /= iterop0. qed. + +lemma expr1 (x : t) : exp x 1 = x. +proof. by rewrite /exp /= iterop1. qed. + +(* Multiplicative analogue of [TcMonoid.iteropE], specialised for + [( * )] / [oner] (i.e. [iterop] folded over the mulmonoid view). *) +lemma mul_iteropE (n : int) (x : t) : + iterop n ( * ) x oner = iter n (( * ) x) oner. +proof. +elim/natcase n => [n le0_n|n ge0_n]. ++ by rewrite ?(iter0, iterop0). ++ by rewrite iterSr // mulr1 iteropS. +qed. + +lemma exprS (x : t) (i : int) : 0 <= i => exp x (i+1) = x * (exp x i). +proof. +move=> ge0i; rewrite /exp !ltzNge ge0i addz_ge0 //=. +by rewrite !mul_iteropE iterS. +qed. + +lemma expr_pred (x : t) (i : int) : 0 < i => exp x i = x * (exp x (i - 1)). +proof. smt(exprS). qed. + +lemma exprSr (x : t) (i : int) : 0 <= i => exp x (i+1) = (exp x i) * x. +proof. by move=> ge0_i; rewrite exprS // mulrC. qed. + +lemma expr2 (x : t) : exp x 2 = x * x. +proof. by rewrite (@exprS _ 1) // expr1. qed. + +lemma exprN (x : t) (i : int) : exp x (-i) = invr (exp x i). +proof. +case: (i = 0) => [->|]; first by rewrite oppz0 expr0 invr1. +rewrite /exp oppz_lt0 ltzNge lez_eqVlt oppzK=> -> /=. +by case: (_ < _)%Int => //=; rewrite invrK. +qed. + +lemma exprN1 (x : t) : exp x (-1) = invr x. +proof. by rewrite exprN expr1. qed. + +lemma unitrX (x : t) (m : int) : unit x => unit (exp x m). +proof. +move=> invx; wlog: m / (0 <= m) => [wlog|]. ++ (have [] : (0 <= m \/ 0 <= -m) by move=> /#); first by apply: wlog. + by move=> ?; rewrite -oppzK exprN unitrV &(wlog). +elim: m => [|m ge0_m ih]; first by rewrite expr0 unitr1. +by rewrite exprS // &(unitrMl). +qed. + +lemma unitrX_neq0 (x : t) (m : int) : m <> 0 => unit (exp x m) => unit x. +proof. +wlog: m / (0 < m) => [wlog|]. ++ case: (0 < m); [by apply: wlog | rewrite ltzNge /= => le0_m nz_m]. + by move=> h; (apply: (wlog (-m)); 1,2:smt()); rewrite exprN unitrV. +by move=> gt0_m _; rewrite (_ : m = m - 1 + 1) // exprS 1:/# unitrM. +qed. + +lemma exprV (x : t) (i : int) : exp (invr x) i = exp x (-i). +proof. +wlog: i / (0 <= i) => [wlog|]; first by smt(exprN). +elim: i => /= [|i ge0_i ih]; first by rewrite !expr0. +case: (i = 0) => [->|] /=; first by rewrite exprN1 expr1. +move=> nz_i; rewrite exprS // ih !exprN. +case: (unit x) => [invx|invNx]. ++ by rewrite -invrM ?unitrX // exprS // mulrC. +rewrite !invr_out //; last by rewrite exprS. ++ by apply: contra invNx; apply: unitrX_neq0 => /#. ++ by apply: contra invNx; apply: unitrX_neq0 => /#. +qed. + +lemma exprVn (x : t) (n : int) : 0 <= n => exp (invr x) n = invr (exp x n). +proof. +elim: n => [|n ge0_n ih]; first by rewrite !expr0 invr1. +case: (unit x) => ux. +- by rewrite exprSr -1:exprS // invrM ?unitrX // ih -invrM // unitrX. +- by rewrite !invr_out //; apply: contra ux; apply: unitrX_neq0 => /#. +qed. + +lemma exprMn (x y : t) (n : int) : 0 <= n => exp (x * y) n = exp x n * exp y n. +proof. +elim: n => [|n ge0_n ih]; first by rewrite !expr0 mulr1. +by rewrite !exprS // mulrACA ih. +qed. + +lemma exprD_nneg (x : t) (m n : int) : 0 <= m => 0 <= n => + exp x (m + n) = exp x m * exp x n. +proof. +move=> ge0_m ge0_n; elim: m ge0_m => [|m ge0_m ih]. ++ by rewrite expr0 mul1r. +by rewrite addzAC !exprS ?addz_ge0 // ih mulrA. +qed. + +lemma exprD (x : t) (m n : int) : unit x => exp x (m + n) = exp x m * exp x n. +proof. +wlog: m n x / (0 <= m + n) => [wlog invx|]. ++ case: (0 <= m + n); [by move=> ?; apply: wlog | rewrite lezNgt /=]. + move=> lt0_mDn; rewrite -(@oppzK (m + n)) -exprV. + rewrite -{2}(@oppzK m) -{2}(@oppzK n) -!(@exprV _ (- _)%Int). + by rewrite -wlog 1:/# ?unitrV //#. +move=> ge0_mDn invx; wlog: m n ge0_mDn / (m <= n) => [wlog|le_mn]. ++ by case: (m <= n); [apply: wlog | rewrite mulrC addzC /#]. +(have ge0_n: 0 <= n by move=> /#); elim: n ge0_n m le_mn ge0_mDn. ++ by move=> n _ _ /=; rewrite expr0 mulr1. +move=> n ge0_n ih m le_m_Sn ge0_mDSn; move: ge0_mDSn. +rewrite lez_eqVlt => -[?|]; first have->: n+1 = -m by move=> /#. ++ by rewrite subzz exprN expr0 divrr // unitrX. +move=> gt0_mDSn; move: le_m_Sn; rewrite lez_eqVlt. +case=> [->>|lt_m_Sn]; first by rewrite exprD_nneg //#. +by rewrite addzA exprS 1:/# ih 1,2:/# exprS // mulrCA. +qed. + +lemma exprM (x : t) (m n : int) : + exp x (m * n) = exp (exp x m) n. +proof. +wlog : n / 0 <= n. ++ move=> h; case: (0 <= n) => hn; 1: by apply h. + by rewrite -{1}(@oppzK n) (_: m * - -n = -(m * -n)) 1:/# + exprN h 1:/# exprN invrK. +wlog : m / 0 <= m. ++ move=> h; case: (0 <= m) => hm hn; 1: by apply h. + rewrite -{1}(@oppzK m) (_: (- -m) * n = - (-m) * n) 1:/#. + by rewrite exprN h 1:/# // exprN exprV exprN invrK. +elim/natind: n => [|n hn ih hm _]; 1: smt (expr0). +by rewrite mulzDr exprS //= mulrC exprD_nneg 1:/# 1:// ih. +qed. + +lemma expr0n (n : int) : 0 <= n => exp zero<:t> n = if n = 0 then oner else zero. +proof. +elim: n => [|n ge0_n _]; first by rewrite expr0. +by rewrite exprS // mul0r addz1_neq0. +qed. + +lemma expr0z (z : int) : exp zero<:t> z = if z = 0 then oner else zero. +proof. +case: (0 <= z) => [/expr0n // | /ltzNge lt0_z]. +rewrite -{1}(@oppzK z) exprN; have ->/=: z <> 0 by smt(). +rewrite invr_eq0 expr0n ?oppz_ge0 1:ltzW //. +by have ->/=: -z <> 0 by smt(). +qed. + +lemma expr1z (z : int) : exp oner<:t> z = oner. +proof. +elim/intwlog: z. ++ by move=> n h; rewrite -(@oppzK n) exprN h invr1. ++ by rewrite expr0. ++ by move=> n ge0_n ih; rewrite exprS // mul1r ih. +qed. + +(* -------------------------------------------------------------------- *) +(* Squaring identities. *) +lemma sqrrD (x y : t) : + exp (x + y) 2 = exp x 2 + intmul (x * y) 2 + exp y 2. +proof. +by rewrite !expr2 mulrDl !mulrDr mulr2z !addrA (@mulrC y x). +qed. + +lemma sqrrN (x : t) : exp (-x) 2 = exp x 2. +proof. by rewrite !expr2 mulrNN. qed. + +lemma sqrrB (x y : t) : + exp (x - y) 2 = exp x 2 - intmul (x * y) 2 + exp y 2. +proof. by rewrite sqrrD sqrrN mulrN mulNrz. qed. + +lemma signr_odd (n : int) : 0 <= n => + exp (-oner<:t>) (b2i (odd n)) = exp (-oner) n. +proof. +elim: n => [|n ge0_nih]; first by rewrite odd0 expr0 expr0. +rewrite !(iterS, oddS) // exprS // -/(odd _) => <-. +by case: (odd _); rewrite /b2i /= !(expr0, expr1) mulN1r ?opprK. +qed. + +lemma subr_sqr_1 (x : t) : exp x 2 - oner = (x - oner) * (x + oner). +proof. +rewrite mulrBl mulrDr !(mulr1, mul1r) expr2 -addrA. +by congr; rewrite opprD addrA addrN add0r. +qed. + +(* -------------------------------------------------------------------- *) +(* Left regularity: [lreg x] iff multiplication by [x] on the left is + injective. *) +op lreg ['a <: comring] (x : 'a) = injective (fun y => x * y). + +lemma mulrI_eq0 (x y : t) : lreg x => (x * y = zero) <=> (y = zero). +proof. by move=> reg_x; rewrite -{1}(mulr0 x) (inj_eq reg_x). qed. + +lemma lreg_neq0 (x : t) : lreg x => x <> zero. +proof. +apply/contraL=> ->; apply/negP => /(_ zero oner). +by rewrite (@eq_sym _ oner) oner_neq0 /= !mul0r. +qed. + +lemma mulrI0_lreg (x : t) : + (forall y, x * y = zero => y = zero) => lreg x. +proof. +by move=> reg_x y z eq; rewrite -subr_eq0 &(reg_x) mulrBr eq subrr. +qed. + +lemma lregN (x : t) : lreg x => lreg (-x). +proof. by move=> reg_x y z; rewrite !mulNr => /oppr_inj /reg_x. qed. + +lemma lreg1 : lreg oner<:t>. +proof. by move=> x y; rewrite !mul1r. qed. + +lemma lregM (x y : t) : lreg x => lreg y => lreg (x * y). +proof. by move=> reg_x reg_y z t; rewrite -!mulrA => /reg_x /reg_y. qed. + +lemma lregXn (x : t) (n : int) : 0 <= n => lreg x => lreg (exp x n). +proof. +move=> + reg_x; elim: n => [|n ge0_n ih]. +- by rewrite expr0 &(lreg1). +- by rewrite exprS // &(lregM). +qed. + +(* -------------------------------------------------------------------- *) +lemma fracrDE (n1 n2 d1 d2 : t) : + unit d1 => unit d2 => + n1 / d1 + n2 / d2 = (n1 * d2 + n2 * d1) / (d1 * d2). +proof. +move=> inv_d1 inv_d2; rewrite mulrDl [n1 * d2]mulrC. +by rewrite !invrM //; congr; rewrite mulrACA divrr // ?(mul1r, mulr1). +qed. + +(* -------------------------------------------------------------------- *) +(* If [x] has order dividing [k] (i.e. [x ^ k = 1]), then [x ^ n] only + depends on [n %% k]. The [unit x] precondition makes the lemma work + for negative [n] (via [exprN], which is well-behaved on units in + any commutative ring). At [field] level [unit x ↔ x ≠ 0] so the + precondition is automatic when [x ≠ 0]. *) +lemma exp_mod_unit (x : t) (n k : int) : + unit x => exp x k = oner => exp x n = exp x (n %% k). +proof. +move=> ux; case: (k = 0) => [->>|nz_k]; first by rewrite modz0. +move=> eq_xk. +have h: n = k * (n %/ k) + n %% k by smt(divz_eq). +rewrite {1}h exprD // exprM eq_xk expr1z mul1r //. +qed. + +end section. +(* ==================================================================== *) +(* Boolean ring: commutative ring with idempotent multiplication. *) +(* ==================================================================== *) +type class boolring <: comring = { + axiom mulrr : forall (x : boolring), x * x = x +}. + +(* -------------------------------------------------------------------- *) +section. +declare type t <: boolring. + +lemma addrr (x : t): x + x = zero. +proof. +apply (@addrI (x + x)); rewrite addr0 -{1 2 3 4}[x]mulrr. +by rewrite -mulrDr -mulrDl mulrr. +qed. + +lemma oppr_id (x : t) : -x = x. +proof. by rewrite -[x]opprK -addr_eq0 opprK addrr. qed. + +end section. + +(* ==================================================================== *) +(* Integral domain: commutative ring with no zero divisors. *) +(* ==================================================================== *) +type class idomain <: comring = { + axiom mulf_eq0 : + forall (x y : idomain), x * y = zero<:idomain> <=> x = zero \/ y = zero +}. + +(* -------------------------------------------------------------------- *) +section. +declare type t <: idomain. + +lemma mulf_neq0 (x y : t) : x <> zero => y <> zero => x * y <> zero. +proof. by move=> nz_x nz_y; apply/negP; rewrite mulf_eq0 /#. qed. + +lemma expf_eq0 (x : t) (n : int) : + (exp x n = zero) <=> (n <> 0 /\ x = zero). +proof. +elim/intwlog: n => [n| |n ge0_n ih]. ++ by rewrite exprN invr_eq0 /#. ++ by rewrite expr0 oner_neq0. +by rewrite exprS // mulf_eq0 ih addz1_neq0 ?andKb. +qed. + +lemma mulfI (x : t) : x <> zero => injective (( * ) x). +proof. +move=> ne0_x y y'; rewrite -(opprK (x * y')) -mulrN -addr_eq0. +by rewrite -mulrDr mulf_eq0 ne0_x /= addr_eq0 opprK. +qed. + +lemma mulIf (x : t) : x <> zero => injective (fun y => y * x). +proof. by move=> nz_x y z; rewrite -!(@mulrC x); exact: mulfI. qed. + +lemma sqrf_eq1 (x : t) : (exp x 2 = oner) <=> (x = oner \/ x = -oner). +proof. by rewrite -subr_eq0 subr_sqr_1 mulf_eq0 subr_eq0 addr_eq0. qed. + +lemma lregP (x : t) : lreg x <=> x <> zero. +proof. by split=> [/lreg_neq0//|/mulfI]. qed. + +lemma eqr_div (x1 y1 x2 y2 : t) : unit y1 => unit y2 => + (x1 / y1 = x2 / y2) <=> (x1 * y2 = x2 * y1). +proof. +move=> Nut1 Nut2; rewrite -{1}(@mulrK y2 _ x1) //. +rewrite -{1}(@mulrK y1 _ x2) // -!mulrA (@mulrC (invr y1)) !mulrA. +split=> [|->] //; + (have nz_Vy1: unit (invr y1) by rewrite unitrV); + (have nz_Vy2: unit (invr y2) by rewrite unitrV). +by move/(mulIr _ nz_Vy1)/(mulIr _ nz_Vy2). +qed. + +end section. + +(* ==================================================================== *) +(* Field: integral domain where every non-zero element is a unit. + The original [Ring.ec] field redefines [unit] via clone-substitution + (`pred unit x <= x <> zeror`); here we keep [unit] as the inherited + predicate and add the equivalence as an axiom of [field]. *) +(* ==================================================================== *) +type class field <: idomain = { + axiom unitfP : forall (x : field), unit x <=> x <> zero<:field> +}. + +(* -------------------------------------------------------------------- *) +section. +declare type t <: field. + +lemma mulfV (x : t) : x <> zero => x * (invr x) = oner. +proof. by move=> nz_x; apply/mulrV/unitfP. qed. + +lemma mulVf (x : t) : x <> zero => (invr x) * x = oner. +proof. by move=> nz_x; apply/mulVr/unitfP. qed. + +lemma divff (x : t) : x <> zero => x / x = oner. +proof. by move=> nz_x; apply/divrr/unitfP. qed. + +lemma invfM (x y : t) : invr (x * y) = invr x * invr y. +proof. +case: (x = zero) => [->|nz_x]; first by rewrite !(mul0r, invr0). +case: (y = zero) => [->|nz_y]; first by rewrite !(mulr0, invr0). +by rewrite invrM ?unitfP // mulrC. +qed. + +lemma invf_div (x y : t) : invr (x / y) = y / x. +proof. by rewrite invfM invrK mulrC. qed. + +lemma eqf_div (x1 y1 x2 y2 : t) : y1 <> zero => y2 <> zero => + (x1 / y1 = x2 / y2) <=> (x1 * y2 = x2 * y1). +proof. by move=> nz_y1 nz_y2; apply: eqr_div; apply/unitfP. qed. + +lemma expfM (x y : t) (n : int) : exp (x * y) n = exp x n * exp y n. +proof. +elim/intwlog: n => [n h | | n ge0_n ih]. ++ by rewrite -(@oppzK n) !(@exprN _ (-n)) h invfM. ++ by rewrite !expr0 mulr1. ++ by rewrite !exprS // mulrCA -!mulrA -ih mulrCA. +qed. + +end section. + +(* ==================================================================== *) +(* Additive morphisms between two [addgroup]s. *) +(* ==================================================================== *) +pred additive ['a <: addgroup, 'b <: addgroup] (f : 'a -> 'b) = + forall (x y : 'a), f (x - y) = f x - f y. + +(* -------------------------------------------------------------------- *) +section. +declare type t1 <: addgroup. +declare type t2 <: addgroup. + +declare op f : t1 -> t2. +declare axiom f_is_additive : additive f. + +lemma raddfB (x y : t1) : f (x - y) = f x - f y. +proof. by apply/f_is_additive. qed. + +lemma raddf0 : f zero<:t1> = zero<:t2>. +proof. by rewrite -(@subr0 zero<:t1>) raddfB subrr. qed. + +lemma raddfN (x : t1) : f (- x) = - (f x). +proof. by rewrite -(@sub0r x) raddfB raddf0 sub0r. qed. + +lemma raddfD (x y : t1) : f (x + y) = f x + f y. +proof. by rewrite -{1}(@opprK y) raddfB raddfN opprK. qed. +end section. + +(* ==================================================================== *) +(* Multiplicative homomorphisms between two [comring]s. *) +(* ==================================================================== *) +pred multiplicative ['a <: comring, 'b <: comring] (f : 'a -> 'b) = + f oner<:'a> = oner<:'b> + /\ forall (x y : 'a), f (x * y) = f x * f y. + +(* ==================================================================== *) +(* Convenience: [(^)] as multiplicative exponentiation on any comring. + Mirrors the [abbrev (^) = exp] declaration in the original + [theories/algebra/Ring.ec:IntID] but is published at top level so + it works for any [comring] carrier (not just [int]). *) +(* ==================================================================== *) +abbrev (^) ['a <: comring] (x : 'a) (n : int) : 'a = exp x n. diff --git a/examples/tcalgebra/TcZModP.ec b/examples/tcalgebra/TcZModP.ec new file mode 100644 index 0000000000..543db0a3fe --- /dev/null +++ b/examples/tcalgebra/TcZModP.ec @@ -0,0 +1,389 @@ +(* -------------------------------------------------------------------- *) +require import AllCore List Distr Int IntDiv. +require import TcMonoid TcRing TcBigop TcBigalg TcInt. +require import StdOrder. +(*---*) import IntOrder. +require (*--*) Subtype. + +(* ==================================================================== *) +(* This abstract theory provides the construction of the ring [Z/pZ] *) +(* as a TC carrier. Mirrors [theories/algebra/ZModP.ec:ZModRing], but *) +(* the [comring]/[idomain] structure is carried by a single *) +(* [instance comring with zmod] declaration rather than via *) +(* [clone Ring.ComRing as ZModpRing] + a redundant [instance ring]. *) +(* ==================================================================== *) +abstract theory ZModRing. + +const p : { int | 2 <= p } as ge2_p. + +(* -------------------------------------------------------------------- *) +subtype zmod as Sub = { x : int | 0 <= x < p }. + +realize inhabited. +proof. by exists 0; smt(ge2_p). qed. + +(* -------------------------------------------------------------------- *) +op inzmod (z : int) = Sub.insubd (z %% p). +op asint (z : zmod) = Sub.val z. + +lemma inzmodK (z : int): asint (inzmod z) = z %% p. +proof. +rewrite /asint /inzmod Sub.insubdK //. +rewrite modz_ge0 /= 1:&(gtr_eqF); first by smt(ge2_p). +by apply: ltz_pmod; smt(ge2_p). +qed. + +lemma inzmod_mod z : + inzmod z = inzmod (z %% p). +proof. by rewrite /inzmod modz_mod. qed. + +lemma asint_inj: injective asint by apply/Sub.val_inj. + +lemma ge0_asint x : 0 <= asint x. +proof. by case: (Sub.valP x). qed. + +lemma gtp_asint x : asint x < p. +proof. by case: (Sub.valP x). qed. + +lemma rg_asint x : 0 <= asint x < p. +proof. by rewrite ge0_asint gtp_asint. qed. + +lemma asintK x : inzmod (asint x) = x. +proof. by rewrite /inzmod pmod_small 1:rg_asint /insubd Sub.valK. qed. + +(* -------------------------------------------------------------------- *) +abbrev zmodcgr (z1 z2 : int) = z1 %% p = z2 %% p. + +lemma eq_inzmod (z1 z2 : int) : zmodcgr z1 z2 <=> inzmod z1 = inzmod z2. +proof. split. ++ by move=> h; apply/asint_inj; rewrite !inzmodK. ++ by move/(congr1 asint); rewrite !inzmodK. +qed. + +lemma asint_eq (z1 z2 : zmod) : (asint z1 = asint z2) <=> (z1 = z2). +proof. by split=> [/asint_inj|->//]. qed. + +(* -------------------------------------------------------------------- *) +(* The ring ops on [zmod]. Direct definitions (not via a private *) +(* [theory ZModule]); the [instance comring with zmod] below proves the *) +(* axioms with [exact:] on these named lemmas. *) +(* -------------------------------------------------------------------- *) +op zmod_opp x = inzmod (- asint x). +op zmod_add x y = inzmod (asint x + asint y). +op zmod_mul x y = inzmod (asint x * asint y). + +op zmod_unit x = exists y, zmod_mul y x = inzmod 1. +op zmod_inv x = choiceb (fun y => zmod_mul y x = inzmod 1) x. + +(* Carrier-specific abbrevs for [+] / [*] / [-]. Not strictly required + anymore — the resolver's op-preservation filter (via + [tci_chain_rename]) now disambiguates the two monoid views on + comring carriers correctly — but kept for parity with Int.ec / + Real.ec, faster elaboration (no TC inference), and explicit + printer behaviour. *) +abbrev ( + ) (x y : zmod) : zmod = zmod_add x y. +abbrev ( * ) (x y : zmod) : zmod = zmod_mul x y. +abbrev [-] (x : zmod) : zmod = zmod_opp x. + +(* -------------------------------------------------------------------- *) +lemma inzmod0E: asint (inzmod 0) = 0. +proof. by rewrite inzmodK mod0z. qed. + +lemma inzmod1E: asint (inzmod 1) = 1. +proof. by rewrite inzmodK modz_small; smt(ge2_p). qed. + +lemma zmod_oppE (x : zmod): asint (zmod_opp x) = (- (asint x)) %% p. +proof. by rewrite /zmod_opp /inzmod /asint /= Sub.insubdK; smt(ge2_p). qed. + +lemma zmod_addE (x y : zmod): + asint (zmod_add x y) = (asint x + asint y) %% p. +proof. by rewrite /zmod_add /inzmod /asint /= Sub.insubdK; smt(ge2_p). qed. + +lemma zmod_mulE (x y : zmod): + asint (zmod_mul x y) = (asint x * asint y) %% p. +proof. rewrite /zmod_mul /inzmod /asint /= Sub.insubdK; smt(ge2_p). qed. + +(* -------------------------------------------------------------------- *) +(* Ring axioms on [zmod]. Proofs go through [asint_inj] + concrete int *) +(* arithmetic; identical body to the legacy [ZModule]/[ComRing] proofs. *) +(* -------------------------------------------------------------------- *) +lemma zmod_addrA (x y z : zmod): + zmod_add x (zmod_add y z) = zmod_add (zmod_add x y) z. +proof. by apply/asint_inj; rewrite !zmod_addE modzDml modzDmr addzA. qed. + +lemma zmod_addrC (x y : zmod): zmod_add x y = zmod_add y x. +proof. by apply/asint_inj; rewrite !zmod_addE addzC. qed. + +lemma zmod_add0r (x : zmod): zmod_add (inzmod 0) x = x. +proof. +by apply/asint_inj; rewrite !(zmod_addE, inzmod0E) add0z; + smt(rg_asint pmod_small ge2_p). +qed. + +lemma zmod_addrN (x : zmod): zmod_add x (zmod_opp x) = inzmod 0. +proof. +apply/asint_inj; rewrite !(inzmod0E, zmod_addE, zmod_oppE). +by rewrite modzDmr addzN. +qed. + +lemma zmod_oner_neq0 : inzmod 1 <> inzmod 0. +proof. by rewrite -eq_inzmod #smt:(ge2_p). qed. + +lemma zmod_mulrA (x y z : zmod): + zmod_mul x (zmod_mul y z) = zmod_mul (zmod_mul x y) z. +proof. by apply/asint_inj; rewrite !zmod_mulE modzMml modzMmr mulzA. qed. + +lemma zmod_mulrC (x y : zmod): zmod_mul x y = zmod_mul y x. +proof. by apply/asint_inj; rewrite !zmod_mulE mulzC. qed. + +lemma zmod_mul1r (x : zmod): zmod_mul (inzmod 1) x = x. +proof. +by apply/asint_inj; rewrite !(zmod_mulE, inzmod1E) mul1z; smt(rg_asint). +qed. + +lemma zmod_mulrDl (x y z : zmod): + zmod_mul (zmod_add x y) z = zmod_add (zmod_mul x z) (zmod_mul y z). +proof. +apply/asint_inj; rewrite !(zmod_addE, zmod_mulE). +by rewrite !(modzMml, modzMmr, modzDml, modzDmr) mulzDl. +qed. + +lemma zmod_mulVr x : zmod_unit x => zmod_mul (zmod_inv x) x = inzmod 1. +proof. by move/choicebP=> /(_ x). qed. + +lemma zmod_unitP x y : zmod_mul y x = inzmod 1 => zmod_unit x. +proof. by move=> eq; exists y. qed. + +lemma zmod_unitout x : ! zmod_unit x => zmod_inv x = x. +proof. +move=> Nux; rewrite /zmod_inv choiceb_dfl //= => y; apply/negP. +by move=> h; apply/Nux; exists y. +qed. + +(* -------------------------------------------------------------------- *) +(* [comring] is the right level: [zmod] is commutative and has the *) +(* abstract [unit]/[inv] machinery via [choiceb], but it's not an *) +(* [idomain] for non-prime [p] (zero divisors exist). Field instance *) +(* lives in [ZModField] below. *) +(* -------------------------------------------------------------------- *) +instance comring with zmod + op zero = (inzmod 0) + op (+) = zmod_add + op [-] = zmod_opp + op oner = (inzmod 1) + op ( * ) = zmod_mul + op invr = zmod_inv + op unit = zmod_unit + + proof mopA<:addmonoid> by exact: zmod_addrA + proof mopC<:addmonoid> by exact: zmod_addrC + proof mop0<:addmonoid> by exact: zmod_add0r + proof addrN by exact: zmod_addrN + proof oner_neq0 by exact: zmod_oner_neq0 + proof mopA<:mulmonoid> by exact: zmod_mulrA + proof mopC<:mulmonoid> by exact: zmod_mulrC + proof mop0<:mulmonoid> by exact: zmod_mul1r + proof mulrDl by exact: zmod_mulrDl + proof mulVr by exact: zmod_mulVr + proof unitP by exact: zmod_unitP + proof unitout by exact: zmod_unitout. + +(* Spacer: flush deferred-proof state before downstream uses. *) +op _spacer1 : zmod = inzmod 0. + +(* ==================================================================== *) +(* inzmod/asint corollaries — these are the user-facing identities *) +(* tying the carrier coercions to the abstract class ops. *) +(* ==================================================================== *) +lemma inzmodD (a b : int): + inzmod (a + b) = zmod_add (inzmod a) (inzmod b). +proof. by apply/asint_inj; rewrite zmod_addE !inzmodK modzDmr modzDml. qed. + +lemma inzmodM (a b : int): + inzmod (a * b) = zmod_mul (inzmod a) (inzmod b). +proof. by apply/asint_inj; rewrite zmod_mulE !inzmodK modzMmr modzMml. qed. + +lemma inzmodN (n : int): + inzmod (- n) = zmod_opp (inzmod n). +proof. by apply/asint_inj; rewrite zmod_oppE !inzmodK modzNm. qed. + +lemma inzmodB (a b : int): + inzmod (a - b) = zmod_add (inzmod a) (zmod_opp (inzmod b)). +proof. by rewrite inzmodD inzmodN. qed. + +lemma inzmodD_mod (a b : int): + inzmod ((a + b) %% p) = zmod_add (inzmod a) (inzmod b). +proof. by rewrite -inzmod_mod inzmodD. qed. + +lemma inzmodM_mod (a b : int): + inzmod ((a * b) %% p) = zmod_mul (inzmod a) (inzmod b). +proof. by rewrite -inzmod_mod inzmodM. qed. + +lemma inzmodN_mod (n : int): + inzmod ((- n) %% p) = zmod_opp (inzmod n). +proof. by rewrite -inzmod_mod inzmodN. qed. + +lemma inzmodB_mod (a b : int): + inzmod ((a - b) %% p) = zmod_add (inzmod a) (zmod_opp (inzmod b)). +proof. by rewrite -inzmod_mod inzmodB. qed. + +(* -------------------------------------------------------------------- *) +lemma zmodcgrP (i j : int) : zmodcgr i j <=> p %| (i - j). +proof. by rewrite dvdzE -[0](mod0z p) !eq_inzmod inzmodB subr_eq0. qed. + +lemma inzmod_eq0P (i : int) : inzmod i = inzmod 0 <=> p %| i. +proof. by rewrite -[inzmod 0]asintK inzmod0E -eq_inzmod zmodcgrP. qed. + +(* -------------------------------------------------------------------- *) +lemma inzmodW (P : zmod -> bool) : + (forall i, 0 <= i < p => P (inzmod i)) => forall n, P n. +proof. by move=> ih n; rewrite -(asintK n) &(ih) rg_asint. qed. + +(* ==================================================================== *) +(* Distribution / finiteness layer (verbatim from legacy ZModP). *) +(* ==================================================================== *) +theory DZmodP. +clone include MFinite with + type t <- zmod, + op Support.enum = map inzmod (range 0 p) + + proof *. + +realize Support.enum_spec. +proof. +elim/inzmodW=> i rgi; rewrite count_uniq_mem; last first. +- by apply/b2i_eq1; apply/mapP; exists i=> /=; rewrite mem_range. +rewrite &(map_inj_in_uniq) -1:range_uniq // => m n. +rewrite !mem_range => rgm rgn /(congr1 asint). +by rewrite !inzmodK !pmod_small. +qed. + +require import DInterval. + +lemma cardE : Support.card = p. +proof. by rewrite /Support.card size_map size_range; smt(ge2_p). qed. + +lemma dzmodE : dunifin = dmap [0..p-1] inzmod. +proof. +apply/eq_distr; elim/inzmodW => i rgi. +rewrite dunifin1E cardE dmapE /pred1 /(\o) /=. +rewrite -(mu_eq_support _ (pred1 i)) => /= [j /supp_dinter|]. +- rewrite ler_subr_addl (addzC 1) -ltzE /pred1 => rgj. + by rewrite -eq_inzmod !pmod_small. +- by rewrite dinter1E ler_subr_addl (addzC 1) -ltzE rgi. +qed. +end DZmodP. + +end ZModRing. + +(* ==================================================================== *) +(* Field structure when [p] is prime. Inherits ZModRing's subtype, ops,*) +(* and comring instance via [clone include]; adds [unitE] and the *) +(* [field] instance. *) +(* ==================================================================== *) +abstract theory ZModField. + +const p : { int | prime p } as prime_p. + +clone include ZModRing with + op p <- p + proof ge2_p by smt(gt1_prime prime_p). + +lemma unitE (x : zmod) : zmod_unit x <=> x <> inzmod 0. +proof. +split; first by apply: contraL => ->; smt(zmod_mulrC zmod_mul1r choicebP). +move=> nz_x; exists (inzmod (invm (asint x) p)). +apply: asint_inj; rewrite inzmod1E zmod_mulE inzmodK. +rewrite (@modzE (invm _ _)) -mulNr mulrDl mulrAC modzMDr mulrC. +apply/mulmV; first by apply/prime_p. +by move: nz_x; rewrite -asint_eq inzmod0E pmod_small // rg_asint. +qed. + +lemma zmod_mulrV (x : zmod) : + x <> inzmod 0 => zmod_mul x (zmod_inv x) = inzmod 1. +proof. +move=> nz_x; rewrite zmod_mulrC; apply: zmod_mulVr; rewrite unitE //. +qed. + +lemma zmod_mulf_eq0 (x y : zmod) : + zmod_mul x y = inzmod 0 <=> x = inzmod 0 \/ y = inzmod 0. +proof. +split; last first. +- by case=> ->; apply/asint_inj; + rewrite zmod_mulE inzmod0E; smt(inzmod0E rg_asint). +move/(congr1 asint); rewrite zmod_mulE inzmod0E => /dvdzE dvd. +have [dvd'|dvd'] : p %| asint x \/ p %| asint y by smt(prime_p). +- by left; apply/asint_inj; rewrite inzmod0E; smt(rg_asint dvdzE). +- by right; apply/asint_inj; rewrite inzmod0E; smt(rg_asint dvdzE). +qed. + +(* Comring (and ancestors) inherited from ZModRing's instance via the + clone include. Two refinements stack on top: idomain adds mulf_eq0, + then field adds unitfP. *) +instance idomain with zmod + proof mulf_eq0 by exact: zmod_mulf_eq0. + +instance field with zmod + proof unitfP by exact: unitE. + +(* Spacer. *) +op _spacer2 : zmod = inzmod 0. + +(* ==================================================================== *) +(* Field-specific exp/Fermat corollaries. Mirrors the tail of legacy *) +(* ZModField (lines 372–467 of theories/algebra/ZModP.ec). *) +(* *) +(* The class-op [exp] is comring's; for nonzero (i.e. [unit]) [x : zmod], + it behaves like [int]'s [exp] modulo [p]. *) +(* ==================================================================== *) + +(* [exp_mod] specialised to [zmod]: when [x] has order dividing [k], the + exponent only matters mod [k]. The [unit x] precondition from the + general comring lemma is automatic over a field except at [x = 0], + handled separately below. *) +lemma exp_mod (x : zmod) (n k : int) : + x <> inzmod 0 => exp x k = inzmod 1 => + exp x n = exp x (n %% k). +proof. +by move=> nz_x; apply: exp_mod_unit; apply/unitE. +qed. + +(* Fermat's little theorem: every unit raised to [p - 1] is one. *) +lemma exp_sub_p_1 (x : zmod) : + unit x => exp x (p - 1) = inzmod 1. +proof. +move=> ux. +have nz_x: x <> inzmod 0 by apply/unitE. +have N_p_div_x: !(p %| asint x). ++ rewrite -inzmod_eq0P; move: nz_x. + by rewrite -{1}(@asintK x). +have ge0_p1: 0 <= p - 1 by smt(prime_p gt1_prime). +have lift_exp : forall i, 0 <= i => + exp (inzmod (asint x)) i = inzmod (exp<:int> (asint x) i). ++ elim=> [|i ge0_i ih]; first by rewrite !expr0. + by rewrite !exprS // ih inzmodM asintK. +rewrite -{1}(@asintK x) lift_exp //. +rewrite -[inzmod 1]asintK inzmod1E -eq_inzmod. +by rewrite zmodcgrP &(Fermat_little) // prime_p. +qed. + +(* Fermat consequence: [x ^ p = x] for any [x : zmod] (including 0). *) +lemma exp_p (x : zmod) : exp x p = x. +proof. +case: (unit x) => [ux|]. ++ by rewrite -(subrK p 1) exprD // expr1 exp_sub_p_1 // mul1r. +rewrite unitE /= => ->; rewrite expr0z. +by move: prime_p; rewrite /prime; case (p = 0) => // ->. +qed. + +(* Inverse via Fermat: [invr x = x ^ (p - 2)] when [x] is a unit. *) +lemma inv_exp_sub_p_2 (x : zmod) : + unit x => invr x = exp x (p - 2). +proof. +move=> ux; rewrite -div1r; move: (eqf_div oner x (exp x (p - 2)) oner). +rewrite -unitE ux oner_neq0 -div1r !mul1r divr1 /= -exprSr /=. ++ by smt(prime_p gt1_prime). +by rewrite exp_sub_p_1. +qed. + +end ZModField. diff --git a/examples/tcalgebra/TcZModPSmokeTest.ec b/examples/tcalgebra/TcZModPSmokeTest.ec new file mode 100644 index 0000000000..294680a223 --- /dev/null +++ b/examples/tcalgebra/TcZModPSmokeTest.ec @@ -0,0 +1,69 @@ +(* ==================================================================== *) +(* Smoke test for TcZModP: instantiate ZModRing at p := 5 and exercise *) +(* class lemmas at the carrier zmod (= Z/5Z). *) +(* ==================================================================== *) +require import AllCore List Int IntDiv. +require import TcMonoid TcRing TcBigop TcBigalg TcInt. +require import TcZModP. + +(* -------------------------------------------------------------------- *) +(* ZModRing at p := 5 (not prime instantiation; ZModField needs prime). *) +clone import ZModRing as Z5 with + op p <- 5 + proof ge2_p by trivial. + +(* Coercion sanity. *) +lemma test_asint_inzmod (n : int) : + 0 <= n < 5 => asint (inzmod n) = n. +proof. by move=> rg; rewrite inzmodK pmod_small. qed. + +(* Concrete arithmetic. *) +lemma test_one_plus_one : zmod_add (Z5.inzmod 1) (Z5.inzmod 1) = inzmod 2. +proof. by rewrite -inzmodD //. qed. + +(* Class lemma at the carrier zmod. *) +lemma test_addrC (x y : zmod) : zmod_add x y = zmod_add y x. +proof. by apply zmod_addrC. qed. + +(* Bare class-op notation. Resolves to the class [(+)] (via the + resolver's op-preservation filter on chain-rename) when there is + no carrier-specific abbrev, or to the abbrev when present. Apply + class-level [addrC] in either case. *) +lemma test_addrC_infix (x y : zmod) : x + y = y + x. +proof. by apply addrC. qed. + +lemma test_mulrC_infix (x y : zmod) : x * y = y * x. +proof. by apply mulrC. qed. + +(* The bigA family applies through the [comring] instance — exercise *) +(* via [BigZModRing] or similar. We just call addrA as a sanity check. *) +lemma test_addrA (x y z : zmod) : + zmod_add x (zmod_add y z) = zmod_add (zmod_add x y) z. +proof. by apply zmod_addrA. qed. + +lemma test_mulrC (x y : zmod) : zmod_mul x y = zmod_mul y x. +proof. by apply zmod_mulrC. qed. + +(* -------------------------------------------------------------------- *) +(* ZModField at p := 5 (prime). Exercises the field instance. *) +clone import ZModField as Z5F with + op p <- 5 + proof prime_p by admit. + +(* unit ↔ nonzero (field-only). *) +lemma test_unitE (x : Z5F.zmod) : + Z5F.zmod_unit x <=> x <> (Z5F.inzmod 0). +proof. by apply Z5F.unitE. qed. + +(* Fermat: x^4 = 1 for every unit in Z/5Z. *) +lemma test_exp_p_minus_1 (x : Z5F.zmod) : + x <> (Z5F.inzmod 0) => exp x 4 = (Z5F.inzmod 1). +proof. +move=> nz_x. +have ->: (4 = 5 - 1) by trivial. +by apply: Z5F.exp_sub_p_1; apply/Z5F.unitE. +qed. + +(* Frobenius: x^5 = x. *) +lemma test_exp_p (x : Z5F.zmod) : exp x 5 = x. +proof. by apply Z5F.exp_p. qed. diff --git a/examples/tcalgebra/sandbox.ec b/examples/tcalgebra/sandbox.ec new file mode 100644 index 0000000000..054768006f --- /dev/null +++ b/examples/tcalgebra/sandbox.ec @@ -0,0 +1,35 @@ +require import AllCore TcMonoid TcRing. + +(* Tvar carrier with multi-parent + factory *) +type class my_comring <: addgroup & (mulmonoid with idm = oner, (+) = mymul) = { + op oner : my_comring + op mymul : my_comring -> my_comring -> my_comring +}. + +section. +declare type t <: my_comring. + +(* Multiplicative side: factory inheritance, abbrev-mediated. *) +lemma test_mulrA : associative ( * )<:t>. +proof. apply addmA. qed. + +lemma test_mulrC : commutative ( * )<:t>. +proof. apply addmC. qed. + +lemma test_mul1r : left_id one<:t> ( * )<:t>. +proof. apply add0m. qed. + +(* Additive side on a multi-parent carrier: [(+)<:t>] is reachable + via two paths to [monoid] (addgroup and mulmonoid-with-renaming), + but only the addgroup path leaves [(+)] unrenamed. Op-name-aware + path resolution should pick that path uniquely. *) +lemma test_addrA : associative (+)<:t>. +proof. apply addmA. qed. + +lemma test_addrC : commutative (+)<:t>. +proof. apply addmC. qed. + +lemma test_add0r : left_id zero<:t> (+)<:t>. +proof. apply add0m. qed. + +end section. diff --git a/examples/tcstdlib/TcBigop.ec b/examples/tcstdlib/TcBigop.ec new file mode 100644 index 0000000000..61c157b49c --- /dev/null +++ b/examples/tcstdlib/TcBigop.ec @@ -0,0 +1,590 @@ +(* This API has been mostly inspired from the [bigop] library of the + * ssreflect Coq extension. *) + +pragma +implicits. + +(* -------------------------------------------------------------------- *) +require import AllCore List Ring TcMonoid. + +import Ring.IntID. + +(* -------------------------------------------------------------------- *) +section. +declare type t <: monoid. + +(* -------------------------------------------------------------------- *) +op big (P : 'a -> bool) (F : 'a -> t) (r : 'a list) = + foldr (+) idm (map F (filter P r)). + +(* -------------------------------------------------------------------- *) +abbrev bigi (P : int -> bool) (F : int -> t) i j = + big P F (range i j). + +(* -------------------------------------------------------------------- *) +lemma big_nil (P : 'a -> bool) (F : 'a -> t): big P F [] = idm. +proof. by []. qed. + +(* -------------------------------------------------------------------- *) +lemma big_cons (P : 'a -> bool) (F : 'a -> t) x s: + big P F (x :: s) = if P x then F x + big P F s else big P F s. +proof. by rewrite {1}/big /= (@fun_if (map F)); case (P x). qed. + +lemma big_consT (F : 'a -> t) x s: + big predT F (x :: s) = F x + big predT F s. +proof. by apply/big_cons. qed. + +(* -------------------------------------------------------------------- *) +lemma big_rec (K : t -> bool) r P (F : 'a -> t): + K idm => (forall i x, P i => K x => K (F i + x)) => K (big P F r). +proof. + move=> K0 Kop; elim: r => //= i r; rewrite big_cons. + by case (P i) => //=; apply/Kop. +qed. + +lemma big_ind (K : t -> bool) r P (F : 'a -> t): + (forall x y, K x => K y => K (x + y)) + => K idm => (forall i, P i => K (F i)) + => K (big P F r). +proof. + move=> Kop Kidx K_F; apply/big_rec => //. + by move=> i x Pi Kx; apply/Kop => //; apply/K_F. +qed. + +lemma big_rec2: + forall (K : t -> t -> bool) r P (F1 F2 : 'a -> t), + K idm idm + => (forall i y1 y2, P i => K y1 y2 => K (F1 i + y1) (F2 i + y2)) + => K (big P F1 r) (big P F2 r). +proof. + move=> K r P F1 F2 KI KF; elim: r => //= i r IHr. + by rewrite !big_cons; case (P i) => ? //=; apply/KF. +qed. + +lemma big_ind2: + forall (K : t -> t -> bool) r P (F1 F2 : 'a -> t), + (forall x1 x2 y1 y2, K x1 x2 => K y1 y2 => K (x1 + y1) (x2 + y2)) + => K idm idm + => (forall i, P i => K (F1 i) (F2 i)) + => K (big P F1 r) (big P F2 r). +proof. + move=> K r P F1 F2 Kop KI KF; apply/big_rec2 => //. + by move=> i x1 x2 Pi Kx1x2; apply/Kop => //; apply/KF. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_endo (f : t -> t): + f idm = idm + => (forall (x y : t), f (x + y) = f x + f y) + => forall r P (F : 'a -> t), + f (big P F r) = big P (f \o F) r. +proof. + (* FIXME: should be a consequence of big_morph *) + move=> fI fM; elim=> //= i r IHr P F; rewrite !big_cons. + by case (P i) => //=; rewrite 1?fM IHr. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_map ['a 'b] (h : 'b -> 'a) (P : 'a -> bool) F s: + big P F (map h s) = big (P \o h) (F \o h) s. +proof. by elim: s => // x s; rewrite map_cons !big_cons=> ->. qed. + +lemma big_mapT ['a 'b] (h : 'b -> 'a) F s: (* -> big_map_predT *) + big predT F (map h s) = big predT (F \o h) s. +proof. by rewrite big_map. qed. + +(* -------------------------------------------------------------------- *) +lemma big_comp ['a] (h : t -> t) (P : 'a -> bool) F s: + h idm = idm => morphism_2 h (+) (+) => + h (big P F s) = big P (h \o F) s. +proof. + move=> Hidm Hh;elim: s => // x s; rewrite !big_cons => <-. + by rewrite /(\o) -Hh;case (P x) => //. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_nth x0 (P : 'a -> bool) (F : 'a -> t) s: + big P F s = bigi (P \o (nth x0 s)) (F \o (nth x0 s)) 0 (size s). +proof. by rewrite -{1}(@mkseq_nth x0 s) /mkseq big_map. qed. + +(* -------------------------------------------------------------------- *) +lemma big_const (P : 'a -> bool) x s: + big P (fun i => x) s = iter (count P s) ((+) x) idm. +proof. + elim: s=> [|y s ih]; [by rewrite iter0 | rewrite big_cons /=]. + by rewrite ih; case (P y) => //; rewrite addzC iterS // count_ge0. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_seq1 (F : 'a -> t) x: big predT F [x] = F x. +proof. by rewrite big_cons big_nil addm0. qed. + +(* -------------------------------------------------------------------- *) +lemma big_mkcond (P : 'a -> bool) (F : 'a -> t) s: + big P F s = big predT (fun i => if P i then F i else idm) s. +proof. + elim: s=> // x s ih; rewrite !big_cons -ih /predT /=. + by case (P x)=> //; rewrite add0m. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_filter (P : 'a -> bool) F s: + big predT F (filter P s) = big P F s. +proof. by elim: s => //= x s; case (P x)=> //; rewrite !big_cons=> -> ->. qed. + +(* -------------------------------------------------------------------- *) +lemma big_filter_cond (P1 P2 : 'a -> bool) F s: + big P2 F (filter P1 s) = big (predI P1 P2) F s. +proof. by rewrite -big_filter -(@big_filter _ _ s) predIC filter_predI. qed. + +(* -------------------------------------------------------------------- *) +lemma eq_bigl (P1 P2 : 'a -> bool) (F : 'a -> t) s: + (forall i, P1 i <=> P2 i) + => big P1 F s = big P2 F s. +proof. by move=> h; rewrite /big (eq_filter h). qed. + +(* -------------------------------------------------------------------- *) +lemma eq_bigr (P : 'a -> bool) (F1 F2 : 'a -> t) s: + (forall i, P i => F1 i = F2 i) + => big P F1 s = big P F2 s. +proof. (* FIXME: big_rec2 *) + move=> eqF; elim: s=> // x s; rewrite !big_cons=> <-. + by case (P x)=> // /eqF <-. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_distrl ['a] (op_ : t -> t -> t) (P : 'a -> bool) F s u: + left_zero idm op_ + => left_distributive op_ (+) + => op_ (big P F s) u = big P (fun a => op_ (F a) u) s. +proof. + move=> mulm1 mulmDl; pose G := fun x => op_ x u. + move: (big_comp G P) => @/G /= -> //. + by rewrite mulm1. by move=> t1 t2; rewrite mulmDl. +qed. + +lemma big_distrr ['a] (op_ : t -> t -> t) (P : 'a -> bool) F s u: + right_zero idm op_ + => right_distributive op_ (+) + => op_ u (big P F s) = big P (fun a => op_ u (F a)) s. +proof. + move=> mul1m mulmDr; pose G := fun x => op_ u x. + move: (big_comp G P) => @/G /= -> //. + by rewrite mul1m. by move=> t1 t2; rewrite mulmDr. +qed. + +lemma big_distr ['a 'b] (op_ : t -> t -> t) + (P1 : 'a -> bool) (P2 : 'b -> bool) F1 s1 F2 s2 : + commutative op_ + => left_zero idm op_ + => left_distributive op_ (+) + => op_ (big P1 F1 s1) (big P2 F2 s2) = + big P1 (fun a1 => big P2 (fun a2 => op_ (F1 a1) (F2 a2)) s2) s1. +proof. + move=> mulmC mulm1 mulmDl; rewrite big_distrl //. + apply/eq_bigr=> i _ /=; rewrite big_distrr //. + by move=> x; rewrite mulmC mulm1. + by move=> x y z; rewrite !(mulmC x) mulmDl. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_andbC (P Q : 'a -> bool) (F : 'a -> t) s: + big (fun x => P x /\ Q x) F s = big (fun x => Q x /\ P x) F s. +proof. by apply/eq_bigl=> i. qed. + +(* -------------------------------------------------------------------- *) +lemma eq_big (P1 P2 : 'a -> bool) (F1 F2 : 'a -> t) s: + (forall i, P1 i <=> P2 i) + => (forall i, P1 i => F1 i = F2 i) + => big P1 F1 s = big P2 F2 s. +proof. by move=> /eq_bigl <- /eq_bigr <-. qed. + +(* -------------------------------------------------------------------- *) +lemma congr_big r1 r2 P1 P2 (F1 F2 : 'a -> t): + r1 = r2 + => (forall x, P1 x <=> P2 x) + => (forall i, P1 i => F1 i = F2 i) + => big P1 F1 r1 = big P2 F2 r2. +proof. by move=> <-; apply/eq_big. qed. + +(* -------------------------------------------------------------------- *) +lemma big_hasC (P : 'a -> bool) (F : 'a -> t) s: !has P s => + big P F s = idm. +proof. + rewrite -big_filter has_count -size_filter. + by rewrite ltz_def size_ge0 /= => /size_eq0 ->. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_pred0_eq (F : 'a -> t) s: big pred0 F s = idm. +proof. by rewrite big_hasC // has_pred0. qed. + +(* -------------------------------------------------------------------- *) +lemma big_pred0 (P : 'a -> bool) (F : 'a -> t) s: + (forall i, P i <=> false) => big P F s = idm. +proof. by move=> h; rewrite -(@big_pred0_eq F s); apply/eq_bigl. qed. + +(* -------------------------------------------------------------------- *) +lemma big_cat (P : 'a -> bool) (F : 'a -> t) s1 s2: + big P F (s1 ++ s2) = big P F s1 + big P F s2. +proof. + rewrite !(@big_mkcond P); elim: s1 => /= [|i s1 ih]. + by rewrite (@big_nil P F) add0m. + by rewrite !big_cons /(predT i) /= ih addmA. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_catl (P : 'a -> bool) (F : 'a -> t) s1 s2: !has P s2 => + big P F (s1 ++ s2) = big P F s1. +proof. by rewrite big_cat => /big_hasC ->; rewrite addm0. qed. + +(* -------------------------------------------------------------------- *) +lemma big_catr (P : 'a -> bool) (F : 'a -> t) s1 s2: !has P s1 => + big P F (s1 ++ s2) = big P F s2. +proof. by rewrite big_cat => /big_hasC ->; rewrite add0m. qed. + +(* -------------------------------------------------------------------- *) +lemma big_rcons (P : 'a -> bool) (F : 'a -> t) s x: + big P F (rcons s x) = if P x then big P F s + F x else big P F s. +proof. + by rewrite -cats1 big_cat big_cons big_nil; case: (P x); rewrite !addm0. +qed. + +(* -------------------------------------------------------------------- *) +lemma eq_big_perm (P : 'a -> bool) (F : 'a -> t) s1 s2: + perm_eq s1 s2 => big P F s1 = big P F s2. +proof. + move=> /perm_eqP; rewrite !(@big_mkcond P). + elim s1 s2 => [|i s1 ih1] s2 eq_s12. + + case: s2 eq_s12=> // i s2 h. + by have := h (pred1 i)=> //=; smt(count_ge0). + have r2i: mem s2 i by rewrite -has_pred1 has_count -eq_s12 #smt:(count_ge0). + have/splitPr [s3 s4] ->> := r2i. + rewrite big_cat !big_cons /(predT i) /=. + rewrite addmCA; congr; rewrite -big_cat; apply/ih1=> a. + by have := eq_s12 a; rewrite !count_cat /= addzCA => /addzI. +qed. + +(* -------------------------------------------------------------------- *) +lemma eq_big_perm_map (F : 'a -> t) s1 s2: + perm_eq (map F s1) (map F s2) => big predT F s1 = big predT F s2. +proof. +by move=> peq; rewrite -!(@big_map F predT idfun) &(eq_big_perm). +qed. + +(* -------------------------------------------------------------------- *) +lemma big_seq_cond (P : 'a -> bool) (F : 'a -> t) s: + big P F s = big (fun i => mem s i /\ P i) F s. +proof. by rewrite -!(@big_filter _ _ s); congr; apply/eq_in_filter. qed. + +(* -------------------------------------------------------------------- *) +lemma big_seq (F : 'a -> t) s: + big predT F s = big (fun i => mem s i) F s. +proof. by rewrite big_seq_cond; apply/eq_bigl. qed. + +(* -------------------------------------------------------------------- *) +lemma big_rem (P : 'a -> bool) (F : 'a -> t) s x: mem s x => + big P F s = (if P x then F x else idm) + big P F (rem x s). +proof. + by move/perm_to_rem/eq_big_perm=> ->; rewrite !(@big_mkcond P) big_cons. +qed. + +(* -------------------------------------------------------------------- *) +lemma bigD1 (F : 'a -> t) s x: mem s x => uniq s => + big predT F s = F x + big (predC1 x) F s. +proof. by move=> /big_rem-> /rem_filter->; rewrite big_filter. qed. + +(* -------------------------------------------------------------------- *) +lemma bigD1_cond P (F : 'a -> t) s x: P x => mem s x => uniq s => + big P F s = F x + big (predI P (predC1 x)) F s. +proof. +move=> Px sx uqs; rewrite -big_filter (@bigD1 _ _ x) ?big_filter_cond //. + by rewrite mem_filter Px. by rewrite filter_uniq. +qed. + +(* -------------------------------------------------------------------- *) +lemma bigD1_cond_if P (F : 'a -> t) s x: uniq s => big P F s = + (if mem s x /\ P x then F x else idm) + big (predI P (predC1 x)) F s. +proof. +case: (mem s x /\ P x) => [[Px sx]|Nsx]; rewrite ?add0m /=. + by apply/bigD1_cond. +move=> uqs; rewrite big_seq_cond eq_sym big_seq_cond; apply/eq_bigl=> i /=. +by case: (i = x) => @/predC1 @/predI [->>|]. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_split (P : 'a -> bool) (F1 F2 : 'a -> t) s: + big P (fun i => F1 i + F2 i) s = big P F1 s + big P F2 s. +proof. + elim: s=> /= [|x s ih]; 1: by rewrite !big_nil addm0. + rewrite !big_cons ih; case: (P x) => // _. + by rewrite addmCA -!addmA addmCA. +qed. + +(* -------------------------------------------------------------------- *) +lemma bigID (P : 'a -> bool) (F : 'a -> t) (a : 'a -> bool) s: + big P F s = big (predI P a) F s + big (predI P (predC a)) F s. +proof. +rewrite !(@big_mkcond _ F) -big_split; apply/eq_bigr => i _ /=. +by rewrite /predI /predC; case: (a i); rewrite ?addm0 ?add0m. +qed. + +(* -------------------------------------------------------------------- *) +lemma bigU ['a] (P Q : 'a -> bool) (F : 'a -> t) s : (forall x, !(P x /\ Q x)) => + big (predU P Q) F s = big P F s + big Q F s. +proof. +move=> dj_PQ; rewrite (@bigID (predU _ _) _ P). +by congr; apply: eq_bigl => /#. +qed. + +(* -------------------------------------------------------------------- *) +lemma bigEM ['a] (P : 'a -> bool) (F : 'a -> t) s : + big predT F s = big P F s + big (predC P) F s. +proof. by rewrite -bigU 1:/#; apply: eq_bigl => /#. qed. + +(* -------------------------------------------------------------------- *) +lemma big_reindex ['a 'b] + (P : 'a -> bool) (F : 'a -> t) (f : 'b -> 'a) (f' : 'a -> 'b) (s : 'a list) : + (forall x, x \in s => f (f' x) = x) + => big P F s = big (P \o f) (F \o f) (map f' s). +proof. +by move => /eq_in_map id_ff'; rewrite -big_map -map_comp id_ff' id_map. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_pair_pswap ['a 'b] (p : 'a * 'b -> bool) (f : 'a * 'b -> t) s : + big<:'a * 'b> p f s + = big<:'b * 'a> (p \o pswap) (f \o pswap) (map pswap s). +proof. by apply/big_reindex; case. qed. + +(* -------------------------------------------------------------------- *) +lemma eq_big_seq (F1 F2 : 'a -> t) s: + (forall x, mem s x => F1 x = F2 x) + => big predT F1 s = big predT F2 s. +proof. by move=> eqF; rewrite !big_seq; apply/eq_bigr. qed. + +(* -------------------------------------------------------------------- *) +lemma congr_big_seq (P1 P2: 'a -> bool) (F1 F2 : 'a -> t) s: + (forall x, mem s x => P1 x = P2 x) => + (forall x, mem s x => P1 x => P2 x => F1 x = F2 x) + => big P1 F1 s = big P2 F2 s. +proof. + move=> eqP eqH; rewrite big_mkcond eq_sym big_mkcond eq_sym. + apply/eq_big_seq=> x x_in_s /=; rewrite eqP //. + by case (P2 x)=> // P2x; rewrite eqH // eqP. +qed. + +(* -------------------------------------------------------------------- *) +lemma big1_eq (P : 'a -> bool) s: big P (fun (x : 'a) => idm) s = idm. +proof. + rewrite big_const; elim/natind: (count _ _)=> n. + by move/iter0<:t> => ->. + by move/iterS<:t> => -> ->; rewrite addm0. +qed. + +(* -------------------------------------------------------------------- *) +lemma big1 (P : 'a -> bool) (F : 'a -> t) s: + (forall i, P i => F i = idm) => big P F s = idm. +proof. by move/eq_bigr=> ->; apply/big1_eq. qed. + +(* -------------------------------------------------------------------- *) +lemma big1_seq (P : 'a -> bool) (F : 'a -> t) s: + (forall i, P i /\ (mem s i) => F i = idm) => big P F s = idm. +proof. by move=> eqF1; rewrite big_seq_cond big_andbC big1. qed. + +(* -------------------------------------------------------------------- *) +lemma big_eq_idm_filter ['a] (P : 'a -> bool) (F : 'a -> t) s : + (forall (x : 'a), !P x => F x = idm) => big predT F s = big P F s. +proof. +by move=> eq1; rewrite (@bigEM P) (@big1 (predC _)) // addm0. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_flatten (P : 'a -> bool) (F : 'a -> t) rr : + big P F (flatten rr) = big predT (fun s => big P F s) rr. +proof. +elim: rr => /= [|r rr ih]; first by rewrite !big_nil. +by rewrite flatten_cons big_cat big_cons -ih. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_pair ['a 'b] (F : 'a * 'b -> t) (s : ('a * 'b) list) : uniq s => + big predT F s = + big predT (fun a => + big predT F (filter (fun xy : _ * _ => xy.`1 = a) s)) + (undup (map fst s)). +proof. +move=> /perm_eq_pair /eq_big_perm /(_ predT F) ->. +by rewrite big_flatten big_map. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_nseq_cond (P : 'a -> bool) (F : 'a -> t) n x : + big P F (nseq n x) = if P x then iter n ((+) (F x)) idm else idm. +proof. +elim/natind: n => [n le0_n|n ge0_n ih]; first by rewrite ?(nseq0_le, iter0). +by rewrite nseqS // big_cons ih; case: (P x) => //; rewrite iterS. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_nseq (F : 'a -> t) n x : + big predT F (nseq n x) = iter n ((+) (F x)) idm. +proof. by apply/big_nseq_cond. qed. + +(* -------------------------------------------------------------------- *) +lemma big_undup ['a] (P : 'a -> bool) (F : 'a -> t) s : + big P F s = big P (fun a => iter (count (pred1 a) s) ((+) (F a)) idm) (undup s). +proof. +have <- := eq_big_perm P F _ _ (perm_undup_count s). +rewrite big_flatten big_map (@big_mkcond P); apply/eq_big => //=. +by move=> @/(\o) /= x _; apply/big_nseq_cond. +qed. + +(* -------------------------------------------------------------------- *) +lemma exchange_big (P1 : 'a -> bool) (P2 : 'b -> bool) (F : 'a -> 'b -> t) s1 s2: + big P1 (fun a => big P2 (F a) s2) s1 = + big P2 (fun b => big P1 (fun a => F a b) s1) s2. +proof. + elim: s1 s2 => [|a s1 ih] s2; first by rewrite big_nil big1_eq. + rewrite big_cons ih; case: (P1 a)=> h; rewrite -?big_split; + by apply/eq_bigr=> x _ /=; rewrite big_cons h. +qed. + +(* -------------------------------------------------------------------- *) +lemma partition_big ['a 'b] (px : 'a -> 'b) P Q (F : 'a -> t) s s' : + uniq s' + => (forall x, mem s x => P x => mem s' (px x) /\ Q (px x)) + => big P F s = big Q (fun x => big (fun y => P y /\ px y = x) F s) s'. +proof. +move=> uq_s'; elim: s => /~= [|x xs ih] hm. + by rewrite big_nil big1_eq. +rewrite big_cons; case: (P x) => /= [Px|PxN]; last first. + rewrite ih //; 1: by move=> y y_xs; apply/hm; rewrite y_xs. + by apply/eq_bigr=> i _ /=; rewrite big_cons /= PxN. +have := hm x; rewrite Px /= => -[s'_px Qpx]; apply/eq_sym. +rewrite (@bigD1_cond _ _ _ (px x)) //= big_cons /= Px /=. +rewrite -addmA; congr; apply/eq_sym; rewrite ih. + by move=> y y_xs; apply/hm; rewrite y_xs. +rewrite (@bigD1_cond _ _ _ (px x)) //=; congr. +apply/eq_bigr=> /= i [Qi @/predC1]; rewrite eq_sym => ne_pxi. +by rewrite big_cons /= ne_pxi. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_allpairs (f : 'a -> 'b -> 'c) (F : 'c -> t) s u: + big predT F (allpairs<:'a, 'b, 'c> f s u) + = big predT (fun x => big predT (fun y => F (f x y)) u) s. +proof. +elim: s u => [|x s ih] u //=. +by rewrite allpairs_consl big_cat ih big_consT big_map. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_int_cond m n P (F : int -> t): + bigi P F m n = bigi (fun i => m <= i < n /\ P i) F m n. +proof. by rewrite big_seq_cond; apply/eq_bigl=> i /=; rewrite mem_range. qed. + +(* -------------------------------------------------------------------- *) +lemma big_int m n (F : int -> t): + bigi predT F m n = bigi (fun i => m <= i < n) F m n. +proof. by rewrite big_int_cond. qed. + +(* -------------------------------------------------------------------- *) +lemma congr_big_int (m1 n1 m2 n2 : int) P1 P2 (F1 F2 : int -> t): + m1 = m2 => n1 = n2 + => (forall i, m1 <= i < n2 => P1 i = P2 i) + => (forall i, P1 i /\ (m1 <= i < n2) => F1 i = F2 i) + => bigi P1 F1 m1 n1 = bigi P2 F2 m2 n2. +proof. + move=> <- <- eqP12 eqF12; rewrite big_seq_cond (@big_seq_cond P2). + by apply/eq_big=> i /=; rewrite mem_range #smt:(). +qed. + +(* -------------------------------------------------------------------- *) +lemma eq_big_int (m n : int) (F1 F2 : int -> t): + (forall i, m <= i < n => F1 i = F2 i) + => bigi predT F1 m n = bigi predT F2 m n. +proof. by move=> eqF; apply/congr_big_int. qed. + +(* -------------------------------------------------------------------- *) +lemma big_ltn_cond (m n : int) P (F : int -> t): m < n => + let x = bigi P F (m+1) n in + bigi P F m n = if P m then F m + x else x. +proof. by move/range_ltn=> ->; rewrite big_cons. qed. + +(* -------------------------------------------------------------------- *) +lemma big_ltn (m n : int) (F : int -> t): m < n => + bigi predT F m n = F m + bigi predT F (m+1) n. +proof. by move/big_ltn_cond=> /= ->. qed. + +(* -------------------------------------------------------------------- *) +lemma big_geq (m n : int) P (F : int -> t): n <= m => + bigi P F m n = idm. +proof. by move/range_geq=> ->; rewrite big_nil. qed. + +(* -------------------------------------------------------------------- *) +lemma big_addn (m n a : int) P (F : int -> t): + bigi P F (m+a) n + = bigi (fun i => P (i+a)) (fun i => F (i+a)) m (n-a). +proof. +rewrite range_addl big_map; apply/eq_big. + by move=> i /=; rewrite /(\o) addzC. +by move=> i /= _; rewrite /(\o) addzC. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_int1 n (F : int -> t): bigi predT F n (n+1) = F n. +proof. by rewrite big_ltn 1:/# big_geq // addm0. qed. + +(* -------------------------------------------------------------------- *) +lemma big_cat_int (n m p : int) P (F : int -> t): m <= n => n <= p => + bigi P F m p = (bigi P F m n) + (bigi P F n p). +proof. by move=> lemn lenp; rewrite -big_cat -range_cat. qed. + +(* -------------------------------------------------------------------- *) +lemma big_int_recl (n m : int) (F : int -> t): m <= n => + bigi predT F m (n+1) = F m + bigi predT (fun i => F (i+1)) m n. +proof. by move=> lemn; rewrite big_ltn 1?big_addn /= 1:/#. qed. + +(* -------------------------------------------------------------------- *) +lemma big_int_recr (n m : int) (F : int -> t): m <= n => + bigi predT F m (n+1) = bigi predT F m n + F n. +proof. by move=> lemn; rewrite (@big_cat_int n) ?big_int1 //#. qed. + +(* -------------------------------------------------------------------- *) +lemma big_int_recl_cond (n m : int) P (F : int -> t): m <= n => + bigi P F m (n+1) = + (if P m then F m else idm) + + bigi (fun i => P (i+1)) (fun i => F (i+1)) m n. +proof. +by move=> lemn; rewrite big_mkcond big_int_recl //= -big_mkcond. +qed. + +(* -------------------------------------------------------------------- *) +lemma big_int_recr_cond (n m : int) P (F : int -> t): m <= n => + bigi P F m (n+1) = + bigi P F m n + (if P n then F n else idm). +proof. by move=> lemn; rewrite !(@big_mkcond P) big_int_recr. qed. + +(* -------------------------------------------------------------------- *) +lemma bigi_split_odd_even (n : int) (F : int -> t) : 0 <= n => + bigi predT (fun i => F (2 * i) + F (2 * i + 1)) 0 n + = bigi predT F 0 (2 * n). +proof. +move=> ge0_n; rewrite big_split; pose rg := range 0 n. +rewrite -(@big_mapT (fun i => 2 * i)). +rewrite -(@big_mapT (fun i => 2 * i + 1)). +rewrite -big_cat &(eq_big_perm) &(uniq_perm_eq) 2:&(range_uniq). +- rewrite cat_uniq !map_inj_in_uniq /= ~-1:/# range_uniq /=. + apply/hasPn => _ /mapP[y] /= [_ ->]. + by apply/negP; case/mapP=> ? [_] /#. +move=> x; split. +- rewrite mem_cat; case=> /mapP[y] /=; + case=> /mem_range y_rg -> {x}; apply/mem_range; + by smt(). +move/mem_range => x_rg; rewrite mem_cat. +have: forall (i : int), exists j, i = 2 * j \/ i = 2 * j + 1 by smt(). +- case/(_ x) => y [] ->>; [left | right]; apply/mapP=> /=; + by exists y; (split; first apply/mem_range); smt(). +qed. + +end section. diff --git a/examples/tcstdlib/TcMonoid.ec b/examples/tcstdlib/TcMonoid.ec new file mode 100644 index 0000000000..f33a9da550 --- /dev/null +++ b/examples/tcstdlib/TcMonoid.ec @@ -0,0 +1,35 @@ +require import Int. + +(* -------------------------------------------------------------------- *) +type class monoid = { + op idm : monoid + op (+) : monoid -> monoid -> monoid + + axiom addmA: associative (+) + axiom addmC: commutative (+) + axiom add0m: left_id idm (+) +}. + +(* -------------------------------------------------------------------- *) +section. +declare type m <: monoid. + +lemma addm0: right_id idm (+)<:m>. +proof. by move=> x; rewrite addmC add0m. qed. + +lemma addmCA: left_commutative (+)<:m>. +proof. by move=> x y z; rewrite !addmA (addmC x). qed. + +lemma addmAC: right_commutative (+)<:m>. +proof. by move=> x y z; rewrite -!addmA (addmC y). qed. + +lemma addmACA: interchange (+)<:m> (+). +proof. by move=> x y z t; rewrite -!addmA (addmCA y). qed. + +lemma iteropE n (x : m): iterop n (+) x idm = iter n ((+) x) idm. +proof. +elim/natcase n => [n le0_n|n ge0_n]. ++ by rewrite ?(iter0, iterop0). ++ by rewrite iterSr // addm0 iteropS. +qed. +end section. diff --git a/examples/tcstdlib/TcRing.ec b/examples/tcstdlib/TcRing.ec new file mode 100644 index 0000000000..6f7a589834 --- /dev/null +++ b/examples/tcstdlib/TcRing.ec @@ -0,0 +1,858 @@ +pragma +implicits. + +(* -------------------------------------------------------------------- *) +require import Core Int TcMonoid. + +(* -------------------------------------------------------------------- *) +type class group <: monoid = { + op [ - ] : group -> group + + axiom addNr: left_inverse idm [-] (+)<:group> +}. + +section. +declare type g <: group. + +abbrev zeror = idm<:g>. +abbrev ( - ) (x y : g) = x + -y. + +(* -------------------------------------------------------------------- *) +lemma addrA: associative (+)<:g>. +proof. by exact: addmA. qed. + +lemma addrC: commutative (+)<:g>. +proof. by exact: addmC. qed. + +lemma add0r: left_id zeror (+)<:g>. +proof. by exact: add0m. qed. + +(* -------------------------------------------------------------------- *) +lemma addr0: right_id zeror (+)<:g>. +proof. by move=> x; rewrite addrC add0r. qed. + +lemma addrN: right_inverse zeror [-] (+)<:g>. +proof. by move=> x; rewrite addrC addNr. qed. + +lemma addrCA: left_commutative (+)<:g>. +proof. by move=> x y z; rewrite !addrA (@addrC x y). qed. + +lemma addrAC: right_commutative (+)<:g>. +proof. by move=> x y z; rewrite -!addrA (@addrC y z). qed. + +lemma addrACA: interchange (+)<:g> (+)<:g>. +proof. by move=> x y z t; rewrite -!addrA (addrCA y). qed. + +lemma subrr (x : g): x - x = zeror. +proof. by rewrite addrN. qed. + +lemma addKr: left_loop [-] (+)<:g>. +proof. by move=> x y; rewrite addrA addNr add0r. qed. + +lemma addNKr: rev_left_loop [-] (+)<:g>. +proof. by move=> x y; rewrite addrA addrN add0r. qed. + +lemma addrK: right_loop [-] (+)<:g>. +proof. by move=> x y; rewrite -addrA addrN addr0. qed. + +lemma addrNK: rev_right_loop [-] (+)<:g>. +proof. by move=> x y; rewrite -addrA addNr addr0. qed. + +lemma subrK (x y : g): (x - y) + y = x. +proof. by rewrite addrNK. qed. + +lemma addrI: right_injective (+)<:g>. +proof. by move=> x y z h; rewrite -(@addKr x z) -h addKr. qed. + +lemma addIr: left_injective (+)<:g>. +proof. by move=> x y z h; rewrite -(@addrK x z) -h addrK. qed. + +lemma opprK: involutive [-]<:g>. +proof. by move=> x; apply (@addIr (-x)); rewrite addNr addrN. qed. + +lemma oppr_inj : injective [-]<:g>. +proof. by move=> x y eq; apply/(addIr (-x)); rewrite subrr eq subrr. qed. + +lemma oppr0 : -zeror = zeror. +proof. by rewrite -(@addr0 (-zeror)) addNr. qed. + +lemma oppr_eq0 (x : g) : (- x = zeror) <=> (x = zeror). +proof. by rewrite (inv_eq opprK) oppr0. qed. + +lemma subr0 (x : g): x - zeror = x. +proof. by rewrite oppr0 addr0. qed. + +lemma sub0r (x : g): zeror - x = - x. +proof. by rewrite add0r. qed. + +lemma opprD (x y : g): -(x + y) = -x + -y. +proof. by apply (@addrI (x + y)); rewrite addrA addrN addrAC addrK addrN. qed. + +lemma opprB (x y : g): -(x - y) = y - x. +proof. by rewrite opprD opprK addrC. qed. + +lemma subrACA: interchange (-) (+)<:g>. +proof. by move=> x y z t; rewrite addrACA opprD. qed. + +lemma subr_eq (x y z : g): + (x - z = y) <=> (x = y + z). +proof. +move: (can2_eq (fun x, x - z) (fun x, x + z) _ _ x y) => //=. ++ by move=> {x} x /=; rewrite addrNK. ++ by move=> {x} x /=; rewrite addrK. +qed. + +lemma subr_eq0 (x y : g): (x - y = zeror) <=> (x = y). +proof. by rewrite subr_eq add0r. qed. + +lemma addr_eq0 (x y : g): (x + y = zeror) <=> (x = -y). +proof. by rewrite -(@subr_eq0 x) opprK. qed. + +lemma eqr_opp (x y : g): (- x = - y) <=> (x = y). +proof. by apply/(@can_eq _ _ opprK x y). qed. + +lemma eqr_oppLR (x y : g) : (- x = y) <=> (x = - y). +proof. by apply/(@inv_eq _ opprK x y). qed. + +lemma eqr_sub (x y z t : g) : (x - y = z - t) <=> (x + t = z + y). +proof. +rewrite -{1}(addrK t x) -{1}(addrK y z) -!addrA. +by rewrite (addrC (-t)) !addrA; split=> [/addIr /addIr|->//]. +qed. + +lemma subr_add2r (z x y : g): (x + z) - (y + z) = x - y. +proof. by rewrite opprD addrACA addrN addr0. qed. + +op intmul (x : g) (n : int) = + (* (signz n) * (iterop `|n| ZModule.(+) x zeror) *) + if n < 0 + then -(iterop (-n) (+)<:g> x zeror) + else (iterop n (+)<:g> x zeror). + +lemma intmulpE (z : g) c : 0 <= c => + intmul z c = iterop c (+)<:g> z zeror. +proof. by rewrite /intmul lezNgt => ->. qed. + +lemma mulr0z (x : g): intmul x 0 = zeror. +proof. by rewrite /intmul /= iterop0. qed. + +lemma mulr1z (x : g): intmul x 1 = x. +proof. by rewrite /intmul /= iterop1. qed. + +lemma mulr2z (x : g): intmul x 2 = x + x. +proof. by rewrite /intmul /= (@iteropS 1) // (@iterS 0) // iter0. qed. + +lemma mulrNz (x : g) (n : int): intmul x (-n) = -(intmul x n). +proof. +case: (n = 0)=> [->|nz_c]; first by rewrite oppz0 mulr0z oppr0. +rewrite /intmul oppz_lt0 oppzK ltz_def nz_c lezNgt /=. +by case: (n < 0); rewrite ?opprK. +qed. + +lemma mulrS (x : g) (n : int): 0 <= n => + intmul x (n+1) = x + intmul x n. +proof. +move=> ge0n; rewrite !intmulpE 1:addz_ge0 //. +by rewrite !iteropE iterS. +qed. + +lemma mulNrz (x : g) n : intmul (- x) n = - (intmul x n). +proof. +elim/intwlog: n => [n h| | n ge0_n ih]. ++ by rewrite -(@oppzK n) !(@mulrNz _ (- n)) h. ++ by rewrite !mulr0z oppr0. ++ by rewrite !mulrS // ih opprD. +qed. + +lemma mulNrNz (x : g) (n : int) : intmul (-x) (-n) = intmul x n. +proof. by rewrite mulNrz mulrNz opprK. qed. + +lemma mulrSz (x : g) n : intmul x (n + 1) = x + intmul x n. +proof. +case: (0 <= n) => [/mulrS ->//|]; rewrite -ltzNge => gt0_n. +case: (n = -1) => [->/=|]; 1: by rewrite mulrNz mulr1z mulr0z subrr. +move=> neq_n_N1; rewrite -!(@mulNrNz x). +rewrite (_ : -n = -(n+1) + 1) 1:/# mulrS 1:/#. +by rewrite addrA subrr add0r. +qed. + +lemma mulrDz (x : g) (n m : int) : intmul x (n + m) = intmul x n + intmul x m. +proof. +wlog: n m / 0 <= m => [wlog|]. ++ case: (0 <= m) => [/wlog|]; first by apply. + rewrite -ltzNge => lt0_m; rewrite (_ : n + m = -(-m - n)) 1:/#. + by rewrite mulrNz addzC wlog 1:/# !mulrNz -opprD opprK. +elim: m => /= [|m ge0_m ih]; first by rewrite mulr0z addr0. +by rewrite addzA !mulrSz ih addrCA. +qed. + +end section. + +(* -------------------------------------------------------------------- *) +type class comring <: group = { + op oner : comring + op ( * ) : comring -> comring -> comring + op invr : comring -> comring + op unit : comring -> bool + + axiom oner_neq0 : oner <> zeror + axiom mulrA : associative ( * ) + axiom mulrC : commutative ( * ) + axiom mul1r : left_id oner ( * ) + axiom mulrDl : left_distributive ( * ) (+)<:comring> + axiom mulVr : left_inverse_in unit oner invr ( * ) + axiom unitP : forall (x y : comring), y * x = oner => unit x + axiom unitout : forall (x : comring), !unit x => invr x = x +}. + +section. +declare type r <: comring. + +instance monoid with r + op idm = oner<:r> + op (+) = ( * )<:r>. +realize addmA by exact: mulrA. +realize addmC by exact: mulrC. +realize add0m by exact: mul1r. + +abbrev ( / ) (x y : r) = x * (invr y). + +lemma mulr1: right_id oner ( * )<:r>. +proof. by move=> x; rewrite mulrC mul1r. qed. + +lemma mulrCA: left_commutative ( * )<:r>. +proof. by move=> x y z; rewrite !mulrA (@mulrC x y). qed. + +lemma mulrAC: right_commutative ( * )<:r>. +proof. by move=> x y z; rewrite -!mulrA (@mulrC y z). qed. + +lemma mulrACA: interchange ( * ) ( * )<:r>. +proof. by move=> x y z t; rewrite -!mulrA (mulrCA y). qed. + +lemma mulrSl (x y : r) : (x + oner) * y = x * y + y. +proof. by rewrite mulrDl mul1r. qed. + +lemma mulrDr: right_distributive ( * ) (+)<:r>. +proof. by move=> x y z; rewrite mulrC mulrDl !(@mulrC _ x). qed. + +lemma mul0r: left_zero zeror ( * )<:r>. +proof. by move=> x; apply: (@addIr (oner * x)); rewrite -mulrDl !add0r mul1r. qed. + +lemma mulr0: right_zero zeror ( * )<:r>. +proof. by move=> x; apply: (@addIr (x * oner)); rewrite -mulrDr !add0r mulr1. qed. + +lemma mulrN (x y : r): x * (- y) = - (x * y). +proof. by apply: (@addrI (x * y)); rewrite -mulrDr !addrN mulr0. qed. + +lemma mulNr (x y : r): (- x) * y = - (x * y). +proof. by apply: (@addrI (x * y)); rewrite -mulrDl !addrN mul0r. qed. + +lemma mulrNN (x y : r): (- x) * (- y) = x * y. +proof. by rewrite mulrN mulNr opprK. qed. + +lemma mulN1r (x : r): (-oner) * x = -x. +proof. by rewrite mulNr mul1r. qed. + +lemma mulrN1 (x : r): x * -oner = -x. +proof. by rewrite mulrN mulr1. qed. + +lemma mulrBl: left_distributive ( * ) (-)<:r>. +proof. by move=> x y z; rewrite mulrDl !mulNr. qed. + +lemma mulrBr: right_distributive ( * ) (-)<:r>. +proof. by move=> x y z; rewrite mulrDr !mulrN. qed. + +lemma mulrnAl (x y : r) n : 0 <= n => (intmul x n) * y = intmul (x * y) n. +proof. +elim: n => [|n ge0n ih]; rewrite !(mulr0z, mulrS) ?mul0r //. +by rewrite mulrDl ih. +qed. + +lemma mulrnAr (x y : r) n : 0 <= n => x * (intmul y n) = intmul (x * y) n. +proof. +elim: n => [|n ge0n ih]; rewrite !(mulr0z, mulrS) ?mulr0 //. +by rewrite mulrDr ih. +qed. + +lemma mulrzAl (x y : r) z : (intmul x z) * y = intmul (x * y) z. +proof. +case: (lezWP 0 z)=> [|_] le; first by rewrite mulrnAl. +by rewrite -oppzK mulrNz mulNr mulrnAl -?mulrNz // oppz_ge0. +qed. + +lemma mulrzAr x (y : r) z : x * (intmul y z) = intmul (x * y) z. +proof. +case: (lezWP 0 z)=> [|_] le; first by rewrite mulrnAr. +by rewrite -oppzK mulrNz mulrN mulrnAr -?mulrNz // oppz_ge0. +qed. + +lemma mulrV: right_inverse_in unit oner invr ( * )<:r>. +proof. by move=> x /mulVr; rewrite mulrC. qed. + +lemma divrr (x : r): unit x => x / x = oner. +proof. by apply/mulrV. qed. + +lemma invr_out (x : r): !unit x => invr x = x. +proof. by apply/unitout. qed. + +lemma unitrP (x : r): unit x <=> (exists y, y * x = oner). +proof. by split=> [/mulVr<- |]; [exists (invr x) | case=> y /unitP]. qed. + +lemma mulKr: left_loop_in unit invr ( * )<:r>. +proof. by move=> x un_x y; rewrite mulrA mulVr // mul1r. qed. + +lemma mulrK: right_loop_in unit invr ( * )<:r>. +proof. by move=> y un_y x; rewrite -mulrA mulrV // mulr1. qed. + +lemma mulVKr: rev_left_loop_in unit invr ( * )<:r>. +proof. by move=> x un_x y; rewrite mulrA mulrV // mul1r. qed. + +lemma mulrVK: rev_right_loop_in unit invr ( * )<:r>. +proof. by move=> y nz_y x; rewrite -mulrA mulVr // mulr1. qed. + +lemma mulrI: right_injective_in unit ( * )<:r>. +proof. by move=> x Ux; have /can_inj h := mulKr _ Ux. qed. + +lemma mulIr: left_injective_in unit ( * )<:r>. +proof. by move=> x /mulrI h y1 y2; rewrite !(@mulrC _ x) => /h. qed. + +lemma unitrE (x : r): unit x <=> (x / x = oner). +proof. +split=> [Ux|xx1]; 1: by apply/divrr. +by apply/unitrP; exists (invr x); rewrite mulrC. +qed. + +lemma invrK: involutive invr<:r>. +proof. +move=> x; case: (unit x)=> Ux; 2: by rewrite !invr_out. +rewrite -(mulrK _ Ux (invr (invr x))) -mulrA. +rewrite (@mulrC x) mulKr //; apply/unitrP. +by exists x; rewrite mulrV. +qed. + +lemma invr_inj: injective invr<:r>. +proof. by apply: (can_inj _ _ invrK). qed. + +lemma unitrV (x : r): unit (invr x) <=> unit x. +proof. by rewrite !unitrE invrK mulrC. qed. + +lemma unitr1: unit oner<:r>. +proof. by apply/unitrP; exists oner; rewrite mulr1. qed. + +lemma invr1: invr oner = oner<:r>. +proof. by rewrite -{2}(mulVr _ unitr1) mulr1. qed. + +lemma div1r x: oner / x = invr x. +proof. by rewrite mul1r. qed. + +lemma divr1 x: x / oner = x. +proof. by rewrite invr1 mulr1. qed. + +lemma unitr0: !unit zeror<:r>. +proof. by apply/negP=> /unitrP [y]; rewrite mulr0 eq_sym oner_neq0. qed. + +lemma invr0: invr zeror = zeror<:r>. +proof. by rewrite invr_out ?unitr0. qed. + +lemma unitrN1: unit (-oner<:r>). +proof. by apply/unitrP; exists (-oner); rewrite mulrNN mulr1. qed. + +lemma invrN1: invr (-oner) = -oner<:r>. +proof. by rewrite -{2}(divrr unitrN1) mulN1r opprK. qed. + +lemma unitrMl (x y : r) : unit y => (unit (x * y) <=> unit x). +proof. (* FIXME: wlog *) +move=> uy; case: (unit x)=> /=; last first. + apply/contra=> uxy; apply/unitrP; exists (y * invr (x * y)). + apply/(mulrI (invr y)); first by rewrite unitrV. + rewrite !mulrA mulVr // mul1r; apply/(mulIr y)=> //. + by rewrite -mulrA mulVr // mulr1 mulVr. +move=> ux; apply/unitrP; exists (invr y * invr x). +by rewrite -!mulrA mulKr // mulVr. +qed. + +lemma unitrMr (x y : r): unit x => (unit (x * y) <=> unit y). +proof. +move=> ux; split=> [uxy|uy]; last by rewrite unitrMl. +by rewrite -(mulKr _ ux y) unitrMl ?unitrV. +qed. + +lemma unitrM (x y : r) : unit (x * y) <=> (unit x /\ unit y). +proof. +case: (unit x) => /=; first by apply: unitrMr. +apply: contra => /unitrP[z] zVE; apply/unitrP. +by exists (y * z); rewrite mulrAC (@mulrC y) (@mulrC _ z). +qed. + +lemma unitrN (x : r) : unit (-x) <=> unit x. +proof. by rewrite -mulN1r unitrMr // unitrN1. qed. + +lemma invrM (x y : r) : unit x => unit y => invr (x * y) = invr y * invr x. +proof. +move=> Ux Uy; have Uxy: unit (x * y) by rewrite unitrMl. +by apply: (mulrI _ Uxy); rewrite mulrV ?mulrA ?mulrK ?mulrV. +qed. + +lemma invrN (x : r) : invr (- x) = - (invr x). +proof. +case: (unit x) => ux; last by rewrite !invr_out ?unitrN. +by rewrite -mulN1r invrM ?unitrN1 // invrN1 mulrN1. +qed. + +lemma invr_neq0 (x : r) : x <> zeror => invr x <> zeror. +proof. +move=> nx0; case: (unit x)=> Ux; last by rewrite invr_out ?Ux. +by apply/negP=> x'0; move: Ux; rewrite -unitrV x'0 unitr0. +qed. + +lemma invr_eq0 (x : r) : (invr x = zeror) <=> (x = zeror). +proof. by apply/iff_negb; split=> /invr_neq0; rewrite ?invrK. qed. + +lemma invr_eq1 (x : r) : (invr x = oner) <=> (x = oner). +proof. by rewrite (inv_eq invrK) invr1. qed. + +op ofint n = intmul oner<:r> n. + +lemma ofint0: ofint 0 = zeror. +proof. by apply/mulr0z. qed. + +lemma ofint1: ofint 1 = oner. +proof. by apply/mulr1z. qed. + +lemma ofintS (i : int): 0 <= i => ofint (i+1) = oner + ofint i. +proof. by apply/mulrS. qed. + +lemma ofintN (i : int): ofint (-i) = - (ofint i). +proof. by apply/mulrNz. qed. + +lemma mul1r0z x: x * ofint 0 = zeror. +proof. by rewrite ofint0 mulr0. qed. + +lemma mul1r1z x : x * ofint 1 = x. +proof. by rewrite ofint1 mulr1. qed. + +lemma mul1r2z x : x * ofint 2 = x + x. +proof. by rewrite /ofint mulr2z mulrDr mulr1. qed. + +lemma mulr_intl x z : (ofint z) * x = intmul x z. +proof. by rewrite mulrzAl mul1r. qed. + +lemma mulr_intr x z : x * (ofint z) = intmul x z. +proof. by rewrite mulrzAr mulr1. qed. + +op exp (x : r) (n : int) = + if n < 0 + then invr (iterop (-n) ( * ) x oner) + else iterop n ( * ) x oner. + +lemma expr0 x: exp x 0 = oner. +proof. by rewrite /exp /= iterop0. qed. + +lemma expr1 x: exp x 1 = x. +proof. by rewrite /exp /= iterop1. qed. + +lemma exprS (x : r) i: 0 <= i => exp x (i+1) = x * (exp x i). +proof. +move=> ge0i; rewrite /exp !ltzNge ge0i addz_ge0 //=. +(* we want to use the multiplicative monoid instance here *) +(* by rewrite !Monoid.iteropE iterS. *) admit. +qed. + +lemma expr_pred (x : r) i : 0 < i => exp x i = x * (exp x (i - 1)). +proof. smt(exprS). qed. + +lemma exprSr (x : r) i: 0 <= i => exp x (i+1) = (exp x i) * x. +proof. by move=> ge0_i; rewrite exprS // mulrC. qed. + +lemma expr2 x: exp x 2 = x * x. +proof. by rewrite (@exprS _ 1) // expr1. qed. + +lemma exprN (x : r) (i : int): exp x (-i) = invr (exp x i). +proof. +case: (i = 0) => [->|]; first by rewrite oppz0 expr0 invr1. +rewrite /exp oppz_lt0 ltzNge lez_eqVlt oppzK=> -> /=. +by case: (_ < _)%Int => //=; rewrite invrK. +qed. + +lemma exprN1 (x : r) : exp x (-1) = invr x. +proof. by rewrite exprN expr1. qed. + +lemma unitrX x m : unit x => unit (exp x m). +proof. +move=> invx; wlog: m / (0 <= m) => [wlog|]. ++ (have [] : (0 <= m \/ 0 <= -m) by move=> /#); first by apply: wlog. + by move=> ?; rewrite -oppzK exprN unitrV &(wlog). +elim: m => [|m ge0_m ih]; first by rewrite expr0 unitr1. +by rewrite exprS // &(unitrMl). +qed. + +lemma unitrX_neq0 x m : m <> 0 => unit (exp x m) => unit x. +proof. +wlog: m / (0 < m) => [wlog|]. ++ case: (0 < m); [by apply: wlog | rewrite ltzNge /= => le0_m nz_m]. + by move=> h; (apply: (wlog (-m)); 1,2:smt()); rewrite exprN unitrV. +by move=> gt0_m _; rewrite (_ : m = m - 1 + 1) // exprS 1:/# unitrM. +qed. + +lemma exprV (x : r) (i : int): exp (invr x) i = exp x (-i). +proof. +wlog: i / (0 <= i) => [wlog|]; first by smt(exprN). +elim: i => /= [|i ge0_i ih]; first by rewrite !expr0. +case: (i = 0) => [->|] /=; first by rewrite exprN1 expr1. +move=> nz_i; rewrite exprS // ih !exprN. +case: (unit x) => [invx|invNx]. ++ by rewrite -invrM ?unitrX // exprS // mulrC. +rewrite !invr_out //; last by rewrite exprS. ++ by apply: contra invNx; apply: unitrX_neq0 => /#. ++ by apply: contra invNx; apply: unitrX_neq0 => /#. +qed. + +lemma exprVn (x : r) (n : int) : 0 <= n => exp (invr x) n = invr (exp x n). +proof. +elim: n => [|n ge0_n ih]; first by rewrite !expr0 invr1. +case: (unit x) => ux. +- by rewrite exprSr -1:exprS // invrM ?unitrX // ih -invrM // unitrX. +- by rewrite !invr_out //; apply: contra ux; apply: unitrX_neq0 => /#. +qed. + +lemma exprMn (x y : r) (n : int) : 0 <= n => exp (x * y) n = exp x n * exp y n. +proof. +elim: n => [|n ge0_n ih]; first by rewrite !expr0 mulr1. +by rewrite !exprS // mulrACA ih. +qed. + +lemma exprD_nneg x (m n : int) : 0 <= m => 0 <= n => + exp x (m + n) = exp x m * exp x n. +proof. + move=> ge0_m ge0_n; elim: m ge0_m => [|m ge0_m ih]. + by rewrite expr0 mul1r. + by rewrite addzAC !exprS ?addz_ge0 // ih mulrA. +qed. + +lemma exprD x (m n : int) : unit x => exp x (m + n) = exp x m * exp x n. +proof. +wlog: m n x / (0 <= m + n) => [wlog invx|]. ++ case: (0 <= m + n); [by move=> ?; apply: wlog | rewrite lezNgt /=]. + move=> lt0_mDn; rewrite -(@oppzK (m + n)) -exprV. + rewrite -{2}(@oppzK m) -{2}(@oppzK n) -!(@exprV _ (- _)%Int). + by rewrite -wlog 1:/# ?unitrV //#. +move=> ge0_mDn invx; wlog: m n ge0_mDn / (m <= n) => [wlog|le_mn]. ++ by case: (m <= n); [apply: wlog | rewrite mulrC addzC /#]. +(have ge0_n: 0 <= n by move=> /#); elim: n ge0_n m le_mn ge0_mDn. ++ by move=> n _ _ /=; rewrite expr0 mulr1. +move=> n ge0_n ih m le_m_Sn ge0_mDSn; move: ge0_mDSn. +rewrite lez_eqVlt => -[?|]; first have->: n+1 = -m by move=> /#. ++ by rewrite subzz exprN expr0 divrr // unitrX. +move=> gt0_mDSn; move: le_m_Sn; rewrite lez_eqVlt. +case=> [->>|lt_m_Sn]; first by rewrite exprD_nneg //#. +by rewrite addzA exprS 1:/# ih 1,2:/# exprS // mulrCA. +qed. + +lemma exprM x (m n : int) : + exp x (m * n) = exp (exp x m) n. +proof. +wlog : n / 0 <= n. ++ move=> h; case: (0 <= n) => hn; 1: by apply h. + by rewrite -{1}(@oppzK n) (_: m * - -n = -(m * -n)) 1:/# + exprN h 1:/# exprN invrK. +wlog : m / 0 <= m. ++ move=> h; case: (0 <= m) => hm hn; 1: by apply h. + rewrite -{1}(@oppzK m) (_: (- -m) * n = - (-m) * n) 1:/#. + by rewrite exprN h 1:/# // exprN exprV exprN invrK. +elim/natind: n => [|n hn ih hm _]; 1: smt (expr0). +by rewrite mulzDr exprS //= mulrC exprD_nneg 1:/# 1:// ih. +qed. + +lemma expr0n n : 0 <= n => exp zeror n = if n = 0 then oner else zeror. +proof. +elim: n => [|n ge0_n _]; first by rewrite expr0. +by rewrite exprS // mul0r addz1_neq0. +qed. + +lemma expr0z z : exp zeror z = if z = 0 then oner else zeror. +proof. +case: (0 <= z) => [/expr0n // | /ltzNge lt0_z]. +rewrite -{1}(@oppzK z) exprN; have ->/=: z <> 0 by smt(). +rewrite invr_eq0 expr0n ?oppz_ge0 1:ltzW //. +by have ->/=: -z <> 0 by smt(). +qed. + +lemma expr1z z : exp oner z = oner. +proof. +elim/intwlog: z. ++ by move=> n h; rewrite -(@oppzK n) exprN h invr1. ++ by rewrite expr0. ++ by move=> n ge0_n ih; rewrite exprS // mul1r ih. +qed. + +lemma sqrrD (x y : r) : + exp (x + y) 2 = exp x 2 + intmul (x * y) 2 + exp y 2. +proof. +by rewrite !expr2 mulrDl !mulrDr mulr2z !addrA (@mulrC y x). +qed. + +lemma sqrrN x : exp (-x) 2 = exp x 2. +proof. by rewrite !expr2 mulrNN. qed. + +lemma sqrrB x y : + exp (x - y) 2 = exp x 2 - intmul (x * y) 2 + exp y 2. +proof. by rewrite sqrrD sqrrN mulrN mulNrz. qed. + +lemma signr_odd n : 0 <= n => exp (-oner) (b2i (odd n)) = exp (-oner) n. +proof. +elim: n => [|n ge0_nih]; first by rewrite odd0 expr0 expr0. +rewrite !(iterS, oddS) // exprS // -/(odd _) => <-. +by case: (odd _); rewrite /b2i /= !(expr0, expr1) mulN1r ?opprK. +qed. + +lemma subr_sqr_1 x : exp x 2 - oner = (x - oner) * (x + oner). +proof. +rewrite mulrBl mulrDr !(mulr1, mul1r) expr2 -addrA. +by congr; rewrite opprD addrA addrN add0r. +qed. + +op lreg (x : r) = injective (fun y => x * y). + +lemma mulrI_eq0 x y : lreg x => (x * y = zeror) <=> (y = zeror). +proof. by move=> reg_x; rewrite -{1}(mulr0 x) (inj_eq reg_x). qed. + +lemma lreg_neq0 x : lreg x => x <> zeror. +proof. +apply/contraL=> ->; apply/negP => /(_ zeror oner). +by rewrite (@eq_sym _ oner) oner_neq0 /= !mul0r. +qed. + +lemma mulrI0_lreg x : (forall y, x * y = zeror => y = zeror) => lreg x. +proof. +by move=> reg_x y z eq; rewrite -subr_eq0 &(reg_x) mulrBr eq subrr. +qed. + +lemma lregN x : lreg x => lreg (-x). +proof. by move=> reg_x y z; rewrite !mulNr => /oppr_inj /reg_x. qed. + +lemma lreg1 : lreg oner. +proof. by move=> x y; rewrite !mul1r. qed. + +lemma lregM x y : lreg x => lreg y => lreg (x * y). +proof. by move=> reg_x reg_y z t; rewrite -!mulrA => /reg_x /reg_y. qed. + +lemma lregXn x n : 0 <= n => lreg x => lreg (exp x n). +proof. +move=> + reg_x; elim: n => [|n ge0_n ih]. +- by rewrite expr0 &(lreg1). +- by rewrite exprS // &(lregM). +qed. +end section. + +(* +(* -------------------------------------------------------------------- *) +abstract theory ComRingDflInv. + clone include ComRing with + pred unit (x : t) = exists y, y * x = oner, + op invr (x : t) = choiceb (fun y => y * x = oner) x + + proof mulVr, unitP, unitout. + + realize mulVr. + proof. + move=> x ^ un_x [y ^ -> <-] @/invr_. + by have /= -> := choicebP _ x un_x. + qed. + + realize unitP. + proof. by move=> x y eq; exists y. qed. + + realize unitout. + proof. + by move=> x; rewrite /unit_ negb_exists => /choiceb_dfl /(_ x). + qed. +end ComRingDflInv. +*) + +(* -------------------------------------------------------------------- *) +type class boolring <: comring = { + axiom mulrr : forall (x : boolring), x * x = x +}. + +lemma addrr ['a <: boolring] (x : 'a): x + x = zeror. +proof. +apply (@addrI (x + x)); rewrite addr0 -{1 2 3 4}[x]mulrr. +by rewrite -mulrDr -mulrDl mulrr. +qed. + +(* -------------------------------------------------------------------- *) +type class idomain <: comring = { + axiom mulf_eq0: + forall (x y : idomain), x * y = zeror <=> x = zeror \/ y = zeror +}. + +section. +declare type r <: idomain. + +lemma mulf_neq0 (x y : r): x <> zeror => y <> zeror => x * y <> zeror. +proof. by move=> nz_x nz_y; apply/negP; rewrite mulf_eq0 /#. qed. + +lemma expf_eq0 (x : r) n : (exp x n = zeror) <=> (n <> 0 /\ x = zeror). +proof. +elim/intwlog: n => [n| |n ge0_n ih]. ++ by rewrite exprN invr_eq0 /#. ++ by rewrite expr0 oner_neq0. +by rewrite exprS // mulf_eq0 ih addz1_neq0 ?andKb. +qed. + +lemma mulfI (x : r): x <> zeror => injective (( * ) x). +proof. +move=> ne0_x y y'; rewrite -(opprK (x * y')) -mulrN -addr_eq0. +by rewrite -mulrDr mulf_eq0 ne0_x /= addr_eq0 opprK. +qed. + +lemma mulIf (x : r): x <> zeror => injective (fun y => y * x). +proof. by move=> nz_x y z; rewrite -!(@mulrC x); exact: mulfI. qed. + +lemma sqrf_eq1 (x : r): (exp x 2 = oner) <=> (x = oner \/ x = -oner). +proof. by rewrite -subr_eq0 subr_sqr_1 mulf_eq0 subr_eq0 addr_eq0. qed. + +lemma lregP (x : r): lreg x <=> x <> zeror. +proof. by split=> [/lreg_neq0//|/mulfI]. qed. + +lemma eqr_div (x1 y1 x2 y2 : r) : unit y1 => unit y2 => + (x1 / y1 = x2 / y2) <=> (x1 * y2 = x2 * y1). +proof. +move=> Nut1 Nut2; rewrite -{1}(@mulrK y2 _ x1) //. +rewrite -{1}(@mulrK y1 _ x2) // -!mulrA (@mulrC (invr y1)) !mulrA. +split=> [|->] //; + (have nz_Vy1: unit (invr y1) by rewrite unitrV); + (have nz_Vy2: unit (invr y2) by rewrite unitrV). +by move/(mulIr _ nz_Vy1)/(mulIr _ nz_Vy2). +qed. +end section. + +(* -------------------------------------------------------------------- *) +(* +(* TODO: Disjointness of type class operator names? *) +type class ffield <: group = { + op onef : ffield + op ( * ) : ffield -> ffield -> ffield + op invf : ffield -> ffield + + axiom onef_neq0 : onef <> zeror + axiom mulfA : associative ( * ) + axiom mulfC : commutative ( * ) + axiom mul1f : left_id onef ( * ) + axiom mulfDl : left_distributive ( * ) (+)<:ffield> + axiom mulVf : left_inverse_in (predC (pred1 zeror)) onef invf ( * ) + axiom unitP : forall (x y : ffield), y * x = onef => x <> zeror + axiom unitout : invr zeror = zeror +}. +*) + +(* TODO: Probably not the right way *) +type class ffield <: idomain = { + axiom unit_neq0: forall (x : ffield), unit x <=> x <> zeror +}. + +section. +declare type f <: ffield. + +lemma mulfV (x : f): x <> zeror => x * (invr x) = oner. +proof. by move=> /unit_neq0/mulrV. qed. + +lemma mulVf (x : f): x <> zeror => (invr x) * x = oner. +proof. by move=> /unit_neq0/mulVr. qed. + +lemma divff (x : f): x <> zeror => x / x = oner. +proof. by move=> /unit_neq0/divrr. qed. + +lemma invfM (x y : f) : invr (x * y) = invr x * invr y. +proof. +case: (x = zeror) => [->|nz_x]; first by rewrite !(mul0r, invr0). +case: (y = zeror) => [->|nz_y]; first by rewrite !(mulr0, invr0). +by rewrite invrM ?unit_neq0 // mulrC. +qed. + +lemma invf_div (x y : f) : invr (x / y) = y / x. +proof. by rewrite invfM invrK mulrC. qed. + +lemma eqf_div (x1 y1 x2 y2 : f) : y1 <> zeror => y2 <> zeror => + (x1 / y1 = x2 / y2) <=> (x1 * y2 = x2 * y1). +proof. by rewrite -!unit_neq0; exact: eqr_div<:f>. qed. + +lemma expfM (x y : f) n : exp (x * y) n = exp x n * exp y n. +proof. +elim/intwlog: n => [n h | | n ge0_n ih]. ++ by rewrite -(@oppzK n) !(@exprN _ (-n)) h invfM. ++ by rewrite !expr0 mulr1. ++ by rewrite !exprS // mulrCA -!mulrA -ih mulrCA. +qed. +end section. + +(* --------------------------------------------------------------------- *) +(* Rewrite database for algebra tactic *) + +hint rewrite rw_algebra : . +hint rewrite inj_algebra : . + +(* -------------------------------------------------------------------- *) +(* TODO: Instantiation of type classes with inheritance is broken *) +(* TODO: Instantiation of type class operators with literals is broken *) +op zeroz = 0. +op addz (x y : int) = x + y. +op negz (x : int) = -x. + + +instance monoid with int + op idm = zeroz + op (+) = addz. +realize addmA by exact: addzA. +realize addmC by exact: addzC. +realize add0m by exact: add0z. + +(* TODO: This is just broken *) +instance group with int + (* op idm = zeroz *) + op [-] = negz. +realize addNr. +(* TODO: Note that the zero remains undefined *) +rewrite /left_inverse /negz /idm. +(* by exact: addNz. *) admit. + +(* +theory IntID. +clone include IDomain with + type t <- int, + pred unit (z : int) <- (z = 1 \/ z = -1), + op zeror <- 0, + op oner <- 1, + op ( + ) <- Int.( + ), + op [ - ] <- Int.([-]), + op ( * ) <- Int.( * ), + op invr <- (fun (z : int) => z) + proof * by smt + remove abbrev (-) + remove abbrev (/) + rename "ofint" as "ofint_id". + +abbrev (^) = exp. + +lemma intmulz z c : intmul z c = z * c. +proof. +have h: forall cp, 0 <= cp => intmul z cp = z * cp. + elim=> /= [|cp ge0_cp ih]; first by rewrite mulr0z. + by rewrite mulrS // ih mulrDr /= addrC. +smt(opprK mulrNz opprK). +qed. + +lemma poddX n x : 0 < n => odd (exp x n) = odd x. +proof. +rewrite ltz_def => - [] + ge0_n; elim: n ge0_n => // + + _ _. +elim=> [|n ge0_n ih]; first by rewrite expr1. +by rewrite exprS ?addz_ge0 // oddM ih andbb. +qed. + +lemma oddX n x : 0 <= n => odd (exp x n) = (odd x \/ n = 0). +proof. +rewrite lez_eqVlt; case: (n = 0) => [->// _|+ h]. ++ by rewrite expr0 odd1. ++ by case: h => [<-//|] /poddX ->. +qed. +end IntID. +*) diff --git a/examples/typeclasses/monoidtc.ec b/examples/typeclasses/monoidtc.ec new file mode 100644 index 0000000000..a892abbcb5 --- /dev/null +++ b/examples/typeclasses/monoidtc.ec @@ -0,0 +1,54 @@ +require import Int. + +(* -------------------------------------------------------------------- *) +type class addmonoid = { + op idm : addmonoid + op (+) : addmonoid -> addmonoid -> addmonoid + + axiom addmA : associative (+) + axiom addmC : commutative (+) + axiom add0m : left_id idm (+) +}. + +(* -------------------------------------------------------------------- *) +lemma addm0 ['a <: addmonoid] : right_id idm (+)<:'a>. +proof. by move=> x; rewrite addmC add0m. qed. + +lemma addmCA ['a <: addmonoid] : left_commutative (+)<:'a>. +proof. by move=> x y z; rewrite !addmA (addmC x). qed. + +lemma addmAC ['a <: addmonoid] : right_commutative (+)<:'a>. +proof. by move=> x y z; rewrite -!addmA (addmC y). qed. + +lemma addmACA ['a <: addmonoid] : interchange (+)<:'a> (+)<:'a>. +proof. by move=> x y z t; rewrite -!addmA (addmCA y). qed. + +lemma iteropE ['a <: addmonoid] n x: iterop n (+)<:'a> x idm<:'a> = iter n ((+)<:'a> x) idm<:'a>. +proof. + elim/natcase n => [n le0_n|n ge0_n]. + + by rewrite ?(iter0, iterop0). + + by rewrite iterSr // addm0 iteropS. +qed. + +(* -------------------------------------------------------------------- *) +abstract theory AddMonoid. + type t. + + op idm : t. + op (+) : t -> t -> t. + + theory Axioms. + axiom addmA: associative AddMonoid.(+). + axiom addmC: commutative AddMonoid.(+). + axiom add0m: left_id AddMonoid.idm AddMonoid.(+). + end Axioms. + + instance addmonoid with t + op idm = idm + op (+) = (+). + + realize addmA by exact Axioms.addmA. + realize addmC by exact Axioms.addmC. + realize add0m by exact Axioms.add0m. + +end AddMonoid. diff --git a/examples/typeclasses/typeclass.ec b/examples/typeclasses/typeclass.ec new file mode 100644 index 0000000000..eaee3603cf --- /dev/null +++ b/examples/typeclasses/typeclass.ec @@ -0,0 +1,353 @@ +(* ==================================================================== *) +(* Typeclass examples *) + +(* -------------------------------------------------------------------- *) +require import AllCore List. + +(* -------------------------------------------------------------------- *) +(* Set theory *) + +type class ['a] artificial = { + op myop : artificial * 'a +}. + +op myopi ['a] : int * 'a = (0, witness<:'a>). + +instance 'b artificial with ['b] int + op myop = myopi<:'b>. + +lemma reduce_tc : myop<:bool, int> = (0, witness). +proof. +class. +reflexivity. +qed. + +(* -------------------------------------------------------------------- *) +type class witness = { + op witness : witness +}. + +print witness. + +type class finite = { + op enum : finite list + axiom enumP : forall (x : finite), x \in enum +}. + +print enum. +print enumP. + +type class countable = { + op count : int -> countable + axiom countP : forall (x : countable), exists (n : int), x = count n +}. + +(* -------------------------------------------------------------------- *) +(* Simple algebraic structures *) + +type class magma = { + op mmul : magma -> magma -> magma +}. + +print mmul. + +type class semigroup <: magma = { + axiom mmulA : associative mmul<:semigroup> +}. + +print associative. + +type class monoid <: semigroup = { + op mid : monoid + + axiom mmulr0 : right_id mid mmul<:monoid> + axiom mmul0r : left_id mid mmul<:monoid> +}. + +type class group <: monoid = { + op minv : group -> group + + axiom mmulN : left_inverse mid minv mmul +}. + +type class ['a <: semigroup] semigroup_action = { + op amul : 'a -> semigroup_action -> semigroup_action + + axiom compatibility : + forall (g h : 'a) (x : semigroup_action), amul (mmul g h) x = amul g (amul h x) +}. + +type class ['a <: monoid] monoid_action <: 'a semigroup_action = { + axiom identity : forall (x : monoid_action), amul mid<:'a> x = x +}. + +(* TODO: why again is this not possible/a good idea? *) +(*type class finite_group <: group & finite = {}.*) + +(* -------------------------------------------------------------------- *) +(* Advanced algebraic structures *) + +type class comgroup = { + op zero : comgroup + op ([-]) : comgroup -> comgroup + op ( + ) : comgroup -> comgroup -> comgroup + + axiom addr0 : right_id zero ( + ) + axiom addrN : left_inverse zero ([-]) ( + ) + axiom addrC : commutative ( + ) + axiom addrA : associative ( + ) +}. + +type class comring <: comgroup = { + op one : comring + op ( * ) : comring -> comring -> comring + + axiom mulr1 : right_id one ( * ) + axiom mulrC : commutative ( * ) + axiom mulrA : associative ( * ) + axiom mulrDl : left_distributive ( * ) ( + ) +}. + +type class ['a <: comring] commodule <: comgroup = { + op ( ** ) : 'a -> commodule -> commodule + + axiom scalerDl : forall (a b : 'a) (x : commodule), + (a + b) ** x = (a ** x) + (b ** x) + axiom scalerDr : forall (a : 'a) (x y : commodule), + a ** (x + y) = (a ** x) + (a ** y) +}. + + +(* ==================================================================== *) +(* Abstract type examples *) + +(* TODO: finish the hierarchy here: + https://en.wikipedia.org/wiki/Magma_(algebra) *) +type foo <: witness. +type fingroup <: group & finite. + + + +(* TODO: printing typeclasses *) +print countable. +print magma. +print semigroup. +print monoid. +print group. +print semigroup_action. +print monoid_action. + + +(* ==================================================================== *) +(* Operator examples *) + +(* -------------------------------------------------------------------- *) +(* Set theory *) + +op all_finite ['a <: finite] (p : 'a -> bool) = + all p enum<:'a>. + +op all_countable ['a <: countable] (p : 'a -> bool) = + forall (n : int), p (count<:'a> n). + +(* -------------------------------------------------------------------- *) +(* Simple algebraic structures *) + +(* TODO: weird issue and/or inapropriate error message : bug in ecUnify select_op*) + +print amul. +(* +op foo1 ['a <: semigroup, 'b <: 'a semigroup_action] = amul<:'a,'b>. +*) +op foo2 ['a <: semigroup, 'b <: 'a semigroup_action] (g : 'a) (x : 'b) = amul g x. +(* +op foo3 ['a <: semigroup, 'b <: 'a semigroup_action] (g : 'a) (x : 'b) = amul<:'a,'b> g x. +*) + +op big ['a, 'b <: monoid] (P : 'a -> bool) (F : 'a -> 'b) (r : 'a list) = + foldr mmul mid (map F (filter P r)). + + +(* ==================================================================== *) +(* Lemma examples *) + +(* -------------------------------------------------------------------- *) +(* Set theory *) + +lemma all_finiteP ['a <: finite] p : (all_finite p) <=> (forall (x : 'a), p x). +proof. by rewrite/all_finite allP; split=> Hp x; rewrite Hp enumP. qed. + +lemma all_countableP ['a <: countable] p : (all_countable p) <=> (forall (x : 'a), p x). +proof. + rewrite/all_countable; split => [Hp x|Hp n]. + by case (countP x) => n ->>; rewrite Hp. + by rewrite Hp. +qed. + +lemma all_finite_countable ['a <: finite & countable] (p : 'a -> bool) : (all_finite p) <=> (all_countable p). +proof. by rewrite all_finiteP all_countableP. qed. + + +(* ==================================================================== *) +(* Instance examples *) + +(* -------------------------------------------------------------------- *) +(* Set theory *) + +op bool_enum = [true; false]. + +(* TODO: we want to be able to give the list directly.*) +instance finite with bool + op enum = bool_enum. + +realize enumP. +proof. by case. qed. + +(* -------------------------------------------------------------------- *) +(* Advanced algebraic structures *) + +(* +op izero = 0. + +instance comgroup with int + op zero = izero + op ( + ) = CoreInt.add + op ([-]) = CoreInt.opp. + +(* TODO: might be any of the two addr0, also apply fails but rewrite works. + In ecScope, where instances are declared. *) +realize addr0 by rewrite addr0. +realize addrN by trivial. +realize addrC by rewrite addrC. +realize addrA by rewrite addrA. + +op foo = 1 + 3. + +print ( + ). +print foo. + +op ione = 1. + +(* TODO: this automatically fetches the only instance of comgroup we have defined for int. + We should give the choice of which instance to use, by adding as desired_name after the with. + Also we should give the choice to define directly an instance of comring with int. *) +instance comring with int + op one = ione + op ( * ) = CoreInt.mul. + +realize mulr1 by trivial. +realize mulrC by rewrite mulrC. +realize mulrA by rewrite mulrA. + +realize mulrDl. +proof. + (*TODO: in the goal, the typeclass operator + should have been replaced with the + from CoreInt, but has not been.*) + print mulrDl. + move => x y z. + class. + apply Ring.IntID.mulrDl. +qed. + +(* ==================================================================== *) +(* Misc *) + +(* -------------------------------------------------------------------- *) +(* TODO: which instance is kept in memory after this? *) + +op bool_enum_alt = [true; false]. + +instance finite with bool + op enum = bool_enum_alt. + +realize enumP. +proof. by case. qed. + +type class find_out <: finite = { + axiom rev_enum : rev<:find_out> enum = enum +}. + +instance find_out with bool. + +realize rev_enum. +proof. + admit. +qed. + + + +(* ==================================================================== *) +(* Old TODO list: 1-3 are done, modulo bugs, 4 is to be done, 5 will be done later. *) + +(* + 1. typage -> selection des operateurs / inference des instances de tc + 2. reduction + 3. unification (tactiques) + 4. clonage + 5. envoi au SMT + + 1. + Fop : + -(old) path * ty list -> form + -(new) path * (ty * (map tcname -> tcinstance)) list -> form + + op ['a <: monoid] (+) : 'a -> 'a -> 'a. + + (+)<:int + monoid -> intadd_monoid> + (+)<:int + monoid -> intmul_monoid> + + 1.1 module de construction des formules avec typage + 1.2 utiliser le module ci-dessous + + let module M = MkForm(struct let env = env' end) in + + 1.3 UnionFind avec contraintes de TC + + 1.4 Overloading: + 3 + 4 + a. 3 Int.(+) 4 + b. 3 Monoid<:int>.(+) 4 (-> instance du dessus -> ignore) + + 1.5 foo<: int[monoid -> intadd_monoid] > + foo<: int[monoid -> intmul_monoid] > + + 2. -> Monoid.(+)<:int> -> Int.(+) + + 3. -> Pb d'unification des op + (+)<: ?[monoid -> ?] > ~ Int.(+) + + Mecanisme de resolution des TC + + 4. -> il faut cloner les TC + + 5. + + a. encodage + + record 'a premonoid = { + op zero : 'a + op add : 'a -> 'a -> 'a; + } + + pred ['a] ismonoid (m : 'a premonoid) = { + left_id m.zero m.add + } + + op ['a <: monoid] foo (x y : 'a) = x + y + + ->> foo ['a] (m : 'a premonoid) (x y : 'a) = m.add x y + + lemma foo ['a <: monoid] P + + ->> foo ['a] (m : 'a premonoid) : ismonoid m => P + + let intmonoid = { zero = 0; add = intadd } + + lemma intmonoid_is_monoid : ismonoid int_monoid + + b. reduction avant envoi + (+)<: int[monoid -> intadd_monoid > -> Int.(+) + + c. ne pas envoyer certaines instances (e.g. int est un groupe) + -> instance [nosmt] e.g. +*) +*) diff --git a/src/ecAlgTactic.ml b/src/ecAlgTactic.ml index f926a7ff3b..faf5a01236 100644 --- a/src/ecAlgTactic.ml +++ b/src/ecAlgTactic.ml @@ -80,7 +80,7 @@ module Axioms = struct let addctt = fun subst x f -> EcSubst.add_opdef subst (xpath x) ([], f) in let subst = - EcSubst.add_tydef EcSubst.empty (xpath tname) ([], cr.r_type) in + EcSubst.add_tydef EcSubst.empty (xpath tname) ([], cr.r_type, []) in let subst = List.fold_left (fun subst (x, p) -> add subst x p) subst crcore in let subst = odfl subst (cr.r_opp |> omap (fun p -> add subst opp p)) in diff --git a/src/ecAst.ml b/src/ecAst.ml index dc04fe95e7..9b353472ce 100644 --- a/src/ecAst.ml +++ b/src/ecAst.ml @@ -3,7 +3,6 @@ open EcUtils open EcSymbols open EcIdent open EcPath -open EcUid module BI = EcBigInt @@ -33,7 +32,6 @@ type quantif = type hoarecmp = FHle | FHeq | FHge (* -------------------------------------------------------------------- *) - type 'a use_restr = { ur_pos : 'a option; (* If not None, can use only element in this set. *) ur_neg : 'a; (* Cannot use element in this set. *) @@ -42,6 +40,13 @@ type 'a use_restr = { type mr_xpaths = EcPath.Sx.t use_restr type mr_mpaths = EcPath.Sm.t use_restr +(* -------------------------------------------------------------------- *) +module TyUni = EcUid.CoreGen () +module TcUni = EcUid.CoreGen () + +type tyuni = TyUni.uid +type tcuni = TcUni.uid + (* -------------------------------------------------------------------- *) type ty = { ty_node : ty_node; @@ -51,12 +56,49 @@ type ty = { and ty_node = | Tglob of EcIdent.t (* The tuple of global variable of the module *) - | Tunivar of EcUid.uid + | Tunivar of tyuni | Tvar of EcIdent.t | Ttuple of ty list - | Tconstr of EcPath.path * ty list + | Tconstr of EcPath.path * etyarg list | Tfun of ty * ty +(* -------------------------------------------------------------------- *) +and etyarg = ty * tcwitness list + +and tcwitness = + (* Unification variable, possibly with a pending [lift] path to apply + once the variable is resolved. *) + | TCIUni of tcuni * int list + + | TCIConcrete of { + path: EcPath.path; + etyargs: (ty * tcwitness list) list; + (* Same semantics as [TCIAbstract.lift]. *) + lift: int list; + } + + | TCIAbstract of { + support: [ + | `Var of EcIdent.t + | `Abs of EcPath.path + ]; + offset: int; + (* Path through the parent DAG starting at the typeclass at + [support]'s [offset]-th position. [lift = []] means "use the + declared typeclass directly"; [lift = [i; j; ...]] means + "take parent index [i], then parent index [j] of that, ...". + For single-parent classes the path is always [0; 0; ...]. + For multi-parent (factory) classes, the path encodes which + parent edge is taken at each step. *) + lift: int list; + } + +(* -------------------------------------------------------------------- *) +and typeclass = { + tc_name : EcPath.path; + tc_args : etyarg list; +} + (* -------------------------------------------------------------------- *) and ovariable = { ov_name : EcSymbols.symbol option; @@ -84,7 +126,7 @@ and expr_node = | Eint of BI.zint (* int. literal *) | Elocal of EcIdent.t (* let-variables *) | Evar of prog_var (* module variable *) - | Eop of EcPath.path * ty list (* op apply to type args *) + | Eop of EcPath.path * etyarg list (* op apply to type args *) | Eapp of expr * expr list (* op. application *) | Equant of equantif * ebindings * expr (* fun/forall/exists *) | Elet of lpattern * expr * expr (* let binding *) @@ -185,7 +227,7 @@ and f_node = | Flocal of EcIdent.t | Fpvar of prog_var * memory | Fglob of EcIdent.t * memory - | Fop of EcPath.path * ty list + | Fop of EcPath.path * etyarg list | Fapp of form * form list | Ftuple of form list | Fproj of form * int @@ -781,6 +823,100 @@ let lp_fv = function (fun s (id, _) -> ofold Sid.add s id) Sid.empty ids +(* -------------------------------------------------------------------- *) +(* Append [extra] to a witness's [lift] path. Used during substitution + when a witness referencing the [k]-th tc of some support gets + replaced by the witness for that tc, which may itself need further + parent-walk steps. *) +let bump_lift (extra : int list) (tcw : tcwitness) : tcwitness = + if extra = [] then tcw else + match tcw with + | TCIUni (uid, l) -> TCIUni (uid, l @ extra) + | TCIConcrete c -> TCIConcrete { c with lift = c.lift @ extra } + | TCIAbstract a -> TCIAbstract { a with lift = a.lift @ extra } + +(* -------------------------------------------------------------------- *) +let rec tcw_fv (tcw : tcwitness) = + match tcw with + | TCIUni _ -> + Mid.empty + + | TCIConcrete { etyargs } -> + List.fold_left + (fun fv (ty, tcws) -> fv_union fv (fv_union ty.ty_fv (tcws_fv tcws))) + Mid.empty etyargs + + | TCIAbstract { support = `Var v } -> + Mid.singleton v 1 + + | TCIAbstract { support = `Abs _ } -> + Mid.empty + +and tcws_fv (tcws : tcwitness list) = + List.fold_left + (fun fv tcw -> fv_union fv (tcw_fv tcw)) + Mid.empty tcws + +let etyarg_fv ((ty, tcws) : etyarg) = + fv_union ty.ty_fv (tcws_fv tcws) + +let etyargs_fv (tyargs : etyarg list) = + List.fold_left + (fun fv tyarg -> fv_union fv (etyarg_fv tyarg)) + Mid.empty tyargs + +(* -------------------------------------------------------------------- *) +let rec tcw_equal (tcw1 : tcwitness) (tcw2 : tcwitness) = + match tcw1, tcw2 with + | TCIUni (uid1, l1), TCIUni (uid2, l2) -> + TcUni.uid_equal uid1 uid2 && l1 = l2 + + | TCIConcrete tcw1, TCIConcrete tcw2 -> + EcPath.p_equal tcw1.path tcw2.path + && tcw1.lift = tcw2.lift + && List.all2 etyarg_equal tcw1.etyargs tcw2.etyargs + + | TCIAbstract { support = support1; offset = o1; lift = l1 } + , TCIAbstract { support = support2; offset = o2; lift = l2 } + -> + let tyvar_eq () = + match support1, support2 with + | `Var x1, `Var x2 -> + EcIdent.id_equal x1 x2 + | `Abs p1, `Abs p2 -> + EcPath.p_equal p1 p2 + | _, _ -> false + + in o1 = o2 && l1 = l2 && tyvar_eq () + + | _, _ -> + false + +and etyarg_equal ((ty1, tcws1) : etyarg) ((ty2, tcws2) : etyarg) = + ty_equal ty1 ty2 && List.all2 tcw_equal tcws1 tcws2 + +(* -------------------------------------------------------------------- *) +let rec tcw_hash (tcw : tcwitness) = + let lift_hash = Why3.Hashcons.combine_list (fun i -> i) 0 in + match tcw with + | TCIUni (uid, l) -> + Why3.Hashcons.combine (Hashtbl.hash uid) (lift_hash l) + + | TCIConcrete tcw -> + Why3.Hashcons.combine_list + etyarg_hash + (Why3.Hashcons.combine (p_hash tcw.path) (lift_hash tcw.lift)) + tcw.etyargs + + | TCIAbstract { support = `Var tyvar; offset; lift } -> + Why3.Hashcons.combine2 (EcIdent.id_hash tyvar) offset (lift_hash lift) + + | TCIAbstract { support = `Abs p; offset; lift } -> + Why3.Hashcons.combine2 (EcPath.p_hash p) offset (lift_hash lift) + + and etyarg_hash ((ty, tcws) : etyarg) = + Why3.Hashcons.combine_list tcw_hash (ty_hash ty) tcws + (* -------------------------------------------------------------------- *) let e_equal = ((==) : expr -> expr -> bool) let e_hash = fun e -> e.e_tag @@ -791,7 +927,6 @@ let eqt_equal : equantif -> equantif -> bool = (==) let eqt_hash : equantif -> int = Hashtbl.hash (* -------------------------------------------------------------------- *) - let lv_equal lv1 lv2 = match lv1, lv2 with | LvVar (pv1, ty1), LvVar (pv2, ty2) -> @@ -815,7 +950,6 @@ let lv_fv = function let add s (pv, _) = EcIdent.fv_union s (pv_fv pv) in List.fold_left add Mid.empty pvs - let lv_hash = function | LvVar (pv, ty) -> Why3.Hashcons.combine (pv_hash pv) (ty_hash ty) @@ -825,7 +959,6 @@ let lv_hash = function (fun (pv, ty) -> Why3.Hashcons.combine (pv_hash pv) (ty_hash ty)) 0 pvs - (* -------------------------------------------------------------------- *) let i_equal = ((==) : instr -> instr -> bool) let i_hash = fun i -> i.i_tag @@ -835,7 +968,6 @@ let s_equal = ((==) : stmt -> stmt -> bool) let s_hash = fun s -> s.s_tag let s_fv = fun s -> s.s_fv - (*-------------------------------------------------------------------- *) let qt_equal : quantif -> quantif -> bool = (==) let qt_hash : quantif -> int = Hashtbl.hash @@ -1216,7 +1348,7 @@ module Hsty = Why3.Hashcons.Make (struct EcIdent.id_equal m1 m2 | Tunivar u1, Tunivar u2 -> - uid_equal u1 u2 + TyUni.uid_equal u1 u2 | Tvar v1, Tvar v2 -> id_equal v1 v2 @@ -1225,7 +1357,7 @@ module Hsty = Why3.Hashcons.Make (struct List.all2 ty_equal lt1 lt2 | Tconstr (p1, lt1), Tconstr (p2, lt2) -> - EcPath.p_equal p1 p2 && List.all2 ty_equal lt1 lt2 + EcPath.p_equal p1 p2 && List.all2 etyarg_equal lt1 lt2 | Tfun (d1, c1), Tfun (d2, c2)-> ty_equal d1 d2 && ty_equal c1 c2 @@ -1235,10 +1367,10 @@ module Hsty = Why3.Hashcons.Make (struct let hash ty = match ty.ty_node with | Tglob m -> EcIdent.id_hash m - | Tunivar u -> u + | Tunivar u -> Hashtbl.hash u | Tvar id -> EcIdent.tag id | Ttuple tl -> Why3.Hashcons.combine_list ty_hash 0 tl - | Tconstr (p, tl) -> Why3.Hashcons.combine_list ty_hash p.p_tag tl + | Tconstr (p, tl) -> Why3.Hashcons.combine_list etyarg_hash p.p_tag tl | Tfun (t1, t2) -> Why3.Hashcons.combine (ty_hash t1) (ty_hash t2) let fv ty = @@ -1250,7 +1382,7 @@ module Hsty = Why3.Hashcons.Make (struct | Tunivar _ -> Mid.empty | Tvar _ -> Mid.empty (* FIXME: section *) | Ttuple tys -> union (fun a -> a.ty_fv) tys - | Tconstr (_, tys) -> union (fun a -> a.ty_fv) tys + | Tconstr (_, tys) -> union etyarg_fv tys | Tfun (t1, t2) -> union (fun a -> a.ty_fv) [t1; t2] let tag n ty = { ty with ty_tag = n; ty_fv = fv ty.ty_node; } @@ -1260,7 +1392,6 @@ let mk_ty node = Hsty.hashcons { ty_node = node; ty_tag = -1; ty_fv = Mid.empty } (* ----------------------------------------------------------------- *) - module Hexpr = Why3.Hashcons.Make (struct type t = expr @@ -1277,7 +1408,7 @@ module Hexpr = Why3.Hashcons.Make (struct | Eop (p1, tys1), Eop (p2, tys2) -> (EcPath.p_equal p1 p2) - && (List.all2 ty_equal tys1 tys2) + && (List.all2 etyarg_equal tys1 tys2) | Eapp (e1, es1), Eapp (e2, es2) -> (e_equal e1 e2) @@ -1320,9 +1451,8 @@ module Hexpr = Why3.Hashcons.Make (struct | Elocal x -> Hashtbl.hash x | Evar x -> pv_hash x - | Eop (p, tys) -> - Why3.Hashcons.combine_list ty_hash - (EcPath.p_hash p) tys + | Eop (p, tyargs) -> + Why3.Hashcons.combine_list etyarg_hash (EcPath.p_hash p) tyargs | Eapp (e, es) -> Why3.Hashcons.combine_list e_hash (e_hash e) es @@ -1359,7 +1489,7 @@ module Hexpr = Why3.Hashcons.Make (struct match e with | Eint _ -> Mid.empty - | Eop (_, tys) -> union (fun a -> a.ty_fv) tys + | Eop (_, tyargs) -> etyargs_fv tyargs | Evar v -> pv_fv v | Elocal id -> fv_singleton id | Eapp (e, es) -> union e_fv (e :: es) @@ -1376,7 +1506,27 @@ module Hexpr = Why3.Hashcons.Make (struct end) (* -------------------------------------------------------------------- *) -let mk_expr e ty = +let normalize_enode (node : expr_node) : expr_node = + match node with + | Equant (_, [], body) -> + body.e_node + + | Equant (q1, bds1, { e_node = Equant (q2, bds2, body) }) + when q1 = q2 + -> Equant (q1, bds1 @ bds2, body) + + | Eapp (hd, []) -> + hd.e_node + + | Eapp ({ e_node = Eapp (hd, args1) }, args2) -> + Eapp (hd, args1 @ args2) + + | _ -> + node + +(* -------------------------------------------------------------------- *) +let mk_expr (e : expr_node) (ty : ty) = + let e = normalize_enode e in Hexpr.hashcons { e_node = e; e_tag = -1; e_fv = Mid.empty; e_ty = ty } (* -------------------------------------------------------------------- *) @@ -1411,7 +1561,7 @@ module Hsform = Why3.Hashcons.Make (struct EcIdent.id_equal mp1 mp2 && EcIdent.id_equal m1 m2 | Fop(p1,lty1), Fop(p2,lty2) -> - EcPath.p_equal p1 p2 && List.all2 ty_equal lty1 lty2 + EcPath.p_equal p1 p2 && List.all2 etyarg_equal lty1 lty2 | Fapp(f1,args1), Fapp(f2,args2) -> f_equal f1 f2 && List.all2 f_equal args1 args2 @@ -1465,8 +1615,10 @@ module Hsform = Why3.Hashcons.Make (struct | Fglob(mp, m) -> Why3.Hashcons.combine (EcIdent.id_hash mp) (EcIdent.id_hash m) - | Fop(p, lty) -> - Why3.Hashcons.combine_list ty_hash (EcPath.p_hash p) lty + | Fop(p, tyargs) -> + Why3.Hashcons.combine_list + etyarg_hash (EcPath.p_hash p) + tyargs | Fapp(f, args) -> Why3.Hashcons.combine_list f_hash (f_hash f) args @@ -1505,7 +1657,7 @@ module Hsform = Why3.Hashcons.Make (struct match f with | Fint _ -> Mid.empty - | Fop (_, tys) -> union (fun a -> a.ty_fv) tys + | Fop (_, tyargs) -> union etyarg_fv tyargs | Fpvar (PVglob pv,m) -> EcPath.x_fv (fv_add m Mid.empty) pv | Fpvar (PVloc _,m) -> fv_add m Mid.empty | Fglob (mp,m) -> fv_add mp (fv_add m Mid.empty) @@ -1581,7 +1733,28 @@ module Hsform = Why3.Hashcons.Make (struct { f with f_tag = n; f_fv = fv; } end) -let mk_form node ty = +(* -------------------------------------------------------------------- *) +let normalize_fnode (node : f_node) : f_node = + match node with + | Fquant (_, [], body) -> + body.f_node + + | Fquant (q1, bds1, { f_node = Fquant (q2, bds2, body) }) + when q1 = q2 + -> Fquant (q1, bds1 @ bds2, body) + + | Fapp (hd, []) -> + hd.f_node + + | Fapp ({ f_node = Fapp (hd, args1)}, args2) -> + Fapp (hd, args1 @ args2) + + | _ -> + node + +(* -------------------------------------------------------------------- *) +let mk_form (node : f_node) (ty : ty) = + let node = normalize_fnode (node) in let aout = Hsform.hashcons { f_node = node; diff --git a/src/ecAst.mli b/src/ecAst.mli index a13023aec3..96cd7fa6db 100644 --- a/src/ecAst.mli +++ b/src/ecAst.mli @@ -36,6 +36,13 @@ type mr_xpaths = EcPath.Sx.t use_restr type mr_mpaths = EcPath.Sm.t use_restr +(* -------------------------------------------------------------------- *) +module TyUni : EcUid.ICore with type uid = private EcUid.uid +module TcUni : EcUid.ICore with type uid = private EcUid.uid + +type tyuni = TyUni.uid +type tcuni = TcUni.uid + (* -------------------------------------------------------------------- *) type ty = private { ty_node : ty_node; @@ -45,12 +52,39 @@ type ty = private { and ty_node = | Tglob of EcIdent.t (* The tuple of global variable of the module *) - | Tunivar of EcUid.uid + | Tunivar of tyuni | Tvar of EcIdent.t | Ttuple of ty list - | Tconstr of EcPath.path * ty list + | Tconstr of EcPath.path * etyarg list | Tfun of ty * ty +(* -------------------------------------------------------------------- *) +and etyarg = ty * tcwitness list + +and tcwitness = + | TCIUni of tcuni * int list + + | TCIConcrete of { + path: EcPath.path; + etyargs: (ty * tcwitness list) list; + lift: int list; + } + + | TCIAbstract of { + support: [ + | `Var of EcIdent.t + | `Abs of EcPath.path + ]; + offset: int; + lift: int list; + } + +(* -------------------------------------------------------------------- *) +and typeclass = { + tc_name : EcPath.path; + tc_args : etyarg list; +} + (* -------------------------------------------------------------------- *) and ovariable = { ov_name : EcSymbols.symbol option; @@ -78,7 +112,7 @@ and expr_node = | Eint of BI.zint (* int. literal *) | Elocal of EcIdent.t (* let-variables *) | Evar of prog_var (* module variable *) - | Eop of EcPath.path * ty list (* op apply to type args *) + | Eop of EcPath.path * etyarg list (* op apply to type args *) | Eapp of expr * expr list (* op. application *) | Equant of equantif * ebindings * expr (* fun/forall/exists *) | Elet of lpattern * expr * expr (* let binding *) @@ -91,7 +125,6 @@ and ebinding = EcIdent.t * ty and ebindings = ebinding list (* -------------------------------------------------------------------- *) - and lvalue = | LvVar of (prog_var * ty) | LvTuple of (prog_var * ty) list @@ -179,7 +212,7 @@ and f_node = | Flocal of EcIdent.t | Fpvar of prog_var * memory | Fglob of EcIdent.t * memory - | Fop of EcPath.path * ty list + | Fop of EcPath.path * etyarg list | Fapp of form * form list | Ftuple of form list | Fproj of form * int @@ -489,6 +522,18 @@ val lp_equal : lpattern equality val lp_hash : lpattern hash val lp_fv : lpattern -> EcIdent.Sid.t +(* -------------------------------------------------------------------- *) +val etyarg_fv : etyarg -> int Mid.t +val etyargs_fv : etyarg list -> int Mid.t +val etyarg_hash : etyarg -> int +val etyarg_equal : etyarg -> etyarg -> bool + +(* -------------------------------------------------------------------- *) +val bump_lift : int list -> tcwitness -> tcwitness +val tcw_fv : tcwitness -> int Mid.t +val tcw_hash : tcwitness -> int +val tcw_equal : tcwitness -> tcwitness -> bool + (* -------------------------------------------------------------------- *) val e_equal : expr equality val e_hash : expr hash diff --git a/src/ecCallbyValue.ml b/src/ecCallbyValue.ml index 227ed19d11..e9765da72f 100644 --- a/src/ecCallbyValue.ml +++ b/src/ecCallbyValue.ml @@ -217,7 +217,7 @@ and betared st s bd f args = (* -------------------------------------------------------------------- *) and try_reduce_record_projection - (st : state) ((p, _tys) : EcPath.path * ty list) (args : args) + (st : state) ((p, _tys) : EcPath.path * etyarg list) (args : args) = let exception Bailout in @@ -245,7 +245,7 @@ and try_reduce_record_projection (* -------------------------------------------------------------------- *) and try_reduce_fixdef - (st : state) ((p, tys) : EcPath.path * ty list) (args : args) + (st : state) ((p, tys) : EcPath.path * etyarg list) (args : args) = let exception Bailout in @@ -300,7 +300,9 @@ and try_reduce_fixdef let body = EcFol.form_of_expr body in let body = - Tvar.f_subst ~freshen:true op.EcDecl.op_tparams tys body in + Tvar.f_subst ~freshen:true + (List.combine (List.map fst op.EcDecl.op_tparams) tys) + body in Some (cbv st subst body (Args.create ty eargs)) @@ -337,7 +339,17 @@ and reduce_user_delta st f1 p tys args = | #Op.redmode as mode when Op.reducible ~mode ~nargs st.st_env p -> let f = Op.reduce ~mode ~nargs st.st_env p tys in cbv st Subst.subst_id f args - | _ -> f2 + | _ -> + (* TC reduction: fold a TC op to its concrete realisation when + the witness resolves to an instance marked [tci_reducible]. + Only fires on the concrete-instance path; abstract-rename + folding is intentionally skipped here so proofs over an + abstract carrier are not perturbed by [/=]. *) + if st.st_ri.delta_tc then + match Op.tc_reduce ~strict:true st.st_env p tys with + | f -> cbv st Subst.subst_id f args + | exception NotReducible -> f2 + else f2 (* -------------------------------------------------------------------- *) and reduce_logic st f = diff --git a/src/ecCommands.ml b/src/ecCommands.ml index e90518ff08..daa4b3ad6c 100644 --- a/src/ecCommands.ml +++ b/src/ecCommands.ml @@ -434,6 +434,13 @@ and process_subtype (scope : EcScope.scope) (subtype : psubtype located) = EcScope.notify scope `Info "added subtype: `%s'" (unloc subtype.pl_desc.pst_name); scope +(* -------------------------------------------------------------------- *) +and process_typeclass (scope : EcScope.scope) (tcd : ptypeclass located) = + EcScope.check_state `InTop "type class" scope; + let scope = EcScope.Ty.add_class scope tcd in + EcScope.notify scope `Info "added type class: `%s'" (unloc tcd.pl_desc.ptc_name); + scope + (* -------------------------------------------------------------------- *) and process_tycinst (scope : EcScope.scope) (tci : ptycinstance located) = EcScope.check_state `InTop "type class instance" scope; @@ -776,6 +783,7 @@ and process ?(src : string option) (ld : Loader.loader) (scope : EcScope.scope) match g.pl_desc with | Gtype t -> `Fct (fun scope -> process_types ?src scope (List.map (mk_loc loc) t)) | Gsubtype t -> `Fct (fun scope -> process_subtype scope (mk_loc loc t)) + | Gtypeclass t -> `Fct (fun scope -> process_typeclass scope (mk_loc loc t)) | Gtycinstance t -> `Fct (fun scope -> process_tycinst scope (mk_loc loc t)) | Gmodule m -> `Fct (fun scope -> process_module ?src scope m) | Ginterface i -> `Fct (fun scope -> process_interface ?src scope i) diff --git a/src/ecCoreEqTest.ml b/src/ecCoreEqTest.ml new file mode 100644 index 0000000000..9dc60f4059 --- /dev/null +++ b/src/ecCoreEqTest.ml @@ -0,0 +1,89 @@ +(* -------------------------------------------------------------------- + * Copyright (c) - 2012--2016 - IMDEA Software Institute + * Copyright (c) - 2012--2018 - Inria + * Copyright (c) - 2012--2018 - Ecole Polytechnique + * + * Distributed under the terms of the CeCILL-C-V1 license + * -------------------------------------------------------------------- *) + +(* -------------------------------------------------------------------- *) +open EcUtils +open EcTypes +open EcEnv + +(* -------------------------------------------------------------------- *) +type 'a eqtest = env -> 'a -> 'a -> bool + +(* -------------------------------------------------------------------- *) +let rec for_type env t1 t2 = + ty_equal t1 t2 || for_type_r env t1 t2 + +(* -------------------------------------------------------------------- *) +and for_type_r env t1 t2 = + match t1.ty_node, t2.ty_node with + | Tunivar uid1, Tunivar uid2 -> + EcAst.TyUni.uid_equal uid1 uid2 + + | Tvar i1, Tvar i2 -> i1 = i2 + + | Ttuple lt1, Ttuple lt2 -> + List.length lt1 = List.length lt2 + && List.all2 (for_type env) lt1 lt2 + + | Tfun (t1, t2), Tfun (t1', t2') -> + for_type env t1 t1' && for_type env t2 t2' + + | Tglob m1, Tglob m2 -> EcIdent.id_equal m1 m2 + + | Tconstr (p1, lt1), Tconstr (p2, lt2) when EcPath.p_equal p1 p2 -> + if + List.length lt1 = List.length lt2 + && List.all2 (for_etyarg env) lt1 lt2 + then true + else + if Ty.defined p1 env + then for_type env (Ty.unfold p1 lt1 env) (Ty.unfold p2 lt2 env) + else false + + | Tconstr (p1, lt1), _ when Ty.defined p1 env -> + for_type env (Ty.unfold p1 lt1 env) t2 + + | _, Tconstr (p2, lt2) when Ty.defined p2 env -> + for_type env t1 (Ty.unfold p2 lt2 env) + + | _, _ -> false + +(* -------------------------------------------------------------------- *) +and for_etyarg env ((ty1, tcws1) : etyarg) ((ty2, tcws2) : etyarg) = + for_type env ty1 ty2 && for_tcws env tcws1 tcws2 + +and for_etyargs env (tyargs1 : etyarg list) (tyargs2 : etyarg list) = + List.length tyargs1 = List.length tyargs2 + && List.for_all2 (for_etyarg env) tyargs1 tyargs2 + +and for_tcw env (tcw1 : tcwitness) (tcw2 : tcwitness) = + let tcw1 = EcTcCanonical.canonicalise_witness env tcw1 in + let tcw2 = EcTcCanonical.canonicalise_witness env tcw2 in + match tcw1, tcw2 with + | TCIUni (uid1, l1), TCIUni (uid2, l2) -> + EcAst.TcUni.uid_equal uid1 uid2 && l1 = l2 + + | TCIConcrete tcw1, TCIConcrete tcw2 -> + EcPath.p_equal tcw1.path tcw2.path + && tcw1.lift = tcw2.lift + && for_etyargs env tcw1.etyargs tcw2.etyargs + + | TCIAbstract { support = `Var v1; offset = o1; lift = l1 }, + TCIAbstract { support = `Var v2; offset = o2; lift = l2 } -> + EcIdent.id_equal v1 v2 && o1 = o2 && l1 = l2 + + | TCIAbstract { support = `Abs p1; offset = o1; lift = l1 }, + TCIAbstract { support = `Abs p2; offset = o2; lift = l2 } -> + EcPath.p_equal p1 p2 && o1 = o2 && l1 = l2 + + | _, _ -> + false + +and for_tcws env (tcws1 : tcwitness list) (tcws2 : tcwitness list) = + List.length tcws1 = List.length tcws2 + && List.for_all2 (for_tcw env) tcws1 tcws2 diff --git a/src/ecCoreEqTest.mli b/src/ecCoreEqTest.mli new file mode 100644 index 0000000000..aa6e5f705b --- /dev/null +++ b/src/ecCoreEqTest.mli @@ -0,0 +1,9 @@ +(* -------------------------------------------------------------------- *) +open EcTypes +open EcEnv + +(* -------------------------------------------------------------------- *) +type 'a eqtest = env -> 'a -> 'a -> bool + +val for_type : ty eqtest +val for_etyarg : etyarg eqtest diff --git a/src/ecCoreFol.ml b/src/ecCoreFol.ml index aae2bacbeb..092eff588c 100644 --- a/src/ecCoreFol.ml +++ b/src/ecCoreFol.ml @@ -153,7 +153,8 @@ let mk_form = EcAst.mk_form let f_node { f_node = form } = form (* -------------------------------------------------------------------- *) -let f_op x tys ty = mk_form (Fop (x, tys)) ty +let f_op x tys ty = mk_form (Fop (x, List.map (fun t -> (t, [])) tys)) ty +let f_op_tc x tys ty = mk_form (Fop (x, tys)) ty let f_app f args ty = let f, args' = @@ -463,9 +464,13 @@ let f_map gt g fp = (f_pvar id ty' s).inv | Fop (p, tys) -> - let tys' = List.Smart.map gt tys in + let tys' = + List.Smart.map + (fun ((t, w) as ety) -> + let t' = gt t in if t == t' then ety else (t', w)) + tys in let ty' = gt fp.f_ty in - f_op p tys' ty' + f_op_tc p tys' ty' | Fapp (f, fs) -> let f' = g f in @@ -956,7 +961,7 @@ let rec form_of_expr_r ?m (e : expr) = end | Eop (op, tys) -> - f_op op tys e.e_ty + f_op_tc op tys e.e_ty | Eapp (ef, es) -> f_app (form_of_expr_r ?m ef) (List.map (form_of_expr_r ?m) es) e.e_ty @@ -1001,7 +1006,7 @@ let expr_of_ss_inv f = | Fint z -> e_int z | Flocal x -> e_local x fp.f_ty - | Fop (p, tys) -> e_op p tys fp.f_ty + | Fop (p, tys) -> e_op_tc p tys fp.f_ty | Fapp (f, fs) -> e_app (aux f) (List.map aux fs) fp.f_ty | Ftuple fs -> e_tuple (List.map aux fs) | Fproj (f, i) -> e_proj (aux f) i fp.f_ty @@ -1043,7 +1048,7 @@ let expr_of_form f = | Fint z -> e_int z | Flocal x -> e_local x fp.f_ty - | Fop (p, tys) -> e_op p tys fp.f_ty + | Fop (p, tys) -> e_op_tc p tys fp.f_ty | Fapp (f, fs) -> e_app (aux f) (List.map aux fs) fp.f_ty | Ftuple fs -> e_tuple (List.map aux fs) | Fproj (f, i) -> e_proj (aux f) i fp.f_ty diff --git a/src/ecCoreFol.mli b/src/ecCoreFol.mli index b270d12d5e..2fd550cc37 100644 --- a/src/ecCoreFol.mli +++ b/src/ecCoreFol.mli @@ -12,9 +12,7 @@ open EcMemory type quantif = EcAst.quantif type hoarecmp = EcAst.hoarecmp - -type gty = EcAst.gty - +type gty = EcAst.gty type binding = (EcIdent.t * gty) type bindings = binding list @@ -74,7 +72,7 @@ val f_node : form -> f_node (* -------------------------------------------------------------------- *) (* not recursive *) -val f_map : (EcTypes.ty -> EcTypes.ty) -> (form -> form) -> form -> form +val f_map : (ty -> ty) -> (form -> form) -> form -> form val f_iter : (form -> unit) -> form -> unit val f_fold : ('a -> form -> 'a) -> 'a -> form -> 'a @@ -96,6 +94,7 @@ val f_glob : EcIdent.t -> memory -> ss_inv (* soft-constructors - common formulas constructors *) val f_op : path -> EcTypes.ty list -> EcTypes.ty -> form +val f_op_tc : path -> etyarg list -> EcTypes.ty -> form val f_app : form -> form list -> EcTypes.ty -> form val f_tuple : form list -> form val f_proj : form -> int -> EcTypes.ty -> form @@ -141,6 +140,7 @@ val f_equivF : ts_inv -> xpath -> xpath -> ts_inv -> form val f_equivS : memtype -> memtype -> ts_inv -> stmt -> stmt -> ts_inv -> form (* soft-constructors - eager *) +val f_eagerF_r : eagerF -> form val f_eagerF : ts_inv -> stmt -> xpath -> xpath -> stmt -> ts_inv -> form (* soft-constructors - Pr *) @@ -250,13 +250,13 @@ val destr_forall1 : form -> ident * gty * form val destr_exists1 : form -> ident * gty * form val destr_lambda1 : form -> ident * gty * form -val destr_op : form -> EcPath.path * ty list +val destr_op : form -> EcPath.path * etyarg list val destr_local : form -> EcIdent.t val destr_pvar : form -> prog_var * memory val destr_proj : form -> form * int val destr_tuple : form -> form list val destr_app : form -> form * form list -val destr_op_app : form -> (EcPath.path * ty list) * form list +val destr_op_app : form -> (EcPath.path * etyarg list) * form list val destr_not : form -> form val destr_nots : form -> bool * form val destr_and : form -> form * form diff --git a/src/ecCoreGoal.ml b/src/ecCoreGoal.ml index 4b75e5b0c1..873df1baa1 100644 --- a/src/ecCoreGoal.ml +++ b/src/ecCoreGoal.ml @@ -51,7 +51,7 @@ and pt_head = | PTCut of EcFol.form * cutsolve option | PTHandle of handle | PTLocal of EcIdent.t -| PTGlobal of EcPath.path * (ty list) +| PTGlobal of EcPath.path * etyarg list | PTTerm of proofterm and cutsolve = [`Done | `Smt | `DoneSmt] diff --git a/src/ecCoreGoal.mli b/src/ecCoreGoal.mli index f574b49bf3..7725546407 100644 --- a/src/ecCoreGoal.mli +++ b/src/ecCoreGoal.mli @@ -53,7 +53,7 @@ and pt_head = | PTCut of EcFol.form * cutsolve option | PTHandle of handle | PTLocal of EcIdent.t -| PTGlobal of EcPath.path * (ty list) +| PTGlobal of EcPath.path * etyarg list | PTTerm of proofterm and cutsolve = [`Done | `Smt | `DoneSmt] @@ -82,12 +82,12 @@ val pamemory : EcMemory.memory -> pt_arg val pamodule : EcPath.mpath * EcModules.module_sig -> pt_arg (* -------------------------------------------------------------------- *) -val paglobal : ?args:pt_arg list -> tys:ty list -> EcPath.path -> pt_arg +val paglobal : ?args:pt_arg list -> tys:etyarg list -> EcPath.path -> pt_arg val palocal : ?args:pt_arg list -> EcIdent.t -> pt_arg val pahandle : ?args:pt_arg list -> handle -> pt_arg (* -------------------------------------------------------------------- *) -val ptglobal : ?args:pt_arg list -> tys:ty list -> EcPath.path -> proofterm +val ptglobal : ?args:pt_arg list -> tys:etyarg list -> EcPath.path -> proofterm val ptlocal : ?args:pt_arg list -> EcIdent.t -> proofterm val pthandle : ?args:pt_arg list -> handle -> proofterm val ptcut : ?args:pt_arg list -> ?cutsolve:cutsolve -> EcFol.form -> proofterm diff --git a/src/ecCorePrinting.ml b/src/ecCorePrinting.ml index dc89869590..3eddc01ba1 100644 --- a/src/ecCorePrinting.ml +++ b/src/ecCorePrinting.ml @@ -4,8 +4,7 @@ module type PrinterAPI = sig open EcIdent open EcSymbols open EcPath - open EcTypes - open EcFol + open EcAst open EcDecl open EcModules open EcTheory @@ -59,7 +58,8 @@ module type PrinterAPI = sig val pp_mem : PPEnv.t -> EcIdent.t pp val pp_memtype : PPEnv.t -> EcMemory.memtype pp val pp_tyvar : PPEnv.t -> ident pp - val pp_tyunivar : PPEnv.t -> EcUid.uid pp + val pp_tyunivar : PPEnv.t -> tyuni pp + val pp_tcunivar : PPEnv.t -> tcuni pp val pp_path : path pp (* ------------------------------------------------------------------ *) @@ -86,11 +86,12 @@ module type PrinterAPI = sig | `Glob of EcIdent.t * EcMemory.memory | `PVar of EcTypes.prog_var * EcMemory.memory ] - + val pp_vsubst : PPEnv.t -> vsubst pp (* ------------------------------------------------------------------ *) val pp_typedecl : PPEnv.t -> (path * tydecl ) pp + val pp_typeclass : PPEnv.t -> (typeclass ) pp val pp_opdecl : ?long:bool -> PPEnv.t -> (path * operator ) pp val pp_added_op : PPEnv.t -> operator pp val pp_axiom : ?long:bool -> PPEnv.t -> (path * axiom ) pp diff --git a/src/ecCoreSubst.ml b/src/ecCoreSubst.ml index 14368120d7..1a4609c199 100644 --- a/src/ecCoreSubst.ml +++ b/src/ecCoreSubst.ml @@ -23,8 +23,17 @@ type sc_instantiate = { (* -------------------------------------------------------------------- *) type f_subst = { fs_freshen : bool; (* true means freshen locals *) - fs_u : ty Muid.t; + fs_u : ty TyUni.Muid.t; fs_v : ty Mid.t; + (* Witnesses to use when substituting [TCIAbstract `Var x] for a + type variable x that is being replaced by [fs_v]. The list is + indexed by witness offset. Empty list / missing key means: leave + the witness alone (caller is doing alpha-renaming, not + instantiation). *) + fs_tw : tcwitness list Mid.t; + (* Resolutions for TCIUni witnesses (typically extracted from the + unifier's tcenv.resolution after a matching/unification step). *) + fs_tw_uni : tcwitness TcUni.Muid.t; fs_mod : EcPath.mpath Mid.t; fs_modex : mod_extra Mid.t; fs_loc : form Mid.t; @@ -56,12 +65,14 @@ let fv_Mid (type a) (* -------------------------------------------------------------------- *) let f_subst_init ?(freshen=false) - ?(tu=Muid.empty) + ?(tu=TyUni.Muid.empty) ?(tv=Mid.empty) + ?(tw=Mid.empty) + ?(tw_uni=TcUni.Muid.empty) ?(esloc=Mid.empty) () = let fv = Mid.empty in - let fv = Muid.fold (fun _ t s -> fv_union s (ty_fv t)) tu fv in + let fv = TyUni.Muid.fold (fun _ t s -> fv_union s (ty_fv t)) tu fv in let fv = fv_Mid ty_fv tv fv in let fv = fv_Mid e_fv esloc fv in @@ -69,6 +80,8 @@ let f_subst_init fs_freshen = freshen; fs_u = tu; fs_v = tv; + fs_tw = tw; + fs_tw_uni = tw_uni; fs_mod = Mid.empty; fs_modex = Mid.empty; fs_loc = Mid.empty; @@ -158,8 +171,10 @@ let f_rem_mod (s : f_subst) (x : ident) : f_subst = (* -------------------------------------------------------------------- *) let is_ty_subst_id (s : f_subst) : bool = Mid.is_empty s.fs_mod - && Muid.is_empty s.fs_u + && TyUni.Muid.is_empty s.fs_u && Mid.is_empty s.fs_v + && Mid.is_empty s.fs_tw + && TcUni.Muid.is_empty s.fs_tw_uni (* -------------------------------------------------------------------- *) let rec ty_subst (s : f_subst) (ty : ty) : ty = @@ -169,7 +184,7 @@ let rec ty_subst (s : f_subst) (ty : ty) : ty = |> Option.map (fun ex -> ex.mex_tglob) |> Option.value ~default:ty | Tunivar id -> - Muid.find_opt id s.fs_u + TyUni.Muid.find_opt id s.fs_u |> Option.map (ty_subst s) |> Option.value ~default:ty | Tvar id -> @@ -181,6 +196,31 @@ let rec ty_subst (s : f_subst) (ty : ty) : ty = let ty_subst (s : f_subst) : ty -> ty = if is_ty_subst_id s then identity else ty_subst s +(* -------------------------------------------------------------------- *) +let rec tcw_subst (s : f_subst) (tcw : tcwitness) : tcwitness = + match tcw with + | TCIAbstract { support = `Var x; offset; lift } when Mid.mem x s.fs_tw -> + let ws = Mid.find x s.fs_tw in + if offset < List.length ws then + bump_lift lift (tcw_subst s (List.nth ws offset)) + else + tcw + | TCIAbstract _ -> tcw + | TCIUni (uid, lift) when TcUni.Muid.mem uid s.fs_tw_uni -> + bump_lift lift (tcw_subst s (TcUni.Muid.find uid s.fs_tw_uni)) + | TCIUni _ -> tcw + | TCIConcrete c -> + let etyargs' = List.Smart.map (etyarg_subst_inner s) c.etyargs in + if etyargs' == c.etyargs then tcw + else TCIConcrete { c with etyargs = etyargs' } + +and etyarg_subst_inner (s : f_subst) ((ty, ws) as e : etyarg) : etyarg = + let ty' = ty_subst s ty in + let ws' = List.Smart.map (tcw_subst s) ws in + if ty == ty' && ws == ws' then e else (ty', ws') + +let etyarg_subst (s : f_subst) (e : etyarg) : etyarg = etyarg_subst_inner s e + (* -------------------------------------------------------------------- *) let is_e_subst_id (s : f_subst) = not s.fs_freshen @@ -256,9 +296,9 @@ let rec e_subst (s : f_subst) (e : expr) : expr = e_var pv' ty' | Eop (p, tys) -> - let tys' = List.Smart.map (ty_subst s) tys in + let tys' = List.Smart.map (etyarg_subst s) tys in let ty' = ty_subst s e.e_ty in - e_op p tys' ty' + e_op_tc p tys' ty' | Elet (lp, e1, e2) -> let e1' = e_subst s e1 in @@ -433,8 +473,9 @@ module Fsubst = struct | Fop (p, tys) -> let ty' = ty_subst s fp.f_ty in - let tys' = List.Smart.map (ty_subst s) tys in - f_op p tys' ty' + let tys' = List.Smart.map (etyarg_subst s) tys in + if ty' == fp.f_ty && tys' == tys then fp + else f_op_tc p tys' ty' | Fpvar (pv, m) -> let pv' = pv_subst s pv in @@ -681,57 +722,64 @@ module Fsubst = struct let init_subst_tvar ~(freshen : bool) (s : ty Mid.t) : f_subst = f_subst_init ~freshen ~tv:s () - let f_subst_tvar ~(freshen : bool) (s : ty Mid.t) : form -> form = - f_subst (init_subst_tvar ~freshen s) + let f_subst_tvar ~(freshen : bool) (s : etyarg Mid.t) : form -> form = + let tv = Mid.map fst s in + let tw = Mid.map snd s in + f_subst (f_subst_init ~freshen ~tv ~tw ()) end (* -------------------------------------------------------------------- *) module Tuni = struct - let subst (uidmap : ty Muid.t) : f_subst = - f_subst_init ~tu:uidmap () + let subst ?(tw_uni = TcUni.Muid.empty) (uidmap : ty TyUni.Muid.t) : f_subst = + f_subst_init ~tu:uidmap ~tw_uni () - let subst1 ((id, t) : uid * ty) : f_subst = - subst (Muid.singleton id t) + let subst1 ((id, t) : tyuni * ty) : f_subst = + subst (TyUni.Muid.singleton id t) - let subst_dom (uidmap : ty Muid.t) (dom : dom) : dom = + let subst_dom (uidmap : ty TyUni.Muid.t) (dom : dom) : dom = List.map (ty_subst (subst uidmap)) dom - let occurs (u : uid) : ty -> bool = + let occurs (u : tyuni) : ty -> bool = let rec aux t = match t.ty_node with - | Tunivar u' -> uid_equal u u' + | Tunivar u' -> TyUni.uid_equal u u' | _ -> ty_sub_exists aux t in aux - let univars : ty -> Suid.t = + let univars : ty -> TyUni.Suid.t = let rec doit univars t = match t.ty_node with - | Tunivar uid -> Suid.add uid univars + | Tunivar uid -> TyUni.Suid.add uid univars | _ -> ty_fold doit univars t - in fun t -> doit Suid.empty t + in fun t -> doit TyUni.Suid.empty t - let rec fv_rec (fv : Suid.t) (t : ty) : Suid.t = + let rec fv_rec (fv : TyUni.Suid.t) (t : ty) : TyUni.Suid.t = match t.ty_node with - | Tunivar id -> Suid.add id fv + | Tunivar id -> TyUni.Suid.add id fv | _ -> ty_fold fv_rec fv t - let fv (ty : ty) : Suid.t = - fv_rec Suid.empty ty + let fv (ty : ty) : TyUni.Suid.t = + fv_rec TyUni.Suid.empty ty end (* -------------------------------------------------------------------- *) module Tvar = struct - let subst (s : ty Mid.t) (ty : ty) : ty = - ty_subst { f_subst_id with fs_v = s } ty + let subst (s : etyarg Mid.t) (ty : ty) : ty = + ty_subst { f_subst_id with fs_v = Mid.map fst s } ty - let subst1 ((id, t) : ebinding) (ty : ty) : ty = + let subst1 ((id, t) : EcIdent.t * etyarg) (ty : ty) : ty = subst (Mid.singleton id t) ty - let init (lv : ident list) (lt : ty list) : ty Mid.t = - assert (List.length lv = List.length lt); - List.fold_left2 (fun s v t -> Mid.add v t s) Mid.empty lv lt + let init (l : (EcIdent.t * etyarg) list) : etyarg Mid.t = + List.fold_left (fun s (v, t) -> Mid.add v t s) Mid.empty l + + let subst_etyarg (s : etyarg Mid.t) ((ty, w) : etyarg) : etyarg = + (subst s ty, w) + + let subst_tc (s : etyarg Mid.t) (tc : typeclass) : typeclass = + { tc with tc_args = List.map (subst_etyarg s) tc.tc_args } - let f_subst ~(freshen : bool) (lv : ident list) (lt : ty list) : form -> form = - Fsubst.f_subst_tvar ~freshen (init lv lt) + let f_subst ~(freshen : bool) (l : (EcIdent.t * etyarg) list) : form -> form = + Fsubst.f_subst_tvar ~freshen (init l) end diff --git a/src/ecCoreSubst.mli b/src/ecCoreSubst.mli index f829b8d387..d8826d82b0 100644 --- a/src/ecCoreSubst.mli +++ b/src/ecCoreSubst.mli @@ -1,5 +1,4 @@ (* -------------------------------------------------------------------- *) -open EcUid open EcIdent open EcPath open EcAst @@ -26,28 +25,33 @@ type 'a subst_binder = f_subst -> 'a -> f_subst * 'a (* -------------------------------------------------------------------- *) val f_subst_init : ?freshen:bool - -> ?tu:ty Muid.t + -> ?tu:ty TyUni.Muid.t -> ?tv:ty Mid.t + -> ?tw:tcwitness list Mid.t + -> ?tw_uni:tcwitness TcUni.Muid.t -> ?esloc:expr Mid.t -> unit -> f_subst (* -------------------------------------------------------------------- *) module Tuni : sig - val univars : ty -> Suid.t - val subst1 : (uid * ty) -> f_subst - val subst : ty Muid.t -> f_subst - val subst_dom : ty Muid.t -> dom -> dom - val occurs : uid -> ty -> bool - val fv : ty -> Suid.t + val univars : ty -> TyUni.Suid.t + val subst1 : (tyuni * ty) -> f_subst + val subst : ?tw_uni:tcwitness TcUni.Muid.t -> ty TyUni.Muid.t -> f_subst + val subst_dom : ty TyUni.Muid.t -> dom -> dom + val occurs : tyuni -> ty -> bool + val fv : ty -> TyUni.Suid.t end (* -------------------------------------------------------------------- *) module Tvar : sig - val init : EcIdent.t list -> ty list -> ty Mid.t - val subst1 : (EcIdent.t * ty) -> ty -> ty - val subst : ty Mid.t -> ty -> ty - val f_subst : freshen:bool -> EcIdent.t list -> ty list -> form -> form + val init : (EcIdent.t * etyarg) list -> etyarg Mid.t + val subst1 : (EcIdent.t * etyarg) -> ty -> ty + val subst : etyarg Mid.t -> ty -> ty + val subst_etyarg : etyarg Mid.t -> etyarg -> etyarg + val subst_tc : etyarg Mid.t -> typeclass -> typeclass + + val f_subst : freshen:bool -> (EcIdent.t * etyarg) list -> form -> form end (* -------------------------------------------------------------------- *) @@ -55,11 +59,11 @@ val add_elocal : (EcIdent.t * ty) subst_binder val add_elocals : (EcIdent.t * ty) list subst_binder val bind_elocal : f_subst -> EcIdent.t -> expr -> f_subst - (* -------------------------------------------------------------------- *) -val ty_subst : ty substitute -val e_subst : expr substitute -val s_subst : stmt substitute +val ty_subst : ty substitute +val etyarg_subst : etyarg substitute +val e_subst : expr substitute +val s_subst : stmt substitute (* -------------------------------------------------------------------- *) module Fsubst : sig @@ -68,8 +72,10 @@ module Fsubst : sig val f_subst_init : ?freshen:bool - -> ?tu:ty Muid.t + -> ?tu:ty TyUni.Muid.t -> ?tv:ty Mid.t + -> ?tw:tcwitness list Mid.t + -> ?tw_uni:tcwitness TcUni.Muid.t -> ?esloc:expr Mid.t -> unit -> f_subst @@ -85,11 +91,7 @@ module Fsubst : sig val f_subst_local : EcIdent.t -> form -> form -> form val f_subst_mem : EcIdent.t -> EcIdent.t -> form -> form - - val f_subst_tvar : - freshen:bool -> - EcTypes.ty EcIdent.Mid.t -> - form -> form + val f_subst_tvar : freshen:bool -> etyarg Mid.t -> form -> form val add_binding : binding subst_binder val add_bindings : bindings subst_binder diff --git a/src/ecDecl.ml b/src/ecDecl.ml index 2dbd8b27c6..aa544e4b67 100644 --- a/src/ecDecl.ml +++ b/src/ecDecl.ml @@ -5,13 +5,12 @@ open EcTypes open EcCoreFol module Sp = EcPath.Sp -module TC = EcTypeClass module BI = EcBigInt module Ssym = EcSymbols.Ssym module CS = EcCoreSubst (* -------------------------------------------------------------------- *) -type ty_param = EcIdent.t +type ty_param = EcIdent.t * typeclass list type ty_params = ty_param list type ty_pctor = [ `Int of int | `Named of ty_params ] @@ -27,33 +26,36 @@ type ty_dtype = { tydt_schcase : EcCoreFol.form; } -type ty_body = - | Concrete of EcTypes.ty - | Abstract - | Datatype of ty_dtype - | Record of ty_record +type ty_body = [ + | `Concrete of EcTypes.ty + | `Abstract of typeclass list + | `Datatype of ty_dtype + | `Record of ty_record +] type tydecl = { - tyd_params : ty_params; - tyd_type : ty_body; - tyd_loca : locality; + tyd_params : ty_params; + tyd_type : ty_body; + tyd_resolve : bool; + tyd_loca : locality; + tyd_subtype : (EcTypes.ty * EcCoreFol.form) option; } let tydecl_as_concrete (td : tydecl) = - match td.tyd_type with Concrete x -> Some x | _ -> None + match td.tyd_type with `Concrete x -> Some x | _ -> None let tydecl_as_abstract (td : tydecl) = - match td.tyd_type with Abstract -> Some () | _ -> None + match td.tyd_type with `Abstract x -> Some x | _ -> None let tydecl_as_datatype (td : tydecl) = - match td.tyd_type with Datatype x -> Some x | _ -> None + match td.tyd_type with `Datatype x -> Some x | _ -> None let tydecl_as_record (td : tydecl) = - match td.tyd_type with Record (x, y) -> Some (x, y) | _ -> None + match td.tyd_type with `Record x -> Some x | _ -> None (* -------------------------------------------------------------------- *) -let abs_tydecl ?(params = `Int 0) lc = +let abs_tydecl ?(resolve = true) ?(tc = []) ?(params = `Int 0) lc = let params = match params with | `Named params -> @@ -61,15 +63,27 @@ let abs_tydecl ?(params = `Int 0) lc = | `Int n -> let fmt = fun x -> Printf.sprintf "'%s" x in List.map - (fun x -> (EcIdent.create x)) + (fun x -> (EcIdent.create x, [])) (EcUid.NameGen.bulk ~fmt n) in - { tyd_params = params; tyd_type = Abstract; tyd_loca = lc; } + { tyd_params = params; + tyd_type = `Abstract tc; + tyd_resolve = resolve; + tyd_loca = lc; + tyd_subtype = None; } + +(* -------------------------------------------------------------------- *) +let etyargs_of_tparams (tps : ty_params) : etyarg list = + List.map (fun (a, tcs) -> + let ety = + List.mapi (fun offset _ -> TCIAbstract { support = `Var a; offset; lift = [] }) tcs + in (tvar a, ety) + ) tps (* -------------------------------------------------------------------- *) -let ty_instantiate (params : ty_params) (args : ty list) (ty : ty) = - let subst = CS.Tvar.init params args in +let ty_instanciate (params : ty_params) (args : etyarg list) (ty : ty) = + let subst = CS.Tvar.init (List.combine (List.map fst params) args) in CS.Tvar.subst subst ty (* -------------------------------------------------------------------- *) @@ -87,7 +101,7 @@ and opbody = | OP_Proj of EcPath.path * int * int | OP_Fix of opfix | OP_Exn of ty list - | OP_TC + | OP_TC of EcPath.path * string and prbody = | PR_Plain of form @@ -187,6 +201,11 @@ let is_rcrd op = | OB_oper (Some (OP_Record _)) -> true | _ -> false +let is_tc_op op = + match op.op_kind with + | OB_oper (Some (OP_TC _)) -> true + | _ -> false + let is_fix op = match op.op_kind with | OB_oper (Some (OP_Fix _)) -> true @@ -268,6 +287,11 @@ let operator_as_prind (op : operator) = | OB_pred (Some (PR_Ind pri)) -> pri | _ -> assert false +let operator_as_tc (op : operator) = + match op.op_kind with + | OB_oper (Some (OP_TC (tcpath, name))) -> (tcpath, name) + | _ -> assert false + let operator_as_exception (op : operator) = match op.op_kind with | OB_oper (Some (OP_Exn exn_dom)) -> @@ -279,47 +303,30 @@ let operator_of_exception (ex: exception_) = mk_op ~opaque: optransparent [] ty (Some (OP_Exn ex.exn_dom)) ex.exn_loca (* -------------------------------------------------------------------- *) -let axiomatized_op - ?(nargs = 0) - ?(nosmt = false) - (path : EcPath.path) - ((tparams, axbd) : ty_params * form) - (lc : locality) - : axiom -= - let axbd, axpm = - let bdpm = tparams in - let axpm = List.map EcIdent.fresh bdpm in - (CS.Tvar.f_subst ~freshen:true bdpm (List.map EcTypes.tvar axpm) axbd, - axpm) - in - - let args, axbd = - match axbd.f_node with - | Fquant (Llambda, bds, axbd) -> - let bds, flam = List.split_at nargs bds in - (bds, f_lambda flam axbd) - | _ -> [], axbd - in - - let opargs = List.map (fun (x, ty) -> f_local x (gty_as_ty ty)) args in - let tyargs = List.map EcTypes.tvar axpm in - let op = f_op path tyargs (toarrow (List.map f_ty opargs) axbd.EcAst.f_ty) in - let op = f_app op opargs axbd.f_ty in - let axspec = f_forall args (f_eq op axbd) in - - { ax_tparams = axpm; - ax_spec = axspec; - ax_kind = `Axiom (Ssym.empty, false); - ax_loca = lc; - ax_smt = not nosmt; } - -(* -------------------------------------------------------------------- *) -type typeclass = { - tc_prt : EcPath.path option; - tc_ops : (EcIdent.t * EcTypes.ty) list; - tc_axs : (EcSymbols.symbol * EcCoreFol.form) list; - tc_loca: is_local; +(* A parent typeclass plus an optional op renaming. The renaming maps + the parent's op names (recursively, including its own ancestors) + to op names declared in or inherited by the subclass — used to + project a subclass instance into a parent instance with different + operator names. Empty list = plain inheritance. *) +type tc_decl = { + tc_tparams : ty_params; + (* Per parent-edge: the typeclass instantiation, an optional label + (defaulting to the parent's bare class name), and the rename + clause. The label disambiguates obligations reaching the + instance through multiple parent edges of the same class. *) + tc_prts : (typeclass * EcSymbols.symbol + * (EcSymbols.symbol * EcSymbols.symbol) list) list; + tc_ops : (EcIdent.t * EcTypes.ty) list; + tc_axs : (EcSymbols.symbol * EcCoreFol.form) list; + tc_loca : is_local; + (* Origin tracking for [tc_ops]: maps each op's local name to its + "canonical source" — the (ancestor class path, original op name) + pair where this op was first introduced. User-declared ops have + origin [(self_path, local_name)]; auto-promoted renamed ops + inherit origin from the ancestor whose op they alias. Used by + downstream classes' auto-import to dedupe ops reached via + multiple inheritance paths. *) + tc_ops_origin : (EcSymbols.symbol * (EcPath.path * EcSymbols.symbol)) list; } (* -------------------------------------------------------------------- *) diff --git a/src/ecDecl.mli b/src/ecDecl.mli index db24d1950b..ba2305e039 100644 --- a/src/ecDecl.mli +++ b/src/ecDecl.mli @@ -1,12 +1,13 @@ (* -------------------------------------------------------------------- *) open EcUtils +open EcAst open EcSymbols open EcBigInt open EcTypes open EcCoreFol (* -------------------------------------------------------------------- *) -type ty_param = EcIdent.t +type ty_param = EcIdent.t * typeclass list type ty_params = ty_param list type ty_pctor = [ `Int of int | `Named of ty_params ] @@ -22,27 +23,40 @@ type ty_dtype = { tydt_schcase : EcCoreFol.form; } -type ty_body = - | Concrete of EcTypes.ty - | Abstract - | Datatype of ty_dtype - | Record of ty_record +and ty_body = [ + | `Concrete of EcTypes.ty + | `Abstract of typeclass list + | `Datatype of ty_dtype + | `Record of ty_record +] type tydecl = { - tyd_params : ty_params; - tyd_type : ty_body; - tyd_loca : locality; + tyd_params : ty_params; + tyd_type : ty_body; + tyd_resolve : bool; + tyd_loca : locality; + (* For [subtype]-declared types: the carrier and the predicate. The + declared type itself stays [tyd_type = `Abstract []], because a + subtype is semantically a fresh abstract type — but its dependency + on free type variables (when declared inside a section) must be + visible to the section-close machinery. [tydecl_fv] unions the + carrier+predicate fv into the type's fv when this field is set, + so a subtype declared inside [section. declare type c <: tc.] gets + the section's tparams added at close, just like type aliases do. *) + tyd_subtype : (EcTypes.ty * EcCoreFol.form) option; } val tydecl_as_concrete : tydecl -> EcTypes.ty option -val tydecl_as_abstract : tydecl -> unit option +val tydecl_as_abstract : tydecl -> typeclass list option val tydecl_as_datatype : tydecl -> ty_dtype option -val tydecl_as_record : tydecl -> (form * (EcSymbols.symbol * EcTypes.ty) list) option +val tydecl_as_record : tydecl -> ty_record option + +val abs_tydecl : ?resolve:bool -> ?tc:typeclass list -> ?params:ty_pctor -> locality -> tydecl -val abs_tydecl : ?params:ty_pctor -> locality -> tydecl +val etyargs_of_tparams : ty_params -> etyarg list -val ty_instantiate : ty_params -> ty list -> ty -> ty +val ty_instanciate : ty_params -> etyarg list -> ty -> ty (* -------------------------------------------------------------------- *) type exception_ = { @@ -67,7 +81,7 @@ and opbody = | OP_Proj of EcPath.path * int * int | OP_Fix of opfix | OP_Exn of ty list - | OP_TC + | OP_TC of EcPath.path * string and prbody = | PR_Plain of form @@ -126,6 +140,7 @@ val is_oper : operator -> bool val is_ctor : operator -> bool val is_proj : operator -> bool val is_rcrd : operator -> bool +val is_tc_op : operator -> bool val is_fix : operator -> bool val is_abbrev : operator -> bool val is_prind : operator -> bool @@ -145,6 +160,7 @@ val operator_as_rcrd : operator -> EcPath.path val operator_as_proj : operator -> EcPath.path * int * int val operator_as_fix : operator -> opfix val operator_as_prind : operator -> prind +val operator_as_tc : operator -> EcPath.path * string val operator_as_exception : operator -> exception_ val operator_of_exception : exception_ -> operator @@ -165,20 +181,14 @@ val is_axiom : axiom_kind -> bool val is_lemma : axiom_kind -> bool (* -------------------------------------------------------------------- *) -val axiomatized_op : - ?nargs: int - -> ?nosmt:bool - -> EcPath.path - -> (ty_params * form) - -> locality - -> axiom - -(* -------------------------------------------------------------------- *) -type typeclass = { - tc_prt : EcPath.path option; - tc_ops : (EcIdent.t * EcTypes.ty) list; - tc_axs : (EcSymbols.symbol * form) list; - tc_loca: is_local; +type tc_decl = { + tc_tparams : ty_params; + tc_prts : (typeclass * EcSymbols.symbol + * (EcSymbols.symbol * EcSymbols.symbol) list) list; + tc_ops : (EcIdent.t * EcTypes.ty) list; + tc_axs : (EcSymbols.symbol * EcCoreFol.form) list; + tc_loca : is_local; + tc_ops_origin : (EcSymbols.symbol * (EcPath.path * EcSymbols.symbol)) list; } (* -------------------------------------------------------------------- *) diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 8a449a7797..1a80f8f23e 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -18,8 +18,8 @@ module Msym = EcSymbols.Msym module Mp = EcPath.Mp module Sid = EcIdent.Sid module Mid = EcIdent.Mid -module TC = EcTypeClass module Mint = EcMaps.Mint +module Mstr = EcMaps.Mstr (* -------------------------------------------------------------------- *) type 'a suspension = { @@ -89,7 +89,8 @@ type mc = { mc_operators : (ipath * EcDecl.operator) MMsym.t; mc_axioms : (ipath * EcDecl.axiom) MMsym.t; mc_theories : (ipath * ctheory) MMsym.t; - mc_typeclasses: (ipath * typeclass) MMsym.t; + mc_typeclasses: (ipath * tc_decl) MMsym.t; + mc_tcinstances: (ipath * tcinstance) MMsym.t; mc_rwbase : (ipath * path) MMsym.t; mc_components : ipath MMsym.t; } @@ -183,8 +184,7 @@ type preenv = { env_memories : EcMemory.memtype Mmem.t; env_actmem : actmem option; env_abs_st : EcModules.abs_uses Mid.t; - env_tci : ((ty_params * ty) * tcinstance) list; - env_tc : TC.graph; + env_tci : (path option * tcinstance) list; env_rwbase : Sp.t Mip.t; env_atbase : atbase Msym.t; env_redbase : mredinfo; @@ -211,12 +211,6 @@ and scope = [ | `Fun of EcPath.xpath ] -and tcinstance = [ - | `Ring of EcDecl.ring - | `Field of EcDecl.field - | `General of EcPath.path -] - and redinfo = { ri_priomap : (EcTheory.rule list) Mint.t; ri_list : (EcTheory.rule list) Lazy.t; } @@ -282,6 +276,7 @@ let empty_mc params = { mc_variables = MMsym.empty; mc_functions = MMsym.empty; mc_typeclasses= MMsym.empty; + mc_tcinstances= MMsym.empty; mc_rwbase = MMsym.empty; mc_components = MMsym.empty; } @@ -313,7 +308,6 @@ let empty gstate = env_actmem = None; env_abs_st = Mid.empty; env_tci = []; - env_tc = TC.Graph.empty; env_rwbase = Mip.empty; env_atbase = Msym.empty; env_redbase = Mrd.empty; @@ -512,12 +506,13 @@ module MC = struct | IPIdent _ -> assert false | IPPath p -> p - let _downpath_for_tydecl = _downpath_for_th - let _downpath_for_modsig = _downpath_for_th - let _downpath_for_operator = _downpath_for_th - let _downpath_for_axiom = _downpath_for_th - let _downpath_for_typeclass = _downpath_for_th - let _downpath_for_rwbase = _downpath_for_th + let _downpath_for_tydecl = _downpath_for_th + let _downpath_for_modsig = _downpath_for_th + let _downpath_for_operator = _downpath_for_th + let _downpath_for_axiom = _downpath_for_th + let _downpath_for_typeclass = _downpath_for_th + let _downpath_for_tcinstance = _downpath_for_th + let _downpath_for_rwbase = _downpath_for_th (* ------------------------------------------------------------------ *) let _params_of_path p env = @@ -789,16 +784,16 @@ module MC = struct let loca = tyd.tyd_loca in match tyd.tyd_type with - | Concrete _ -> mc - | Abstract -> mc + | `Concrete _ -> mc + | `Abstract _ -> mc - | Datatype dtype -> + | `Datatype dtype -> let cs = dtype.tydt_ctors in let schelim = dtype.tydt_schelim in let schcase = dtype.tydt_schcase in - let params = List.map tvar tyd.tyd_params in + let params = etyargs_of_tparams tyd.tyd_params in let for1 i (c, aty) = - let aty = EcTypes.toarrow aty (tconstr mypath params) in + let aty = toarrow aty (tconstr_tc mypath params) in let aty = EcSubst.freshen_type (tyd.tyd_params, aty) in let cop = mk_op ~opaque:optransparent (fst aty) (snd aty) @@ -836,12 +831,12 @@ module MC = struct _up_operator candup mc name (ipath name, op) ) mc projs - | Record (scheme, fields) -> - let params = List.map tvar tyd.tyd_params in + | `Record (scheme, fields) -> + let params = etyargs_of_tparams tyd.tyd_params in let nfields = List.length fields in let cfields = let for1 i (f, aty) = - let aty = EcTypes.tfun (tconstr mypath params) aty in + let aty = tfun (tconstr_tc mypath params) aty in let aty = EcSubst.freshen_type (tyd.tyd_params, aty) in let fop = mk_op ~opaque:optransparent (fst aty) (snd aty) (Some (OP_Proj (mypath, i, nfields))) loca in @@ -862,7 +857,7 @@ module MC = struct let stname = Printf.sprintf "mk_%s" x in let stop = - let stty = toarrow (List.map snd fields) (tconstr mypath params) in + let stty = toarrow (List.map snd fields) (tconstr_tc mypath params) in let stty = EcSubst.freshen_type (tyd.tyd_params, stty) in mk_op ~opaque:optransparent (fst stty) (snd stty) (Some (OP_Record mypath)) loca in @@ -912,24 +907,31 @@ module MC = struct let self = EcIdent.create "'self" in - let tsubst =EcSubst.add_tydef EcSubst.empty mypath ([], tvar self) in + let tsubst =EcSubst.add_tydef EcSubst.empty mypath ([], tvar self, []) in let operators = let on1 (opid, optype) = let opname = EcIdent.name opid in let optype = EcSubst.subst_ty tsubst optype in - let opdecl = - mk_op ~opaque:optransparent [(self)] - optype (Some OP_TC) loca - in (opid, xpath opname, optype, opdecl) + let tcargs = etyargs_of_tparams tc.tc_tparams in + let opargs = (self, [{tc_name = mypath; tc_args = tcargs;}]) in + let opargs = tc.tc_tparams @ [opargs] in + let opdecl = OP_TC (mypath, opname) in + let opdecl = mk_op ~opaque:optransparent opargs optype (Some opdecl) loca in + (opid, xpath opname, optype, opdecl) in List.map on1 tc.tc_ops in let fsubst = + let op_etyargs = + let tparams = + tc.tc_tparams + @ [(self, [{tc_name = mypath; tc_args = etyargs_of_tparams tc.tc_tparams}])] + in EcDecl.etyargs_of_tparams tparams in List.fold_left (fun s (x, xp, xty, _) -> - let fop = EcCoreFol.f_op xp [tvar self] xty in + let fop = EcCoreFol.f_op_tc xp op_etyargs xty in EcSubst.add_flocal s x fop) tsubst operators @@ -938,8 +940,11 @@ module MC = struct let axioms = List.map (fun (x, ax) -> + let tcargs = etyargs_of_tparams tc.tc_tparams in + let axargs = (self, [{tc_name = mypath; tc_args = tcargs}]) in + let axargs = tc.tc_tparams @ [axargs] in let ax = EcSubst.subst_form fsubst ax in - (x, { ax_tparams = [(self)]; + (x, { ax_tparams = axargs; ax_spec = ax; ax_kind = `Lemma; ax_loca = loca; @@ -963,6 +968,20 @@ module MC = struct let import_typeclass p ax env = import (_up_typeclass true) (IPPath p) ax env + (* -------------------------------------------------------------------- *) + let lookup_tcinstance qnx env = + match lookup (fun mc -> mc.mc_tcinstances) qnx env with + | None -> lookup_error (`QSymbol qnx) + | Some (p, (args, obj)) -> (_downpath_for_tcinstance env p args, obj) + + let _up_tcinstance candup mc x obj= + if not candup && MMsym.last x mc.mc_tcinstances <> None then + raise (DuplicatedBinding x); + { mc with mc_tcinstances = MMsym.add x obj mc.mc_tcinstances } + + let import_tcinstance p tci env = + import (_up_tcinstance true) (IPPath p) tci env + (* -------------------------------------------------------------------- *) let lookup_rwbase qnx env = match lookup (fun mc -> mc.mc_rwbase) qnx env with @@ -1115,6 +1134,16 @@ module MC = struct else (add2mc _up_theory xsubth cth mc, None) + | Th_typeclass (x, tc) -> + (add2mc _up_typeclass x tc mc, None) + + | Th_instance (x, tci) -> + let mc = + x |> Option.fold + ~none:mc + ~some:(fun x -> add2mc _up_tcinstance x tci mc) + in (mc, None) + | Th_baserw (x, _) -> (add2mc _up_rwbase x (expath x) mc, None) @@ -1122,8 +1151,7 @@ module MC = struct (* FIXME:ALIAS *) (mc, None) - | Th_export _ | Th_addrw _ | Th_instance _ - | Th_auto _ | Th_reduction _ -> + | Th_export _ | Th_addrw _ | Th_auto _ | Th_reduction _ -> (mc, None) in @@ -1202,6 +1230,9 @@ module MC = struct and bind_typeclass x tc env = bind _up_typeclass x tc env + and bind_tcinstance x tci env = + bind _up_tcinstance x tci env + and bind_rwbase x p env = bind _up_rwbase x p env end @@ -1387,7 +1418,7 @@ let gen_all fmc flk ?(check = fun _ _ -> true) ?name (env : env) = (* ------------------------------------------------------------------ *) module TypeClass = struct - type t = typeclass + type t = tc_decl let by_path_opt (p : EcPath.path) (env : env) = omap @@ -1400,39 +1431,77 @@ module TypeClass = struct | Some obj -> obj let add (p : EcPath.path) (env : env) = - let obj = by_path p env in - MC.import_typeclass p obj env + MC.import_typeclass p (by_path p env) env - let rebind name tc env = - let env = MC.bind_typeclass name tc env in - match tc.tc_prt with - | None -> env - | Some prt -> - let myself = EcPath.pqname (root env) name in - { env with env_tc = TC.Graph.add ~src:myself ~dst:prt env.env_tc } + let rebind (name : symbol) (tc : t) (env : env) = + MC.bind_typeclass name tc env - let lookup qname (env : env) = + let bind ?(import = true) (name : symbol) (tc : t) (env : env) = + let env = if import then rebind name tc env else env in + { env with + env_item = mkitem ~import (Th_typeclass (name, tc)) :: env.env_item } + + let lookup (qname : qsymbol) (env : env) = MC.lookup_typeclass qname env - let lookup_opt name env = + let lookup_opt (name : qsymbol) (env : env) = try_lf (fun () -> lookup name env) - let lookup_path name env = + let lookup_path (name : qsymbol) (env : env) = fst (lookup name env) +end - let graph (env : env) = - env.env_tc +(* ------------------------------------------------------------------ *) +module TcInstance = struct + type t = tcinstance + + let by_path_opt (p : EcPath.path) (env : env) = + omap + check_not_suspended + (MC.by_path (fun mc -> mc.mc_tcinstances) (IPPath p) env) - let bind_instance ty cr tci = - (ty, cr) :: tci + let by_path (p : EcPath.path) (env : env) = + match by_path_opt p env with + | None -> lookup_error (`Path p) + | Some obj -> obj - let add_instance ?(import = true) ty cr lc env = - let item = Th_instance (ty, cr, lc) in + let add (p : EcPath.path) (env : env) = + MC.import_tcinstance p (by_path p env) env + + let bind_instance (path : path option) (tci : t) (env : _) = + (path, tci) :: env + + let rebind (name : symbol option) (tci : t) (env : env) = + let env = + name |> Option.fold ~none:env ~some:(fun name -> + MC.bind_tcinstance name tci env) + in + let path = + Option.map + (fun name -> EcPath.pqname (root env) name) + name + in { env with env_tci = bind_instance path tci env.env_tci } + + let bind ?(import = true) (name : symbol option) (tci : t) (env : env) = + let env = + if import then rebind name tci env else env in { env with - env_tci = bind_instance ty cr env.env_tci; - env_item = mkitem ~import item :: env.env_item; } + env_item = mkitem ~import (Th_instance (name, tci)) :: env.env_item } + + let lookup qname (env : env) = + MC.lookup_tcinstance qname env - let get_instances env = env.env_tci + let lookup_opt (name : qsymbol) (env : env) = + try_lf (fun () -> lookup name env) + + let lookup_path (name : qsymbol) (env : env) = + fst (lookup name env) + + let get_instances (env : env) = + env.env_tci + + let get_all (env : env) : (path option * t) list = + env.env_tci end (* -------------------------------------------------------------------- *) @@ -2528,7 +2597,7 @@ module Ty = struct let add (p : EcPath.path) (env : env) = let obj = by_path p env in - MC.import_tydecl p obj env + MC.import_tydecl p obj env let lookup ?unique (qname : qsymbol) (env : env) = MC.lookup_tydecl ?unique qname env @@ -2541,14 +2610,14 @@ module Ty = struct let defined (name : EcPath.path) (env : env) = match by_path_opt name env with - | Some { tyd_type = Concrete _ } -> true + | Some { tyd_type = `Concrete _ } -> true | _ -> false - let unfold (name : EcPath.path) (args : EcTypes.ty list) (env : env) = + let unfold (name : EcPath.path) (args : etyarg list) (env : env) = match by_path_opt name env with - | Some ({ tyd_type = Concrete body } as tyd) -> + | Some ({ tyd_type = `Concrete body } as tyd) -> Tvar.subst - (Tvar.init tyd.tyd_params args) + (Tvar.init (List.combine (List.map fst tyd.tyd_params) args)) body | _ -> raise (LookupFailure (`Path name)) @@ -2557,13 +2626,11 @@ module Ty = struct | Tconstr (p, tys) when defined p env -> hnorm (unfold p tys env) env | _ -> ty - let rec ty_hnorm (ty : ty) (env : env) = match ty.ty_node with | Tconstr (p, tys) when defined p env -> ty_hnorm (unfold p tys env) env | _ -> ty - let rec decompose_fun (ty : ty) (env : env) : dom * ty = match (hnorm ty env).ty_node with | Tfun (ty1, ty2) -> @@ -2582,14 +2649,14 @@ module Ty = struct match ty.ty_node with | Tconstr (p, tys) -> begin match by_path_opt p env with - | Some ({ tyd_type = (Datatype _ | Record _) as body }) -> + | Some ({ tyd_type = (`Datatype _ | `Record _) as body }) -> let prefix = EcPath.prefix p in let basename = EcPath.basename p in let basename = match body, mode with - | Record _, (`Ind | `Case) -> basename ^ "_ind" - | Datatype _, `Ind -> basename ^ "_ind" - | Datatype _, `Case -> basename ^ "_case" + | `Record _, (`Ind | `Case) -> basename ^ "_ind" + | `Datatype _, `Ind -> basename ^ "_ind" + | `Datatype _, `Case -> basename ^ "_case" | _, _ -> assert false in Some (EcPath.pqoname prefix basename, tys) @@ -2602,11 +2669,11 @@ module Ty = struct | Tconstr (p, tys) -> Some (p, oget (by_path_opt p env), tys) | _ -> None - let rebind name ty env = - MC.bind_tydecl name ty env + let rebind (name : symbol) (tyd : t) (env : env) = + MC.bind_tydecl name tyd env let bind ?(import = true) name ty env = - let env = rebind name ty env in + let env = if import then rebind name ty env else env in { env with env_item = mkitem ~import (Th_type (name, ty)) :: env.env_item } @@ -2678,7 +2745,6 @@ module Op = struct let core_reduce ?(mode = `IfTransparent) ?(nargs = 0) env p = let op = oget (by_path_opt p env) in - match op.op_kind with | OB_oper (Some (OP_Plain f)) | OB_pred (Some (PR_Plain f)) -> begin @@ -2706,8 +2772,145 @@ module Op = struct else false let reduce ?mode ?nargs env p tys = - let op, f = core_reduce ?mode ?nargs env p in - Tvar.f_subst ~freshen:true op.op_tparams tys f + let op, form = core_reduce ?mode ?nargs env p in + Tvar.f_subst ~freshen:true + (List.combine (List.map fst op.op_tparams) tys) + form + + (* Resolve a TC class op application to the form that realises it on + the witness's carrier. Returns the substituted form (carrier + tparams instantiated at the witness's etyargs). Internal helper: + [tc_reduce] is the public wrapper that handles the abstract-rename + fallback. *) + let tc_core_reduce ?(strict = false) (env : env) (p : path) (tys : etyarg list) + : form + = + let op = by_path p env in + + if not (is_tc_op op) then + raise NotReducible; + + let opname = snd (EcDecl.operator_as_tc op) in + + (* Last type application is the TC parameter. We extract the + type-class information from the witness. *) + let _, (_, tcw) = List.betail tys in + + let finalise (tci_target : tcinstance) (symbols : form Mstr.t) : form = + let body = Mstr.find opname symbols in + let subst = + List.fold_left + (fun subst (a, ety) -> + let ety = EcSubst.subst_etyarg subst ety in + EcSubst.add_tyvar subst a ety) + EcSubst.empty + (List.combine + (List.map fst tci_target.tci_params) + (let tciargs = + match tcw with + | [TCIConcrete { etyargs; _ }] -> etyargs + | _ -> [] + in tciargs)) + in EcSubst.subst_form subst body + in + + match as_seq1 tcw with + | TCIConcrete { path = tcipath; lift; _ } -> begin + let tci = TcInstance.by_path tcipath env in + + (* The witness's [lift] is a path through the parent DAG: each + element selects which parent edge to take. We follow it via + [tci_parents] (the synthesised parent instance paths). For + single-parent classes the path is always all-zeros; for + multi-parent (factory) classes the path encodes which + parent is taken at each step. + + Fallback when [tci_parents] is empty (manually-declared + instance with no synthesis tracking): walk the TC parent + chain naively and search the database for a matching + ancestor instance. This loses path-disambiguation but + covers the legacy single-parent case. *) + let resolve_lifted () = + if lift = [] then None + else + let rec walk tci = function + | [] -> Some tci + | i :: rest -> + match List.nth_opt tci.tci_parents i with + | None -> None + | Some parent_path -> + let parent_tci = TcInstance.by_path parent_path env in + walk parent_tci rest + in + match walk tci lift with + | Some target_tci -> begin + match target_tci.tci_instance with + | `General (_, Some sym) -> Some (target_tci, sym) + | _ -> None + end + | None -> + (* Fallback: walk the TC parent chain (taking parent #0 + at each step — equivalent to the all-zeros path) and + search the database for the matching ancestor instance + on the same carrier. *) + let walk_up_tc (tc : typeclass) (path : int list) : typeclass option = + let rec aux tc = function + | [] -> Some tc + | i :: rest -> + let decl = TypeClass.by_path tc.tc_name env in + match List.nth_opt decl.tc_prts i with + | None -> None + | Some (parent, _lbl, _ren) -> + let subst = + List.fold_left2 + (fun s (a, _) etyarg -> Mid.add a etyarg s) + Mid.empty decl.tc_tparams tc.tc_args in + let parent = EcCoreSubst.Tvar.subst_tc subst parent in + aux parent rest + in aux tc path in + match tci.tci_instance with + | `General (tgp, _) -> begin + match walk_up_tc tgp lift with + | None -> None + | Some target -> + let carrier = tci.tci_type in + List.fold_left (fun acc (_, tci_existing) -> + match acc with + | Some _ -> acc + | None -> + match tci_existing.tci_instance with + | `General (tgp', Some sym) + when EcPath.p_equal tgp'.tc_name target.tc_name + && EcTypes.ty_equal tci_existing.tci_type carrier -> + Some (tci_existing, sym) + | _ -> None) + None (TcInstance.get_all env) + end + | _ -> None in + + match resolve_lifted () with + | Some (tci_target, symbols) -> + if strict && not tci_target.tci_reducible then + raise NotReducible; + finalise tci_target symbols + | None -> + match tci.tci_instance with + | `General (_, Some symbols) -> + if strict && not tci.tci_reducible then + raise NotReducible; + finalise tci symbols + | _ -> raise NotReducible + end + + | _ -> + raise NotReducible + + let tc_reducible ?(strict = false) (env : env) (p : path) (tys : etyarg list) = + try ignore (tc_core_reduce ~strict env p tys); true + with NotReducible -> false + + let tc_reduce ?(strict = false) (env : env) (p : path) (tys : etyarg list) = + tc_core_reduce ~strict env p tys let is_projection env p = try EcDecl.is_proj (by_path p env) @@ -2717,6 +2920,25 @@ module Op = struct try EcDecl.is_rcrd (by_path p env) with LookupFailure _ -> false + let is_tc_op env p = + try EcDecl.is_tc_op (by_path p env) + with LookupFailure _ -> false + + let tc_op_realised_by (env : env) (tcop : path) (concrete : path) = + if not (is_tc_op env tcop) then false + else + let tcop_basename = EcPath.basename tcop in + List.exists (fun (_, tci) -> + match tci.EcTheory.tci_instance with + | `General (_, Some sym) -> + (match EcMaps.Mstr.find_opt tcop_basename sym with + | Some { f_node = Fop (p, _); _ } -> EcPath.p_equal p concrete + | Some { f_node = Fapp ({ f_node = Fop (p, _); _ }, _); _ } -> + EcPath.p_equal p concrete + | _ -> false) + | _ -> false) + (TcInstance.get_all env) + let is_dtype_ctor ?nargs env p = try match (by_path p env).op_kind with @@ -2825,10 +3047,10 @@ module Ax = struct let rebind name ax env = MC.bind_axiom name ax env - let instantiate p tys env = + let instanciate p tys env = match by_path_opt p env with | Some ({ ax_spec = f } as ax) -> - Tvar.f_subst ~freshen:true ax.ax_tparams tys f + Tvar.f_subst ~freshen:true (List.combine (List.map fst ax.ax_tparams) tys) f | _ -> raise (LookupFailure (`Path p)) let iter ?name f (env : env) = @@ -2838,22 +3060,6 @@ module Ax = struct gen_all (fun mc -> mc.mc_axioms) MC.lookup_axioms ?check ?name env end -(* -------------------------------------------------------------------- *) -module Algebra = struct - let bind_ring ty cr env = - assert (Mid.is_empty ty.ty_fv); - { env with env_tci = - TypeClass.bind_instance ([], ty) (`Ring cr) env.env_tci } - - let bind_field ty cr env = - assert (Mid.is_empty ty.ty_fv); - { env with env_tci = - TypeClass.bind_instance ([], ty) (`Field cr) env.env_tci } - - let add_ring ty cr lc env = TypeClass.add_instance ([], ty) (`Ring cr) lc env - let add_field ty cr lc env = TypeClass.add_instance ([], ty) (`Field cr) lc env -end - (* -------------------------------------------------------------------- *) module Theory = struct type t = ctheory @@ -2937,8 +3143,8 @@ module Theory = struct let xpath x = EcPath.pqname path x in match item.ti_item with - | Th_instance (ty, k, _) -> - TypeClass.bind_instance ty k inst + | Th_instance (name, tci) -> + TcInstance.bind_instance (Option.map xpath name) tci inst | Th_theory (x, cth) when cth.cth_mode = `Concrete -> bind_instance_th (xpath x) inst cth.cth_items @@ -2963,6 +3169,16 @@ module Theory = struct end | _ -> odfl base (tx path base item.ti_item) + (* ------------------------------------------------------------------ *) + let bind_tc_th = + let for1 _path base = function + | Th_typeclass (_, tc) -> + Some (tc :: base) + + | _ -> None + + in bind_base_th for1 + (* ------------------------------------------------------------------ *) let bind_br_th = let for1 path base = function @@ -3040,9 +3256,7 @@ module Theory = struct let env_ntbase = bind_nt_th thname env.env_ntbase items in let env_redbase = bind_rd_th thname env.env_redbase items in let env = - { env with - env_tci ; env_rwbase; - env_atbase; env_ntbase; env_redbase; } + { env with env_tci; env_rwbase; env_atbase; env_ntbase; env_redbase; } in add_restr_th thname env items @@ -3099,6 +3313,9 @@ module Theory = struct | Th_alias (name, path) -> rebind_alias name path env + | Th_typeclass (x, tc) -> + MC.import_typeclass (xpath x) tc env + | Th_addrw _ | Th_instance _ | Th_auto _ | Th_reduction _ -> env diff --git a/src/ecEnv.mli b/src/ecEnv.mli index 04354a391d..a61b92cece 100644 --- a/src/ecEnv.mli +++ b/src/ecEnv.mli @@ -180,7 +180,7 @@ module Ax : sig val iter : ?name:qsymbol -> (path -> t -> unit) -> env -> unit val all : ?check:(path -> t -> bool) -> ?name:qsymbol -> env -> (path * t) list - val instantiate : path -> EcTypes.ty list -> env -> form + val instanciate : path -> etyarg list -> env -> form end (* -------------------------------------------------------------------- *) @@ -328,11 +328,30 @@ module Op : sig val bind : ?import:bool -> symbol -> operator -> env -> env val reducible : ?mode:redmode -> ?nargs:int -> env -> path -> bool - val reduce : ?mode:redmode -> ?nargs:int -> env -> path -> ty list -> form + val reduce : ?mode:redmode -> ?nargs:int -> env -> path -> etyarg list -> form + + (* When [strict = true] (default [false]), only reduce through TC + instances marked [tci_reducible]. Used by the simplifier ([/=], + [norm_cbv]); the matcher and [is_conv] keep [strict = false] so + they always look through concrete witnesses. *) + val tc_reducible : ?strict:bool -> env -> path -> etyarg list -> bool + val tc_reduce : ?strict:bool -> env -> path -> etyarg list -> form + + (* [tc_op_realised_by env tcop concrete] is true iff [tcop] is a + TC-class op and there exists a registered instance whose + symbol-map binds [tcop]'s basename to [concrete]. Used by the + matcher to bridge a pattern with a TC-op head whose carrier + is still a univar to a goal whose head is the registered + realisation, so e.g. [rewrite mul0r] (no TVI) matches goals + containing the structural [polyM]. The lookup is purely + syntactic — the caller must still post the carrier-pinning + unification that makes the bridge sound. *) + val tc_op_realised_by : env -> path -> path -> bool val is_projection : env -> path -> bool val is_record_ctor : env -> path -> bool val is_dtype_ctor : ?nargs:int -> env -> path -> bool + val is_tc_op : env -> path -> bool val is_fix_def : env -> path -> bool val is_abbrev : env -> path -> bool val is_prind : env -> path -> bool @@ -362,16 +381,15 @@ module Ty : sig val bind : ?import:bool -> symbol -> t -> env -> env val defined : path -> env -> bool - val unfold : path -> EcTypes.ty list -> env -> EcTypes.ty - val hnorm : EcTypes.ty -> env -> EcTypes.ty - val decompose_fun : EcTypes.ty -> env -> EcTypes.dom * EcTypes.ty + val unfold : path -> etyarg list -> env -> ty + val hnorm : ty -> env -> ty + val decompose_fun : ty -> env -> EcTypes.dom * ty val get_top_decl : - EcTypes.ty -> env -> (path * EcDecl.tydecl * EcTypes.ty list) option - + EcTypes.ty -> env -> (path * EcDecl.tydecl * etyarg list) option val scheme_of_ty : - [`Ind | `Case] -> EcTypes.ty -> env -> (path * EcTypes.ty list) option + [`Ind | `Case] -> EcTypes.ty -> env -> (path * etyarg list) option val signature : env -> ty -> ty list * ty @@ -382,17 +400,26 @@ end val ty_hnorm : ty -> env -> ty (* -------------------------------------------------------------------- *) -module Algebra : sig - val add_ring : ty -> EcDecl.ring -> is_local -> env -> env - val add_field : ty -> EcDecl.field -> is_local -> env -> env +module TypeClass : sig + type t = tc_decl + + val add : path -> env -> env + val bind : ?import:bool -> symbol -> t -> env -> env + val rebind : symbol -> t -> env -> env + + val by_path : path -> env -> t + val by_path_opt : path -> env -> t option + val lookup : qsymbol -> env -> path * t + val lookup_opt : qsymbol -> env -> (path * t) option + val lookup_path : qsymbol -> env -> path end (* -------------------------------------------------------------------- *) -module TypeClass : sig - type t = typeclass +module TcInstance : sig + type t = tcinstance - val add : path -> env -> env - val graph : env -> EcTypeClass.graph + val add : path -> env -> env + val bind : ?import:bool -> symbol option -> t -> env -> env val by_path : path -> env -> t val by_path_opt : path -> env -> t option @@ -400,8 +427,7 @@ module TypeClass : sig val lookup_opt : qsymbol -> env -> (path * t) option val lookup_path : qsymbol -> env -> path - val add_instance : ?import:bool -> (ty_params * ty) -> tcinstance -> is_local -> env -> env - val get_instances : env -> ((ty_params * ty) * tcinstance) list + val get_all : env -> (path option * t) list end (* -------------------------------------------------------------------- *) diff --git a/src/ecFol.ml b/src/ecFol.ml index 7a9fbf4942..8a97a1e6b4 100644 --- a/src/ecFol.ml +++ b/src/ecFol.ml @@ -191,8 +191,7 @@ let f_mu_x f1 f2 = let proj_distr_ty env ty = match (EcEnv.Ty.hnorm ty env).ty_node with - | Tconstr(_,lty) when List.length lty = 1 -> - List.hd lty + | Tconstr(_, [lty, []]) -> lty | _ -> assert false let f_mu env f1 f2 = @@ -854,7 +853,7 @@ type sform = | SFimp of form * form | SFiff of form * form | SFeq of form * form - | SFop of (EcPath.path * ty list) * (form list) + | SFop of (EcPath.path * etyarg list) * (form list) | SFhoareF of sHoareF | SFhoareS of sHoareS diff --git a/src/ecFol.mli b/src/ecFol.mli index 6be1d1aafc..787c877f38 100644 --- a/src/ecFol.mli +++ b/src/ecFol.mli @@ -226,7 +226,7 @@ type sform = | SFimp of form * form | SFiff of form * form | SFeq of form * form - | SFop of (path * ty list) * (form list) + | SFop of (path * etyarg list) * (form list) | SFhoareF of sHoareF | SFhoareS of sHoareS diff --git a/src/ecHiGoal.ml b/src/ecHiGoal.ml index 93389a275f..83e1c4fcc3 100644 --- a/src/ecHiGoal.ml +++ b/src/ecHiGoal.ml @@ -114,15 +114,16 @@ let process_simplify_info ri (tc : tcenv1) = in { - EcReduction.beta = ri.pbeta; - EcReduction.delta_p = delta_p; - EcReduction.delta_h = delta_h; - EcReduction.zeta = ri.pzeta; - EcReduction.iota = ri.piota; - EcReduction.eta = ri.peta; - EcReduction.logic = if ri.plogic then Some `Full else None; - EcReduction.modpath = ri.pmodpath; - EcReduction.user = ri.puser; + EcReduction.beta = ri.pbeta; + EcReduction.delta_p = delta_p; + EcReduction.delta_h = delta_h; + EcReduction.delta_tc = ri.pdeltatc; + EcReduction.zeta = ri.pzeta; + EcReduction.iota = ri.piota; + EcReduction.eta = ri.peta; + EcReduction.logic = if ri.plogic then Some `Full else None; + EcReduction.modpath = ri.pmodpath; + EcReduction.user = ri.puser; } (*-------------------------------------------------------------------- *) @@ -571,7 +572,7 @@ let process_exacttype qs (tc : tcenv1) = tc_error !!tc "%a" EcEnv.pp_lookup_failure cause in let tys = - List.map (fun a -> EcTypes.tvar a) + List.map (fun (a, _) -> (tvar a, [])) (EcEnv.LDecl.tohyps hyps).h_tvar in let pt = ptglobal ~tys p in @@ -753,8 +754,10 @@ let process_delta ~und_delta ?target ((s :rwside), o, p) tc = in - let ri = { EcReduction.full_red with - delta_p = (fun p -> if Some p = dp then `Force else `IfTransparent)} in + let ri = + let delta_p p = + if Some p = dp then `Force else `IfTransparent + in { EcReduction.full_red with delta_p } in let na = List.length args in match s with @@ -791,9 +794,12 @@ let process_delta ~und_delta ?target ((s :rwside), o, p) tc = match sform_of_form fp with | SFop ((_, tvi), []) -> begin - (* FIXME: TC HOOK *) - let body = Tvar.f_subst ~freshen:true tparams tvi body in - let body = f_app body args topfp.f_ty in + let body = + Tvar.f_subst + ~freshen:true + (List.combine (List.map fst tparams) tvi) + body in + let body = f_app body args topfp.f_ty in try EcReduction.h_red EcReduction.beta_red hyps body with EcEnv.NotReducible -> body end @@ -814,9 +820,13 @@ let process_delta ~und_delta ?target ((s :rwside), o, p) tc = | `RtoL -> let fp = - (* FIXME: TC HOOK *) - let body = Tvar.f_subst ~freshen:true tparams tvi body in - let fp = f_app body args p.f_ty in + let body = + Tvar.f_subst + ~freshen:true + (List.combine (List.map fst tparams) tvi) + body + in + let fp = f_app body args p.f_ty in try EcReduction.h_red EcReduction.beta_red hyps fp with EcEnv.NotReducible -> fp in @@ -1183,7 +1193,7 @@ let process_view1 pe tc = if not meta then raise E.Bailout; let y, yty = - let CPTEnv subst = PT.concretize_env pe.PT.ptev_env in + let CPTEnv (subst, _) = PT.concretize_env pe.PT.ptev_env in snd_map (ty_subst subst) (oget pre) in let fy = EcIdent.fresh y in @@ -1542,7 +1552,10 @@ let rec process_mintros_1 ?(cf = true) ttenv pis gs = end in - let tc = t_ors [t_elimT_ind `Case; t_elim; t_elim_prind `Case] in + let tc = t_ors [ + t_elimT_ind ~reduce:`Full `Case; + t_elim ~reduce:`Full; + t_elim_prind ~reduce:`Full `Case] in let tc = fun g -> try tc g @@ -2176,7 +2189,11 @@ let process_split ?(i : int option) (tc : tcenv1) = let process_elim (pe, qs) tc = let doelim tc = match qs with - | None -> t_or (t_elimT_ind `Ind) t_elim tc + | None -> + t_or + (t_elimT_ind ~reduce:`Full `Ind) + (t_elim ~reduce:`Full) + tc | Some qs -> let qs = { fp_mode = `Implicit; @@ -2222,7 +2239,10 @@ let process_case ?(doeq = false) gp tc = with E.LEMFailure -> try FApi.t_last - (t_ors [t_elimT_ind `Case; t_elim; t_elim_prind `Case]) + (t_ors [ + t_elimT_ind ~reduce:`Full `Case; + t_elim ~reduce:`Full; + t_elim_prind ~reduce:`Full `Case]) (process_move ~doeq gp.pr_view gp.pr_rev tc) with EcCoreGoal.InvalidGoalShape -> diff --git a/src/ecHiInductive.ml b/src/ecHiInductive.ml index 9084f1118a..9a5dae1122 100644 --- a/src/ecHiInductive.ml +++ b/src/ecHiInductive.ml @@ -84,8 +84,10 @@ let trans_datatype (env : EcEnv.env) (name : ptydname) (dt : pdatatype) = let env0 = let myself = { tyd_params = EcUnify.UniEnv.tparams ue; - tyd_type = Abstract; + tyd_type = `Abstract []; + tyd_resolve = true; tyd_loca = lc; + tyd_subtype = None; } in EcEnv.Ty.bind (unloc name) myself env in @@ -131,19 +133,19 @@ let trans_datatype (env : EcEnv.env) (name : ptydname) (dt : pdatatype) = let tdecl = EcEnv.Ty.by_path_opt tname env0 |> odfl (EcDecl.abs_tydecl ~params:(`Named tparams) lc) in - let tyinst = ty_instantiate tdecl.tyd_params targs in + let tyinst = ty_instanciate tdecl.tyd_params targs in match tdecl.tyd_type with - | Abstract -> - List.exists isempty targs + | `Abstract _ -> + List.exists isempty (List.fst targs) - | Concrete ty -> + | `Concrete ty -> isempty_1 [ tyinst ty ] - | Record (_, fields) -> + | `Record (_, fields) -> isempty_1 (List.map (tyinst -| snd) fields) - | Datatype dt -> + | `Datatype dt -> (* FIXME: Inspecting all constructors recursively causes non-termination in some cases. One can have the same limitation as is done for positivity in order to limit this @@ -333,7 +335,7 @@ let trans_matchfix | PPApp ((cname, tvi), _cargs) -> let tvi = tvi |> omap (TT.transtvi env ue) in let filter = fun _ op -> EcDecl.is_ctor op in - let cts = EcUnify.select_op ~filter tvi env (unloc cname) ue ([], None) in + let cts = EcUnify.select_op ~filter tvi env (unloc cname) ue [] in match cts with | [] -> fxerror cname.pl_loc env TT.FXE_CtorUnk @@ -368,7 +370,7 @@ let trans_matchfix let indp, _ = Msym.find x indtbl in let indty = oget (EcEnv.Ty.by_path_opt indp env) in let ind = (oget (EcDecl.tydecl_as_datatype indty)).tydt_ctors in - let codom = tconstr indp (List.map tvar indty.tyd_params) in + let codom = tconstr_tc indp (etyargs_of_tparams indty.tyd_params) in let tys = List.map (fun (_, dom) -> toarrow dom codom) ind in let tys, _ = EcUnify.UniEnv.opentys ue indty.tyd_params None tys in let doargs cty = @@ -380,7 +382,7 @@ let trans_matchfix | PPApp ((cname, tvi), cargs) -> let filter = fun _ op -> EcDecl.is_ctor op in let tvi = tvi |> omap (TT.transtvi env ue) in - let cts = EcUnify.select_op ~filter tvi env (unloc cname) ue ([], None) in + let cts = EcUnify.select_op ~filter tvi env (unloc cname) ue [] in match cts with | [] -> @@ -411,8 +413,8 @@ let trans_matchfix EcUnify.UniEnv.restore ~src:subue ~dst:ue; let ctorty = - let tvi = Some (EcUnify.TVIunamed tvi) in - fst (EcUnify.UniEnv.opentys ue indty.tyd_params tvi ctorty) in + let tvi = Some (EcUnify.tvi_unamed tvi) in + fst (EcUnify.UniEnv.opentys ue indty.tyd_params tvi ctorty) in let pty = EcUnify.UniEnv.fresh ue in (try EcUnify.unify env ue (toarrow ctorty pty) opty @@ -483,7 +485,7 @@ let trans_matchfix let codom = ty_subst ts codom in let opexpr = EcPath.pqname (EcEnv.root env) name in let args = List.map (snd_map (ty_subst ts)) args in - let opexpr = e_op opexpr (List.map tvar tparams) + let opexpr = e_op_tc opexpr (etyargs_of_tparams tparams) (toarrow (List.map snd args) codom) in let ebsubst = bind_elocal ts opname opexpr diff --git a/src/ecHiNotations.ml b/src/ecHiNotations.ml index 3d742857c5..6ed6ac979e 100644 --- a/src/ecHiNotations.ml +++ b/src/ecHiNotations.ml @@ -12,7 +12,7 @@ module TT = EcTyping (* -------------------------------------------------------------------- *) type nterror = | NTE_Typing of EcTyping.tyerror -| NTE_TyNotClosed +| NTE_TyNotClosed of EcUnify.uniflags | NTE_DupIdent | NTE_UnknownBinder of symbol | NTE_AbbrevIsVar @@ -62,8 +62,8 @@ let trans_notation_r (env : env) (nt : pnotation located) = let codom = TT.transty TT.tp_relax env ue nt.nt_codom in let body = TT.transexpcast benv `InOp ue codom nt.nt_body in - if not (EcUnify.UniEnv.closed ue) then - nterror gloc env NTE_TyNotClosed; + Option.iter (fun infos -> nterror gloc env (NTE_TyNotClosed infos)) + @@ EcUnify.UniEnv.xclosed ue; ignore body; () @@ -80,11 +80,13 @@ let trans_abbrev_r (env : env) (at : pabbrev located) = let codom = TT.transty TT.tp_relax env ue (fst at.ab_def) in let body = TT.transexpcast benv `InOp ue codom (snd at.ab_def) in - if not (EcUnify.UniEnv.closed ue) then - nterror gloc env NTE_TyNotClosed; + Option.iter (fun infos -> nterror gloc env (NTE_TyNotClosed infos)) + @@ EcUnify.UniEnv.xclosed ue; - let ts = Tuni.subst (EcUnify.UniEnv.close ue) in - let es = e_subst ts in + let ts = Tuni.subst + ~tw_uni:(EcUnify.UniEnv.tw_assubst ue) + (EcUnify.UniEnv.close ue) in + let es = e_subst ts in let body = es body in let codom = ty_subst ts codom in let xs = List.map (snd_map (ty_subst ts)) xs in diff --git a/src/ecHiNotations.mli b/src/ecHiNotations.mli index 54dd54543e..53aa868c15 100644 --- a/src/ecHiNotations.mli +++ b/src/ecHiNotations.mli @@ -8,7 +8,7 @@ open EcEnv (* -------------------------------------------------------------------- *) type nterror = | NTE_Typing of EcTyping.tyerror -| NTE_TyNotClosed +| NTE_TyNotClosed of EcUnify.uniflags | NTE_DupIdent | NTE_UnknownBinder of symbol | NTE_AbbrevIsVar diff --git a/src/ecHiPredicates.ml b/src/ecHiPredicates.ml index 49e725ad58..9fba05c55b 100644 --- a/src/ecHiPredicates.ml +++ b/src/ecHiPredicates.ml @@ -2,7 +2,6 @@ open EcUtils open EcSymbols open EcLocation -open EcTypes open EcCoreSubst open EcParsetree open EcDecl @@ -11,8 +10,8 @@ module TT = EcTyping (* -------------------------------------------------------------------- *) type tperror = -| TPE_Typing of EcTyping.tyerror -| TPE_TyNotClosed +| TPE_Typing of EcTyping.tyerror +| TPE_TyNotClosed of EcUnify.uniflags | TPE_DuplicatedConstr of symbol exception TransPredError of EcLocation.t * EcEnv.env * tperror @@ -20,8 +19,8 @@ exception TransPredError of EcLocation.t * EcEnv.env * tperror let tperror loc env e = raise (TransPredError (loc, env, e)) (* -------------------------------------------------------------------- *) -let close_pr_body (uni : ty EcUid.Muid.t) (body : prbody) = - let fsubst = EcFol.Fsubst.f_subst_init ~tu:uni () in +let close_pr_body (uidmap : EcTypes.ty EcAst.TyUni.Muid.t) (body : prbody) = + let fsubst = EcFol.Fsubst.f_subst_init ~tu:uidmap () in let tsubst = ty_subst fsubst in match body with @@ -74,13 +73,13 @@ let trans_preddecl_r (env : EcEnv.env) (pr : ppredicate located) = in - if not (EcUnify.UniEnv.closed ue) then - tperror loc env TPE_TyNotClosed; + Option.iter + (fun infos -> tperror loc env (TPE_TyNotClosed infos)) + (EcUnify.UniEnv.xclosed ue); - let uidmap = EcUnify.UniEnv.assubst ue in + let uidmap = EcUnify.UniEnv.assubst ue in let tparams = EcUnify.UniEnv.tparams ue in let body = body |> omap (close_pr_body uidmap) in - let dom = Tuni.subst_dom uidmap dom in EcDecl.mk_pred ~opaque:optransparent tparams dom body pr.pp_locality diff --git a/src/ecHiPredicates.mli b/src/ecHiPredicates.mli index eb56da6628..f411802cce 100644 --- a/src/ecHiPredicates.mli +++ b/src/ecHiPredicates.mli @@ -5,8 +5,8 @@ open EcParsetree (* -------------------------------------------------------------------- *) type tperror = -| TPE_Typing of EcTyping.tyerror -| TPE_TyNotClosed +| TPE_Typing of EcTyping.tyerror +| TPE_TyNotClosed of EcUnify.uniflags | TPE_DuplicatedConstr of symbol exception TransPredError of EcLocation.t * EcEnv.env * tperror diff --git a/src/ecIdent.ml b/src/ecIdent.ml index 9487c0e42c..3968b34c69 100644 --- a/src/ecIdent.ml +++ b/src/ecIdent.ml @@ -57,3 +57,4 @@ let tostring_internal (id : t) = (* -------------------------------------------------------------------- *) let pp_ident fmt id = Format.fprintf fmt "%s" (name id) +let pp = pp_ident diff --git a/src/ecIdent.mli b/src/ecIdent.mli index 82942edb77..659a7e474c 100644 --- a/src/ecIdent.mli +++ b/src/ecIdent.mli @@ -38,3 +38,4 @@ val fv_add : ident -> int Mid.t -> int Mid.t (* -------------------------------------------------------------------- *) val pp_ident : Format.formatter -> t -> unit +val pp : Format.formatter -> t -> unit diff --git a/src/ecInductive.ml b/src/ecInductive.ml index 81f3be80d8..eb146ee9a0 100644 --- a/src/ecInductive.ml +++ b/src/ecInductive.ml @@ -38,15 +38,15 @@ let datatype_proj_path (p : EP.path) (x : symbol) = (* -------------------------------------------------------------------- *) let indsc_of_record (rc : record) = - let targs = List.map tvar rc.rc_tparams in - let recty = tconstr rc.rc_path targs in + let targs = etyargs_of_tparams rc.rc_tparams in + let recty = tconstr_tc rc.rc_path targs in let recx = fresh_id_of_ty recty in let recfm = FL.f_local recx recty in let predty = tfun recty tbool in let predx = EcIdent.create "P" in let pred = FL.f_local predx predty in let ctor = record_ctor_path rc.rc_path in - let ctor = FL.f_op ctor targs (toarrow (List.map snd rc.rc_fields) recty) in + let ctor = FL.f_op_tc ctor targs (toarrow (List.map snd rc.rc_fields) recty) in let prem = let ids = List.map (fun (_, fty) -> (fresh_id_of_ty fty, fty)) rc.rc_fields in let vars = List.map (fun (x, xty) -> FL.f_local x xty) ids in @@ -129,7 +129,7 @@ let rec occurs ?(normty = identity) p t = (** Tests whether the first list is a list of type variables, matching the identifiers of the second list. *) let ty_params_compat = - List.for_all2 (fun ty param_id -> + List.for_all2 (fun (ty, _) (param_id, _) -> match ty.ty_node with | Tvar id -> EcIdent.id_equal id param_id | _ -> false) @@ -142,13 +142,13 @@ let rec check_positivity_in_decl fct p decl ident = and iter l f = List.iter f l in match decl.tyd_type with - | Concrete ty -> with_context ~ident p Concrete (check ty) - | Abstract -> non_positive p AbstractTypeRestriction - | Datatype { tydt_ctors } -> + | `Concrete ty -> with_context ~ident p Concrete (check ty) + | `Abstract _ -> non_positive p AbstractTypeRestriction + | `Datatype { tydt_ctors; _ } -> iter tydt_ctors @@ fun (name, argty) -> iter argty @@ fun ty -> with_context ~ident p (Variant name) (check ty) - | Record (_, tys) -> + | `Record (_, tys) -> iter tys @@ fun (name, ty) -> with_context ~ident p (Record name) (check ty) @@ -162,9 +162,9 @@ and check_positivity_ident fct p params ident ty = non_positive p (TypePositionRestriction ty) | Tconstr (q, args) -> let decl = fct q in - List.iter (check_positivity_ident fct p params ident) args; + List.iter (fun (a, _) -> check_positivity_ident fct p params ident a) args; List.combine args decl.tyd_params - |> List.filter_map (fun (arg, ident') -> + |> List.filter_map (fun ((arg, _), (ident', _)) -> if EcTypes.var_mem ident arg then Some ident' else None) |> List.iter (check_positivity_in_decl fct q decl) | Tfun (from, to_) -> @@ -177,12 +177,12 @@ let rec check_positivity_path fct p ty = | Tglob _ | Tunivar _ | Tvar _ -> () | Ttuple tys -> List.iter (check_positivity_path fct p) tys | Tconstr (q, args) when EcPath.p_equal q p -> - if List.exists (occurs p) args then non_positive p (NonPositiveOcc ty) + if List.exists (fun (a, _) -> occurs p a) args then non_positive p (NonPositiveOcc ty) | Tconstr (q, args) -> let decl = fct q in - List.iter (check_positivity_path fct p) args; + List.iter (fun (a, _) -> check_positivity_path fct p a) args; List.combine args decl.tyd_params - |> List.filter_map (fun (arg, ident) -> + |> List.filter_map (fun ((arg, _), (ident, _)) -> if occurs p arg then Some ident else None) |> List.iter (check_positivity_in_decl fct q decl) | Tfun (from, to_) -> @@ -223,11 +223,11 @@ let indsc_of_datatype ?(normty = identity) (mode : indmode) (dt : datatype) = |> omap (FL.f_forall [x, GTty ty1]) and schemec mode (targs, p) pred (ctor, tys) = - let indty = tconstr p (List.map tvar targs) in + let indty = tconstr_tc p targs in let xs = List.map (fun xty -> (fresh_id_of_ty xty, xty)) tys in let cargs = List.map (fun (x, xty) -> FL.f_local x xty) xs in let ctor = EcPath.pqoname (EcPath.prefix tpath) ctor in - let ctor = FL.f_op ctor (List.map tvar targs) (toarrow tys indty) in + let ctor = FL.f_op_tc ctor targs (toarrow tys indty) in let form = FL.f_app pred [FL.f_app ctor cargs indty] tbool in let form = match mode with @@ -247,7 +247,7 @@ let indsc_of_datatype ?(normty = identity) (mode : indmode) (dt : datatype) = form and scheme mode (targs, p) ctors = - let indty = tconstr p (List.map tvar targs) in + let indty = tconstr_tc p targs in let indx = fresh_id_of_ty indty in let indfm = FL.f_local indx indty in let predty = tfun indty tbool in @@ -260,11 +260,11 @@ let indsc_of_datatype ?(normty = identity) (mode : indmode) (dt : datatype) = let form = FL.f_forall [predx, GTty predty] form in form - in scheme mode (dt.dt_tparams, tpath) dt.dt_ctors + in scheme mode (etyargs_of_tparams dt.dt_tparams, tpath) dt.dt_ctors (* -------------------------------------------------------------------- *) let datatype_projectors (tpath, tparams, { tydt_ctors = ctors }) = - let thety = tconstr tpath (List.map tvar tparams) in + let thety = tconstr_tc tpath (etyargs_of_tparams tparams) in let do1 i (cname, cty) = let thv = EcIdent.create "the" in @@ -378,7 +378,7 @@ let indsc_of_prind ({ ip_path = p; ip_prind = pri } as pr) = FL.f_forall ctor.prc_bds px in - let sc = FL.f_op p (List.map tvar pr.ip_tparams) prty in + let sc = FL.f_op_tc p (etyargs_of_tparams pr.ip_tparams) prty in let sc = FL.f_imp (FL.f_app sc prag tbool) pred in let sc = FL.f_imps (List.map for1 pri.pri_ctors) sc in let sc = FL.f_forall [predx, FL.gtty tbool] sc in @@ -391,7 +391,7 @@ let introsc_of_prind ({ ip_path = p; ip_prind = pri } as pr) = let bds = List.map (snd_map FL.gtty) pri.pri_args in let clty = toarrow (List.map snd pri.pri_args) tbool in let clag = (List.map (curry FL.f_local) pri.pri_args) in - let cl = FL.f_op p (List.map tvar pr.ip_tparams) clty in + let cl = FL.f_op_tc p (etyargs_of_tparams pr.ip_tparams) clty in let cl = FL.f_app cl clag tbool in let for1 ctor = diff --git a/src/ecLexer.mll b/src/ecLexer.mll index 704b0e9764..b8b4392053 100644 --- a/src/ecLexer.mll +++ b/src/ecLexer.mll @@ -199,6 +199,7 @@ "theory" , THEORY ; (* KW: global *) "abstract" , ABSTRACT ; (* KW: global *) "section" , SECTION ; (* KW: global *) + "class" , CLASS ; (* KW: global *) "subtype" , SUBTYPE ; (* KW: global *) "type" , TYPE ; (* KW: global *) "instance" , INSTANCE ; (* KW: global *) @@ -209,7 +210,9 @@ "Pr" , PR ; (* KW: global *) "clone" , CLONE ; (* KW: global *) "with" , WITH ; (* KW: global *) + "via" , VIA ; (* KW: global *) "rename" , RENAME ; (* KW: global *) + "reducible" , REDUCIBLE ; (* KW: global *) "prover" , PROVER ; (* KW: global *) "timeout" , TIMEOUT ; (* KW: global *) "why3" , WHY3 ; (* KW: global *) diff --git a/src/ecLowGoal.ml b/src/ecLowGoal.ml index ae5a28eb0f..a14d0bab11 100644 --- a/src/ecLowGoal.ml +++ b/src/ecLowGoal.ml @@ -168,7 +168,7 @@ module LowApply = struct | PTGlobal (p, tys) -> (* FIXME: poor API ==> poor error recovery *) let env = LDecl.toenv (hyps_of_ckenv tc) in - (pt, EcEnv.Ax.instantiate p tys env, subgoals) + (pt, EcEnv.Ax.instanciate p tys env, subgoals) | PTTerm pt -> let pt, ax, subgoals = check_ `Elim pt subgoals tc in @@ -261,13 +261,24 @@ module LowApply = struct (PTQuant (bd, pt), f_forall [bd] ax, subgoals) end + (* Fold every TC op in [f] whose witness resolves through a + [tci_reducible] instance. Applied to the type returned by [check_] + so that [Ax.instanciate]'s polymorphic-lemma instantiation at a + concrete carrier is normalised at the point of consumption. Pairs + with [EcProofTerm.cpt_subst_form] which applies the same rule to + concretization-time substitutions. *) + let fold_check_ax (tc : ckenv) (f : form) : form = + let env = LDecl.toenv (hyps_of_ckenv tc) in + EcReduction.fold_reducible_tc env f + let check_with_cutsolve (mode : [`Intro | `Elim]) (pt : proofterm) (tc : ckenv) = - check_ mode pt DMap.empty tc + let pt, f, subgoals = check_ mode pt DMap.empty tc in + (pt, fold_check_ax tc f, subgoals) let check (mode : [`Intro | `Elim]) (pt : proofterm) (tc : ckenv) = let pt, f, subgoals = check_ mode pt DMap.empty tc in assert (DMap.is_empty subgoals); - (pt, f) + (pt, fold_check_ax tc f) end (* -------------------------------------------------------------------- *) @@ -743,9 +754,14 @@ let t_apply_hyp (x : EcIdent.t) ?args ?sk tc = let t_hyp (x : EcIdent.t) tc = t_apply_hyp x ~args:[] ~sk:0 tc +(* -------------------------------------------------------------------- *) +let t_apply_s_tc (p : path) (etys : etyarg list) ?args ?sk tc = + tt_apply_s p etys ?args ?sk (FApi.tcenv_of_tcenv1 tc) + (* -------------------------------------------------------------------- *) let t_apply_s (p : path) (tys : ty list) ?args ?sk tc = - tt_apply_s p tys ?args ?sk (FApi.tcenv_of_tcenv1 tc) + let etys = List.map (fun ty -> (ty, [])) tys in + tt_apply_s p etys ?args ?sk (FApi.tcenv_of_tcenv1 tc) (* -------------------------------------------------------------------- *) let t_apply_hd (hd : handle) ?args ?sk tc = @@ -1009,7 +1025,7 @@ let t_true (tc : tcenv1) = let t_reflex_s (f : form) (tc : tcenv1) = t_apply_s LG.p_eq_refl [f.f_ty] ~args:[f] tc -let t_reflex ?(mode=`Conv) ?reduce (tc : tcenv1) = +let t_reflex ?(mode = `Conv) ?reduce (tc : tcenv1) = let t_reflex_r (fp : form) (tc : tcenv1) = match sform_of_form fp with | SFeq (f1, f2) -> @@ -1171,9 +1187,9 @@ let t_elim_r ?(reduce = (`Full : lazyred)) txs tc = | None -> begin let strategy = match reduce with - | `None -> raise InvalidGoalShape - | `Full -> EcReduction.full_red - | `NoDelta -> EcReduction.nodelta in + | `None -> raise InvalidGoalShape + | `Full -> EcReduction.full_red + | `NoDelta -> EcReduction.nodelta in match h_red_opt strategy (FApi.tc1_hyps tc) f1 with | None -> raise InvalidGoalShape @@ -1508,9 +1524,9 @@ let t_elim_prind_r ?reduce ?accept (_mode : [`Case | `Ind]) tc = end; (oget (EcEnv.Op.scheme_of_prind env `Case p), tv, args) - | _ -> raise InvalidGoalShape + | _ -> raise InvalidGoalShape in - in t_apply_s p tv ~args:(args @ [f2]) ~sk tc + t_apply_s_tc p tv ~args:(args @ [f2]) ~sk tc | _ -> raise TTC.NoMatch @@ -1665,7 +1681,7 @@ let t_split_prind ?reduce (tc : tcenv1) = | None -> raise InvalidGoalShape | Some (x, sk) -> let p = EcInductive.prind_introsc_path p x in - t_apply_s p tv ~args ~sk tc + t_apply_s_tc p tv ~args ~sk tc in t_lazy_match ?reduce t_split_r tc @@ -1685,10 +1701,10 @@ let t_or_intro_prind ?reduce (side : side) (tc : tcenv1) = match EcInductive.prind_is_iso_ors pri with | Some ((x, sk), _) when side = `Left -> let p = EcInductive.prind_introsc_path p x in - t_apply_s p tv ~args ~sk tc + t_apply_s_tc p tv ~args ~sk tc | Some (_, (x, sk)) when side = `Right -> let p = EcInductive.prind_introsc_path p x in - t_apply_s p tv ~args ~sk tc + t_apply_s_tc p tv ~args ~sk tc | _ -> raise InvalidGoalShape in t_lazy_match ?reduce t_split_r tc @@ -1889,9 +1905,14 @@ module LowSubst = struct (* check if x is a declared module *) let fv = Sid.add x fv in if EcEnv.Mod.by_mpath_opt (EcPath.mident x) env <> None then fv + (* [f.f_fv] also collects type-variables (which live in + [h_tvar], not [h_local]) and other non-hypothesis idents; + a raw [LDecl.by_id] would crash with [LookupError]. Only + expand let-bound locals. *) else match LDecl.by_id x hyps with | LD_var (_, Some f) -> add_f fv f | _ -> fv + | exception LDecl.LdeclError _ -> fv and add_f fv f = Mid.fold_left add fv f.f_fv in Some(side,v,f, add_f Sid.empty f) @@ -2288,8 +2309,7 @@ let t_progress ?options ?ti (tt : FApi.backward) (tc : tcenv1) = else elims in - let reduce = - if options.pgo_delta.pgod_case then `Full else `NoDelta in + let reduce = if options.pgo_delta.pgod_case then `Full else `NoDelta in FApi.t_switch ~on:`All (t_elim_r ~reduce elims) ~ifok:aux0 ~iffail tc end diff --git a/src/ecLowGoal.mli b/src/ecLowGoal.mli index c17b4e4b28..a9b806d429 100644 --- a/src/ecLowGoal.mli +++ b/src/ecLowGoal.mli @@ -18,7 +18,6 @@ exception InvalidProofTerm (* invalid proof term *) type side = [`Left|`Right] type lazyred = [`Full | `NoDelta | `None] - (* -------------------------------------------------------------------- *) val (@!) : FApi.backward -> FApi.backward -> FApi.backward val (@+) : FApi.backward -> FApi.backward list -> FApi.backward @@ -113,6 +112,8 @@ val t_apply : ?cutsolver:cutsolver -> proofterm -> FApi.backward * skip before applying [p]. *) val t_apply_s : path -> ty list -> ?args:(form list) -> ?sk:int -> FApi.backward +val t_apply_s_tc : path -> etyarg list -> ?args:(form list) -> ?sk:int -> FApi.backward + (* Apply a proof term of the form [h f1...fp _ ... _] constructed from * the local hypothesis and formulas given to the function. The [int] * argument gives the number of premises to skip before applying @@ -191,7 +192,7 @@ val t_elim_iso_or : ?reduce:lazyred -> tcenv1 -> int list * tcenv (* Elimination using an custom elimination principle. *) val t_elimT_form : proofterm -> ?sk:int -> form -> FApi.backward -val t_elimT_form_global : path -> ?typ:(ty list) -> ?sk:int -> form -> FApi.backward +val t_elimT_form_global : path -> ?typ:(etyarg list) -> ?sk:int -> form -> FApi.backward (* Eliminiation using an elimation principle of an induction type *) val t_elimT_ind : ?reduce:lazyred -> [ `Case | `Ind ] -> FApi.backward diff --git a/src/ecMatching.ml b/src/ecMatching.ml index 29a4617cb0..0aa653746a 100644 --- a/src/ecMatching.ml +++ b/src/ecMatching.ml @@ -389,10 +389,10 @@ module Position = struct let (env, s), npath = normalize_cpos_path env cpath s in (env, s), (npath, normalize_cpos1 env cp1 s) - let resolve_offset1_from_cpos1 env (base: nm_codepos1) (off: codeoffset1) (s: stmt) : nm_codepos1 = + let resolve_offset1_from_cpos1 env (base: nm_codepos1) (off: codeoffset1) (s: stmt) : nm_codepos1 = match off with - | `Absolute off -> normalize_cpos1 env off s - | `Relative i -> + | `Absolute off -> normalize_cpos1 env off s + | `Relative i -> let nm = (base + i) in check_nm_cpos1 nm s; nm @@ -828,7 +828,9 @@ module MEV = struct v let assubst ue ev env = - let subst = f_subst_init ~tu:(EcUnify.UniEnv.assubst ue) () in + let subst = f_subst_init + ~tu:(EcUnify.UniEnv.assubst ue) + ~tw_uni:(EcUnify.UniEnv.tw_assubst ue) () in let subst = EV.fold (fun x m s -> Fsubst.f_bind_mem s x m) ev.evm_mem subst in let subst = EV.fold (fun x mp s -> EcFol.f_bind_mod s x mp env) ev.evm_mod subst in let seen = ref Sid.empty in @@ -1046,9 +1048,8 @@ let f_match_core opts hyps (ue, ev) f1 f2 = if i <> j then failure () else doit env ilc f1 f2 | Fop (op1, tys1), Fop (op2, tys2) -> begin - if not (EcPath.p_equal op1 op2) then - failure (); - try List.iter2 (EcUnify.unify env ue) tys1 tys2 + if not (EcPath.p_equal op1 op2) then failure (); + try List.iter2 (EcUnify.unify_etyarg env ue) tys1 tys2 with EcUnify.UnificationFailure _ -> failure () end @@ -1144,6 +1145,55 @@ let f_match_core opts hyps (ue, ev) f1 f2 = failure (); doit env (subst, mxs) f1' f2' in + (* Eta-reduce a [fun (x_1 ... x_n) => h x_1 ... x_n] body when + [h] does not mention any [x_i]. Returns [Some h] on success. *) + let try_eta_reduce (f : form) : form option = + match f.f_node with + | Fquant (Llambda, bd, body) -> begin + let nbd = List.length bd in + match destr_app body with + | (h, args) when List.length args >= nbd -> + let n_extra = List.length args - nbd in + let extra, tail = List.split_at n_extra args in + let bd_ids = List.map fst bd in + (* Tail must be exactly [x_1; ...; x_n] in order. *) + let tail_ok = + List.for_all2 (fun (x, _) a -> + match a.f_node with + | Flocal y -> EcIdent.id_equal x y + | _ -> false) bd tail in + (* And [h] (with extras) must not mention the [x_i]. *) + let captures = + List.exists (fun id -> Mid.mem id h.f_fv) bd_ids + || List.exists + (fun a -> List.exists (fun id -> Mid.mem id a.f_fv) bd_ids) + extra in + if tail_ok && not captures then + Some (if n_extra = 0 then h else f_app h extra body.f_ty) + else None + | _ -> None + end + | _ -> None in + + let is_lambda f = + match f.f_node with Fquant (Llambda, _, _) -> true | _ -> false in + let try_etared () = + (* Only η-reduce when the other side is not itself a lambda; + if both are lambdas, the structural Fquant/Fquant case + handles it, and prematurely eta-reducing one side would + interfere with higher-order matching against lambda + patterns. *) + match f1.f_node, f2.f_node with + | Fquant (Llambda, _, _), _ when not (is_lambda f2) -> + (match try_eta_reduce f1 with + | Some f1' -> doit env (subst, mxs) f1' f2 + | None -> failure ()) + | _, Fquant (Llambda, _, _) when not (is_lambda f1) -> + (match try_eta_reduce f2 with + | Some f2' -> doit env (subst, mxs) f1 f2' + | None -> failure ()) + | _ -> failure () in + let try_horder () = if not opts.fm_horder then failure (); @@ -1166,6 +1216,36 @@ let f_match_core opts hyps (ue, ev) f1 f2 = let try_delta () = if not opts.fm_delta then failure (); + (* Drain pending TC constraints before checking [tc_reducible]: + a [TCIUni] witness on a TC op-head needs to be committed in + the resolution map (and then dereferenced via [norm]) for + [tc_core_reduce] to fire. Without this drain, a parametric- + carrier proof-term carrying an unresolved [TCIUni] would + fail to reduce here even when the carrier's TC instance is + registered in the env. *) + EcUnify.UniEnv.flush_tc_problems env ue; + let f1 = norm f1 in + let f2 = norm f2 in + if Sys.getenv_opt "EC_DBG_TD" <> None then begin + let dump f = match (destr_app f) with + | { f_node = Fop (p, _); _ }, args -> + Printf.sprintf "Fop %s [%d]" (EcPath.tostring p) (List.length args) + | _ -> "" in + Format.eprintf "[try_delta] %s | %s@." (dump f1) (dump f2) + end; + (* When one side is a TC op call on a univar carrier and the + other side's head is a registered realisation of that same + class op, we'd lose the chance to pin the carrier if we + [delta]-unfolded the realisation first. Detect this case so + the mathcomp-style branch below is preferred. *) + let mathcomp_eligible op_tc tys_tc op_concrete = + EcEnv.Op.is_tc_op env op_tc + && (not (EcPath.p_equal op_tc op_concrete)) + && EcEnv.Op.tc_op_realised_by env op_tc op_concrete + && (match List.rev tys_tc with + | (ty, _) :: _ -> + not (TyUni.Suid.is_empty (Tuni.univars ty)) + | [] -> false) in match fst_map f_node (destr_app f1), fst_map f_node (destr_app f2) @@ -1176,12 +1256,61 @@ let f_match_core opts hyps (ue, ev) f1 f2 = | _, (Flocal x2, args2) when LDecl.can_unfold x2 hyps -> doit_lreduce env (doit env ilc f1) f2.f_ty x2 args2 + (* Mathcomp-style (pre-empt delta unfolding of [op2] which would + commit the carrier to a specific realisation and lose the + cross-instance match). After unifying carriers, re-normalise + the now-pinned TC op call so [tc_reduce] can fire and the + realisation matches the goal-side concrete op. *) + | (Fop (op1, tys1), _), (Fop (op2, _), _) + when mathcomp_eligible op1 tys1 op2 -> + let before = Tuni.univars f1.f_ty in + (try EcUnify.unify env ue f1.f_ty f2.f_ty + with EcUnify.UnificationFailure _ -> failure ()); + let f1' = norm f1 in + let after = Tuni.univars f1'.f_ty in + if TyUni.Suid.cardinal after >= TyUni.Suid.cardinal before then + failure (); + EcUnify.UniEnv.flush_tc_problems env ue; + (* The pattern's TC-op application is now at a concrete + carrier; reduce it through the registered instance. *) + let f1_reduced = + let head, args = destr_app f1' in + match head.f_node with + | Fop (p, tys) when EcEnv.Op.tc_reducible env p tys -> + f_app (EcEnv.Op.tc_reduce env p tys) args f1'.f_ty + | _ -> f1' in + doit env ilc (norm f1_reduced) (norm f2) + + | (Fop (op1, _), _), (Fop (op2, tys2), _) + when mathcomp_eligible op2 tys2 op1 -> + let before = Tuni.univars f2.f_ty in + (try EcUnify.unify env ue f1.f_ty f2.f_ty + with EcUnify.UnificationFailure _ -> failure ()); + let f2' = norm f2 in + let after = Tuni.univars f2'.f_ty in + if TyUni.Suid.cardinal after >= TyUni.Suid.cardinal before then + failure (); + EcUnify.UniEnv.flush_tc_problems env ue; + let f2_reduced = + let head, args = destr_app f2' in + match head.f_node with + | Fop (p, tys) when EcEnv.Op.tc_reducible env p tys -> + f_app (EcEnv.Op.tc_reduce env p tys) args f2'.f_ty + | _ -> f2' in + doit env ilc (norm f1) (norm f2_reduced) + | (Fop (op1, tys1), args1), _ when EcEnv.Op.reducible env op1 -> doit_reduce env ((doit env ilc)^~ f2) f1.f_ty op1 tys1 args1 | _, (Fop (op2, tys2), args2) when EcEnv.Op.reducible env op2 -> doit_reduce env (doit env ilc f1) f2.f_ty op2 tys2 args2 + | (Fop (op1, tys1), args1), _ when EcEnv.Op.tc_reducible env op1 tys1 -> + doit_tc_reduce env ((doit env ilc)^~ f2) f1.f_ty op1 tys1 args1 + + | _, (Fop (op2, tys2), args2) when EcEnv.Op.tc_reducible env op2 tys2 -> + doit_tc_reduce env (doit env ilc f1) f2.f_ty op2 tys2 args2 + | _, _ -> failure () in @@ -1193,7 +1322,7 @@ let f_match_core opts hyps (ue, ev) f1 f2 = List.find_map_opt (fun doit -> try Some (doit ()) with MatchFailure -> None) - [try_betared; try_horder; try_delta; default] + [try_betared; try_horder; try_etared; try_delta; default] |> oget ~exn:MatchFailure and doit_args env ilc fs1 fs2 = @@ -1207,6 +1336,12 @@ let f_match_core opts hyps (ue, ev) f1 f2 = with NotReducible -> raise MatchFailure in cb (odfl reduced (EcReduction.h_red_opt EcReduction.beta_red hyps reduced)) + and doit_tc_reduce env cb ty op tys args = + let reduced = + try f_app (EcEnv.Op.tc_reduce env op tys) args ty + with NotReducible -> raise MatchFailure in + cb (odfl reduced (EcReduction.h_red_opt EcReduction.beta_red hyps reduced)) + and doit_lreduce _env cb ty x args = let reduced = try f_app (LDecl.unfold x hyps) args ty @@ -1292,7 +1427,7 @@ let f_match opts hyps (ue, ev) f1 f2 = raise MatchFailure; let clue = try EcUnify.UniEnv.close ue - with EcUnify.UninstantiateUni -> raise MatchFailure + with EcUnify.UninstanciateUni _ -> raise MatchFailure in (ue, clue, ev) @@ -1652,7 +1787,10 @@ module FPosition = struct end (* -------------------------------------------------------------------- *) -type cptenv = CPTEnv of f_subst +(* The [env] component is the environment in which the proof-term was + elaborated. It is needed to consult [tci_reducible] flags when + normalising the substituted form via [EcReduction.fold_reducible_tc]. *) +type cptenv = CPTEnv of f_subst * EcEnv.env let can_concretize ev ue = EcUnify.UniEnv.closed ue && MEV.filled ev diff --git a/src/ecMatching.mli b/src/ecMatching.mli index d13622e4d7..663a8106f9 100644 --- a/src/ecMatching.mli +++ b/src/ecMatching.mli @@ -1,6 +1,5 @@ (* -------------------------------------------------------------------- *) open EcMaps -open EcUid open EcIdent open EcTypes open EcModules @@ -384,7 +383,7 @@ val f_match : -> unienv * mevmap -> form -> form - -> unienv * (ty Muid.t) * mevmap + -> unienv * (ty EcAst.TyUni.Muid.t) * mevmap (* -------------------------------------------------------------------- *) type ptnpos = private [`Select of int | `Sub of ptnpos] Mint.t @@ -425,7 +424,7 @@ module FPosition : sig end (* -------------------------------------------------------------------- *) -type cptenv = CPTEnv of f_subst +type cptenv = CPTEnv of f_subst * EcEnv.env val can_concretize : mevmap -> EcUnify.unienv -> bool diff --git a/src/ecPV.ml b/src/ecPV.ml index 3d173b9b67..5eff3d8adb 100644 --- a/src/ecPV.ml +++ b/src/ecPV.ml @@ -1011,7 +1011,7 @@ module Mpv2 = struct when EcIdent.id_equal ml m1 && EcIdent.id_equal mr m2 -> add_glob env (EcPath.mident mp1) (EcPath.mident mp2) eqs | Fop(op1,tys1), Fop(op2,tys2) when EcPath.p_equal op1 op2 && - List.all2 (EcReduction.EqTest.for_type env) tys1 tys2 -> eqs + List.all2 (fun (t1, _) (t2, _) -> EcReduction.EqTest.for_type env t1 t2) tys1 tys2 -> eqs | Fapp(f1,a1), Fapp(f2,a2) -> List.fold_left2 (add_eq local) eqs (f1::a1) (f2::a2) | Ftuple es1, Ftuple es2 -> @@ -1110,7 +1110,7 @@ module Mpv2 = struct I postpone this for latter *) | Eop(op1,tys1), Eop(op2,tys2) when EcPath.p_equal op1 op2 && - List.all2 (EcReduction.EqTest.for_type env) tys1 tys2 -> eqs + List.all2 (fun (t1, _) (t2, _) -> EcReduction.EqTest.for_type env t1 t2) tys1 tys2 -> eqs | Eapp(f1,a1), Eapp(f2,a2) -> List.fold_left2 (add_eqs_loc env local) eqs (f1::a1) (f2::a2) | Elet(lp1,a1,b1), Elet(lp2,a2,b2) -> diff --git a/src/ecParser.mly b/src/ecParser.mly index 8633c13125..3507ea3e72 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -90,17 +90,18 @@ let mk_simplify l = if l = [] then - { pbeta = true; pzeta = true; - piota = true; peta = true; - plogic = true; pdelta = None; - pmodpath = true; puser = true; } + { pbeta = true; pzeta = true; + piota = true; peta = true; + plogic = true; pdelta = None; + pdeltatc = true; pmodpath = true; + puser = true; } else let doarg acc = function | `Delta l -> if l = [] || acc.pdelta = None then { acc with pdelta = None } else { acc with pdelta = Some (oget acc.pdelta @ l) } - + | `DeltaTC -> { acc with pdeltatc = true } | `Zeta -> { acc with pzeta = true } | `Iota -> { acc with piota = true } | `Beta -> { acc with pbeta = true } @@ -110,10 +111,11 @@ | `User -> { acc with puser = true } in List.fold_left doarg - { pbeta = false; pzeta = false; - piota = false; peta = false; - plogic = false; pdelta = Some []; - pmodpath = false; puser = false; } l + { pbeta = false; pzeta = false; + piota = false; peta = false; + plogic = false; pdelta = Some []; + pdeltatc = false; pmodpath = false; + puser = false; } l let simplify_red = [`Zeta; `Iota; `Beta; `Eta; `Logic; `ModPath; `User] @@ -398,6 +400,7 @@ %token CEQ %token CFOLD %token CHANGE +%token CLASS %token CLEAR %token CLONE %token COLON @@ -532,6 +535,7 @@ %token REFLEX %token REMOVE %token RENAME +%token REDUCIBLE %token REPLACE %token REQUIRE %token RES @@ -595,6 +599,7 @@ %token WHILE %token WHY3 %token WITH +%token VIA %token WLOG %token WP %token ZETA @@ -902,11 +907,28 @@ lp_field: (* -------------------------------------------------------------------- *) (* Expressions: program expression, real expression *) +(* Optional witness selector trailing a type-instantiation entry. + Accepts any combination of [/Lbl+] and [via P]. *) +witness_selector: +| (* empty *) + { pws_none } +| SLASH lbls=plist1(ident, SLASH) + { { pws_labels = lbls; pws_via = None; } } +| VIA p=qident + { { pws_labels = []; pws_via = Some p; } } +| SLASH lbls=plist1(ident, SLASH) VIA p=qident + { { pws_labels = lbls; pws_via = Some p; } } +| VIA p=qident SLASH lbls=plist1(ident, SLASH) + { { pws_labels = lbls; pws_via = Some p; } } + +tyvar_unnamed1: +| ty=loc(type_exp) sel=witness_selector { (ty, sel) } + tyvar_byname1: -| x=tident EQ ty=loc(type_exp) { (x, ty) } +| x=tident EQ ty=loc(type_exp) sel=witness_selector { (x, ty, sel) } tyvar_annot: -| lt = plist1(loc(type_exp), COMMA) { TVIunamed lt } +| lt = plist1(tyvar_unnamed1, COMMA) { TVIunamed lt } | lt = plist1(tyvar_byname1, COMMA) { TVInamed lt } %inline tvars_app: @@ -1629,6 +1651,7 @@ signature_item: pfd_uses = { pmre_name = x; pmre_orcls = orcls; } } } (* -------------------------------------------------------------------- *) +(* EcTypes declarations / definitions *) %inline locality: | (* empty *) { `Global } | LOCAL { `Local } @@ -1643,19 +1666,38 @@ signature_item: %inline is_local: | lc=loc(locality) { locality_as_local lc } -(* -------------------------------------------------------------------- *) -(* EcTypes declarations / definitions *) +(* A TC class instantiation: type args + class name. Used inside + [tc_bound] (the bare-or-parenthesized class-bound form). *) +tcparam: +| tys=ioption(type_args) x=lqident + { (x, odfl [] tys) } + +(* A class bound: optionally labeled and/or renamed. Used uniformly + in class-declaration parents, type-declaration tparams, and + op/lemma-signature tparams. *) +tc_bound: +| p=tcparam + { (p, None, []) } +| LPAREN p=tcparam AS lbl=ident RPAREN + { (p, Some lbl, []) } +| LPAREN p=tcparam WITH ren=plist1(tc_rename, COMMA) RPAREN + { (p, None, ren) } +| LPAREN p=tcparam AS lbl=ident WITH ren=plist1(tc_rename, COMMA) RPAREN + { (p, Some lbl, ren) } + +tc_rename: +| src=oident EQ tgt=oident { (src, tgt) } typaram: -| x=tident - { (x : ptyparam) } +| x=tident { (x, []) } +| x=tident LTCOLON tc=plist1(tc_bound, AMP) { (x, tc) } typarams: | empty { ([] : ptyparams) } | x=tident - { ([x] : ptyparams) } + { ([(x, [])] : ptyparams) } | xs=paren(plist1(typaram, COMMA)) { (xs : ptyparams) } @@ -1679,7 +1721,10 @@ rec_field_def: typedecl: | locality=locality TYPE td=rlist1(tyd_name, COMMA) - { List.map (fun x -> mk_tydecl ~locality x PTYD_Abstract) td } + { List.map (fun x -> mk_tydecl ~locality x (PTYD_Abstract [])) td } + +| locality=locality TYPE td=tyd_name LTCOLON tcs=rlist1(tc_bound, AMP) + { [mk_tydecl ~locality td (PTYD_Abstract tcs)] } | locality=locality TYPE td=tyd_name EQ te=loc(type_exp) { [mk_tydecl ~locality td (PTYD_Alias te)] } @@ -1690,6 +1735,29 @@ typedecl: | locality=locality TYPE td=tyd_name EQ te=datatype_def { [mk_tydecl ~locality td (PTYD_Datatype te)] } +(* -------------------------------------------------------------------- *) +(* Type classes *) +typeclass: +| loca=is_local TYPE CLASS tya=tyvars_decl? x=lident + inth=prefix(LTCOLON, plist1(tc_bound, AMP))? + EQ LBRACE body=tc_body RBRACE { + { ptc_name = x; + ptc_params = tya; + ptc_inth = odfl [] inth; + ptc_ops = fst body; + ptc_axs = snd body; + ptc_loca = loca; } + } + +tc_body: +| ops=tc_op* axs=tc_ax* { (ops, axs) } + +tc_op: +| OP x=oident COLON ty=loc(type_exp) { (x, ty) } + +tc_ax: +| AXIOM x=ident COLON ax=form { (x, ax) } + (* -------------------------------------------------------------------- *) (* Subtypes *) subtype: @@ -1708,40 +1776,34 @@ subtype_rename: (* -------------------------------------------------------------------- *) (* Type classes (instances) *) tycinstance: -| loca=is_local INSTANCE x=qident - WITH typ=tyvars_decl? ty=loc(type_exp) ops=tyci_op* axs=tyci_ax* +| loca=is_local INSTANCE tc=tcparam args=tyci_args? + name=prefix(AS, lident)? WITH typ=tyvars_decl? ty=loc(type_exp) + reducible=boption(REDUCIBLE) ops=tyci_op* axs=tyci_ax* { - { pti_name = x; - pti_type = (odfl [] typ, ty); - pti_ops = ops; - pti_axs = axs; - pti_args = None; - pti_loca = loca; - } + let args = args |> omap (fun (c, p) -> `Ring (c, p)) in + { pti_tc = tc; + pti_name = name; + pti_type = (odfl [] typ, ty); + pti_ops = ops; + pti_axs = axs; + pti_args = args; + pti_loca = loca; + pti_reducible = reducible; } } -| loca=is_local INSTANCE x=qident c=uoption(UINT) p=uoption(UINT) - WITH typ=tyvars_decl? ty=loc(type_exp) ops=tyci_op* axs=tyci_ax* - { - { pti_name = x; - pti_type = (odfl [] typ, ty); - pti_ops = ops; - pti_axs = axs; - pti_args = Some (`Ring (c, p)); - pti_loca = loca; - } - } +tyci_args: +| c=uoption(UINT) p=uoption(UINT) + { (c, p) } tyci_op: -| OP x=oident EQ tg=qoident - { (x, ([], tg)) } - -| OP x=oident EQ tg=qoident LTCOLON tvi=plist0(loc(type_exp), COMMA) GT - { (x, (tvi, tg)) } +| OP x=oident EQ body=sform + { (x, body) } tyci_ax: | PROOF x=ident BY tg=tactic_core - { (x, tg) } + { (x, None, tg) } +| PROOF x=ident LTCOLON lbls=plist1(ident, SLASH) GT BY tg=tactic_core + { (x, Some lbls, tg) } (* -------------------------------------------------------------------- *) (* Operator definitions *) @@ -1758,8 +1820,9 @@ pred_tydom: tyvars_decl: | LBRACKET tyvars=rlist0(typaram, COMMA) RBRACKET -| LBRACKET tyvars=rlist2(tident, empty) RBRACKET { tyvars } +| LBRACKET tyvars=rlist2(tident, empty) RBRACKET + { List.map (fun x -> (x, [])) tyvars } op_or_const: | OP { `Op } @@ -2486,6 +2549,7 @@ genpattern: simplify_arg: | DELTA l=qoident* { `Delta l } +| CLASS { `DeltaTC } | ZETA { `Zeta } | IOTA { `Iota } | BETA { `Beta } @@ -3927,6 +3991,7 @@ global_action: | sig_def { Ginterface $1 } | typedecl { Gtype $1 } | subtype { Gsubtype $1 } +| typeclass { Gtypeclass $1 } | tycinstance { Gtycinstance $1 } | operator { Goperator $1 } | exception_ { Gexception $1 } diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index 9644cfde65..3133501304 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -107,9 +107,22 @@ type pty_r = | PTglob of pmsymbol located and pty = pty_r located +(* Optional witness selector for a type-instantiation entry. Combines + label-suffix [/Lbl1/Lbl2/...] and path-via [via P] forms. Empty + means: let TC inference pick the witness as before. Parser accepts + any combination; the typer rejects irrelevant mixtures. *) +type pwitness_selector = { + pws_labels : psymbol list; + pws_via : pqsymbol option; +} + +let pws_none : pwitness_selector = { pws_labels = []; pws_via = None; } +let pws_is_empty (s : pwitness_selector) = + List.is_empty s.pws_labels && Option.is_none s.pws_via + type ptyannot_r = - | TVIunamed of pty list - | TVInamed of (psymbol * pty) list + | TVIunamed of (pty * pwitness_selector) list + | TVInamed of (psymbol * pty * pwitness_selector) list and ptyannot = ptyannot_r located @@ -136,19 +149,23 @@ and 'a rfield = { (* -------------------------------------------------------------------- *) type pmodule_type = pqsymbol -type ptyparam = psymbol +(* -------------------------------------------------------------------- *) +type ptcparam = pqsymbol * pty list +(* A class bound: class instantiation + optional label + rename clause. *) +type ptcbound = ptcparam * psymbol option * (psymbol * psymbol) list +type ptyparam = psymbol * ptcbound list type ptyparams = ptyparam list type ptydname = (ptyparams * psymbol) located type ptydecl = { - pty_name : psymbol; - pty_tyvars : ptyparams; - pty_body : ptydbody; + pty_name : psymbol; + pty_tyvars : ptyparams; + pty_body : ptydbody; pty_locality : locality; } and ptydbody = - | PTYD_Abstract + | PTYD_Abstract of ptcbound list | PTYD_Alias of pty | PTYD_Record of precord | PTYD_Datatype of pdatatype @@ -162,7 +179,6 @@ type f_or_mod_ident = | FM_FunOrVar of pgamepath | FM_Mod of pmsymbol located - type pmod_restr_mem_el = | PMPlus of f_or_mod_ident | PMMinus of f_or_mod_ident @@ -172,7 +188,7 @@ type pmod_restr_mem_el = type pmod_restr_mem = pmod_restr_mem_el list (* -------------------------------------------------------------------- *) -type pmemory = psymbol +type pmemory = psymbol type phoarecmp = EcFol.hoarecmp @@ -441,9 +457,6 @@ type psubtype = { } (* -------------------------------------------------------------------- *) -type ptyvardecls = - psymbol list - type pop_def = | PO_abstr of pty | PO_concr of pty * pformula @@ -465,7 +478,7 @@ type poperator = { po_name : psymbol; po_aliases: psymbol list; po_tags : psymbol list; - po_tyvars : ptyvardecls option; + po_tyvars : ptyparams option; po_args : ptybindings * ptybindings option; po_def : pop_def; po_ax : osymbol_r; @@ -499,7 +512,7 @@ and ppind = ptybindings * (ppind_ctor list) type ppredicate = { pp_name : psymbol; - pp_tyvars : psymbol list option; + pp_tyvars : ptyparams option; pp_def : ppred_def; pp_locality : locality; } @@ -507,7 +520,7 @@ type ppredicate = { (* -------------------------------------------------------------------- *) type pnotation = { nt_name : psymbol; - nt_tv : ptyvardecls option; + nt_tv : ptyparams option; nt_bd : (psymbol * pty) list; nt_args : (psymbol * (psymbol list * pty option)) list; nt_codom : pty; @@ -521,7 +534,7 @@ type abrvopts = (bool * abrvopt) list type pabbrev = { ab_name : psymbol; - ab_tv : ptyvardecls option; + ab_tv : ptyparams option; ab_args : ptybindings; ab_def : pty * pexpr; ab_opts : abrvopts; @@ -562,6 +575,7 @@ type pmpred_args = (osymbol * pformula) list type preduction = { pbeta : bool; (* β-reduction *) pdelta : pqsymbol list option; (* definition unfolding *) + pdeltatc : bool; pzeta : bool; (* let-reduction *) piota : bool; (* case/if-reduction *) peta : bool; (* η-reduction *) @@ -1146,13 +1160,28 @@ type prealize = { } (* -------------------------------------------------------------------- *) +type ptypeclass = { + ptc_name : psymbol; + ptc_params : ptyparams option; + ptc_inth : ptcbound list; + ptc_ops : (psymbol * pty) list; + ptc_axs : (psymbol * pformula) list; + ptc_loca : is_local; +} + type ptycinstance = { - pti_name : pqsymbol; - pti_type : ptyparams * pty; - pti_ops : (psymbol * (pty list * pqsymbol)) list; - pti_axs : (psymbol * ptactic_core) list; - pti_args : [`Ring of (zint option * zint option)] option; - pti_loca : is_local; + pti_tc : ptcparam; + pti_name : psymbol option; + pti_type : ptyparams * pty; + (* Each [op X = body] binding parses [body] as an arbitrary form. For + existing instances the body is a bare op application (e.g. + [CoreInt.zero]), which is a degenerate form; the elaborator + handles it uniformly via [trans_form]. *) + pti_ops : (psymbol * pformula) list; + pti_axs : (psymbol * psymbol list option * ptactic_core) list; + pti_args : [`Ring of (zint option * zint option)] option; + pti_loca : is_local; + pti_reducible : bool; } (* -------------------------------------------------------------------- *) @@ -1344,6 +1373,7 @@ type global_action = | Gaxiom of paxiom | Gtype of ptydecl list | Gsubtype of psubtype + | Gtypeclass of ptypeclass | Gtycinstance of ptycinstance | Gaddrw of (is_local * pqsymbol * pqsymbol list) | Greduction of puserred diff --git a/src/ecPath.ml b/src/ecPath.ml index 0cb0edf4da..8cb456c743 100644 --- a/src/ecPath.ml +++ b/src/ecPath.ml @@ -104,6 +104,9 @@ let rec tostring p = | Psymbol x -> x | Pqname (p,x) -> Printf.sprintf "%s.%s" (tostring p) x +let pp_path fmt p = + Format.fprintf fmt "%s" (tostring p) + let tolist = let rec aux l p = match p.p_node with @@ -394,10 +397,16 @@ let rec m_tostring (m : mpath) = in Printf.sprintf "%s%s%s" top args sub +let pp_mpath fmt p = + Format.fprintf fmt "%s" (m_tostring p) + let x_tostring x = Printf.sprintf "%s./%s" (m_tostring x.x_top) x.x_sub +let pp_xpath fmt x = + Format.fprintf fmt "%s" (x_tostring x) + (* -------------------------------------------------------------------- *) type smsubst = { sms_crt : path Mp.t; diff --git a/src/ecPath.mli b/src/ecPath.mli index ef2d2e8c0f..a34361bc7b 100644 --- a/src/ecPath.mli +++ b/src/ecPath.mli @@ -13,6 +13,8 @@ and path_node = | Psymbol of symbol | Pqname of path * symbol +val pp_path : Format.formatter -> path -> unit + (* -------------------------------------------------------------------- *) val psymbol : symbol -> path val pqname : path -> symbol -> path @@ -62,6 +64,8 @@ and mpath_top = [ | `Local of ident | `Concrete of path * path option ] +val pp_mpath : Format.formatter -> mpath -> unit + (* -------------------------------------------------------------------- *) val mpath : mpath_top -> mpath list -> mpath val mpath_abs : ident -> mpath list -> mpath @@ -96,6 +100,8 @@ type xpath = private { x_tag : int; } +val pp_xpath : Format.formatter -> xpath -> unit + val xpath : mpath -> symbol -> xpath val xastrip : xpath -> xpath diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index b5f4e20300..e3d7902159 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -194,8 +194,12 @@ module PPEnv = struct let ty_symb (ppe : t) p = let exists sm = - try EcPath.p_equal (EcEnv.Ty.lookup_path ~unique:true sm ppe.ppe_env) p - with EcEnv.LookupFailure _ -> false + let p1 = Option.map fst (EcEnv.Ty.lookup_opt sm ppe.ppe_env) in + let p2 = Option.map fst (EcEnv.TypeClass.lookup_opt sm ppe.ppe_env) in + + List.exists + (EcPath.p_equal p) + (Option.to_list p1 @ Option.to_list p2) in p_shorten ppe exists (P.toqsymbol p) @@ -206,6 +210,13 @@ module PPEnv = struct in p_shorten ppe exists (P.toqsymbol p) + let tci_symb (ppe : t) p = + let exists sm = + try EcPath.p_equal (EcEnv.TcInstance.lookup_path sm ppe.ppe_env) p + with EcEnv.LookupFailure _ -> false + in + p_shorten ppe exists (P.toqsymbol p) + let rw_symb (ppe : t) p = let exists sm = try EcPath.p_equal (EcEnv.BaseRw.lookup_path sm ppe.ppe_env) p @@ -227,7 +238,7 @@ module PPEnv = struct in p_shorten ppe exists (P.toqsymbol p) - let op_symb (ppe : t) p info = + let op_symb (ppe : t) (p : P.path) (info : ([`Expr | `Form] * etyarg list * dom) option) = let specs = [1, EcPath.pqoname (EcPath.prefix EcCoreLib.CI_Bool.p_eq) "<>"] in let check_for_local sm = @@ -241,13 +252,13 @@ module PPEnv = struct check_for_local sm; EcEnv.Op.lookup_path sm ppe.ppe_env - | Some (mode, typ, dom) -> + | Some (mode, ety, dom) -> let filter = match mode with | `Expr -> fun _ op -> not (EcDecl.is_pred op) | `Form -> fun _ _ -> true in - let tvi = Some (EcUnify.TVIunamed typ) in + let tvi = Some (EcUnify.tvi_unamed ety) in fun sm -> check_for_local sm; @@ -259,6 +270,13 @@ module PPEnv = struct let ue = EcUnify.UniEnv.create None in let ops = EcUnify.select_op ~hidden:true ~filter tvi ppe.ppe_env sm ue dom in let ops = match List.mbfilter by_current ops with [] -> ops | ops -> ops in + (* Run the same candidate-deduplication chain as the + elaborator. Without this, a TC class op like + [Top.TcRing.*] coexists with an abbreviation + [Top.TcMonoid.*] (a [mulmonoid]-view alias) and [op_symb] + can't pick a unique short form, falling back to qualified + — which then forces prefix display instead of infix. *) + let ops = EcUnify.canonicalize ppe.ppe_env ops in match ops with | [(p1, _), _, _, _] -> p1 @@ -382,7 +400,7 @@ module PPEnv = struct exception FoundUnivarSym of symbol - let tyunivar (ppe : t) i = + let univar (ppe : t) (i : EcUid.uid) = if not (Mint.mem i (fst !(ppe.ppe_univar))) then begin let alpha = "abcdefghijklmnopqrstuvwxyz" in @@ -495,6 +513,14 @@ let pp_paren pp fmt x = let pp_maybe_paren c pp = pp_maybe c pp_paren pp +(* -------------------------------------------------------------------- *) +let pp_bracket pp fmt x = + pp_enclose ~pre:"[" ~post:"]" pp fmt x + +(* -------------------------------------------------------------------- *) +let pp_maybe_bracket c pp = + pp_maybe c pp_bracket pp + (* -------------------------------------------------------------------- *) let pp_string fmt x = Format.fprintf fmt "%s" x @@ -547,8 +573,12 @@ let pp_tyvar ppe fmt x = Format.fprintf fmt "%s" (PPEnv.tyvar ppe x) (* -------------------------------------------------------------------- *) -let pp_tyunivar ppe fmt x = - Format.fprintf fmt "%s" (PPEnv.tyunivar ppe x) +let pp_tyunivar (ppe : PPEnv.t) (fmt : Format.formatter) (a : tyuni) = + Format.fprintf fmt "%s" (PPEnv.univar ppe (a :> EcUid.uid)) + +(* -------------------------------------------------------------------- *) +let pp_tcunivar (ppe : PPEnv.t) (fmt : Format.formatter) (a : tcuni) = + Format.fprintf fmt "%s" (PPEnv.univar ppe (a :> EcUid.uid)) (* -------------------------------------------------------------------- *) let pp_tyname ppe fmt p = @@ -559,6 +589,10 @@ let pp_tcname ppe fmt p = Format.fprintf fmt "%a" EcSymbols.pp_qsymbol (PPEnv.tc_symb ppe p) (* -------------------------------------------------------------------- *) +let pp_tciname ppe fmt p = + Format.fprintf fmt "%a" EcSymbols.pp_qsymbol (PPEnv.tci_symb ppe p) + + (* -------------------------------------------------------------------- *) let pp_rwname ppe fmt p = Format.fprintf fmt "%a" EcSymbols.pp_qsymbol (PPEnv.rw_symb ppe p) @@ -840,7 +874,7 @@ let rec pp_type_r (pp_paren (pp_list ",@ " subpp)) xs (pp_tyname ppe) name in - maybe_paren outer t_prio_name pp fmt (name, tyargs) + maybe_paren outer t_prio_name pp fmt (name, List.map fst tyargs) end | Tfun (t1, t2) -> @@ -1091,41 +1125,114 @@ let pp_app (type v1 v2) maybe_paren outer e_app_prio pp fmt () (* -------------------------------------------------------------------- *) -(* [tvi_dominated env op nargs] checks whether all type parameters of [op] - can be inferred from the types of the first [nargs] arguments. *) +(* [tvi_dominated env op nargs] checks whether all type parameters of + [op] can be inferred from the types visible at the use site: the + types of the first [nargs] arguments AND the type of the residual + term after those args have been consumed (i.e. the unconsumed-dom + suffix plus the codomain). Including the residual type catches + nullary ops whose tparam appears only in the codomain — like + [zero ['a]: 'a] used bare — for which the surrounding context + pins ['a]. *) let tvi_dominated (env : EcEnv.env) (op : EcPath.path) (nargs : int) : bool = match EcEnv.Op.by_path_opt op env with | None -> false | Some opdecl -> let tparams = opdecl.op_tparams in - let dom, _ = tyfun_flat opdecl.op_ty in + let dom, codom = tyfun_flat opdecl.op_ty in let arg_tys = List.take nargs dom in + let residual = EcTypes.toarrow (List.drop nargs dom) codom in let covered = List.fold_left (fun acc ty -> Sid.union acc (EcTypes.Tvar.fv ty)) - Sid.empty arg_tys in - List.for_all (fun id -> Sid.mem id covered) tparams + Sid.empty (residual :: arg_tys) in + List.for_all (fun (id, _) -> Sid.mem id covered) tparams + +(* -------------------------------------------------------------------- *) +let pp_opname fmt (nm, op) = + let op = + if EcCoreLib.is_mixfix_op op then + Printf.sprintf "\"%s\"" op + else if is_binop op then begin + if op.[0] = '*' || op.[String.length op - 1] = '*' + then Format.sprintf "( %s )" op + else Format.sprintf "(%s)" op + end else op + + in EcSymbols.pp_qsymbol fmt (nm, op) + +(* -------------------------------------------------------------------- *) +let rec pp_etyarg (ppe : PPEnv.t) (fmt : Format.formatter) ((ty, tcws) : etyarg) = + match tcws with + | [] -> pp_type ppe fmt ty + | _ -> Format.fprintf fmt "%a[%a]" (pp_type ppe) ty (pp_tcws ppe) tcws + +(* -------------------------------------------------------------------- *) +and pp_etyargs (ppe : PPEnv.t) (fmt : Format.formatter) (etys : etyarg list) = + Format.fprintf fmt "%a" (pp_list ",@ " (pp_etyarg ppe)) etys + +(* -------------------------------------------------------------------- *) +and pp_tcw (ppe : PPEnv.t) (fmt : Format.formatter) (tcw : tcwitness) = + let pp_lift fmt = function + | [] -> () + | l when List.for_all (fun i -> i = 0) l -> + Format.fprintf fmt "^%d" (List.length l) + | l -> + Format.fprintf fmt "^[%a]" + (pp_list ",@ " (fun fmt i -> Format.fprintf fmt "%d" i)) l in + match tcw with + | TCIUni (uid, lift) -> + Format.fprintf fmt "%a%a" (pp_tcunivar ppe) uid pp_lift lift + + | TCIConcrete { path; etyargs; lift } -> + (match etyargs with + | [] -> Format.fprintf fmt "%a%a" (pp_tciname ppe) path pp_lift lift + | _ -> Format.fprintf fmt "%a[%a]%a" + (pp_tciname ppe) path (pp_etyargs ppe) etyargs pp_lift lift) + + | TCIAbstract { support = `Var x; offset; lift } -> + Format.fprintf fmt "%a.`%d%a" (pp_tyvar ppe) x (offset + 1) pp_lift lift + + | TCIAbstract { support = `Abs path; offset; lift } -> + Format.fprintf fmt "%a.`%d%a" (pp_tyname ppe) path (offset + 1) pp_lift lift + +(* -------------------------------------------------------------------- *) +and pp_tcws (ppe : PPEnv.t) (fmt : Format.formatter) (tcws : tcwitness list) = + Format.fprintf fmt "%a" (pp_list ",@ " (pp_tcw ppe)) tcws + +(* -------------------------------------------------------------------- *) +let pp_opname_with_tvi + (ppe : PPEnv.t) + (fmt : Format.formatter) + ((nm, op, tvi) : symbol list * symbol * etyarg list option) += + match tvi with + | None -> + pp_opname fmt (nm, op) + + | Some tvi -> + Format.fprintf fmt "%a<:%a>" + pp_opname (nm, op) (pp_etyargs ppe) tvi (* -------------------------------------------------------------------- *) let pp_opapp - (ppe : PPEnv.t) - (t_ty : 'a -> EcTypes.ty) - ((dt_sub : 'a -> (EcPath.path * _ * 'a list) option), - (pp_sub : PPEnv.t -> (opprec * iassoc) -> 'a pp), - (is_trm : 'a -> bool), - (is_tuple : 'a -> 'a list option), - (is_proj : EcPath.path -> 'a -> (EcIdent.t * int) option)) - (lwr_left : PPEnv.t -> ('a -> EcTypes.ty) -> 'a -> opprec -> int option) - (outer : ((_ * fixity) * iassoc)) - (fmt : Format.formatter) - ((pred : [`Expr | `Form]), - (op : EcPath.path), - (tvi : EcTypes.ty list), - (es : 'a list), - (tyopt : ty option)) + (ppe : PPEnv.t) + (t_ty : 'a -> EcTypes.ty) + ((dt_sub : 'a -> (EcPath.path * _ * 'a list) option), + (pp_sub : PPEnv.t -> opprec * iassoc -> Format.formatter -> 'a -> unit), + (is_trm : 'a -> bool), + (is_tuple : 'a -> 'a list option), + (is_proj : EcPath.path -> 'a -> (EcIdent.t * int) option)) + (lwr_left : PPEnv.t -> ('a -> EcTypes.ty) -> 'a -> + EcSymbols.symbol list -> opprec -> int option) + (outer : symbol list * ((_ * fixity) * iassoc)) + (fmt : Format.formatter) + ((pred : [`Expr | `Form]), + (op : EcPath.path), + (tvi : EcTypes.etyarg list), + (es : 'a list)) = let (nm, opname) = - PPEnv.op_symb ppe op (Some (pred, tvi, (List.map t_ty es, tyopt))) in + PPEnv.op_symb ppe op (Some (pred, tvi, List.map t_ty es)) in let pp_tuple_sub ppe prec fmt e = match is_tuple e with @@ -1171,7 +1278,7 @@ let pp_opapp let rec doit fmt args = match args with | [] -> - maybe_paren outer prio (fun fmt () -> pp fmt) fmt () + maybe_paren (snd outer) prio (fun fmt () -> pp fmt) fmt () | a :: args -> Format.fprintf fmt "%a@ %a" @@ -1195,10 +1302,10 @@ let pp_opapp pp_opname_with_tvi ppe fmt (nm, opname, tvi_opt) | _ -> - let pp_first = fun _ _ fmt op -> - pp_opname_with_tvi ppe fmt (fst op, snd op, tvi_opt) in - let pp fmt () = pp_app ppe ~pp_first ~pp_sub outer fmt ((nm, opname), es) in - maybe_paren outer max_op_prec pp fmt () + let pp_first = fun ppe _ -> pp_opname_with_tvi ppe in + let pp fmt () = + pp_app ppe ~pp_first ~pp_sub (snd outer) fmt (([], opname, tvi_opt), es) + in maybe_paren (snd outer) max_op_prec pp fmt () and try_pp_as_uniop () = match es with @@ -1216,7 +1323,7 @@ let pp_opapp (if is_trm e then "" else " ") (pp_sub ppe (opprio, `NonAssoc)) e in let pp fmt = - maybe_paren outer opprio (fun fmt () -> pp fmt) fmt + maybe_paren (snd outer) opprio (fun fmt () -> pp fmt) fmt in Some pp end @@ -1257,14 +1364,14 @@ let pp_opapp (pp_sub ppe (e_bin_prio_rop4, `Left )) e1 (pp_sub ppe (e_bin_prio_rop4, `Right)) e2 in let opprio_left = - match lwr_left ppe t_ty e2 e_bin_prio_rop4 with + match lwr_left ppe t_ty e2 nm e_bin_prio_rop4 with | None -> e_bin_prio_rop4 | Some n -> if n <= fst e_bin_prio_rop4 then (n, snd e_bin_prio_rop4) else e_bin_prio_rop4 in let pp fmt = - maybe_paren_gen outer (e_bin_prio_rop4, opprio_left) + maybe_paren_gen (snd outer) (e_bin_prio_rop4, opprio_left) (fun fmt () -> pp fmt) fmt in Some pp end @@ -1279,12 +1386,12 @@ let pp_opapp opname (pp_sub ppe (opprio, `Right)) e2 in let opprio_left = - match lwr_left ppe t_ty e2 opprio with + match lwr_left ppe t_ty e2 nm opprio with | None -> opprio | Some n -> if n <= fst opprio then (n, snd opprio) else opprio in let pp fmt = - maybe_paren_gen outer (opprio, opprio_left) + maybe_paren_gen (snd outer) (opprio, opprio_left) (fun fmt () -> pp fmt) fmt in Some pp @@ -1299,8 +1406,8 @@ let pp_opapp let pp_first _ _ fmt opname = let subpp = pp_sub ppe (e_uni_prio_rint, `NonAssoc) in Format.fprintf fmt "%a%s" subpp e opname in - let pp fmt () = pp_app ppe ~pp_first ~pp_sub outer fmt (opname, es) in - Some (maybe_paren outer max_op_prec pp) + let pp fmt () = pp_app ppe ~pp_first ~pp_sub (snd outer) fmt (opname, es) in + Some (maybe_paren (snd outer) max_op_prec pp) end | _ -> @@ -1338,7 +1445,7 @@ let pp_opapp let recp = EcDecl.operator_as_rcrd op in match EcEnv.Ty.by_path_opt recp env with - | Some { tyd_type = Record (_, fields) } + | Some { tyd_type = `Record (_, fields) } when List.length fields = List.length es -> begin let wmap = @@ -1414,7 +1521,7 @@ let pp_opapp (pp_list "@ " (pp_sub ppe (max_op_prec, `NonAssoc))) args in let pp fmt = - maybe_paren outer e_app_prio (fun fmt () -> pp fmt) fmt + maybe_paren (snd outer) e_app_prio (fun fmt () -> pp fmt) fmt in Some pp | _ -> None @@ -1440,7 +1547,7 @@ let pp_chained_orderings (type v) (pp_sub : PPEnv.t -> opprec * iassoc -> v pp) (outer : opprec * iassoc) (fmt : Format.formatter) - ((f, fs) : v * (P.path * ty list * v) list) + ((f, fs) : v * (P.path * etyarg list * v) list) = match fs with | [] -> pp_sub ppe outer fmt f @@ -1451,7 +1558,7 @@ let pp_chained_orderings (type v) ignore (List.fold_left (fun fe (op, tvi, f) -> let (nm, opname) = - PPEnv.op_symb ppe op (Some (`Form, tvi, ([t_ty fe; t_ty f], None))) + PPEnv.op_symb ppe op (Some (`Form, tvi, [t_ty fe; t_ty f])) in Format.fprintf fmt " %t@ %a" (fun fmt -> @@ -1541,7 +1648,7 @@ let pp_locality fmt lc = this function. see maybe_paren_gen for how this precedence is used *) -let lower_left (ppe : PPEnv.t) (t_ty : form -> EcTypes.ty) (f : form) (opprec : opprec) : int option +let lower_left (ppe : PPEnv.t) (t_ty : form -> EcTypes.ty) (f : form) (_nm : symbol list) (opprec : opprec) : int option = let rec l_l f opprec = match f.f_node with @@ -1555,7 +1662,7 @@ let lower_left (ppe : PPEnv.t) (t_ty : form -> EcTypes.ty) (f : form) (opprec : else l_l f2 e_bin_prio_rop4 | Fapp ({f_node = Fop (op, tys)}, [f1; f2]) -> (let (_, opname) = - PPEnv.op_symb ppe op (Some (`Form, tys, (List.map t_ty [f1; f2], None))) in + PPEnv.op_symb ppe op (Some (`Form, tys, List.map t_ty [f1; f2])) in match priority_of_binop opname with | None -> None | Some opprec' -> @@ -1721,9 +1828,9 @@ and try_pp_chained_orderings let as_ordering (f : form) = match match_pp_notations ~filter:(fun (p, _) -> is_ordering_op p) ppe f with - | Some ((op, (tvi, _)), ue, ev, ov, [i1; i2]) -> begin - let ti = Tvar.subst ov in - let tvi = List.map (ti -| tvar) tvi in + | Some ((op, (tvi, _)), ue, ev, (ov : EcUnify.UniEnv.opened), [i1; i2]) -> begin + let ti = Tvar.subst ov.subst in + let tvi = List.map (fun (t, _) -> (ti (tvar t), [])) tvi in let sb = EcMatching.MEV.assubst ue ev ppe.ppe_env in let i1 = Fsubst.f_subst sb i1 in let i2 = Fsubst.f_subst sb i2 in @@ -1756,11 +1863,10 @@ and try_pp_chained_orderings Option.fold ~none:(i1, acc) ~some:(collect acc (Some i1)) f1 in match collect [] None f with - | (_, ([] | [_])) -> - false - + | (_, ([] | [_])) -> false | (f, fs) -> - pp_chained_orderings ppe f_ty pp_form_r outer fmt (f, fs); + pp_chained_orderings + ppe f_ty pp_form_r outer fmt (f, fs); true | exception Bailout -> @@ -1810,15 +1916,13 @@ and match_pp_notations let a1, a2 = List.split_at na a in f_app f a1 (toarrow (List.map f_ty a2) oty), a2 else f_app f a oty, [] in - - let ev = MEV.of_idents (List.map fst nt.ont_args) `Form in - let ue = EcUnify.UniEnv.create None in - let ov = EcUnify.UniEnv.opentvi ue tv None in - let hy = EcEnv.LDecl.init ppe.PPEnv.ppe_env [] in - let bd = match (EcEnv.Memory.get_active_ss ppe.PPEnv.ppe_env) with - | None -> form_of_expr nt.ont_body - | Some m -> (ss_inv_of_expr m nt.ont_body).inv in - let bd = Fsubst.f_subst_tvar ~freshen:true ov bd in + let ev = MEV.of_idents (List.map fst nt.ont_args) `Form in + let ue = EcUnify.UniEnv.create None in + let ov = EcUnify.UniEnv.opentvi ue tv None in + let hy = EcEnv.LDecl.init ppe.PPEnv.ppe_env [] in + let mr = odfl (EcIdent.create "&hr") (EcEnv.Memory.get_active_ss ppe.PPEnv.ppe_env) in + let bd = form_of_expr ~m:mr nt.ont_body in + let bd = Fsubst.f_subst_tvar ~freshen:true ov.subst bd in try let (ue, ev) = @@ -1858,15 +1962,28 @@ and try_pp_notations | None -> false - | Some ((p, (tv, nt)), ue, ev, ov, eargs) -> - let ti = Tvar.subst ov in - let rty = ti nt.ont_resty in - let tv = List.map (ti -| tvar) tv in - let args = List.map (curry f_local -| snd_map ti) nt.ont_args in - let args = - let subst = EcMatching.MEV.assubst ue ev ppe.ppe_env in - List.map (Fsubst.f_subst subst) args in - let f = f_app (f_op p tv rty) (args @ eargs) f.f_ty in + | Some ((p, (_tv, nt)), ue, ev, (ov : EcUnify.UniEnv.opened), eargs) -> + let ti = Tvar.subst ov.subst in + (* After [f_match_core], the abbrev's tparam univars (created by + [opentvi] in [ov.subst]) have been bound by the matcher. Chase + those bindings through the unienv so the displayed [tv] / + [resty] / [args] show concrete carriers (e.g. [c]) rather than + the fresh univars [#a, #b, ...] that [ov.subst] alone would + produce. + + Use [ov.args] (the [etyarg list] from [opentvi], which carries + both the type univar AND its TC-witness univar(s)) instead of + just the bare tparams; chasing through [mev_subst] then + resolves both the type univars AND the TC-witness univars + into their committed forms, so the printed notation shows + both the carrier ([c]) and its TC witness when one exists. *) + let mev_subst = EcMatching.MEV.assubst ue ev ppe.ppe_env in + let chase ty = EcCoreSubst.ty_subst mev_subst (ti ty) in + let rty = chase nt.ont_resty in + let tv = List.map (EcCoreSubst.etyarg_subst mev_subst) ov.args in + let args = List.map (curry f_local -| snd_map chase) nt.ont_args in + let args = List.map (Fsubst.f_subst mev_subst) args in + let f = f_app (f_op_tc p tv rty) (args @ eargs) f.f_ty in pp_form_core_r ppe outer fmt f; true and pp_poe (ppe : PPEnv.t) (fmt : Format.formatter) (poe : form Mop.t) = @@ -1900,7 +2017,7 @@ and pp_form_core_r (f : form) = let pp_opapp ppe (outer : opprec * iassoc) (fmt : Format.formatter) - (op, tys, es, tyopt) = + (op, tys, es, _tyopt) = let rec dt_sub f = match destr_app f with | ({ f_node = Fop (p, tvi) }, args) -> Some (p, tvi, args) @@ -1930,7 +2047,7 @@ and pp_form_core_r in pp_opapp ppe f_ty (dt_sub, pp_form_r, is_trm, is_tuple, is_proj) - lower_left outer fmt (`Form, op, tys, es, tyopt) + lower_left ([], outer) fmt (`Form, op, tys, es) in match f.f_node with @@ -2135,8 +2252,9 @@ and pp_form_core_r (string_of_hcmp hs.bhs_cmp) (pp_form_r ppef (max_op_prec,`NonAssoc)) (bhs_bd hs).inv - | Fpr pr-> + | Fpr pr -> let me = EcEnv.Fun.prF_memenv pr.pr_event.m pr.pr_fun ppe.PPEnv.ppe_env in + let ppep = PPEnv.create_and_push_mem ppe ~active:true me in let pm = debug_mode || pr.pr_event.m.id_symb <> "&hr" in Format.fprintf fmt "Pr[@[%a@[%t@] %a@@ %a :@ %a@]]" @@ -2152,12 +2270,7 @@ and pp_form_core_r (pp_local ppe) pr.pr_mem (pp_form ppep) pr.pr_event.inv -and pp_form_r - (ppe : PPEnv.t) - (outer : opprec * iassoc) - (fmt : Format.formatter) - (f : form) -= +and pp_form_r (ppe : PPEnv.t) outer fmt f = let printers = [try_pp_notations; try_pp_form_eqveq; @@ -2351,7 +2464,7 @@ let pp_sform ppe fmt f = (* -------------------------------------------------------------------- *) let pp_typedecl (ppe : PPEnv.t) fmt (x, tyd) = let ppe = PPEnv.enter_theory ppe (Option.get (EcPath.prefix x)) in - let ppe = PPEnv.add_locals ppe tyd.tyd_params in + let ppe = PPEnv.add_locals ppe (List.map fst tyd.tyd_params) in let name = P.basename x in let pp_prelude fmt = @@ -2359,22 +2472,34 @@ let pp_typedecl (ppe : PPEnv.t) fmt (x, tyd) = | [] -> Format.fprintf fmt "type %s" name - | [tx] -> + | [(tx, _)] -> Format.fprintf fmt "type %a %s" (pp_tyvar ppe) tx name | txs -> Format.fprintf fmt "type %a %s" - (pp_paren (pp_list ",@ " (pp_tyvar ppe))) txs name + (pp_paren (pp_list ",@ " (pp_tyvar ppe))) (List.map fst txs) name and pp_body fmt = + let pp_one_tc fmt (tc : typeclass) = + match tc.tc_args with + | [] -> pp_tyname ppe fmt tc.tc_name + | [ty] -> + Format.fprintf fmt "%a %a" + (pp_type ppe) (fst ty) (pp_tyname ppe) tc.tc_name + | tys -> + Format.fprintf fmt "(%a) %a" + (pp_list ",@ " (pp_type ppe)) (List.fst tys) + (pp_tyname ppe) tc.tc_name in match tyd.tyd_type with - | Abstract -> - () + | `Abstract [] -> () + | `Abstract tcs -> + Format.fprintf fmt " <: %a" + (pp_list " &@ " pp_one_tc) tcs - | Concrete ty -> + | `Concrete ty -> Format.fprintf fmt " =@ %a" (pp_type ppe) ty - | Datatype { tydt_ctors = cs } -> + | `Datatype { tydt_ctors = cs } -> let pp_ctor fmt (c, cty) = match cty with | [] -> @@ -2385,7 +2510,7 @@ let pp_typedecl (ppe : PPEnv.t) fmt (x, tyd) = in Format.fprintf fmt " =@ [@[%a@]]" (pp_list " |@ " pp_ctor) cs - | Record (_, fields) -> + | `Record (_, fields) -> let pp_field fmt (f, fty) = Format.fprintf fmt "%s: @[%a@]" f (pp_type ppe) fty in @@ -2394,11 +2519,36 @@ let pp_typedecl (ppe : PPEnv.t) fmt (x, tyd) = in Format.fprintf fmt "@[%a%t%t.@]" pp_locality tyd.tyd_loca pp_prelude pp_body +(* -------------------------------------------------------------------- *) +let pp_typeclass (ppe : PPEnv.t) fmt tc = + match tc.tc_args with + | [] -> + pp_tyname ppe fmt tc.tc_name + + | [ty] -> + Format.fprintf fmt "%a %a" + (pp_type ppe) (fst ty) + (pp_tyname ppe) tc.tc_name + + | tys -> + Format.fprintf fmt "(%a) %a" + (pp_list ",@ " (pp_type ppe)) (List.map fst tys) + (pp_tyname ppe) tc.tc_name + +(* -------------------------------------------------------------------- *) +let pp_tyvar_ctt (ppe : PPEnv.t) fmt (tvar, ctt) = + match ctt with + | [] -> pp_tyvar ppe fmt tvar + | ctt -> + Format.fprintf fmt "%a <: %a" + (pp_tyvar ppe) tvar + (pp_list " &@ " (fun fmt tc -> pp_typeclass ppe fmt tc)) ctt + (* -------------------------------------------------------------------- *) let pp_tyvarannot (ppe : PPEnv.t) fmt (ids: ty_param list) = match ids with | [] -> () - | ids -> Format.fprintf fmt "[%a]" (pp_list ",@ " (pp_tyvar ppe)) ids + | ids -> Format.fprintf fmt "[%a]" (pp_list ",@ " (pp_tyvar_ctt ppe)) ids let pp_pvar (ppe : PPEnv.t) fmt ids = match ids with @@ -2480,8 +2630,19 @@ let pp_codepos_path ppe = (pp_list "" (pp_codepos_step ppe)) (* -------------------------------------------------------------------- *) -let pp_codepos (ppe : PPEnv.t) (fmt : Format.formatter) ((cpath, cp1) : CP.codepos) = - Format.fprintf fmt "%a%a" (pp_codepos_path ppe) cpath (pp_codepos1 ppe) cp1 +let pp_codepos (ppe : PPEnv.t) (fmt : Format.formatter) ((nm, cp1) : CP.codepos) = + let pp_nm (fmt : Format.formatter) ((cp, bs) : CP.codepos1 * CP.codepos_brsel) = + let bs = + match bs with + | `Cond true -> "." + | `Cond false -> "?" + | `Match cp -> Format.sprintf "#%s." cp + | `MatchByPos i -> Format.sprintf "#%d." i + in + Format.fprintf fmt "%a%s" (pp_codepos1 ppe) cp bs + in + + Format.fprintf fmt "%a%a" (pp_list "" pp_nm) nm (pp_codepos1 ppe) cp1 (* -------------------------------------------------------------------- *) let pp_codegap1 (ppe : PPEnv.t) (fmt : Format.formatter) (g : CP.codegap1) = @@ -2509,7 +2670,7 @@ let pp_codegap_range (ppe: PPEnv.t) (fmt: Format.formatter) ((cpath, cp1r) : CP. (* -------------------------------------------------------------------- *) let pp_opdecl_pr (ppe : PPEnv.t) fmt ((basename, ts, ty, op): symbol * ty_param list * ty * prbody option) = - let ppe = PPEnv.add_locals ppe ts in + let ppe = PPEnv.add_locals ppe (List.map fst ts) in let pp_body fmt = match op with @@ -2574,8 +2735,8 @@ let pp_exception_decl (ppe: PPEnv.t) fmt basename ty = pp_opname ([], basename) pp_body (* -------------------------------------------------------------------- *) -let pp_opdecl_op (ppe : PPEnv.t) fmt (basename, ts, ty, op) = - let ppe = PPEnv.add_locals ppe ts in +let pp_opdecl_op (ppe : PPEnv.t) fmt ((basename, ts, ty, op) : symbol * ty_param list * ty * _) = + let ppe = PPEnv.add_locals ppe (List.map fst ts) in let pp_body fmt = match op with @@ -2649,8 +2810,9 @@ let pp_opdecl_op (ppe : PPEnv.t) fmt (basename, ts, ty, op) = (pp_type ppe) fix.opf_resty (pp_list "@\n" pp_branch) cfix - | Some (OP_TC) -> - Format.fprintf fmt "= < type-class-operator >" + | Some (OP_TC (path, name)) -> + Format.fprintf fmt ": %a = < type-class operator `%s' of `%a'>" + (pp_type ppe) ty name (pp_tyname ppe) path | Some (OP_Exn _) -> Format.fprintf fmt "= < exception >" @@ -2667,7 +2829,7 @@ let pp_opdecl_op (ppe : PPEnv.t) fmt (basename, ts, ty, op) = let pp_opdecl_nt (ppe : PPEnv.t) fmt ((basename, ts, _ty, nt) : symbol * ty_param list * ty * notation) = - let ppe = PPEnv.add_locals ppe ts in + let ppe = PPEnv.add_locals ppe (List.map fst ts) in let pp_body fmt = let subppe, pplocs = @@ -2716,7 +2878,7 @@ let pp_opdecl in Format.fprintf fmt "@[%a%a%a@]" pp_locality op.op_loca pp_name x pp_decl op let pp_added_op (ppe : PPEnv.t) fmt op = - let ppe = PPEnv.add_locals ppe op.op_tparams in + let ppe = PPEnv.add_locals ppe (List.map fst op.op_tparams) in match op.op_tparams with | [] -> Format.fprintf fmt ": @[%a@]" (pp_type ppe) op.op_ty @@ -2738,7 +2900,7 @@ let tags_of_axkind = function | `Lemma -> [] let pp_axiom ?(long=false) (ppe : PPEnv.t) fmt (x, ax) = - let ppe = PPEnv.add_locals ppe ax.ax_tparams in + let ppe = PPEnv.add_locals ppe (List.map fst ax.ax_tparams) in let basename = P.basename x in let pp_spec fmt = @@ -3281,8 +3443,8 @@ let pp_equivS (ppe : PPEnv.t) ?prpo fmt es = let insync = EcMemory.mt_equal (snd es.es_ml) (snd es.es_mr) - && EcReduction.EqTest.for_stmt - ppe.PPEnv.ppe_env ~norm:false es.es_sl es.es_sr in +(* && EcReduction.EqTest.for_stmt + ppe.PPEnv.ppe_env ~norm:false es.es_sl es.es_sr in *) in let ppnode = if insync then begin @@ -3317,6 +3479,50 @@ let pp_rwbase ppe fmt (p, rws) = Format.fprintf fmt "%a = %a@\n%!" (pp_rwname ppe) p (pp_list ", " (pp_axname ppe)) (Sp.elements rws) +(* -------------------------------------------------------------------- *) +let pp_tparam ppe fmt (id, tcs) = + Format.fprintf fmt "%a <: %a" + pp_symbol (EcIdent.name id) + (pp_list " &@ " (pp_typeclass ppe)) tcs + +let pp_tparams ppe fmt tparams = + Format.fprintf fmt "%a" + (pp_maybe (List.length tparams != 0) (pp_enclose ~pre:"[" ~post:"] ") (pp_list ",@ " (pp_tparam ppe))) tparams + +let pp_prts ppe fmt = function + | [] -> () + | tcs -> + let pp_one fmt (p, _lbl, _ren) = pp_typeclass ppe fmt p in + Format.fprintf fmt " <: %a" + (pp_list "@ & " pp_one) tcs + +let pp_op ppe fmt (t, ty) = + Format.fprintf fmt " @[op %s :@ %a.@]" + (EcIdent.name t) + (pp_type ppe) ty + +let pp_ops ppe fmt ops = + pp_maybe (List.length ops != 0) (pp_enclose ~pre:"" ~post:"@,@,") (pp_list "@,@," (pp_op ppe)) fmt ops + +let pp_ax ppe fmt (s, f) = + Format.fprintf fmt " @[axiom %s :@ %a.@]" + s (pp_form ppe) f + +let pp_axs ppe fmt axs = + pp_maybe (List.length axs != 0) (pp_enclose ~pre:"" ~post:"@,@,") (pp_list "@,@," (pp_ax ppe)) fmt axs + +let pp_ops_axs ppe fmt (ops, axs) = + Format.fprintf fmt "%a%a" + (pp_maybe (List.length ops + List.length axs != 0) (pp_enclose ~pre:"@,@," ~post:"") (pp_ops ppe)) ops + (pp_axs ppe) axs + +let pp_tc_decl ppe fmt (p, tcdecl) = + Format.fprintf fmt "@[type class %a%a%a = {%a}.@]" + (pp_tparams ppe) tcdecl.tc_tparams + (pp_tyname ppe) p + (pp_prts ppe) tcdecl.tc_prts + (pp_ops_axs ppe) (tcdecl.tc_ops, tcdecl.tc_axs) + (* -------------------------------------------------------------------- *) let pp_solvedb ppe fmt (db: (int * (P.path * _) list) list) = List.iter (fun (lvl, ps) -> @@ -3409,7 +3615,7 @@ module PPGoal = struct in (ppe, (id, pdk)) let pp_goal1 ?(pphyps = true) ?prpo ?(idx) (ppe : PPEnv.t) fmt (hyps, concl) = - let ppe = PPEnv.add_locals ppe hyps.EcBaseLogic.h_tvar in + let ppe = PPEnv.add_locals ppe (List.map fst hyps.EcBaseLogic.h_tvar) in let ppe, pps = List.map_fold pre_pp_hyp ppe (List.rev hyps.EcBaseLogic.h_local) in idx |> oiter (Format.fprintf fmt "Goal #%d@\n"); @@ -3420,7 +3626,7 @@ module PPGoal = struct | [] -> Format.fprintf fmt "Type variables: @\n\n%!" | tv -> Format.fprintf fmt "Type variables: %a@\n\n%!" - (pp_list ", " (pp_tyvar ppe)) tv + (pp_list ", " (pp_tyvar ppe)) (List.map fst tv) end; List.iter (fun (id, (pk, dk)) -> let pk fmt = @@ -3455,7 +3661,7 @@ end (* -------------------------------------------------------------------- *) let pp_hyps (ppe : PPEnv.t) fmt hyps = let hyps = EcEnv.LDecl.tohyps hyps in - let ppe = PPEnv.add_locals ppe hyps.EcBaseLogic.h_tvar in + let ppe = PPEnv.add_locals ppe (List.map fst hyps.EcBaseLogic.h_tvar) in let ppe, pps = List.map_fold PPGoal.pre_pp_hyp ppe (List.rev hyps.EcBaseLogic.h_local) in @@ -3464,7 +3670,7 @@ let pp_hyps (ppe : PPEnv.t) fmt hyps = | [] -> Format.fprintf fmt "Type variables: @\n\n%!" | tv -> Format.fprintf fmt "Type variables: %a@\n\n%!" - (pp_list ", " (pp_tyvar ppe)) tv + (pp_list ", " (pp_tyvar ppe)) (List.map fst tv) end; List.iter (fun (id, (pk, dk)) -> let pk fmt = @@ -3615,7 +3821,7 @@ let rec pp_instr_r (ppe : PPEnv.t) fmt i = let pp_branch fmt ((vars, s), (cname, _)) = let ptn = EcTypes.toarrow (List.snd vars) e.e_ty in - let ptn = f_op (EcPath.pqoname (EcPath.prefix p) cname) typ ptn in + let ptn = f_op_tc (EcPath.pqoname (EcPath.prefix p) cname) typ ptn in let ptn = f_app ptn (List.map (fun (x, ty) -> f_local x ty) vars) e.e_ty in Format.fprintf fmt "| %a => @[%a@]@ " @@ -3770,10 +3976,13 @@ let rec pp_theory ppe (fmt : Format.formatter) (path, cth) = Format.fprintf fmt "export %a." EcSymbols.pp_qsymbol (PPEnv.th_symb ppe p) - | EcTheory.Th_instance ((typ, ty), tc, lc) -> begin - let ppe = PPEnv.add_locals ppe typ in (* FIXME *) + | EcTheory.Th_typeclass _ -> + Format.fprintf fmt "typeclass ." + + | EcTheory.Th_instance (_, tci) -> begin + let ppe = PPEnv.add_locals ppe (List.map fst tci.tci_params) in - match tc with + match tci.tci_instance with | (`Ring _ | `Field _) as tc -> begin let (name, ops) = let rec ops_of_ring cr = @@ -3809,10 +4018,10 @@ let rec pp_theory ppe (fmt : Format.formatter) (path, cth) = in Format.fprintf fmt "%ainstance %s with [%a] %a@\n@[ %a@]" - pp_locality lc + pp_locality tci.tci_local name - (pp_paren (pp_list ",@ " (pp_tyvar ppe))) typ - (pp_type ppe) ty + (pp_paren (pp_list ",@ " (pp_tyvar ppe))) (List.map fst tci.tci_params) + (pp_type ppe) tci.tci_type (pp_list "@\n" (fun fmt (name, op) -> Format.fprintf fmt "op %s = %s" @@ -3820,9 +4029,11 @@ let rec pp_theory ppe (fmt : Format.formatter) (path, cth) = ops end - | `General p -> + | `General (tc, _) -> Format.fprintf fmt "%ainstance %a with %a." - pp_locality lc (pp_type ppe) ty pp_path p + pp_locality tci.tci_local + (pp_type ppe) tci.tci_type + (pp_typeclass ppe) tc end | EcTheory.Th_baserw (name, _lc) -> @@ -4043,6 +4254,12 @@ module ObjectInfo = struct | `Rewrite name -> pr_rw fmt env name | `Solve name -> pr_at fmt env name + (* ------------------------------------------------------------------ *) + let pr_tc_r = + { od_name = "type classes"; + od_lookup = EcEnv.TypeClass.lookup; + od_printer = pp_tc_decl; } + (* ------------------------------------------------------------------ *) let pr_any fmt env qs = let printers = [pr_gen_r ~prcat:true pr_ty_r ; @@ -4052,7 +4269,8 @@ module ObjectInfo = struct pr_gen_r ~prcat:true pr_mod_r; pr_gen_r ~prcat:true pr_mty_r; pr_gen_r ~prcat:true pr_rw_r ; - pr_gen_r ~prcat:true pr_at_r ; ] in + pr_gen_r ~prcat:true pr_at_r ; + pr_gen_r ~prcat:true pr_tc_r ; ] in let ok = ref (List.length printers) in diff --git a/src/ecProcSem.ml b/src/ecProcSem.ml index 2fb1af20f5..c997d47005 100644 --- a/src/ecProcSem.ml +++ b/src/ecProcSem.ml @@ -416,7 +416,7 @@ and translate_e (env : senv) (e : expr) = raise SemNotSupported | _ -> - e_map (fun x -> x) (translate_e env) e + e_map (fun ty -> ty) (translate_e env) e (* -------------------------------------------------------------------- *) and translate_lv (env : senv) (lv : lvalue) : lpattern = diff --git a/src/ecProofTerm.ml b/src/ecProofTerm.ml index 4235c079a8..9cd4e10dce 100644 --- a/src/ecProofTerm.ml +++ b/src/ecProofTerm.ml @@ -111,36 +111,46 @@ let can_concretize (pt : pt_env) = (* -------------------------------------------------------------------- *) let concretize_env pe = - CPTEnv (EcMatching.MEV.assubst pe.pte_ue !(pe.pte_ev) (LDecl.toenv pe.pte_hy)) + let env = LDecl.toenv pe.pte_hy in + CPTEnv (EcMatching.MEV.assubst pe.pte_ue !(pe.pte_ev) env, env) + +(* Substitute [subst] in [f] and then fold every TC op whose witness + resolves through a [tci_reducible] instance. Used to normalise a + form right after a polymorphic template has been instantiated at + a concrete carrier — without this, the user-visible term carries + verbose [op<:T[Conc(...)]>]-style heads instead of the underlying + core op. The fold for non-reducible-marked instances is a no-op. *) +let cpt_subst_form ((subst, env) : f_subst * EcEnv.env) (f : form) : form = + EcReduction.fold_reducible_tc env (Fsubst.f_subst subst f) (* -------------------------------------------------------------------- *) -let concretize_e_form_gen (CPTEnv subst) ids f = - let f = Fsubst.f_subst subst f in +let concretize_e_form_gen (CPTEnv (subst, env)) ids f = + let f = cpt_subst_form (subst, env) f in let ids = List.map (snd_map (Fsubst.gty_subst subst)) ids in f_forall ids f (* -------------------------------------------------------------------- *) -let concretize_e_form cptenv f = - concretize_e_form_gen cptenv [] f +let concretize_e_form (CPTEnv (subst, env)) f = + cpt_subst_form (subst, env) f (* -------------------------------------------------------------------- *) -let rec concretize_e_arg ((CPTEnv subst) as cptenv) arg = +let rec concretize_e_arg ((CPTEnv (subst, env)) as cptenv) arg = match arg with - | PAFormula f -> PAFormula (Fsubst.f_subst subst f) + | PAFormula f -> PAFormula (cpt_subst_form (subst, env) f) | PAMemory m -> PAMemory (Fsubst.m_subst subst m) | PAModule (mp, ms) -> PAModule (mp, ms) | PASub pt -> PASub (pt |> omap (concretize_e_pt cptenv)) -and concretize_e_head ((CPTEnv subst) as cptenv) head = +and concretize_e_head ((CPTEnv (subst, env)) as cptenv) head = match head with - | PTCut (f, s) -> PTCut (Fsubst.f_subst subst f, s) + | PTCut (f, s) -> PTCut (cpt_subst_form (subst, env) f, s) | PTHandle h -> PTHandle h | PTLocal x -> PTLocal x - | PTGlobal (p, tys) -> PTGlobal (p, List.map (ty_subst subst) tys) + | PTGlobal (p, tys) -> PTGlobal (p, List.map (EcCoreSubst.etyarg_subst subst) tys) | PTTerm pt -> PTTerm (concretize_e_pt cptenv pt) -and concretize_e_pt ((CPTEnv subst) as cptenv) pt = +and concretize_e_pt ((CPTEnv (subst, _)) as cptenv) pt = match pt with | PTApply { pt_head; pt_args } -> PTApply { @@ -163,8 +173,8 @@ let concretize_gen ({ ptev_env = pe } as pt) ids = (* -------------------------------------------------------------------- *) let concretize ({ ptev_env = pe } as pt) = - let (CPTEnv subst) as cptenv = concretize_env pe in - (concretize_e_pt cptenv pt.ptev_pt, Fsubst.f_subst subst pt.ptev_ax) + let (CPTEnv (subst, env)) as cptenv = concretize_env pe in + (concretize_e_pt cptenv pt.ptev_pt, cpt_subst_form (subst, env) pt.ptev_ax) (* -------------------------------------------------------------------- *) let tc_pterm_apperror pte ?loc (kind : apperror) = @@ -191,23 +201,31 @@ let pt_of_hyp_r ptenv x = ptev_ax = ax; } (* -------------------------------------------------------------------- *) -let pt_of_global pf hyps p tys = +let pt_of_global_tc pf hyps p etyargs = let ptenv = ptenv_of_penv hyps pf in - let ax = EcEnv.Ax.instantiate p tys (LDecl.toenv hyps) in + let ax = EcEnv.Ax.instanciate p etyargs (LDecl.toenv hyps) in { ptev_env = ptenv; - ptev_pt = ptglobal ~tys p; + ptev_pt = ptglobal ~tys:etyargs p; ptev_ax = ax; } (* -------------------------------------------------------------------- *) -let pt_of_global_r ptenv p tys = +let pt_of_global pf hyps p tys = + pt_of_global_tc pf hyps p (List.map (fun ty -> (ty, [])) tys) + +(* -------------------------------------------------------------------- *) +let pt_of_global_tc_r ptenv p etyargs = let env = LDecl.toenv ptenv.pte_hy in - let ax = EcEnv.Ax.instantiate p tys env in + let ax = EcEnv.Ax.instanciate p etyargs env in { ptev_env = ptenv; - ptev_pt = ptglobal ~tys p; + ptev_pt = ptglobal ~tys:etyargs p; ptev_ax = ax; } +(* -------------------------------------------------------------------- *) +let pt_of_global_r ptenv p tys = + pt_of_global_tc_r ptenv p (List.map (fun ty -> (ty, [])) tys) + (* -------------------------------------------------------------------- *) let pt_of_handle_r ptenv hd = let g = FApi.get_pregoal_by_id hd ptenv.pte_pe in @@ -222,13 +240,11 @@ let pt_of_uglobal_r ptenv p = let ax = oget (EcEnv.Ax.by_path_opt p env) in let typ, ax = (ax.EcDecl.ax_tparams, ax.EcDecl.ax_spec) in - (* FIXME: TC HOOK *) let fs = EcUnify.UniEnv.opentvi ptenv.pte_ue typ None in - let ax = Fsubst.f_subst_tvar ~freshen:true fs ax in - let typ = List.map (fun a -> EcIdent.Mid.find a fs) typ in + let ax = Fsubst.f_subst_tvar ~freshen:true fs.subst ax in { ptev_env = ptenv; - ptev_pt = ptglobal ~tys:typ p; + ptev_pt = ptglobal ~tys:fs.args p; ptev_ax = ax; } (* -------------------------------------------------------------------- *) @@ -313,21 +329,95 @@ let pf_find_occurence | _, _ -> false in + (* Two heads match keywise iff they're path-equal, OR the candidate's + head TC-reduces (via factory rename on its abstract witness) to an + [Fop] with the pattern's key. Without the second clause, [rewrite L] + misses positions where [L]'s LHS uses a class op like [( * )<:comring>] + and the goal has the rename-equivalent [(+)<:t mulmonoid leg>] — + deeper matching would resolve them, but [keycheck] would have + filtered them out first. *) + let env_for_kmatch = EcEnv.LDecl.toenv pt.pte_hy in + let head_op_after_tc_reduce (head : form) : EcPath.path option = + match head.f_node with + | Fop (p, tys) -> begin + match EcEnv.Op.tc_reduce env_for_kmatch p tys with + | exception EcEnv.NotReducible -> None + | reduced -> + match (fst (destr_app reduced)).f_node with + | Fop (p', _) -> Some p' + | _ -> None + end + | _ -> None in + (* Reverse-instance lookup: given a TC class op [tcop] and a + concrete op [concrete], is there a registered instance where + [tcop]'s realisation is [concrete]? Used by [kmatch] when the + pattern is a TC-op call with a univar carrier (so [tc_reduce] + can't fire forward) and the goal's head is the concrete + realisation. Lets [rewrite mul0r] (no TVI) match positions + whose head is e.g. [polyM] — pinning the carrier via + [try_delta] / [doit_tc_reduce] downstream. *) + let tc_op_realised_by tcop concrete = + EcEnv.Op.tc_op_realised_by env_for_kmatch tcop concrete in + (* Compute the alternative head an [Fop p tys] could expose after a + single [tc_reduce] step at the carrier. Used for both pattern- and + goal-side keyed matching. *) + let kmatch_alt_head (head : form) : EcPath.path option = + head_op_after_tc_reduce head in let kmatch key tp = - match key, (fst (destr_app tp)).f_node with + let tp_head = fst (destr_app tp) in + match key, tp_head.f_node with | `NoKey , _ -> true - | `Path p, Fop (p', _) -> EcPath.p_equal p p' - | `Path _, _ -> false + | `Path p, Fop (p', _) when EcPath.p_equal p p' -> true + | `Path p, Fop (p', _) when tc_op_realised_by p p' -> true + | `Path p, _ -> begin + match kmatch_alt_head tp_head with + | Some p' when EcPath.p_equal p p' -> true + (* Multi-parent factory rename: pattern's [p] is a TC op (e.g. + [( * )] from comring) and goal's head is a different TC op + (e.g. [(+)] inherited from monoid via comring's mulmonoid + parent edge with [( * ) := (+)] rename). The goal's head + [tc_reduce]s to a concrete op; check whether the pattern's + [p] is also realised by that same concrete op in some + registered instance. *) + | Some p' -> tc_op_realised_by p p' + | None -> false + end | `Var x, Flocal x' -> id_equal x x' | `Var _, _ -> false in - let keycheck tp key = not occmode.k_keyed || kmatch key tp in - - (* Extract key from pattern *) + let keycheck tp key = + let r = not occmode.k_keyed || kmatch key tp in + if Sys.getenv_opt "EC_DBG_KEY" <> None then begin + let dump_key = function + | `NoKey -> "NoKey" + | `Path p -> "Path " ^ EcPath.tostring p + | `Var v -> "Var " ^ EcIdent.name v in + let dump_head f = + match (destr_app f) with + | { f_node = Fop (p, _); _ }, _ -> "Fop " ^ EcPath.tostring p + | { f_node = Flocal id; _ }, _ -> "Flocal " ^ EcIdent.name id + | _ -> "" in + Format.eprintf "[keycheck] key=%s head=%s -> %b@." + (dump_key key) (dump_head tp) r + end; + r in + + (* Extract key from pattern. For a TC-op pattern, take the *reduced* + head as the key when [tc_reduce] yields a concrete op at the + pattern's carrier — that's the form most goals will have after + abbrev expansion at that carrier. Without this, [rewrite L] with + [L] using a class op like [(+)<:int poly>] would key on [(+)] + and miss goals where the same position has been elaborated to + the carrier's structural realisation (e.g. [polyD]). *) let key = - match (fst (destr_app ptn)).f_node with - | Fop (p, _) -> `Path p + let ptn_head = fst (destr_app ptn) in + match ptn_head.f_node with + | Fop (p, _) -> begin + match kmatch_alt_head ptn_head with + | Some p' -> `Path p' + | None -> `Path p + end | Flocal x -> if is_none (EcMatching.MEV.get x `Form !(pt.pte_ev)) then `Var x @@ -514,14 +604,16 @@ let process_named_pterm pe (tvi, fp) = (fun () -> omap (EcTyping.transtvi env pe.pte_ue) tvi) in - PT.pf_check_tvi pe.pte_pe typ tvi; + PT.pf_check_tvi env pe.pte_pe typ tvi; - (* FIXME: TC HOOK *) - let fs = EcUnify.UniEnv.opentvi pe.pte_ue typ tvi in - let ax = Fsubst.f_subst_tvar ~freshen:false fs ax in - let typ = List.map (fun a -> EcIdent.Mid.find a fs) typ in + let fs = + try EcUnify.UniEnv.opentvi ~env pe.pte_ue typ tvi + with EcUnify.UniEnv.InvalidSelector msg -> + tc_error pe.pte_pe "invalid witness selector: %s" msg + in + let ax = Fsubst.f_subst_tvar ~freshen:false fs.subst ax in - (p, (typ, ax)) + (p, (fs.args, ax)) (* ------------------------------------------------------------------ *) let process_pterm_cut ~prcut pe pt = @@ -918,7 +1010,7 @@ let tc1_process_full_closed_pterm (tc : tcenv1) (ff : ppterm) = (* -------------------------------------------------------------------- *) type prept = [ | `Hy of EcIdent.t - | `G of EcPath.path * ty list + | `G of EcPath.path * etyarg list | `UG of EcPath.path | `HD of handle | `PE of pt_ev @@ -937,8 +1029,8 @@ and prept_arg = [ let pt_of_prept_r (ptenv : pt_env) : prept -> pt_ev = let rec build_pt : prept -> pt_ev = function | `Hy id -> pt_of_hyp_r ptenv id - | `G (p, tys) -> pt_of_global_r ptenv p tys - | `UG p -> pt_of_global_r ptenv p [] + | `G (p, tys) -> pt_of_global_tc_r ptenv p tys + | `UG p -> pt_of_global_tc_r ptenv p [] | `HD hd -> pt_of_handle_r ptenv hd | `PE pe -> pe | `App (pt, args) -> List.fold_left app_pt_ev (build_pt pt) args diff --git a/src/ecProofTerm.mli b/src/ecProofTerm.mli index af3d0509fe..2045187f6d 100644 --- a/src/ecProofTerm.mli +++ b/src/ecProofTerm.mli @@ -154,12 +154,13 @@ val ptenv : proofenv -> LDecl.hyps -> (EcUnify.unienv * mevmap) -> pt_env val copy : pt_env -> pt_env (* Proof-terms construction from components *) -val pt_of_hyp : proofenv -> LDecl.hyps -> EcIdent.t -> pt_ev -val pt_of_global_r : pt_env -> EcPath.path -> ty list -> pt_ev -val pt_of_global : proofenv -> LDecl.hyps -> EcPath.path -> ty list -> pt_ev -val pt_of_uglobal_r : pt_env -> EcPath.path -> pt_ev -val pt_of_uglobal : proofenv -> LDecl.hyps -> EcPath.path -> pt_ev - +val pt_of_hyp : proofenv -> LDecl.hyps -> EcIdent.t -> pt_ev +val pt_of_global_tc_r : pt_env -> EcPath.path -> etyarg list -> pt_ev +val pt_of_global_tc : proofenv -> LDecl.hyps -> EcPath.path -> etyarg list -> pt_ev +val pt_of_global_r : pt_env -> EcPath.path -> ty list -> pt_ev +val pt_of_global : proofenv -> LDecl.hyps -> EcPath.path -> ty list -> pt_ev +val pt_of_uglobal_r : pt_env -> EcPath.path -> pt_ev +val pt_of_uglobal : proofenv -> LDecl.hyps -> EcPath.path -> pt_ev (* -------------------------------------------------------------------- *) val ffpattern_of_genpattern : LDecl.hyps -> genpattern -> ppterm option @@ -167,7 +168,7 @@ val ffpattern_of_genpattern : LDecl.hyps -> genpattern -> ppterm option (* -------------------------------------------------------------------- *) type prept = [ | `Hy of EcIdent.t - | `G of EcPath.path * ty list + | `G of EcPath.path * etyarg list | `UG of EcPath.path | `HD of handle | `PE of pt_ev @@ -190,7 +191,7 @@ module Prept : sig val (@) : prept -> prept_arg list -> prept val hyp : EcIdent.t -> prept - val glob : EcPath.path -> ty list -> prept + val glob : EcPath.path -> etyarg list -> prept val uglob : EcPath.path -> prept val hdl : handle -> prept diff --git a/src/ecProofTyping.ml b/src/ecProofTyping.ml index 6dffd0f6d9..403f215556 100644 --- a/src/ecProofTyping.ml +++ b/src/ecProofTyping.ml @@ -1,14 +1,13 @@ (* -------------------------------------------------------------------- *) open EcUtils open EcIdent +open EcAst open EcTypes open EcPath open EcFol open EcEnv open EcCoreGoal -open EcAst open EcParsetree -open EcUnify module Msym = EcSymbols.Msym @@ -26,12 +25,12 @@ let process_form_opt ?mv hyps pf oty = try let ue = unienv_of_hyps hyps in let ff = EcTyping.trans_form_opt ?mv (LDecl.toenv hyps) ue pf oty in - let ts = Tuni.subst (EcUnify.UniEnv.close ue) in + let ts = Tuni.subst ~tw_uni:(EcUnify.UniEnv.tw_assubst ue) (EcUnify.UniEnv.close ue) in EcFol.Fsubst.f_subst ts ff - with EcUnify.UninstantiateUni -> + with EcUnify.UninstanciateUni infos -> EcTyping.tyerror pf.EcLocation.pl_loc - (LDecl.toenv hyps) EcTyping.FreeTypeVariables + (LDecl.toenv hyps) (FreeUniVariables infos) (* ------------------------------------------------------------------ *) let process_form ?mv hyps pf ty = @@ -60,8 +59,10 @@ let process_type hyps pty = let ue = unienv_of_hyps hyps in let ty = EcTyping.transty EcTyping.tp_tydecl env ue pty in - if not (EcUnify.UniEnv.closed ue) then - EcTyping.tyerror (EcLocation.loc pty) env EcTyping.FreeTypeVariables; + begin match EcUnify.UniEnv.xclosed ue with + | None -> () + | Some flags -> EcTyping.tyerror (EcLocation.loc pty) env (EcTyping.FreeUniVariables flags) + end; let ts = Tuni.subst (EcUnify.UniEnv.close ue) in EcCoreSubst.ty_subst ts ty @@ -73,17 +74,17 @@ let process_stmt hyps s = let s = EcTyping.transstmt env ue s in try - let ts = Tuni.subst (EcUnify.UniEnv.close ue) in + let ts = Tuni.subst ~tw_uni:(EcUnify.UniEnv.tw_assubst ue) (EcUnify.UniEnv.close ue) in s_subst ts s - with EcUnify.UninstantiateUni -> - EcTyping.tyerror EcLocation._dummy env EcTyping.FreeTypeVariables + with EcUnify.UninstanciateUni flags -> + EcTyping.tyerror EcLocation._dummy env (EcTyping.FreeUniVariables flags) (* ------------------------------------------------------------------ *) let process_exp hyps mode oty e = let env = LDecl.toenv hyps in let ue = unienv_of_hyps hyps in let e = EcTyping.transexpcast_opt env mode ue oty e in - let ts = Tuni.subst (EcUnify.UniEnv.close ue) in + let ts = Tuni.subst ~tw_uni:(EcUnify.UniEnv.tw_assubst ue) (EcUnify.UniEnv.close ue) in e_subst ts e (* ------------------------------------------------------------------ *) @@ -166,7 +167,8 @@ let tc1_process_stmt ?map hyps tc c = let ue = unienv_of_hyps hyps in let c = Exn.recast_pe !!tc hyps (fun () -> EcTyping.transstmt ?map env ue c) in let uidmap = Exn.recast_pe !!tc hyps (fun () -> EcUnify.UniEnv.close ue) in - let es = Tuni.subst uidmap in + let tw_uni = EcUnify.UniEnv.tw_assubst ue in + let es = Tuni.subst ~tw_uni uidmap in s_subst es c @@ -228,11 +230,53 @@ let tc1_process_Xhl_formula ?side tc pf = let tc1_process_Xhl_formula_xreal tc pf = tc1_process_Xhl_form tc txreal pf + (* ------------------------------------------------------------------ *) -(* FIXME: factor out to typing module *) -(* FIXME: TC HOOK - check parameter constraints *) -(* ------------------------------------------------------------------ *) -let pf_check_tvi (pe : proofenv) (typ : EcDecl.ty_params) (tvi : tvar_inst option) = +let pf_check_tvi (env : env) (pe : proofenv) typ tvi = + let rec is_ground (ty : ty) = + match ty.ty_node with + | Tunivar _ | Tvar _ -> false + | _ -> not (ty_sub_exists (fun t -> not (is_ground t)) ty) in + + (* Walk the ancestor chain of each TC declared on an abstract type + [p] (i.e. [tyd_type = `Abstract tcs]) and accept [tc] if it + appears anywhere in [ancestors tcs(i)]. This mirrors Mode #6 of + the unifier strategies (see [strat_abs_via_decl] in ecUnify.ml). *) + let abs_satisfies (ty : ty) (tc : typeclass) = + match ty.ty_node with + | Tconstr (p, _) -> begin + match EcEnv.Ty.by_path_opt p env with + | Some { tyd_type = `Abstract tcs; _ } -> + let eq_tc tc' = + EcPath.p_equal tc.tc_name tc'.tc_name + && List.length tc.tc_args = List.length tc'.tc_args + && List.for_all2 + (fun (a, _) (b, _) -> EcCoreEqTest.for_type env a b) + tc.tc_args tc'.tc_args in + List.exists + (fun tc' -> List.exists eq_tc (EcTypeClass.ancestors env tc')) + tcs + | _ -> false + end + | _ -> false in + + (* Constraints can reference earlier tparams (e.g. 'c <: ('a, 'b) embed + references 'a, 'b). We substitute the user-supplied tparam values + before calling [infer]. *) + let check_constraints (subst : etyarg Mid.t) (tcs : typeclass list) (ty : ty) = + if is_ground ty then + List.iter (fun tc -> + let tc = EcCoreSubst.Tvar.subst_tc subst tc in + if Option.is_none (EcTypeClass.infer env ty tc) + && not (abs_satisfies ty tc) then + let ppe = EcPrinting.PPEnv.ofenv env in + tc_error_lazy pe (fun fmt -> + Format.fprintf fmt + "type @[%a@] does not satisfy typeclass constraint @[%a@]" + (EcPrinting.pp_type ppe) ty + (EcPrinting.pp_tyname ppe) tc.tc_name) + ) tcs in + match tvi with | None -> () @@ -240,15 +284,32 @@ let pf_check_tvi (pe : proofenv) (typ : EcDecl.ty_params) (tvi : tvar_inst optio if List.length tyargs <> List.length typ then tc_error pe "wrong number of type parameters (%d, expecting %d)" - (List.length tyargs) (List.length typ) + (List.length tyargs) (List.length typ); + let _ : etyarg Mid.t = + List.fold_left2 (fun subst (id, tcs) (ty_opt, _, _) -> + Option.iter (check_constraints subst tcs) ty_opt; + match ty_opt with + | Some ty -> Mid.add id (ty, []) subst + | None -> subst + ) Mid.empty typ tyargs + in () | Some (EcUnify.TVInamed tyargs) -> - let typnames = List.map EcIdent.name typ in + let typnames = List.map (fun (id, _) -> EcIdent.name id) typ in List.iter (fun (x, _) -> if not (List.mem x typnames) then tc_error pe "unknown type variable: %s" x) - tyargs + tyargs; + let _ : etyarg Mid.t = + List.fold_left (fun subst (id, tcs) -> + match List.assoc_opt (EcIdent.name id) tyargs with + | Some (Some ty, _, _) -> + check_constraints subst tcs ty; + Mid.add id (ty, []) subst + | _ -> subst + ) Mid.empty typ + in () (* -------------------------------------------------------------------- *) exception NoMatch diff --git a/src/ecProofTyping.mli b/src/ecProofTyping.mli index b5622e8b09..3a55995e46 100644 --- a/src/ecProofTyping.mli +++ b/src/ecProofTyping.mli @@ -1,11 +1,13 @@ (* -------------------------------------------------------------------- *) open EcParsetree open EcIdent +open EcAst +open EcFol open EcPath open EcDecl open EcEnv open EcCoreGoal -open EcAst +open EcMemory (* -------------------------------------------------------------------- *) type ptnenv = ty Mid.t * EcUnify.unienv @@ -15,7 +17,7 @@ type metavs = EcFol.form EcSymbols.Msym.t * proof-environment. See the [Exn] module for more information. *) val unienv_of_hyps : LDecl.hyps -> EcUnify.unienv -val pf_check_tvi : proofenv -> ty_params -> EcUnify.tvi -> unit +val pf_check_tvi : env -> proofenv -> ty_params -> EcUnify.tvi -> unit (* Typing in the environment implied by [LDecl.hyps]. *) val process_form_opt : ?mv:metavs -> LDecl.hyps -> pformula -> ty option -> form diff --git a/src/ecReduction.ml b/src/ecReduction.ml index d28cb2058c..1fd456f62e 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -16,47 +16,15 @@ exception IncompatibleType of env * (ty * ty) exception IncompatibleForm of env * (form * form) exception IncompatibleExpr of env * (expr * expr) -(* -------------------------------------------------------------------- *) -type 'a eqtest = env -> 'a -> 'a -> bool +type 'a eqtest = env -> 'a -> 'a -> bool type 'a eqntest = env -> ?norm:bool -> 'a -> 'a -> bool type 'a eqantest = env -> ?alpha:(EcIdent.t * ty) Mid.t -> ?norm:bool -> 'a -> 'a -> bool +(* -------------------------------------------------------------------- *) module EqTest_base = struct - let rec for_type env t1 t2 = - ty_equal t1 t2 || for_type_r env t1 t2 - - and for_type_r env t1 t2 = - match t1.ty_node, t2.ty_node with - | Tunivar uid1, Tunivar uid2 -> EcUid.uid_equal uid1 uid2 - - | Tvar i1, Tvar i2 -> i1 = i2 - - | Ttuple lt1, Ttuple lt2 -> - List.length lt1 = List.length lt2 - && List.all2 (for_type env) lt1 lt2 - - | Tfun (t1, t2), Tfun (t1', t2') -> - for_type env t1 t1' && for_type env t2 t2' - - | Tglob m1, Tglob m2 -> EcIdent.id_equal m1 m2 - - | Tconstr (p1, lt1), Tconstr (p2, lt2) when EcPath.p_equal p1 p2 -> - if - List.length lt1 = List.length lt2 - && List.all2 (for_type env) lt1 lt2 - then true - else - if Ty.defined p1 env - then for_type env (Ty.unfold p1 lt1 env) (Ty.unfold p2 lt2 env) - else false - - | Tconstr(p1,lt1), _ when Ty.defined p1 env -> - for_type env (Ty.unfold p1 lt1 env) t2 - - | _, Tconstr(p2,lt2) when Ty.defined p2 env -> - for_type env t1 (Ty.unfold p2 lt2 env) - - | _, _ -> false + (* ------------------------------------------------------------------ *) + let for_type = EcCoreEqTest.for_type + let for_etyarg = EcCoreEqTest.for_etyarg (* ------------------------------------------------------------------ *) let is_unit env ty = for_type env tunit ty @@ -137,7 +105,7 @@ module EqTest_base = struct for_pv env ~norm p1 p2 | Eop(o1,ty1), Eop(o2,ty2) -> - p_equal o1 o2 && List.all2 (for_type env) ty1 ty2 + p_equal o1 o2 && List.all2 (for_etyarg env) ty1 ty2 | Equant(q1,b1,e1), Equant(q2,b2,e2) when eqt_equal q1 q2 -> let alpha = check_bindings env alpha b1 b2 in @@ -409,6 +377,9 @@ let ensure b = if b then () else raise NotConv let check_ty env subst ty1 ty2 = ensure (EqTest_base.for_type env ty1 (ty_subst subst ty2)) +let check_etyarg env subst (ty1, w1) (ty2, w2) = + ensure (EqTest_base.for_etyarg env (ty1, w1) (ty_subst subst ty2, w2)) + let add_local (env, subst) (x1, ty1) (x2, ty2) = check_ty env subst ty1 ty2; env, @@ -538,7 +509,7 @@ let is_alpha_eq ?(subst=Fsubst.f_subst_id) hyps f1 f2 = check_mod subst m1 m2 | Fop(p1, ty1), Fop(p2, ty2) when EcPath.p_equal p1 p2 -> - List.iter2 (check_ty env subst) ty1 ty2 + List.iter2 (check_etyarg env subst) ty1 ty2 | Fapp(f1',args1), Fapp(f2',args2) when List.length args1 = List.length args2 -> @@ -636,6 +607,7 @@ type reduction_info = { beta : bool; delta_p : (path -> deltap); (* reduce operators *) delta_h : (ident -> bool); (* reduce local definitions *) + delta_tc : bool; zeta : bool; iota : bool; eta : bool; @@ -652,6 +624,7 @@ let full_red = { beta = true; delta_p = (fun _ -> `IfTransparent); delta_h = EcUtils.predT; + delta_tc = true; zeta = true; iota = true; eta = true; @@ -661,15 +634,16 @@ let full_red = { } let no_red = { - beta = false; - delta_p = (fun _ -> `No); - delta_h = EcUtils.pred0; - zeta = false; - iota = false; - eta = false; - logic = None; - modpath = false; - user = false; + beta = false; + delta_p = (fun _ -> `No); + delta_h = EcUtils.pred0; + delta_tc = false; + zeta = false; + iota = false; + eta = false; + logic = None; + modpath = false; + user = false; } let beta_red = { no_red with beta = true; } @@ -677,8 +651,8 @@ let betaiota_red = { no_red with beta = true; iota = true; } let nodelta = { full_red with - delta_h = EcUtils.pred0; - delta_p = (fun _ -> `No); } + delta_h = EcUtils.pred0; + delta_p = (fun _ -> `No); } let delta = { no_red with delta_p = (fun _ -> `IfTransparent); } @@ -708,6 +682,56 @@ let reduce_op ri env nargs p tys = Op.reduce ~mode ~nargs env p tys with NotReducible -> raise nohead +(* When a TC witness is [`Abs path] and [path] resolves to a concrete + (non-abstract) type, infer the concrete instance so that the TC op + becomes reducible. This arises after cloning an abstract theory with + a [type t <: tc] carrier substituted to a concrete type. *) +let resolve_concrete_tcw (env : EcEnv.env) (p : path) (tys : etyarg list) : etyarg list = + let op = EcEnv.Op.by_path p env in + if not (EcDecl.is_tc_op op) then tys + else match List.rev tys with + | (carrier_ty, [TCIAbstract { support = `Abs ap; offset = 0; lift = [] }]) :: rest + when (match EcEnv.Ty.by_path_opt ap env with + | Some { tyd_type = `Abstract _; _ } -> false + | _ -> true) -> + let tcpath, _ = EcDecl.operator_as_tc op in + let tc_decl = EcEnv.TypeClass.by_path tcpath env in + let tc = { tc_name = tcpath; + tc_args = EcDecl.etyargs_of_tparams tc_decl.tc_tparams; } in + (match EcTypeClass.infer env carrier_ty tc with + | Some w -> List.rev ((carrier_ty, [w]) :: rest) + | None -> tys) + | _ -> tys + +let reduce_tc_op (ri : reduction_info) (env : EcEnv.env) (p : path) (tys : etyarg list) = + if ri.delta_tc then + try + Op.tc_reduce env p (resolve_concrete_tcw env p tys) + with NotReducible -> raise nohead + else + raise nohead + +(* Fold every TC op whose witness resolves through a reducible-marked + instance, recursively. Used to normalise a term after a polymorphic + template (rewrite RHS, [apply] result) has been instantiated at a + concrete carrier — without this, the user-visible term carries + verbose [idm<:int[Conc(...)]>]-style heads instead of [0]. *) +let rec fold_reducible_tc (env : EcEnv.env) (f : form) : form = + let f = EcCoreFol.f_map (fun ty -> ty) (fold_reducible_tc env) f in + match f.f_node with + | Fop (p, tys) + when EcEnv.Op.tc_reducible ~strict:true env p tys -> + (try fold_reducible_tc env (EcEnv.Op.tc_reduce ~strict:true env p tys) + with NotReducible -> f) + | Fapp ({ f_node = Fop (p, tys); _ }, args) + when EcEnv.Op.tc_reducible ~strict:true env p tys -> + (try + let head = EcEnv.Op.tc_reduce ~strict:true env p tys in + fold_reducible_tc env (f_app_simpl head args f.f_ty) + with NotReducible -> f) + | _ -> f + +(* -------------------------------------------------------------------- *) let is_record env f = match EcFol.destr_app f with | { f_node = Fop (p, _) }, _ -> EcEnv.Op.is_record_ctor env p @@ -750,8 +774,8 @@ let reduce_user_gen simplify ri env hyps f = oget ~exn:needsubterm (List.Exceptionless.find_map (fun rule -> try - let ue = EcUnify.UniEnv.create None in - let tvi = EcUnify.UniEnv.opentvi ue rule.R.rl_tyd None in + let ue = EcUnify.UniEnv.create None in + let tvi = EcUnify.UniEnv.opentvi ue rule.R.rl_tyd None in let check_alpha_eq f f' = if not (is_alpha_eq hyps f f') then raise NotReducible @@ -769,10 +793,12 @@ let reduce_user_gen simplify ri env hyps f = | ({ f_node = Fop (p, tys) }, args), R.Rule (`Op (p', tys'), args') when EcPath.p_equal p p' && List.length args = List.length args' -> - let tys' = List.map (Tvar.subst tvi) tys' in + let tys' = List.map (Tvar.subst_etyarg tvi.subst) tys' in begin - try List.iter2 (EcUnify.unify env ue) tys tys' + try + if List.length tys <> List.length tys' then raise NotReducible; + List.iter2 (EcUnify.unify_etyarg env ue) tys tys' with EcUnify.UnificationFailure _ -> raise NotReducible end; List.iter2 doit args args' @@ -804,7 +830,7 @@ let reduce_user_gen simplify ri env hyps f = let subst = ts in let subst = Mid.fold (fun x f s -> Fsubst.f_bind_local s x f) !pv subst in - Fsubst.f_subst subst (Fsubst.f_subst_tvar ~freshen:true tvi f) + Fsubst.f_subst subst (Fsubst.f_subst_tvar ~freshen:true tvi.subst f) in List.iter (fun cond -> @@ -883,7 +909,7 @@ let reduce_logic ri env hyps f p args = when EcPath.p_equal p1 p2 && EcEnv.Op.is_record_ctor env p1 && EcEnv.Op.is_record_ctor env p2 - && List.for_all2 (EqTest_i.for_type env) tys1 tys2 -> + && List.for_all2 (EqTest_i.for_etyarg env) tys1 tys2 -> f_ands (List.map2 f_eq args1 args2) @@ -904,14 +930,31 @@ let reduce_logic ri env hyps f p args = check_reduced hyps needsubterm f f' (* -------------------------------------------------------------------- *) -let reduce_delta ri env _hyps f = +let reduce_delta ri env f = match f.f_node with | Fop (p, tys) when ri.delta_p p <> `No -> - reduce_op ri env 0 p tys + reduce_op ri env 0 p tys | Fapp ({ f_node = Fop (p, tys) }, args) when ri.delta_p p <> `No -> - let op = reduce_op ri env (List.length args) p tys in - f_app_simpl op args f.f_ty + let op = reduce_op ri env (List.length args) p tys in + f_app_simpl op args f.f_ty + + | _ -> raise nohead + +(* -------------------------------------------------------------------- *) +let reduce_tc ri env f = + match f.f_node with + | Fop (p, etyargs) + when ri.delta_tc && + Op.tc_reducible env p (resolve_concrete_tcw env p etyargs) -> + reduce_tc_op ri env p etyargs + + | Fapp ({ f_node = Fop (p, etyargs) }, args) + when ri.delta_tc && + Op.tc_reducible env p (resolve_concrete_tcw env p etyargs) + -> + let op = reduce_tc_op ri env p etyargs in + f_app_simpl op args f.f_ty | _ -> raise nohead @@ -1064,7 +1107,10 @@ let reduce_head simplify ri env hyps f = let body = EcFol.form_of_expr body in (* FIXME subst-refact can we do both subst in once *) let body = - Tvar.f_subst ~freshen:true op.EcDecl.op_tparams tys body in + Tvar.f_subst ~freshen:true + (List.combine + (List.map fst op.EcDecl.op_tparams) + tys) body in f_app (Fsubst.f_subst subst body) eargs f.f_ty @@ -1081,19 +1127,22 @@ let reduce_head simplify ri env hyps f = when ri.eta && can_eta x (fn, args) -> f_app fn (List.take (List.length args - 1) args) f.f_ty - | Fop _ -> begin - try - reduce_user_gen simplify ri env hyps f - with NotRed _ -> - reduce_delta ri env hyps f - end + | Fop _ -> + oget ~exn:nohead @@ + List.find_map_opt + (fun cb -> try Some (cb f) with NotRed _ -> None) + [ reduce_user_gen simplify ri env hyps + ; reduce_delta ri env + ; reduce_tc ri env ] - | Fapp({ f_node = Fop(p,_); }, args) -> begin + | Fapp ({ f_node = Fop (p, _); }, args) -> begin try reduce_logic ri env hyps f p args with NotRed kind1 -> try reduce_user_gen simplify ri env hyps f with NotRed kind2 -> - if kind1 = NoHead && kind2 = NoHead then reduce_delta ri env hyps f + if kind1 = NoHead && kind2 = NoHead then + (try reduce_delta ri env f + with NotRed NoHead -> reduce_tc ri env f) else raise needsubterm end @@ -1195,9 +1244,18 @@ and reduce_head_top_force ri env onhead f = match reduce_head_sub ri env f with | f -> if onhead then reduce_head_top ri env ~onhead f else f - | exception (NotRed _) -> - try reduce_delta ri.ri env ri.hyps f - with NotRed _ -> RedTbl.set_norm ri.redtbl f; raise nohead + | exception (NotRed _) -> begin + match + List.find_map_opt + (fun cb -> try Some (cb ri.ri env f) with NotRed _ -> None) + [reduce_delta; reduce_tc] + with + | Some f -> + f + | None -> + RedTbl.set_norm ri.redtbl f; + raise nohead + end end and reduce_head_sub ri env f = @@ -1258,30 +1316,25 @@ let rec simplify ri env f = match f.f_node with | FhoareF hf when ri.ri.modpath -> let hf_f = EcEnv.NormMp.norm_xfun env hf.hf_f in - f_map (fun ty -> ty) (simplify ri env) - (f_hoareF (hf_pr hf) hf_f (hf_po hf)) + f_map (fun ty -> ty) (simplify ri env) (f_hoareF_r { hf with hf_f }) | FeHoareF hf when ri.ri.modpath -> let ehf_f = EcEnv.NormMp.norm_xfun env hf.ehf_f in - f_map (fun ty -> ty) (simplify ri env) - (f_eHoareF (ehf_pr hf) ehf_f (ehf_po hf)) + f_map (fun ty -> ty) (simplify ri env) (f_eHoareF_r { hf with ehf_f }) | FbdHoareF hf when ri.ri.modpath -> let bhf_f = EcEnv.NormMp.norm_xfun env hf.bhf_f in - f_map (fun ty -> ty) (simplify ri env) - (f_bdHoareF (bhf_pr hf) bhf_f (bhf_po hf) hf.bhf_cmp (bhf_bd hf)) + f_map (fun ty -> ty) (simplify ri env) (f_bdHoareF_r { hf with bhf_f }) | FequivF ef when ri.ri.modpath -> let ef_fl = EcEnv.NormMp.norm_xfun env ef.ef_fl in let ef_fr = EcEnv.NormMp.norm_xfun env ef.ef_fr in - f_map (fun ty -> ty) (simplify ri env) - (f_equivF (ef_pr ef) ef_fl ef_fr (ef_po ef)) + f_map (fun ty -> ty) (simplify ri env) (f_equivF_r { ef with ef_fl; ef_fr; }) | FeagerF eg when ri.ri.modpath -> let eg_fl = EcEnv.NormMp.norm_xfun env eg.eg_fl in let eg_fr = EcEnv.NormMp.norm_xfun env eg.eg_fr in - f_map (fun ty -> ty) (simplify ri env) - (f_eagerF (eg_pr eg) eg.eg_sl eg_fl eg_fr eg.eg_sr (eg_po eg)) + f_map (fun ty -> ty) (simplify ri env) (f_eagerF_r { eg with eg_fl ; eg_fr; }) | Fpr pr when ri.ri.modpath -> let pr_fun = EcEnv.NormMp.norm_xfun env pr.pr_fun in @@ -1410,6 +1463,9 @@ let zpop ri side f hd = let rec conv ri env f1 f2 stk = if f_equal f1 f2 then conv_next ri env f1 stk else match f1.f_node, f2.f_node with + | Flocal x, Flocal y when EcIdent.id_equal x y -> + true + | Fquant (q1, bd1, f1'), Fquant(q2,bd2,f2') -> if q1 <> q2 then force_head_sub ri env f1 f2 stk else @@ -1463,7 +1519,8 @@ let rec conv ri env f1 f2 stk = end | Fop(p1, ty1), Fop(p2,ty2) - when EcPath.p_equal p1 p2 && List.all2 (EqTest_i.for_type env) ty1 ty2 -> + when EcPath.p_equal p1 p2 + && List.all2 (EqTest_i.for_etyarg env) ty1 ty2 -> conv_next ri env f1 stk | Fapp(f1', args1), Fapp(f2', args2) @@ -1773,8 +1830,8 @@ module User = struct let rule = let rec rule (f : form) : EcTheory.rule_pattern = match EcFol.destr_app f with - | { f_node = Fop (p, tys) }, args -> - R.Rule (`Op (p, tys), List.map rule args) + | { f_node = Fop (p, etyargs) }, args -> + R.Rule (`Op (p, etyargs), List.map rule args) | { f_node = Ftuple args }, [] -> R.Rule (`Tuple, List.map rule args) | { f_node = Fproj (target, i) }, [] -> @@ -1797,12 +1854,13 @@ module User = struct | R.Rule (op, args) -> let ltyvars = match op with - | `Op (_, tys) -> - List.fold_left ( - let rec doit ltyvars = function - | { ty_node = Tvar a } -> Sid.add a ltyvars - | _ as ty -> ty_fold doit ltyvars ty in doit) - cst.cst_ty_vs tys + | `Op (_, etyargs) -> + let rec doit_ty ltyvars = function + | { ty_node = Tvar a } -> Sid.add a ltyvars + | _ as ty -> ty_fold doit_ty ltyvars ty in + List.fold_left + (fun ltyvars (ty, _) -> doit_ty ltyvars ty) + cst.cst_ty_vs etyargs | `Tuple -> cst.cst_ty_vs | `Proj _ -> cst.cst_ty_vs in let cst = {cst with cst_ty_vs = ltyvars } in @@ -1811,7 +1869,7 @@ module User = struct in doit empty_cst rule in let s_bds = Sid.of_list (List.map fst bds) - and s_tybds = Sid.of_list ax.ax_tparams in + and s_tybds = Sid.of_list (List.map fst ax.ax_tparams) in (* Variables appearing in types and formulas are always, respectively, * type and formula variables. diff --git a/src/ecReduction.mli b/src/ecReduction.mli index ceb057d245..9cc31451a6 100644 --- a/src/ecReduction.mli +++ b/src/ecReduction.mli @@ -19,16 +19,17 @@ type 'a eqantest = env -> ?alpha:(EcIdent.t * ty) Mid.t -> ?norm:bool -> 'a -> ' module EqTest : sig val for_type_exn : env -> ty -> ty -> unit - val for_type : ty eqtest - val for_pv : prog_var eqntest - val for_lv : lvalue eqntest - val for_xp : xpath eqntest - val for_mp : mpath eqntest - val for_instr : instr eqantest - val for_stmt : stmt eqantest - val for_expr : expr eqantest - val for_msig : module_sig eqntest - val for_mexpr : env -> ?norm:bool -> ?body:bool -> module_expr -> module_expr -> bool + val for_type : ty eqtest + val for_etyarg : etyarg eqtest + val for_pv : prog_var eqntest + val for_lv : lvalue eqntest + val for_xp : xpath eqntest + val for_mp : mpath eqntest + val for_instr : instr eqantest + val for_stmt : stmt eqantest + val for_expr : expr eqantest + val for_msig : module_sig eqntest + val for_mexpr : env -> ?norm:bool -> ?body:bool -> module_expr -> module_expr -> bool val is_unit : env -> ty -> bool val is_bool : env -> ty -> bool @@ -64,6 +65,7 @@ type reduction_info = { beta : bool; delta_p : (path -> deltap); (* reduce operators *) delta_h : (ident -> bool); (* reduce local definitions *) + delta_tc : bool; (* reduce tc-operators *) zeta : bool; (* reduce let *) iota : bool; (* reduce case *) eta : bool; (* reduce eta-expansion *) @@ -103,6 +105,13 @@ val reduce_user_gen : val simplify : reduction_info -> LDecl.hyps -> form -> form +(* Recursively fold every TC op whose witness resolves through a + [tci_reducible] instance. Use after instantiating a polymorphic + template at a concrete carrier (rewrite RHS, [apply] result) so the + resulting goal carries the underlying core ops rather than verbose + class-op applications. *) +val fold_reducible_tc : EcEnv.env -> form -> form + val is_conv : ?ri:reduction_info -> LDecl.hyps -> form -> form -> bool val check_conv : ?ri:reduction_info -> LDecl.hyps -> form -> form -> unit diff --git a/src/ecScope.ml b/src/ecScope.ml index 989174512f..ded2460092 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -305,10 +305,22 @@ and proof_state = PSNoCheck | PSCheck of EcCoreGoal.proof and pucflags = { - puc_smt : bool; - puc_local : bool; + puc_smt : bool; + puc_local : bool; } +(* -------------------------------------------------------------------- *) +type docentity = + | ItemDoc of string list * docitem + | SubDoc of (string list * docitem) * docentity list + +and docitem = + mode * itemkind * string * string list + +and itemkind = [`Type | `Operator | `Axiom | `Lemma | `ModuleType | `Module | `Theory] + +and mode = [`Abstract | `Specific] + (* -------------------------------------------------------------------- *) type required_info = { rqd_name : symbol; @@ -337,104 +349,11 @@ type scope = { sc_clears : path list; sc_pr_uc : proof_uc option; sc_options : GenOptions.options; - sc_globdoc : string list; - sc_locdoc : docstate; -} - -and docstate = { - docentities : docentity list; - subdocentbl : docentity list; - docstringbl : string list; - srcstringbl : string list; - currentname : string option; - currentkind : itemkind option; - currentmode : mode option; - currentproc : bool; } -and docentity = - | ItemDoc of string list * docitem - | SubDoc of (string list * docitem) * docentity list - -and docitem = - mode * itemkind * string * string list (* dec/reg, kind, name, src *) - -and itemkind = [`Type | `Operator | `Axiom | `Lemma | `ModuleType | `Module | `Theory] - -and mode = [`Abstract | `Specific] - (* -------------------------------------------------------------------- *) -let get_gdocstrings (sc : scope) : string list = - sc.sc_globdoc - -let get_ldocentities (sc : scope) : docentity list = - sc.sc_locdoc.docentities - -module DocState = struct - let empty : docstate = - { docentities = []; - subdocentbl = []; - docstringbl = []; - srcstringbl = []; - currentname = None; - currentkind = None; - currentmode = None; - currentproc = false; } - - let start_process (state : docstate) (name : string) (kind : itemkind) (md : mode): docstate = - { state with - currentname = Some name; - currentkind = Some kind; - currentmode = Some md; - currentproc = true } - - let prevent_process (state : docstate) : docstate = - { state with - currentname = None; - currentkind = None; - currentmode = None; - currentproc = false } - - let reinitialize_process (state : docstate) : docstate = - { state with - docstringbl = []; - srcstringbl = []; - currentname = None; - currentkind = None; - currentmode = None; - currentproc = false } - - let push_docbl (state : docstate) (docc : string) : docstate = - { state with docstringbl = state.docstringbl @ [docc] } - - let push_srcbl (state : docstate) (srcs : string) : docstate = - { state with srcstringbl = state.srcstringbl @ [srcs] } - - let add_entity (state : docstate) (docent : docentity) : docstate = - { state with docentities = state.docentities @ [docent] } - - let add_item (state : docstate) : docstate = - let state = - if state.currentproc - then - add_entity state (ItemDoc (state.docstringbl, (oget state.currentmode, oget state.currentkind, oget state.currentname, state.srcstringbl))) - else - state - in - reinitialize_process state - - let add_sub (state : docstate) (substate : docstate) : docstate = - let state = - if state.currentproc - then - add_entity state (SubDoc ((state.docstringbl, (oget state.currentmode, oget state.currentkind, oget state.currentname, state.srcstringbl)), - (substate.docentities))) - else - state - in - reinitialize_process state - - end +let get_gdocstrings (_ : scope) : string list = [] +let get_ldocentities (_ : scope) : docentity list = [] (* -------------------------------------------------------------------- *) let empty (gstate : EcGState.gstate) = @@ -447,9 +366,7 @@ let empty (gstate : EcGState.gstate) = sc_required = []; sc_clears = []; sc_pr_uc = None; - sc_options = GenOptions.freeze (); - sc_globdoc = []; - sc_locdoc = DocState.empty; } + sc_options = GenOptions.freeze (); } (* -------------------------------------------------------------------- *) let env (scope : scope) = @@ -569,8 +486,7 @@ let for_loading (scope : scope) = sc_clears = []; sc_pr_uc = None; sc_options = GenOptions.for_loading scope.sc_options; - sc_globdoc = []; - sc_locdoc = DocState.empty; } + } (* -------------------------------------------------------------------- *) let subscope (scope : scope) (mode : EcTheory.thmode) (name : symbol) lc = @@ -584,10 +500,7 @@ let subscope (scope : scope) (mode : EcTheory.thmode) (name : symbol) lc = sc_required = scope.sc_required; sc_clears = []; sc_pr_uc = None; - sc_options = GenOptions.for_subscope scope.sc_options; - sc_globdoc = []; - sc_locdoc = DocState.empty; - } + sc_options = GenOptions.for_subscope scope.sc_options; } (* -------------------------------------------------------------------- *) module Prover = struct @@ -793,7 +706,7 @@ module Tactics = struct let pi scope pi = Prover.do_prover_info scope pi - let proof ?(src : string option) (scope : scope) = + let proof ?src:_ (scope : scope) = check_state `InActiveProof "proof script" scope; match (oget scope.sc_pr_uc).puc_active with @@ -804,14 +717,10 @@ module Tactics = struct hierror "[proof] can only be used at beginning of a proof script"; { pac with puc_started = true } in - { scope with - sc_pr_uc = Some { (oget scope.sc_pr_uc) with puc_active = Some (pac, pct) }; - sc_locdoc = - match src with - | Some src -> DocState.push_srcbl scope.sc_locdoc src - | None -> scope.sc_locdoc; } + { scope with sc_pr_uc = + Some { (oget scope.sc_pr_uc) with puc_active = Some (pac, pct); } } - let process_r ?(src : string option) ?reloc mark (mode : proofmode) (scope : scope) (tac : ptactic list) = + let process_r ?reloc mark (mode : proofmode) (scope : scope) (tac : ptactic list) = check_state `InProof "proof script" scope; let scope = @@ -823,13 +732,6 @@ module Tactics = struct else scope in - let scope = { scope with - sc_locdoc = - match src with - | Some src -> DocState.push_srcbl scope.sc_locdoc src - | None -> scope.sc_locdoc; } - in - let puc = oget (scope.sc_pr_uc) in let pac, pct = oget (puc).puc_active in @@ -870,7 +772,7 @@ module Tactics = struct let pac = { pac with puc_jdg = PSCheck juc } in let puc = { puc with puc_active = Some (pac, pct); } in - let scope = { scope with sc_pr_uc = Some puc; } in + let scope = { scope with sc_pr_uc = Some puc } in Some (penv, hds), scope let process1_r mark mode scope t = @@ -880,8 +782,8 @@ module Tactics = struct let ts = List.map (fun t -> { pt_core = t; pt_intros = []; }) ts in snd (process_r mark mode scope ts) - let process ?(src : string option) scope mode tac = - process_r ?src true mode scope tac + let process ?src:_ scope mode tac = + process_r true mode scope tac end (* -------------------------------------------------------------------- *) @@ -907,7 +809,7 @@ module Auto = struct { scope with sc_env = EcSection.add_item item scope.sc_env } let bind_hint scope ~local ~level ?base axioms = - let item = EcTheory.mkitem ~import:true (Th_auto { level; base; axioms; locality=local} ) in + let item = EcTheory.mkitem ~import:true (Th_auto { level; base; axioms; locality = local; }) in { scope with sc_env = EcSection.add_item item scope.sc_env } let add_hint scope hint = @@ -935,9 +837,7 @@ module Ax = struct let bind ?(import = true) (scope : scope) ((x, ax) : _ * axiom) = assert (scope.sc_pr_uc = None); let item = EcTheory.mkitem ~import (EcTheory.Th_axiom (x, ax)) in - { scope with sc_env = - EcSection.add_item item scope.sc_env; - sc_locdoc = DocState.add_item scope.sc_locdoc; } + { scope with sc_env = EcSection.add_item item scope.sc_env } (* ------------------------------------------------------------------ *) let start_lemma scope (cont, axflags) check ?name (axd, ctxt) = @@ -988,11 +888,15 @@ module Ax = struct let concl = TT.trans_prop env ue pconcl in - if not (EcUnify.UniEnv.closed ue) then - hierror "the formula contains free type variables"; + Option.iter (fun infos -> + hierror + "the formula contains free %a variables" + EcUserMessages.TypingError.pp_uniflags infos + ) (EcUnify.UniEnv.xclosed ue); let uidmap = EcUnify.UniEnv.close ue in - let fs = Tuni.subst uidmap in + let tw_uni = EcUnify.UniEnv.tw_assubst ue in + let fs = Tuni.subst ~tw_uni uidmap in let concl = Fsubst.f_subst fs concl in let tparams = EcUnify.UniEnv.tparams ue in @@ -1002,11 +906,11 @@ module Ax = struct | PAxiom tags -> `Axiom (Ssym.of_list (List.map unloc tags), false) | _ -> `Lemma - in { ax_tparams = tparams; - ax_spec = concl; - ax_kind = kind; - ax_loca = ax.pa_locality; - ax_smt = true; } + in { ax_tparams = tparams; + ax_spec = concl; + ax_kind = kind; + ax_loca = ax.pa_locality; + ax_smt = true; } in match ax.pa_kind with @@ -1129,69 +1033,22 @@ module Ax = struct save_r scope (* ------------------------------------------------------------------ *) - let save ?(src : string option) scope = + let save ?src:_ scope = check_state `InProof "save" scope; - - let scope = - { scope with - sc_locdoc = - match src with - | Some src -> DocState.push_srcbl scope.sc_locdoc src - | None -> scope.sc_locdoc; } - in save_r ~mode:`Save scope (* ------------------------------------------------------------------ *) - let admit ?(src : string option) scope = + let admit ?src:_ scope = check_state `InProof "admitted" scope; - - let scope = - { scope with - sc_locdoc = - match src with - | Some src -> DocState.push_srcbl scope.sc_locdoc src - | None -> scope.sc_locdoc; } - in - save_r ~mode:`Admit scope (* ------------------------------------------------------------------ *) - let abort ?(src : string option) scope = + let abort ?src:_ scope = check_state `InProof "abort" scope; - - let scope = - { scope with - sc_locdoc = - match src with - | Some src -> DocState.push_srcbl scope.sc_locdoc src - | None -> scope.sc_locdoc; } - in - snd (save_r ~mode:`Abort scope) (* ------------------------------------------------------------------ *) - let add ?(src : string option) (scope : scope) (mode : proofmode) (ax : paxiom located) = - let uax = unloc ax in - let kind = - match uax.pa_kind with - | PLemma _ -> `Lemma - | _ -> `Axiom - in - let scope = - { scope with - sc_locdoc = - match uax.pa_locality with - | `Local -> DocState.prevent_process scope.sc_locdoc - | `Global -> DocState.start_process scope.sc_locdoc (unloc uax.pa_name) kind `Specific - | `Declare -> DocState.start_process scope.sc_locdoc (unloc uax.pa_name) kind `Abstract} - in - let scope = - { scope with - sc_locdoc = - match src with - | Some src -> DocState.push_srcbl scope.sc_locdoc src - | None -> scope.sc_locdoc; } - in + let add ?src:_ (scope : scope) (mode : proofmode) (ax : paxiom located) = add_r scope mode ax (* ------------------------------------------------------------------ *) @@ -1247,33 +1104,41 @@ module Op = struct let bind ?(import = true) (scope : scope) ((x, op) : _ * operator) = assert (scope.sc_pr_uc = None); let item = EcTheory.mkitem ~import (EcTheory.Th_operator (x, op)) in - { scope with sc_env = - EcSection.add_item item scope.sc_env; - sc_locdoc = DocState.add_item scope.sc_locdoc; } - - let add ?(src : string option) (scope : scope) (op : poperator located) = - assert (scope.sc_pr_uc = None); + { scope with sc_env = EcSection.add_item item scope.sc_env; } - let uop = unloc op in - let scope = - { scope with - sc_locdoc = - match uop.po_locality with - | `Local -> DocState.prevent_process scope.sc_locdoc - | `Global -> DocState.start_process scope.sc_locdoc (unloc uop.po_name) `Operator `Specific - | `Declare -> DocState.start_process scope.sc_locdoc (unloc uop.po_name) `Operator `Abstract } + (* -------------------------------------------------------------------- *) + let axiomatized_op ?(nargs = 0) ?(nosmt = false) path (tparams, axbd) lc = + let axpm, axbd = + let subst, axpm = EcSubst.fresh_tparams EcSubst.empty tparams in + (axpm, EcSubst.subst_form subst axbd) in - let scope = - { scope with - sc_locdoc = - match src with - | Some src -> DocState.push_srcbl scope.sc_locdoc src - | None -> scope.sc_locdoc; } + + let args, axbd = + match axbd.f_node with + | Fquant (Llambda, bds, axbd) -> + let bds, flam = List.split_at nargs bds in + (bds, f_lambda flam axbd) + | _ -> [], axbd in + let opargs = List.map (fun (x, ty) -> f_local x (gty_as_ty ty)) args in + let opty = toarrow (List.map f_ty opargs) axbd.EcAst.f_ty in + let op = f_op_tc path (etyargs_of_tparams axpm) opty in + let op = f_app op opargs axbd.f_ty in + let axspec = f_forall args (f_eq op axbd) in + + { ax_tparams = axpm; + ax_spec = axspec; + ax_kind = `Axiom (Ssym.empty, false); + ax_loca = lc; + ax_smt = if nosmt then false else true; } + + let add ?src:_ (scope : scope) (op : poperator located) = + assert (scope.sc_pr_uc = None); let op = op.pl_desc and loc = op.pl_loc in let eenv = env scope in let ue = TT.transtyvars eenv (loc, op.po_tyvars) in + let lc = op.po_locality in let args = fst op.po_args @ odfl [] (snd op.po_args) in let (ty, body, refts) = @@ -1308,11 +1173,15 @@ module Op = struct (opty, `Abstract, [(rname, xs, reft, codom)]) in - if not (EcUnify.UniEnv.closed ue) then - hierror ~loc "this operator type contains free type variables"; + Option.iter (fun infos -> + hierror ~loc + "this operator type contains free %a variables" + EcUserMessages.TypingError.pp_uniflags infos + ) (EcUnify.UniEnv.xclosed ue); let uidmap = EcUnify.UniEnv.close ue in - let ts = Tuni.subst uidmap in + let tw_uni = EcUnify.UniEnv.tw_assubst ue in + let ts = Tuni.subst ~tw_uni uidmap in let fs = Fsubst.f_subst ts in let ty = ty_subst ts ty in let tparams = EcUnify.UniEnv.tparams ue in @@ -1322,7 +1191,7 @@ module Op = struct | `Plain e -> Some (OP_Plain (fs e)) | `Fix opfx -> Some (OP_Fix { - opf_recp = EcPath.pqname (EcEnv.root eenv) (EcIdent.name opfx.EHI.mf_name); + opf_recp = EcPath.psymbol "_"; opf_args = opfx.EHI.mf_args; opf_resty = opfx.EHI.mf_codom; opf_struct = (opfx.EHI.mf_recs, List.length opfx.EHI.mf_args); @@ -1353,7 +1222,7 @@ module Op = struct try EcUnify.unify eenv tue ty tfun; - let msg = "this operator type is (unifiable) to a function type" in + let msg = "this operator type is (unifiable to) a function type" in hierror ~loc "%s" msg with EcUnify.UnificationFailure _ -> () end; @@ -1366,8 +1235,8 @@ module Op = struct | OB_oper (Some (OP_Plain bd)) -> let path = EcPath.pqname (path scope) (unloc op.po_name) in let axop = - let nargs = List.sum (List.map (List.length -| fst) args) in - EcDecl.axiomatized_op ~nargs path (tyop.op_tparams, bd) lc in + let nargs = List.sum (List.map (fst |- List.length) args) in + axiomatized_op ~nargs path (tyop.op_tparams, bd) lc in let tyop = { tyop with op_opaque = { reduction = true; smt = false; }} in let scope = bind scope (unloc op.po_name, tyop) in Ax.bind scope (unloc ax, axop) @@ -1380,7 +1249,7 @@ module Op = struct List.fold_left (fun scope (rname, xs, ax, codom) -> let ax = let opargs = List.map (fun (x, xty) -> e_local x xty) xs in - let opapp = List.map tvar tparams in + let opapp = List.map (fst |- tvar) tparams in let opapp = e_app (e_op opname opapp ty) opargs codom in let subst = EcSubst.add_opdef EcSubst.empty opname ([], opapp) in @@ -1388,23 +1257,23 @@ module Op = struct let ax = f_forall (List.map (snd_map gtty) xs) ax in let uidmap = EcUnify.UniEnv.close ue in - let subst = Tuni.subst uidmap in + let tw_uni = EcUnify.UniEnv.tw_assubst ue in + let subst = Tuni.subst ~tw_uni uidmap in let ax = Fsubst.f_subst subst ax in ax in - let ax, axpm = - let bdpm = tparams in - let axpm = List.map EcIdent.fresh bdpm in - (Tvar.f_subst ~freshen:true bdpm (List.map EcTypes.tvar axpm) ax, - axpm) in + let axpm, ax = + let subst, tparams = EcSubst.fresh_tparams EcSubst.empty tparams in + (tparams, EcSubst.subst_form subst ax) in + let ax = - { ax_tparams = axpm; - ax_spec = ax; - ax_kind = `Axiom (Ssym.empty, false); - ax_loca = lc; - ax_smt = true; } + { ax_tparams = axpm; + ax_spec = ax; + ax_kind = `Axiom (Ssym.empty, false); + ax_loca = lc; + ax_smt = true; } in Ax.bind scope (unloc rname, ax)) scope refts in @@ -1415,11 +1284,11 @@ module Op = struct hierror ~loc "multiple names are only allowed for non-refined abstract operators"; let addnew scope name = - let nparams = List.map EcIdent.fresh tparams in - let subst = Tvar.init - tparams - (List.map tvar nparams) in - let rop = EcDecl.mk_op ~opaque:optransparent nparams (Tvar.subst subst ty) None lc in + let subst, nparams = + EcSubst.fresh_tparams EcSubst.empty tparams in + let rop = + EcDecl.mk_op ~opaque:optransparent + nparams (EcSubst.subst_ty subst ty) None lc in bind scope (unloc name, rop) in List.fold_left addnew scope op.po_aliases @@ -1434,10 +1303,18 @@ module Op = struct if not (EcAlgTactic.is_module_loaded (env scope)) then hierror "for tag %s, load Distr first" tag; - let oppath = EcPath.pqname (path scope) (unloc op.po_name) in - let nparams = List.map EcIdent.fresh tyop.op_tparams in - let subst = Tvar.init tyop.op_tparams (List.map tvar nparams) in - let ty = Tvar.subst subst tyop.op_ty in + let subst, nparams = + EcSubst.fresh_tparams EcSubst.empty tyop.op_tparams in + let oppath = EcPath.pqname (path scope) (unloc op.po_name) in + let optyargs = + let mktcw (a : EcIdent.t) (i : int) = + TCIAbstract { support = `Var a; offset = i; lift = [] } + in + List.map + (fun (a, tcs) -> (tvar a, List.mapi (fun i _ -> mktcw a i) tcs)) + nparams + in + let ty = EcSubst.subst_ty subst tyop.op_ty in let aty, rty = EcTypes.tyfun_flat ty in let dty = @@ -1447,17 +1324,17 @@ module Op = struct in let bds = List.combine (List.map EcTypes.fresh_id_of_ty aty) aty in - let ax = EcFol.f_op oppath (List.map tvar nparams) ty in + let ax = EcFol.f_op_tc oppath optyargs ty in let ax = EcFol.f_app ax (List.map (curry f_local) bds) rty in let ax = EcFol.f_app (EcFol.f_op pred [dty] (tfun rty tbool)) [ax] tbool in let ax = EcFol.f_forall (List.map (snd_map gtty) bds) ax in let ax = - { ax_tparams = nparams; - ax_spec = ax; - ax_kind = `Axiom (Ssym.empty, false); - ax_loca = lc; - ax_smt = true; } in + { ax_tparams = nparams; + ax_spec = ax; + ax_kind = `Axiom (Ssym.empty, false); + ax_loca = lc; + ax_smt = true; } in let scope, axname = let axname = Printf.sprintf "%s_%s" (unloc op.po_name) suffix in @@ -1469,9 +1346,7 @@ module Op = struct List.fold_left (fun scope base -> - Auto.bind_hint - ~local:(local_of_locality lc) ~level:0 ~base scope - [(axpath, `Default)]) + Auto.bind_hint ~local:(local_of_locality lc) ~level:0 ~base scope [(axpath, `Default)]) scope bases in @@ -1497,26 +1372,9 @@ module Op = struct tyop, List.rev !axs, scope - let add_opsem ?(src : string option) (scope : scope) (op : pprocop located) = + let add_opsem ?src:_ (scope : scope) (op : pprocop located) = let module Sem = EcProcSem in - let uop = unloc op in - let scope = - { scope with - sc_locdoc = - match uop.ppo_locality with - | `Local -> DocState.prevent_process scope.sc_locdoc - | `Global -> DocState.start_process scope.sc_locdoc (unloc uop.ppo_name) `Operator `Specific - | `Declare -> DocState.start_process scope.sc_locdoc (unloc uop.ppo_name) `Operator `Abstract } - in - let scope = - { scope with - sc_locdoc = - match src with - | Some src -> DocState.push_srcbl scope.sc_locdoc src - | None -> scope.sc_locdoc; } - in - let op = unloc op in let f = EcTyping.trans_gamepath (env scope) op.ppo_target in let sig_, body = @@ -1542,7 +1400,9 @@ module Op = struct (`Det, Sem.translate_e env ret) in let mode, aout = Sem.translate_s env cont body.f_body in - let aout = form_of_expr aout in (* FIXME: translate to forms directly? *) + let aout = + let m = EcIdent.create "&hr" in + form_of_expr ~m aout in (* FIXME: translate to forms directly? *) let aout = f_lambda (List.map2 (fun (_, ty) x -> (x, GTty ty)) params ids) aout in let opdecl = EcDecl.{ @@ -1561,11 +1421,12 @@ module Op = struct let scope = let prax = + let m = EcIdent.create "&hr" in let locs = List.map (fun (x, ty) -> (EcIdent.create x, ty)) params in - let prmem = EcIdent.create "&m" in - let res = f_pvar pv_res sig_.fs_ret prmem in + let res = f_pvar pv_res sig_.fs_ret m in let resx = EcIdent.create "v" in let resv = f_local resx sig_.fs_ret in + let prmem = EcIdent.create "&m" in let mu = let sem = @@ -1590,16 +1451,16 @@ module Op = struct (f_pr prmem f (f_tuple (List.map (fun (x, ty) -> f_local x ty) locs)) - (map_ss_inv1 (fun r -> f_eq r resv) res)) + { m; inv = f_eq res.inv resv }) mu)) in let prax = EcDecl.{ - ax_tparams = []; - ax_spec = prax; - ax_kind = `Lemma; - ax_loca = op.ppo_locality; - ax_smt = true; + ax_tparams = []; + ax_spec = prax; + ax_kind = `Lemma; + ax_loca = op.ppo_locality; + ax_smt = true; } in Ax.bind scope (unloc op.ppo_name ^ "_opsem", prax) in @@ -1608,35 +1469,32 @@ module Op = struct match mode with | `Det -> let hax = + let m = EcIdent.create "&hr" in let locs = List.map (fun (x, ty) -> (EcIdent.create x, ty)) params in - let m = EcIdent.create "&hr" in let res = f_pvar pv_res sig_.fs_ret m in let args = f_pvar pv_arg sig_.fs_arg m in - let post = - f_eq - res.inv - (f_app - (f_op oppath [] opdecl.op_ty) - (List.map (fun (x, ty) -> f_local x ty) locs) - sig_.fs_ret) - in f_forall (List.map (fun (x, ty) -> (x, GTty ty)) locs) (f_hoareF - {m;inv=(f_eq + { m; inv = f_eq args.inv - (f_tuple (List.map (fun (x, ty) -> f_local x ty) locs)))} + (f_tuple (List.map (fun (x, ty) -> f_local x ty) locs)) } f - {hsi_m=m;hsi_inv= POE.empty post}) + (POE.lift { m; inv = f_eq + res.inv + (f_app + (f_op oppath [] opdecl.op_ty) + (List.map (fun (x, ty) -> f_local x ty) locs) + sig_.fs_ret) })) in let prax = EcDecl.{ - ax_tparams = []; - ax_spec = hax; - ax_kind = `Lemma; - ax_loca = op.ppo_locality; - ax_smt = true; + ax_tparams = []; + ax_spec = hax; + ax_kind = `Lemma; + ax_loca = op.ppo_locality; + ax_smt = true; } in Ax.bind scope (unloc op.ppo_name ^ "_opsem_det", prax) @@ -1652,11 +1510,6 @@ end module Exception = struct module TT = EcTyping - let bind ?(import = true) (scope : scope) (x, e) = - assert (scope.sc_pr_uc = None); - let op = operator_of_exception e in - Op.bind ~import scope (x, op) - let add (scope : scope) (pe : pexception_decl located) = assert (scope.sc_pr_uc = None); let loc = loc pe in @@ -1669,7 +1522,8 @@ module Exception = struct if tparams <> [] then hierror ~loc "Polymorphic expression are not allowed"; let e = EcDecl.mk_exception lc e_dom in - let scope = bind scope (unloc pe.pe_name, e) in + let op = EcDecl.operator_of_exception e in + let scope = Op.bind scope (unloc pe.pe_name, op) in e, scope end @@ -1677,26 +1531,9 @@ end module Pred = struct module TT = EcTyping - let add ?(src : string option) (scope : scope) (pr : ppredicate located) = + let add ?src:_ (scope : scope) (pr : ppredicate located) = assert (scope.sc_pr_uc = None); - let upr = unloc pr in - let scope = - { scope with - sc_locdoc = - match upr.pp_locality with - | `Local -> DocState.prevent_process scope.sc_locdoc - | `Global -> DocState.start_process scope.sc_locdoc (unloc upr.pp_name) `Operator `Specific - | `Declare -> DocState.start_process scope.sc_locdoc (unloc upr.pp_name) `Operator `Abstract } - in - let scope = - { scope with - sc_locdoc = - match src with - | Some src -> DocState.push_srcbl scope.sc_locdoc src - | None -> scope.sc_locdoc; } - in - let typr = EcHiPredicates.trans_preddecl (env scope) pr in let scope = Op.bind scope (unloc (unloc pr).pp_name, typr) in typr, scope @@ -1721,34 +1558,14 @@ module Mod = struct let bind ?(import = true) (scope : scope) (m : top_module_expr) = assert (scope.sc_pr_uc = None); let item = EcTheory.mkitem ~import (EcTheory.Th_module m) in - { scope with - sc_env = EcSection.add_item item scope.sc_env; - sc_locdoc = DocState.add_item scope.sc_locdoc; } + { scope with sc_env = EcSection.add_item item scope.sc_env } - let add_concrete ?(src : string option) (scope : scope) lc (ptm : pmodule_def) = + let add_concrete (scope : scope) lc (ptm : pmodule_def) = assert (scope.sc_pr_uc = None); if lc = `Declare then hierror "cannot use [declare] for concrete modules"; - let nm = unloc (EcParsetree.pcmhd_ident ptm.ptm_header) in - - let scope = - { scope with - sc_locdoc = - match lc with - | `Local -> DocState.prevent_process scope.sc_locdoc - | `Global -> DocState.start_process scope.sc_locdoc nm `Module `Specific - | `Declare -> DocState.start_process scope.sc_locdoc nm `Module `Abstract } - in - let scope = - { scope with - sc_locdoc = - match src with - | Some src -> DocState.push_srcbl scope.sc_locdoc src - | None -> scope.sc_locdoc; } - in - let m = TT.transmod (env scope) ~attop:true ptm in let ur = EcModules.get_uninit_read_of_module (path scope) m in @@ -1778,10 +1595,10 @@ module Mod = struct { scope with sc_env = EcSection.add_decl_mod name tysig scope.sc_env } - let add ?(src : string option) (scope : scope) (m : pmodule_def_or_decl) = + let add ?src:_ (scope : scope) (m : pmodule_def_or_decl) = match m with | { ptm_locality = lc; ptm_def = `Concrete def } -> - add_concrete ?src scope lc def + add_concrete scope lc def | { ptm_locality = lc; ptm_def = `Abstract decl } -> if lc <> `Declare then @@ -1802,863 +1619,1752 @@ module ModType = struct = assert (scope.sc_pr_uc = None); let item = EcTheory.mkitem ~import (EcTheory.Th_modtype (x, tysig)) in - { scope with - sc_env = EcSection.add_item item scope.sc_env; - sc_locdoc = DocState.add_item scope.sc_locdoc; } + { scope with sc_env = EcSection.add_item item scope.sc_env } - let add ?(src : string option) (scope : scope) (intf : pinterface) = + let add ?src:_ (scope : scope) (intf : pinterface) = assert (scope.sc_pr_uc = None); - - let scope = - { scope with - sc_locdoc = - match intf.pi_locality with - | `Local -> DocState.prevent_process scope.sc_locdoc - | `Global -> DocState.start_process scope.sc_locdoc (unloc intf.pi_name) `ModuleType `Specific } - in - let scope = - { scope with - sc_locdoc = - match src with - | Some src -> DocState.push_srcbl scope.sc_locdoc src - | None -> scope.sc_locdoc; } - in let tysig = EcTyping.transmodsig (env scope) intf in bind scope (unloc intf.pi_name, tysig) end (* -------------------------------------------------------------------- *) -module Theory = struct - open EcTheory +(* Forward reference: filled in later by [Cloning] (which depends on + [Theory] which is defined after [Ty]). *) +let subtype_hooks_ref : scope EcTheoryReplay.ovrhooks ref = + ref { EcTheoryReplay.henv = (fun _ -> assert false); + EcTheoryReplay.hadd_item = (fun _ ~import:_ _ -> assert false); + EcTheoryReplay.hthenter = (fun _ _ _ _ -> assert false); + EcTheoryReplay.hthexit = (fun _ ~import:_ _ -> assert false); + EcTheoryReplay.herr = (fun ?loc:_ _ -> assert false); } - exception TopScope +(* -------------------------------------------------------------------- *) +module Ty = struct + open EcDecl + open EcTyping - (* ------------------------------------------------------------------ *) - let bind ?(import = true) (scope : scope) (cth : thloaded) = - assert (scope.sc_pr_uc = None); - { scope with - sc_env = EcSection.add_th ~import cth scope.sc_env } + module TT = EcTyping + module ELI = EcInductive + module EHI = EcHiInductive (* ------------------------------------------------------------------ *) - let required (scope : scope) (rqd : required_info) = - assert (scope.sc_pr_uc = None); - List.exists (fun x -> - if x.rqd_name = rqd.rqd_name then ( - if (x.rqd_digest <> rqd.rqd_digest) then begin - let fullname (ri : required_info) = - let namespace = - ri.rqd_namespace - |> Option.map EcLoader.string_of_namespace - |> Option.map (fun s -> s ^ ":") - |> Option.value ~default:"" in - namespace ^ ri.rqd_name in - hierror - "Digest mismatch, file %s differs from %s" - (fullname x) (fullname rqd) - end; - true) - else false) - scope.sc_required + let check_name_available scope x = + let pname = EcPath.pqname (EcEnv.root (env scope)) x.pl_desc in - (* ------------------------------------------------------------------ *) - let mark_as_direct (scope : scope) (name : symbol) = - let for1 rq = - if rq.rqd_name = name - then { rq with rqd_direct = true } - else rq - in { scope with sc_required = List.map for1 scope.sc_required } + if EcEnv.Ty .by_path_opt pname (env scope) <> None + || EcEnv.TypeClass.by_path_opt pname (env scope) <> None then + hierror ~loc:x.pl_loc "duplicated type/type-class name `%s'" x.pl_desc (* ------------------------------------------------------------------ *) - let enter ?(src : string option) (scope : scope) (mode : thmode) (name : symbol) = + let bind ?(import = true) (scope : scope) ((x, tydecl) : (_ * tydecl)) = assert (scope.sc_pr_uc = None); - let sc_locdoc = scope.sc_locdoc in - let sc_locdoc = - match src with - | None -> DocState.prevent_process scope.sc_locdoc - | Some src -> - let sc_locdoc = - DocState.start_process sc_locdoc name `Theory - (match mode with `Concrete -> `Specific | `Abstract -> `Abstract) - in - DocState.push_srcbl sc_locdoc src - in - let - scope = { scope with sc_locdoc } - in - - subscope scope mode name + let item = EcTheory.mkitem ~import (EcTheory.Th_type (x, tydecl)) in + { scope with sc_env = EcSection.add_item item scope.sc_env } (* ------------------------------------------------------------------ *) - let rec require_loaded (id : required_info) scope = - if required scope id then - scope - else - match Msym.find_opt id.rqd_name scope.sc_loaded with - | Some (rth, ids) -> - let scope = List.fold_right require_loaded ids scope in - let env = EcSection.require rth scope.sc_env in - { scope with - sc_env = env; - sc_required = id :: scope.sc_required; } + let add_subtype (scope : scope) ({ pl_desc = subtype } : psubtype located) = + let loced x = mk_loc _dummy x in + let env = env scope in - | None -> assert false + let carrier = + let ue = EcUnify.UniEnv.create None in + transty tp_tydecl env ue subtype.pst_carrier in - (* ------------------------------------------------------------------ *) - let update_with_required ~(dst : scope) ~(src : scope) = - let dst = - let sc_loaded = - Msym.union - (fun _ x y -> assert (x ==(*phy*) y); Some x) - dst.sc_loaded src.sc_loaded - in { dst with sc_loaded } - in List.fold_right require_loaded src.sc_required dst + let pred = + let x = EcIdent.create (fst subtype.pst_pred).pl_desc in + let env = EcEnv.Var.bind_local x carrier env in + let ue = EcUnify.UniEnv.create None in + let pred = EcTyping.trans_prop env ue (snd subtype.pst_pred) in + if not (EcUnify.UniEnv.closed ue) then + hierror ~loc:(snd subtype.pst_pred).pl_loc + "the predicate contains free type variables"; + let uidmap = EcUnify.UniEnv.close ue in + let tw_uni = EcUnify.UniEnv.tw_assubst ue in + let fs = EcCoreSubst.Tuni.subst ~tw_uni uidmap in + f_lambda [(x, GTty carrier)] (Fsubst.f_subst fs pred) in - (* ------------------------------------------------------------------ *) - let add_clears clears scope = - let clears = - let for1 = function - | None -> EcEnv.root (env scope) - | Some { pl_loc = loc; pl_desc = (xs, x) as q } -> - let xp = EcEnv.root (env scope) in - let xp = EcPath.pqname (EcPath.extend xp xs) x in - if is_none (EcEnv.Theory.by_path_opt xp (env scope)) then - hierror ~loc "unknown theory: `%s`" (string_of_qsymbol q); - xp - in List.map for1 clears - in { scope with sc_clears = scope.sc_clears @ clears } + let scope = + let decl = EcDecl.{ + tyd_params = []; + tyd_type = `Abstract []; + tyd_resolve = true; + tyd_loca = `Global; + (* Carry the carrier+predicate so [tydecl_fv] picks up the + dependency on section-declared types and [generalize_tydecl] + produces the right tparams at section close. *) + tyd_subtype = Some (carrier, pred); + } in bind scope (unloc subtype.pst_name, decl) in - (* -------------------------------------------------------------------- *) - let exit_r ?pempty (scope : scope) = - match scope.sc_top with - | None -> raise TopScope - | Some sup -> - let clears = scope.sc_clears in - let _, cth, _ = EcSection.exit_theory ?pempty ~clears scope.sc_env in - let loaded = scope.sc_loaded in - let required = scope.sc_required in - let sup = { - sup with - sc_loaded = loaded; - sc_locdoc = DocState.add_sub sup.sc_locdoc scope.sc_locdoc} in - ((cth, required), scope.sc_name, sup) + let evclone : EcThCloning.evclone = + let t_entry : EcThCloning.xty_override = (`Direct carrier, `Inline `Clear) in + let st_entry : EcThCloning.xty_override = + ((`ByPath + (EcPath.pqname (EcEnv.root env) (unloc subtype.pst_name)) + :> [`ByPath of EcPath.path | `BySyntax of EcParsetree.ty_override_def | `Direct of EcAst.ty]), + `Inline `Clear) in + let p_entry : EcThCloning.xop_override = (`Direct pred, `Inline `Clear) in + { EcThCloning.evc_empty with + evc_types = Msym.of_list [ + "T", loced t_entry; + "sT", loced st_entry; + ]; + evc_ops = Msym.of_list [ + "P", loced p_entry; + ]; + evc_lemmas = { + ev_bynames = Msym.empty; + ev_global = [ (None, Some [`Include, "prove"]) ] + } } in - (* ------------------------------------------------------------------ *) - let exit ?import ?(pempty = `ClearOnly) ?(clears =[]) (scope : scope) = - assert (scope.sc_pr_uc = None); + let cname = Option.map unloc subtype.pst_cname in + let npath = ofold ((^~) EcPath.pqname) (EcEnv.root env) cname in + let cpath = EcPath.fromqsymbol ([EcCoreLib.i_top], "Subtype") in + let theory = EcEnv.Theory.by_path ~mode:`Abstract cpath env in - let cth = exit_r ~pempty (add_clears clears scope) in - let ((cth, required), (name, _), scope) = cth in - let scope = List.fold_right require_loaded required scope in - let scope = ofold (fun cth scope -> bind ?import scope cth) scope cth in - (name, scope) + let renames : EcThCloning.renaming list = + match subtype.pst_rename with + | None -> [] + | Some (insub, val_) -> [ + (`All, (EcRegexp.regexp "val", EcRegexp.subst val_)); + (`All, (EcRegexp.regexp "insub", EcRegexp.subst insub)); + ] in - (* ------------------------------------------------------------------ *) - let bump_prelude (scope : scope) = - match scope.sc_prelude with - | `InPrelude, _ -> - { scope with sc_prelude = (`InPrelude, - { pr_env = env scope; - pr_required = scope.sc_required; }) } - | _ -> scope + let theory = theory.cth_items in + + let (proofs, scope) = + EcTheoryReplay.replay !subtype_hooks_ref + ~abstract:false ~override_locality:None ~incl:(Option.is_none cname) + ~clears:Sp.empty ~renames ~opath:cpath ~npath + evclone scope + (Option.value ~default:(EcPath.basename cpath) cname, theory, `Global) + in + let proofs = + List.pmap (fun axc -> + match axc.EcThCloning.axc_tac with + | None -> + Some (fst_map some axc.EcThCloning.axc_axiom, + axc.EcThCloning.axc_path, + axc.EcThCloning.axc_env) + | Some _ -> + (* tactic-bearing proofs require Tactics.process_r which + isn't available at this point (defined after Ty); they + are not produced by Subtype's evclone (which only + provides ev_global), so this branch is unreachable. *) + assert false) + proofs + in + Ax.add_defer scope proofs (* ------------------------------------------------------------------ *) - let import (scope : scope) (name : qsymbol) = - assert (scope.sc_pr_uc = None); + let add ?src:_ scope (tyd : ptydecl located) = + let loc = loc tyd in - match EcEnv.Theory.lookup_opt ~mode:`All name (env scope) with - | None -> - hierror - "cannot import the non-existent theory `%s'" - (string_of_qsymbol name) + let { pty_name = name; pty_tyvars = args; + pty_body = body; pty_locality = tyd_loca } = unloc tyd in - | Some (path, cth) -> - if cth.cth_mode = `Abstract then - hierror "cannot import an abstract theory"; - bump_prelude - { scope with - sc_env = EcSection.import path scope.sc_env } + check_name_available scope name; + let env = env scope in + let tyd_params, tyd_type = + match body with + | PTYD_Abstract tcs -> + let ue = TT.transtyvars env (loc, Some args) in + (* Reject duplicate bound labels on the same type declaration. + Default label = parent class bare name. *) + let () = + let seen = ref Sstr.empty in + List.iter (fun ((tc_name, _), lbl_opt, _) -> + let lbl = + match lbl_opt with + | Some l -> unloc l + | None -> snd (unloc tc_name) in + if Sstr.mem lbl !seen then + hierror ~loc + "class bound label `%s' is used by more than one bound \ + on this type. Disambiguate with an explicit \ + [( as