swh:1:snp:1160b607213f14ec0f922dad3284705c8e588b30
Tip revision: e15c19fa91bfeaa48aac1e1225d26b3c2e38afba authored by Pierre-Yves Strub on 10 July 2019, 05:57:29 UTC
Merge branch '1.0' into deploy-transeq
Merge branch '1.0' into deploy-transeq
Tip revision: e15c19f
ecRing.ml
(* --------------------------------------------------------------------
* 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
* -------------------------------------------------------------------- *)
(* Copyright The Coq Development Team, 1999-2010
* Copyright INRIA - CNRS - LIX - LRI - PPS, 1999-2010
*
* This file is distributed under the terms of the:
* GNU Lesser General Public License Version 2.1
*
* This file originates from the `Coq Proof Assistant'
* It has been modified for the needs of EasyCrypt
*)
(* -------------------------------------------------------------------- *)
open EcMaps
open EcUtils
module BI = EcBigInt
open EcBigInt.Notations
(* -------------------------------------------------------------------- *)
type pexpr =
| PEc of BI.zint
| PEX of int
| PEadd of pexpr * pexpr
| PEsub of pexpr * pexpr
| PEmul of pexpr * pexpr
| PEopp of pexpr
| PEpow of pexpr * BI.zint
let rec pp_pe fmt = function
| PEc c -> Format.fprintf fmt "%a" BI.pp_print c
| PEX i -> Format.fprintf fmt "x_%i" i
| PEadd(p1,p2) -> Format.fprintf fmt "%a + %a" pp_pe p1 pp_pe p2
| PEsub(p1,p2) -> Format.fprintf fmt "%a - %a" pp_pe p1 pp_pe p2
| PEmul(p1,p2) -> Format.fprintf fmt "%a * %a" pp_pe p1 pp_pe p2
| PEopp p -> Format.fprintf fmt "-%a" pp_pe p
| PEpow(p,i) -> Format.fprintf fmt "%a^%a" pp_pe p BI.pp_print i
let rec pexpr_eq (e1 : pexpr) (e2 : pexpr) : bool =
match (e1,e2) with
| (PEc c, PEc c') -> BI.equal c c'
| (PEX p1, PEX p2) -> p1 = p2
| (PEadd (e3,e5), PEadd (e4,e6)) -> pexpr_eq e3 e4 && pexpr_eq e5 e6
| (PEsub (e3,e5), PEsub (e4,e6)) -> pexpr_eq e3 e4 && pexpr_eq e5 e6
| (PEmul (e3,e5), PEmul (e4,e6)) -> pexpr_eq e3 e4 && pexpr_eq e5 e6
| (PEopp e3, PEopp e4) -> pexpr_eq e3 e4
| (PEpow (e3,n3), PEpow (e4,n4)) -> BI.equal n3 n4 && pexpr_eq e3 e4
| (_,_) -> false
let fv_pe =
let rec aux fv = function
| PEc _ -> fv
| PEX i -> Sint.add i fv
| PEadd(e1,e2) -> aux (aux fv e1) e2
| PEsub(e1,e2) -> aux (aux fv e1) e2
| PEmul(e1,e2) -> aux (aux fv e1) e2
| PEopp e1 -> aux fv e1
| PEpow(e1,_) -> aux fv e1 in
aux Sint.empty
(* -------------------------------------------------------------------- *)
type 'a cmp_sub = [`Eq | `Lt | `Gt of 'a]
(* -------------------------------------------------------------------- *)
exception Overflow
(* -------------------------------------------------------------------- *)
module type Coef = sig
(* ------------------------------------------------------------------ *)
type c
val cofint : BI.zint -> c
val ctoint : c -> BI.zint
val c0 : c
val c1 : c
val cadd : c -> c -> c
val csub : c -> c -> c
val cmul : c -> c -> c
val copp : c -> c
val ceq : c -> c -> bool
val cdiv : c -> c -> c * c
(* ------------------------------------------------------------------ *)
type p
val pofint : BI.zint -> p
val ptoint : p -> BI.zint
val padd : p -> p -> p
val peq : p -> p -> bool
val pcmp : p -> p -> int
val pcmp_sub : p -> p -> p cmp_sub
end
(* -------------------------------------------------------------------- *)
module Cint : Coef = struct
type c = BI.zint
let cofint = (identity : BI.zint -> c)
let ctoint = (identity : c -> BI.zint)
let c0 : c = BI.zero
let c1 : c = BI.one
let cadd = (BI.add : c -> c -> c)
let csub = (BI.sub : c -> c -> c)
let cmul = (BI.mul : c -> c -> c)
let copp = (BI.neg : c -> c)
let cdiv = (BI.ediv : c -> c -> c * c)
let ceq = (BI.equal : c -> c -> bool)
type p = BI.zint
let pofint = (identity : BI.zint -> p)
let ptoint = (identity : p -> BI.zint)
let padd = (BI.add : c -> c -> c)
let peq = (BI.equal : c -> c -> bool)
let pcmp = (BI.compare : c -> c -> int)
let pcmp_sub (p1 : p) (p2 : p) : p cmp_sub =
match BI.compare p1 p2 with
| c when c < 0 -> `Lt
| 0 -> `Eq
| _ -> `Gt (p1 -^ p2)
end
(* -------------------------------------------------------------------- *)
module Cbool : Coef = struct
type c = int
let cofint (c : BI.zint) =
if BI.sign c = 0 then 0 else 1
let ctoint (c : int) =
if c == 0 then BI.zero else BI.one
let c0 : c = 0
let c1 : c = 1
let cadd = ((lxor) : c -> c -> c)
let csub = ((lxor) : c -> c -> c)
let cmul = ((land) : c -> c -> c)
let copp = (identity : c -> c)
let ceq = ((=) : c -> c -> bool)
let cdiv (x : c) (y : c) : c * c =
if y == 0 then raise Division_by_zero; (x, 0)
type p = unit
let pofint (_p : BI.zint) = assert (BI.one <=^ _p); ()
let ptoint (_p : p) = BI.one
let padd = (fun (_ : p) (_ : p) -> ())
let peq = (fun (_ : p) (_ : p) -> true)
let pcmp = (fun (_ : p) (_ : p) -> 0)
let pcmp_sub _p1 _p2 = `Eq
end
(* -------------------------------------------------------------------- *)
module type ModVal = sig
val c : BI.zint option
val p : BI.zint option
end
(* -------------------------------------------------------------------- *)
module Cmod (M : ModVal) : Coef = struct
type c = BI.zint
let correct_c : c -> c =
match M.c with
| None -> fun x -> x
| Some c -> fun x -> BI.erem x c
let cofint c = correct_c c
let ctoint c = c
let c0 = correct_c BI.zero
let c1 = correct_c BI.one
let cadd a b = correct_c (a +^ b)
let csub a b = correct_c (a -^ b)
let cmul a b = correct_c (a *^ b)
let copp a = correct_c (~^ a)
let cdiv a b =
let (q, r) = BI.ediv a b in
(correct_c q, correct_c r)
let ceq = (BI.equal : c -> c -> bool)
type p = BI.zint
let correct_p : p -> p =
match M.p with
| None -> fun p -> p
| Some pn ->
let rec doit p =
if p <^ pn then p else
let (q, r) = BI.ediv p pn in doit (q +^ r)
in doit
let pofint (p : BI.zint) = correct_p p
let ptoint (p : p) = p
let padd p1 p2 = correct_p (p1 +^ p2)
let peq = (BI.equal : p -> p -> bool)
let pcmp = (BI.compare : p -> p -> int)
let pcmp_sub : p -> p -> p cmp_sub =
match M.p with
| None ->
fun (p1 : p) (p2 : p) -> begin
match BI.compare p1 p2 with
| c when c < 0 -> `Lt
| 0 -> `Eq
| _ -> `Gt (p1 -^ p2)
end
| Some pn ->
fun (p1 : p) (p2 : p) -> begin
match BI.compare p1 p2 with
| c when c < 0 -> `Gt (BI.pred (p1 +^ (pn -^ p2)))
| 0 -> `Eq
| _ -> `Gt (p1 -^ p2)
end
end
(* -------------------------------------------------------------------- *)
module type Rnorm = sig
module C : Coef
val norm_pe: pexpr -> (pexpr * pexpr) list -> pexpr
end
(* -------------------------------------------------------------------- *)
module Make (C : Coef) : Rnorm = struct
module C = C
module Var = struct
type t = int
let compare = (compare : t -> t -> int)
let eq = ((==) : t -> t -> bool)
end
module Mon = struct
type t = (Var.t * C.p) list
let rec eq (m1 : t) (m2 : t) =
match m1, m2 with
| (x1,p1)::m1, (x2,p2)::m2 ->
Var.eq x1 x2 && C.peq p1 p2 && eq m1 m2
| [], [] -> true
| _ , _ -> false
let rec compare (m1 : t) (m2 : t) =
match m1, m2 with
| [], [] -> 0
| [], _ -> -1
| _, [] -> 1
| (x1,p1)::m1, (x2,p2)::m2 -> begin
match Var.compare x1 x2 with
| n when n <> 0 -> n
| _ ->
match C.pcmp p1 p2 with
| n when n <> 0 -> n
| _ -> compare m1 m2
end
let one : t =
[]
let cons (x : Var.t) (p : C.p) (m : t) : t =
(x, p) :: m
let rec mul m1 m2 =
match m1, m2 with
| [], _ -> m2 | _, [] -> m1
| ((x1, p1) as xp1) :: m1', ((x2, p2) as xp2) :: m2' ->
match Var.compare x1 x2 with
| c when c < 0 -> xp1 :: mul m1' m2
| c when c > 0 -> xp2 :: mul m1 m2'
| _ -> cons x1 (C.padd p1 p2) (mul m1' m2')
(* factor m1 m2 = Some m => m1 = m*m2 *)
let rec factor m m1 m2 =
match m1, m2 with
| _, [] -> Some (List.rev_append m m1)
| [], _ -> None
| (x1,p1 as xp1) :: m1', (x2,p2) :: m2' ->
match Var.compare x1 x2 with
| c when c < 0 -> factor (xp1::m) m1' m2
| c when c > 0 -> None
| _ -> begin
match C.pcmp_sub p1 p2 with
| `Lt -> None
| `Eq -> factor m m1' m2'
| `Gt p -> factor ((x1,p)::m) m1' m2'
end
let factor m1 m2 = factor [] m1 m2
let degree m =
List.fold_left (fun i (_, p) -> i +^ C.ptoint p) BI.zero m
end
module Pol = struct
type t = (C.c * Mon.t) list
let rec eq (p1 : t) (p2 : t) =
match p1, p2 with
| (c1,m1)::p1, (c2,m2)::p2 ->
C.ceq c1 c2 && Mon.eq m1 m2 && eq p1 p2
| [], [] -> true
| _ , _ -> false
let zero : t = []
let one : t = [C.c1, Mon.one]
let cmon (c : C.c) (m : Mon.t) : t =
if C.ceq c C.c0 then zero else [c, m]
let cons (c : C.c) (m : Mon.t) (p : t) : t =
if C.ceq c C.c0 then p else (c, m)::p
let rec add (p1 : t) (p2 : t) : t =
match p1, p2 with
| [], _ -> p2
| _ , [] -> p1
| ((c1, m1) as cm1) :: p1', ((c2, m2) as cm2) :: p2' ->
match Mon.compare m1 m2 with
| c when c < 0 -> cm1 :: add p1' p2
| c when c > 0 -> cm2 :: add p1 p2'
| _ -> cons (C.cadd c1 c2) m1 (add p1' p2')
let rec opp (p : t) : t =
List.map (fst_map C.copp) p
let rec sub (p1 : t) (p2 : t) : t =
match p1, p2 with
| [], _ -> opp p2
| _ , [] -> p1
| (c1,m1 as cm1) :: p1', (c2,m2) :: p2' ->
match Mon.compare m1 m2 with
| c when c < 0 -> cm1 :: sub p1' p2
| c when c > 0 -> (C.copp c2, m2) :: sub p1 p2'
| _ -> cons (C.csub c1 c2) m1 (sub p1' p2')
let rec mul =
let rec mul_mon ((c1, m1) as cm1) (p : t) : t=
match p with
| [] -> []
| (c2, m2) :: p -> add [C.cmul c1 c2, Mon.mul m1 m2] (mul_mon cm1 p)
in fun (p1 : t) (p2 : t) ->
match p1 with
| [] -> []
| cm1::p1 -> add (mul_mon cm1 p2) (mul p1 p2)
let rec pow_int p n =
if BI.equal n BI.one then p else
let r = pow_int p (BI.rshift n 1) in
match BI.parity n with
| `Even -> mul r r
| `Odd -> mul p (mul r r)
let pow p e =
let n = C.ptoint e in
if BI.sign n <= 0 then [C.c1, Mon.one] else pow_int p n
(* pexpr -> pol *)
let rec ofpexpr = function
| PEc i -> cmon (C.cofint i) []
| PEX x -> [C.c1, [x, C.pofint BI.one]]
| PEadd(p1,p2) -> add (ofpexpr p1) (ofpexpr p2)
| PEsub(p1,p2) -> sub (ofpexpr p1) (ofpexpr p2)
| PEmul(p1,p2) -> mul (ofpexpr p1) (ofpexpr p2)
| PEopp p -> opp (ofpexpr p)
| PEpow(p,i) -> pow (ofpexpr p) (C.pofint i)
(* factorization by a monomial *)
let cmfactor (c1, m1 as cm1) (c2, m2) =
match Mon.factor m1 m2 with
| None -> zero, [cm1]
| Some m -> let (q, r) = C.cdiv c1 c2 in (cmon q m, cmon r m1)
let rec factor (p : t) (cm : C.c * Mon.t) : t * t =
match p with
| [] ->
(zero, zero)
| cm'::p ->
let (cq, cr) = cmfactor cm' cm in
let (pq, pr) = factor p cm in
(add cq pq, add cr pr)
type rw = (C.c * Mon.t) * t
let rec rewrite1 (p : t) (cm, p' as rw : rw) : t =
let (q, r) = factor p cm in
if eq q zero
then r
else let p = add (mul q p') r in rewrite1 p rw
let rec rewrites (p : t) (rws : rw list) : t =
let p' = List.fold_left rewrite1 p rws in
if eq p p' then p else rewrites p' rws
end
(* pol -> pexpr *)
let xptopexpr (x, p) =
if C.peq p (C.pofint BI.one)
then PEX x
else PEpow (PEX x, C.ptoint p)
let rec mtopexpr pe m =
match m with
| [] -> pe
| xp::m -> mtopexpr (PEmul (pe, xptopexpr xp)) m
let mtopexpr (c, m) =
let i = C.ctoint c in
let i' = BI.abs i in
let set_sign pe = if BI.sign i < 0 then PEopp pe else pe in
if BI.equal i' BI.one then begin
match m with
| [] -> set_sign (PEc i')
| xp::m -> mtopexpr (set_sign (xptopexpr xp)) m
end else
mtopexpr (set_sign (PEc i')) m
let rec topexpr pe p =
match p with
| [] -> pe
| cm :: p -> topexpr (PEadd(pe, mtopexpr cm)) p
let topexpr p =
match p with
| [] -> PEc (C.ctoint C.c0)
| cm :: p -> topexpr (mtopexpr cm) p
let rec get_mon p =
match p with
| [] -> (C.c0, Mon.one, BI.zero, Pol.zero)
| (c, m as cm) :: p ->
let (c', m', d', p') = get_mon p in
let d = Mon.degree m in
if d' <^ d
then (c , m , d , p)
else (c', m', d', cm::p')
let mk_rw (pe1,pe2) =
let p1 = Pol.ofpexpr pe1 in
let p2 = Pol.ofpexpr pe2 in
let (c,m,_,p1') = get_mon p1 in
if C.ceq c C.c0 || Mon.eq m Mon.one then begin
let (c,m,_,p2') = get_mon p2 in
if C.ceq c C.c0 || Mon.eq m Mon.one
then None
else Some ((c,m), Pol.sub p1 p2')
end else
Some ((c,m), Pol.sub p2 p1')
let norm_pe pe lpe =
let rws = List.pmap mk_rw lpe in
let p = Pol.ofpexpr pe in
topexpr (Pol.rewrites p rws)
end
(* -------------------------------------------------------------------- *)
module Iring : Rnorm = Make(Cint)
module Bring : Rnorm = Make(Cbool)
(* -------------------------------------------------------------------- *)
type c = BI.zint
let c0 : c = BI.zero
let c1 : c = BI.one
let cadd = (BI.add : c -> c -> c)
let csub = (BI.sub : c -> c -> c)
let cmul = (BI.mul : c -> c -> c)
let copp = (BI.neg : c -> c)
let ceq = (BI.equal : c -> c -> bool)
let cdiv = (BI.ediv : c -> c -> c * c)