(** {1 Theory of Booleans} *)

(** {2 Signatures for booleans} *)
module View = struct
  type 'a t =
    | B_not of 'a
    | B_and of 'a IArray.t
    | B_or of 'a IArray.t
    | B_imply of 'a IArray.t * 'a
    | B_atom of 'a
end

module type ARG = sig
  module S : Sidekick_core.SOLVER

  type term = S.A.Term.t

  val view_as_bool : term -> term View.t
  val mk_bool : S.A.Term.state -> term View.t -> term
end

module type S = sig
  module A : ARG
  val theory : A.S.theory
end

(** Theory with dynamic reduction to clauses *)
module Make_dyn_tseitin(A : ARG)
(*   : S with module A = A *)
= struct
  (* TODO (long term): relevancy propagation *)

  (* TODO: Tseitin on the fly when a composite boolean term is asserted.
    --> maybe, cache the clause inside the literal *)

  module A = A
  module SI = A.S.Solver_internal
  module T = SI.A.Term
  module Lit = SI.A.Lit

  type term = T.t

  module T_tbl = CCHashtbl.Make(T)

  type t = {
    expanded: unit T_tbl.t; (* set of literals already expanded *)
  }

  let tseitin ~final (self:t) (solver:SI.t) (lit:Lit.t) (lit_t:term) (v:term View.t) : unit =
    Log.debugf 5 (fun k->k "(@[th_bool.tseitin@ %a@])" Lit.pp lit);
    let expanded () = T_tbl.mem self.expanded lit_t in
    let add_axiom c =
      T_tbl.replace self.expanded lit_t ();
      SI.add_persistent_axiom solver c
    in
    match v with
    | B_not _ -> assert false (* normalized *)
    | B_atom _ -> () (* CC will manage *)
    | B_and subs ->
      if Lit.sign lit then (
        (* propagate [lit => subs_i] *)
        IArray.iter
          (fun sub ->
             let sublit = SI.mk_lit solver sub in
             SI.propagate_l solver sublit [lit])
          subs
      ) else if final && not @@ expanded () then (
        (* axiom [¬lit => ∨_i ¬ subs_i] *)
        let subs = IArray.to_list subs in
        let c = Lit.neg lit :: List.map (SI.mk_lit solver ~sign:false) subs in
        add_axiom c
      )
    | B_or subs ->
      if not @@ Lit.sign lit then (
        (* propagate [¬lit => ¬subs_i] *)
        IArray.iter
          (fun sub ->
             let sublit = SI.mk_lit solver ~sign:false sub in
             SI.add_local_axiom solver [Lit.neg lit; sublit])
          subs
      ) else if final && not @@ expanded () then (
        (* axiom [lit => ∨_i subs_i] *)
        let subs = IArray.to_list subs in
        let c = Lit.neg lit :: List.map (SI.mk_lit solver ~sign:true) subs in
        add_axiom c
      )
    | B_imply (guard,concl) ->
      if Lit.sign lit && final && not @@ expanded () then (
        (* axiom [lit => ∨_i ¬guard_i ∨ concl] *)
        let guard = IArray.to_list guard in
        let c =
          SI.mk_lit solver concl :: Lit.neg lit ::
          List.map (SI.mk_lit solver ~sign:false) guard in
        add_axiom c
      ) else if not @@ Lit.sign lit then (
        (* propagate [¬lit => ¬concl] *)
        SI.propagate_l solver (SI.mk_lit solver ~sign:false concl) [lit];
        (* propagate [¬lit => ∧_i guard_i] *)
        IArray.iter
          (fun sub ->
             let sublit = SI.mk_lit solver ~sign:true sub in
             SI.propagate_l solver sublit [lit])
          guard
      )

  let check_ ~final self solver lits =
    lits
      (fun lit ->
         let t = Lit.term lit in
         match A.view_as_bool t with
         | B_atom _ -> ()
         | v -> tseitin ~final self solver lit t v)

  let partial_check (self:t) acts (lits:Lit.t Iter.t) =
    check_ ~final:false self acts lits

  let final_check (self:t) acts (lits:Lit.t Iter.t) =
    check_ ~final:true self acts lits

  let create_and_setup (solver:SI.t) : t =
    let self = {expanded=T_tbl.create 24} in
    SI.on_final_check solver (final_check self);
    SI.on_partial_check solver (partial_check self);
    self

  let theory =
    A.S.mk_theory ~name:"boolean" ~create_and_setup ()
end