wip: emit proof steps

src/base/Proof.ml

@@ -51,6 +51,7 @@ end
 (* a step is just a unique integer ID.
    The actual step is stored in the chunk_stack. *)
 type proof_step = Proof_ser.ID.t
+type term_id = Proof_ser.ID.t
 
 type lit = Lit.t
 type term = Term.t
@@ -58,9 +59,13 @@ type term = Term.t
 type t = {
   mutable enabled : bool;
   config: Config.t;
+  buf: Buffer.t;
   mutable storage: Storage.t;
   mutable dispose: unit -> unit;
-  mutable steps: CS.Writer.t;
+  mutable steps_writer: CS.Writer.t;
+  mutable next_id: int;
+  map_term: term_id Term.Tbl.t; (* term -> proof ID *)
+  map_fun: term_id Fun.Tbl.t;
 }
 type proof_rule = t -> proof_step
 
@@ -73,14 +78,14 @@ let disable (self:t) : unit =
   self.enabled <- false;
   self.storage <- Storage.No_store;
   self.dispose();
-  self.steps <- CS.Writer.dummy;
+  self.steps_writer <- CS.Writer.dummy;
   ()
 
 let nop_ _ = ()
 
 let create ?(config=Config.default) () : t =
   (* acquire resources for logging *)
-  let storage, steps, dispose =
+  let storage, steps_writer, dispose =
     match config.Config.storage with
     | Config.No_store ->
       Storage.No_store, CS.Writer.dummy, nop_
@@ -99,7 +104,12 @@ let create ?(config=Config.default) () : t =
   in
   { enabled=config.Config.enabled;
     config;
-    steps; storage; dispose; }
+    next_id=1;
+    buf=Buffer.create 1_024;
+    map_term=Term.Tbl.create 32;
+    map_fun=Fun.Tbl.create 32;
+    steps_writer; storage; dispose;
+  }
 
 let iter_chunks_ (r:CS.Reader.t) k =
   let rec loop () =
@@ -127,14 +137,77 @@ let iter_steps_backward (self:t) : Proof_ser.Step.t Iter.t =
         iter_chunks_ iter yield
     end
 
-let dummy_step : proof_step = -1l
+let dummy_step : proof_step = Int32.min_int
 
 let[@inline] enabled (self:t) = self.enabled
 
-let begin_subproof _ = dummy_step
-let end_subproof _ = dummy_step
+(* allocate a unique ID to refer to an event in the trace *)
+let[@inline] alloc_id (self:t) : Proof_ser.ID.t =
+  let n = self.next_id in
+  self.next_id <- 1 + self.next_id;
+  Int32.of_int n
+
+(* emit a proof step *)
+let emit_step_ (self:t) (step:Proof_ser.Step.t) : unit =
+  if enabled self then (
+    Buffer.clear self.buf;
+    Proof_ser.Step.encode self.buf step;
+    Chunk_stack.Writer.add_buffer self.steps_writer self.buf;
+  )
+
+let emit_fun_ (self:t) (f:Fun.t) : term_id =
+  try Fun.Tbl.find self.map_fun f
+  with Not_found ->
+    let id = alloc_id self in
+    Fun.Tbl.add self.map_fun f id;
+    let f_name = ID.to_string (Fun.id f) in
+    emit_step_ self
+      Proof_ser.({ Step.id; view=Fun_decl {Fun_decl.f=f_name}});
+    id
+
+let rec emit_term_ (self:t) (t:Term.t) : term_id =
+  try Term.Tbl.find self.map_term t
+  with Not_found ->
+    let view = match Term_cell.map (emit_term_ self) @@ Term.view t with
+      | Term_cell.Bool b ->
+        Proof_ser.Step_view.Expr_bool {Proof_ser.Expr_bool.b}
+
+      | Term_cell.Ite (a,b,c) ->
+        Proof_ser.Step_view.Expr_if {Proof_ser.Expr_if.cond=a; then_=b; else_=c}
+
+      | Term_cell.Not a ->
+        Proof_ser.Step_view.Expr_not {Proof_ser.Expr_not.f=a}
+
+      | Term_cell.App_fun (f, arr) ->
+        let f = emit_fun_ self f in
+        Proof_ser.Step_view.Expr_app {Proof_ser.Expr_app.f; args=(arr:_ IArray.t:> _ array)}
+
+      | Term_cell.Eq (a, b) ->
+        Proof_ser.Step_view.Expr_eq {Proof_ser.Expr_eq.lhs=a; rhs=b}
+
+      | LRA _ -> assert false (* TODO *)
+    in
+
+    let id = alloc_id self in
+    emit_step_ self Proof_ser.({id; view});
+    id
+
+let emit_lit_ (self:t) (lit:Lit.t) : term_id =
+  let sign = Lit.sign lit in
+  let t = emit_term_ self (Lit.term lit) in
+  if sign then t else Int32.neg t
+
 let emit_redundant_clause _ ~hyps:_ _ = dummy_step
