Add more {fmt,pp}_hr, reimplement StateNub.compat_ielr1 (still no…

…t quite correct)

bootstrap/bin/hocc/attribs.ml

@@ -12,6 +12,17 @@ module T = struct
     formatter |> Ordmap.fmt ~alt ~width Contrib.pp t
 
   let pp = Ordmap.pp Contrib.pp
+
+  let fmt_hr symbols prods ?(alt=false) ?(width=0L) t formatter =
+    formatter
+    |> (fun formatter ->
+      List.fmt ~alt ~width (fun (symbol_index, contribs) formatter ->
+        formatter
+        |> Symbol.pp_hr (Symbols.symbol_of_symbol_index symbol_index symbols)
+        |> Fmt.fmt " = "
+        |> Contrib.pp_hr symbols prods contribs
+      ) (Ordmap.to_alist t) formatter
+    )
 end
 include T
 include Identifiable.Make(T)

bootstrap/bin/hocc/attribs.mli

@@ -13,6 +13,12 @@ val fmt: ?alt:bool -> ?width:uns -> t -> (module Fmt.Formatter) -> (module Fmt.F
     If [~alt=true], the output is broken across multiple lines with outermost indentation [~width]
     (elements are indented to [~width + 4]). *)
 
+val fmt_hr: Symbols.t -> Prods.t -> ?alt:bool -> ?width:uns -> t -> (module Fmt.Formatter)
+  -> (module Fmt.Formatter)
+(** [fmt_hr symbols prods ~alt ~width t formatter] formats a human-readable representation of [t].
+    If [~alt=true], the output is broken across multiple lines with outermost indentation [~width]
+    (elements are indented to [~width + 4]). *)
+
 module Seq : sig
   type container = t
 

bootstrap/bin/hocc/contrib.ml

@@ -28,6 +28,29 @@ module T = struct
     |> Fmt.fmt "{shift=" |> Bool.pp shift
     |> Fmt.fmt "; reduce=" |> Ordset.pp reduce
     |> Fmt.fmt "}"
+
+  let pp_hr symbols prods {shift; reduce} formatter =
+    formatter
+    |> Fmt.fmt (match shift with false -> "{" | true -> "{Shift")
+    |> (fun formatter ->
+      match Ordset.is_empty reduce with
+      | true -> formatter
+      | false -> begin
+          formatter
+          |> Fmt.fmt (match shift with false -> "" | true -> ";")
+          |> (fun formatter ->
+            Ordset.foldi ~init:formatter ~f:(fun i formatter prod_index ->
+              let prod = Prods.prod_of_prod_index prod_index prods in
+              formatter
+              |> Fmt.fmt (match i with 0L -> "" | _ -> "; ")
+              |> Fmt.fmt "Reduce ["
+              |> Symbols.pp_prod_hr prod symbols
+              |> Fmt.fmt "]"
+            ) reduce
+          )
+        end
+    )
+    |> Fmt.fmt "}"
 end
 include T
 include Identifiable.Make(T)

bootstrap/bin/hocc/contrib.mli

@@ -11,6 +11,9 @@ type t
 
 include IdentifiableIntf.S with type t := t
 
+val pp_hr: Symbols.t -> Prods.t -> t -> (module Fmt.Formatter) -> (module Fmt.Formatter)
+(** Formatter which outputs contrib in human-readable form. *)
+
 val length: t -> uns
 (** [length t] returns the number of conflicts [t] contributes to. *)
 

bootstrap/bin/hocc/contribs.ml

@@ -21,6 +21,14 @@ module T = struct
 
   let pp t formatter =
     fmt t formatter
+
+  let fmt_hr symbols prods ?(alt=false) ?(width=0L) t formatter =
+    List.fmt ~alt ~width (fun (conflict_state_index, attribs) formatter ->
+      formatter
+      |> StateIndex.pp conflict_state_index
+      |> Fmt.fmt " = "
+      |> Attribs.fmt_hr ~alt ~width:(width + 4L) symbols prods attribs
+    ) (Ordmap.to_alist t) formatter
 end
 include T
 include Identifiable.Make(T)

bootstrap/bin/hocc/contribs.mli

@@ -12,6 +12,12 @@ val fmt: ?alt:bool -> ?width:uns -> t -> (module Fmt.Formatter) -> (module Fmt.F
     If [~alt=true], the output is broken across multiple lines with outermost indentation [~width]
     (elements are indented to [~width + 4]). *)
 
