module type OrderedType = sig
type t
val compare: t -> t -> int
end
module BinaryHeap = struct
module MakeArray (Label: OrderedType) = struct
type 'a with_empty =
| Empty
| Value of 'a
type tree = { count: int ref; ary: Label.t with_empty array }
let make_empty_tree q = { count=ref 0; ary=Array.make (q+1) Empty}
let exc_of_opt = function
| Some x -> x
| None -> failwith "error"
let get_value num tree = Array.get tree.ary num
let is_empty num tree =
match get_value num tree with
| Empty -> true
| _ -> false
let is_root num = num <= 1
let set_value num value tree = Array.set tree.ary num value
let get_tail tree = get_value !(tree.count) tree
let set_root value tree = set_value 1 value tree
let get_root tree = get_value 1 tree
let remove_tail tree = let res = get_tail tree in
let count = !(tree.count) in
let () = Array.set tree.ary count Empty in
let () = tree.count := (count - 1) in
res
let add_tail v tree = let () = tree.count := !(tree.count) + 1 in
let () = Array.set tree.ary !(tree.count) v in !(tree.count)
let parent_num num = num / 2
let left_child_num num = 2 * num
let right_child_num num = 2 * num + 1
let swap num num' tree =
let tmp = get_value num tree in
let () = set_value num (get_value num' tree) tree in
let () = set_value num' tmp tree in ()
let gt num num' tree =
match get_value num tree,get_value num' tree with
| Empty,_ -> false
| _,Empty -> true
| Value x,Value y -> Label.compare x y > 0
let max_of_elems num num' tree =
if gt num num' tree then num else num'
let rec up_heap child tree =
if is_root child then ()
else
let parent = parent_num child in
let () = if gt child parent tree then swap child parent tree else () in
up_heap parent tree
let add q tree =
let tail = add_tail (Value q) tree in
let () = up_heap tail tree in tree
let rec down_heap parent tree =
if is_empty parent tree then ()
else
let left = left_child_num parent in
let right = right_child_num parent in
let mc = max_of_elems left right tree in
let () = if gt mc parent tree then swap mc parent tree else () in
down_heap mc tree
let remove tree =
match get_root tree with
| Empty -> None
| Value x ->
let tail_v = remove_tail tree in
match get_root tree with
| Empty -> Some (x,tree)
| _ -> let () = set_root tail_v tree in
let () = down_heap 1 tree in Some (x,tree)
let rec add_list ls tree =
match ls with
| [] -> ()
| x :: xs -> let _ = add x tree in
add_list xs tree
let list_of_tree tree =
let rec iter () =
match remove tree with
| None -> []
| Some (x,_) -> x :: iter () in
iter ()
let find q tree =
let merge_opt opt1 opt2 =
match opt1,opt2 with
| None,None -> None
| Some _,None -> opt1
| None,Some _-> opt2
| Some _,Some _ -> opt1 in
let rec iter num =
match get_value num tree with
| Empty -> None
| Value x -> if Label.compare x q = 0 then Some x
else if Label.compare x q < 0 then None
else
let left = left_child_num num in
let right = right_child_num num in
match get_value left tree,get_value right tree with
| Empty,Empty-> None
| Value l,Empty -> iter left
| Empty,Value r -> iter right
| Value l,Value r -> if Label.compare l q >= 0 && Label.compare r q >= 0
then merge_opt (iter left) (iter right)
else if Label.compare l q >= 0 then iter left
else if Label.compare r q >= 0 then iter right
else None
in iter 1
let mem v tree =
match find v tree with
| Some _ -> true
| None -> false
end
module Make (Label: OrderedType) = struct
type 'a tree =
| Empty
| Node of int * 'a * 'a tree * 'a tree
let empty = Empty
let rank_of_tree = function
| Empty -> 0
| Node(rank,_,_,_) -> rank
let gt q q' = if Label.compare q q' > 0 then (q,q') else (q',q)
let rec gt3 q q' q'' = if Label.compare q q' < 0 then
if Label.compare q' q'' < 0 then (q'',q',q)
else if Label.compare q q'' < 0 then (q',q'',q)
else (q',q,q'')
else
if Label.compare q q'' < 0 then (q'',q,q')
else if Label.compare q' q'' < 0 then (q,q'',q')
else (q,q',q'')
let make_leaf q = Node (1,q,Empty,Empty)
let make_triple q q' q'' =
let y,y',y'' = gt3 q q' q'' in Node (2,y,Node (1,y',Empty,Empty),Node (1,y'',Empty,Empty))
let make_couple q q' = let y,y' = gt q q' in Node (2,y,Node (1,y',Empty,Empty),Empty)
let is_leaf = function
| Node (_,_,Empty,Empty) -> true
| _ -> false
let rec count_rank = function
| Empty -> 0
| Node (_,_,l,r) -> (max (count_rank l) (count_rank r)) + 1
let rec find key = function
| Empty -> None
| Node (rank,v,l,r) -> if Label.compare key v = 0 then Some v
else if Label.compare v key > 0 then
match find key l,find key r with
| None,None -> None
| Some v,_ | _,Some v -> Some v
else None
let rec remove = function
| Empty -> None
| Node (rank,v,l,r) ->
match l,r with
| Empty,Empty -> Some (v,Empty)
| Empty,(Node (_,x,_,_) as t)| (Node (_,x,_,_) as t),Empty -> Some (v,t)
| Node (rank',x',_,_),Node (rank'',x'',_,_) ->
(* let () = assert (abs (rank' - rank'') <= 2) in *)
if Label.compare x' x'' < 0 then
(match remove r with
| None -> None
| Some (_,nr) ->
Some (v,Node ((min rank' (rank_of_tree nr)) + 1,x'',l,nr)))
else
(match remove l with
| None -> None
| Some (_,nl) ->
Some (v,Node ((min rank'' (rank_of_tree nl) + 1,x',nl,r))))
let rec add q = function
| Empty -> make_leaf q
| Node (_,v,l,r) ->
match l,r with
| Empty,Empty -> make_couple v q
| Empty,(Node (_,x,_,_) as t)| (Node (_,x,_,_) as t),Empty -> let y,y' = gt v q in
Node (1,y,t,make_leaf y')
| Node (rank',_,_,_),Node (rank'',_,_,_) ->
(* let () = assert (abs (rank' - rank'') <= 2) in *)
let y,y' = gt v q in
if rank' > rank'' then
let nr = add y' r in
Node ((min rank' (rank_of_tree nr)) + 1,y,l,nr)
else
let nl = add y' l in
Node ((min rank'' (rank_of_tree nl)) + 1,y,nl,r)
let mem key tree =
match find key tree with
| None -> false
| Some _ -> true
end
end
type label_t = {cost: Int64.t; end_point: int; sleep_cost: int}
let init_cost = Int64.zero
type v_t = int * label_t
let left_proj = (fun (x,_) (y,_) -> compare x y)
let right_proj = (fun (_,x) (_,y) -> compare y x)
module Vert = struct
type t = int
let compare = compare
end
module LeftProj = struct
type t = int * Int64.t
let compare = left_proj
end
module RightProj = struct
type t = int * Int64.t
let compare = right_proj
end
module RightProja = struct
type t = v_t
let compare = (fun (_,x) (_,y) -> compare y.cost x.cost)
end
module Ex = BinaryHeap.MakeArray (LeftProj)
module Log = BinaryHeap.MakeArray (LeftProj)
module Cda = BinaryHeap.MakeArray (RightProja)
module Cd = BinaryHeap.MakeArray (RightProj)
let empty = Array.make 25260 []
let add_graph_edge v edge graph =
match Array.get graph v with
| [] -> let () = Array.set graph v [edge] in graph
| edges -> let () = Array.set graph v (edge::edges) in graph
let adjacency_list v graph = Array.get graph v
let get_label x seen =
match Log.find (x,init_cost) seen with
| None -> None
| Some (_,v) -> Some v
let search_all merge_label graph src =
let update log cost = List.fold_left
(fun cand (v,l) ->
if Log.mem (v,l.cost) log then cand
else Cd.add (v,merge_label v l.cost cost) cand) in
let log = Log.add (src,init_cost) (Log.make_empty_tree 25260) in
let rec iter log cand =
match Cd.remove cand with
| None -> log
| Some ((closest,label),cand') ->
if Log.mem (closest,label) log then iter log cand'
else let log' = Log.add (closest,label) log in
let next = update log' label cand' (adjacency_list closest graph) in
iter log' next in
iter log (update log init_cost (Cd.make_empty_tree 100000) (adjacency_list src graph))
let search merge_label graph src dst =
let update seen cost = List.fold_left
(fun cand (v,l) ->
if Ex.mem (v,l.cost) seen then cand
else Cda.add (v,merge_label v l cost) cand) in
let seen = Ex.add (src,init_cost) (Ex.make_empty_tree 25260) in
let rec iter seen cand =
match Cda.remove cand with
| None -> None
| Some ((closest,label),cand') ->
if closest = dst then Some label.cost
else if Ex.mem (closest,label.cost) seen then iter seen cand'
else let seen' = Ex.add (closest,label.cost) seen in
let next = update seen' label.cost cand' (adjacency_list closest graph) in
iter seen' next in
iter seen (update seen init_cost (Cda.make_empty_tree 100000) (adjacency_list src graph))
let int_list_of_line len =
let rec iter n =
if n = 1 then Scanf.scanf "%d\n" (fun x -> x) :: iter 2
else if n <= len then Scanf.scanf "%d " (fun x -> x) :: iter (n + 1)
else [] in
List.rev (iter 1)
let int_list_of_line_with_fold_left len f init =
let apply f v (v',ls) = (f v' v,v :: ls) in
let rec iter n =
if n = 1 then apply f (Scanf.scanf "%d\n" (fun x -> x)) (iter 2)
else if n <= len then apply f (Scanf.scanf "%d " (fun x -> x)) (iter (n + 1))
else (init,[]) in
let (v,ls) = iter 1 in (v,List.rev ls)
let int_list_of_line_conti len ls =
let rec iter n =
if n <= len then Scanf.scanf "%d " (fun x -> x) :: iter (n + 1)
else ls in
iter 1
let read_rails m =
let rec graph_of_rail stations costs total start last graph now =
match stations,costs with
| ([],_) | (_,[]) -> graph
| (x :: [] , y :: _ ) -> failwith "error"
| (x :: (x' :: xs as nxt), y :: ys) ->
let graph = (add_graph_edge x (x',{cost=Int64.of_int y;end_point=start;sleep_cost=now+y;}) graph) in
let graph = (add_graph_edge x'(x,{cost=Int64.of_int y;end_point=last;sleep_cost=total - now;}) graph) in
graph_of_rail nxt ys total start last graph (now + y) in
let rec iter graph m =
match m with
| 0 -> graph
| _ -> let n = Scanf.scanf "%d\n" (fun x -> x) in
let start = Scanf.scanf "%d " (fun x -> x) in
let stations = int_list_of_line_conti (n - 2) [start] in
let last = Scanf.scanf "%d " (fun x -> x) in
let stations = List.rev (last :: stations) in
let total,costs = int_list_of_line_with_fold_left (n - 1) (fun x y -> x + y) 0 in
let graph = graph_of_rail stations costs total start last graph 0 in
(iter graph (m - 1)) in
iter empty m
let search_ex graph src dst =
let dist = search_all (fun _ y z -> Int64.add y z) graph dst in
let merge_label v l cost =
match get_label l.end_point dist with
| Some sleep_case ->
{l with cost = max (Int64.add l.cost cost) (Int64.add (Int64.of_int l.sleep_cost) sleep_case)}
| _ -> failwith "error" in
match search merge_label graph dst src with
| Some res -> Int64.to_int res
| None -> failwith "error"
let (n,m,src,dst) = Scanf.scanf "%d %d %d %d\n" (fun x y z w -> (x,y,z,w))
let rails = read_rails m
let () = search_ex rails src dst |> string_of_int |> print_endline