-let emit_input_clause _ _ = dummy_step
+let emit_input_clause (lits:Lit.t Iter.t) (self:t) =
+  if enabled self then (
+    let lits = Iter.map (emit_lit_ self) lits |> Iter.to_array in
+    let id = alloc_id self in
+    emit_step_ self (
+      Proof_ser.({Step.id; view=Step_view.Step_input {Step_input.c={Clause.lits}}})
+    );
+    id
+  ) else dummy_step
+
 let define_term _ _ _ = dummy_step
 let proof_p1 _ _ (_pr:t) = dummy_step
 let lemma_preprocess _ _ ~using:_ (_pr:t) = dummy_step

src/base/Proof_dummy.ml

@@ -14,8 +14,6 @@ let create () : t = ()
 let with_proof _ _ = ()
 
 let enabled (_pr:t) = false
-let begin_subproof _ = ()
-let end_subproof _ = ()
 let del_clause _ _ (_pr:t) = ()
 let emit_redundant_clause _ ~hyps:_ _ = ()
 let emit_input_clause _ _ = ()

src/base/proof_ser.bare

@@ -1,17 +1,22 @@
 
 type ID i32
-type Lit int
+type Lit ID
 
 type Clause {
   lits: []Lit
 }
 
+type Step_input {
+  c: Clause
+}
+
 # clause, RUP with previous steps
 type Step_rup {
   res: Clause
   steps: []ID
 }
 
