(*
This file is part of the dpll(t) engine sammy
Copyright (C) 2004  The University of Iowa
George Hagen

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
*)

(* implements priority queue using heapsort *)

(* heap management *)

(* this assumes elements will have a "key" field that is an integer value 
   (actually an integer*status pair to indicate the score of the favored
   literal polarity)
*)

(* In order to speed processing time, predicate ranking scores are calculated
   in a single pass before any sorting occurs (too intensive to be re-
   calculating then during the sort compares.  These score only change on a
   conflict, so are only calculated when we backtrack.
*)

open Global

type pqelement = {
                   pred: Pred.pred;
                   mutable status: Global.status;
                   mutable score: int
                 }


type pqueue = {
                mutable q: pqelement array; (* elements of the queue *)
                mutable size: int; (* "active size" of queue *)
                mutable prev: (int * State.state) list (* previous q sizes *)
              }


(* priority queue functions *)

let parent i = i/2-1

let left i = 2*i+1

let right i = 2*(i+1)

(* x > y = 1
   x < y = -1
   x == y = 0
*)
(* compare x > y ? *)
(* watched preferred over unwatched *)
(* regular favored over quant_abstr *)
(* high score favored over low score *)
(* in event of a score tie, ite guards are favored, then lesser depth predicates *)
let x_gt_y (x:pqelement) (y:pqelement) =
  if Global.pars.Global.nonwatched_lits_last then
    begin
      let wx = Pred.is_watched x.pred in
      let wy = Pred.is_watched y.pred in
      let qx = Pred.is_quantified_abstraction x.pred in
      let qy = Pred.is_quantified_abstraction y.pred in
      if wx && not wy then true
      else if wy && not wx then false
      else if qx && not qy then false
      else if qy && not qx then true
      else if x.score == y.score then
        begin
          let gx = Pred.is_guard x.pred in
          let gy = Pred.is_guard y.pred in
          if gx && not gy then true
          else if gy && not gx then false
          else Pred.get_formula_depth x.pred <= Pred.get_formula_depth y.pred
        end
      else x.score >= y.score
    end
  else if x.score == y.score then
    begin
      let gx = Pred.is_guard x.pred in
      let gy = Pred.is_guard y.pred in
      if gx && not gy then true
      else if gy && not gx then false
      else Pred.get_formula_depth x.pred <= Pred.get_formula_depth y.pred
    end
  else x.score >= y.score


let x_eq_y (x:pqelement) (y:pqelement) =
  Pred.is_watched x.pred == Pred.is_watched y.pred &&
  Pred.is_quantified_abstraction x.pred == Pred.is_quantified_abstraction y.pred &&
  x.score == y.score
  

let rec heapify (a:pqelement array) size i =
  let l = left i in
  let r = right i in
  let largest' = 
    if l < size && (x_gt_y a.(l) a.(i)) then l
    else if l < size && (x_eq_y a.(l) a.(i)) (*&& (Global.id_compare (Pred.id a.(l).pred) (Pred.id a.(i).pred) > 0)*) then l
    else i
  in
  let largest =
    if r < size && (x_gt_y a.(r) a.(largest')) then r
    else if r < size && (x_eq_y a.(r) a.(largest'))(* && (Global.id_compare (Pred.id a.(r).pred) (Pred.id a.(largest').pred) > 0)*) then l
    else largest'
  in
  if largest != i then
    begin
      let tmp = a.(i) in
      a.(i) <- a.(largest);
      a.(largest) <- tmp;
      heapify a size largest
    end

let build_heap (a:pqelement array) size = 
  let rec make_heap a l =
    if (l >= 0) then 
      begin
        heapify a size l;
        make_heap a (l-1)
      end
  in
  make_heap a (size/2)


exception Empty
exception Missed_level

(* this returns the max pred element without changing the queue *)
let peek_queue q =
  if q.size < 1 then raise Empty;
  let a = q.q in
  a.(0).pred


(* this returns the max element *)
(* also moves it to the back of the array (size should now be sz-1) *)
let dequeue q =
  if q.size < 1 then raise Empty;
  (* update the array as appropriate *)
  let a = q.q in
  let max = a.(0) in
  a.(0) <- a.(q.size-1);
  a.(q.size-1) <- max;
  heapify a (q.size-1) 0;
  (* note new q size *)
  q.size <- q.size - 1;
  (max.pred,max.status)

(* save the current queue *)
(* uses current_state *)
let mark_queue q = 
if debug then (print_string  ("Pqueue.mark_queue at "^(string_of_int (State.current_level())));print_string "\n";flush stdout);
  q.prev <- (q.size,State.current_state())::q.prev

(* this (re)builds the priority queue, recalculating current activity 
   keys, from 0 to sz-1 *)
let build_queue q =
  let a = q.q in
  let n = ref 0 in
  while !n < q.size do
    let (score,status) = Pred.get_score_and_status a.(!n).pred in
    a.(!n).score <- score;
    a.(!n).status <- status;
    n:= !n + 1
  done; 
  build_heap a q.size

let empty_queue = 
  {
    q = Array.of_list [];
    size = 0;
    prev = []
  }

let create_queue a state' =
  let size' = Array.length a in
  let newq = {
            q = Array.map (fun x -> 
                            let (sc,st) = Pred.get_score_and_status x in
                            {pred = x; score = sc; status = st}
                          ) a;
            size = size';
            prev = [(size',state')]
          }
  in
  build_queue newq;
  newq

let sort_queue =
  build_queue


(* state' should be the actual state level we are backtracking to *)
(* this means that we are restoring it to the point where it was 
   marked while at state' *)
let backtrack_queue q state' =
  let targ_level = State.level state' in 
  let rec backtrack_q sp =
    match sp with
        (sz,p)::t ->
                   let current_level = State.level p in
                   if targ_level < current_level then
                     backtrack_q t
                   else if targ_level = current_level then
                     begin
                       q.size <- sz;
                       q.prev <- sp
                     end
                   else
                     raise Missed_level
      | [] -> raise Empty
  in
  backtrack_q q.prev;
  build_queue q

(* note: this does _not_ set a backup point *)
(* also this does not re-sort the queue *)
let augment_queue q new_preds =
  let n = List.length new_preds in
  let qn = Array.length q.q in
  let new_q = Array.make (qn + n) q.q.(0) in
  Array.blit q.q 0 new_q n qn;
  let rec add_in l i =
    match l with
        p::t ->
                let (sc,st) = Pred.get_score_and_status p in
                new_q.(i) <- {pred = p; score = sc; status = st};
                add_in t (i+1)
      | [] -> ()
  in
  add_in new_preds 0;
  q.q <- new_q;
  (* update backtracking information to allow for extra preds *)
  q.prev <- List.map (fun (sz,p) -> (sz+n,p)) q.prev

(* ***** debugging support code ***** *)

let print_queue q = 
Printf.printf "queue %d/%d (@ %d):" q.size (Array.length q.q) (State.current_level());
Array.iter (fun x -> 
Printf.printf "%d:%s%s:%d " (Pred.id x.pred)(if x.status == Global.Unsat then "~" else "")(Pred.pred_string x.pred)(x.score)
) q.q;
print_string "\n"

let get_element_ids q = 
  let rec getq n =
    if n = 0 then
      []
    else
      (Pred.id (q.q.(n-1).pred))::(getq (n-1))
  in
  List.sort (Global.id_compare) (getq q.size)

(*
let check_linkages q (max_id:Pred.clause_id) =
 let tbl = Hashtbl.create 100 in
(* Array.iter (fun x -> 
   Hashtbl.iter (fun y _ -> if y <= max_id then Hashtbl.replace tbl y true) (Pred.p_set (x.pred));
   Hashtbl.iter (fun y _ -> if y <= max_id then Hashtbl.replace tbl y true) (Pred.n_set (x.pred))
 ) q.q;*)
  let rec chk n =
    if n = 0 then
      true
    else
      begin
        if (Hashtbl.mem tbl n) then
          chk (n-1)
        else
          begin
            Printf.printf "clause #%d\n" n;
            failwith "lost a base clause!"
          end
      end
  in
  chk max_id
*)