+val fmt_hr: Symbols.t -> Prods.t -> ?alt:bool -> ?width:uns -> t -> (module Fmt.Formatter)
+  -> (module Fmt.Formatter)
+(** [fmt_hr symbols prods ~alt ~width t formatter] formats a human-readable representation of [t].
+    If [~alt=true], the output is broken across multiple lines with outermost indentation [~width]
+    (elements are indented to [~width + 4]). *)
+
 module Seq : sig
   type container = t
 

bootstrap/bin/hocc/kernelContribs.ml

@@ -8,15 +8,15 @@ module T = struct
 
   let cmp = Ordmap.cmp Contribs.cmp
 
-  let fmt_hr precs symbols ?(alt=false) ?(width=0L) t formatter =
+  let pp = Ordmap.pp Contribs.pp
+
+  let fmt_hr symbols prods ?(alt=false) ?(width=0L) t formatter =
     List.fmt ~alt ~width (fun (lr1item, contribs) formatter ->
       formatter
-      |> Lr1Item.pp_hr symbols precs lr1item
+      |> Lr1Item.pp_hr symbols lr1item
       |> Fmt.fmt " = "
-      |> Contribs.pp contribs
+      |> Contribs.fmt_hr symbols prods ~alt ~width:(width + 4L) contribs
     ) (Ordmap.to_alist t) formatter
-
-  let pp = Ordmap.pp Contribs.pp
 end
 include T
 include Identifiable.Make(T)

bootstrap/bin/hocc/kernelContribs.mli

@@ -7,9 +7,9 @@ type t
 
 include IdentifiableIntf.S with type t := t
 
-val fmt_hr: Precs.t -> Symbols.t -> ?alt:bool -> ?width:uns -> t -> (module Fmt.Formatter)
+val fmt_hr: Symbols.t -> Prods.t -> ?alt:bool -> ?width:uns -> t -> (module Fmt.Formatter)
   -> (module Fmt.Formatter)
