Source file `Domain.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
(*******************************************************************************
 * electrod - a model finder for relational first-order linear temporal logic
 * 
 * Copyright (C) 2016-2020 ONERA
 * Authors: Julien Brunel (ONERA), David Chemouil (ONERA)
 * 
 * This Source Code Form is subject to the terms of the Mozilla Public
 * License, v. 2.0. If a copy of the MPL was not distributed with this
 * file, You can obtain one at http://mozilla.org/MPL/2.0/.
 * 
 * SPDX-License-Identifier: MPL-2.0
 * License-Filename: LICENSE.md
 ******************************************************************************)

open Containers
module Map = Name.Map

type t = Relation.t Map.t

let equal dom1 dom2 = Map.equal Relation.equal dom1 dom2

let empty = Map.empty

let mem = Map.mem

let add name rel domain =
  assert (not @@ Map.mem name domain);
  Map.add name rel domain


let get_exn = Map.find

let get = Map.get

let to_list = Map.to_list

let of_list = Map.of_list

let univ_atoms domain =
  let open Relation in
  let open Scope in
  match get_exn Name.univ domain with
  | Const { scope; _ } ->
    (match scope with Exact b -> b | Inexact _ -> assert false)
  | Var _ ->
      assert false
  | exception Not_found ->
      assert false


let pp out rels =
  Fmtc.(
    vbox
    @@ Map.pp
         ~sep:" "
         ~arrow:" : "
         ~start:""
         ~stop:""
         (styled `Cyan Name.pp)
         (Relation.pp ~print_name:false))
    out
    rels


let must name domain =
  assert (mem name domain);
  get_exn name domain |> Relation.scope |> Scope.must


let may name domain =
  assert (mem name domain);
  get_exn name domain |> Relation.scope |> Scope.may


let sup name domain =
  assert (mem name domain);
  get_exn name domain |> Relation.scope |> Scope.sup


let musts ?(with_univ_and_ident = true) domain =
  ( if with_univ_and_ident
  then domain
  else domain |> Map.remove Name.univ |> Map.remove Name.iden )
  |> Map.map Relation.must
  |> to_list


let arities = Fun.(Map.map Relation.arity %> to_list)

let update_domain_with_instance domain instance =
  let module R = Relation in
  let module I = Instance in
  let relation_of_instance_item inst_item rel =
    assert (R.is_const rel);
    R.const (R.name rel) (R.arity rel) (Scope.exact inst_item)
  in
  let keep_instance __name = function
    | `Both (dom_entry, inst_entry) ->
        Some (relation_of_instance_item inst_entry dom_entry)
    | `Left dom_entry ->
        Some dom_entry
    | `Right _ ->
        (* cannot happen: Raw_to_ast checked that every
           instance is in the domain *)
        assert false
  in
  Map.merge_safe ~f:keep_instance domain (Instance.to_map instance)


let rename atom_renaming name_renaming domain =
  to_list domain
  |> List.map (fun (name, rel) ->
         ( List.assoc ~eq:Name.equal name name_renaming
         , Relation.rename atom_renaming name_renaming rel ))
  |> of_list


module P = Intf.Print.Mixin (struct
  type nonrec t = t

  let pp = pp
end)

include P