module type OrderedType = sig
type t
val compare: t -> t -> int
end
module type BaseItem = sig
type vertex
val compare_vertex: vertex -> vertex -> int
end
module type Item = sig
include BaseItem
type label
val compare_label: label -> label -> int
val init_label: label
end
module BinaryHeap = struct
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 (rank',x,_,_) as t)| (Node (rank',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,(Node (rank',x,_,_) as t)| (Node (rank',x,_,_) as t),Empty -> let y,y' = gt v q in Node (1,y,t,make_leaf y')
| Empty,Empty -> make_couple v q
| 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 find_and_update key cond tree =
let rec iter p = function
| Empty -> None
| Node (rank,v,l,r) as tree -> match cond v with
| None -> None
| Some true -> (match remove tree with
| None -> None
| Some (_,tree') -> Some (add p tree'))
| Some false ->
let y,y' = gt v p in
match iter y' l,iter y' r with
| None,None -> None
| Some nl,_ -> Some (Node ((min (rank_of_tree nl) (rank_of_tree r))+1,y,nl,r))
| _,Some nr -> Some (Node ((min (rank_of_tree l) (rank_of_tree nr))+1,y,l,nr))
in iter key tree
let mem key tree =
match find key tree with
| None -> false
| Some _ -> true
end
end
module Dijkstra = struct
module Make (Item: Item) = struct
type v_t = Item.vertex * Item.label
let left_proj = (fun (x,_) (y,_) -> Item.compare_vertex x y)
let right_proj = (fun (_,x) (_,y) -> Item.compare_label y x)
module Vert = struct
type t = Item.vertex
let compare = Item.compare_vertex
end
module LeftProj = struct
type t = v_t
let compare = left_proj
end
module RightProj = struct
type t = v_t
let compare = right_proj
end
module Ex = Set.Make (Vert)
module Gp = Map.Make (Vert)
module Log = BinaryHeap.Make (LeftProj)
module Cd = BinaryHeap.Make (RightProj)
let empty = Gp.empty
let rec graph_of_adjacency_form = function
| [] -> Gp.empty
| (v,edges) :: xs -> Gp.add v edges (graph_of_adjacency_form xs)
let add_graph_edge v edge graph =
try
Gp.add v (edge::(Gp.find v graph)) graph
with _ -> Gp.add v [edge] graph
let symmetric graph =
Gp.fold (fun v edges gp -> List.fold_left (fun gp' (v',d) -> add_graph_edge v' (v,d) gp') gp edges) graph graph
let rec adjacency_list v graph =
try
Gp.find v graph
with _ -> []
let update_all merge_label log cost = List.fold_left
(fun cand (v,l) ->
if Log.mem (v,l) log then cand
else
let pl = merge_label v l cost in
(match Cd.find_and_update (v,pl)
(fun x ->
match left_proj x (v,pl) = 0,right_proj x (v,pl) <= 0 with
| true,false -> None
| true,true -> Some true
| false,_ -> Some false)
cand with
| None -> Cd.add (v,pl) cand
| Some nc -> nc))
let update merge_label seen cost = List.fold_left
(fun cand (v,l) ->
if Ex.mem v seen then cand
else
let pl = merge_label v l cost in
(match Cd.find_and_update (v,pl)
(fun x ->
match left_proj x (v,pl) = 0,right_proj x (v,pl) <= 0 with
| true,false -> None
| true,true -> Some true
| false,_ -> Some false)
cand with
| None -> Cd.add (v,pl) cand
| Some nc -> nc))
let get_label x seen =
match Log.find (x,Item.init_label) seen with
| None -> None
| Some (_,v) -> Some v
let search_all merge_label graph src =
let log = Log.add (src,Item.init_label) Log.empty in
let rec iter log cand =
match Cd.remove cand with
| None -> log
| Some (((closest,label) as x),cand') ->
if Log.mem x log then iter log cand'
else let log = Log.add x log in
let nexts = update_all merge_label log label cand' (adjacency_list closest graph) in
iter log nexts in
iter log (update_all merge_label log Item.init_label Cd.empty (adjacency_list src graph))
let search merge_label graph src dst =
let seen = Ex.add src Ex.empty in
let rec iter seen cand =
match Cd.remove cand with
| None -> None
| Some ((closest,label),cand') ->
if closest = dst then Some label
else if Ex.mem closest seen then iter seen cand'
else let seen = Ex.add closest seen in
let nexts = update merge_label seen label cand' (adjacency_list closest graph) in
iter seen nexts in
iter seen (update merge_label seen Item.init_label Cd.empty (adjacency_list src graph))
end
end
type label_t = {cost: Int64.t; end_point: int; sleep_cost: int}
module Sp = struct
type vertex = int
type label = label_t
let compare_vertex = compare
let compare_label = (fun x y -> compare x.cost y.cost)
let init_label = {cost = Int64.zero ;end_point = -1;sleep_cost = 0;}
end
module Bs = Dijkstra.Make (Sp)
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 = (Bs.add_graph_edge x (x',{cost=Int64.of_int y;end_point=start;sleep_cost=now+y;}) graph) in
let graph = (Bs.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 Bs.empty m
let search graph src dst =
let dist = Bs.search_all (fun _ y z -> {y with cost = Int64.add y.cost z.cost}) graph dst in
let merge_label v l label =
match Bs.get_label l.end_point dist with
| Some {cost = sleep_case} ->
{l with cost = max (Int64.add l.cost label.cost) (Int64.add (Int64.of_int l.sleep_cost) sleep_case)}
| _ -> failwith "error" in
let Some {cost=res} = Bs.search merge_label graph dst src in Int64.to_int res
let [n;m;src;dst] = int_list_of_line 4
let rails = read_rails m
let () = search rails src dst |> string_of_int |> print_endline
File "./Main.ml", line 286, characters 6-21:
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a value that is not matched:
None
File "./Main.ml", line 288, characters 4-17:
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a value that is not matched:
[]