-(** [fmt_hr precs symbols ~alt ~width t formatter] formats a human-readable representation of [t].
+(** [fmt_hr symbols prods ~alt ~width t formatter] formats a human-readable representation of [t].
     If [~alt=true], the output is broken across multiple lines with outermost indentation [~width]
     (elements are indented to [~width + 4]). *)
 

bootstrap/bin/hocc/lr0Item.mli

@@ -15,7 +15,7 @@ type t = {
 include IdentifiableIntf.S with type t := t
 
 val pp_hr: Symbols.t -> t -> (module Fmt.Formatter) -> (module Fmt.Formatter)
-(** Formatter which outputs precedence in human-readable form. *)
+(** Formatter which outputs LR(0) item in human-readable form. *)
 
 val init: prod:Prod.t -> dot:uns -> t
 (** [init ~prod ~dot] creates an LR(0) item. *)

bootstrap/bin/hocc/lr1Item.ml

@@ -24,7 +24,7 @@ module T = struct
     |> Fmt.fmt "{lr0item=" |> Lr0Item.pp lr0item
     |> Fmt.fmt "; follow=" |> Ordset.pp follow
 
-  let pp_hr symbols precs {lr0item=({prod={prec; _}; _} as lr0item); follow} formatter =
+  let pp_hr symbols {lr0item=({prod={prec; _}; _} as lr0item); follow} formatter =
     formatter
     |> Fmt.fmt "["
     |> Lr0Item.pp_hr symbols lr0item
@@ -43,8 +43,7 @@ module T = struct
     |> (fun formatter ->
       match prec with
       | None -> formatter
-      | Some {index=prec_index; _} ->
-        formatter |> Fmt.fmt " " |> Prec.pp_hr (Precs.prec_of_prec_index prec_index precs)
+      | Some prec -> formatter |> Fmt.fmt " " |> Prec.pp_hr prec
     )
 end
 include T

bootstrap/bin/hocc/lr1Item.mli

@@ -13,8 +13,8 @@ type t = {
 
 include IdentifiableIntf.S with type t := t
 
-val pp_hr: Symbols.t -> Precs.t -> t -> (module Fmt.Formatter) -> (module Fmt.Formatter)
-(** Formatter which outputs precedence in human-readable form. *)
+val pp_hr: Symbols.t -> t -> (module Fmt.Formatter) -> (module Fmt.Formatter)
+(** Formatter which outputs LR(1) item in human-readable form. *)
 
 val init: lr0item:Lr0Item.t -> follow:(Symbol.Index.t, Symbol.Index.cmper_witness) Ordset.t -> t
 (** [init ~lr0item ~follow] creates an LR(1) item. *)

bootstrap/bin/hocc/lr1Itemset.ml

@@ -18,6 +18,12 @@ module T = struct
     |> Fmt.fmt "{items=" |> Ordmap.pp Lr1Item.pp items
     |> Fmt.fmt "; core=" |> Lr0Itemset.pp core
     |> Fmt.fmt "}"
+
+  let fmt_hr symbols ?(alt=false) ?(width=0L) {items; _} formatter =
+    List.fmt ~alt ~width (fun (_lr0item, lr1item) formatter ->
+      formatter
+      |> Lr1Item.pp_hr symbols lr1item
+    ) (Ordmap.to_alist items) formatter
 end
 include T
 include Identifiable.Make(T)
@@ -71,6 +77,12 @@ let choose {items; _} =
   | None -> None
   | Some (_, lr1item) -> Some lr1item
 
+let get Lr1Item.{lr0item; _} {items; _} =
+  Ordmap.get lr0item items
+
+let get_hlt Lr1Item.{lr0item; _} {items; _} =
+  Ordmap.get_hlt lr0item items
+
 let insert (Lr1Item.{lr0item; follow} as lr1item) ({items; core} as t) =
   match Ordmap.get lr0item items with
   | None -> {items=Ordmap.insert ~k:lr0item ~v:lr1item items; core=Lr0Itemset.insert lr0item core}

bootstrap/bin/hocc/lr1Itemset.mli

@@ -7,6 +7,12 @@ type t
 
 include IdentifiableIntf.S with type t := t
 
+val fmt_hr: Symbols.t -> ?alt:bool -> ?width:uns -> t -> (module Fmt.Formatter)
+  -> (module Fmt.Formatter)
+(** [fmt_hr symbols ~alt ~width t formatter] formats a human-readable representation of [t]. If
+    [~alt=true], the output is broken across multiple lines with outermost indentation [~width]
+    (elements are indented to [~width + 4]). *)
+
 module Seq : sig
   type container = t
 
@@ -39,6 +45,14 @@ val mem: Lr1Item.t -> t -> bool
 val choose: t -> Lr1Item.t option
 (** [choose t] returns an arbitrary LR(1) item in [t] if the set is non-empty, [None] otherwise. *)
 
+val get: Lr1Item.t -> t -> Lr1Item.t option
+(** [get lr1item t] returns the LR(1) item in [t] with LR(0) core matching that of [lr1item] if
+    present, [None] otherwise. *)
+
+val get_hlt: Lr1Item.t -> t -> Lr1Item.t
+(** [get lr1item t] returns the LR(1) item in [t] with LR(0) core matching that of [lr1item] if
+    present, halts otherwise. *)
+
 val insert: Lr1Item.t -> t -> t
 (** [insert lr1item t] creates an LR(1) item set equivalent to [t] with [lr1item] inserted, or
     returns [t] if [lr1item] is already present in [t]. *)

bootstrap/bin/hocc/spec.ml

@@ -742,11 +742,10 @@ let symbols_init io precs symbols hmh =
   in
   io, symbols, prods, reductions
 
-let compat_init algorithm ~resolve io symbols prods ~kernel_contribs_of_statenub =
+let compat_init algorithm ~resolve io precs symbols prods ~kernel_contribs =
   let io, compat_string, compat = match algorithm with
     | Conf.Lr1 -> io, "lr1", StateNub.compat_lr1
-    | Conf.Ielr1 ->
-      io, "ielr1", StateNub.compat_ielr1 ~resolve symbols prods ~kernel_contribs_of_statenub
+    | Conf.Ielr1 -> io, "ielr1", StateNub.compat_ielr1 ~resolve precs symbols prods ~kernel_contribs
     | Conf.Pgm1 -> io, "weak", StateNub.compat_pgm1
     | Conf.Lalr1 -> io, "lalr1", StateNub.compat_lalr1
   in
@@ -1391,17 +1390,17 @@ let rec isocores_init algorithm ~resolve io precs symbols prods reductions =
     let io, lalr1_transit_contribs = close_transit_contribs io antes ergos lalr1_transit_contribs in
     let io = io.log |> Fmt.fmt "\n" |> Io.with_log io in
     File.Fmt.stderr |> Fmt.fmt "XXX lalr1_transit_contribs="
-    |> (Ordmap.fmt ~alt:true (TransitContribs.fmt_hr precs symbols ~alt:true ~width:4L) lalr1_transit_contribs)
+    |> (Ordmap.fmt ~alt:true (TransitContribs.fmt_hr symbols prods ~alt:true ~width:4L) lalr1_transit_contribs)
     |> Fmt.fmt "\n"
     |> ignore;
 
     (* Determine state split-stability. *)
     let io, lalr1_isocores_stable = close_stable ~resolve io symbols prods lalr1_isocores
         lalr1_states antes ergos ~lalr1_transit_contribs in
 
-    (* Merge each state's in-transit contribs to determine per state contribs. *)
+    (* Merge each state's out-transit contribs to determine per state contribs. *)
     let lalr1_isocores_contribs_map = Ordmap.fold ~init:(Map.empty (module State.Index))
-      ~f:(fun lalr1_contribs (Transit.{dst=state_index; _}, transit_contribs) ->
+      ~f:(fun lalr1_contribs (Transit.{src=state_index; _}, transit_contribs) ->
         let isocore_contribs = TransitContribs.kernel_contribs transit_contribs
                                |> KernelContribs.merge_shifts (TransitContribs.shifts transit_contribs)
         in
@@ -1522,8 +1521,7 @@ let rec isocores_init algorithm ~resolve io precs symbols prods reductions =
           ~stable isocores' ~workq:workq' ~reported_isocores_length
       end
   end in
-  let io, transit_contribs_of_statenub_gotonub, constrict_contribs, stable,
-    kernel_contribs_of_statenub =
+  let io, transit_contribs_of_statenub_gotonub, constrict_contribs, stable, kernel_contribs =
     match algorithm with
     | Conf.Ielr1 -> begin
         (* Create lookup function for contribs that closes on the prerequisite LALR(1) inadequacy
@@ -1553,8 +1551,11 @@ let rec isocores_init algorithm ~resolve io precs symbols prods reductions =
               | true -> TransitContribs.all transit_contribs
             end
         end in
-        let kernel_contribs_of_statenub statenub = begin
-          Array.get (StateNub.index statenub) lalr1_isocores_contribs
+        let kernel_contribs lr1itemset = begin
+          let core = Lr1Itemset.core lr1itemset in
+          let isocore_index = Isocores.get_core_hlt core lalr1_isocores in
+          File.Fmt.stderr |> Fmt.fmt "XXX isocore_index=" |> State.Index.pp isocore_index |> Fmt.fmt "\n" |> ignore;
+          Array.get isocore_index lalr1_isocores_contribs
         end in
         let constrict_contribs statenub gotocore contribs = begin
           (* Constrict contribs flowing through transitions such that contribs never escape relevant
@@ -1579,15 +1580,14 @@ let rec isocores_init algorithm ~resolve io precs symbols prods reductions =
           let statenub_index = Isocores.get_core_hlt (GotoNub.core gotonub) lalr1_isocores in
           Array.get statenub_index lalr1_isocores_stable
         end in
-        io, transit_contribs_of_statenub_gotonub, constrict_contribs, stable,
-        kernel_contribs_of_statenub
+        io, transit_contribs_of_statenub_gotonub, constrict_contribs, stable, kernel_contribs
       end
     | _ -> io, (fun _statenub _gotonub -> Contribs.empty),
       (fun _statenub _gotocore _contribs -> Contribs.empty), (fun _gotonub -> false),
       (fun _statenub -> KernelContribs.empty)
 
   in
-  let io, compat = compat_init algorithm ~resolve io symbols prods ~kernel_contribs_of_statenub in
+  let io, compat = compat_init algorithm ~resolve io precs symbols prods ~kernel_contribs in
   let isocores, workq = init symbols ~compat in
   let io =
     io.log

bootstrap/bin/hocc/stateNub.ml

@@ -258,47 +258,53 @@ let resolve symbols prods actions =
 let compat_lr1 GotoNub.{goto; _} {lr1itemsetclosure={kernel; _}; _} =
   Lr1Itemset.compat_lr1 goto kernel
 
-let compat_ielr1 ~resolve:do_resolve symbols prods ~kernel_contribs_of_statenub
-    (GotoNub.{contribs=o_contribs; _} as gotonub)
-    ({lr1itemsetclosure=Lr1ItemsetClosure.{index; _}; _} as t) =
-  let kernel_contribs = kernel_contribs_of_statenub t in
-  match KernelContribs.is_empty kernel_contribs with
-  | true -> true
-  | false -> begin
-      let o = init symbols ~index gotonub o_contribs in
-      let constrict_contribs _ _ _ = Contribs.empty in (* XXX Remove. *)
-      let o_actions = actions ~constrict_contribs symbols o in
-      let t_actions = actions ~constrict_contribs symbols t in
-      let o_actions, t_actions = match do_resolve with
-        | false -> o_actions, t_actions
-        | true -> resolve symbols prods o_actions, resolve symbols prods t_actions
-      in
+let compat_ielr1 ~resolve:do_resolve _XXXprecs symbols prods ~kernel_contribs
+    GotoNub.{goto=o_lr1itemset; _}
+    {lr1itemsetclosure=Lr1ItemsetClosure.{kernel=t_lr1itemset; _}; _} =
+  let kernel_contribs = kernel_contribs t_lr1itemset in
+
+  File.Fmt.stderr |> Fmt.fmt "XXX kernel_contribs=" |> KernelContribs.fmt_hr symbols prods ~alt:true kernel_contribs |> Fmt.fmt "\n" |> ignore;
+  File.Fmt.stderr |> Fmt.fmt "XXX kernel_contribs=" |> KernelContribs.fmt_hr symbols prods ~alt:true kernel_contribs |> Fmt.fmt "\n" |> ignore;
+  File.Fmt.stderr |> Fmt.fmt "XXX o_lr1itemset=" |> Lr1Itemset.fmt_hr symbols ~alt:true o_lr1itemset |> Fmt.fmt "\n" |> ignore;
+  File.Fmt.stderr |> Fmt.fmt "XXX t_lr1itemset=" |> Lr1Itemset.fmt_hr symbols ~alt:true t_lr1itemset |> Fmt.fmt "\n" |> ignore;
 
-      KernelContribs.fold_until ~init:true ~f:(fun _ (_item, contribs) ->
-        let compat = Ordset.fold_until ~init:true ~f:(fun _ symbol_index ->
-          let o_action = Ordmap.get symbol_index o_actions in
-          let t_action = Ordmap.get symbol_index t_actions in
-          let eq = Cmp.is_eq (Option.cmp Ordset.cmp o_action t_action) in
-          eq, not eq
-        ) (Contribs.symbol_indexes contribs)
+  let o_contribs, t_contribs = KernelContribs.fold ~init:(Contribs.empty, Contribs.empty)
+    ~f:(fun (o_contribs, t_contribs) (lr1item, contribs) ->
+      let Lr1Item.{follow=o_follow; _} = Lr1Itemset.get_hlt lr1item o_lr1itemset in
+      let Lr1Item.{follow=t_follow; _} = Lr1Itemset.get_hlt lr1item t_lr1itemset in
+      Contribs.fold ~init:(o_contribs, t_contribs)
+        ~f:(fun (o_contribs, t_contribs) conflict_state_index symbol_index contrib ->
+          let contrib_default = match Contrib.mem_shift contrib with
+            | false -> Contrib.empty
+            | true -> Contrib.shift
+          in
+          let o_contrib = match Ordset.mem symbol_index o_follow with
+            | false -> contrib_default
+            | true -> contrib
+          in
+          let t_contrib = match Ordset.mem symbol_index t_follow with
+            | false -> contrib_default
+            | true -> contrib
+          in
+          Contribs.insert ~conflict_state_index symbol_index o_contrib o_contribs,
+          Contribs.insert ~conflict_state_index symbol_index t_contrib t_contribs
+        ) contribs
+    ) kernel_contribs in
+  let compat = Contribs.fold2_until ~init:true
+      ~f:(fun _ _conflict_state_index symbol_index o_contrib_opt t_contrib_opt ->
+        let o_contrib, t_contrib = match o_contrib_opt, t_contrib_opt with
+          | Some o_contrib, None -> o_contrib, Contrib.empty
+          | None, Some t_contrib -> Contrib.empty, t_contrib
+          | Some o_contrib, Some t_contrib -> o_contrib, t_contrib
+          | None, None -> not_reached ()
         in
+        let compat =
+          Contrib.compat_ielr1 ~resolve:do_resolve symbols prods symbol_index o_contrib t_contrib in
         compat, not compat
-      ) kernel_contribs
-    end
-
-(*
-  Contribs.fold2_until ~init:true
-    ~f:(fun _ _conflict_state_index symbol_index contrib0_opt contrib1_opt ->
-      let contrib0, contrib1 = match contrib0_opt, contrib1_opt with
-        | Some contrib0, None -> contrib0, Contrib.empty
-        | None, Some contrib1 -> Contrib.empty, contrib1
-        | Some contrib0, Some contrib1 -> contrib0, contrib1
-        | None, None -> not_reached ()
-      in
-      let compat = Contrib.compat_ielr1 ~resolve symbols prods symbol_index contrib0 contrib1 in
-      compat, not compat
-    ) o_contribs t_contribs
-*)
+      ) o_contribs t_contribs
+  in
+  File.Fmt.stderr |> Fmt.fmt "XXX --> compat=" |> Bool.pp compat |> Fmt.fmt "\n" |> ignore;
+  compat
 
 let compat_pgm1 GotoNub.{goto; _} {lr1itemsetclosure={kernel; _}; _} =
   Lr1Itemset.compat_pgm1 goto kernel