Reviewed By: ngorogiannis Differential Revision: D26250525 fbshipit-source-id: 5a61bc4ffmaster
Josh Berdine
4 years ago
committed by
Facebook GitHub Bot
parent
daaff7ad01
commit
e284b06e5b
@ -0,0 +1,78 @@
|
||||
(*
|
||||
* Copyright (c) Facebook, Inc. and its affiliates.
|
||||
*
|
||||
* This source code is licensed under the MIT license found in the
|
||||
* LICENSE file in the root directory of this source tree.
|
||||
*)
|
||||
|
||||
(** Renaming Substitutions: injective maps from variables to variables *)
|
||||
|
||||
include Subst_intf
|
||||
|
||||
module Make (Var : VAR) = struct
|
||||
module Set = Var.Set
|
||||
module Map = Var.Map
|
||||
|
||||
type t = Var.t Map.t [@@deriving compare, equal, sexp_of]
|
||||
type x = {sub: t; dom: Set.t; rng: Set.t}
|
||||
|
||||
let t_of_sexp = Map.t_of_sexp Var.t_of_sexp
|
||||
let pp = Map.pp Var.pp Var.pp
|
||||
|
||||
let invariant s =
|
||||
let@ () = Invariant.invariant [%here] s [%sexp_of: t] in
|
||||
let domain, range =
|
||||
Map.fold s (Set.empty, Set.empty)
|
||||
~f:(fun ~key ~data (domain, range) ->
|
||||
(* substs are injective *)
|
||||
assert (not (Set.mem data range)) ;
|
||||
(Set.add key domain, Set.add data range) )
|
||||
in
|
||||
assert (Set.disjoint domain range)
|
||||
|
||||
let empty = Map.empty
|
||||
let is_empty = Map.is_empty
|
||||
|
||||
let freshen vs ~wrt =
|
||||
let dom = Set.inter wrt vs in
|
||||
( if Set.is_empty dom then
|
||||
({sub= empty; dom= Set.empty; rng= Set.empty}, wrt)
|
||||
else
|
||||
let wrt = Set.union wrt vs in
|
||||
let sub, rng, wrt =
|
||||
Set.fold dom (empty, Set.empty, wrt) ~f:(fun x (sub, rng, wrt) ->
|
||||
let x', wrt = Var.freshen x ~wrt in
|
||||
let sub = Map.add_exn ~key:x ~data:x' sub in
|
||||
let rng = Set.add x' rng in
|
||||
(sub, rng, wrt) )
|
||||
in
|
||||
({sub; dom; rng}, wrt) )
|
||||
|> check (fun ({sub; _}, _) -> invariant sub)
|
||||
|
||||
let fold sub z ~f = Map.fold ~f:(fun ~key ~data -> f key data) sub z
|
||||
let domain sub = Set.of_iter (Map.keys sub)
|
||||
let range sub = Set.of_iter (Map.values sub)
|
||||
|
||||
let invert sub =
|
||||
Map.fold sub empty ~f:(fun ~key ~data sub' ->
|
||||
Map.add_exn ~key:data ~data:key sub' )
|
||||
|> check invariant
|
||||
|
||||
let restrict_dom sub0 vs =
|
||||
Map.fold sub0 {sub= sub0; dom= Set.empty; rng= Set.empty}
|
||||
~f:(fun ~key ~data z ->
|
||||
let rng = Set.add data z.rng in
|
||||
if Set.mem key vs then {z with dom= Set.add key z.dom; rng}
|
||||
else (
|
||||
assert (
|
||||
(* all substs are injective, so the current mapping is the only
|
||||
one that can cause [data] to be in [rng] *)
|
||||
(not (Set.mem data (range (Map.remove key sub0))))
|
||||
|| violates invariant sub0 ) ;
|
||||
{z with sub= Map.remove key z.sub; rng} ) )
|
||||
|> check (fun {sub; dom; rng} ->
|
||||
assert (Set.equal dom (domain sub)) ;
|
||||
assert (Set.equal rng (range sub0)) )
|
||||
|
||||
let apply sub v = Map.find v sub |> Option.value ~default:v
|
||||
end
|
||||
@ -0,0 +1,46 @@
|
||||
(*
|
||||
* Copyright (c) Facebook, Inc. and its affiliates.
|
||||
*
|
||||
* This source code is licensed under the MIT license found in the
|
||||
* LICENSE file in the root directory of this source tree.
|
||||
*)
|
||||
|
||||
(** Renaming Substitutions: injective maps from variables to variables *)
|
||||
|
||||
module type VAR = sig
|
||||
type t [@@deriving compare, equal, sexp]
|
||||
|
||||
val pp : t pp
|
||||
|
||||
module Map : sig
|
||||
include Map.S with type key := t
|
||||
|
||||
val t_of_sexp : (Sexp.t -> 'a) -> Sexp.t -> 'a t
|
||||
end
|
||||
|
||||
module Set : Set.S with type elt := t
|
||||
|
||||
val freshen : t -> wrt:Set.t -> t * Set.t
|
||||
end
|
||||
|
||||
module type S = sig
|
||||
type var
|
||||
type set
|
||||
type t [@@deriving compare, equal, sexp]
|
||||
type x = {sub: t; dom: set; rng: set}
|
||||
|
||||
val pp : t pp
|
||||
val empty : t
|
||||
val freshen : set -> wrt:set -> x * set
|
||||
val invert : t -> t
|
||||
|
||||
val restrict_dom : t -> set -> x
|
||||
(** restrict the domain of a substitution to a set, and yield the range of
|
||||
the unrestricted substitution *)
|
||||
|
||||
val is_empty : t -> bool
|
||||
val domain : t -> set
|
||||
val range : t -> set
|
||||
val fold : t -> 's -> f:(var -> var -> 's -> 's) -> 's
|
||||
val apply : t -> var -> var
|
||||
end
|
||||
@ -1,129 +0,0 @@
|
||||
(*
|
||||
* Copyright (c) Facebook, Inc. and its affiliates.
|
||||
*
|
||||
* This source code is licensed under the MIT license found in the
|
||||
* LICENSE file in the root directory of this source tree.
|
||||
*)
|
||||
|
||||
open Var_intf
|
||||
|
||||
(** Variables, parameterized over their representation *)
|
||||
module Make (T : REPR) = struct
|
||||
module T = struct
|
||||
include T
|
||||
|
||||
type strength = t -> [`Universal | `Existential | `Anonymous] option
|
||||
|
||||
let ppx strength ppf v =
|
||||
let id = id v in
|
||||
let name = name v in
|
||||
if id < 0 then Trace.pp_styled `Bold "%%%s!%i" ppf name (-id)
|
||||
else
|
||||
match strength v with
|
||||
| None -> Format.fprintf ppf "%%%s_%i" name id
|
||||
| Some `Universal -> Trace.pp_styled `Bold "%%%s_%i" ppf name id
|
||||
| Some `Existential -> Trace.pp_styled `Cyan "%%%s_%i" ppf name id
|
||||
| Some `Anonymous -> Trace.pp_styled `Cyan "_" ppf
|
||||
|
||||
let pp = ppx (fun _ -> None)
|
||||
end
|
||||
|
||||
include T
|
||||
|
||||
module Map = struct
|
||||
include NS.Map.Make (T)
|
||||
include Provide_of_sexp (T)
|
||||
end
|
||||
|
||||
module Set = struct
|
||||
module S = NS.Set.Make (T)
|
||||
include S
|
||||
include Provide_of_sexp (T)
|
||||
include Provide_pp (T)
|
||||
|
||||
let ppx strength vs = S.pp_full (ppx strength) vs
|
||||
|
||||
let pp_xs fs xs =
|
||||
if not (is_empty xs) then
|
||||
Format.fprintf fs "@<2>∃ @[%a@] .@;<1 2>" pp xs
|
||||
end
|
||||
|
||||
let fresh name ~wrt =
|
||||
let max =
|
||||
match Set.max_elt wrt with None -> 0 | Some m -> max 0 (id m)
|
||||
in
|
||||
let x' = make ~id:(max + 1) ~name in
|
||||
(x', Set.add x' wrt)
|
||||
|
||||
let program ?(name = "") ~id =
|
||||
assert (id > 0) ;
|
||||
make ~id:(-id) ~name
|
||||
|
||||
let identified ~name ~id = make ~id ~name
|
||||
|
||||
(** Variable renaming substitutions *)
|
||||
module Subst = struct
|
||||
type t = T.t Map.t [@@deriving compare, equal, sexp_of]
|
||||
type x = {sub: t; dom: Set.t; rng: Set.t}
|
||||
|
||||
let t_of_sexp = Map.t_of_sexp t_of_sexp
|
||||
let pp = Map.pp pp pp
|
||||
|
||||
let invariant s =
|
||||
let@ () = Invariant.invariant [%here] s [%sexp_of: t] in
|
||||
let domain, range =
|
||||
Map.fold s (Set.empty, Set.empty)
|
||||
~f:(fun ~key ~data (domain, range) ->
|
||||
(* substs are injective *)
|
||||
assert (not (Set.mem data range)) ;
|
||||
(Set.add key domain, Set.add data range) )
|
||||
in
|
||||
assert (Set.disjoint domain range)
|
||||
|
||||
let empty = Map.empty
|
||||
let is_empty = Map.is_empty
|
||||
|
||||
let freshen vs ~wrt =
|
||||
let dom = Set.inter wrt vs in
|
||||
( if Set.is_empty dom then
|
||||
({sub= empty; dom= Set.empty; rng= Set.empty}, wrt)
|
||||
else
|
||||
let wrt = Set.union wrt vs in
|
||||
let sub, rng, wrt =
|
||||
Set.fold dom (empty, Set.empty, wrt) ~f:(fun x (sub, rng, wrt) ->
|
||||
let x', wrt = fresh (name x) ~wrt in
|
||||
let sub = Map.add_exn ~key:x ~data:x' sub in
|
||||
let rng = Set.add x' rng in
|
||||
(sub, rng, wrt) )
|
||||
in
|
||||
({sub; dom; rng}, wrt) )
|
||||
|> check (fun ({sub; _}, _) -> invariant sub)
|
||||
|
||||
let fold sub z ~f = Map.fold ~f:(fun ~key ~data -> f key data) sub z
|
||||
let domain sub = Set.of_iter (Map.keys sub)
|
||||
let range sub = Set.of_iter (Map.values sub)
|
||||
|
||||
let invert sub =
|
||||
Map.fold sub empty ~f:(fun ~key ~data sub' ->
|
||||
Map.add_exn ~key:data ~data:key sub' )
|
||||
|> check invariant
|
||||
|
||||
let restrict_dom sub0 vs =
|
||||
Map.fold sub0 {sub= sub0; dom= Set.empty; rng= Set.empty}
|
||||
~f:(fun ~key ~data z ->
|
||||
let rng = Set.add data z.rng in
|
||||
if Set.mem key vs then {z with dom= Set.add key z.dom; rng}
|
||||
else (
|
||||
assert (
|
||||
(* all substs are injective, so the current mapping is the
|
||||
only one that can cause [data] to be in [rng] *)
|
||||
(not (Set.mem data (range (Map.remove key sub0))))
|
||||
|| violates invariant sub0 ) ;
|
||||
{z with sub= Map.remove key z.sub; rng} ) )
|
||||
|> check (fun {sub; dom; rng} ->
|
||||
assert (Set.equal dom (domain sub)) ;
|
||||
assert (Set.equal rng (range sub0)) )
|
||||
|
||||
let apply sub v = Map.find v sub |> Option.value ~default:v
|
||||
end
|
||||
end
|
||||
Loading…
Reference in new issue