+# TODO: remove?
 # lit <-> expr
 type Step_bridge_lit_expr {
   lit: Lit
@@ -31,11 +36,46 @@ type Step_preprocess {
   using: []ID
 }
 
+type Fun_decl {
+  f: string
+}
+
+type Expr_bool {
+  b: bool
+}
+
+type Expr_if {
+  cond: ID
+  then_: ID
+  else_: ID
+}
+
+type Expr_not {
+  f: ID
+}
+
+type Expr_eq {
+  lhs: ID
+  rhs: ID
+}
+
+type Expr_app {
+  f: ID
+  args: []ID
+}
+
 type Step_view
-  ( Step_rup
+  ( Step_input
+  | Step_rup
   | Step_bridge_lit_expr
   | Step_cc
   | Step_preprocess
+  | Fun_decl
+  | Expr_bool
+  | Expr_if
+  | Expr_not
+  | Expr_eq
+  | Expr_app
   )
 
 type Step {

src/base/proof_ser.ml

@@ -252,14 +252,14 @@ module ID = struct
 end
 
 module Lit = struct
-  type t = int64
+  type t = ID.t
   
   (** @raise Bare.Decode.Error in case of error. *)
   let decode (dec: Bare.Decode.t) : t =
-    Bare.Decode.int dec
+    ID.decode dec
   
   let encode (enc: Bare.Encode.t) (self: t) : unit =
-    Bare.Encode.int enc self
+    ID.encode enc self
   
 end
 
@@ -285,6 +285,20 @@ module Clause = struct
   
 end
 
+module Step_input = struct
+  type t = {
+    c: Clause.t;
+  }
+  
+  (** @raise Bare.Decode.Error in case of error. *)
+  let decode (dec: Bare.Decode.t) : t =
+    let c = Clause.decode dec in {c; }
+  
+  let encode (enc: Bare.Encode.t) (self: t) : unit =
+    begin Clause.encode enc self.c; end
+  
+end
+
 module Step_rup = struct
   type t = {
     res: Clause.t;
@@ -375,39 +389,179 @@ module Step_preprocess = struct
   
 end
 
+module Fun_decl = struct
+  type t = {
+    f: string;
+  }
+  
+  (** @raise Bare.Decode.Error in case of error. *)
+  let decode (dec: Bare.Decode.t) : t =
+    let f = Bare.Decode.string dec in {f; }
+  
+  let encode (enc: Bare.Encode.t) (self: t) : unit =
+    begin Bare.Encode.string enc self.f; end
+  
+end
+
+module Expr_bool = struct
+  type t = {
+    b: bool;
+  }
+  
+  (** @raise Bare.Decode.Error in case of error. *)
+  let decode (dec: Bare.Decode.t) : t =
+    let b = Bare.Decode.bool dec in {b; }
+  
+  let encode (enc: Bare.Encode.t) (self: t) : unit =
+    begin Bare.Encode.bool enc self.b; end
+  
+end
+
+module Expr_if = struct
+  type t = {
+    cond: ID.t;
+    then_: ID.t;
+    else_: ID.t;
+  }
+  
+  (** @raise Bare.Decode.Error in case of error. *)
+  let decode (dec: Bare.Decode.t) : t =
+    let cond = ID.decode dec in
+    let then_ = ID.decode dec in
+    let else_ = ID.decode dec in
+    {cond; then_; else_; }
+  
+  let encode (enc: Bare.Encode.t) (self: t) : unit =
+    begin
+      ID.encode enc self.cond;
+      ID.encode enc self.then_;
+      ID.encode enc self.else_;
+    end
+  
+end
+
+module Expr_not = struct
+  type t = {
+    f: ID.t;
+  }
+  
+  (** @raise Bare.Decode.Error in case of error. *)
+  let decode (dec: Bare.Decode.t) : t =
+    let f = ID.decode dec in {f; }
+  
+  let encode (enc: Bare.Encode.t) (self: t) : unit =
+    begin ID.encode enc self.f; end
+  
+end
+
+module Expr_eq = struct
+  type t = {
+    lhs: ID.t;
+    rhs: ID.t;
+  }
+  
+  (** @raise Bare.Decode.Error in case of error. *)
+  let decode (dec: Bare.Decode.t) : t =
+    let lhs = ID.decode dec in let rhs = ID.decode dec in {lhs; rhs; }
+  
+  let encode (enc: Bare.Encode.t) (self: t) : unit =
+    begin ID.encode enc self.lhs; ID.encode enc self.rhs; end
+  
+end
+
+module Expr_app = struct
+  type t = {
+    f: ID.t;
+    args: ID.t array;
+  }
+  
+  (** @raise Bare.Decode.Error in case of error. *)
+  let decode (dec: Bare.Decode.t) : t =
+    let f = ID.decode dec in
+    let args =
+      (let len = Bare.Decode.uint dec in
+       if len>Int64.of_int Sys.max_array_length then raise (Bare.Decode.Error"array too big");
+       Array.init (Int64.to_int len) (fun _ -> ID.decode dec)) in
+    {f; args; }
+  
+  let encode (enc: Bare.Encode.t) (self: t) : unit =
+    begin
+      ID.encode enc self.f;
+      (let arr = self.args in
+       Bare.Encode.uint enc (Int64.of_int (Array.length arr));
+       Array.iter (fun xi -> ID.encode enc xi) arr);
+    end
+  
+end
+
 module Step_view = struct
   type t =
+    | Step_input of Step_input.t
     | Step_rup of Step_rup.t
     | Step_bridge_lit_expr of Step_bridge_lit_expr.t
     | Step_cc of Step_cc.t
     | Step_preprocess of Step_preprocess.t
+    | Fun_decl of Fun_decl.t
+    | Expr_bool of Expr_bool.t
+    | Expr_if of Expr_if.t
+    | Expr_not of Expr_not.t
+    | Expr_eq of Expr_eq.t
+    | Expr_app of Expr_app.t
     
   
   (** @raise Bare.Decode.Error in case of error. *)
   let decode (dec: Bare.Decode.t) : t =
     let tag = Bare.Decode.uint dec in
     match tag with
-    | 0L -> Step_rup (Step_rup.decode dec)
-    | 1L -> Step_bridge_lit_expr (Step_bridge_lit_expr.decode dec)
-    | 2L -> Step_cc (Step_cc.decode dec)
-    | 3L -> Step_preprocess (Step_preprocess.decode dec)
+    | 0L -> Step_input (Step_input.decode dec)
+    | 1L -> Step_rup (Step_rup.decode dec)
+    | 2L -> Step_bridge_lit_expr (Step_bridge_lit_expr.decode dec)
+    | 3L -> Step_cc (Step_cc.decode dec)
+    | 4L -> Step_preprocess (Step_preprocess.decode dec)
+    | 5L -> Fun_decl (Fun_decl.decode dec)
+    | 6L -> Expr_bool (Expr_bool.decode dec)
+    | 7L -> Expr_if (Expr_if.decode dec)
+    | 8L -> Expr_not (Expr_not.decode dec)
+    | 9L -> Expr_eq (Expr_eq.decode dec)
+    | 10L -> Expr_app (Expr_app.decode dec)
     | _ -> raise (Bare.Decode.Error(Printf.sprintf "unknown union tag Step_view.t: %Ld" tag))
     
   
   let encode (enc: Bare.Encode.t) (self: t) : unit =
     match self with
-    | Step_rup x ->
+    | Step_input x ->
       Bare.Encode.uint enc 0L;
+      Step_input.encode enc x
+    | Step_rup x ->
+      Bare.Encode.uint enc 1L;
       Step_rup.encode enc x
     | Step_bridge_lit_expr x ->
-      Bare.Encode.uint enc 1L;
+      Bare.Encode.uint enc 2L;
       Step_bridge_lit_expr.encode enc x
     | Step_cc x ->
-      Bare.Encode.uint enc 2L;
+      Bare.Encode.uint enc 3L;
       Step_cc.encode enc x
     | Step_preprocess x ->
-      Bare.Encode.uint enc 3L;
+      Bare.Encode.uint enc 4L;
       Step_preprocess.encode enc x
+    | Fun_decl x ->
+      Bare.Encode.uint enc 5L;
+      Fun_decl.encode enc x
+    | Expr_bool x ->
+      Bare.Encode.uint enc 6L;
+      Expr_bool.encode enc x
+    | Expr_if x ->
+      Bare.Encode.uint enc 7L;
+      Expr_if.encode enc x
+    | Expr_not x ->
+      Bare.Encode.uint enc 8L;
+      Expr_not.encode enc x
+    | Expr_eq x ->
+      Bare.Encode.uint enc 9L;
+      Expr_eq.encode enc x
+    | Expr_app x ->
+      Bare.Encode.uint enc 10L;
+      Expr_app.encode enc x
     
     
 end

src/util/Chunk_stack.ml

@@ -8,6 +8,8 @@ module Buf = struct
   let create ?(cap=16) () : t =
     { len=0; b=Bytes.create cap; }
 
+  let[@inline] size self = self.len
+
   let resize_ self new_len : unit =
     let size = min (new_len + new_len / 4 + 5) Sys.max_string_length in
     if new_len > size then failwith "max buf size exceeded";
@@ -27,6 +29,10 @@ module Buf = struct
     Bytes.blit b off self.b self.len len;
     self.len <- self.len + len
 
+  let add_buffer (self:t) (buf:Buffer.t) =
+    ensure_size_ self (size self + Buffer.length buf);
+    Buffer.blit buf 0 self.b self.len (Buffer.length buf)
+
   let[@inline] add_buf (self:t) (other:t) =
     add_bytes self other.b 0 other.len
 
@@ -38,11 +44,15 @@ end
 module Writer = struct
   type t = {
     write: bytes -> int -> int -> unit;
+    write_buf: Buffer.t -> unit;
   }
 
   let nop_ _ = ()
 
-  let dummy : t = { write=fun _ _ _ -> (); }
+  let dummy : t = {
+    write=(fun _ _ _ -> ());
+    write_buf=(fun _ -> ());
+  }
 
   let into_buf (into:Buf.t) : t =
     let blen = Bytes.create 4 in
@@ -52,7 +62,12 @@ module Writer = struct
       Bytes.set_int32_le blen 0 (Int32.of_int len);
       Buf.add_bytes into blen 0 4;
     in
-    { write; }
+    let write_buf buf =
+      Buf.add_buffer into buf;
+      Bytes.set_int32_le blen 0 (Int32.of_int (Buffer.length buf));
+      Buf.add_bytes into blen 0 4;
+    in
+    { write; write_buf }
 
   let into_channel (oc:out_channel) : t =
     let blen = Bytes.create 4 in
@@ -61,13 +76,19 @@ module Writer = struct
       (* add len *)
       Bytes.set_int32_le blen 0 (Int32.of_int len);
       output oc blen 0 4
+    and write_buf buf =
+      Buffer.output_buffer oc buf;
+      (* add len *)
+      Bytes.set_int32_le blen 0 (Int32.of_int (Buffer.length buf));
+      output oc blen 0 4
     in
-    { write; }
+    { write; write_buf; }
 
   let[@inline] add_buf self buf = self.write buf.Buf.b 0 buf.Buf.len
   let[@inline] add_bytes self b i len = self.write b i len
   let[@inline] add_string self s =
     add_bytes self (Bytes.unsafe_of_string s) 0 (String.length s)
+  let[@inline] add_buffer self (buf:Buffer.t) = self.write_buf buf
 end
 
 module Reader = struct

src/util/Chunk_stack.mli

@@ -41,6 +41,8 @@ module Writer : sig
   val add_bytes : t -> bytes -> int -> int -> unit
 
   val add_string : t -> string -> unit
+
+  val add_buffer : t -> Buffer.t -> unit
 end
 
 module Reader : sig